getting super confused while trying to make generic tree structure operations that map to irmin

irc.ml

@@ -8,111 +8,194 @@ features:
    - 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.
 *)
-
+open Human
 open Lwt
 open Lwt_react
 module F = Fmt
 
 module Communicator = struct
-  module Message = struct
+  module Istore = struct
-    type t = {content: string; time: string; mutable seen: bool}
+    include Human.Store
 
-    let make ?(time = "<ts>") content = {content; time; seen= false}
+    let from_storeview (sv : storeview) = sv.store
+
+    include Human.Store.Istore
+  end
+
+  module Message = struct
+    type t = {time: string list; content: string}
+
+    let make ?(time = Unix.time ()) content =
+      let tm = Unix.localtime time in
+      { time=
+          [ string_of_int tm.tm_year; string_of_int tm.tm_mon
+          ; string_of_int tm.tm_mday; string_of_int tm.tm_hour ]
+      ; content }
   end
 
   module Channel = struct
-    type t = {name: string; content: Message.t list Lwd.var}
+    type t = {store: Istore.t; path: Istore.key}
 
-    let add_msg (c : t) (msg : Message.t) =
+    let make (store : Istore.t) ~path ~name =
-      F.epr "Channel.add_msg msg.content=\"%s\"@." msg.content ;
+      {store; path= path @ name}
-      let cn = Lwd.peek c.content in
-      Lwd.set c.content (msg :: cn)
 
-    let make name = {name; content= Lwd.var []}
+    let add_msg {store; path} (msg : Message.t) : unit Lwt.t =
+      Istore.set_exn store ~info:Irmin.Info.none (path @ msg.time)
+        msg.content
   end
 
   module Tree = struct
-    open Channel
     open Message
 
-    type t =
+    type selection = Istore.Key.t
-      { channel: Channel.t
+    type t = {store: Istore.t; view: Istore.key}
-      ; subs: t Lwd_table.t
-      ; focus: Nottui.Focus.handle }
-
     type protocol = Irc | Email | Rss | Mublog | ActivityPub
 
-    let add (comm : t) ch : unit =
+    let contents {store; view} (s : selection) :
-      let c' =
+        Istore.Contents.t option Lwt.t =
-        { channel= ch
+      Istore.find store (view @ s)
-        ; subs= Lwd_table.make ()
-        ; focus= Nottui.Focus.make () } in
-      Lwd_table.append' comm.subs c'
 
-    let make_top () =
+    let make_top ?(view = ["communicator"]) gitpath branchname :
-      let channel = Channel.make "communicator-top" in
+        t Lwt.t =
-      add_msg channel (Message.make "Welcome to the Communicator") ;
+      Istore.Repo.v (Irmin_git.config gitpath)
-      add_msg channel
+      >>= fun repo ->
-        (Message.make "Currently only IRC is implemented") ;
+      Istore.of_branch repo branchname
-      {channel; subs= Lwd_table.make (); focus= Nottui.Focus.make ()}
+      >>= fun store ->
+      let t = {store; view= []} in
+      Istore.get_tree store view
+      >>= fun _tree ->
+      let view = Istore.Key.v view in
+      Istore.list store view
+      >>= fun _viewlist ->
+      let ch_top = Channel.make store ~path:[] ~name:["top"] in
+      Channel.add_msg ch_top
+        (Message.make "Communicator restarting...")
+      >>= fun () ->
+      Channel.add_msg ch_top
+        (Message.make "Currently only IRC is implemented")
+      >>= fun () -> Lwt.return t
+
+    let add {store; view} ~(name : string list) ~(config : Istore.tree)
+        : t Lwt.t =
+      Istore.get_tree store name
+      >>= fun tree ->
+      Istore.Tree.remove tree ["_config"]
+      >>= fun tree ->
+      Istore.Tree.add_tree tree [] config
+      >>= fun tree ->
+      Istore.set_tree_exn ~info:Irmin.Info.none store name tree
+      >>= fun () -> Lwt.return {store; view}
   end
 
   module Irc = struct
     module C = Irc_client_tls
     module M = Irc_message
 
-    let connection (c : Tree.t) server port nick
+    module Config = struct
-        (channels : string list) : Channel.t =
+      type t = Istore.tree
-      let channel =
+
-        Channel.make ("IRC: " ^ server ^ ":" ^ string_of_int port)
+      open Lwt.Infix
-      in
+
-      let _c' = Tree.add c channel in
+      let make_connection Tree.{store; _} server port nick =
-      let add_msg str = Channel.add_msg channel (Message.make str) in
+        let name = F.str "%s@%s:%d" nick server port in
+        Istore.Tree.add Istore.Tree.empty ["server"] server
+        >>= fun t' ->
+        Istore.Tree.add t' ["port"] (string_of_int port)
+        >>= fun t' ->
+        Istore.Tree.add t' ["nick"] nick
+        >>= fun t' ->
+        Istore.set_tree_exn ~info:Irmin.Info.none store
+          ["irc"; name; "_config"]
+          t'
+        >>= fun _ -> Lwt.return_unit
+
+      let server t : string Lwt.t = Istore.Tree.get t ["server"]
+
+      let port t : int Lwt.t =
+        Istore.Tree.get t ["port"] >|= fun p -> int_of_string p
+
+      let nick t : string Lwt.t = Istore.Tree.get t ["nick"]
+    end
+
+    let get_channels ~store ~path =
+      Istore.list store path
+      >>= fun c -> Lwt.return (fst (List.split c))
+
+    let connect ?(path = ["irc"]) ({store; _} : Tree.t) : unit Lwt.t =
+      (* search for all connections and start them *)
+      (* also need ot figure out how to preserve custom ordering of items like servers and channels
+         maybe just a _order file that has the ordering of files listed and hten gets  updated etc. *)
+      let top_channel =
+        Channel.make store ~path:["irc"] ~name:["top"] in
+      let _top_msg str =
+        Channel.add_msg top_channel (Message.make str) in
+      Istore.list store path
+      >>= fun servers ->
       let channel_assoc = ref [] in
-      let make_ch name =
+      let make_channel store server (name : string) =
-        let ch = Channel.make name in
+        let ch =
-        Tree.add c ch ;
+          Channel.make store ~path:(["irc"] @ server) ~name:[name]
+        in
         channel_assoc := (name, ch) :: !channel_assoc ;
-        ch in
+        Channel.add_msg ch
-      Lwt.async
+          (Message.make (F.str "channel %s created" name))
-        (C.reconnect_loop ~after:30
+        >>= fun () -> Lwt.return ch in
-           ~connect:(fun () ->
+      Lwt_list.iter_p
-             add_msg "Connecting..." ;
+        (fun (_server, tree) ->
-             C.connect_by_name ~server ~port ~nick ()
+          Config.nick tree
-             >>= fun c ->
+          >>= fun nick ->
-             Lwt_io.printl "connect_by_name returned"
+          Config.server tree
-             >>= fun () -> Lwt.return c )
+          >>= fun server ->
-           ~f:(fun connection ->
+          Config.port tree
-             add_msg "Connected" ;
+          >>= fun port ->
-             Lwt_list.iter_p
+          let server_channel =
-               (fun chname ->
+            Channel.make store ~path ~name:[server; server] in
-                 C.send_join ~connection ~channel:chname
+          let add_msg s =
-                 >>= fun () ->
+            Channel.add_msg server_channel (Message.make s) in
-                 ignore (make_ch chname) ;
+          C.reconnect_loop ~after:30
-                 Lwt.return_unit )
+            ~connect:(fun () ->
-               channels )
+              add_msg "Connecting..."
-           ~callback:(fun _connection result ->
+              >>= fun () ->
-             match result with
+              C.connect_by_name ~server ~port ~nick ()
-             | Result.Ok ({M.command= M.Other _; _} as msg) ->
+              >>= fun c -> Lwt.return c )
-                 add_msg (M.to_string msg) ;
+            ~f:(fun connection ->
-                 Lwt.return_unit
+              add_msg "Connected"
-             | Result.Ok
+              >>= fun () ->
-                 {M.command= M.PRIVMSG (target, data); prefix= user}
+              get_channels ~store ~path:["irc"; server]
-               ->
+              >>= fun chs ->
-                 let user =
+              Lwt_list.iter_p
-                   match user with
+                (fun chname ->
-                   | Some u -> List.hd (String.split_on_char '!' u)
+                  C.send_join ~connection ~channel:chname
-                   | None -> "unknown" in
+                  >>= fun () ->
-                 ( match List.assoc_opt target !channel_assoc with
+                  ignore (make_channel store [server] chname) ;
-                 | Some ch -> Channel.add_msg ch
+                  Lwt.return_unit )
-                 | None -> Channel.add_msg (make_ch target) )
+                chs )
-                   (Message.make (F.str "<%s> %s" user data)) ;
+            ~callback:(fun _connection result ->
-                 Lwt.return_unit
+              match result with
-             | Result.Ok msg ->
+              | Result.Ok ({M.command= M.Other _; _} as msg) ->
-                 add_msg (M.to_string msg) ;
+                  add_msg (M.to_string msg)
-                 Lwt.return_unit
+              | Result.Ok
-             | Result.Error e -> Lwt_io.printl e ) ) ;
+                  {M.command= M.PRIVMSG (target, data); prefix= user}
-      channel
+                -> (
+                  let user =
+                    match user with
+                    | Some u -> List.hd (String.split_on_char '!' u)
+                    | None -> "unknown" in
+                  match List.assoc_opt target !channel_assoc with
+                  | Some ch ->
+                      Channel.add_msg ch
+                        (Message.make (F.str "<%s> %s" user data))
+                  | None ->
+                      make_channel store [server] target
+                      >>= fun ch ->
+                      Channel.add_msg ch
+                        (Message.make (F.str "<%s> %s" user data)) )
+              | Result.Ok msg ->
+                  add_msg (M.to_string msg)
+                  >>= fun () -> Lwt.return_unit
+              | Result.Error e -> Lwt_io.printl e )
+            () )
+        servers
   end
 
   module Panel = struct
@@ -122,39 +205,208 @@ module Communicator = struct
     let string ?attr text = P.ui (Nottui_widgets.string ?attr text)
     let ( ^^ ) = P.( ^^ )
     let ( ^/^ ) a b = P.(a ^^ break 1 ^^ b)
+    let (messagelist_watch : Istore.watch option ref) = ref None
 
-    let messagelist (ch : Channel.t) : P.t Lwd.t =
+    let messagelist ~store (ch : Channel.t) : P.t Lwd.t Lwt.t =
-      Lwd.map (Lwd.get ch.content) ~f:(fun (msgs : Message.t list) ->
+      ( match !messagelist_watch with
-          List.fold_left
+      | Some w -> Istore.unwatch w
-            (fun doc (msg : Message.t) ->
+      | None -> Lwt.return_unit )
-              F.epr "Communicator.Panel.messagelist ch.content=%s@."
+      >>= fun () ->
-                msg.content ;
+      let mlist' () =
-              doc
+        let sl l =
-              ^^ P.group
+          l
-                   ( string msg.time ^/^ string " | "
+          >>= fun x ->
-                   ^/^ string msg.content )
+          Lwt.return (List.sort String.compare (fst (List.split x)))
-              ^^ P.hardline )
+        in
-            P.empty msgs )
+        sl (Istore.list store ch.path)
+        >>= fun years ->
+        let year = List.hd years in
+        sl (Istore.list store (ch.path @ [year]))
+        >>= fun months ->
+        let month = List.hd months in
+        sl (Istore.list store (ch.path @ [month]))
+        >>= fun days ->
+        let day = List.hd days in
+        sl (Istore.list store (ch.path @ [day]))
+        >>= fun hours ->
+        let hour = List.hd hours in
+        Istore.list store [year; month; day; hour]
+        >>= fun mlist ->
+        Lwt_list.map_p
+          (fun (second, content) ->
+            Istore.Tree.get content []
+            >>= fun content ->
+            Lwt.return ((year, month, day, hour, second), content) )
+          mlist in
+      mlist' ()
+      >>= fun mlist ->
+      let mlist = Lwd.var mlist in
+      Istore.watch_key store ch.path (function _ ->
+          mlist' ()
+          >>= fun mlist' -> Lwt.return (Lwd.set mlist mlist') )
+      >>= fun watch ->
+      messagelist_watch := Some watch ;
+      Lwt.return
+        (Lwd.map (Lwd.get mlist) ~f:(fun mlist ->
+             List.fold_left
+               (fun doc ((year, month, day, hour, sec), content) ->
+                 F.epr
+                   "Communicator.Panel.messagelist ch.content=%s@."
+                   content ;
+                 doc
+                 ^^ P.group
+                      ( string
+                          (F.str "%s.%s.%s.%s.%s" year month day hour
+                             sec )
+                      ^^ string " | " ^^ string content )
+                 ^^ P.hardline )
+               P.empty mlist ) )
 
     open Nottui_widgets
 
-    (*type focustree =
+    module StoreTree = struct
-        {channel: Channel.t; subs: focustree list; focus: Focus.handle}
+      (* the tree structure needs to allow:
+         - arbitrary traversal from a handle for any node (double linked sufficient?)
+         - Incremental updates, where the tree/node generation function is only called on updated nodes
+         - returns a Lwd.var which gets updated anytime the watch is triggered by a change on disk.
+      *)
 
-      let channeltree (tree : Tree.t) : focustree Lwd.t =
+      type 'a t =
-         let rec fold (tree : Tree.t) : focustree list Lwd.t =
+        {step: string; mutable super: 'a super; mutable node: 'a node}
-           Lwd_table.map_reduce
-             (fun _row (tree : Tree.t) ->
-                Lwd.map (fold tree) ~f:(fun (subs : focustree list) ->
-                  { channel= tree.channel
-                    ; subs
-                    ; focus= Focus.make () } ))
-             ([], fun a b -> List.append a b)
-             tree.subs in
-         let {channel= tree.channel; subs= fold tree; focus= Focus.make ()} *)
 
-    let channelview (tree : Tree.t) : 'a Lwd.t * Channel.t Lwd.var =
+      and 'a super = [`Tree of 'a t | `Root]
-      let channel = Lwd.var tree.channel in
+
+      and 'a sub = 'a t list
+
+      and 'a node = [`Node of 'a sub | `Contents of 'a]
+
+      let rec mapt ?(super = `Root) ~(f : 'a t -> 'b t -> 'b t)
+          (a : 'a t) : 'b t =
+        let this = {a with super; node= `Node []} in
+        match a with
+        | {node= `Node subs; _} as aa ->
+            let rec iter = function
+              | x :: xs -> mapt ~super:(`Tree this) ~f x :: iter xs
+              | [] -> [] in
+            this.node <- `Node (iter subs) ;
+            f aa this
+        | {node= `Contents _; _} as aa -> f aa this
+
+      let rec map ?(super = `Root)
+          ~(f : 'a node -> 'b node -> 'b node) (a : 'a node) : 'b node
+          =
+        match a with
+        | `Node subs as aa ->
+            let rec iter = function
+              | ({node; _} as x) :: xs ->
+                  let this = {x with super; node= `Node []} in
+                  this.node <- map ~super:(`Tree this) ~f node ;
+                  this :: iter xs
+              | [] -> [] in
+            f aa (`Node (iter subs))
+        | `Contents _ as aa -> f aa (`Node [])
+
+      let rec map2 ?(super = `Root)
+          ~(f : 'a t option -> 'b t option -> 'c t -> 'c t) (a : 'a t)
+          (b : 'b t) : 'c t =
+        let this = {a with super; node= `Node []} in
+        let rec iter2 (a : 'a sub) (b : 'b sub) : 'c sub =
+          match (a, b) with
+          | ae :: al, be :: bl ->
+              map2 ~super:(`Tree this) ~f ae be :: iter2 al bl
+          | [], be :: bl ->
+              mapt ~super:(`Tree this)
+                ~f:(fun x -> f None (Some x))
+                be
+              :: iter2 [] bl
+          | ae :: al, [] ->
+              mapt ~super:(`Tree this)
+                ~f:(fun x -> f (Some x) None)
+                ae
+              :: iter2 [] al
+          | [], [] -> [] in
+        f (Some a) (Some b)
+          { this with
+            node=
+              ( match (a.node, b.node) with
+              | `Node nodes_a, `Node nodes_b ->
+                  `Node (iter2 nodes_a nodes_b)
+              | `Contents _, `Node nodes_b -> `Node (iter2 [] nodes_b)
+              | `Node nodes_a, `Contents _ -> `Node (iter2 nodes_a [])
+              | `Contents _, `Contents _ -> `Node [] ) }
+
+      let rec of_istore_tree ?(super = `Root) (tree : Istore.tree) :
+          'a node Lwt.t =
+        Istore.Tree.kind tree []
+        >>= fun kind ->
+        match kind with
+        | None -> Lwt.return (`Node [])
+        | Some `Node ->
+            Istore.Tree.list tree []
+            >>= fun nlist ->
+            Lwt_list.map_p
+              (fun (step, tree') ->
+                let t = {step; super; node= `Node []} in
+                of_istore_tree ~super:(`Tree t) tree'
+                >>= fun sub ->
+                t.node <- sub ;
+                Lwt.return t )
+              nlist
+            >>= fun sub -> Lwt.return (`Node sub)
+        | Some `Contents ->
+            Istore.Tree.get tree []
+            >>= fun content -> Lwt.return (`Contents content)
+
+      let watch_tree (store : Istore.t) (tree : Istore.tree)
+          ~(f : string t Irmin.diff -> 'a t) :
+          (Istore.watch * 'a t Lwd.var) Lwt.t =
+        of_istore_tree tree
+        >>= (function
+              | `Contents _ as node ->
+                  Lwt.return {step= ""; super= `Root; node}
+              | `Node sub ->
+                  Lwt_list.map_p
+                    (fun t' ->
+                      Lwt.return
+                        (mapt ~f:(fun a _ -> f (`Added a)) t') )
+                    sub
+                  >>= fun node ->
+                  Lwt.return {step= ""; super= `Root; node= `Node node}
+              )
+        >>= fun t ->
+        let tree = Lwd.var t in
+        let aux c =
+          of_istore_tree (Istore.Commit.tree c)
+          >>= fun t' ->
+          Lwd.set tree
+            (map2 (Lwd.peek tree)
+               {step= ""; super= `Root; node= t'}
+               ~f:(fun prev next _ ->
+                 match (prev, next) with
+                 | Some prev, Some next -> f (`Updated (prev, next))
+                 | Some prev, None -> f (`Removed prev)
+                 | None, Some next -> f (`Added next)
+                 | None, None -> failwith "StoreTree.watch_tree" ) ) ;
+          Lwt.return_unit in
+        Istore.watch store (function
+          | `Added c -> aux c
+          | `Removed c -> aux c
+          | `Updated (_, c') -> aux c' )
+        >>= fun watch -> Lwt.return (watch, tree)
+    end
+
+    let channelview ({store; path} : Channel.t) =
+      Istore.get_tree store path
+      >>= fun tree -> StoreTree.watch_tree store tree ~f:(function
+            `Added ({node=`Contents _;_} as t) -> t
+          | `Removed _ -> 
+
+    let _channelview ({store; _} : Tree.t) (channel : Channel.t) =
+      Fold.tree store ~depth:3 ~path:[] ~f:(function
+        | Tree (step, tl) -> Tree (step, tl)
+        | Node (step, content) -> Node (step, content) )
+      >>= fun (tree : string Fold.t Lwd.var) ->
+      let channel = Lwd.var channel in
       let rec fold ?(indent = 0) ?superfocus (tree : Tree.t) :
           'a Lwd.t =
         let subfocus = Focus.make () in
@@ -164,8 +416,7 @@ module Communicator = struct
                let focus =
                  match superfocus with
                  | Some sf ->
-                     Lwd.map2 (Focus.status sf)
+                     Lwd.map2 (Focus.status sf) Focus.status
-                       (Focus.status tree.focus)
                        ~f:(fun superfocus' focus' ->
                          if Focus.has_focus superfocus' then
                            F.epr
@@ -230,7 +481,7 @@ module Communicator = struct
       Panel.Nottui.scroll_area
         (Lwd.map
            (Lwd.bind (Lwd.get ch) ~f:messagelist)
-           ~f:(P.pretty 200) )
+           ~f:(P.pretty 100) )
 
     let commview c =
       let cv, ch = channelview c in
@@ -247,16 +498,16 @@ module Communicator = struct
   end
 end
 
-let _ =
-  let comm = Communicator.Tree.make_top () in
-  let _irc =
-    Communicator.Irc.connection comm "irc.hackint.org" 6697 "cqcaml"
-      ["#CQC"] in
-  root_actor := std_actor (Communicator.Panel.panel comm)
-
 (**
    program starts...
    - spawn connections to servers
    - these connections will populate the Channel.t in a Channel.tree
        
  **)
+let _ =
+  Lwt.async (fun () ->
+      let comm = Communicator.Tree.make_top root_storeview in
+      Irc.Config.make "irc.hackint.org" 6697 "cqcaml"
+      >|= fun irc_config ->
+      let _irc = Communicator.Irc.connection comm irc_config in
+      root_actor := std_actor (Communicator.Panel.panel comm) )