From 480e77bbb9716d97e52b7adb18601d5956a974db Mon Sep 17 00:00:00 2001 From: cqc Date: Thu, 16 Feb 2023 13:35:34 -0600 Subject: [PATCH] switched to using local test repo because there was no internet on Le Canadien, fixed tree_nav focus handle embedding, added Moar to may_handle --- boot_js.ml | 2 +- human.ml | 86 ++++++++++++++++++++++++++++++++++-------------------- 2 files changed, 55 insertions(+), 33 deletions(-) diff --git a/boot_js.ml b/boot_js.ml index 0cf0556..4784d15 100644 --- a/boot_js.ml +++ b/boot_js.ml @@ -90,7 +90,7 @@ let _ = let gravity_crop = Gravity.make ~h:`Positive ~v:`Negative in let body = Lwd.var (Lwd.pure Ui.empty) in let wm = Widgets.window_manager (Lwd.join (Lwd.get body)) in - Nav.test_pull () >>= fun test_store -> + Nav.test_populate () >>= fun test_store -> let ui = Widgets.(h_node_area (test_store, [ [] ])) in let root = Lwd.set body diff --git a/human.ml b/human.ml index 8e996f5..29025b6 100644 --- a/human.ml +++ b/human.ml @@ -441,6 +441,8 @@ module Nav = struct end module Sync = Irmin.Sync.Make (S) + (* owo *) + (* owo *) type t = S.tree type store = S.t @@ -448,13 +450,24 @@ module Nav = struct type step = S.step type path = step list - let init () = S.Repo.v (Irmin_mem.config ()) >>= S.main >>= S.tree + let empty_repo_main () = S.Repo.v (Irmin_mem.config ()) >>= S.main - let test_populate () : t Lwt.t = + let time_now () = + Int64.of_float ((new%js Js.date_now)##getTime /. 1000.) + + let info_msg ?(time = time_now ()) message = S.Info.v ~message time + + let test_populate () : store Lwt.t = let add p s t = S.Tree.add t p s in + let r' = empty_repo_main () in add [ "hello" ] "world" (S.Tree.empty ()) - >>= add [ "hello"; "daddy" ] "ily" + >>= add [ "daddy" ] "ily" >>= add [ "beep"; "beep" ] "motherfucker" + >>= fun t -> + r' >>= fun r -> + S.set_tree ~info:(fun () -> info_msg "test_populate ()") r [] t + |> ignore; + r' let test_pull () : store Lwt.t = (* test_populate ()*) @@ -573,8 +586,6 @@ module NVG = struct include Graphv_webgl.Color let none = Color.transparent - - (* let transparent = rgbaf ~r:0. ~g:0. ~b:0. ~a:0.000001 *) let gray a = rgbf ~r:a ~g:a ~b:a let light = gray 0.8 let dark = gray 0.2 @@ -1360,7 +1371,7 @@ module Nottui = struct end module Ui = struct - type may_handle = [ `Unhandled | `Handled ] + type may_handle = [ `Unhandled | `Handled | `Moar ] let may_handle (type a) (v : a option) (f : a -> may_handle) : may_handle = @@ -1369,6 +1380,7 @@ module Nottui = struct let pp_may_handle ppf = function | `Unhandled -> F.pf ppf "`Unhandled" | `Handled -> F.pf ppf "`Handled" + | `Moar -> F.pf ppf "`Moar" type mouse_handler = x:float -> @@ -1966,7 +1978,7 @@ module Nottui = struct | Event_filter (n, f) -> ( match f (`Mouse (`Press btn, (x, y), [])) with | `Handled -> true - | `Unhandled -> aux ox oy sw sh n) + | `Unhandled | `Moar -> aux ox oy sw sh n) in aux 0. 0. w h t @@ -2036,7 +2048,9 @@ module Nottui = struct | Atom image -> let image = if Focus.has_focus t.focus then ( - Log.debug (fun m -> m "render_node Atom has_focus"); + Log.debug (fun m -> + m "render_node Atom has_focus status=%a" + Focus.pp_status t.focus); I.attr A.clickable image) else image in @@ -2170,7 +2184,11 @@ module Nottui = struct else { cache with - image = I.attr A.(bg Color.transparent) cache.image; + image = + I.attr + A.(bg Color.(rgbaf ~r:0. ~g:0. ~b:0. ~a:0.000001)) + (* TODO: HACK *) + cache.image; } in t.cache <- cache; @@ -2182,7 +2200,7 @@ module Nottui = struct (render_node vg 0. 0. w h w h view).image let dispatch_raw_key st keys = - let rec iter (st : ui list) : [> `Unhandled ] = + let rec iter (st : ui list) : [> `Unhandled | `Moar ] = match st with | [] -> `Unhandled | ui :: tl -> ( @@ -2198,10 +2216,10 @@ module Nottui = struct | Focus_area (t, f) -> ( match iter [ t ] with | `Handled -> `Handled - | `Unhandled -> ( + | `Unhandled | `Moar -> ( match f keys with | `Handled -> `Handled - | `Unhandled -> iter tl)) + | `Unhandled | `Moar -> iter tl)) | Attr (t, _) | Mouse_handler (t, _) | Size_sensor (t, _) @@ -2214,7 +2232,7 @@ module Nottui = struct | Event_filter (t, f) -> ( match f (`Keys keys) with | `Unhandled -> iter (t :: tl) - | `Handled -> `Handled)) + | a -> a)) in iter [ st.view ] @@ -2305,25 +2323,24 @@ module Nottui = struct let rec dispatch_key st (keys : Ui.keys) = match (dispatch_raw_key st keys, keys) with | `Handled, _ -> `Handled - | `Unhandled, [ (`Arrow dir, []) ] -> + | _, [ (`Arrow dir, []) ] -> let dir : [ `Down | `Left | `Right | `Up ] :> [ `Down | `Left | `Right | `Up | `Next | `Prev ] = dir in dispatch_key st [ (`Focus dir, [ `Meta ]) ] - | `Unhandled, [ (`Tab, mods) ] - when mods == [] || mods = [ `Shift ] -> + | _, [ (`Tab, mods) ] when mods == [] || mods = [ `Shift ] -> dispatch_key st [ ( `Focus (if List.mem `Shift mods then `Prev else `Next), mods ); ] - | `Unhandled, [ (`Focus dir, _) ] -> + | _, [ (`Focus dir, _) ] -> let r = dispatch_focus st.view dir in (if r then Log.debug else Log.warn) (fun m -> m "Renderer.dispatch_focus key:%a -> %b" pp_keys keys r); if r then `Handled else `Unhandled - | `Unhandled, _ -> `Unhandled + | a, _ -> a let dispatch_event t = function | `Keys keys -> dispatch_key t keys @@ -2399,12 +2416,12 @@ module Nottui_lwt = struct match Renderer.dispatch_event renderer (`Keys !key_list) with - | `Handled -> key_list := [] - | `Unhandled -> ()) + | `Handled | `Unhandled -> key_list := [] + | `Moar -> ()) | #Ui.event as event -> ( match Renderer.dispatch_event renderer event with | `Handled -> () - | `Unhandled -> + | `Moar | `Unhandled -> Log.warn (fun m -> m "Nottui_lwt.render process_event #Ui.event -> \ @@ -2482,6 +2499,10 @@ module Widgets = struct List.mem (`Uchar (Uchar.of_char 'g'), [ `Ctrl ]) k' + || + match k' with + | [ (`Escape, []) ] -> true + | _ -> false then `Handled else `Unhandled | _ -> `Unhandled) @@ -3186,6 +3207,7 @@ module Widgets = struct Lwd_table.append' table (Focus.make (), step)) treelist; let cursor = Lwd.var @@ Lwd_table.first table in + Log.debug (fun m -> m "tree_nav cursor focus.request"); Lwd.peek cursor |> Option.iter (fun cursor -> Lwd_table.get cursor @@ -3194,8 +3216,17 @@ module Widgets = struct (Lwd_table.map_reduce (fun _ (f, s) -> Lwd.map (Focus.status f) ~f:(fun focus_h -> - if Focus.has_focus focus_h then string ~attr:A.cursor s - else string s)) + Ui.keyboard_area ~focus:focus_h + (fun k -> + Log.debug (fun m -> + m + "keyboard_area: tree_nav map_reduce \ + %a->`Unhandled" + Ui.pp_keys k); + `Unhandled) + (if Focus.has_focus focus_h then + string ~attr:A.cursor s + else string s))) (Lwd_utils.lift_monoid Ui.pack_y) table |> Lwd.join @@ -3321,7 +3352,6 @@ module Widgets = struct Lwt.return_unit) let h_node_area ?(table = Lwd_table.make ()) - ?(focus = Focus.make ()) ((store, paths) : Nav.S.t * Nav.path list) : Ui.t Lwd.t = List.iter (fun path -> @@ -3334,14 +3364,6 @@ module Widgets = struct (Lwd_utils.lift_monoid Ui.pack_x) table |> Lwd.join - |> Lwd.map2 (Focus.status focus) ~f:(fun focus' -> - Ui.keyboard_area ~focus:focus' (fun k -> - Log.debug (fun m -> - m "keyboard_area: h_node_area_handler %a" - Ui.pp_keys k); - match k with - | [ (`Enter, []) ] -> `Unhandled - | _ -> `Unhandled)) (** 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