Compare commits

..

3 Commits

Author SHA1 Message Date
cqc
5c9c41487c added some lwd, not sure it's useful yet 2024-05-19 13:21:18 -05:00
cqc
accf22a9f9 remove more debug 2024-05-15 15:10:50 -05:00
cqc
d72b7529c5 remove debug 2024-05-15 15:10:10 -05:00
3 changed files with 226 additions and 231 deletions

1
dune
View File

@ -28,6 +28,7 @@
irmin-git irmin-git
compiler-libs.toplevel compiler-libs.toplevel
re re
lwd
) )
(link_flags (-linkall)) (link_flags (-linkall))
(ocamlopt_flags (:standard -O3 -unboxed-types)) (ocamlopt_flags (:standard -O3 -unboxed-types))

340
ogui.ml
View File

@ -5,7 +5,6 @@ module Str = Re.Str
type stroke = { width : float; color : Gv.Color.t } type stroke = { width : float; color : Gv.Color.t }
let debuglayout = ref false
let stroke_none = { width = 0.; color = Gv.Color.transparent } let stroke_none = { width = 0.; color = Gv.Color.transparent }
let pp_text_row : Gv.Text.text_row F.t = let pp_text_row : Gv.Text.text_row F.t =
@ -91,11 +90,25 @@ module TextBuffer = struct
mutable path : string list; mutable path : string list;
mutable tree : Store.S.tree; mutable tree : Store.S.tree;
repo : Store.Sync.db Lwt.t; 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 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 = let of_string ~path ?(repo = None) str =
{ {
@ -104,13 +117,13 @@ module TextBuffer = struct
repo = repo =
( Store.S.Repo.v (Irmin_mem.config ()) >>= fun repo' -> ( Store.S.Repo.v (Irmin_mem.config ()) >>= fun repo' ->
Option.value ~default:Store.S.(empty repo') repo ); Option.value ~default:Store.S.(empty repo') repo );
var = Lwd.var str;
} }
let insert_uchar t n uc : t Lwt.t = 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 match t with
| { path; tree; _ } as tt -> | { path; tree; var; _ } as tt ->
Store.S.Tree.update tree path (function Store.S.Tree.update tree path (function
| Some src -> | Some src ->
let sn = String.length src in let sn = String.length src in
@ -126,15 +139,16 @@ module TextBuffer = struct
BytesLabels.blit_string ~src ~src_pos:n ~dst BytesLabels.blit_string ~src ~src_pos:n ~dst
~dst_pos:(n + uclen) ~dst_pos:(n + uclen)
~len:(sn - (n + uclen)); ~len:(sn - (n + uclen));
Some (Bytes.to_string dst) Lwd.set var (Bytes.to_string dst);
Some (Lwd.peek var)
| None -> None) | None -> None)
>>= fun tree -> Lwt.return { tt with tree } >>= fun tree -> Lwt.return { tt with tree }
let remove t (a, b) : t Lwt.t = let remove t (a, b) : t Lwt.t =
let a, b = (min a b, max a b) in 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 match t with
| { path; tree; _ } as tt -> | { path; tree; var; _ } as tt ->
Store.S.Tree.update tree path (function Store.S.Tree.update tree path (function
| Some src -> | Some src ->
let srcn = String.length src in let srcn = String.length src in
@ -142,14 +156,15 @@ module TextBuffer = struct
let dst = Bytes.create (srcn - (b - a)) in let dst = Bytes.create (srcn - (b - a)) in
Bytes.blit_string src 0 dst 0 a; Bytes.blit_string src 0 dst 0 a;
Bytes.blit_string src b dst a (srcn - b); Bytes.blit_string src b dst a (srcn - b);
Lwd.set var (Bytes.to_string dst);
Some (Bytes.to_string dst) Some (Bytes.to_string dst)
| v -> v) | v -> v)
>>= fun tree -> Lwt.return { tt with tree } >>= fun tree -> Lwt.return { tt with tree }
let remove_uchar t n : t Lwt.t = 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 match t with
| { path; tree; _ } as tt -> | { path; tree; var; _ } as tt ->
Store.S.Tree.update tree path (function Store.S.Tree.update tree path (function
| Some src -> | Some src ->
let srcn = String.length src in let srcn = String.length src in
@ -160,8 +175,11 @@ module TextBuffer = struct
let dst = Bytes.create (srcn - ucn) in let dst = Bytes.create (srcn - ucn) in
Bytes.blit_string src 0 dst 0 n; Bytes.blit_string src 0 dst 0 n;
Bytes.blit_string src (n + ucn) dst n (srcn - n - ucn); Bytes.blit_string src (n + ucn) dst n (srcn - n - ucn);
Lwd.set var (Bytes.to_string dst);
Some (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 } >>= fun tree -> Lwt.return { tt with tree }
let fold_string t (f : string -> 'a) : 'a Lwt.t = let fold_string t (f : string -> 'a) : 'a Lwt.t =
@ -169,6 +187,8 @@ module TextBuffer = struct
| { path; tree; _ } -> | { path; tree; _ } ->
Store.S.Tree.get tree path >>= fun text -> Lwt.return (f text) Store.S.Tree.get tree path >>= fun text -> Lwt.return (f text)
let get t = Lwd.get t.var
let contents { path; tree; _ } = let contents { path; tree; _ } =
(try Store.S.Tree.get tree path with (try Store.S.Tree.get tree path with
| Not_found | Invalid_argument _ -> | Not_found | Invalid_argument _ ->
@ -504,19 +524,16 @@ module TextLayout = struct
]) ])
let cursor_default = { index = 0; last_col = 0 } 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 = let simple (text : 'a) ?(start = Lwd.pure 0)
F.epr "cursor last_col=%d index=%d@." last_col index; ?(format = format_default) wrap_width : layout Lwd.t =
{ index; last_col } Lwd.map2 (TextBuffer.get text) start ~f:(fun str start ->
let simple text ?(start = 0) ?(format = format_default) wrap_width :
layout Lwt.t =
TextBuffer.fold_string text (fun s ->
{ {
layout_default with layout_default with
text; text;
sections = sections =
[ { byte_range = (start, String.length s); format } ]; [ { byte_range = (start, String.length str); format } ];
wrap = wrap =
{ (default_text_wrapping ()) with max_width = wrap_width }; { (default_text_wrapping ()) with max_width = wrap_width };
}) })
@ -537,10 +554,6 @@ module TextLayout = struct
List.fold_left List.fold_left
(fun (l : section list) sec -> (fun (l : section list) sec ->
let s, e = sec.byte_range in let s, e = sec.byte_range in
if !debuglayout then
F.epr "with_range section cs=%d ce=%d s=%d e=%d@." cs ce
s e;
l l
@ (if @ (if
e < cs || ce < s e < cs || ce < s
@ -571,21 +584,19 @@ module TextLayout = struct
[] layout.sections; [] layout.sections;
} }
let with_cursor (cur : cursor) ?(format = default_cursor_formatter) let with_cursor (cursor : cursor Lwd.t)
layout : layout = ?(format = default_cursor_formatter) layout : layout Lwd.t =
let c = with_range (cur.index, cur.index + 1) ~format layout in Lwd.map2 cursor layout ~f:(fun c l ->
if !debuglayout then with_range (c.index, c.index + 1) ~format l)
F.epr "with_cursor %a@."
F.(brackets @@ list ~sep:cut pp_section)
c.sections;
c
let with_mark (mark : int option) (cur : int) let with_mark (mark : int option Lwd.t) (cursor : cursor Lwd.t)
?(format = default_mark_formatter) layout : layout = ?(format = default_mark_formatter) layout : layout Lwd.t =
match mark with Lwd.bind layout ~f:(fun l ->
| Some mark' -> Lwd.map2 mark cursor ~f:(fun m c ->
with_range ~format (min mark' cur, max mark' cur) layout match m with
| None -> layout | Some m' ->
with_range ~format (min m' c.index, max m' c.index) l
| None -> l))
end end
let rec nth_tl n = function let rec nth_tl n = function
@ -594,11 +605,11 @@ let rec nth_tl n = function
module Ui = struct module Ui = struct
type t = { type t = {
mutable rect : Gg.box2; rect : Gg.box2 Lwd.var;
enabled : bool; enabled : bool;
gv : Gv.t; gv : Gv.t;
glfw_window : GLFW.window option; 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) and action = Custom of (unit -> unit Lwt.t)
@ -611,7 +622,7 @@ module Ui = struct
enabled = true; enabled = true;
gv; gv;
glfw_window = window; glfw_window = window;
bindings = Event.empty; bindings = Lwd.var Event.empty;
} }
let callback_resolver : action list Event.resolver option ref = let callback_resolver : action list Event.resolver option ref =
@ -622,12 +633,18 @@ module Ui = struct
let res = let res =
match !callback_resolver with match !callback_resolver with
| Some res -> res | 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 in
Event.( (*Event.(
F.epr "Ui.keycallback %a %a %a@." pp_key key pp_key_action state F.epr "Ui.keycallback %a %a %a@." pp_key key pp_key_action state
pp_mods mods); pp_mods mods); *)
match Event.resolve (Key (state, key, mods)) res with match Event.resolve (Key (state, key, mods)) res with
| Event.Accepted actions -> | Event.Accepted actions ->
callback_resolver := None; callback_resolver := None;
@ -645,11 +662,11 @@ module Ui = struct
let update_bindings ui let update_bindings ui
(f : action list Event.t -> action list Event.t) = (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 = let chrcallback_ref : (Uchar.t -> unit Lwt.t) ref =
ref (fun c -> ref (fun _c ->
F.epr "chrcallback: '%a'@." pp_uchar c; (* F.epr "chrcallback: '%a'@." pp_uchar _c; *)
Lwt.return_unit) Lwt.return_unit)
let chrcallback _t (chr : int) : unit Lwt.t = let chrcallback _t (chr : int) : unit Lwt.t =
@ -691,11 +708,11 @@ module TextEdit = struct
open Gg open Gg
type t = { type t = {
mutable text : TextBuffer.t; text : TextBuffer.t;
mutable cursor : TextLayout.cursor; cursor : TextLayout.cursor Lwd.var;
mutable mark : int option; mark : int option Lwd.var;
mutable scroll : int; scroll : int Lwd.var;
mutable rows : int; rows : int Lwd.var;
text_format : TextLayout.format; text_format : TextLayout.format;
formatter : formatter :
(Ui.t -> TextBuffer.t -> float -> TextLayout.layout) option; (Ui.t -> TextBuffer.t -> float -> TextLayout.layout) option;
@ -715,8 +732,8 @@ module TextEdit = struct
let col t = let col t =
TextBuffer.fold_string t.text (fun s -> TextBuffer.fold_string t.text (fun s ->
t.cursor.index let c = Lwd.peek t.cursor in
- Str.search_backward (Str.regexp "^") s t.cursor.index) c.index - Str.search_backward (Str.regexp "^") s c.index)
let rec newlines (s : string) (i : int) : int list = let rec newlines (s : string) (i : int) : int list =
match String.index_from_opt s i '\n' with match String.index_from_opt s i '\n' with
@ -744,41 +761,38 @@ module TextEdit = struct
let scroll_update ({ text; cursor; scroll; rows; _ } as t : t) : let scroll_update ({ text; cursor; scroll; rows; _ } as t : t) :
unit Lwt.t = unit Lwt.t =
TextBuffer.fold_string text (fun s -> TextBuffer.fold_string text (fun s ->
let cursor = Lwd.peek cursor in
let rows = Lwd.peek rows in
let slen = String.length s in let slen = String.length s in
(if cursor.index < scroll then if cursor.index < Lwd.peek scroll then
match match
String.rindex_from_opt s String.rindex_from_opt s
(min (slen - 1) (cursor.index - 1)) (min (slen - 1) (cursor.index - 1))
'\n' '\n'
with with
| Some i' -> t.scroll <- i' + 1 | Some i' -> Lwd.set t.scroll (i' + 1)
| None -> t.scroll <- 0 | None -> Lwd.set t.scroll 0
else else
match index_rows_from s scroll rows with match index_rows_from s (Lwd.peek scroll) rows with
| None -> () | None -> ()
| Some eow -> ( | Some eow -> (
F.epr "eow=%d@." eow; if cursor.index >= eow then
if cursor.index >= eow then match
match rindex_rows_from s
rindex_rows_from s (min (slen - 1) cursor.index)
(min (slen - 1) cursor.index) rows
rows with
with | None -> ()
| None -> () | Some i' -> Lwd.set t.scroll i'))
| Some i' -> t.scroll <- i'));
F.epr
"scroll_update slen=%d cursor=%d scroll=%d c-s=%d rows=%d@."
(String.length s) t.cursor.index t.scroll
(cursor.index - t.scroll)
rows;
debuglayout := true)
let cursor_update (t : t) (f : int -> int) : unit Lwt.t = let cursor_update (t : t) (f : int -> int) : unit Lwt.t =
col t >>= fun last_col -> col t >>= fun last_col ->
TextBuffer.fold_string t.text (fun s -> TextBuffer.fold_string t.text (fun s ->
t.cursor <- Lwd.set t.cursor
TextLayout.cursor ~last_col (TextLayout.cursor ~last_col
(f t.cursor.index |> max 0 |> min (String.length s))) (f (Lwd.peek t.cursor).index
|> max 0
|> min (String.length s))))
>>= fun () -> scroll_update t >>= fun () -> scroll_update t
let cursor_move (t : t) (amt : int) : unit Lwt.t = let cursor_move (t : t) (amt : int) : unit Lwt.t =
@ -825,16 +839,18 @@ module TextEdit = struct
Str.search_forward (Str.regexp "$") Str.search_forward (Str.regexp "$")
in in
let next_bol = let next_bol =
min sn (seol s t.cursor.index + 1) min sn (seol s (Lwd.peek t.cursor).index + 1)
in in
let next_line_len = let next_line_len =
seol s next_bol - next_bol seol s next_bol - next_bol
in in
next_bol next_bol
+ +
if t.cursor.last_col > next_line_len then if (Lwd.peek t.cursor).last_col > next_line_len
next_line_len then next_line_len
else min next_line_len t.cursor.last_col) else
min next_line_len
(Lwd.peek t.cursor).last_col)
>>= cursor_set t); >>= cursor_set t);
] ]
|> adds |> adds
@ -851,7 +867,7 @@ module TextEdit = struct
let sbol = let sbol =
Str.search_backward (Str.regexp "^") s Str.search_backward (Str.regexp "^") s
in in
let bol = sbol t.cursor.index in let bol = sbol (Lwd.peek t.cursor).index in
if bol > 0 then if bol > 0 then
let prev_bol = sbol (max 0 (bol - 1)) in let prev_bol = sbol (max 0 (bol - 1)) in
let prev_line_len = bol - 1 - prev_bol in let prev_line_len = bol - 1 - prev_bol in
@ -862,10 +878,14 @@ module TextEdit = struct
t.cursor.index bol prev_bol prev_line_len; *) t.cursor.index bol prev_bol prev_line_len; *)
prev_bol prev_bol
+ +
if t.cursor.last_col > prev_line_len then if
prev_line_len (Lwd.peek t.cursor).last_col
else min prev_line_len t.cursor.last_col > prev_line_len
else t.cursor.index) then prev_line_len
else
min prev_line_len
(Lwd.peek t.cursor).last_col
else (Lwd.peek t.cursor).index)
>>= cursor_set t); >>= cursor_set t);
] ]
|> adds (* EOL *) |> adds (* EOL *)
@ -879,14 +899,14 @@ module TextEdit = struct
TextBuffer.fold_string t.text (fun s -> TextBuffer.fold_string t.text (fun s ->
let bol = let bol =
Str.search_backward (Str.regexp "^") s Str.search_backward (Str.regexp "^") s
t.cursor.index (Lwd.peek t.cursor).index
in in
let eol = let eol =
Str.search_forward (Str.regexp "$") s Str.search_forward (Str.regexp "$") s
t.cursor.index (Lwd.peek t.cursor).index
in in
t.cursor <- Lwd.set t.cursor
TextLayout.cursor ~last_col:(eol - bol) eol)); @@ TextLayout.cursor ~last_col:(eol - bol) eol));
] ]
|> adds (* BOL *) |> adds (* BOL *)
[ [
@ -897,10 +917,10 @@ module TextEdit = struct
Custom Custom
(fun () -> (fun () ->
TextBuffer.fold_string t.text (fun s -> TextBuffer.fold_string t.text (fun s ->
t.cursor <- Lwd.set t.cursor
TextLayout.cursor ~last_col:0 @@ TextLayout.cursor ~last_col:0
(Str.search_backward (Str.regexp "^") s (Str.search_backward (Str.regexp "^") s
t.cursor.index))); (Lwd.peek t.cursor).index)));
] ]
|> adds |> adds
[ [
@ -910,20 +930,19 @@ module TextEdit = struct
[ [
Custom Custom
(fun () -> (fun () ->
match t.mark with match Lwd.peek t.mark with
| Some mark -> | Some mark ->
TextBuffer.remove t.text (mark, t.cursor.index) TextBuffer.remove t.text
>>= fun text -> (mark, (Lwd.peek t.cursor).index)
t.text <- text; >>= fun _ ->
t.mark <- None; Lwd.set t.mark None;
cursor_set t (min mark t.cursor.index) cursor_set t
(min mark (Lwd.peek t.cursor).index)
| None -> | None ->
if t.cursor.index > 0 then ( if (Lwd.peek t.cursor).index > 0 then
TextBuffer.remove_uchar t.text TextBuffer.remove_uchar t.text
(t.cursor.index - 1) ((Lwd.peek t.cursor).index - 1)
>>= fun text -> >>= fun _ -> cursor_move t (-1)
t.text <- text;
cursor_move t (-1))
else Lwt.return_unit); else Lwt.return_unit);
] ]
|> adds |> adds
@ -933,20 +952,19 @@ module TextEdit = struct
(fun () -> (fun () ->
TextBuffer.fold_string t.text (fun s -> TextBuffer.fold_string t.text (fun s ->
TextBuffer.remove t.text TextBuffer.remove t.text
( t.cursor.index, ( (Lwd.peek t.cursor).index,
let eol = let eol =
Str.search_forward (Str.regexp "$") s Str.search_forward (Str.regexp "$") s
t.cursor.index (Lwd.peek t.cursor).index
in in
if if
eol == t.cursor.index eol == (Lwd.peek t.cursor).index
&& String.length s > eol && String.length s > eol
then eol + 1 then eol + 1
else eol ) else eol )
>>= fun text -> >>= fun _ ->
t.text <- text; Lwd.set t.mark None;
t.mark <- None; cursor_set t (Lwd.peek t.cursor).index)
cursor_set t t.cursor.index)
>>= fun u -> u); >>= fun u -> u);
] ]
|> adds |> adds
@ -956,30 +974,26 @@ module TextEdit = struct
[ [
Custom Custom
(fun () -> (fun () ->
TextBuffer.insert_uchar t.text t.cursor.index TextBuffer.insert_uchar t.text
(Uchar.of_char '\n') (Lwd.peek t.cursor).index (Uchar.of_char '\n')
>>= fun text -> >>= fun _ -> cursor_move t 1);
t.text <- text;
cursor_move t 1);
] ]
|> adds |> adds
[ [ Key (Press, Space, [ Control ]) ] ] (* Mark set *) [ [ Key (Press, Space, [ Control ]) ] ] (* Mark set *)
[ [
Custom Custom
(fun () -> (fun () ->
t.mark <- Lwd.set t.mark
(match t.mark with (match Lwd.peek t.mark with
| Some _ -> None | Some _ -> None
| None -> Some t.cursor.index); | None -> Some (Lwd.peek t.cursor).index);
Lwt.return_unit); Lwt.return_unit);
]); ]);
(* WARN XXX TKTK TODO this is probably "breaking" the lwt context and being used in other calls to Lwt_main.run *) (* WARN XXX TKTK TODO this is probably "breaking" the lwt context and being used in other calls to Lwt_main.run *)
(Ui.chrcallback_ref := (Ui.chrcallback_ref :=
fun c -> fun c ->
TextBuffer.insert_uchar t.text t.cursor.index c TextBuffer.insert_uchar t.text (Lwd.peek t.cursor).index c
>>= fun text -> >>= fun _ -> cursor_move t 1
t.text <- text;
cursor_move t 1
(* This creates a giant stack of calls lol (* This creates a giant stack of calls lol
>>= fun () -> !Ui.chrcallback_ref c *)); >>= fun () -> !Ui.chrcallback_ref c *));
Lwt.return_unit Lwt.return_unit
@ -989,10 +1003,10 @@ module TextEdit = struct
let t = let t =
{ {
text; text;
cursor = TextLayout.cursor 0; cursor = Lwd.var (TextLayout.cursor 0);
mark = None; mark = Lwd.var None;
scroll = 0; scroll = Lwd.var 0;
rows = 0; rows = Lwd.var 0;
text_format; text_format;
formatter = None; formatter = None;
password = false; password = false;
@ -1024,7 +1038,7 @@ module Layout = struct
[ `Box of [ `H | `V | `Z ] * frame list [ `Box of [ `H | `V | `Z ] * frame list
| `String of string | `String of string
| `Buffer of TextBuffer.t | `Buffer of TextBuffer.t
| `TextEdit of TextEdit.t | `TextEdit of TextEdit.t * TextLayout.layout Lwd.root
| `None ] | `None ]
and size = [ `Fixed of size2 | `Max | `Min ] and size = [ `Fixed of size2 | `Max | `Min ]
@ -1043,8 +1057,14 @@ module Layout = struct
margin = Margin.symmetric 10. 10.; margin = Margin.symmetric 10. 10.;
} }
let textedit ?size ?(style = textedit_style) te = let textedit ?size ?(style = textedit_style) (t : TextEdit.t) =
frame ?size ~style (`TextEdit te) 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 ]) = let pp_dir ppf (t : [ `H | `V | `Z ]) =
F.pf ppf "%s" F.pf ppf "%s"
@ -1112,26 +1132,23 @@ module Painter = struct
Text.set_align t ~align:Align.(left lor top) Text.set_align t ~align:Align.(left lor top)
let text_layout (t : Gv.t) (rect : box2) (te : TextEdit.t) 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 = let line_height =
Option.value ~default:(Gv.Text.metrics t).line_height Option.value ~default:(Gv.Text.metrics t).line_height
g.line_height g.line_height
in in
let max_rows = Int.of_float (Box2.h rect /. 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 let lines = Gv.Text.make_empty_rows max_rows in
TextBuffer.contents g.text >>= fun contents -> TextBuffer.contents g.text >>= fun contents ->
let contents_len = String.length contents in let contents_len = String.length contents in
let row_count = let row_count =
Gv.Text.break_lines t ~break_width:(Box2.w rect) ~max_rows 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 in
Seq.fold_left Seq.fold_left
(fun ((cur, start) : p2 * int) (row : Gv.Text.text_row) -> (fun ((cur, start) : p2 * int) (row : Gv.Text.text_row) ->
if !debuglayout then
F.epr "start=%d row=%a %a @." start pp_text_row row
F.(brackets @@ list TextLayout.pp_section)
g.sections;
let sections = let sections =
List.filter List.filter
(fun (r : TextLayout.section) -> (fun (r : TextLayout.section) ->
@ -1174,18 +1191,17 @@ module Painter = struct
|> fun cur'' -> |> fun cur'' ->
( V2.(v (max (x cur) (x cur'')) (y cur'' +. line_height)), ( V2.(v (max (x cur) (x cur'')) (y cur'' +. line_height)),
row.next )) row.next ))
(Box2.o rect, te.scroll) (Box2.o rect, Lwd.peek te.scroll)
(Seq.take row_count (Array.to_seq lines)) (Seq.take row_count (Array.to_seq lines))
|> fst |> fst
|> (fun cur''' -> V2.(cur''' - v 0. line_height)) |> (fun cur''' -> V2.(cur''' - v 0. line_height))
|> Box2.(of_pts (o rect)) |> Box2.(of_pts (o rect))
|> Lwt.return |> Lwt.return
let rec layout (box : box2) (ui : Ui.t) (frame : frame) : box2 Lwt.t let rec layout (box : box2) (ui : Ui.t) ({ t; style; _ } : frame) :
= box2 Lwt.t =
let box' = Margin.inner frame.style.margin box in let box' = Margin.inner style.margin box in
if !debuglayout then F.epr "layout box'=%a@." Gg.Box2.pp box'; (match t with
(match frame.t with
| `Box (dir, ll) -> | `Box (dir, ll) ->
Lwt_list.fold_left_s Lwt_list.fold_left_s
(fun (c : box2) f -> (fun (c : box2) f ->
@ -1199,28 +1215,14 @@ module Painter = struct
in in
Lwt.return c') Lwt.return c')
box' ll box' ll
| `TextEdit t -> | `TextEdit (t, root) -> text_layout ui.gv box' t root
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)
| _ -> Lwt.return box) | _ -> Lwt.return box)
>>= fun r -> >>= fun r ->
let r' = let r' =
Box2.add_pt r Box2.add_pt r
V2.( V2.(Box2.max r + v style.margin.right style.margin.bottom)
Box2.max r |> Margin.outer style.margin
+ v frame.style.margin.right frame.style.margin.bottom)
|> Margin.outer frame.style.margin
in in
draw_box ui.gv ~box:r' ~style:frame.style; draw_box ui.gv ~box:r' ~style;
Lwt.return r' Lwt.return r'
let layout a b c =
let r = layout a b c in
debuglayout := false;
r
end end

View File

@ -18,7 +18,7 @@ end
let errorcb error desc = let errorcb error desc =
Printf.printf "GLFW error %d: %s\n%!" error desc Printf.printf "GLFW error %d: %s\n%!" error desc
let load_data vg = let load_fonts vg =
let _ = Gv.Text.create vg ~name:"mono" ~file:"./assets/mono.ttf" in let _ = Gv.Text.create vg ~name:"mono" ~file:"./assets/mono.ttf" in
let _ = let _ =
Gv.Text.create vg ~name:"icons" ~file:"./assets/entypo.ttf" Gv.Text.create vg ~name:"icons" ~file:"./assets/entypo.ttf"
@ -62,8 +62,6 @@ let () =
in in
let graph = Perfgraph.init Perfgraph.FPS "Frame Time" in let graph = Perfgraph.init Perfgraph.FPS "Frame Time" in
let _odata = load_data ctx in
let continue = ref true in
let min_fps = ref Float.max_float in let min_fps = ref Float.max_float in
let max_fps = ref Float.min_float in let max_fps = ref Float.min_float in
@ -78,9 +76,11 @@ let () =
in in
let ui = let ui =
Ogui.Ui.window ctx ~window Gg.(Box2.v P2.o (P2.v 500. 500.)) Ogui.Ui.window ctx ~window
(Lwd.var Gg.(Box2.v P2.o (P2.v 500. 500.)))
in in
load_fonts ui.gv;
GLFW.setKeyCallback ~window GLFW.setKeyCallback ~window
~f: ~f:
(Some (Some
@ -100,7 +100,7 @@ let () =
F.pr "oplevel.ml: building initial page@."; F.pr "oplevel.ml: building initial page@.";
let page = let page =
ref Lwd.var
Layout.( Layout.(
vbox vbox
~style: ~style:
@ -108,82 +108,76 @@ let () =
[ [
textedit textedit
(TextEdit.multiline ui (TextEdit.multiline ui
(TextBuffer.of_repo (Lwt_main.run
~path:[ ".config"; "init.ml" ] (TextBuffer.of_repo
~repo:rootrepo)); ~path:[ ".config"; "init.ml" ]
~repo:rootrepo)));
(*textedit (*textedit
(TextEdit.multiline ui (TextEdit.multiline ui
(TextBuffer.of_repo ~path:[ "README" ] ~repo:rootrepo)); *) (TextBuffer.of_repo ~path:[ "README" ] ~repo:rootrepo)); *)
]) ])
in in
(let open GLFW in let open GLFW in
let open Event in let open Event in
let open Ui in Ui.update_bindings ui
Ui.update_bindings ui Ui.(
(adds adds
[ [
[ Key (Press, X, [ Control ]); Key (Press, E, [ Control ]) ]; [ Key (Press, X, [ Control ]); Key (Press, E, [ Control ]) ];
] ]
[ Custom (fun () -> Lwt.return ()) ])); [ Custom (fun () -> Lwt.return ()) ]);
F.pr "oplevel.ml: entering drawing loop@."; F.pr "oplevel.ml: entering drawing loop@.";
let period_min = 1.0 /. 30. in let period_min = 1.0 /. 30. in
let t = GLFW.getTime () |> ref in let t = GLFW.getTime () |> ref in
while (not GLFW.(windowShouldClose ~window)) && !continue do
Lwt_main.run
((fun () ->
let now = GLFW.getTime () in
let dt = now -. !t in
t := now;
Perfgraph.update graph dt; let render page =
let now = GLFW.getTime () in
let dt = now -. !t in
t := now;
if now > 2. then ( Perfgraph.update graph dt;
let avg = 1. /. Perfgraph.average graph in
min_fps := Float.min avg !min_fps;
max_fps := Float.max avg !max_fps);
let _mx, _my = GLFW.getCursorPos ~window in if now > 2. then (
let win_w, win_h = GLFW.getWindowSize ~window in let avg = 1. /. Perfgraph.average graph in
min_fps := Float.min avg !min_fps;
max_fps := Float.max avg !max_fps);
Gl.viewport 0 0 win_w win_h; let _mx, _my = GLFW.getCursorPos ~window in
Gl.clear let win_w, win_h = GLFW.getWindowSize ~window in
(Gl.color_buffer_bit lor Gl.depth_buffer_bit
lor Gl.stencil_buffer_bit);
Gl.enable Gl.blend;
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 Gl.viewport 0 0 win_w win_h;
let box = Gl.clear
Gg.(Box2.v V2.zero Size2.(v width (height -. 20.))) (Gl.color_buffer_bit lor Gl.depth_buffer_bit
in lor Gl.stencil_buffer_bit);
Gv.begin_frame ctx ~width ~height ~device_ratio:1.; Gl.enable Gl.blend;
Perfgraph.render graph ctx (width -. 205.) 5.; Gl.blend_func Gl.src_alpha Gl.one_minus_src_alpha;
(* F.epr "box=%a@." Gg.Box2.pp box; Gl.enable Gl.cull_face_enum;
F.epr "Painter.layout=%a@." Gg.Box2.pp *) Gl.disable Gl.depth_test;
Painter.layout box ui !page >>= fun _ ->
(* Demo.render_demo ctx mx my win_w win_h now !blowup data; *)
Gv.end_frame ctx;
Gc.major_slice 0 |> ignore; let width, height = (float win_w, float win_h) in
GLFW.swapBuffers ~window; let box = Gg.(Box2.v V2.zero Size2.(v width (height -. 20.))) in
GLFW.pollEvents (); Gv.begin_frame ctx ~width ~height ~device_ratio:1.;
Unix.sleepf Perfgraph.render graph ctx (width -. 205.) 5.;
Float.(max 0. (period_min -. GLFW.getTime () +. !t)); (* F.epr "box=%a@." Gg.Box2.pp box;
Lwt.return_unit) 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;
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))
done; done;
Printf.printf "MIN %.2f\n" !min_fps; Printf.printf "MIN %.2f\n" !min_fps;
Printf.printf "MAX %.2f\n%!" !max_fps; Printf.printf "MAX %.2f\n%!" !max_fps
if Array.length Sys.argv = 1 then
while not GLFW.(windowShouldClose ~window) do
GLFW.pollEvents ();
Unix.sleepf 0.25
done
(* let out_ppf = (* let out_ppf =
Format.formatter_of_out_functions Format.formatter_of_out_functions
@ -205,5 +199,3 @@ let () =
(* ignore (* ignore
(Toploop.use_input out_ppf (Toploop.use_input out_ppf
(String "#use \"topfind\";;\n#list;;")); *) (String "#use \"topfind\";;\n#list;;")); *)
(* ignore (Toploop.use_input Format.std_formatter (String text)); *)
(* Wait for it to be closed. *)