From 36fd690e213d5711d7c7fb67a913743f43d2cfaf Mon Sep 17 00:00:00 2001 From: cqc Date: Tue, 21 May 2024 20:15:50 -0500 Subject: [PATCH] more Lwd.t-ification --- ogui.ml | 294 +++++++++++++++++++++++++++-------------------------- oplevel.ml | 79 +++++++------- 2 files changed, 191 insertions(+), 182 deletions(-) diff --git a/ogui.ml b/ogui.ml index 9c14db9..c04257d 100644 --- a/ogui.ml +++ b/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; - mutable tree : Store.S.tree; + path : string list Lwd.var; + 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 tree = Lwt_main.run (repo >>= Store.S.tree) in - Store.S.Tree.find tree path >>= fun res -> + let of_repo ~initial_path ~(repo : Store.Sync.db Lwt.t) : t Lwt.t = + repo >>= Store.S.tree >>= fun tree -> Lwt.return - { - path; - tree; - repo; - var = - Lwd.var - (match res with - | Some s -> s - | None -> - F.epr "TextBuffer.of_repo: None@."; - ""); - } + { path = Lwd.var initial_path; tree = Lwd.var tree; repo } let of_string ~path ?(repo = None) str = { - path; - tree = Store.S.Tree.singleton path str; + path = Lwd.var path; + 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 = - (* F.epr "TextBuffer.insert_uchar %d %a@." n pp_uchar uc; *) - match t with - | { path; tree; var; _ } as tt -> - Store.S.Tree.update tree path (function - | Some src -> - let sn = String.length src in - assert (n <= sn); - let ucbuf = Bytes.create 8 in - let uclen = Bytes.set_utf_8_uchar ucbuf 0 uc in - let dst = Bytes.create (sn + uclen) in - BytesLabels.blit_string ~src ~src_pos:0 ~dst ~dst_pos:0 - ~len:n; - BytesLabels.blit ~src:ucbuf ~src_pos:0 ~dst ~dst_pos:n - ~len:uclen; - if sn > n + uclen then - BytesLabels.blit_string ~src ~src_pos:n ~dst - ~dst_pos:(n + uclen) - ~len:(sn - (n + uclen)); - Lwd.set var (Bytes.to_string dst); - Some (Lwd.peek var) - | None -> None) - >>= fun tree -> Lwt.return { tt with tree } + let insert_uchar { path; tree; _ } n uc : unit Lwt.t = + F.epr "TextBuffer.insert_uchar %d %a@." n pp_uchar uc; + let ucbuf = Bytes.create 8 in + let uclen = Bytes.set_utf_8_uchar ucbuf 0 uc in + Store.S.Tree.update (Lwd.peek tree) (Lwd.peek path) (function + | Some src -> + let sn = String.length src in + assert (n <= sn); + let dst = Bytes.create (sn + uclen) in + BytesLabels.blit_string ~src ~src_pos:0 ~dst ~dst_pos:0 + ~len:n; + BytesLabels.blit ~src:ucbuf ~src_pos:0 ~dst ~dst_pos:n + ~len:uclen; + if sn > n + uclen then + BytesLabels.blit_string ~src ~src_pos:n ~dst + ~dst_pos:(n + uclen) + ~len:(sn - (n + uclen)); + Some (Bytes.to_string dst) + | None -> + F.epr "TextBuffer.insert_uchar Tree.update -> Nonep@."; + Some (String.sub (Bytes.to_string ucbuf) 0 uclen)) + >>= fun t -> + 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 - | { path; tree; var; _ } as tt -> - Store.S.Tree.update tree path (function - | Some src -> - let srcn = String.length src in - assert (max a b <= srcn); - let dst = Bytes.create (srcn - (b - a)) in - Bytes.blit_string src 0 dst 0 a; - Bytes.blit_string src b dst a (srcn - b); - Lwd.set var (Bytes.to_string dst); - Some (Bytes.to_string dst) - | v -> v) - >>= fun tree -> Lwt.return { tt with tree } + Store.S.Tree.update (Lwd.peek tree) (Lwd.peek path) (function + | Some src -> + let srcn = String.length src in + assert (max a b <= srcn); + let dst = Bytes.create (srcn - (b - a)) in + Bytes.blit_string src 0 dst 0 a; + Bytes.blit_string src b dst a (srcn - b); + Some (Bytes.to_string dst) + | v -> v) + >>= fun t -> + Lwd.set tree t; + Lwt.return_unit - 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 - | { path; tree; var; _ } as tt -> - Store.S.Tree.update tree path (function - | Some src -> - let srcn = String.length src in - assert (n < srcn); - let ucn = - Uchar.utf_decode_length (String.get_utf_8_uchar src n) - in - let dst = Bytes.create (srcn - ucn) in - Bytes.blit_string src 0 dst 0 n; - Bytes.blit_string src (n + ucn) dst n (srcn - n - ucn); - Lwd.set var (Bytes.to_string dst); - Some (Bytes.to_string dst) - | None -> - F.epr "TextBuffer.remove_uchar None"; - None) - >>= fun tree -> Lwt.return { tt with tree } + Store.S.Tree.update (Lwd.peek tree) (Lwd.peek path) (function + | Some src -> + let srcn = String.length src in + assert (n < srcn); + let ucn = + Uchar.utf_decode_length (String.get_utf_8_uchar src n) + in + let dst = Bytes.create (srcn - ucn) in + Bytes.blit_string src 0 dst 0 n; + Bytes.blit_string src (n + ucn) dst n (srcn - n - ucn); + Some (Bytes.to_string dst) + | None -> + F.epr "TextBuffer.remove_uchar None"; + None) + >>= fun t -> + Lwd.set tree t; + Lwt.return_unit 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; _ } = - (try Store.S.Tree.get tree path with - | Not_found | Invalid_argument _ -> - Lwt.return - @@ F.str - "print_newline \"/%s: Not_found | Invalid_argument\";;" - (String.concat "/" path) - | exc -> - Lwt.return - (F.str "Store.S.Tree.get /%s exception: %s" - (String.concat "/" path) - (Printexc.to_string exc))) + let contents { path; tree; _ } : string Lwt.t = + (try Store.S.Tree.get (Lwd.peek tree) (Lwd.peek path) + with e -> + F.epr "TextBuffer.contents %s: %s" + (String.concat "/" (Lwd.peek path)) + (match e with + | Not_found -> "Not_found" + | Invalid_argument a -> F.str "Invalid_argument %s" a + | exc -> F.str "Exception: %s" (Printexc.to_string exc)); + Lwt.return "") >>= 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) - ?(format = format_default) wrap_width : layout Lwd.t = - Lwd.map2 (TextBuffer.get text) start ~f:(fun str start -> + let simple (text : TextBuffer.t) ?(start = Lwd.pure 0) + ?(format = format_default) wrap_width : layout Lwd.t Lwt.t = + 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 - e < cs || ce < s - (* cursor start is after this section or cursor end is before this section *) - then [ sec ] + @ (if e < cs || ce < s then [ sec ] else []) + @ (if cs > s && cs <= e then + [ { sec with byte_range = (s, cs) } ] else []) - @ (if - 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 + @ (if cs <= e && ce >= s then [ { format = format sec.format; @@ -577,9 +568,8 @@ module TextLayout = struct ] else []) @ - if - ce > s && ce <= e (* if cursor end is in this section *) - then [ { sec with byte_range = (ce, e) } ] + if ce > s && 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 := - 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 *)); - Lwt.return_unit + 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 = @@ -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 hbox, vbox, zbox = (box `H, box `V, box `Z) + let none = frame `None + 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 - |> fun root -> frame ?size ~style (`TextEdit (t, root)) + |> Lwd.map ~f:(fun tl -> frame ?size ~style (`TextEdit (t, tl))) + |> 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) - (layout : TextLayout.layout Lwd.root) : box2 Lwt.t = - let g = Lwd.quick_sample layout in + let text_layout (t : Gv.t) (rect : box2) + ((te, layout) : TextEdit.t * TextLayout.layout) : box2 Lwt.t = + 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) - | `H -> of_pts (V2.v (maxx r) (miny c)) (max c) + | `X -> of_pts (V2.v (minx c) (maxy r)) (max c) + | `Y -> of_pts (V2.v (maxx r) (miny c)) (max c) | `Z -> box) in Lwt.return c') - box' ll - | `TextEdit (t, root) -> text_layout ui.gv box' t root + box' [ a; b ] + | `TextEdit tt -> text_layout ui.gv box' tt | _ -> Lwt.return box) >>= fun r -> let r' = diff --git a/oplevel.ml b/oplevel.ml index 874dade..6dd30ef 100644 --- a/oplevel.ml +++ b/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.( - vbox - ~style: - Style.{ default with margin = Margin.symmetric 10.0 10.0 } - [ - textedit - (TextEdit.multiline ui - (Lwt_main.run - (TextBuffer.of_repo - ~path:[ ".config"; "init.ml" ] - ~repo:rootrepo))); - (*textedit - (TextEdit.multiline ui - (TextBuffer.of_repo ~path:[ "README" ] ~repo:rootrepo)); *) - ]) + Layout.( + vbox + ~style: + Style.{ default with margin = Margin.symmetric 10.0 10.0 } + [ + te_init; + (*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; - - 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.async (fun () -> render page_root); Gc.major_slice 0 |> ignore; GLFW.swapBuffers ~window; GLFW.pollEvents (); - 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)) + Unix.sleepf Float.(max 0. (period_min -. GLFW.getTime () +. !t)) 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