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

event processing still doesn't work right

Browse Source
This commit is contained in:
cqc
2024-06-29 20:06:36 -05:00
parent 8243029cee
commit 1e3b9da1ed
2 changed files with 217 additions and 187 deletions
Download Patch File Download Diff File Expand all files Collapse all files

139
ogui.ml
View File

@ -339,18 +339,7 @@ module Event = struct
let open Glfw_types in let open Glfw_types in
match e with match e with
| Key (a, k, m) -> | Key (a, k, m) ->
F.pf ppf "Key %a, %a, %a" pp_key_action a pp_key k pp_mods m F.pf ppf "%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 end
type event = Event.event type event = Event.event
@ -633,7 +622,7 @@ module Ui = struct
bindings : action list Event.t Lwd.var; bindings : action list Event.t Lwd.var;
} }
and action = Custom of (unit -> unit Lwt.t) and action = Custom of string * (unit -> unit Lwt.t)
type event = type event =
[ `Key of Event.key_action * Event.key * Event.key_mod list [ `Key of Event.key_action * Event.key * Event.key_mod list
@ -650,6 +639,22 @@ module Ui = struct
bindings = Lwd.var Event.empty; bindings = Lwd.var Event.empty;
} }
let pp_action : action F.t =
fun ppf -> function Custom (name, _) -> F.pf ppf "%s" name
let pp_bindings : action list Event.t F.t =
fun ppf p ->
let open Event in
fold
(fun events action () ->
F.pf ppf "%a: %a@."
F.(list pp_action)
action
F.(brackets @@ list ~sep:semi pp_event)
events
|> ignore)
p ()
let process_key t (resolver : action list Event.result) let process_key t (resolver : action list Event.result)
(state : Event.key_action) (key : Event.key) (state : Event.key_action) (key : Event.key)
(mods : Event.key_mod list) : action list Event.result Lwt.t = (mods : Event.key_mod list) : action list Event.result Lwt.t =
@ -661,8 +666,6 @@ module Ui = struct
t.bindings |> Lwd.get |> Lwd.observe t.bindings |> Lwd.get |> Lwd.observe
|> Lwd.quick_sample |> Lwd.quick_sample
in in
F.epr "process_key bindings:@.%a@." Event.pp_pack
(Event.pack Fun.id bindings);
Event.pack Fun.id bindings); Event.pack Fun.id bindings);
] ]
| Event.Continue r -> r | Event.Continue r -> r
@ -671,7 +674,8 @@ module Ui = struct
(match res with (match res with
| Event.Accepted actions -> | Event.Accepted actions ->
let rec exec : action list -> unit Lwt.t = function let rec exec : action list -> unit Lwt.t = function
| Custom f :: actions -> f () >>= fun () -> exec actions | Custom (_, f) :: actions ->
f () >>= fun () -> exec actions
| [] -> Lwt.return_unit | [] -> Lwt.return_unit
in in
exec actions >>= fun () -> Lwt.return_unit exec actions >>= fun () -> Lwt.return_unit
@ -692,10 +696,11 @@ module Ui = struct
let process_events (ui : t) (events : event Lwt_stream.t) : unit = let process_events (ui : t) (events : event Lwt_stream.t) : unit =
Lwt.async (fun () -> Lwt.async (fun () ->
Lwt_stream.fold_s let rec proc ?(skip : event option)
(fun (e : event) (r : action list Event.result) -> (r : action list Event.result) :
match e with action list Event.result Lwt.t =
| `Key (state, key, mods) -> Lwt_stream.last_new events >>= function
| `Key (state, key, mods) -> (
process_key ui r state key mods process_key ui r state key mods
>>= fun (res : action list Event.result) -> >>= fun (res : action list Event.result) ->
Event.( Event.(
@ -705,23 +710,28 @@ module Ui = struct
| Accepted _ -> "Accepted" | Accepted _ -> "Accepted"
| Continue _ -> "Continue" | Continue _ -> "Continue"
| Rejected -> "Rejected")); | Rejected -> "Rejected"));
(Lwt_stream.peek events >>= function Lwt_stream.peek events >>= function
| Some (`Char _) -> ( | Some (`Char cc) -> (
match res with match res with
| Accepted _ | Continue _ -> | Accepted _ | Continue _ ->
F.epr F.epr
"Ui.process_events Lwt_stream.junk \ "Ui.process_events Lwt_stream.junk events@.";
events@."; proc ~skip:(`Char cc) res
Lwt_stream.junk events | Rejected -> proc res)
| Rejected -> Lwt.return_unit) | Some (`Key _) | None -> proc res)
| Some (`Key _) | None -> Lwt.return_unit) | `Char char -> (
>>= fun () -> Lwt.return res
| `Char char ->
F.epr "Ui.process_events `Char '%a'@." pp_uchar F.epr "Ui.process_events `Char '%a'@." pp_uchar
(Uchar.of_int char); (Uchar.of_int char);
process_char char >>= fun () -> Lwt.return r) match skip with
events Event.Rejected | Some (`Char c) when c == char ->
>>= fun _ -> Lwt.return_unit) F.epr "Ui.process_events skip match@.";
Lwt.return (Event.Accepted [])
| Some _ | None ->
process_char char >>= fun () ->
proc (Event.Accepted []))
in
proc Event.Rejected >>= fun _ -> Lwt.return_unit)
module Style = struct module Style = struct
type t = { type t = {
@ -865,7 +875,7 @@ module TextEdit = struct
[ Key (Press, Right, []) ]; [ Key (Press, Right, []) ];
[ Key (Repeat, Right, []) ]; [ Key (Repeat, Right, []) ];
] ]
[ Custom (fun () -> cursor_move t 1) ] [ Custom ("char_forward", fun () -> cursor_move t 1) ]
|> adds |> adds
[ [
[ Key (Press, B, [ Control ]) ]; [ Key (Press, B, [ Control ]) ];
@ -873,7 +883,9 @@ module TextEdit = struct
[ Key (Press, Left, []) ]; [ Key (Press, Left, []) ];
[ Key (Repeat, Left, []) ]; [ Key (Repeat, Left, []) ];
] ]
[ Custom (fun () -> cursor_move t (-1)) ] [
Custom ("char_backward", fun () -> cursor_move t (-1));
]
|> adds |> adds
[ [
[ Key (Press, N, [ Control ]) ]; [ Key (Press, N, [ Control ]) ];
@ -883,21 +895,25 @@ module TextEdit = struct
] ]
[ [
Custom Custom
(fun () -> ( "forward_line",
fun () ->
TextBuffer.fold_string t.text (fun s -> TextBuffer.fold_string t.text (fun s ->
let sn = String.length s in let sn = String.length s in
let seol = let seol =
Str.search_forward (Str.regexp "$") Str.search_forward (Str.regexp "$")
in in
let next_bol = let next_bol =
min sn (seol s (Lwd.peek t.cursor).index + 1) min sn
(seol s (Lwd.peek t.cursor).index + 1)
in in
let next_line_len = let next_line_len =
seol s next_bol - next_bol seol s next_bol - next_bol
in in
next_bol next_bol
+ +
if (Lwd.peek t.cursor).last_col > next_line_len if
(Lwd.peek t.cursor).last_col
> next_line_len
then next_line_len then next_line_len
else else
min next_line_len min next_line_len
@ -913,7 +929,8 @@ module TextEdit = struct
] ]
[ [
Custom Custom
(fun () -> ( "line_backward",
fun () ->
TextBuffer.fold_string t.text (fun s -> TextBuffer.fold_string t.text (fun s ->
let sbol = let sbol =
Str.search_backward (Str.regexp "^") s Str.search_backward (Str.regexp "^") s
@ -946,7 +963,8 @@ module TextEdit = struct
] ]
[ [
Custom Custom
(fun () -> ( "end_of_line",
fun () ->
TextBuffer.fold_string t.text (fun s -> TextBuffer.fold_string t.text (fun s ->
let bol = let bol =
Str.search_backward (Str.regexp "^") s Str.search_backward (Str.regexp "^") s
@ -957,7 +975,8 @@ module TextEdit = struct
(Lwd.peek t.cursor).index (Lwd.peek t.cursor).index
in in
Lwd.set t.cursor Lwd.set t.cursor
@@ TextLayout.cursor ~last_col:(eol - bol) eol)); @@ TextLayout.cursor ~last_col:(eol - bol)
eol) );
] ]
|> adds (* BOL *) |> adds (* BOL *)
[ [
@ -966,7 +985,8 @@ module TextEdit = struct
] ]
[ [
Custom Custom
(fun () -> ( "beginning_of_line",
fun () ->
TextBuffer.fold_string t.text (fun s -> TextBuffer.fold_string t.text (fun s ->
Lwd.set t.cursor Lwd.set t.cursor
@@ TextLayout.cursor ~last_col:0 @@ TextLayout.cursor ~last_col:0
@ -980,7 +1000,8 @@ module TextEdit = struct
] ]
[ [
Custom Custom
(fun () -> ( "delete_char_backward",
fun () ->
match Lwd.peek t.mark with match Lwd.peek t.mark with
| Some mark -> | Some mark ->
TextBuffer.remove t.text TextBuffer.remove t.text
@ -1000,7 +1021,8 @@ module TextEdit = struct
[ [ Key (Press, K, [ Control ]) ] ] [ [ Key (Press, K, [ Control ]) ] ]
[ [
Custom Custom
(fun () -> ( "line_kill",
fun () ->
TextBuffer.fold_string t.text (fun s -> TextBuffer.fold_string t.text (fun s ->
TextBuffer.remove t.text TextBuffer.remove t.text
( (Lwd.peek t.cursor).index, ( (Lwd.peek t.cursor).index,
@ -1024,7 +1046,8 @@ module TextEdit = struct
] ]
[ [
Custom Custom
(fun () -> ( "new_line",
fun () ->
TextBuffer.insert_uchar t.text TextBuffer.insert_uchar t.text
(Lwd.peek t.cursor).index (Uchar.of_char '\n') (Lwd.peek t.cursor).index (Uchar.of_char '\n')
>>= fun _ -> cursor_move t 1 ); >>= fun _ -> cursor_move t 1 );
@ -1033,7 +1056,8 @@ module TextEdit = struct
[ [ Key (Press, Space, [ Control ]) ] ] (* Mark set *) [ [ Key (Press, Space, [ Control ]) ] ] (* Mark set *)
[ [
Custom Custom
(fun () -> ( "mark_toggle",
fun () ->
Lwd.set t.mark Lwd.set t.mark
(match Lwd.peek t.mark with (match Lwd.peek t.mark with
| Some _ -> None | Some _ -> None
@ -1044,7 +1068,8 @@ module TextEdit = struct
[ [ Key (Press, G, [ Control ]) ] ] (* Exit / Clear *) [ [ Key (Press, G, [ Control ]) ] ] (* Exit / Clear *)
[ [
Custom Custom
(fun () -> ( "command_clear",
fun () ->
Lwd.set t.mark None; Lwd.set t.mark None;
Lwt.return_unit ); Lwt.return_unit );
]); ]);
@ -1142,19 +1167,18 @@ module Layout = struct
|> Lwd.map ~f:(fun tl -> frame ?size ~style (`TextEdit (t, tl))) |> Lwd.map ~f:(fun tl -> frame ?size ~style (`TextEdit (t, tl)))
|> Lwt.return |> Lwt.return
let tiling ui ?(style = textedit_style) d (telist : TextEdit.t list) let system ui ?(style = textedit_style) d (telist : TextEdit.t list)
= =
let cursor = Lwd.var 0 in let cursor = Lwd.var 0 in
let len = List.length telist in let len = List.length telist in
Ui.update_bindings ui (fun a -> Ui.update_bindings ui (fun a ->
a a
|> Event.adds |> Event.adds
[ [ [ Key (Press, X, [ Control ]); Key (Press, O, []) ] ]
[ Key (Press, X, [ Control ]) ]; [ Key (Press, O, []) ];
]
[ [
Ui.Custom Ui.Custom
(fun () -> ( "window_next",
fun () ->
Lwd.set cursor Lwd.set cursor
(if Lwd.peek cursor < len - 1 then (if Lwd.peek cursor < len - 1 then
Lwd.peek cursor + 1 Lwd.peek cursor + 1
@ -1165,16 +1189,15 @@ module Layout = struct
Lwt.return_unit ); Lwt.return_unit );
] ]
|> Event.adds |> Event.adds
[ [ [ Key (Press, X, [ Control ]); Key (Press, P, []) ] ]
[ Key (Press, X, [ Control ]) ]; [ Key (Press, P, []) ];
]
[ [
Ui.Custom Ui.Custom
(fun () -> ( "window_previous",
fun () ->
Lwd.set cursor Lwd.set cursor
(if Lwd.peek cursor < len - 1 then (if Lwd.peek cursor > 0 then
Lwd.peek cursor + 1 Lwd.peek cursor - 1
else 0); else len - 1);
TextEdit.default_bindings TextEdit.default_bindings
(List.nth telist (Lwd.peek cursor)) (List.nth telist (Lwd.peek cursor))
ui; ui;

13
oplevel.ml
View File

@ -166,7 +166,8 @@ let main =
] ]
[ [
Custom Custom
(fun () -> ( "toplevel_execute",
fun () ->
F.epr "Ctrl-X Ctrl-E@."; F.epr "Ctrl-X Ctrl-E@.";
TextBuffer.peek tb_init >>= fun str -> TextBuffer.peek tb_init >>= fun str ->
Toploop.use_input out_ppf (String str) Toploop.use_input out_ppf (String str)
@ -175,7 +176,7 @@ let main =
])); ]));
Layout.( Layout.(
tiling ui `Y system ui `Y
~style: ~style:
Style.{ default with margin = Margin.symmetric 10.0 10.0 } Style.{ default with margin = Margin.symmetric 10.0 10.0 }
[ TextEdit.multiline ui tb_init; TextEdit.multiline ui to_init ]) [ TextEdit.multiline ui tb_init; TextEdit.multiline ui to_init ])
@ -190,7 +191,13 @@ let main =
[ [
[ Key (Press, X, [ Control ]); Key (Press, E, [ Control ]) ]; [ Key (Press, X, [ Control ]); Key (Press, E, [ Control ]) ];
] ]
[ Custom (fun () -> Lwt.return ()) ]); [ Custom ("toplevel_execute", fun () -> Lwt.return ()) ]);
let bindings =
ui.bindings |> Lwd.get |> Lwd.observe |> Lwd.quick_sample
in
F.epr "Bindings:@.%a" Ui.pp_bindings bindings;
F.pr "oplevel.ml: entering drawing loop@."; F.pr "oplevel.ml: entering drawing loop@.";
let period_min = 1.0 /. 30. in let period_min = 1.0 /. 30. in
let t = GLFW.getTime () |> ref in let t = GLFW.getTime () |> ref in