Wip: misc + widgets

examples/cbor/cbor_explorer.ml

@@ -3,30 +3,6 @@ module W = Nottui_widgets
 module C = CBOR.Simple
 module A = Notty.A
 
-let unfoldable summary (f: unit -> Ui.Ui.t Lwd.t) : Ui.Ui.t Lwd.t =
-  let opened = ref false in
-  let v = Lwd.var W.empty_lwd in
-  let cursor ~x:_ ~y:_ = function
-     | `Left when !opened ->
-       opened := false;
-       Lwd.set v W.empty_lwd;
-       `Handled
-     | `Left ->
-       opened := true;
-       (* call [f] and pad a bit *)
-       let inner =
-         f()
-         |> Lwd.map (fun x -> Ui.Ui.join_x (W.string "> ") x)
-       in
-       Lwd.set v @@  inner;
-       `Handled
-     | _ -> `Unhandled
-  in
-  let mouse =
-    Lwd.map (fun m -> Ui.Ui.mouse_area cursor m) summary
-  in
-  Lwd_utils.pack Ui.Ui.pack_x [mouse; Lwd.join @@ Lwd.get v]
-
 let ui_of_cbor (c:C.t) =
   let quit = Lwd.var false in
   let w_q = W.main_menu_item "[quit]" (fun () -> Lwd.set quit true; W.empty_lwd) in
@@ -43,8 +19,9 @@ let ui_of_cbor (c:C.t) =
     | `Array [] -> Lwd.return (W.string "[]")
     | `Array l ->
       if fold then (
-        let summary = Lwd.return @@ W.printf ~attr:A.(fg yellow) "<array(%d)>" (List.length l) in
-        unfoldable summary
+        let summary =
+          Lwd.return @@ W.printf ~attr:A.(fg yellow) "<array(%d)>" (List.length l) in
+        W.unfoldable summary
           (fun () ->
              let l = List.map (traverse ~fold:true) l in
              Lwd_utils.pack Ui.Ui.pack_y l)
@@ -53,25 +30,32 @@ let ui_of_cbor (c:C.t) =
         Lwd_utils.pack Ui.Ui.pack_y l
       )
     | `Map [] -> Lwd.return (W.string "{}")
-    | `Map [x,y] ->
-      unfoldable (traverse x) (fun () -> traverse ~fold:false y)
+    | `Map [x,y] -> mk_k_v x y
     | `Map l ->
       let summary = Lwd.return @@ W.printf ~attr:A.(fg yellow) "<map(%d)>" (List.length l) in
-      unfoldable summary
+      W.unfoldable summary
         (fun () ->
            let tbl = Lwd_table.make () in
            List.iter (fun (x,y) ->
                let row = Lwd_table.append tbl in
-               let kv = unfoldable (traverse x) (fun () -> traverse ~fold:false y) in
+               let kv = mk_k_v x y in
                Lwd_table.set row kv)
              l;
            Lwd.join @@ Lwd_table.reduce (Lwd_utils.lift_monoid Ui.Ui.pack_y) tbl)
+  and mk_k_v x y =
+    let tr_x = traverse x in
+    let summary = match y with
+      | `Array _ | `Map _ ->
+        W.hbox [tr_x; Lwd.return (W.string ~attr:A.(bg @@ gray 15) "/")]
+      | _ -> tr_x
+    in
+    W.unfoldable summary (fun () -> traverse ~fold:false y)
   in
   let w =
     Lwd.map2 Ui.Ui.join_y w_q
       (Nottui_widgets.scroll_area @@ traverse ~fold:true c)
   in
-  Lwd.get quit, w
+  quit, w
 
 let show_file f =
   let cbor = CCIO.with_in f (fun ic -> CCIO.read_all ic |> C.decode) in

examples/cbor/cbor_of_fs.ml

@@ -21,10 +21,7 @@ let rec fs_to_cbor ~path (f:string) : C.t =
       with _e ->
         `Text "<read error>"
       in
-    `Map [
-      `Text f,
-      `Array [content]
-    ]
+    `Map [ `Text f, content ]
   )
 
 let () =

lib/lwd/lwd.ml

@@ -510,3 +510,9 @@ let set_on_invalidate x f =
   match x with
   | Pure _ | Impure _ | Operator _ -> assert false
   | Root t -> t.on_invalidate <- f
+
+module Infix = struct
+  let (>>=) = bind
+  let (>|=) = map'
+  let (<*>) = app
+end

lib/lwd/lwd.mli

@@ -112,3 +112,9 @@ val is_damaged : 'a root -> bool
 val release : 'a root -> unit
 (** Forget about this root and release sub-values no longer reachable from
     any root. *)
+
+module Infix : sig
+  val (>|=) : 'a t -> ('a -> 'b) -> 'b t
+  val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+  val (<*>) : ('a -> 'b) t -> 'a t -> 'b t
+end

lib/nottui-widgets/nottui_widgets.ml

@@ -77,6 +77,8 @@ let vscroll_area ~state ~change t =
     (*| `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
@@ -120,6 +122,8 @@ let scroll_area ?(offset=0,0) t =
     | `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
@@ -275,7 +279,7 @@ let sub' str p l =
   else String.sub str p l
 
 let edit_field state ~on_change ~on_submit =
-  let update focus (text, pos) =
+  let update focus_h focus (text, pos) =
     let pos = min (max 0 pos) (String.length text) in
     let content =
       Ui.atom @@ I.hcat @@
@@ -294,6 +298,8 @@ let edit_field state ~on_change ~on_submit =
         [I.string A.empty (if text = "" then " " else text)]
     in
     let handler = function
+      | `ASCII 'U', [`Ctrl] -> on_change ("", 0); `Handled (* clear *)
+      | `Escape, [] -> Focus.release focus_h; `Handled
       | `ASCII k, _ ->
         let text =
           if pos < String.length text then (
@@ -338,7 +344,7 @@ let edit_field state ~on_change ~on_submit =
   in
   let focus = Focus.make () in
   let node =
-    Lwd.map2 update (Nottui.Focus.status focus) state
+    Lwd.map2 (update focus) (Focus.status focus) state
   in
   let mouse_grab (text, pos) ~x ~y:_ = function
     | `Left ->
@@ -349,3 +355,78 @@ let edit_field state ~on_change ~on_submit =
   in
   Lwd.map2' state node @@ fun state content ->
   Ui.mouse_area (mouse_grab state) content
+
+(** Prints the summary, but calls [f()] to compute a sub-widget
+    when clicked on. Useful for displaying deep trees. *)
+let unfoldable ?(folded_by_default=true) summary (f: unit -> Ui.t Lwd.t) : Ui.t Lwd.t =
+  let open Lwd.Infix in
+  let opened = Lwd.var (not folded_by_default) in
+  let fold_content =
+    Lwd.get opened >>= function
+    | true ->
+      (* call [f] and pad a bit *)
+      f() |> Lwd.map (Ui.join_x (string " "))
+    | false -> empty_lwd
+  in
+  (* pad summary with a "> " when it's opened *)
+  let summary =
+    Lwd.get opened >>= function
+    | true -> Lwd.map (Ui.join_x (string ~attr:A.(bg blue) "> ")) summary
+    | false -> summary
+  in
+  let cursor ~x:_ ~y:_ = function
+     | `Left when Lwd.peek opened -> Lwd.set opened false; `Handled
+     | `Left -> Lwd.set opened true; `Handled
+     | _ -> `Unhandled
+  in
+  let mouse = Lwd.map (fun m -> Ui.mouse_area cursor m) summary in
+  Lwd.map2
+    (fun summary fold ->
+      (* TODO: make this configurable/optional *)
+      (* newline if it's too big to fit on one line nicely *)
+      let spec_sum = Ui.layout_spec summary in
+      let spec_fold = Ui.layout_spec fold in
+      (* TODO: somehow, probe for available width here? *)
+      let too_big =
+        spec_fold.Ui.h > 1 ||
+        (spec_fold.Ui.h>0 && spec_sum.Ui.w + spec_fold.Ui.w > 60)
+      in
+      if too_big
+      then Ui.join_y summary (Ui.join_x (string " ") fold)
+      else Ui.join_x summary fold)
+    mouse fold_content
+
+let hbox l = Lwd_utils.pack Ui.pack_x l
+let vbox l = Lwd_utils.pack Ui.pack_y l
+let zbox l = Lwd_utils.pack Ui.pack_z l
+
+let vlist (l: Ui.t Lwd.t list) : Ui.t Lwd.t =
+  l
+  |> List.map (fun ui -> Lwd.map (Ui.join_x (string "- ")) ui)
+  |> Lwd_utils.pack Ui.pack_y
+
+(** A list of items with a dynamic filter on the items *)
+let vlist_with
+    ?(filter=Lwd.return (fun _ -> true))
+    (f:'a -> Ui.t Lwd.t)
+    (l:'a list Lwd.t) : Ui.t Lwd.t =
+  let open Lwd.Infix in
+  let rec filter_map_ acc f l =
+    match l with
+    | [] -> List.rev acc
+    | x::l' ->
+      let acc' = match f x with | None -> acc | Some y -> y::acc in
+      filter_map_ acc' f l'
+  in
+  let l = l >|= List.map (fun x -> x, Lwd.map (Ui.join_x (string "- ")) @@ f x) in
+  let l_filter : _ list Lwd.t =
+    filter >>= fun filter ->
+    l >|=
+    filter_map_ []
+      (fun (x,ui) -> if filter x then Some ui else None)
+  in
+  l_filter >>= Lwd_utils.pack Ui.pack_y
+
+let button ?attr s f =
+  Ui.mouse_area (fun ~x:_ ~y:_ _ -> f(); `Handled) (string ?attr s)
+

lib/nottui/nottui.ml

@@ -10,6 +10,7 @@ sig
   val make : unit -> handle
   val request : handle -> unit
   val request_var : var -> unit
+  val release : handle -> unit
 
   type status =
     | Empty
@@ -51,6 +52,7 @@ end = struct
     Lwd.set v !clock
 
   let request (v, _ : handle) = request_var v
+  let release (v, _ : handle) = incr clock; Lwd.set v 0
 
   let merge s1 s2 : status = match s1, s2 with
     | Empty, x | x, Empty -> x
@@ -611,32 +613,37 @@ struct
     let cache = render_node 0 0 w h w h st.view in
     process (cache.image, cache.overlays)
 
-  let rec dispatch_key_branch acc t =
-    match t.desc with
-    | Atom _ | Overlay _ -> acc
-    | X (a, b) | Y (a, b) | Z (a, b) ->
-      (* Default to left/top-most branch if there is no focus *)
-      if Focus.has_focus b.focus
-      then dispatch_key_branch acc b
-      else dispatch_key_branch acc a
-    | Focus_area (t, f) -> dispatch_key_branch (f :: acc) t
-    | Mouse_handler (t, _) | Size_sensor (t, _)
-    | Scroll_area (t, _, _) | Resize (t, _, _) ->
-      dispatch_key_branch acc t
-    | Event_filter (t, f) ->
-      (fun key -> f (`Key key)) :: dispatch_key_branch acc t
-
   let dispatch_raw_key st key =
-    let branch = dispatch_key_branch [] st.view in
-    let rec iter = function
-      | f :: fs ->
-        begin match f key with
-          | `Unhandled -> iter fs
-          | `Handled -> `Handled
-        end
+    let rec iter (st: ui list) : [> `Unhandled] =
+      match st with
       | [] -> `Unhandled
+      | ui :: tl ->
+        begin match ui.desc with
+          | Atom _ | Overlay _ -> iter tl
+          | X (a, b) | Y (a, b) | Z (a, b) ->
+            (* Try left/top most branch first *)
+            let st' =
+              if Focus.has_focus b.focus
+              then b :: tl
+              else a :: b :: tl
+            in
+            iter st'
+          | Focus_area (t, f) ->
+            begin match f key with
+              | `Handled -> `Handled
+              | `Unhandled -> iter (t :: tl)
+            end
+          | Mouse_handler (t, _) | Size_sensor (t, _)
+          | Scroll_area (t, _, _) | Resize (t, _, _) ->
+            iter (t :: tl)
+          | Event_filter (t, f) ->
+            begin match f (`Key key) with
+              | `Unhandled -> iter (t :: tl)
+              | `Handled -> `Handled
+            end
+        end
     in
-    iter branch
+    iter [st.view]
 
   exception Acquired_focus
 
@@ -761,7 +768,7 @@ struct
           ignore (Renderer.dispatch_event renderer event : [`Handled | `Unhandled])
 
   let run_with_term term ?tick_period ?(tick=ignore) ~renderer quit t =
-    let quit = Lwd.observe quit in
+    let quit = Lwd.observe (Lwd.get quit) in
     let root = Lwd.observe t in
     let rec loop () =
       let quit = Lwd.sample quit in
@@ -777,16 +784,15 @@ struct
 
   let run ?tick_period ?tick ?term ?(renderer=Renderer.make ())
           ?quit t =
-    let quit, t = match quit with
-      | Some quit -> quit, t
-      | None ->
-        let quit = Lwd.var false in
-        let t = t |> Lwd.map (Ui.event_filter (function
-            | `Key (`Escape, _) -> Lwd.set quit true; `Handled
+    let quit = match quit with
+      | Some quit -> quit
+      | None -> Lwd.var false
+    in
+    let t =
+      t |> Lwd.map (Ui.event_filter (function
+            | `Key (`ASCII 'Q', [`Ctrl]) -> Lwd.set quit true; `Handled
             | _ -> `Unhandled
-          ))
-        in
-        Lwd.get quit, t
+        ))
     in
     match term with
     | Some term -> run_with_term term ?tick_period ?tick ~renderer quit t

lib/nottui/nottui.mli

@@ -5,6 +5,7 @@ sig
   type handle
   val make : unit -> handle
   val request : handle -> unit
+  val release : handle -> unit
 
   type status
   val empty : status
@@ -115,5 +116,5 @@ sig
   val run :
     ?tick_period:float -> ?tick:(unit -> unit) ->
     ?term:Term.t -> ?renderer:Renderer.t ->
-    ?quit:bool Lwd.t -> ui Lwd.t -> unit
+    ?quit:bool Lwd.var -> ui Lwd.t -> unit
 end