ui node tree pretty-printer

.console

@@ -0,0 +1 @@
+it consoles you

dune

@@ -18,7 +18,6 @@
   nottui
   nottui-pretty
   uuseg.string
-  grenier.trope
   uutf
   uucp
   ocaml-compiler-libs.common

human.ml

@@ -1,5 +1,7 @@
 (*
 
+ALWAYS BREAK UP THE PROBLEM INTO SMALLER CHUNKS BITCH!!
+
 a computation console
 
 - irmin store provides a tree of data objects
@@ -1226,42 +1228,6 @@ module Panel = struct
       ; font= Font.merge a.font b.font }
   end
 
-  module Focus = struct
-    (* Stolen from lwd/lib/nottui/nottui.ml *)
-    type var = int Lwd.var
-    type status = [`Empty | `Handle of int * var | `Conflict of int]
-    type handle = var * status Lwd.t
-
-    let make () =
-      let v = Lwd.var 0 in
-      (v, Lwd.map ~f:(fun n -> `Handle (n, v)) (Lwd.get v))
-
-    let empty : status = `Empty
-    let status (h : handle) : status Lwd.t = snd h
-
-    let has_focus = function
-      | `Empty -> false
-      | `Handle (i, _) | `Conflict i -> i > 0
-
-    let clock = ref 0
-    let request_var (v : var) = incr clock ; 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
-      | s, (`Empty | `Handle (0, _)) | (`Empty | `Handle (0, _)), s ->
-          s
-      | (`Handle (i, _) as s), `Handle (j, _) when i = j -> s
-      | (`Handle (i, _) | `Conflict i), (`Conflict j as s) when i < j
-        ->
-          s
-      | (`Handle (i, _) | `Conflict i), `Handle (j, _) when i < j ->
-          `Conflict j
-      | (`Conflict _ as s), (`Handle (_, _) | `Conflict _) -> s
-      | `Handle (i, _), (`Handle (_, _) | `Conflict _) -> `Conflict i
-  end
-
   module Pad = struct
     type t = {t: Gg.size1; b: Gg.size1; l: Gg.size1; r: Gg.size1}
 
@@ -1272,334 +1238,270 @@ module Panel = struct
       ; r= Gg.Size1.zero }
   end
 
-  module Region = struct
-    type 'a t =
-      {t: 'a Trope.t; left: Trope.cursor; right: Trope.cursor}
-
-    type cursor = Trope.cursor
-    type 'a region = 'a t
-
-    let create () =
-      let t = Trope.create () in
-      let left = Trope.cursor_at_origin t in
-      {t; left; right= left}
-
-    let append (t : 'a region) (e : 'a) : 'a region =
-      let right = Trope.cursor_after t.right in
-      {t with t= Trope.put_right t.t right e; right}
-
-    let rec iter ~t ?(start = t.left) ~(f : 'a -> unit) () =
-      match Trope.seek_after t.t start with
-      | Some (c, e) -> f e ; iter ~start:c ~t ~f ()
-      | None -> ()
-
-    let rec trope_replace ~(t : 'a region) ?(start = t.left)
-        ~(f :
-              'a Trope.t * Trope.cursor
-           -> 'a
-           -> 'a Trope.t * Trope.cursor ) () : 'a region =
-      match Trope.seek_after t.t start with
-      | Some (c, e) ->
-          let t', c' = f (t.t, c) e in
-          trope_replace
-            ~t:
-              { t with
-                t= t'
-              ; right=
-                  ( if Trope.compare t.right c' < 0 then c'
-                  else t.right ) }
-            ~start:c' ~f ()
-      | None -> t
-
-    let rec replace ~(r : 'a region) ?(start = r.left)
-        ~(f : 'a t * cursor -> 'a -> 'a t * cursor) () : 'a region =
-      match Trope.seek_after r.t start with
-      | Some (c, e) ->
-          let r', c' = f (r, c) e in
-          replace
-            ~r:
-              { r' with
-                right=
-                  ( if Trope.compare r.right c' < 0 then c'
-                  else r.right ) }
-            ~start:c' ~f ()
-      | None -> r
-
-    let rec fold ~(t : 'a region) ?(start = t.left)
-        ~(f : 'a Trope.t * Trope.cursor -> 'a -> 'b -> 'b) (acc : 'b)
-        : 'b =
-      match Trope.seek_after t.t start with
-      | Some (c, e) -> fold ~t ~start:c ~f (f (t.t, c) e acc)
-      | None -> acc
-
-    let rec fold_lwt ~(t : 'a region) ?(start = t.left)
-        ~(f : 'a Trope.t * Trope.cursor -> 'a -> 'b -> 'b Lwt.t)
-        (acc : 'b) : 'b Lwt.t =
-      match Trope.seek_after t.t start with
-      | Some (c, e) ->
-          f (t.t, c) e acc >>= fun x -> fold_lwt ~t ~start:c ~f x
-      | None -> Lwt.return acc
-
-    let rec fold_lwt_opt ~(t : 'a region) ?(start = t.left)
-        ~(f : 'a Trope.t * Trope.cursor -> 'a -> 'b -> 'b option Lwt.t)
-        (acc : 'b) : 'b Lwt.t =
-      match Trope.seek_after t.t start with
-      | Some (c, e) -> (
-          f (t.t, c) e acc
-          >>= function
-          | Some x -> fold_lwt_opt ~t ~start:c ~f x
-          | None -> Lwt.return acc )
-      | None -> Lwt.return acc
-
-                  
-  end
-
   module Ui = struct
+    (* Tree-like structure of Ui elements, from the entire display down to individual glyphs. *)
+    (* i think this is gonna end up being a binary tree?? *)
+
     open Gg
     open Wall
 
-    type t = [`Atom of atom | `Attr of (attr * node) | `Region of (dir * region)]
+    type t =
+      [ `Atom of atom
+      | `Attr of attr * node
+      | `Join of dir * node * node ]
 
-    and node = {mutable parent: parent; mutable child: t}
+    and node = {mutable parent: node option; mutable t: t}
-
+    and cursor = {root: node; mutable sel: node}
-    and parent = [ `Atom of atom | `Attr of (attr * node) | `Region of (dir * region * Region.cursor)]
 
     and atom =
       [ `Image of image
       | `Uchar of Uchar.t
-      | `Boundary of [`Word | `Line | `Sentance | `Hint] ]
+      | `Boundary of [`Word | `Line | `Sentance]
+      | `Hint of [`Line | `Other]
+      | `Empty ]
 
     and attr =
       [ `Style of style
       | `Pad of Pad.t
       | `Shift of dim
-      | `Focus of handle * Focus.handle
+      | `Cursor
-      | `Handle of handle ]
+      | `Handler of handler ]
-
-    and region = node Region.t
-
 
+    and dim = Size2.t
+    and image = Wall.image * dim
+    and style = Style.t
+    and handler = node -> Event.t -> Event.t option Lwt.t
     and dir = [`X | `Y | `Z]
 
-    and image = Wall.image * Size2.t
+    let set_parent_on_children n : node =
-
+      ( match n.t with
-    and dim = Gg.size2
+      | `Atom _ -> ()
-
+      | `Attr (_, a) -> a.parent <- Some n
-    and style = Style.t
+      | `Join (_, a, b) ->
-
+          a.parent <- Some n ;
-    and handle = node -> Event.t -> Event.t option Lwt.t
+          b.parent <- Some n ) ;
+      n
 
+    let node (t : t) = set_parent_on_children {parent= None; t}
     let empty_image = (Image.empty, V2.zero)
-
+    let empty_node = node (`Atom `Empty)
-    let empty_node =
-      let rec parent = `Atom (`Image empty_image) in
-      parent
-
-    let empty_region dir =
-      let rec parent =
-        `Region (dir, Region.create ()) in
-      parent
-
-    let set_parent_on_children parent =
-      match parent.child with
-      | `Atom _ -> ()
-      | `Attr (_, n) -> n.parent <- parent
-      | `Region (_, r) ->
-          Region.iter ~t:r ~f:(fun n -> n.parent <- parent) ()
-
-    let set_children_on_parent (t : t) =
-      match t with
-      | `Atom _ -> ()
-      | `Attr (_, n) -> n.parent.child <- t
-      | `Region (_, r) ->
-          Region.iter ~t:r ~f:(fun n -> n.parent.child <- t) ()
-
-    let node (child : t) =
-      let rec parent = {parent; child} in
-      set_parent_on_children parent ;
-      parent
-
     let style (s : Style.t) (n : node) = node (`Attr (`Style s, n))
 
-    let focus ((f, h) : handle * Focus.handle) (n : node) =
+    let rec traverse_nodes ~(f : node -> node option) (n : node) :
-      node (`Attr (`Focus (f, h), n))
+        unit =
-
+      match f n with
-    let node_func ?(fnode = fun (x : node) -> x)
+      | Some {t= `Atom _; _} -> ()
-        ?(fregion = fun (x : node Region.t) -> x)
+      | Some {t= `Attr (_, n'); _} -> traverse_nodes ~f n'
-        ?(fatom = fun (x : atom) -> x) parent : node =
+      | Some {t= `Join (_, a, b); _} ->
-      parent.child <-
+          traverse_nodes ~f a ; traverse_nodes ~f b
-        ( match parent.child with
+      | None -> ()
-        | `Attr (a, n) -> `Attr (a, {(fnode n) with parent})
-        | `Region (a, r) -> `Region (a, fregion r)
-        | `Atom a -> `Atom (fatom a) ) ;
-      parent
-
-    let rec traverse_nodes ~(f : node -> node) (n : node) : node =
-      node_func
-        ~fnode:(fun n -> traverse_nodes ~f (f n))
-        ~fregion:(fun r ->
-          Region.replace ~r
-            ~f:(fun (r, c) e ->
-              ( { r with
-                  t=
-                    Trope.put_right r.t c
-                      {(traverse_nodes ~f e) with parent= n} }
-              , c ) )
-            () )
-        n
-
-    let rec traverse_regions
-        ~(region :
-              parent:node
-           -> node Region.t * Region.cursor
-           -> child:node
-           -> node Region.t * Region.cursor ) ~(node : node -> node)
-        (parent : node) : node =
-      node_func
-        ~fnode:(fun n -> traverse_regions ~region ~node (node n))
-        ~fregion:(fun r ->
-          Region.replace ~r
-            ~f:(fun (r, c) child -> region ~parent (r, c) ~child)
-            () )
-        parent
-
-    let rec search_backward (node : node) (t : [`Atom of atom | `Attr of attr | `Region of dir] ) =
-      match node.parent.child with
-      | `Atom a when t <> `Atom a -> search_backward node.parent t
-      | `Attr (a, n) when t <> `Attr a -> search_backward node.parent t
-      | `Region (d, r) when t <> `Region d -> 
-        
-                                  | `Region ->  x where x = t -> x
 
+    let insert_attr (a : attr) (n : node) : node =
+      let p = n.parent in
+      let n' = node (`Attr (a, n)) in
+      n'.parent <- p ;
+      ( match p with
+      | Some p ->
+          p.t <-
+            ( match p.t with
+            | `Attr (a, _) -> `Attr (a, n')
+            | `Join (d, a, b) when n == a -> `Join (d, n', b)
+            | `Join (d, a, b) when n == b -> `Join (d, a, n')
+            | _ -> assert false )
+      | None -> () ) ;
+      n'
 
+    let remove_attr (n : node) : node =
+      match n.t with
+      | `Attr (_, n') ->
+          ( match n.parent with
+          | Some p ->
+              p.t <-
+                ( match p.t with
+                | `Attr (a, _) -> `Attr (a, n')
+                | `Join (d, a, b) when n == a -> `Join (d, n', b)
+                | `Join (d, a, b) when n == b -> `Join (d, a, n')
+                | _ -> assert false )
+          | None -> () ) ;
+          n'
+      | _ -> assert false
 
+    let sub (n : node) : node =
+      match n.t with
+      | `Atom _ -> n
+      | `Attr (_, n) -> n
+      | `Join (_, a, _) -> a
 
     let join_ d (a : node) (b : node) =
-      let rec parent =
+      set_parent_on_children {parent= a.parent; t= `Join (d, a, b)}
-        { parent
-        ; child=
-            `Region
-              (d, Region.append (Region.append (Region.create ()) a) b)
-        } in
-      set_parent_on_children parent ;
-      parent
 
+    let empty_join d = node (`Join (d, empty_node, empty_node))
     let join_x = join_ `X
     let join_y = join_ `Y
     let join_z = join_ `Z
-    let pack_x : node Lwd_utils.monoid = (empty_region `X, join_x)
+    let pack_x : node Lwd_utils.monoid = (empty_join `X, join_x)
-    let pack_y : node Lwd_utils.monoid = (empty_region `Y, join_y)
+    let pack_y : node Lwd_utils.monoid = (empty_join `Y, join_y)
-    let pack_z : node Lwd_utils.monoid = (empty_region `Z, join_z)
+    let pack_z : node Lwd_utils.monoid = (empty_join `Z, join_z)
     let ( ^^ ) = join_x
     let ( ^/^ ) = join_y
 
+    let pp_uchar ppf v =
+      if Uchar.is_char v then Fmt.pf ppf "'%c'" (Uchar.to_char v)
+      else Fmt.Dump.uchar ppf v
+
+    let pp_atom ppf v =
+      let open Fmt in
+      ( match v with
+      | `Image _ -> any "`Image"
+      | `Uchar c -> any "`Uchar " ++ const pp_uchar c
+      | `Boundary b -> (
+          any "`Boundary "
+          ++
+          match b with
+          | `Word -> any "`Word"
+          | `Line -> any "`Line"
+          | `Sentance -> any "`Sentance" )
+      | `Hint h ->
+          any "`Hint "
+          ++ any (match h with `Line -> "`Line" | `Other -> "`Other")
+      | `Empty -> any "`Empty" )
+        ppf ()
+
+    let tess v = F.epr "%a" pp_atom v
+
+    let pp_attr ppf v =
+      let open Fmt in
+      (any
+         ( match v with
+         | `Style _ -> "`Style ..."
+         | `Pad _ -> "`Pad ..."
+         | `Shift _ -> "`Shift ..."
+         | `Cursor -> "`Cursor"
+         | `Handler _ -> "`Handler ..." ) )
+        ppf ()
+
+    let pp_dir ppf v =
+      F.pf ppf "%s"
+        (match v with `X -> "`X" | `Y -> "`Y" | `Z -> "`Z")
+
+    let rec pp_node ppf v =
+      let open Fmt in
+      pf ppf "@[<hov>%a@]" pp_t v.t
+
+    and pp_t ppf v =
+      let open Fmt in
+      match v with
+      | `Join (d, a, b) ->
+          pf ppf "`Join %a"
+            (parens
+               ( const pp_dir d ++ comma ++ const pp_node a ++ comma
+               ++ const pp_node b ) )
+            ()
+      | `Attr (a, n) ->
+          pf ppf "`Attr %a"
+            (parens (const pp_attr a ++ comma ++ const pp_node n))
+            ()
+      | `Atom x -> pf ppf "`Atom %a" pp_atom x
+
+    (* there's no difference between a node element and a node list what, tho an element is kinda like a node.t,
+       so i guess we'll use that to kinda emulate append (vs. concat which is what join is)
+       ugh maybe using types to build this double-linked binary-tree data structure is not a good idea.
+       I'm STONED, so i'm not making sense, but i'm gonna carry on anyway and see what happens.
+       So i think what is really happening is that i'm defining the `list` for this node type that allows `append`.
+       The main problem with this thought is that you can't do anything but append with the datastructure.
+    *)
+    let new_append () = empty_node
+
+    let append (d : dir) (l : unit -> node) (n : node) : unit -> node
+        =
+     fun () ->
+      set_parent_on_children {parent= None; t= `Join (d, l (), n)}
+
     module Text = struct
-      (* let to_buffer t =
+      let rec _of_string (la : unit -> node) (str : string) :
-            let b = Buffer.create 0 in
+          unit -> node =
-            let enc' = Uutf.encoder `UTF_8 (`Buffer b) in
-            let rec enc c =
-              match Uutf.encode enc' c with
-              | `Partial -> enc `Await
-              | `Ok -> () in
-            let rec aux c =
-              match Trope.seek_after t.t c with
-              | Some (c, Uchar char) ->
-                  enc (`Uchar char) ;
-                  aux c
-              | Some (c, _) -> aux c
-              | None -> () in
-            aux line.left ; b
-
-          let to_string t =
-            Bytes.to_string (Buffer.to_bytes (to_buffer t)) *)
-
-      let rec _of_string ~rl (str : string) : node =
-        let rec parent = {parent; child= `Region (`Y, rl)} in
         let uudec = Uutf.decoder (`String str) in
-        let rec dec (rl : node Region.t) : 'a * node Region.t =
+        let rec dec (lx : unit -> node) : 'a * (unit -> node) =
           match Uutf.decode uudec with
-          | `Malformed b ->
+          | `Malformed b -> dec (_of_string lx (String.escaped b))
-              dec
+          | (`Await | `Uchar _ | `End) as x -> (x, lx) in
-                (Region.append rl
-                   (_of_string ~rl:(Region.create ())
-                      (String.escaped b) ) )
-          | (`Await | `Uchar _ | `End) as x -> (x, rl) in
         let uuline = Uuseg.create `Line_break in
-        let rec line (rl : node Region.t) =
+        let rec new_line la' : unit -> node =
-          let rec char (x, t) (line : node Region.t) =
+          let rec char (x, lx) (ly : unit -> node) =
             match Uuseg.add uuline x with
-            | `End as x -> (line, x)
+            | `End as x -> (ly, x)
-            | `Boundary as x when Uuseg.mandatory uuline -> (line, x)
+            | `Boundary as x when Uuseg.mandatory uuline -> (ly, x)
-            | `Await -> char (dec t) line
+            | `Await -> char (dec lx) ly
             | `Boundary ->
                 char
-                  (`Await, t)
+                  (`Await, append `X lx (node (`Atom (`Hint `Line))))
-                  (Region.append line
+                  ly
-                     {parent; child= `Atom (`Boundary `Hint)} )
             | `Uchar c ->
                 char
-                  (`Await, t)
+                  (`Await, append `X lx (node (`Atom (`Uchar c))))
-                  (Region.append line
+                  ly in
-                     {parent; child= `Atom (`Uchar c)} ) in
+          match char (`Await, la') la' with
-          match
-            char
-              (`Await, rl)
-              (Region.append (Region.create ())
-                 {parent; child= `Atom (`Boundary `Line)} )
-          with
           | l, `Boundary ->
-              line (Region.append rl {parent; child= `Region (`X, l)})
+              new_line
-          | l, `End ->
+                (append `Y la'
-              Region.append rl {parent; child= `Region (`X, l)} in
+                   ((append `X l (node (`Atom (`Boundary `Line)))) ()) )
-        parent.child <- `Region (`Y, line rl) ;
+          | l, `End -> l in
-        parent
+        new_line la
 
-      let of_string ?(rl = Region.create ()) (str : string) =
+      let of_string str = _of_string new_append str ()
-        _of_string ~rl str
 
-      let segment ?(boundary = `Word) ?(label = `Word) (node : node) :
+      (* let segment ?(boundary = `Word) ?(label = `Word) (node : node) :
-          node =
+             node =
-        let uuseg = Uuseg.create boundary in
+           let uuseg = Uuseg.create boundary in
-        traverse_regions
+           traverse_regions
-          ~node:(fun node -> node)
+             ~node:(fun node -> node)
-          ~region:(fun ~parent (r, c) ~child ->
+             ~region:(fun ~parent (r, c) ~child ->
-            match child.child with
+               match child.child with
-            | `Atom (`Uchar uc) ->
+               | `Atom (`Uchar uc) ->
-                let rec seg ((t : node Trope.t), (c : Region.cursor))
+                   let rec seg ((t : node Trope.t), (c : Region.cursor))
-                    e' =
+                       e' =
-                  match Uuseg.add uuseg e' with
+                     match Uuseg.add uuseg e' with
-                  | `Boundary ->
+                     | `Boundary ->
-                      seg
+                         seg
-                        ( Trope.put_right t c
+                           ( Trope.put_right t c
-                            {parent; child= `Atom (`Boundary label)}
+                               {parent; child= `Atom (`Boundary label)}
-                        , Trope.cursor_after c )
+                           , Trope.cursor_after c )
-                        `Await
+                           `Await
-                  | `End | `Await -> (t, c)
+                     | `End | `Await -> (t, c)
-                  | `Uchar ch ->
+                     | `Uchar ch ->
-                      seg
+                         seg
-                        ( Trope.put_right t c
+                           ( Trope.put_right t c
-                            {parent; child= `Atom (`Uchar ch)}
+                               {parent; child= `Atom (`Uchar ch)}
-                        , c )
+                           , c )
-                        `Await in
+                           `Await in
-                let r', c' = seg (r.t, c) (`Uchar uc) in
+                   let r', c' = seg (r.t, c) (`Uchar uc) in
-                ({r with t= r'}, c')
+                   ({r with t= r'}, c')
-            | _ -> (r, c) )
+               | _ -> (r, c) )
-          node
+             node
 
-      let words node : node =
+          let words node : node =
-        segment ~boundary:`Word ~label:`Word node
+           segment ~boundary:`Word ~label:`Word node
 
-      let sentances node : node =
+         let sentances node : node =
-        segment ~boundary:`Sentence ~label:`Sentance node
+           segment ~boundary:`Sentence ~label:`Sentance node
 
-      let text str : node = of_string str |> sentances |> words
+         let text str : node = insert_string str |> sentances |> words *)
     end
 
-    let text = Text.text
+    let text = Text.of_string
 
     module Draw = struct
       type d = [`X | `Y | `Z]
 
+      let cursor ((i, v) : image) =
+        ( I.stack
+            (I.paint (Paint.color Color.red)
+               ( I.stroke_path (Outline.make ())
+               @@ fun t ->
+               P.rect t ~x:0. ~y:0. ~w:(V2.x v) ~h:(V2.y v) ) )
+            i
+        , v )
+
       let vcat d a b =
         match d with
         | `X -> V2.v (V2.x a +. V2.x b) (Float.fmax (V2.y a) (V2.y b))
@@ -1661,24 +1563,25 @@ module Panel = struct
         | `Image i -> i
         | `Uchar uc -> uchar style uc
         | `Boundary _ -> empty_image
+        | `Hint _ -> empty_image
+        | `Empty -> empty_image
 
       and attr ?(style = Style.empty) (attr, node) : image =
         match attr with
         | `Style s -> pane ~style:(Style.merge s style) node
         | `Pad p -> pad p (pane ~style node)
         | `Shift s -> shift s (pane ~style node)
+        | `Cursor -> cursor (pane ~style node)
         | _ -> pane ~style node
 
-      and region ?(style = Style.empty) (dir, region) : image =
+      and join ?(style = Style.empty) (d, a, b) : image =
-        Region.fold ~t:region
+        cat d (pane ~style a) (pane ~style b)
-          ~f:(fun _ n i -> cat dir i (pane ~style n))
-          empty_image
 
       and pane ?(style = Style.empty) (node : node) : image =
-        match node.child with
+        match node.t with
         | `Atom a -> atom ~style a
         | `Attr a -> attr ~style a
-        | `Region a -> region ~style a
+        | `Join a -> join ~style a
     end
 
     module Action = struct
@@ -1695,6 +1598,8 @@ module Panel = struct
         [ `Move of segment
         | `Yank of segment
         | `Kill of segment
+        | `Ascend
+        | `Descend
         | `Custom of string * (node -> t Key.Bind.t -> unit Lwt.t) ]
 
       type dir =
@@ -1708,48 +1613,47 @@ module Panel = struct
         | `Enter
         | `In
         | `Out ]
-
-      let handle (action : t) (node : node) : node option =
-        match action with
-        | `Move (`Beginning `Char) -> Some node
-        | `Move (`Beginning `Word) ->
-            Some (search_backward node (`Boundary `Word))
-        | `Move _ -> None
-        | `Yank _s -> None
-        | `Kill _s -> None
-        | `Custom _s -> None
     end
 
-    type event_status =
+    let rec search_forward (n : node) (f : node -> 'a option) :
-      [ `Handled
+        'a option =
-      | (*`Focus of [`Next | `Prev | `Up | `Down] | *)
+      match f n with
-        `Event of
+      | None -> (
-        Event.t ]
+        match n.t with
+        | `Atom _ -> None
+        | `Attr (_, n) -> search_forward n f
+        | `Join (_, a, b) -> (
+          match search_forward a f with
+          | Some n' -> Some n'
+          | None -> search_forward b f ) )
+      | Some a -> Some a
 
-    let rec handle_event (node : node) (ev : Event.t) :
+    let rec search_backward (n : node) (f : node -> 'a option) :
-        event_status Lwt.t =
+        'a option =
-      match node.child with
+      match f n with
-      | `Atom _ -> Lwt.return (`Event ev)
+      | None -> (
-      | `Attr (`Focus (f, _), n) -> (
+        match n.parent with
-          f n ev
+        | None -> None (* at root and didn't find anything *)
-          >>= function
+        | Some n -> search_backward n f )
-          | None -> Lwt.return `Handled | Some e -> handle_event n e )
+      | Some n' -> Some n'
-      | `Attr (`Handle f, n) -> (
+
-          f n ev
+    let perform_action (a : Action.t) (c : node) : node =
-          >>= function
+      match a with
-          | None -> Lwt.return `Handled | Some e -> handle_event n e )
+      | `Move (`Beginning `Char) -> c
-      | `Attr (_, n) -> handle_event n ev
+      | `Move (`Beginning `Word) ->
-      | `Region (_, r) ->
+          Option.value ~default:c
-          Region.fold_lwt_opt ~t:r
+            (search_backward c (fun n ->
-            ~f:(fun _ n (es : event_status) ->
+                 match n.t with
-              match es with
+                 | `Atom (`Boundary `Word) -> Some n
-              | `Event e -> (
+                 | _ -> None ) )
-                  handle_event n e
+      | `Move _ -> c
-                  >>= function
+      | `Yank _s -> c
-                  | `Handled -> Lwt.return None
+      | `Kill _s -> c
-                  | x -> Lwt.return (Some x) )
+      | `Descend -> sub c
-              | `Handled -> Lwt.return None )
+      | `Ascend -> ( match c.parent with Some n -> n | None -> c )
-            (`Event ev)
+      | `Custom _s -> c
+
+    type event_status = [`Handled | `Event of Event.t]
 
     let textedit_bindings =
       let open Key.Bind in
@@ -1774,33 +1678,64 @@ module Panel = struct
       |> add
            [([Ctrl], C 'x'); ([], U `Backspace)]
            [`Kill (`Back `Phrase)]
+      |> add [([Ctrl], C 'q')] [`Ascend]
+      |> add [([Ctrl], C 'e')] [`Descend]
 
-    let textedit_handler ?(bindings = textedit_bindings) n =
+    let textedit_handler ?(bindings = textedit_bindings) (n : node) =
       let bind = Key.Bind.init bindings in
-      let fq = Stack.create () in
+      let n' = insert_attr `Cursor n in
-      Stack.push (`Down, node) fq ;
+      let c = ref n in
-      focus
+      Format.(
-        ( (fun (_ : node) (e : Event.t) : Event.t option Lwt.t ->
+        F.epr
-            match Key.Bind.resolve_events bind [e] with
+          "@[<hv> F.stderr margin: %d, max_indent: %d, max_boxes: %d \
-            | x :: _ -> Action.handle x
+           @]@."
-            | [] -> Lwt.return_some e )
+          (pp_get_margin F.stderr ())
-        , Focus.make () )
+          (pp_get_max_indent F.stderr ())
-        n
+          (pp_get_max_boxes F.stderr ())) ;
+      F.epr "@[<v>%a@]@." pp_node n' ;
+      node
+        (`Attr
+          ( `Handler
+              (fun (_ : node) (e : Event.t) : Event.t option Lwt.t ->
+                match Key.Bind.resolve_events bind [e] with
+                | x :: _ ->
+                    c :=
+                      insert_attr `Cursor
+                        (perform_action x (remove_attr !c)) ;
+                    F.epr "%a@." pp_node !c ;
+                    Lwt.return_none
+                | [] -> Lwt.return_some e )
+          , n ) )
+
+    let handler_of_node (n : node) : handler option =
+      search_forward n (fun n ->
+          match n.t with `Attr (`Handler f, _) -> Some f | _ -> None )
+
+    let handle_event (n : node) (ev : Event.t) : event_status Lwt.t =
+      match handler_of_node n with
+      | Some f -> (
+          f n ev
+          >>= function
+          | Some ev -> Lwt.return (`Event ev)
+          | None -> Lwt.return `Handled )
+      | None -> Lwt.return (`Event ev)
 
     let panel (t : node Lwd.t) : (Event.events -> image Lwt.t) Lwt.t =
       let rq = Lwd.make_release_queue () in
       let root = Lwd.observe t in
       Lwt.return (fun ev ->
           let r = Lwd.sample rq root in
+          (* F.epr "Draw.pane: %a@." pp_ui r ; *)
           Lwt_list.iter_s
             (fun e ->
               handle_event r e
               >>= fun h ->
               ( match h with
-              | `Handled -> ()
+              | `Handled -> F.epr "Handled %s@." (Event.to_string e)
-              | `Event e ->
+              | `Event _e ->
-                  F.epr "handle_event: Unhandled event: %s@."
+                  (* F.epr "Unhandled event: %s@."
-                    (Event.to_string e) ) ;
+                     (Event.to_string _e)*)
+                  () ) ;
               Lwt.return_unit )
             ev
           >|= fun () -> Draw.pane r )
@@ -1810,14 +1745,16 @@ module Panel = struct
         (Lwd.pure
            (textedit_handler
               (style Style.dark
-                 (join_y
+                 (*(join_y
                     (join_y
-                       (Text.of_string
+                       (Text.insert_string empty_node
-                          "-- welcome to the land of idiots ---" )
+                          "-- welcome to my land of idiocy ---" )
                        (join_x
-                          (Text.of_string "hello bitch")
+                          (Text.insert_string empty_node "hello bitch")
-                          (Text.of_string "!\n sup dude") ) )
+                          (Text.insert_string empty_node
-                    (Text.of_string "test 1 2 3 4 5 6") ) ) ) )
+                             "!\n sup daddy" ) ) )*)
+                 (Text.of_string "test 1 2 3") ) ) )
+    (* ) *)
   end
 end
 

opam-switch

@@ -0,0 +1,361 @@
+opam-version: "2.0"
+compiler: ["ocaml-system.4.13.1"]
+roots: [
+  "bogue.20210917"
+  "findlib_top.v0.11.0"
+  "glfw-ocaml.3.3.1-1"
+  "huffman.0.1.2"
+  "inuit.0.4.1"
+  "irc-client.0.7.0"
+  "irc-client-lwt.0.7.0"
+  "irc-client-tls.0.7.0"
+  "irc-client-unix.0.7.0"
+  "irmin.2.9.0"
+  "irmin-unix.2.9.0"
+  "lambda-term.3.1.0"
+  "lwd.0.1"
+  "lwt_ppx.2.0.3"
+  "merlin.4.4-413"
+  "note.0.0.1"
+  "nottui.0.1"
+  "nottui-lwt.0.1"
+  "nottui-pretty.0.1"
+  "ocaml-manual.4.13.0"
+  "ocaml-system.4.13.1"
+  "ocamlformat.0.20.1"
+  "odig.0.0.7"
+  "odoc.2.0.2"
+  "pp.1.1.2"
+  "pprint.20211129"
+  "tgls.0.8.5"
+  "tsdl.0.9.8"
+  "user-setup.0.7"
+  "wall.0.4.1"
+  "zed.3.1.0"
+]
+installed: [
+  "angstrom.0.15.0"
+  "arp.3.0.0"
+  "asn1-combinators.0.2.6"
+  "astring.0.8.5"
+  "awa.0.0.4"
+  "awa-mirage.0.0.4"
+  "b0.0.0.3"
+  "base.v0.14.2"
+  "base-bigarray.base"
+  "base-bytes.base"
+  "base-threads.base"
+  "base-unix.base"
+  "base64.3.5.0"
+  "bheap.2.0.0"
+  "bigarray-compat.1.0.0"
+  "bigstringaf.0.8.0"
+  "biniou.1.2.1"
+  "bogue.20210917"
+  "bos.0.2.0"
+  "ca-certs.0.2.2"
+  "ca-certs-nss.3.71"
+  "camomile.1.0.2"
+  "carton.0.4.3"
+  "carton-git.0.4.3"
+  "carton-lwt.0.4.3"
+  "cf.0.4"
+  "cf-lwt.0.4"
+  "charInfo_width.1.1.0"
+  "checkseum.0.3.2"
+  "cmdliner.1.0.4"
+  "cohttp.4.0.0"
+  "cohttp-lwt.4.0.0"
+  "cohttp-lwt-unix.4.0.0"
+  "conduit.4.0.2"
+  "conduit-lwt.4.0.2"
+  "conduit-lwt-unix.4.0.2"
+  "conf-cairo.1"
+  "conf-gles2.1"
+  "conf-glfw3.2"
+  "conf-gmp.3"
+  "conf-gmp-powm-sec.3"
+  "conf-libffi.2.0.0"
+  "conf-libX11.1"
+  "conf-m4.1"
+  "conf-pkg-config.2"
+  "conf-sdl2.1"
+  "conf-sdl2-image.1"
+  "conf-sdl2-ttf.1"
+  "cppo.1.6.8"
+  "crunch.3.2.0"
+  "csexp.1.5.1"
+  "cstruct.6.0.1"
+  "cstruct-lwt.6.0.1"
+  "cstruct-sexp.6.0.1"
+  "cstruct-unix.6.0.1"
+  "ctypes.0.20.0"
+  "ctypes-foreign.0.18.0"
+  "decompress.1.4.2"
+  "digestif.1.1.0"
+  "dispatch.0.5.0"
+  "domain-name.0.3.1"
+  "dot-merlin-reader.4.1"
+  "duff.0.4"
+  "dune.2.9.1"
+  "dune-build-info.2.9.1"
+  "dune-configurator.2.9.1"
+  "duration.0.2.0"
+  "easy-format.1.3.2"
+  "either.1.0.0"
+  "emile.1.1"
+  "encore.0.8"
+  "eqaf.0.8"
+  "ethernet.3.0.0"
+  "findlib_top.v0.11.0"
+  "fix.20211125"
+  "fmt.0.9.0"
+  "fpath.0.7.3"
+  "fsevents.0.3.0"
+  "fsevents-lwt.0.3.0"
+  "gg.0.9.3"
+  "git.3.6.0"
+  "git-cohttp.3.6.0"
+  "git-cohttp-unix.3.6.0"
+  "git-unix.3.6.0"
+  "glfw-ocaml.3.3.1-1"
+  "gmap.0.3.0"
+  "graphql.0.13.0"
+  "graphql-cohttp.0.13.0"
+  "graphql-lwt.0.13.0"
+  "graphql_parser.0.13.0"
+  "graphv_core.0.1.1"
+  "graphv_core_lib.0.1.1"
+  "graphv_font.0.1.1"
+  "graphv_font_js.0.1.1"
+  "graphv_gles2.0.1.1"
+  "graphv_gles2_native_impl.0.1.1"
+  "graphv_webgl.0.1.1"
+  "graphv_webgl_impl.0.1.1"
+  "grenier.0.13"
+  "hex.1.4.0"
+  "hkdf.1.0.4"
+  "huffman.0.1.2"
+  "hxd.0.3.1"
+  "index.1.5.0"
+  "inotify.2.3"
+  "integers.0.5.1"
+  "inuit.0.4.1"
+  "ipaddr.5.2.0"
+  "ipaddr-sexp.5.2.0"
+  "irc-client.0.7.0"
+  "irc-client-lwt.0.7.0"
+  "irc-client-tls.0.7.0"
+  "irc-client-unix.0.7.0"
+  "irmin.2.9.0"
+  "irmin-fs.2.9.0"
+  "irmin-git.2.9.0"
+  "irmin-graphql.2.9.0"
+  "irmin-http.2.9.0"
+  "irmin-layers.2.9.0"
+  "irmin-pack.2.9.0"
+  "irmin-unix.2.9.0"
+  "irmin-watcher.0.5.0"
+  "jbuilder.1.0+beta20.2"
+  "js_of_ocaml.3.11.0"
+  "js_of_ocaml-compiler.3.11.0"
+  "js_of_ocaml-ppx.3.11.0"
+  "jsonm.1.0.1"
+  "ke.0.4"
+  "lambda-term.3.1.0"
+  "logs.0.7.0"
+  "lru.0.3.0"
+  "lwd.0.1"
+  "lwt.5.5.0"
+  "lwt-dllist.1.0.1"
+  "lwt_log.1.1.1"
+  "lwt_ppx.2.0.3"
+  "lwt_react.1.1.5"
+  "macaddr.5.2.0"
+  "macaddr-cstruct.5.2.0"
+  "magic-mime.1.2.0"
+  "menhir.20211128"
+  "menhirLib.20211128"
+  "menhirSdk.20211128"
+  "merlin.4.4-413"
+  "metrics.0.3.0"
+  "mew.0.1.0"
+  "mew_vi.0.5.0"
+  "mimic.0.0.4"
+  "mirage-clock.4.0.0"
+  "mirage-clock-unix.4.0.0"
+  "mirage-crypto.0.10.5"
+  "mirage-crypto-ec.0.10.5"
+  "mirage-crypto-pk.0.10.5"
+  "mirage-crypto-rng.0.10.5"
+  "mirage-device.2.0.0"
+  "mirage-flow.3.0.0"
+  "mirage-kv.4.0.0"
+  "mirage-net.4.0.0"
+  "mirage-no-solo5.1"
+  "mirage-no-xen.1"
+  "mirage-profile.0.9.1"
+  "mirage-protocols.8.0.0"
+  "mirage-random.3.0.0"
+  "mirage-stack.4.0.0"
+  "mirage-time.3.0.0"
+  "mmap.1.1.0"
+  "mtime.1.3.0"
+  "note.0.0.1"
+  "nottui.0.1"
+  "nottui-lwt.0.1"
+  "nottui-pretty.0.1"
+  "notty.0.2.2"
+  "num.1.4"
+  "oasis.0.4.11"
+  "ocaml.4.13.1"
+  "ocaml-compiler-libs.v0.12.4"
+  "ocaml-config.2"
+  "ocaml-manual.4.13.0"
+  "ocaml-migrate-parsetree.2.3.0"
+  "ocaml-options-vanilla.1"
+  "ocaml-syntax-shims.1.0.0"
+  "ocaml-system.4.13.1"
+  "ocaml-version.3.4.0"
+  "ocamlbuild.0.14.0"
+  "ocamlfind.1.9.1"
+  "ocamlformat.0.20.1"
+  "ocamlgraph.2.0.0"
+  "ocamlify.0.0.1"
+  "ocamlmod.0.0.9"
+  "ocb-stubblr.0.1.1-1"
+  "ocp-indent.1.8.1"
+  "ocplib-endian.1.2"
+  "odig.0.0.7"
+  "odoc.2.0.2"
+  "odoc-parser.1.0.0"
+  "optint.0.1.0"
+  "parsexp.v0.14.1"
+  "pbkdf.1.2.0"
+  "pecu.0.6"
+  "pp.1.1.2"
+  "pprint.20211129"
+  "ppx_cstruct.6.0.1"
+  "ppx_derivers.1.2.1"
+  "ppx_deriving.5.2.1"
+  "ppx_irmin.2.9.0"
+  "ppx_repr.0.5.0"
+  "ppx_sexp_conv.v0.14.3"
+  "ppxlib.0.24.0"
+  "progress.0.2.1"
+  "psq.0.2.0"
+  "ptime.0.8.6"
+  "randomconv.0.1.3"
+  "re.1.10.3"
+  "react.1.2.1"
+  "repr.0.5.0"
+  "result.1.5"
+  "rresult.0.6.0"
+  "semaphore-compat.1.0.1"
+  "seq.base"
+  "sexplib.v0.14.0"
+  "sexplib0.v0.14.0"
+  "stb_image.0.5"
+  "stb_truetype.0.6"
+  "stdio.v0.14.0"
+  "stdlib-shims.0.3.0"
+  "stringext.1.6.0"
+  "tcpip.7.0.0"
+  "terminal.0.2.1"
+  "terminal_size.0.1.4"
+  "tgls.0.8.5"
+  "tls.0.14.1"
+  "tls-mirage.0.14.1"
+  "topkg.1.0.4"
+  "trie.1.0.0"
+  "tsdl.0.9.8"
+  "tsdl-image.0.3.2"
+  "tsdl-ttf.0.3.2"
+  "tyxml.4.5.0"
+  "uchar.0.0.2"
+  "uri.4.2.0"
+  "uri-sexp.4.2.0"
+  "user-setup.0.7"
+  "uucp.14.0.0"
+  "uuseg.14.0.0"
+  "uutf.1.0.2"
+  "vector.1.0.0"
+  "wall.0.4.1"
+  "webmachine.0.7.0"
+  "x509.0.14.1"
+  "yaml.3.0.0"
+  "yojson.1.7.0"
+  "zarith.1.12"
+  "zed.3.1.0"
+]
+pinned: ["lwd.0.1" "nottui.0.1"]
+package "lwd" {
+  opam-version: "2.0"
+  version: "0.1"
+  synopsis: "Lightweight reactive documents"
+  maintainer: "fred@tarides.com"
+  authors: "Frédéric Bour"
+  license: "MIT"
+  homepage: "https://github.com/let-def/lwd"
+  doc: "https://let-def.github.io/lwd/doc"
+  bug-reports: "https://github.com/let-def/lwd/issues"
+  depends: [
+    "dune" {>= "2.0"}
+    "seq"
+    "ocaml" {>= "4.03"}
+    "qtest" {with-test}
+    "qcheck" {with-test}
+  ]
+  build: [
+    ["dune" "subst"] {pinned}
+    [
+      "dune"
+      "build"
+      "-p"
+      name
+      "-j"
+      jobs
+      "@install"
+      "@runtest" {with-test}
+      "@doc" {with-doc}
+    ]
+  ]
+  dev-repo: "git+https://github.com/let-def/lwd.git"
+  url {
+    src: "git+file:///home/cqc/p/console/ref/lwd#master"
+  }
+}
+package "nottui" {
+  opam-version: "2.0"
+  version: "0.1"
+  synopsis: "UI toolkit for the terminal built on top of Notty and Lwd"
+  maintainer: "fred@tarides.com"
+  authors: "Frédéric Bour"
+  license: "MIT"
+  homepage: "https://github.com/let-def/lwd"
+  doc: "https://let-def.github.io/lwd/doc"
+  bug-reports: "https://github.com/let-def/lwd/issues"
+  depends: [
+    "dune" {>= "2.0"}
+    "lwd"
+    "notty"
+  ]
+  build: [
+    ["dune" "subst"] {pinned}
+    [
+      "dune"
+      "build"
+      "-p"
+      name
+      "-j"
+      jobs
+      "@install"
+      "@runtest" {with-test}
+      "@doc" {with-doc}
+    ]
+  ]
+  dev-repo: "git+https://github.com/let-def/lwd.git"
+  url {
+    src: "git+file:///home/cqc/p/console/ref/lwd#master"
+  }
+}