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

cleaned up

Browse Source
This commit is contained in:
cqc
2024-05-11 22:53:29 -05:00
parent 7473c66bee
commit 1820e5f8a9
3 changed files with 181 additions and 437 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
dune
View File

@ -26,10 +26,10 @@
graphv_gles2_native
gg
irmin-git
compiler-libs.toplevel
; compiler-libs.toplevel
re
)
(link_flags (-linkall))
; (link_flags (-linkall))
; (ocamlopt_flags (:standard -O3 -unboxed-types))
(ocamlc_flags (:standard -verbose))
(modes byte)

594
ogui.ml
View File

@ -66,17 +66,21 @@ module TextBuffer = struct
type t = {
mutable path : string list;
mutable tree : Store.S.tree;
repo : Store.Sync.db;
repo : Store.Sync.db Lwt.t;
}
let of_repo ~path ~(repo : Store.Sync.db) =
let tree = Lwt_main.run ((fun () -> Store.S.tree repo) ()) in
let of_repo ~path ~(repo : Store.Sync.db Lwt.t) =
let tree = Lwt_main.run (repo >>= Store.S.tree) in
{ path; tree; repo }
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 }
{
path;
tree = Store.S.Tree.singleton path str;
repo =
( Store.S.Repo.v (Irmin_mem.config ()) >>= fun repo' ->
Option.value ~default:Store.S.(empty repo') repo );
}
let insert_uchar t n uc : t Lwt.t =
F.epr "TextBuffer.insert_uchar %d %a@." n pp_uchar uc;
@ -361,13 +365,14 @@ end
let pp_color : Gv.Color.t Fmt.t =
F.(
record
[
field "r" (fun (s : Gv.Color.t) -> s.r) float;
field "g" (fun (s : Gv.Color.t) -> s.g) float;
field "b" (fun (s : Gv.Color.t) -> s.b) float;
field "a" (fun (s : Gv.Color.t) -> s.a) float;
])
hbox
@@ record
[
field "r" (fun (s : Gv.Color.t) -> s.r) float;
field "g" (fun (s : Gv.Color.t) -> s.g) float;
field "b" (fun (s : Gv.Color.t) -> s.b) float;
field "a" (fun (s : Gv.Color.t) -> s.a) float;
])
module TextLayout = struct
open Gg
@ -386,6 +391,26 @@ module TextLayout = struct
valign : align;
}
type text_wrapping = {
max_width : float;
max_rows : int;
break_anywhere : bool;
overflow_character : string option;
}
type section = { byte_range : int * int; format : text_format }
type layout = {
text : TextBuffer.t;
sections : section list;
wrap : text_wrapping;
halign : align;
justify : bool;
line_height : float option;
}
type cursor = { index : int; last_col : int }
let pp_text_format : text_format F.t =
F.(
record
@ -394,7 +419,9 @@ module TextLayout = struct
field "extra_letter_spacing"
(fun s -> s.extra_letter_spacing)
float;
field "line_height" (fun s -> s.line_height) (option float);
field "line_height"
(fun (s : text_format) -> s.line_height)
(option float);
field "color" (fun s -> s.color) pp_color;
field "background" (fun s -> s.background) pp_color;
])
@ -415,13 +442,6 @@ module TextLayout = struct
let text_format_simple font_id color : text_format =
{ text_format_default with font_id; color }
type text_wrapping = {
max_width : float;
max_rows : int;
break_anywhere : bool;
overflow_character : string option;
}
let pp_text_wrapping =
F.(
record
@ -443,42 +463,20 @@ module TextLayout = struct
overflow_character = Some "…";
}
type layout_section = {
leading_space : float;
byte_range : int * int;
format : text_format;
}
let pp_layout_section : Format.formatter -> 'a -> unit =
let pp_section : Format.formatter -> 'a -> unit =
F.(
record
[
field "leading_space" (fun s -> s.leading_space) float;
field "byte_range"
(fun s -> s.byte_range)
(pair ~sep:(any ",") int int);
field "format" (fun s -> s.format) pp_text_format;
])
let layout_section_default =
{
leading_space = 0.0;
byte_range = (0, 0);
format = text_format_default;
}
let section_default =
{ byte_range = (0, 0); format = text_format_default }
type layout_job = {
text : TextBuffer.t;
sections : layout_section array;
wrap : text_wrapping;
first_row_min_height : float;
break_on_newline : bool;
halign : align;
justify : bool;
line_height : float option;
}
let pp_layout_job =
let pp_layout =
F.(
record
[
@ -487,62 +485,22 @@ module TextLayout = struct
string;
field "sections"
(fun s -> s.sections)
(brackets @@ array pp_layout_section);
(brackets @@ list pp_section);
field "wrap" (fun s -> s.wrap) pp_text_wrapping;
field "first_row_min_height"
(fun s -> s.first_row_min_height)
float;
field "break_on_newline" (fun s -> s.break_on_newline) bool;
field "halign" (fun s -> s.halign) Align.pp_t;
field "justify" (fun s -> s.justify) bool;
])
let layout_job_of_text text =
let layout_default =
{
text;
sections = Array.make 0 layout_section_default;
text = TextBuffer.of_string ~path:[] "";
sections = [ section_default ];
wrap = default_text_wrapping ();
first_row_min_height = 0.0;
break_on_newline = true;
halign = Min;
justify = false;
line_height = Some 18.;
}
type uv_rect = {
offset : Gg.v2;
size : Gg.v2;
min : Gg.p2; (* Top left corner UV in texture *)
max : Gg.p2; (* Bottom right corner (exclusive) *)
}
type glyph = {
chr : string;
pos : Gg.p2;
ascent : float;
size : Gg.size2;
uv_rect : uv_rect;
section_index : int;
}
type row_visuals = {
(* mesh : mesh; *)
mesh_bounds : Gg.box2;
glyph_vertex_range : int * int;
}
let pp_row_visuals =
F.(
record
[
field "mesh_bounds"
(fun (s : row_visuals) -> s.mesh_bounds)
Gg.Box2.pp;
field "glyph_vertex_range"
(fun (s : row_visuals) -> s.glyph_vertex_range)
(pair ~sep:(any ",") int int);
])
let pp_text_row : Format.formatter -> Gv.Text.text_row -> unit =
F.(
record
@ -558,139 +516,24 @@ module TextLayout = struct
field "maxx" (fun (s : Gv.Text.text_row) -> s.maxx) float;
])
type row = {
text_row : Gv.Text.text_row;
section_index_at_start : int;
glyphs : glyph list;
rect : Gg.box2;
visuals : row_visuals;
ends_with_newline : bool;
}
let pp_row : Format.formatter -> row -> unit =
F.(
record
[
field "text_row" (fun s -> s.text_row) pp_text_row;
field "section_index_at_start"
(fun (s : row) -> s.section_index_at_start)
int;
field "format" (fun (s : row) -> List.length s.glyphs) int;
field "rect" (fun (s : row) -> s.rect) Gg.Box2.pp;
field "visuals" (fun (s : row) -> s.visuals) pp_row_visuals;
field "ends_with_newline"
(fun (s : row) -> s.ends_with_newline)
bool;
])
let row_default () =
{
text_row =
{
start_index = 0;
end_index = 0;
width = 0.;
minx = 0.;
maxx = 0.;
next = 0;
};
section_index_at_start = 0;
glyphs = [];
rect = Box2.zero;
visuals =
{ mesh_bounds = Box2.zero; glyph_vertex_range = (0, 0) };
ends_with_newline = false;
}
type galley = {
job : layout_job;
rows : row array;
elided : bool;
rect : Gg.box2;
mesh_bounds : Gg.box2;
num_vertices : int;
num_indices : int;
pixels_per_point : float;
}
type rich_text = {
text : string;
size : float option;
extra_letter_spacing : float;
line_height : float option;
font : string option;
background_color : Gv.Color.t;
text_color : Gv.Color.t;
code : bool;
strong : bool;
weak : bool;
strikethrough : bool;
underline : bool;
italics : bool;
raised : bool;
}
let rich_text_default =
{
text = "";
size = None;
extra_letter_spacing = 0.0;
line_height = None;
font = None;
background_color = Gv.Color.transparent;
text_color = Gv.Color.rgbf ~r:0.9 ~g:0.9 ~b:0.9;
code = false;
strong = false;
weak = false;
strikethrough = false;
underline = false;
italics = false;
raised = false;
}
type widget_text =
| RichText of rich_text
| LayoutJob of layout_job
| Galley of galley
type cursor = {
index : int;
row : int option;
last_col : int;
prefer_next_row : bool;
}
let cursor_default =
{ index = 0; row = None; last_col = 0; prefer_next_row = false }
let cursor_default = { index = 0; last_col = 0 }
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 }
{ index; last_col }
let simple text ?(format = text_format_default) wrap_width :
layout_job Lwt.t =
layout Lwt.t =
TextBuffer.length text >>= fun textlen ->
Lwt.return
{
(layout_job_of_text text) with
sections =
Array.make 1
{ leading_space = 0.0; byte_range = (0, textlen); format };
layout_default with
text;
sections = [ { 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 Lwt.t =
simple text ~format Float.infinity >>= fun simple ->
Lwt.return
{
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.)
@ -702,139 +545,55 @@ module TextLayout = struct
{ f with background = Gv.Color.rgbf ~r:0.3 ~g:0.3 ~b:0.3 }
let with_range ((cs, ce) : int * int)
?(cursor_format = default_cursor_formatter) layout_job :
layout_job =
(* this is more like a general range application to layout sections, but i don't need it yet *)
?(format = default_cursor_formatter) layout : layout =
{
layout_job with
layout with
sections =
Array.of_list
(* Lol maybe this is inefficient? (or maybe not) *)
(List.fold_left
(fun (l : layout_section list) sec ->
let s, e = sec.byte_range in
List.fold_left
(fun (l : section list) sec ->
let s, e = sec.byte_range in
l
@ (if
e < cs || ce < s
(* cursor start is after this section or cursor end is before this section *)
then [ sec ]
else [])
@ (if
cs > s
&& cs
<= e (* if cursor start is in this section *)
then [ { sec with byte_range = (s, cs) } ]
else [])
@ (if
cs <= e && ce >= s
(* if cursor start is at or before the end this section and cursor end is at or after the beginning of this section *)
then
[
{
sec with
format = cursor_format sec.format;
byte_range = (max cs s, min ce e);
};
]
else [])
@
if
ce > s
&& ce <= e (* if cursor end is in this section *)
then [ { sec with byte_range = (ce, e) } ]
l
@ (if
e < cs || ce < s
(* cursor start is after this section or cursor end is before this section *)
then [ sec ]
else [])
[]
(Array.to_list layout_job.sections));
@ (if
cs > s
&& cs <= e (* if cursor start is in this section *)
then [ { sec with byte_range = (s, cs) } ]
else [])
@ (if
cs <= e && ce >= s
(* if cursor start is at or before the end this section and cursor end is at or after the beginning of this section *)
then
[
{
format = format sec.format;
byte_range = (max cs s, min ce e);
};
]
else [])
@
if
ce > s && ce <= e (* if cursor end is in this section *)
then [ { sec with byte_range = (ce, e) } ]
else [])
[] layout.sections;
}
let with_cursor (cur : cursor)
?(cursor_format = default_cursor_formatter) layout_job :
layout_job =
let c =
with_range (cur.index, cur.index + 1) ~cursor_format layout_job
in
let with_cursor (cur : cursor) ?(format = default_cursor_formatter)
layout : layout =
let c = with_range (cur.index, cur.index + 1) ~format layout in
c
let with_mark (mark : int option) (cur : int)
?(cursor_format = default_mark_formatter) layout_job :
layout_job =
?(format = default_mark_formatter) layout : layout =
match mark with
| Some mark' ->
with_range ~cursor_format
(min mark' cur, max mark' cur)
layout_job
| None -> layout_job
let layout (gv : Gv.t) (fonts : Fonts.t) (job : layout_job)
(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 ());
rect = Box2.move pos Box2.zero;
mesh_bounds = Box2.zero;
elided = true;
num_vertices = 0;
num_indices = 0;
pixels_per_point = fonts.pixels_per_point;
}
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 contents
in
(* F.epr "row_count=%d@." row_count; *)
let height = ref (V2.y pos) in
let max_width = ref 0. in
let line_height =
Option.value ~default:metrics.line_height job.line_height
in
Lwt.return
{
job;
rows =
Array.init row_count (fun n ->
let text_row = Array.get lines n in
height := !height +. line_height;
let rect =
Box2.v
(P2.v (V2.x pos) !height)
(P2.v
(text_row.width +. V2.x pos)
(!height +. line_height))
in
max_width := Float.max text_row.maxx !max_width;
{
text_row;
section_index_at_start = 0;
glyphs = [ (* TODO *) ];
rect;
visuals =
{
mesh_bounds = rect;
glyph_vertex_range =
(text_row.start_index, text_row.end_index);
};
ends_with_newline = false (* TODO *);
});
rect =
Box2.v Size2.zero
(P2.v job.wrap.max_width
(Float.of_int row_count *. line_height));
elided = row_count > job.wrap.max_rows (* TODO *);
mesh_bounds = Box2.v Size2.zero (P2.v !max_width !height);
num_indices = 0 (* TODO *);
num_vertices = 0 (* TODO *);
pixels_per_point = fonts.pixels_per_point;
}
with_range ~format (min mark' cur, max mark' cur) layout
| None -> layout
end
let rec nth_tl n = function
@ -907,7 +666,6 @@ module Ui = struct
let id = ref 0
let spacing ui = ui.style.spacing
let fonts ui (reader : Gv.t -> 'a) : 'a = reader ui
let allocate_space (_gv : Gv.t) (size : Gg.box2) : id * Gg.box2 =
id := !id + 1;
@ -971,8 +729,8 @@ module TextEdit = struct
id : id option;
id_source : id option;
text_format : TextLayout.text_format;
layouter :
(Ui.t -> TextBuffer.t -> float -> TextLayout.galley) option;
formatter :
(Ui.t -> TextBuffer.t -> float -> TextLayout.layout) option;
password : bool;
frame : bool;
margin : margin;
@ -1216,7 +974,7 @@ module TextEdit = struct
id = None;
id_source = None;
text_format;
layouter = None;
formatter = None;
password = false;
frame = true;
margin = Margin.symmetric 4.0 2.0;
@ -1430,60 +1188,71 @@ module Painter = struct
Text.set_size t ~size:font_size;
Text.set_align t ~align:Align.(left lor top)
let paint_galley (t : Gv.t) (g : TextLayout.galley) : box2 Lwt.t =
TextBuffer.contents g.job.text >>= fun contents ->
let text_layout (t : Gv.t) (rect : box2) (g : TextLayout.layout) :
box2 Lwt.t =
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
let lines = Gv.Text.make_empty_rows max_rows in
TextBuffer.contents g.text >>= fun contents ->
let contents_len = String.length contents in
g.rows
|> ( Array.iter @@ fun (row : TextLayout.row) ->
let sections =
List.filter
(fun (r : TextLayout.layout_section) ->
fst r.byte_range <= row.text_row.end_index
&& snd r.byte_range > row.text_row.start_index)
Array.(
to_list
@@ sub g.job.sections row.section_index_at_start
@@ (length g.job.sections - row.section_index_at_start))
in
assert (List.length sections > 0);
let y = Box2.miny row.rect in
List.fold_left
(fun x (sec : TextLayout.layout_section) ->
let start, end_ =
Stdlib.
( row.text_row.start_index
|> max (fst sec.byte_range)
|> min contents_len,
row.text_row.end_index |> min contents_len
|> min (snd sec.byte_range) )
in
let metrics = Gv.Text.metrics t in
let bounds =
if start == row.text_row.end_index then
(* hack to display cursor at end of row *)
Gv.Text.bounds t ~x ~y:0. " "
else Gv.Text.bounds t ~x ~y:0. ~start ~end_ contents
in
let line_height =
Option.value ~default:metrics.line_height
sec.format.line_height
in
draw_box t
~box:
Box2.(v (V2.v x y) (V2.v bounds.advance line_height))
~style:
Layout.Style.
{ default with fill = sec.format.background };
set_text_format t sec.format;
Gv.set_fill_color t ~color:sec.format.color;
Gv.Text.text_w t ~x ~y ~start ~end_ contents)
(Box2.minx row.rect) sections
|> ignore )
|> ignore;
Lwt.return g.rect
let row_count =
Gv.Text.break_lines t ~break_width:(Box2.w rect) ~max_rows
~lines contents
in
Seq.fold_left
(fun (cur : p2) (row : Gv.Text.text_row) ->
let sections =
List.filter
(fun (r : TextLayout.section) ->
fst r.byte_range <= row.end_index
&& snd r.byte_range > row.start_index)
g.sections
in
List.fold_left
(fun (cur' : p2) (sec : TextLayout.section) ->
let start, end_ =
( row.start_index
|> max (fst sec.byte_range)
|> min contents_len,
row.end_index |> min contents_len
|> min (snd sec.byte_range) )
in
let bounds =
if start == row.end_index then
(* hack to display cursor at end of row *)
Gv.Text.bounds t ~x:(P2.x cur') ~y:0. " "
else
Gv.Text.bounds t ~x:(P2.x cur') ~y:0. ~start ~end_
contents
in
let line_height =
Option.value ~default:(Gv.Text.metrics t).line_height
sec.format.line_height
in
draw_box t
~box:
(Box2.v
(V2.v (P2.x cur') (P2.y cur))
(V2.v bounds.advance line_height))
~style:
Layout.Style.
{ default with fill = sec.format.background };
set_text_format t sec.format;
Gv.set_fill_color t ~color:sec.format.color;
V2.v
(Gv.Text.text_w t ~x:(P2.x cur') ~y:(P2.y cur) ~start
~end_ contents)
Float.(max (P2.y cur +. line_height) (P2.y cur')))
P2.(v (Box2.minx rect) (y cur))
sections
|> fun cur'' -> V2.(v (max (x cur) (x cur'')) (y cur'')))
(Box2.o rect)
(Seq.take row_count (Array.to_seq lines))
|> Box2.(of_pts (o rect))
|> Lwt.return
let rec layout (box : box2) (ui : Ui.t) (frame : frame) : box2 Lwt.t
=
@ -1494,38 +1263,25 @@ module Painter = struct
(fun (c : box2) f ->
layout c ui f >>= fun r ->
let c' =
let open Box2 in
match dir with
| `V -> Box2.of_pts (V2.v (minx c) (maxy r)) (max c)
| `H -> Box2.of_pts (V2.v (maxx r) (miny c)) (max c)
| `Z -> box
Box2.(
match dir with
| `V -> of_pts (V2.v (minx c) (maxy r)) (max c)
| `H -> of_pts (V2.v (maxx r) (miny c)) (max c)
| `Z -> box)
in
Lwt.return c')
box' ll
| `TextEdit t ->
let font =
match Gv.Text.find_font ui.gv ~name:"mono" with
| Some gv -> Fonts.{ gv; pixels_per_point = 1.0 }
| None -> failwith "can't find font 'mono'"
in
(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)
>>= fun layout_job ->
Ui.fonts ui.gv
TextLayout.(
fun gv ->
(layout gv font
(with_cursor t.cursor
(with_mark t.mark t.cursor.index layout_job)))
(Box2.o box'))
>>= fun galley -> paint_galley ui.gv galley
TextLayout.(
simple t.text ~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')
| _ -> Lwt.return box)
>>= fun r ->
F.epr "@[<v>layout@;box=%a@;box'=%a@;r=%a@;%a@]@." Box2.pp box
Box2.pp box' Box2.pp r pp_frame frame;
draw_box ui.gv ~box:r ~style:frame.style;
Lwt.return r
let r' = Margin.outer frame.style.margin r in
draw_box ui.gv ~box:r' ~style:frame.style;
Lwt.return r'
end

20
oplevel.ml
View File

@ -69,13 +69,12 @@ let () =
(* Thread which is woken up when the main window is closed. *)
let _waiter, _wakener = Lwt.wait () in
F.pr "oplevel.ml: Toploop.initialize_toplevel_env@.";
Toploop.initialize_toplevel_env ();
(* F.pr "oplevel.ml: Toploop.initialize_toplevel_env@.";
Toploop.initialize_toplevel_env (); *)
let rootrepo =
Lwt_main.run
(Store.init_default
(F.str "%s/console/rootstore.git" Secrets.giturl))
Store.init_default
(F.str "%s/console/rootstore.git" Secrets.giturl)
in
let ui =
@ -86,10 +85,6 @@ let () =
~f:
(Some
(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; *)
Lwt.async (fun () ->
Ogui.Ui.keycallback ui state key mods >>= fun _ ->
Lwt.return_unit)))
@ -99,13 +94,6 @@ let () =
~f:
(Some
(fun _window ch ->
(* 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); *)
Lwt.async (fun () ->
Ogui.Ui.chrcallback ui ch >>= fun _ -> Lwt.return_unit)))
|> ignore;