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 gg
irmin-git irmin-git
compiler-libs.toplevel compiler-libs.toplevel
re
) )
(link_flags (-linkall)) (link_flags (-linkall))
; (ocamlopt_flags (:standard -O3 -unboxed-types)) ; (ocamlopt_flags (:standard -O3 -unboxed-types))

541
ogui.ml
View File

@ -1,6 +1,7 @@
open Lwt.Infix open Lwt.Infix
module Gv = Graphv_gles2_native module Gv = Graphv_gles2_native
module F = Fmt module F = Fmt
module Str = Re.Str
type stroke = { width : float; color : Gv.Color.t } type stroke = { width : float; color : Gv.Color.t }
@ -52,24 +53,25 @@ module Sense = struct
end end
module TextBuffer = struct module TextBuffer = struct
type t = type t = {
| Tree of { mutable path : string list;
mutable path : string list; mutable tree : Store.S.tree;
mutable tree : Store.S.tree; repo : Store.Sync.db;
repo : Store.Sync.db; }
}
| Buffer of { name : string; buf : Buffer.t }
let of_repo ~path ~(repo : Store.Sync.db) = let of_repo ~path ~(repo : Store.Sync.db) =
let tree = Lwt_main.run ((fun () -> Store.S.tree repo) ()) in 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 = 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
| Tree ({ path; tree; _ } as tt) -> | { path; tree; _ } as tt ->
Store.S.Tree.update tree path (function Store.S.Tree.update tree path (function
| Some src -> | Some src ->
assert (n <= String.length src); assert (n <= String.length src);
@ -85,36 +87,48 @@ module TextBuffer = struct
~len:(String.length src - (n + uclen)); ~len:(String.length src - (n + uclen));
Some (Bytes.to_string dst) Some (Bytes.to_string dst)
| None -> None) | None -> None)
>>= fun tree -> Lwt.return (Tree { tt with tree }) >>= fun tree -> Lwt.return { 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
let contents = function let remove_uchar t n : t Lwt.t =
| Tree { path; tree; _ } -> F.epr "TextBuffer.remove_subset n=%d @." n;
(try Store.S.Tree.get tree path with match t with
| Not_found | Invalid_argument _ -> | { path; tree; _ } as tt ->
Lwt.return Store.S.Tree.update tree path (function
@@ F.str | Some src ->
"print_newline \"/%s: Not_found | \ let srcn = String.length src in
Invalid_argument\";;" assert (n < srcn);
(String.concat "/" path) let dst = Bytes.create srcn in
| exc -> let ucn =
Lwt.return Uchar.utf_decode_length (String.get_utf_8_uchar src n)
(F.str "Store.S.Tree.get /%s exception: %s" in
(String.concat "/" path) Bytes.blit_string src 0 dst 0 n;
(Printexc.to_string exc))) Bytes.blit_string src (n + ucn) dst n (srcn - n - ucn);
>>= fun text -> Lwt.return text Some (Bytes.to_string dst)
| Buffer { buf; _ } -> Lwt.return (Buffer.contents buf) | v -> v)
>>= fun tree -> Lwt.return { tt with tree }
let length = function let fold_string t (f : string -> 'a) : 'a Lwt.t =
| Tree { path; tree; _ } -> match t with
Store.S.Tree.get tree path >>= fun text -> | { path; tree; _ } ->
Lwt.return (String.length text) Store.S.Tree.get tree path >>= fun text -> Lwt.return (f text)
| Buffer { buf; _ } -> Lwt.return @@ Buffer.length buf
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)))
>>= fun text -> Lwt.return text
let length { path; tree; _ } =
Store.S.Tree.get tree path >>= fun text ->
Lwt.return (String.length text)
end end
module Event = struct module Event = struct
@ -440,8 +454,8 @@ module TextLayout = struct
record record
[ [
field "text" field "text"
(fun s -> Lwt_main.run (TextBuffer.length s.text)) (fun s -> str "path=%s" (String.concat "/" s.text.path))
int; string;
field "sections" field "sections"
(fun s -> s.sections) (fun s -> s.sections)
(brackets @@ array pp_layout_section); (brackets @@ array pp_layout_section);
@ -454,11 +468,9 @@ module TextLayout = struct
field "justify" (fun s -> s.justify) bool; field "justify" (fun s -> s.justify) bool;
]) ])
let default_layout_job () = let layout_job_of_text text =
{ {
text = text;
TextBuffer.buffer ~name:"default_layout_job"
~buf:(Buffer.create 32);
sections = Array.make 0 layout_section_default; sections = Array.make 0 layout_section_default;
wrap = default_text_wrapping (); wrap = default_text_wrapping ();
first_row_min_height = 0.0; first_row_min_height = 0.0;
@ -615,45 +627,42 @@ module TextLayout = struct
type cursor = { type cursor = {
index : int; index : int;
row : int option; row : int option;
last_col : int;
prefer_next_row : bool; prefer_next_row : bool;
} }
let cursor_default = 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 = let cursor ?(row : int option) ?(last_col = 0) index : cursor =
{ index = loc; row = None; prefer_next_row = false } F.epr "cursor row=%a last_col=%d index=%d@."
F.(option int)
let cursor_move amt max c : cursor = row last_col index;
cursor { index; row; last_col; prefer_next_row = false }
(if c.index + amt < 0 then 0
else if c.index + amt > max then max
else c.index + amt)
let simple text ?(format = text_format_default) wrap_width : let simple text ?(format = text_format_default) wrap_width :
layout_job = layout_job Lwt.t =
{ TextBuffer.length text >>= fun textlen ->
(default_layout_job ()) with Lwt.return
text; {
sections = (layout_job_of_text text) with
Array.make 1 sections =
{ Array.make 1
leading_space = 0.0; { leading_space = 0.0; byte_range = (0, textlen); format };
byte_range = (0, Lwt_main.run (TextBuffer.length text)); wrap =
format; { (default_text_wrapping ()) with max_width = wrap_width };
}; break_on_newline = true;
wrap = }
{ (default_text_wrapping ()) with max_width = wrap_width };
break_on_newline = true;
}
let singleline (text : TextBuffer.t) (format : text_format) : let singleline (text : TextBuffer.t) (format : text_format) :
layout_job = layout_job Lwt.t =
{ simple text ~format Float.infinity >>= fun simple ->
(simple text ~format Float.infinity) with Lwt.return
wrap = default_text_wrapping (); {
break_on_newline = true; simple with
} wrap = default_text_wrapping ();
break_on_newline = true;
}
let cursor_color = ref (Gv.Color.rgbf ~r:0.5 ~g:0.5 ~b:0.) let cursor_color = ref (Gv.Color.rgbf ~r:0.5 ~g:0.5 ~b:0.)
@ -709,28 +718,29 @@ module TextLayout = struct
} }
let layout (gv : Gv.t) (fonts : Fonts.t) (job : layout_job) 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 "TextLayout.layout@.";
F.epr "job.wrap.max_width=%f@." job.wrap.max_widtha; F.epr "job.wrap.max_width=%f@." job.wrap.max_widtha;
F.epr "job.wrap.max_rows=%d@." job.wrap.max_rows; *) F.epr "job.wrap.max_rows=%d@." job.wrap.max_rows; *)
if job.wrap.max_rows == 0 then if job.wrap.max_rows == 0 then
{ Lwt.return
job; {
rows = Array.make 1 (row_default ()); job;
rect = Box2.move pos Box2.zero; rows = Array.make 1 (row_default ());
mesh_bounds = Box2.zero; rect = Box2.move pos Box2.zero;
elided = true; mesh_bounds = Box2.zero;
num_vertices = 0; elided = true;
num_indices = 0; num_vertices = 0;
pixels_per_point = fonts.pixels_per_point; num_indices = 0;
} pixels_per_point = fonts.pixels_per_point;
}
else else
let metrics = Gv.Text.metrics gv in let metrics = Gv.Text.metrics gv in
let lines = Gv.Text.make_empty_rows job.wrap.max_rows in let lines = Gv.Text.make_empty_rows job.wrap.max_rows in
TextBuffer.contents job.text >>= fun contents ->
let row_count = let row_count =
Gv.Text.break_lines gv ~break_width:job.wrap.max_width Gv.Text.break_lines gv ~break_width:job.wrap.max_width
~max_rows:job.wrap.max_rows ~lines ~max_rows:job.wrap.max_rows ~lines contents
(Lwt_main.run (TextBuffer.contents job.text))
in in
(* F.epr "row_count=%d@." row_count; *) (* F.epr "row_count=%d@." row_count; *)
let height = ref (V2.y pos) in let height = ref (V2.y pos) in
@ -738,43 +748,44 @@ module TextLayout = struct
let line_height = let line_height =
Option.value ~default:metrics.line_height job.line_height Option.value ~default:metrics.line_height job.line_height
in in
{ Lwt.return
job; {
rows = job;
Array.init row_count (fun n -> rows =
let text_row = Array.get lines n in Array.init row_count (fun n ->
height := !height +. line_height; let text_row = Array.get lines n in
let rect = height := !height +. line_height;
Box2.v let rect =
(P2.v (V2.x pos) !height) Box2.v
(P2.v (P2.v (V2.x pos) !height)
(text_row.width +. V2.x pos) (P2.v
(!height +. line_height)) (text_row.width +. V2.x pos)
in (!height +. line_height))
max_width := Float.max text_row.maxx !max_width; in
{ max_width := Float.max text_row.maxx !max_width;
text_row; {
section_index_at_start = 0; text_row;
glyphs = [ (* TODO *) ]; section_index_at_start = 0;
rect; glyphs = [ (* TODO *) ];
visuals = rect;
{ visuals =
mesh_bounds = rect; {
glyph_vertex_range = mesh_bounds = rect;
(text_row.start_index, text_row.end_index); glyph_vertex_range =
}; (text_row.start_index, text_row.end_index);
ends_with_newline = false (* TODO *); };
}); ends_with_newline = false (* TODO *);
rect = });
Box2.v Size2.zero rect =
(P2.v job.wrap.max_width Box2.v Size2.zero
(Float.of_int row_count *. line_height)); (P2.v job.wrap.max_width
elided = row_count > job.wrap.max_rows (* TODO *); (Float.of_int row_count *. line_height));
mesh_bounds = Box2.v Size2.zero (P2.v !max_width !height); elided = row_count > job.wrap.max_rows (* TODO *);
num_indices = 0 (* TODO *); mesh_bounds = Box2.v Size2.zero (P2.v !max_width !height);
num_vertices = 0 (* TODO *); num_indices = 0 (* TODO *);
pixels_per_point = fonts.pixels_per_point; num_vertices = 0 (* TODO *);
} pixels_per_point = fonts.pixels_per_point;
}
end end
let rec nth_tl n = function let rec nth_tl n = function
@ -867,7 +878,7 @@ module Ui = struct
ref Option.None ref Option.None
let keycallback t (state : Event.key_action) (key : Event.key) 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 = let res =
match !callback_resolver with match !callback_resolver with
| Some res -> res | Some res -> res
@ -877,33 +888,28 @@ module Ui = struct
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);
ignore match Event.resolve (Key (state, key, mods)) res with
@@ Lwt_main.run | Event.Accepted actions ->
((fun () : bool Lwt.t -> callback_resolver := None;
match Event.resolve (Key (state, key, mods)) res with let rec exec : action list -> bool Lwt.t = function
| Event.Accepted actions -> | Custom f :: actions -> f () >>= fun () -> exec actions
callback_resolver := None; | [] -> Lwt.return false
let rec exec : action list -> bool Lwt.t = function in
| Custom f :: actions -> exec actions
f () >>= fun () -> exec actions | Event.Continue res ->
| [] -> Lwt.return false callback_resolver := Some res;
in Lwt.return true
exec actions | Event.Rejected ->
| Event.Continue res -> callback_resolver := None;
callback_resolver := Some res; Lwt.return false
Lwt.return true
| Event.Rejected ->
callback_resolver := None;
Lwt.return false)
())
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 = let chrcallback _t (chr : int) : unit Lwt.t =
Lwt_main.run @@ !chrcallback_ref @@ Uchar.of_int chr !chrcallback_ref @@ Uchar.of_int chr
end end
module TextEdit = struct module TextEdit = struct
@ -931,6 +937,21 @@ module TextEdit = struct
char_limit : int; (* return_key : keyboard_shortcut; *) 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 add_bindings (t : t) (ui : Ui.t) : unit Lwt.t =
let open GLFW in let open GLFW in
let open Event in let open Event in
@ -942,26 +963,13 @@ module TextEdit = struct
[ Key (Press, F, [ Control ]) ]; [ Key (Press, F, [ Control ]) ];
[ Key (Press, Right, []) ]; [ Key (Press, Right, []) ];
] ]
[ [ Custom (fun () -> cursor_move t 1) ]
Custom
(fun () ->
TextBuffer.length t.text >>= fun textlen ->
t.cursor <- TextLayout.cursor_move 1 textlen t.cursor;
Lwt.return_unit);
]
|> adds |> adds
[ [
[ Key (Press, B, [ Control ]) ]; [ Key (Press, B, [ Control ]) ];
[ Key (Press, Left, []) ]; [ Key (Press, Left, []) ];
] ]
[ [ Custom (fun () -> cursor_move t (-1)) ]
Custom
(fun () ->
TextBuffer.length t.text >>= fun textlen ->
t.cursor <-
TextLayout.cursor_move (-1) textlen t.cursor;
Lwt.return_unit);
]
|> adds |> adds
[ [
[ Key (Press, N, [ Control ]) ]; [ Key (Press, N, [ Control ]) ];
@ -970,42 +978,73 @@ module TextEdit = struct
[ [
Custom Custom
(fun () -> (fun () ->
TextBuffer.length t.text >>= fun textlen -> TextBuffer.fold_string t.text (fun s ->
t.cursor <- let sn = String.length s in
TextLayout.cursor_move 10 textlen t.cursor; let last_col = t.cursor.last_col in
Lwt.return_unit); 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 <-
{
t.cursor with
index =
(bol'
+
if last_col > next_line_len then
next_line_len
else min next_line_len last_col);
}));
] ]
|> adds |> adds
[ [
[ Key (Press, P, [ Control ]) ]; [ Key (Press, Up, []) ]; [ Key (Press, P, [ Control ]) ]; [ Key (Press, Up, []) ];
] ]
[ [ Custom (fun () -> cursor_move t (-10)) ]
Custom
(fun () ->
TextBuffer.length t.text >>= fun textlen ->
t.cursor <-
TextLayout.cursor_move (-10) textlen t.cursor;
Lwt.return_unit);
]
|> adds |> adds
[ [ Key (Press, Backspace, []) ]; [ Key (Press, Up, []) ] ] [ [ Key (Press, Backspace, []) ] ]
[ [
Custom Custom
(fun () -> (fun () ->
TextBuffer.length t.text >>= fun textlen -> if t.cursor.index > 0 then (
t.cursor <- TextBuffer.remove_uchar t.text (t.cursor.index - 1)
TextLayout.cursor_move (-10) textlen t.cursor; >>= 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); 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 t.cursor.index c
>>= fun text -> >>= fun text ->
t.text <- text; t.text <- text;
TextBuffer.length t.text >>= fun textlen -> cursor_move t 1
t.cursor <- TextLayout.cursor_move 1 textlen t.cursor;
Lwt.return_unit
(* 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
@ -1148,7 +1187,7 @@ module Painter = struct
open Layout open Layout
open Gg 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 (* F.epr
"Painter.galley (String.length g.job.text)=%d (Array.length \ "Painter.galley (String.length g.job.text)=%d (Array.length \
g.rows)=%d @." g.rows)=%d @."
@ -1156,70 +1195,69 @@ module Painter = struct
(Array.length g.rows); (Array.length g.rows);
F.epr "g.job=%a@." TextLayout.pp_layout_job g.job; F.epr "g.job=%a@." TextLayout.pp_layout_job g.job;
F.epr "g.rows=%a@." F.(braces (array TextLayout.pp_row)) g.rows; *) F.epr "g.rows=%a@." F.(braces (array TextLayout.pp_row)) g.rows; *)
Array.fold_left TextBuffer.contents g.job.text >>= fun contents ->
(fun (br : box2) (row : TextLayout.row) -> let contents_len = String.length contents in
let sections = g.rows
List.filter |> Array.fold_left
(fun (r : TextLayout.layout_section) -> (fun (br : box2) (row : TextLayout.row) ->
fst r.byte_range <= row.text_row.end_index let sections =
&& snd r.byte_range > row.text_row.start_index) List.filter
(Array.to_list (fun (r : TextLayout.layout_section) ->
@@ Array.sub g.job.sections row.section_index_at_start fst r.byte_range <= row.text_row.end_index
(Array.length g.job.sections && snd r.byte_range > row.text_row.start_index)
- row.section_index_at_start)) (Array.to_list
in @@ Array.sub g.job.sections row.section_index_at_start
assert (List.length sections > 0); (Array.length g.job.sections
- row.section_index_at_start))
in
assert (List.length sections > 0);
ignore ignore
(List.fold_left (List.fold_left
(fun x (sec : TextLayout.layout_section) -> (fun x (sec : TextLayout.layout_section) ->
let start, end_ = let start, end_ =
( min ( min (contents_len - 1)
(Lwt_main.run (TextBuffer.length g.job.text) - 1) (max 0
(max 0 (max (fst sec.byte_range)
(max (fst sec.byte_range) row.text_row.start_index)),
row.text_row.start_index)), min (contents_len - 1)
min (max 0
(Lwt_main.run (TextBuffer.length g.job.text) - 1) (min (snd sec.byte_range)
(max 0 row.text_row.end_index)) )
(min (snd sec.byte_range) in
row.text_row.end_index)) )
in
let font_name, font_size = let font_name, font_size =
match sec.format.font_id with match sec.format.font_id with
| Default -> ("mono", 18.) | Default -> ("mono", 18.)
| FontId (s, size) -> (s, size) | FontId (s, size) -> (s, size)
in in
let open Gv in let open Gv in
Text.set_font_face t ~name:font_name; Text.set_font_face t ~name:font_name;
Text.set_size t ~size:font_size; Text.set_size t ~size:font_size;
Text.set_align t ~align:Align.(left lor top); Text.set_align t ~align:Align.(left lor top);
let metrics = Gv.Text.metrics t in let metrics = Gv.Text.metrics t in
let bounds = let bounds =
Gv.Text.bounds t ~x ~y:0. ~start ~end_ Gv.Text.bounds t ~x ~y:0. ~start ~end_ contents
(Lwt_main.run (TextBuffer.contents g.job.text)) in
in Path.begin_ t;
Path.begin_ t; Path.rect t ~x ~y:(Box2.miny row.rect)
Path.rect t ~x ~y:(Box2.miny row.rect) ~w:bounds.advance ~h:metrics.line_height;
~w:bounds.advance ~h:metrics.line_height; set_fill_color t ~color:sec.format.background;
set_fill_color t ~color:sec.format.background; fill t;
fill t;
set_fill_color t ~color:sec.format.color; set_fill_color t ~color:sec.format.color;
let w = Text.text_w t ~x ~y:(Box2.miny row.rect) ~start
Text.text_w t ~x ~y:(Box2.miny row.rect) ~start ~end_ ~end_ contents)
(Lwt_main.run (TextBuffer.contents g.job.text)) (Box2.minx row.rect) sections);
in Box2.(union br row.rect))
w) Box2.empty
(Box2.minx row.rect) sections); |> Lwt.return
Box2.(union br row.rect))
Box2.empty g.rows
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 match frame.t with
| `Box (dir, ll) -> | `Box (dir, ll) ->
List.fold_left Lwt_list.fold_left_s
(fun (o : box2) f -> (fun (o : box2) f ->
layout layout
(match dir with (match dir with
@ -1240,18 +1278,15 @@ module Painter = struct
| Some gv -> Fonts.{ gv; pixels_per_point = 1.0 } | Some gv -> Fonts.{ gv; pixels_per_point = 1.0 }
| None -> failwith "can't find font 'mono'" | None -> failwith "can't find font 'mono'"
in in
let layout_job = (if t.multiline then
if t.multiline then TextLayout.simple t.text ~format:t.text_format
TextLayout.simple t.text ~format:t.text_format (Option.value ~default:(Box2.w box) t.desired_width)
(Option.value ~default:(Box2.w box) t.desired_width) else TextLayout.singleline t.text t.text_format)
else TextLayout.singleline t.text t.text_format >>= fun layout_job ->
in Ui.fonts ui.gv (fun f ->
let galley = TextLayout.layout f font
Ui.fonts ui.gv (fun f -> (TextLayout.with_cursor t.cursor layout_job)
TextLayout.layout f font (Box2.o box))
(TextLayout.with_cursor t.cursor layout_job) >>= fun galley -> paint_galley ui.gv galley
(Box2.o box)) | _ -> Lwt.return box
in
paint_galley ui.gv galley
| _ -> box
end end

33
oplevel.ml
View File

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