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_up of Input.key
+    [ `Key_down of Input.keystate
+    | `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,9 +357,12 @@ module Event = struct
 
   let actions_of_events (state : Input.Bind.state) (events : events) =
     let open Input.Bind in
-    List.iter
-      (function
-        | `Key_down (k : Input.key) ->
+    List.flatten
+      (List.filter_map
+         (fun e ->
+           (*F.epr "action_of_events: %s@." (to_string e) ;*)
+           match e with
+           | `Key_down (k : Input.keystate) -> (
                ( match state.state with
                | Continue _ -> ()
                | _ -> state.last_keyseq <- [] ) ;
@@ -361,17 +370,17 @@ module Event = struct
                  resolve k
                    (get_resolver state.state
                       (default_resolver state.bindings) ) ;
-            state.last_keyseq <- k :: state.last_keyseq
-        | _ -> () )
-      events ;
+               state.last_keyseq <- k :: state.last_keyseq ;
                match state.state with
                | Accepted a ->
                    state.last_actions <- a ;
-        a
+                   Some a
                | 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
-    let open Zed_edit in
-    let m = Input.Keymod.of_list in
-    let b = ref empty in
-    let add e a = b := Input.Bind.S.add e a !b in
-    add [{mods= m []; code= Left}] [Zed Prev_char] ;
-    add [{mods= m []; code= Right}] [Zed Next_char] ;
-    add [{mods= m []; code= Up}] [Zed Prev_line] ;
-    add [{mods= m []; code= Down}] [Zed Next_line] ;
-    add [{mods= m []; code= Home}] [Zed Goto_bol] ;
-    add [{mods= m []; code= End}] [Zed Goto_eol] ;
-    add [{mods= m []; code= Insert}] [Zed Switch_erase_mode] ;
-    add [{mods= m []; code= Delete}] [Zed Delete_next_char] ;
-    add [{mods= m []; code= Enter}] [Zed Newline] ;
-    add
-      [{mods= m [Ctrl]; code= Char (UChar.of_char ' ')}]
-      [Zed Set_mark] ;
-    add
-      [{mods= m [Ctrl]; code= Char (UChar.of_char 'a')}]
-      [Zed Goto_bol] ;
-    add
-      [{mods= m [Ctrl]; code= Char (UChar.of_char 'e')}]
-      [Zed Goto_eol] ;
-    add
-      [{mods= m [Ctrl]; code= Char (UChar.of_char 'd')}]
-      [Zed Delete_next_char] ;
-    add
-      [{mods= m [Ctrl]; code= Char (UChar.of_char 'h')}]
-      [Zed Delete_prev_char] ;
-    add
-      [{mods= m [Ctrl]; code= Char (UChar.of_char 'k')}]
-      [Zed Kill_next_line] ;
-    add
-      [{mods= m [Ctrl]; code= Char (UChar.of_char 'u')}]
-      [Zed Kill_prev_line] ;
-    add
-      [{mods= m [Ctrl]; code= Char (UChar.of_char 'n')}]
-      [Zed Next_line] ;
-    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
+    add [([], Code Left)] [Zed Prev_char]
+    @@ add [([], Code Right)] [Zed Next_char]
+    @@ add [([], Code Up)] [Zed Prev_line]
+    @@ add [([], Code Down)] [Zed Next_line]
+    @@ add [([], Code Home)] [Zed Goto_bol]
+    @@ add [([], Code End)] [Zed Goto_eol]
+    @@ add [([], Code Insert)] [Zed Switch_erase_mode]
+    @@ add [([], Code Delete)] [Zed Delete_next_char]
+    @@ add [([], Code Enter)] [Zed Newline]
+    @@ add [([Ctrl], Char ' ')] [Zed Set_mark]
+    @@ add [([Ctrl], Char 'a')] [Zed Goto_bol]
+    @@ add [([Ctrl], Char 'e')] [Zed Goto_eol]
+    @@ add [([Ctrl], Char 'd')] [Zed Delete_next_char]
+    @@ add [([Ctrl], Char 'h')] [Zed Delete_prev_char]
+    @@ add [([Ctrl], Char 'k')] [Zed Kill_next_line]
+    @@ add [([Ctrl], Char 'u')] [Zed Kill_prev_line]
+    @@ add [([Ctrl], Char 'n')] [Zed Next_line]
+    @@ add [([Ctrl], Char 'p')] [Zed Prev_line]
+    @@ add [([Ctrl], Char 'w')] [Zed Kill]
+    @@ add [([Ctrl], Char 'y')] [Zed Yank]
+    @@ add [([], Code Backspace)] [Zed Delete_prev_char]
+    @@ add [([Meta], Char 'w')] [Zed Copy]
+    @@ add [([Meta], Char 'c')] [Zed Capitalize_word]
+    @@ add [([Meta], Char 'l')] [Zed Lowercase_word]
+    @@ add [([Meta], Char 'u')] [Zed Uppercase_word]
+    @@ add [([Meta], Char 'b')] [Zed Prev_word]
+    @@ add [([Meta], Char 'f')] [Zed Next_word]
+    @@ add [([Meta], Code Right)] [Zed Next_word]
+    @@ add [([Meta], Code Left)] [Zed Prev_word]
+    @@ add [([Ctrl], Code Right)] [Zed Next_word]
+    @@ add [([Ctrl], Code Left)] [Zed Prev_word]
+    @@ add [([Meta], Code Backspace)] [Zed Kill_prev_word]
+    @@ add [([Meta], Code Delete)] [Zed Kill_prev_word]
+    @@ add [([Ctrl], Code Delete)] [Zed Kill_next_word]
+    @@ add [([Meta], Char 'd')] [Zed Kill_next_word]
+    @@ add [([Ctrl], Char '/')] [Zed Undo]
+    @@ add [([Ctrl], Char 'x'); ([], Char 'u')] [Zed Undo]
+    @@ empty
 
   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,12 +978,77 @@ 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 navigate sv action =
+    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 top ->
+        nodecount (removelast sv.selected) top
+        >>= fun seln ->
+        nodecount sv.selected top
+        >>= fun subn ->
+        Lwt.return
+          ( ( match action with
+            | `Next ->
+                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 [([], Char 'n')] [Custom (navigate sv `Next)]
+      @@ 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 ->
+          List.iter
+            Input.Bind.(function Custom f -> f () | _ -> ())
+            (Event.actions_of_events bindstate events) ;
+          (Panel.vbox panel.subpanels).act panel events )
+    ; subpanels=
+        [ Panel.prettyprint (fun pp ->
               let indent = ref 0 in
-    let rec draw_levels ttree sel =
+              let rec draw_levels tree sel =
                 indent := !indent + 1 ;
                 List.iteri
                   (fun i (step, node) ->
@@ -1022,55 +1060,26 @@ module Store = struct
                     if sel = [i] then
                       Format.pp_open_stag pp
                         Display.(
-                Panel.Color_bg (Wall.Color.v 0.99 0.99 0.125 0.3)) ;
+                          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 subtree =
+                      Lwt_main.run (Istore.Tree.list node []) in
                     let subsel =
-            if List.length sel > 0 && List.hd sel = i then List.tl sel
+                      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 ;
+                  tree ;
                 indent := !indent - 1 in
-    draw_levels tree selected
-
-  let navigate sv action =
-    let _root =
-      Lwt_main.run
-        ( Istore.get_tree sv.store sv.view
-        >>= fun n -> Istore.Tree.list n [] ) in
-    let rec listlast f = function
-      | [] -> []
-      | [x] -> F.epr "%d@." x ; [f x]
-      | _ :: x -> listlast f x in
-    fun () ->
-      match action with
-      | `Next -> sv.selected <- listlast succ sv.selected
-      | `Prev -> sv.selected <- listlast pred sv.selected
-
-  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 [([], 'p')] [Custom (navigate sv `Prev)] empty in
-    let bindstate = Input.Bind.init keybinds in
-    { act=
-        (fun panel events ->
-          List.iter
-            Input.Bind.(function Custom f -> f () | _ -> ())
-            (Event.actions_of_events bindstate events) ;
-          (Panel.vbox panel.subpanels).act panel events )
-    ; subpanels=
-        [ Panel.prettyprint (fun pp ->
               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
-        [{mods= Keymod.of_list [Ctrl]; code= Enter}]
+      Bind.add
+        [([Ctrl], Code Enter)]
         Bind.[Custom eval]
         t.te.keybind.bindings) ;
   Panel.(