From 0193c3e7f0482c72170b715513e83de59f46742d Mon Sep 17 00:00:00 2001 From: cqc Date: Mon, 8 Jul 2024 21:55:16 -0500 Subject: [PATCH] lol replaced Lwd with Lwt_react basically seemlessly, hope the physical equality hack doesn't bite me in the ass --- dune | 7 +- ogui.ml | 184 ++++++++++++++++++++++++++++++++++++++++++----------- oplevel.ml | 29 ++++++--- 3 files changed, 171 insertions(+), 49 deletions(-) diff --git a/dune b/dune index 899200a..721226d 100644 --- a/dune +++ b/dune @@ -29,10 +29,11 @@ irmin-git compiler-libs.toplevel re - lwd + lwt_react ) - (link_flags (-linkall)) - (ocamlopt_flags (:standard -O3 -unboxed-types)) + (flags (-g)) + (link_flags (-linkall -g)) + ;;(ocamlopt_flags (:standard -O3 -unboxed-types)) (ocamlc_flags (:standard -verbose)) (modes byte_complete) (preprocess diff --git a/ogui.ml b/ogui.ml index 7754f6f..dd8c345 100644 --- a/ogui.ml +++ b/ogui.ml @@ -3,6 +3,87 @@ module Gv = Graphv_gles2_native module F = Fmt module Str = Re.Str +module Lwd = struct + open Lwt_react + + (*module S = struct + include Lwt_react.S + + include Lwt_react.S.Make (struct + type 'a t + + let equal = Stdlib.( == ) + end) + end*) + + type 'a var = 'a React.signal * (?step:React.step -> 'a -> unit) + type 'a t = 'a React.signal + + let eq = Stdlib.( == ) + let var ?(eq = eq) (v : 'a) : 'a var = S.create ~eq v + let get (s, _) : 'a t = s + let peek (s, _) = S.value s + let set ?step (_, f) v = f ?step v + let pure = S.const + let return = S.return + let map ?(eq = eq) ~(f : 'a -> 'b) (a : 'a t) : 'b t = S.l1 ~eq f a + + let map2 ?(eq = eq) ~(f : 'a -> 'b -> 'c) (a : 'a t) (b : 'b t) : + 'c t = + S.l2 ~eq f a b + + let map_s ?(eq = eq) ~(f : 'a -> 'b Lwt.t) (a : 'a t) : 'b t Lwt.t = + S.l1_s f a + + let map2_s ?(eq = eq) ~(f : 'a -> 'b -> 'c Lwt.t) (a : 'a t) + (b : 'b t) : 'c t Lwt.t = + S.l2_s f a b + + let bind ?(eq = eq) (a : 'a t) ~(f : 'a -> 'b t) : 'b t = + S.bind ~eq a f + + let join ?(eq = eq) : 'a t t -> 'a t = S.switch ~eq + + type 'a root = Root of 'a t + + let observe (t : 'a t) : 'a root = Root t + let quick_sample = function Root t -> S.value t +end + +module Lwd_utils = struct + (* stolen from Lwd_utils *) + type 'a monoid = 'a * ('a -> 'a -> 'a) + + let lift_monoid (zero, plus) = (Lwd.return zero, Lwd.map2 ~f:plus) + + let map_reduce inj (zero, plus) items = + let rec cons_monoid c xs v = + match xs with + | (c', v') :: xs when c = c' -> + cons_monoid (c + 1) xs (plus v' v) + | xs -> (c, v) :: xs + in + let cons_monoid xs v = cons_monoid 0 xs (inj v) in + match List.fold_left cons_monoid [] items with + | [] -> zero + | (_, x) :: xs -> + List.fold_left (fun acc (_, v) -> plus v acc) x xs + + let reduce monoid items = map_reduce (fun x -> x) monoid items + + let rec cons_lwd_monoid plus c xs v = + match xs with + | (c', v') :: xs when c = c' -> + cons_lwd_monoid plus (c + 1) xs (Lwd.map2 ~f:plus v' v) + | xs -> (c, v) :: xs + + let pack (zero, plus) items = + match List.fold_left (cons_lwd_monoid plus 0) [] items with + | [] -> Lwd.return zero + | (_, x) :: xs -> + List.fold_left (fun acc (_, v) -> Lwd.map2 ~f:plus v acc) x xs +end + type stroke = { width : float; color : Gv.Color.t } let stroke_none = { width = 0.; color = Gv.Color.transparent } @@ -30,15 +111,15 @@ 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) +(* 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 @@ -81,21 +162,32 @@ let pp_uchar : Uchar.t F.t = fun ppf u -> F.pf ppf "%S" (string_of_utf_8_uchar u) module TextBuffer = struct + let tree_eq (a : Store.S.tree) b = + F.epr "tree_eq (a=%s) (b=%s) @." + Store.(S.Tree.hash a |> S.Git.Hash.to_hex) + Store.(S.Tree.hash b |> S.Git.Hash.to_hex); + Store.(S.Git.Hash.equal (S.Tree.hash a) (S.Tree.hash b)) + type t = { path : string list Lwd.var; tree : Store.S.tree Lwd.var; repo : Store.Sync.db Lwt.t; } - let of_repo ~initial_path ~(repo : Store.Sync.db Lwt.t) : t Lwt.t = + let of_repo ~(initial_path : string list) + ~(repo : Store.Sync.db Lwt.t) : t Lwt.t = repo >>= Store.S.tree >>= fun tree -> Lwt.return - { path = Lwd.var initial_path; tree = Lwd.var tree; repo } + { + path = Lwd.var initial_path; + tree = Lwd.var ~eq:tree_eq tree; + repo; + } let of_string ~path ?(repo : Store.Sync.db Lwt.t option) str = { path = Lwd.var path; - tree = Lwd.var @@ Store.S.Tree.singleton path str; + tree = Lwd.var ~eq:tree_eq @@ Store.S.Tree.singleton path str; repo = ( Store.S.Repo.v (Irmin_mem.config ()) >>= fun repo' -> Option.value ~default:Store.S.(empty repo') repo ); @@ -123,7 +215,9 @@ module TextBuffer = struct F.epr "TextBuffer.insert_uchar Tree.update -> Nonep@."; Some (String.sub (Bytes.to_string ucbuf) 0 uclen)) >>= fun t -> + F.epr "TextBuffer.insert_uchar Tree.update @."; Lwd.set tree t; + F.epr "TextBuffer.insert_uchar Lwd.set tree @."; Lwt.return_unit let insert { path; tree; _ } n str = @@ -135,7 +229,7 @@ module TextBuffer = struct String.( cat (cat (sub src 0 n) str) (sub src n (srcn - n))) | None -> - F.epr "TextBuffer.insert Tree.update -> Nonep@."; + F.epr "TextBuffer.insert Tree.update -> None@."; Some str) >>= fun t -> Lwd.set tree t; @@ -196,9 +290,8 @@ module TextBuffer = struct >>= fun text -> Lwt.return text let get { tree; path; _ } = - Lwd.map2 (Lwd.get tree) (Lwd.get path) ~f:(fun tree path -> + Lwd.map2_s (Lwd.get tree) (Lwd.get path) ~f:(fun tree path -> Store.S.Tree.get tree path) - |> lwt_lwd let peek { tree; path; _ } = Store.S.Tree.get (Lwd.peek tree) (Lwd.peek path) @@ -604,7 +697,7 @@ module Ui = struct enabled : bool; gv : Gv.t; glfw_window : GLFW.window option; - bindings : action list Event.t Lwd.var; + bindings : (int * action list Event.t) Lwd.var; } and action = Custom of string * (unit -> unit Lwt.t) @@ -617,11 +710,12 @@ module Ui = struct let window gv ?(window : GLFW.window option) rect : t = { - rect; + rect = Lwd.var ~eq:Gg.Box2.equal rect; enabled = true; gv; glfw_window = window; - bindings = Lwd.var Event.empty; + bindings = + Lwd.var ~eq:(fun (a, _) (b, _) -> a = b) (0, Event.empty); } let pp_action : action F.t = @@ -643,33 +737,41 @@ module Ui = struct 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 = + F.epr "process_key1@."; let res = match resolver with | Event.Rejected | Event.Accepted _ -> [ - (let bindings = - t.bindings |> Lwd.get |> Lwd.observe - |> Lwd.quick_sample - in - Event.pack Fun.id bindings); + t.bindings |> Lwd.peek + (*Lwd.get |> Lwd.observe |> Lwd.quick_sample *) |> snd + |> Event.pack Fun.id; ] | Event.Continue r -> r in + F.epr "process_key2@."; let res = Event.resolve (Key (state, key, mods)) res in + F.epr "process_key3@."; (match res with | Event.Accepted actions -> let rec exec : action list -> unit Lwt.t = function - | Custom (_, f) :: actions -> - f () >>= fun () -> exec actions + | Custom (name, f) :: actions -> + f () >>= fun () -> + F.epr "process_key4 %s f ()@." name; + exec actions | [] -> Lwt.return_unit in + F.epr "process_key5@."; exec actions >>= fun () -> Lwt.return_unit | Event.Continue _ | Event.Rejected -> Lwt.return_unit) - >>= fun () -> Lwt.return res + >>= fun () -> + F.epr "process_key5@."; + Lwt.return res let update_bindings ui (f : action list Event.t -> action list Event.t) = - Lwd.set ui.bindings (f (Lwd.peek ui.bindings)) + Lwd.set ui.bindings + ( 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 -> @@ -685,11 +787,14 @@ 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 "Ui.process_events `Key %a %a %a (%s)@." - pp_key_action state pp_key key pp_mods mods + F.epr " (%s)@." (match res with | Accepted _ -> "Accepted" | Continue _ -> "Continue" @@ -1146,7 +1251,7 @@ module Layout = struct |> Lwt.return let system ui ?(style = textedit_style) d - (telist : TextEdit.t list Lwd.var) = + (telist : (int * TextEdit.t list) Lwd.var) = let cursor = Lwd.var 0 in Ui.update_bindings ui (fun a -> a @@ -1159,11 +1264,14 @@ module Layout = struct Lwd.set cursor (if Lwd.peek cursor - < (List.length @@ Lwd.peek telist) - 1 + < (Lwd.peek telist |> snd |> List.length) + - 1 then Lwd.peek cursor + 1 else 0); TextEdit.default_bindings - (List.nth (Lwd.peek telist) (Lwd.peek cursor)) + (List.nth + (Lwd.peek telist |> snd) + (Lwd.peek cursor)) ui; Lwt.return_unit ); ] @@ -1176,16 +1284,19 @@ module Layout = struct Lwd.set cursor (if Lwd.peek cursor > 0 then Lwd.peek cursor - 1 - else (Lwd.peek telist |> List.length) - 1); + else + (Lwd.peek telist |> snd |> List.length) - 1); TextEdit.default_bindings - (List.nth (Lwd.peek telist) (Lwd.peek cursor)) + (List.nth + (Lwd.peek telist |> snd) + (Lwd.peek cursor)) ui; Lwt.return_unit ); ]); (* let teln = List.length telist in *) (* let ratio n = `Ratio (1. /. float (teln - (n + 1))) in *) - Lwd.map - ~f:(fun tl -> + Lwd.map_s + ~f:(fun (_, tl) -> Lwt_list.mapi_s (fun n te -> textedit @@ -1213,7 +1324,6 @@ module Layout = struct tl >>= fun framelist -> box ~style d framelist |> Lwt.return) (Lwd.get telist) - |> lwt_lwd >>= fun d -> Lwd.join d |> Lwt.return let pp_dir ppf (t : [ `X | `Y | `Z ]) = diff --git a/oplevel.ml b/oplevel.ml index 9563cfa..f06d39e 100644 --- a/oplevel.ml +++ b/oplevel.ml @@ -76,8 +76,7 @@ let main = in let ui = - Ogui.Ui.window ctx ~window - (Lwd.var Gg.(Box2.v P2.o (P2.v 500. 500.))) + Ogui.Ui.window ctx ~window Gg.(Box2.v P2.o (P2.v 500. 500.)) in load_fonts ui.gv; @@ -178,10 +177,12 @@ let main = ~style: Style.{ default with margin = Margin.symmetric 10.0 10.0 } (Lwd.var - [ - TextEdit.multiline ui tb_init; - TextEdit.multiline ui to_init; - ])) + ~eq:(fun (a, _) (b, _) -> Int.equal a b) + ( 0, + [ + TextEdit.multiline ui tb_init; + TextEdit.multiline ui to_init; + ] ))) >>= fun page -> let page_root = Lwd.observe page in @@ -196,7 +197,7 @@ let main = [ Custom ("toplevel_execute", fun () -> Lwt.return ()) ]); let bindings = - ui.bindings |> Lwd.get |> Lwd.observe |> Lwd.quick_sample + ui.bindings |> Lwd.get |> Lwd.observe |> Lwd.quick_sample |> snd in F.epr "Bindings:@.%a" Ui.pp_bindings bindings; @@ -244,9 +245,19 @@ let main = if not GLFW.(windowShouldClose ~window) then draw_loop () else Lwt.return_unit in - draw_loop () >>= fun () -> + (try draw_loop () + with e -> + F.epr "draw_loop Exception: %s@.Backtrace:@.%s@." + (Printexc.to_string e) + (Printexc.get_backtrace ()) + |> Lwt.return) + >>= fun () -> Printf.printf "MIN %.2f\n" !min_fps; Printf.printf "MAX %.2f\n%!" !max_fps; Lwt.return_unit -let () = Lwt_main.run main +let () = + try Lwt_main.run main + with e -> + F.epr "Exception: %s@.Backtrace:@.%s@." (Printexc.to_string e) + (Printexc.get_backtrace ())