console/oplevel
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

lol replaced Lwd with Lwt_react basically seemlessly, hope the physical equality hack doesn't bite me in the ass

Browse Source
This commit is contained in:
cqc
2024-07-08 21:55:16 -05:00
parent b117b6916b
commit 0193c3e7f0
3 changed files with 171 additions and 49 deletions
Download Patch File Download Diff File Expand all files Collapse all files

7
dune
View File

@ -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

184
ogui.ml
View File

@ -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 ]) =

29
oplevel.ml
View File

@ -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 ())