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

down might be correct?

Browse Source
This commit is contained in:
cqc
2024-05-09 21:23:14 -05:00
parent 11b255758c
commit f1653a93b4
3 changed files with 307 additions and 268 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
dune
View File

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

267
ogui.ml
View File

@ -1,6 +1,7 @@
open Lwt.Infix
module Gv = Graphv_gles2_native
module F = Fmt
module Str = Re.Str
type stroke = { width : float; color : Gv.Color.t }
@ -52,24 +53,25 @@ module Sense = struct
end
module TextBuffer = struct
type t =
| Tree of {
type t = {
mutable path : string list;
mutable tree : Store.S.tree;
repo : Store.Sync.db;
}
| Buffer of { name : string; buf : Buffer.t }
let of_repo ~path ~(repo : Store.Sync.db) =
let tree = Lwt_main.run ((fun () -> Store.S.tree repo) ()) in
Tree { path; tree; repo }
{ path; tree; repo }
let buffer ~name ~buf = Buffer { name; buf }
let of_string ~path ?(repo = None) str =
Store.S.Repo.v (Irmin_mem.config ()) >>= fun repo' ->
Option.value ~default:Store.S.(empty repo') repo >>= fun repo ->
Lwt.return { path; tree = Store.S.Tree.singleton path str; repo }
let insert_uchar t n uc : t Lwt.t =
F.epr "TextBuffer.insert_uchar %d %a@." n pp_uchar uc;
match t with
| Tree ({ path; tree; _ } as tt) ->
| { path; tree; _ } as tt ->
Store.S.Tree.update tree path (function
| Some src ->
assert (n <= String.length src);
@ -85,22 +87,37 @@ module TextBuffer = struct
~len:(String.length src - (n + uclen));
Some (Bytes.to_string dst)
| None -> None)
>>= fun tree -> Lwt.return (Tree { tt with tree })
| Buffer { buf; _ } as b ->
let textend = Buffer.sub buf n (Buffer.length buf - n) in
Buffer.truncate buf n;
Buffer.add_utf_8_uchar buf uc;
Buffer.add_string buf textend;
Lwt.return b
>>= fun tree -> Lwt.return { tt with tree }
let contents = function
| Tree { path; tree; _ } ->
let remove_uchar t n : t Lwt.t =
F.epr "TextBuffer.remove_subset n=%d @." n;
match t with
| { path; tree; _ } as tt ->
Store.S.Tree.update tree path (function
| Some src ->
let srcn = String.length src in
assert (n < srcn);
let dst = Bytes.create srcn in
let ucn =
Uchar.utf_decode_length (String.get_utf_8_uchar src n)
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)
| v -> v)
>>= fun tree -> Lwt.return { tt with tree }
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)
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\";;"
"print_newline \"/%s: Not_found | Invalid_argument\";;"
(String.concat "/" path)
| exc ->
Lwt.return
@ -108,13 +125,10 @@ module TextBuffer = struct
(String.concat "/" path)
(Printexc.to_string exc)))
>>= fun text -> Lwt.return text
| Buffer { buf; _ } -> Lwt.return (Buffer.contents buf)
let length = function
| Tree { path; tree; _ } ->
let length { path; tree; _ } =
Store.S.Tree.get tree path >>= fun text ->
Lwt.return (String.length text)
| Buffer { buf; _ } -> Lwt.return @@ Buffer.length buf
end
module Event = struct
@ -440,8 +454,8 @@ module TextLayout = struct
record
[
field "text"
(fun s -> Lwt_main.run (TextBuffer.length s.text))
int;
(fun s -> str "path=%s" (String.concat "/" s.text.path))
string;
field "sections"
(fun s -> s.sections)
(brackets @@ array pp_layout_section);
@ -454,11 +468,9 @@ module TextLayout = struct
field "justify" (fun s -> s.justify) bool;
])
let default_layout_job () =
let layout_job_of_text text =
{
text =
TextBuffer.buffer ~name:"default_layout_job"
~buf:(Buffer.create 32);
text;
sections = Array.make 0 layout_section_default;
wrap = default_text_wrapping ();
first_row_min_height = 0.0;
@ -615,42 +627,39 @@ module TextLayout = struct
type cursor = {
index : int;
row : int option;
last_col : int;
prefer_next_row : bool;
}
let cursor_default =
{ index = 0; row = None; prefer_next_row = false }
{ index = 0; row = None; last_col = 0; prefer_next_row = false }
let cursor loc : cursor =
{ index = loc; row = None; prefer_next_row = false }
let cursor_move amt max c : cursor =
cursor
(if c.index + amt < 0 then 0
else if c.index + amt > max then max
else c.index + amt)
let cursor ?(row : int option) ?(last_col = 0) index : cursor =
F.epr "cursor row=%a last_col=%d index=%d@."
F.(option int)
row last_col index;
{ index; row; last_col; prefer_next_row = false }
let simple text ?(format = text_format_default) wrap_width :
layout_job =
layout_job Lwt.t =
TextBuffer.length text >>= fun textlen ->
Lwt.return
{
(default_layout_job ()) with
text;
(layout_job_of_text text) with
sections =
Array.make 1
{
leading_space = 0.0;
byte_range = (0, Lwt_main.run (TextBuffer.length text));
format;
};
{ leading_space = 0.0; byte_range = (0, textlen); format };
wrap =
{ (default_text_wrapping ()) with max_width = wrap_width };
break_on_newline = true;
}
let singleline (text : TextBuffer.t) (format : text_format) :
layout_job =
layout_job Lwt.t =
simple text ~format Float.infinity >>= fun simple ->
Lwt.return
{
(simple text ~format Float.infinity) with
simple with
wrap = default_text_wrapping ();
break_on_newline = true;
}
@ -709,11 +718,12 @@ module TextLayout = struct
}
let layout (gv : Gv.t) (fonts : Fonts.t) (job : layout_job)
(pos : v2) : galley =
(pos : v2) : galley Lwt.t =
(* F.epr "TextLayout.layout@.";
F.epr "job.wrap.max_width=%f@." job.wrap.max_widtha;
F.epr "job.wrap.max_rows=%d@." job.wrap.max_rows; *)
if job.wrap.max_rows == 0 then
Lwt.return
{
job;
rows = Array.make 1 (row_default ());
@ -727,10 +737,10 @@ module TextLayout = struct
else
let metrics = Gv.Text.metrics gv in
let lines = Gv.Text.make_empty_rows job.wrap.max_rows in
TextBuffer.contents job.text >>= fun contents ->
let row_count =
Gv.Text.break_lines gv ~break_width:job.wrap.max_width
~max_rows:job.wrap.max_rows ~lines
(Lwt_main.run (TextBuffer.contents job.text))
~max_rows:job.wrap.max_rows ~lines contents
in
(* F.epr "row_count=%d@." row_count; *)
let height = ref (V2.y pos) in
@ -738,6 +748,7 @@ module TextLayout = struct
let line_height =
Option.value ~default:metrics.line_height job.line_height
in
Lwt.return
{
job;
rows =
@ -867,7 +878,7 @@ module Ui = struct
ref Option.None
let keycallback t (state : Event.key_action) (key : Event.key)
(mods : Event.key_mod list) : unit =
(mods : Event.key_mod list) : bool Lwt.t =
let res =
match !callback_resolver with
| Some res -> res
@ -877,15 +888,11 @@ module Ui = struct
Event.(
F.epr "Ui.keycallback %a %a %a@." pp_key key pp_key_action state
pp_mods mods);
ignore
@@ Lwt_main.run
((fun () : bool Lwt.t ->
match Event.resolve (Key (state, key, mods)) res with
| Event.Accepted actions ->
callback_resolver := None;
let rec exec : action list -> bool Lwt.t = function
| Custom f :: actions ->
f () >>= fun () -> exec actions
| Custom f :: actions -> f () >>= fun () -> exec actions
| [] -> Lwt.return false
in
exec actions
@ -894,16 +901,15 @@ module Ui = struct
Lwt.return true
| Event.Rejected ->
callback_resolver := None;
Lwt.return false)
())
Lwt.return false
let chrcallback_ref : (Uchar.t -> unit Lwt.t) ref =
ref (fun c ->
F.epr "chrcallback: '%a'@." pp_uchar c;
Lwt.return_unit)
let chrcallback _t (chr : int) : unit =
Lwt_main.run @@ !chrcallback_ref @@ Uchar.of_int chr
let chrcallback _t (chr : int) : unit Lwt.t =
!chrcallback_ref @@ Uchar.of_int chr
end
module TextEdit = struct
@ -931,6 +937,21 @@ module TextEdit = struct
char_limit : int; (* return_key : keyboard_shortcut; *)
}
let col t =
TextBuffer.fold_string t.text (fun s ->
Str.search_backward (Str.regexp "^") s t.cursor.index)
let cursor_move (t : t) (amt : int) : unit Lwt.t =
TextBuffer.fold_string t.text (fun s ->
let index' =
t.cursor.index + amt |> max 0 |> min (String.length s)
in
t.cursor <-
TextLayout.cursor
~last_col:
(index' - Str.search_backward (Str.regexp "^") s index')
index')
let add_bindings (t : t) (ui : Ui.t) : unit Lwt.t =
let open GLFW in
let open Event in
@ -942,26 +963,13 @@ module TextEdit = struct
[ Key (Press, F, [ Control ]) ];
[ Key (Press, Right, []) ];
]
[
Custom
(fun () ->
TextBuffer.length t.text >>= fun textlen ->
t.cursor <- TextLayout.cursor_move 1 textlen t.cursor;
Lwt.return_unit);
]
[ Custom (fun () -> cursor_move t 1) ]
|> adds
[
[ Key (Press, B, [ Control ]) ];
[ Key (Press, Left, []) ];
]
[
Custom
(fun () ->
TextBuffer.length t.text >>= fun textlen ->
t.cursor <-
TextLayout.cursor_move (-1) textlen t.cursor;
Lwt.return_unit);
]
[ Custom (fun () -> cursor_move t (-1)) ]
|> adds
[
[ Key (Press, N, [ Control ]) ];
@ -970,42 +978,73 @@ module TextEdit = struct
[
Custom
(fun () ->
TextBuffer.length t.text >>= fun textlen ->
TextBuffer.fold_string t.text (fun s ->
let sn = String.length s in
let last_col = t.cursor.last_col in
let seol = Str.search_forward (Str.regexp "$") in
let bol =
Str.search_backward (Str.regexp "^") s
t.cursor.index
in
let eol = seol s t.cursor.index in
let bol' = min sn eol + 1 in
let eol' = seol s bol' in
let next_line_len = eol' - bol' in
F.epr
"Down: index=%d last_col=%d eol=%d eol'=%d \
bol=%d @."
t.cursor.index last_col eol eol' bol;
t.cursor <-
TextLayout.cursor_move 10 textlen t.cursor;
Lwt.return_unit);
{
t.cursor with
index =
(bol'
+
if last_col > next_line_len then
next_line_len
else min next_line_len last_col);
}));
]
|> adds
[
[ Key (Press, P, [ Control ]) ]; [ Key (Press, Up, []) ];
]
[
Custom
(fun () ->
TextBuffer.length t.text >>= fun textlen ->
t.cursor <-
TextLayout.cursor_move (-10) textlen t.cursor;
Lwt.return_unit);
]
[ Custom (fun () -> cursor_move t (-10)) ]
|> adds
[ [ Key (Press, Backspace, []) ]; [ Key (Press, Up, []) ] ]
[ [ Key (Press, Backspace, []) ] ]
[
Custom
(fun () ->
TextBuffer.length t.text >>= fun textlen ->
t.cursor <-
TextLayout.cursor_move (-10) textlen t.cursor;
if t.cursor.index > 0 then (
TextBuffer.remove_uchar t.text (t.cursor.index - 1)
>>= fun text ->
t.text <- text;
cursor_move t (-1))
else Lwt.return_unit);
]
|> adds (* EOL *)
[
[ Key (Press, E, [ Control ]) ]; [ Key (Press, End, []) ];
]
[
Custom
(fun () ->
TextBuffer.length t.text >>= fun _textlen ->
TextBuffer.fold_string t.text (fun s ->
Str.search_forward (Str.regexp "$") s
t.cursor.index)
>>= fun index ->
t.cursor <- { t.cursor with 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;
TextBuffer.length t.text >>= fun textlen ->
t.cursor <- TextLayout.cursor_move 1 textlen t.cursor;
Lwt.return_unit
cursor_move t 1
(* This creates a giant stack of calls lol
>>= fun () -> !Ui.chrcallback_ref c *));
Lwt.return_unit
@ -1148,7 +1187,7 @@ module Painter = struct
open Layout
open Gg
let paint_galley (t : Gv.t) (g : TextLayout.galley) : box2 =
let paint_galley (t : Gv.t) (g : TextLayout.galley) : box2 Lwt.t =
(* F.epr
"Painter.galley (String.length g.job.text)=%d (Array.length \
g.rows)=%d @."
@ -1156,7 +1195,10 @@ module Painter = struct
(Array.length g.rows);
F.epr "g.job=%a@." TextLayout.pp_layout_job g.job;
F.epr "g.rows=%a@." F.(braces (array TextLayout.pp_row)) g.rows; *)
Array.fold_left
TextBuffer.contents g.job.text >>= fun contents ->
let contents_len = String.length contents in
g.rows
|> Array.fold_left
(fun (br : box2) (row : TextLayout.row) ->
let sections =
List.filter
@ -1174,13 +1216,11 @@ module Painter = struct
(List.fold_left
(fun x (sec : TextLayout.layout_section) ->
let start, end_ =
( min
(Lwt_main.run (TextBuffer.length g.job.text) - 1)
( min (contents_len - 1)
(max 0
(max (fst sec.byte_range)
row.text_row.start_index)),
min
(Lwt_main.run (TextBuffer.length g.job.text) - 1)
min (contents_len - 1)
(max 0
(min (snd sec.byte_range)
row.text_row.end_index)) )
@ -1197,8 +1237,7 @@ module Painter = struct
Text.set_align t ~align:Align.(left lor top);
let metrics = Gv.Text.metrics t in
let bounds =
Gv.Text.bounds t ~x ~y:0. ~start ~end_
(Lwt_main.run (TextBuffer.contents g.job.text))
Gv.Text.bounds t ~x ~y:0. ~start ~end_ contents
in
Path.begin_ t;
Path.rect t ~x ~y:(Box2.miny row.rect)
@ -1207,19 +1246,18 @@ module Painter = struct
fill t;
set_fill_color t ~color:sec.format.color;
let w =
Text.text_w t ~x ~y:(Box2.miny row.rect) ~start ~end_
(Lwt_main.run (TextBuffer.contents g.job.text))
in
w)
Text.text_w t ~x ~y:(Box2.miny row.rect) ~start
~end_ contents)
(Box2.minx row.rect) sections);
Box2.(union br row.rect))
Box2.empty g.rows
Box2.empty
|> Lwt.return
let rec layout (box : box2) (ui : Ui.t) (frame : frame) : box2 =
let rec layout (box : box2) (ui : Ui.t) (frame : frame) : box2 Lwt.t
=
match frame.t with
| `Box (dir, ll) ->
List.fold_left
Lwt_list.fold_left_s
(fun (o : box2) f ->
layout
(match dir with
@ -1240,18 +1278,15 @@ module Painter = struct
| Some gv -> Fonts.{ gv; pixels_per_point = 1.0 }
| None -> failwith "can't find font 'mono'"
in
let layout_job =
if t.multiline then
(if t.multiline then
TextLayout.simple t.text ~format:t.text_format
(Option.value ~default:(Box2.w box) t.desired_width)
else TextLayout.singleline t.text t.text_format
in
let galley =
else TextLayout.singleline t.text t.text_format)
>>= fun layout_job ->
Ui.fonts ui.gv (fun f ->
TextLayout.layout f font
(TextLayout.with_cursor t.cursor layout_job)
(Box2.o box))
in
paint_galley ui.gv galley
| _ -> box
>>= fun galley -> paint_galley ui.gv galley
| _ -> Lwt.return box
end

23
oplevel.ml
View File

@ -1,3 +1,4 @@
open Lwt.Infix
module F = Fmt
open Tgles2
module Gv = Graphv_gles2_native
@ -84,27 +85,29 @@ let () =
GLFW.setKeyCallback ~window
~f:
(Some
Glfw_types.(
fun _window key int state mods ->
F.epr
(fun _window key _int state mods ->
(* F.epr
"GLFW.setKeyCallback ~f: _win key=%a int=%d state=%a \
mods=%a@."
pp_key key int pp_key_action state pp_mods mods;
Ogui.Ui.keycallback ui state key mods))
pp_key key int pp_key_action state pp_mods mods; *)
Lwt.async (fun () ->
Ogui.Ui.keycallback ui state key mods >>= fun _ ->
Lwt.return_unit)))
|> ignore;
GLFW.setCharCallback ~window
~f:
(Some
(fun _window ch ->
let uc = Uchar.of_int ch in
(* let uc = Uchar.of_int ch in
F.epr "GLFW.setCharCallback ~f: _win ch=%d(%a)@." ch
F.(option string)
(if Uchar.is_char uc then
Some (String.make 1 @@ Uchar.to_char uc)
else None);
Ogui.Ui.chrcallback ui ch))
else None); *)
Lwt.async (fun () ->
Ogui.Ui.chrcallback ui ch >>= fun _ -> Lwt.return_unit)))
|> ignore;
F.pr "oplevel.ml: building initial page@.";
@ -156,7 +159,7 @@ let () =
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 |> ignore;
Painter.layout box ui page >>= fun _ ->
(* Demo.render_demo ctx mx my win_w win_h now !blowup data; *)
Gv.end_frame ctx;