examples.ml lol that was hard

might require Focus.release, but may be incorrect use of Focus.request.

.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,123 @@
+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)
+
+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 webgl_initialize canvas =
+  scale_canvas canvas;
+  (* 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
+
+let graphv_initialize webgl_ctx =
+  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.;
+  vg
+
+let request_animation_frame () =
+  let t, s = Lwt.wait () in
+  let (_ : Dom_html.animation_frame_request_id) =
+    Dom_html.window##requestAnimationFrame
+      (Js.wrap_callback (fun (time : float) -> Lwt.wakeup s time))
+  in
+  t
+
+let render_stream canvas webgl_ctx vg
+    (render : NVG.t -> ?time:float -> Gg.p2 -> Human.I.t -> unit) :
+    Human.I.t Lwt_stream.t -> unit Lwt.t =
+  Lwt_stream.iter_n (fun i ->
+      request_animation_frame () >>= fun time ->
+      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
+      NVG.begin_frame vg ~width:canvas##.width ~height:canvas##.height
+        ~device_ratio;
+      NVG.Transform.scale vg ~x:device_ratio ~y:device_ratio;
+      render vg ~time Gg.P2.o i;
+      NVG.end_frame vg;
+      Lwt.return_unit)
+
+open Human
+
+let _ =
+  let canvas =
+    Js.Unsafe.coerce (Dom_html.getElementById_exn "canvas")
+  in
+  let webgl_ctx = webgl_initialize canvas in
+  let vg = graphv_initialize webgl_ctx in
+  let open Js_of_ocaml_lwt.Lwt_js_events in
+  let open Nottui in
+  let gravity_pad = Gravity.make ~h:`Negative ~v:`Negative in
+  let gravity_crop = Gravity.make ~h:`Positive ~v:`Negative in
+  let body = Lwd.var (Lwd.pure Ui.empty) in
+  let wm = Widgets.window_manager (Lwd.join (Lwd.get body)) in
+  Nav.test_populate () >>= fun test_store ->
+  let ui = Widgets.(h_node_area (test_store, [ [] ])) in
+  let root =
+    Lwd.set body
+      (Lwd.map ~f:(Ui.resize ~pad:gravity_pad ~crop:gravity_crop) ui);
+    Widgets.window_manager_view wm
+  in
+
+  let events, push_event = Lwt_stream.create () in
+  let images =
+    Human.Nottui_lwt.render vg
+      ~size:(Gg.P2.v canvas##.width canvas##.height)
+      events root
+  in
+  async (fun () ->
+      render_stream canvas webgl_ctx vg
+        (fun vg ?(time = 0.) p i ->
+          let _ = time in
+          Log.debug (fun m ->
+              m "Drawing image: p=%a n=%a" Gg.V2.pp p
+                (I.Draw.pp ~attr:A.dark)
+                i);
+          let p' = I.Draw.node vg A.dark p i in
+          Logs.debug (fun m ->
+              m "Drawing finished: p'=%a" Gg.V2.pp p'))
+        images);
+  buffered_loop (make_event Dom_html.Event.keydown) Dom_html.document
+    (fun ev _ ->
+      Dom.preventDefault ev;
+      Lwt.return
+      @@ push_event (Some (`Keys [ Event_js.evt_of_jskey ev ])))

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://gitea.departmentofinter.net --log-ip -c-1 -C /tmp/cert.pem -K /tmp/key.pem

dune

@@ -1,45 +1,160 @@
 (env
-  (dev
+ (dev (flags (:standard -warn-error -A))
-   (flags (:standard -warn-error -A))))
+  (js_of_ocaml (flags :standard)
-
+   (build_runtime_flags :standard --no-inline --debug-info)
-(executable
+   (compilation_mode whole_program)
- (name main)
+   (link_flags :standard))))
- (modes byte)
- (modules main)
- (link_flags (-linkall))
- (libraries
-  topinf
-  tsdl
-  tgls.tgles2
-  wall
-  zed
-  lambda-term
-  irmin-unix
-  ocaml-compiler-libs.common
-  ocaml-compiler-libs.bytecomp
-  ocaml-compiler-libs.toplevel))
-
-(executable
- (name boot)
- (modes byte)
- (modules boot)
- (link_flags (-linkall))
- (libraries
-  lambda-term
-  topinf))
 
 (library
- (name topinf)
+ (name log_js)
   (modes byte)
- (modules topinf)
+ (preprocess (pps js_of_ocaml-ppx))
+ (flags (:standard -rectypes -linkall))
+ (modules log_js)
+ (libraries
+   logs))
+
+(executable
+ (name boot_js)
+ (modes byte js)
+ (preprocess (pps js_of_ocaml-ppx)) 
+ (flags (:standard -rectypes -linkall))
+ (modules boot_js human)
  (libraries
    fmt
-  tsdl
+   graphv_webgl
-  tgls.tgles2
+   js_of_ocaml-lwt
-  wall
+   js_of_ocaml-compiler
-  zed
+   js_of_ocaml-toplevel
-  lambda-term
+   digestif.ocaml
-  irmin-unix
+   checkseum.ocaml
-  ocaml-compiler-libs.common
+   irmin.mem
-  ocaml-compiler-libs.bytecomp
+   git 
-  ocaml-compiler-libs.toplevel))
+   irmin-git
+   cohttp-lwt-jsoo
+   mimic
+   uri
+   gg
+   lwd
+   log_js))
+
+(rule
+ (targets test_dynlink.cmo test_dynlink.cmi)
+ (action
+  (run ocamlc -c %{dep:test_dynlink.ml})))
+
+(rule
+ (targets test_dynlink.js)
+ (action
+  (run %{bin:js_of_ocaml} --pretty --toplevel %{dep:test_dynlink.cmo})))
+
+(rule
+ (targets embedded_fs.js)
+ (action
+  (run %{bin:jsoo_fs} -I . -o %{targets} %{dep:examples.ml} %{dep:test_dynlink.js})))
+
+(rule
+ (targets export.txt)
+ (deps
+  (package js_of_ocaml-ppx)
+  (package js_of_ocaml)
+  (package js_of_ocaml-compiler)
+  (package js_of_ocaml-lwt)
+  (package js_of_ocaml-tyxml)
+  (package js_of_ocaml-toplevel))
+ (action
+  (run
+    jsoo_listunits
+    -o
+    %{targets}
+    stdlib
+    graphics
+    str
+    dynlink
+    js_of_ocaml-compiler.runtime
+    js_of_ocaml-lwt.graphics
+    js_of_ocaml-ppx.as-lib
+    js_of_ocaml.deriving
+    lwt
+    tyxml.functor
+    tyxml.functor:html_types.cmi
+    react
+    reactiveData
+    js_of_ocaml
+    js_of_ocaml-lwt
+    js_of_ocaml-tyxml
+    js_of_ocaml-toplevel
+    dynlink)))
+
+(executables
+ (names toplevel)
+ (modules toplevel ppx_graph)
+ (flags
+  (:standard -rectypes -linkall))
+ (modes js)
+ (js_of_ocaml
+  (flags
+   compile
+   --pretty
+   --Werror
+   --target-env
+   browser
+   --export
+   %{dep:export.txt}
+   --toplevel
+   --disable
+   shortvar
+   +toplevel.js
+   +dynlink.js
+   %{dep:embedded_fs.js}))
+ (preprocess
+  (pps js_of_ocaml-ppx))
+ (libraries
+  js_of_ocaml-compiler
+  js_of_ocaml-tyxml
+  js_of_ocaml-toplevel
+  lwt
+  js_of_ocaml-lwt
+  ;; not used directly
+  graphics
+  js_of_ocaml.deriving
+  js_of_ocaml-lwt.graphics
+  js_of_ocaml-ppx.as-lib
+  compiler-libs
+  compiler-libs.common
+  compiler-libs.bytecomp
+  js_of_ocaml-compiler.runtime
+  ocp-indent.lib
+  react
+  reactiveData
+  str
+  log_js)
+)
+
+; (rule
+;  (targets toplevel.js)
+;  (deps examples.ml)
+;  (action
+;   (run
+;    %{bin:js_of_ocaml}
+;    compile
+;    --pretty
+;    --Werror
+;    --target-env
+;    browser
+;    --extern-fs
+;    "--file=%{dep:examples.ml}"
+;    --export
+;    %{dep:export.txt}
+;    --toplevel
+;    --disable
+;    shortvar
+;    +toplevel.js
+;    +dynlink.js
+;    %{dep:toplevel.bc}
+;    -o
+;    %{targets})))
+
+(alias
+  (name default)
+  (deps toplevel.bc.js index.html toplevel.html))

dune-project

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

fonts/LICENSE.txt

@@ -0,0 +1,202 @@
+
+                                 Apache License
+                           Version 2.0, January 2004
+                        http://www.apache.org/licenses/
+
+   TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION
+
+   1. Definitions.
+
+      "License" shall mean the terms and conditions for use, reproduction,
+      and distribution as defined by Sections 1 through 9 of this document.
+
+      "Licensor" shall mean the copyright owner or entity authorized by
+      the copyright owner that is granting the License.
+
+      "Legal Entity" shall mean the union of the acting entity and all
+      other entities that control, are controlled by, or are under common
+      control with that entity. For the purposes of this definition,
+      "control" means (i) the power, direct or indirect, to cause the
+      direction or management of such entity, whether by contract or
+      otherwise, or (ii) ownership of fifty percent (50%) or more of the
+      outstanding shares, or (iii) beneficial ownership of such entity.
+
+      "You" (or "Your") shall mean an individual or Legal Entity
+      exercising permissions granted by this License.
+
+      "Source" form shall mean the preferred form for making modifications,
+      including but not limited to software source code, documentation
+      source, and configuration files.
+
+      "Object" form shall mean any form resulting from mechanical
+      transformation or translation of a Source form, including but
+      not limited to compiled object code, generated documentation,
+      and conversions to other media types.
+
+      "Work" shall mean the work of authorship, whether in Source or
+      Object form, made available under the License, as indicated by a
+      copyright notice that is included in or attached to the work
+      (an example is provided in the Appendix below).
+
+      "Derivative Works" shall mean any work, whether in Source or Object
+      form, that is based on (or derived from) the Work and for which the
+      editorial revisions, annotations, elaborations, or other modifications
+      represent, as a whole, an original work of authorship. For the purposes
+      of this License, Derivative Works shall not include works that remain
+      separable from, or merely link (or bind by name) to the interfaces of,
+      the Work and Derivative Works thereof.
+
+      "Contribution" shall mean any work of authorship, including
+      the original version of the Work and any modifications or additions
+      to that Work or Derivative Works thereof, that is intentionally
+      submitted to Licensor for inclusion in the Work by the copyright owner
+      or by an individual or Legal Entity authorized to submit on behalf of
+      the copyright owner. For the purposes of this definition, "submitted"
+      means any form of electronic, verbal, or written communication sent
+      to the Licensor or its representatives, including but not limited to
+      communication on electronic mailing lists, source code control systems,
+      and issue tracking systems that are managed by, or on behalf of, the
+      Licensor for the purpose of discussing and improving the Work, but
+      excluding communication that is conspicuously marked or otherwise
+      designated in writing by the copyright owner as "Not a Contribution."
+
+      "Contributor" shall mean Licensor and any individual or Legal Entity
+      on behalf of whom a Contribution has been received by Licensor and
+      subsequently incorporated within the Work.
+
+   2. Grant of Copyright License. Subject to the terms and conditions of
+      this License, each Contributor hereby grants to You a perpetual,
+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable
+      copyright license to reproduce, prepare Derivative Works of,
+      publicly display, publicly perform, sublicense, and distribute the
+      Work and such Derivative Works in Source or Object form.
+
+   3. Grant of Patent License. Subject to the terms and conditions of
+      this License, each Contributor hereby grants to You a perpetual,
+      worldwide, non-exclusive, no-charge, royalty-free, irrevocable
+      (except as stated in this section) patent license to make, have made,
+      use, offer to sell, sell, import, and otherwise transfer the Work,
+      where such license applies only to those patent claims licensable
+      by such Contributor that are necessarily infringed by their
+      Contribution(s) alone or by combination of their Contribution(s)
+      with the Work to which such Contribution(s) was submitted. If You
+      institute patent litigation against any entity (including a
+      cross-claim or counterclaim in a lawsuit) alleging that the Work
+      or a Contribution incorporated within the Work constitutes direct
+      or contributory patent infringement, then any patent licenses
+      granted to You under this License for that Work shall terminate
+      as of the date such litigation is filed.
+
+   4. Redistribution. You may reproduce and distribute copies of the
+      Work or Derivative Works thereof in any medium, with or without
+      modifications, and in Source or Object form, provided that You
+      meet the following conditions:
+
+      (a) You must give any other recipients of the Work or
+          Derivative Works a copy of this License; and
+
+      (b) You must cause any modified files to carry prominent notices
+          stating that You changed the files; and
+
+      (c) You must retain, in the Source form of any Derivative Works
+          that You distribute, all copyright, patent, trademark, and
+          attribution notices from the Source form of the Work,
+          excluding those notices that do not pertain to any part of
+          the Derivative Works; and
+
+      (d) If the Work includes a "NOTICE" text file as part of its
+          distribution, then any Derivative Works that You distribute must
+          include a readable copy of the attribution notices contained
+          within such NOTICE file, excluding those notices that do not
+          pertain to any part of the Derivative Works, in at least one
+          of the following places: within a NOTICE text file distributed
+          as part of the Derivative Works; within the Source form or
+          documentation, if provided along with the Derivative Works; or,
+          within a display generated by the Derivative Works, if and
+          wherever such third-party notices normally appear. The contents
+          of the NOTICE file are for informational purposes only and
+          do not modify the License. You may add Your own attribution
+          notices within Derivative Works that You distribute, alongside
+          or as an addendum to the NOTICE text from the Work, provided
+          that such additional attribution notices cannot be construed
+          as modifying the License.
+
+      You may add Your own copyright statement to Your modifications and
+      may provide additional or different license terms and conditions
+      for use, reproduction, or distribution of Your modifications, or
+      for any such Derivative Works as a whole, provided Your use,
+      reproduction, and distribution of the Work otherwise complies with
+      the conditions stated in this License.
+
+   5. Submission of Contributions. Unless You explicitly state otherwise,
+      any Contribution intentionally submitted for inclusion in the Work
+      by You to the Licensor shall be under the terms and conditions of
+      this License, without any additional terms or conditions.
+      Notwithstanding the above, nothing herein shall supersede or modify
+      the terms of any separate license agreement you may have executed
+      with Licensor regarding such Contributions.
+
+   6. Trademarks. This License does not grant permission to use the trade
+      names, trademarks, service marks, or product names of the Licensor,
+      except as required for reasonable and customary use in describing the
+      origin of the Work and reproducing the content of the NOTICE file.
+
+   7. Disclaimer of Warranty. Unless required by applicable law or
+      agreed to in writing, Licensor provides the Work (and each
+      Contributor provides its Contributions) on an "AS IS" BASIS,
+      WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or
+      implied, including, without limitation, any warranties or conditions
+      of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A
+      PARTICULAR PURPOSE. You are solely responsible for determining the
+      appropriateness of using or redistributing the Work and assume any
+      risks associated with Your exercise of permissions under this License.
+
+   8. Limitation of Liability. In no event and under no legal theory,
+      whether in tort (including negligence), contract, or otherwise,
+      unless required by applicable law (such as deliberate and grossly
+      negligent acts) or agreed to in writing, shall any Contributor be
+      liable to You for damages, including any direct, indirect, special,
+      incidental, or consequential damages of any character arising as a
+      result of this License or out of the use or inability to use the
+      Work (including but not limited to damages for loss of goodwill,
+      work stoppage, computer failure or malfunction, or any and all
+      other commercial damages or losses), even if such Contributor
+      has been advised of the possibility of such damages.
+
+   9. Accepting Warranty or Additional Liability. While redistributing
+      the Work or Derivative Works thereof, You may choose to offer,
+      and charge a fee for, acceptance of support, warranty, indemnity,
+      or other liability obligations and/or rights consistent with this
+      License. However, in accepting such obligations, You may act only
+      on Your own behalf and on Your sole responsibility, not on behalf
+      of any other Contributor, and only if You agree to indemnify,
+      defend, and hold each Contributor harmless for any liability
+      incurred by, or claims asserted against, such Contributor by reason
+      of your accepting any such warranty or additional liability.
+
+   END OF TERMS AND CONDITIONS
+
+   APPENDIX: How to apply the Apache License to your work.
+
+      To apply the Apache License to your work, attach the following
+      boilerplate notice, with the fields enclosed by brackets "[]"
+      replaced with your own identifying information. (Don't include
+      the brackets!)  The text should be enclosed in the appropriate
+      comment syntax for the file format. We also recommend that a
+      file or class name and description of purpose be included on the
+      same "printed page" as the copyright notice for easier
+      identification within third-party archives.
+
+   Copyright [yyyy] [name of copyright owner]
+
+   Licensed under the Apache License, Version 2.0 (the "License");
+   you may not use this file except in compliance with the License.
+   You may obtain a copy of the License at
+
+       http://www.apache.org/licenses/LICENSE-2.0
+
+   Unless required by applicable law or agreed to in writing, software
+   distributed under the License is distributed on an "AS IS" BASIS,
+   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+   See the License for the specific language governing permissions and
+   limitations under the License.

fonts/OFL.txt

@@ -0,0 +1,94 @@
+Copyright (c) 1994-2021, SIL International (http://www.sil.org/),
+with Reserved Font Names "Scheherazade" and "SIL".
+
+This Font Software is licensed under the SIL Open Font License, Version 1.1.
+This license is copied below, and is also available with a FAQ at:
+http://scripts.sil.org/OFL
+
+
+-----------------------------------------------------------
+SIL OPEN FONT LICENSE Version 1.1 - 26 February 2007
+-----------------------------------------------------------
+
+PREAMBLE
+The goals of the Open Font License (OFL) are to stimulate worldwide
+development of collaborative font projects, to support the font creation
+efforts of academic and linguistic communities, and to provide a free and
+open framework in which fonts may be shared and improved in partnership
+with others.
+
+The OFL allows the licensed fonts to be used, studied, modified and
+redistributed freely as long as they are not sold by themselves. The
+fonts, including any derivative works, can be bundled, embedded, 
+redistributed and/or sold with any software provided that any reserved
+names are not used by derivative works. The fonts and derivatives,
+however, cannot be released under any other type of license. The
+requirement for fonts to remain under this license does not apply
+to any document created using the fonts or their derivatives.
+
+DEFINITIONS
+"Font Software" refers to the set of files released by the Copyright
+Holder(s) under this license and clearly marked as such. This may
+include source files, build scripts and documentation.
+
+"Reserved Font Name" refers to any names specified as such after the
+copyright statement(s).
+
+"Original Version" refers to the collection of Font Software components as
+distributed by the Copyright Holder(s).
+
+"Modified Version" refers to any derivative made by adding to, deleting,
+or substituting -- in part or in whole -- any of the components of the
+Original Version, by changing formats or by porting the Font Software to a
+new environment.
+
+"Author" refers to any designer, engineer, programmer, technical
+writer or other person who contributed to the Font Software.
+
+PERMISSION & CONDITIONS
+Permission is hereby granted, free of charge, to any person obtaining
+a copy of the Font Software, to use, study, copy, merge, embed, modify,
+redistribute, and sell modified and unmodified copies of the Font
+Software, subject to the following conditions:
+
+1) Neither the Font Software nor any of its individual components,
+in Original or Modified Versions, may be sold by itself.
+
+2) Original or Modified Versions of the Font Software may be bundled,
+redistributed and/or sold with any software, provided that each copy
+contains the above copyright notice and this license. These can be
+included either as stand-alone text files, human-readable headers or
+in the appropriate machine-readable metadata fields within text or
+binary files as long as those fields can be easily viewed by the user.
+
+3) No Modified Version of the Font Software may use the Reserved Font
+Name(s) unless explicit written permission is granted by the corresponding
+Copyright Holder. This restriction only applies to the primary font name as
+presented to the users.
+
+4) The name(s) of the Copyright Holder(s) or the Author(s) of the Font
+Software shall not be used to promote, endorse or advertise any
+Modified Version, except to acknowledge the contribution(s) of the
+Copyright Holder(s) and the Author(s) or with their explicit written
+permission.
+
+5) The Font Software, modified or unmodified, in part or in whole,
+must be distributed entirely under this license, and must not be
+distributed under any other license. The requirement for fonts to
+remain under this license does not apply to any document created
+using the Font Software.
+
+TERMINATION
+This license becomes null and void if any of the above conditions are
+not met.
+
+DISCLAIMER
+THE FONT SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO ANY WARRANTIES OF
+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT
+OF COPYRIGHT, PATENT, TRADEMARK, OR OTHER RIGHT. IN NO EVENT SHALL THE
+COPYRIGHT HOLDER BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+INCLUDING ANY GENERAL, SPECIAL, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL
+DAMAGES, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+FROM, OUT OF THE USE OR INABILITY TO USE THE FONT SOFTWARE OR FROM
+OTHER DEALINGS IN THE FONT SOFTWARE.

fonts/README.txt

@@ -0,0 +1,77 @@
+Roboto Mono Variable Font
+=========================
+
+This download contains Roboto Mono as both variable fonts and static fonts.
+
+Roboto Mono is a variable font with this axis:
+  wght
+
+This means all the styles are contained in these files:
+  RobotoMono-VariableFont_wght.ttf
+  RobotoMono-Italic-VariableFont_wght.ttf
+
+If your app fully supports variable fonts, you can now pick intermediate styles
+that aren’t available as static fonts. Not all apps support variable fonts, and
+in those cases you can use the static font files for Roboto Mono:
+  static/RobotoMono-Thin.ttf
+  static/RobotoMono-ExtraLight.ttf
+  static/RobotoMono-Light.ttf
+  static/RobotoMono-Regular.ttf
+  static/RobotoMono-Medium.ttf
+  static/RobotoMono-SemiBold.ttf
+  static/RobotoMono-Bold.ttf
+  static/RobotoMono-ThinItalic.ttf
+  static/RobotoMono-ExtraLightItalic.ttf
+  static/RobotoMono-LightItalic.ttf
+  static/RobotoMono-Italic.ttf
+  static/RobotoMono-MediumItalic.ttf
+  static/RobotoMono-SemiBoldItalic.ttf
+  static/RobotoMono-BoldItalic.ttf
+
+Get started
+-----------
+
+1. Install the font files you want to use
+
+2. Use your app's font picker to view the font family and all the
+available styles
+
+Learn more about variable fonts
+-------------------------------
+
+  https://developers.google.com/web/fundamentals/design-and-ux/typography/variable-fonts
+  https://variablefonts.typenetwork.com
+  https://medium.com/variable-fonts
+
+In desktop apps
+
+  https://theblog.adobe.com/can-variable-fonts-illustrator-cc
+  https://helpx.adobe.com/nz/photoshop/using/fonts.html#variable_fonts
+
+Online
+
+  https://developers.google.com/fonts/docs/getting_started
+  https://developer.mozilla.org/en-US/docs/Web/CSS/CSS_Fonts/Variable_Fonts_Guide
+  https://developer.microsoft.com/en-us/microsoft-edge/testdrive/demos/variable-fonts
+
+Installing fonts
+
+  MacOS: https://support.apple.com/en-us/HT201749
+  Linux: https://www.google.com/search?q=how+to+install+a+font+on+gnu%2Blinux
+  Windows: https://support.microsoft.com/en-us/help/314960/how-to-install-or-remove-a-font-in-windows
+
+Android Apps
+
+  https://developers.google.com/fonts/docs/android
+  https://developer.android.com/guide/topics/ui/look-and-feel/downloadable-fonts
+
+License
+-------
+Please read the full license text (LICENSE.txt) to understand the permissions,
+restrictions and requirements for usage, redistribution, and modification.
+
+You can use them freely in your products & projects - print or digital,
+commercial or otherwise.
+
+This isn't legal advice, please consider consulting a lawyer and see the full
+license for all details.

index.html

@@ -0,0 +1,35 @@
+<!DOCTYPE html>
+<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>

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

@@ -0,0 +1,494 @@
+(*
+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
+open Lwt_react
+module F = Fmt
+
+module Communicator = struct
+  let base_path = "communicator"
+  let topch = "top"
+
+  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
+    (* 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 : 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
+
+  module Tree = struct
+    open Message
+
+    type selection = Istore.Key.t
+    type t = {store: Istore.t; view: Istore.key}
+
+    let contents {store; view} (s : selection) :
+        Istore.Contents.t option Lwt.t =
+      Istore.find store (view @ s)
+
+    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
+      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 add {store; view} ~(name : string list) ~(config : Istore.tree)
+        : t Lwt.t =
+      Istore.get_tree store name
+      >>= fun tree ->
+      Istore.Tree.remove tree ["_config"]
+      >>= fun tree ->
+      Istore.Tree.add_tree tree [] config
+      >>= fun tree ->
+      Istore.set_tree_exn ~info:Irmin.Info.none store name tree
+      >>= fun () -> Lwt.return {store; view}
+  end
+
+  module 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
+
+    module Config = struct
+      type t = Istore.tree
+
+      open Lwt.Infix
+
+      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' ->
+        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_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 (name, tree) ->
+          F.epr "Irc.connect server=%s @." name ;
+          Config.nick tree
+          >>= fun nick ->
+          Config.server tree
+          >>= fun server ->
+          Config.port tree
+          >>= fun port ->
+          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
+            ~connect:(fun () ->
+              add_msg "Connecting..."
+              >>= fun () ->
+              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:[name]
+              >>= fun chs ->
+              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 Panel
+    open Panel.Ui
+
+    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)
+
+    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
+                              (Ui.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' () =
+        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 ml ->
+      Lwd.set mlist ml ;
+      Istore.watch_key store path (fun _ ->
+          mlist' ()
+          >>= fun mlist' -> Lwt.return (Lwd.set mlist mlist') )
+
+    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) ;
+      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 ) ) )
+
+    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 ({store; view} : Tree.t) : (Event.t -> atom Lwt.t) Lwt.t
+        =
+      commview (store, view) >>= fun cv -> Panel.Ui.panel cv
+  end
+end
+
+(**
+   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" } ) )

log_js.ml

@@ -0,0 +1,56 @@
+module Logs_reporter = struct
+  (* Console reporter *)
+
+  open Jsoo_runtime
+
+  let console : Logs.level -> string -> unit =
+   fun level s ->
+    let meth =
+      match level with
+      | Logs.Error -> "error"
+      | Logs.Warning -> "warn"
+      | Logs.Info -> "info"
+      | Logs.Debug -> "debug"
+      | Logs.App -> "log"
+    in
+    ignore
+      (Js.meth_call
+         (Js.pure_js_expr "console")
+         meth
+         [| Js.string s |])
+
+  let ppf, flush =
+    let b = Buffer.create 255 in
+    let flush () =
+      let s = Buffer.contents b in
+      Buffer.clear b;
+      s
+    in
+    (Format.formatter_of_buffer b, flush)
+
+  let hook =
+    ref (fun level s ->
+        ignore (Logs.level_to_string (Some level) ^ ": " ^ s))
+
+  let console_report _src level ~over k msgf =
+    let k _ =
+      let s = flush () in
+      console level s;
+      !hook level s;
+      over ();
+      k ()
+    in
+    msgf @@ fun ?header ?tags fmt ->
+    let _tags = tags in
+    match header with
+    | None -> Format.kfprintf k ppf ("@[" ^^ fmt ^^ "@]@.")
+    | Some h -> Format.kfprintf k ppf ("[%s] @[" ^^ fmt ^^ "@]@.") h
+
+  let console_reporter () = { Logs.report = console_report }
+end
+
+let _ =
+  Logs.set_reporter (Logs_reporter.console_reporter ());
+  Logs.set_level (Some Debug)
+
+module Log = Logs

main.ml

@@ -1,970 +0,0 @@
-open Lwt.Infix
-module F = Fmt
-module Store = Irmin_unix.Git.FS.KV (Irmin.Contents.String)
-
-module Input = struct
-  open CamomileLibrary
-  open Zed_edit
-  open CamomileLibrary
-
-  (** Type of key code. *)
-  type code =
-    | Char of UChar.t  (** A unicode character. *)
-    | Enter
-    | Escape
-    | Tab
-    | Up
-    | Down
-    | Left
-    | Right
-    | F1
-    | F2
-    | F3
-    | F4
-    | F5
-    | F6
-    | F7
-    | F8
-    | F9
-    | F10
-    | F11
-    | F12
-    | Next_page
-    | Prev_page
-    | Home
-    | End
-    | Insert
-    | Delete
-    | Backspace
-    | Unknown
-    | None
-
-  module KeymodSet = struct
-    type t = Shift | Ctrl | Meta | Fn
-
-    let compare (x : t) (y : t) = compare x y
-  end
-
-  module Keymod = Set.Make (KeymodSet)
-
-  type key = {mods: Keymod.t; code: code}
-
-  module Key = struct
-    type t = key
-
-    let compare (x : t) (y : t) = compare x y
-  end
-
-  module Bind = struct
-    module S = Zed_input.Make (Key)
-    include S
-
-    type action = Custom of (unit -> unit) | Zed of Zed_edit.action
-
-    (* stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *)
-    let bindings = ref empty
-    let bind seq actions = bindings := add seq actions !bindings
-    let unbind seq = bindings := remove seq !bindings
-
-    type t = action list S.t
-    type resolver = action list S.resolver
-    type result = action list S.result
-
-    let default_resolver b = resolver [pack (fun (x : action list) -> x) b]
-
-    let get_resolver result default =
-      match result with Continue r -> r | _ -> default
-
-    let handle_actions actions zectx =
-      List.iter
-        (function Custom f -> f () | Zed za -> Zed_edit.get_action za zectx)
-        actions
-  end
-
-  (* stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *)
-  let string_of_code = function
-    | Char ch -> Printf.sprintf "Char 0x%02x" (UChar.code ch)
-    | Enter -> "Enter"
-    | Escape -> "Escape"
-    | Tab -> "Tab"
-    | Up -> "Up"
-    | Down -> "Down"
-    | Left -> "Left"
-    | Right -> "Right"
-    | F1 -> "F1"
-    | F2 -> "F2"
-    | F3 -> "F3"
-    | F4 -> "F4"
-    | F5 -> "F5"
-    | F6 -> "F6"
-    | F7 -> "F7"
-    | F8 -> "F8"
-    | F9 -> "F9"
-    | F10 -> "F10"
-    | F11 -> "F11"
-    | F12 -> "F12"
-    | Next_page -> "Next_page"
-    | Prev_page -> "Prev_page"
-    | Home -> "Home"
-    | End -> "End"
-    | Insert -> "Insert"
-    | Delete -> "Delete"
-    | Backspace -> "Backspace"
-    | Unknown -> "Unknown"
-    | None -> "None"
-
-  let to_string key =
-    Printf.sprintf "{ control = %B; meta = %B; shift = %B; fn = %B; code = %s }"
-      (Keymod.mem Ctrl key.mods) (Keymod.mem Meta key.mods)
-      (Keymod.mem Shift key.mods)
-      (Keymod.mem Fn key.mods) (string_of_code key.code)
-
-  let to_string_compact key =
-    let buffer = Buffer.create 32 in
-    if Keymod.mem Ctrl key.mods then Buffer.add_string buffer "C-" ;
-    if Keymod.mem Meta key.mods then Buffer.add_string buffer "M-" ;
-    if Keymod.mem Shift key.mods then Buffer.add_string buffer "S-" ;
-    if Keymod.mem Fn key.mods then Buffer.add_string buffer "Fn-" ;
-    ( match key.code with
-    | Char ch ->
-        let code = UChar.code ch in
-        if code <= 255 then
-          match Char.chr code 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
-    | Next_page -> Buffer.add_string buffer "next"
-    | Prev_page -> Buffer.add_string buffer "prev"
-    | code ->
-        Buffer.add_string buffer (String.lowercase_ascii (string_of_code code))
-    ) ;
-    Buffer.contents buffer
-end
-
-module Event = struct
-  open Tsdl
-  open CamomileLibrary
-  open Zed_edit
-  open Input
-  open Input.KeymodSet
-
-  type mouse = int * int
-
-  type event =
-    [ `Key_down of Input.key
-    | `Key_up of Input.key
-    | `Text_editing of string
-    | `Text_input of string
-    | `Mouse of mouse
-    | `Quit
-    | `Fullscreen of bool
-    | `Unknown of string
-    | `None ]
-
-  let string_of_event = function
-    | `Key_down _ -> "`Key_down"
-    | `Key_up _ -> "`Key_up"
-    | `Text_editing _ -> "`Text_editing"
-    | `Text_input _ -> "`Text_input"
-    | `Mouse _ -> "`Mouse"
-    | `Quit -> "`Quit"
-    | `Fullscreen _ -> "`Fullscreen"
-    | `Unknown _ -> "`Unknown"
-    | `None -> "`None"
-
-  let to_string ev =
-    let p =
-      match ev with
-      | `Key_down k | `Key_up k -> Input.to_string k
-      | `Text_editing s | `Text_input s -> s
-      | `Mouse _ -> ""
-      | `Fullscreen b -> Format.sprintf "%b" b
-      | `Unknown s -> s
-      | `Quit | `None -> "" in
-    string_of_event ev ^ " " ^ p
-
-  let event_of_sdlevent ev =
-    let key_of_sdlkey ev =
-      let km = Sdl.Event.get ev Sdl.Event.keyboard_keymod in
-      let (kc : Sdl.keycode) =
-        Sdl.Event.get ev Sdl.Event.keyboard_keycode
-        land lnot Sdl.K.scancode_mask in
-      let open Sdl.K in
-      let (c : Input.code) =
-        match (kc : Sdl.keycode) with
-        (* HACK WHENENENENENENENENEHWEHWEHNWEWHWEHWEN FUCK X WHEN X whatS>!!>!> *)
-        | x when x = return -> Enter
-        | x when x = escape -> Escape
-        | x when x = backspace -> Backspace
-        | x when x = tab -> Tab
-        | x when x = f1 -> F1
-        | x when x = f2 -> F2
-        | x when x = f3 -> F3
-        | x when x = f4 -> F4
-        | x when x = f5 -> F5
-        | x when x = f6 -> F6
-        | x when x = f7 -> F7
-        | x when x = f8 -> F8
-        | x when x = f9 -> F9
-        | x when x = f10 -> F10
-        | x when x = f11 -> F11
-        | x when x = f12 -> F12
-        | x when x = insert -> Insert
-        | x when x = delete -> Delete
-        | x when x = home -> Home
-        | x when x = kend -> End
-        | x when x = pageup -> Prev_page
-        | x when x = pagedown -> Next_page
-        | x when x = right -> Right
-        | x when x = left -> Left
-        | x when x = down -> Down
-        | x when x = up -> Up
-        | k -> (
-          match UChar.char_of (UChar.of_int k) with
-          | 'a' .. 'z'
-           |'A' .. 'Z'
-           |'0' .. '9'
-           |'_' | '(' | ')' | '[' | ']' | '{' | '}' | '#' | '~' | '&' | '$'
-           |'*' | '%' | '!' | '?' | ',' | ';' | ':' | '/' | '\\' | '.' | '@'
-           |'=' | '+' | '-' | ' ' | '"' | '\'' | '>' | '<' | '^' | '`' | '|' ->
-              Char (UChar.of_int k)
-          | _ -> None ) in
-      let mods =
-        List.filter_map
-          (fun (m, v) -> if km land m > 0 then Some v else None)
-          Sdl.Kmod.[(shift, Shift); (ctrl, Ctrl); (alt, Meta); (gui, Fn)] in
-      {code= c; mods= Input.Keymod.of_list mods} in
-    let repeat = Sdl.Event.get ev Sdl.Event.keyboard_repeat in
-    let r =
-      match Sdl.Event.enum (Sdl.Event.get ev Sdl.Event.typ) with
-      | `Text_editing ->
-          `Unknown
-            (Format.sprintf "`Text_editing %s"
-               (Sdl.Event.get ev Sdl.Event.text_editing_text) )
-      | `Text_input -> `Text_input (Sdl.Event.get ev Sdl.Event.text_input_text)
-      | `Key_down -> if repeat < 1 then `Key_down (key_of_sdlkey ev) else `None
-      | `Key_up -> if repeat < 1 then `Key_up (key_of_sdlkey ev) else `None
-      | `Mouse_motion ->
-          let _, mouse_xy = Tsdl.Sdl.get_mouse_state () in
-          `Mouse mouse_xy
-      | `Quit -> `Quit
-      (* Unhandled events *)
-      | `App_did_enter_background -> `Unknown "`App_did_enter_background"
-      | `App_did_enter_foreground -> `Unknown "`App_did_enter_foreground "
-      | `App_low_memory -> `Unknown "`App_low_memory "
-      | `App_terminating -> `Unknown "`App_terminating "
-      | `App_will_enter_background -> `Unknown "`App_will_enter_background "
-      | `App_will_enter_foreground -> `Unknown "`App_will_enter_foreground "
-      | `Clipboard_update -> `Unknown "`Clipboard_update "
-      | `Controller_axis_motion -> `Unknown "`Controller_axis_motion "
-      | `Controller_button_down -> `Unknown "`Controller_button_down "
-      | `Controller_button_up -> `Unknown "`Controller_button_up "
-      | `Controller_device_added -> `Unknown "`Controller_device_added "
-      | `Controller_device_remapped -> `Unknown "`Controller_device_remapped "
-      | `Controller_device_removed -> `Unknown "`Controller_device_removed "
-      | `Dollar_gesture -> `Unknown "`Dollar_gesture "
-      | `Dollar_record -> `Unknown "`Dollar_record "
-      | `Drop_file -> `Unknown "`Drop_file "
-      | `Finger_down -> `Unknown "`Finger_down"
-      | `Finger_motion -> `Unknown "`Finger_motion "
-      | `Finger_up -> `Unknown "`Finger_up "
-      | `Joy_axis_motion -> `Unknown "`Joy_axis_motion "
-      | `Joy_ball_motion -> `Unknown "`Joy_ball_motion "
-      | `Joy_button_down -> `Unknown "`Joy_button_down "
-      | `Joy_button_up -> `Unknown "`Joy_button_up "
-      | `Joy_device_added -> `Unknown "`Joy_device_added "
-      | `Joy_device_removed -> `Unknown "`Joy_device_removed "
-      | `Joy_hat_motion -> `Unknown "`Joy_hat_motion "
-      | `Mouse_button_down -> `Unknown "`Mouse_button_down "
-      | `Mouse_button_up -> `Unknown "`Mouse_button_up"
-      | `Mouse_wheel -> `Unknown "`Mouse_wheel "
-      | `Multi_gesture -> `Unknown "`Multi_gesture"
-      | `Sys_wm_event -> `Unknown "`Sys_wm_event "
-      | `Unknown e -> `Unknown (Format.sprintf "`Unknown %d " e)
-      | `User_event -> `Unknown "`User_event "
-      | `Window_event -> `Unknown "`Window_event "
-      | `Display_event -> `Unknown "`Display_event "
-      | `Sensor_update -> `Unknown "`Sensor_update " in
-    F.epr "event_of_sdlevent: %s@." (to_string r) ;
-    r
-
-  let key_up : Sdl.keycode = 0x40000052
-  let key_down : Sdl.keycode = 0x40000051
-  let key_left : Sdl.keycode = 0x40000050
-  let key_right : Sdl.keycode = 0x4000004f
-  let handle_keyevents (el : event list) f = List.iter f el
-end
-
-module Display = struct
-  open Tgles2
-  open Tsdl
-  open Gg
-  open CamomileLibrary
-  open Zed_edit
-  open Wall
-  module I = Image
-  module P = Path
-  module Text = Wall_text
-
-  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
-    ; events: Event.event list
-    ; wall: Wall.renderer }
-
-  type image = box2 * Wall.image
-  (* the box2 here is cannonically the place the returner drew
-     (the Wall.image extents) *)
-
-  type pane = state -> state * image
-  type box = {f: pane list -> pane; name: string; mutable focus: bool list}
-  type panetree = Empty | Box of (box * panetree list) | Pane of pane
-
-  type frame =
-    { sdl_win: Sdl.window
-    ; gl: Sdl.gl_context
-    ; wall: Wall.renderer
-    ; mutable quit: bool
-    ; mutable fullscreen: bool
-    ; mutable panetree: panetree }
-
-  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; panetree= Empty} )
-      ~cleanup:(fun () -> Sdl.destroy_window sdl_win)
-
-  let display_frame frame render =
-    (* create and fill event list *)
-    let ev = Sdl.Event.create () in
-    let el = ref [`None] in
-    while Sdl.wait_event_timeout (Some ev) 50 (* HACK *) do
-      let e = Event.event_of_sdlevent ev in
-      if e != `None then el := !el @ [e]
-      (* HACK? *)
-    done ;
-    (* Filter the events *)
-    el :=
-      List.filter_map
-        (function
-          | `Quit ->
-              frame.quit <- true ;
-              None
-          | `Fullscreen a ->
-              if a then (
-                frame.fullscreen <- not frame.fullscreen ;
-                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 ) ) ;
-              None
-          | `Key_up a -> Some (`Key_up a)
-          | `Key_down a -> Some (`Key_down a)
-          | `Mouse a -> Some (`Mouse a)
-          | a -> Some a (*| a -> Some a*) )
-        !el ;
-    if List.length !el > 0 then (
-      let width, height = Sdl.gl_get_drawable_size frame.sdl_win in
-      let _, (_, image) =
-        render
-          { box= Box2.v (P2.v 0. 0.) (P2.v (float width) (float height))
-          ; time= ticks ()
-          ; events= !el
-          ; wall= frame.wall } in
-      Sdl.gl_make_current frame.sdl_win frame.gl
-      >>= fun () ->
-      let width, height = Sdl.gl_get_drawable_size frame.sdl_win in
-      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 () )
-    else Ok ()
-
-  let run frame render () =
-    let frame = get_result frame in
-    Sdl.show_window frame.sdl_win ;
-    while not frame.quit do
-      ignore (display_frame frame render)
-    done ;
-    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
-
-  let load_font name =
-    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
-
-  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_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 = Text.Font.make ~size:(Box2.h b) (Lazy.force font_sans) in
-    ( Box2.v (Box2.o b) (P2.v (Text.Font.text_width f text) (Box2.h b))
-    , I.paint
-        (Paint.color (gray ~a:0.5 1.0))
-        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. 
-
-    Widgets 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 pane_box next_point_func (subpanes : pane list) (so : state) =
-    F.epr "pane_box: subpanes count=%d@." (List.length subpanes) ;
-    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))
-
-  (* draws the second item below if there's room in so.box *)
-  let pane_vbox =
-    { f= pane_box Box2.tl_pt
-    ; (* tl_pt is actually bl_pt in the Wall coordinate system *)
-      name= "vertical-box"
-    ; focus= [] }
-
-  (* draws second item to right if there's room in so.box *)
-  let pane_hbox =
-    { f= pane_box Box2.br_pt
-    ; (* br_pt is actually tr_pt in the Wall coordinate system *)
-      name= "horizontal-box"
-    ; focus= [] }
-
-  let simple_text f text (s : state) =
-    let fm = Text.Font.font_metrics f in
-    let font_height = fm.ascent -. fm.descent +. fm.line_gap in
-    let tm = 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))
-          Text.(
-            simple_text f ~valign:`BASELINE ~halign:`LEFT ~x:(Box2.ox s.box)
-              ~y:(Box2.oy s.box +. fm.ascent)
-              text) ) )
-
-  type Format.stag += Color_bg of Wall.color
-  type Format.stag += Color_fg of Wall.color
-  type Format.stag += Cursor of Wall.color
-
-  let draw_pp height fpp (s : state) =
-    let node, sc, box = (ref I.empty, ref s, ref Box2.zero) in
-    let push (s, (b, i)) =
-      node := I.stack !node i ;
-      sc := s ;
-      box := b in
-    let font = Text.Font.make ~size:height (Lazy.force font_sans) in
-    let fm = Text.Font.font_metrics font in
-    let font_height = fm.ascent -. fm.descent +. fm.line_gap in
-    let max_x = ref 0. in
-    let out_string text o l =
-      let sp = !sc in
-      push @@ simple_text font (String.sub text o l) !sc ;
-      max_x := max !max_x (Box2.maxx !box) ;
-      sc :=
-        { !sc with
-          box=
-            Box2.of_pts
-              (P2.v (Box2.maxx !box) (Box2.oy sp.box))
-              (Box2.max sp.box) } in
-    let out_flush () = () in
-    let out_newline () =
-      sc :=
-        { !sc with
-          box=
-            Box2.of_pts
-              (P2.v (Box2.ox s.box) (Box2.oy !sc.box +. font_height))
-              (Box2.max s.box) } in
-    let out_spaces n =
-      let wpx = Text.Font.text_width font " " in
-      if Box2.ox !sc.box +. (float n *. wpx) > Box2.maxx !sc.box then
-        (* WRAP *)
-        out_newline () ;
-      let so = !sc in
-      (* let bsp = Box2.v (Box2.br_pt !box) (P2.v wpx height) in
-         push @@ pane_hbox (List.init n (fun _ -> path_circle Color.green bsp)) !sc;*)
-      box := Box2.v (Box2.o so.box) (P2.v (float n *. wpx) height) ;
-      sc := {!sc with box= Box2.of_pts (Box2.br_pt !box) (Box2.max so.box)}
-    in
-    let out_indent n =
-      let p = min (Box2.w !sc.box -. 1.) (height *. 2.0 *. float n) in
-      sc :=
-        { !sc with
-          box=
-            Box2.of_pts
-              (P2.v (Box2.ox !sc.box +. p) (Box2.oy !sc.box))
-              (Box2.max !sc.box) } in
-    let out_funs =
-      Format.{out_string; out_flush; out_newline; out_spaces; out_indent} in
-    let pp = Format.formatter_of_out_functions out_funs in
-    Format.pp_set_formatter_stag_functions pp
-      { mark_open_stag=
-          (fun s ->
-            ( match s with
-            | Cursor c ->
-                push
-                @@ ( !sc
-                   , fill_box c
-                       (Box2.v (Box2.o !sc.box) (P2.v (height *. 0.333) height))
-                   )
-            | Color_bg c -> push @@ (!sc, fill_box c !box)
-            | _ -> () ) ;
-            "" )
-      ; mark_close_stag= (function _ -> () ; "")
-      ; print_open_stag= (fun _ -> (*"<open_stag>"*) ())
-      ; (* TKTKTKTK XXX IT SHOULD BE USING THESE print ONES *)
-        print_close_stag= (fun _ -> (*"<close_stag>"*) ()) } ;
-    Format.pp_set_tags pp true ;
-    let margin = int_of_float (Box2.w s.box /. Text.Font.text_width font " ") in
-    let max_indent = margin - 1 in
-    Format.pp_safe_set_geometry pp ~max_indent ~margin ;
-    fpp pp ;
-    Format.pp_force_newline pp () ;
-    (!sc, (Box2.of_pts (Box2.o s.box) (P2.v !max_x (Box2.maxy !box)), !node))
-end
-
-open Wall
-open Gg
-module I = Image
-module P = Path
-module Text = Wall_text
-
-let default_bindings =
-  let open Input.Bind in
-  let open CamomileLibrary in
-  let open Zed_edit in
-  let m = Input.Keymod.of_list in
-  let b = ref empty in
-  let add e a = b := Input.Bind.add e a !b in
-  add [{mods= m []; code= Left}] [Zed Prev_char] ;
-  add [{mods= m []; code= Right}] [Zed Next_char] ;
-  add [{mods= m []; code= Up}] [Zed Prev_line] ;
-  add [{mods= m []; code= Down}] [Zed Next_line] ;
-  add [{mods= m []; code= Home}] [Zed Goto_bol] ;
-  add [{mods= m []; code= End}] [Zed Goto_eol] ;
-  add [{mods= m []; code= Insert}] [Zed Switch_erase_mode] ;
-  add [{mods= m []; code= Delete}] [Zed Delete_next_char] ;
-  add [{mods= m []; code= Enter}] [Zed Newline] ;
-  add [{mods= m [Ctrl]; code= Char (UChar.of_char ' ')}] [Zed Set_mark] ;
-  add [{mods= m [Ctrl]; code= Char (UChar.of_char 'a')}] [Zed Goto_bol] ;
-  add [{mods= m [Ctrl]; code= Char (UChar.of_char 'e')}] [Zed Goto_eol] ;
-  add [{mods= m [Ctrl]; code= Char (UChar.of_char 'd')}] [Zed Delete_next_char] ;
-  add [{mods= m [Ctrl]; code= Char (UChar.of_char 'h')}] [Zed Delete_prev_char] ;
-  add [{mods= m [Ctrl]; code= Char (UChar.of_char 'k')}] [Zed Kill_next_line] ;
-  add [{mods= m [Ctrl]; code= Char (UChar.of_char 'u')}] [Zed Kill_prev_line] ;
-  add [{mods= m [Ctrl]; code= Char (UChar.of_char 'n')}] [Zed Next_line] ;
-  add [{mods= m [Ctrl]; code= Char (UChar.of_char 'p')}] [Zed Prev_line] ;
-  add [{mods= m [Ctrl]; code= Char (UChar.of_char 'w')}] [Zed Kill] ;
-  add [{mods= m [Ctrl]; code= Char (UChar.of_char 'y')}] [Zed Yank] ;
-  add [{mods= m []; code= Backspace}] [Zed Delete_prev_char] ;
-  add [{mods= m [Meta]; code= Char (UChar.of_char 'w')}] [Zed Copy] ;
-  add [{mods= m [Meta]; code= Char (UChar.of_char 'c')}] [Zed Capitalize_word] ;
-  add [{mods= m [Meta]; code= Char (UChar.of_char 'l')}] [Zed Lowercase_word] ;
-  add [{mods= m [Meta]; code= Char (UChar.of_char 'u')}] [Zed Uppercase_word] ;
-  add [{mods= m [Meta]; code= Char (UChar.of_char 'b')}] [Zed Prev_word] ;
-  add [{mods= m [Meta]; code= Char (UChar.of_char 'f')}] [Zed Next_word] ;
-  add [{mods= m [Meta]; code= Right}] [Zed Next_word] ;
-  add [{mods= m [Meta]; code= Left}] [Zed Prev_word] ;
-  add [{mods= m [Ctrl]; code= Right}] [Zed Next_word] ;
-  add [{mods= m [Ctrl]; code= Left}] [Zed Prev_word] ;
-  add [{mods= m [Meta]; code= Backspace}] [Zed Kill_prev_word] ;
-  add [{mods= m [Meta]; code= Delete}] [Zed Kill_prev_word] ;
-  add [{mods= m [Ctrl]; code= Delete}] [Zed Kill_next_word] ;
-  add [{mods= m [Meta]; code= Char (UChar.of_char 'd')}] [Zed Kill_next_word] ;
-  add [{mods= m [Ctrl]; code= Char (UChar.of_char '/')}] [Zed Undo] ;
-  add
-    [ {mods= m [Ctrl]; code= Char (UChar.of_char 'x')}
-    ; {mods= m []; code= Char (UChar.of_char 'u')} ]
-    [Zed Undo] ;
-  !b
-
-type textedit =
-  { ze: unit Zed_edit.t
-  ; zc: Zed_cursor.t
-  ; mutable bindings: Input.Bind.t
-  ; mutable binding_state: Input.Bind.result
-  ; mutable last_keyseq: Input.key list
-  ; mutable last_actions: Input.Bind.action list }
-
-let make_textedit () =
-  let z = Zed_edit.create () in
-  { ze= z
-  ; zc= Zed_edit.new_cursor z
-  ; bindings= default_bindings
-  ; binding_state= Input.Bind.S.Rejected
-  ; last_keyseq= [{mods= Input.Keymod.empty; code= Input.None}]
-  ; last_actions= [] }
-
-let draw_textedit (te : textedit) height (s : Display.state) =
-  let ctx = Zed_edit.context te.ze te.zc in
-  (* collect events and update Zed context *)
-  List.iter
-    (function
-      | `Key_down (k : Input.key) -> (
-          let open Input.Bind in
-          ( match te.binding_state with
-          | Accepted _ | Rejected ->
-              te.last_keyseq <- [] ;
-              te.last_actions <- []
-          | Continue _ -> () ) ;
-          te.binding_state <-
-            resolve k
-              (get_resolver te.binding_state (default_resolver te.bindings)) ;
-          te.last_keyseq <- k :: te.last_keyseq ;
-          match te.binding_state with
-          | Accepted a ->
-              te.last_actions <- a ;
-              List.iter
-                (function
-                  | Input.Bind.Custom f -> f ()
-                  | Zed za -> Zed_edit.get_action za ctx )
-                a
-          | Continue _ -> ()
-          | Rejected -> () )
-      | `Key_up _ -> ()
-      | `Text_input s ->
-          Zed_edit.insert ctx (Zed_rope.of_string (Zed_string.of_utf8 s))
-      | _ -> () )
-    s.events ;
-  (* draw contents *)
-  Display.draw_pp height
-    (fun pp ->
-      let zrb, zra =
-        Zed_rope.break (Zed_edit.text te.ze) (Zed_cursor.get_position te.zc)
-      in
-      let before_cursor = Zed_string.to_utf8 (Zed_rope.to_string zrb) in
-      let after_cursor = Zed_string.to_utf8 (Zed_rope.to_string zra) in
-      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)) ;
-      F.pf pp "" ;
-      Format.pp_close_stag pp () ;
-      F.text pp after_cursor ;
-      F.pf pp "@." ;
-      Format.pp_close_box pp () )
-    s
-
-(* pane that displays last key binding match state *)
-let draw_textedit_input height (te : textedit) =
-  Display.draw_pp height (fun pp ->
-      Format.pp_open_hbox pp () ;
-      F.text pp
-        (List.fold_right
-           (fun x s -> Input.to_string_compact x ^ " " ^ s)
-           te.last_keyseq "" ) ;
-      F.text pp
-        (List.fold_right
-           (fun x s ->
-             s ^ "-> "
-             ^ Input.Bind.(
-                 match x with
-                 | Zed a -> Zed_edit.name_of_action a
-                 | Custom _ -> "Custom") )
-           te.last_actions "" ) ;
-      Format.pp_close_box pp () ;
-      F.flush pp () )
-
-let str_of_textedit (te : textedit) =
-  Zed_string.to_utf8 (Zed_rope.to_string (Zed_edit.text te.ze))
-
-type storeview = {s: Store.t; path: string list}
-
-let make_storeview storepath branch ?(path = []) () =
-  { s=
-      Lwt_main.run
-        (Store.of_branch
-           (Lwt_main.run (Store.Repo.v (Irmin_git.config storepath)))
-           branch )
-  ; path }
-
-let draw_storeview (r : storeview) height (s : Display.state) =
-  let indent = ref 0 in
-  let rec draw_levels (tree : (string * Store.tree) list) pp =
-    indent := !indent + 1 ;
-    List.iter
-      (fun (step, node) ->
-        Format.pp_open_vbox pp 0 ;
-        Format.pp_open_hbox pp () ;
-        for _ = 0 to !indent do
-          Format.pp_print_space pp ()
-        done ;
-        Format.fprintf pp "%d-%s@." !indent step ;
-        Format.pp_close_box pp () ;
-        let subtree = Lwt_main.run (Store.Tree.list node []) in
-        draw_levels subtree pp ; Format.pp_close_box pp () )
-      tree ;
-    indent := !indent - 1 in
-  let root =
-    Lwt_main.run (Store.get_tree r.s r.path >>= fun n -> Store.Tree.list n [])
-  in
-  Display.draw_pp height (draw_levels root) s
-
-let format_symbolic_output_buffer (ppf : Format.formatter) buf =
-  List.iter
-    Format.(
-      function
-      | Output_flush -> F.pf ppf "@?"
-      | Output_newline -> F.pf ppf "@."
-      | Output_string s -> Format.pp_print_string ppf s
-      | Output_spaces n | Output_indent n ->
-          Format.pp_print_string ppf (String.make n ' '))
-    buf
-
-let out_funs_of_sob sob =
-  Format.
-    { out_string=
-        (fun s p n ->
-          add_symbolic_output_item sob (Output_string (String.sub s p n)) )
-    ; out_flush= (fun () -> add_symbolic_output_item sob Output_flush)
-    ; out_indent= (fun n -> add_symbolic_output_item sob (Output_indent n))
-    ; out_newline= (fun () -> add_symbolic_output_item sob Output_newline)
-    ; out_spaces= (fun n -> add_symbolic_output_item sob (Output_spaces n)) }
-
-type top =
-  { te: textedit
-  ; res: Format.symbolic_output_buffer
-  ; mutable eval: Topinf.evalenv option
-  ; mutable path: string list
-  ; mutable histpath: string list
-  ; storeview: storeview }
-
-let make_top storepath ?(branch = "current") () =
-  let t =
-    { te= make_textedit ()
-    ; res= Format.make_symbolic_output_buffer ()
-    ; eval= None
-    ; path= ["init"]
-    ; histpath= ["history"]
-    ; storeview= 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) ;
-  let zctx = Zed_edit.context t.te.ze t.te.zc in
-  Zed_edit.insert zctx
-    (Zed_rope.of_string
-       (Zed_string.of_utf8 (Lwt_main.run (Store.get t.storeview.s t.path))) ) ;
-  t
-
-let pane_top (t : top) height =
-  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 ppf "#use \"init.ml\";;"; *)
-        e
-    | Some e -> e in
-  let eval () =
-    try
-      ignore
-        (Lwt_main.run
-           ( Store.tree t.storeview.s
-           >>= fun tree ->
-           Store.Tree.add tree (t.histpath @ ["input"]) (str_of_textedit t.te)
-           ) ) ;
-      ignore (Format.flush_symbolic_output_buffer t.res) ;
-      F.epr "pane_top//eval//%s@." (str_of_textedit t.te) ;
-      eval ppf (str_of_textedit t.te ^ ";;") ;
-      (*HACK to prevent getting stuck in parser*)
-      let b = Buffer.create 69 in
-      format_symbolic_output_buffer
-        (Format.formatter_of_buffer b)
-        (Format.get_symbolic_output_buffer t.res) ;
-      ignore
-        (Lwt_main.run
-           ( Store.tree t.storeview.s
-           >>= fun tree ->
-           Store.Tree.add tree (t.histpath @ ["output"]) (Buffer.contents b) ) ) ;
-      ignore
-        (Lwt_main.run
-           (Store.set_exn t.storeview.s
-              ~info:(Irmin_unix.info "history")
-              t.path (str_of_textedit t.te) ) ) ;
-      Zed_edit.clear_data t.te.ze
-    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.bindings <-
-    Input.(
-      Bind.add
-        [{mods= Keymod.of_list [Ctrl]; code= Enter}]
-        Bind.[Custom eval]
-        t.te.bindings) ;
-  let draw_top (s : Display.state) =
-    (s, (Box2.of_pts (Box2.o s.box) (Box2.o s.box), Image.empty)) in
-  Display.(
-    Box
-      ( pane_vbox
-      , [ Pane draw_top; Pane (draw_textedit t.te height)
-        ; Pane
-            (draw_pp height (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 () ) ); Pane (draw_storeview t.storeview height)
-        ; Pane (draw_textedit_input height t.te) ] ))
-
-let top_1 = make_top "../rootstore" ()
-
-let rec draw_panetree_default =
-  Display.(
-    function
-    | Box (b, l) ->
-        F.epr "draw_panetree_default: Box b.name=%s@." b.name ;
-        b.f
-          (List.filter_map
-             (function
-               | Box _ as bb -> Some (draw_panetree_default bb)
-               | Pane p -> Some p
-               | Empty -> None )
-             l )
-    | Pane p -> p
-    | Empty -> fun (s : state) -> (s, (Box2.empty, Image.empty)))
-
-let draw_panetree = ref draw_panetree_default
-
-let ptref : Display.panetree ref =
-  ref
-    Display.(
-      Box
-        ( pane_vbox
-        , [ Pane
-              (fun s ->
-                F.epr "ptref//Box(_, [%s .. ]) br=%s@." (str_of_box s.box)
-                  (str_of_box (Box2.of_pts (Box2.o s.box) (Box2.o s.box))) ;
-                F.epr "ptref//Box(_, [%s .. ])@." (str_of_box s.box) ;
-                (s, (Box2.of_pts (Box2.o s.box) (Box2.o s.box), Image.empty)) )
-          ; Pane
-              (fun (s : state) ->
-                let _, i = fill_box (Display.gray 0.125) s.box in
-                (s, (Box2.of_pts (Box2.o s.box) (Box2.o s.box), i)) )
-          ; pane_top top_1 30. ] ))
-
-let () =
-  Display.(
-    run (make_frame ~title:"hi" ~w:1440 ~h:900 ()) (!draw_panetree !ptref))
-    ()
-
-(* Implement the "window management" as just toplevel defined functions that manipulate the window tree *)

notes.org

@@ -0,0 +1,44 @@
+* mvp todo
+
+
+** toplevel repl in js_of_ocaml
+** git pull from gitea.departmentofinter.net/console/boot
+** git push to gitea.departmentofinter.net/console/boot
+** execute a git file execution in top level
+** display arbitrary git file from pulled repo
+** edit arbitrary file with common emacs bindings
+*** move left and right by character
+*** move up and down by line
+
+
+
+
+
+
+* other todo
+*** yank (to clipboard) next char
+*** move left and right by word and sentance
+*** region select
+
+
+* principles?
+an "anywhere" programming environment
+
+* 221211
+ok you got the scroll box mostly working so next:
+** fix the scroll jump bugs
+** setup better keybindings
+** fix cursor and active focus indicators
+
+
+
+* 221210 -
+** need to resolve the issue with the ui.t Resize type.
+this is an issue with the direction of the determination of the .height and .width fields of Ui.t
+
+currently you were planning to combine update_sensors and update_size
+
+in the original nottui.ml library, are Ui.t.w and Ui.t.h determined from the top down orbottom up?
+the bottom up, becahse they are chars
+
+

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"
+  }
+}

ppx_graph.ml

@@ -0,0 +1,11 @@
+open Ppxlib
+open Log_js
+
+let log_info pp exp =
+  Log.info (fun m -> m "ppx_graph: %a" pp exp);
+  exp
+
+let init () =
+  Driver.register_transformation
+    ~impl:(log_info Ocaml_common.Pprintast.structure)
+    "ppx_graph"

topinf.mli

@@ -6,7 +6,6 @@ val setvalue : string -> Obj.t -> unit
 (* End of: accessors for table of toplevel value bindings that must be first in the module signature *)
 
 val print_toplevel_value_bindings : Format.formatter -> unit
-
 val toplevel_env : Env.t ref
 
 type evalenv = Format.formatter -> string -> unit
@@ -20,12 +19,12 @@ type directive_fun =
   | Directive_ident of (Longident.t -> unit)
   | Directive_bool of (bool -> unit)
 
-type directive_info = { section : string; doc : string }
+type directive_info = {section: string; doc: string}
 
-val add_directive : Misc.filepath -> directive_fun -> directive_info -> unit
+val add_directive :
+  Misc.filepath -> directive_fun -> directive_info -> unit
 
 val directive_info_table : (string, directive_info) Hashtbl.t
-
 val ppf : Format.formatter ref
-
+val eval : evalenv ref
-val eval : evalenv option ref
+val eval_value_path : Env.t -> Path.t -> Obj.t

toplevel.html

@@ -0,0 +1,230 @@
+<?xml version="1.0" encoding="utf-8"?>
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN"
+          "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
+<html xmlns="http://www.w3.org/1999/xhtml">
+  <head>
+    <title>OCaml toplevel</title>
+    <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
+    <link rel="stylesheet" href="//maxcdn.bootstrapcdn.com/bootstrap/3.3.5/css/bootstrap.min.css" />
+    <link rel="stylesheet" href="https://maxcdn.bootstrapcdn.com/bootstrap/3.3.5/css/bootstrap.min.css" />
+    <style>
+
+      code, kbd, pre, samp {
+      font-family: Menlo,Monaco,Consolas,monospace;
+      }
+      body,html {
+      height: 100%;
+      background-color:#eee;
+      }
+
+      #toplevel-container {
+      width: 50%;
+      background-color: black;
+      color: #ccc;
+      overflow: auto;
+      overflow-x: hidden;
+      height: 100%;
+      float:left;
+      padding:10px;
+      padding-top: 20px;
+      }
+
+      #toplevel-container pre#output {
+      padding: 0px;
+      }
+
+      #toplevel-container #output {
+      background-color:transparent;
+      color: #ccc;
+      border: none;
+      line-height:18px;
+      font-size: 12px;
+      margin-bottom: 0px;
+      }
+
+      #toplevel-container textarea {
+      width:90%;
+      line-height:18px;
+      font-size: 12px;
+      background-color: transparent;
+      color: #fff;
+      border: 0;
+      resize: none;
+      outline: none;
+      font-family: Menlo,Monaco,Consolas,monospace;
+      font-weight: bold;
+      float:left;
+      margin: 0px;
+      padding:0px;
+      }
+      #toplevel-container #sharp {
+      float: left;
+      line-height:18px;
+      font-size: 12px;
+      font-family: Menlo,Monaco,Consolas,monospace;
+      white-space: pre;
+      }
+      .sharp:before{
+      content:"# ";
+      line-height:18px;
+      font-size: 12px;
+      font-family: Menlo,Monaco,Consolas,monospace;
+      }
+      .caml{
+      color:rgb(110, 110, 201);
+      }
+      #toplevel-side{
+      position:relative;
+      width:45%;
+      height: 100%;
+      overflow: auto;
+      text-align:justify;
+      float:left;
+      margin-left:30px;
+      }
+      #toplevel-side ul{
+      padding: 0px;
+      list-style-type: none;
+      }
+
+      .stderr {
+      color: #d9534f;
+      }
+      .stdout {
+
+      }
+      .errorloc{
+      border-bottom-width: 3px;
+      border-bottom-style: solid;
+      border-bottom-color: red;
+      }
+      canvas {
+      border: 1px dashed black;
+      float: left;
+      margin: 7px;
+      }
+      #output canvas {
+      background-color: #464646;
+      float: none;
+      display: block;
+      border: 1px dashed while;
+      margin: 7px;
+      }
+      #output img {
+      display:block;
+      }
+      #toplevel-examples {
+      width: 270px;
+      float: left;
+      }
+      #toplevel-examples .list-group-item{
+      padding: 5px 15px;
+      }
+      #btn-share {
+      float:right;
+      margin-top:-20px;
+      background-color:rgb(92, 129, 184);
+      border-color: rgb(70, 75, 128);
+      padding: 1px 5px;
+      display:none;
+      }
+      .clear { clear:both; }
+
+      .sharp .id { color: #59B65C ; font-style: italic }
+      .sharp .kw0 { color: rgb(64, 75, 190); font-weight: bold ;}
+      .sharp .kw1 { color: rgb(150, 0, 108); font-weight: bold ;}
+      .sharp .kw2 { color: rgb(23, 100, 42); font-weight: bold ;}
+      .sharp .kw3 { color: #59B65C; font-weight: bold ;}
+      .sharp .kw4 { color: #59B65C; font-weight: bold ;}
+      .sharp .comment { color: green ; font-style: italic ; }
+      .sharp .string { color: #6B6B6B; font-weight: bold ; }
+      .sharp .text { }
+      .sharp .numeric { color: #729AAF; }
+      .sharp .directive { font-style: italic ; color : #EB00FF; } ;
+      .sharp .escape { color: #409290 ; }
+      .sharp .symbol0 { color: orange ; font-weight: bold ; }
+      .sharp .symbol1 { color: #993300 ; font-weight: bold ; }
+      .sharp .constant { color: rgb(0, 152, 255); }
+    </style>
+    <script type="text/javascript">
+
+      window.onhashchange = function() { window.location.reload() }
+      var hash = window.location.hash.replace(/^#/,"");
+      var fields = hash.split(/&/);
+      var prefix = "";
+      var version = "";
+      for(var f in fields){
+        var data = fields[f].split(/=/);
+        if(data[0] == "version"){
+          version = data[1].replace(/%20|%2B/g,"+");
+          break;
+        }
+      }
+      function load_script(url){
+        var fileref=document.createElement('script');
+        fileref.setAttribute("type","text/javascript");
+        fileref.setAttribute("src", prefix+(version==""?"":(version+"/"))+url);
+        document.getElementsByTagName("head")[0].appendChild(fileref);
+      }
+      load_script("_build/default/exported-unit.cmis.js");
+      load_script("_build/default/toplevel.bc.js");
+
+    </script>
+  </head>
+  <body>
+    <div id="toplevel-container">
+      <pre id="output"></pre>
+      <div>
+        <div id="sharp" class="sharp"></div>
+        <textarea id="userinput">Loading ...</textarea>
+        <button type="button" class="btn btn-default"
+                id="btn-share">Share</button>
+      </div>
+    </div>
+    <div id="toplevel-side">
+      <h3>Js_of_ocaml</h3>
+      <h4>A compiler from OCaml bytecode to Javascript.</h4>
+      <p>It makes OCaml programs that run on Web browsers. It is
+        easy to install as it works with an existing installation of OCaml,
+        with no need to recompile any library. It comes with bindings for a
+        large part of the browser APIs.</p>
+      <p>This web-based OCaml toplevel is compiled using Js_of_ocaml.</p>
+      <h4>Command</h4>
+      <table class="table table-striped table-condensed">
+        <tbody class>
+          <tr>
+            <td>Enter/Return</td>
+            <td>Submit code</td>
+          </tr>
+          <tr>
+            <td>Ctrl + Enter</td>
+            <td>Newline</td>
+          </tr>
+          <tr>
+            <td>Up / Down</td>
+            <td>Browse history</td>
+          </tr>
+          <tr>
+            <td>Ctrl + l</td>
+            <td>Clear display</td>
+          </tr>
+          <tr>
+            <td>Ctrl + k</td>
+            <td>Reset toplevel</td>
+          </tr>
+          <tr>
+            <td>Tab</td>
+            <td>Indent code</td>
+          </tr>
+
+        </tbody>
+      </table>
+      <h4>Try to execute samples</h4>
+      <div id="toplevel-examples" class="list-group"></div>
+      <canvas width=200 height=200 id="test-canvas"></canvas>
+      <h4 class="clear">See the generated javascript code</h4>
+      <pre id="last-js">
+      </pre>
+    </div>
+  </body>
+</html>

toplevel.ml

@@ -0,0 +1,644 @@
+(* Js_of_ocaml toplevel
+ * http://www.ocsigen.org/js_of_ocaml/
+ * Copyright (C) 2011 Jérôme Vouillon
+ * Laboratoire PPS - CNRS Université Paris Diderot
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, with linking exception;
+ * either version 2.1 of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+ *)
+
+open Js_of_ocaml
+open Js_of_ocaml_lwt
+open Js_of_ocaml_tyxml
+open Js_of_ocaml_toplevel
+open Lwt
+
+module Graphics_support = struct
+  let init elt = Graphics_js.open_canvas elt
+end
+
+open Log_js
+
+module Ppx_support = struct
+  let init () =
+    Ppx_graph.init ();
+    Ast_mapper.register "js_of_ocaml" (fun _ -> Ppx_js.mapper);
+    Ast_mapper.register "ppxlib" (fun _ ->
+        Log.info (fun m -> m "Ppxlib.mapper");
+        {
+          Ast_mapper.default_mapper with
+          structure =
+            (fun _ ->
+              Log.info (fun m -> m "Ppxlib.Driver.map_structure");
+              Ppxlib.Driver.map_structure);
+          signature =
+            (fun _ ->
+              Log.info (fun m -> m "Ppxlib.Driver.map_signature");
+              Ppxlib.Driver.map_signature);
+        })
+end
+
+module Colorize = struct
+  open Js_of_ocaml
+  open Js_of_ocaml_tyxml
+
+  let text ~a_class:cl s =
+    Tyxml_js.Html.(span ~a:[ a_class [ cl ] ] [ txt s ])
+
+  let ocaml = text
+
+  let highlight from_ to_ e =
+    match Js.Opt.to_option e##.textContent with
+    | None -> assert false
+    | Some x ->
+        let x = Js.to_string x in
+        let (`Pos from_) = from_ in
+        let to_ =
+          match to_ with `Pos n -> n | `Last -> String.length x - 1
+        in
+        e##.innerHTML := Js.string "";
+        let span kind s =
+          if s <> "" then
+            let span =
+              Tyxml_js.Html.(span ~a:[ a_class [ kind ] ] [ txt s ])
+            in
+            Dom.appendChild e (Tyxml_js.To_dom.of_element span)
+        in
+        span "normal" (String.sub x 0 from_);
+        span "errorloc" (String.sub x from_ (to_ - from_));
+        span "normal" (String.sub x to_ (String.length x - to_))
+end
+
+module Indent : sig
+  val textarea : Dom_html.textAreaElement Js.t -> unit
+end = struct
+  let _ = Approx_lexer.enable_extension "lwt"
+
+  let indent s in_lines =
+    let output =
+      {
+        IndentPrinter.debug = false;
+        config = IndentConfig.default;
+        in_lines;
+        indent_empty = true;
+        adaptive = true;
+        kind = IndentPrinter.Print (fun s acc -> acc ^ s);
+      }
+    in
+    let stream = Nstream.of_string s in
+    IndentPrinter.proceed output stream IndentBlock.empty ""
+
+  let textarea (textbox : Dom_html.textAreaElement Js.t) : unit =
+    let rec loop s acc (i, pos') =
+      try
+        let pos = String.index_from s pos' '\n' in
+        loop s ((i, (pos', pos)) :: acc) (succ i, succ pos)
+      with _ -> List.rev ((i, (pos', String.length s)) :: acc)
+    in
+    let rec find (l : (int * (int * int)) list) c =
+      match l with
+      | [] -> assert false
+      | (i, (lo, up)) :: _ when up >= c -> (c, i, lo, up)
+      | (_, (_lo, _up)) :: rem -> find rem c
+    in
+    let v = textbox##.value in
+    let pos =
+      let c1 = textbox##.selectionStart
+      and c2 = textbox##.selectionEnd in
+      if
+        Js.Opt.test (Js.Opt.return c1)
+        && Js.Opt.test (Js.Opt.return c2)
+      then
+        let l = loop (Js.to_string v) [] (0, 0) in
+        Some (find l c1, find l c2)
+      else None
+    in
+    let f =
+      match pos with
+      | None -> fun _ -> true
+      | Some ((_c1, line1, _lo1, _up1), (_c2, line2, _lo2, _up2)) ->
+          fun l -> l >= line1 + 1 && l <= line2 + 1
+    in
+    let v = indent (Js.to_string v) f in
+    textbox##.value := Js.string v;
+    match pos with
+    | Some ((c1, line1, _lo1, up1), (c2, line2, _lo2, up2)) ->
+        let l = loop v [] (0, 0) in
+        let lo1'', up1'' = List.assoc line1 l in
+        let lo2'', up2'' = List.assoc line2 l in
+        let n1 = max (c1 + up1'' - up1) lo1'' in
+        let n2 = max (c2 + up2'' - up2) lo2'' in
+        let () = (Obj.magic textbox)##setSelectionRange n1 n2 in
+        textbox##focus;
+        ()
+    | None -> ()
+end
+
+let compiler_name = "OCaml"
+let by_id s = Dom_html.getElementById s
+
+let by_id_coerce s f =
+  Js.Opt.get
+    (f (Dom_html.getElementById s))
+    (fun () -> raise Not_found)
+
+let do_by_id s f =
+  try f (Dom_html.getElementById s) with Not_found -> ()
+
+(* load file using a synchronous XMLHttpRequest *)
+let load_resource_aux filename url =
+  Js_of_ocaml_lwt.XmlHttpRequest.perform_raw
+    ~response_type:XmlHttpRequest.ArrayBuffer url
+  >|= fun frame ->
+  if frame.Js_of_ocaml_lwt.XmlHttpRequest.code = 200 then
+    Js.Opt.case frame.Js_of_ocaml_lwt.XmlHttpRequest.content
+      (fun () -> Printf.eprintf "Could not load %s\n" filename)
+      (fun b ->
+        Sys_js.update_file ~name:filename
+          ~content:(Typed_array.String.of_arrayBuffer b))
+  else ()
+
+let load_resource scheme ~prefix ~path:suffix =
+  let url = scheme ^ suffix in
+  let filename = Filename.concat prefix suffix in
+  Lwt.async (fun () -> load_resource_aux filename url);
+  Some ""
+
+let setup_pseudo_fs () =
+  Sys_js.mount ~path:"/dev/" (fun ~prefix:_ ~path:_ -> None);
+  Sys_js.mount ~path:"/http/" (load_resource "http://");
+  Sys_js.mount ~path:"/https/" (load_resource "https://");
+  Sys_js.mount ~path:"/ftp/" (load_resource "ftp://");
+  Sys_js.mount ~path:"/home/" (load_resource "filesys/")
+
+let exec' s =
+  let res : bool = JsooTop.use Format.std_formatter s in
+  if not res then Format.eprintf "error while evaluating %s@." s
+
+module Version = struct
+  type t = int list
+
+  let split_char ~sep p =
+    let len = String.length p in
+    let rec split beg cur =
+      if cur >= len then
+        if cur - beg > 0 then [ String.sub p beg (cur - beg) ] else []
+      else if sep p.[cur] then
+        String.sub p beg (cur - beg) :: split (cur + 1) (cur + 1)
+      else split beg (cur + 1)
+    in
+    split 0 0
+
+  let split v =
+    match
+      split_char
+        ~sep:(function '+' | '-' | '~' -> true | _ -> false)
+        v
+    with
+    | [] -> assert false
+    | x :: _ ->
+        List.map int_of_string
+          (split_char ~sep:(function '.' -> true | _ -> false) x)
+
+  let current : t = split Sys.ocaml_version
+  let compint (a : int) b = compare a b
+
+  let rec compare v v' =
+    match (v, v') with
+    | [ x ], [ y ] -> compint x y
+    | [], [] -> 0
+    | [], y :: _ -> compint 0 y
+    | x :: _, [] -> compint x 0
+    | x :: xs, y :: ys -> (
+        match compint x y with 0 -> compare xs ys | n -> n)
+end
+
+let setup_toplevel () =
+  JsooTop.initialize ();
+  Sys.interactive := false;
+  if Version.compare Version.current [ 4; 07 ] >= 0 then
+    exec' "open Stdlib";
+  exec'
+    "module Lwt_main = struct\n\
+    \             let run t = match Lwt.state t with\n\
+    \               | Lwt.Return x -> x\n\
+    \               | Lwt.Fail e -> raise e\n\
+    \               | Lwt.Sleep -> failwith \"Lwt_main.run: thread \
+     didn't return\"\n\
+    \            end";
+  let header1 =
+    Printf.sprintf "        %s version %%s" compiler_name
+  in
+  let header2 =
+    Printf.sprintf "     Compiled with Js_of_ocaml version %s"
+      Sys_js.js_of_ocaml_version
+  in
+  exec'
+    (Printf.sprintf "Format.printf \"%s@.\" Sys.ocaml_version;;"
+       header1);
+  exec' (Printf.sprintf "Format.printf \"%s@.\";;" header2);
+  exec' "#enable \"pretty\";;";
+  exec' "#disable \"shortvar\";;";
+  Ppx_support.init ();
+  let[@alert "-deprecated"] new_directive n k =
+    Hashtbl.add Toploop.directive_table n k
+  in
+  new_directive "load_js"
+    (Toploop.Directive_string
+       (fun name -> Js.Unsafe.global##load_script_ name));
+  Sys.interactive := true;
+  ()
+
+let resize ~container ~textbox () =
+  Lwt.pause () >>= fun () ->
+  textbox##.style##.height := Js.string "auto";
+  textbox##.style##.height
+  := Js.string (Printf.sprintf "%dpx" (max 18 textbox##.scrollHeight));
+  container##.scrollTop := container##.scrollHeight;
+  Lwt.return ()
+
+let setup_printers () =
+  exec'
+    "let _print_error fmt e = Format.pp_print_string fmt \
+     (Js_of_ocaml.Js_error.to_string e)";
+  Topdirs.dir_install_printer Format.std_formatter
+    Longident.(Lident "_print_error");
+  exec'
+    "let _print_unit fmt (_ : 'a) : 'a = Format.pp_print_string fmt \
+     \"()\"";
+  Topdirs.dir_install_printer Format.std_formatter
+    Longident.(Lident "_print_unit")
+
+let setup_examples ~container ~textbox =
+  let r = Regexp.regexp "^\\(\\*+(.*)\\*+\\)$" in
+  let all = ref [] in
+  (try
+     let ic = open_in "/static/examples.ml" in
+     while true do
+       let line = input_line ic in
+       match Regexp.string_match r line 0 with
+       | Some res ->
+           let name =
+             match Regexp.matched_group res 1 with
+             | Some s -> s
+             | None -> assert false
+           in
+           all := `Title name :: !all
+       | None -> all := `Content line :: !all
+     done;
+     assert false
+   with _ -> ());
+  let example_container = by_id "toplevel-examples" in
+  let _ =
+    List.fold_left
+      (fun acc tok ->
+        match tok with
+        | `Content line -> line ^ "\n" ^ acc
+        | `Title name ->
+            let a =
+              Tyxml_js.Html.(
+                a
+                  ~a:
+                    [
+                      a_class [ "list-group-item" ];
+                      a_onclick (fun _ ->
+                          textbox##.value := (Js.string acc)##trim;
+                          Lwt.async (fun () ->
+                              resize ~container ~textbox ()
+                              >>= fun () ->
+                              textbox##focus;
+                              Lwt.return_unit);
+                          true);
+                    ]
+                  [ txt name ])
+            in
+            Dom.appendChild example_container (Tyxml_js.To_dom.of_a a);
+            "")
+      "" !all
+  in
+  ()
+
+(* we need to compute the hash form href to avoid different encoding behavior
+     across browser. see Url.get_fragment *)
+let parse_hash () =
+  let frag = Url.Current.get_fragment () in
+  Url.decode_arguments frag
+
+let rec iter_on_sharp ~f x =
+  Js.Opt.iter (Dom_html.CoerceTo.element x) (fun e ->
+      if Js.to_bool (e##.classList##contains (Js.string "sharp")) then
+        f e);
+  match Js.Opt.to_option x##.nextSibling with
+  | None -> ()
+  | Some n -> iter_on_sharp ~f n
+
+let setup_share_button ~output =
+  do_by_id "btn-share" (fun e ->
+      e##.style##.display := Js.string "block";
+      e##.onclick :=
+        Dom_html.handler (fun _ ->
+            (* get all ocaml code *)
+            let code = ref [] in
+            Js.Opt.iter output##.firstChild
+              (iter_on_sharp ~f:(fun e ->
+                   code :=
+                     Js.Opt.case e##.textContent
+                       (fun () -> "")
+                       Js.to_string
+                     :: !code));
+            let code_encoded = String.concat "" (List.rev !code) in
+            let url, is_file =
+              match Url.Current.get () with
+              | Some (Url.Http url) ->
+                  (Url.Http { url with Url.hu_fragment = "" }, false)
+              | Some (Url.Https url) ->
+                  (Url.Https { url with Url.hu_fragment = "" }, false)
+              | Some (Url.File url) ->
+                  (Url.File { url with Url.fu_fragment = "" }, true)
+              | _ -> assert false
+            in
+            let frag =
+              let frags = parse_hash () in
+              let frags =
+                List.remove_assoc "code" frags
+                @ [ ("code", code_encoded) ]
+              in
+              Url.encode_arguments frags
+            in
+            let uri = Url.string_of_url url ^ "#" ^ frag in
+            let append_url str =
+              let dom =
+                Tyxml_js.Html.(
+                  p
+                    [
+                      txt "Share this url : ";
+                      a ~a:[ a_href str ] [ txt str ];
+                    ])
+              in
+              Dom.appendChild output (Tyxml_js.To_dom.of_element dom)
+            in
+            Lwt.async (fun () ->
+                Lwt.catch
+                  (fun () ->
+                    if is_file then
+                      failwith "Cannot shorten url with file scheme"
+                    else
+                      let uri =
+                        Printf.sprintf
+                          "http://is.gd/create.php?format=json&url=%s"
+                          (Url.urlencode uri)
+                      in
+                      Lwt.bind (Js_of_ocaml_lwt.Jsonp.call uri)
+                        (fun o ->
+                          let str = Js.to_string o##.shorturl in
+                          append_url str;
+                          Lwt.return_unit))
+                  (fun exn ->
+                    Format.eprintf
+                      "Could not generate short url. reason: %s@."
+                      (Printexc.to_string exn);
+                    append_url uri;
+                    Lwt.return_unit));
+            Js._false))
+
+let setup_js_preview () =
+  let ph = by_id "last-js" in
+  let runcode : string -> 'a = Js.Unsafe.global##.toplevelEval in
+  Js.Unsafe.global##.toplevelEval := fun bc ->
+  ph##.innerHTML := Js.string bc;
+  runcode bc
+
+let current_position = ref 0
+
+let highlight_location loc =
+  let x = ref 0 in
+  let output = by_id "output" in
+  let first =
+    Js.Opt.get
+      (output##.childNodes##item !current_position)
+      (fun _ -> assert false)
+  in
+  iter_on_sharp first ~f:(fun e ->
+      incr x;
+      let _file1, line1, col1 =
+        Location.get_pos_info loc.Location.loc_start
+      in
+      let _file2, line2, col2 =
+        Location.get_pos_info loc.Location.loc_end
+      in
+      if !x >= line1 && !x <= line2 then
+        let from_ = if !x = line1 then `Pos col1 else `Pos 0 in
+        let to_ = if !x = line2 then `Pos col2 else `Last in
+        Colorize.highlight from_ to_ e)
+
+let append colorize output cl s =
+  Dom.appendChild output
+    (Tyxml_js.To_dom.of_element (colorize ~a_class:cl s))
+
+module History = struct
+  let data = ref [| "" |]
+  let idx = ref 0
+
+  let get_storage () =
+    match Js.Optdef.to_option Dom_html.window##.localStorage with
+    | exception _ -> raise Not_found
+    | None -> raise Not_found
+    | Some t -> t
+
+  let setup () =
+    try
+      let s = get_storage () in
+      match Js.Opt.to_option (s##getItem (Js.string "history")) with
+      | None -> raise Not_found
+      | Some s ->
+          let a = Json.unsafe_input s in
+          data := a;
+          idx := Array.length a - 1
+    with _ -> ()
+
+  let push text =
+    let l = Array.length !data in
+    let n = Array.make (l + 1) "" in
+    !data.(l - 1) <- text;
+    Array.blit !data 0 n 0 l;
+    data := n;
+    idx := l;
+    try
+      let s = get_storage () in
+      let str = Json.output !data in
+      s##setItem (Js.string "history") str
+    with Not_found -> ()
+
+  let current text = !data.(!idx) <- text
+
+  let previous textbox =
+    if !idx > 0 then (
+      decr idx;
+      textbox##.value := Js.string !data.(!idx))
+
+  let next textbox =
+    if !idx < Array.length !data - 1 then (
+      incr idx;
+      textbox##.value := Js.string !data.(!idx))
+end
+
+let run _ =
+  let container = by_id "toplevel-container" in
+  let output = by_id "output" in
+  let textbox : 'a Js.t =
+    by_id_coerce "userinput" Dom_html.CoerceTo.textarea
+  in
+  let sharp_chan = open_out "/dev/null0" in
+  let sharp_ppf = Format.formatter_of_out_channel sharp_chan in
+  let caml_chan = open_out "/dev/null1" in
+  let caml_ppf = Format.formatter_of_out_channel caml_chan in
+  let execute () =
+    let content = Js.to_string textbox##.value##trim in
+    let content' =
+      let len = String.length content in
+      if
+        try
+          content <> ""
+          && content.[len - 1] <> ';'
+          && content.[len - 2] <> ';'
+        with _ -> true
+      then content ^ ";;"
+      else content
+    in
+    current_position := output##.childNodes##.length;
+    textbox##.value := Js.string "";
+    History.push content;
+    JsooTop.execute true ~pp_code:sharp_ppf ~highlight_location
+      caml_ppf content';
+    resize ~container ~textbox () >>= fun () ->
+    container##.scrollTop := container##.scrollHeight;
+    textbox##focus;
+    Lwt.return_unit
+  in
+  let history_down _e =
+    let txt = Js.to_string textbox##.value in
+    let pos = textbox##.selectionStart in
+    try
+      if String.length txt = pos then raise Not_found;
+      let _ = String.index_from txt pos '\n' in
+      Js._true
+    with Not_found ->
+      History.current txt;
+      History.next textbox;
+      Js._false
+  in
+  let history_up _e =
+    let txt = Js.to_string textbox##.value in
+    let pos = textbox##.selectionStart - 1 in
+    try
+      if pos < 0 then raise Not_found;
+      let _ = String.rindex_from txt pos '\n' in
+      Js._true
+    with Not_found ->
+      History.current txt;
+      History.previous textbox;
+      Js._false
+  in
+  let meta e =
+    let b = Js.to_bool in
+    b e##.ctrlKey || b e##.altKey || b e##.metaKey
+  in
+  let shift e = Js.to_bool e##.shiftKey in
+  (* setup handlers *)
+  textbox##.onkeyup :=
+    Dom_html.handler (fun _ ->
+        Lwt.async (resize ~container ~textbox);
+        Js._true);
+  textbox##.onchange :=
+    Dom_html.handler (fun _ ->
+        Lwt.async (resize ~container ~textbox);
+        Js._true);
+  textbox##.onkeydown :=
+    Dom_html.handler (fun e ->
+        match e##.keyCode with
+        | 13 when not (meta e || shift e) ->
+            Lwt.async execute;
+            Js._false
+        | 13 ->
+            Lwt.async (resize ~container ~textbox);
+            Js._true
+        | 09 ->
+            Indent.textarea textbox;
+            Js._false
+        | 76 when meta e ->
+            output##.innerHTML := Js.string "";
+            Js._true
+        | 75 when meta e ->
+            setup_toplevel ();
+            Js._false
+        | 38 -> history_up e
+        | 40 -> history_down e
+        | _ -> Js._true);
+  (Lwt.async_exception_hook :=
+     fun exc ->
+       Format.eprintf "exc during Lwt.async: %s@."
+         (Printexc.to_string exc);
+       match exc with
+       | Js_error.Exn e ->
+           let e = Js_error.to_error e in
+           Firebug.console##log e##.stack
+       | _ -> ());
+  Lwt.async (fun () ->
+      resize ~container ~textbox () >>= fun () ->
+      textbox##focus;
+      Lwt.return_unit);
+  Graphics_support.init
+    (by_id_coerce "test-canvas" Dom_html.CoerceTo.canvas);
+  Sys_js.set_channel_flusher caml_chan
+    (append Colorize.ocaml output "caml");
+  Sys_js.set_channel_flusher sharp_chan
+    (append Colorize.ocaml output "sharp");
+  Sys_js.set_channel_flusher stdout
+    (append Colorize.text output "stdout");
+  Sys_js.set_channel_flusher stderr
+    (append Colorize.text output "stderr");
+  let readline () =
+    Js.Opt.case
+      (Dom_html.window##prompt
+         (Js.string "The toplevel expects inputs:")
+         (Js.string ""))
+      (fun () -> "")
+      (fun s -> Js.to_string s ^ "\n")
+  in
+  Sys_js.set_channel_filler stdin readline;
+  setup_share_button ~output;
+  setup_examples ~container ~textbox;
+  setup_pseudo_fs ();
+  setup_toplevel ();
+  setup_js_preview ();
+  setup_printers ();
+  History.setup ();
+  textbox##.value := Js.string "";
+  (* Run initial code if any *)
+  try
+    let code = List.assoc "code" (parse_hash ()) in
+    textbox##.value := Js.string code;
+    Lwt.async execute
+  with
+  | Not_found -> ()
+  | exc ->
+      Firebug.console##log_3 (Js.string "exception")
+        (Js.string (Printexc.to_string exc))
+        exc
+
+let _ =
+  Dom_html.window##.onload
+  := Dom_html.handler (fun _ ->
+         run ();
+         Js._false)

unicom.org

@@ -0,0 +1,37 @@
+UNICOM
+
+unifying tools for thought and commmunication
+
+At the top level is a kind of "trace" that connects all the tools together
+and records the exact use of all the tools in a session. Traces are the only
+kind of document in the system, and are basically written by a user when
+they interact with the system. Users can store, retrieve, view, and modify
+traces as a way of controlling system state, retrieving history, and sharing
+information?
+
+
+tools for thought:
+- todo lists
+- personal journal
+- calendar
+- calculator/spreadsheet
+- health, fitness, finance data tracking, analysis
+- Integrated Development Environment [for development/configuration of all these tools]
+
+
+tools for communication:
+- collaborative documents
+  video / .txt file
+- content discovery,display,labeling?
+  twitter / netflix / books
+- direct messages
+  sms / email
+- group messages
+  private (chat) / private (irc,twitter)
+- audio/music production
+  sound driver / DAW
+- cad
+  KiCad / OpenSCAD
+
+
+