diff --git a/main.ml b/main.ml index 1e969bc..8a0056f 100644 --- a/main.ml +++ b/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=