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

381
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,36 +696,42 @@ 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
process_key ui r state key mods | `Key (state, key, mods) -> (
>>= fun (res : action list Event.result) -> process_key ui r state key mods
Event.( >>= fun (res : action list Event.result) ->
F.epr "Ui.process_events `Key %a %a %a (%s)@." Event.(
pp_key_action state pp_key key pp_mods mods F.epr "Ui.process_events `Key %a %a %a (%s)@."
(match res with pp_key_action state pp_key key pp_mods mods
| Accepted _ -> "Accepted" (match res with
| Continue _ -> "Continue" | Accepted _ -> "Accepted"
| Rejected -> "Rejected")); | Continue _ -> "Continue"
(Lwt_stream.peek events >>= function | Rejected -> "Rejected"));
| Some (`Char _) -> ( Lwt_stream.peek events >>= function
match res with | Some (`Char cc) -> (
| Accepted _ | Continue _ -> match res with
F.epr | Accepted _ | Continue _ ->
"Ui.process_events Lwt_stream.junk \ F.epr
events@."; "Ui.process_events Lwt_stream.junk events@.";
Lwt_stream.junk events proc ~skip:(`Char cc) res
| Rejected -> Lwt.return_unit) | Rejected -> proc res)
| Some (`Key _) | None -> Lwt.return_unit) | Some (`Key _) | None -> proc res)
>>= fun () -> Lwt.return res | `Char char -> (
| `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); match skip with
process_char char >>= fun () -> Lwt.return r) | Some (`Char c) when c == char ->
events Event.Rejected F.epr "Ui.process_events skip match@.";
>>= fun _ -> Lwt.return_unit) 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,26 +895,30 @@ module TextEdit = struct
] ]
[ [
Custom Custom
(fun () -> ( "forward_line",
TextBuffer.fold_string t.text (fun s -> fun () ->
let sn = String.length s in TextBuffer.fold_string t.text (fun s ->
let seol = let sn = String.length s in
Str.search_forward (Str.regexp "$") let seol =
in Str.search_forward (Str.regexp "$")
let next_bol = in
min sn (seol s (Lwd.peek t.cursor).index + 1) let next_bol =
in min sn
let next_line_len = (seol s (Lwd.peek t.cursor).index + 1)
seol s next_bol - next_bol in
in let next_line_len =
next_bol seol s next_bol - next_bol
+ in
if (Lwd.peek t.cursor).last_col > next_line_len next_bol
then next_line_len +
else if
min next_line_len (Lwd.peek t.cursor).last_col
(Lwd.peek t.cursor).last_col) > next_line_len
>>= cursor_set t); then next_line_len
else
min next_line_len
(Lwd.peek t.cursor).last_col)
>>= cursor_set t );
] ]
|> adds |> adds
[ [
@ -913,31 +929,32 @@ module TextEdit = struct
] ]
[ [
Custom Custom
(fun () -> ( "line_backward",
TextBuffer.fold_string t.text (fun s -> fun () ->
let sbol = TextBuffer.fold_string t.text (fun s ->
Str.search_backward (Str.regexp "^") s let sbol =
in Str.search_backward (Str.regexp "^") s
let bol = sbol (Lwd.peek t.cursor).index in in
if bol > 0 then let bol = sbol (Lwd.peek t.cursor).index in
let prev_bol = sbol (max 0 (bol - 1)) in if bol > 0 then
let prev_line_len = bol - 1 - prev_bol in let prev_bol = sbol (max 0 (bol - 1)) in
let prev_line_len = bol - 1 - prev_bol in
(*F.epr (*F.epr
"up: index=%d bol=%d prev_bol=%d \ "up: index=%d bol=%d prev_bol=%d \
prev_line_len=%d @." prev_line_len=%d @."
t.cursor.index bol prev_bol prev_line_len; *) t.cursor.index bol prev_bol prev_line_len; *)
prev_bol prev_bol
+ +
if if
(Lwd.peek t.cursor).last_col
> prev_line_len
then prev_line_len
else
min prev_line_len
(Lwd.peek t.cursor).last_col (Lwd.peek t.cursor).last_col
else (Lwd.peek t.cursor).index) > prev_line_len
>>= cursor_set t); then prev_line_len
else
min prev_line_len
(Lwd.peek t.cursor).last_col
else (Lwd.peek t.cursor).index)
>>= cursor_set t );
] ]
|> adds (* EOL *) |> adds (* EOL *)
[ [
@ -946,18 +963,20 @@ module TextEdit = struct
] ]
[ [
Custom Custom
(fun () -> ( "end_of_line",
TextBuffer.fold_string t.text (fun s -> fun () ->
let bol = TextBuffer.fold_string t.text (fun s ->
Str.search_backward (Str.regexp "^") s let bol =
(Lwd.peek t.cursor).index Str.search_backward (Str.regexp "^") s
in (Lwd.peek t.cursor).index
let eol = in
Str.search_forward (Str.regexp "$") s let eol =
(Lwd.peek t.cursor).index Str.search_forward (Str.regexp "$") s
in (Lwd.peek t.cursor).index
Lwd.set t.cursor in
@@ TextLayout.cursor ~last_col:(eol - bol) eol)); Lwd.set t.cursor
@@ TextLayout.cursor ~last_col:(eol - bol)
eol) );
] ]
|> adds (* BOL *) |> adds (* BOL *)
[ [
@ -966,12 +985,13 @@ module TextEdit = struct
] ]
[ [
Custom Custom
(fun () -> ( "beginning_of_line",
TextBuffer.fold_string t.text (fun s -> fun () ->
Lwd.set t.cursor TextBuffer.fold_string t.text (fun s ->
@@ TextLayout.cursor ~last_col:0 Lwd.set t.cursor
(Str.search_backward (Str.regexp "^") s @@ TextLayout.cursor ~last_col:0
(Lwd.peek t.cursor).index))); (Str.search_backward (Str.regexp "^") s
(Lwd.peek t.cursor).index)) );
] ]
|> adds |> adds
[ [
@ -980,43 +1000,45 @@ module TextEdit = struct
] ]
[ [
Custom Custom
(fun () -> ( "delete_char_backward",
match Lwd.peek t.mark with fun () ->
| Some mark -> match Lwd.peek t.mark with
TextBuffer.remove t.text | Some mark ->
(mark, (Lwd.peek t.cursor).index) TextBuffer.remove t.text
>>= fun _ -> (mark, (Lwd.peek t.cursor).index)
Lwd.set t.mark None; >>= fun _ ->
cursor_set t Lwd.set t.mark None;
(min mark (Lwd.peek t.cursor).index) cursor_set t
| None -> (min mark (Lwd.peek t.cursor).index)
if (Lwd.peek t.cursor).index > 0 then | None ->
TextBuffer.remove_uchar t.text if (Lwd.peek t.cursor).index > 0 then
((Lwd.peek t.cursor).index - 1) TextBuffer.remove_uchar t.text
>>= fun _ -> cursor_move t (-1) ((Lwd.peek t.cursor).index - 1)
else Lwt.return_unit); >>= fun _ -> cursor_move t (-1)
else Lwt.return_unit );
] ]
|> adds |> adds
[ [ Key (Press, K, [ Control ]) ] ] [ [ Key (Press, K, [ Control ]) ] ]
[ [
Custom Custom
(fun () -> ( "line_kill",
TextBuffer.fold_string t.text (fun s -> fun () ->
TextBuffer.remove t.text TextBuffer.fold_string t.text (fun s ->
( (Lwd.peek t.cursor).index, TextBuffer.remove t.text
let eol = ( (Lwd.peek t.cursor).index,
Str.search_forward (Str.regexp "$") s let eol =
(Lwd.peek t.cursor).index Str.search_forward (Str.regexp "$") s
in (Lwd.peek t.cursor).index
if in
eol == (Lwd.peek t.cursor).index if
&& String.length s > eol eol == (Lwd.peek t.cursor).index
then eol + 1 && String.length s > eol
else eol ) then eol + 1
>>= fun _ -> else eol )
Lwd.set t.mark None; >>= fun _ ->
cursor_set t (Lwd.peek t.cursor).index) Lwd.set t.mark None;
>>= fun u -> u); cursor_set t (Lwd.peek t.cursor).index)
>>= fun u -> u );
] ]
|> adds |> adds
[ [
@ -1024,29 +1046,32 @@ module TextEdit = struct
] ]
[ [
Custom Custom
(fun () -> ( "new_line",
TextBuffer.insert_uchar t.text fun () ->
(Lwd.peek t.cursor).index (Uchar.of_char '\n') TextBuffer.insert_uchar t.text
>>= fun _ -> cursor_move t 1); (Lwd.peek t.cursor).index (Uchar.of_char '\n')
>>= fun _ -> cursor_move t 1 );
] ]
|> adds |> adds
[ [ Key (Press, Space, [ Control ]) ] ] (* Mark set *) [ [ Key (Press, Space, [ Control ]) ] ] (* Mark set *)
[ [
Custom Custom
(fun () -> ( "mark_toggle",
Lwd.set t.mark fun () ->
(match Lwd.peek t.mark with Lwd.set t.mark
| Some _ -> None (match Lwd.peek t.mark with
| None -> Some (Lwd.peek t.cursor).index); | Some _ -> None
Lwt.return_unit); | None -> Some (Lwd.peek t.cursor).index);
Lwt.return_unit );
] ]
|> adds |> adds
[ [ Key (Press, G, [ Control ]) ] ] (* Exit / Clear *) [ [ Key (Press, G, [ Control ]) ] ] (* Exit / Clear *)
[ [
Custom Custom
(fun () -> ( "command_clear",
Lwd.set t.mark None; fun () ->
Lwt.return_unit); Lwd.set t.mark None;
Lwt.return_unit );
]); ]);
Ui.chrcallback_ref := Ui.chrcallback_ref :=
@ -1142,43 +1167,41 @@ 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",
Lwd.set cursor fun () ->
(if Lwd.peek cursor < len - 1 then Lwd.set cursor
Lwd.peek cursor + 1 (if Lwd.peek cursor < len - 1 then
else 0); Lwd.peek cursor + 1
TextEdit.default_bindings else 0);
(List.nth telist (Lwd.peek cursor)) TextEdit.default_bindings
ui; (List.nth telist (Lwd.peek cursor))
Lwt.return_unit); ui;
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",
Lwd.set cursor fun () ->
(if Lwd.peek cursor < len - 1 then Lwd.set cursor
Lwd.peek cursor + 1 (if Lwd.peek cursor > 0 then
else 0); Lwd.peek cursor - 1
TextEdit.default_bindings else len - 1);
(List.nth telist (Lwd.peek cursor)) TextEdit.default_bindings
ui; (List.nth telist (Lwd.peek cursor))
Lwt.return_unit); 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 *)

23
oplevel.ml
View File

@ -166,16 +166,17 @@ let main =
] ]
[ [
Custom Custom
(fun () -> ( "toplevel_execute",
F.epr "Ctrl-X Ctrl-E@."; fun () ->
TextBuffer.peek tb_init >>= fun str -> F.epr "Ctrl-X Ctrl-E@.";
Toploop.use_input out_ppf (String str) TextBuffer.peek tb_init >>= fun str ->
|> F.epr "Toploop.use_input=%b@."; Toploop.use_input out_ppf (String str)
Lwt.return_unit); |> F.epr "Toploop.use_input=%b@.";
Lwt.return_unit );
])); ]));
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