From 5c10f3860ae93468c6a0abf0185090120d431130 Mon Sep 17 00:00:00 2001 From: cqc Date: Wed, 14 Dec 2022 09:46:09 -0600 Subject: [PATCH] basic text field edition --- boot_js.ml | 40 ++-- human.ml | 601 ++++++++++++++++++++++++++++++----------------------- notes.org | 8 + 3 files changed, 368 insertions(+), 281 deletions(-) diff --git a/boot_js.ml b/boot_js.ml index f9158fc..ea9ee16 100644 --- a/boot_js.ml +++ b/boot_js.ml @@ -94,24 +94,28 @@ let _ = let ui = Nottui_widgets.( let string s = Lwd.pure @@ Nottui_widgets.string s in - scroll_area - @@ Lwd_utils.pack Ui.pack_y - [ - edit_field edit_me; - string "derp derp derp"; - string "herp herp derp"; - string "ding dong beep beep"; - string "derp derp derp"; - string "herp herp derp"; - string "ding dong beep beep"; - string "derp derp derp"; - string "herp herp derp"; - string "ding dong beep beep"; - string "derp derp derp"; - string "herp herp derp"; - string "ding dong beep beep"; - main_menu_item wm "Quit" (fun () -> exit 0); - ]) + line_table_of_string + "edit me?\n\ + derp derp derp\n\ + herp herp derp\n\ + ding dong beep beep" + (* @@ Lwd_utils.pack Ui.pack_y + [ + edit_field edit_me; + string "derp derp derp"; + string "herp herp derp"; + string "ding dong beep beep"; + string "derp derp derp"; + string "herp herp derp"; + string "ding dong beep beep"; + string "derp derp derp"; + string "herp herp derp"; + string "ding dong beep beep"; + string "derp derp derp"; + string "herp herp derp"; + string "ding dong beep beep"; + main_menu_item wm "Quit" (fun () -> exit 0); + ] *)) in let root = Lwd.set body diff --git a/human.ml b/human.ml index 39e35aa..531e8e4 100644 --- a/human.ml +++ b/human.ml @@ -256,8 +256,7 @@ module Git_console_http = struct | Ok (_resp, contents) -> Lwt.return_ok (`Data (Cstruct.of_string contents)) | Error err -> - Lwt.return_error - (`Msg (Fmt.str "%a" Git_af.pp_error err))) + Lwt.return_error (`Msg (Fmt.str "%a" pp_error err))) let close _ = Lwt.return_unit @@ -489,14 +488,6 @@ module Input = struct type code = [ `Uchar of Uchar.t (* A unicode character. *) | special ] - type mods = [ `Super | `Meta | `Ctrl | `Shift ] list - - type mouse = - [ `Press of button | `Drag | `Release ] * (float * float) * mods - - type paste = [ `Start | `End ] - type keyaction = [ `Press | `Release | `Repeat ] - (* stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *) let string_of_code = function | `Uchar ch -> @@ -518,6 +509,25 @@ module Input = struct | `Delete -> "Delete" | `Backspace -> "Backspace" | `Unknown s -> String.concat "Unknown " [ "\""; s; "\"" ] + | _ -> "Code Unknown!" + + let pp_code ppf v = F.pf ppf "%s" (string_of_code v) + + type mods = [ `Super | `Meta | `Ctrl | `Shift ] list + + let pp_mods = + F.( + list (fun ppf -> function + | `Super -> pf ppf "`Super" + | `Meta -> pf ppf "`Meta" + | `Ctrl -> pf ppf "`Ctrl" + | `Shift -> pf ppf "`Shift")) + + type mouse = + [ `Press of button | `Drag | `Release ] * (float * float) * mods + + type paste = [ `Start | `End ] + type keyaction = [ `Press | `Release | `Repeat ] end module Event_js = struct @@ -583,14 +593,17 @@ module NVG = struct and lightcyan = rgbf ~r:0.5 ~g:1.0 ~b:1.0 and lightwhite = rgbf ~r:1.0 ~g:1.0 ~b:1.0 + let ( = ) a b = a.r = b.r && a.g = b.g && a.b = b.b && a.a = b.a + let ( ++ ) a b = - (* { - r = Float.clamp ~min:0. ~max:1. (a.r +. b.r); - g = Float.clamp ~min:0. ~max:1. (a.g +. b.g); - b = Float.clamp ~min:0. ~max:1. (a.b +. b.b); - a = Float.clamp ~min:0. ~max:1. (a.a +. b.a); - } *) - if a = none then b else a + { + r = Float.clamp ~min:0. ~max:1. (a.r +. b.r); + g = Float.clamp ~min:0. ~max:1. (a.g +. b.g); + b = Float.clamp ~min:0. ~max:1. (a.b +. b.b); + a = Float.clamp ~min:0. ~max:1. (a.a +. b.a); + } + + let replace ~prev ~next = if next = none then prev else next let pp ppf t : unit = if t != none then @@ -746,6 +759,8 @@ module Style = struct match t.font with | `Sans -> Text.set_font_face vg ~name:"sans" | _ -> () + + let replace ~prev ~next = merge prev next end type t = { fg : Color.t; bg : Color.t; font : Font.t } @@ -772,6 +787,13 @@ module Style = struct font = Font.merge a1.font a2.font; } + let replace ~prev ~next = + { + fg = Color.replace ~prev:prev.fg ~next:next.fg; + bg = Color.replace ~prev:prev.bg ~next:next.bg; + font = Font.replace ~prev:prev.font ~next:next.font; + } + let fg ?(t = empty) c = { t with fg = c } let bg ?(t = empty) c = { t with bg = c } let font ?(t = empty) c = { t with font = c } @@ -823,15 +845,19 @@ module I = struct V2.(v (Float.max (x p1) (x p2)) (Float.max (y p1) (y p2))) [@@inline] + let bounds_segment vg p : Text.t -> NVG.Text.bounds = function + | String s -> + let open NVG.Text in + let { ascender; _ } = NVG.Text.metrics vg in + bounds vg ~x:(V2.x p) ~y:(V2.y p +. ascender) s + let rec size vg p = function | Empty -> V2.zero | Segment s -> - let NVG.Bounds.{ xmin; ymin; xmax; ymax } = - (NVG.Text.bounds vg ~x:(V2.x p) ~y:(V2.y p) - (Text.to_string s)) - .box + let NVG.Text.{ box = { ymax; ymin; _ }; advance } = + bounds_segment vg p s in - V2.v (xmax -. xmin) (ymax -. ymin) + V2.v advance (ymax -. ymin) | Attr (t, _a) -> size vg p t | Hcompose (t1, t2) -> let p1 = size vg p t1 in @@ -853,7 +879,7 @@ module I = struct let void w h = Void (P2.v w h) let attr a = function - | Attr (t, a0) -> Attr (t, A.(a ++ a0)) + | Attr (t, a0) -> Attr (t, A.(replace ~prev:a0 ~next:a)) | t -> Attr (t, a) let ( <|> ) t1 t2 = @@ -877,11 +903,11 @@ module I = struct (* crop is positive value, pad is negative *) let hcrop left right img = - Log.debug (fun m -> m "Hcrop (%f, %f)" left right); + (* Log.debug (fun m -> m "Hcrop (%f, %f)" left right); *) Hcrop (img, left, right) let vcrop top bottom img = - Log.debug (fun m -> m "Vcrop (%f, %f)" top bottom); + (* Log.debug (fun m -> m "Vcrop (%f, %f)" top bottom); *) Vcrop (img, top, bottom) let crop ?(l = 0.) ?(r = 0.) ?(t = 0.) ?(b = 0.) img = @@ -1042,7 +1068,7 @@ module I = struct set_fill_color vg ~color; fill vg; NVG.restore vg; - Log.debug (fun m -> m "fill_box: %a" Box2.pp b); + (* Log.debug (fun m -> m "fill_box: %a" Box2.pp b); *) Box2.size b let path_box vg color ?(width = 0.) b = @@ -1073,8 +1099,9 @@ module I = struct | Segment v -> fmt "@[Segment %a@]" ppf Text.pp v | Attr (t, a) -> fmt "@[Attr %a@]" ppf - (pair ~sep:comma A.pp (pp ~attr:A.(attr ++ a))) - (A.(attr ++ a), t) + (pair ~sep:comma A.pp + (pp ~attr:A.(replace ~prev:attr ~next:a))) + (A.(replace ~prev:attr ~next:a), t) | Hcompose a -> fmt "Hcat %a" ppf compose a | Vcompose a -> fmt "Vcat %a" ppf compose a | Zcompose a -> fmt "Zcat %a" ppf compose a @@ -1084,18 +1111,37 @@ module I = struct fmt "Vcrop (%.1f,%.1f,%a)" ppf top bottom (pp ~attr) t | Void dim -> fmt "Void %a" ppf (parens V2.pp) dim + let segment_kern_cache = ref (Box2.zero, "") + let rec segment vg p : Text.t -> P2.t = function | String s -> (* Log.debug (fun m -> m "I.Draw.segment p=%a %s" Gg.V2.pp p s); *) + (* let p' = + let cache_p, cache_s = !segment_kern_cache in + (* tries to get the kerning right across segments *) + if V2.(equal (Box2.max cache_p) p) then + V2.( + Box2.o cache_p + + v + ((bounds_segment vg (Box2.o cache_p) + (Text.of_string (cache_s ^ s))) + .advance + -. (bounds_segment vg p (Text.of_string s)).advance + ) + 0.) + else p + in *) let metrics = NVG.Text.metrics vg in NVG.Text.text vg ~x:(V2.x p) ~y:(V2.y p +. metrics.ascender) - (* TODO make segments include neighbors so kerning is correct *) s; - let NVG.Bounds.{ xmin; ymin; xmax; ymax } = - (NVG.Text.bounds vg ~x:(V2.x p) ~y:(V2.y p) s).box + + let sz = + V2.v (bounds_segment vg p (Text.of_string s)).advance + metrics.line_height in - V2.v (xmax -. xmin) (ymax -. ymin) + segment_kern_cache := (Box2.(v p sz), s); + sz and node vg attr p n : p2 = (* returns the *size* of the drawn area not the max coordinates anymore *) @@ -1104,12 +1150,12 @@ module I = struct | Empty | Void _ -> p | Segment text -> segment vg p text | Attr (i, a) -> - let a0 = A.(attr ++ a) in + let a0 = A.(replace ~prev:attr ~next:a) in if - A.(a0.bg) != NVG.Color.transparent - && A.(a0.bg) != A.(attr.bg) + (A.(a.bg) != A.(attr.bg)) + && A.(a0.bg) != NVG.Color.transparent then fill_box vg a0.bg (Box2.v p (size vg p i)) |> ignore; - if A.(attr.fg) != a0.fg then ( + if A.(attr.fg) != a.fg then ( NVG.set_fill_color vg ~color:Style.(a0.fg); NVG.set_stroke_color vg ~color:Style.(a0.fg)); node vg a0 p i @@ -1287,6 +1333,10 @@ module Nottui = struct module Ui = struct type may_handle = [ `Unhandled | `Handled ] + let pp_may_handle ppf = function + | `Unhandled -> F.pf ppf "`Unhandled" + | `Handled -> F.pf ppf "`Unhandled" + type mouse_handler = x:float -> y:float -> @@ -1309,6 +1359,25 @@ module Nottui = struct [ Input.special | `Uchar of Uchar.t | semantic_key ] * Input.mods + let pp_key = + F.( + pair + (fun ppf v -> + match v with + | `Copy -> pf ppf "`Copy" + | `Paste -> pf ppf "`Paste" + | `Focus v -> + pf ppf "`Focus %s" + (match v with + | `Next -> "`Next" + | `Prev -> "`Prev" + | `Left -> "`Left" + | `Right -> "`Right" + | `Up -> "`Up" + | `Down -> "`Down") + | a -> pf ppf "%a" Input.pp_code a) + Input.pp_mods) + type mouse = Input.mouse type event = @@ -1627,11 +1696,11 @@ module Nottui = struct (a +. ratio, b +. flex -. ratio) else (a, b) in - Log.debug (fun m -> - m - "split: a=%.1f sa=%.1f b=%.1f sb=%.1f total=%.1f (%.1f, \ - %.1f)" - a sa b sb total a' b'); + (* Log.debug (fun m -> + m + "split: a=%.1f sa=%.1f b=%.1f sb=%.1f total=%.1f (%.1f, \ + %.1f)" + a sa b sb total a' b'); *) (a', b') let pack ~fixed ~stretch total g1 g2 = @@ -1645,9 +1714,9 @@ module Nottui = struct | `Neutral -> (flex /. 2., fixed) | `Positive -> (flex, fixed) in - Log.debug (fun m -> - m "pack fixed=%.1f stretch=%.1f total=%.1f (%.1f, %.1f)" - fixed stretch total v1 v2); + (* Log.debug (fun m -> + m "pack fixed=%.1f stretch=%.1f total=%.1f (%.1f, %.1f)" + fixed stretch total v1 v2); *) (v1, v2) let has_transient_sensor flags = @@ -1794,16 +1863,7 @@ module Nottui = struct | Y (a, b) -> (max a.w b.w, a.h +. b.h) | Z (a, b) -> (max a.w b.w, max a.h b.h) in - { - ui with - w; - h; - sw = w; - sh = h; - desc; - sensor_cache = None; - cache; - } + { ui with w; h; desc; sensor_cache = None; cache } let update t size (ui : Ui.t) = t.size <- size; @@ -1876,8 +1936,8 @@ module Nottui = struct let resize_canvas vg rw rh image = let w, h = V2.to_tuple @@ I.size vg V2.zero image in - Log.debug (fun m -> - m "resize_canvas: w=%.1f rw=%.1f h=%.1f rh=%.1f" w rw h rh); + (* Log.debug (fun m -> + m "resize_canvas: w=%.1f rw=%.1f h=%.1f rh=%.1f" w rw h rh); *) if w <> rw || h <> rh then I.pad ~r:(rw -. w) ~b:(rh -. h) image else image @@ -1907,109 +1967,13 @@ module Nottui = struct then `Handled else `Unhandled - let rec _render_node vg (vx1 : size1) (vy1 : size1) (vx2 : size1) + let rec render_node vg (vx1 : size1) (vy1 : size1) (vx2 : size1) (vy2 : size1) (sw : size1) (sh : size1) (t : ui) : cache = - match t.desc with - | Atom image -> - { - vx = Interval.make 0. sw; - vy = Interval.make 0. sh; - image = resize_canvas vg sw sh image; - } - | Size_sensor (desc, handler) -> - handler ~w:sw ~h:sh; - render_node vg vx1 vy1 vx2 vy2 sw sh desc - | Transient_sensor (desc, _) | Permanent_sensor (desc, _) -> - render_node vg vx1 vy1 vx2 vy2 sw sh desc - | Focus_area (desc, _) | Mouse_handler (desc, _) -> - render_node vg vx1 vy1 vx2 vy2 sw sh desc - | Shift_area (t', sx, sy) -> - let cache = - render_node vg (vx1 +. sx) (vy1 +. sy) (vx2 +. sx) - (vy2 +. sy) (sx +. sw) (sy +. sh) t' - in - let vx = Interval.make vx1 vx2 - and vy = Interval.make vy1 vy2 in - let image = - resize_canvas vg sw sh (I.crop ~l:sx ~t:sy cache.image) - in - { vx; vy; image } - | X (a, b) -> - let aw, bw = split ~a:a.w ~sa:a.sw ~b:b.w ~sb:b.sw sw in - let ca = render_node vg vx1 vy1 vx2 vy2 aw sh a in - let cb = - render_node vg (vx1 -. aw) vy1 (vx2 -. aw) vy2 bw sh b - in - let vx = - Interval.make - (max (Interval.fst ca.vx) (Interval.fst cb.vx +. aw)) - (min (Interval.snd ca.vx) (Interval.snd cb.vx +. aw)) - and vy = - Interval.make - (max (Interval.fst ca.vy) (Interval.fst cb.vy)) - (min (Interval.snd ca.vy) (Interval.snd cb.vy)) - and image = - resize_canvas vg sw sh I.(ca.image <|> cb.image) - in - { vx; vy; image } - | Y (a, b) -> - let ah, bh = split ~a:a.h ~sa:a.sh ~b:b.h ~sb:b.sh sh in - let ca = render_node vg vx1 vy1 vx2 vy2 sw ah a in - let cb = - render_node vg vx1 (vy1 -. ah) vx2 (vy2 -. ah) sw bh b - in - let vx = - Interval.make - (max (Interval.fst ca.vx) (Interval.fst cb.vx)) - (min (Interval.snd ca.vx) (Interval.snd cb.vx)) - and vy = - Interval.make - (max (Interval.fst ca.vy) (Interval.fst cb.vy +. ah)) - (min (Interval.snd ca.vy) (Interval.snd cb.vy +. ah)) - and image = - resize_canvas vg sw sh (I.( <-> ) ca.image cb.image) - in - { vx; vy; image } - | Z (a, b) -> - let ca = render_node vg vx1 vy1 vx2 vy2 sw sh a in - let cb = render_node vg vx1 vy1 vx2 vy2 sw sh b in - let vx = - Interval.make - (max (Interval.fst ca.vx) (Interval.fst cb.vx)) - (min (Interval.snd ca.vx) (Interval.snd cb.vx)) - and vy = - Interval.make - (max (Interval.fst ca.vy) (Interval.fst cb.vy)) - (min (Interval.snd ca.vy) (Interval.snd cb.vy)) - and image = - resize_canvas vg sw sh (I.( ) cb.image ca.image) - in - { vx; vy; image } - | Resize (t, _, _, g) -> - let open Gravity in - let dx, rw = - pack ~fixed:t.w ~stretch:t.sw sw (h (p1 g)) (h (p2 g)) - in - let dy, rh = - pack ~fixed:t.h ~stretch:t.sh sh (v (p1 g)) (v (p2 g)) - in - let c = - render_node vg (vx1 -. dx) (vy1 -. dy) (vx2 -. dx) - (vy2 -. dy) rw rh t - in - let image = resize_canvas2 vg dx dy sw sh c.image in - let vx = Interval.shift c.vx dx in - let vy = Interval.shift c.vy dy in - { vx; vy; image } - | Event_filter (t, _f) -> render_node vg vx1 vy1 vx2 vy2 sw sh t - - and render_node vg (vx1 : size1) (vy1 : size1) (vx2 : size1) - (vy2 : size1) (sw : size1) (sh : size1) (t : ui) : cache = - Log.debug (fun m -> - m - "render_node vx1=%.0f@ vy1=%.0f@ vx2=%.0f@ vy2=%.0f@ \ - sw=%.0f@ sh=%.0f@ @[%a@]" - vx1 vy1 vx2 vy2 sw sh pp t); + (* Log.debug (fun m -> + m + "render_node vx1=%.0f@ vy1=%.0f@ vx2=%.0f@ vy2=%.0f@ \ + sw=%.0f@ sh=%.0f@ @[%a@]" + vx1 vy1 vx2 vy2 sw sh pp t); *) if let cache = t.cache in vx1 >= Interval.fst cache.vx @@ -2024,7 +1988,107 @@ module Nottui = struct image = I.void sw sh; } else - let cache = _render_node vg vx1 vy1 vx2 vy2 sw sh t in + let cache = + match t.desc with + | Atom image -> + { + vx = Interval.make 0. sw; + vy = Interval.make 0. sh; + image = resize_canvas vg sw sh image; + } + | Size_sensor (desc, handler) -> + handler ~w:sw ~h:sh; + render_node vg vx1 vy1 vx2 vy2 sw sh desc + | Transient_sensor (desc, _) | Permanent_sensor (desc, _) -> + render_node vg vx1 vy1 vx2 vy2 sw sh desc + | Focus_area (desc, _) | Mouse_handler (desc, _) -> + render_node vg vx1 vy1 vx2 vy2 sw sh desc + | Shift_area (t', sx, sy) -> + let cache = + render_node vg (vx1 +. sx) (vy1 +. sy) (vx2 +. sx) + (vy2 +. sy) (sx +. sw) (sy +. sh) t' + in + let vx = Interval.make vx1 vx2 + and vy = Interval.make vy1 vy2 in + let image = + resize_canvas vg sw sh + (I.crop ~l:sx ~t:sy cache.image) + in + { vx; vy; image } + | X (a, b) -> + let aw, bw = split ~a:a.w ~sa:a.sw ~b:b.w ~sb:b.sw sw in + let ca = render_node vg vx1 vy1 vx2 vy2 aw sh a in + let cb = + render_node vg (vx1 -. aw) vy1 (vx2 -. aw) vy2 bw sh b + in + let vx = + Interval.make + (max (Interval.fst ca.vx) + (Interval.fst cb.vx +. aw)) + (min (Interval.snd ca.vx) + (Interval.snd cb.vx +. aw)) + and vy = + Interval.make + (max (Interval.fst ca.vy) (Interval.fst cb.vy)) + (min (Interval.snd ca.vy) (Interval.snd cb.vy)) + and image = + resize_canvas vg sw sh I.(ca.image <|> cb.image) + in + { vx; vy; image } + | Y (a, b) -> + let ah, bh = split ~a:a.h ~sa:a.sh ~b:b.h ~sb:b.sh sh in + let ca = render_node vg vx1 vy1 vx2 vy2 sw ah a in + let cb = + render_node vg vx1 (vy1 -. ah) vx2 (vy2 -. ah) sw bh b + in + let vx = + Interval.make + (max (Interval.fst ca.vx) (Interval.fst cb.vx)) + (min (Interval.snd ca.vx) (Interval.snd cb.vx)) + and vy = + Interval.make + (max (Interval.fst ca.vy) + (Interval.fst cb.vy +. ah)) + (min (Interval.snd ca.vy) + (Interval.snd cb.vy +. ah)) + and image = + resize_canvas vg sw sh (I.( <-> ) ca.image cb.image) + in + { vx; vy; image } + | Z (a, b) -> + let ca = render_node vg vx1 vy1 vx2 vy2 sw sh a in + let cb = render_node vg vx1 vy1 vx2 vy2 sw sh b in + let vx = + Interval.make + (max (Interval.fst ca.vx) (Interval.fst cb.vx)) + (min (Interval.snd ca.vx) (Interval.snd cb.vx)) + and vy = + Interval.make + (max (Interval.fst ca.vy) (Interval.fst cb.vy)) + (min (Interval.snd ca.vy) (Interval.snd cb.vy)) + and image = + resize_canvas vg sw sh (I.( ) cb.image ca.image) + in + { vx; vy; image } + | Resize (t, _, _, g) -> + let open Gravity in + let dx, rw = + pack ~fixed:t.w ~stretch:t.sw sw (h (p1 g)) (h (p2 g)) + in + let dy, rh = + pack ~fixed:t.h ~stretch:t.sh sh (v (p1 g)) (v (p2 g)) + in + let c = + render_node vg (vx1 -. dx) (vy1 -. dy) (vx2 -. dx) + (vy2 -. dy) rw rh t + in + let image = resize_canvas2 vg dx dy sw sh c.image in + let vx = Interval.shift c.vx dx in + let vy = Interval.shift c.vy dy in + { vx; vy; image } + | Event_filter (t, _f) -> + render_node vg vx1 vy1 vx2 vy2 sw sh t + in t.cache <- cache; cache @@ -2048,7 +2112,6 @@ module Nottui = struct in iter st' | Focus_area (t, f) -> ( - Log.debug (fun m -> m "dispatch_raw_key Focus_area"); match iter [ t ] with | `Handled -> `Handled | `Unhandled -> ( @@ -2097,18 +2160,10 @@ module Nottui = struct | Event_filter (t, _) -> dispatch_focus t dir | Focus_area (t', _) -> - if Focus.has_focus t'.focus then ( - Log.debug (fun m -> - m "dispatch_focus: Focus.has_focus t'.focus"); - dispatch_focus t' dir || grab_focus t) - else if - Log.debug (fun m -> - m "dispatch_focus: Focus.has_focus t.focus"); - Focus.has_focus t.focus - then false - else ( - Log.debug (fun m -> m "dispatch_focus: grab_focus"); - grab_focus t) + if Focus.has_focus t'.focus then + dispatch_focus t' dir || grab_focus t + else if Focus.has_focus t.focus then false + else grab_focus t | X (a, b) -> ( if Focus.has_focus a.focus then dispatch_focus a dir @@ -2228,7 +2283,6 @@ module Nottui_lwt = struct in refresh (); let process_event e = - Log.debug (fun m -> m "Nottui_lwt.render= process_event"); match e with | `Key (`Uchar c, [ `Meta ]) as event when Uchar.(equal c (of_char 'q')) -> ( @@ -2239,10 +2293,11 @@ module Nottui_lwt = struct match Renderer.dispatch_event renderer event with | `Handled -> () | `Unhandled -> - Log.warn (fun m -> + (* Log.warn (fun m -> m "Nottui_lwt.render process_event #Ui.event -> \ - `Unhandled")) + `Unhandled") *) + ()) | `Resize size' -> size := size'; refresh () @@ -2284,8 +2339,11 @@ module Nottui_widgets = struct let attr_menu_main = A.(bg Color.green ++ fg Color.black) let attr_menu_sub = A.(bg Color.lightgreen ++ fg Color.black) - let attr_clickable = A.(bg @@ Color.rgbf ~r:0.2 ~g:0.2 ~b:0.5) - let attr_cursor = A.(bg @@ Color.rgbf ~r:0.4 ~g:0.4 ~b:0.1) + + let attr_clickable = + A.((bg @@ Color.rgbf ~r:0.2 ~g:0.2 ~b:0.5) ++ (fg @@ Color.light)) + + let attr_cursor = A.((fg @@ Color.dark) ++ (bg @@ Color.yellow)) type window_manager = { overlays : ui Lwd.t Lwd_table.t; @@ -2397,73 +2455,6 @@ module Nottui_widgets = struct let scroll_step = 7. - type scroll_state = { - position : float; - bound : float; - visible : float; - total : float; - } - - let default_scroll_state = - { position = 0.; bound = 0.; visible = 0.; total = 0. } - - let pp_scroll_state ppf { position; bound; visible; total } = - Format.fprintf ppf - "{position=%.1f;@ bound=%.1f;@ visible=%.1f;@ total=%.1f}" - position bound visible total - - let vscroll_area ~state ~change (t : Ui.t Lwd.t) = - let visible = ref (-1.) in - let total = ref (-1.) in - let scroll state delta = - let position = state.position +. delta in - let position = max 0. (min state.bound position) in - if position <> state.position then - change `Action { state with position }; - `Handled - in - let focus_handler state = function - (*| `Arrow `Left , _ -> scroll (-scroll_step) 0*) - (*| `Arrow `Right, _ -> scroll (+scroll_step) 0*) - | `Arrow `Up, [] -> scroll state (-.scroll_step) - | `Arrow `Down, [] -> scroll state (+.scroll_step) - | `Page `Up, [] -> scroll state (-.scroll_step *. 8.) - | `Page `Down, [] -> scroll state (+.scroll_step *. 8.) - | _ -> `Unhandled - in - let scroll_handler state ~x:_ ~y:_ = function - | `Scroll `Up -> scroll state (-.scroll_step) - | `Scroll `Down -> scroll state (+.scroll_step) - | _ -> `Unhandled - in - Lwd.map2 t state ~f:(fun t state -> - t - |> Ui.shift_area 0. state.position - |> Ui.resize ~h:0. ~sh:1. - |> Ui.size_sensor (fun ~w:_ ~h -> - let tchange = - if !total <> Ui.(layout_spec t).h then ( - total := Ui.(layout_spec t).h; - true) - else false - in - let vchange = - if !visible <> h then ( - visible := h; - true) - else false - in - if tchange || vchange then - change `Content - { - state with - visible = !visible; - total = !total; - bound = max 0. (!total -. !visible); - }) - |> Ui.mouse_area (scroll_handler state) - |> Ui.keyboard_area (focus_handler state)) - let scroll_area ?(offset = (0., 0.)) t = let offset = Lwd.var offset in let scroll d_x d_y = @@ -2637,12 +2628,9 @@ module Nottui_widgets = struct let sub' str p l = if p = 0 && l = String.length str then str else String.sub str p l - let edit_field ?(focus = Focus.make ()) ?(on_change = ignore) + let edit_field ?(focus = Focus.make ()) ?(on_change = Fun.id) ?(on_submit = ignore) state = - let on_change a = - on_change a; - Lwd.set state a - in + let on_change a = Lwd.set state (on_change a) in let update focus_h focus (text, pos) = let pos = min (max 0 pos) (String.length text) in let content = @@ -2651,25 +2639,18 @@ module Nottui_widgets = struct if Focus.has_focus focus then let attr = attr_clickable in let len = String.length text in - (if pos >= len then [ I.string ~attr text ] - else [ I.string ~attr (sub' text 0 pos) ]) - @ - if pos < String.length text then + if pos >= len then + [ I.string ~attr text; I.string ~attr:attr_cursor " " ] + else [ + I.string ~attr (sub' text 0 pos); I.string ~attr:attr_cursor (sub' text pos 1); I.string ~attr (sub' text (pos + 1) (len - pos - 1)); ] - else [ I.string ~attr:A.(bg Color.lightred) " " ] - else - [ - I.string - ~attr:A.(font Font.underline) - (if text = "" then " " else text); - ] + else [ I.string (if text = "" then " " else text) ] in let handler k = - (* Log.debug (fun m -> m "edit_field keyboard_area handler");*) - match k with + (match k with | `Uchar c, [ `Ctrl ] when Uchar.(equal c (of_char 'U')) -> on_change ("", 0); `Handled (* clear *) @@ -2715,7 +2696,12 @@ module Nottui_widgets = struct on_change (text, pos); `Handled) else `Unhandled - | _ -> `Unhandled + | _ -> `Unhandled) + |> fun r -> + Log.debug (fun m -> + m "edit_field keyboard_area handler %a -> %a" Ui.pp_key k + Ui.pp_may_handle r); + r in Ui.keyboard_area ~focus handler content in @@ -2735,6 +2721,95 @@ module Nottui_widgets = struct open Lwd.Infix + type line = { + focus : Focus.handle; + state : (string * int) Lwd.var; + ui : Ui.t Lwd.t; + } + + let _line_on_change _table _row (s, i) = (s, i) + let eq_uc_c uc c = Uchar.(equal uc (of_char c)) + + let copy_line_cursor (x : line) (y : line) = + let _, xi = Lwd.peek x.state in + let ys, _ = Lwd.peek y.state in + let yi = Int.max 0 (Int.min xi (String.length ys)) in + Lwd.set y.state (ys, yi) + + let cursor_move cursor + (f : line Lwd_table.row -> line Lwd_table.row option) = + match Lwd.peek cursor with + | Some cursor_line -> ( + match f cursor_line with + | Some new_line -> + (match Lwd_table.get new_line with + | Some line' -> + cursor_line |> Lwd_table.get + |> Option.iter (fun line -> + copy_line_cursor line line'); + Focus.request line'.focus + | None -> ()); + Lwd.set cursor (Some new_line); + `Handled + | None -> `Unhandled) + | None -> `Unhandled + + let line_append ?(table = Lwd_table.make ()) str = + let focus = Focus.make () in + let state = Lwd.var (str, 0) in + let row = Lwd_table.append table in + Lwd_table.set row + { + focus; + state; + ui = + edit_field ~focus + ~on_change:(_line_on_change table row) + state; + } + + let line_table_of_string ?(table = Lwd_table.make ()) + ?(focus = Focus.make ()) (s : string) : Ui.t Lwd.t = + (* Append lines from s to table *) + List.iter (line_append ~table) (String.split_on_char '\n' s); + (* create the cursor var *) + let cursor = Lwd.var @@ Lwd_table.first table in + Option.iter + (fun cursor -> + Option.iter (fun first -> Focus.request first.focus) + @@ Lwd_table.get cursor) + (Lwd.peek cursor); + + (* Build view of table *) + Lwd_table.map_reduce + (fun _ { ui; _ } -> ui) + (Lwd_utils.lift_monoid Ui.pack_y) + table + |> Lwd.join + |> Lwd.map2 + ~f:(fun focus -> + Ui.keyboard_area ~focus (function + | `Uchar u, [ `Ctrl ] when eq_uc_c u 'n' -> + cursor_move cursor (fun c -> Lwd_table.next c) + | `Arrow `Down, _ -> + cursor_move cursor (fun c -> Lwd_table.next c) + | `Uchar u, [ `Ctrl ] when eq_uc_c u 'p' -> + cursor_move cursor (fun c -> Lwd_table.prev c) + | `Arrow `Up, _ -> + cursor_move cursor (fun c -> Lwd_table.prev c) + | `Uchar u, [ `Meta ] when eq_uc_c u '<' -> + cursor_move cursor (fun _ -> Lwd_table.first table) + | `Uchar u, [ `Meta ] when eq_uc_c u '>' -> + cursor_move cursor (fun _ -> Lwd_table.last table) + (* | `Enter, [] -> ( + let row = Lwd.peek cursor in + match Lwd_table.get row with + | Some line -> + Lwd_table.after row ~set:Lwd.set cursor + | None -> `Unhandled) *) + | _ -> `Unhandled)) + (Focus.status focus) + (** Tab view, where exactly one element of [l] is shown at a time. *) let tabs (tabs : (string * (unit -> Ui.t Lwd.t)) list) : Ui.t Lwd.t = diff --git a/notes.org b/notes.org index 696e331..8bc7661 100644 --- a/notes.org +++ b/notes.org @@ -24,6 +24,14 @@ * principles? an "anywhere" programming environment +* 221211 +ok you got the scroll box mostly working so next: +** fix the scroll jump bugs +** setup better keybindings +** fix cursor and active focus indicators + + + * 221210 - ** need to resolve the issue with the ui.t Resize type. this is an issue with the direction of the determination of the .height and .width fields of Ui.t