events use lwt_stream, mainloop uses recusive fun, better binding handling, binding pretty printing

.ocamlformat

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

ogui.ml

@@ -340,6 +340,17 @@ module Event = struct
     match e with
     | Key (a, k, m) ->
         F.pf ppf "Key %a, %a, %a" pp_key_action a pp_key k pp_mods m
+
+  let pp_pack : 'a pack F.t =
+   fun (type u) ppf p ->
+    let module Pack = (val p : Pack with type b = u) in
+    fold
+      (fun events _action _ ->
+        F.pf ppf "events: %a@ "
+          F.(brackets @@ list ~sep:semi pp_event)
+          events
+        |> ignore)
+      Pack.set ()
 end
 
 type event = Event.event
@@ -624,6 +635,10 @@ module Ui = struct
 
   and action = Custom of (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 =
@@ -635,40 +650,33 @@ module Ui = struct
       bindings = Lwd.var Event.empty;
     }
 
-  let callback_resolver : action list Event.resolver option ref =
+  let process_key t (resolver : action list Event.result)
-    ref Option.None
+      (state : Event.key_action) (key : Event.key)
-
+      (mods : Event.key_mod list) : action list Event.result Lwt.t =
-  let keycallback t (state : Event.key_action) (key : Event.key)
-      (mods : Event.key_mod list) : bool Lwt.t =
     let res =
-      match !callback_resolver with
+      match resolver with
-      | Some res -> res
+      | Event.Rejected | Event.Accepted _ ->
-      | None ->
+          [
-          Event.resolver
+            (let bindings =
-            [
+               t.bindings |> Lwd.get |> Lwd.observe
-              Event.pack Fun.id
+               |> Lwd.quick_sample
-                (t.bindings |> Lwd.get |> Lwd.observe
+             in
-               |> Lwd.quick_sample);
+             F.epr "process_key bindings:@.%a@." Event.pp_pack
-            ]
+               (Event.pack Fun.id bindings);
+             Event.pack Fun.id bindings);
+          ]
+      | Event.Continue r -> r
     in
-
+    let res = Event.resolve (Key (state, key, mods)) res in
-    Event.(
+    (match res with
-      F.epr "Ui.keycallback %a %a %a@." pp_key key pp_key_action state
-        pp_mods mods);
-    match Event.resolve (Key (state, key, mods)) res with
     | Event.Accepted actions ->
-        callback_resolver := None;
+        let rec exec : action list -> unit Lwt.t = function
-        let rec exec : action list -> bool Lwt.t = function
           | Custom f :: actions -> f () >>= fun () -> exec actions
-          | [] -> Lwt.return false
+          | [] -> Lwt.return_unit
         in
-        exec actions
+        exec actions >>= fun () -> Lwt.return_unit
-    | Event.Continue res ->
+    | Event.Continue _ | Event.Rejected -> Lwt.return_unit)
-        callback_resolver := Some res;
+    >>= fun () -> Lwt.return res
-        Lwt.return true
-    | Event.Rejected ->
-        callback_resolver := None;
-        Lwt.return false
 
   let update_bindings ui
       (f : action list Event.t -> action list Event.t) =
@@ -679,9 +687,42 @@ module Ui = struct
         F.epr "chrcallback: '%a'@." pp_uchar _c;
         Lwt.return_unit)
 
-  let chrcallback _t (chr : int) : unit Lwt.t =
+  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 () ->
+        Lwt_stream.fold_s
+          (fun (e : event) (r : action list Event.result) ->
+            match e with
+            | `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"));
+                (Lwt_stream.peek events >>= function
+                 | Some (`Char _) -> (
+                     match res with
+                     | Accepted _ | Continue _ ->
+                         F.epr
+                           "Ui.process_events Lwt_stream.junk \
+                            events@.";
+                         Lwt_stream.junk events
+                     | Rejected -> Lwt.return_unit)
+                 | Some (`Key _) | None -> Lwt.return_unit)
+                >>= fun () -> Lwt.return res
+            | `Char char ->
+                F.epr "Ui.process_events `Char '%a'@." pp_uchar
+                  (Uchar.of_int char);
+                process_char char >>= fun () -> Lwt.return r)
+          events Event.Rejected
+        >>= fun _ -> Lwt.return_unit)
+
   module Style = struct
     type t = {
       stroke : float option * Gv.Color.t;
@@ -998,7 +1039,16 @@ module TextEdit = struct
                      | Some _ -> None
                      | None -> Some (Lwd.peek t.cursor).index);
                    Lwt.return_unit);
+             ]
+        |> adds
+             [ [ Key (Press, G, [ Control ]) ] ] (* Exit / Clear *)
+             [
+               Custom
+                 (fun () ->
+                   Lwd.set t.mark None;
+                   Lwt.return_unit);
              ]);
+
     Ui.chrcallback_ref :=
       fun c ->
         TextBuffer.insert_uchar t.text (Lwd.peek t.cursor).index c
@@ -1100,9 +1150,23 @@ module Layout = struct
         a
         |> Event.adds
              [
-               (*[ Key (Press, X, [Control])];
+               [ Key (Press, X, [ Control ]) ]; [ Key (Press, O, []) ];
-                 [ 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);
+             ]
+        |> Event.adds
+             [
+               [ Key (Press, X, [ Control ]) ]; [ Key (Press, P, []) ];
              ]
              [
                Ui.Custom
@@ -1116,8 +1180,8 @@ module Layout = struct
                      ui;
                    Lwt.return_unit);
              ]);
-    let teln = List.length telist in
+    (* let teln = List.length telist in *)
-    let ratio n = `Ratio (1. /. float (teln - (n + 1))) in
+    (* let ratio n = `Ratio (1. /. float (teln - (n + 1))) in *)
     Lwt_list.mapi_s
       (fun n te ->
         textedit

oplevel.ml

@@ -81,21 +81,28 @@ let main =
   in
 
   load_fonts ui.gv;
+
+  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
@@ -188,23 +195,7 @@ let main =
   let period_min = 1.0 /. 30. in
   let t = GLFW.getTime () |> ref in
 
-  let render root =
+  let rec draw_loop () =
-    let page = Lwd.quick_sample 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 -. 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 *)
-    Painter.layout box ui page >>= fun _ ->
-    (* Demo.render_demo ctx mx my win_w win_h now !blowup data; *)
-    Gv.end_frame ctx;
-
-    Lwt.return_unit
-  in
-
-  while not GLFW.(windowShouldClose ~window) do
     let now = GLFW.getTime () in
     let dt = now -. !t in
     t := now;
@@ -225,13 +216,26 @@ let main =
     Gl.blend_func Gl.src_alpha Gl.one_minus_src_alpha;
     Gl.enable Gl.cull_face_enum;
     Gl.disable Gl.depth_test;
-    Lwt.async (fun () -> render page_root);
+    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 -. 20.))) in
+    Gv.begin_frame ctx ~width ~height ~device_ratio:1.;
+    Perfgraph.render graph ctx (width -. 205.) 5.;
+    (*F.epr "Painter.layout=%a@." Gg.Box2.pp box; *)
+    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 Float.(max 0. (period_min -. GLFW.getTime () +. !t))
+    Lwt_unix.sleep
-  done;
+      Float.(max 0. (period_min -. GLFW.getTime () +. !t))
-
+    >>= fun () ->
+    if not GLFW.(windowShouldClose ~window) then draw_loop ()
+    else Lwt.return_unit
+  in
+  draw_loop () >>= fun () ->
   Printf.printf "MIN %.2f\n" !min_fps;
   Printf.printf "MAX %.2f\n%!" !max_fps;
   Lwt.return_unit