basic

dune

@@ -31,11 +31,14 @@
    re
    lwt_react
  )
- (flags (-g))
+
- (link_flags (-linkall -g))
+ ;; none of this makes backtraces work
+ ;;(flags (-g))
+ ;;(link_flags (-linkall -g))
  ;;(ocamlopt_flags (:standard -O3 -unboxed-types))
- (ocamlc_flags (:standard -verbose))
+ ;;(ocamlc_flags (:standard -verbose -g))
- (modes byte_complete)
+
+ ;;(modes byte_complete) ;; this causes backtraces to not work, but somehow includes the implementation of Toploop
  (preprocess
   (pps ppx_irmin))
 )

ogui.ml

@@ -3,6 +3,16 @@ module Gv = Graphv_gles2_native
 module F = Fmt
 module Str = Re.Str
 
+let pp_box2 ppf b =
+  F.(
+    pf ppf "[%a %a]"
+      (pair ~sep:(any " ") float float)
+      Gg.(Box2.min b |> V2.to_tuple)
+      (pair ~sep:(any " ") float float)
+      Gg.(Box2.max b |> V2.to_tuple))
+
+let pair a b = (a, b)
+
 module Lwd = struct
   open Lwt_react
 
@@ -91,7 +101,8 @@ let pp_text_row : Gv.Text.text_row F.t =
       ])
 
 let pp_color : Gv.Color.t Fmt.t =
-  F.(
+ fun ppf s -> F.pf ppf "r:%.3f g:%.3f b:%.3f a:%.3f" s.r s.g s.b s.a
+(*F.(
   hbox
   @@ record ~sep:sp
        [
@@ -99,7 +110,7 @@ let pp_color : Gv.Color.t Fmt.t =
          field "g" (fun (s : Gv.Color.t) -> s.g) float;
          field "b" (fun (s : Gv.Color.t) -> s.b) float;
          field "a" (fun (s : Gv.Color.t) -> s.a) float;
-         ])
+       ]) *)
 
 (* let lwt_lwd (t : 'a Lwt.t Lwd.t) : 'a Lwd.t Lwt.t =
    let root = Lwd.observe t in
@@ -126,18 +137,20 @@ module Margin = struct
   let sum t : size2 = Size2.v (t.left +. t.right) (t.top +. t.bottom)
 
   let inner t b : box2 =
-    Box2.v
+    Box2.(
-      (V2.v (Box2.minx b +. t.left) (Box2.miny b +. t.top))
+      of_pts
-      (V2.v (Box2.maxx b -. t.right) (Box2.maxy b -. t.bottom))
+        (V2.v (minx b +. t.left) (miny b +. t.top))
+        (V2.v (maxx b -. t.right) (maxy b -. t.bottom)))
 
   let outer t b =
     Box2.(
-      v
+      of_pts
         (V2.v (minx b -. t.left) (miny b -. t.top))
         (V2.v (maxx b +. t.right) (maxy b +. t.bottom)))
 
   let pp ppf t =
-    F.pf ppf "l=%f@;r=%f@;t=%f@;b=%f" t.left t.right t.top t.bottom
+    F.pf ppf "l=%.2f@;r=%.2f@;t=%.2f@;b=%.2f" t.left t.right t.top
+      t.bottom
 end
 
 type margin = Margin.t
@@ -308,7 +321,7 @@ module TextBuffer = struct
         F.epr "TextBuffer.save Error `Conflict %s@." s
     | Error (`Too_many_retries n) ->
         F.epr "TextBuffer.save Error `Too_many_retries %d@." n
-    | Error (`Test_was n) ->
+    | Error (`Test_was _) ->
         F.epr "TextBuffer.save Error `Test_was %s@."
           "<not implemented>");
     Lwt.return_unit
@@ -427,7 +440,6 @@ module Event = struct
 
   let pp_event : event F.t =
    fun ppf e ->
-    let open Glfw_types in
     match e with
     | Key (a, k, m) ->
         F.pf ppf "%a %a %a" pp_key_action a pp_key k pp_mods m
@@ -710,7 +722,7 @@ module Ui = struct
     enabled : bool;
     gv : Gv.t;
     glfw_window : GLFW.window option;
-    bindings : (int * action list Event.t) Lwd.var;
+    mutable bindings : action list Event.resolver Lwd.t;
   }
 
   and action = Custom of string * (unit -> unit Lwt.t)
@@ -727,8 +739,7 @@ module Ui = struct
       enabled = true;
       gv;
       glfw_window = window;
-      bindings =
+      bindings = Lwd.pure Event.[ pack Fun.id empty ];
-        Lwd.var ~eq:(fun (a, _) (b, _) -> a = b) (0, Event.empty);
     }
 
   let pp_action : action F.t =
@@ -747,24 +758,42 @@ module Ui = struct
         |> ignore)
       p ()
 
+  let pp_pack : action list Event.pack F.t =
+   fun ppf p ->
+    let open Event in
+    let rec iter (prev : Event.event list)
+        (p : action list Event.pack) : unit =
+      let module Pack = (val p) in
+      match EventMap.bindings Pack.set with
+      | (event, node) :: rest ->
+          (match node with
+          | Set set -> iter (prev @ [ event ]) (pack Pack.map set)
+          | Val action ->
+              F.pf ppf "%a: %a@."
+                F.(list pp_action)
+                (Pack.map action)
+                F.(brackets @@ list ~sep:semi pp_event)
+                (prev @ [ event ]));
+          iter prev (pack Pack.map (EventMap.of_list rest))
+      | [] -> ()
+    in
+
+    iter [] p
+
   let process_key t (resolver : action list Event.result)
       (state : Event.key_action) (key : Event.key)
       (mods : Event.key_mod list) : action list Event.result Lwt.t =
     let res =
       match resolver with
       | Event.Rejected | Event.Accepted _ ->
-          [
+          t.bindings |> Lwd.observe |> Lwd.quick_sample
-            t.bindings |> Lwd.peek
-            (*Lwd.get |> Lwd.observe |> Lwd.quick_sample *) |> snd
-            |> Event.pack Fun.id;
-          ]
       | Event.Continue r -> r
     in
     let res = Event.resolve (Key (state, key, mods)) res in
     (match res with
     | Event.Accepted actions ->
         let rec exec : action list -> unit Lwt.t = function
-          | Custom (name, f) :: actions ->
+          | Custom (_name, f) :: actions ->
               f () >>= fun () -> exec actions
           | [] -> Lwt.return_unit
         in
@@ -772,11 +801,9 @@ module Ui = struct
     | Event.Continue _ | Event.Rejected -> Lwt.return_unit)
     >>= fun () -> Lwt.return res
 
-  let update_bindings ui
+  let append_bindings ui (b : action list Event.resolver Lwd.t) : unit
-      (f : action list Event.t -> action list Event.t) =
+      =
-    Lwd.set ui.bindings
+    ui.bindings <- Lwd.map2 ~f:List.append ui.bindings b
-      ( Lwd.peek ui.bindings |> fst |> Int.add 1,
-        f (Lwd.peek ui.bindings |> snd) )
 
   let chrcallback_ref : (Uchar.t -> unit Lwt.t) ref =
     ref (fun _c ->
@@ -792,23 +819,20 @@ module Ui = struct
             action list Event.result Lwt.t =
           Lwt_stream.last_new events >>= function
           | `Key (state, key, mods) ->
-              Event.(
-                F.epr "Ui.process_events `Key %a %a %a" pp_key_action
-                  state pp_key key pp_mods mods);
-
               process_key ui r state key mods
               >>= fun (res : action list Event.result) ->
               Event.(
-                F.epr " (%s)@."
+                F.epr "Ui.process_events `Key %a %a %a (%s)@."
+                  pp_key_action state pp_key key pp_mods mods
                   (match res with
                   | Accepted _ -> "Accepted"
                   | Continue _ -> "Continue"
                   | Rejected -> "Rejected"));
+
+              (* junk the `Char that is sent with a `Key that has no mods *)
               (match res with
               | Accepted _ when mods = [] || mods == [ Shift ] -> (
-                  (* junk the `Char that is sent with a `Key that has no mods *)
+                  Lwt_stream.peek events >>= function
-                  Lwt_stream.peek events
-                  >>= function
                   | Some (`Char _) ->
                       F.epr "process_events: junking next event@.";
                       Lwt_stream.junk events
@@ -820,19 +844,18 @@ module Ui = struct
                 (Uchar.of_int char);
               process_char char >>= fun () -> proc (Event.Accepted [])
         in
-
         proc Event.Rejected >>= fun _ -> Lwt.return_unit)
 
   module Style = struct
     type t = {
-      stroke : float option * Gv.Color.t;
+      stroke : (float * Gv.Color.t) option;
       fill : Gv.Color.t;
       margin : Margin.t;
     }
 
     let default =
       {
-        stroke = (None, Gv.Color.transparent);
+        stroke = None;
         fill = Gv.Color.transparent;
         margin = Margin.empty;
       }
@@ -840,14 +863,14 @@ module Ui = struct
     let pp ppf t =
       F.pf ppf "%a"
         F.(
-          record
+          hovbox
+          @@ record
                [
                  field "stroke"
                    (fun t -> t.stroke)
-                (hbox
+                   (pair ~sep:comma float pp_color
-                @@ pair ~sep:comma
+                   |> option ~none:(any "None")
-                     (option ~none:(any "None") float)
+                   |> hbox);
-                     pp_color);
                  field "fill" (fun t -> t.fill) pp_color;
                  field "margin" (fun t -> t.margin) Margin.pp;
                ])
@@ -952,12 +975,15 @@ module TextEdit = struct
   let cursor_set (t : t) (index : int) : unit Lwt.t =
     cursor_update t (Fun.const index)
 
-  let default_bindings (t : t) (ui : Ui.t) : unit =
+  let default_bindings (t : t) : Ui.action list Event.pack =
     let open GLFW in
     let open Event in
     let open Ui in
-    Ui.update_bindings ui (fun a ->
+    (Ui.chrcallback_ref :=
-        a
+       fun c ->
+         TextBuffer.insert_uchar t.text (Lwd.peek t.cursor).index c
+         >>= fun _ -> cursor_move t 1);
+    empty
     |> adds
          [
            [ Key (Press, F, [ Control ]) ];
@@ -973,9 +999,7 @@ module TextEdit = struct
            [ Key (Press, Left, []) ];
            [ Key (Repeat, Left, []) ];
          ]
-             [
+         [ Custom ("char_backward", fun () -> cursor_move t (-1)) ]
-               Custom ("char_backward", fun () -> cursor_move t (-1));
-             ]
     |> adds
          [
            [ Key (Press, N, [ Control ]) ];
@@ -989,25 +1013,17 @@ module TextEdit = struct
                fun () ->
                  TextBuffer.fold_string t.text (fun s ->
                      let sn = String.length s in
-                         let seol =
+                     let seol = Str.search_forward (Str.regexp "$") in
-                           Str.search_forward (Str.regexp "$")
-                         in
                      let next_bol =
-                           min sn
+                       min sn (seol s (Lwd.peek t.cursor).index + 1)
-                             (seol s (Lwd.peek t.cursor).index + 1)
-                         in
-                         let next_line_len =
-                           seol s next_bol - next_bol
                      in
+                     let next_line_len = seol s next_bol - next_bol in
                      next_bol
                      +
-                         if
+                     if (Lwd.peek t.cursor).last_col > next_line_len
-                           (Lwd.peek t.cursor).last_col
-                           > next_line_len
                      then next_line_len
                      else
-                           min next_line_len
+                       min next_line_len (Lwd.peek t.cursor).last_col)
-                             (Lwd.peek t.cursor).last_col)
                  >>= cursor_set t );
          ]
     |> adds
@@ -1036,9 +1052,7 @@ module TextEdit = struct
                          t.cursor.index bol prev_bol prev_line_len; *)
                        prev_bol
                        +
-                           if
+                       if (Lwd.peek t.cursor).last_col > prev_line_len
-                             (Lwd.peek t.cursor).last_col
-                             > prev_line_len
                        then prev_line_len
                        else
                          min prev_line_len
@@ -1047,10 +1061,7 @@ module TextEdit = struct
                  >>= cursor_set t );
          ]
     |> adds (* EOL *)
-             [
+         [ [ Key (Press, E, [ Control ]) ]; [ Key (Press, End, []) ] ]
-               [ Key (Press, E, [ Control ]) ];
-               [ Key (Press, End, []) ];
-             ]
          [
            Custom
              ( "end_of_line",
@@ -1065,13 +1076,12 @@ module TextEdit = struct
                          (Lwd.peek t.cursor).index
                      in
                      Lwd.set t.cursor
-                         @@ TextLayout.cursor ~last_col:(eol - bol)
+                     @@ TextLayout.cursor ~last_col:(eol - bol) eol)
-                              eol) );
+             );
          ]
     |> adds (* BOL *)
          [
-               [ Key (Press, A, [ Control ]) ];
+           [ Key (Press, A, [ Control ]) ]; [ Key (Press, Home, []) ];
-               [ Key (Press, Home, []) ];
          ]
          [
            Custom
@@ -1098,8 +1108,7 @@ module TextEdit = struct
                        (mark, (Lwd.peek t.cursor).index)
                      >>= fun _ ->
                      Lwd.set t.mark None;
-                         cursor_set t
+                     cursor_set t (min mark (Lwd.peek t.cursor).index)
-                           (min mark (Lwd.peek t.cursor).index)
                  | None ->
                      if (Lwd.peek t.cursor).index > 0 then
                        TextBuffer.remove_uchar t.text
@@ -1131,9 +1140,7 @@ module TextEdit = struct
                  >>= fun u -> u );
          ]
     |> adds
-             [
+         [ [ Key (Press, Enter, []) ]; [ Key (Repeat, Enter, []) ] ]
-               [ Key (Press, Enter, []) ]; [ Key (Repeat, Enter, []) ];
-             ]
          [
            Custom
              ( "new_line",
@@ -1166,21 +1173,12 @@ module TextEdit = struct
     |> adds
          [
            [
-                 Key (Press, X, [ Control ]);
+             Key (Press, X, [ Control ]); Key (Press, S, [ Control ]);
-                 Key (Press, S, [ Control ]);
            ];
          ]
          (* Save *)
-             [
+         [ Custom ("save_buffer", fun () -> TextBuffer.save t.text) ]
-               Custom ("save_buffer", fun () -> TextBuffer.save t.text);
+    |> Event.pack Fun.id
-             ]);
-
-    Ui.chrcallback_ref :=
-      fun c ->
-        TextBuffer.insert_uchar t.text (Lwd.peek t.cursor).index c
-        >>= fun _ -> cursor_move t 1
-  (* This creates a giant stack of calls lol
-     >>= fun () -> !Ui.chrcallback_ref c *)
 
   let multiline ui ?(text_format = TextLayout.format_default)
       (text : TextBuffer.t) : t =
@@ -1208,23 +1206,27 @@ module TextEdit = struct
         (* return_key = keyboard_shortcut; *)
       }
     in
-    default_bindings t ui;
+    Ui.append_bindings ui (Lwd.pure [ default_bindings t ]);
     t
 end
 
 module Layout = struct
   module Style = Ui.Style
 
+  type dir = [ `X | `Y | `Z ]
+
   type frame = { t : t; mutable size : size; style : Style.t }
 
   and t =
-    [ `Join of [ `X | `Y | `Z ] * (frame * frame)
+    [ `Join of dir * (frame * frame)
-    | `String of string
+    | `String of string * TextLayout.format
-    | `Buffer of TextBuffer.t
+    | `Buffer of TextBuffer.t * TextLayout.format
     | `TextEdit of TextEdit.t * TextLayout.layout
     | `None ]
 
-  and dim = [ `Ratio of float | `Pixels of float ]
+  and dim =
+    [ `Ratio of float | `Pixels of float | `Fun of Gg.box2 -> float ]
+
   and size = dim * dim
 
   let ratio x y = (`Ratio x, `Ratio y)
@@ -1234,7 +1236,7 @@ module Layout = struct
     { t; size; style }
 
   let none = frame `None
-  let join d ?style a b = frame ?style (`Join (d, (a, b)))
+  let join ?size ?style d a b = frame ?size ?style (`Join (d, (a, b)))
 
   (*  let hbox, vbox, zbox = (box `X, box `Y, box `Z) *)
   let pack ?style d = (none, join d ?style)
@@ -1251,11 +1253,28 @@ module Layout = struct
   let textedit_style =
     Style.
       {
-        default with
+        fill = Gv.Color.rgbaf ~r:0.1 ~g:0.1 ~b:0.1 ~a:0.0;
-        stroke = (Some 1.2, Gv.Color.rgbf ~r:0.9 ~g:0.9 ~b:0.9);
+        stroke = Some (1.2, Gv.Color.rgbf ~r:0.9 ~g:0.9 ~b:0.9);
         margin = Margin.symmetric 10. 10.;
       }
 
+  let string ?size ?style s = frame ?size ?style (`String s)
+
+  let textedit_s ?size ?(style = textedit_style)
+      (t : TextEdit.t Lwd.t) : frame Lwd.t Lwt.t =
+    let open TextLayout in
+    F.epr "Layout.textedit@.";
+    Lwd.map_s t ~f:(fun (t : TextEdit.t) ->
+        simple t.text ~start:(Lwd.get t.scroll) ~format:t.text_format
+          (Option.value ~default:80. t.desired_width)
+        >>= fun layout ->
+        with_cursor (Lwd.get t.cursor) layout
+        |> with_mark (Lwd.get t.mark) (Lwd.get t.cursor)
+        |> Lwd.map ~f:(fun tl ->
+               frame ?size ~style (`TextEdit (t, tl)))
+        |> Lwt.return)
+    >>= fun v -> Lwd.join v |> Lwt.return
+
   let textedit ?size ?(style = textedit_style) (t : TextEdit.t) :
       frame Lwd.t Lwt.t =
     let open TextLayout in
@@ -1268,80 +1287,6 @@ module Layout = struct
     |> Lwd.map ~f:(fun tl -> frame ?size ~style (`TextEdit (t, tl)))
     |> Lwt.return
 
-  let system ui ?(style = textedit_style) d
-      (telist : (int * TextEdit.t list) Lwd.var) =
-    let cursor = Lwd.var 0 in
-    Ui.update_bindings ui (fun a ->
-        a
-        |> Event.adds
-             [ [ Key (Press, X, [ Control ]); Key (Press, O, []) ] ]
-             [
-               Ui.Custom
-                 ( "window_next",
-                   fun () ->
-                     Lwd.set cursor
-                       (if
-                          Lwd.peek cursor
-                          < (Lwd.peek telist |> snd |> List.length)
-                            - 1
-                        then Lwd.peek cursor + 1
-                        else 0);
-                     TextEdit.default_bindings
-                       (List.nth
-                          (Lwd.peek telist |> snd)
-                          (Lwd.peek cursor))
-                       ui;
-                     Lwt.return_unit );
-             ]
-        |> Event.adds
-             [ [ Key (Press, X, [ Control ]); Key (Press, P, []) ] ]
-             [
-               Ui.Custom
-                 ( "window_previous",
-                   fun () ->
-                     Lwd.set cursor
-                       (if Lwd.peek cursor > 0 then
-                          Lwd.peek cursor - 1
-                        else
-                          (Lwd.peek telist |> snd |> List.length) - 1);
-                     TextEdit.default_bindings
-                       (List.nth
-                          (Lwd.peek telist |> snd)
-                          (Lwd.peek cursor))
-                       ui;
-                     Lwt.return_unit );
-             ]);
-    Lwd.map_s
-      ~f:(fun (_, tl) ->
-        Lwt_list.mapi_s
-          (fun n te ->
-            textedit
-              ~size:
-                (match d with
-                | `X -> (`Ratio 0.5, `Ratio 1.)
-                | `Y -> (`Ratio 1., `Ratio 0.5)
-                | `Z -> (`Ratio 1., `Ratio 1.))
-              te
-            >>= fun tl ->
-            Lwd.map2 tl (Lwd.get cursor) ~f:(fun tl cursor ->
-                {
-                  tl with
-                  style =
-                    {
-                      tl.style with
-                      stroke =
-                        ( fst style.stroke,
-                          if n == cursor then
-                            Gv.Color.(transf (snd style.stroke) 0.5)
-                          else snd style.stroke );
-                    };
-                })
-            |> Lwt.return)
-          tl
-        >>= fun framelist -> box ~style d framelist |> Lwt.return)
-      (Lwd.get telist)
-    >>= fun d -> Lwd.join d |> Lwt.return
-
   let pp_dir ppf (t : [ `X | `Y | `Z ]) =
     F.pf ppf "%s"
       (match t with `X -> "`X" | `Y -> "`Y" | `Z -> "`Z")
@@ -1352,16 +1297,15 @@ module Layout = struct
       | `Join (d, _) -> F.str "`Join %a" pp_dir d
       | `Buffer _ -> "`Buffer"
       | `TextEdit _ -> "`TextEdit"
-      | `String s -> F.str "`String %s" s
+      | `String (s, _) -> F.str "`String %s" s
       | `None -> "`None")
 
-  let pp_size ppf (x, y) =
+  let pp_dim ppf = function
-    (match x with
+    | `Pixels p -> F.pf ppf "%.2fpx" p
-    | `Pixels p -> F.pf ppf "`Pixels %f.2, " p
+    | `Ratio p -> F.pf ppf "%.2f%%" p
-    | `Ratio p -> F.pf ppf "`Ratio %f.2, " p);
+    | `Fun _ -> F.pf ppf "`Fun _"
-    match y with
+
-    | `Pixels p -> F.pf ppf "`Pixels %f.2" p
+  let pp_size = F.pair ~sep:F.(any " ") pp_dim pp_dim
-    | `Ratio p -> F.pf ppf "`Ratio %f.2" p
 
   let pp_frame =
     F.(
@@ -1372,6 +1316,21 @@ module Layout = struct
           field "style" (fun t -> t.style) Style.pp;
         ])
 
+  let rec pp_t_rec ppf (t : t) =
+    let open Fmt in
+    match t with
+    | `Join (d, p) ->
+        pf ppf "`Join %a (@,%a)" pp_dir d
+          (pair ~sep:F.comma pp_frame_rec pp_frame_rec)
+          p
+    | `Buffer _ -> pf ppf "`Buffer"
+    | `TextEdit _ -> pf ppf "`TextEdit"
+    | `String (s, _) -> pf ppf "`String @[<h 1>%s@]" s
+    | `None -> pf ppf "`None"
+
+  and pp_frame_rec ppf t =
+    F.pf ppf "@[<hv 3>[%a] %a@]" pp_size t.size pp_t_rec t.t
+
   let parse_t_frame s =
     match s with
     | "`Box" -> `Vbox
@@ -1381,6 +1340,175 @@ module Layout = struct
     | s -> `S s
 end
 
+module WindowManager = struct
+  open Layout
+
+  type content = [ `TextEdit of TextEdit.t | `Frame of frame ]
+  type bindings = Event.event Event.resolver
+
+  type t = [ `T of dir * tt list | content ]
+  and tt = { t : t; dim : dim; bindings : bindings }
+
+  let rec length : t -> int = function
+    | `T (_, tl) ->
+        List.fold_left (fun a { t; _ } -> a + length t) 0 tl
+    | _ -> 1
+
+  let rec nth (n : int) : t -> content option = function
+    | `T (_, tl) ->
+        let rec nl n' : tt list -> content option = function
+          | { t; _ } :: tl' -> (
+              match nth n' t with
+              | Some t -> Some t
+              | None -> nl (n - 1) tl')
+          | [] -> None
+        in
+        nl n tl
+    | (`TextEdit _ | `Frame _) as t ->
+        F.epr "nth: %d@." n;
+        if n == 0 then Some t else None
+
+  let rec fold_left ?(dir = `X)
+      ~(f :
+         dir ->
+         'a ->
+         [ `Frame of frame | `TextEdit of TextEdit.t ] ->
+         'a) acc = function
+    | `T (dir, tl) ->
+        List.fold_left (fun a' t' -> fold_left ~f ~dir a' t') acc tl
+    | (`Frame _ as tt) | (`TextEdit _ as tt) -> f dir acc tt
+
+  let color_gray c = Gv.Color.rgbf ~r:c ~g:c ~b:c
+
+  let status_style sel : Style.t =
+    let open Ui.Style in
+    {
+      stroke =
+        Some (3.0, if sel then color_gray 0.6 else color_gray 0.4);
+      fill = (if sel then color_gray 0.8 else color_gray 0.2);
+      margin = Margin.symmetric 2. 2.;
+    }
+
+  let status_format sel : TextLayout.format =
+    {
+      TextLayout.format_default with
+      font_id = FontId ("mono", 18.0);
+      line_height = Some 19.;
+      color = (if sel then color_gray 0.1 else color_gray 0.9);
+      background = Gv.Color.transparent;
+    }
+
+  let frame_of_window (n : int) cursor style (size : dim * dim)
+      (content : frame Lwd.t) : frame Lwd.t =
+    Lwd.map2 content (Lwd.get cursor) ~f:(fun content cursor ->
+        join ~size
+          ~style:
+            {
+              style with
+              stroke =
+                Option.map
+                  (fun (s, c) ->
+                    ( s,
+                      if n != cursor then Gv.Color.(transf c 0.3)
+                      else c ))
+                  content.style.stroke;
+            }
+          `Y content
+          (string
+             ~style:(status_style (n == cursor))
+             ~size:(`Ratio 1.0, `Pixels 30.)
+             (F.str "window/%d" n, status_format (n == cursor))))
+
+  let frame_default_bindings _ui _f = Event.empty |> Event.pack Fun.id
+
+  let default_bindings ui = function
+    | `TextEdit t -> [ TextEdit.default_bindings t ]
+    | `Frame f -> [ frame_default_bindings ui f ]
+
+  let make ui ?(style = textedit_style)
+      ?(_mode : [ `Tiling | `FullScreen | `Floating ] = `Tiling)
+      (t : t Lwd.var) =
+    let cursor = Lwd.var 0 in
+    (* add the bindings of the currently selected window *)
+    Ui.append_bindings ui
+      (Lwd.map2 (Lwd.get cursor) (Lwd.get t) ~f:nth
+      |> Lwd.map ~f:(function
+           | Some v -> default_bindings ui v
+           | None -> []));
+    Ui.append_bindings ui
+      (Lwd.return
+         Event.
+           [
+             empty
+             |> adds
+                  [
+                    [
+                      Key (Press, X, [ Control ]); Key (Press, O, []);
+                    ];
+                  ]
+                  Lwd.
+                    [
+                      Ui.Custom
+                        ( "window_next",
+                          fun () ->
+                            set cursor
+                              (if peek cursor < (peek t |> length) - 1
+                               then peek cursor + 1
+                               else 0);
+                            Lwt.return_unit );
+                    ]
+             |> adds
+                  [
+                    [
+                      Key (Press, X, [ Control ]); Key (Press, P, []);
+                    ];
+                  ]
+                  Lwd.
+                    [
+                      Ui.Custom
+                        ( "window_previous",
+                          fun () ->
+                            set cursor
+                              (if peek cursor > 0 then peek cursor - 1
+                               else (peek t |> length) - 1);
+                            Lwt.return_unit );
+                    ]
+             |> pack Fun.id;
+           ]);
+    let i = ref 0 in
+    Lwd.map_s (Lwd.get t) ~f:(fun (t : t) ->
+        let rec fold dir (t : tt) : Layout.frame Lwd.t Lwt.t =
+          let size =
+            match dir with
+            | `X -> (t.dim, `Ratio 1.)
+            | `Y -> (`Ratio 1., t.dim)
+            | `Z -> (t.dim, t.dim)
+          in
+          match t.t with
+          | `T (dir', t0 :: trest) ->
+              fold dir' t0 >>= fun fst ->
+              Lwt_list.fold_left_s
+                (fun f t ->
+                  fold dir' t >>= fun newf ->
+                  Lwd.map2 f newf ~f:(join ~size dir') |> Lwt.return)
+                fst trest
+          | `T (_, []) -> Layout.none |> Lwd.return |> Lwt.return
+          | `Frame f' ->
+              i := !i + 1;
+              frame_of_window !i cursor style size (Lwd.return f')
+              |> Lwt.return
+          | `TextEdit t' ->
+              Layout.textedit
+                ~size:(`Ratio 1.0, `Fun (fun b -> Gg.Box2.h b -. 30.))
+                t'
+              >>= fun tt ->
+              i := !i + 1;
+              frame_of_window !i cursor style size tt |> Lwt.return
+        in
+        fold `X { t; dim = `Ratio 1.; bindings = [] })
+    >>= fun d -> Lwd.join d |> Lwt.return
+end
+
 module Painter = struct
   open Layout
   open Gg
@@ -1391,11 +1519,12 @@ module Painter = struct
     Path.begin_ t;
     Path.rect t ~x:(minx box) ~y:(miny box) ~w:(w box) ~h:(h box);
     set_fill_color t ~color:style.fill;
-    set_stroke_color t ~color:(snd style.stroke);
+
     (match style.stroke with
-    | None, _ -> ()
+    | None -> ()
-    | Some width, _ ->
+    | Some (width, color) ->
         set_stroke_width t ~width;
+        set_stroke_color t ~color;
         stroke t);
     fill t
 
@@ -1408,7 +1537,22 @@ module Painter = struct
     let open Gv in
     Text.set_font_face t ~name:font_name;
     Text.set_size t ~size:font_size;
-    Text.set_align t ~align:Align.(left lor top)
+    Text.set_align t ~align:Align.(left lor top);
+    set_fill_color t ~color:format.color
+
+  let string ?(style = Style.default) (t : Gv.t) (rect : box2)
+      ((contents, format) : string * TextLayout.format) : box2 Lwt.t =
+    (*    draw_box t ~box:rect ~style; *)
+    (* F.epr "string"; *)
+    set_text_format t format;
+    let rect' = Margin.inner style.margin rect in
+    V2.v
+      (Gv.Text.text_w t ~x:(Box2.minx rect') ~y:(Box2.miny rect')
+         contents)
+      (Gv.Text.metrics t).line_height
+    |> Box2.v (Box2.o rect')
+    |> Margin.outer style.margin
+    |> Lwt.return
 
   let text_layout (t : Gv.t) (rect : box2)
       ((te, layout) : TextEdit.t * TextLayout.layout) : box2 Lwt.t =
@@ -1417,12 +1561,13 @@ module Painter = struct
       Option.value ~default:(Gv.Text.metrics t).line_height
         g.line_height
     in
-    let max_rows = Int.of_float (Box2.h rect /. line_height) in
+    let max_rows =
+      Int.of_float (Box2.h rect /. line_height) |> max 1
+    in
     Lwd.set te.rows max_rows;
     let lines = Gv.Text.make_empty_rows max_rows in
     Store.S.Tree.get (Lwd.peek te.text.tree) (Lwd.peek te.text.path)
     >>= fun contents ->
-    let contents_len = String.length contents in
     let row_count =
       Gv.Text.break_lines t ~break_width:(Box2.w rect) ~max_rows
         ~lines ~start:(Lwd.peek te.scroll) contents
@@ -1439,6 +1584,7 @@ module Painter = struct
         List.fold_left
           (fun (cur' : p2) (sec : TextLayout.section) ->
             let start, end_ =
+              let contents_len = String.length contents in
               ( start |> max (fst sec.byte_range) |> min contents_len,
                 row.end_index |> min contents_len
                 |> min (snd sec.byte_range) )
@@ -1474,7 +1620,6 @@ module Painter = struct
       (Box2.o rect, Lwd.peek te.scroll)
       (Seq.take row_count (Array.to_seq lines))
     |> fst
-    |> (fun cur''' -> V2.(cur''' - v 0. line_height))
     |> Box2.(of_pts (o rect))
     |> Lwt.return
 
@@ -1482,37 +1627,55 @@ module Painter = struct
       ({ t; style; size = sx, sy } : frame) : box2 Lwt.t =
     let box =
       Box2.v (Box2.o box)
-        (V2.v
+        (Size2.v
            (match sx with
            | `Ratio r -> Box2.w box *. r
-           | `Pixels p -> p)
+           | `Pixels p -> p
+           | `Fun f -> f box)
            (match sy with
            | `Ratio r -> Box2.h box *. r
-           | `Pixels p -> p))
+           | `Pixels p -> p
+           | `Fun f -> f box))
     in
     let box' = Margin.inner style.margin box in
+    (* F.epr "@[<hv 3>%a " pp_box2 box; *)
+    draw_box ui.gv ~box ~style;
     (match t with
     | `Join (dir, (a, b)) ->
-        Lwt_list.fold_left_s
+        (* F.epr "`Join %a @,(@[<hv>" pp_dir dir; *)
-          (fun (c : box2) f ->
+        layout box' ui a >>= fun ra ->
-            layout c ui f >>= fun r ->
+        (* F.epr ",@ "; *)
         let c' =
           Box2.(
             match dir with
-                | `X -> of_pts (V2.v (maxx r) (miny c)) (max c)
+            | `X -> of_pts (V2.v (maxx ra) (miny box')) (max box')
-                | `Y -> of_pts (V2.v (minx c) (maxy r)) (max c)
+            | `Y -> of_pts (V2.v (minx box') (maxy ra)) (max box')
-                | `Z -> box)
+            | `Z -> box')
         in
-            Lwt.return c')
+        layout c' ui b >>= fun rb ->
-          box' [ a; b ]
+        (* F.epr "@])"; *)
-    | `TextEdit tt -> text_layout ui.gv box' tt
+        Gg.Box2.union ra rb |> Lwt.return
-    | _ -> Lwt.return box)
+    | `TextEdit tt ->
+        (* F.epr "`TextEdit"; *)
+        text_layout ui.gv box' tt >>= fun _ -> Lwt.return box'
+    | `None ->
+        (* F.epr "`None"; *)
+        Lwt.return Gg.Box2.(v (o box') Gg.V2.zero)
+    | `String s -> string ui.gv box' s
+    | _ ->
+        F.epr "_ !!Unimplemented!!";
+        Lwt.return Gg.Box2.zero)
     >>= fun r ->
-    let r' =
+    (* F.epr "@]"; *)
-      Box2.add_pt r
+    let r' = Margin.outer style.margin r in
-        V2.(Box2.max r + v style.margin.right style.margin.bottom)
+
-      |> Margin.outer style.margin
+    (*F.epr "layout: box=%a box'=%a r=%a r'=%a@." Gg.Box2.pp box
-    in
+      Gg.Box2.pp box' Gg.Box2.pp r Gg.Box2.pp r'; *)
-    draw_box ui.gv ~box:r' ~style;
     Lwt.return r'
+
+  let layout box ui frame =
+    (* F.epr "layout:@ @[%a@]@.as:@.@[<hv>" Layout.pp_frame_rec frame; *)
+    let r = layout box ui frame in
+    (* F.epr "@]@."; *)
+    r
 end

opam_switch

@@ -0,0 +1,275 @@
+opam-version: "2.0"
+compiler: ["ocaml-variants.5.1.1+options"]
+roots: [
+  "camlp5.8.03.00"
+  "gg.1.0.0"
+  "glfw-ocaml.3.3.1-2"
+  "graphv_gles2_native.0.1.1"
+  "irmin-git.3.9.0"
+  "lablgtk3.3.1.4"
+  "lablgtk3-sourceview3.3.1.4"
+  "lwd.0.3"
+  "lwt_glib.1.1.1"
+  "memtrace.0.2.3"
+  "merlin.4.14-501"
+  "ocamlformat.0.26.2"
+  "odig.0.0.9"
+  "stb_image.0.5"
+  "tgls.0.8.6"
+  "tuareg.3.0.1"
+  "user-setup.0.7"
+  "utop.2.14.0"
+]
+installed: [
+  "angstrom.0.16.0"
+  "arp.3.1.1"
+  "asn1-combinators.0.2.6"
+  "astring.0.8.5"
+  "awa.0.3.0"
+  "awa-mirage.0.3.0"
+  "b0.0.0.5"
+  "base.v0.16.3"
+  "base-bigarray.base"
+  "base-bytes.base"
+  "base-domains.base"
+  "base-nnp.base"
+  "base-threads.base"
+  "base-unix.base"
+  "base64.3.5.1"
+  "bheap.2.0.0"
+  "bigarray-compat.1.1.0"
+  "bigstringaf.0.9.1"
+  "biniou.1.2.2"
+  "bos.0.2.1"
+  "ca-certs.0.2.3"
+  "ca-certs-nss.3.98"
+  "cairo2.0.6.4"
+  "camlp-streams.5.0.1"
+  "camlp5.8.03.00"
+  "camlp5-buildscripts.0.03"
+  "carton.0.7.1"
+  "carton-git.0.7.1"
+  "carton-lwt.0.7.1"
+  "cf.0.5.0"
+  "cf-lwt.0.5.0"
+  "checkseum.0.5.2"
+  "cmdliner.1.2.0"
+  "cohttp.5.3.1"
+  "cohttp-lwt.5.3.0"
+  "cohttp-lwt-unix.5.3.0"
+  "conduit.6.2.2"
+  "conduit-lwt.6.2.2"
+  "conduit-lwt-unix.6.2.2"
+  "conf-bash.1"
+  "conf-cairo.1"
+  "conf-emacs.1"
+  "conf-gles2.1"
+  "conf-glfw3.2"
+  "conf-glib-2.1"
+  "conf-gmp.4"
+  "conf-gmp-powm-sec.3"
+  "conf-gtk3.18"
+  "conf-gtksourceview3.0+2"
+  "conf-libffi.2.0.0"
+  "conf-m4.1"
+  "conf-perl.2"
+  "conf-pkg-config.3"
+  "conf-which.1"
+  "cppo.1.6.9"
+  "crunch.3.3.1"
+  "csexp.1.5.2"
+  "cstruct.6.2.0"
+  "cstruct-lwt.6.2.0"
+  "cstruct-unix.6.2.0"
+  "ctypes.0.20.2"
+  "ctypes-foreign.0.18.0"
+  "decompress.1.5.3"
+  "digestif.1.2.0"
+  "dispatch.0.5.0"
+  "dns.7.0.3"
+  "dns-client.7.0.3"
+  "dns-client-lwt.7.0.3"
+  "dns-client-mirage.7.0.3"
+  "domain-name.0.4.0"
+  "dot-merlin-reader.4.9"
+  "duff.0.5"
+  "dune.3.15.2"
+  "dune-build-info.3.15.2"
+  "dune-configurator.3.15.2"
+  "duration.0.2.1"
+  "easy-format.1.3.4"
+  "either.1.0.0"
+  "emile.1.1"
+  "encore.0.8"
+  "eqaf.0.9"
+  "ethernet.3.2.0"
+  "faraday.0.8.2"
+  "fix.20230505"
+  "fmt.0.9.0"
+  "fpath.0.7.3"
+  "fsevents.0.3.0"
+  "fsevents-lwt.0.3.0"
+  "functoria-runtime.4.4.2"
+  "gg.1.0.0"
+  "git.3.15.0"
+  "git-mirage.3.15.0"
+  "git-paf.3.15.0"
+  "git-unix.3.15.0"
+  "glfw-ocaml.3.3.1-2"
+  "gmap.0.3.0"
+  "graphql.0.14.0"
+  "graphql-cohttp.0.14.0"
+  "graphql-lwt.0.14.0"
+  "graphql_parser.0.14.0"
+  "graphv_core.0.1.1"
+  "graphv_core_lib.0.1.1"
+  "graphv_font.0.1.1"
+  "graphv_font_stb_truetype.0.1.1"
+  "graphv_gles2.0.1.1"
+  "graphv_gles2_native.0.1.1"
+  "graphv_gles2_native_impl.0.1.1"
+  "h2.0.11.0"
+  "happy-eyeballs.0.6.0"
+  "happy-eyeballs-lwt.0.6.0"
+  "happy-eyeballs-mirage.0.6.0"
+  "hashcons.1.4.0"
+  "hex.1.5.0"
+  "hkdf.1.0.4"
+  "hpack.0.11.0"
+  "httpaf.0.7.1"
+  "hxd.0.3.2"
+  "index.1.6.2"
+  "inotify.2.5"
+  "integers.0.7.0"
+  "ipaddr.5.5.0"
+  "ipaddr-cstruct.5.5.0"
+  "ipaddr-sexp.5.5.0"
+  "irmin.3.9.0"
+  "irmin-fs.3.9.0"
+  "irmin-git.3.9.0"
+  "irmin-graphql.3.9.0"
+  "irmin-pack.3.9.0"
+  "irmin-tezos.3.9.0"
+  "irmin-watcher.0.5.0"
+  "jsonm.1.0.2"
+  "ke.0.6"
+  "lablgtk3.3.1.4"
+  "lablgtk3-sourceview3.3.1.4"
+  "lambda-term.3.3.2"
+  "logs.0.7.0"
+  "lru.0.3.1"
+  "lwd.0.3"
+  "lwt.5.7.0"
+  "lwt-dllist.1.0.1"
+  "lwt_glib.1.1.1"
+  "lwt_react.1.2.0"
+  "macaddr.5.5.0"
+  "macaddr-cstruct.5.5.0"
+  "magic-mime.1.3.1"
+  "memtrace.0.2.3"
+  "menhir.20231231"
+  "menhirCST.20231231"
+  "menhirLib.20231231"
+  "menhirSdk.20231231"
+  "merlin.4.14-501"
+  "merlin-lib.4.14-501"
+  "metrics.0.4.1"
+  "metrics-lwt.0.4.1"
+  "mew.0.1.0"
+  "mew_vi.0.5.0"
+  "mimic.0.0.6"
+  "mimic-happy-eyeballs.0.0.6"
+  "mirage-clock.4.2.0"
+  "mirage-clock-unix.4.2.0"
+  "mirage-crypto.0.11.3"
+  "mirage-crypto-ec.0.11.3"
+  "mirage-crypto-pk.0.11.3"
+  "mirage-crypto-rng.0.11.3"
+  "mirage-crypto-rng-lwt.0.11.3"
+  "mirage-device.2.0.0"
+  "mirage-flow.3.0.0"
+  "mirage-kv.6.1.1"
+  "mirage-net.4.0.0"
+  "mirage-no-solo5.1"
+  "mirage-random.3.0.0"
+  "mirage-runtime.4.5.1"
+  "mirage-time.3.0.0"
+  "mirage-unix.5.0.1"
+  "mtime.2.0.0"
+  "not-ocamlfind.0.13"
+  "num.1.5"
+  "ocaml.5.1.1"
+  "ocaml-compiler-libs.v0.12.4"
+  "ocaml-config.3"
+  "ocaml-syntax-shims.1.0.0"
+  "ocaml-variants.5.1.1+options"
+  "ocaml-version.3.6.7"
+  "ocamlbuild.0.14.3"
+  "ocamlfind.1.9.6"
+  "ocamlformat.0.26.2"
+  "ocamlformat-lib.0.26.2"
+  "ocamlgraph.2.1.0"
+  "ocp-indent.1.8.1"
+  "ocplib-endian.1.2"
+  "odig.0.0.9"
+  "odoc.2.4.2"
+  "odoc-parser.2.4.2"
+  "optint.0.3.0"
+  "paf.0.5.0"
+  "parsexp.v0.16.0"
+  "pbkdf.1.2.0"
+  "pecu.0.7"
+  "ppx_derivers.1.2.1"
+  "ppx_deriving.5.2.1"
+  "ppx_enumerate.v0.16.0"
+  "ppx_irmin.3.9.0"
+  "ppx_repr.0.7.0"
+  "ppx_sexp_conv.v0.16.0"
+  "ppxlib.0.32.1"
+  "progress.0.4.0"
+  "psq.0.2.1"
+  "ptime.1.1.0"
+  "randomconv.0.1.3"
+  "re.1.11.0"
+  "react.1.2.2"
+  "repr.0.7.0"
+  "result.1.5"
+  "rresult.0.7.0"
+  "rusage.1.0.0"
+  "semaphore-compat.1.0.1"
+  "seq.base"
+  "sexplib.v0.16.0"
+  "sexplib0.v0.16.0"
+  "stb_image.0.5"
+  "stb_truetype.0.7"
+  "stdio.v0.16.0"
+  "stdlib-shims.0.3.0"
+  "stringext.1.6.0"
+  "tcpip.8.0.0"
+  "terminal.0.4.0"
+  "tezos-base58.1.0.0"
+  "tgls.0.8.6"
+  "tls.0.17.3"
+  "tls-lwt.0.17.3"
+  "tls-mirage.0.17.3"
+  "topkg.1.0.7"
+  "trie.1.0.0"
+  "tuareg.3.0.1"
+  "tyxml.4.6.0"
+  "uchar.0.0.2"
+  "uri.4.4.0"
+  "uri-sexp.4.4.0"
+  "user-setup.0.7"
+  "utop.2.14.0"
+  "uucp.15.1.0"
+  "uuseg.15.1.0"
+  "uutf.1.0.3"
+  "vector.1.0.0"
+  "webmachine.0.7.0"
+  "x509.0.16.5"
+  "xdg.3.15.2"
+  "yaml.3.2.0"
+  "yojson.2.1.2"
+  "zarith.1.13"
+  "zed.3.2.3"
+]

oplevel.ml

@@ -64,12 +64,6 @@ let main =
   let min_fps = ref Float.max_float in
   let max_fps = ref Float.min_float in
 
-  (* Thread which is woken up when the main window is closed. *)
-  let _waiter, _wakener = Lwt.wait () in
-
-  F.pr "oplevel.ml: Toploop.initialize_toplevel_env@.";
-  Toploop.initialize_toplevel_env ();
-
   let rootrepo =
     Store.init_default
       (F.str "%s/console/rootstore.git" Secrets.giturl)
@@ -81,6 +75,7 @@ let main =
 
   load_fonts ui.gv;
 
+  (* Format.safe_set_geometry ~max_indent:(500 - 1) ~margin:500; *)
   let event_stream, event_push = Lwt_stream.create () in
   Ogui.Ui.process_events ui event_stream;
   GLFW.setKeyCallback ~window
@@ -128,7 +123,7 @@ let main =
        (String.concat "/" initial_path))
   |> Lwt.return
   >>= fun to_init ->
-  let out_ppf =
+  let _out_ppf =
     let insert s =
       Lwt.async (fun () ->
           TextBuffer.length to_init >>= fun len ->
@@ -146,15 +141,20 @@ let main =
         }
   in
 
+  (*F.pr "oplevel.ml: Toploop.initialize_toplevel_env@.";
+    Toploop.initialize_toplevel_env ();
+    Clflags.debug := true;
     ignore
       (Toploop.use_input out_ppf
-       (String "#use \"topfind\";;\n#list;;#require \"lwt\";;"));
+         (String "#use \"topfind\";;\n#list;;#require \"lwt\";;")); *)
   (* toplevel execution binding *)
   Ui.(
-    update_bindings ui
+    append_bindings ui
-      Event.(
+      (Lwd.return
-        fun a ->
+         Event.
-          a
+           [
+             pack Fun.id
+               (empty
                |> adds
                     [
                       [
@@ -166,40 +166,41 @@ let main =
                       Custom
                         ( "toplevel_execute",
                           fun () ->
-                       TextBuffer.peek tb_init >>= fun str ->
+                            TextBuffer.peek tb_init >>= fun _str ->
-                       Toploop.use_input out_ppf (String str)
+                            (*Toploop.use_input out_ppf (String str)
-                       |> F.epr "Toploop.use_input=%b@.";
+                              |> F.epr "Toploop.use_input=%b@."; *)
                             Lwt.return_unit );
+                    ]);
            ]));
 
-  Layout.(
+  WindowManager.make ui
-    system ui `Y
-      ~style:
-        Style.{ default with margin = Margin.symmetric 10.0 10.0 }
     (Lwd.var
-         ~eq:(fun (a, _) (b, _) -> Int.equal a b)
+       (`T
-         ( 0,
+         ( `Y,
+           WindowManager.
              [
-             TextEdit.multiline ui tb_init;
+               {
-             TextEdit.multiline ui to_init;
+                 t = `TextEdit (TextEdit.multiline ui to_init);
+                 dim = `Ratio 0.333;
+                 bindings = [];
+               };
+               {
+                 t = `TextEdit (TextEdit.multiline ui tb_init);
+                 dim = `Ratio 0.5;
+                 bindings = [];
+               };
+               {
+                 t = `TextEdit (TextEdit.multiline ui to_init);
+                 dim = `Ratio 1.0;
+                 bindings = [];
+               };
              ] )))
   >>= fun page ->
   let page_root = Lwd.observe page in
 
-  let open GLFW in
+  let bindings = ui.bindings |> Lwd.observe |> Lwd.quick_sample in
-  let open Event in
+  F.epr "Bindings:@.";
-  Ui.update_bindings ui
+  List.iter (fun bs -> F.epr "%a" Ui.pp_pack bs) bindings;
-    Ui.(
-      adds
-        [
-          [ Key (Press, X, [ Control ]); Key (Press, E, [ Control ]) ];
-        ]
-        [ Custom ("toplevel_execute", fun () -> Lwt.return ()) ]);
-
-  let bindings =
-    ui.bindings |> Lwd.get |> Lwd.observe |> Lwd.quick_sample |> snd
-  in
-  F.epr "Bindings:@.%a" Ui.pp_bindings bindings;
 
   F.pr "oplevel.ml: entering drawing loop@.";
   let period_min = 1.0 /. 30. in