Compare commits
2 Commits
c065a0423b
...
686d868a94
| Author | SHA1 | Date | |
|---|---|---|---|
| 686d868a94 | |||
| d3dc3d091b |
11
dune
11
dune
@ -31,11 +31,14 @@
|
||||
re
|
||||
lwt_react
|
||||
)
|
||||
(flags (-g))
|
||||
(link_flags (-linkall -g))
|
||||
|
||||
;; none of this makes backtraces work
|
||||
;;(flags (-g))
|
||||
;;(link_flags (-linkall -g))
|
||||
;;(ocamlopt_flags (:standard -O3 -unboxed-types))
|
||||
(ocamlc_flags (:standard -verbose))
|
||||
(modes byte_complete)
|
||||
;;(ocamlc_flags (:standard -verbose -g))
|
||||
|
||||
;;(modes byte_complete) ;; this causes backtraces to not work, but somehow includes the implementation of Toploop
|
||||
(preprocess
|
||||
(pps ppx_irmin))
|
||||
)
|
||||
|
||||
414
ogui.ml
414
ogui.ml
@ -3,6 +3,16 @@ 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
|
||||
|
||||
@ -91,7 +101,8 @@ let pp_text_row : Gv.Text.text_row F.t =
|
||||
])
|
||||
|
||||
let pp_color : Gv.Color.t Fmt.t =
|
||||
F.(
|
||||
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
|
||||
[
|
||||
@ -99,7 +110,7 @@ let pp_color : Gv.Color.t Fmt.t =
|
||||
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
|
||||
@ -126,18 +137,20 @@ module Margin = struct
|
||||
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))
|
||||
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.(
|
||||
v
|
||||
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=%f@;r=%f@;t=%f@;b=%f" t.left t.right t.top t.bottom
|
||||
F.pf ppf "l=%.2f@;r=%.2f@;t=%.2f@;b=%.2f" t.left t.right t.top
|
||||
t.bottom
|
||||
end
|
||||
|
||||
type margin = Margin.t
|
||||
@ -308,7 +321,7 @@ module TextBuffer = struct
|
||||
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 n) ->
|
||||
| Error (`Test_was _) ->
|
||||
F.epr "TextBuffer.save Error `Test_was %s@."
|
||||
"<not implemented>");
|
||||
Lwt.return_unit
|
||||
@ -764,7 +777,7 @@ module Ui = struct
|
||||
(match res with
|
||||
| Event.Accepted actions ->
|
||||
let rec exec : action list -> unit Lwt.t = function
|
||||
| Custom (name, f) :: actions ->
|
||||
| Custom (_name, f) :: actions ->
|
||||
f () >>= fun () -> exec actions
|
||||
| [] -> Lwt.return_unit
|
||||
in
|
||||
@ -792,14 +805,11 @@ module Ui = struct
|
||||
action list Event.result Lwt.t =
|
||||
Lwt_stream.last_new events >>= function
|
||||
| `Key (state, key, mods) ->
|
||||
Event.(
|
||||
F.epr "Ui.process_events `Key %a %a %a" pp_key_action
|
||||
state pp_key key pp_mods mods);
|
||||
|
||||
process_key ui r state key mods
|
||||
>>= fun (res : action list Event.result) ->
|
||||
Event.(
|
||||
F.epr " (%s)@."
|
||||
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"
|
||||
@ -825,14 +835,14 @@ module Ui = struct
|
||||
|
||||
module Style = struct
|
||||
type t = {
|
||||
stroke : float option * Gv.Color.t;
|
||||
stroke : (float * Gv.Color.t) option;
|
||||
fill : Gv.Color.t;
|
||||
margin : Margin.t;
|
||||
}
|
||||
|
||||
let default =
|
||||
{
|
||||
stroke = (None, Gv.Color.transparent);
|
||||
stroke = None;
|
||||
fill = Gv.Color.transparent;
|
||||
margin = Margin.empty;
|
||||
}
|
||||
@ -840,14 +850,14 @@ module Ui = struct
|
||||
let pp ppf t =
|
||||
F.pf ppf "%a"
|
||||
F.(
|
||||
record
|
||||
hovbox
|
||||
@@ record
|
||||
[
|
||||
field "stroke"
|
||||
(fun t -> t.stroke)
|
||||
(hbox
|
||||
@@ pair ~sep:comma
|
||||
(option ~none:(any "None") float)
|
||||
pp_color);
|
||||
(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;
|
||||
])
|
||||
@ -1215,16 +1225,20 @@ 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 [ `X | `Y | `Z ] * (frame * frame)
|
||||
| `String of string
|
||||
| `Buffer of TextBuffer.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 ]
|
||||
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)
|
||||
@ -1234,7 +1248,7 @@ module Layout = struct
|
||||
{ t; size; style }
|
||||
|
||||
let none = frame `None
|
||||
let join d ?style a b = frame ?style (`Join (d, (a, b)))
|
||||
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)
|
||||
@ -1251,11 +1265,28 @@ module Layout = struct
|
||||
let textedit_style =
|
||||
Style.
|
||||
{
|
||||
default with
|
||||
stroke = (Some 1.2, Gv.Color.rgbf ~r:0.9 ~g:0.9 ~b:0.9);
|
||||
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
|
||||
@ -1268,8 +1299,126 @@ module Layout = struct
|
||||
|> Lwd.map ~f:(fun tl -> frame ?size ~style (`TextEdit (t, tl)))
|
||||
|> Lwt.return
|
||||
|
||||
let system ui ?(style = textedit_style) d
|
||||
(telist : (int * TextEdit.t list) Lwd.var) =
|
||||
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
|
||||
@ -1282,15 +1431,12 @@ module Layout = struct
|
||||
Lwd.set cursor
|
||||
(if
|
||||
Lwd.peek cursor
|
||||
< (Lwd.peek telist |> snd |> List.length)
|
||||
- 1
|
||||
< (Lwd.peek telist |> length) - 1
|
||||
then Lwd.peek cursor + 1
|
||||
else 0);
|
||||
TextEdit.default_bindings
|
||||
(List.nth
|
||||
(Lwd.peek telist |> snd)
|
||||
(Lwd.peek cursor))
|
||||
ui;
|
||||
(*TextEdit.default_bindings
|
||||
(List.nth (Lwd.peek telist) (Lwd.peek cursor))
|
||||
ui; *)
|
||||
Lwt.return_unit );
|
||||
]
|
||||
|> Event.adds
|
||||
@ -1302,83 +1448,42 @@ module Layout = struct
|
||||
Lwd.set cursor
|
||||
(if Lwd.peek cursor > 0 then
|
||||
Lwd.peek cursor - 1
|
||||
else
|
||||
(Lwd.peek telist |> snd |> List.length) - 1);
|
||||
TextEdit.default_bindings
|
||||
(List.nth
|
||||
(Lwd.peek telist |> snd)
|
||||
(Lwd.peek cursor))
|
||||
ui;
|
||||
else (Lwd.peek telist |> length) - 1);
|
||||
(*TextEdit.default_bindings
|
||||
(List.nth (Lwd.peek telist) (Lwd.peek cursor))
|
||||
ui;*)
|
||||
Lwt.return_unit );
|
||||
]);
|
||||
Lwd.map_s
|
||||
~f:(fun (_, tl) ->
|
||||
Lwt_list.mapi_s
|
||||
(fun n te ->
|
||||
textedit
|
||||
~size:
|
||||
(match d with
|
||||
| `X -> (`Ratio 0.5, `Ratio 1.)
|
||||
| `Y -> (`Ratio 1., `Ratio 0.5)
|
||||
| `Z -> (`Ratio 1., `Ratio 1.))
|
||||
te
|
||||
>>= fun tl ->
|
||||
Lwd.map2 tl (Lwd.get cursor) ~f:(fun tl cursor ->
|
||||
{
|
||||
tl with
|
||||
style =
|
||||
{
|
||||
tl.style with
|
||||
stroke =
|
||||
( fst style.stroke,
|
||||
if n == cursor then
|
||||
Gv.Color.(transf (snd style.stroke) 0.5)
|
||||
else snd style.stroke );
|
||||
};
|
||||
})
|
||||
|> Lwt.return)
|
||||
tl
|
||||
>>= fun framelist -> box ~style d framelist |> Lwt.return)
|
||||
(Lwd.get telist)
|
||||
|
||||
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
|
||||
|
||||
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_size ppf (x, y) =
|
||||
(match x with
|
||||
| `Pixels p -> F.pf ppf "`Pixels %f.2, " p
|
||||
| `Ratio p -> F.pf ppf "`Ratio %f.2, " p);
|
||||
match y with
|
||||
| `Pixels p -> F.pf ppf "`Pixels %f.2" p
|
||||
| `Ratio p -> F.pf ppf "`Ratio %f.2" p
|
||||
|
||||
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 parse_t_frame s =
|
||||
match s with
|
||||
| "`Box" -> `Vbox
|
||||
| "`Buffer" -> `Buffer
|
||||
| "`TextEdit" -> `TextEdit
|
||||
| "`None" -> `None
|
||||
| s -> `S s
|
||||
end
|
||||
|
||||
module Painter = struct
|
||||
@ -1391,11 +1496,12 @@ module Painter = struct
|
||||
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;
|
||||
set_stroke_color t ~color:(snd style.stroke);
|
||||
|
||||
(match style.stroke with
|
||||
| None, _ -> ()
|
||||
| Some width, _ ->
|
||||
| None -> ()
|
||||
| Some (width, color) ->
|
||||
set_stroke_width t ~width;
|
||||
set_stroke_color t ~color;
|
||||
stroke t);
|
||||
fill t
|
||||
|
||||
@ -1408,7 +1514,22 @@ module Painter = struct
|
||||
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)
|
||||
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 =
|
||||
@ -1417,12 +1538,13 @@ module Painter = struct
|
||||
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 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 contents_len = String.length contents in
|
||||
let row_count =
|
||||
Gv.Text.break_lines t ~break_width:(Box2.w rect) ~max_rows
|
||||
~lines ~start:(Lwd.peek te.scroll) contents
|
||||
@ -1439,6 +1561,7 @@ module Painter = struct
|
||||
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) )
|
||||
@ -1474,7 +1597,6 @@ module Painter = struct
|
||||
(Box2.o rect, Lwd.peek te.scroll)
|
||||
(Seq.take row_count (Array.to_seq lines))
|
||||
|> fst
|
||||
|> (fun cur''' -> V2.(cur''' - v 0. line_height))
|
||||
|> Box2.(of_pts (o rect))
|
||||
|> Lwt.return
|
||||
|
||||
@ -1482,37 +1604,61 @@ module Painter = struct
|
||||
({ t; style; size = sx, sy } : frame) : box2 Lwt.t =
|
||||
let box =
|
||||
Box2.v (Box2.o box)
|
||||
(V2.v
|
||||
(Size2.v
|
||||
(match sx with
|
||||
| `Ratio r -> Box2.w box *. r
|
||||
| `Pixels p -> p)
|
||||
| `Pixels p -> p
|
||||
| `Fun f -> f box)
|
||||
(match sy with
|
||||
| `Ratio r -> Box2.h box *. r
|
||||
| `Pixels p -> p))
|
||||
| `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)) ->
|
||||
Lwt_list.fold_left_s
|
||||
(fun (c : box2) f ->
|
||||
layout c ui f >>= fun r ->
|
||||
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 r) (miny c)) (max c)
|
||||
| `Y -> of_pts (V2.v (minx c) (maxy r)) (max c)
|
||||
| `Z -> box)
|
||||
| `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
|
||||
Lwt.return c')
|
||||
box' [ a; b ]
|
||||
| `TextEdit tt -> text_layout ui.gv box' tt
|
||||
| _ -> Lwt.return box)
|
||||
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
|
||||
(*Box2.add_pt r
|
||||
V2.(Box2.max r + v style.margin.right style.margin.bottom)
|
||||
|> Margin.outer style.margin
|
||||
|> *)
|
||||
Margin.outer style.margin r
|
||||
in
|
||||
draw_box ui.gv ~box:r' ~style;
|
||||
|
||||
(*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
|
||||
|
||||
41
oplevel.ml
41
oplevel.ml
@ -67,9 +67,6 @@ let main =
|
||||
(* 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 ();
|
||||
|
||||
let rootrepo =
|
||||
Store.init_default
|
||||
(F.str "%s/console/rootstore.git" Secrets.giturl)
|
||||
@ -81,6 +78,7 @@ let main =
|
||||
|
||||
load_fonts ui.gv;
|
||||
|
||||
(* Format.safe_set_geometry ~max_indent:(500 - 1) ~margin:500; *)
|
||||
let event_stream, event_push = Lwt_stream.create () in
|
||||
Ogui.Ui.process_events ui event_stream;
|
||||
GLFW.setKeyCallback ~window
|
||||
@ -128,7 +126,7 @@ let main =
|
||||
(String.concat "/" initial_path))
|
||||
|> Lwt.return
|
||||
>>= fun to_init ->
|
||||
let out_ppf =
|
||||
let _out_ppf =
|
||||
let insert s =
|
||||
Lwt.async (fun () ->
|
||||
TextBuffer.length to_init >>= fun len ->
|
||||
@ -146,9 +144,12 @@ let main =
|
||||
}
|
||||
in
|
||||
|
||||
(*F.pr "oplevel.ml: Toploop.initialize_toplevel_env@.";
|
||||
Toploop.initialize_toplevel_env ();
|
||||
Clflags.debug := true;
|
||||
ignore
|
||||
(Toploop.use_input out_ppf
|
||||
(String "#use \"topfind\";;\n#list;;#require \"lwt\";;"));
|
||||
(String "#use \"topfind\";;\n#list;;#require \"lwt\";;")); *)
|
||||
(* toplevel execution binding *)
|
||||
Ui.(
|
||||
update_bindings ui
|
||||
@ -166,36 +167,24 @@ let main =
|
||||
Custom
|
||||
( "toplevel_execute",
|
||||
fun () ->
|
||||
TextBuffer.peek tb_init >>= fun str ->
|
||||
Toploop.use_input out_ppf (String str)
|
||||
|> F.epr "Toploop.use_input=%b@.";
|
||||
TextBuffer.peek tb_init >>= fun _str ->
|
||||
(*Toploop.use_input out_ppf (String str)
|
||||
|> F.epr "Toploop.use_input=%b@."; *)
|
||||
Lwt.return_unit );
|
||||
]));
|
||||
|
||||
Layout.(
|
||||
system ui `Y
|
||||
~style:
|
||||
Style.{ default with margin = Margin.symmetric 10.0 10.0 }
|
||||
WindowManager.make ui
|
||||
(Lwd.var
|
||||
~eq:(fun (a, _) (b, _) -> Int.equal a b)
|
||||
( 0,
|
||||
(`T
|
||||
( `Y,
|
||||
[
|
||||
TextEdit.multiline ui tb_init;
|
||||
TextEdit.multiline ui to_init;
|
||||
(`TextEdit (TextEdit.multiline ui to_init), `Ratio 0.333);
|
||||
(`TextEdit (TextEdit.multiline ui tb_init), `Ratio 0.5);
|
||||
(`TextEdit (TextEdit.multiline ui to_init), `Ratio 1.0);
|
||||
] )))
|
||||
>>= fun page ->
|
||||
let page_root = Lwd.observe page in
|
||||
|
||||
let open GLFW in
|
||||
let open Event in
|
||||
Ui.update_bindings ui
|
||||
Ui.(
|
||||
adds
|
||||
[
|
||||
[ Key (Press, X, [ Control ]); Key (Press, E, [ Control ]) ];
|
||||
]
|
||||
[ Custom ("toplevel_execute", fun () -> Lwt.return ()) ]);
|
||||
|
||||
let bindings =
|
||||
ui.bindings |> Lwd.get |> Lwd.observe |> Lwd.quick_sample |> snd
|
||||
in
|
||||
|
||||
Reference in New Issue
Block a user