selectable node/contents, needs correcting focus control

boot_js.ml

@@ -91,7 +91,7 @@ let _ =
   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 ->
-  Widgets.(tree_nav (test_store, [])) >>= fun ui ->
+  let ui = Widgets.(h_node_area (test_store, [ [] ])) in
   let root =
     Lwd.set body
       (Lwd.map ~f:(Ui.resize ~pad:gravity_pad ~crop:gravity_crop) ui);

human.ml

@@ -2483,15 +2483,6 @@ module Widgets = struct
       Lwd.set offset (s_x, s_y);
       `Handled
     in
-    let focus_handler = function
-      | `Arrow `Left, [] -> scroll (-.scroll_step) 0.
-      | `Arrow `Right, [] -> scroll (+.scroll_step) 0.
-      | `Arrow `Up, [] -> scroll 0. (-.scroll_step)
-      | `Arrow `Down, [] -> scroll 0. (+.scroll_step)
-      | `Page `Up, [] -> scroll 0. (-.scroll_step *. 8.)
-      | `Page `Down, [] -> scroll 0. (+.scroll_step *. 8.)
-      | _ -> `Unhandled
-    in
     (* let scroll_handler ~x:_ ~y:_ = function
          | `Scroll `Up -> scroll 0. (-.scroll_step)
          | `Scroll `Down -> scroll 0. (+.scroll_step)
@@ -2500,7 +2491,17 @@ module Widgets = struct
     Lwd.map2 t (Lwd.get offset) ~f:(fun t (s_x, s_y) ->
         t |> Ui.shift_area s_x s_y
         (*|> Ui.mouse_area scroll_handler*)
-        |> Ui.keyboard_area focus_handler)
+        |> Ui.keyboard_area (fun e ->
+               Log.debug (fun m ->
+                   m "keyboard_area: scroll_area focus_handler");
+               match e with
+               | `Arrow `Left, [] -> scroll (-.scroll_step) 0.
+               | `Arrow `Right, [] -> scroll (+.scroll_step) 0.
+               | `Arrow `Up, [] -> scroll 0. (-.scroll_step)
+               | `Arrow `Down, [] -> scroll 0. (+.scroll_step)
+               | `Page `Up, [] -> scroll 0. (-.scroll_step *. 8.)
+               | `Page `Down, [] -> scroll 0. (+.scroll_step *. 8.)
+               | _ -> `Unhandled))
 
   let main_menu_item wm text f =
     let text = string ~attr:A.menu_main (" " ^ text ^ " ") in
@@ -2737,8 +2738,6 @@ module Widgets = struct
      Lwd.map2 state node ~f:(fun state content ->
          Ui.mouse_area (mouse_grab state) content *)
 
-  open Lwd.Infix
-
   type line = {
     focus : Focus.handle;
     state : (string * int) Lwd.var;
@@ -2788,7 +2787,7 @@ module Widgets = struct
         | Some new_row ->
             (match Lwd_table.get new_row with
             | Some new_line ->
-                cursor_row |> Lwd_table.get
+                Lwd_table.get cursor_row
                 |> Option.iter (fun cursor_line ->
                        update cursor_line new_line;
                        Focus.release cursor_line.focus);
@@ -2851,11 +2850,10 @@ module Widgets = struct
   let edit_area ?(table = Lwd_table.make ()) ?(focus = Focus.make ())
       () : Ui.t Lwd.t =
     let cursor = Lwd.var @@ Lwd_table.first table in
-    Option.iter
+    Lwd.peek cursor
-      (fun cursor ->
+    |> Option.iter (fun cursor ->
-        Option.iter (fun first -> Focus.request first.focus)
+           Lwd_table.get cursor
-        @@ Lwd_table.get cursor)
+           |> Option.iter (fun first -> Focus.request first.focus));
-      (Lwd.peek cursor);
 
     (* Build view of table *)
     Lwd_table.map_reduce
@@ -2867,7 +2865,7 @@ module Widgets = struct
          ~f:(fun focus ->
            Ui.keyboard_area ~focus (fun k ->
                Log.debug (fun m ->
-                   m "edit_area handler %a" Ui.pp_key k);
+                   m "keyboard_area: edit_area handler %a" Ui.pp_key k);
                let cursor_move =
                  cursor_move ~update:copy_line_cursor cursor
                in
@@ -2921,19 +2919,12 @@ module Widgets = struct
 
   (* TODO: view_metadata *)
 
-  let rec node_edit_area ?(table = Lwd_table.make ())
+  let node_edit_area ?(table = Lwd_table.make ())
       ?(focus = Focus.make ()) ((store, path) : Nav.S.t * Nav.path) :
       Ui.t Lwd.t Lwt.t =
     let cursor = Lwd.var @@ Lwd_table.first table in
     let open Lwt.Infix in
     Nav.S.tree store >>= fun tree ->
-    Nav.S.Tree.kind tree path >>= function
-    | None ->
-        lwt_lwd_string
-          ("Nav.S.Tree.kind " ^ String.concat "/" path
-         ^ " how'd you get here??")
-    | Some `Node -> tree_nav (store, path)
-    | Some `Contents -> (
     let save_stream, save_push = Lwt_stream.create () in
     Lwt.async (fun () ->
         Lwt_stream.iter_s
@@ -2941,12 +2932,16 @@ module Widgets = struct
             Nav.S.Tree.add tree path contents >>= fun tree' ->
             Nav.S.set_tree
               ~info:(fun () ->
-                    Nav.S.Info.v ~message:"node_edit_area 'save'"
+                Nav.S.Info.v
+                  ~message:
+                    ("node_edit_area " ^ String.concat "/" path
+                   ^ " 'save'")
                   (Int64.of_float
                      ((new%js Js.date_now)##getTime /. 1000.)))
               store path tree'
             >>= fun _ -> Lwt.return_unit)
           save_stream);
+
     Nav.S.Tree.find_all tree path >>= function
     | None ->
         lwt_lwd_string
@@ -2954,11 +2949,11 @@ module Widgets = struct
          ^ " -> None")
     | Some (contents, _metadata) ->
         line_table_of_string ~table contents |> ignore;
-            Option.iter
+
-              (fun cursor ->
+        Lwd.peek cursor
-                Option.iter (fun first -> Focus.request first.focus)
+        |> Option.iter (fun cursor ->
-                @@ Lwd_table.get cursor)
+               Lwd_table.get cursor
-              (Lwd.peek cursor);
+               |> Option.iter (fun first -> Focus.request first.focus));
 
         (* Build view of table *)
         Lwt.return
@@ -2967,37 +2962,30 @@ module Widgets = struct
              (Lwd_utils.lift_monoid Ui.pack_y)
              table
           |> Lwd.join
-              |> Lwd.map2
+          |> Lwd.map2 (Focus.status focus) ~f:(fun focus' ->
-                   ~f:(fun focus ->
+                 Ui.keyboard_area ~focus:focus' (fun k ->
-                     Ui.keyboard_area ~focus (fun k ->
                      Log.debug (fun m ->
-                             m "edit_area handler %a" Ui.pp_key k);
+                         m "node_edit_area handler %a" Ui.pp_key k);
                      let cursor_move =
                        cursor_move ~update:copy_line_cursor cursor
                      in
                      match k with
                      | `Uchar u, [ `Ctrl ] when eq_uc_c u 'n' ->
                          cursor_move Lwd_table.next
-                         | `Arrow `Down, _ ->
+                     | `Arrow `Down, _ -> cursor_move Lwd_table.next
-                             cursor_move Lwd_table.next
                      | `Uchar u, [ `Ctrl ] when eq_uc_c u 'p' ->
                          cursor_move Lwd_table.prev
                      | `Arrow `Up, _ -> cursor_move Lwd_table.prev
                      | `Uchar u, [ `Meta ] when eq_uc_c u '<' ->
-                             cursor_move (fun _ ->
+                         cursor_move (fun _ -> Lwd_table.first table)
-                                 Lwd_table.first table)
                      | `Uchar u, [ `Meta ] when eq_uc_c u '>' ->
-                             cursor_move (fun _ ->
+                         cursor_move (fun _ -> Lwd_table.last table)
-                                 Lwd_table.last table)
                      | `Enter, [] ->
                          line_of_cursor cursor
                            (fun old_row old_line ->
-                                 let str, pos =
+                             let str, pos = Lwd.peek old_line.state in
-                                   Lwd.peek old_line.state
-                                 in
                              let n_str =
-                                   String.(
+                               String.(sub str pos (length str - pos))
-                                     sub str pos (length str - pos))
                              in
                              Lwd.set old_line.state
                                (String.sub str 0 pos, pos);
@@ -3022,12 +3010,10 @@ module Widgets = struct
                                          Lwd.peek line_prev.state
                                        in
                                        Focus.release line.focus;
-                                           Focus.request
+                                       Focus.request line_prev.focus;
-                                             line_prev.focus;
                                        Lwd.set line_prev.state
                                          ( str_prev ^ str,
-                                               String.length str_prev
+                                           String.length str_prev );
-                                             );
                                        Lwd_table.remove row;
                                        `Handled)
                                  else `Unhandled))
@@ -3041,100 +3027,59 @@ module Widgets = struct
                              @@ string_of_line line)
                            table;
                          save_push (Some (Buffer.contents b));
-
                          `Handled
-                         | _ -> `Unhandled))
+                     | _ -> `Unhandled)))
-                   (Focus.status focus)))
 
-  and tree_nav ?(focus = Focus.make ())
+  module Cursor = struct
+    type 'a t = 'a Lwd_table.row option Lwd.var
+
+    let get t ~f =
+      Lwd.peek t
+      |> Option.iter (fun t_row ->
+             Option.iter (f t_row) (Lwd_table.get t_row))
+  end
+
+  let tree_nav ?(focus = Focus.make ()) ?(selection = Lwd.var @@ None)
       ((store, path) : Nav.S.t * Nav.path) : Ui.t Lwd.t Lwt.t =
     let table = Lwd_table.make () in
-
+    let cursor_move cursor f =
-    let cursor_move cursor
+      Ui.may_handle (Lwd.peek cursor) (fun cursor_row ->
-        (f : 'a Lwd_table.row -> 'a Lwd_table.row option) =
+          Ui.may_handle (f cursor_row) (fun new_row ->
-      match Lwd.peek cursor with
+              Lwd_table.get new_row
-      | Some cursor_row -> (
+              |> Option.iter (fun (new_line_focus, new_line_sel) ->
-          match f cursor_row with
+                     Lwd.set selection (Some new_line_sel);
-          | Some new_row ->
+                     Lwd_table.get cursor_row
-              (match Lwd_table.get new_row with
-              | Some (new_line_focus, _) ->
-                  cursor_row |> Lwd_table.get
                      |> Option.iter (fun (cursor_line_focus, _) ->
                             Focus.release cursor_line_focus);
-                  Focus.request new_line_focus
+                     Focus.request new_line_focus);
-              | None -> ());
               Lwd.set cursor (Some new_row);
-              `Handled
+              `Handled))
-          | None -> `Unhandled)
-      | None -> `Unhandled
     in
-
     (* Build view of tree *)
     let open Lwt.Infix in
-    Nav.S.tree store >>= fun tree ->
+    Nav.S.list store path >>= fun treelist ->
-    Nav.S.Tree.list tree path >>= fun treelist ->
     List.iter
       (fun (step, _tree) ->
         Lwd_table.append' table (Focus.make (), step))
       treelist;
     let cursor = Lwd.var @@ Lwd_table.first table in
-    Option.iter
+    Lwd.peek cursor
-      (fun cursor ->
+    |> Option.iter (fun cursor ->
-        Option.iter (fun (f, _) -> Focus.request f)
+           Lwd_table.get cursor
-        @@ Lwd_table.get cursor)
+           |> Option.iter (fun (f, _) -> Focus.request f));
-      (Lwd.peek cursor);
-
-    (* Lwd.observe ~on_invalidate:(fun _ ->
-         Lwd.set cursorview (Lwd.quick_sample (root ()))); *)
-    let cursorview =
-      Lwd.var @@ Lwd.pure @@ string "initializing..."
-    in
-    let cv, push_cv = Lwt_stream.create () in
-    let cvroot =
-      Lwd.observe ~on_invalidate:(fun _ ->
-          Log.info (fun m ->
-              m
-                "tree_nav cursorviewroot on_invalidate push_cv \
-                 triggered??");
-          push_cv (Some ()))
-      @@ Lwd.map (Lwd.get cursor) ~f:(function
-           | Some cursor_row -> (
-               match Lwd_table.get cursor_row with
-               | Some (_focus, step) -> (
-                   Nav.S.Tree.kind tree (path @ [ step ]) >>= function
-                   | Some `Node -> lwt_lwd_string "Sub-node??"
-                   | Some `Contents ->
-                       node_edit_area (store, path @ [ step ])
-                   | None ->
-                       lwt_lwd_string
-                         ("Nav.S.Tree.kind " ^ step ^ " -> None?"))
-               | None ->
-                   lwt_lwd_string "cursor table row doesn't exist")
-           | None -> lwt_lwd_string "cursor doesn't exist")
-    in
-    Lwt.async (fun () ->
-        Lwt_stream.iter_s
-          (fun _ ->
-            Lwd.quick_sample cvroot >>= fun cursorview'' ->
-            Log.info (fun m ->
-                m "tree_nav Lwt.async (Lwd.set cursorview)");
-            Lwt.return (Lwd.set cursorview cursorview''))
-          cv);
-    push_cv (Some ());
     Lwt.return
       (Lwd_table.map_reduce
          (fun _ (f, s) ->
-           Lwd.map
+           Lwd.map (Focus.status f) ~f:(fun focus_h ->
-             ~f:(fun focus_h ->
                if Focus.has_focus focus_h then string ~attr:A.cursor s
-               else string s)
+               else string s))
-             (Focus.status f))
          (Lwd_utils.lift_monoid Ui.pack_y)
          table
       |> Lwd.join
-      |> Lwd.map2 (Focus.status focus) ~f:(fun focus ->
+      |> Lwd.map2 (Focus.status focus) ~f:(fun focus' ->
-             Ui.keyboard_area ~focus (fun k ->
+             Ui.keyboard_area ~focus:focus' (fun k ->
-                 Log.debug (fun m -> m "nav_handler %a" Ui.pp_key k);
+                 Log.debug (fun m ->
+                     m "keyboard_area: tree_nav %a" Ui.pp_key k);
                  match k with
                  | `Uchar u, [ `Ctrl ] when eq_uc_c u 'n' ->
                      cursor_move cursor Lwd_table.next
@@ -3149,18 +3094,135 @@ module Widgets = struct
                  | `Uchar u, [ `Meta ] when eq_uc_c u '>' ->
                      cursor_move cursor (fun _ ->
                          Lwd_table.last table)
-                 | `Enter, [] -> `Handled
-                 | `Backspace, [] -> `Unhandled
                  | `Uchar u, [ `Ctrl ] when eq_uc_c u 'k' -> `Handled
-                 | _ -> `Unhandled))
+                 | `Enter, [] ->
-      |> Lwd.map2
+                     Lwd.peek cursor
+                     |> Option.iter (fun c ->
+                            Lwd_table.get c
+                            |> Option.iter (fun (f, _step) ->
+                                   Focus.release focus;
+                                   Focus.request f));
+                     `Unhandled
+                 | `Backspace, [] -> `Unhandled
+                 | _ -> `Unhandled)))
+
+  (* let cursorview =
+       Lwd.var @@ Lwd.pure @@ string "initializing..."
+     in
+     let cv, push_cv = Lwt_stream.create () in
+     let cvroot =
+       Lwd.observe ~on_invalidate:(fun _ ->
+           Log.info (fun m ->
+               m
+                 "tree_nav cursorviewroot on_invalidate push_cv \
+                  triggered??");
+           push_cv (Some ()))
+       @@ Lwd.map (Lwd.get cursor) ~f:(function
+            | Some cursor_row -> (
+                match Lwd_table.get cursor_row with
+                | Some (focus, step) -> (
+                    let path' = path @ [ step ] in
+                    Nav.S.kind store path' >>= function
+                    | Some `Node -> lwt_lwd_string "Sub-node??"
+                    | Some `Contents -> node_edit_area (store, path')
+                    | None ->
+                        lwt_lwd_string
+                          ("Nav.S.kind " ^ String.concat "/" path'
+                         ^ " -> None?"))
+                | None ->
+                    lwt_lwd_string "cursor table row doesn't exist")
+            | None -> lwt_lwd_string "cursor doesn't exist")
+     in
+     Lwt.async (fun () ->
+         Lwt_stream.iter_s
+           (fun _ ->
+             Lwd.quick_sample cvroot >>= fun cursorview'' ->
+             Log.info (fun m ->
+                 m "tree_nav Lwt.async (Lwd.set cursorview)");
+             Lwt.return (Lwd.set cursorview cursorview''))
+           cv);
+       push_cv (Some ()); *)
+  (*|> Lwd.map2
        (Lwd.join @@ Lwd.get cursorview)
        ~f:(fun cursorview' tree_view ->
-             Ui.join_x tree_view cursorview'))
+         Ui.join_x tree_view cursorview') *)
+
+  open Lwt.Infix
+
+  let rec node_ui ?(focus = Focus.make ()) store path
+      (f : Focus.handle * ui Lwd.t -> unit) : unit =
+    Lwt.async (fun () ->
+        Nav.S.tree store >>= fun tree ->
+        Nav.S.Tree.kind tree path >>= function
+        | None ->
+            f
+              ( focus,
+                Lwd.pure
+                @@ string
+                     ("Nav.S.Tree.kind " ^ String.concat "/" path
+                    ^ " how'd you get here??") );
+            Lwt.return_unit
+        | Some `Node ->
+            let selection = Lwd.var None in
+            tree_nav ~selection ~focus (store, path) >>= fun ui ->
+            f
+              ( focus,
+                Lwd.map2
+                  (Lwd.pair (Focus.status focus) (Lwd.get selection))
+                  ui
+                  ~f:(fun (focus, selection) ui ->
+                    Ui.keyboard_area ~focus
+                      (fun k ->
+                        Log.debug (fun m ->
+                            m "keyboard_area: node_ui %a" Ui.pp_key k);
+
+                        match k with
+                        | `Enter, [] -> (
+                            match selection with
+                            | Some sel ->
+                                Log.debug (fun m ->
+                                    m "node_ui selecting '%s'" sel);
+                                node_ui store (path @ [ sel ]) f;
+                                Log.debug (fun m ->
+                                    m "node_ui done selecting '%s'"
+                                      sel);
+
+                                `Handled
+                            | None -> `Unhandled)
+                        | _ -> `Unhandled)
+                      ui) );
+            Lwt.return_unit
+        | Some `Contents ->
+            node_edit_area ~focus (store, path) >>= fun ui ->
+            f (focus, ui);
+            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 ->
+        node_ui store path (fun v -> Lwd_table.append' table v))
+      paths;
+    let _cursor = Lwd.var @@ Lwd_table.first table in
+    Lwd_table.map_reduce
+      (fun _row (_focus, ui) -> ui)
+      (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_key
+                     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
       =
+    let open Lwd.Infix in
     match tabs with
     | [] -> Lwd.return Ui.empty
     | _ ->