lol took me forever to understand lwt but finally have concurrency in the actor event processing handlers

dune

@@ -2,11 +2,10 @@
   (dev
    (flags (:standard -warn-error -A))))
 
-(executable
+(library
- (name main)
+ (name human)
  (modes byte)
- (modules main)
+ (modules human)
- (link_flags (-linkall))
  (libraries
   topinf
    lwt_ppx
@@ -26,6 +25,8 @@
  (modes byte)
  (modules irc)
  (libraries
+   human
+   lwt
    fmt
    topinf
    lwt_ppx

human.ml

@@ -22,8 +22,6 @@ module F = Fmt
 
 module Input = struct
   open CamomileLibrary
-  open Zed_edit
-  open CamomileLibrary
 
   (** Type of key code. *)
   type code =
@@ -226,7 +224,6 @@ end
 module Event = struct
   open Tsdl
   open CamomileLibrary
-  open Zed_edit
   open Input
 
   type mouse = int * int
@@ -393,8 +390,6 @@ module Display = struct
   open Tgles2
   open Tsdl
   open Gg
-  open CamomileLibrary
-  open Zed_edit
   open Wall
   module I = Image
   module P = Path
@@ -418,6 +413,7 @@ module Display = struct
      (the Wall.image extents) *)
   type image = box2 * Wall.image
   type pane = state -> state * image
+  type actor = (Event.events -> pane Lwt.t) ref
 
   let pane_empty s =
     (s, (Box2.of_pts (Box2.o s.box) (Box2.o s.box), Image.empty))
@@ -505,7 +501,7 @@ module Display = struct
     Sdl.gl_swap_window frame.sdl_win ;
     Ok ()
 
-  let display_frame frame actor =
+  let display_frame frame (actor : actor) =
     (* create and fill event list *)
     let convert_event ev =
       match Event.event_of_sdlevent ev with
@@ -519,18 +515,25 @@ module Display = struct
         events := !events @ [convert_event ev]
       done ) ;
     handle_frame_events frame !events ;
-    if List.length !events > 0 then
+    if List.length !events > 0 then (
       (* recompute the actor definition with the new events to return a new pane *)
-      frame.last_pane <- actor !events ;
+      !actor !events
-    (* call draw_pane because we should redraw now that we have updated *)
+      >>= fun p ->
-    draw_pane frame frame.last_pane
+      frame.last_pane <- p ;
+      (* call draw_pane because we should redraw now that we have updated *)
+      ignore (draw_pane frame frame.last_pane) ;
+      Lwt.return_unit )
+    else Lwt.return_unit
 
-  let run frame render () =
+  let run frame actor () =
     let frame = get_result frame in
     Sdl.show_window frame.sdl_win ;
-    while not frame.quit do
+    let rec loop () =
-      ignore (display_frame frame render)
+      ignore (display_frame frame actor) ;
-    done ;
+      Lwt_main.yield ()
+      >>= fun () ->
+      if not frame.quit then loop () else Lwt.return_unit in
+    Lwt_main.run (loop ()) ;
     print_endline "quit" ;
     Sdl.hide_window frame.sdl_win ;
     Sdl.gl_delete_context frame.gl ;
@@ -660,32 +663,27 @@ end
 
 module Panel = struct
   open Display
-  open Wall
   open Gg
 
   type t =
-    { mutable act: t -> Event.events -> t * Display.pane
+    { mutable act: t -> Event.events -> (t * Display.pane) Lwt.t
     ; mutable subpanels: t list
     ; mutable tag: string }
 
-  type actor = Event.events -> Display.pane
-
   let blank =
-    { act= (fun panel _events -> (panel, Display.pane_empty))
+    { act=
+        (fun panel _events -> Lwt.return (panel, Display.pane_empty))
     ; subpanels= []
     ; tag= "blank pane" }
 
   let draw (pane : Display.pane) =
-    { act= (fun panel _events -> (panel, pane))
+    { act= (fun panel _events -> Lwt.return (panel, pane))
     ; subpanels= []
     ; tag= "draw-pane" }
 
-  let actor (panel : t) : Event.events -> Display.pane =
+  let actor (panel : t) : Event.events -> Display.pane Lwt.t =
-    let enclosure = ref panel in
+   fun events ->
-    fun events ->
+    panel.act panel events >>= fun (_panel, pane) -> Lwt.return pane
-      let panel, pane = panel.act !enclosure events in
-      enclosure := panel ;
-      pane
 
   let filter_events ef p =
     {p with act= (fun panel events -> p.act panel (ef events))}
@@ -694,12 +692,13 @@ module Panel = struct
   let vbox subpanels =
     { act=
         (fun panel events ->
-          ( panel
+          Lwt_list.map_p
-          , pane_box Box2.tl_pt
+            (fun subpanel ->
-              (* tl_pt is actually bl_pt in the Wall coordinate system *)
+              subpanel.act subpanel events
-              (List.map
+              >>= fun (_panel, pane) -> Lwt.return pane )
-                 (fun subpanel -> snd (subpanel.act subpanel events))
+            panel.subpanels
-                 panel.subpanels ) ) )
+          >>= fun pl -> Lwt.return (panel, pane_box Box2.tl_pt pl) )
+        (* tl_pt is actually bl_pt in the Wall coordinate system *)
     ; subpanels
     ; tag= "vertical-box" }
 
@@ -707,12 +706,13 @@ module Panel = struct
   let hbox subpanels =
     { act=
         (fun panel events ->
-          ( panel
+          Lwt_list.map_p
-          , pane_box Box2.br_pt
+            (fun subpanel ->
-              (* br_pt is actually tr_pt in the Wall coordinate system *)
+              subpanel.act subpanel events
-              (List.map
+              >>= fun (_panel, pane) -> Lwt.return pane )
-                 (fun subpanel -> snd (subpanel.act subpanel events))
+            panel.subpanels
-                 panel.subpanels ) ) )
+          >>= fun pl -> Lwt.return (panel, pane_box Box2.br_pt pl) )
+        (* br_pt is actually tr_pt in the Wall coordinate system *)
     ; subpanels
     ; tag= "horizontal-box" }
 
@@ -720,11 +720,12 @@ module Panel = struct
   let obox subpanels =
     { act=
         (fun panel events ->
-          ( panel
+          Lwt_list.map_p
-          , pane_box Box2.o
+            (fun subpanel ->
-              (List.map
+              subpanel.act subpanel events
-                 (fun subpanel -> snd (subpanel.act subpanel events))
+              >>= fun (_panel, pane) -> Lwt.return pane )
-                 panel.subpanels ) ) )
+            panel.subpanels
+          >>= fun pl -> Lwt.return (panel, pane_box Box2.o pl) )
     ; subpanels
     ; tag= "origin-box" }
 
@@ -843,10 +844,12 @@ module Panel = struct
       ; out_spaces=
           (fun n -> add_symbolic_output_item sob (Output_spaces n)) }
 
-  let prettyprint ?(height = !g_text_height) fpp =
+  let prettyprint ?(height = !g_text_height) ?(tag = "pretty-print")
-    { act= (fun panel _events -> (panel, draw_pp height fpp))
+      fpp =
+    { act=
+        (fun panel _events -> Lwt.return (panel, draw_pp height fpp))
     ; subpanels= []
-    ; tag= "pretty-print" }
+    ; tag }
 
   module Textedit = struct
     let bindings =
@@ -963,14 +966,13 @@ module Panel = struct
                   Format.pp_open_hvbox pp 0 ;
                   F.text pp before_cursor ;
                   Format.pp_open_stag pp
-                    Display.(
+                    (Cursor (Wall.Color.v 0.99 0.99 0.125 0.3)) ;
-                      Cursor (Wall.Color.v 0.99 0.99 0.125 0.3)) ;
                   F.pf pp "" ;
                   Format.pp_close_stag pp () ;
                   F.text pp after_cursor ;
                   F.pf pp "@." ;
                   Format.pp_close_box pp () ) in
-            (panel, draw_textedit) )
+            Lwt.return (panel, draw_textedit) )
       ; subpanels= []
       ; tag= "textedit" }
 
@@ -979,31 +981,34 @@ module Panel = struct
         =
       { act=
           (fun panel _events ->
-            ( panel
+            Lwt.return
-            , draw_pp height (fun pp ->
+              ( panel
-                  Format.pp_open_hbox pp () ;
+              , draw_pp height (fun pp ->
-                  F.text pp
+                    Format.pp_open_hbox pp () ;
-                    (List.fold_left
+                    F.text pp
-                       (fun s x -> Input.to_string_compact x ^ " " ^ s)
+                      (List.fold_left
-                       "" b.last_keyseq ) ;
+                         (fun s x ->
-                  F.text pp "-> " ;
+                           Input.to_string_compact x ^ " " ^ s )
-                  F.text pp
+                         "" b.last_keyseq ) ;
-                    ( match b.state with
+                    F.text pp "-> " ;
-                    | Accepted a ->
+                    F.text pp
-                        "Accepted "
+                      ( match b.state with
-                        ^ List.fold_right
+                      | Accepted a ->
-                            (fun x s ->
+                          "Accepted "
-                              s
+                          ^ List.fold_right
-                              ^ Input.Bind.(
+                              (fun x s ->
-                                  match x with
+                                s
-                                  | Zed a -> Zed_edit.name_of_action a
+                                ^ Input.Bind.(
-                                  | Custom _ -> "Custom")
+                                    match x with
-                              ^ "; " )
+                                    | Zed a ->
-                            a ""
+                                        Zed_edit.name_of_action a
-                    | Rejected -> "Rejected"
+                                    | Custom _ -> "Custom")
-                    | Continue _ -> "Continue" ) ;
+                                ^ "; " )
-                  Format.pp_close_box pp () ;
+                              a ""
-                  F.flush pp () ) ) )
+                      | Rejected -> "Rejected"
+                      | Continue _ -> "Continue" ) ;
+                    Format.pp_close_box pp () ;
+                    F.flush pp () ) ) )
       ; subpanels= []
       ; tag= "binding-state" }
   end
@@ -1038,7 +1043,7 @@ module Panel = struct
             | Some text ->
                 Textedit.insert me.te text ;
                 (hbox panel.subpanels).act panel events
-            | None -> (panel, Display.pane_empty)
+            | None -> Lwt.return (panel, Display.pane_empty)
             (* don't draw anything if modal isn't active *) )
       ; subpanels=
           [ prettyprint (fun pp -> F.text pp me.prompt)
@@ -1063,8 +1068,8 @@ module Toplevel = struct
 
   let init () =
     let sob = Format.make_symbolic_output_buffer () in
-    let ppf = Format.formatter_of_symbolic_output_buffer sob in
+    Topinf.ppf := Format.formatter_of_symbolic_output_buffer sob ;
-    {eval= Topinf.init ppf; res= sob}
+    {eval= !Topinf.eval; res= sob}
 
   let eval t str =
     let ppf = Format.formatter_of_symbolic_output_buffer t.res in
@@ -1094,7 +1099,8 @@ module Store = struct
     { store: Istore.t
     ; mutable view: Istore.key
     ; mutable selection: Istore.key
-    ; mutable editmode: bool }
+    ; mutable editmode: bool
+    ; sob: Format.symbolic_output_buffer }
 
   let make_storeview ?(path = []) storepath branch =
     Lwt_main.run
@@ -1109,7 +1115,8 @@ module Store = struct
         { store
         ; view
         ; selection= Istore.Key.v [fst (List.hd viewlist)]
-        ; editmode= false } )
+        ; editmode= false
+        ; sob= Format.make_symbolic_output_buffer () } )
 
   let directives (top : Toplevel.t) sv =
     let dir_use_key key_lid =
@@ -1223,22 +1230,56 @@ module Store = struct
         >>= function
         | Some `Node -> Lwt.return_true | _ -> Lwt.return_false )
     in
+    let update_storeview () =
+      ignore (Format.flush_symbolic_output_buffer sv.sob) ;
+      let pp = Format.formatter_of_symbolic_output_buffer sv.sob in
+      let rec draw_levels ?(indent = 0) (sel : Istore.key)
+          (tree : Istore.tree) : unit Lwt.t =
+        Istore.Tree.list tree []
+        >>= Lwt_list.iteri_s (fun _i (step, node) ->
+                Format.pp_open_box pp indent ;
+                if sel = [step] then (
+                  Format.pp_open_stag pp
+                    (Panel.Cursor (Wall.Color.v 0.99 0.99 0.125 0.3)) ;
+                  F.pf pp "@," ;
+                  Format.pp_close_stag pp () ) ;
+                Istore.Tree.kind node []
+                >>= fun k ->
+                ( match k with
+                | Some `Contents ->
+                    F.pf pp "- %s@." step ; Lwt.return_unit
+                | Some `Node ->
+                    F.pf pp "> %s@." step ;
+                    let subsel =
+                      match Istore.Key.decons sel with
+                      | Some (_tstep, subkey) -> subkey
+                      | None -> [] in
+                    Format.pp_open_vbox pp 0 ;
+                    draw_levels ~indent:(indent + 1) subsel node
+                    >>= fun () ->
+                    Format.pp_close_box pp () ;
+                    Lwt.return_unit
+                | None -> F.pf pp "ERROR: None" ; Lwt.return_unit )
+                >>= fun () ->
+                Format.pp_close_box pp () ;
+                Lwt.return_unit ) in
+      Istore.get_tree sv.store sv.view >>= draw_levels sv.selection
+    in
     let update_textedit () =
       Panel.Textedit.clear te ;
-      Lwt_main.run
+      Istore.get_tree sv.store sv.view
-        ( Istore.get_tree sv.store sv.view
+      >>= fun t ->
-        >>= fun t ->
+      Istore.Tree.kind t sv.selection
-        Istore.Tree.kind t sv.selection
+      >>= function
-        >>= function
+      | Some `Contents ->
-        | Some `Contents ->
+          Istore.Tree.get t sv.selection
-            Istore.Tree.get t sv.selection
+          >>= fun content ->
-            >>= fun content ->
+          Panel.Textedit.insert te content ;
-            Panel.Textedit.insert te content ;
+          Lwt.return_unit
-            Lwt.return_unit
+      | Some `Node ->
-        | Some `Node ->
+          Panel.Textedit.insert te "Node..." ;
-            Panel.Textedit.insert te "Node..." ;
+          Lwt.return_unit
-            Lwt.return_unit
+      | None -> Lwt.return_unit in
-        | None -> Lwt.return_unit ) in
     let navbinds =
       let open Input.Bind in
       let new_contents name content =
@@ -1260,7 +1301,8 @@ module Store = struct
       @@ add [([], Char 's')] [Custom (navigate sv `Next)]
       @@ add [([], Char 'd')] [Custom (navigate sv `Sub)]
       @@ add [([], Char 'a')] [Custom (navigate sv `Sup)]
-      @@ add [([], Char 'e')]
+      @@ add
+           [([], Char 'e')] (* enter edit mode *)
            [ Custom
                (fun () ->
                  if not (is_node sv.selection) then
@@ -1305,19 +1347,20 @@ module Store = struct
            [([], Char 'x')] (* execute contents/node *)
            [ Custom
                (fun () ->
-                 Panel.Modal.start ~prompt:"!!Not implemented!!"
+                 Toplevel.eval top (Panel.Textedit.contents te) ) ]
-                   modalstate "" (fun _ -> ()) ) ]
            empty in
     let bindstate = Input.Bind.init navbinds in
     { act=
         (fun panel events ->
-          if
+          ( if
             (not sv.editmode)
             && not (Panel.Modal.is_active modalstate)
           then (
             Input.Bind.process bindstate events ;
-            update_textedit () ) ;
+            Lwt.join [update_storeview (); update_textedit ()] )
-          (Panel.vbox panel.subpanels).act panel events )
+          else Lwt.return_unit )
+          >>= fun () -> (Panel.vbox panel.subpanels).act panel events
+          )
     ; subpanels=
         [ Panel.filter_events
             (fun ev ->
@@ -1325,39 +1368,8 @@ module Store = struct
             (Panel.Modal.panel modalstate)
         ; Panel.hbox
             [ Panel.prettyprint (fun pp ->
-                  let rec draw_levels ?(indent = 0)
+                  Panel.format_symbolic_output_buffer pp
-                      (tree : Istore.tree) (sel : Istore.key) =
+                    (Format.get_symbolic_output_buffer sv.sob) )
-                    List.iteri
-                      (fun _i (step, node) ->
-                        Format.pp_open_box pp indent ;
-                        if sel = [step] then (
-                          Format.pp_open_stag pp
-                            Display.(
-                              Panel.Cursor
-                                (Wall.Color.v 0.99 0.99 0.125 0.3)) ;
-                          F.pf pp "@," ;
-                          Format.pp_close_stag pp () ) ;
-                        ( match
-                            Lwt_main.run (Istore.Tree.kind node [])
-                          with
-                        | Some `Contents -> F.pf pp "- %s@." step
-                        | Some `Node ->
-                            F.pf pp "> %s@." step ;
-                            let subsel =
-                              match Istore.Key.decons sel with
-                              | Some (_tstep, subkey) -> subkey
-                              | None -> [] in
-                            Format.pp_open_vbox pp 0 ;
-                            draw_levels ~indent:(indent + 1) node
-                              subsel ;
-                            Format.pp_close_box pp ()
-                        | None -> F.pf pp "ERROR: None" ) ;
-                        Format.pp_close_box pp () )
-                      (Lwt_main.run (Istore.Tree.list tree [])) in
-                  let root =
-                    Lwt_main.run (Istore.get_tree sv.store sv.view)
-                  in
-                  draw_levels root sv.selection )
             ; Panel.vbox
                 [ Panel.filter_events
                     (fun ev -> if sv.editmode then ev else [])
@@ -1375,109 +1387,18 @@ module Store = struct
     ; tag= "store-editor" }
 end
 
-open Wall
+let std_actor root_panel =
-open Gg
+  Panel.actor
-module I = Image
+    (Panel.obox
-module P = Path
+       [ Panel.draw (fun (s : Display.state) ->
-module Text = Wall_text
+             (s, Display.fill_box (Display.gray 0.125) s.box) )
+       ; root_panel ] )
 
-type top =
+let root_actor = ref (std_actor (Store.editor "../rootstore"))
-  { te: Panel.Textedit.t
-  ; res: Format.symbolic_output_buffer
-  ; mutable eval: Topinf.evalenv option
-  ; mutable path: string list
-  ; mutable histpath: string list
-  ; storeview: Store.storeview }
 
-let make_top storepath ?(branch = "current") () =
+let start () =
-  let t =
+  Display.(
-    { te= Panel.Textedit.make "" ()
+    run (make_frame ~title:"hi" ~w:1440 ~h:900 ()) root_actor ())
-    ; res= Format.make_symbolic_output_buffer ()
-    ; eval= None
-    ; path= ["init"]
-    ; histpath= ["history"]
-    ; storeview= Store.make_storeview storepath branch } in
-  Topinf.ppf := Format.formatter_of_symbolic_output_buffer t.res ;
-  (* Format.pp_set_formatter_out_functions Format.std_formatter
-     (out_funs_of_sob t.res) ;*)
-  Panel.Textedit.insert t.te
-    (Lwt_main.run (Store.Istore.get t.storeview.store t.path)) ;
-  t
-
-let top_panel (t : top) =
-  let ppf = Format.formatter_of_symbolic_output_buffer t.res in
-  Topinf.ppf := ppf ;
-  let eval =
-    match t.eval with
-    (* HACK use Lazy.? *)
-    | None ->
-        let e =
-          match !Topinf.eval with
-          | Some e -> e
-          | None -> Topinf.init ppf in
-        t.eval <- Some e ;
-        e
-    | Some e -> e in
-  let eval () =
-    try
-      ignore
-        (Lwt_main.run
-           ( Store.Istore.tree t.storeview.store
-           >>= fun tree ->
-           Store.Istore.Tree.add tree
-             (t.histpath @ ["input"])
-             (Panel.Textedit.contents t.te) ) ) ;
-      ignore (Format.flush_symbolic_output_buffer t.res) ;
-      eval ppf (Panel.Textedit.contents t.te ^ ";;") ;
-      (*HACK to prevent getting stuck in parser*)
-      let b = Buffer.create 69 in
-      Panel.format_symbolic_output_buffer
-        (Format.formatter_of_buffer b)
-        (Format.get_symbolic_output_buffer t.res) ;
-      ignore
-        (Lwt_main.run
-           ( Store.Istore.tree t.storeview.store
-           >>= fun tree ->
-           Store.Istore.Tree.add tree
-             (t.histpath @ ["output"])
-             (Buffer.contents b) ) ) ;
-      ignore
-        (Lwt_main.run
-           (Store.Istore.set_exn t.storeview.store
-              ~info:(Irmin_unix.info "history")
-              t.path
-              (Panel.Textedit.contents t.te) ) ) ;
-      Panel.Textedit.clear t.te
-    with e ->
-      F.pf ppf "Exception in pane_top//eval@." ;
-      Location.report_exception ppf e ;
-      F.epr "Exception in pane_top//eval@." in
-  t.te.keybind.bindings <-
-    Input.(
-      Bind.add
-        [([Ctrl], Code Enter)]
-        Bind.[Custom eval]
-        t.te.keybind.bindings) ;
-  Panel.(
-    vbox
-      [ Textedit.panel t.te
-      ; prettyprint (fun pp ->
-            Format.pp_open_hovbox pp 0 ;
-            format_symbolic_output_buffer pp
-              (Format.get_symbolic_output_buffer t.res) ;
-            Format.pp_close_box pp () ;
-            F.flush pp () ) (*; draw_textedit_input height t.te *) ])
-
-(*let top_1 = make_top "../rootstore" () *)
-
-let () =
-  let actor =
-    Panel.actor
-      (Panel.obox
-         [ Panel.draw (fun (s : Display.state) ->
-               (s, Display.fill_box (Display.gray 0.125) s.box) )
-         ; Store.editor "../rootstore" ] ) in
-  Display.(run (make_frame ~title:"hi" ~w:1440 ~h:900 ()) actor) ()
 
 (* Implement the "window management" as just toplevel defined functions that manipulate the window tree *)
 

init.ml

@@ -6,11 +6,13 @@ let print_directives () =
   Format.printf "directive_info_table:@.";
   Hashtbl.iter (fun n _ -> Format.printf "\t%s@." n) Topinf.directive_info_table;;
 
-#directory "+compiler-libs";;
+(*#directory "+compiler-libs";; *)
 
 let print_modules () =
   Format.printf "Env.fold_modules !Topinf.toplevel_env :\n";
   Env.fold_modules (fun modname _ _ () -> Format.printf "\t%s@." modname) None !Topinf.toplevel_env ();;
+(*print_modules ();;*)
 
-#use_silently "main.ml";;
+#use_silently "human.ml";;
 
+start ();;

irc.ml

@@ -1,109 +1,109 @@
 (*
-
 when all you can do is type, making things more complicated than a list is hard?
 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.
-
 *)
 
 open Lwt
-module C = Irc_client_tls
+open Lwt_react
-module M = Irc_message
+module F = Fmt
 
-let host = ref "irc.hackint.org"
+module Communicator = struct
-let port = ref 6697
+  type msg = {content: string; time: string; mutable seen: bool}
-let nick = ref "cqcaml"
-let channel = ref "#freeside"
-let message = "Hello, world!  This is a test from ocaml-irc-client"
 
-let output_channel_of_ppf ppf =
+  let create_msg ?(time = "<ts>") content =
-  Lwt_io.make ~mode:Output (fun b o l ->
+    {content; time; seen= false}
-      let s = String.sub (Lwt_bytes.to_string b) o l in
-      Fmt.pf ppf "%s" s ;
-      Lwt.return (String.length s) )
 
-let callback connection result =
+  type channel =
-  match result with
+    { mutable name: string
-  | Result.Ok ({M.command= M.Other _; _} as msg) ->
+    ; mutable content: msg list
-      Lwt_io.printf "Got unknown message: %s\n" (M.to_string msg)
+    ; mutable sender: string -> unit }
-      >>= fun () -> Lwt_io.flush Lwt_io.stdout
-  | Result.Ok ({M.command= M.PRIVMSG (_target, data); _} as msg) ->
-      Lwt_io.printf "Got message: %s\n" (M.to_string msg)
-      >>= fun () ->
-      Lwt_io.flush Lwt_io.stdout
-      >>= fun () ->
-      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
-  | Result.Error e -> Lwt_io.printl e
 
-let lwt_main () =
+  let add_msg (c : channel) msg = c.content <- msg :: c.content
-  C.reconnect_loop ~after:30
+
-    ~connect:(fun () ->
+  type c = {mutable channel: channel; mutable subs: c list}
-      Lwt_io.printl "Connecting..."
+  type protocol = Irc | Email | Rss | Mublog
-      >>= fun () ->
+
-      C.connect_by_name ~server:!host ~port:!port ~nick:!nick () )
+  let make_channel (c : c) ?(sender = fun _ -> ()) name =
-    ~f:(fun connection ->
+    c.subs <-
-      Lwt_io.printl "Connected"
+      {channel= {name; content= []; sender}; subs= []} :: c.subs
-      >>= fun () ->
+
-      Lwt_io.printl "send join msg"
+  let make () : c =
-      >>= fun () ->
+    let c =
-      C.send_join ~connection ~channel:!channel
+      { name= "top"
-      >>= fun () ->
+      ; content= [create_msg "Wecome to the Communicator"]
-      C.send_privmsg ~connection ~target:!channel ~message )
+      ; sender= (fun _ -> ()) } in
-    ~callback ()
+    c.sender <- (fun s -> c.content <- create_msg s :: c.content) ;
+    c.sender "Currently only IRC is implemented" ;
+    {channel= c; subs= []}
+
+  type connection = unit Lwt.t
+
+  module Irc = struct
+    module C = Irc_client_tls
+    module M = Irc_message
+
+    let connection (c : c) server port nick channels : unit Lwt.t =
+      let add_msg cn str = add_msg cn.channel (create_msg str) in
+      C.reconnect_loop ~after:30
+        ~connect:(fun () ->
+          Lwt_io.printl "Connecting..."
+          >>= fun () -> C.connect_by_name ~server ~port ~nick () )
+        ~f:(fun connection ->
+          Lwt_io.printl "Connected"
+          >>= fun () ->
+          Lwt_list.iter_p
+            (fun channel ->
+              let joiner = C.send_join ~connection ~channel in
+              (* make_channel c ~sender:(fun s ->
+                   C.send_privmsg ~target:channel ~message:s) channel ; *)
+              joiner )
+            channels )
+        ~callback:(fun _connection result ->
+          match result with
+          | Result.Ok ({M.command= M.Other _; _} as msg) ->
+              add_msg c
+                (F.str "Got unknown message: %s\n" (M.to_string msg)) ;
+              Lwt.return_unit
+          | Result.Ok ({M.command= M.PRIVMSG (target, data); _} as msg)
+            ->
+              add_msg c
+                (F.str "Got PRIVMSG: target=%s, data=%s; %s\n" target
+                   data (M.to_string msg) ) ;
+              Lwt.return_unit
+          | Result.Ok msg ->
+              add_msg c (M.to_string msg) ;
+              Lwt.return_unit
+          | Result.Error e -> Lwt_io.printl e )
+        ()
+  end
+
+  module Panel = struct
+    let panel c =
+      Panel.prettyprint ~height:20. ~tag:"Communicator" (fun pp ->
+          F.pf pp " <><><> COMMUNICATOR <><><> @.@." ;
+          List.iter
+            (fun msg -> F.pf pp "[%s] %s@." msg.time msg.content)
+            c.channel.content )
+  end
+end
 
 let _ =
-  Lwt_main.run
+  let comm = Communicator.make () in
-    (Lwt.catch lwt_main (fun e ->
+  let hackint =
-         Printf.printf "exception: %s\n" (Printexc.to_string e) ;
+    Communicator.Irc.connection comm "irc.hackint.org" 6697 "cqcaml"
-         exit 1 ) )
+      ["#CQC"] in
+  root_actor := std_actor (Communicator.Panel.panel comm) ;
+  Lwt.async (fun () -> hackint)
 
-(* ocamlfind ocamlopt -package irc-client.lwt -linkpkg code.ml *)
+(**
-
+   program starts...
-(*open Lwt
+   - spawn connections to servers
-  module C = Irc_client_lwt
+   - these connections will populate the Channel.t in a Channel.tree
-
+       
-  let host = "irc.hackint.org"
+ **)
-  let port = 6697
-  let realname = "Demo IRC bot"
-  let nick = "cqcqcqcqc"
-  let username = nick
-  let channel = "#freeside"
-  let message = "Hello, world!  This is a test from ocaml-irc-client"
-
-  let callback oc _connection result =
-    let open Irc_message in
-    match result with
-    | Result.Ok msg ->
-        Fmt.epr "irc msg: msg" ;
-        Lwt_io.fprintf oc "Got message: %s\n" (to_string msg)
-    | Result.Error e -> Lwt_io.fprintl oc e
-
-  let lwt_main =
-    let oc = output_channel_of_ppf !Topinf.ppf in
-    Lwt_unix.gethostbyname host
-    >>= fun he ->
-    C.connect
-      ~addr:he.Lwt_unix.h_addr_list.(0)
-      ~port ~username ~mode:0 ~realname ~nick ()
-    >>= fun connection ->
-    Lwt_io.fprintl oc "Connected"
-    >>= fun () ->
-    C.send_join ~connection ~channel
-    >>= fun () ->
-    C.send_privmsg ~connection ~target:channel ~message
-    >>= fun () ->
-    C.listen ~connection ~callback:(callback oc) ()
-    >>= fun () -> C.send_quit ~connection ()
-
-  let _ = Lwt_main.run lwt_main
-*)

topinf.ml

@@ -44,7 +44,7 @@ let toplevel_value_bindings : Obj.t String.Map.t ref =
   ref String.Map.empty
 
 let ppf = ref Format.std_formatter
-let eval = ref None
+let eval = ref (fun _ _ -> ())
 
 let getvalue name =
   try String.Map.find name !toplevel_value_bindings
@@ -2398,5 +2398,5 @@ let init ppf =
   Location.input_phrase_buffer := Some phrase_buffer ;
   Sys.catch_break true ;
   run_hooks After_setup ;
-  eval := Some (eval_fun lb) ;
+  eval := eval_fun lb ;
   eval_fun lb

topinf.mli

@@ -26,5 +26,5 @@ val add_directive :
 
 val directive_info_table : (string, directive_info) Hashtbl.t
 val ppf : Format.formatter ref
-val eval : evalenv option ref
+val eval : evalenv ref
 val eval_value_path : Env.t -> Path.t -> Obj.t