1665 lines
51 KiB
OCaml
1665 lines
51 KiB
OCaml
open Lwt.Infix
|
|
module Gv = Graphv_gles2_native
|
|
module F = Fmt
|
|
module Str = Re.Str
|
|
|
|
let pp_box2 ppf b =
|
|
F.(
|
|
pf ppf "[%a %a]"
|
|
(pair ~sep:(any " ") float float)
|
|
Gg.(Box2.min b |> V2.to_tuple)
|
|
(pair ~sep:(any " ") float float)
|
|
Gg.(Box2.max b |> V2.to_tuple))
|
|
|
|
let pair a b = (a, b)
|
|
|
|
module Lwd = struct
|
|
open Lwt_react
|
|
|
|
type 'a var = 'a React.signal * (?step:React.step -> 'a -> unit)
|
|
type 'a t = 'a React.signal
|
|
|
|
let eq = Stdlib.( == )
|
|
let var ?(eq = eq) (v : 'a) : 'a var = S.create ~eq v
|
|
let get (s, _) : 'a t = s
|
|
let peek (s, _) = S.value s
|
|
let set ?step (_, f) v = f ?step v
|
|
let pure = S.const
|
|
let return = S.return
|
|
let map ?(eq = eq) ~(f : 'a -> 'b) (a : 'a t) : 'b t = S.l1 ~eq f a
|
|
|
|
let map2 ?(eq = eq) ~(f : 'a -> 'b -> 'c) (a : 'a t) (b : 'b t) :
|
|
'c t =
|
|
S.l2 ~eq f a b
|
|
|
|
let map_s ?(eq = eq) ~(f : 'a -> 'b Lwt.t) (a : 'a t) : 'b t Lwt.t =
|
|
S.l1_s ~eq f a
|
|
|
|
let map2_s ?(eq = eq) ~(f : 'a -> 'b -> 'c Lwt.t) (a : 'a t)
|
|
(b : 'b t) : 'c t Lwt.t =
|
|
S.l2_s ~eq f a b
|
|
|
|
let bind ?(eq = eq) (a : 'a t) ~(f : 'a -> 'b t) : 'b t =
|
|
S.bind ~eq a f
|
|
|
|
let join ?(eq = eq) : 'a t t -> 'a t = S.switch ~eq
|
|
|
|
type 'a root = Root of 'a t
|
|
|
|
let observe (t : 'a t) : 'a root = Root t
|
|
let quick_sample = function Root t -> S.value t
|
|
end
|
|
|
|
module Lwd_utils = struct
|
|
(* stolen from Lwd_utils *)
|
|
type 'a monoid = 'a * ('a -> 'a -> 'a)
|
|
|
|
let lift_monoid (zero, plus) = (Lwd.return zero, Lwd.map2 ~f:plus)
|
|
|
|
let map_reduce inj (zero, plus) items =
|
|
let rec cons_monoid c xs v =
|
|
match xs with
|
|
| (c', v') :: xs when c = c' ->
|
|
cons_monoid (c + 1) xs (plus v' v)
|
|
| xs -> (c, v) :: xs
|
|
in
|
|
let cons_monoid xs v = cons_monoid 0 xs (inj v) in
|
|
match List.fold_left cons_monoid [] items with
|
|
| [] -> zero
|
|
| (_, x) :: xs ->
|
|
List.fold_left (fun acc (_, v) -> plus v acc) x xs
|
|
|
|
let reduce monoid items = map_reduce (fun x -> x) monoid items
|
|
|
|
let rec cons_lwd_monoid plus c xs v =
|
|
match xs with
|
|
| (c', v') :: xs when c = c' ->
|
|
cons_lwd_monoid plus (c + 1) xs (Lwd.map2 ~f:plus v' v)
|
|
| xs -> (c, v) :: xs
|
|
|
|
let pack (zero, plus) items =
|
|
match List.fold_left (cons_lwd_monoid plus 0) [] items with
|
|
| [] -> Lwd.return zero
|
|
| (_, x) :: xs ->
|
|
List.fold_left (fun acc (_, v) -> Lwd.map2 ~f:plus v acc) x xs
|
|
end
|
|
|
|
type stroke = { width : float; color : Gv.Color.t }
|
|
|
|
let stroke_none = { width = 0.; color = Gv.Color.transparent }
|
|
|
|
let pp_text_row : Gv.Text.text_row F.t =
|
|
F.(
|
|
record
|
|
[
|
|
field "start_index" (fun r -> Gv.Text.(r.start_index)) int;
|
|
field "end_index" (fun r -> Gv.Text.(r.end_index)) int;
|
|
field "width" (fun r -> Gv.Text.(r.width)) float;
|
|
field "minx" (fun r -> Gv.Text.(r.minx)) float;
|
|
field "maxx" (fun r -> Gv.Text.(r.maxx)) float;
|
|
field "next" (fun r -> Gv.Text.(r.next)) int;
|
|
])
|
|
|
|
let pp_color : Gv.Color.t Fmt.t =
|
|
fun ppf s -> F.pf ppf "r:%.3f g:%.3f b:%.3f a:%.3f" s.r s.g s.b s.a
|
|
(*F.(
|
|
hbox
|
|
@@ record ~sep:sp
|
|
[
|
|
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;
|
|
]) *)
|
|
|
|
(* let lwt_lwd (t : 'a Lwt.t Lwd.t) : 'a Lwd.t Lwt.t =
|
|
let root = Lwd.observe t in
|
|
Lwd.quick_sample root >>= fun root' ->
|
|
let var = Lwd.var root' in
|
|
Lwd.set_on_invalidate root (fun _t' ->
|
|
Lwt.async (fun () ->
|
|
Lwd.quick_sample root >>= fun root' ->
|
|
Lwt.return @@ Lwd.set var root'));
|
|
Lwt.return (Lwd.get var) *)
|
|
|
|
module Margin = struct
|
|
open Gg
|
|
|
|
type t = {
|
|
left : size1;
|
|
right : size1;
|
|
top : size1;
|
|
bottom : size1;
|
|
}
|
|
|
|
let empty = { left = 0.; right = 0.; top = 0.; bottom = 0. }
|
|
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.(
|
|
of_pts
|
|
(V2.v (minx b +. t.left) (miny b +. t.top))
|
|
(V2.v (maxx b -. t.right) (maxy b -. t.bottom)))
|
|
|
|
let outer t b =
|
|
Box2.(
|
|
of_pts
|
|
(V2.v (minx b -. t.left) (miny b -. t.top))
|
|
(V2.v (maxx b +. t.right) (maxy b +. t.bottom)))
|
|
|
|
let pp ppf t =
|
|
F.pf ppf "l=%.2f@;r=%.2f@;t=%.2f@;b=%.2f" t.left t.right t.top
|
|
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 TextBuffer = struct
|
|
let tree_eq (a : Store.S.tree) b =
|
|
F.epr "tree_eq (a=%s) (b=%s) @."
|
|
Store.(S.Tree.hash a |> S.Git.Hash.to_hex)
|
|
Store.(S.Tree.hash b |> S.Git.Hash.to_hex);
|
|
Store.(S.Git.Hash.equal (S.Tree.hash a) (S.Tree.hash b))
|
|
|
|
type t = {
|
|
path : string list Lwd.var;
|
|
tree : Store.S.tree Lwd.var;
|
|
repo : Store.Sync.db Lwt.t;
|
|
}
|
|
|
|
let of_repo ~(initial_path : string list)
|
|
~(repo : Store.Sync.db Lwt.t) : t Lwt.t =
|
|
repo >>= Store.S.tree >>= fun tree ->
|
|
Lwt.return
|
|
{
|
|
path = Lwd.var initial_path;
|
|
tree = Lwd.var ~eq:tree_eq tree;
|
|
repo;
|
|
}
|
|
|
|
let of_string ~path ?(repo : Store.Sync.db Lwt.t option) str =
|
|
{
|
|
path = Lwd.var path;
|
|
tree = Lwd.var ~eq:tree_eq @@ 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 { path; tree; _ } n uc : unit Lwt.t =
|
|
F.epr "TextBuffer.insert_uchar %d %a@." n pp_uchar uc;
|
|
let ucbuf = Bytes.create 8 in
|
|
let uclen = Bytes.set_utf_8_uchar ucbuf 0 uc in
|
|
Store.S.Tree.update (Lwd.peek tree) (Lwd.peek path) (function
|
|
| Some src ->
|
|
let sn = String.length src in
|
|
assert (n <= sn);
|
|
let dst = Bytes.create (sn + 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;
|
|
if sn > n + uclen then
|
|
BytesLabels.blit_string ~src ~src_pos:n ~dst
|
|
~dst_pos:(n + uclen)
|
|
~len:(sn - (n + uclen));
|
|
Some (Bytes.to_string dst)
|
|
| None ->
|
|
F.epr "TextBuffer.insert_uchar Tree.update -> Nonep@.";
|
|
Some (String.sub (Bytes.to_string ucbuf) 0 uclen))
|
|
>>= fun t ->
|
|
F.epr "TextBuffer.insert_uchar Tree.update @.";
|
|
Lwd.set tree t;
|
|
F.epr "TextBuffer.insert_uchar Lwd.set tree @.";
|
|
Lwt.return_unit
|
|
|
|
let insert { path; tree; _ } n str =
|
|
Store.S.Tree.update (Lwd.peek tree) (Lwd.peek path) (function
|
|
| Some src ->
|
|
let srcn = String.length src in
|
|
assert (n <= srcn);
|
|
Some
|
|
String.(
|
|
cat (cat (sub src 0 n) str) (sub src n (srcn - n)))
|
|
| None ->
|
|
F.epr "TextBuffer.insert Tree.update -> None@.";
|
|
Some str)
|
|
>>= fun t ->
|
|
Lwd.set tree t;
|
|
Lwt.return_unit
|
|
|
|
let remove { path; tree; _ } (a, b) : unit Lwt.t =
|
|
let a, b = (min a b, max a b) in
|
|
(* F.epr "TextBuffer.remove (%d, %d)@." a b; *)
|
|
Store.S.Tree.update (Lwd.peek tree) (Lwd.peek path) (function
|
|
| Some src ->
|
|
let srcn = String.length src in
|
|
assert (max a b <= srcn);
|
|
let dst = Bytes.create (srcn - (b - a)) in
|
|
Bytes.blit_string src 0 dst 0 a;
|
|
Bytes.blit_string src b dst a (srcn - b);
|
|
Some (Bytes.to_string dst)
|
|
| v -> v)
|
|
>>= fun t ->
|
|
Lwd.set tree t;
|
|
Lwt.return_unit
|
|
|
|
let remove_uchar { path; tree; _ } n : unit Lwt.t =
|
|
(* F.epr "TextBuffer.remove_subset n=%d @." n; *)
|
|
Store.S.Tree.update (Lwd.peek tree) (Lwd.peek path) (function
|
|
| Some src ->
|
|
let srcn = String.length src in
|
|
assert (n < srcn);
|
|
let ucn =
|
|
Uchar.utf_decode_length (String.get_utf_8_uchar src n)
|
|
in
|
|
let dst = Bytes.create (srcn - ucn) in
|
|
Bytes.blit_string src 0 dst 0 n;
|
|
Bytes.blit_string src (n + ucn) dst n (srcn - n - ucn);
|
|
Some (Bytes.to_string dst)
|
|
| None ->
|
|
F.epr "TextBuffer.remove_uchar None";
|
|
None)
|
|
>>= fun t ->
|
|
Lwd.set tree t;
|
|
Lwt.return_unit
|
|
|
|
let fold_string t (f : string -> 'a) : 'a Lwt.t =
|
|
match t with
|
|
| { path; tree; _ } ->
|
|
Store.S.Tree.get (Lwd.peek tree) (Lwd.peek path)
|
|
>>= fun text -> Lwt.return (f text)
|
|
|
|
let contents { path; tree; _ } : string Lwt.t =
|
|
(try Store.S.Tree.get (Lwd.peek tree) (Lwd.peek path)
|
|
with e ->
|
|
F.epr "TextBuffer.contents %s: %s"
|
|
(String.concat "/" (Lwd.peek path))
|
|
(match e with
|
|
| Not_found -> "Not_found"
|
|
| Invalid_argument a -> F.str "Invalid_argument %s" a
|
|
| exc -> F.str "Exception: %s" (Printexc.to_string exc));
|
|
Lwt.return "")
|
|
>>= fun text -> Lwt.return text
|
|
|
|
let get { tree; path; _ } =
|
|
Lwd.map2_s (Lwd.get tree) (Lwd.get path) ~f:(fun tree path ->
|
|
Store.S.Tree.get tree path)
|
|
|
|
let peek { tree; path; _ } =
|
|
Store.S.Tree.get (Lwd.peek tree) (Lwd.peek path)
|
|
|
|
let length { path; tree; _ } =
|
|
Store.S.Tree.get (Lwd.peek tree) (Lwd.peek path) >>= fun text ->
|
|
Lwt.return (String.length text)
|
|
|
|
let save { path; tree; repo } =
|
|
Store.S.Tree.get (Lwd.peek tree) (Lwd.peek path)
|
|
>>= fun contents ->
|
|
repo >>= fun r ->
|
|
Store.S.set
|
|
~info:
|
|
Store.S.Info.(
|
|
fun () ->
|
|
v ~author:"me" ~message:"TextBuffer.save"
|
|
(Unix.time () |> Int64.of_float))
|
|
r (Lwd.peek path) contents
|
|
>>= fun r ->
|
|
(match r with
|
|
| Ok () -> ()
|
|
| Error (`Conflict s) ->
|
|
F.epr "TextBuffer.save Error `Conflict %s@." s
|
|
| Error (`Too_many_retries n) ->
|
|
F.epr "TextBuffer.save Error `Too_many_retries %d@." n
|
|
| Error (`Test_was _) ->
|
|
F.epr "TextBuffer.save Error `Test_was %s@."
|
|
"<not implemented>");
|
|
Lwt.return_unit
|
|
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 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 "%a %a %a" pp_key_action a pp_key k pp_mods m
|
|
end
|
|
|
|
type event = Event.event
|
|
|
|
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
|
|
|
|
module TextLayout = struct
|
|
open Gg
|
|
|
|
type font_selection = Default | FontId of (string * float)
|
|
|
|
type 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;
|
|
}
|
|
|
|
type text_wrapping = {
|
|
max_width : float;
|
|
max_rows : int;
|
|
break_anywhere : bool;
|
|
overflow_character : string option;
|
|
}
|
|
|
|
type section = { byte_range : int * int; format : 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_format : 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 : format) -> s.line_height)
|
|
(option float);
|
|
field "color" (fun s -> s.color) pp_color;
|
|
field "background" (fun s -> s.background) pp_color;
|
|
])
|
|
|
|
let 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 format_simple font_id color : format =
|
|
{ format_default with font_id; color }
|
|
|
|
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 "…";
|
|
}
|
|
|
|
let pp_section : Format.formatter -> 'a -> unit =
|
|
F.(
|
|
record
|
|
[
|
|
field "byte_range"
|
|
(fun s -> s.byte_range)
|
|
(pair ~sep:(any ",") int int);
|
|
(* field "format" (fun s -> s.format) pp_format; *)
|
|
])
|
|
|
|
let section_default =
|
|
{ byte_range = (0, 0); format = format_default }
|
|
|
|
let pp_layout =
|
|
F.(
|
|
record
|
|
[
|
|
field "text"
|
|
(fun s ->
|
|
str "path=%s" (String.concat "/" (Lwd.peek s.text.path)))
|
|
string;
|
|
field "sections"
|
|
(fun s -> s.sections)
|
|
(brackets @@ list pp_section);
|
|
field "wrap" (fun s -> s.wrap) pp_text_wrapping;
|
|
field "halign" (fun s -> s.halign) Align.pp_t;
|
|
field "justify" (fun s -> s.justify) bool;
|
|
])
|
|
|
|
let layout_default =
|
|
{
|
|
text = TextBuffer.of_string ~path:[] "";
|
|
sections = [ section_default ];
|
|
wrap = default_text_wrapping ();
|
|
halign = Min;
|
|
justify = false;
|
|
line_height = Some 20.;
|
|
}
|
|
|
|
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;
|
|
])
|
|
|
|
let cursor_default = { index = 0; last_col = 0 }
|
|
let cursor ?(last_col = 0) index : cursor = { index; last_col }
|
|
|
|
let simple (text : TextBuffer.t) ?(start = Lwd.pure 0)
|
|
?(format = format_default) wrap_width : layout Lwd.t Lwt.t =
|
|
TextBuffer.get text >>= fun str ->
|
|
Lwd.map2 start str ~f:(fun start str ->
|
|
{
|
|
layout_default with
|
|
text;
|
|
sections =
|
|
[ { byte_range = (start, String.length str); format } ];
|
|
wrap =
|
|
{ (default_text_wrapping ()) with max_width = wrap_width };
|
|
})
|
|
|> Lwt.return
|
|
|
|
let cursor_color = ref (Gv.Color.rgbf ~r:0.5 ~g:0.5 ~b:0.)
|
|
|
|
let default_cursor_formatter (f : format) =
|
|
{ f with background = !cursor_color }
|
|
|
|
let default_mark_formatter (f : format) =
|
|
{ f with background = Gv.Color.rgbf ~r:0.3 ~g:0.3 ~b:0.3 }
|
|
|
|
let with_range ((cs, ce) : int * int)
|
|
?(format = default_cursor_formatter) layout : layout =
|
|
{
|
|
layout with
|
|
sections =
|
|
List.fold_left
|
|
(fun (l : section list) sec ->
|
|
let s, e = sec.byte_range in
|
|
l
|
|
@ (if e < cs || ce < s then [ sec ] else [])
|
|
@ (if cs > s && cs <= e then
|
|
[ { sec with byte_range = (s, cs) } ]
|
|
else [])
|
|
@ (if cs <= e && ce >= s then
|
|
[
|
|
{
|
|
format = format sec.format;
|
|
byte_range = (max cs s, min ce e);
|
|
};
|
|
]
|
|
else [])
|
|
@
|
|
if ce > s && ce <= e then
|
|
[ { sec with byte_range = (ce, e) } ]
|
|
else [])
|
|
[] layout.sections;
|
|
}
|
|
|
|
let with_cursor (cursor : cursor Lwd.t)
|
|
?(format = default_cursor_formatter) layout : layout Lwd.t =
|
|
Lwd.map2 cursor layout ~f:(fun c l ->
|
|
with_range (c.index, c.index + 1) ~format l)
|
|
|
|
let with_mark (mark : int option Lwd.t) (cursor : cursor Lwd.t)
|
|
?(format = default_mark_formatter) layout : layout Lwd.t =
|
|
Lwd.bind layout ~f:(fun l ->
|
|
Lwd.map2 mark cursor ~f:(fun m c ->
|
|
match m with
|
|
| Some m' ->
|
|
F.epr "TextLayout.with_mark inside Lwd.map@.";
|
|
|
|
with_range ~format (min m' c.index, max m' c.index) l
|
|
| None -> l))
|
|
end
|
|
|
|
let rec nth_tl n = function
|
|
| hd :: tl -> if n > 0 then nth_tl (n - 1) tl else hd :: tl
|
|
| [] -> []
|
|
|
|
module Ui = struct
|
|
type t = {
|
|
rect : Gg.box2 Lwd.var;
|
|
enabled : bool;
|
|
gv : Gv.t;
|
|
glfw_window : GLFW.window option;
|
|
bindings : (int * action list Event.t) Lwd.var;
|
|
}
|
|
|
|
and action = Custom of string * (unit -> unit Lwt.t)
|
|
|
|
type event =
|
|
[ `Key of Event.key_action * Event.key * Event.key_mod list
|
|
| `Char of int ]
|
|
|
|
let id = ref 0
|
|
|
|
let window gv ?(window : GLFW.window option) rect : t =
|
|
{
|
|
rect = Lwd.var ~eq:Gg.Box2.equal rect;
|
|
enabled = true;
|
|
gv;
|
|
glfw_window = window;
|
|
bindings =
|
|
Lwd.var ~eq:(fun (a, _) (b, _) -> a = b) (0, Event.empty);
|
|
}
|
|
|
|
let pp_action : action F.t =
|
|
fun ppf -> function Custom (name, _) -> F.pf ppf "%s" name
|
|
|
|
let pp_bindings : action list Event.t F.t =
|
|
fun ppf p ->
|
|
let open Event in
|
|
fold
|
|
(fun events action () ->
|
|
F.pf ppf "%a: %a@."
|
|
F.(list pp_action)
|
|
action
|
|
F.(brackets @@ list ~sep:semi pp_event)
|
|
events
|
|
|> ignore)
|
|
p ()
|
|
|
|
let process_key t (resolver : action list Event.result)
|
|
(state : Event.key_action) (key : Event.key)
|
|
(mods : Event.key_mod list) : action list Event.result Lwt.t =
|
|
let res =
|
|
match resolver with
|
|
| Event.Rejected | Event.Accepted _ ->
|
|
[
|
|
t.bindings |> Lwd.peek
|
|
(*Lwd.get |> Lwd.observe |> Lwd.quick_sample *) |> snd
|
|
|> Event.pack Fun.id;
|
|
]
|
|
| Event.Continue r -> r
|
|
in
|
|
let res = Event.resolve (Key (state, key, mods)) res in
|
|
(match res with
|
|
| Event.Accepted actions ->
|
|
let rec exec : action list -> unit Lwt.t = function
|
|
| Custom (_name, f) :: actions ->
|
|
f () >>= fun () -> exec actions
|
|
| [] -> Lwt.return_unit
|
|
in
|
|
exec actions >>= fun () -> Lwt.return_unit
|
|
| Event.Continue _ | Event.Rejected -> Lwt.return_unit)
|
|
>>= fun () -> Lwt.return res
|
|
|
|
let update_bindings ui
|
|
(f : action list Event.t -> action list Event.t) =
|
|
Lwd.set ui.bindings
|
|
( Lwd.peek ui.bindings |> fst |> Int.add 1,
|
|
f (Lwd.peek ui.bindings |> snd) )
|
|
|
|
let chrcallback_ref : (Uchar.t -> unit Lwt.t) ref =
|
|
ref (fun _c ->
|
|
F.epr "chrcallback: '%a'@." pp_uchar _c;
|
|
Lwt.return_unit)
|
|
|
|
let process_char (chr : int) : unit Lwt.t =
|
|
!chrcallback_ref @@ Uchar.of_int chr
|
|
|
|
let process_events (ui : t) (events : event Lwt_stream.t) : unit =
|
|
Lwt.async (fun () ->
|
|
let rec proc (r : action list Event.result) :
|
|
action list Event.result Lwt.t =
|
|
Lwt_stream.last_new events >>= function
|
|
| `Key (state, key, mods) ->
|
|
process_key ui r state key mods
|
|
>>= fun (res : action list Event.result) ->
|
|
Event.(
|
|
F.epr "Ui.process_events `Key %a %a %a (%s)@."
|
|
pp_key_action state pp_key key pp_mods mods
|
|
(match res with
|
|
| Accepted _ -> "Accepted"
|
|
| Continue _ -> "Continue"
|
|
| Rejected -> "Rejected"));
|
|
(match res with
|
|
| Accepted _ when mods = [] || mods == [ Shift ] -> (
|
|
(* junk the `Char that is sent with a `Key that has no mods *)
|
|
Lwt_stream.peek events
|
|
>>= function
|
|
| Some (`Char _) ->
|
|
F.epr "process_events: junking next event@.";
|
|
Lwt_stream.junk events
|
|
| _ -> Lwt.return_unit)
|
|
| Accepted _ | Continue _ | Rejected -> Lwt.return_unit)
|
|
>>= fun () -> proc res
|
|
| `Char char ->
|
|
F.epr "Ui.process_events `Char '%a'@." pp_uchar
|
|
(Uchar.of_int char);
|
|
process_char char >>= fun () -> proc (Event.Accepted [])
|
|
in
|
|
|
|
proc Event.Rejected >>= fun _ -> Lwt.return_unit)
|
|
|
|
module Style = struct
|
|
type t = {
|
|
stroke : (float * Gv.Color.t) option;
|
|
fill : Gv.Color.t;
|
|
margin : Margin.t;
|
|
}
|
|
|
|
let default =
|
|
{
|
|
stroke = None;
|
|
fill = Gv.Color.transparent;
|
|
margin = Margin.empty;
|
|
}
|
|
|
|
let pp ppf t =
|
|
F.pf ppf "%a"
|
|
F.(
|
|
hovbox
|
|
@@ record
|
|
[
|
|
field "stroke"
|
|
(fun t -> t.stroke)
|
|
(pair ~sep:comma float pp_color
|
|
|> option ~none:(any "None")
|
|
|> hbox);
|
|
field "fill" (fun t -> t.fill) pp_color;
|
|
field "margin" (fun t -> t.margin) Margin.pp;
|
|
])
|
|
t
|
|
end
|
|
end
|
|
|
|
module TextEdit = struct
|
|
open Gg
|
|
|
|
type t = {
|
|
text : TextBuffer.t;
|
|
cursor : TextLayout.cursor Lwd.var;
|
|
mark : int option Lwd.var;
|
|
scroll : int Lwd.var;
|
|
rows : int Lwd.var;
|
|
text_format : TextLayout.format;
|
|
formatter :
|
|
(Ui.t -> TextBuffer.t -> float -> TextLayout.layout) option;
|
|
password : bool;
|
|
frame : bool;
|
|
margin : margin;
|
|
multiline : bool;
|
|
interactive : bool;
|
|
desired_width : float option;
|
|
desired_height_rows : int;
|
|
cursor_at_end : bool;
|
|
min_size : v2;
|
|
align : align;
|
|
clip_text : bool;
|
|
char_limit : int; (* return_key : keyboard_shortcut; *)
|
|
}
|
|
|
|
let col t =
|
|
TextBuffer.fold_string t.text (fun s ->
|
|
let c = Lwd.peek t.cursor in
|
|
c.index - Str.search_backward (Str.regexp "^") s c.index)
|
|
|
|
let rec newlines (s : string) (i : int) : int list =
|
|
match String.index_from_opt s i '\n' with
|
|
| Some i' -> i :: newlines s i'
|
|
| None -> []
|
|
|
|
let rec index_rows_from (s : string) (start : int) (rows : int) :
|
|
int option =
|
|
match String.index_from_opt s start '\n' with
|
|
| Some start' ->
|
|
if rows - 1 > 0 then index_rows_from s (start' + 1) (rows - 1)
|
|
else Some (start' + 1)
|
|
| None -> None (* eof *)
|
|
|
|
let rec rindex_rows_from (s : string) (start : int) (rows : int) :
|
|
int option =
|
|
match String.rindex_from_opt s start '\n' with
|
|
| Some start' ->
|
|
if start' - 1 <= 0 then None
|
|
else if rows - 1 > 0 then
|
|
rindex_rows_from s (start' - 1) (rows - 1)
|
|
else Some (start' + 1)
|
|
| None -> None (* eof *)
|
|
|
|
let scroll_update ({ text; cursor; scroll; rows; _ } as t : t) :
|
|
unit Lwt.t =
|
|
TextBuffer.fold_string text (fun s ->
|
|
let cursor = Lwd.peek cursor in
|
|
let rows = Lwd.peek rows in
|
|
let slen = String.length s in
|
|
if cursor.index < Lwd.peek scroll then
|
|
match
|
|
String.rindex_from_opt s
|
|
(min (slen - 1) (cursor.index - 1))
|
|
'\n'
|
|
with
|
|
| Some i' -> Lwd.set t.scroll (i' + 1)
|
|
| None -> Lwd.set t.scroll 0
|
|
else
|
|
match index_rows_from s (Lwd.peek scroll) rows with
|
|
| None -> ()
|
|
| Some eow -> (
|
|
if cursor.index >= eow then
|
|
match
|
|
rindex_rows_from s
|
|
(min (slen - 1) cursor.index)
|
|
rows
|
|
with
|
|
| None -> ()
|
|
| Some i' -> Lwd.set t.scroll i'))
|
|
|
|
let cursor_update (t : t) (f : int -> int) : unit Lwt.t =
|
|
col t >>= fun last_col ->
|
|
TextBuffer.fold_string t.text (fun s ->
|
|
Lwd.set t.cursor
|
|
(TextLayout.cursor ~last_col
|
|
(f (Lwd.peek t.cursor).index
|
|
|> max 0
|
|
|> min (String.length s))))
|
|
>>= fun () -> scroll_update t
|
|
|
|
let cursor_move (t : t) (amt : int) : unit Lwt.t =
|
|
cursor_update t (( + ) amt)
|
|
|
|
let cursor_set (t : t) (index : int) : unit Lwt.t =
|
|
cursor_update t (Fun.const index)
|
|
|
|
let default_bindings (t : t) (ui : Ui.t) : unit =
|
|
let open GLFW in
|
|
let open Event in
|
|
let open Ui in
|
|
Ui.update_bindings ui (fun a ->
|
|
a
|
|
|> adds
|
|
[
|
|
[ Key (Press, F, [ Control ]) ];
|
|
[ Key (Repeat, F, [ Control ]) ];
|
|
[ Key (Press, Right, []) ];
|
|
[ Key (Repeat, Right, []) ];
|
|
]
|
|
[ Custom ("char_forward", fun () -> cursor_move t 1) ]
|
|
|> adds
|
|
[
|
|
[ Key (Press, B, [ Control ]) ];
|
|
[ Key (Repeat, B, [ Control ]) ];
|
|
[ Key (Press, Left, []) ];
|
|
[ Key (Repeat, Left, []) ];
|
|
]
|
|
[
|
|
Custom ("char_backward", fun () -> cursor_move t (-1));
|
|
]
|
|
|> adds
|
|
[
|
|
[ Key (Press, N, [ Control ]) ];
|
|
[ Key (Repeat, N, [ Control ]) ];
|
|
[ Key (Press, Down, []) ];
|
|
[ Key (Repeat, Down, []) ];
|
|
]
|
|
[
|
|
Custom
|
|
( "forward_line",
|
|
fun () ->
|
|
TextBuffer.fold_string t.text (fun s ->
|
|
let sn = String.length s in
|
|
let seol =
|
|
Str.search_forward (Str.regexp "$")
|
|
in
|
|
let next_bol =
|
|
min sn
|
|
(seol s (Lwd.peek t.cursor).index + 1)
|
|
in
|
|
let next_line_len =
|
|
seol s next_bol - next_bol
|
|
in
|
|
next_bol
|
|
+
|
|
if
|
|
(Lwd.peek t.cursor).last_col
|
|
> next_line_len
|
|
then next_line_len
|
|
else
|
|
min next_line_len
|
|
(Lwd.peek t.cursor).last_col)
|
|
>>= cursor_set t );
|
|
]
|
|
|> adds
|
|
[
|
|
[ Key (Press, P, [ Control ]) ];
|
|
[ Key (Repeat, P, [ Control ]) ];
|
|
[ Key (Press, Up, []) ];
|
|
[ Key (Repeat, Up, []) ];
|
|
]
|
|
[
|
|
Custom
|
|
( "line_backward",
|
|
fun () ->
|
|
TextBuffer.fold_string t.text (fun s ->
|
|
let sbol =
|
|
Str.search_backward (Str.regexp "^") s
|
|
in
|
|
let bol = sbol (Lwd.peek t.cursor).index in
|
|
if bol > 0 then
|
|
let prev_bol = sbol (max 0 (bol - 1)) in
|
|
let prev_line_len = bol - 1 - prev_bol in
|
|
|
|
(*F.epr
|
|
"up: index=%d bol=%d prev_bol=%d \
|
|
prev_line_len=%d @."
|
|
t.cursor.index bol prev_bol prev_line_len; *)
|
|
prev_bol
|
|
+
|
|
if
|
|
(Lwd.peek t.cursor).last_col
|
|
> prev_line_len
|
|
then prev_line_len
|
|
else
|
|
min prev_line_len
|
|
(Lwd.peek t.cursor).last_col
|
|
else (Lwd.peek t.cursor).index)
|
|
>>= cursor_set t );
|
|
]
|
|
|> adds (* EOL *)
|
|
[
|
|
[ Key (Press, E, [ Control ]) ];
|
|
[ Key (Press, End, []) ];
|
|
]
|
|
[
|
|
Custom
|
|
( "end_of_line",
|
|
fun () ->
|
|
TextBuffer.fold_string t.text (fun s ->
|
|
let bol =
|
|
Str.search_backward (Str.regexp "^") s
|
|
(Lwd.peek t.cursor).index
|
|
in
|
|
let eol =
|
|
Str.search_forward (Str.regexp "$") s
|
|
(Lwd.peek t.cursor).index
|
|
in
|
|
Lwd.set t.cursor
|
|
@@ TextLayout.cursor ~last_col:(eol - bol)
|
|
eol) );
|
|
]
|
|
|> adds (* BOL *)
|
|
[
|
|
[ Key (Press, A, [ Control ]) ];
|
|
[ Key (Press, Home, []) ];
|
|
]
|
|
[
|
|
Custom
|
|
( "beginning_of_line",
|
|
fun () ->
|
|
TextBuffer.fold_string t.text (fun s ->
|
|
Lwd.set t.cursor
|
|
@@ TextLayout.cursor ~last_col:0
|
|
(Str.search_backward (Str.regexp "^") s
|
|
(Lwd.peek t.cursor).index)) );
|
|
]
|
|
|> adds
|
|
[
|
|
[ Key (Press, Backspace, []) ];
|
|
[ Key (Repeat, Backspace, []) ];
|
|
]
|
|
[
|
|
Custom
|
|
( "delete_char_backward",
|
|
fun () ->
|
|
match Lwd.peek t.mark with
|
|
| Some mark ->
|
|
TextBuffer.remove t.text
|
|
(mark, (Lwd.peek t.cursor).index)
|
|
>>= fun _ ->
|
|
Lwd.set t.mark None;
|
|
cursor_set t
|
|
(min mark (Lwd.peek t.cursor).index)
|
|
| None ->
|
|
if (Lwd.peek t.cursor).index > 0 then
|
|
TextBuffer.remove_uchar t.text
|
|
((Lwd.peek t.cursor).index - 1)
|
|
>>= fun _ -> cursor_move t (-1)
|
|
else Lwt.return_unit );
|
|
]
|
|
|> adds
|
|
[ [ Key (Press, K, [ Control ]) ] ]
|
|
[
|
|
Custom
|
|
( "line_kill",
|
|
fun () ->
|
|
TextBuffer.fold_string t.text (fun s ->
|
|
TextBuffer.remove t.text
|
|
( (Lwd.peek t.cursor).index,
|
|
let eol =
|
|
Str.search_forward (Str.regexp "$") s
|
|
(Lwd.peek t.cursor).index
|
|
in
|
|
if
|
|
eol == (Lwd.peek t.cursor).index
|
|
&& String.length s > eol
|
|
then eol + 1
|
|
else eol )
|
|
>>= fun _ ->
|
|
Lwd.set t.mark None;
|
|
cursor_set t (Lwd.peek t.cursor).index)
|
|
>>= fun u -> u );
|
|
]
|
|
|> adds
|
|
[
|
|
[ Key (Press, Enter, []) ]; [ Key (Repeat, Enter, []) ];
|
|
]
|
|
[
|
|
Custom
|
|
( "new_line",
|
|
fun () ->
|
|
TextBuffer.insert_uchar t.text
|
|
(Lwd.peek t.cursor).index (Uchar.of_char '\n')
|
|
>>= fun _ -> cursor_move t 1 );
|
|
]
|
|
|> adds
|
|
[ [ Key (Press, Space, [ Control ]) ] ] (* Mark set *)
|
|
[
|
|
Custom
|
|
( "mark_toggle",
|
|
fun () ->
|
|
Lwd.set t.mark
|
|
(match Lwd.peek t.mark with
|
|
| Some _ -> None
|
|
| None -> Some (Lwd.peek t.cursor).index);
|
|
Lwt.return_unit );
|
|
]
|
|
|> adds
|
|
[ [ Key (Press, G, [ Control ]) ] ] (* Exit / Clear *)
|
|
[
|
|
Custom
|
|
( "command_clear",
|
|
fun () ->
|
|
Lwd.set t.mark None;
|
|
Lwt.return_unit );
|
|
]
|
|
|> adds
|
|
[
|
|
[
|
|
Key (Press, X, [ Control ]);
|
|
Key (Press, S, [ Control ]);
|
|
];
|
|
]
|
|
(* Save *)
|
|
[
|
|
Custom ("save_buffer", fun () -> TextBuffer.save t.text);
|
|
]);
|
|
|
|
Ui.chrcallback_ref :=
|
|
fun c ->
|
|
TextBuffer.insert_uchar t.text (Lwd.peek t.cursor).index c
|
|
>>= fun _ -> cursor_move t 1
|
|
(* This creates a giant stack of calls lol
|
|
>>= fun () -> !Ui.chrcallback_ref c *)
|
|
|
|
let multiline ui ?(text_format = TextLayout.format_default)
|
|
(text : TextBuffer.t) : t =
|
|
let t =
|
|
{
|
|
text;
|
|
cursor = Lwd.var (TextLayout.cursor 0);
|
|
mark = Lwd.var None;
|
|
scroll = Lwd.var 0;
|
|
rows = Lwd.var 0;
|
|
text_format;
|
|
formatter = None;
|
|
password = false;
|
|
frame = true;
|
|
margin = Margin.symmetric 4.0 4.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; *)
|
|
}
|
|
in
|
|
default_bindings t ui;
|
|
t
|
|
end
|
|
|
|
module Layout = struct
|
|
module Style = Ui.Style
|
|
|
|
type dir = [ `X | `Y | `Z ]
|
|
|
|
type frame = { t : t; mutable size : size; style : Style.t }
|
|
|
|
and t =
|
|
[ `Join of dir * (frame * frame)
|
|
| `String of string * TextLayout.format
|
|
| `Buffer of TextBuffer.t * TextLayout.format
|
|
| `TextEdit of TextEdit.t * TextLayout.layout
|
|
| `None ]
|
|
|
|
and dim =
|
|
[ `Ratio of float | `Pixels of float | `Fun of Gg.box2 -> float ]
|
|
|
|
and size = dim * dim
|
|
|
|
let ratio x y = (`Ratio x, `Ratio y)
|
|
let pixels x y = (`Pixels (Int.of_float x), `Pixels (Int.of_float y))
|
|
|
|
let frame ?(size = ratio 1. 1.) ?(style = Style.default) t : frame =
|
|
{ t; size; style }
|
|
|
|
let none = frame `None
|
|
let join ?size ?style d a b = frame ?size ?style (`Join (d, (a, b)))
|
|
|
|
(* let hbox, vbox, zbox = (box `X, box `Y, box `Z) *)
|
|
let pack ?style d = (none, join d ?style)
|
|
let pack_x ?style () = pack `X ?style
|
|
let pack_y ?style () = pack `Y ?style
|
|
let pack_z ?style () = pack `Z ?style
|
|
let cat ?style d = Lwd_utils.reduce (pack ?style d)
|
|
let hcat ?style = cat ?style `X
|
|
let vcat ?style = Lwd_utils.reduce (pack_y ?style ())
|
|
let zcat ?style = Lwd_utils.reduce (pack_z ?style ())
|
|
let box ?style d = Lwd_utils.pack (pack ?style d)
|
|
let hbox, vbox, zbox = (box `X, box `Y, box `Z)
|
|
|
|
let textedit_style =
|
|
Style.
|
|
{
|
|
fill = Gv.Color.rgbaf ~r:0.1 ~g:0.1 ~b:0.1 ~a:0.0;
|
|
stroke = Some (1.2, Gv.Color.rgbf ~r:0.9 ~g:0.9 ~b:0.9);
|
|
margin = Margin.symmetric 10. 10.;
|
|
}
|
|
|
|
let string ?size ?style s = frame ?size ?style (`String s)
|
|
|
|
let textedit_s ?size ?(style = textedit_style)
|
|
(t : TextEdit.t Lwd.t) : frame Lwd.t Lwt.t =
|
|
let open TextLayout in
|
|
F.epr "Layout.textedit@.";
|
|
Lwd.map_s t ~f:(fun (t : TextEdit.t) ->
|
|
simple t.text ~start:(Lwd.get t.scroll) ~format:t.text_format
|
|
(Option.value ~default:80. t.desired_width)
|
|
>>= fun layout ->
|
|
with_cursor (Lwd.get t.cursor) layout
|
|
|> with_mark (Lwd.get t.mark) (Lwd.get t.cursor)
|
|
|> Lwd.map ~f:(fun tl ->
|
|
frame ?size ~style (`TextEdit (t, tl)))
|
|
|> Lwt.return)
|
|
>>= fun v -> Lwd.join v |> Lwt.return
|
|
|
|
let textedit ?size ?(style = textedit_style) (t : TextEdit.t) :
|
|
frame Lwd.t Lwt.t =
|
|
let open TextLayout in
|
|
F.epr "Layout.textedit@.";
|
|
simple t.text ~start:(Lwd.get t.scroll) ~format:t.text_format
|
|
(Option.value ~default:80. t.desired_width)
|
|
>>= fun layout ->
|
|
with_cursor (Lwd.get t.cursor) layout
|
|
|> with_mark (Lwd.get t.mark) (Lwd.get t.cursor)
|
|
|> Lwd.map ~f:(fun tl -> frame ?size ~style (`TextEdit (t, tl)))
|
|
|> Lwt.return
|
|
|
|
let pp_dir ppf (t : [ `X | `Y | `Z ]) =
|
|
F.pf ppf "%s"
|
|
(match t with `X -> "`X" | `Y -> "`Y" | `Z -> "`Z")
|
|
|
|
let pp_t ppf (t : t) =
|
|
F.pf ppf "%s"
|
|
(match t with
|
|
| `Join (d, _) -> F.str "`Join %a" pp_dir d
|
|
| `Buffer _ -> "`Buffer"
|
|
| `TextEdit _ -> "`TextEdit"
|
|
| `String (s, _) -> F.str "`String %s" s
|
|
| `None -> "`None")
|
|
|
|
let pp_dim ppf = function
|
|
| `Pixels p -> F.pf ppf "%.2fpx" p
|
|
| `Ratio p -> F.pf ppf "%.2f%%" p
|
|
| `Fun _ -> F.pf ppf "`Fun _"
|
|
|
|
let pp_size = F.pair ~sep:F.(any " ") pp_dim pp_dim
|
|
|
|
let pp_frame =
|
|
F.(
|
|
record
|
|
[
|
|
field "t" (fun t -> t.t) pp_t;
|
|
field "size" (fun t -> t.size) pp_size;
|
|
field "style" (fun t -> t.style) Style.pp;
|
|
])
|
|
|
|
let rec pp_t_rec ppf (t : t) =
|
|
let open Fmt in
|
|
match t with
|
|
| `Join (d, p) ->
|
|
pf ppf "`Join %a (@,%a)" pp_dir d
|
|
(pair ~sep:F.comma pp_frame_rec pp_frame_rec)
|
|
p
|
|
| `Buffer _ -> pf ppf "`Buffer"
|
|
| `TextEdit _ -> pf ppf "`TextEdit"
|
|
| `String (s, _) -> pf ppf "`String @[<h 1>%s@]" s
|
|
| `None -> pf ppf "`None"
|
|
|
|
and pp_frame_rec ppf t =
|
|
F.pf ppf "@[<hv 3>[%a] %a@]" pp_size t.size pp_t_rec t.t
|
|
|
|
let parse_t_frame s =
|
|
match s with
|
|
| "`Box" -> `Vbox
|
|
| "`Buffer" -> `Buffer
|
|
| "`TextEdit" -> `TextEdit
|
|
| "`None" -> `None
|
|
| s -> `S s
|
|
end
|
|
|
|
module WindowManager = struct
|
|
open Layout
|
|
|
|
type t =
|
|
[ `T of dir * (t * dim) list
|
|
| `TextEdit of TextEdit.t
|
|
| `Frame of frame ]
|
|
|
|
let rec length : t -> int = function
|
|
| `T (_, tl) ->
|
|
List.fold_left (fun a (t', _) -> a + length t') 0 tl
|
|
| _ -> 1
|
|
|
|
let rec fold_left ?(dir = `X)
|
|
~(f :
|
|
dir ->
|
|
'a ->
|
|
[ `Frame of frame | `TextEdit of TextEdit.t ] ->
|
|
'a) acc = function
|
|
| `T (dir, tl) ->
|
|
List.fold_left (fun a' t' -> fold_left ~f ~dir a' t') acc tl
|
|
| (`Frame _ as tt) | (`TextEdit _ as tt) -> f dir acc tt
|
|
|
|
let color_gray c = Gv.Color.rgbf ~r:c ~g:c ~b:c
|
|
|
|
let status_style sel : Style.t =
|
|
let open Ui.Style in
|
|
{
|
|
stroke =
|
|
Some (3.0, if sel then color_gray 0.6 else color_gray 0.4);
|
|
fill = (if sel then color_gray 0.8 else color_gray 0.2);
|
|
margin = Margin.symmetric 2. 2.;
|
|
}
|
|
|
|
let status_format sel : TextLayout.format =
|
|
{
|
|
TextLayout.format_default with
|
|
font_id = FontId ("mono", 18.0);
|
|
line_height = Some 19.;
|
|
color = (if sel then color_gray 0.1 else color_gray 0.9);
|
|
background = Gv.Color.transparent;
|
|
}
|
|
|
|
let frame_of_window (n : int) cursor style (size : dim * dim)
|
|
(content : frame Lwd.t) : frame Lwd.t =
|
|
Lwd.map2 content (Lwd.get cursor) ~f:(fun content cursor ->
|
|
join ~size
|
|
~style:
|
|
{
|
|
style with
|
|
stroke =
|
|
Option.map
|
|
(fun (s, c) ->
|
|
( s,
|
|
if n != cursor then Gv.Color.(transf c 0.3)
|
|
else c ))
|
|
content.style.stroke;
|
|
}
|
|
`Y content
|
|
(string
|
|
~style:(status_style (n == cursor))
|
|
~size:(`Ratio 1.0, `Pixels 30.)
|
|
(F.str "window/%d" n, status_format (n == cursor))))
|
|
|
|
let make ui ?(style = textedit_style)
|
|
?(_mode : [ `Tiling | `FullScreen | `Floating ] = `Tiling)
|
|
(telist : t Lwd.var) =
|
|
let cursor = Lwd.var 0 in
|
|
Ui.update_bindings ui (fun a ->
|
|
a
|
|
|> Event.adds
|
|
[ [ Key (Press, X, [ Control ]); Key (Press, O, []) ] ]
|
|
[
|
|
Ui.Custom
|
|
( "window_next",
|
|
fun () ->
|
|
Lwd.set cursor
|
|
(if
|
|
Lwd.peek cursor
|
|
< (Lwd.peek telist |> length) - 1
|
|
then Lwd.peek cursor + 1
|
|
else 0);
|
|
(*TextEdit.default_bindings
|
|
(List.nth (Lwd.peek telist) (Lwd.peek cursor))
|
|
ui; *)
|
|
Lwt.return_unit );
|
|
]
|
|
|> Event.adds
|
|
[ [ Key (Press, X, [ Control ]); Key (Press, P, []) ] ]
|
|
[
|
|
Ui.Custom
|
|
( "window_previous",
|
|
fun () ->
|
|
Lwd.set cursor
|
|
(if Lwd.peek cursor > 0 then
|
|
Lwd.peek cursor - 1
|
|
else (Lwd.peek telist |> length) - 1);
|
|
(*TextEdit.default_bindings
|
|
(List.nth (Lwd.peek telist) (Lwd.peek cursor))
|
|
ui;*)
|
|
Lwt.return_unit );
|
|
]);
|
|
|
|
Lwd.map_s (Lwd.get telist) ~f:(fun (tl : t) ->
|
|
let rec fold dir dim : t -> Layout.frame Lwd.t Lwt.t =
|
|
let size =
|
|
match dir with
|
|
| `X -> (dim, `Ratio 1.)
|
|
| `Y -> (`Ratio 1., dim)
|
|
| `Z -> (dim, dim)
|
|
in
|
|
function
|
|
| `T ((dir', (t0, dim0) :: trest) as tl) ->
|
|
fold dir' dim0 t0 >>= fun fst ->
|
|
Lwt_list.fold_left_s
|
|
(fun f (t, dim) ->
|
|
fold dir' dim t >>= fun newf ->
|
|
Lwd.map2 f newf ~f:(join ~size dir') |> Lwt.return)
|
|
fst trest
|
|
| `T (_, []) -> Layout.none |> Lwd.return |> Lwt.return
|
|
| `Frame f' ->
|
|
frame_of_window 314 cursor style size (Lwd.return f')
|
|
|> Lwt.return
|
|
| `TextEdit t' ->
|
|
Layout.textedit
|
|
~size:(`Ratio 1.0, `Fun (fun b -> Gg.Box2.h b -. 30.))
|
|
t'
|
|
>>= fun tt ->
|
|
frame_of_window 314 cursor style size tt |> Lwt.return
|
|
in
|
|
fold `X (`Ratio 1.) tl)
|
|
>>= fun d -> Lwd.join d |> Lwt.return
|
|
end
|
|
|
|
module Painter = struct
|
|
open Layout
|
|
open Gg
|
|
|
|
let draw_box (t : Gv.t) ~(box : Gg.box2) ~(style : Layout.Style.t) =
|
|
let open Gv in
|
|
let open Box2 in
|
|
Path.begin_ t;
|
|
Path.rect t ~x:(minx box) ~y:(miny box) ~w:(w box) ~h:(h box);
|
|
set_fill_color t ~color:style.fill;
|
|
|
|
(match style.stroke with
|
|
| None -> ()
|
|
| Some (width, color) ->
|
|
set_stroke_width t ~width;
|
|
set_stroke_color t ~color;
|
|
stroke t);
|
|
fill t
|
|
|
|
let set_text_format (t : Gv.t) (format : TextLayout.format) =
|
|
let font_name, font_size =
|
|
match 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);
|
|
set_fill_color t ~color:format.color
|
|
|
|
let string ?(style = Style.default) (t : Gv.t) (rect : box2)
|
|
((contents, format) : string * TextLayout.format) : box2 Lwt.t =
|
|
(* draw_box t ~box:rect ~style; *)
|
|
F.epr "string";
|
|
set_text_format t format;
|
|
let rect' = Margin.inner style.margin rect in
|
|
V2.v
|
|
(Gv.Text.text_w t ~x:(Box2.minx rect') ~y:(Box2.miny rect')
|
|
contents)
|
|
(Gv.Text.metrics t).line_height
|
|
|> Box2.v (Box2.o rect')
|
|
|> Margin.outer style.margin
|
|
|> Lwt.return
|
|
|
|
let text_layout (t : Gv.t) (rect : box2)
|
|
((te, layout) : TextEdit.t * TextLayout.layout) : box2 Lwt.t =
|
|
let g = layout in
|
|
let line_height =
|
|
Option.value ~default:(Gv.Text.metrics t).line_height
|
|
g.line_height
|
|
in
|
|
let max_rows =
|
|
Int.of_float (Box2.h rect /. line_height) |> max 1
|
|
in
|
|
Lwd.set te.rows max_rows;
|
|
let lines = Gv.Text.make_empty_rows max_rows in
|
|
Store.S.Tree.get (Lwd.peek te.text.tree) (Lwd.peek te.text.path)
|
|
>>= fun contents ->
|
|
let row_count =
|
|
Gv.Text.break_lines t ~break_width:(Box2.w rect) ~max_rows
|
|
~lines ~start:(Lwd.peek te.scroll) contents
|
|
in
|
|
Seq.fold_left
|
|
(fun ((cur, start) : p2 * int) (row : Gv.Text.text_row) ->
|
|
let sections =
|
|
List.filter
|
|
(fun (r : TextLayout.section) ->
|
|
fst r.byte_range <= row.end_index
|
|
&& snd r.byte_range > start)
|
|
g.sections
|
|
in
|
|
List.fold_left
|
|
(fun (cur' : p2) (sec : TextLayout.section) ->
|
|
let start, end_ =
|
|
let contents_len = String.length contents in
|
|
( start |> max (fst sec.byte_range) |> min contents_len,
|
|
row.end_index |> min contents_len
|
|
|> min (snd sec.byte_range) )
|
|
in
|
|
let width =
|
|
if start == row.end_index then
|
|
(* hack to display cursor at end of row *)
|
|
(Gv.Text.bounds t ~x:(P2.x cur') ~y:0. " ").advance
|
|
else
|
|
(Gv.Text.bounds t ~x:(P2.x cur') ~y:0. ~start ~end_
|
|
contents)
|
|
.advance
|
|
in
|
|
draw_box t
|
|
~box:
|
|
(Box2.v
|
|
(V2.v (P2.x cur') (P2.y cur))
|
|
(V2.v width 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)
|
|
(P2.y cur'))
|
|
P2.(v (Box2.minx rect) (y cur))
|
|
sections
|
|
|> fun cur'' ->
|
|
( V2.(v (max (x cur) (x cur'')) (y cur'' +. line_height)),
|
|
row.next ))
|
|
(Box2.o rect, Lwd.peek te.scroll)
|
|
(Seq.take row_count (Array.to_seq lines))
|
|
|> fst
|
|
|> Box2.(of_pts (o rect))
|
|
|> Lwt.return
|
|
|
|
let rec layout (box : box2) (ui : Ui.t)
|
|
({ t; style; size = sx, sy } : frame) : box2 Lwt.t =
|
|
let box =
|
|
Box2.v (Box2.o box)
|
|
(Size2.v
|
|
(match sx with
|
|
| `Ratio r -> Box2.w box *. r
|
|
| `Pixels p -> p
|
|
| `Fun f -> f box)
|
|
(match sy with
|
|
| `Ratio r -> Box2.h box *. r
|
|
| `Pixels p -> p
|
|
| `Fun f -> f box))
|
|
in
|
|
let box' = Margin.inner style.margin box in
|
|
F.epr "@[<hv 3>%a " pp_box2 box;
|
|
draw_box ui.gv ~box ~style;
|
|
(match t with
|
|
| `Join (dir, (a, b)) ->
|
|
F.epr "`Join %a @,(@[<hv>" pp_dir dir;
|
|
layout box' ui a >>= fun ra ->
|
|
F.epr ",@ ";
|
|
let c' =
|
|
Box2.(
|
|
match dir with
|
|
| `X -> of_pts (V2.v (maxx ra) (miny box')) (max box')
|
|
| `Y -> of_pts (V2.v (minx box') (maxy ra)) (max box')
|
|
| `Z -> box')
|
|
in
|
|
layout c' ui b >>= fun rb ->
|
|
F.epr "@])";
|
|
Gg.Box2.union ra rb |> Lwt.return
|
|
| `TextEdit tt ->
|
|
F.epr "`TextEdit";
|
|
text_layout ui.gv box' tt
|
|
| `None ->
|
|
F.epr "`None";
|
|
Lwt.return Gg.Box2.(v (o box') Gg.V2.zero)
|
|
| `String s -> string ui.gv box' s
|
|
| _ ->
|
|
F.epr "_ !!Unimplemented!!";
|
|
Lwt.return Gg.Box2.zero)
|
|
>>= fun r ->
|
|
F.epr "@]";
|
|
|
|
let r' =
|
|
(*Box2.add_pt r
|
|
V2.(Box2.max r + v style.margin.right style.margin.bottom)
|
|
|> *)
|
|
Margin.outer style.margin r
|
|
in
|
|
|
|
(*F.epr "layout: box=%a box'=%a r=%a r'=%a@." Gg.Box2.pp box
|
|
Gg.Box2.pp box' Gg.Box2.pp r Gg.Box2.pp r'; *)
|
|
Lwt.return r'
|
|
|
|
let layout box ui frame =
|
|
F.epr "layout:@ @[%a@]@.as:@.@[<hv>" Layout.pp_frame_rec frame;
|
|
let r = layout box ui frame in
|
|
F.epr "@]@.";
|
|
r
|
|
end
|