basic

.ocamlformat

@@ -0,0 +1,3 @@
+profile = default
+version = 0.26.2
+parse-toplevel-phrases=false

dune

@@ -13,26 +13,32 @@
  (modules store)
 )
 
+
 (executables
  (names oplevel)
  (modules oplevel secrets perfgraph ogui glfw_types)
  (libraries
    lwt
    store
-   memtrace
+   ;;memtrace
    glfw-ocaml
    tgls
    tgls.tgles2
    graphv_gles2_native
    gg
    irmin-git
- ;  compiler-libs.toplevel
+   compiler-libs.toplevel
    re
+   lwt_react
  )
-; (link_flags (-linkall))
+
- ; (ocamlopt_flags (:standard -O3 -unboxed-types))
+ ;; none of this makes backtraces work
-  (ocamlc_flags (:standard -verbose))
+ ;;(flags (-g))
- (modes byte)
+ ;;(link_flags (-linkall -g))
+ ;;(ocamlopt_flags (:standard -O3 -unboxed-types))
+ ;;(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))
 )

dune-project

@@ -1,2 +1,2 @@
-(lang dune 3.4)
+(lang dune 3.15)
 (name oplevel)

opam_switch

@@ -0,0 +1,275 @@
+opam-version: "2.0"
+compiler: ["ocaml-variants.5.1.1+options"]
+roots: [
+  "camlp5.8.03.00"
+  "gg.1.0.0"
+  "glfw-ocaml.3.3.1-2"
+  "graphv_gles2_native.0.1.1"
+  "irmin-git.3.9.0"
+  "lablgtk3.3.1.4"
+  "lablgtk3-sourceview3.3.1.4"
+  "lwd.0.3"
+  "lwt_glib.1.1.1"
+  "memtrace.0.2.3"
+  "merlin.4.14-501"
+  "ocamlformat.0.26.2"
+  "odig.0.0.9"
+  "stb_image.0.5"
+  "tgls.0.8.6"
+  "tuareg.3.0.1"
+  "user-setup.0.7"
+  "utop.2.14.0"
+]
+installed: [
+  "angstrom.0.16.0"
+  "arp.3.1.1"
+  "asn1-combinators.0.2.6"
+  "astring.0.8.5"
+  "awa.0.3.0"
+  "awa-mirage.0.3.0"
+  "b0.0.0.5"
+  "base.v0.16.3"
+  "base-bigarray.base"
+  "base-bytes.base"
+  "base-domains.base"
+  "base-nnp.base"
+  "base-threads.base"
+  "base-unix.base"
+  "base64.3.5.1"
+  "bheap.2.0.0"
+  "bigarray-compat.1.1.0"
+  "bigstringaf.0.9.1"
+  "biniou.1.2.2"
+  "bos.0.2.1"
+  "ca-certs.0.2.3"
+  "ca-certs-nss.3.98"
+  "cairo2.0.6.4"
+  "camlp-streams.5.0.1"
+  "camlp5.8.03.00"
+  "camlp5-buildscripts.0.03"
+  "carton.0.7.1"
+  "carton-git.0.7.1"
+  "carton-lwt.0.7.1"
+  "cf.0.5.0"
+  "cf-lwt.0.5.0"
+  "checkseum.0.5.2"
+  "cmdliner.1.2.0"
+  "cohttp.5.3.1"
+  "cohttp-lwt.5.3.0"
+  "cohttp-lwt-unix.5.3.0"
+  "conduit.6.2.2"
+  "conduit-lwt.6.2.2"
+  "conduit-lwt-unix.6.2.2"
+  "conf-bash.1"
+  "conf-cairo.1"
+  "conf-emacs.1"
+  "conf-gles2.1"
+  "conf-glfw3.2"
+  "conf-glib-2.1"
+  "conf-gmp.4"
+  "conf-gmp-powm-sec.3"
+  "conf-gtk3.18"
+  "conf-gtksourceview3.0+2"
+  "conf-libffi.2.0.0"
+  "conf-m4.1"
+  "conf-perl.2"
+  "conf-pkg-config.3"
+  "conf-which.1"
+  "cppo.1.6.9"
+  "crunch.3.3.1"
+  "csexp.1.5.2"
+  "cstruct.6.2.0"
+  "cstruct-lwt.6.2.0"
+  "cstruct-unix.6.2.0"
+  "ctypes.0.20.2"
+  "ctypes-foreign.0.18.0"
+  "decompress.1.5.3"
+  "digestif.1.2.0"
+  "dispatch.0.5.0"
+  "dns.7.0.3"
+  "dns-client.7.0.3"
+  "dns-client-lwt.7.0.3"
+  "dns-client-mirage.7.0.3"
+  "domain-name.0.4.0"
+  "dot-merlin-reader.4.9"
+  "duff.0.5"
+  "dune.3.15.2"
+  "dune-build-info.3.15.2"
+  "dune-configurator.3.15.2"
+  "duration.0.2.1"
+  "easy-format.1.3.4"
+  "either.1.0.0"
+  "emile.1.1"
+  "encore.0.8"
+  "eqaf.0.9"
+  "ethernet.3.2.0"
+  "faraday.0.8.2"
+  "fix.20230505"
+  "fmt.0.9.0"
+  "fpath.0.7.3"
+  "fsevents.0.3.0"
+  "fsevents-lwt.0.3.0"
+  "functoria-runtime.4.4.2"
+  "gg.1.0.0"
+  "git.3.15.0"
+  "git-mirage.3.15.0"
+  "git-paf.3.15.0"
+  "git-unix.3.15.0"
+  "glfw-ocaml.3.3.1-2"
+  "gmap.0.3.0"
+  "graphql.0.14.0"
+  "graphql-cohttp.0.14.0"
+  "graphql-lwt.0.14.0"
+  "graphql_parser.0.14.0"
+  "graphv_core.0.1.1"
+  "graphv_core_lib.0.1.1"
+  "graphv_font.0.1.1"
+  "graphv_font_stb_truetype.0.1.1"
+  "graphv_gles2.0.1.1"
+  "graphv_gles2_native.0.1.1"
+  "graphv_gles2_native_impl.0.1.1"
+  "h2.0.11.0"
+  "happy-eyeballs.0.6.0"
+  "happy-eyeballs-lwt.0.6.0"
+  "happy-eyeballs-mirage.0.6.0"
+  "hashcons.1.4.0"
+  "hex.1.5.0"
+  "hkdf.1.0.4"
+  "hpack.0.11.0"
+  "httpaf.0.7.1"
+  "hxd.0.3.2"
+  "index.1.6.2"
+  "inotify.2.5"
+  "integers.0.7.0"
+  "ipaddr.5.5.0"
+  "ipaddr-cstruct.5.5.0"
+  "ipaddr-sexp.5.5.0"
+  "irmin.3.9.0"
+  "irmin-fs.3.9.0"
+  "irmin-git.3.9.0"
+  "irmin-graphql.3.9.0"
+  "irmin-pack.3.9.0"
+  "irmin-tezos.3.9.0"
+  "irmin-watcher.0.5.0"
+  "jsonm.1.0.2"
+  "ke.0.6"
+  "lablgtk3.3.1.4"
+  "lablgtk3-sourceview3.3.1.4"
+  "lambda-term.3.3.2"
+  "logs.0.7.0"
+  "lru.0.3.1"
+  "lwd.0.3"
+  "lwt.5.7.0"
+  "lwt-dllist.1.0.1"
+  "lwt_glib.1.1.1"
+  "lwt_react.1.2.0"
+  "macaddr.5.5.0"
+  "macaddr-cstruct.5.5.0"
+  "magic-mime.1.3.1"
+  "memtrace.0.2.3"
+  "menhir.20231231"
+  "menhirCST.20231231"
+  "menhirLib.20231231"
+  "menhirSdk.20231231"
+  "merlin.4.14-501"
+  "merlin-lib.4.14-501"
+  "metrics.0.4.1"
+  "metrics-lwt.0.4.1"
+  "mew.0.1.0"
+  "mew_vi.0.5.0"
+  "mimic.0.0.6"
+  "mimic-happy-eyeballs.0.0.6"
+  "mirage-clock.4.2.0"
+  "mirage-clock-unix.4.2.0"
+  "mirage-crypto.0.11.3"
+  "mirage-crypto-ec.0.11.3"
+  "mirage-crypto-pk.0.11.3"
+  "mirage-crypto-rng.0.11.3"
+  "mirage-crypto-rng-lwt.0.11.3"
+  "mirage-device.2.0.0"
+  "mirage-flow.3.0.0"
+  "mirage-kv.6.1.1"
+  "mirage-net.4.0.0"
+  "mirage-no-solo5.1"
+  "mirage-random.3.0.0"
+  "mirage-runtime.4.5.1"
+  "mirage-time.3.0.0"
+  "mirage-unix.5.0.1"
+  "mtime.2.0.0"
+  "not-ocamlfind.0.13"
+  "num.1.5"
+  "ocaml.5.1.1"
+  "ocaml-compiler-libs.v0.12.4"
+  "ocaml-config.3"
+  "ocaml-syntax-shims.1.0.0"
+  "ocaml-variants.5.1.1+options"
+  "ocaml-version.3.6.7"
+  "ocamlbuild.0.14.3"
+  "ocamlfind.1.9.6"
+  "ocamlformat.0.26.2"
+  "ocamlformat-lib.0.26.2"
+  "ocamlgraph.2.1.0"
+  "ocp-indent.1.8.1"
+  "ocplib-endian.1.2"
+  "odig.0.0.9"
+  "odoc.2.4.2"
+  "odoc-parser.2.4.2"
+  "optint.0.3.0"
+  "paf.0.5.0"
+  "parsexp.v0.16.0"
+  "pbkdf.1.2.0"
+  "pecu.0.7"
+  "ppx_derivers.1.2.1"
+  "ppx_deriving.5.2.1"
+  "ppx_enumerate.v0.16.0"
+  "ppx_irmin.3.9.0"
+  "ppx_repr.0.7.0"
+  "ppx_sexp_conv.v0.16.0"
+  "ppxlib.0.32.1"
+  "progress.0.4.0"
+  "psq.0.2.1"
+  "ptime.1.1.0"
+  "randomconv.0.1.3"
+  "re.1.11.0"
+  "react.1.2.2"
+  "repr.0.7.0"
+  "result.1.5"
+  "rresult.0.7.0"
+  "rusage.1.0.0"
+  "semaphore-compat.1.0.1"
+  "seq.base"
+  "sexplib.v0.16.0"
+  "sexplib0.v0.16.0"
+  "stb_image.0.5"
+  "stb_truetype.0.7"
+  "stdio.v0.16.0"
+  "stdlib-shims.0.3.0"
+  "stringext.1.6.0"
+  "tcpip.8.0.0"
+  "terminal.0.4.0"
+  "tezos-base58.1.0.0"
+  "tgls.0.8.6"
+  "tls.0.17.3"
+  "tls-lwt.0.17.3"
+  "tls-mirage.0.17.3"
+  "topkg.1.0.7"
+  "trie.1.0.0"
+  "tuareg.3.0.1"
+  "tyxml.4.6.0"
+  "uchar.0.0.2"
+  "uri.4.4.0"
+  "uri-sexp.4.4.0"
+  "user-setup.0.7"
+  "utop.2.14.0"
+  "uucp.15.1.0"
+  "uuseg.15.1.0"
+  "uutf.1.0.3"
+  "vector.1.0.0"
+  "webmachine.0.7.0"
+  "x509.0.16.5"
+  "xdg.3.15.2"
+  "yaml.3.2.0"
+  "yojson.2.1.2"
+  "zarith.1.13"
+  "zed.3.2.3"
+]

oplevel.ml

@@ -18,7 +18,7 @@ end
 let errorcb error desc =
   Printf.printf "GLFW error %d: %s\n%!" error desc
 
-let load_data vg =
+let load_fonts vg =
   let _ = Gv.Text.create vg ~name:"mono" ~file:"./assets/mono.ttf" in
   let _ =
     Gv.Text.create vg ~name:"icons" ~file:"./assets/entypo.ttf"
@@ -38,7 +38,7 @@ let load_data vg =
   Gv.Text.add_fallback vg ~name:"sans-bold" ~fallback:"emoji";
   Gv.Text.set_font_face vg ~name:"mono"
 
-let () =
+let main =
   GLFW.init ();
   at_exit GLFW.terminate;
   let _res = GLFWExtras.glfwSetErrorCallback errorcb in
@@ -55,23 +55,15 @@ let () =
 
   Gl.clear_color 0.1 0.2 0.2 1.;
 
-  Memtrace.trace_if_requested ();
+  (*Memtrace.trace_if_requested (); *)
-
   let ctx =
     Gv.create ~flags:Gv.CreateFlags.(antialias lor stencil_strokes) ()
   in
 
   let graph = Perfgraph.init Perfgraph.FPS "Frame Time" in
-  let _odata = load_data ctx in
-  let continue = ref true in
   let min_fps = ref Float.max_float in
   let max_fps = ref Float.min_float in
 
-  (* 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,45 +73,140 @@ let () =
     Ogui.Ui.window ctx ~window Gg.(Box2.v P2.o (P2.v 500. 500.))
   in
 
+  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
     ~f:
       (Some
          (fun _window key _int state mods ->
-           Lwt.async (fun () ->
+           (* ignore key releases and capslock *)
+           match (state, key, mods) with
+           | Release, _, _ | _, CapsLock, _ -> ()
+           | _ -> event_push (Some (`Key (state, key, mods)))
+           (*Lwt.async (fun () ->
                Ogui.Ui.keycallback ui state key mods >>= fun _ ->
-               Lwt.return_unit)))
+               Lwt.return_unit) *)))
   |> ignore;
 
   GLFW.setCharCallback ~window
     ~f:
       (Some
          (fun _window ch ->
-           Lwt.async (fun () ->
+           event_push (Some (`Char ch))
-               Ogui.Ui.chrcallback ui ch >>= fun _ -> Lwt.return_unit)))
+           (* Lwt.async (fun () -> Ogui.Ui.chrcallback ui ch) *)))
+  |> 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@.";
-  let page =
+  let initial_path = [ ".config"; "init.ml" ] in
-    Layout.(
+  TextBuffer.of_repo ~initial_path ~repo:rootrepo >>= fun tb_init ->
-      vbox
+  TextBuffer.of_string ~repo:rootrepo
-        [
+    ~path:
-          textedit
+      (List.fold_right
-            (TextEdit.multiline ui
+         (fun a (acc : string list) ->
-               (TextBuffer.of_repo ~path:[ "README" ] ~repo:rootrepo));
+           match acc with
-          textedit
+           | [] -> [ F.str "%s.output" a ]
-            (TextEdit.multiline ui
+           | a' -> a :: a')
-               (TextBuffer.of_repo
+         [] initial_path)
-                  ~path:[ ".config"; "init.ml" ]
+    (F.str "(* --- output:%s --- *)\n\n"
-                  ~repo:rootrepo));
+       (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
+
+  (*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.(
+    append_bindings ui
+      (Lwd.return
+         Event.
+           [
+             pack Fun.id
+               (empty
+               |> adds
+                    [
+                      [
+                        Key (Press, X, [ Control ]);
+                        Key (Press, E, [ Control ]);
+                      ];
+                    ]
+                    [
+                      Custom
+                        ( "toplevel_execute",
+                          fun () ->
+                            TextBuffer.peek tb_init >>= fun _str ->
+                            (*Toploop.use_input out_ppf (String str)
+                              |> F.epr "Toploop.use_input=%b@."; *)
+                            Lwt.return_unit );
+                    ]);
+           ]));
+
+  WindowManager.make ui
+    (Lwd.var
+       (`T
+         ( `Y,
+           WindowManager.
+             [
+               {
+                 t = `TextEdit (TextEdit.multiline ui to_init);
+                 dim = `Ratio 0.333;
+                 bindings = [];
+               };
+               {
+                 t = `TextEdit (TextEdit.multiline ui tb_init);
+                 dim = `Ratio 0.5;
+                 bindings = [];
+               };
+               {
+                 t = `TextEdit (TextEdit.multiline ui to_init);
+                 dim = `Ratio 1.0;
+                 bindings = [];
+               };
+             ] )))
+  >>= fun page ->
+  let page_root = Lwd.observe page in
+
+  let bindings = ui.bindings |> Lwd.observe |> Lwd.quick_sample in
+  F.epr "Bindings:@.";
+  List.iter (fun bs -> F.epr "%a" Ui.pp_pack bs) bindings;
 
   F.pr "oplevel.ml: entering drawing loop@.";
   let period_min = 1.0 /. 30. in
   let t = GLFW.getTime () |> ref in
-  while (not GLFW.(windowShouldClose ~window)) && !continue do
+
-    Lwt_main.run
+  let rec draw_loop () =
-      ((fun () ->
     let now = GLFW.getTime () in
     let dt = now -. !t in
     t := now;
@@ -131,9 +218,7 @@ let () =
       min_fps := Float.min avg !min_fps;
       max_fps := Float.max avg !max_fps);
 
-         let _mx, _my = GLFW.getCursorPos ~window in
     let win_w, win_h = GLFW.getWindowSize ~window in
-
     Gl.viewport 0 0 win_w win_h;
     Gl.clear
       (Gl.color_buffer_bit lor Gl.depth_buffer_bit
@@ -142,54 +227,38 @@ let () =
     Gl.blend_func Gl.src_alpha Gl.one_minus_src_alpha;
     Gl.enable Gl.cull_face_enum;
     Gl.disable Gl.depth_test;
-
+    let page = Lwd.quick_sample page_root in
+    let win_w, win_h = GLFW.getWindowSize ~window in
     let width, height = (float win_w, float win_h) in
-         let box = Gg.(Box2.v V2.zero Size2.(v width height)) in
+    let box = Gg.(Box2.v V2.zero Size2.(v width (height -. 20.))) in
     Gv.begin_frame ctx ~width ~height ~device_ratio:1.;
     Perfgraph.render graph ctx (width -. 205.) 5.;
-         (* F.epr "box=%a@." Gg.Box2.pp box;
+    (*F.epr "Painter.layout=%a@." Gg.Box2.pp box; *)
-            F.epr "Painter.layout=%a@." Gg.Box2.pp *)
     Painter.layout box ui page >>= fun _ ->
     (* Demo.render_demo ctx mx my win_w win_h now !blowup data; *)
     Gv.end_frame ctx;
-
     Gc.major_slice 0 |> ignore;
     GLFW.swapBuffers ~window;
     GLFW.pollEvents ();
-         Unix.sleepf
+    Lwt_unix.sleep
-           Float.(max 0. (period_min -. GLFW.getTime () +. !t));
+      Float.(max 0. (period_min -. GLFW.getTime () +. !t))
-         Lwt.return_unit)
+    >>= fun () ->
-         ())
+    if not GLFW.(windowShouldClose ~window) then draw_loop ()
-  done;
+    else Lwt.return_unit
-
+  in
+  (try draw_loop ()
+   with e ->
+     F.epr "draw_loop Exception: %s@.Backtrace:@.%s@."
+       (Printexc.to_string e)
+       (Printexc.get_backtrace ())
+     |> Lwt.return)
+  >>= fun () ->
   Printf.printf "MIN %.2f\n" !min_fps;
   Printf.printf "MAX %.2f\n%!" !max_fps;
+  Lwt.return_unit
 
-  if Array.length Sys.argv = 1 then
+let () =
-    while not GLFW.(windowShouldClose ~window) do
+  try Lwt_main.run main
-      GLFW.pollEvents ();
+  with e ->
-      Unix.sleepf 0.25
+    F.epr "Exception: %s@.Backtrace:@.%s@." (Printexc.to_string e)
-    done
+      (Printexc.get_backtrace ())
-
-(* 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;;")); *)
-(* ignore (Toploop.use_input Format.std_formatter (String text)); *)
-(* Wait for it to be closed. *)

store.ml

@@ -19,10 +19,11 @@ let test_populate () : t Lwt.t =
 
 let init_default upstream_url : Sync.db Lwt.t =
   S.Repo.v (Irmin_git.Conf.init "../rootstore") >>= fun repo ->
-  S.of_branch repo "lablgtk" >>= fun t ->
+  S.of_branch repo "ogui" >>= fun t ->
   S.remote upstream_url >>= fun upstream ->
-  (try Sync.pull_exn t upstream `Set >>= fun _ -> Lwt.return_unit
+  (* (try Sync.pull_exn t upstream `Set >>= fun _ -> Lwt.return_unit
       with Invalid_argument a ->
         F.epr "Sync.pull_exn raised Invalid_argument(%s)" a;
         Lwt.return_unit)
-  >>= fun () -> Lwt.return t
+     >>= fun () -> *)
+  Lwt.return t