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

added some lwd, not sure it's useful yet

Browse Source
This commit is contained in:
cqc
2024-05-19 13:21:18 -05:00
parent accf22a9f9
commit 5c9c41487c
3 changed files with 207 additions and 187 deletions
Download Patch File Download Diff File Expand all files Collapse all files

277
ogui.ml
View File

@ -90,11 +90,25 @@ module TextBuffer = struct
mutable path : string list;
mutable tree : Store.S.tree;
repo : Store.Sync.db Lwt.t;
var : string Lwd.var;
}
let of_repo ~path ~(repo : Store.Sync.db Lwt.t) =
let of_repo ~path ~(repo : Store.Sync.db Lwt.t) : t Lwt.t =
let tree = Lwt_main.run (repo >>= Store.S.tree) in
{ path; tree; repo }
Store.S.Tree.find tree path >>= fun res ->
Lwt.return
{
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 =
{
@ -103,13 +117,13 @@ module TextBuffer = struct
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;
(* F.epr "TextBuffer.insert_uchar %d %a@." n pp_uchar uc; *)
match t with
| { path; tree; _ } as tt ->
| { path; tree; var; _ } as tt ->
Store.S.Tree.update tree path (function
| Some src ->
let sn = String.length src in
@ -125,15 +139,16 @@ module TextBuffer = struct
BytesLabels.blit_string ~src ~src_pos:n ~dst
~dst_pos:(n + uclen)
~len:(sn - (n + uclen));
Some (Bytes.to_string dst)
Lwd.set var (Bytes.to_string dst);
Some (Lwd.peek var)
| None -> None)
>>= fun tree -> Lwt.return { tt with tree }
let remove t (a, b) : t Lwt.t =
let a, b = (min a b, max a b) in
F.epr "TextBuffer.remove (%d, %d)@." a b;
(* F.epr "TextBuffer.remove (%d, %d)@." a b; *)
match t with
| { path; tree; _ } as tt ->
| { path; tree; var; _ } as tt ->
Store.S.Tree.update tree path (function
| Some src ->
let srcn = String.length src in
@ -141,14 +156,15 @@ module TextBuffer = struct
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 }
let remove_uchar t n : t Lwt.t =
F.epr "TextBuffer.remove_subset n=%d @." n;
(* F.epr "TextBuffer.remove_subset n=%d @." n; *)
match t with
| { path; tree; _ } as tt ->
| { path; tree; var; _ } as tt ->
Store.S.Tree.update tree path (function
| Some src ->
let srcn = String.length src in
@ -159,8 +175,11 @@ module TextBuffer = struct
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)
| v -> v)
| None ->
F.epr "TextBuffer.remove_uchar None";
None)
>>= fun tree -> Lwt.return { tt with tree }
let fold_string t (f : string -> 'a) : 'a Lwt.t =
@ -168,6 +187,8 @@ module TextBuffer = struct
| { path; tree; _ } ->
Store.S.Tree.get tree 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 _ ->
@ -503,19 +524,16 @@ module TextLayout = struct
])
let cursor_default = { index = 0; last_col = 0 }
let cursor ?(last_col = 0) index : cursor = { index; last_col }
let cursor ?(last_col = 0) index : cursor =
F.epr "cursor last_col=%d index=%d@." last_col index;
{ index; last_col }
let simple text ?(start = 0) ?(format = format_default) wrap_width :
layout Lwt.t =
TextBuffer.fold_string text (fun s ->
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 ->
{
layout_default with
text;
sections =
[ { byte_range = (start, String.length s); format } ];
[ { byte_range = (start, String.length str); format } ];
wrap =
{ (default_text_wrapping ()) with max_width = wrap_width };
})
@ -566,17 +584,19 @@ module TextLayout = struct
[] layout.sections;
}
let with_cursor (cur : cursor) ?(format = default_cursor_formatter)
layout : layout =
let c = with_range (cur.index, cur.index + 1) ~format layout in
c
let with_cursor (cursor : cursor Lwd.t)
?(format = default_cursor_formatter) layout : layout Lwd.t =
Lwd.map2 cursor layout ~f:(fun c l ->
with_range (c.index, c.index + 1) ~format l)
let with_mark (mark : int option) (cur : int)
?(format = default_mark_formatter) layout : layout =
match mark with
| Some mark' ->
with_range ~format (min mark' cur, max mark' cur) layout
| None -> layout
let with_mark (mark : int option Lwd.t) (cursor : cursor Lwd.t)
?(format = default_mark_formatter) layout : layout Lwd.t =
Lwd.bind layout ~f:(fun l ->
Lwd.map2 mark cursor ~f:(fun m c ->
match m with
| Some m' ->
with_range ~format (min m' c.index, max m' c.index) l
| None -> l))
end
let rec nth_tl n = function
@ -585,11 +605,11 @@ let rec nth_tl n = function
module Ui = struct
type t = {
mutable rect : Gg.box2;
rect : Gg.box2 Lwd.var;
enabled : bool;
gv : Gv.t;
glfw_window : GLFW.window option;
mutable bindings : action list Event.t;
bindings : action list Event.t Lwd.var;
}
and action = Custom of (unit -> unit Lwt.t)
@ -602,7 +622,7 @@ module Ui = struct
enabled = true;
gv;
glfw_window = window;
bindings = Event.empty;
bindings = Lwd.var Event.empty;
}
let callback_resolver : action list Event.resolver option ref =
@ -613,7 +633,13 @@ module Ui = struct
let res =
match !callback_resolver with
| Some res -> res
| None -> Event.resolver [ Event.pack Fun.id t.bindings ]
| None ->
Event.resolver
[
Event.pack Fun.id
(t.bindings |> Lwd.get |> Lwd.observe
|> Lwd.quick_sample);
]
in
(*Event.(
@ -636,7 +662,7 @@ module Ui = struct
let update_bindings ui
(f : action list Event.t -> action list Event.t) =
ui.bindings <- f ui.bindings
Lwd.set ui.bindings (f (Lwd.peek ui.bindings))
let chrcallback_ref : (Uchar.t -> unit Lwt.t) ref =
ref (fun _c ->
@ -682,11 +708,11 @@ module TextEdit = struct
open Gg
type t = {
mutable text : TextBuffer.t;
mutable cursor : TextLayout.cursor;
mutable mark : int option;
mutable scroll : int;
mutable rows : int;
text : TextBuffer.t;
cursor : TextLayout.cursor Lwd.var;
mark : int option Lwd.var;
scroll : int Lwd.var;
rows : int Lwd.var;
text_format : TextLayout.format;
formatter :
(Ui.t -> TextBuffer.t -> float -> TextLayout.layout) option;
@ -706,8 +732,8 @@ module TextEdit = struct
let col t =
TextBuffer.fold_string t.text (fun s ->
t.cursor.index
- Str.search_backward (Str.regexp "^") s t.cursor.index)
let c = Lwd.peek t.cursor in
c.index - Str.search_backward (Str.regexp "^") s c.index)
let rec newlines (s : string) (i : int) : int list =
match String.index_from_opt s i '\n' with
@ -735,20 +761,21 @@ module TextEdit = struct
let scroll_update ({ text; cursor; scroll; rows; _ } as t : t) :
unit Lwt.t =
TextBuffer.fold_string text (fun s ->
let cursor = Lwd.peek cursor in
let rows = Lwd.peek rows in
let slen = String.length s in
if cursor.index < scroll then
if cursor.index < Lwd.peek scroll then
match
String.rindex_from_opt s
(min (slen - 1) (cursor.index - 1))
'\n'
with
| Some i' -> t.scroll <- i' + 1
| None -> t.scroll <- 0
| Some i' -> Lwd.set t.scroll (i' + 1)
| None -> Lwd.set t.scroll 0
else
match index_rows_from s scroll rows with
match index_rows_from s (Lwd.peek scroll) rows with
| None -> ()
| Some eow -> (
F.epr "eow=%d@." eow;
if cursor.index >= eow then
match
rindex_rows_from s
@ -756,14 +783,16 @@ module TextEdit = struct
rows
with
| None -> ()
| Some i' -> t.scroll <- i'))
| Some i' -> Lwd.set t.scroll i'))
let cursor_update (t : t) (f : int -> int) : unit Lwt.t =
col t >>= fun last_col ->
TextBuffer.fold_string t.text (fun s ->
t.cursor <-
TextLayout.cursor ~last_col
(f t.cursor.index |> max 0 |> min (String.length s)))
Lwd.set t.cursor
(TextLayout.cursor ~last_col
(f (Lwd.peek t.cursor).index
|> max 0
|> min (String.length s))))
>>= fun () -> scroll_update t
let cursor_move (t : t) (amt : int) : unit Lwt.t =
@ -810,16 +839,18 @@ module TextEdit = struct
Str.search_forward (Str.regexp "$")
in
let next_bol =
min sn (seol s t.cursor.index + 1)
min sn (seol s (Lwd.peek t.cursor).index + 1)
in
let next_line_len =
seol s next_bol - next_bol
in
next_bol
+
if t.cursor.last_col > next_line_len then
next_line_len
else min next_line_len t.cursor.last_col)
if (Lwd.peek t.cursor).last_col > next_line_len
then next_line_len
else
min next_line_len
(Lwd.peek t.cursor).last_col)
>>= cursor_set t);
]
|> adds
@ -836,7 +867,7 @@ module TextEdit = struct
let sbol =
Str.search_backward (Str.regexp "^") s
in
let bol = sbol t.cursor.index in
let bol = sbol (Lwd.peek t.cursor).index in
if bol > 0 then
let prev_bol = sbol (max 0 (bol - 1)) in
let prev_line_len = bol - 1 - prev_bol in
@ -847,10 +878,14 @@ module TextEdit = struct
t.cursor.index bol prev_bol prev_line_len; *)
prev_bol
+
if t.cursor.last_col > prev_line_len then
prev_line_len
else min prev_line_len t.cursor.last_col
else t.cursor.index)
if
(Lwd.peek t.cursor).last_col
> prev_line_len
then prev_line_len
else
min prev_line_len
(Lwd.peek t.cursor).last_col
else (Lwd.peek t.cursor).index)
>>= cursor_set t);
]
|> adds (* EOL *)
@ -864,14 +899,14 @@ module TextEdit = struct
TextBuffer.fold_string t.text (fun s ->
let bol =
Str.search_backward (Str.regexp "^") s
t.cursor.index
(Lwd.peek t.cursor).index
in
let eol =
Str.search_forward (Str.regexp "$") s
t.cursor.index
(Lwd.peek t.cursor).index
in
t.cursor <-
TextLayout.cursor ~last_col:(eol - bol) eol));
Lwd.set t.cursor
@@ TextLayout.cursor ~last_col:(eol - bol) eol));
]
|> adds (* BOL *)
[
@ -882,10 +917,10 @@ module TextEdit = struct
Custom
(fun () ->
TextBuffer.fold_string t.text (fun s ->
t.cursor <-
TextLayout.cursor ~last_col:0
(Str.search_backward (Str.regexp "^") s
t.cursor.index)));
Lwd.set t.cursor
@@ TextLayout.cursor ~last_col:0
(Str.search_backward (Str.regexp "^") s
(Lwd.peek t.cursor).index)));
]
|> adds
[
@ -895,20 +930,19 @@ module TextEdit = struct
[
Custom
(fun () ->
match t.mark with
match Lwd.peek t.mark with
| Some mark ->
TextBuffer.remove t.text (mark, t.cursor.index)
>>= fun text ->
t.text <- text;
t.mark <- None;
cursor_set t (min mark t.cursor.index)
TextBuffer.remove t.text
(mark, (Lwd.peek t.cursor).index)
>>= fun _ ->
Lwd.set t.mark None;
cursor_set t
(min mark (Lwd.peek t.cursor).index)
| None ->
if t.cursor.index > 0 then (
if (Lwd.peek t.cursor).index > 0 then
TextBuffer.remove_uchar t.text
(t.cursor.index - 1)
>>= fun text ->
t.text <- text;
cursor_move t (-1))
((Lwd.peek t.cursor).index - 1)
>>= fun _ -> cursor_move t (-1)
else Lwt.return_unit);
]
|> adds
@ -918,20 +952,19 @@ module TextEdit = struct
(fun () ->
TextBuffer.fold_string t.text (fun s ->
TextBuffer.remove t.text
( t.cursor.index,
( (Lwd.peek t.cursor).index,
let eol =
Str.search_forward (Str.regexp "$") s
t.cursor.index
(Lwd.peek t.cursor).index
in
if
eol == t.cursor.index
eol == (Lwd.peek t.cursor).index
&& String.length s > eol
then eol + 1
else eol )
>>= fun text ->
t.text <- text;
t.mark <- None;
cursor_set t t.cursor.index)
>>= fun _ ->
Lwd.set t.mark None;
cursor_set t (Lwd.peek t.cursor).index)
>>= fun u -> u);
]
|> adds
@ -941,30 +974,26 @@ module TextEdit = struct
[
Custom
(fun () ->
TextBuffer.insert_uchar t.text t.cursor.index
(Uchar.of_char '\n')
>>= fun text ->
t.text <- text;
cursor_move t 1);
TextBuffer.insert_uchar t.text
(Lwd.peek t.cursor).index (Uchar.of_char '\n')
>>= fun _ -> cursor_move t 1);
]
|> adds
[ [ Key (Press, Space, [ Control ]) ] ] (* Mark set *)
[
Custom
(fun () ->
t.mark <-
(match t.mark with
Lwd.set t.mark
(match Lwd.peek t.mark with
| Some _ -> None
| None -> Some t.cursor.index);
| 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 t.cursor.index c
>>= fun text ->
t.text <- text;
cursor_move t 1
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
@ -974,10 +1003,10 @@ module TextEdit = struct
let t =
{
text;
cursor = TextLayout.cursor 0;
mark = None;
scroll = 0;
rows = 0;
cursor = Lwd.var (TextLayout.cursor 0);
mark = Lwd.var None;
scroll = Lwd.var 0;
rows = Lwd.var 0;
text_format;
formatter = None;
password = false;
@ -1009,7 +1038,7 @@ module Layout = struct
[ `Box of [ `H | `V | `Z ] * frame list
| `String of string
| `Buffer of TextBuffer.t
| `TextEdit of TextEdit.t
| `TextEdit of TextEdit.t * TextLayout.layout Lwd.root
| `None ]
and size = [ `Fixed of size2 | `Max | `Min ]
@ -1028,8 +1057,14 @@ module Layout = struct
margin = Margin.symmetric 10. 10.;
}
let textedit ?size ?(style = textedit_style) te =
frame ?size ~style (`TextEdit te)
let textedit ?size ?(style = textedit_style) (t : TextEdit.t) =
let open TextLayout in
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)
|> with_mark (Lwd.get t.mark) (Lwd.get t.cursor)
|> Lwd.observe
|> fun root -> frame ?size ~style (`TextEdit (t, root))
let pp_dir ppf (t : [ `H | `V | `Z ]) =
F.pf ppf "%s"
@ -1097,19 +1132,20 @@ module Painter = struct
Text.set_align t ~align:Align.(left lor top)
let text_layout (t : Gv.t) (rect : box2) (te : TextEdit.t)
(g : TextLayout.layout) : box2 Lwt.t =
(layout : TextLayout.layout Lwd.root) : box2 Lwt.t =
let g = Lwd.quick_sample layout in
let line_height =
Option.value ~default:(Gv.Text.metrics t).line_height
g.line_height
in
let max_rows = Int.of_float (Box2.h rect /. line_height) in
te.rows <- max_rows;
Lwd.set te.rows max_rows;
let lines = Gv.Text.make_empty_rows max_rows in
TextBuffer.contents g.text >>= fun contents ->
let contents_len = String.length contents in
let row_count =
Gv.Text.break_lines t ~break_width:(Box2.w rect) ~max_rows
~lines ~start:te.scroll contents
~lines ~start:(Lwd.peek te.scroll) contents
in
Seq.fold_left
(fun ((cur, start) : p2 * int) (row : Gv.Text.text_row) ->
@ -1155,17 +1191,17 @@ module Painter = struct
|> fun cur'' ->
( V2.(v (max (x cur) (x cur'')) (y cur'' +. line_height)),
row.next ))
(Box2.o rect, te.scroll)
(Box2.o rect, Lwd.peek te.scroll)
(Seq.take row_count (Array.to_seq lines))
|> fst
|> (fun cur''' -> V2.(cur''' - v 0. line_height))
|> Box2.(of_pts (o rect))
|> Lwt.return
let rec layout (box : box2) (ui : Ui.t) (frame : frame) : box2 Lwt.t
=
let box' = Margin.inner frame.style.margin box in
(match frame.t with
let rec layout (box : box2) (ui : Ui.t) ({ t; style; _ } : frame) :
box2 Lwt.t =
let box' = Margin.inner style.margin box in
(match t with
| `Box (dir, ll) ->
Lwt_list.fold_left_s
(fun (c : box2) f ->
@ -1179,23 +1215,14 @@ module Painter = struct
in
Lwt.return c')
box' ll
| `TextEdit t ->
TextLayout.(
simple t.text ~start:t.scroll ~format:t.text_format
(Option.value ~default:(Box2.w box') t.desired_width)
>>= fun layout ->
with_cursor t.cursor layout
|> with_mark t.mark t.cursor.index
|> text_layout ui.gv box' t)
| `TextEdit (t, root) -> text_layout ui.gv box' t root
| _ -> Lwt.return box)
>>= fun r ->
let r' =
Box2.add_pt r
V2.(
Box2.max r
+ v frame.style.margin.right frame.style.margin.bottom)
|> Margin.outer frame.style.margin
V2.(Box2.max r + v style.margin.right style.margin.bottom)
|> Margin.outer style.margin
in
draw_box ui.gv ~box:r' ~style:frame.style;
draw_box ui.gv ~box:r' ~style;
Lwt.return r'
end