input and bindings refactoring

main.ml

@@ -57,20 +57,12 @@ module Input = struct
     | Unknown
     | None
 
+  type keystate =
+    {ctrl: bool; meta: bool; shift: bool; super: bool; code: code}
+
+  type mods = Ctrl | Meta | Super | Shift
   type key = Char of char | Code of code
 
-  module KeymodSet = struct
-    type t = Shift | Ctrl | Meta | Fn
-
-    let compare (x : t) (y : t) = compare x y
-  end
-
-  module Keymod = Set.Make (KeymodSet)
-
-  let modset = Keymod.of_list
-
-  type keystate = {mods: Keymod.t; code: code}
-
   module Key = struct
     type t = keystate
 
@@ -80,7 +72,6 @@ module Input = struct
   module Bind = struct
     (* parts stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *)
     module S = Zed_input.Make (Key)
-    include S
 
     type action = Custom of (unit -> unit) | Zed of Zed_edit.action
     type t = action list S.t
@@ -93,26 +84,74 @@ module Input = struct
       ; mutable last_keyseq: keystate list
       ; mutable last_actions: action list }
 
+    let keystate_of_mods ks m =
+      List.fold_left
+        (fun ks m ->
+          match m with
+          | Meta -> {ks with meta= true}
+          | Ctrl -> {ks with ctrl= true}
+          | Super -> {ks with super= true}
+          | Shift -> {ks with shift= true} )
+        ks m
+
     let add events action bindings =
       let events =
         List.map
           (fun (m, k) ->
-            { mods= Keymod.of_list m
-            ; code=
-                ( match k with
-                | Char c -> UChar (UChar.of_char c)
-                | Code c -> c ) } )
+            keystate_of_mods
+              { meta= false
+              ; ctrl= false
+              ; super= false
+              ; shift= false
+              ; code=
+                  ( match k with
+                  | Char c -> UChar (UChar.of_char c)
+                  | Code c -> c ) }
+              m )
           events in
       S.add events action bindings
 
-    let default_resolver b =
-      resolver [pack (fun (x : action list) -> x) b]
+    let default_resolver b = S.resolver [S.pack (fun x -> x) b]
 
     let get_resolver result default =
-      match result with Continue r -> r | _ -> default
+      match result with S.Continue r -> r | _ -> default
 
     let init bindings =
       {bindings; state= S.Rejected; last_keyseq= []; last_actions= []}
+
+    let resolve = S.resolve
+    let empty = S.empty
+
+    let actions_of_events (state : state) events =
+      List.flatten
+        (List.filter_map
+           (fun e ->
+             (*F.epr "action_of_events: %s@." (to_string e) ;*)
+             match e with
+             | `Key_down (k : keystate) -> (
+                 ( match state.state with
+                 | Continue _ -> ()
+                 | _ -> state.last_keyseq <- [] ) ;
+                 state.state <-
+                   resolve k
+                     (get_resolver state.state
+                        (default_resolver state.bindings) ) ;
+                 state.last_keyseq <- k :: state.last_keyseq ;
+                 match state.state with
+                 | Accepted a ->
+                     state.last_actions <- a ;
+                     Some a
+                 | Rejected ->
+                     state.last_actions <- [] ;
+                     None
+                 | _ -> None )
+             | _ -> None )
+           events )
+
+    let process bindstate events =
+      List.iter
+        (function Custom f -> f () | _ -> ())
+        (actions_of_events bindstate events)
   end
 
   (* stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *)
@@ -149,19 +188,16 @@ module Input = struct
 
   let to_string key =
     Printf.sprintf
-      "{ control = %B; meta = %B; shift = %B; fn = %B; code = %s }"
-      (Keymod.mem Ctrl key.mods)
-      (Keymod.mem Meta key.mods)
-      (Keymod.mem Shift key.mods)
-      (Keymod.mem Fn key.mods)
+      "{ control = %B; meta = %B; shift = %B; super = %B; code = %s }"
+      key.ctrl key.meta key.shift key.super
       (string_of_code key.code)
 
   let to_string_compact key =
     let buffer = Buffer.create 32 in
-    if Keymod.mem Ctrl key.mods then Buffer.add_string buffer "C-" ;
-    if Keymod.mem Meta key.mods then Buffer.add_string buffer "M-" ;
-    if Keymod.mem Shift key.mods then Buffer.add_string buffer "S-" ;
-    if Keymod.mem Fn key.mods then Buffer.add_string buffer "Fn-" ;
+    if key.ctrl then Buffer.add_string buffer "Ctrl-" ;
+    if key.meta then Buffer.add_string buffer "Meta-" ;
+    if key.shift then Buffer.add_string buffer "Shift-" ;
+    if key.super then Buffer.add_string buffer "Super-" ;
     ( match key.code with
     | UChar ch ->
         let code = UChar.code ch in
@@ -192,7 +228,6 @@ module Event = struct
   open CamomileLibrary
   open Zed_edit
   open Input
-  open Input.KeymodSet
 
   type mouse = int * int
 
@@ -233,7 +268,6 @@ module Event = struct
 
   let event_of_sdlevent ev =
     let key_of_sdlkey ev =
-      let km = Sdl.Event.get ev Sdl.Event.keyboard_keymod in
       let (kc : Sdl.keycode) =
         Sdl.Event.get ev Sdl.Event.keyboard_keycode
         land lnot Sdl.K.scancode_mask in
@@ -278,13 +312,12 @@ module Event = struct
            |'\'' | '>' | '<' | '^' | '`' | '|' ->
               UChar (UChar.of_int k)
           | _ -> None ) in
-      let mods =
-        List.filter_map
-          (fun (m, v) -> if km land m > 0 then Some v else None)
-          Sdl.Kmod.
-            [(shift, Shift); (ctrl, Ctrl); (alt, Meta); (gui, Fn)]
-      in
-      {code= c; mods= Input.Keymod.of_list mods} in
+      let km = Sdl.Event.get ev Sdl.Event.keyboard_keymod in
+      { code= c
+      ; ctrl= km land Sdl.Kmod.ctrl > 0
+      ; meta= km land Sdl.Kmod.alt > 0
+      ; super= km land Sdl.Kmod.gui > 0
+      ; shift= km land Sdl.Kmod.shift > 0 } in
     let repeat = Sdl.Event.get ev Sdl.Event.keyboard_repeat in
     let r =
       match Sdl.Event.enum (Sdl.Event.get ev Sdl.Event.typ) with
@@ -354,33 +387,6 @@ module Event = struct
   let key_left : Sdl.keycode = 0x40000050
   let key_right : Sdl.keycode = 0x4000004f
   let handle_keyevents (el : events) f = List.iter f el
-
-  let actions_of_events (state : Input.Bind.state) (events : events) =
-    let open Input.Bind in
-    List.flatten
-      (List.filter_map
-         (fun e ->
-           (*F.epr "action_of_events: %s@." (to_string e) ;*)
-           match e with
-           | `Key_down (k : Input.keystate) -> (
-               ( match state.state with
-               | Continue _ -> ()
-               | _ -> state.last_keyseq <- [] ) ;
-               state.state <-
-                 resolve k
-                   (get_resolver state.state
-                      (default_resolver state.bindings) ) ;
-               state.last_keyseq <- k :: state.last_keyseq ;
-               match state.state with
-               | Accepted a ->
-                   state.last_actions <- a ;
-                   Some a
-               | Rejected ->
-                   state.last_actions <- [] ;
-                   None
-               | _ -> None )
-           | _ -> None )
-         events )
 end
 
 module Display = struct
@@ -713,7 +719,7 @@ module Panel = struct
     ; subpanels
     ; tag= "origin-box" }
 
-  let g_text_height = ref 30.
+  let g_text_height = ref 25.
 
   type Format.stag += Color_bg of Wall.color
   type Format.stag += Color_fg of Wall.color
@@ -1300,9 +1306,7 @@ module Store = struct
             (not sv.editmode)
             && not (Panel.Modal.is_active modalstate)
           then (
-            List.iter
-              Input.Bind.(function Custom f -> f () | _ -> ())
-              (Event.actions_of_events bindstate events) ;
+            Input.Bind.process bindstate events ;
             update_textedit () ) ;
           (Panel.vbox panel.subpanels).act panel events )
     ; subpanels=