console/oplevel
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
cqc
2024-06-27 12:23:49 -05:00
parent cd79cd2537
commit 8243029cee
3 changed files with 129 additions and 61 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
.ocamlformat
View File

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

130
ogui.ml
View File

@ -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
match resolver with
| Event.Rejected | Event.Accepted _ ->
[
Event.pack Fun.id
(t.bindings |> Lwd.get |> Lwd.observe
|> Lwd.quick_sample);
(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

54
oplevel.ml
View File

@ -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