Compare commits
3 Commits
4ce218978b
...
5c9c41487c
| Author | SHA1 | Date | |
|---|---|---|---|
| 5c9c41487c | |||
| accf22a9f9 | |||
| d72b7529c5 |
1
dune
1
dune
@ -28,6 +28,7 @@
|
||||
irmin-git
|
||||
compiler-libs.toplevel
|
||||
re
|
||||
lwd
|
||||
)
|
||||
(link_flags (-linkall))
|
||||
(ocamlopt_flags (:standard -O3 -unboxed-types))
|
||||
|
||||
340
ogui.ml
340
ogui.ml
@ -5,7 +5,6 @@ module Str = Re.Str
|
||||
|
||||
type stroke = { width : float; color : Gv.Color.t }
|
||||
|
||||
let debuglayout = ref false
|
||||
let stroke_none = { width = 0.; color = Gv.Color.transparent }
|
||||
|
||||
let pp_text_row : Gv.Text.text_row F.t =
|
||||
@ -91,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 =
|
||||
{
|
||||
@ -104,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
|
||||
@ -126,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
|
||||
@ -142,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
|
||||
@ -160,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 =
|
||||
@ -169,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 _ ->
|
||||
@ -504,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 };
|
||||
})
|
||||
@ -537,10 +554,6 @@ module TextLayout = struct
|
||||
List.fold_left
|
||||
(fun (l : section list) sec ->
|
||||
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
|
||||
@ (if
|
||||
e < cs || ce < s
|
||||
@ -571,21 +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
|
||||
if !debuglayout then
|
||||
F.epr "with_cursor %a@."
|
||||
F.(brackets @@ list ~sep:cut pp_section)
|
||||
c.sections;
|
||||
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
|
||||
@ -594,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)
|
||||
@ -611,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 =
|
||||
@ -622,12 +633,18 @@ 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.(
|
||||
(*Event.(
|
||||
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
|
||||
| Event.Accepted actions ->
|
||||
callback_resolver := None;
|
||||
@ -645,11 +662,11 @@ 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 ->
|
||||
F.epr "chrcallback: '%a'@." pp_uchar c;
|
||||
ref (fun _c ->
|
||||
(* F.epr "chrcallback: '%a'@." pp_uchar _c; *)
|
||||
Lwt.return_unit)
|
||||
|
||||
let chrcallback _t (chr : int) : unit Lwt.t =
|
||||
@ -691,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;
|
||||
@ -715,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
|
||||
@ -744,41 +761,38 @@ 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
|
||||
match
|
||||
String.rindex_from_opt s
|
||||
(min (slen - 1) (cursor.index - 1))
|
||||
'\n'
|
||||
with
|
||||
| Some i' -> t.scroll <- i' + 1
|
||||
| None -> t.scroll <- 0
|
||||
else
|
||||
match index_rows_from s scroll rows with
|
||||
| None -> ()
|
||||
| Some eow -> (
|
||||
F.epr "eow=%d@." eow;
|
||||
if cursor.index >= eow then
|
||||
match
|
||||
rindex_rows_from s
|
||||
(min (slen - 1) cursor.index)
|
||||
rows
|
||||
with
|
||||
| None -> ()
|
||||
| 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)
|
||||
if cursor.index < Lwd.peek scroll then
|
||||
match
|
||||
String.rindex_from_opt s
|
||||
(min (slen - 1) (cursor.index - 1))
|
||||
'\n'
|
||||
with
|
||||
| Some i' -> Lwd.set t.scroll (i' + 1)
|
||||
| None -> Lwd.set t.scroll 0
|
||||
else
|
||||
match index_rows_from s (Lwd.peek scroll) rows with
|
||||
| None -> ()
|
||||
| Some eow -> (
|
||||
if cursor.index >= eow then
|
||||
match
|
||||
rindex_rows_from s
|
||||
(min (slen - 1) cursor.index)
|
||||
rows
|
||||
with
|
||||
| None -> ()
|
||||
| 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 =
|
||||
@ -825,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
|
||||
@ -851,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
|
||||
@ -862,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 *)
|
||||
@ -879,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 *)
|
||||
[
|
||||
@ -897,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
|
||||
[
|
||||
@ -910,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
|
||||
@ -933,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
|
||||
@ -956,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
|
||||
@ -989,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;
|
||||
@ -1024,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 ]
|
||||
@ -1043,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"
|
||||
@ -1112,26 +1132,23 @@ 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) ->
|
||||
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 =
|
||||
List.filter
|
||||
(fun (r : TextLayout.section) ->
|
||||
@ -1174,18 +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
|
||||
if !debuglayout then F.epr "layout box'=%a@." Gg.Box2.pp box';
|
||||
(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 ->
|
||||
@ -1199,28 +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'
|
||||
|
||||
let layout a b c =
|
||||
let r = layout a b c in
|
||||
debuglayout := false;
|
||||
r
|
||||
end
|
||||
|
||||
116
oplevel.ml
116
oplevel.ml
@ -18,7 +18,7 @@ end
|
||||
let errorcb 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:"icons" ~file:"./assets/entypo.ttf"
|
||||
@ -62,8 +62,6 @@ let () =
|
||||
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 max_fps = ref Float.min_float in
|
||||
|
||||
@ -78,9 +76,11 @@ let () =
|
||||
in
|
||||
|
||||
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
|
||||
|
||||
load_fonts ui.gv;
|
||||
GLFW.setKeyCallback ~window
|
||||
~f:
|
||||
(Some
|
||||
@ -100,7 +100,7 @@ let () =
|
||||
|
||||
F.pr "oplevel.ml: building initial page@.";
|
||||
let page =
|
||||
ref
|
||||
Lwd.var
|
||||
Layout.(
|
||||
vbox
|
||||
~style:
|
||||
@ -108,82 +108,76 @@ let () =
|
||||
[
|
||||
textedit
|
||||
(TextEdit.multiline ui
|
||||
(TextBuffer.of_repo
|
||||
~path:[ ".config"; "init.ml" ]
|
||||
~repo:rootrepo));
|
||||
(Lwt_main.run
|
||||
(TextBuffer.of_repo
|
||||
~path:[ ".config"; "init.ml" ]
|
||||
~repo:rootrepo)));
|
||||
(*textedit
|
||||
(TextEdit.multiline ui
|
||||
(TextBuffer.of_repo ~path:[ "README" ] ~repo:rootrepo)); *)
|
||||
])
|
||||
in
|
||||
|
||||
(let open GLFW in
|
||||
let open Event in
|
||||
let open Ui in
|
||||
Ui.update_bindings ui
|
||||
(adds
|
||||
let open GLFW in
|
||||
let open Event in
|
||||
Ui.update_bindings ui
|
||||
Ui.(
|
||||
adds
|
||||
[
|
||||
[ Key (Press, X, [ Control ]); Key (Press, E, [ Control ]) ];
|
||||
]
|
||||
[ Custom (fun () -> Lwt.return ()) ]));
|
||||
[ Custom (fun () -> Lwt.return ()) ]);
|
||||
F.pr "oplevel.ml: entering drawing loop@.";
|
||||
let period_min = 1.0 /. 30. 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 (
|
||||
let avg = 1. /. Perfgraph.average graph in
|
||||
min_fps := Float.min avg !min_fps;
|
||||
max_fps := Float.max avg !max_fps);
|
||||
Perfgraph.update graph dt;
|
||||
|
||||
let _mx, _my = GLFW.getCursorPos ~window in
|
||||
let win_w, win_h = GLFW.getWindowSize ~window in
|
||||
if now > 2. then (
|
||||
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;
|
||||
Gl.clear
|
||||
(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 _mx, _my = GLFW.getCursorPos ~window in
|
||||
let win_w, win_h = GLFW.getWindowSize ~window in
|
||||
|
||||
let width, height = (float win_w, float win_h) in
|
||||
let box =
|
||||
Gg.(Box2.v V2.zero Size2.(v width (height -. 20.)))
|
||||
in
|
||||
Gv.begin_frame ctx ~width ~height ~device_ratio:1.;
|
||||
Perfgraph.render graph ctx (width -. 205.) 5.;
|
||||
(* F.epr "box=%a@." Gg.Box2.pp box;
|
||||
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;
|
||||
Gl.viewport 0 0 win_w win_h;
|
||||
Gl.clear
|
||||
(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;
|
||||
|
||||
Gc.major_slice 0 |> ignore;
|
||||
GLFW.swapBuffers ~window;
|
||||
GLFW.pollEvents ();
|
||||
Unix.sleepf
|
||||
Float.(max 0. (period_min -. GLFW.getTime () +. !t));
|
||||
Lwt.return_unit)
|
||||
())
|
||||
let width, height = (float win_w, float win_h) in
|
||||
let box = Gg.(Box2.v V2.zero Size2.(v width (height -. 20.))) in
|
||||
Gv.begin_frame ctx ~width ~height ~device_ratio:1.;
|
||||
Perfgraph.render graph ctx (width -. 205.) 5.;
|
||||
(* F.epr "box=%a@." Gg.Box2.pp box;
|
||||
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;
|
||||
|
||||
Printf.printf "MIN %.2f\n" !min_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
|
||||
Printf.printf "MAX %.2f\n%!" !max_fps
|
||||
|
||||
(* let out_ppf =
|
||||
Format.formatter_of_out_functions
|
||||
@ -205,5 +199,3 @@ let () =
|
||||
(* ignore
|
||||
(Toploop.use_input out_ppf
|
||||
(String "#use \"topfind\";;\n#list;;")); *)
|
||||
(* ignore (Toploop.use_input Format.std_formatter (String text)); *)
|
||||
(* Wait for it to be closed. *)
|
||||
|
||||
Reference in New Issue
Block a user