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

more Lwd.t-ification

Browse Source
This commit is contained in:
cqc
2024-05-21 20:15:50 -05:00
parent 5c9c41487c
commit 36fd690e21
2 changed files with 191 additions and 182 deletions
Download Patch File Download Diff File Expand all files Collapse all files

294
ogui.ml
View File

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