From 983fc326d600b014f37833648d4da35bae0c1543 Mon Sep 17 00:00:00 2001 From: cqc Date: Fri, 29 Oct 2021 12:27:58 -0500 Subject: [PATCH] storeview --- human.ml | 18 +- irc.ml | 613 ++++++++++++++++++++++++++----------------------------- 2 files changed, 308 insertions(+), 323 deletions(-) diff --git a/human.ml b/human.ml index f34b52e..018d98d 100644 --- a/human.ml +++ b/human.ml @@ -514,12 +514,25 @@ module Display = struct get_events () @ [Event.event_of_sdlevent ev] else [] + let successful_actor = ref (fun _ -> Lwt.return pane_empty) + let display_frame frame (actor : actor) = let events = get_events () in handle_frame_events frame events ; if List.length events > 0 then ( (* recompute the actor definition with the new events to return a new pane *) - !actor events + ( try + !actor events + >|= fun p -> + successful_actor := !actor ; + p + with e -> + F.epr + "Display.display_frame (!actor events) failed with:@. %s \ + @." + (Printexc.to_string e) ; + actor := !successful_actor ; + !actor events ) >>= fun p -> frame.last_pane <- p ; (* call draw_pane because we should redraw now that we have updated *) @@ -1118,7 +1131,6 @@ module Panel = struct module Nottui = struct open Nottui - open Notty module P = Nottui_pretty let convert_events events : Nottui_lwt.event option list = @@ -1227,8 +1239,6 @@ module Panel = struct | _, _, _ -> "fonts/Roboto-Regular.ttf" ) ) end - open Notty - let invalid_arg fmt = Format.kasprintf invalid_arg fmt let ( &. ) f g x = f (g x) let btw (x : int) a b = a <= x && x <= b diff --git a/irc.ml b/irc.ml index a09eb91..ba0b068 100644 --- a/irc.ml +++ b/irc.ml @@ -8,12 +8,15 @@ 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 + let base_path = "communicator" + let topch = "top" + module Istore = struct include Human.Store @@ -25,21 +28,28 @@ module Communicator = struct module Message = struct type t = {time: string list; content: string} - let make ?(time = Unix.time ()) content = + let make ?(time = Unix.gettimeofday ()) 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 ] + List.map string_of_int + [tm.tm_year + 1900; tm.tm_mon + 1; tm.tm_mday; tm.tm_hour] + @ [ string_of_float + ( float_of_int (tm.tm_min * tm.tm_sec) + +. fst (modf time) ) ] ; content } end module Channel = struct + (* a channels step key may not be blank (i.e. "") *) type t = {store: Istore.t; path: Istore.key} - let make (store : Istore.t) ~path ~name = - {store; path= path @ name} + let make (store : Istore.t) ~path ~(name : string) = + Lwt.return {store; path= path @ ["#" ^ name]} let add_msg {store; path} (msg : Message.t) : unit Lwt.t = + F.epr "add_msg path=[" ; + F.list ~sep:F.semi F.string F.stderr (path @ msg.time) ; + F.epr "] content=%s @." msg.content ; Istore.set_exn store ~info:Irmin.Info.none (path @ msg.time) msg.content end @@ -49,25 +59,19 @@ module Communicator = struct type selection = Istore.Key.t type t = {store: Istore.t; view: Istore.key} - type protocol = Irc | Email | Rss | Mublog | ActivityPub let contents {store; view} (s : selection) : Istore.Contents.t option Lwt.t = Istore.find store (view @ s) - let make_top ?(view = ["communicator"]) gitpath branchname : - t Lwt.t = + let make_top ?(view = [base_path]) gitpath branchname : t Lwt.t = Istore.Repo.v (Irmin_git.config gitpath) >>= fun repo -> Istore.of_branch repo branchname >>= 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 + let t = {store; view} in + Channel.make store ~path:view ~name:topch + >>= fun ch_top -> Channel.add_msg ch_top (Message.make "Communicator restarting...") >>= fun () -> @@ -87,6 +91,20 @@ module Communicator = struct >>= fun () -> Lwt.return {store; view} end + module Protocol = struct + type t = Irc | Email | Rss | Mublog | ActivityPub + + let to_string = function + | Irc -> ("IRC", "Internet Relay Chat") + | Email -> ("E-mail", "Electronic Mail") + | Rss -> ("RSS", "Really Simple Subscriptions???") + | Mublog -> ("uBlog", "Microblogging (Twitter)") + | ActivityPub -> ("ActivityPub", "Mastodon, etc.") + + let id t = fst (to_string t) + let desc t = snd (to_string t) + end + module Irc = struct module C = Irc_client_tls module M = Irc_message @@ -96,7 +114,9 @@ module Communicator = struct open Lwt.Infix - let make_connection Tree.{store; _} server port nick = + let path = "_config" + + let make_connection Tree.{store; view} server port nick = let name = F.str "%s@%s:%d" nick server port in Istore.Tree.add Istore.Tree.empty ["server"] server >>= fun t' -> @@ -104,52 +124,76 @@ module Communicator = struct >>= fun t' -> Istore.Tree.add t' ["nick"] nick >>= fun t' -> + Istore.Tree.add t' ["protocol"] (Protocol.id Irc) + >>= fun t' -> + F.epr "Creating connection config /%s/%s/@." name path ; Istore.set_tree_exn ~info:Irmin.Info.none store - ["irc"; name; "_config"] + (view @ [name; path]) t' >>= fun _ -> Lwt.return_unit - let server t : string Lwt.t = Istore.Tree.get t ["server"] + let server t : string Lwt.t = Istore.Tree.get t [path; "server"] let port t : int Lwt.t = - Istore.Tree.get t ["port"] >|= fun p -> int_of_string p + Istore.Tree.get t [path; "port"] >|= fun p -> int_of_string p - let nick t : string Lwt.t = Istore.Tree.get t ["nick"] + let nick t : string Lwt.t = Istore.Tree.get t [path; "nick"] + + let protocol t : string option Lwt.t = + Istore.Tree.find t [path; "protocol"] end let get_channels ~store ~path = Istore.list store path - >>= fun c -> Lwt.return (fst (List.split c)) + >>= fun c -> + let rec iter l = + Lwt_list.filter_map_p + (fun (s, _) -> + if String.length s > 1 && String.get s 0 = '#' then + Lwt.return (Some s) + else Lwt.return None ) + l in + iter c - let connect ?(path = ["irc"]) ({store; _} : Tree.t) : unit Lwt.t = + let connect ?(path = [base_path]) ({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 + Channel.make store ~path ~name:topch + >>= fun top_channel -> 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_channel store server (name : string) = - let ch = - Channel.make store ~path:(["irc"] @ server) ~name:[name] - in + let make_channel store path (name : string) = + Channel.make store ~path ~name + >>= fun ch -> channel_assoc := (name, ch) :: !channel_assoc ; Channel.add_msg ch (Message.make (F.str "channel %s created" name)) >>= fun () -> Lwt.return ch in + Istore.list store path + >>= fun servers -> + Lwt_list.filter_p + (fun (_, tree) -> + Config.protocol tree + >|= function Some p -> p = Protocol.id Irc | None -> false + ) + servers + (* filter out non-irc protocols, TODO currently relying on this to filter out non-server folders too *) + >>= fun servers -> + F.epr "protocols filtered for irc@." ; Lwt_list.iter_p - (fun (_server, tree) -> + (fun (name, tree) -> + F.epr "Irc.connect server=%s @." name ; Config.nick tree >>= fun nick -> Config.server tree >>= fun server -> Config.port tree >>= fun port -> - let server_channel = - Channel.make store ~path ~name:[server; server] in + Channel.make store ~path:(path @ [name]) ~name:topch + >>= fun server_channel -> let add_msg s = Channel.add_msg server_channel (Message.make s) in C.reconnect_loop ~after:30 @@ -159,15 +203,16 @@ module Communicator = struct C.connect_by_name ~server ~port ~nick () >>= fun c -> Lwt.return c ) ~f:(fun connection -> + F.epr "Irc.connect C.reconnect_loop ~f:(Connected...)@." ; add_msg "Connected" >>= fun () -> - get_channels ~store ~path:["irc"; server] + get_channels ~store ~path:[name] >>= fun chs -> Lwt_list.iter_p (fun chname -> C.send_join ~connection ~channel:chname >>= fun () -> - ignore (make_channel store [server] chname) ; + ignore (make_channel store [name] chname) ; Lwt.return_unit ) chs ) ~callback:(fun _connection result -> @@ -199,301 +244,227 @@ module Communicator = struct end module Panel = struct + type viewer = + { step: string + ; var: view Lwd.var + ; mutable parent: view + ; mutable node: viewer list } + + and view = [`Empty | `View of viewer] + + let add v node = + ( match v with + | `View v -> + v.node <- node :: v.node ; + Lwd.set v.var (`View v) + | `Empty -> () ) ; + node.parent <- v ; + Lwd.set node.var (`View node) ; + `View node + + let make step parent node = + let v = {step; var= Lwd.var `Empty; parent; node} in + ( match parent with + | `View parent -> + parent.node <- v :: parent.node ; + Lwd.set parent.var (`View parent) + | `Empty -> () ) ; + let rec iter = function + | [] -> () + | x :: xs -> + x.parent <- `View v ; + Lwd.set x.var (`View x) ; + iter xs in + iter node ; + Lwd.set v.var (`View v) ; + `View v + + let rec last = function + | [] -> None + | [x] -> Some x + | _ :: xs -> last xs + + let rec last_def = function + | [] -> "[]" + | [x] -> x + | _ :: xs -> last_def xs + + let find_node ~step ~view = + match view with + | `Empty -> None + | `View v -> List.find_opt (fun v' -> v'.step = step) v.node + + let string_of_path path = + "[" ^ F.str "%a" (F.list ~sep:F.semi F.string) path ^ "]" + + let remove (v : viewer) = + Lwd.set v.var `Empty ; + `Empty + + let storeview store path = + Istore.get_tree store path + >>= fun tree -> + let update d key (view : view) : view option Lwt.t = + F.epr "fold ~pre:update key=%s @." (string_of_path key) ; + Lwt.return + ( match + ( List.rev key + , find_node + ~step:(Option.value (last key) ~default:"[]") + ~view + , d ) + with + | [], None, `Added | [], None, `Updated -> + Some (make "[]" view []) + | [], Some v, _ -> Some (`View v) + | [], None, `Removed -> None + | _ :: k :: _, _, _ when k.[0] == '#' -> None + | k :: _, None, `Added | k :: _, None, `Updated -> + Some (make k view []) + | _ :: _, None, `Removed -> None + | _ :: _, Some v, _ -> Some (`View v) ) in + (* if pre returns None, the children of that node are skipped. *) + let rec map ?(key = []) ~node tree (acc : view) : view Lwt.t = + let acc = + match acc with + | `Empty -> make (last_def key) acc [] + | v -> v in + Istore.Tree.list tree [] + >>= fun tree -> + Lwt_list.iter_s + (fun (s, t) -> + let k = key @ [s] in + node k acc + >|= function + | Some a -> + F.epr "storeview Fold step=%s @." s ; + ignore (map ~key:k ~node t a) + | None -> F.epr "storeview None step=%s @." s ) + tree + >|= fun () -> acc in + map ~node:(update `Added) tree `Empty + >>= fun t -> + let root = Lwd.var t in + Istore.watch_key store path (fun diff -> + let d, tree = + match diff with + | `Added (_, tree) -> (`Added, tree) + | `Removed (_, tree) -> (`Removed, tree) + | `Updated (_, (_, tree)) -> (`Updated, tree) in + map ~node:(update d) tree t + >>= fun t' -> Lwd.set root t' ; Lwt.return_unit ) + >>= fun watch -> Lwt.return (watch, root) + open Nottui module P = Nottui_pretty 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 ~store (ch : Channel.t) : P.t Lwd.t Lwt.t = - ( match !messagelist_watch with - | Some w -> Istore.unwatch w - | None -> Lwt.return_unit ) - >>= fun () -> + let channelview (store, path) = + storeview store path + >>= fun (_watch, root) -> + let ui = + Lwd.join + (Lwd.map (Lwd.get root) ~f:(function + | `Empty -> + failwith "channelview says root Lwd.var is `Empty" + | `View v -> + let rec iter ?(indent = 0) (v : viewer) = + Lwd.bind (Lwd.get v.var) ~f:(function + | `Empty -> Lwd.return Ui.empty + | `View v' -> + let sub = + Lwd_utils.pack Ui.pack_y + (List.map + (iter ~indent:(indent + 1)) + v'.node ) in + Lwd.map sub ~f:(fun sub -> + Ui.join_y + (Nottui_widgets.string + ( String.make indent '>' ^ " " + ^ v'.step ) ) + sub ) ) in + iter v ) ) in + let chs, chs_push = Lwt_stream.create () in + Channel.make store ~path:[base_path] ~name:topch + >>= fun ch -> + chs_push (Some ch) ; + Lwt.return (chs, ui) + + let messagelist ({store; path} : Channel.t) mlist : + Istore.watch Lwt.t = let mlist' () = - let sl l = - l - >>= fun x -> - Lwt.return (List.sort String.compare (fst (List.split x))) - in - 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 + Istore.get_tree store path + >>= fun tree -> + Istore.Tree.fold ~depth:(`Eq 5) + ~contents:(fun key contents view -> + match key with + | [y; m; d; h; s] -> + Lwt.return (((y, m, d, h, s), contents) :: view) + | _ -> + F.epr + "ERROR: messagelist (fold ~depth:(`Eq 5)) got \ + wrong number of steps@." ; + Lwt.return view ) + ~node:(fun _key _node view -> + F.epr + "ERROR: messagelist (fold ~depth:(`Eq 5)) found a \ + node@." ; + Lwt.return view ) + tree [] in mlist' () - >>= fun mlist -> - let mlist = Lwd.var mlist in - Istore.watch_key store ch.path (function _ -> + >>= fun ml -> + Lwd.set mlist ml ; + Istore.watch_key store path (fun _ -> mlist' () >>= fun mlist' -> Lwt.return (Lwd.set mlist mlist') ) - >>= fun watch -> - messagelist_watch := Some watch ; + + let messageview ch = + let mlist = Lwd.var [(("", "", "", "", ""), "")] in + let rec update_messagelist watch () = + Lwt_stream.last_new ch + >>= fun ch -> + ( match watch with + | None -> Lwt.return_unit + | Some w -> Istore.unwatch w ) + >>= fun () -> + messagelist ch mlist + >>= fun watch -> update_messagelist (Some watch) () in + Lwt.async (update_messagelist None) ; + let doc = + 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 ) in 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 ) ) + (Panel.Nottui.scroll_area (Lwd.map doc ~f:(P.pretty 100))) + + let commview (store, path) = + channelview (store, List.rev (List.tl (List.rev path))) + >>= fun (ch, cv) -> + messageview ch + >>= fun mv -> + Lwt.return + (Nottui_widgets.h_pane (Panel.Nottui.scroll_area cv) mv) open Nottui_widgets - module StoreTree = struct - (* 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. - *) - - type 'a t = - {step: string; mutable super: 'a super; mutable node: 'a node} - - and 'a super = [`Tree of 'a t | `Root] - - 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 - Lwd.join - (Lwd_table.map_reduce - (fun row (tree : Tree.t) -> - let focus = - match superfocus with - | Some sf -> - Lwd.map2 (Focus.status sf) Focus.status - ~f:(fun superfocus' focus' -> - if Focus.has_focus superfocus' then - F.epr - "Focus.has_focus superfocus' = true@." ; - Focus.release sf ; - Focus.request tree.focus ; - focus' ) - | None -> Focus.status tree.focus in - Lwd.map2 - (Lwd.map focus ~f:(fun focus -> - if Focus.has_focus focus then - Lwd.set channel tree.channel ; - Ui.keyboard_area ~focus - (fun key -> - match key with - | `ASCII 'w', [] -> ( - match Lwd_table.prev row with - | Some r -> ( - match Lwd_table.get r with - | Some r -> - Focus.release tree.focus ; - Focus.request r.focus ; - `Handled - | None -> `Unhandled ) - | None -> `Unhandled ) - | `ASCII 'a', [] -> ( - match superfocus with - | Some f -> - Focus.release tree.focus ; - Focus.request f ; - `Handled - | None -> `Unhandled ) - | `ASCII 's', [] -> ( - match Lwd_table.next row with - | Some r -> ( - match Lwd_table.get r with - | Some r -> - Focus.release tree.focus ; - Focus.request r.focus ; - `Handled - | None -> `Unhandled ) - | None -> `Unhandled ) - | `ASCII 'd', [] -> - Focus.release tree.focus ; - Focus.request subfocus ; - `Handled - | _ -> `Unhandled ) - (Ui.join_x - (Ui.join_x - ( if Focus.has_focus focus then - string "+" - else string "" ) - (string (String.make indent '-')) ) - (string Tree.(tree.channel.name)) ) ) ) - (fold ~indent:(indent + 1) ~superfocus:subfocus tree) - ~f:(fun parent subs -> Ui.join_y parent subs) ) - (Lwd_utils.lift_monoid Ui.pack_y) - tree.subs ) in - (fold tree, channel) - - let messageview (ch : Channel.t Lwd.var) = - Panel.Nottui.scroll_area - (Lwd.map - (Lwd.bind (Lwd.get ch) ~f:messagelist) - ~f:(P.pretty 100) ) - - let commview c = - let cv, ch = channelview c in - Nottui_widgets.h_pane - (Panel.Nottui.scroll_area cv) - (messageview ch) - - type view = Channel of (Channel.t * view list) | Cursor of view - - let panel (comm : Tree.t) = + let panel ({store; view} : Tree.t) = let base = Lwd.var Nottui_widgets.empty_lwd in - Lwd.set base (commview comm) ; + commview (store, view) + >>= fun cv -> + Lwd.set base cv ; Panel.Nottui.panel (Lwd.join (Lwd.get base)) () end end @@ -506,8 +477,12 @@ end **) 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 + Communicator.Tree.make_top "commstore" "current" + >>= fun comm -> + Communicator.Irc.Config.make_connection comm "irc.hackint.org" + 6697 "cqcaml" + >|= fun () -> + Lwt.async (fun () -> Communicator.Irc.connect comm) ; + F.epr + "root_actor := std_actor (Communicator.Panel.panel comm)@." ; root_actor := std_actor (Communicator.Panel.panel comm) )