From 1e3b9da1ed73312e400d39f8d80f393ebe708af3 Mon Sep 17 00:00:00 2001 From: cqc Date: Sat, 29 Jun 2024 20:06:36 -0500 Subject: [PATCH] event processing still doesn't work right --- ogui.ml | 381 ++++++++++++++++++++++++++++------------------------- oplevel.ml | 23 ++-- 2 files changed, 217 insertions(+), 187 deletions(-) diff --git a/ogui.ml b/ogui.ml index 4504c79..00a0dbd 100644 --- a/ogui.ml +++ b/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 *) diff --git a/oplevel.ml b/oplevel.ml index 6d7c441..fb9da77 100644 --- a/oplevel.ml +++ b/oplevel.ml @@ -166,16 +166,17 @@ let main = ] [ Custom - (fun () -> - F.epr "Ctrl-X Ctrl-E@."; - TextBuffer.peek tb_init >>= fun str -> - Toploop.use_input out_ppf (String str) - |> F.epr "Toploop.use_input=%b@."; - Lwt.return_unit); + ( "toplevel_execute", + fun () -> + F.epr "Ctrl-X Ctrl-E@."; + TextBuffer.peek tb_init >>= fun str -> + Toploop.use_input out_ppf (String str) + |> F.epr "Toploop.use_input=%b@."; + Lwt.return_unit ); ])); Layout.( - tiling ui `Y + system ui `Y ~style: Style.{ default with margin = Margin.symmetric 10.0 10.0 } [ TextEdit.multiline ui tb_init; TextEdit.multiline ui to_init ]) @@ -190,7 +191,13 @@ let main = [ [ 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@."; let period_min = 1.0 /. 30. in let t = GLFW.getTime () |> ref in