more Lwd.t-ification

ogui.ml

@@ -30,6 +30,16 @@ let pp_color : Gv.Color.t Fmt.t =
            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
+  Lwd.quick_sample root >>= fun root' ->
+  let var = Lwd.var root' in
+  Lwd.set_on_invalidate root (fun _t' ->
+      Lwt.async (fun () ->
+          Lwd.quick_sample root >>= fun root' ->
+          Lwt.return @@ Lwd.set var root'));
+  Lwt.return (Lwd.get var)
+
 module Margin = struct
   open Gg
 
@@ -87,124 +97,111 @@ end
 
 module TextBuffer = struct
   type t = {
-    mutable path : string list;
+    path : string list Lwd.var;
-    mutable tree : Store.S.tree;
+    tree : Store.S.tree Lwd.var;
     repo : Store.Sync.db Lwt.t;
-    var : string Lwd.var;
   }
 
-  let of_repo ~path ~(repo : Store.Sync.db Lwt.t) : t Lwt.t =
+  let of_repo ~initial_path ~(repo : Store.Sync.db Lwt.t) : t Lwt.t =
-    let tree = Lwt_main.run (repo >>= Store.S.tree) in
+    repo >>= Store.S.tree >>= fun tree ->
-    Store.S.Tree.find tree path >>= fun res ->
     Lwt.return
-      {
+      { path = Lwd.var initial_path; tree = Lwd.var tree; repo }
-        path;
-        tree;
-        repo;
-        var =
-          Lwd.var
-            (match res with
-            | Some s -> s
-            | None ->
-                F.epr "TextBuffer.of_repo: None@.";
-                "");
-      }
 
   let of_string ~path ?(repo = None) str =
     {
-      path;
+      path = Lwd.var path;
-      tree = Store.S.Tree.singleton path str;
+      tree = Lwd.var @@ Store.S.Tree.singleton path str;
       repo =
         ( Store.S.Repo.v (Irmin_mem.config ()) >>= fun repo' ->
           Option.value ~default:Store.S.(empty repo') repo );
-      var = Lwd.var str;
     }
 
-  let insert_uchar t n uc : t Lwt.t =
+  let insert_uchar { path; tree; _ } n uc : unit Lwt.t =
-    (* F.epr "TextBuffer.insert_uchar %d %a@." n pp_uchar uc; *)
+    F.epr "TextBuffer.insert_uchar %d %a@." n pp_uchar uc;
-    match t with
+    let ucbuf = Bytes.create 8 in
-    | { path; tree; var; _ } as tt ->
+    let uclen = Bytes.set_utf_8_uchar ucbuf 0 uc in
-        Store.S.Tree.update tree path (function
+    Store.S.Tree.update (Lwd.peek tree) (Lwd.peek path) (function
-          | Some src ->
+      | Some src ->
-              let sn = String.length src in
+          let sn = String.length src in
-              assert (n <= sn);
+          assert (n <= sn);
-              let ucbuf = Bytes.create 8 in
+          let dst = Bytes.create (sn + uclen) in
-              let uclen = Bytes.set_utf_8_uchar ucbuf 0 uc in
+          BytesLabels.blit_string ~src ~src_pos:0 ~dst ~dst_pos:0
-              let dst = Bytes.create (sn + uclen) in
+            ~len:n;
-              BytesLabels.blit_string ~src ~src_pos:0 ~dst ~dst_pos:0
+          BytesLabels.blit ~src:ucbuf ~src_pos:0 ~dst ~dst_pos:n
-                ~len:n;
+            ~len:uclen;
-              BytesLabels.blit ~src:ucbuf ~src_pos:0 ~dst ~dst_pos:n
+          if sn > n + uclen then
-                ~len:uclen;
+            BytesLabels.blit_string ~src ~src_pos:n ~dst
-              if sn > n + uclen then
+              ~dst_pos:(n + uclen)
-                BytesLabels.blit_string ~src ~src_pos:n ~dst
+              ~len:(sn - (n + uclen));
-                  ~dst_pos:(n + uclen)
+          Some (Bytes.to_string dst)
-                  ~len:(sn - (n + uclen));
+      | None ->
-              Lwd.set var (Bytes.to_string dst);
+          F.epr "TextBuffer.insert_uchar Tree.update -> Nonep@.";
-              Some (Lwd.peek var)
+          Some (String.sub (Bytes.to_string ucbuf) 0 uclen))
-          | None -> None)
+    >>= fun t ->
-        >>= fun tree -> Lwt.return { tt with tree }
+    Lwd.set tree t;
+    Lwt.return_unit
 
-  let remove t (a, b) : t Lwt.t =
+  let remove { path; tree; _ } (a, b) : unit Lwt.t =
     let a, b = (min a b, max a b) in
     (* F.epr "TextBuffer.remove (%d, %d)@." a b; *)
-    match t with
+    Store.S.Tree.update (Lwd.peek tree) (Lwd.peek path) (function
-    | { path; tree; var; _ } as tt ->
+      | Some src ->
-        Store.S.Tree.update tree path (function
+          let srcn = String.length src in
-          | Some src ->
+          assert (max a b <= srcn);
-              let srcn = String.length src in
+          let dst = Bytes.create (srcn - (b - a)) in
-              assert (max a b <= srcn);
+          Bytes.blit_string src 0 dst 0 a;
-              let dst = Bytes.create (srcn - (b - a)) in
+          Bytes.blit_string src b dst a (srcn - b);
-              Bytes.blit_string src 0 dst 0 a;
+          Some (Bytes.to_string dst)
-              Bytes.blit_string src b dst a (srcn - b);
+      | v -> v)
-              Lwd.set var (Bytes.to_string dst);
+    >>= fun t ->
-              Some (Bytes.to_string dst)
+    Lwd.set tree t;
-          | v -> v)
+    Lwt.return_unit
-        >>= fun tree -> Lwt.return { tt with tree }
 
-  let remove_uchar t n : t Lwt.t =
+  let remove_uchar { path; tree; _ } n : unit Lwt.t =
     (* F.epr "TextBuffer.remove_subset n=%d @." n; *)
-    match t with
+    Store.S.Tree.update (Lwd.peek tree) (Lwd.peek path) (function
-    | { path; tree; var; _ } as tt ->
+      | Some src ->
-        Store.S.Tree.update tree path (function
+          let srcn = String.length src in
-          | Some src ->
+          assert (n < srcn);
-              let srcn = String.length src in
+          let ucn =
-              assert (n < srcn);
+            Uchar.utf_decode_length (String.get_utf_8_uchar src n)
-              let ucn =
+          in
-                Uchar.utf_decode_length (String.get_utf_8_uchar src n)
+          let dst = Bytes.create (srcn - ucn) in
-              in
+          Bytes.blit_string src 0 dst 0 n;
-              let dst = Bytes.create (srcn - ucn) in
+          Bytes.blit_string src (n + ucn) dst n (srcn - n - ucn);
-              Bytes.blit_string src 0 dst 0 n;
+          Some (Bytes.to_string dst)
-              Bytes.blit_string src (n + ucn) dst n (srcn - n - ucn);
+      | None ->
-              Lwd.set var (Bytes.to_string dst);
+          F.epr "TextBuffer.remove_uchar None";
-              Some (Bytes.to_string dst)
+          None)
-          | None ->
+    >>= fun t ->
-              F.epr "TextBuffer.remove_uchar None";
+    Lwd.set tree t;
-              None)
+    Lwt.return_unit
-        >>= fun tree -> Lwt.return { tt with tree }
 
   let fold_string t (f : string -> 'a) : 'a Lwt.t =
     match t with
     | { path; tree; _ } ->
-        Store.S.Tree.get tree path >>= fun text -> Lwt.return (f text)
+        Store.S.Tree.get (Lwd.peek tree) (Lwd.peek path)
+        >>= fun text -> Lwt.return (f text)
 
-  let get t = Lwd.get t.var
+  let contents { path; tree; _ } : string Lwt.t =
-
+    (try Store.S.Tree.get (Lwd.peek tree) (Lwd.peek path)
-  let contents { path; tree; _ } =
+     with e ->
-    (try Store.S.Tree.get tree path with
+       F.epr "TextBuffer.contents %s: %s"
-    | Not_found | Invalid_argument _ ->
+         (String.concat "/" (Lwd.peek path))
-        Lwt.return
+         (match e with
-        @@ F.str
+         | Not_found -> "Not_found"
-             "print_newline \"/%s: Not_found | Invalid_argument\";;"
+         | Invalid_argument a -> F.str "Invalid_argument %s" a
-             (String.concat "/" path)
+         | exc -> F.str "Exception: %s" (Printexc.to_string exc));
-    | exc ->
+       Lwt.return "")
-        Lwt.return
-          (F.str "Store.S.Tree.get /%s exception: %s"
-             (String.concat "/" path)
-             (Printexc.to_string exc)))
     >>= fun text -> Lwt.return text
 
+  let get { tree; path; _ } =
+    Lwd.map2 (Lwd.get tree) (Lwd.get path) ~f:(fun tree path ->
+        Store.S.Tree.get tree path)
+    |> lwt_lwd
+
   let length { path; tree; _ } =
-    Store.S.Tree.get tree path >>= fun text ->
+    Store.S.Tree.get (Lwd.peek tree) (Lwd.peek path) >>= fun text ->
     Lwt.return (String.length text)
 end
 
@@ -488,7 +485,8 @@ module TextLayout = struct
       record
         [
           field "text"
-            (fun s -> str "path=%s" (String.concat "/" s.text.path))
+            (fun s ->
+              str "path=%s" (String.concat "/" (Lwd.peek s.text.path)))
             string;
           field "sections"
             (fun s -> s.sections)
@@ -526,9 +524,10 @@ module TextLayout = struct
   let cursor_default = { index = 0; last_col = 0 }
   let cursor ?(last_col = 0) index : cursor = { index; last_col }
 
-  let simple (text : 'a) ?(start = Lwd.pure 0)
+  let simple (text : TextBuffer.t) ?(start = Lwd.pure 0)
-      ?(format = format_default) wrap_width : layout Lwd.t =
+      ?(format = format_default) wrap_width : layout Lwd.t Lwt.t =
-    Lwd.map2 (TextBuffer.get text) start ~f:(fun str start ->
+    TextBuffer.get text >>= fun str ->
+    Lwd.map2 start str ~f:(fun start str ->
         {
           layout_default with
           text;
@@ -537,6 +536,7 @@ module TextLayout = struct
           wrap =
             { (default_text_wrapping ()) with max_width = wrap_width };
         })
+    |> Lwt.return
 
   let cursor_color = ref (Gv.Color.rgbf ~r:0.5 ~g:0.5 ~b:0.)
 
@@ -555,20 +555,11 @@ module TextLayout = struct
           (fun (l : section list) sec ->
             let s, e = sec.byte_range in
             l
-            @ (if
+            @ (if e < cs || ce < s then [ sec ] else [])
-                 e < cs || ce < s
+            @ (if cs > s && cs <= e then
-                 (* cursor start is after this section or cursor end is before this section *)
+                 [ { sec with byte_range = (s, cs) } ]
-               then [ sec ]
                else [])
-            @ (if
+            @ (if cs <= e && ce >= s then
-                 cs > s
-                 && cs <= e (* if cursor start is in this section *)
-               then [ { sec with byte_range = (s, cs) } ]
-               else [])
-            @ (if
-                 cs <= e && ce >= s
-                 (* if cursor start is at or before the end this section and cursor end is at or after the beginning of this section *)
-               then
                  [
                    {
                      format = format sec.format;
@@ -577,9 +568,8 @@ module TextLayout = struct
                  ]
                else [])
             @
-            if
+            if ce > s && ce <= e then
-              ce > s && ce <= e (* if cursor end is in this section *)
+              [ { sec with byte_range = (ce, e) } ]
-            then [ { sec with byte_range = (ce, e) } ]
             else [])
           [] layout.sections;
     }
@@ -595,6 +585,8 @@ module TextLayout = struct
         Lwd.map2 mark cursor ~f:(fun m c ->
             match m with
             | Some m' ->
+                F.epr "TextLayout.with_mark inside Lwd.map@.";
+
                 with_range ~format (min m' c.index, max m' c.index) l
             | None -> l))
 end
@@ -801,7 +793,7 @@ 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 Lwt.t =
+  let default_bindings (t : t) (ui : Ui.t) : unit =
     let open GLFW in
     let open Event in
     let open Ui in
@@ -989,14 +981,12 @@ module TextEdit = struct
                      | None -> Some (Lwd.peek t.cursor).index);
                    Lwt.return_unit);
              ]);
-    (* WARN XXX TKTK TODO this is probably "breaking" the lwt context and being used in other calls to Lwt_main.run *)
+    Ui.chrcallback_ref :=
-    (Ui.chrcallback_ref :=
+      fun c ->
-       fun c ->
+        TextBuffer.insert_uchar t.text (Lwd.peek t.cursor).index c
-         TextBuffer.insert_uchar t.text (Lwd.peek t.cursor).index c
+        >>= fun _ -> cursor_move t 1
-         >>= fun _ -> cursor_move t 1
+  (* This creates a giant stack of calls lol
-       (* This creates a giant stack of calls lol
+     >>= fun () -> !Ui.chrcallback_ref c *)
-          >>= fun () -> !Ui.chrcallback_ref c *));
-    Lwt.return_unit
 
   let multiline ui ?(text_format = TextLayout.format_default)
       (text : TextBuffer.t) : t =
@@ -1024,7 +1014,7 @@ module TextEdit = struct
         (* return_key = keyboard_shortcut; *)
       }
     in
-    Lwt_main.run (default_bindings t ui);
+    default_bindings t ui;
     t
 end
 
@@ -1035,10 +1025,10 @@ module Layout = struct
   type frame = { t : t; mutable size : size; style : Style.t }
 
   and t =
-    [ `Box of [ `H | `V | `Z ] * frame list
+    [ `Join of [ `X | `Y | `Z ] * (frame * frame)
     | `String of string
     | `Buffer of TextBuffer.t
-    | `TextEdit of TextEdit.t * TextLayout.layout Lwd.root
+    | `TextEdit of TextEdit.t * TextLayout.layout
     | `None ]
 
   and size = [ `Fixed of size2 | `Max | `Min ]
@@ -1046,8 +1036,22 @@ module Layout = struct
   let frame ?(size = `Max) ?(style = Style.default) t : frame =
     { t; size; style }
 
-  let box d ?style t = frame ?style (`Box (d, t))
+  let none = frame `None
-  let hbox, vbox, zbox = (box `H, box `V, box `Z)
+  let join d ?style a b = frame ?style (`Join (d, (a, b)))
+
+  let box d ?style =
+    List.fold_left (fun acc a -> join d ?style a acc) none
+
+  (*  let hbox, vbox, zbox = (box `X, box `Y, box `Z) *)
+  let pack_x ?style () = (none, join `X ?style)
+  let pack_y ?style () = (none, join `Y ?style)
+  let pack_z ?style () = (none, join `Z ?style)
+  let hcat ?style = Lwd_utils.reduce (pack_x ?style ())
+  let vcat ?style = Lwd_utils.reduce (pack_y ?style ())
+  let zcat ?style = Lwd_utils.reduce (pack_z ?style ())
+  let hbox ?style = Lwd_utils.pack (pack_x ?style ())
+  let vbox ?style = Lwd_utils.pack (pack_y ?style ())
+  let zbox ?style = Lwd_utils.pack (pack_z ?style ())
 
   let textedit_style =
     Style.
@@ -1057,23 +1061,26 @@ module Layout = struct
         margin = Margin.symmetric 10. 10.;
       }
 
-  let textedit ?size ?(style = textedit_style) (t : TextEdit.t) =
+  let textedit ?size ?(style = textedit_style) (t : TextEdit.t) :
+      frame Lwd.t Lwt.t =
     let open TextLayout in
+    F.epr "Layout.textedit@.";
     simple t.text ~start:(Lwd.get t.scroll) ~format:t.text_format
       (Option.value ~default:80. t.desired_width)
-    |> with_cursor (Lwd.get t.cursor)
+    >>= fun layout ->
+    with_cursor (Lwd.get t.cursor) layout
     |> with_mark (Lwd.get t.mark) (Lwd.get t.cursor)
-    |> Lwd.observe
+    |> Lwd.map ~f:(fun tl -> frame ?size ~style (`TextEdit (t, tl)))
-    |> fun root -> frame ?size ~style (`TextEdit (t, root))
+    |> Lwt.return
 
-  let pp_dir ppf (t : [ `H | `V | `Z ]) =
+  let pp_dir ppf (t : [ `X | `Y | `Z ]) =
     F.pf ppf "%s"
-      (match t with `H -> "`H" | `V -> "`V" | `Z -> "`Z")
+      (match t with `X -> "`X" | `Y -> "`Y" | `Z -> "`Z")
 
   let pp_t ppf (t : t) =
     F.pf ppf "%s"
       (match t with
-      | `Box (d, _) -> F.str "`Box %a" pp_dir d
+      | `Join (d, _) -> F.str "`Join %a" pp_dir d
       | `Buffer _ -> "`Buffer"
       | `TextEdit _ -> "`TextEdit"
       | `String s -> F.str "`String %s" s
@@ -1131,9 +1138,9 @@ module Painter = struct
     Text.set_size t ~size:font_size;
     Text.set_align t ~align:Align.(left lor top)
 
-  let text_layout (t : Gv.t) (rect : box2) (te : TextEdit.t)
+  let text_layout (t : Gv.t) (rect : box2)
-      (layout : TextLayout.layout Lwd.root) : box2 Lwt.t =
+      ((te, layout) : TextEdit.t * TextLayout.layout) : box2 Lwt.t =
-    let g = Lwd.quick_sample layout in
+    let g = layout in
     let line_height =
       Option.value ~default:(Gv.Text.metrics t).line_height
         g.line_height
@@ -1141,7 +1148,8 @@ module Painter = struct
     let max_rows = Int.of_float (Box2.h rect /. line_height) in
     Lwd.set te.rows max_rows;
     let lines = Gv.Text.make_empty_rows max_rows in
-    TextBuffer.contents g.text >>= fun contents ->
+    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
@@ -1202,20 +1210,20 @@ module Painter = struct
       box2 Lwt.t =
     let box' = Margin.inner style.margin box in
     (match t with
-    | `Box (dir, ll) ->
+    | `Join (dir, (a, b)) ->
         Lwt_list.fold_left_s
           (fun (c : box2) f ->
             layout c ui f >>= fun r ->
             let c' =
               Box2.(
                 match dir with
-                | `V -> of_pts (V2.v (minx c) (maxy r)) (max c)
+                | `X -> of_pts (V2.v (minx c) (maxy r)) (max c)
-                | `H -> of_pts (V2.v (maxx r) (miny c)) (max c)
+                | `Y -> of_pts (V2.v (maxx r) (miny c)) (max c)
                 | `Z -> box)
             in
             Lwt.return c')
-          box' ll
+          box' [ a; b ]
-    | `TextEdit (t, root) -> text_layout ui.gv box' t root
+    | `TextEdit tt -> text_layout ui.gv box' tt
     | _ -> Lwt.return box)
     >>= fun r ->
     let r' =

oplevel.ml

@@ -38,7 +38,7 @@ let load_fonts vg =
   Gv.Text.add_fallback vg ~name:"sans-bold" ~fallback:"emoji";
   Gv.Text.set_font_face vg ~name:"mono"
 
-let () =
+let main =
   GLFW.init ();
   at_exit GLFW.terminate;
   let _res = GLFWExtras.glfwSetErrorCallback errorcb in
@@ -99,24 +99,24 @@ let () =
   |> ignore;
 
   F.pr "oplevel.ml: building initial page@.";
+  TextBuffer.of_repo
+    ~initial_path:[ ".config"; "init.ml" ]
+    ~repo:rootrepo
+  >>= fun tb_init ->
+  Layout.textedit (TextEdit.multiline ui tb_init) >>= fun te_init ->
   let page =
-    Lwd.var
+    Layout.(
-      Layout.(
+      vbox
-        vbox
+        ~style:
-          ~style:
+          Style.{ default with margin = Margin.symmetric 10.0 10.0 }
-            Style.{ default with margin = Margin.symmetric 10.0 10.0 }
+        [
-          [
+          te_init;
-            textedit
+          (*textedit
-              (TextEdit.multiline ui
+            (TextEdit.multiline ui
-                 (Lwt_main.run
+               (TextBuffer.of_repo ~path:[ "README" ] ~repo:rootrepo)); *)
-                    (TextBuffer.of_repo
+        ])
-                       ~path:[ ".config"; "init.ml" ]
-                       ~repo:rootrepo)));
-            (*textedit
-              (TextEdit.multiline ui
-                 (TextBuffer.of_repo ~path:[ "README" ] ~repo:rootrepo)); *)
-          ])
   in
+  let page_root = Lwd.observe page in
 
   let open GLFW in
   let open Event in
@@ -131,7 +131,23 @@ let () =
   let period_min = 1.0 /. 30. in
   let t = GLFW.getTime () |> ref in
 
-  let render page =
+  let render root =
+    let page = Lwd.quick_sample root in
+    let win_w, win_h = GLFW.getWindowSize ~window in
+    let width, height = (float win_w, float win_h) in
+    let box = Gg.(Box2.v V2.zero Size2.(v width (height -. 20.))) in
+    Gv.begin_frame ctx ~width ~height ~device_ratio:1.;
+    Perfgraph.render graph ctx (width -. 205.) 5.;
+    (* F.epr "box=%a@." Gg.Box2.pp box;
+       F.epr "Painter.layout=%a@." Gg.Box2.pp *)
+    Painter.layout box ui page >>= fun _ ->
+    (* Demo.render_demo ctx mx my win_w win_h now !blowup data; *)
+    Gv.end_frame ctx;
+
+    Lwt.return_unit
+  in
+
+  while not GLFW.(windowShouldClose ~window) do
     let now = GLFW.getTime () in
     let dt = now -. !t in
     t := now;
@@ -143,9 +159,7 @@ let () =
       min_fps := Float.min avg !min_fps;
       max_fps := Float.max avg !max_fps);
 
-    let _mx, _my = GLFW.getCursorPos ~window in
     let win_w, win_h = GLFW.getWindowSize ~window in
-
     Gl.viewport 0 0 win_w win_h;
     Gl.clear
       (Gl.color_buffer_bit lor Gl.depth_buffer_bit
@@ -154,31 +168,16 @@ let () =
     Gl.blend_func Gl.src_alpha Gl.one_minus_src_alpha;
     Gl.enable Gl.cull_face_enum;
     Gl.disable Gl.depth_test;
-
+    Lwt.async (fun () -> render page_root);
-    let width, height = (float win_w, float win_h) in
-    let box = Gg.(Box2.v V2.zero Size2.(v width (height -. 20.))) in
-    Gv.begin_frame ctx ~width ~height ~device_ratio:1.;
-    Perfgraph.render graph ctx (width -. 205.) 5.;
-    (* F.epr "box=%a@." Gg.Box2.pp box;
-       F.epr "Painter.layout=%a@." Gg.Box2.pp *)
-    Painter.layout box ui page >>= fun _ ->
-    (* Demo.render_demo ctx mx my win_w win_h now !blowup data; *)
-    Gv.end_frame ctx;
-
     Gc.major_slice 0 |> ignore;
     GLFW.swapBuffers ~window;
     GLFW.pollEvents ();
-    Unix.sleepf Float.(max 0. (period_min -. GLFW.getTime () +. !t));
+    Unix.sleepf Float.(max 0. (period_min -. GLFW.getTime () +. !t))
-    Lwt.return_unit
-  in
-
-  while not GLFW.(windowShouldClose ~window) do
-    Lwt_main.run (render (Lwd.peek page))
   done;
 
   Printf.printf "MIN %.2f\n" !min_fps;
-  Printf.printf "MAX %.2f\n%!" !max_fps
+  Printf.printf "MAX %.2f\n%!" !max_fps;
-
+  Lwt.return_unit
 (* let out_ppf =
      Format.formatter_of_out_functions
        Format.
@@ -199,3 +198,5 @@ let () =
 (* ignore
    (Toploop.use_input out_ppf
       (String "#use \"topfind\";;\n#list;;")); *)
+
+let () = Lwt_main.run main