store editor tree navigation works????

irc.ml

@@ -5,6 +5,10 @@ we need to design this somehow before implementing it
 really the graphical drawing / window management funcitons i think at this point.
 
 
+features:
+ - message drafts? more like, if you send too many messages to someone all at once it will hold them so you can respond later and not flood people.......
+   - i mean really what you want is an editable stream, so you can stage messages for later
+   - because i mean, if this is a bicycle, and you can make it however you want, you can just fuck with the conversation thread with computer assistance instaed of just relying on your memory.
 
 *)
 
@@ -34,7 +38,8 @@ let callback connection result =
       >>= fun () ->
       Lwt_io.flush Lwt_io.stdout
       >>= fun () ->
-      C.send_privmsg ~connection ~target:"cqc" ~message:("ack: " ^ data)
+      C.send_privmsg ~connection ~target:"cqc"
+        ~message:("ack: " ^ data)
   | Result.Ok msg ->
       Lwt_io.printf "Got message: %s\n" (M.to_string msg)
       >>= fun () -> Lwt_io.flush Lwt_io.stdout
@@ -44,15 +49,16 @@ let lwt_main () =
   C.reconnect_loop ~after:30
     ~connect:(fun () ->
       Lwt_io.printl "Connecting..."
-      >>= fun () -> C.connect_by_name ~server:!host ~port:!port ~nick:!nick ()
+      >>= fun () ->
-      )
+      C.connect_by_name ~server:!host ~port:!port ~nick:!nick () )
     ~f:(fun connection ->
       Lwt_io.printl "Connected"
       >>= fun () ->
       Lwt_io.printl "send join msg"
       >>= fun () ->
       C.send_join ~connection ~channel:!channel
-      >>= fun () -> C.send_privmsg ~connection ~target:!channel ~message )
+      >>= fun () ->
+      C.send_privmsg ~connection ~target:!channel ~message )
     ~callback ()
 
 let _ =

main.ml

@@ -27,7 +27,7 @@ module Input = struct
 
   (** Type of key code. *)
   type code =
-    | Char of UChar.t  (** A unicode character. *)
+    | UChar of UChar.t  (** A unicode character. *)
     | Enter
     | Escape
     | Tab
@@ -57,6 +57,8 @@ module Input = struct
     | Unknown
     | None
 
+  type key = Char of char | Code of code
+
   module KeymodSet = struct
     type t = Shift | Ctrl | Meta | Fn
 
@@ -67,10 +69,10 @@ module Input = struct
 
   let modset = Keymod.of_list
 
-  type key = {mods: Keymod.t; code: code}
+  type keystate = {mods: Keymod.t; code: code}
 
   module Key = struct
-    type t = key
+    type t = keystate
 
     let compare = compare
   end
@@ -88,14 +90,18 @@ module Input = struct
     type state =
       { mutable bindings: t
       ; mutable state: result
-      ; mutable last_keyseq: key list
+      ; mutable last_keyseq: keystate list
       ; mutable last_actions: action list }
 
     let add events action bindings =
       let events =
         List.map
           (fun (m, k) ->
-            {mods= Keymod.of_list m; code= Char (UChar.of_char k)} )
+            { mods= Keymod.of_list m
+            ; code=
+                ( match k with
+                | Char c -> UChar (UChar.of_char c)
+                | Code c -> c ) } )
           events in
       S.add events action bindings
 
@@ -111,7 +117,7 @@ module Input = struct
 
   (* stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *)
   let string_of_code = function
-    | Char ch -> Printf.sprintf "Char 0x%02x" (UChar.code ch)
+    | UChar ch -> Printf.sprintf "Char 0x%02x" (UChar.code ch)
     | Enter -> "Enter"
     | Escape -> "Escape"
     | Tab -> "Tab"
@@ -157,7 +163,7 @@ module Input = struct
     if Keymod.mem Shift key.mods then Buffer.add_string buffer "S-" ;
     if Keymod.mem Fn key.mods then Buffer.add_string buffer "Fn-" ;
     ( match key.code with
-    | Char ch ->
+    | UChar ch ->
         let code = UChar.code ch in
         if code <= 255 then
           match Char.chr code with
@@ -191,8 +197,8 @@ module Event = struct
   type mouse = int * int
 
   type t =
-    [ `Key_down of Input.key
+    [ `Key_down of Input.keystate
-    | `Key_up of Input.key
+    | `Key_up of Input.keystate
     | `Text_editing of string
     | `Text_input of string
     | `Mouse of mouse
@@ -270,7 +276,7 @@ module Event = struct
            |'&' | '$' | '*' | '%' | '!' | '?' | ',' | ';' | ':'
            |'/' | '\\' | '.' | '@' | '=' | '+' | '-' | ' ' | '"'
            |'\'' | '>' | '<' | '^' | '`' | '|' ->
-              Char (UChar.of_int k)
+              UChar (UChar.of_int k)
           | _ -> None ) in
       let mods =
         List.filter_map
@@ -340,7 +346,7 @@ module Event = struct
       | `Window_event -> `Unknown "`Window_event "
       | `Display_event -> `Unknown "`Display_event "
       | `Sensor_update -> `Unknown "`Sensor_update " in
-    (*    F.epr "event_of_sdlevent: %s@." (to_string r) ;*)
+    (*F.epr "event_of_sdlevent: %s@." (to_string r) ;*)
     r
 
   let key_up : Sdl.keycode = 0x40000052
@@ -351,27 +357,30 @@ module Event = struct
 
   let actions_of_events (state : Input.Bind.state) (events : events) =
     let open Input.Bind in
-    List.iter
+    List.flatten
-      (function
+      (List.filter_map
-        | `Key_down (k : Input.key) ->
+         (fun e ->
-            ( match state.state with
+           (*F.epr "action_of_events: %s@." (to_string e) ;*)
-            | Continue _ -> ()
+           match e with
-            | _ -> state.last_keyseq <- [] ) ;
+           | `Key_down (k : Input.keystate) -> (
-            state.state <-
+               ( match state.state with
-              resolve k
+               | Continue _ -> ()
-                (get_resolver state.state
+               | _ -> state.last_keyseq <- [] ) ;
-                   (default_resolver state.bindings) ) ;
+               state.state <-
-            state.last_keyseq <- k :: state.last_keyseq
+                 resolve k
-        | _ -> () )
+                   (get_resolver state.state
-      events ;
+                      (default_resolver state.bindings) ) ;
-    match state.state with
+               state.last_keyseq <- k :: state.last_keyseq ;
-    | Accepted a ->
+               match state.state with
-        state.last_actions <- a ;
+               | Accepted a ->
-        a
+                   state.last_actions <- a ;
-    | Rejected ->
+                   Some a
-        state.last_actions <- [] ;
+               | Rejected ->
-        []
+                   state.last_actions <- [] ;
-    | _ -> []
+                   None
+               | _ -> None )
+           | _ -> None )
+         events )
 end
 
 module Display = struct
@@ -787,89 +796,51 @@ module Panel = struct
     , ( Box2.of_pts (Box2.o s.box) (P2.v !max_x (Box2.maxy !box))
       , !node ) )
 
-  let default_bindings =
+  let textedit_bindings =
     let open Input.Bind in
-    let open CamomileLibrary in
+    add [([], Code Left)] [Zed Prev_char]
-    let open Zed_edit in
+    @@ add [([], Code Right)] [Zed Next_char]
-    let m = Input.Keymod.of_list in
+    @@ add [([], Code Up)] [Zed Prev_line]
-    let b = ref empty in
+    @@ add [([], Code Down)] [Zed Next_line]
-    let add e a = b := Input.Bind.S.add e a !b in
+    @@ add [([], Code Home)] [Zed Goto_bol]
-    add [{mods= m []; code= Left}] [Zed Prev_char] ;
+    @@ add [([], Code End)] [Zed Goto_eol]
-    add [{mods= m []; code= Right}] [Zed Next_char] ;
+    @@ add [([], Code Insert)] [Zed Switch_erase_mode]
-    add [{mods= m []; code= Up}] [Zed Prev_line] ;
+    @@ add [([], Code Delete)] [Zed Delete_next_char]
-    add [{mods= m []; code= Down}] [Zed Next_line] ;
+    @@ add [([], Code Enter)] [Zed Newline]
-    add [{mods= m []; code= Home}] [Zed Goto_bol] ;
+    @@ add [([Ctrl], Char ' ')] [Zed Set_mark]
-    add [{mods= m []; code= End}] [Zed Goto_eol] ;
+    @@ add [([Ctrl], Char 'a')] [Zed Goto_bol]
-    add [{mods= m []; code= Insert}] [Zed Switch_erase_mode] ;
+    @@ add [([Ctrl], Char 'e')] [Zed Goto_eol]
-    add [{mods= m []; code= Delete}] [Zed Delete_next_char] ;
+    @@ add [([Ctrl], Char 'd')] [Zed Delete_next_char]
-    add [{mods= m []; code= Enter}] [Zed Newline] ;
+    @@ add [([Ctrl], Char 'h')] [Zed Delete_prev_char]
-    add
+    @@ add [([Ctrl], Char 'k')] [Zed Kill_next_line]
-      [{mods= m [Ctrl]; code= Char (UChar.of_char ' ')}]
+    @@ add [([Ctrl], Char 'u')] [Zed Kill_prev_line]
-      [Zed Set_mark] ;
+    @@ add [([Ctrl], Char 'n')] [Zed Next_line]
-    add
+    @@ add [([Ctrl], Char 'p')] [Zed Prev_line]
-      [{mods= m [Ctrl]; code= Char (UChar.of_char 'a')}]
+    @@ add [([Ctrl], Char 'w')] [Zed Kill]
-      [Zed Goto_bol] ;
+    @@ add [([Ctrl], Char 'y')] [Zed Yank]
-    add
+    @@ add [([], Code Backspace)] [Zed Delete_prev_char]
-      [{mods= m [Ctrl]; code= Char (UChar.of_char 'e')}]
+    @@ add [([Meta], Char 'w')] [Zed Copy]
-      [Zed Goto_eol] ;
+    @@ add [([Meta], Char 'c')] [Zed Capitalize_word]
-    add
+    @@ add [([Meta], Char 'l')] [Zed Lowercase_word]
-      [{mods= m [Ctrl]; code= Char (UChar.of_char 'd')}]
+    @@ add [([Meta], Char 'u')] [Zed Uppercase_word]
-      [Zed Delete_next_char] ;
+    @@ add [([Meta], Char 'b')] [Zed Prev_word]
-    add
+    @@ add [([Meta], Char 'f')] [Zed Next_word]
-      [{mods= m [Ctrl]; code= Char (UChar.of_char 'h')}]
+    @@ add [([Meta], Code Right)] [Zed Next_word]
-      [Zed Delete_prev_char] ;
+    @@ add [([Meta], Code Left)] [Zed Prev_word]
-    add
+    @@ add [([Ctrl], Code Right)] [Zed Next_word]
-      [{mods= m [Ctrl]; code= Char (UChar.of_char 'k')}]
+    @@ add [([Ctrl], Code Left)] [Zed Prev_word]
-      [Zed Kill_next_line] ;
+    @@ add [([Meta], Code Backspace)] [Zed Kill_prev_word]
-    add
+    @@ add [([Meta], Code Delete)] [Zed Kill_prev_word]
-      [{mods= m [Ctrl]; code= Char (UChar.of_char 'u')}]
+    @@ add [([Ctrl], Code Delete)] [Zed Kill_next_word]
-      [Zed Kill_prev_line] ;
+    @@ add [([Meta], Char 'd')] [Zed Kill_next_word]
-    add
+    @@ add [([Ctrl], Char '/')] [Zed Undo]
-      [{mods= m [Ctrl]; code= Char (UChar.of_char 'n')}]
+    @@ add [([Ctrl], Char 'x'); ([], Char 'u')] [Zed Undo]
-      [Zed Next_line] ;
+    @@ empty
-    add
-      [{mods= m [Ctrl]; code= Char (UChar.of_char 'p')}]
-      [Zed Prev_line] ;
-    add [{mods= m [Ctrl]; code= Char (UChar.of_char 'w')}] [Zed Kill] ;
-    add [{mods= m [Ctrl]; code= Char (UChar.of_char 'y')}] [Zed Yank] ;
-    add [{mods= m []; code= Backspace}] [Zed Delete_prev_char] ;
-    add [{mods= m [Meta]; code= Char (UChar.of_char 'w')}] [Zed Copy] ;
-    add
-      [{mods= m [Meta]; code= Char (UChar.of_char 'c')}]
-      [Zed Capitalize_word] ;
-    add
-      [{mods= m [Meta]; code= Char (UChar.of_char 'l')}]
-      [Zed Lowercase_word] ;
-    add
-      [{mods= m [Meta]; code= Char (UChar.of_char 'u')}]
-      [Zed Uppercase_word] ;
-    add
-      [{mods= m [Meta]; code= Char (UChar.of_char 'b')}]
-      [Zed Prev_word] ;
-    add
-      [{mods= m [Meta]; code= Char (UChar.of_char 'f')}]
-      [Zed Next_word] ;
-    add [{mods= m [Meta]; code= Right}] [Zed Next_word] ;
-    add [{mods= m [Meta]; code= Left}] [Zed Prev_word] ;
-    add [{mods= m [Ctrl]; code= Right}] [Zed Next_word] ;
-    add [{mods= m [Ctrl]; code= Left}] [Zed Prev_word] ;
-    add [{mods= m [Meta]; code= Backspace}] [Zed Kill_prev_word] ;
-    add [{mods= m [Meta]; code= Delete}] [Zed Kill_prev_word] ;
-    add [{mods= m [Ctrl]; code= Delete}] [Zed Kill_next_word] ;
-    add
-      [{mods= m [Meta]; code= Char (UChar.of_char 'd')}]
-      [Zed Kill_next_word] ;
-    add [{mods= m [Ctrl]; code= Char (UChar.of_char '/')}] [Zed Undo] ;
-    add
-      [ {mods= m [Ctrl]; code= Char (UChar.of_char 'x')}
-      ; {mods= m []; code= Char (UChar.of_char 'u')} ]
-      [Zed Undo] ;
-    !b
 
   type textedit =
     {ze: unit Zed_edit.t; zc: Zed_cursor.t; keybind: Input.Bind.state}
 
-  let make_textedit ?(keybinds = default_bindings) () =
+  let make_textedit ?(keybinds = textedit_bindings) () =
     let z = Zed_edit.create () in
     { ze= z
     ; zc= Zed_edit.new_cursor z
@@ -885,7 +856,7 @@ module Panel = struct
           (* collect events and update Zed context *)
           List.iter
             (function
-              | `Key_down (k : Input.key) -> (
+              | `Key_down (k : Input.keystate) -> (
                   let open Input.Bind in
                   ( match te.keybind.state with
                   | Accepted _ | Rejected ->
@@ -990,6 +961,8 @@ module Text = Wall_text
 module Store = struct
   module Istore = Irmin_unix.Git.FS.KV (Irmin.Contents.String)
 
+  (* storeview shows items of the selected level *)
+
   type storeview =
     { store: Istore.t
     ; mutable view: string list
@@ -1005,58 +978,66 @@ module Store = struct
                 (Istore.Repo.v (Irmin_git.config storepath)) )
              branch )
     ; view= path
-    ; selected= [2]
+    ; selected= [1]
     ; edit= false }
 
-  let draw_storeview tree selected pp =
-    let indent = ref 0 in
-    let rec draw_levels ttree sel =
-      indent := !indent + 1 ;
-      List.iteri
-        (fun i (step, node) ->
-          Format.pp_open_vbox pp 0 ;
-          Format.pp_open_hbox pp () ;
-          for _ = 0 to !indent do
-            Format.pp_print_space pp ()
-          done ;
-          if sel = [i] then
-            Format.pp_open_stag pp
-              Display.(
-                Panel.Color_bg (Wall.Color.v 0.99 0.99 0.125 0.3)) ;
-          Format.fprintf pp "%d-%s@." !indent step ;
-          if sel = [i] then Format.pp_close_stag pp () ;
-          Format.pp_close_box pp () ;
-          let subtree = Lwt_main.run (Istore.Tree.list node []) in
-          let subsel =
-            if List.length sel > 0 && List.hd sel = i then List.tl sel
-            else [] in
-          draw_levels subtree subsel ;
-          Format.pp_close_box pp () )
-        ttree ;
-      indent := !indent - 1 in
-    draw_levels tree selected
-
   let navigate sv action =
-    let _root =
+    let rec nodecount (ipath : int list) tree =
+      match ipath with
+      | [] ->
+          Istore.Tree.list tree []
+          >>= fun l -> Lwt.return (List.length l)
+      | a :: b ->
+          Istore.Tree.list tree []
+          >>= fun l -> nodecount b (snd (List.nth l a)) in
+    let removelast l = List.rev (List.tl (List.rev l)) in
+    let last l = List.nth l (List.length l - 1) in
+    fun () ->
       Lwt_main.run
         ( Istore.get_tree sv.store sv.view
-        >>= fun n -> Istore.Tree.list n [] ) in
+        >>= fun top ->
-    let rec listlast f = function
+        nodecount (removelast sv.selected) top
-      | [] -> []
+        >>= fun seln ->
-      | [x] -> F.epr "%d@." x ; [f x]
+        nodecount sv.selected top
-      | _ :: x -> listlast f x in
+        >>= fun subn ->
-    fun () ->
+        Lwt.return
-      match action with
+          ( ( match action with
-      | `Next -> sv.selected <- listlast succ sv.selected
+            | `Next ->
-      | `Prev -> sv.selected <- listlast pred sv.selected
+                F.epr
+                  "navigate `Next: (last sv.selected)=%d seln=%d@."
+                  (last sv.selected) seln ;
+                if last sv.selected < seln - 1 then
+                  sv.selected <-
+                    List.mapi
+                      (fun i a ->
+                        if i >= List.length sv.selected - 1 then a + 1
+                        else a )
+                      sv.selected
+            | `Prev ->
+                if last sv.selected > 0 then
+                  sv.selected <-
+                    List.mapi
+                      (fun i a ->
+                        if i >= List.length sv.selected - 1 then a - 1
+                        else a )
+                      sv.selected
+            | `Sub -> if subn > 0 then sv.selected <- sv.selected @ [0]
+            | `Sup ->
+                if List.length sv.selected > 1 then
+                  sv.selected <- removelast sv.selected ) ;
+            F.epr "Store.editor selected: %d@."
+              (List.nth sv.selected (List.length sv.selected - 1)) )
+        )
 
   let editor ?(branch = "current") storepath : Panel.t =
     let sv = make_storeview storepath branch in
     let keybinds =
       let open CamomileLibrary in
       let open Input.Bind in
-      add [([], 'n')] [Custom (navigate sv `Next)]
+      add [([], Char 'n')] [Custom (navigate sv `Next)]
-      @@ add [([], 'p')] [Custom (navigate sv `Prev)] empty in
+      @@ add [([], Char 'p')] [Custom (navigate sv `Prev)]
+      @@ add [([], Char 'd')] [Custom (navigate sv `Sub)]
+      @@ add [([], Char 'u')] [Custom (navigate sv `Sup)] empty in
     let bindstate = Input.Bind.init keybinds in
     { act=
         (fun panel events ->
@@ -1066,11 +1047,39 @@ module Store = struct
           (Panel.vbox panel.subpanels).act panel events )
     ; subpanels=
         [ Panel.prettyprint (fun pp ->
+              let indent = ref 0 in
+              let rec draw_levels tree sel =
+                indent := !indent + 1 ;
+                List.iteri
+                  (fun i (step, node) ->
+                    Format.pp_open_vbox pp 0 ;
+                    Format.pp_open_hbox pp () ;
+                    for _ = 0 to !indent do
+                      Format.pp_print_space pp ()
+                    done ;
+                    if sel = [i] then
+                      Format.pp_open_stag pp
+                        Display.(
+                          Panel.Color_bg
+                            (Wall.Color.v 0.99 0.99 0.125 0.3)) ;
+                    Format.fprintf pp "%d-%s@." !indent step ;
+                    if sel = [i] then Format.pp_close_stag pp () ;
+                    Format.pp_close_box pp () ;
+                    let subtree =
+                      Lwt_main.run (Istore.Tree.list node []) in
+                    let subsel =
+                      if List.length sel > 0 && List.hd sel = i then
+                        List.tl sel
+                      else [] in
+                    draw_levels subtree subsel ;
+                    Format.pp_close_box pp () )
+                  tree ;
+                indent := !indent - 1 in
               let root =
                 Lwt_main.run
                   ( Istore.get_tree sv.store sv.view
                   >>= fun n -> Istore.Tree.list n [] ) in
-              draw_storeview root sv.selected pp )
+              draw_levels root sv.selected )
         ; Panel.bindingstate bindstate ]
     ; tag= "store-editor" }
 end
@@ -1176,8 +1185,8 @@ let top_panel (t : top) =
       F.epr "Exception in pane_top//eval@." in
   t.te.keybind.bindings <-
     Input.(
-      Bind.S.add
+      Bind.add
-        [{mods= Keymod.of_list [Ctrl]; code= Enter}]
+        [([Ctrl], Code Enter)]
         Bind.[Custom eval]
         t.te.keybind.bindings) ;
   Panel.(