Allow using symbols for keystroke definitions (#117)

* Allow using symbols for keystroke definitions. Add Dash to allow using the - character as part of a combination * Log when an invalid sequence is provided * Revert test changes to Tutorial02 * Be more explicit about restrictions * Add missing keyCode definitions * Handle Dash as text and add support for KpEnter * Update Changelog
2024-09-11 12:05:35 +03:00 · 2022-04-14 18:51:34 +02:00 · 2022-04-14 18:51:34 +02:00 · 1972e8cce3
commit 1972e8cce3
parent f98c3e3900
4 changed files with 203 additions and 30 deletions
--- a/ChangeLog.md
+++ b/ChangeLog.md
@ -19,6 +19,7 @@
 - `style...Set` family of functions ([PR #104](https://github.com/fjvallarino/monomer/pull/104)).
 - Several sizeReq helpers ([PR #106](https://github.com/fjvallarino/monomer/pull/106)).
 - `compositeMergeEvents`, for completeness ([PR #114](https://github.com/fjvallarino/monomer/pull/114)).
+- Support for symbols and other keys in `keystroke` ([PR #117](https://github.com/fjvallarino/monomer/pull/117)).

 ### Changed

--- a/src/Monomer/Event/Keyboard.hs
+++ b/src/Monomer/Event/Keyboard.hs
@ -337,6 +337,56 @@ keyY = getKeyCode SDL.KeycodeY
 keyZ :: KeyCode
 keyZ = getKeyCode SDL.KeycodeZ

+-- Key pad
+keyPadDivide :: KeyCode
+keyPadDivide = getKeyCode SDL.KeycodeKPDivide
+
+keyPadMultiply :: KeyCode
+keyPadMultiply = getKeyCode SDL.KeycodeKPMultiply
+
+keyPadMinus :: KeyCode
+keyPadMinus = getKeyCode SDL.KeycodeKPMinus
+
+keyPadPlus :: KeyCode
+keyPadPlus = getKeyCode SDL.KeycodeKPPlus
+
+keyPadEnter :: KeyCode
+keyPadEnter = getKeyCode SDL.KeycodeKPEnter
+
+keyPadPeriod :: KeyCode
+keyPadPeriod = getKeyCode SDL.KeycodeKPPeriod
+
+-- Key pad numbers
+keyPad0 :: KeyCode
+keyPad0 = getKeyCode SDL.KeycodeKP0
+
+keyPad1 :: KeyCode
+keyPad1 = getKeyCode SDL.KeycodeKP1
+
+keyPad2 :: KeyCode
+keyPad2 = getKeyCode SDL.KeycodeKP2
+
+keyPad3 :: KeyCode
+keyPad3 = getKeyCode SDL.KeycodeKP3
+
+keyPad4 :: KeyCode
+keyPad4 = getKeyCode SDL.KeycodeKP4
+
+keyPad5 :: KeyCode
+keyPad5 = getKeyCode SDL.KeycodeKP5
+
+keyPad6 :: KeyCode
+keyPad6 = getKeyCode SDL.KeycodeKP6
+
+keyPad7 :: KeyCode
+keyPad7 = getKeyCode SDL.KeycodeKP7
+
+keyPad8 :: KeyCode
+keyPad8 = getKeyCode SDL.KeycodeKP8
+
+keyPad9 :: KeyCode
+keyPad9 = getKeyCode SDL.KeycodeKP9
+
 --

 -- Mod keys
@ -657,3 +707,53 @@ isKeyY = (== keyY)

 isKeyZ :: KeyCode -> Bool
 isKeyZ = (== keyZ)
+
+-- Key pad
+isKeyPadDivide :: KeyCode -> Bool
+isKeyPadDivide = (== keyPadDivide)
+
+isKeyPadMultiply :: KeyCode -> Bool
+isKeyPadMultiply = (== keyPadMultiply)
+
+isKeyPadMinus :: KeyCode -> Bool
+isKeyPadMinus = (== keyPadMinus)
+
+isKeyPadPlus :: KeyCode -> Bool
+isKeyPadPlus = (== keyPadPlus)
+
+isKeyPadEnter :: KeyCode -> Bool
+isKeyPadEnter = (== keyPadEnter)
+
+isKeyPadPeriod :: KeyCode -> Bool
+isKeyPadPeriod = (== keyPadPeriod)
+
+-- Key pad numbers
+isKeyPad0 :: KeyCode -> Bool
+isKeyPad0 = (== keyPad0)
+
+isKeyPad1 :: KeyCode -> Bool
+isKeyPad1 = (== keyPad1)
+
+isKeyPad2 :: KeyCode -> Bool
+isKeyPad2 = (== keyPad2)
+
+isKeyPad3 :: KeyCode -> Bool
+isKeyPad3 = (== keyPad3)
+
+isKeyPad4 :: KeyCode -> Bool
+isKeyPad4 = (== keyPad4)
+
+isKeyPad5 :: KeyCode -> Bool
+isKeyPad5 = (== keyPad5)
+
+isKeyPad6 :: KeyCode -> Bool
+isKeyPad6 = (== keyPad6)
+
+isKeyPad7 :: KeyCode -> Bool
+isKeyPad7 = (== keyPad7)
+
+isKeyPad8 :: KeyCode -> Bool
+isKeyPad8 = (== keyPad8)
+
+isKeyPad9 :: KeyCode -> Bool
+isKeyPad9 = (== keyPad9)
--- a/src/Monomer/Widgets/Containers/Keystroke.hs
+++ b/src/Monomer/Widgets/Containers/Keystroke.hs
@ -11,28 +11,47 @@ Using these event makes sense at the application or Composite level. If you are
 implementing a widget from scratch, keyboard events are directly available.

 The shortcut definitions are provided as a list of tuples of 'Text', containing
-the key combination and associated event. The widget handles unordered
-combinations of multiple keys at the same time, but does not support ordered
-sequences (pressing "a", releasing, then "b" and "c"). The available keys are:
+the key combination and associated event, separated by "-". The widget handles
+unordered combinations of multiple keys at the same time, but does not support
+ordered sequences (pressing "a", releasing, then "b" and "c"). The available
+keys are:

 - Mod keys: A, Alt, C, Ctrl, Cmd, O, Option, S, Shift
 - Action keys: Caps, Delete, Enter, Esc, Return, Space, Tab
 - Arrows: Up, Down, Left, Right
 - Function keys: F1-F12
+- Separator: Dash (since '-' is used for defining keystrokes)
+- Symbols: brackets, ^, *, &, etc.
 - Lowercase letters (uppercase keys are reserved for mod and action keys)
 - Numbers

-These can be combined, for example:
+The keys can be combined, for example:

 - Copy: "Ctrl-c" or "C-c"
 - App config: "Ctrl-Shift-p" or "C-S-p"
+
+Note 1: Except in the specific cases mentioned here (Ctrl, Cmd, etc), the keys
+must be single characters.
+
+Note 2: Full words must be input exactly as indicated (Ctrl, Cmd, etc). Alias
+only exist for the keys described here (A for Alt, C for Ctrl/Cmd, etc).
+
+Note 3: Symbols that require pressing the Shift key (^, &, etc) are virtual keys
+and share the KeyCode with the symbol associated to the same physical key. This
+causes issues when detecting their pressed status, and thus it's not possible to
+combine these symbols with letters, numbers or other symbols in the same
+keystroke. The same happens with characters that require pressing a combination
+of keys (e.g. accented characters). It is still possible to combine them with
+mod keys, so using "C-^" or "C-[" should work. If you find that binding a
+symbol/complex character does not work, try using the names of the physical keys
+instead (e.g. "Shift-e" instead of "E").
 -}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE StrictData #-}
 {-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE Strict #-}

 module Monomer.Widgets.Containers.Keystroke (
  -- * Configuration
@ -42,6 +61,8 @@ module Monomer.Widgets.Containers.Keystroke (
  keystroke_
 ) where

+import Debug.Trace (traceShow)
+
 import Control.Applicative ((<|>))
 import Control.Lens ((&), (^.), (^..), (.~), (%~), _1, at, folded)
 import Control.Lens.TH (abbreviatedFields, makeLensesWith)
@ -96,7 +117,9 @@ data KeyStroke = KeyStroke {
  _kstKsCmd :: Bool,
  _kstKsAlt :: Bool,
  _kstKsShift :: Bool,
-  _kstKsKeys :: Set KeyCode
+  _kstKsKeys :: Set KeyCode,
+  _kstKsKeysText :: Set Text,
+  _kstKsErrors :: [Text]
 } deriving (Eq, Show)

 instance Default KeyStroke where
@ -107,13 +130,20 @@ instance Default KeyStroke where
    _kstKsCmd = False,
    _kstKsAlt = False,
    _kstKsShift = False,
-    _kstKsKeys = Set.empty
+    _kstKsKeys = Set.empty,
+    _kstKsKeysText = Set.empty,
+    _kstKsErrors = []
  }

 newtype KeyStrokeState e = KeyStrokeState {
  _kssLatest :: [(KeyStroke, e)]
 } deriving (Eq, Show)

+data KeyEntry
+  = KeyEntryCode KeyCode
+  | KeyEntryText Text
+  deriving (Eq, Show)
+
 makeLensesWith abbreviatedFields ''KeyStroke
 makeLensesWith abbreviatedFields ''KeyStrokeState

@ -156,37 +186,47 @@ makeKeystroke bindings config state = widget where
      & L.widget .~ makeKeystroke bindings config oldState

  handleEvent wenv node target evt = case evt of
-    KeyAction mod code KeyPressed -> Just result where
-      newWenv = wenv & L.inputStatus %~ removeMods
-      matches = filter (keyStrokeActive newWenv code . fst) bindings
-      newState = KeyStrokeState matches
-      newNode = node
-        & L.widget .~ makeKeystroke bindings config newState
-      evts = snd <$> matches
-      reqs
-        | ignoreChildren && not (null evts) = [IgnoreChildrenEvents]
-        | otherwise = []
-      result = resultReqsEvts newNode reqs evts
-    TextInput t
-      | ignoreChildren && ignorePrevious t -> Just result where
-        previousMatch t = t `elem` _kssLatest state ^.. folded . _1 . ksText
-        ignorePrevious t = isTextValidCode t && previousMatch t
+    KeyAction mod code KeyPressed -> result where
+      result = handleKeystroke (KeyEntryCode code)
+    TextInput text
+      | ignoreChildren && ignorePrevious text -> Just result where
        newState = KeyStrokeState []
        newNode = node
          & L.widget .~ makeKeystroke bindings config newState
        result = resultReqs newNode [IgnoreChildrenEvents]
+    TextInput text
+      | not (previousMatch text) -> result where
+        result = handleKeystroke (KeyEntryText text)
    _ -> Nothing
    where
      ignoreChildren = Just True == _kscIgnoreChildren config
+      previousMatch t = t `elem` _kssLatest state ^.. folded . _1 . ksText
+      ignorePrevious t = isTextValidCode t && previousMatch t

-keyStrokeActive :: WidgetEnv s e -> KeyCode -> KeyStroke -> Bool
-keyStrokeActive wenv code ks = currValid && allPressed && validMods where
+      handleKeystroke entry = Just result where
+        newWenv = wenv & L.inputStatus %~ removeMods
+        matches = filter (keyStrokeActive newWenv entry . fst) bindings
+        newState = KeyStrokeState matches
+        newNode = node
+          & L.widget .~ makeKeystroke bindings config newState
+        evts = snd <$> matches
+        reqs
+          | ignoreChildren && not (null evts) = [IgnoreChildrenEvents]
+          | otherwise = []
+        result = resultReqsEvts newNode reqs evts
+
+keyStrokeActive :: WidgetEnv s e -> KeyEntry -> KeyStroke -> Bool
+keyStrokeActive wenv entry ks = currValid && allPressed && validMods where
  status = wenv ^. L.inputStatus
  keyMod = status ^. L.keyMod
  pressedKeys = M.filter (== KeyPressed) (status ^. L.keys)

-  currValid = code `elem` (ks ^. ksKeys) || code `elem` modKeys
-  allPressed = M.keysSet pressedKeys == ks ^. ksKeys
+  (currValid, allPressed, ignoreShift) = case entry of
+    KeyEntryCode code -> (valid, pressed, False) where
+      valid = code `elem` (ks ^. ksKeys) || code `elem` modKeys
+      pressed = M.keysSet pressedKeys == ks ^. ksKeys
+    KeyEntryText txt -> (valid, True, True) where
+      valid = txt `elem` (ks ^. ksKeysText)

  ctrlPressed = isCtrlPressed keyMod
  cmdPressed = isMacOS wenv && isGUIPressed keyMod
@ -194,17 +234,24 @@ keyStrokeActive wenv code ks = currValid && allPressed && validMods where
  validC = not (ks ^. ksC) || ks ^. ksC == (ctrlPressed || cmdPressed)
  validCtrl = ks ^. ksCtrl == ctrlPressed || ctrlPressed && validC
  validCmd = ks ^. ksCmd == cmdPressed || cmdPressed && validC
-  validShift = ks ^. ksShift == isShiftPressed keyMod
+  validShift = ks ^. ksShift == isShiftPressed keyMod || ignoreShift
  validAlt = ks ^. ksAlt == isAltPressed keyMod

  validMods = (validC && validCtrl && validCmd) && validShift && validAlt

 textToStroke :: Text -> KeyStroke
-textToStroke text = ks where
+textToStroke text = result where
  parts = T.split (=='-') text
  ks = foldl' partToStroke def parts
    & ksText .~ text

+  errors = ks ^. ksErrors
+  errorMsg = "'" <> text <> "' is not valid. Invalid parts: "
+
+  result
+    | not (T.null text) && null errors = ks
+    | otherwise = traceShow (errorMsg, errors) ks
+
 partToStroke :: KeyStroke -> Text -> KeyStroke
 partToStroke ks "A" = ks & ksAlt .~ True
 partToStroke ks "Alt" = ks & ksAlt .~ True
@ -220,6 +267,7 @@ partToStroke ks "Backspace" = ks & ksKeys %~ Set.insert keyBackspace
 partToStroke ks "Caps" = ks & ksKeys %~ Set.insert keyCapsLock
 partToStroke ks "Delete" = ks & ksKeys %~ Set.insert keyDelete
 partToStroke ks "Enter" = ks & ksKeys %~ Set.insert keyReturn
+partToStroke ks "KpEnter" = ks & ksKeys %~ Set.insert keyPadEnter
 partToStroke ks "Esc" = ks & ksKeys %~ Set.insert keyEscape
 partToStroke ks "Return" = ks & ksKeys %~ Set.insert keyReturn
 partToStroke ks "Space" = ks & ksKeys %~ Set.insert keySpace
@ -243,9 +291,13 @@ partToStroke ks "F10" = ks & ksKeys %~ Set.insert keyF10
 partToStroke ks "F11" = ks & ksKeys %~ Set.insert keyF11
 partToStroke ks "F12" = ks & ksKeys %~ Set.insert keyF12
 -- Other keys (numbers, letters, points, etc)
+partToStroke ks "Dash" = partToStroke ks "-"
 partToStroke ks txt
-  | isTextValidCode txt = ks & ksKeys %~ Set.insert (KeyCode (ord txtHead))
+  | isTextValidCode txt = ks
+      & ksKeys %~ Set.insert (KeyCode (ord txtHead))
+      & ksKeysText %~ Set.insert txt
  | otherwise = ks
+      & ksErrors %~ (++ [txt])
  where
    txtHead = T.index txt 0

--- a/test/unit/Monomer/Widgets/Containers/KeystrokeSpec.hs
+++ b/test/unit/Monomer/Widgets/Containers/KeystrokeSpec.hs
@ -39,9 +39,11 @@ data TestEvt
  | TextFieldChanged Text
  | CtrlA
  | CtrlSpace
+  | CtrlDash
  | CtrlShiftSpace
  | MultiKey Int
  | FunctionKey Int
+  | SymbolKey Text
  deriving (Eq, Show)

 newtype TestModel = TestModel {
@ -63,6 +65,13 @@ handleEvent = describe "handleEvent" $ do
  it "should generate an event when Ctrl-Space is pressed" $ do
    events [evtKC keySpace] `shouldBe` Seq.fromList [CtrlSpace]

+  it "should generate an event when Ctrl-Dash is pressed" $ do
+    let wenv = mockWenv (TestModel "")
+          & L.inputStatus . L.keyMod . L.leftCtrl .~ True
+    let events es = nodeHandleEventEvts wenv es kstNode
+
+    events [evtT "-"] `shouldBe` Seq.fromList [CtrlDash]
+
  it "should generate an event when Ctrl-Shift-Space is pressed" $ do
    events [evtKCS keySpace] `shouldBe` Seq.fromList [CtrlShiftSpace]

@ -72,6 +81,14 @@ handleEvent = describe "handleEvent" $ do
    events [evtKG keyF7] `shouldBe` Seq.fromList [FunctionKey 7]
    events [evtKS keyF12] `shouldBe` Seq.fromList [FunctionKey 12]

+  it "should generate events when symbol keys are pressed" $ do
+    let wenv = mockWenv (TestModel "")
+          & L.inputStatus . L.keyMod . L.leftCtrl .~ True
+    let events es = nodeHandleEventEvts wenv es kstNode
+
+    events [evtT "["] `shouldBe` Seq.fromList [SymbolKey "["]
+    events [evtT "^"] `shouldBe` Seq.fromList [SymbolKey "^"]
+
  it "should only generate events when the exact keys are pressed" $ do
    events [evtKC keyA, evtKC keyB] `shouldBe` Seq.fromList []
    events [evtKC keyA, evtKC keyB, evtKC keyD, evtKC keyC] `shouldBe` Seq.fromList []
@ -104,13 +121,16 @@ handleEvent = describe "handleEvent" $ do
    wenv = mockWenv (TestModel "")
    bindings = [
        ("C-Space", CtrlSpace),
+        ("C-Dash", CtrlDash),
        ("C-S-Space", CtrlShiftSpace),
        ("C-a-b-c", MultiKey 1),
        ("C-d-e", MultiKey 2),
        ("F1", FunctionKey 1),
        ("Ctrl-F3", FunctionKey 3),
        ("Cmd-F7", FunctionKey 7),
-        ("S-F12", FunctionKey 12)
+        ("S-F12", FunctionKey 12),
+        ("C-[", SymbolKey "["),
+        ("Shift-^", SymbolKey "^")
      ]
    kstNode = keystroke bindings (textField textValue)
    events es = nodeHandleEventEvts wenv es kstNode