events use lwt_stream, mainloop uses recusive fun, better binding handling, binding pretty printing
This commit is contained in:
cqc
134
ogui.ml
134
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
|
||||
|
||||
Reference in New Issue
Block a user