Take some symbols from face2.html
[llpp.git] / listview.ml
blob351c42e6c9c109f24a3ee3d6f332c2dbf668cb9b
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 messages)" 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 <- Textentry (
135 (c, action cmd, opthist,
136 onkey, ondone, cancelonempty),
137 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 enttext (c, E.s, opthist, onkey, ondone, cancelonempty)
176 | Delete -> ()
178 | Insert when Wsi.withshift mask ->
179 let s = getcmdoutput (fun s ->
180 prerr_endline ("error pasting: " ^ s)) conf.pastecmd in
181 enttext (c, s, opthist, onkey, ondone, cancelonempty)
183 | Code _ | Ascii _ ->
184 begin match onkey text kt with
185 | TEdone text ->
186 ondone text;
187 onleave Confirm;
188 postRedisplay "textentrykeyboard after confirm2";
190 | TEcont text ->
191 enttext (c, text, opthist, onkey, ondone, cancelonempty);
193 | TEstop ->
194 onleave Cancel;
195 postRedisplay "textentrykeyboard after cancel3";
197 | TEswitch te ->
198 state.mode <- Textentry (te, onleave);
199 postRedisplay "textentrykeyboard switch";
201 | _ -> vlog "unhandled key"
204 class type lvsource =
205 object
206 method getitemcount : int
207 method getitem : int -> (string * int)
208 method hasaction : int -> bool
209 method exit : uioh:uioh ->
210 cancel:bool ->
211 active:int ->
212 first:int ->
213 pan:int ->
214 uioh option
215 method getactive : int
216 method getfirst : int
217 method getpan : int
218 method getminfo : (int * int) array
219 end;;
221 class virtual lvsourcebase =
222 object
223 val mutable m_active = 0
224 val mutable m_first = 0
225 val mutable m_pan = 0
226 method getactive = m_active
227 method getfirst = m_first
228 method getpan = m_pan
229 method getminfo : (int * int) array = E.a
230 end;;
232 let coe s = (s :> uioh);;
234 class listview ~zebra ~helpmode ~(source:lvsource) ~trusted ~modehash =
235 object (self)
236 val m_pan = source#getpan
237 val m_first = source#getfirst
238 val m_active = source#getactive
239 val m_qsearch = E.s
240 val m_prev_uioh = state.uioh
242 method private elemunder y =
243 if y < 0
244 then None
245 else
246 let n = y / (fstate.fontsize+1) in
247 if m_first + n < source#getitemcount
248 then (
249 if source#hasaction (m_first + n)
250 then Some (m_first + n)
251 else None
253 else None
255 method display =
256 Gl.enable `blend;
257 GlFunc.blend_func ~src:`src_alpha ~dst:`one_minus_src_alpha;
258 GlDraw.color (0., 0., 0.) ~alpha:0.85;
259 filledrect 0. 0. (float state.winw) (float state.winh);
260 GlDraw.color (1., 1., 1.);
261 Gl.enable `texture_2d;
262 let fs = fstate.fontsize in
263 let nfs = fs + 1 in
264 let hw = state.winw/3 in
265 let ww = fstate.wwidth in
266 let tabw = 17.0*.ww in
267 let itemcount = source#getitemcount in
268 let minfo = source#getminfo in
269 if conf.leftscroll
270 then (
271 GlMat.push ();
272 GlMat.translate ~x:(float conf.scrollbw) ();
274 let x0 = 0.0 and x1 = float (state.winw - conf.scrollbw - 1) in
275 let rec loop row =
276 if not ((row - m_first) > fstate.maxrows)
277 then (
278 if row >= 0 && row < itemcount
279 then (
280 let (s, level) = source#getitem row in
281 let y = (row - m_first) * nfs in
282 let x = 5.0 +. (float (level + m_pan)) *. ww in
283 if helpmode
284 then GlDraw.color
285 (let c = if row land 1 = 0 then 1.0 else 0.92 in (c,c,c));
287 if row = m_active
288 then (
289 Gl.disable `texture_2d;
290 let alpha = if source#hasaction row then 0.9 else 0.3 in
291 GlDraw.color (1., 1., 1.) ~alpha;
292 linerect (x0 +. 1.) (float (y + 1)) (x1) (float (y + fs + 3));
293 Gl.enable `texture_2d;
295 let c =
296 if zebra && row land 1 = 1
297 then 0.8
298 else 1.0
300 GlDraw.color (c,c,c);
301 let drawtabularstring s =
302 let drawstr x s =
303 let x' = truncate (x0 +. x) in
304 let s1, s2 = splitatchar s '\000' in
305 if emptystr s2
306 then drawstring1 fs x' (y+nfs) s
307 else
308 let rec e s =
309 if emptystr s
310 then s
311 else
312 let s' = withoutlastutf8 s in
313 let s = s' ^ Utf8syms.ellipsis in
314 let w = measurestr fs s in
315 if float x' +. w +. ww < float (hw + x')
316 then s
317 else e s'
319 let s1 =
320 if float x' +. ww +. measurestr fs s1 > float (hw + x')
321 then e s1
322 else s1
324 ignore (drawstring1 fs x' (y+nfs) s1);
325 drawstring1 fs (hw + x') (y+nfs) s2
327 if trusted
328 then
329 let x = if helpmode && row > 0 then x +. ww else x in
330 let s1, s2 = splitatchar s '\t' in
331 if nonemptystr s2
332 then
333 let nx = drawstr x s1 in
334 let sw = nx -. x in
335 let x = x +. (max tabw sw) in
336 drawstr x s2
337 else
338 let len = String.length s - 2 in
339 if len > 0 && s.[0] = '\xc2' && s.[1] = '\xb7'
340 then
341 let s = String.sub s 2 len in
342 let x = if not helpmode then x +. ww else x in
343 GlDraw.color (1.2, 1.2, 1.2);
344 let vinc = drawstring1 (fs+fs/4)
345 (truncate (x -. ww)) (y+nfs) s in
346 GlDraw.color (1., 1., 1.);
347 vinc +. (float fs *. 0.8)
348 else drawstr x s
349 else drawstr x s
351 ignore (drawtabularstring s);
352 loop (row+1)
356 loop m_first;
357 GlDraw.color (1.0, 1.0, 1.0) ~alpha:0.5;
358 let xadj = 5.0 in
359 let rec loop row =
360 if (row - m_first) <= fstate.maxrows
361 then
362 if row >= 0 && row < itemcount
363 then
364 let (s, level) = source#getitem row in
365 let pos0 = Ne.index s '\000' in
366 let y = (row - m_first) * nfs in
367 let x = float (level + m_pan) *. ww in
368 let (first, last) = minfo.(row) in
369 let prefix =
370 if pos0 > 0 && first > pos0
371 then String.sub s (pos0+1) (first-pos0-1)
372 else String.sub s 0 first
374 let suffix = String.sub s first (last - first) in
375 let w1 = measurestr fstate.fontsize prefix in
376 let w2 = measurestr fstate.fontsize suffix in
377 let x = x +. if conf.leftscroll then xadj else 5.0 in
378 let x = if pos0 > 0 && first > pos0 then x +. float hw else x in
379 let x0 = x +. w1
380 and y0 = float (y+2) in
381 let x1 = x0 +. w2
382 and y1 = float (y+fs+3) in
383 filledrect x0 y0 x1 y1;
384 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 nextcurlevel 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
401 then i-1
402 else (
403 if i = -1
404 then 0
405 else
406 let _, l = source#getitem i in
407 if l <= curlevel then i else flow (i+incr)
410 let active = flow (m_active+incr) in
411 let first = calcfirst m_first active in
412 postRedisplay "outline nextcurlevel";
413 {< m_active = active; m_first = first >}
415 method updownlevel incr =
416 let len = source#getitemcount in
417 let curlevel =
418 if m_active >= 0 && m_active < len
419 then snd (source#getitem m_active)
420 else -1
422 let rec flow i =
423 if i = len
424 then i-1
425 else (
426 if i = -1 then 0 else
427 let _, l = source#getitem i in
428 if l != curlevel then i else flow (i+incr)
431 let active = flow m_active in
432 let first = calcfirst m_first active in
433 postRedisplay "outline updownlevel";
434 {< m_active = active; m_first = first >}
436 method private key1 key mask =
437 let set1 active first qsearch =
438 coe {< m_active = active; m_first = first; m_qsearch = qsearch >}
440 let search active pattern incr =
441 let active = if active = -1 then m_first else active in
442 let dosearch re =
443 let rec loop n =
444 if n >= 0 && n < source#getitemcount
445 then (
446 let s, _ = source#getitem n in
447 match Str.search_forward re s 0 with
448 | exception Not_found -> loop (n + incr)
449 | _ -> Some n
451 else None
453 loop active
455 let qpat = Str.quote pattern in
456 match Str.regexp_case_fold qpat with
457 | s -> dosearch s
458 | exception exn ->
459 dolog "regexp_case_fold for `%S' failed: %S\n" qpat @@
460 Printexc.to_string exn;
461 None
463 let itemcount = source#getitemcount in
464 let find start incr =
465 let rec find i =
466 if i = -1 || i = itemcount
467 then -1
468 else (
469 if source#hasaction i
470 then i
471 else find (i + incr)
474 find start
476 let set active first =
477 let first = bound first 0 (itemcount - fstate.maxrows) in
478 state.text <- E.s;
479 coe {< m_active = active; m_first = first; m_qsearch = E.s >}
481 let navigate incr =
482 let isvisible first n = n >= first && n - first <= fstate.maxrows in
483 let active, first =
484 let incr1 = if incr > 0 then 1 else -1 in
485 if isvisible m_first m_active
486 then
487 let next =
488 let next = m_active + incr in
489 let next =
490 if next < 0 || next >= itemcount
491 then -1
492 else find next incr1
494 if abs (m_active - next) > fstate.maxrows
495 then -1
496 else next
498 if next = -1
499 then
500 let first = m_first + incr in
501 let first = bound first 0 (itemcount - fstate.maxrows) in
502 let next =
503 let next = m_active + incr in
504 let next = bound next 0 (itemcount - 1) in
505 find next ~-incr1
507 let active =
508 if next = -1
509 then m_active
510 else (
511 if isvisible first next
512 then next
513 else m_active
516 active, first
517 else
518 let first = min next m_first in
519 let first =
520 if abs (next - first) > fstate.maxrows
521 then first + incr
522 else first
524 next, first
525 else
526 let first = m_first + incr in
527 let first = bound first 0 (itemcount - 1) in
528 let active =
529 let next = m_active + incr in
530 let next = bound next 0 (itemcount - 1) in
531 let next = find next incr1 in
532 let active =
533 if next = -1 || abs (m_active - first) > fstate.maxrows
534 then (
535 let active = if m_active = -1 then next else m_active in
536 active
538 else next
540 if isvisible first active
541 then active
542 else -1
544 active, first
546 postRedisplay "listview navigate";
547 set active first;
549 let open Keys in
550 let kt = Wsi.kc2kt key in
551 match [@warning "-4"] kt with
552 | Ascii (('r'|'s') as c) when Wsi.withctrl mask ->
553 let incr = if c = 'r' then -1 else 1 in
554 let active, first =
555 match search (m_active + incr) m_qsearch incr with
556 | None ->
557 state.text <- m_qsearch ^ " [not found]";
558 m_active, m_first
559 | Some active ->
560 state.text <- m_qsearch;
561 active, firstof m_first active
563 postRedisplay "listview ctrl-r/s";
564 set1 active first m_qsearch;
566 | Insert when Wsi.withctrl mask ->
567 if m_active >= 0 && m_active < source#getitemcount
568 then (
569 let s, _ = source#getitem m_active in
570 selstring conf.selcmd s;
572 coe self
574 | Backspace ->
575 if emptystr m_qsearch
576 then coe self
577 else (
578 let qsearch = withoutlastutf8 m_qsearch in
579 if emptystr qsearch
580 then (
581 state.text <- E.s;
582 postRedisplay "listview empty qsearch";
583 set1 m_active m_first E.s;
585 else
586 let active, first =
587 match search m_active qsearch ~-1 with
588 | None ->
589 state.text <- qsearch ^ " [not found]";
590 m_active, m_first
591 | Some active ->
592 state.text <- qsearch;
593 active, firstof m_first active
595 postRedisplay "listview backspace qsearch";
596 set1 active first qsearch
599 | Ascii _ | Code _ ->
600 let utf8 =
601 match [@warning "-8"] kt with
602 | Ascii c -> String.make 1 c
603 | Code code -> toutf8 code
605 let pattern = m_qsearch ^ utf8 in
606 let active, first =
607 match search m_active pattern 1 with
608 | None ->
609 state.text <- pattern ^ " [not found]";
610 m_active, m_first
611 | Some active ->
612 state.text <- pattern;
613 active, firstof m_first active
615 postRedisplay "listview qsearch add";
616 set1 active first pattern;
618 | Escape ->
619 state.text <- E.s;
620 if emptystr m_qsearch
621 then (
622 postRedisplay "list view escape";
623 (* XXX:
624 let mx, my = state.mpos in
625 updateunder mx my;
627 getoptdef m_prev_uioh @@
628 source#exit ~uioh:(coe self) ~cancel:true ~active:m_active
629 ~first:m_first ~pan:m_pan
631 else (
632 postRedisplay "list view kill qsearch";
633 coe {< m_qsearch = E.s >}
636 | Enter ->
637 state.text <- E.s;
638 let self = {< m_qsearch = E.s >} in
639 let opt =
640 postRedisplay "listview enter";
641 let cancel = not (m_active >= 0 && m_active < source#getitemcount) in
642 source#exit ~uioh:(coe self) ~cancel
643 ~active:m_active ~first:m_first ~pan:m_pan;
645 getoptdef m_prev_uioh opt
647 | Delete -> coe self
648 | Up -> navigate ~-1
649 | Down -> navigate 1
650 | Prior -> navigate ~-(fstate.maxrows)
651 | Next -> navigate fstate.maxrows
653 | Right ->
654 state.text <- E.s;
655 postRedisplay "listview right";
656 coe {< m_pan = m_pan - 1 >}
658 | Left ->
659 state.text <- E.s;
660 postRedisplay "listview left";
661 coe {< m_pan = m_pan + 1 >}
663 | Home ->
664 let active = find 0 1 in
665 postRedisplay "listview home";
666 set active 0;
668 | End ->
669 let first = max 0 (itemcount - fstate.maxrows) in
670 let active = find (itemcount - 1) ~-1 in
671 postRedisplay "listview end";
672 set active first;
674 | _ -> coe self
676 method key key mask =
677 match state.mode with
678 | Textentry te ->
679 textentrykeyboard key mask te;
680 coe self
681 | Birdseye _ | View | LinkNav _ -> self#key1 key mask
683 method button button down x y _ =
684 let opt =
685 match button with
686 | 1 when vscrollhit x ->
687 postRedisplay "listview scroll";
688 if down
689 then
690 let _, position, sh = self#scrollph in
691 if y > truncate position && y < truncate (position +. sh)
692 then (
693 state.mstate <- Mscrolly;
694 Some (coe self)
696 else
697 let s = float (max 0 (y - conf.scrollh)) /. float state.winh in
698 let first = truncate (s *. float source#getitemcount) in
699 let first = min source#getitemcount first in
700 Some (coe {< m_first = first; m_active = first >})
701 else (
702 state.mstate <- Mnone;
703 Some (coe self);
705 | 1 when down ->
706 begin match self#elemunder y with
707 | Some n ->
708 postRedisplay "listview click";
709 source#exit ~uioh:(coe {< m_active = n >})
710 ~cancel:false ~active:n ~first:m_first ~pan:m_pan
711 | _ ->
712 Some (coe self)
714 | n when (n == 4 || n == 5) && not down ->
715 let len = source#getitemcount in
716 let first =
717 if n = 5 && m_first + fstate.maxrows >= len
718 then m_first
719 else
720 let first = m_first + (if n == 4 then -1 else 1) in
721 bound first 0 (len - 1)
723 postRedisplay "listview wheel";
724 Some (coe {< m_first = first >})
725 | n when (n = 6 || n = 7) && not down ->
726 let inc = if n = 7 then -1 else 1 in
727 postRedisplay "listview hwheel";
728 Some (coe {< m_pan = m_pan + inc >})
729 | _ -> Some (coe self)
731 getoptdef m_prev_uioh opt
733 method multiclick _ x y = self#button 1 true x y
735 method motion _ y =
736 match state.mstate with
737 | Mscrolly ->
738 let s = float (max 0 (y - conf.scrollh)) /. float state.winh in
739 let first = truncate (s *. float source#getitemcount) in
740 let first = min source#getitemcount first in
741 postRedisplay "listview motion";
742 coe {< m_first = first; m_active = first >}
743 | Msel _
744 | Mpan _
745 | Mscrollx
746 | Mzoom _
747 | Mzoomrect _
748 | Mnone -> coe self
750 method pmotion x y =
751 if x < state.winw - conf.scrollbw
752 then
753 let n =
754 match self#elemunder y with
755 | None -> Wsi.setcursor Wsi.CURSOR_INHERIT; m_active
756 | Some n -> Wsi.setcursor Wsi.CURSOR_INFO; n
758 let o =
759 if n != m_active
760 then (postRedisplay "listview pmotion"; {< m_active = n >})
761 else self
763 coe o
764 else (
765 Wsi.setcursor Wsi.CURSOR_INHERIT;
766 coe self
769 method infochanged _ = ()
771 method scrollpw = (0, 0.0, 0.0)
772 method scrollph =
773 let nfs = fstate.fontsize + 1 in
774 let y = m_first * nfs in
775 let itemcount = source#getitemcount in
776 let maxi = max 0 (itemcount - fstate.maxrows) in
777 let maxy = maxi * nfs in
778 let p, h = scrollph y maxy in
779 conf.scrollbw, p, h
781 method modehash = modehash
782 method eformsgs = false
783 method alwaysscrolly = true
784 method scroll _ dy =
785 let self =
786 if dy != 0 then begin
787 let len = source#getitemcount in
788 let first =
789 if dy > 0 && m_first + fstate.maxrows >= len
790 then m_first
791 else
792 let first = m_first + dy / 10 in
793 bound first 0 (len - 1)
795 postRedisplay "listview wheel";
796 {< m_first = first >}
797 end else
798 self
800 coe self
802 method zoom _ _ _ = ()
803 end;;