mirror of
https://github.com/fjvallarino/monomer.git
synced 2024-09-11 12:05:35 +03:00
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
This commit is contained in:
parent
f98c3e3900
commit
1972e8cce3
@ -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
|
||||
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user