little re-arranging

.console

@@ -0,0 +1 @@
+it consoles you

.ocamlformat

@@ -1 +0,0 @@
-profile = compact

backend.ml

@@ -0,0 +1,205 @@
+module F = Fmt
+
+module Key = struct
+  type special =
+    [ `Enter
+    | `Escape
+    | `Tab
+    | `Arrow of [`Up | `Down | `Left | `Right]
+    | `Function of int
+    | `Page of [`Up | `Down]
+    | `Home
+    | `End
+    | `Insert
+    | `Delete
+    | `Backspace ]
+
+  (** Type of key code. *)
+  type code =
+    [`Uchar of Uchar.t  (** A unicode character. *) | special]
+
+  type keystate =
+    {ctrl: bool; meta: bool; shift: bool; super: bool; code: code}
+
+  module KeyS = struct
+    type t = keystate
+
+    let compare = compare
+  end
+
+  module Bind = struct
+    (* parts stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *)
+    module S = Zed_input.Make (KeyS)
+
+    type 'a t = 'a list S.t
+    type 'a resolver = 'a list S.resolver
+    type 'a result = 'a list S.result
+
+    type 'a state =
+      { mutable bindings: 'a t
+      ; mutable state: 'a result
+      ; mutable last_keyseq: keystate list
+      ; mutable last_actions: 'a list }
+
+    type mods = Ctrl | Meta | Super | Shift
+    type key = C of char | U of code
+
+    let keystate_of_mods ks m =
+      List.fold_left
+        (fun ks m ->
+          match m with
+          | Meta -> {ks with meta= true}
+          | Ctrl -> {ks with ctrl= true}
+          | Super -> {ks with super= true}
+          | Shift -> {ks with shift= true} )
+        ks m
+
+    let add events action bindings =
+      let events =
+        List.map
+          (fun (m, k) ->
+            keystate_of_mods
+              { meta= false
+              ; ctrl= false
+              ; super= false
+              ; shift= false
+              ; code=
+                  ( match k with
+                  | C c -> `Uchar (Uchar.of_char c)
+                  | U c -> c ) }
+              m )
+          events in
+      S.add events action bindings
+
+    let default_resolver b = S.resolver [S.pack (fun x -> x) b]
+
+    let get_resolver result default =
+      match result with S.Continue r -> r | _ -> default
+
+    let init bindings =
+      {bindings; state= S.Rejected; last_keyseq= []; last_actions= []}
+
+    let resolve = S.resolve
+    let empty = S.empty
+
+    type action =
+      | Custom of (unit -> unit)
+      | CustomLwt of (unit -> unit Lwt.t)
+      | Zed of Zed_edit.action
+
+    let resolve_events (state : 'a state) events =
+      List.flatten
+        (List.filter_map
+           (fun e ->
+             match e with
+             | `Key (`Press, (k : keystate)) -> (
+                 ( match state.state with
+                 | Continue _ -> ()
+                 | _ -> state.last_keyseq <- [] ) ;
+                 state.state <-
+                   resolve k
+                     (get_resolver state.state
+                        (default_resolver state.bindings) ) ;
+                 state.last_keyseq <- k :: state.last_keyseq ;
+                 match state.state with
+                 | Accepted a ->
+                     state.last_actions <- a ;
+                     Some a
+                 | Rejected ->
+                     state.last_actions <- [] ;
+                     None
+                 | _ -> None )
+             | _ -> None )
+           events )
+
+    let actions_of_events (state : action state) events =
+      List.flatten
+        (List.filter_map
+           (fun e ->
+             match e with
+             | `Key (`Press, (k : keystate)) -> (
+                 ( match state.state with
+                 | Continue _ -> ()
+                 | _ -> state.last_keyseq <- [] ) ;
+                 state.state <-
+                   resolve k
+                     (get_resolver state.state
+                        (default_resolver state.bindings) ) ;
+                 state.last_keyseq <- k :: state.last_keyseq ;
+                 match state.state with
+                 | Accepted a ->
+                     state.last_actions <- a ;
+                     Some a
+                 | Rejected ->
+                     state.last_actions <- [] ;
+                     None
+                 | _ -> None )
+             | _ -> None )
+           events )
+
+    let process bindstate events =
+      Lwt_list.iter_s
+        (function
+          | Custom f -> Lwt.return (f ())
+          | CustomLwt f -> f ()
+          | Zed _ -> Lwt.return_unit )
+        (actions_of_events bindstate events)
+  end
+
+  (* stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *)
+  let string_of_code = function
+    | `Uchar ch ->
+        if Uchar.is_char ch then F.str "Char '%c'" (Uchar.to_char ch)
+        else F.str "Char 0x%02x" (Uchar.to_int ch)
+    | `Enter -> "Enter"
+    | `Escape -> "Escape"
+    | `Tab -> "Tab"
+    | `Arrow `Up -> "Up"
+    | `Arrow `Down -> "Down"
+    | `Arrow `Left -> "Left"
+    | `Arrow `Right -> "Right"
+    | `Function i -> F.str "F%d" i
+    | `Page `Up -> "Page Up"
+    | `Page `Down -> "Page Down"
+    | `Home -> "Home"
+    | `End -> "End"
+    | `Insert -> "Insert"
+    | `Delete -> "Delete"
+    | `Backspace -> "Backspace"
+
+  let to_string key =
+    Printf.sprintf
+      "{ control = %B; meta = %B; shift = %B; super = %B; code = %s }"
+      key.ctrl key.meta key.shift key.super
+      (string_of_code key.code)
+
+  let to_string_compact key =
+    let buffer = Buffer.create 32 in
+    if key.ctrl then Buffer.add_string buffer "Ctrl-" ;
+    if key.meta then Buffer.add_string buffer "Meta-" ;
+    if key.shift then Buffer.add_string buffer "Shift-" ;
+    if key.super then Buffer.add_string buffer "Super-" ;
+    ( match key.code with
+    | `Uchar ch ->
+        let code = Uchar.to_int ch in
+        if Uchar.is_char ch then
+          match Uchar.to_char ch with
+          | ( 'a' .. 'z'
+            | 'A' .. 'Z'
+            | '0' .. '9'
+            | '_' | '(' | ')' | '[' | ']' | '{' | '}' | '#' | '~'
+            | '&' | '$' | '*' | '%' | '!' | '?' | ',' | ';' | ':'
+            | '/' | '\\' | '.' | '@' | '=' | '+' | '-' ) as ch ->
+              Buffer.add_char buffer ch
+          | ' ' -> Buffer.add_string buffer "space"
+          | _ -> Printf.bprintf buffer "U+%02x" code
+        else if code <= 0xffff then
+          Printf.bprintf buffer "U+%04x" code
+        else Printf.bprintf buffer "U+%06x" code
+    | `Page `Down -> Buffer.add_string buffer "pgup"
+    | `Page `Up -> Buffer.add_string buffer "pgdn"
+    | code ->
+        Buffer.add_string buffer
+          (String.lowercase_ascii (string_of_code code)) ) ;
+    Buffer.contents buffer
+end

backend_js.ml

@@ -0,0 +1,7 @@
+include Backend
+
+module Keycode = struct
+  open Js_of_ocaml
+
+  type t = Dom_html.Keyboard_code.t
+end

backend_sdl.ml

@@ -0,0 +1,438 @@
+module Key = struct
+  let sdlkey_map = Hashtbl.create 1024
+
+  let () =
+    let aa (x : int) (y : Key.code) = Hashtbl.add sdlkey_map x y in
+    aa return `Enter ;
+    aa escape `Escape ;
+    aa backspace `Backspace ;
+    aa tab `Tab ;
+    aa f1 (`Function 1) ;
+    aa f2 (`Function 2) ;
+    aa f3 (`Function 3) ;
+    aa f4 (`Function 4) ;
+    aa f5 (`Function 5) ;
+    aa f6 (`Function 6) ;
+    aa f7 (`Function 7) ;
+    aa f8 (`Function 8) ;
+    aa f9 (`Function 9) ;
+    aa f10 (`Function 10) ;
+    aa f11 (`Function 11) ;
+    aa f12 (`Function 12) ;
+    aa insert `Insert ;
+    aa delete `Delete ;
+    aa home `Home ;
+    aa kend `End ;
+    aa pageup (`Page `Up) ;
+    aa pagedown (`Page `Down) ;
+    aa right (`Arrow `Right) ;
+    aa left (`Arrow `Left) ;
+    aa down (`Arrow `Down) ;
+    aa up (`Arrow `Up)
+
+  let key_of_sdlkey ev =
+    let (kc : Sdl.keycode) =
+      Sdl.Event.get ev Sdl.Event.keyboard_keycode
+      land lnot Sdl.K.scancode_mask in
+    match (Hashtbl.find_opt sdlkey_map kc, Uchar.is_valid kc) with
+    | Some s, _ -> Some s
+    | None, true -> Some (`Uchar (Uchar.of_int kc))
+    | None, false -> None
+
+  let event_of_sdlevent ev : t option =
+    match Sdl.Event.enum (Sdl.Event.get ev Sdl.Event.typ) with
+    | (`Key_down | `Key_up) as d -> (
+      match key_of_sdlkey ev with
+      | None -> None
+      | Some code ->
+          let km = Sdl.Event.get ev Sdl.Event.keyboard_keymod in
+          Some
+            (`Key
+              ( ( match d with
+                | _
+                  when Sdl.Event.get ev Sdl.Event.keyboard_repeat > 1
+                  ->
+                    `Repeat
+                | `Key_up -> `Release
+                | _ -> `Press )
+              , { code
+                ; ctrl= km land Sdl.Kmod.ctrl > 0
+                ; meta= km land Sdl.Kmod.alt > 0
+                ; super= km land Sdl.Kmod.gui > 0
+                ; shift= km land Sdl.Kmod.shift > 0 } ) ) )
+    | `Mouse_motion ->
+        let x, y = snd (Tsdl.Sdl.get_mouse_state ()) in
+        Some (`Mouse (V2.v (float x) (float y)))
+    | `Quit -> Some `Quit
+    (* Unhandled events *)
+    | `Text_editing -> Some (`Unknown "`Text_editing")
+    | `Text_input -> Some (`Unknown "`Text_input")
+    | `App_did_enter_background ->
+        Some (`Unknown "`App_did_enter_background")
+    | `App_did_enter_foreground ->
+        Some (`Unknown "`App_did_enter_foreground ")
+    | `App_low_memory -> Some (`Unknown "`App_low_memory ")
+    | `App_terminating -> Some (`Unknown "`App_terminating ")
+    | `App_will_enter_background ->
+        Some (`Unknown "`App_will_enter_background ")
+    | `App_will_enter_foreground ->
+        Some (`Unknown "`App_will_enter_foreground ")
+    | `Clipboard_update -> Some (`Unknown "`Clipboard_update ")
+    | `Controller_axis_motion ->
+        Some (`Unknown "`Controller_axis_motion ")
+    | `Controller_button_down ->
+        Some (`Unknown "`Controller_button_down ")
+    | `Controller_button_up -> Some (`Unknown "`Controller_button_up ")
+    | `Controller_device_added ->
+        Some (`Unknown "`Controller_device_added ")
+    | `Controller_device_remapped ->
+        Some (`Unknown "`Controller_device_remapped ")
+    | `Controller_device_removed ->
+        Some (`Unknown "`Controller_device_removed ")
+    | `Dollar_gesture -> Some (`Unknown "`Dollar_gesture ")
+    | `Dollar_record -> Some (`Unknown "`Dollar_record ")
+    | `Drop_file -> Some (`Unknown "`Drop_file ")
+    | `Finger_down -> Some (`Unknown "`Finger_down")
+    | `Finger_motion -> Some (`Unknown "`Finger_motion ")
+    | `Finger_up -> Some (`Unknown "`Finger_up ")
+    | `Joy_axis_motion -> Some (`Unknown "`Joy_axis_motion ")
+    | `Joy_ball_motion -> Some (`Unknown "`Joy_ball_motion ")
+    | `Joy_button_down -> Some (`Unknown "`Joy_button_down ")
+    | `Joy_button_up -> Some (`Unknown "`Joy_button_up ")
+    | `Joy_device_added -> Some (`Unknown "`Joy_device_added ")
+    | `Joy_device_removed -> Some (`Unknown "`Joy_device_removed ")
+    | `Joy_hat_motion -> Some (`Unknown "`Joy_hat_motion ")
+    | `Mouse_button_down -> Some (`Unknown "`Mouse_button_down ")
+    | `Mouse_button_up -> Some (`Unknown "`Mouse_button_up")
+    | `Mouse_wheel -> Some (`Unknown "`Mouse_wheel ")
+    | `Multi_gesture -> Some (`Unknown "`Multi_gesture")
+    | `Sys_wm_event -> Some (`Unknown "`Sys_wm_event ")
+    | `Unknown e -> Some (`Unknown (Format.sprintf "`Unknown %d" e))
+    | `User_event -> Some (`Unknown "`User_event ")
+    | `Display_event -> Some (`Unknown "`Display_event ")
+    | `Sensor_update -> Some (`Unknown "`Sensor_update ")
+    | `Window_event -> Some (`Unknown "`Window_event ")
+
+  let key_up : Sdl.keycode = 0x40000052
+  let key_down : Sdl.keycode = 0x40000051
+  let key_left : Sdl.keycode = 0x40000050
+  let key_right : Sdl.keycode = 0x4000004f
+end
+
+module Display = struct
+  open Tgles2
+  open Tsdl
+  open Gg
+  open Wall
+  module I = Image
+  module P = Path
+
+  let ( >>>= ) x f =
+    match x with Ok a -> f a | Error _ as result -> result
+
+  let get_result = function
+    | Ok x -> x
+    | Error (`Msg msg) -> failwith msg
+
+  (* current window state to be passed to window renderer *)
+  type state =
+    { box: box2
+          (* This is cannonically box within which the next element should draw *)
+    ; time: float
+    ; wall: Wall.renderer }
+
+  (* the box2 here is cannonically the place the returner drew
+     (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))
+
+  type frame =
+    { sdl_win: Sdl.window
+    ; gl: Sdl.gl_context
+    ; wall: Wall.renderer
+    ; mutable last_pane: pane
+    ; mutable quit: bool
+    ; mutable fullscreen: bool }
+
+  let ticks () = Int32.to_float (Sdl.get_ticks ()) /. 1000.
+
+  let on_failure ~cleanup result =
+    (match result with Ok _ -> () | Error _ -> cleanup ()) ;
+    result
+
+  let video_initialized = lazy (Sdl.init Sdl.Init.video)
+
+  let make_frame ?(title = "komm") ~w ~h () =
+    Lazy.force video_initialized
+    >>>= fun () ->
+    Sdl.create_window ~w ~h title
+      Sdl.Window.(
+        opengl + allow_highdpi + resizable (*+ input_grabbed*))
+    >>>= fun sdl_win ->
+    Sdl.set_window_title sdl_win title ;
+    ignore (Sdl.gl_set_swap_interval (-1)) ;
+    ignore (Sdl.gl_set_attribute Sdl.Gl.stencil_size 1) ;
+    on_failure
+      ( Sdl.gl_create_context sdl_win
+      >>>= fun gl ->
+      let wall =
+        Wall.Renderer.create ~antialias:true ~stencil_strokes:true ()
+      in
+      Ok
+        { sdl_win
+        ; gl
+        ; wall
+        ; quit= false
+        ; fullscreen= false
+        ; last_pane= pane_empty } )
+      ~cleanup:(fun () -> Sdl.destroy_window sdl_win)
+
+  let handle_frame_events frame events =
+    List.iter
+      (fun (e : Event.t) ->
+        match e with
+        | `Quit -> frame.quit <- true
+        | `Fullscreen a ->
+            frame.fullscreen <- a ;
+            ignore (Sdl.show_cursor (not frame.fullscreen) : _ result) ;
+            ignore
+              ( Sdl.set_window_fullscreen frame.sdl_win
+                  ( if frame.fullscreen then
+                    Sdl.Window.fullscreen_desktop
+                  else Sdl.Window.windowed )
+                : _ result )
+        | _ -> () )
+      events
+
+  let draw_pane frame pane =
+    let width, height = Sdl.gl_get_drawable_size frame.sdl_win in
+    let _, (_, image) =
+      pane
+        { box= Box2.v (P2.v 0. 0.) (P2.v (float width) (float height))
+        ; time= ticks ()
+        ; wall= frame.wall } in
+    Sdl.gl_make_current frame.sdl_win frame.gl
+    >>>= fun () ->
+    Gl.viewport 0 0 width height ;
+    Gl.clear_color 0.0 0.0 0.0 1.0 ;
+    Gl.(
+      clear
+        (color_buffer_bit lor depth_buffer_bit lor stencil_buffer_bit)) ;
+    Gl.enable Gl.blend ;
+    Gl.blend_func_separate Gl.one Gl.src_alpha Gl.one
+      Gl.one_minus_src_alpha ;
+    Gl.enable Gl.cull_face_enum ;
+    Gl.disable Gl.depth_test ;
+    let width = float width and height = float height in
+    Wall.Renderer.render frame.wall ~width ~height image ;
+    Sdl.gl_swap_window frame.sdl_win ;
+    Ok ()
+
+  let rec get_events () : Event.t list =
+    (* create and fill event list *)
+    let ev = Sdl.Event.create () in
+    if Sdl.poll_event (Some ev) then
+      match Event.event_of_sdlevent ev with
+      | Some e -> get_events () @ [e]
+      | None -> get_events ()
+    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 *)
+      ( 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 *)
+      ignore (draw_pane frame frame.last_pane) ;
+      Lwt.return_unit )
+    else Lwt.return_unit
+
+  let run frame actor () =
+    let frame = get_result frame in
+    Sdl.show_window frame.sdl_win ;
+    let rec loop () =
+      Lwt.pause () (* seems required for the irc connection to work *)
+      >>= fun () ->
+      Lwt_unix.sleep 0.030
+      >>= fun () ->
+      display_frame frame actor
+      >>= 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 ;
+    Sdl.destroy_window frame.sdl_win ;
+    Sdl.quit () ;
+    ()
+
+  let gray ?(a = 1.0) v = Color.v v v v a
+
+  module FontCache = Map.Make (String)
+
+  let font_cache = ref FontCache.empty
+
+  let load_font name =
+    match FontCache.find_opt name !font_cache with
+    | Some font -> font
+    | None -> (
+        let ic = open_in_bin name in
+        let dim = in_channel_length ic in
+        let fd = Unix.descr_of_in_channel ic in
+        let buffer =
+          Unix.map_file fd Bigarray.int8_unsigned Bigarray.c_layout
+            false [|dim|]
+          |> Bigarray.array1_of_genarray in
+        let offset = List.hd (Stb_truetype.enum buffer) in
+        match Stb_truetype.init buffer offset with
+        | None -> assert false
+        | Some font ->
+            font_cache := FontCache.add name font !font_cache ;
+            font )
+
+  let font_icons = lazy (load_font "fonts/entypo.ttf")
+  let font_sans = lazy (load_font "fonts/Roboto-Regular.ttf")
+  let font_sans_bold = lazy (load_font "fonts/Roboto-Bold.ttf")
+  let font_sans_light = lazy (load_font "fonts/Roboto-Light.ttf")
+  let font_sans_italic = lazy (load_font "fonts/Roboto-Italic.ttf")
+
+  let font_sans_bold_italic =
+    lazy (load_font "fonts/Roboto-BoldItalic.ttf")
+
+  let font_serif =
+    lazy (load_font "fonts/ScheherazadeNew-Regular.ttf")
+
+  let font_serif_bold =
+    lazy (load_font "fonts/ScheherazadeNew-Bold.ttf")
+
+  let font_mono = lazy (load_font "fonts/static/RobotoMono-Regular")
+
+  let font_mono_bold =
+    lazy (load_font "fonts/static/RobotoMono-Regular")
+
+  let font_mono_light =
+    lazy (load_font "fonts/static/RobotoMono-Regular")
+
+  let font_emoji = lazy (load_font "fonts/NotoEmoji-Regular.ttf")
+
+  let str_of_box b =
+    Printf.sprintf "(ox:%0.1f oy:%0.1f ex%0.1f ey%0.1f)" (Box2.ox b)
+      (Box2.oy b) (Box2.maxx b) (Box2.maxy b)
+
+  let draw_label text b =
+    let f =
+      Wall_text.Font.make ~size:(Box2.h b) (Lazy.force font_sans)
+    in
+    ( Box2.v (Box2.o b)
+        (P2.v (Wall_text.Font.text_width f text) (Box2.h b))
+    , I.paint
+        (Paint.color (gray ~a:0.5 1.0))
+        Wall_text.(
+          simple_text f ~valign:`BASELINE ~halign:`LEFT ~x:(Box2.ox b)
+            ~y:(Box2.oy b +. (Box2.h b *. 0.75))
+            text) )
+
+  let fill_box c b =
+    ( b
+    , I.paint (Paint.color c)
+        ( I.fill_path
+        @@ fun t ->
+        P.rect t ~x:(Box2.ox b) ~y:(Box2.oy b) ~w:(Box2.w b)
+          ~h:(Box2.h b) ) )
+
+  let draw_filled_box c (s : state) = (s, fill_box c s.box)
+
+  let path_box c b (s : state) =
+    ( s
+    , ( b
+      , I.paint (Paint.color c)
+          ( I.stroke_path (Outline.make ())
+          @@ fun t ->
+          P.rect t ~x:(Box2.ox b) ~y:(Box2.oy b) ~w:(Box2.w b)
+            ~h:(Box2.h b) ) ) )
+
+  let path_circle c b (s : state) =
+    ( s
+    , ( b
+      , I.paint (Paint.color c)
+          ( I.stroke_path (Outline.make ())
+          @@ fun t ->
+          P.circle t ~cx:(Box2.midx b) ~cy:(Box2.midy b)
+            ~r:(Box2.w b /. 2.) ) ) )
+
+  (** Display.state.box as supplied to a widget defines the allowed drawing area for the widget.
+    This way basic widgets will just expand to the full area of a box, while other widgets can have
+    the express purpose of limiting the size of an object in a larger system of limitations. 
+
+    Panes return a tuple: (state, (box, image))
+    state is the updated state, where state.box is always 
+      - the top left corner of the box the pane drew in, and
+      - the bottom right corner of the state.box that was passed in
+    box is the area the widget actually drew in (or wants to sort of "use")
+    image is the Wall.image to compose with other panes and draw to the display
+  *)
+
+  let simple_text f text (s : state) =
+    let fm = Wall_text.Font.font_metrics f in
+    let font_height = fm.ascent -. fm.descent +. fm.line_gap in
+    let tm = Wall_text.Font.text_measure f text in
+    let br_pt =
+      P2.v (Box2.ox s.box +. tm.width) (Box2.oy s.box +. font_height)
+    in
+    let bextent = Box2.of_pts (Box2.o s.box) br_pt in
+    (*  let _, (_, redbox) = path_box Color.red bextent s in*)
+    ( {s with box= Box2.of_pts (Box2.br_pt bextent) (Box2.max s.box)}
+    , ( bextent
+      , (* I.stack redbox *)
+        I.paint
+          (Paint.color (gray ~a:0.5 1.0))
+          Wall_text.(
+            simple_text f ~valign:`BASELINE ~halign:`LEFT
+              ~x:(Box2.ox s.box)
+              ~y:(Box2.oy s.box +. fm.ascent)
+              text) ) )
+
+  let pane_box next_point_func (subpanes : pane list) (so : state) =
+    let sr, (br, ir) =
+      List.fold_left
+        (fun (sp, (bp, ip)) (pane : pane) ->
+          (* uses br to hold max extent of boxes *)
+          let sr, (br, ir) = pane sp in
+          (* draw the pane *)
+          let _, (_, irb) = path_box Color.blue br sr in
+          (* draw the box around the pane *)
+          ( { sr with
+              box= Box2.of_pts (next_point_func br) (Box2.max sp.box)
+            }
+          , ( Box2.of_pts (Box2.o bp)
+                (P2.v
+                   (max (Box2.maxx br) (Box2.maxx bp))
+                   (max (Box2.maxy br) (Box2.maxy bp)) )
+            , Image.seq [ip; irb; ir] ) ) )
+        ( so
+        , (Box2.of_pts (Box2.o so.box) (Box2.o so.box), Image.empty)
+        )
+        subpanes in
+    let _, (_, redbox) = path_box Color.red br sr in
+    (sr, (br, Image.stack redbox ir))
+end

boot_js.ml

@@ -0,0 +1,109 @@
+open Js_of_ocaml
+open Lwt.Infix
+module NVG = Graphv_webgl
+
+let _ =
+  Logs.set_reporter (Human.Logs_reporter.console_reporter ());
+  Logs.set_level (Some Debug);
+  Logs.debug (fun m -> m "hello")
+
+module Log = (val Logs.src_log Logs.default : Logs.LOG)
+
+(* This scales the canvas to match the DPI of the window,
+   it prevents blurriness when rendering to the canvas *)
+let scale_canvas (canvas : Dom_html.canvasElement Js.t) =
+  let dpr = Dom_html.window##.devicePixelRatio in
+  let rect = canvas##getBoundingClientRect in
+  let width = rect##.right -. rect##.left in
+  let height = rect##.bottom -. rect##.top in
+  canvas##.width := width *. dpr |> int_of_float;
+  canvas##.height := height *. dpr |> int_of_float;
+  let width =
+    Printf.sprintf "%dpx" (int_of_float width) |> Js.string
+  in
+  let height =
+    Printf.sprintf "%dpx" (int_of_float height) |> Js.string
+  in
+  canvas##.style##.width := width;
+  canvas##.style##.height := height
+
+let _ =
+  let canvas =
+    Js.Unsafe.coerce (Dom_html.getElementById_exn "canvas")
+  in
+  scale_canvas canvas;
+  let webgl_ctx =
+    (* Graphv requires a stencil buffer to work properly *)
+    let attrs = WebGL.defaultContextAttributes in
+    attrs##.stencil := Js._true;
+    match
+      WebGL.getContextWithAttributes canvas attrs |> Js.Opt.to_option
+    with
+    | None ->
+        print_endline "Sorry your browser does not support WebGL";
+        raise Exit
+    | Some ctx -> ctx
+  in
+  let open NVG in
+  let vg =
+    create
+      ~flags:CreateFlags.(antialias lor stencil_strokes)
+      webgl_ctx
+  in
+  (* File in this case is actually the CSS font name *)
+  Text.create vg ~name:"sans" ~file:"sans" |> ignore;
+  webgl_ctx##clearColor 0.3 0.3 0.32 1.;
+
+  (*
+    let render ev =
+    webgl_ctx##clear
+      (webgl_ctx##._COLOR_BUFFER_BIT_
+      lor webgl_ctx##._DEPTH_BUFFER_BIT_
+      lor webgl_ctx##._STENCIL_BUFFER_BIT_);
+    let device_ratio = Dom_html.window##.devicePixelRatio in
+    begin_frame vg ~width:canvas##.width ~height:canvas##.height
+      ~device_ratio;
+    Transform.scale vg ~x:device_ratio ~y:device_ratio;
+    ignore Human.Panel.Ui.(panel vg Gg.P2.o test ev);
+    (*
+    Path.begin_ vg ;
+    Path.rect vg ~x:40. ~y:40. ~w:320. ~h:320. ;
+    set_fill_color vg ~color:Color.(rgba ~r:154 ~g:203 ~b:255 ~a:200) ;
+    fill vg ;
+    Transform.translate vg ~x:200. ~y:200. ;
+    Transform.rotate vg ~angle:(time *. 0.0005) ;
+    Text.set_font_face vg ~name:"sans" ;
+    Text.set_size vg ~size:48. ;
+    Text.set_align vg ~align:Align.(center lor middle) ;
+    set_fill_color vg ~color:Color.white ;
+    Text.text vg ~x:0. ~y:0. "Hello World!" ; *)
+    NVG.end_frame vg
+  in
+  Dom_html.window##requestAnimationFrame
+    (Js.wrap_callback (fun _ -> render Human.Event.empty))
+  |> ignore;*)
+  let open Js_of_ocaml_lwt.Lwt_js_events in
+  async (fun () ->
+      buffered_loop (make_event Dom_html.Event.keydown)
+        Dom_html.document (fun ev _ ->
+          webgl_ctx##clear
+            (webgl_ctx##._COLOR_BUFFER_BIT_
+            lor webgl_ctx##._DEPTH_BUFFER_BIT_
+            lor webgl_ctx##._STENCIL_BUFFER_BIT_);
+          let device_ratio = Dom_html.window##.devicePixelRatio in
+          begin_frame vg ~width:canvas##.width ~height:canvas##.height
+            ~device_ratio;
+          Transform.scale vg ~x:device_ratio ~y:device_ratio;
+          Human.Panel.Ui.(
+            render_lwt vg Gg.P2.o
+              (Human.Event_js.evt_of_jskey `Press ev))
+          >>= fun p ->
+          Logs.debug (fun m ->
+              m "Drawing finished at point: %a" Gg.V2.pp p);
+          NVG.end_frame vg;
+          Lwt.return_unit))
+
+(* Dom_html.document##.onkeydown
+   := Dom.handler (fun (evt : Dom_html.keyboardEvent Js.t) ->
+          render (Human.Event_js.evt_of_jskey `Press evt) ;
+          Js._false ) *)

cors_proxy.sh

@@ -0,0 +1,7 @@
+#!/bin/bash
+if [ ! -f /tmp/key.pem ]; then
+  echo Creating key
+  openssl req -newkey rsa:2048 -new -nodes -x509 -days 3650 -keyout /tmp/key.pem -out /tmp/cert.pem -batch
+fi
+
+npx http-server --cors -S -P https://github.com --log-ip -c-1 -C /tmp/cert.pem -K /tmp/key.pem

dune

@@ -1,74 +1,31 @@
 (env
-  (dev
+ (dev (flags (:standard -warn-error -A))
-   (flags (:standard -warn-error -A))))
+  (js_of_ocaml (flags --no-inline --pretty --source-map-inline --debug-info)
-
+   (build_runtime_flags --no-inline --pretty --source-map-inline --debug-info)
-(library
+   (link_flags --source-map-inline))))
- (name human)
- (modes byte)
- (modules human)
- (libraries
-  topinf
-   lwt_ppx
-  tsdl
-  tgls.tgles2
-  wall
-  zed
-  lambda-term
-  irmin-unix
-  nottui-pretty
-  ocaml-compiler-libs.common
-  ocaml-compiler-libs.bytecomp
-  ocaml-compiler-libs.toplevel))
-
 
 (executable
- (name irc)
+ (name boot_js)
- (modes byte)
+ (modes byte js)
- (modules irc)
+ (preprocess (pps js_of_ocaml-ppx)) 
+
+ (modules boot_js human)
  (libraries
-   human
-   lwt
    fmt
-   topinf
+   logs
-   lwt_ppx
+   graphv_webgl
-   irc-client
+   js_of_ocaml-lwt
-   irc-client-lwt
+   digestif.ocaml
-   irc-client-unix
+   checkseum.ocaml
-   irc-client-tls
+   irmin.mem
-   nottui-lwt
+   git 
-   nottui-pretty
+   irmin-git
+   cohttp-lwt-jsoo
+   mimic
+   uri
+   zed
+   gg
+   wall
+
 ))
 
-(executable
- (name boot)
- (modes byte)
- (modules boot)
- (link_flags (-linkall))
- (libraries
-   lwt_ppx
-   lambda-term
-   topinf))
-
-(library
- (name topinf)
- (modes byte)
- (modules topinf)
- (libraries
-   fmt
-  tsdl
-  tgls.tgles2
-  wall
-  zed
-  lambda-term
-  irmin-unix
-  nottui
-  nottui-pretty
-  nottui-lwt
-  uuseg
-  irc-client
-  irc-client-lwt
-  irc-client-unix
-  irc-client-tls
-  ocaml-compiler-libs.common
-  ocaml-compiler-libs.bytecomp
-  ocaml-compiler-libs.toplevel))

dune-project

@@ -1,3 +1,2 @@
-(lang dune 2.8)
+(lang dune 3.4)
-(name komm)
+(name boot)
-(wrapped_executables false)

index.html

@@ -0,0 +1,35 @@
+<!DOCTYPE>
+<html>
+  <head>
+    <style>
+html, body {
+    width: 100%;
+    height: 100%;
+    overflow: hidden;
+    margin: 0;
+    padding: 0;
+}
+
+div {
+    display: flex;
+    align-items: center;
+    justify-content: center;
+}
+
+canvas {
+    width: 100%;
+    height: 100%;
+}
+    </style>
+  </head>
+  <body>
+      <div>
+          <canvas id='canvas'></canvas>
+      </div>
+  </body>
+  <script 
+    type='text/javascript' 
+    defer 
+    src='_build/default/boot_js.bc.js'>
+  </script>
+</html>

irc.ml

@@ -14,249 +14,481 @@ open Lwt_react
 module F = Fmt
 
 module Communicator = struct
-  module Message = struct
+  let base_path = "communicator"
-    type t = {content: string; time: string; mutable seen: bool}
+  let topch = "top"
 
-    let make ?(time = "<ts>") content = {content; time; seen= false}
+  module Istore = struct
+    include Human.Store
+
+    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.gettimeofday ()) content =
+      let tm = Unix.localtime time in
+      { time=
+          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
-    type t = {name: string; content: Message.t list Lwd.var}
+    (* a channels step key may not be blank (i.e. "") *)
+    type t = {store: Istore.t; path: Istore.key}
 
-    let add_msg (c : t) (msg : Message.t) =
+    let make (store : Istore.t) ~path ~(name : string) =
-      F.epr "Channel.add_msg msg.content=\"%s\"@." msg.content ;
+      Lwt.return {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 =
+      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
 
   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 contents {store; view} (s : selection) :
+        Istore.Contents.t option Lwt.t =
+      Istore.find store (view @ s)
 
-    let add (comm : t) ch : unit =
+    let make_top ?(view = [base_path]) gitpath branchname : t Lwt.t =
-      let c' =
+      Istore.Repo.v (Irmin_git.config gitpath)
-        { channel= ch
+      >>= fun repo ->
-        ; subs= Lwd_table.make ()
+      Istore.of_branch repo branchname
-        ; focus= Nottui.Focus.make () } in
+      >>= fun store ->
-      Lwd_table.append' comm.subs c'
+      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 () ->
+      Channel.add_msg ch_top
+        (Message.make "Currently only IRC is implemented")
+      >>= fun () -> Lwt.return t
 
-    let make_top () =
+    let add {store; view} ~(name : string list) ~(config : Istore.tree)
-      let channel = Channel.make "communicator-top" in
+        : t Lwt.t =
-      add_msg channel (Message.make "Welcome to the Communicator") ;
+      Istore.get_tree store name
-      add_msg channel
+      >>= fun tree ->
-        (Message.make "Currently only IRC is implemented") ;
+      Istore.Tree.remove tree ["_config"]
-      {channel; subs= Lwd_table.make (); focus= Nottui.Focus.make ()}
+      >>= 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 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
 
-    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 path = "_config"
-      let add_msg str = Channel.add_msg channel (Message.make str) in
+
+      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' ->
+        Istore.Tree.add t' ["port"] (string_of_int port)
+        >>= 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
+          (view @ [name; path])
+          t'
+        >>= fun _ -> Lwt.return_unit
+
+      let server t : string Lwt.t = Istore.Tree.get t [path; "server"]
+
+      let port t : int Lwt.t =
+        Istore.Tree.get t [path; "port"] >|= fun p -> int_of_string p
+
+      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 ->
+      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 = [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. *)
+      Channel.make store ~path ~name:topch
+      >>= fun top_channel ->
+      let _top_msg str =
+        Channel.add_msg top_channel (Message.make str) in
       let channel_assoc = ref [] in
-      let make_ch name =
+      let make_channel store path (name : string) =
-        let ch = Channel.make name in
+        Channel.make store ~path ~name
-        Tree.add c ch ;
+        >>= fun ch ->
         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 () ->
+      Istore.list store path
-             add_msg "Connecting..." ;
+      >>= fun servers ->
-             C.connect_by_name ~server ~port ~nick ()
+      Lwt_list.filter_p
-             >>= fun c ->
+        (fun (_, tree) ->
-             Lwt_io.printl "connect_by_name returned"
+          Config.protocol tree
-             >>= fun () -> Lwt.return c )
+          >|= function Some p -> p = Protocol.id Irc | None -> false
-           ~f:(fun connection ->
+          )
-             add_msg "Connected" ;
+        servers
-             Lwt_list.iter_p
+      (* filter out non-irc protocols, TODO currently relying on this to filter out non-server folders too *)
-               (fun chname ->
+      >>= fun servers ->
-                 C.send_join ~connection ~channel:chname
+      F.epr "protocols filtered for irc@." ;
-                 >>= fun () ->
+      Lwt_list.iter_p
-                 ignore (make_ch chname) ;
+        (fun (name, tree) ->
-                 Lwt.return_unit )
+          F.epr "Irc.connect server=%s @." name ;
-               channels )
+          Config.nick tree
-           ~callback:(fun _connection result ->
+          >>= fun nick ->
-             match result with
+          Config.server tree
-             | Result.Ok ({M.command= M.Other _; _} as msg) ->
+          >>= fun server ->
-                 add_msg (M.to_string msg) ;
+          Config.port tree
-                 Lwt.return_unit
+          >>= fun port ->
-             | Result.Ok
+          Channel.make store ~path:(path @ [name]) ~name:topch
-                 {M.command= M.PRIVMSG (target, data); prefix= user}
+          >>= fun server_channel ->
-               ->
+          let add_msg s =
-                 let user =
+            Channel.add_msg server_channel (Message.make s) in
-                   match user with
+          C.reconnect_loop ~after:30
-                   | Some u -> List.hd (String.split_on_char '!' u)
+            ~connect:(fun () ->
-                   | None -> "unknown" in
+              add_msg "Connecting..."
-                 ( match List.assoc_opt target !channel_assoc with
+              >>= fun () ->
-                 | Some ch -> Channel.add_msg ch
+              C.connect_by_name ~server ~port ~nick ()
-                 | None -> Channel.add_msg (make_ch target) )
+              >>= fun c -> Lwt.return c )
-                   (Message.make (F.str "<%s> %s" user data)) ;
+            ~f:(fun connection ->
-                 Lwt.return_unit
+              F.epr "Irc.connect C.reconnect_loop ~f:(Connected...)@." ;
-             | Result.Ok msg ->
+              add_msg "Connected"
-                 add_msg (M.to_string msg) ;
+              >>= fun () ->
-                 Lwt.return_unit
+              get_channels ~store ~path:[name]
-             | Result.Error e -> Lwt_io.printl e ) ) ;
+              >>= fun chs ->
-      channel
+              Lwt_list.iter_p
+                (fun chname ->
+                  C.send_join ~connection ~channel:chname
+                  >>= fun () ->
+                  ignore (make_channel store [name] chname) ;
+                  Lwt.return_unit )
+                chs )
+            ~callback:(fun _connection result ->
+              match result with
+              | Result.Ok ({M.command= M.Other _; _} as msg) ->
+                  add_msg (M.to_string msg)
+              | Result.Ok
+                  {M.command= M.PRIVMSG (target, data); prefix= user}
+                -> (
+                  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
-    open Nottui
+    open Panel
-    module P = Nottui_pretty
+    open Panel.Ui
 
-    let string ?attr text = P.ui (Nottui_widgets.string ?attr text)
+    type viewer =
-    let ( ^^ ) = P.( ^^ )
+      { step: string
-    let ( ^/^ ) a b = P.(a ^^ break 1 ^^ b)
+      ; var: view Lwd.var
+      ; mutable parent: view
+      ; mutable node: viewer list }
 
-    let messagelist (ch : Channel.t) : P.t Lwd.t =
+    and view = [`Empty | `View of viewer]
-      Lwd.map (Lwd.get ch.content) ~f:(fun (msgs : Message.t list) ->
-          List.fold_left
-            (fun doc (msg : Message.t) ->
-              F.epr "Communicator.Panel.messagelist ch.content=%s@."
-                msg.content ;
-              doc
-              ^^ P.group
-                   ( string msg.time ^/^ string " | "
-                   ^/^ string msg.content )
-              ^^ P.hardline )
-            P.empty msgs )
 
-    open Nottui_widgets
+    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
 
-    (*type focustree =
+    let make step parent node =
-        {channel: Channel.t; subs: focustree list; focus: Focus.handle}
+      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 channeltree (tree : Tree.t) : focustree Lwd.t =
+    let rec last = function
-         let rec fold (tree : Tree.t) : focustree list Lwd.t =
+      | [] -> None
-           Lwd_table.map_reduce
+      | [x] -> Some x
-             (fun _row (tree : Tree.t) ->
+      | _ :: xs -> last xs
-                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 =
+    let rec last_def = function
-      let channel = Lwd.var tree.channel in
+      | [] -> "[]"
-      let rec fold ?(indent = 0) ?superfocus (tree : Tree.t) :
+      | [x] -> x
-          'a Lwd.t =
+      | _ :: xs -> last_def xs
-        let subfocus = Focus.make () in
+
+    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)
+
+    let channelview (store, path) =
+      storeview store path
+      >>= fun (_watch, root) ->
+      let ui =
         Lwd.join
-          (Lwd_table.map_reduce
+          (Lwd.map (Lwd.get root) ~f:(function
-             (fun row (tree : Tree.t) ->
+            | `Empty ->
-               let focus =
+                failwith "channelview says root Lwd.var is `Empty"
-                 match superfocus with
+            | `View v ->
-                 | Some sf ->
+                let rec iter ?(indent = 0) (v : viewer) =
-                     Lwd.map2 (Focus.status sf)
+                  Lwd.bind (Lwd.get v.var) ~f:(function
-                       (Focus.status tree.focus)
+                    | `Empty -> Lwd.return Ui.empty
-                       ~f:(fun superfocus' focus' ->
+                    | `View v' ->
-                         if Focus.has_focus superfocus' then
+                        let sub =
-                           F.epr
+                          Lwd_utils.pack Ui.pack_y
-                             "Focus.has_focus superfocus' = true@." ;
+                            (List.map
-                         Focus.release sf ;
+                               (iter ~indent:(indent + 1))
-                         Focus.request tree.focus ;
+                               v'.node ) in
-                         focus' )
+                        Lwd.map sub ~f:(fun sub ->
-                 | None -> Focus.status tree.focus in
+                            Ui.join_y
-               Lwd.map2
+                              (Ui.string
-                 (Lwd.map focus ~f:(fun focus ->
+                                 ( String.make indent '>' ^ " "
-                      if Focus.has_focus focus then
+                                 ^ v'.step ) )
-                        Lwd.set channel tree.channel ;
+                              sub ) ) in
-                      Ui.keyboard_area ~focus
+                iter v ) ) in
-                        (fun key ->
+      let chs, chs_push = Lwt_stream.create () in
-                          match key with
+      Channel.make store ~path:[base_path] ~name:topch
-                          | `ASCII 'w', [] -> (
+      >>= fun ch ->
-                            match Lwd_table.prev row with
+      chs_push (Some ch) ;
-                            | Some r -> (
+      Lwt.return (chs, ui)
-                              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) =
+    let messagelist ({store; path} : Channel.t) mlist :
-      Panel.Nottui.scroll_area
+        Istore.watch Lwt.t =
-        (Lwd.map
+      let mlist' () =
-           (Lwd.bind (Lwd.get ch) ~f:messagelist)
+        Istore.get_tree store path
-           ~f:(P.pretty 200) )
+        >>= 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 ml ->
+      Lwd.set mlist ml ;
+      Istore.watch_key store path (fun _ ->
+          mlist' ()
+          >>= fun mlist' -> Lwt.return (Lwd.set mlist mlist') )
 
-    let commview c =
+    let messageview ch =
-      let cv, ch = channelview c in
+      let mlist = Lwd.var [(("", "", "", "", ""), "")] in
-      Nottui_widgets.h_pane
+      let rec update_messagelist watch () =
-        (Panel.Nottui.scroll_area cv)
+        Lwt_stream.last_new ch
-        (messageview 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) ;
+      Lwt.return
+        (Lwd.map (Lwd.get mlist) ~f:(fun mlist ->
+             scroll
+               (List.fold_left
+                  (fun doc ((year, month, day, hour, sec), content) ->
+                    F.epr
+                      "Communicator.Panel.messagelist ch.content=%s@."
+                      content ;
+                    doc
+                    ^/^ Ui.string
+                          (F.str "%s.%s.%s.%s.%s" year month day hour
+                             sec )
+                    ^^ Ui.string " | " ^^ string content )
+                  Ui.empty mlist ) ) )
 
-    type view = Channel of (Channel.t * view list) | Cursor of view
+    let commview (store, path) =
+      channelview (store, List.rev (List.tl (List.rev path)))
+      >>= fun (ch, cv) ->
+      messageview ch
+      >>= fun mv ->
+      Lwt.return (Lwd.map2 cv mv ~f:(fun c m -> join_x c m))
 
-    let panel (comm : Tree.t) =
+    let panel ({store; view} : Tree.t) : (Event.t -> atom Lwt.t) Lwt.t
-      let base = Lwd.var Nottui_widgets.empty_lwd in
+        =
-      Lwd.set base (commview comm) ;
+      commview (store, view) >>= fun cv -> Panel.Ui.panel cv
-      Panel.Nottui.panel (Lwd.join (Lwd.get base)) ()
   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 () ->
+      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)@." ;
+      Communicator.Panel.panel comm
+      >|= fun f ->
+      root_actor :=
+        std_actor
+          (Lwt.return
+             Panel.
+               { act=
+                   (fun _ events ->
+                     Lwt_list.fold_left_s
+                       (fun _ ev ->
+                         f ev
+                         >>= fun i ->
+                         Lwt.return (fun s ->
+                             ( s
+                             , ( Gg.Box2.of_pts Gg.V2.zero (snd i)
+                               , fst i ) ) ) )
+                       Display.pane_empty events )
+               ; subpanels= []
+               ; tag= "irc" } ) )

opam-switch

@@ -0,0 +1,361 @@
+opam-version: "2.0"
+compiler: ["ocaml-system.4.13.1"]
+roots: [
+  "bogue.20210917"
+  "findlib_top.v0.11.0"
+  "glfw-ocaml.3.3.1-1"
+  "huffman.0.1.2"
+  "inuit.0.4.1"
+  "irc-client.0.7.0"
+  "irc-client-lwt.0.7.0"
+  "irc-client-tls.0.7.0"
+  "irc-client-unix.0.7.0"
+  "irmin.2.9.0"
+  "irmin-unix.2.9.0"
+  "lambda-term.3.1.0"
+  "lwd.0.1"
+  "lwt_ppx.2.0.3"
+  "merlin.4.4-413"
+  "note.0.0.1"
+  "nottui.0.1"
+  "nottui-lwt.0.1"
+  "nottui-pretty.0.1"
+  "ocaml-manual.4.13.0"
+  "ocaml-system.4.13.1"
+  "ocamlformat.0.20.1"
+  "odig.0.0.7"
+  "odoc.2.0.2"
+  "pp.1.1.2"
+  "pprint.20211129"
+  "tgls.0.8.5"
+  "tsdl.0.9.8"
+  "user-setup.0.7"
+  "wall.0.4.1"
+  "zed.3.1.0"
+]
+installed: [
+  "angstrom.0.15.0"
+  "arp.3.0.0"
+  "asn1-combinators.0.2.6"
+  "astring.0.8.5"
+  "awa.0.0.4"
+  "awa-mirage.0.0.4"
+  "b0.0.0.3"
+  "base.v0.14.2"
+  "base-bigarray.base"
+  "base-bytes.base"
+  "base-threads.base"
+  "base-unix.base"
+  "base64.3.5.0"
+  "bheap.2.0.0"
+  "bigarray-compat.1.0.0"
+  "bigstringaf.0.8.0"
+  "biniou.1.2.1"
+  "bogue.20210917"
+  "bos.0.2.0"
+  "ca-certs.0.2.2"
+  "ca-certs-nss.3.71"
+  "camomile.1.0.2"
+  "carton.0.4.3"
+  "carton-git.0.4.3"
+  "carton-lwt.0.4.3"
+  "cf.0.4"
+  "cf-lwt.0.4"
+  "charInfo_width.1.1.0"
+  "checkseum.0.3.2"
+  "cmdliner.1.0.4"
+  "cohttp.4.0.0"
+  "cohttp-lwt.4.0.0"
+  "cohttp-lwt-unix.4.0.0"
+  "conduit.4.0.2"
+  "conduit-lwt.4.0.2"
+  "conduit-lwt-unix.4.0.2"
+  "conf-cairo.1"
+  "conf-gles2.1"
+  "conf-glfw3.2"
+  "conf-gmp.3"
+  "conf-gmp-powm-sec.3"
+  "conf-libffi.2.0.0"
+  "conf-libX11.1"
+  "conf-m4.1"
+  "conf-pkg-config.2"
+  "conf-sdl2.1"
+  "conf-sdl2-image.1"
+  "conf-sdl2-ttf.1"
+  "cppo.1.6.8"
+  "crunch.3.2.0"
+  "csexp.1.5.1"
+  "cstruct.6.0.1"
+  "cstruct-lwt.6.0.1"
+  "cstruct-sexp.6.0.1"
+  "cstruct-unix.6.0.1"
+  "ctypes.0.20.0"
+  "ctypes-foreign.0.18.0"
+  "decompress.1.4.2"
+  "digestif.1.1.0"
+  "dispatch.0.5.0"
+  "domain-name.0.3.1"
+  "dot-merlin-reader.4.1"
+  "duff.0.4"
+  "dune.2.9.1"
+  "dune-build-info.2.9.1"
+  "dune-configurator.2.9.1"
+  "duration.0.2.0"
+  "easy-format.1.3.2"
+  "either.1.0.0"
+  "emile.1.1"
+  "encore.0.8"
+  "eqaf.0.8"
+  "ethernet.3.0.0"
+  "findlib_top.v0.11.0"
+  "fix.20211125"
+  "fmt.0.9.0"
+  "fpath.0.7.3"
+  "fsevents.0.3.0"
+  "fsevents-lwt.0.3.0"
+  "gg.0.9.3"
+  "git.3.6.0"
+  "git-cohttp.3.6.0"
+  "git-cohttp-unix.3.6.0"
+  "git-unix.3.6.0"
+  "glfw-ocaml.3.3.1-1"
+  "gmap.0.3.0"
+  "graphql.0.13.0"
+  "graphql-cohttp.0.13.0"
+  "graphql-lwt.0.13.0"
+  "graphql_parser.0.13.0"
+  "graphv_core.0.1.1"
+  "graphv_core_lib.0.1.1"
+  "graphv_font.0.1.1"
+  "graphv_font_js.0.1.1"
+  "graphv_gles2.0.1.1"
+  "graphv_gles2_native_impl.0.1.1"
+  "graphv_webgl.0.1.1"
+  "graphv_webgl_impl.0.1.1"
+  "grenier.0.13"
+  "hex.1.4.0"
+  "hkdf.1.0.4"
+  "huffman.0.1.2"
+  "hxd.0.3.1"
+  "index.1.5.0"
+  "inotify.2.3"
+  "integers.0.5.1"
+  "inuit.0.4.1"
+  "ipaddr.5.2.0"
+  "ipaddr-sexp.5.2.0"
+  "irc-client.0.7.0"
+  "irc-client-lwt.0.7.0"
+  "irc-client-tls.0.7.0"
+  "irc-client-unix.0.7.0"
+  "irmin.2.9.0"
+  "irmin-fs.2.9.0"
+  "irmin-git.2.9.0"
+  "irmin-graphql.2.9.0"
+  "irmin-http.2.9.0"
+  "irmin-layers.2.9.0"
+  "irmin-pack.2.9.0"
+  "irmin-unix.2.9.0"
+  "irmin-watcher.0.5.0"
+  "jbuilder.1.0+beta20.2"
+  "js_of_ocaml.3.11.0"
+  "js_of_ocaml-compiler.3.11.0"
+  "js_of_ocaml-ppx.3.11.0"
+  "jsonm.1.0.1"
+  "ke.0.4"
+  "lambda-term.3.1.0"
+  "logs.0.7.0"
+  "lru.0.3.0"
+  "lwd.0.1"
+  "lwt.5.5.0"
+  "lwt-dllist.1.0.1"
+  "lwt_log.1.1.1"
+  "lwt_ppx.2.0.3"
+  "lwt_react.1.1.5"
+  "macaddr.5.2.0"
+  "macaddr-cstruct.5.2.0"
+  "magic-mime.1.2.0"
+  "menhir.20211128"
+  "menhirLib.20211128"
+  "menhirSdk.20211128"
+  "merlin.4.4-413"
+  "metrics.0.3.0"
+  "mew.0.1.0"
+  "mew_vi.0.5.0"
+  "mimic.0.0.4"
+  "mirage-clock.4.0.0"
+  "mirage-clock-unix.4.0.0"
+  "mirage-crypto.0.10.5"
+  "mirage-crypto-ec.0.10.5"
+  "mirage-crypto-pk.0.10.5"
+  "mirage-crypto-rng.0.10.5"
+  "mirage-device.2.0.0"
+  "mirage-flow.3.0.0"
+  "mirage-kv.4.0.0"
+  "mirage-net.4.0.0"
+  "mirage-no-solo5.1"
+  "mirage-no-xen.1"
+  "mirage-profile.0.9.1"
+  "mirage-protocols.8.0.0"
+  "mirage-random.3.0.0"
+  "mirage-stack.4.0.0"
+  "mirage-time.3.0.0"
+  "mmap.1.1.0"
+  "mtime.1.3.0"
+  "note.0.0.1"
+  "nottui.0.1"
+  "nottui-lwt.0.1"
+  "nottui-pretty.0.1"
+  "notty.0.2.2"
+  "num.1.4"
+  "oasis.0.4.11"
+  "ocaml.4.13.1"
+  "ocaml-compiler-libs.v0.12.4"
+  "ocaml-config.2"
+  "ocaml-manual.4.13.0"
+  "ocaml-migrate-parsetree.2.3.0"
+  "ocaml-options-vanilla.1"
+  "ocaml-syntax-shims.1.0.0"
+  "ocaml-system.4.13.1"
+  "ocaml-version.3.4.0"
+  "ocamlbuild.0.14.0"
+  "ocamlfind.1.9.1"
+  "ocamlformat.0.20.1"
+  "ocamlgraph.2.0.0"
+  "ocamlify.0.0.1"
+  "ocamlmod.0.0.9"
+  "ocb-stubblr.0.1.1-1"
+  "ocp-indent.1.8.1"
+  "ocplib-endian.1.2"
+  "odig.0.0.7"
+  "odoc.2.0.2"
+  "odoc-parser.1.0.0"
+  "optint.0.1.0"
+  "parsexp.v0.14.1"
+  "pbkdf.1.2.0"
+  "pecu.0.6"
+  "pp.1.1.2"
+  "pprint.20211129"
+  "ppx_cstruct.6.0.1"
+  "ppx_derivers.1.2.1"
+  "ppx_deriving.5.2.1"
+  "ppx_irmin.2.9.0"
+  "ppx_repr.0.5.0"
+  "ppx_sexp_conv.v0.14.3"
+  "ppxlib.0.24.0"
+  "progress.0.2.1"
+  "psq.0.2.0"
+  "ptime.0.8.6"
+  "randomconv.0.1.3"
+  "re.1.10.3"
+  "react.1.2.1"
+  "repr.0.5.0"
+  "result.1.5"
+  "rresult.0.6.0"
+  "semaphore-compat.1.0.1"
+  "seq.base"
+  "sexplib.v0.14.0"
+  "sexplib0.v0.14.0"
+  "stb_image.0.5"
+  "stb_truetype.0.6"
+  "stdio.v0.14.0"
+  "stdlib-shims.0.3.0"
+  "stringext.1.6.0"
+  "tcpip.7.0.0"
+  "terminal.0.2.1"
+  "terminal_size.0.1.4"
+  "tgls.0.8.5"
+  "tls.0.14.1"
+  "tls-mirage.0.14.1"
+  "topkg.1.0.4"
+  "trie.1.0.0"
+  "tsdl.0.9.8"
+  "tsdl-image.0.3.2"
+  "tsdl-ttf.0.3.2"
+  "tyxml.4.5.0"
+  "uchar.0.0.2"
+  "uri.4.2.0"
+  "uri-sexp.4.2.0"
+  "user-setup.0.7"
+  "uucp.14.0.0"
+  "uuseg.14.0.0"
+  "uutf.1.0.2"
+  "vector.1.0.0"
+  "wall.0.4.1"
+  "webmachine.0.7.0"
+  "x509.0.14.1"
+  "yaml.3.0.0"
+  "yojson.1.7.0"
+  "zarith.1.12"
+  "zed.3.1.0"
+]
+pinned: ["lwd.0.1" "nottui.0.1"]
+package "lwd" {
+  opam-version: "2.0"
+  version: "0.1"
+  synopsis: "Lightweight reactive documents"
+  maintainer: "fred@tarides.com"
+  authors: "Frédéric Bour"
+  license: "MIT"
+  homepage: "https://github.com/let-def/lwd"
+  doc: "https://let-def.github.io/lwd/doc"
+  bug-reports: "https://github.com/let-def/lwd/issues"
+  depends: [
+    "dune" {>= "2.0"}
+    "seq"
+    "ocaml" {>= "4.03"}
+    "qtest" {with-test}
+    "qcheck" {with-test}
+  ]
+  build: [
+    ["dune" "subst"] {pinned}
+    [
+      "dune"
+      "build"
+      "-p"
+      name
+      "-j"
+      jobs
+      "@install"
+      "@runtest" {with-test}
+      "@doc" {with-doc}
+    ]
+  ]
+  dev-repo: "git+https://github.com/let-def/lwd.git"
+  url {
+    src: "git+file:///home/cqc/p/console/ref/lwd#master"
+  }
+}
+package "nottui" {
+  opam-version: "2.0"
+  version: "0.1"
+  synopsis: "UI toolkit for the terminal built on top of Notty and Lwd"
+  maintainer: "fred@tarides.com"
+  authors: "Frédéric Bour"
+  license: "MIT"
+  homepage: "https://github.com/let-def/lwd"
+  doc: "https://let-def.github.io/lwd/doc"
+  bug-reports: "https://github.com/let-def/lwd/issues"
+  depends: [
+    "dune" {>= "2.0"}
+    "lwd"
+    "notty"
+  ]
+  build: [
+    ["dune" "subst"] {pinned}
+    [
+      "dune"
+      "build"
+      "-p"
+      name
+      "-j"
+      jobs
+      "@install"
+      "@runtest" {with-test}
+      "@doc" {with-doc}
+    ]
+  ]
+  dev-repo: "git+https://github.com/let-def/lwd.git"
+  url {
+    src: "git+file:///home/cqc/p/console/ref/lwd#master"
+  }
+}