{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
module Monomer.Widgets.Containers.Keystroke (
KeystrokeCfg,
keystroke,
keystroke_
) where
import Debug.Trace (traceShow)
import Control.Applicative ((<|>))
import Control.Lens ((&), (^.), (^..), (.~), (%~), _1, at, folded)
import Control.Lens.TH (abbreviatedFields, makeLensesWith)
import Data.Bifunctor (first)
import Data.Char (chr, isAscii, isPrint, ord)
import Data.Default
import Data.List (foldl')
import Data.Set (Set)
import Data.Text (Text)
import qualified Data.Map as M
import qualified Data.Sequence as Seq
import qualified Data.Set as Set
import qualified Data.Text as T
import Monomer.Widgets.Container
import qualified Monomer.Lens as L
newtype KeystrokeCfg = KeystrokeCfg {
KeystrokeCfg -> Maybe Bool
_kscIgnoreChildren :: Maybe Bool
}
instance Default KeystrokeCfg where
def :: KeystrokeCfg
def = KeystrokeCfg {
_kscIgnoreChildren :: Maybe Bool
_kscIgnoreChildren = forall a. Maybe a
Nothing
}
instance Semigroup KeystrokeCfg where
<> :: KeystrokeCfg -> KeystrokeCfg -> KeystrokeCfg
(<>) KeystrokeCfg
t1 KeystrokeCfg
t2 = KeystrokeCfg {
_kscIgnoreChildren :: Maybe Bool
_kscIgnoreChildren = KeystrokeCfg -> Maybe Bool
_kscIgnoreChildren KeystrokeCfg
t2 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> KeystrokeCfg -> Maybe Bool
_kscIgnoreChildren KeystrokeCfg
t1
}
instance Monoid KeystrokeCfg where
mempty :: KeystrokeCfg
mempty = forall a. Default a => a
def
instance CmbIgnoreChildrenEvts KeystrokeCfg where
ignoreChildrenEvts_ :: Bool -> KeystrokeCfg
ignoreChildrenEvts_ Bool
ignore = forall a. Default a => a
def {
_kscIgnoreChildren :: Maybe Bool
_kscIgnoreChildren = forall a. a -> Maybe a
Just Bool
ignore
}
data KeyStroke = KeyStroke {
KeyStroke -> Text
_kstKsText :: Text,
KeyStroke -> Bool
_kstKsC :: Bool,
KeyStroke -> Bool
_kstKsCtrl :: Bool,
KeyStroke -> Bool
_kstKsCmd :: Bool,
KeyStroke -> Bool
_kstKsAlt :: Bool,
KeyStroke -> Bool
_kstKsShift :: Bool,
KeyStroke -> Set KeyCode
_kstKsKeys :: Set KeyCode,
KeyStroke -> Set Text
_kstKsKeysText :: Set Text,
KeyStroke -> [Text]
_kstKsErrors :: [Text]
} deriving (KeyStroke -> KeyStroke -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: KeyStroke -> KeyStroke -> Bool
$c/= :: KeyStroke -> KeyStroke -> Bool
== :: KeyStroke -> KeyStroke -> Bool
$c== :: KeyStroke -> KeyStroke -> Bool
Eq, Int -> KeyStroke -> ShowS
[KeyStroke] -> ShowS
KeyStroke -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [KeyStroke] -> ShowS
$cshowList :: [KeyStroke] -> ShowS
show :: KeyStroke -> String
$cshow :: KeyStroke -> String
showsPrec :: Int -> KeyStroke -> ShowS
$cshowsPrec :: Int -> KeyStroke -> ShowS
Show)
instance Default KeyStroke where
def :: KeyStroke
def = KeyStroke {
_kstKsText :: Text
_kstKsText = Text
"",
_kstKsC :: Bool
_kstKsC = Bool
False,
_kstKsCtrl :: Bool
_kstKsCtrl = Bool
False,
_kstKsCmd :: Bool
_kstKsCmd = Bool
False,
_kstKsAlt :: Bool
_kstKsAlt = Bool
False,
_kstKsShift :: Bool
_kstKsShift = Bool
False,
_kstKsKeys :: Set KeyCode
_kstKsKeys = forall a. Set a
Set.empty,
_kstKsKeysText :: Set Text
_kstKsKeysText = forall a. Set a
Set.empty,
_kstKsErrors :: [Text]
_kstKsErrors = []
}
newtype KeyStrokeState e = KeyStrokeState {
forall e. KeyStrokeState e -> [(KeyStroke, e)]
_kssLatest :: [(KeyStroke, e)]
} deriving (KeyStrokeState e -> KeyStrokeState e -> Bool
forall e. Eq e => KeyStrokeState e -> KeyStrokeState e -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: KeyStrokeState e -> KeyStrokeState e -> Bool
$c/= :: forall e. Eq e => KeyStrokeState e -> KeyStrokeState e -> Bool
== :: KeyStrokeState e -> KeyStrokeState e -> Bool
$c== :: forall e. Eq e => KeyStrokeState e -> KeyStrokeState e -> Bool
Eq, Int -> KeyStrokeState e -> ShowS
forall e. Show e => Int -> KeyStrokeState e -> ShowS
forall e. Show e => [KeyStrokeState e] -> ShowS
forall e. Show e => KeyStrokeState e -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [KeyStrokeState e] -> ShowS
$cshowList :: forall e. Show e => [KeyStrokeState e] -> ShowS
show :: KeyStrokeState e -> String
$cshow :: forall e. Show e => KeyStrokeState e -> String
showsPrec :: Int -> KeyStrokeState e -> ShowS
$cshowsPrec :: forall e. Show e => Int -> KeyStrokeState e -> ShowS
Show)
data KeyEntry
= KeyEntryCode KeyCode
| KeyEntryText Text
deriving (KeyEntry -> KeyEntry -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: KeyEntry -> KeyEntry -> Bool
$c/= :: KeyEntry -> KeyEntry -> Bool
== :: KeyEntry -> KeyEntry -> Bool
$c== :: KeyEntry -> KeyEntry -> Bool
Eq, Int -> KeyEntry -> ShowS
[KeyEntry] -> ShowS
KeyEntry -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [KeyEntry] -> ShowS
$cshowList :: [KeyEntry] -> ShowS
show :: KeyEntry -> String
$cshow :: KeyEntry -> String
showsPrec :: Int -> KeyEntry -> ShowS
$cshowsPrec :: Int -> KeyEntry -> ShowS
Show)
makeLensesWith abbreviatedFields ''KeyStroke
makeLensesWith abbreviatedFields ''KeyStrokeState
keystroke :: WidgetEvent e => [(Text, e)] -> WidgetNode s e -> WidgetNode s e
keystroke :: forall e s.
WidgetEvent e =>
[(Text, e)] -> WidgetNode s e -> WidgetNode s e
keystroke [(Text, e)]
bindings WidgetNode s e
managed = forall e s.
WidgetEvent e =>
[(Text, e)] -> [KeystrokeCfg] -> WidgetNode s e -> WidgetNode s e
keystroke_ [(Text, e)]
bindings forall a. Default a => a
def WidgetNode s e
managed
keystroke_
:: WidgetEvent e
=> [(Text, e)]
-> [KeystrokeCfg]
-> WidgetNode s e
-> WidgetNode s e
keystroke_ :: forall e s.
WidgetEvent e =>
[(Text, e)] -> [KeystrokeCfg] -> WidgetNode s e -> WidgetNode s e
keystroke_ [(Text, e)]
bindings [KeystrokeCfg]
configs WidgetNode s e
managed = forall s e. Widget s e -> WidgetNode s e -> WidgetNode s e
makeNode forall {s}. Widget s e
widget WidgetNode s e
managed where
config :: KeystrokeCfg
config = forall a. Monoid a => [a] -> a
mconcat [KeystrokeCfg]
configs
newBindings :: [(KeyStroke, e)]
newBindings = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> KeyStroke
textToStroke) [(Text, e)]
bindings
state :: KeyStrokeState e
state = forall e. [(KeyStroke, e)] -> KeyStrokeState e
KeyStrokeState []
widget :: Widget s e
widget = forall e s.
WidgetEvent e =>
[(KeyStroke, e)] -> KeystrokeCfg -> KeyStrokeState e -> Widget s e
makeKeystroke [(KeyStroke, e)]
newBindings KeystrokeCfg
config forall {e}. KeyStrokeState e
state
makeNode :: Widget s e -> WidgetNode s e -> WidgetNode s e
makeNode :: forall s e. Widget s e -> WidgetNode s e -> WidgetNode s e
makeNode Widget s e
widget WidgetNode s e
managedWidget = forall s e. WidgetType -> Widget s e -> WidgetNode s e
defaultWidgetNode WidgetType
"keystroke" Widget s e
widget
forall a b. a -> (a -> b) -> b
& forall s a. HasInfo s a => Lens' s a
L.info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasFocusable s a => Lens' s a
L.focusable forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
False
forall a b. a -> (a -> b) -> b
& forall s a. HasChildren s a => Lens' s a
L.children forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. a -> Seq a
Seq.singleton WidgetNode s e
managedWidget
makeKeystroke
:: WidgetEvent e
=> [(KeyStroke, e)]
-> KeystrokeCfg
-> KeyStrokeState e
-> Widget s e
makeKeystroke :: forall e s.
WidgetEvent e =>
[(KeyStroke, e)] -> KeystrokeCfg -> KeyStrokeState e -> Widget s e
makeKeystroke [(KeyStroke, e)]
bindings KeystrokeCfg
config KeyStrokeState e
state = forall {s}. Widget s e
widget where
widget :: Widget s e
widget = forall a s e. WidgetModel a => a -> Container s e a -> Widget s e
createContainer KeyStrokeState e
state forall a. Default a => a
def {
containerMerge :: ContainerMergeHandler s e (KeyStrokeState e)
containerMerge = forall {p} {s} {p}.
p -> WidgetNode s e -> p -> KeyStrokeState e -> WidgetResult s e
merge,
containerHandleEvent :: ContainerEventHandler s e
containerHandleEvent = forall {s} {e} {s} {p}.
WidgetEnv s e
-> WidgetNode s e -> p -> SystemEvent -> Maybe (WidgetResult s e)
handleEvent
}
merge :: p -> WidgetNode s e -> p -> KeyStrokeState e -> WidgetResult s e
merge p
wenv WidgetNode s e
node p
oldNode KeyStrokeState e
oldState = forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
newNode where
newNode :: WidgetNode s e
newNode = WidgetNode s e
node
forall a b. a -> (a -> b) -> b
& forall s a. HasWidget s a => Lens' s a
L.widget forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall e s.
WidgetEvent e =>
[(KeyStroke, e)] -> KeystrokeCfg -> KeyStrokeState e -> Widget s e
makeKeystroke [(KeyStroke, e)]
bindings KeystrokeCfg
config KeyStrokeState e
oldState
handleEvent :: WidgetEnv s e
-> WidgetNode s e -> p -> SystemEvent -> Maybe (WidgetResult s e)
handleEvent WidgetEnv s e
wenv WidgetNode s e
node p
target SystemEvent
evt = case SystemEvent
evt of
KeyAction KeyMod
mod KeyCode
code KeyStatus
KeyPressed -> Maybe (WidgetResult s e)
result where
result :: Maybe (WidgetResult s e)
result = KeyEntry -> Maybe (WidgetResult s e)
handleKeystroke (KeyCode -> KeyEntry
KeyEntryCode KeyCode
code)
TextInput Text
text
| Bool
ignoreChildren Bool -> Bool -> Bool
&& Text -> Bool
ignorePrevious Text
text -> forall a. a -> Maybe a
Just WidgetResult s e
result where
newState :: KeyStrokeState e
newState = forall e. [(KeyStroke, e)] -> KeyStrokeState e
KeyStrokeState []
newNode :: WidgetNode s e
newNode = WidgetNode s e
node
forall a b. a -> (a -> b) -> b
& forall s a. HasWidget s a => Lens' s a
L.widget forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall e s.
WidgetEvent e =>
[(KeyStroke, e)] -> KeystrokeCfg -> KeyStrokeState e -> Widget s e
makeKeystroke [(KeyStroke, e)]
bindings KeystrokeCfg
config forall {e}. KeyStrokeState e
newState
result :: WidgetResult s e
result = forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs WidgetNode s e
newNode [forall s e. WidgetRequest s e
IgnoreChildrenEvents]
TextInput Text
text
| Bool -> Bool
not (Text -> Bool
previousMatch Text
text) -> Maybe (WidgetResult s e)
result where
result :: Maybe (WidgetResult s e)
result = KeyEntry -> Maybe (WidgetResult s e)
handleKeystroke (Text -> KeyEntry
KeyEntryText Text
text)
SystemEvent
_ -> forall a. Maybe a
Nothing
where
ignoreChildren :: Bool
ignoreChildren = forall a. a -> Maybe a
Just Bool
True forall a. Eq a => a -> a -> Bool
== KeystrokeCfg -> Maybe Bool
_kscIgnoreChildren KeystrokeCfg
config
previousMatch :: Text -> Bool
previousMatch Text
t = Text
t forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall e. KeyStrokeState e -> [(KeyStroke, e)]
_kssLatest KeyStrokeState e
state forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
folded forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. Field1 s t a b => Lens s t a b
_1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasKsText s a => Lens' s a
ksText
ignorePrevious :: Text -> Bool
ignorePrevious Text
t = Text -> Bool
isTextValidCode Text
t Bool -> Bool -> Bool
&& Text -> Bool
previousMatch Text
t
handleKeystroke :: KeyEntry -> Maybe (WidgetResult s e)
handleKeystroke KeyEntry
entry = forall a. a -> Maybe a
Just WidgetResult s e
result where
newWenv :: WidgetEnv s e
newWenv = WidgetEnv s e
wenv forall a b. a -> (a -> b) -> b
& forall s a. HasInputStatus s a => Lens' s a
L.inputStatus forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ InputStatus -> InputStatus
removeMods
matches :: [(KeyStroke, e)]
matches = forall a. (a -> Bool) -> [a] -> [a]
filter (forall s e. WidgetEnv s e -> KeyEntry -> KeyStroke -> Bool
keyStrokeActive WidgetEnv s e
newWenv KeyEntry
entry forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(KeyStroke, e)]
bindings
newState :: KeyStrokeState e
newState = forall e. [(KeyStroke, e)] -> KeyStrokeState e
KeyStrokeState [(KeyStroke, e)]
matches
newNode :: WidgetNode s e
newNode = WidgetNode s e
node
forall a b. a -> (a -> b) -> b
& forall s a. HasWidget s a => Lens' s a
L.widget forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall e s.
WidgetEvent e =>
[(KeyStroke, e)] -> KeystrokeCfg -> KeyStrokeState e -> Widget s e
makeKeystroke [(KeyStroke, e)]
bindings KeystrokeCfg
config KeyStrokeState e
newState
evts :: [e]
evts = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(KeyStroke, e)]
matches
reqs :: [WidgetRequest s e]
reqs
| Bool
ignoreChildren Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [e]
evts) = [forall s e. WidgetRequest s e
IgnoreChildrenEvents]
| Bool
otherwise = []
result :: WidgetResult s e
result = forall e s.
Typeable e =>
WidgetNode s e -> [WidgetRequest s e] -> [e] -> WidgetResult s e
resultReqsEvts WidgetNode s e
newNode forall {s} {e}. [WidgetRequest s e]
reqs [e]
evts
keyStrokeActive :: WidgetEnv s e -> KeyEntry -> KeyStroke -> Bool
keyStrokeActive :: forall s e. WidgetEnv s e -> KeyEntry -> KeyStroke -> Bool
keyStrokeActive WidgetEnv s e
wenv KeyEntry
entry KeyStroke
ks = Bool
currValid Bool -> Bool -> Bool
&& Bool
allPressed Bool -> Bool -> Bool
&& Bool
validMods where
status :: InputStatus
status = WidgetEnv s e
wenv forall s a. s -> Getting a s a -> a
^. forall s a. HasInputStatus s a => Lens' s a
L.inputStatus
keyMod :: KeyMod
keyMod = InputStatus
status forall s a. s -> Getting a s a -> a
^. forall s a. HasKeyMod s a => Lens' s a
L.keyMod
pressedKeys :: Map KeyCode KeyStatus
pressedKeys = forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (forall a. Eq a => a -> a -> Bool
== KeyStatus
KeyPressed) (InputStatus
status forall s a. s -> Getting a s a -> a
^. forall s a. HasKeys s a => Lens' s a
L.keys)
(Bool
currValid, Bool
allPressed, Bool
ignoreShift) = case KeyEntry
entry of
KeyEntryCode KeyCode
code -> (Bool
valid, Bool
pressed, Bool
False) where
valid :: Bool
valid = KeyCode
code forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (KeyStroke
ks forall s a. s -> Getting a s a -> a
^. forall s a. HasKsKeys s a => Lens' s a
ksKeys) Bool -> Bool -> Bool
|| KeyCode
code forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KeyCode]
modKeys
pressed :: Bool
pressed = forall k a. Map k a -> Set k
M.keysSet Map KeyCode KeyStatus
pressedKeys forall a. Eq a => a -> a -> Bool
== KeyStroke
ks forall s a. s -> Getting a s a -> a
^. forall s a. HasKsKeys s a => Lens' s a
ksKeys
KeyEntryText Text
txt -> (Bool
valid, Bool
True, Bool
True) where
valid :: Bool
valid = Text
txt forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (KeyStroke
ks forall s a. s -> Getting a s a -> a
^. forall s a. HasKsKeysText s a => Lens' s a
ksKeysText)
ctrlPressed :: Bool
ctrlPressed = KeyMod -> Bool
isCtrlPressed KeyMod
keyMod
cmdPressed :: Bool
cmdPressed = forall s e. WidgetEnv s e -> Bool
isMacOS WidgetEnv s e
wenv Bool -> Bool -> Bool
&& KeyMod -> Bool
isGUIPressed KeyMod
keyMod
validC :: Bool
validC = Bool -> Bool
not (KeyStroke
ks forall s a. s -> Getting a s a -> a
^. forall s a. HasKsC s a => Lens' s a
ksC) Bool -> Bool -> Bool
|| KeyStroke
ks forall s a. s -> Getting a s a -> a
^. forall s a. HasKsC s a => Lens' s a
ksC forall a. Eq a => a -> a -> Bool
== (Bool
ctrlPressed Bool -> Bool -> Bool
|| Bool
cmdPressed)
validCtrl :: Bool
validCtrl = KeyStroke
ks forall s a. s -> Getting a s a -> a
^. forall s a. HasKsCtrl s a => Lens' s a
ksCtrl forall a. Eq a => a -> a -> Bool
== Bool
ctrlPressed Bool -> Bool -> Bool
|| Bool
ctrlPressed Bool -> Bool -> Bool
&& Bool
validC
validCmd :: Bool
validCmd = KeyStroke
ks forall s a. s -> Getting a s a -> a
^. forall s a. HasKsCmd s a => Lens' s a
ksCmd forall a. Eq a => a -> a -> Bool
== Bool
cmdPressed Bool -> Bool -> Bool
|| Bool
cmdPressed Bool -> Bool -> Bool
&& Bool
validC
validShift :: Bool
validShift = KeyStroke
ks forall s a. s -> Getting a s a -> a
^. forall s a. HasKsShift s a => Lens' s a
ksShift forall a. Eq a => a -> a -> Bool
== KeyMod -> Bool
isShiftPressed KeyMod
keyMod Bool -> Bool -> Bool
|| Bool
ignoreShift
validAlt :: Bool
validAlt = KeyStroke
ks forall s a. s -> Getting a s a -> a
^. forall s a. HasKsAlt s a => Lens' s a
ksAlt forall a. Eq a => a -> a -> Bool
== KeyMod -> Bool
isAltPressed KeyMod
keyMod
validMods :: Bool
validMods = (Bool
validC Bool -> Bool -> Bool
&& Bool
validCtrl Bool -> Bool -> Bool
&& Bool
validCmd) Bool -> Bool -> Bool
&& Bool
validShift Bool -> Bool -> Bool
&& Bool
validAlt
textToStroke :: Text -> KeyStroke
textToStroke :: Text -> KeyStroke
textToStroke Text
text = KeyStroke
result where
parts :: [Text]
parts = (Char -> Bool) -> Text -> [Text]
T.split (forall a. Eq a => a -> a -> Bool
==Char
'-') Text
text
ks :: KeyStroke
ks = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' KeyStroke -> Text -> KeyStroke
partToStroke forall a. Default a => a
def [Text]
parts
forall a b. a -> (a -> b) -> b
& forall s a. HasKsText s a => Lens' s a
ksText forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text
text
errors :: [Text]
errors = KeyStroke
ks forall s a. s -> Getting a s a -> a
^. forall s a. HasKsErrors s a => Lens' s a
ksErrors
errorMsg :: Text
errorMsg = Text
"'" forall a. Semigroup a => a -> a -> a
<> Text
text forall a. Semigroup a => a -> a -> a
<> Text
"' is not valid. Invalid parts: "
result :: KeyStroke
result
| Bool -> Bool
not (Text -> Bool
T.null Text
text) Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
errors = KeyStroke
ks
| Bool
otherwise = forall a b. Show a => a -> b -> b
traceShow (Text
errorMsg, [Text]
errors) KeyStroke
ks
partToStroke :: KeyStroke -> Text -> KeyStroke
partToStroke :: KeyStroke -> Text -> KeyStroke
partToStroke KeyStroke
ks Text
"A" = KeyStroke
ks forall a b. a -> (a -> b) -> b
& forall s a. HasKsAlt s a => Lens' s a
ksAlt forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True
partToStroke KeyStroke
ks Text
"Alt" = KeyStroke
ks forall a b. a -> (a -> b) -> b
& forall s a. HasKsAlt s a => Lens' s a
ksAlt forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True
partToStroke KeyStroke
ks Text
"C" = KeyStroke
ks forall a b. a -> (a -> b) -> b
& forall s a. HasKsC s a => Lens' s a
ksC forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True
partToStroke KeyStroke
ks Text
"Ctrl" = KeyStroke
ks forall a b. a -> (a -> b) -> b
& forall s a. HasKsCtrl s a => Lens' s a
ksCtrl forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True
partToStroke KeyStroke
ks Text
"Cmd" = KeyStroke
ks forall a b. a -> (a -> b) -> b
& forall s a. HasKsCmd s a => Lens' s a
ksCmd forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True
partToStroke KeyStroke
ks Text
"O" = KeyStroke
ks forall a b. a -> (a -> b) -> b
& forall s a. HasKsAlt s a => Lens' s a
ksAlt forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True
partToStroke KeyStroke
ks Text
"Option" = KeyStroke
ks forall a b. a -> (a -> b) -> b
& forall s a. HasKsAlt s a => Lens' s a
ksAlt forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True
partToStroke KeyStroke
ks Text
"S" = KeyStroke
ks forall a b. a -> (a -> b) -> b
& forall s a. HasKsShift s a => Lens' s a
ksShift forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True
partToStroke KeyStroke
ks Text
"Shift" = KeyStroke
ks forall a b. a -> (a -> b) -> b
& forall s a. HasKsShift s a => Lens' s a
ksShift forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True
partToStroke KeyStroke
ks Text
"Backspace" = KeyStroke
ks forall a b. a -> (a -> b) -> b
& forall s a. HasKsKeys s a => Lens' s a
ksKeys forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyBackspace
partToStroke KeyStroke
ks Text
"Caps" = KeyStroke
ks forall a b. a -> (a -> b) -> b
& forall s a. HasKsKeys s a => Lens' s a
ksKeys forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyCapsLock
partToStroke KeyStroke
ks Text
"Delete" = KeyStroke
ks forall a b. a -> (a -> b) -> b
& forall s a. HasKsKeys s a => Lens' s a
ksKeys forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyDelete
partToStroke KeyStroke
ks Text
"Enter" = KeyStroke
ks forall a b. a -> (a -> b) -> b
& forall s a. HasKsKeys s a => Lens' s a
ksKeys forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyReturn
partToStroke KeyStroke
ks Text
"KpEnter" = KeyStroke
ks forall a b. a -> (a -> b) -> b
& forall s a. HasKsKeys s a => Lens' s a
ksKeys forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyPadEnter
partToStroke KeyStroke
ks Text
"Esc" = KeyStroke
ks forall a b. a -> (a -> b) -> b
& forall s a. HasKsKeys s a => Lens' s a
ksKeys forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyEscape
partToStroke KeyStroke
ks Text
"Return" = KeyStroke
ks forall a b. a -> (a -> b) -> b
& forall s a. HasKsKeys s a => Lens' s a
ksKeys forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyReturn
partToStroke KeyStroke
ks Text
"Space" = KeyStroke
ks forall a b. a -> (a -> b) -> b
& forall s a. HasKsKeys s a => Lens' s a
ksKeys forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keySpace
partToStroke KeyStroke
ks Text
"Tab" = KeyStroke
ks forall a b. a -> (a -> b) -> b
& forall s a. HasKsKeys s a => Lens' s a
ksKeys forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyTab
partToStroke KeyStroke
ks Text
"Up" = KeyStroke
ks forall a b. a -> (a -> b) -> b
& forall s a. HasKsKeys s a => Lens' s a
ksKeys forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyUp
partToStroke KeyStroke
ks Text
"Down" = KeyStroke
ks forall a b. a -> (a -> b) -> b
& forall s a. HasKsKeys s a => Lens' s a
ksKeys forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyDown
partToStroke KeyStroke
ks Text
"Left" = KeyStroke
ks forall a b. a -> (a -> b) -> b
& forall s a. HasKsKeys s a => Lens' s a
ksKeys forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyLeft
partToStroke KeyStroke
ks Text
"Right" = KeyStroke
ks forall a b. a -> (a -> b) -> b
& forall s a. HasKsKeys s a => Lens' s a
ksKeys forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyRight
partToStroke KeyStroke
ks Text
"F1" = KeyStroke
ks forall a b. a -> (a -> b) -> b
& forall s a. HasKsKeys s a => Lens' s a
ksKeys forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyF1
partToStroke KeyStroke
ks Text
"F2" = KeyStroke
ks forall a b. a -> (a -> b) -> b
& forall s a. HasKsKeys s a => Lens' s a
ksKeys forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyF2
partToStroke KeyStroke
ks Text
"F3" = KeyStroke
ks forall a b. a -> (a -> b) -> b
& forall s a. HasKsKeys s a => Lens' s a
ksKeys forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyF3
partToStroke KeyStroke
ks Text
"F4" = KeyStroke
ks forall a b. a -> (a -> b) -> b
& forall s a. HasKsKeys s a => Lens' s a
ksKeys forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyF4
partToStroke KeyStroke
ks Text
"F5" = KeyStroke
ks forall a b. a -> (a -> b) -> b
& forall s a. HasKsKeys s a => Lens' s a
ksKeys forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyF5
partToStroke KeyStroke
ks Text
"F6" = KeyStroke
ks forall a b. a -> (a -> b) -> b
& forall s a. HasKsKeys s a => Lens' s a
ksKeys forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyF6
partToStroke KeyStroke
ks Text
"F7" = KeyStroke
ks forall a b. a -> (a -> b) -> b
& forall s a. HasKsKeys s a => Lens' s a
ksKeys forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyF7
partToStroke KeyStroke
ks Text
"F8" = KeyStroke
ks forall a b. a -> (a -> b) -> b
& forall s a. HasKsKeys s a => Lens' s a
ksKeys forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyF8
partToStroke KeyStroke
ks Text
"F9" = KeyStroke
ks forall a b. a -> (a -> b) -> b
& forall s a. HasKsKeys s a => Lens' s a
ksKeys forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyF9
partToStroke KeyStroke
ks Text
"F10" = KeyStroke
ks forall a b. a -> (a -> b) -> b
& forall s a. HasKsKeys s a => Lens' s a
ksKeys forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyF10
partToStroke KeyStroke
ks Text
"F11" = KeyStroke
ks forall a b. a -> (a -> b) -> b
& forall s a. HasKsKeys s a => Lens' s a
ksKeys forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyF11
partToStroke KeyStroke
ks Text
"F12" = KeyStroke
ks forall a b. a -> (a -> b) -> b
& forall s a. HasKsKeys s a => Lens' s a
ksKeys forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyF12
partToStroke KeyStroke
ks Text
"Dash" = KeyStroke -> Text -> KeyStroke
partToStroke KeyStroke
ks Text
"-"
partToStroke KeyStroke
ks Text
txt
| Text -> Bool
isTextValidCode Text
txt = KeyStroke
ks
forall a b. a -> (a -> b) -> b
& forall s a. HasKsKeys s a => Lens' s a
ksKeys forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. Ord a => a -> Set a -> Set a
Set.insert (Int -> KeyCode
KeyCode (Char -> Int
ord Char
txtHead))
forall a b. a -> (a -> b) -> b
& forall s a. HasKsKeysText s a => Lens' s a
ksKeysText forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. Ord a => a -> Set a -> Set a
Set.insert Text
txt
| Bool
otherwise = KeyStroke
ks
forall a b. a -> (a -> b) -> b
& forall s a. HasKsErrors s a => Lens' s a
ksErrors forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall a. [a] -> [a] -> [a]
++ [Text
txt])
where
txtHead :: Char
txtHead = Text -> Int -> Char
T.index Text
txt Int
0
isTextValidCode :: Text -> Bool
isTextValidCode :: Text -> Bool
isTextValidCode Text
txt = Bool
validLen Bool -> Bool -> Bool
&& Char -> Bool
isAscii Char
txtHead Bool -> Bool -> Bool
&& Char -> Bool
isPrint Char
txtHead where
validLen :: Bool
validLen = Text -> Int
T.length Text
txt forall a. Eq a => a -> a -> Bool
== Int
1
txtHead :: Char
txtHead = Text -> Int -> Char
T.index Text
txt Int
0
removeMods :: InputStatus -> InputStatus
removeMods :: InputStatus -> InputStatus
removeMods InputStatus
status = InputStatus
status
forall a b. a -> (a -> b) -> b
& forall s a. HasKeys s a => Lens' s a
L.keys forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (\KeyCode
k KeyStatus
v -> KeyCode
k forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [KeyCode]
modKeys)
modKeys :: [KeyCode]
modKeys :: [KeyCode]
modKeys = [
KeyCode
keyLAlt, KeyCode
keyRAlt, KeyCode
keyLCtrl, KeyCode
keyRCtrl, KeyCode
keyLGUI, KeyCode
keyRGUI, KeyCode
keyLShift, KeyCode
keyRShift
]