1392 lines
38 KiB
OCaml
1392 lines
38 KiB
OCaml
open Lwt.Infix
|
|
module Gv = Graphv_gles2_native
|
|
module F = Fmt
|
|
|
|
type stroke = { width : float; color : Gv.Color.t }
|
|
|
|
let stroke_none = { width = 0.; color = Gv.Color.transparent }
|
|
|
|
module Margin = struct
|
|
open Gg
|
|
|
|
type t = {
|
|
left : size1;
|
|
right : size1;
|
|
top : size1;
|
|
bottom : size1;
|
|
}
|
|
|
|
let symmetric h w = { left = w; right = w; top = h; bottom = h }
|
|
let sum t : size2 = Size2.v (t.left +. t.right) (t.top +. t.bottom)
|
|
|
|
let inner t b : box2 =
|
|
Box2.v
|
|
(V2.v (Box2.minx b +. t.left) (Box2.miny b +. t.top))
|
|
(V2.v (Box2.maxx b -. t.right) (Box2.maxy b -. t.bottom))
|
|
end
|
|
|
|
type margin = Margin.t
|
|
|
|
let string_of_utf_8_uchar uc =
|
|
Buffer.(
|
|
let b = create 4 in
|
|
add_utf_8_uchar b uc;
|
|
contents b)
|
|
|
|
let pp_uchar : Uchar.t F.t =
|
|
fun ppf u -> F.pf ppf "%s" (string_of_utf_8_uchar u)
|
|
|
|
module Sense = struct
|
|
type t = {
|
|
click : bool;
|
|
drag : bool;
|
|
focusable : bool;
|
|
edit : bool;
|
|
}
|
|
|
|
let click =
|
|
{ click = true; drag = false; focusable = true; edit = false }
|
|
|
|
let hover =
|
|
{ click = false; drag = false; focusable = true; edit = false }
|
|
end
|
|
|
|
module TextBuffer = struct
|
|
type t =
|
|
| Tree of {
|
|
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 }
|
|
|
|
let buffer ~name ~buf = Buffer { name; buf }
|
|
|
|
let insert_uchar t n uc : t Lwt.t =
|
|
F.epr "TextBuffer.insert_uchar %d %s" n (string_of_utf_8_uchar uc);
|
|
match t with
|
|
| Tree ({ path; tree; _ } as tt) ->
|
|
Store.S.Tree.update tree path (function
|
|
| Some src ->
|
|
assert (n <= String.length src);
|
|
let ucbuf = Bytes.create 8 in
|
|
let uclen = Bytes.set_utf_8_uchar ucbuf 0 uc in
|
|
let dst = Bytes.create (String.length src + uclen) in
|
|
BytesLabels.blit_string ~src ~src_pos:0 ~dst ~dst_pos:0
|
|
~len:n;
|
|
BytesLabels.blit ~src:ucbuf ~src_pos:0 ~dst ~dst_pos:n
|
|
~len:uclen;
|
|
BytesLabels.blit_string ~src ~src_pos:n ~dst
|
|
~dst_pos:(n + uclen)
|
|
~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
|
|
|
|
let contents = function
|
|
| Tree { 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
|
|
| Buffer { buf; _ } -> Lwt.return (Buffer.contents buf)
|
|
|
|
let length = function
|
|
| Tree { 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
|
|
type key_action = GLFW.key_action
|
|
type key = GLFW.key
|
|
type key_mod = GLFW.key_mod
|
|
type event = Key of key_action * key * key_mod list
|
|
|
|
(* Stolen from zed_input.ml *)
|
|
module EventMap = Map.Make (struct
|
|
type t = event
|
|
|
|
let compare = compare
|
|
end)
|
|
|
|
type 'a t = 'a node EventMap.t
|
|
and 'a node = Set of 'a t | Val of 'a
|
|
|
|
let empty = EventMap.empty
|
|
|
|
let rec add (events : event list) value set =
|
|
match events with
|
|
| [] -> invalid_arg "Event.add"
|
|
| [ event ] -> EventMap.add event (Val value) set
|
|
| event :: events -> (
|
|
match
|
|
try Some (EventMap.find event set) with Not_found -> None
|
|
with
|
|
| None | Some (Val _) ->
|
|
EventMap.add event (Set (add events value empty)) set
|
|
| Some (Set s) ->
|
|
EventMap.add event (Set (add events value s)) set)
|
|
|
|
let rec adds (events : event list list) value set =
|
|
List.fold_left (fun s e -> add e value s) set events
|
|
|
|
let rec remove events set =
|
|
match events with
|
|
| [] -> invalid_arg "Event.remove"
|
|
| [ event ] -> EventMap.remove event set
|
|
| event :: events -> (
|
|
match
|
|
try Some (EventMap.find event set) with Not_found -> None
|
|
with
|
|
| None | Some (Val _) -> set
|
|
| Some (Set s) ->
|
|
let s = remove events s in
|
|
if EventMap.is_empty s then EventMap.remove event set
|
|
else EventMap.add event (Set s) set)
|
|
|
|
let fold f set acc =
|
|
let rec loop prefix set acc =
|
|
EventMap.fold
|
|
(fun event node acc ->
|
|
match node with
|
|
| Val v -> f (List.rev (event :: prefix)) v acc
|
|
| Set s -> loop (event :: prefix) s acc)
|
|
set acc
|
|
in
|
|
loop [] set acc
|
|
|
|
let bindings set =
|
|
List.rev
|
|
(fold (fun events action l -> (events, action) :: l) set [])
|
|
|
|
module type Pack = sig
|
|
type a
|
|
type b
|
|
|
|
val set : a t
|
|
val map : a -> b
|
|
end
|
|
|
|
type 'a pack = (module Pack with type b = 'a)
|
|
type 'a resolver = 'a pack list
|
|
|
|
let pack (type u v) map set =
|
|
let module Pack = struct
|
|
type a = u
|
|
type b = v
|
|
|
|
let set = set
|
|
let map = map
|
|
end in
|
|
(module Pack : Pack with type b = v)
|
|
|
|
let resolver l = l
|
|
|
|
type 'a result =
|
|
| Accepted of 'a
|
|
| Continue of 'a resolver
|
|
| Rejected
|
|
|
|
let rec resolve_rec :
|
|
'a. event -> 'a pack list -> 'a pack list -> 'a result =
|
|
fun (type u) event acc packs ->
|
|
match packs with
|
|
| [] -> if acc = [] then Rejected else Continue (List.rev acc)
|
|
| p :: packs -> (
|
|
let module Pack = (val p : Pack with type b = u) in
|
|
match
|
|
try Some (EventMap.find event Pack.set)
|
|
with Not_found -> None
|
|
with
|
|
| Some (Set set) ->
|
|
resolve_rec event (pack Pack.map set :: acc) packs
|
|
| Some (Val v) -> Accepted (Pack.map v)
|
|
| None -> resolve_rec event acc packs)
|
|
|
|
let resolve event sets = resolve_rec event [] sets
|
|
|
|
include Glfw_types
|
|
|
|
let pp_event : event F.t =
|
|
fun ppf e ->
|
|
let open Glfw_types in
|
|
match e with
|
|
| Key (a, k, m) ->
|
|
F.pf ppf "Key %a, %a, %a" pp_key_action a pp_key k pp_mods m
|
|
(* | Char u -> F.pf ppf "Char %a" pp_uchar u
|
|
| AnyChar -> F.pf ppf "AnyChar" *)
|
|
end
|
|
|
|
type event = Event.event
|
|
type id = int
|
|
|
|
module Context = struct
|
|
type t = { derp : bool }
|
|
end
|
|
|
|
module Response = struct
|
|
type t = {
|
|
ctx : Context.t;
|
|
(* layer_id : LayerId.t; *)
|
|
id : id;
|
|
rect : Gg.box2;
|
|
interact_rect : Gg.box2;
|
|
sense : Sense.t;
|
|
enabled : bool;
|
|
contains_pointer : bool;
|
|
hovered : bool;
|
|
highlighted : bool;
|
|
clicked : bool;
|
|
fake_primary_click : bool;
|
|
long_touched : bool;
|
|
drag_started : bool;
|
|
dragged : bool;
|
|
drag_stopped : bool;
|
|
is_pointer_button_down_on : bool;
|
|
interact_pointer_pos : Gg.p2 option;
|
|
changed : bool;
|
|
}
|
|
end
|
|
|
|
module Align = struct
|
|
open Gg
|
|
|
|
type range = size1 * size1
|
|
|
|
type t =
|
|
| Min (* Left or top. *)
|
|
| Center (* Horizontal or vertical center *)
|
|
| Max (* Right or bottom *)
|
|
|
|
let pp_t ppf =
|
|
F.(
|
|
function
|
|
| Min -> pf ppf "Min"
|
|
| Center -> pf ppf "Center"
|
|
| Max -> pf ppf "Max")
|
|
|
|
let size_within_rect (size : size2) (frame : box2) : box2 =
|
|
let size_within_range (size : size1) (range : range) : range =
|
|
let min, max = range in
|
|
if max -. min == Float.infinity && size == Float.infinity then
|
|
range
|
|
else range
|
|
in
|
|
let x_range =
|
|
size_within_range (P2.x size) (Box2.minx frame, Box2.maxx frame)
|
|
in
|
|
let y_range =
|
|
size_within_range (P2.y size) (Box2.miny frame, Box2.maxy frame)
|
|
in
|
|
Box2.v
|
|
(P2.v (fst x_range) (fst y_range))
|
|
(P2.v (snd x_range) (snd y_range))
|
|
end
|
|
|
|
type align = Align.t
|
|
|
|
module Fonts = struct
|
|
open Gg
|
|
|
|
let pixels_per_point = ref 1.0
|
|
|
|
type t = { gv : Gv.Text.font; pixels_per_point : size1 }
|
|
|
|
let find_font gv name : t option =
|
|
Option.fold
|
|
~some:(fun gv ->
|
|
Some { gv; pixels_per_point = !pixels_per_point })
|
|
~none:None
|
|
(Gv.Text.find_font gv ~name)
|
|
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;
|
|
])
|
|
|
|
module TextLayout = struct
|
|
open Gg
|
|
|
|
type font_selection = Default | FontId of (string * float)
|
|
|
|
type text_format = {
|
|
font_id : font_selection;
|
|
extra_letter_spacing : float;
|
|
line_height : float option;
|
|
color : Gv.Color.t;
|
|
background : Gv.Color.t;
|
|
italics : bool;
|
|
underline : stroke;
|
|
strikethrough : stroke;
|
|
valign : align;
|
|
}
|
|
|
|
let pp_text_format : text_format F.t =
|
|
F.(
|
|
record
|
|
[
|
|
field "font_id" (fun _ -> "...") string;
|
|
field "extra_letter_spacing"
|
|
(fun s -> s.extra_letter_spacing)
|
|
float;
|
|
field "line_height" (fun s -> s.line_height) (option float);
|
|
field "color" (fun s -> s.color) pp_color;
|
|
field "background" (fun s -> s.background) pp_color;
|
|
])
|
|
|
|
let text_format_default =
|
|
{
|
|
font_id = FontId ("mono", 18.0);
|
|
extra_letter_spacing = 0.0;
|
|
line_height = Some 19.;
|
|
color = Gv.Color.rgbf ~r:0.9 ~g:0.9 ~b:0.9;
|
|
background = Gv.Color.transparent;
|
|
italics = false;
|
|
underline = stroke_none;
|
|
strikethrough = stroke_none;
|
|
valign = Max;
|
|
}
|
|
|
|
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
|
|
[
|
|
field "max_width" (fun s -> s.max_width) float;
|
|
field "max_rows" (fun s -> s.max_rows) int;
|
|
field "break_anywhere" (fun s -> s.break_anywhere) bool;
|
|
field "overflow_character"
|
|
(fun s -> s.overflow_character)
|
|
(option string);
|
|
])
|
|
|
|
let default_text_wrapping () =
|
|
{
|
|
max_width = Float.infinity;
|
|
max_rows = 100;
|
|
(* TODO *)
|
|
break_anywhere = false;
|
|
overflow_character = Some "…";
|
|
}
|
|
|
|
type layout_section = {
|
|
leading_space : float;
|
|
byte_range : int * int;
|
|
format : text_format;
|
|
}
|
|
|
|
let pp_layout_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;
|
|
}
|
|
|
|
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 =
|
|
F.(
|
|
record
|
|
[
|
|
field "text"
|
|
(fun s -> Lwt_main.run (TextBuffer.length s.text))
|
|
int;
|
|
field "sections"
|
|
(fun s -> s.sections)
|
|
(array pp_layout_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 default_layout_job () =
|
|
{
|
|
text =
|
|
TextBuffer.buffer ~name:"default_layout_job"
|
|
~buf:(Buffer.create 32);
|
|
sections = Array.make 0 layout_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
|
|
[
|
|
field "start_index"
|
|
(fun (s : Gv.Text.text_row) -> s.start_index)
|
|
int;
|
|
field "end_index"
|
|
(fun (s : Gv.Text.text_row) -> s.end_index)
|
|
int;
|
|
field "width" (fun (s : Gv.Text.text_row) -> s.width) float;
|
|
field "minx" (fun (s : Gv.Text.text_row) -> s.minx) float;
|
|
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;
|
|
prefer_next_row : bool;
|
|
}
|
|
|
|
let cursor_default =
|
|
{ index = 0; row = None; prefer_next_row = false }
|
|
|
|
type cursor_range = cursor * cursor
|
|
type cursor_state = cursor_range option
|
|
|
|
let cursor_index = ref 0
|
|
let cursor_range c = ((fst c).index, (snd c).index)
|
|
|
|
let new_cursor ?(loc = 0) () : cursor =
|
|
cursor_index := !cursor_index + 1;
|
|
{ index = loc; row = None; prefer_next_row = false }
|
|
|
|
let new_cursor_range (s, e) : cursor_range =
|
|
( { cursor_default with index = s },
|
|
{ cursor_default with index = e } )
|
|
|
|
let cursor_state_update ~(f : int -> int -> int * int)
|
|
(c : cursor_state) : cursor_state =
|
|
match c with
|
|
| Some (a, b) ->
|
|
let a', b' = f a.index b.index in
|
|
F.epr "cursor_state_update %d %d@." a' b';
|
|
Some (new_cursor_range (max a' 0, max b' 0))
|
|
| None -> None
|
|
|
|
let layout_job text ?(format = text_format_default) wrap_width :
|
|
layout_job =
|
|
{
|
|
(default_layout_job ()) with
|
|
text;
|
|
sections =
|
|
Array.make 1
|
|
{
|
|
leading_space = 0.0;
|
|
byte_range = (0, Lwt_main.run (TextBuffer.length text));
|
|
format;
|
|
};
|
|
wrap =
|
|
{ (default_text_wrapping ()) with max_width = wrap_width };
|
|
break_on_newline = true;
|
|
}
|
|
|
|
let simple (text : TextBuffer.t) (format : text_format) wrap_width :
|
|
layout_job =
|
|
{
|
|
(default_layout_job ()) with
|
|
text;
|
|
sections =
|
|
Array.make 1
|
|
{
|
|
leading_space = 0.0;
|
|
byte_range = (0, Lwt_main.run (TextBuffer.length text));
|
|
format;
|
|
};
|
|
wrap =
|
|
{ (default_text_wrapping ()) with max_width = wrap_width };
|
|
break_on_newline = true;
|
|
}
|
|
|
|
let simple_singleline (text : TextBuffer.t) (format : text_format) :
|
|
layout_job =
|
|
{
|
|
(default_layout_job ()) with
|
|
text;
|
|
sections =
|
|
Array.make 1
|
|
{
|
|
leading_space = 0.0;
|
|
byte_range = (0, Lwt_main.run (TextBuffer.length text));
|
|
format;
|
|
};
|
|
wrap = default_text_wrapping ();
|
|
break_on_newline = true;
|
|
}
|
|
|
|
let cursor_color = ref (Gv.Color.rgbf ~r:0.9 ~g:0.9 ~b:0.)
|
|
|
|
let default_cursor_formatter (f : text_format) =
|
|
{ f with background = !cursor_color }
|
|
|
|
let with_cursor (cur : cursor_range)
|
|
?(cursor_format = default_cursor_formatter) layout_job :
|
|
layout_job =
|
|
let cs, ce = ((fst cur).index, (snd cur).index) in
|
|
{
|
|
layout_job 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
|
|
|
|
if e < cs || ce < s then l @ [ sec ]
|
|
else
|
|
l
|
|
@ (if s = cs then
|
|
[
|
|
{
|
|
sec with
|
|
byte_range = (s, if ce > e then e else ce);
|
|
format = cursor_format sec.format;
|
|
};
|
|
]
|
|
else if s < cs && cs <= e then
|
|
(* cursor start in section *)
|
|
[
|
|
{ sec with byte_range = (s, cs) };
|
|
{
|
|
sec with
|
|
byte_range = (cs, if ce > e then e else ce);
|
|
format = cursor_format sec.format;
|
|
};
|
|
]
|
|
else if cs < s && e < ce then
|
|
[
|
|
{ sec with format = cursor_format sec.format };
|
|
]
|
|
else [])
|
|
@
|
|
if ce > s && ce < e then
|
|
[ { sec with byte_range = (ce, e) } ]
|
|
else [])
|
|
[]
|
|
(Array.to_list layout_job.sections));
|
|
}
|
|
|
|
let layout (gv : Gv.t) (fonts : Fonts.t) (job : layout_job)
|
|
(pos : v2) : galley =
|
|
(* 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
|
|
{
|
|
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
|
|
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))
|
|
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
|
|
{
|
|
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;
|
|
}
|
|
end
|
|
|
|
let rec nth_tl n = function
|
|
| hd :: tl -> if n > 0 then nth_tl (n - 1) tl else hd :: tl
|
|
| [] -> []
|
|
|
|
let _ =
|
|
assert (List.equal Int.equal (nth_tl 2 [ 0; 1; 2; 3 ]) [ 2; 3 ]);
|
|
assert (List.equal Int.equal (nth_tl 3 [ 0; 1; 2 ]) []);
|
|
assert (List.equal Int.equal (nth_tl 0 [ 0; 1 ]) [ 0; 1 ])
|
|
|
|
module Painter = struct
|
|
type t = Gv.t
|
|
|
|
let galley (t : t) (g : TextLayout.galley) : unit =
|
|
(* F.epr
|
|
"Painter.galley (String.length g.job.text)=%d (Array.length \
|
|
g.rows)=%d @."
|
|
(String.length g.job.text)
|
|
(Array.length g.rows);
|
|
F.epr "g.rect=%a@." Gg.Box2.pp g.rect; *)
|
|
|
|
(* F.epr "g.rows=%a@." F.(braces (array TextLayout.pp_row)) 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
|
|
@@ Array.sub g.job.sections row.section_index_at_start
|
|
(Array.length g.job.sections
|
|
- row.section_index_at_start))
|
|
in
|
|
assert (List.length sections > 0);
|
|
|
|
ignore
|
|
Gg.(
|
|
List.fold_left
|
|
(fun x (sec : TextLayout.layout_section) ->
|
|
let start, end_ =
|
|
( min
|
|
(Lwt_main.run (TextBuffer.length g.job.text) - 1)
|
|
(max 0
|
|
(max (fst sec.byte_range)
|
|
row.text_row.start_index)),
|
|
min
|
|
(Lwt_main.run (TextBuffer.length g.job.text) - 1)
|
|
(max 0
|
|
(min (snd sec.byte_range)
|
|
row.text_row.end_index)) )
|
|
in
|
|
|
|
let font_name, font_size =
|
|
match sec.format.font_id with
|
|
| Default -> ("mono", 18.)
|
|
| FontId (s, size) -> (s, size)
|
|
in
|
|
let open Gv in
|
|
Text.set_font_face t ~name:font_name;
|
|
Text.set_size t ~size:font_size;
|
|
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))
|
|
in
|
|
Path.begin_ t;
|
|
Path.rect t ~x ~y:(Box2.miny row.rect)
|
|
~w:bounds.advance ~h:metrics.line_height;
|
|
set_fill_color t ~color:sec.format.background;
|
|
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)
|
|
(Box2.minx row.rect) sections))
|
|
g.rows
|
|
end
|
|
|
|
module Style = struct
|
|
open Gg
|
|
|
|
type text_style = unit
|
|
|
|
type spacing = {
|
|
item_spacing : Gg.size2;
|
|
window_margin : Margin.t;
|
|
indent : Gg.size1;
|
|
interact_size : Gg.size2;
|
|
slider_width : Gg.size1;
|
|
text_edit_width : Gg.size1;
|
|
icon_width : Gg.size1;
|
|
icon_width_inner : Gg.size1;
|
|
icon_spacing : Gg.size1;
|
|
}
|
|
|
|
type t = {
|
|
override_text_style : text_style option;
|
|
override_font : TextLayout.font_selection option;
|
|
wrap : bool option;
|
|
spacing : spacing;
|
|
(*interaction: Interaction.t; *)
|
|
animation_time : float;
|
|
}
|
|
|
|
let default =
|
|
{
|
|
override_text_style = None;
|
|
override_font = None;
|
|
wrap = None;
|
|
spacing =
|
|
{
|
|
item_spacing = Size2.v 10. 10.;
|
|
window_margin = Margin.symmetric 5. 5.;
|
|
indent = 5.;
|
|
slider_width = 5.;
|
|
text_edit_width = 500.;
|
|
icon_width = 40.;
|
|
icon_width_inner = 35.;
|
|
icon_spacing = 50.;
|
|
interact_size = P2.v 500. 500.;
|
|
};
|
|
animation_time = 0.1;
|
|
}
|
|
end
|
|
|
|
module Layout = struct
|
|
open Gg
|
|
|
|
type direction = LeftToRight | RightToLeft | TopDown | BottomUp
|
|
|
|
type t = {
|
|
main_dir : direction;
|
|
main_wrap : bool;
|
|
main_align : align;
|
|
main_justify : bool;
|
|
cross_align : align;
|
|
cross_justify : bool;
|
|
}
|
|
|
|
let horizontal =
|
|
{
|
|
main_dir = LeftToRight;
|
|
main_wrap = true;
|
|
main_align = Min;
|
|
main_justify = true;
|
|
cross_align = Min;
|
|
cross_justify = true;
|
|
}
|
|
|
|
let vertical =
|
|
{
|
|
main_dir = TopDown;
|
|
main_wrap = true;
|
|
main_align = Min;
|
|
main_justify = true;
|
|
cross_align = Min;
|
|
cross_justify = true;
|
|
}
|
|
|
|
type region = { min_rect : box2; max_rect : box2; cursor : box2 }
|
|
|
|
let rec is_horizontal = function
|
|
| `Direction d -> (
|
|
match d with
|
|
| LeftToRight | RightToLeft -> true
|
|
| TopDown | BottomUp -> false)
|
|
| `Layout t -> is_horizontal (`Direction t.main_dir)
|
|
|
|
let available_from_cursor_max_rect t cursor max_rect : box2 =
|
|
(* TODO assert !cursor.any_nan() *)
|
|
(* TODO assert !max_rect.any_nan() *)
|
|
(* TODO assert !max_rect.is_finite() *)
|
|
let avail =
|
|
match t.main_dir with
|
|
| LeftToRight ->
|
|
Box2.of_pts
|
|
(V2.v (Box2.minx cursor) (Box2.miny max_rect))
|
|
(V2.v
|
|
Float.(
|
|
max
|
|
(max (Box2.maxx max_rect) (Box2.minx cursor))
|
|
(Box2.minx max_rect))
|
|
Float.(max (Box2.maxy max_rect) (Box2.miny max_rect)))
|
|
| RightToLeft -> Box2.zero (* TODO *)
|
|
| TopDown | BottomUp -> Box2.zero
|
|
in
|
|
let avail = Box2.inter avail cursor in
|
|
|
|
(* todo make sure it isn't negative (won't because Gg.maxx is maxing )*)
|
|
avail
|
|
|
|
let available_size t r =
|
|
if t.main_wrap then
|
|
if is_horizontal (`Direction t.main_dir) then
|
|
V2.v (Box2.w r.max_rect) (Box2.h r.cursor)
|
|
else V2.v (Box2.w r.cursor) (Box2.h r.max_rect)
|
|
else
|
|
Box2.size (available_from_cursor_max_rect t r.cursor r.max_rect)
|
|
|
|
let horizontal_justify (l : t) =
|
|
if is_horizontal (`Layout l) then l.main_justify
|
|
else l.cross_justify
|
|
|
|
module Grid = struct
|
|
type state = {
|
|
col_widths : Gg.size1 list;
|
|
row_heights : Gg.size1 list;
|
|
}
|
|
|
|
type t = {
|
|
id : id;
|
|
is_first_frame : bool;
|
|
prev_state : state;
|
|
initial_available : Gg.size1 option;
|
|
spacing : Gg.v2;
|
|
min_cell_size : Gg.v2;
|
|
max_cell_size : Gg.v2;
|
|
col : int;
|
|
row : int;
|
|
}
|
|
|
|
let available_rect _t _r = Gg.Box2.zero (*TODO*)
|
|
end
|
|
end
|
|
|
|
module Placer = struct
|
|
type t = {
|
|
grid : Layout.Grid.t option;
|
|
layout : Layout.t;
|
|
region : Layout.region;
|
|
}
|
|
|
|
let available_size t =
|
|
match t.grid with
|
|
| Some grid ->
|
|
Gg.Box2.size (Layout.Grid.available_rect grid t.region)
|
|
| None -> Layout.available_size t.layout t.region
|
|
|
|
let create layout region = { grid = None; layout; region }
|
|
end
|
|
|
|
module Ui = struct
|
|
type t = {
|
|
id : id;
|
|
style : Style.t;
|
|
placer : Placer.t;
|
|
enabled : bool;
|
|
gv : Gv.t;
|
|
glfw_window : GLFW.window option;
|
|
mutable bindings : action list Event.t;
|
|
}
|
|
|
|
and action = Custom of (unit -> unit Lwt.t)
|
|
|
|
let id = ref 0
|
|
let spacing ui = ui.style.spacing
|
|
let available_size ui = Placer.available_size ui.placer
|
|
let available_width ui = Gg.P2.x (available_size ui)
|
|
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;
|
|
(!id, size)
|
|
|
|
let cursor_origin (ui : t) = Gg.Box2.o ui.placer.region.max_rect
|
|
|
|
let window gv ?(window : GLFW.window option) rect : t =
|
|
let id, rect = allocate_space gv rect in
|
|
{
|
|
id;
|
|
style = Style.default;
|
|
placer =
|
|
Placer.create Layout.vertical
|
|
Layout.{ min_rect = rect; max_rect = rect; cursor = rect };
|
|
enabled = true;
|
|
gv;
|
|
glfw_window = window;
|
|
bindings = Event.empty;
|
|
}
|
|
|
|
let callback_resolver : action list Event.resolver option ref =
|
|
ref Option.None
|
|
|
|
let keycallback t key state mods : unit =
|
|
let res =
|
|
match !callback_resolver with
|
|
| Some res -> res
|
|
| None -> Event.resolver [ Event.pack Fun.id t.bindings ]
|
|
in
|
|
|
|
ignore
|
|
@@ Lwt_main.run
|
|
((fun () : bool Lwt.t ->
|
|
match Event.resolve (Key (key, state, 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
|
|
| [] -> Lwt.return false
|
|
in
|
|
exec actions
|
|
| Event.Continue res ->
|
|
callback_resolver := Some res;
|
|
Lwt.return true
|
|
| Event.Rejected ->
|
|
callback_resolver := None;
|
|
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
|
|
end
|
|
|
|
module TextEdit = struct
|
|
open Gg
|
|
|
|
type t = {
|
|
mutable text : TextBuffer.t;
|
|
id : id option;
|
|
id_source : id option;
|
|
text_format : TextLayout.text_format;
|
|
layouter :
|
|
(Ui.t -> TextBuffer.t -> float -> TextLayout.galley) option;
|
|
password : bool;
|
|
frame : bool;
|
|
margin : margin;
|
|
multiline : bool;
|
|
interactive : bool;
|
|
desired_width : float option;
|
|
desired_height_rows : int;
|
|
cursor_at_end : bool;
|
|
min_size : Gg.v2;
|
|
align : align;
|
|
clip_text : bool;
|
|
char_limit : int; (* return_key : keyboard_shortcut; *)
|
|
}
|
|
|
|
and state = {
|
|
mutable cursor : TextLayout.cursor_state;
|
|
(* undoer : undoer; *)
|
|
singleline_offset : float;
|
|
last_edit_time : float;
|
|
}
|
|
|
|
let state_mem : (int * state) list ref = ref []
|
|
|
|
let add_bindings (t : t) (ui : Ui.t) (state : state) : unit Lwt.t =
|
|
let open GLFW in
|
|
let open Event in
|
|
let open Ui in
|
|
ui.bindings <-
|
|
empty
|
|
|> adds
|
|
[
|
|
[ Key (Press, F, [ Control ]) ];
|
|
[ Key (Press, Right, []) ];
|
|
]
|
|
[
|
|
Custom
|
|
(fun () ->
|
|
state.cursor <-
|
|
TextLayout.cursor_state_update
|
|
~f:(fun a b -> (a + 1, b + 1))
|
|
state.cursor;
|
|
Lwt.return_unit);
|
|
]
|
|
|> adds
|
|
[
|
|
[ Key (Press, B, [ Control ]) ];
|
|
[ Key (Press, Left, []) ];
|
|
]
|
|
[
|
|
Custom
|
|
(fun () ->
|
|
state.cursor <-
|
|
TextLayout.cursor_state_update
|
|
~f:(fun a b -> (a - 1, b - 1))
|
|
state.cursor;
|
|
Lwt.return_unit);
|
|
]
|
|
|> adds
|
|
[
|
|
[ Key (Press, N, [ Control ]) ];
|
|
[ Key (Press, Down, []) ];
|
|
]
|
|
[
|
|
Custom
|
|
(fun () ->
|
|
state.cursor <-
|
|
TextLayout.cursor_state_update
|
|
~f:(fun a b -> (a - 1, b - 1))
|
|
state.cursor;
|
|
Lwt.return_unit);
|
|
]
|
|
|> adds
|
|
[
|
|
[ Key (Press, P, [ Control ]) ]; [ Key (Press, Up, []) ];
|
|
]
|
|
[
|
|
Custom
|
|
(fun () ->
|
|
state.cursor <-
|
|
TextLayout.cursor_state_update
|
|
~f:(fun a b -> (a - 1, b - 1))
|
|
state.cursor;
|
|
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 ->
|
|
(match state.cursor with
|
|
| Some (_a, b) ->
|
|
TextBuffer.insert_uchar t.text b.index c >>= fun text ->
|
|
t.text <- text;
|
|
Lwt.return_unit
|
|
| None -> Lwt.return_unit)
|
|
>>= fun () -> !Ui.chrcallback_ref c);
|
|
Lwt.return_unit
|
|
|
|
let load_state id =
|
|
match List.assoc_opt id !state_mem with
|
|
| Some state -> state
|
|
| None ->
|
|
let state =
|
|
{
|
|
cursor = Some (TextLayout.new_cursor_range (12, 13));
|
|
singleline_offset = 0.0;
|
|
last_edit_time = 0.0;
|
|
}
|
|
in
|
|
state_mem := (id, state) :: !state_mem;
|
|
state
|
|
|
|
type output = {
|
|
(* response : Response.t; *)
|
|
galley : TextLayout.galley;
|
|
galley_pos : Gg.p2;
|
|
text_clip_rect : Gg.box2;
|
|
state : state;
|
|
cursor_range : TextLayout.cursor_range option;
|
|
}
|
|
|
|
let multiline ?(text_format = TextLayout.text_format_default)
|
|
(text : TextBuffer.t) : t =
|
|
{
|
|
text;
|
|
id = None;
|
|
id_source = None;
|
|
text_format;
|
|
layouter = None;
|
|
password = false;
|
|
frame = true;
|
|
margin = Margin.symmetric 4.0 2.0;
|
|
multiline = true;
|
|
interactive = true;
|
|
desired_width = None;
|
|
desired_height_rows = 4;
|
|
cursor_at_end = true;
|
|
min_size = Gg.V2.zero;
|
|
align = Min;
|
|
clip_text = false;
|
|
char_limit = Int.max_int;
|
|
(* return_key = keyboard_shortcut; *)
|
|
}
|
|
|
|
let show_content (t : t) (ui : Ui.t) : output =
|
|
let state = load_state (Option.value ~default:(-1) t.id) in
|
|
let origin = Ui.cursor_origin ui in
|
|
(* TODO .or(ui.visuals().override_text_color) *)
|
|
(* let row_height = (Gv.Text.metrics ui.gv).line_height in *)
|
|
let available_width =
|
|
Ui.available_width ui -. (t.margin.left +. t.margin.right)
|
|
in
|
|
let desired_width =
|
|
Option.fold ~none:(Ui.spacing ui).text_edit_width ~some:Fun.id
|
|
t.desired_width
|
|
in
|
|
let wrap_width =
|
|
if Layout.horizontal_justify ui.placer.layout then
|
|
available_width
|
|
else Float.min desired_width available_width
|
|
in
|
|
let default_layouter (ui : Ui.t) (text : TextBuffer.t)
|
|
(wrap_width : size1) : TextLayout.galley =
|
|
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
|
|
let layout_job =
|
|
if t.multiline then
|
|
TextLayout.simple text t.text_format wrap_width
|
|
else TextLayout.simple_singleline text t.text_format
|
|
in
|
|
let layout_job =
|
|
TextLayout.with_cursor
|
|
(Option.value
|
|
~default:(TextLayout.new_cursor_range (0, 0))
|
|
state.cursor)
|
|
layout_job
|
|
in
|
|
Ui.fonts ui.gv (fun f ->
|
|
TextLayout.layout f font layout_job origin)
|
|
in
|
|
|
|
let layouter =
|
|
Option.value ~default:default_layouter t.layouter
|
|
in
|
|
let galley = layouter ui t.text wrap_width in
|
|
let galley_size = galley.mesh_bounds in
|
|
let desired_width =
|
|
if t.clip_text then wrap_width
|
|
else Float.max (Size2.w (Box2.size galley_size)) wrap_width
|
|
in
|
|
let desired_inner_size =
|
|
V2.v desired_width (Box2.maxy galley_size)
|
|
in
|
|
let desired_outer_size =
|
|
V2.(desired_inner_size + Margin.sum t.margin)
|
|
in
|
|
let (_auto_id, outer_rect) : id * box2 =
|
|
Ui.allocate_space ui.gv (Box2.v origin desired_outer_size)
|
|
in
|
|
let rect = Margin.inner t.margin outer_rect in
|
|
(* TODO id = ui.make_persistent_id(id_source) else auto_id *)
|
|
(* TODO state = TextEditState::load(ui.ctx(), id)... *)
|
|
(* TODO moved up let state = load_state (Option.value ~default:(-1) t.id) in *)
|
|
(* TODO allow_drag_to_select = ... *)
|
|
let _sense = if t.interactive then Sense.click else Sense.hover in
|
|
|
|
(* let response = Ui.interact ui outer_rect t.id sense in *)
|
|
(* TODO *)
|
|
let text_clip_rect = rect in
|
|
(* let painter = Ui.painter_at ui text_clip_rect in *)
|
|
let cursor_range = None in
|
|
(* TODO cursor_range *)
|
|
let galley_pos =
|
|
Align.size_within_rect (Box2.size galley_size) rect
|
|
in
|
|
|
|
(* if Ui.is_rect_visible ui rect then *)
|
|
Painter.galley ui.gv galley;
|
|
|
|
let _align_offset = rect in
|
|
{
|
|
galley;
|
|
galley_pos = Box2.o galley_pos;
|
|
text_clip_rect;
|
|
state;
|
|
cursor_range;
|
|
}
|
|
|
|
let show (t : t) ui : output =
|
|
let _margin = t.margin in
|
|
let output = show_content t ui in
|
|
(* let _outer_rect = output.response.rect in *)
|
|
output
|
|
end
|