From d3dc3d091b7e4b1d956a494a9888c1b084c8020e Mon Sep 17 00:00:00 2001 From: cqc Date: Wed, 17 Jul 2024 20:23:46 -0500 Subject: [PATCH] rewrote a bunch of pieces of the gui layouts, it's still silly but it might work now --- dune | 11 +- ogui.ml | 382 +++++++++++++++++++++++++++++++++-------------------- oplevel.ml | 47 +++---- 3 files changed, 266 insertions(+), 174 deletions(-) diff --git a/dune b/dune index 721226d..7ce7be1 100644 --- a/dune +++ b/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)) ) diff --git a/ogui.ml b/ogui.ml index f6f99b7..0511065 100644 --- a/ogui.ml +++ b/ogui.ml @@ -3,6 +3,8 @@ module Gv = Graphv_gles2_native module F = Fmt module Str = Re.Str +let pair a b = (a, b) + module Lwd = struct open Lwt_react @@ -91,15 +93,16 @@ let pp_text_row : Gv.Text.text_row F.t = ]) let pp_color : Gv.Color.t Fmt.t = - 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; - ]) + 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 @@ -126,7 +129,7 @@ module Margin = struct let sum t : size2 = Size2.v (t.left +. t.right) (t.top +. t.bottom) let inner t b : box2 = - Box2.v + Box2.of_pts (V2.v (Box2.minx b +. t.left) (Box2.miny b +. t.top)) (V2.v (Box2.maxx b -. t.right) (Box2.maxy b -. t.bottom)) @@ -137,7 +140,8 @@ module Margin = struct (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 +312,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@." ""); Lwt.return_unit @@ -764,7 +768,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 +796,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 +826,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,17 +841,17 @@ module Ui = struct let pp ppf t = F.pf ppf "%a" F.( - record - [ - field "stroke" - (fun t -> t.stroke) - (hbox - @@ pair ~sep:comma - (option ~none:(any "None") float) - pp_color); - field "fill" (fun t -> t.fill) pp_color; - field "margin" (fun t -> t.margin) Margin.pp; - ]) + 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 @@ -1215,16 +1216,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) + [ `Join of dir * (frame * frame) | `String of string | `Buffer of TextBuffer.t | `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) @@ -1251,11 +1256,26 @@ 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 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,80 +1288,6 @@ 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 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 |> snd |> List.length) - - 1 - then Lwd.peek cursor + 1 - else 0); - TextEdit.default_bindings - (List.nth - (Lwd.peek telist |> snd) - (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 |> snd |> List.length) - 1); - TextEdit.default_bindings - (List.nth - (Lwd.peek telist |> snd) - (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) - >>= 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") @@ -1355,13 +1301,12 @@ module Layout = struct | `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_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.( @@ -1372,6 +1317,21 @@ module Layout = struct 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 @[%s@]" s + | `None -> pf ppf "`None" + + and pp_frame_rec ppf t = + F.pf ppf "@[[%a] %a@]" pp_size t.size pp_t_rec t.t + let parse_t_frame s = match s with | "`Box" -> `Vbox @@ -1381,6 +1341,119 @@ module Layout = struct | s -> `S s end +module WindowManager = struct + type dir = Layout.dir + + type t = + [ `T of dir * t list + | `TextEdit of TextEdit.t * Layout.dim + | `Frame of Layout.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 Layout.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 frame_of_window (ui : Ui.t) (n : int) cursor style + (content : Layout.frame Lwd.t) : Layout.frame Lwd.t Lwt.t = + let open Layout in + textedit + ~size:(`Ratio 1.0, `Pixels 30.) + ~style + (TextEdit.multiline ui + (TextBuffer.of_string + ~path:[ F.str "window/%d/status" n ] + (F.str "window/%d" n))) + >>= fun status -> + Lwd.map2 (Lwd.map2 content status ~f:pair) (Lwd.get cursor) + ~f:(fun (tt', status) cursor -> + join `Y + ~style: + { + tt'.style with + stroke = + Option.map + (fun (s, c) -> + ( s, + if n != cursor then Gv.Color.(transf c 0.3) + else c )) + tt'.style.stroke; + } + tt' status) + |> Lwt.return + + let make ui ?(style = Layout.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 : t -> Layout.frame Lwd.t Lwt.t = function + | `T (dir', tl) -> + Lwt_list.fold_left_s + (fun f t -> + fold dir' t >>= fun newf -> + Lwd.map2 f newf ~f:(Layout.join dir') |> Lwt.return) + (Lwd.pure Layout.none) tl + | `Frame f' -> + frame_of_window ui 314 cursor style (Lwd.return f') + | `TextEdit (t', dim) -> + Layout.textedit + ~size: + (match dir with + | `X -> (dim, `Ratio 1.) + | `Y -> (`Ratio 1., dim) + | `Z -> (dim, dim)) + ~style t' + >>= fun tt -> frame_of_window ui 314 cursor style tt + in + fold `X tl) + >>= fun d -> Lwd.join d |> Lwt.return +end + module Painter = struct open Layout open Gg @@ -1391,11 +1464,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 @@ -1410,6 +1484,9 @@ module Painter = struct Text.set_size t ~size:font_size; Text.set_align t ~align:Align.(left lor top) + let string (t : Gv.t) (rect : box2) str : box2 Lwt.t = + Lwt.return Gg.Box2.zero + let text_layout (t : Gv.t) (rect : box2) ((te, layout) : TextEdit.t * TextLayout.layout) : box2 Lwt.t = let g = layout in @@ -1417,12 +1494,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 +1517,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 +1553,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 @@ -1485,34 +1563,54 @@ module Painter = struct (V2.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 (match t with | `Join (dir, (a, b)) -> - Lwt_list.fold_left_s - (fun (c : box2) f -> - layout c ui f >>= fun r -> - 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) - in - Lwt.return c') - box' [ a; b ] - | `TextEdit tt -> text_layout ui.gv box' tt - | _ -> Lwt.return box) + F.epr "`Join %a (@,@[" pp_dir dir; + layout box' ui a >>= fun ra -> + 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.zero + | `String s -> string ui.gv box' s + | _ -> + F.epr "Layout not implemented!!@."; + Lwt.return Gg.Box2.zero) >>= fun r -> + draw_box ui.gv ~box:r ~style; let r' = - Box2.add_pt r - V2.(Box2.max r + v style.margin.right style.margin.bottom) - |> Margin.outer style.margin + (*Box2.add_pt r + V2.(Box2.max r + v style.margin.right style.margin.bottom) + |> *) + 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:@.@[" Layout.pp_frame_rec frame; + let r = layout box ui frame in + F.epr "@]@."; + r end diff --git a/oplevel.ml b/oplevel.ml index f06d39e..56c21d3 100644 --- a/oplevel.ml +++ b/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 @@ -146,9 +144,12 @@ let main = } in - ignore - (Toploop.use_input out_ppf - (String "#use \"topfind\";;\n#list;;#require \"lwt\";;")); + (*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\";;")); *) (* toplevel execution binding *) Ui.( update_bindings ui @@ -166,36 +167,26 @@ 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 } - (Lwd.var - ~eq:(fun (a, _) (b, _) -> Int.equal a b) - ( 0, + WindowManager.make ui + ~style: + Layout.Style. + { default with margin = Margin.symmetric 10.0 10.0 } + (Lwd.var + (`T + ( `Y, [ - TextEdit.multiline ui tb_init; - TextEdit.multiline ui to_init; + `TextEdit (TextEdit.multiline ui tb_init, `Ratio 1.0); + `TextEdit (TextEdit.multiline ui to_init, `Ratio 0.5); ] ))) >>= 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