event processing still doesn't work right
This commit is contained in:
cqc
381
ogui.ml
381
ogui.ml
@ -339,18 +339,7 @@ module Event = struct
|
||||
let open Glfw_types in
|
||||
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 ()
|
||||
F.pf ppf "%a %a %a" pp_key_action a pp_key k pp_mods m
|
||||
end
|
||||
|
||||
type event = Event.event
|
||||
@ -633,7 +622,7 @@ module Ui = struct
|
||||
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 =
|
||||
[ `Key of Event.key_action * Event.key * Event.key_mod list
|
||||
@ -650,6 +639,22 @@ module Ui = struct
|
||||
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)
|
||||
(state : Event.key_action) (key : Event.key)
|
||||
(mods : Event.key_mod list) : action list Event.result Lwt.t =
|
||||
@ -661,8 +666,6 @@ module Ui = struct
|
||||
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
|
||||
@ -671,7 +674,8 @@ module Ui = struct
|
||||
(match res with
|
||||
| Event.Accepted actions ->
|
||||
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
|
||||
in
|
||||
exec actions >>= fun () -> Lwt.return_unit
|
||||
@ -692,36 +696,42 @@ module Ui = struct
|
||||
|
||||
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)
|
||||
let rec proc ?(skip : event option)
|
||||
(r : action list Event.result) :
|
||||
action list Event.result Lwt.t =
|
||||
Lwt_stream.last_new events >>= function
|
||||
| `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 cc) -> (
|
||||
match res with
|
||||
| Accepted _ | Continue _ ->
|
||||
F.epr
|
||||
"Ui.process_events Lwt_stream.junk events@.";
|
||||
proc ~skip:(`Char cc) res
|
||||
| Rejected -> proc res)
|
||||
| Some (`Key _) | None -> proc res)
|
||||
| `Char char -> (
|
||||
F.epr "Ui.process_events `Char '%a'@." pp_uchar
|
||||
(Uchar.of_int char);
|
||||
match skip with
|
||||
| Some (`Char c) when c == char ->
|
||||
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
|
||||
type t = {
|
||||
@ -865,7 +875,7 @@ module TextEdit = struct
|
||||
[ Key (Press, Right, []) ];
|
||||
[ Key (Repeat, Right, []) ];
|
||||
]
|
||||
[ Custom (fun () -> cursor_move t 1) ]
|
||||
[ Custom ("char_forward", fun () -> cursor_move t 1) ]
|
||||
|> adds
|
||||
[
|
||||
[ Key (Press, B, [ Control ]) ];
|
||||
@ -873,7 +883,9 @@ module TextEdit = struct
|
||||
[ Key (Press, Left, []) ];
|
||||
[ Key (Repeat, Left, []) ];
|
||||
]
|
||||
[ Custom (fun () -> cursor_move t (-1)) ]
|
||||
[
|
||||
Custom ("char_backward", fun () -> cursor_move t (-1));
|
||||
]
|
||||
|> adds
|
||||
[
|
||||
[ Key (Press, N, [ Control ]) ];
|
||||
@ -883,26 +895,30 @@ module TextEdit = struct
|
||||
]
|
||||
[
|
||||
Custom
|
||||
(fun () ->
|
||||
TextBuffer.fold_string t.text (fun s ->
|
||||
let sn = String.length s in
|
||||
let seol =
|
||||
Str.search_forward (Str.regexp "$")
|
||||
in
|
||||
let next_bol =
|
||||
min sn (seol s (Lwd.peek t.cursor).index + 1)
|
||||
in
|
||||
let next_line_len =
|
||||
seol s next_bol - next_bol
|
||||
in
|
||||
next_bol
|
||||
+
|
||||
if (Lwd.peek t.cursor).last_col > next_line_len
|
||||
then next_line_len
|
||||
else
|
||||
min next_line_len
|
||||
(Lwd.peek t.cursor).last_col)
|
||||
>>= cursor_set t);
|
||||
( "forward_line",
|
||||
fun () ->
|
||||
TextBuffer.fold_string t.text (fun s ->
|
||||
let sn = String.length s in
|
||||
let seol =
|
||||
Str.search_forward (Str.regexp "$")
|
||||
in
|
||||
let next_bol =
|
||||
min sn
|
||||
(seol s (Lwd.peek t.cursor).index + 1)
|
||||
in
|
||||
let next_line_len =
|
||||
seol s next_bol - next_bol
|
||||
in
|
||||
next_bol
|
||||
+
|
||||
if
|
||||
(Lwd.peek t.cursor).last_col
|
||||
> next_line_len
|
||||
then next_line_len
|
||||
else
|
||||
min next_line_len
|
||||
(Lwd.peek t.cursor).last_col)
|
||||
>>= cursor_set t );
|
||||
]
|
||||
|> adds
|
||||
[
|
||||
@ -913,31 +929,32 @@ module TextEdit = struct
|
||||
]
|
||||
[
|
||||
Custom
|
||||
(fun () ->
|
||||
TextBuffer.fold_string t.text (fun s ->
|
||||
let sbol =
|
||||
Str.search_backward (Str.regexp "^") s
|
||||
in
|
||||
let bol = sbol (Lwd.peek t.cursor).index in
|
||||
if bol > 0 then
|
||||
let prev_bol = sbol (max 0 (bol - 1)) in
|
||||
let prev_line_len = bol - 1 - prev_bol in
|
||||
( "line_backward",
|
||||
fun () ->
|
||||
TextBuffer.fold_string t.text (fun s ->
|
||||
let sbol =
|
||||
Str.search_backward (Str.regexp "^") s
|
||||
in
|
||||
let bol = sbol (Lwd.peek t.cursor).index in
|
||||
if bol > 0 then
|
||||
let prev_bol = sbol (max 0 (bol - 1)) in
|
||||
let prev_line_len = bol - 1 - prev_bol in
|
||||
|
||||
(*F.epr
|
||||
"up: index=%d bol=%d prev_bol=%d \
|
||||
prev_line_len=%d @."
|
||||
t.cursor.index bol prev_bol prev_line_len; *)
|
||||
prev_bol
|
||||
+
|
||||
if
|
||||
(Lwd.peek t.cursor).last_col
|
||||
> prev_line_len
|
||||
then prev_line_len
|
||||
else
|
||||
min prev_line_len
|
||||
(*F.epr
|
||||
"up: index=%d bol=%d prev_bol=%d \
|
||||
prev_line_len=%d @."
|
||||
t.cursor.index bol prev_bol prev_line_len; *)
|
||||
prev_bol
|
||||
+
|
||||
if
|
||||
(Lwd.peek t.cursor).last_col
|
||||
else (Lwd.peek t.cursor).index)
|
||||
>>= cursor_set t);
|
||||
> prev_line_len
|
||||
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 *)
|
||||
[
|
||||
@ -946,18 +963,20 @@ module TextEdit = struct
|
||||
]
|
||||
[
|
||||
Custom
|
||||
(fun () ->
|
||||
TextBuffer.fold_string t.text (fun s ->
|
||||
let bol =
|
||||
Str.search_backward (Str.regexp "^") s
|
||||
(Lwd.peek t.cursor).index
|
||||
in
|
||||
let eol =
|
||||
Str.search_forward (Str.regexp "$") s
|
||||
(Lwd.peek t.cursor).index
|
||||
in
|
||||
Lwd.set t.cursor
|
||||
@@ TextLayout.cursor ~last_col:(eol - bol) eol));
|
||||
( "end_of_line",
|
||||
fun () ->
|
||||
TextBuffer.fold_string t.text (fun s ->
|
||||
let bol =
|
||||
Str.search_backward (Str.regexp "^") s
|
||||
(Lwd.peek t.cursor).index
|
||||
in
|
||||
let eol =
|
||||
Str.search_forward (Str.regexp "$") s
|
||||
(Lwd.peek t.cursor).index
|
||||
in
|
||||
Lwd.set t.cursor
|
||||
@@ TextLayout.cursor ~last_col:(eol - bol)
|
||||
eol) );
|
||||
]
|
||||
|> adds (* BOL *)
|
||||
[
|
||||
@ -966,12 +985,13 @@ module TextEdit = struct
|
||||
]
|
||||
[
|
||||
Custom
|
||||
(fun () ->
|
||||
TextBuffer.fold_string t.text (fun s ->
|
||||
Lwd.set t.cursor
|
||||
@@ TextLayout.cursor ~last_col:0
|
||||
(Str.search_backward (Str.regexp "^") s
|
||||
(Lwd.peek t.cursor).index)));
|
||||
( "beginning_of_line",
|
||||
fun () ->
|
||||
TextBuffer.fold_string t.text (fun s ->
|
||||
Lwd.set t.cursor
|
||||
@@ TextLayout.cursor ~last_col:0
|
||||
(Str.search_backward (Str.regexp "^") s
|
||||
(Lwd.peek t.cursor).index)) );
|
||||
]
|
||||
|> adds
|
||||
[
|
||||
@ -980,43 +1000,45 @@ module TextEdit = struct
|
||||
]
|
||||
[
|
||||
Custom
|
||||
(fun () ->
|
||||
match Lwd.peek t.mark with
|
||||
| Some mark ->
|
||||
TextBuffer.remove t.text
|
||||
(mark, (Lwd.peek t.cursor).index)
|
||||
>>= fun _ ->
|
||||
Lwd.set t.mark None;
|
||||
cursor_set t
|
||||
(min mark (Lwd.peek t.cursor).index)
|
||||
| None ->
|
||||
if (Lwd.peek t.cursor).index > 0 then
|
||||
TextBuffer.remove_uchar t.text
|
||||
((Lwd.peek t.cursor).index - 1)
|
||||
>>= fun _ -> cursor_move t (-1)
|
||||
else Lwt.return_unit);
|
||||
( "delete_char_backward",
|
||||
fun () ->
|
||||
match Lwd.peek t.mark with
|
||||
| Some mark ->
|
||||
TextBuffer.remove t.text
|
||||
(mark, (Lwd.peek t.cursor).index)
|
||||
>>= fun _ ->
|
||||
Lwd.set t.mark None;
|
||||
cursor_set t
|
||||
(min mark (Lwd.peek t.cursor).index)
|
||||
| None ->
|
||||
if (Lwd.peek t.cursor).index > 0 then
|
||||
TextBuffer.remove_uchar t.text
|
||||
((Lwd.peek t.cursor).index - 1)
|
||||
>>= fun _ -> cursor_move t (-1)
|
||||
else Lwt.return_unit );
|
||||
]
|
||||
|> adds
|
||||
[ [ Key (Press, K, [ Control ]) ] ]
|
||||
[
|
||||
Custom
|
||||
(fun () ->
|
||||
TextBuffer.fold_string t.text (fun s ->
|
||||
TextBuffer.remove t.text
|
||||
( (Lwd.peek t.cursor).index,
|
||||
let eol =
|
||||
Str.search_forward (Str.regexp "$") s
|
||||
(Lwd.peek t.cursor).index
|
||||
in
|
||||
if
|
||||
eol == (Lwd.peek t.cursor).index
|
||||
&& String.length s > eol
|
||||
then eol + 1
|
||||
else eol )
|
||||
>>= fun _ ->
|
||||
Lwd.set t.mark None;
|
||||
cursor_set t (Lwd.peek t.cursor).index)
|
||||
>>= fun u -> u);
|
||||
( "line_kill",
|
||||
fun () ->
|
||||
TextBuffer.fold_string t.text (fun s ->
|
||||
TextBuffer.remove t.text
|
||||
( (Lwd.peek t.cursor).index,
|
||||
let eol =
|
||||
Str.search_forward (Str.regexp "$") s
|
||||
(Lwd.peek t.cursor).index
|
||||
in
|
||||
if
|
||||
eol == (Lwd.peek t.cursor).index
|
||||
&& String.length s > eol
|
||||
then eol + 1
|
||||
else eol )
|
||||
>>= fun _ ->
|
||||
Lwd.set t.mark None;
|
||||
cursor_set t (Lwd.peek t.cursor).index)
|
||||
>>= fun u -> u );
|
||||
]
|
||||
|> adds
|
||||
[
|
||||
@ -1024,29 +1046,32 @@ module TextEdit = struct
|
||||
]
|
||||
[
|
||||
Custom
|
||||
(fun () ->
|
||||
TextBuffer.insert_uchar t.text
|
||||
(Lwd.peek t.cursor).index (Uchar.of_char '\n')
|
||||
>>= fun _ -> cursor_move t 1);
|
||||
( "new_line",
|
||||
fun () ->
|
||||
TextBuffer.insert_uchar t.text
|
||||
(Lwd.peek t.cursor).index (Uchar.of_char '\n')
|
||||
>>= fun _ -> cursor_move t 1 );
|
||||
]
|
||||
|> adds
|
||||
[ [ Key (Press, Space, [ Control ]) ] ] (* Mark set *)
|
||||
[
|
||||
Custom
|
||||
(fun () ->
|
||||
Lwd.set t.mark
|
||||
(match Lwd.peek t.mark with
|
||||
| Some _ -> None
|
||||
| None -> Some (Lwd.peek t.cursor).index);
|
||||
Lwt.return_unit);
|
||||
( "mark_toggle",
|
||||
fun () ->
|
||||
Lwd.set t.mark
|
||||
(match Lwd.peek t.mark with
|
||||
| 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);
|
||||
( "command_clear",
|
||||
fun () ->
|
||||
Lwd.set t.mark None;
|
||||
Lwt.return_unit );
|
||||
]);
|
||||
|
||||
Ui.chrcallback_ref :=
|
||||
@ -1142,43 +1167,41 @@ module Layout = struct
|
||||
|> Lwd.map ~f:(fun tl -> frame ?size ~style (`TextEdit (t, tl)))
|
||||
|> 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 len = List.length telist in
|
||||
Ui.update_bindings ui (fun a ->
|
||||
a
|
||||
|> Event.adds
|
||||
[
|
||||
[ Key (Press, X, [ Control ]) ]; [ Key (Press, O, []) ];
|
||||
]
|
||||
[ [ 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);
|
||||
( "window_next",
|
||||
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, []) ];
|
||||
]
|
||||
[ [ Key (Press, X, [ Control ]); Key (Press, P, []) ] ]
|
||||
[
|
||||
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);
|
||||
( "window_previous",
|
||||
fun () ->
|
||||
Lwd.set cursor
|
||||
(if Lwd.peek cursor > 0 then
|
||||
Lwd.peek cursor - 1
|
||||
else len - 1);
|
||||
TextEdit.default_bindings
|
||||
(List.nth telist (Lwd.peek cursor))
|
||||
ui;
|
||||
Lwt.return_unit );
|
||||
]);
|
||||
(* let teln = List.length telist in *)
|
||||
(* let ratio n = `Ratio (1. /. float (teln - (n + 1))) in *)
|
||||
|
||||
Reference in New Issue
Block a user