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

@@ -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

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,7 +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
@@ -1260,7 +1272,7 @@ module Nottui = struct
     let request_var (v : var) =
       incr clock;
       Log.debug (fun m ->
-          m "Focus.request_var v=%d clock=%d" (Lwd.peek v) !clock);
+          m "Focus.request_var v=%d->%d" (Lwd.peek v) !clock);
       Lwd.set v !clock
 
     let request ((v, _) : handle) = request_var v
@@ -1359,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 =
@@ -1368,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 ->
@@ -1621,10 +1634,9 @@ module Nottui = struct
     let has_focus t = Focus.has_focus t.focus
 
     let rec pp ppf t =
-      if has_focus t then
-        F.pf ppf "@[<hov>%a %a@]" Focus.pp_status t.focus pp_desc
-          t.desc
-      else F.pf ppf "@[<hov> %a@]" pp_desc t.desc
+      (*  if has_focus t then*)
+      F.pf ppf "@[<hov>%a %a@]" Focus.pp_status t.focus pp_desc t.desc
+    (* else F.pf ppf "@[<hov> %a@]" pp_desc t.desc *)
 
     and pp_desc ppf = function
       | Atom a ->
@@ -1814,7 +1826,10 @@ module Nottui = struct
     let update_focus ui =
       match ui.focus with
       | Focus.Empty | Focus.Handle _ -> ()
-      | Focus.Conflict i -> solve_focus ui i
+      | Focus.Conflict i ->
+          Log.debug (fun m ->
+              m "update_focus Conflict %d -> solve_focus ()" i);
+          solve_focus ui i
 
     let rec t_size_desc_of_t vg (size : box2) (ui : Ui.t desc) =
       match ui with
@@ -1963,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
 
@@ -2033,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
@@ -2167,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;
@@ -2179,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 -> (
@@ -2195,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, _)
@@ -2211,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 ]
 
@@ -2302,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
@@ -2396,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 -> \
@@ -2479,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)
@@ -3183,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
@@ -3191,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
@@ -3201,7 +3235,11 @@ module Widgets = struct
                Lwd.peek cursor
                |> Option.iter (fun cursor ->
                       Lwd_table.get cursor
-                      |> Option.iter (fun (f, _) -> Focus.request f));
+                      |> Option.iter (fun (f, _) ->
+                             Log.debug (fun m ->
+                                 m "tree_nav has_focus request %a"
+                                   Focus.pp_status focus');
+                             Focus.request f));
              Ui.keyboard_area ~focus:focus' (fun k ->
                  Log.debug (fun m ->
                      m "keyboard_area: tree_nav %a" Ui.pp_keys k);
@@ -3314,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 ->
@@ -3327,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