diff --git a/.ocamlformat b/.ocamlformat index 75b374d..b839a14 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,3 +1,3 @@ profile = default version = 0.26.2 -no-parse-toplevel-phrases \ No newline at end of file +parse-toplevel-phrases=false \ No newline at end of file diff --git a/ogui.ml b/ogui.ml index 60f4e84..4504c79 100644 --- a/ogui.ml +++ b/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 = - ref Option.None - - let keycallback t (state : Event.key_action) (key : Event.key) - (mods : Event.key_mod list) : bool Lwt.t = + let process_key t (resolver : action list Event.result) + (state : Event.key_action) (key : Event.key) + (mods : Event.key_mod list) : action list Event.result Lwt.t = let res = - match !callback_resolver with - | Some res -> res - | None -> - Event.resolver - [ - Event.pack Fun.id - (t.bindings |> Lwd.get |> Lwd.observe - |> Lwd.quick_sample); - ] + match resolver with + | Event.Rejected | Event.Accepted _ -> + [ + (let bindings = + t.bindings |> Lwd.get |> Lwd.observe + |> Lwd.quick_sample + in + F.epr "process_key bindings:@.%a@." Event.pp_pack + (Event.pack Fun.id bindings); + Event.pack Fun.id bindings); + ] + | Event.Continue r -> r in - - Event.( - 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 + let res = Event.resolve (Key (state, key, mods)) res in + (match res with | Event.Accepted actions -> - callback_resolver := None; - let rec exec : action list -> bool Lwt.t = function + let rec exec : action list -> unit Lwt.t = function | Custom f :: actions -> f () >>= fun () -> exec actions - | [] -> Lwt.return false + | [] -> Lwt.return_unit in - exec actions - | Event.Continue res -> - callback_resolver := Some res; - Lwt.return true - | Event.Rejected -> - callback_resolver := None; - Lwt.return false + exec actions >>= fun () -> Lwt.return_unit + | Event.Continue _ | Event.Rejected -> Lwt.return_unit) + >>= fun () -> Lwt.return res 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 (Release, X, [Control])];*) - [ Key (Press, O, [ Control ]) ]; + [ Key (Press, X, [ Control ]) ]; [ Key (Press, O, []) ]; + ] + [ + 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 ratio n = `Ratio (1. /. float (teln - (n + 1))) in + (* let teln = List.length telist in *) + (* let ratio n = `Ratio (1. /. float (teln - (n + 1))) in *) Lwt_list.mapi_s (fun n te -> textedit diff --git a/oplevel.ml b/oplevel.ml index aaf49c1..6d7c441 100644 --- a/oplevel.ml +++ b/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 () -> - Ogui.Ui.chrcallback ui ch >>= fun _ -> Lwt.return_unit))) + event_push (Some (`Char ch)) + (* 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 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 rec draw_loop () = 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)) - done; - + Lwt_unix.sleep + 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