diff --git a/dune b/dune index 1414199..ddcb786 100644 --- a/dune +++ b/dune @@ -13,6 +13,7 @@ (modules store) ) + (executables (names oplevel) (modules oplevel secrets perfgraph ogui glfw_types) @@ -31,9 +32,9 @@ lwd ) (link_flags (-linkall)) - (ocamlopt_flags (:standard -O3 -unboxed-types)) - (ocamlc_flags (:standard -verbose)) - (modes byte) + (ocamlopt_flags (:standard -O3 -unboxed-types)) + (ocamlc_flags (:standard -verbose)) + (modes byte_complete) (preprocess (pps ppx_irmin)) ) diff --git a/dune-project b/dune-project index fb9ead4..ad06708 100644 --- a/dune-project +++ b/dune-project @@ -1,2 +1,2 @@ -(lang dune 3.4) +(lang dune 3.6) (name oplevel) diff --git a/ogui.ml b/ogui.ml index c04257d..60f4e84 100644 --- a/ogui.ml +++ b/ogui.ml @@ -107,7 +107,7 @@ module TextBuffer = struct Lwt.return { path = Lwd.var initial_path; tree = Lwd.var tree; repo } - let of_string ~path ?(repo = None) str = + let of_string ~path ?(repo : Store.Sync.db Lwt.t option) str = { path = Lwd.var path; tree = Lwd.var @@ Store.S.Tree.singleton path str; @@ -141,6 +141,21 @@ module TextBuffer = struct Lwd.set tree t; 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 -> Nonep@."; + 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; *) @@ -200,6 +215,9 @@ module TextBuffer = struct Store.S.Tree.get tree path) |> lwt_lwd + 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) @@ -634,9 +652,9 @@ module Ui = struct ] in - (*Event.( + Event.( F.epr "Ui.keycallback %a %a %a@." pp_key key pp_key_action state - pp_mods mods); *) + pp_mods mods); match Event.resolve (Key (state, key, mods)) res with | Event.Accepted actions -> callback_resolver := None; @@ -658,7 +676,7 @@ module Ui = struct let chrcallback_ref : (Uchar.t -> unit Lwt.t) ref = ref (fun _c -> - (* F.epr "chrcallback: '%a'@." pp_uchar _c; *) + F.epr "chrcallback: '%a'@." pp_uchar _c; Lwt.return_unit) let chrcallback _t (chr : int) : unit Lwt.t = @@ -1019,7 +1037,6 @@ module TextEdit = struct end module Layout = struct - open Gg module Style = Ui.Style type frame = { t : t; mutable size : size; style : Style.t } @@ -1031,27 +1048,29 @@ module Layout = struct | `TextEdit of TextEdit.t * TextLayout.layout | `None ] - and size = [ `Fixed of size2 | `Max | `Min ] + and dim = [ `Ratio of float | `Pixels of float ] + and size = dim * dim - let frame ?(size = `Max) ?(style = Style.default) t : frame = + 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 d ?style a b = frame ?style (`Join (d, (a, b))) - let box d ?style = - List.fold_left (fun acc a -> join d ?style a acc) none - (* let hbox, vbox, zbox = (box `X, box `Y, box `Z) *) - let pack_x ?style () = (none, join `X ?style) - let pack_y ?style () = (none, join `Y ?style) - let pack_z ?style () = (none, join `Z ?style) - let hcat ?style = Lwd_utils.reduce (pack_x ?style ()) + 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 hbox ?style = Lwd_utils.pack (pack_x ?style ()) - let vbox ?style = Lwd_utils.pack (pack_y ?style ()) - let zbox ?style = Lwd_utils.pack (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. @@ -1073,6 +1092,59 @@ module Layout = struct |> Lwd.map ~f:(fun tl -> frame ?size ~style (`TextEdit (t, tl))) |> Lwt.return + let tiling ui ?(style = textedit_style) d (telist : TextEdit.t list) + = + let cursor = Lwd.var 0 in + let len = List.length telist in + Ui.update_bindings ui (fun a -> + a + |> Event.adds + [ + (*[ Key (Press, X, [Control])]; + [ Key (Release, X, [Control])];*) + [ Key (Press, O, [ Control ]) ]; + ] + [ + Ui.Custom + (fun () -> + Lwd.set cursor + (if Lwd.peek cursor < len - 1 then + Lwd.peek cursor + 1 + else 0); + TextEdit.default_bindings + (List.nth telist (Lwd.peek cursor)) + ui; + Lwt.return_unit); + ]); + let teln = List.length telist in + let ratio n = `Ratio (1. /. float (teln - (n + 1))) in + 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) + telist + >>= fun framelist -> box ~style d framelist |> Lwt.return + let pp_dir ppf (t : [ `X | `Y | `Z ]) = F.pf ppf "%s" (match t with `X -> "`X" | `Y -> "`Y" | `Z -> "`Z") @@ -1086,10 +1158,13 @@ module Layout = struct | `String s -> F.str "`String %s" s | `None -> "`None") - let pp_size ppf = function - | `Fixed p -> F.pf ppf "`Fixed %a" Gg.V2.pp p - | `Max -> F.pf ppf "`Max" - | `Min -> F.pf ppf "`Min" + 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.( @@ -1206,8 +1281,18 @@ module Painter = struct |> Box2.(of_pts (o rect)) |> Lwt.return - let rec layout (box : box2) (ui : Ui.t) ({ t; style; _ } : frame) : - box2 Lwt.t = + let rec layout (box : box2) (ui : Ui.t) + ({ t; style; size = sx, sy } : frame) : box2 Lwt.t = + let box = + Box2.v (Box2.o box) + (V2.v + (match sx with + | `Ratio r -> Box2.w box *. r + | `Pixels p -> p) + (match sy with + | `Ratio r -> Box2.h box *. r + | `Pixels p -> p)) + in let box' = Margin.inner style.margin box in (match t with | `Join (dir, (a, b)) -> @@ -1217,8 +1302,8 @@ module Painter = struct let c' = Box2.( match dir with - | `X -> of_pts (V2.v (minx c) (maxy r)) (max c) - | `Y -> of_pts (V2.v (maxx r) (miny c)) (max c) + | `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') diff --git a/oplevel.ml b/oplevel.ml index 6dd30ef..1e79d7a 100644 --- a/oplevel.ml +++ b/oplevel.ml @@ -70,6 +70,7 @@ let main = 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) @@ -98,24 +99,80 @@ let main = Ogui.Ui.chrcallback ui ch >>= fun _ -> Lwt.return_unit))) |> ignore; + GLFW.setWindowSizeCallback ~window + ~f: + (Some + Gg.( + fun _window x y -> + Lwd.set ui.rect + (Box2.v V2.zero (V2.v (float x) (float y))))) + |> ignore; + F.pr "oplevel.ml: building initial page@."; - TextBuffer.of_repo - ~initial_path:[ ".config"; "init.ml" ] - ~repo:rootrepo - >>= fun tb_init -> - Layout.textedit (TextEdit.multiline ui tb_init) >>= fun te_init -> - let page = - Layout.( - vbox - ~style: - Style.{ default with margin = Margin.symmetric 10.0 10.0 } - [ - te_init; - (*textedit - (TextEdit.multiline ui - (TextBuffer.of_repo ~path:[ "README" ] ~repo:rootrepo)); *) - ]) + let initial_path = [ ".config"; "init.ml" ] in + TextBuffer.of_repo ~initial_path ~repo:rootrepo >>= fun tb_init -> + TextBuffer.of_string ~repo:rootrepo + ~path: + (List.fold_right + (fun a (acc : string list) -> + match acc with + | [] -> [ F.str "%s.output" a ] + | a' -> a :: a') + [] initial_path) + (F.str "(* --- output:%s --- *)\n\n" + (String.concat "/" initial_path)) + |> Lwt.return + >>= fun to_init -> + let out_ppf = + let insert s = + Lwt.async (fun () -> + TextBuffer.length to_init >>= fun len -> + (* TKTK if buffer is modified here during yield from >>= it could be weird *) + TextBuffer.insert to_init len s) + in + Format.formatter_of_out_functions + Format. + { + out_string = (fun s _ _ -> insert s); + out_flush = (fun () -> ()); + out_indent = (fun n -> insert (String.make (n * 2) ' ')); + out_newline = (fun () -> insert "\n"); + out_spaces = (fun n -> insert (String.make n ' ')); + } in + + ignore + (Toploop.use_input out_ppf (String "#use \"topfind\";;\n#list;;")); + (* toplevel execution binding *) + Ui.( + update_bindings ui + Event.( + fun a -> + a + |> adds + [ + [ + Key (Press, X, [ Control ]); + Key (Release, X, [ Control ]); + Key (Press, E, [ Control ]); + ]; + ] + [ + Custom + (fun () -> + F.epr "Ctrl-X Ctrl-E@."; + TextBuffer.peek tb_init >>= fun str -> + Toploop.use_input out_ppf (String str) + |> F.epr "Toploop.use_input=%b@."; + Lwt.return_unit); + ])); + + Layout.( + tiling ui `Y + ~style: + Style.{ default with margin = Margin.symmetric 10.0 10.0 } + [ TextEdit.multiline ui tb_init; TextEdit.multiline ui to_init ]) + >>= fun page -> let page_root = Lwd.observe page in let open GLFW in @@ -178,25 +235,5 @@ let main = Printf.printf "MIN %.2f\n" !min_fps; Printf.printf "MAX %.2f\n%!" !max_fps; Lwt.return_unit -(* let out_ppf = - Format.formatter_of_out_functions - Format. - { - out_string = (fun s _ _ -> output_buffer#insert s); - out_flush = (fun () -> ()); - out_indent = - (fun n -> - for _ = 0 to n do - output_buffer#insert " " - done); - out_newline = (fun () -> output_buffer#insert "\n"); - out_spaces = - (fun n -> output_buffer#insert (String.make n ' ')); - } - in *) - -(* ignore - (Toploop.use_input out_ppf - (String "#use \"topfind\";;\n#list;;")); *) let () = Lwt_main.run main