Update
[llpp.git] / listview.ml
blob1c409c73163c3b8dc16f44e00d967aaaf884da90
1 open Utils;;
2 open Glutils;;
3 open Config;;
5 let scrollph y maxy =
6 let sh = float (maxy + state.winh) /. float state.winh in
7 let sh = float state.winh /. sh in
8 let sh = max sh (float conf.scrollh) in
10 let percent = float y /. float maxy in
11 let position = (float state.winh -. sh) *. percent in
13 let position =
14 if position +. sh > float state.winh
15 then float state.winh -. sh
16 else position
18 position, sh;
21 let isbirdseye = function
22 | Birdseye _ -> true
23 | Textentry _ | View | LinkNav _ -> false
26 let istextentry = function
27 | Textentry _ -> true
28 | Birdseye _ | View | LinkNav _ -> false
31 let vscrollw () =
32 if state.uioh#alwaysscrolly || ((conf.scrollb land scrollbvv != 0)
33 && (state.maxy > state.winh))
34 then conf.scrollbw
35 else 0
38 let vscrollhit x =
39 if conf.leftscroll
40 then x < vscrollw ()
41 else x > state.winw - vscrollw ()
44 let firstof first active =
45 if first > active || abs (first - active) > fstate.maxrows - 1
46 then max 0 (active - (fstate.maxrows/2))
47 else first
50 let calcfirst first active =
51 if active > first
52 then
53 let rows = active - first in
54 if rows > fstate.maxrows then active - fstate.maxrows else first
55 else active
58 let enttext () =
59 let len = String.length state.text in
60 let x0 = if conf.leftscroll then vscrollw () else 0 in
61 let drawstring s =
62 let hscrollh =
63 match state.mode with
64 | Textentry _ | View | LinkNav _ ->
65 let h, _, _ = state.uioh#scrollpw in
67 | Birdseye _ -> 0
69 let rect x w =
70 filledrect
71 x (float (state.winh - (fstate.fontsize + 4) - hscrollh))
72 (x+.w) (float (state.winh - hscrollh))
75 let w = float (state.winw - 1 - vscrollw ()) in
76 if state.progress >= 0.0 && state.progress < 1.0
77 then (
78 GlDraw.color (0.3, 0.3, 0.3);
79 let w1 = w *. state.progress in
80 rect (float x0) w1;
81 GlDraw.color (0.0, 0.0, 0.0);
82 rect (float x0+.w1) (float x0+.w-.w1)
84 else (
85 GlDraw.color (0.0, 0.0, 0.0);
86 rect (float x0) w;
89 GlDraw.color (1.0, 1.0, 1.0);
90 drawstring
91 fstate.fontsize
92 (if conf.leftscroll then x0 + 2 else x0 + if len > 0 then 8 else 2)
93 (state.winh - hscrollh - 5) s;
95 let s =
96 match state.mode with
97 | Textentry ((prefix, text, _, _, _, _), _) ->
98 let s =
99 if len > 0
100 then Printf.sprintf "%s%s_ [%s]" prefix text state.text
101 else Printf.sprintf "%s%s_" prefix text
105 | Birdseye _ | View | LinkNav _ -> state.text
107 let s =
108 if state.newerrmsgs
109 then (
110 if not (istextentry state.mode) && state.uioh#eformsgs
111 then
112 let s1 = "(press 'e' to review error messasges)" in
113 if nonemptystr s then s ^ " " ^ s1 else s1
114 else s
116 else s
118 if nonemptystr s
119 then drawstring s
122 let textentrykeyboard
123 key _mask ((c, text, opthist, onkey, ondone, cancelonempty), onleave) =
124 state.text <- E.s;
125 let enttext te =
126 state.mode <- Textentry (te, onleave);
127 enttext ();
128 postRedisplay "textentrykeyboard enttext";
130 let histaction cmd =
131 match opthist with
132 | None -> ()
133 | Some (action, _) ->
134 state.mode <-
135 Textentry (
136 (c, action cmd, opthist, onkey, ondone, cancelonempty), onleave
138 postRedisplay "textentry histaction"
140 let open Keys in
141 let kt = Wsi.kc2kt key in
142 match [@warning "-4"] kt with
143 | Backspace ->
144 if emptystr text && cancelonempty
145 then (
146 onleave Cancel;
147 postRedisplay "textentrykeyboard after cancel";
149 else
150 let s = withoutlastutf8 text in
151 enttext (c, s, opthist, onkey, ondone, cancelonempty)
153 | Enter ->
154 ondone text;
155 onleave Confirm;
156 postRedisplay "textentrykeyboard after confirm"
158 | Up -> histaction HCprev
159 | Down -> histaction HCnext
160 | Home -> histaction HCfirst
161 | End -> histaction HClast
163 | Escape ->
164 if emptystr text
165 then (
166 begin match opthist with
167 | None -> ()
168 | Some (_, onhistcancel) -> onhistcancel ()
169 end;
170 onleave Cancel;
171 state.text <- E.s;
172 postRedisplay "textentrykeyboard after cancel2"
174 else (
175 enttext (c, E.s, opthist, onkey, ondone, cancelonempty)
178 | Delete -> ()
180 | Code _ | Ascii _ ->
181 begin match onkey text kt with
182 | TEdone text ->
183 ondone text;
184 onleave Confirm;
185 postRedisplay "textentrykeyboard after confirm2";
187 | TEcont text ->
188 enttext (c, text, opthist, onkey, ondone, cancelonempty);
190 | TEstop ->
191 onleave Cancel;
192 postRedisplay "textentrykeyboard after cancel3"
194 | TEswitch te ->
195 state.mode <- Textentry (te, onleave);
196 postRedisplay "textentrykeyboard switch";
198 | _ -> vlog "unhandled key"
201 class type lvsource =
202 object
203 method getitemcount : int
204 method getitem : int -> (string * int)
205 method hasaction : int -> bool
206 method exit : uioh:uioh ->
207 cancel:bool ->
208 active:int ->
209 first:int ->
210 pan:int ->
211 uioh option
212 method getactive : int
213 method getfirst : int
214 method getpan : int
215 method getminfo : (int * int) array
216 end;;
218 class virtual lvsourcebase = object
219 val mutable m_active = 0
220 val mutable m_first = 0
221 val mutable m_pan = 0
222 method getactive = m_active
223 method getfirst = m_first
224 method getpan = m_pan
225 method getminfo : (int * int) array = E.a
226 end;;
228 let coe s = (s :> uioh);;
230 class listview ~zebra ~helpmode ~(source:lvsource) ~trusted ~modehash =
231 object (self)
232 val m_pan = source#getpan
233 val m_first = source#getfirst
234 val m_active = source#getactive
235 val m_qsearch = E.s
236 val m_prev_uioh = state.uioh
238 method private elemunder y =
239 if y < 0
240 then None
241 else
242 let n = y / (fstate.fontsize+1) in
243 if m_first + n < source#getitemcount
244 then (
245 if source#hasaction (m_first + n)
246 then Some (m_first + n)
247 else None
249 else None
251 method display =
252 Gl.enable `blend;
253 GlFunc.blend_func ~src:`src_alpha ~dst:`one_minus_src_alpha;
254 GlDraw.color (0., 0., 0.) ~alpha:0.85;
255 filledrect 0. 0. (float state.winw) (float state.winh);
256 GlDraw.color (1., 1., 1.);
257 Gl.enable `texture_2d;
258 let fs = fstate.fontsize in
259 let nfs = fs + 1 in
260 let hw = state.winw/3 in
261 let ww = fstate.wwidth in
262 let tabw = 17.0*.ww in
263 let itemcount = source#getitemcount in
264 let minfo = source#getminfo in
265 if conf.leftscroll
266 then (
267 GlMat.push ();
268 GlMat.translate ~x:(float conf.scrollbw) ();
270 let x0 = 0.0 and x1 = float (state.winw - conf.scrollbw - 1) in
271 let rec loop row =
272 if (row - m_first) > fstate.maxrows
273 then ()
274 else (
275 if row >= 0 && row < itemcount
276 then (
277 let (s, level) = source#getitem row in
278 let y = (row - m_first) * nfs in
279 let x = 5.0 +. (float (level + m_pan)) *. ww in
280 if helpmode
281 then GlDraw.color
282 (let c = if row land 1 = 0 then 1.0 else 0.92 in (c,c,c));
284 if row = m_active
285 then (
286 Gl.disable `texture_2d;
287 let alpha = if source#hasaction row then 0.9 else 0.3 in
288 GlDraw.color (1., 1., 1.) ~alpha;
289 linerect (x0 +. 1.) (float (y + 1)) (x1) (float (y + fs + 3));
290 Gl.enable `texture_2d;
292 let c =
293 if zebra && row land 1 = 1
294 then 0.8
295 else 1.0
297 GlDraw.color (c,c,c);
298 let drawtabularstring s =
299 let drawstr x s =
300 let x' = truncate (x0 +. x) in
301 let s1, s2 = splitatchar s '\000' in
302 if emptystr s2
303 then drawstring1 fs x' (y+nfs) s
304 else
305 let rec e s =
306 if emptystr s
307 then s
308 else
309 let s' = withoutlastutf8 s in
310 let s = s' ^ Utf8syms.ellipsis in
311 let w = measurestr fs s in
312 if float x' +. w +. ww < float (hw + x')
313 then s
314 else e s'
316 let s1 =
317 if float x' +. ww +. measurestr fs s1 > float (hw + x')
318 then e s1
319 else s1
321 ignore (drawstring1 fs x' (y+nfs) s1);
322 drawstring1 fs (hw + x') (y+nfs) s2
324 if trusted
325 then
326 let x = if helpmode && row > 0 then x +. ww else x in
327 let s1, s2 = splitatchar s '\t' in
328 if nonemptystr s2
329 then
330 let nx = drawstr x s1 in
331 let sw = nx -. x in
332 let x = x +. (max tabw sw) in
333 drawstr x s2
334 else
335 let len = String.length s - 2 in
336 if len > 0 && s.[0] = '\xc2' && s.[1] = '\xb7'
337 then
338 let s = String.sub s 2 len in
339 let x = if not helpmode then x +. ww else x in
340 GlDraw.color (1.2, 1.2, 1.2);
341 let vinc = drawstring1 (fs+fs/4)
342 (truncate (x -. ww)) (y+nfs) s in
343 GlDraw.color (1., 1., 1.);
344 vinc +. (float fs *. 0.8)
345 else
346 drawstr x s
347 else
348 drawstr x s
350 ignore (drawtabularstring s);
351 loop (row+1)
355 loop m_first;
356 GlDraw.color (1.0, 1.0, 1.0) ~alpha:0.5;
357 let xadj = 5.0 in
358 let rec loop row =
359 if (row - m_first) <= fstate.maxrows
360 then
361 if row >= 0 && row < itemcount
362 then (
363 let (s, level) = source#getitem row in
364 let pos0 = Ne.index s '\000' in
365 let y = (row - m_first) * nfs in
366 let x = float (level + m_pan) *. ww in
367 let (first, last) = minfo.(row) in
368 let prefix =
369 if pos0 > 0 && first > pos0
370 then String.sub s (pos0+1) (first-pos0-1)
371 else String.sub s 0 first
373 let suffix = String.sub s first (last - first) in
374 let w1 = measurestr fstate.fontsize prefix in
375 let w2 = measurestr fstate.fontsize suffix in
376 let x = x +. if conf.leftscroll then xadj else 5.0 in
377 let x = if pos0 > 0 && first > pos0 then x +. float hw else x in
378 let x0 = x +. w1
379 and y0 = float (y+2) in
380 let x1 = x0 +. w2
381 and y1 = float (y+fs+3) in
382 filledrect x0 y0 x1 y1;
383 loop (row+1)
386 Gl.disable `texture_2d;
387 if Array.length minfo > 0 then loop m_first;
388 Gl.disable `blend;
389 if conf.leftscroll
390 then GlMat.pop ()
392 method updownlevel incr =
393 let len = source#getitemcount in
394 let curlevel =
395 if m_active >= 0 && m_active < len
396 then snd (source#getitem m_active)
397 else -1
399 let rec flow i =
400 if i = len then i-1 else if i = -1 then 0 else
401 let _, l = source#getitem i in
402 if l != curlevel then i else flow (i+incr)
404 let active = flow m_active in
405 let first = calcfirst m_first active in
406 postRedisplay "outline updownlevel";
407 {< m_active = active; m_first = first >}
409 method private key1 key mask =
410 let set1 active first qsearch =
411 coe {< m_active = active; m_first = first; m_qsearch = qsearch >}
413 let search active pattern incr =
414 let active = if active = -1 then m_first else active in
415 let dosearch re =
416 let rec loop n =
417 if n >= 0 && n < source#getitemcount
418 then (
419 let s, _ = source#getitem n in
420 match Str.search_forward re s 0 with
421 | exception Not_found -> loop (n + incr)
422 | _ -> Some n
424 else None
426 loop active
428 let qpat = Str.quote pattern in
429 match Str.regexp_case_fold qpat with
430 | s -> dosearch s
431 | exception exn ->
432 dolog "regexp_case_fold for `%S' failed: %S\n" qpat @@
433 Printexc.to_string exn;
434 None
436 let itemcount = source#getitemcount in
437 let find start incr =
438 let rec find i =
439 if i = -1 || i = itemcount
440 then -1
441 else (
442 if source#hasaction i
443 then i
444 else find (i + incr)
447 find start
449 let set active first =
450 let first = bound first 0 (itemcount - fstate.maxrows) in
451 state.text <- E.s;
452 coe {< m_active = active; m_first = first; m_qsearch = E.s >}
454 let navigate incr =
455 let isvisible first n = n >= first && n - first <= fstate.maxrows in
456 let active, first =
457 let incr1 = if incr > 0 then 1 else -1 in
458 if isvisible m_first m_active
459 then
460 let next =
461 let next = m_active + incr in
462 let next =
463 if next < 0 || next >= itemcount
464 then -1
465 else find next incr1
467 if abs (m_active - next) > fstate.maxrows
468 then -1
469 else next
471 if next = -1
472 then
473 let first = m_first + incr in
474 let first = bound first 0 (itemcount - fstate.maxrows) in
475 let next =
476 let next = m_active + incr in
477 let next = bound next 0 (itemcount - 1) in
478 find next ~-incr1
480 let active =
481 if next = -1
482 then m_active
483 else (
484 if isvisible first next
485 then next
486 else m_active
489 active, first
490 else
491 let first = min next m_first in
492 let first =
493 if abs (next - first) > fstate.maxrows
494 then first + incr
495 else first
497 next, first
498 else
499 let first = m_first + incr in
500 let first = bound first 0 (itemcount - 1) in
501 let active =
502 let next = m_active + incr in
503 let next = bound next 0 (itemcount - 1) in
504 let next = find next incr1 in
505 let active =
506 if next = -1 || abs (m_active - first) > fstate.maxrows
507 then (
508 let active = if m_active = -1 then next else m_active in
509 active
511 else next
513 if isvisible first active
514 then active
515 else -1
517 active, first
519 postRedisplay "listview navigate";
520 set active first;
522 let open Keys in
523 let kt = Wsi.kc2kt key in
524 match [@warning "-4"] kt with
525 | Ascii (('r'|'s') as c) when Wsi.withctrl mask ->
526 let incr = if c = 'r' then -1 else 1 in
527 let active, first =
528 match search (m_active + incr) m_qsearch incr with
529 | None ->
530 state.text <- m_qsearch ^ " [not found]";
531 m_active, m_first
532 | Some active ->
533 state.text <- m_qsearch;
534 active, firstof m_first active
536 postRedisplay "listview ctrl-r/s";
537 set1 active first m_qsearch;
539 | Insert when Wsi.withctrl mask ->
540 if m_active >= 0 && m_active < source#getitemcount
541 then (
542 let s, _ = source#getitem m_active in
543 selstring conf.selcmd s;
545 coe self
547 | Backspace ->
548 if emptystr m_qsearch
549 then coe self
550 else (
551 let qsearch = withoutlastutf8 m_qsearch in
552 if emptystr qsearch
553 then (
554 state.text <- E.s;
555 postRedisplay "listview empty qsearch";
556 set1 m_active m_first E.s;
558 else
559 let active, first =
560 match search m_active qsearch ~-1 with
561 | None ->
562 state.text <- qsearch ^ " [not found]";
563 m_active, m_first
564 | Some active ->
565 state.text <- qsearch;
566 active, firstof m_first active
568 postRedisplay "listview backspace qsearch";
569 set1 active first qsearch
572 | Ascii _ | Code _ ->
573 let utf8 =
574 match [@warning "-8"] kt with
575 | Ascii c -> String.make 1 c
576 | Code code -> toutf8 code
578 let pattern = m_qsearch ^ utf8 in
579 let active, first =
580 match search m_active pattern 1 with
581 | None ->
582 state.text <- pattern ^ " [not found]";
583 m_active, m_first
584 | Some active ->
585 state.text <- pattern;
586 active, firstof m_first active
588 postRedisplay "listview qsearch add";
589 set1 active first pattern;
591 | Escape ->
592 state.text <- E.s;
593 if emptystr m_qsearch
594 then (
595 postRedisplay "list view escape";
596 (* XXX:
597 let mx, my = state.mpos in
598 updateunder mx my;
600 match source#exit ~uioh:(coe self) ~cancel:true ~active:m_active
601 ~first:m_first ~pan:m_pan with
602 | None -> m_prev_uioh
603 | Some uioh -> uioh
605 else (
606 postRedisplay "list view kill qsearch";
607 coe {< m_qsearch = E.s >}
610 | Enter ->
611 state.text <- E.s;
612 let self = {< m_qsearch = E.s >} in
613 let opt =
614 postRedisplay "listview enter";
615 let cancel = not (m_active >= 0 && m_active < source#getitemcount) in
616 source#exit ~uioh:(coe self) ~cancel
617 ~active:m_active ~first:m_first ~pan:m_pan;
619 begin match opt with
620 | None -> m_prev_uioh
621 | Some uioh -> uioh
624 | Delete ->
625 coe self
627 | Up -> navigate ~-1
628 | Down -> navigate 1
629 | Prior -> navigate ~-(fstate.maxrows)
630 | Next -> navigate fstate.maxrows
632 | Right ->
633 state.text <- E.s;
634 postRedisplay "listview right";
635 coe {< m_pan = m_pan - 1 >}
637 | Left ->
638 state.text <- E.s;
639 postRedisplay "listview left";
640 coe {< m_pan = m_pan + 1 >}
642 | Home ->
643 let active = find 0 1 in
644 postRedisplay "listview home";
645 set active 0;
647 | End ->
648 let first = max 0 (itemcount - fstate.maxrows) in
649 let active = find (itemcount - 1) ~-1 in
650 postRedisplay "listview end";
651 set active first;
653 | _ -> coe self
655 method key key mask =
656 match state.mode with
657 | Textentry te ->
658 textentrykeyboard key mask te;
659 coe self
660 | Birdseye _ | View | LinkNav _ -> self#key1 key mask
662 method button button down x y _ =
663 let opt =
664 match button with
665 | 1 when vscrollhit x ->
666 postRedisplay "listview scroll";
667 if down
668 then
669 let _, position, sh = self#scrollph in
670 if y > truncate position && y < truncate (position +. sh)
671 then (
672 state.mstate <- Mscrolly;
673 Some (coe self)
675 else
676 let s = float (max 0 (y - conf.scrollh)) /. float state.winh in
677 let first = truncate (s *. float source#getitemcount) in
678 let first = min source#getitemcount first in
679 Some (coe {< m_first = first; m_active = first >})
680 else (
681 state.mstate <- Mnone;
682 Some (coe self);
684 | 1 when down ->
685 begin match self#elemunder y with
686 | Some n ->
687 postRedisplay "listview click";
688 source#exit ~uioh:(coe {< m_active = n >})
689 ~cancel:false ~active:n ~first:m_first ~pan:m_pan
690 | _ ->
691 Some (coe self)
693 | n when (n == 4 || n == 5) && not down ->
694 let len = source#getitemcount in
695 let first =
696 if n = 5 && m_first + fstate.maxrows >= len
697 then
698 m_first
699 else
700 let first = m_first + (if n == 4 then -1 else 1) in
701 bound first 0 (len - 1)
703 postRedisplay "listview wheel";
704 Some (coe {< m_first = first >})
705 | n when (n = 6 || n = 7) && not down ->
706 let inc = if n = 7 then -1 else 1 in
707 postRedisplay "listview hwheel";
708 Some (coe {< m_pan = m_pan + inc >})
709 | _ ->
710 Some (coe self)
712 match opt with
713 | None -> m_prev_uioh
714 | Some uioh -> uioh
716 method multiclick _ x y = self#button 1 true x y
718 method motion _ y =
719 match state.mstate with
720 | Mscrolly ->
721 let s = float (max 0 (y - conf.scrollh)) /. float state.winh in
722 let first = truncate (s *. float source#getitemcount) in
723 let first = min source#getitemcount first in
724 postRedisplay "listview motion";
725 coe {< m_first = first; m_active = first >}
726 | Msel _
727 | Mpan _
728 | Mscrollx
729 | Mzoom _
730 | Mzoomrect _
731 | Mnone -> coe self
733 method pmotion x y =
734 if x < state.winw - conf.scrollbw
735 then
736 let n =
737 match self#elemunder y with
738 | None -> Wsi.setcursor Wsi.CURSOR_INHERIT; m_active
739 | Some n -> Wsi.setcursor Wsi.CURSOR_INFO; n
741 let o =
742 if n != m_active
743 then (postRedisplay "listview pmotion"; {< m_active = n >})
744 else self
746 coe o
747 else (
748 Wsi.setcursor Wsi.CURSOR_INHERIT;
749 coe self
752 method infochanged _ = ()
754 method scrollpw = (0, 0.0, 0.0)
755 method scrollph =
756 let nfs = fstate.fontsize + 1 in
757 let y = m_first * nfs in
758 let itemcount = source#getitemcount in
759 let maxi = max 0 (itemcount - fstate.maxrows) in
760 let maxy = maxi * nfs in
761 let p, h = scrollph y maxy in
762 conf.scrollbw, p, h
764 method modehash = modehash
765 method eformsgs = false
766 method alwaysscrolly = true
767 method scroll _ dy =
768 let self =
769 if dy != 0 then begin
770 let len = source#getitemcount in
771 let first =
772 if dy > 0 && m_first + fstate.maxrows >= len
773 then
774 m_first
775 else
776 let first = m_first + dy / 10 in
777 bound first 0 (len - 1)
779 postRedisplay "listview wheel";
780 {< m_first = first >}
781 end else
782 self
784 coe self
786 method zoom _ _ _ = ()
787 end;;