{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE RecordWildCards, NamedFieldPuns #-} module Workflow.Keys where --TODO mv to workflow-derived import Workflow.Extra import Workflow.Types import Workflow.Lens import Data.List.Split import qualified Data.Map.Strict as Map import Data.Map.Strict (Map) -------------------------------------------------------------------------------- {-| Parses and executes a keyboard shortcut. (via 'readKeySequence' and 'sendKeyChord'). * more convenient than manually constructing 'Modifier's and 'Key's. * but, (safely) partial e.g. compare: @ press "H-S-t H-l" @ to: @ 'traverse_' 'sendKeyChord'' [ 'KeyChord' ['HyperModifier', 'ShiftModifier'] 'TKey' , 'KeyChord' ['HyperModifier') 'LKey' ] @ (a keyboard shortcut to "re-open tab, then jump to url bar") 'throwM's on a "syntax error" The default syntax is inspired by Emacs: @ press = 'press'' 'defaultKeyChordSyntax' @ -} press :: (MonadWorkflow m, MonadThrow m) => String -> m () press = press' defaultKeyChordSyntax {-| >>> readEmacsKeySequence "H-S-t H-l" Just [([HyperModifier,ShiftModifier],TKey),([HyperModifier],LKey)] @='readEmacsKeySequence' 'emacsKeyChordSyntax'@ -} readEmacsKeySequence :: String -> Maybe KeySequence readEmacsKeySequence = readKeySequence emacsKeyChordSyntax {-| >>> readEmacsKeyChord "H-S-t" Just ([HyperModifier,ShiftModifier],TKey) @='readEmacsKeyChord' 'emacsKeyChordSyntax'@ -} readEmacsKeyChord :: String -> Maybe KeySequence readEmacsKeyChord = readKeySequence emacsKeyChordSyntax {- | >>> readEmacsModifier "H" Just HyperModifier @='readModifier' 'emacsModifierSyntax'@ -} readEmacsModifier :: String -> Maybe Modifier readEmacsModifier = readModifier emacsModifierSyntax {- | >>> readEmacsKey "" Just TabKey @='readKey' 'emacsKeySyntax'@ -} readEmacsKey :: String -> Maybe KeyChord readEmacsKey = readKey emacsKeySyntax -------------------------------------------------------------------------------- {-| Build your own 'press'. e.g. @ import "Workflow.Core" hiding (press) press = press' KeyChordSyntax{..} modifierSyntax :: ModifierSyntax modifierSyntax = defaultModifierSyntax -- defaulting keySyntax :: KeySyntax -- overriding keySyntax = Map.fromList [ ... ] @ -} press' :: (MonadWorkflow m, MonadThrow m) => KeyChordSyntax -> String -> m () press' syntax s = go s where go = (readKeySequence syntax >>> __cast__) >=> traverse_ sendKeyChord' __cast__ = \case Nothing -> __fail__ Just [] -> __fail__ --TODO? readKeySequence :: MonadThrow m => String -> m KeySequence Just ks -> return ks --TODO NonEmpty __fail__ = failed $ "syntax error: {{Workflow.Keys.press "++(show s)++"}}" -- TODO? Control.Monad.Fail (MonadFail(..)) readKeySequence :: KeyChordSyntax -> String -> Maybe KeySequence --TODO Either ReadKeySequenceError / ErrorReadingKeySequence readKeySequence syntax --TODO plural? --TODO make extensible with Map Char Key and Map String Modifier and inner-div and outer-div = splitOn " " >>> fmap (splitOn "-") >>> traverse (readKeyChord syntax) -- >>> fmap concat readKeyChord :: KeyChordSyntax -> [String] -> Maybe KeyChord readKeyChord KeyChordSyntax{..} = \case [] -> Nothing s@(_:_) -> do ms <- traverse (readModifier modifierSyntax) (init s) --NOTE total, TODO prove with NonEmpty.init k <- (readKey keySyntax) (last s) --NOTE total --TODO munch uppercase until lwoer return $ addMods ms k -- | surjective, non-injective. readModifier :: ModifierSyntax -> String -> Maybe Modifier readModifier = (flip Map.lookup) -- | readKey :: KeySyntax -> String -> Maybe KeyChord --TODO string for non-alphanums like readKey = (flip Map.lookup) -------------------------------------------------------------------------------- {-| A table for parsing strings of modifiers and keys. -} data KeyChordSyntax = KeyChordSyntax { modifierSyntax :: ModifierSyntax , keySyntax :: KeySyntax } deriving (Show,Read,Eq,Ord,Data,Generic) instance NFData KeyChordSyntax -- | '<>' overrides (i.e. right-biased i.e. pick the last). instance Monoid KeyChordSyntax where mempty = KeyChordSyntax mempty mempty mappend (KeyChordSyntax m1 k1) (KeyChordSyntax m2 k2) = KeyChordSyntax{..} where modifierSyntax = Map.unionWith (curry snd) m1 m2 keySyntax = Map.unionWith (curry snd) k1 k2 type ModifierSyntax = Map String Modifier type KeySyntax = Map String KeyChord -- | @= 'emacsKeyChordSyntax'@ defaultKeyChordSyntax :: KeyChordSyntax defaultKeyChordSyntax = KeyChordSyntax defaultModifierSyntax defaultKeySyntax -- | @= 'emacsModifierSyntax'@ defaultModifierSyntax :: ModifierSyntax defaultModifierSyntax = emacsModifierSyntax -- | @= 'emacsKeySyntax'@ defaultKeySyntax :: KeySyntax defaultKeySyntax = emacsKeySyntax -- | @= 'KeyChordSyntax' 'defaultModifierSyntax' 'defaultKeySyntax'@ emacsKeyChordSyntax :: KeyChordSyntax emacsKeyChordSyntax = KeyChordSyntax defaultModifierSyntax defaultKeySyntax -- | (see source) emacsModifierSyntax :: ModifierSyntax emacsModifierSyntax = Map.fromList [ "M" -: MetaModifier , "H" -: HyperModifier --TODO C , "C" -: ControlModifier --TODO N / R / L , "O" -: OptionModifier --TODO A , "A" -: OptionModifier , "S" -: ShiftModifier , "F" -: FunctionModifier ] {- | follows , with some differences: * non-modifier uppercase alphabetic characters are not shifted, for consistency: * e.g. use @"M-S-a"@, not @"M-A"@ * e.g. but @"M-:"@ and @"M-S-;"@ can both be used * non-alphanumeric characters can be in angle brackets: * e.g. use @"C-"@, not @"C-TAB"@ * e.g. but @"C-\t"@ can be used (see source) -} emacsKeySyntax :: KeySyntax --TODO newtype, def, IsList --TODO modules, neither explicit nor implicit param emacsKeySyntax = Map.fromList [ "a" -: KeyChord [ ] AKey , "A" -: KeyChord [ShiftModifier] AKey , "b" -: KeyChord [ ] BKey , "B" -: KeyChord [ShiftModifier] BKey , "c" -: KeyChord [ ] CKey , "C" -: KeyChord [ShiftModifier] CKey , "d" -: KeyChord [ ] DKey , "D" -: KeyChord [ShiftModifier] DKey , "e" -: KeyChord [ ] EKey , "E" -: KeyChord [ShiftModifier] EKey , "f" -: KeyChord [ ] FKey , "F" -: KeyChord [ShiftModifier] FKey , "g" -: KeyChord [ ] GKey , "G" -: KeyChord [ShiftModifier] GKey , "h" -: KeyChord [ ] HKey , "H" -: KeyChord [ShiftModifier] HKey , "i" -: KeyChord [ ] IKey , "I" -: KeyChord [ShiftModifier] IKey , "j" -: KeyChord [ ] JKey , "J" -: KeyChord [ShiftModifier] JKey , "k" -: KeyChord [ ] KKey , "K" -: KeyChord [ShiftModifier] KKey , "l" -: KeyChord [ ] LKey , "L" -: KeyChord [ShiftModifier] LKey , "m" -: KeyChord [ ] MKey , "M" -: KeyChord [ShiftModifier] MKey , "n" -: KeyChord [ ] NKey , "N" -: KeyChord [ShiftModifier] NKey , "o" -: KeyChord [ ] OKey , "O" -: KeyChord [ShiftModifier] OKey , "p" -: KeyChord [ ] PKey , "P" -: KeyChord [ShiftModifier] PKey , "q" -: KeyChord [ ] QKey , "Q" -: KeyChord [ShiftModifier] QKey , "r" -: KeyChord [ ] RKey , "R" -: KeyChord [ShiftModifier] RKey , "s" -: KeyChord [ ] SKey , "S" -: KeyChord [ShiftModifier] SKey , "t" -: KeyChord [ ] TKey , "T" -: KeyChord [ShiftModifier] TKey , "u" -: KeyChord [ ] UKey , "U" -: KeyChord [ShiftModifier] UKey , "v" -: KeyChord [ ] VKey , "V" -: KeyChord [ShiftModifier] VKey , "w" -: KeyChord [ ] WKey , "W" -: KeyChord [ShiftModifier] WKey , "x" -: KeyChord [ ] XKey , "X" -: KeyChord [ShiftModifier] XKey , "y" -: KeyChord [ ] YKey , "Y" -: KeyChord [ShiftModifier] YKey , "z" -: KeyChord [ ] ZKey , "Z" -: KeyChord [ShiftModifier] ZKey , "0" -: KeyChord [ ] ZeroKey , ")" -: KeyChord [ShiftModifier] ZeroKey , "1" -: KeyChord [ ] OneKey , "!" -: KeyChord [ShiftModifier] OneKey , "2" -: KeyChord [ ] TwoKey , "@" -: KeyChord [ShiftModifier] TwoKey , "3" -: KeyChord [ ] ThreeKey , "#" -: KeyChord [ShiftModifier] ThreeKey , "4" -: KeyChord [ ] FourKey , "$" -: KeyChord [ShiftModifier] FourKey , "5" -: KeyChord [ ] FiveKey , "%" -: KeyChord [ShiftModifier] FiveKey , "6" -: KeyChord [ ] SixKey , "^" -: KeyChord [ShiftModifier] SixKey , "7" -: KeyChord [ ] SevenKey , "&" -: KeyChord [ShiftModifier] SevenKey , "8" -: KeyChord [ ] EightKey , "*" -: KeyChord [ShiftModifier] EightKey , "9" -: KeyChord [ ] NineKey , "(" -: KeyChord [ShiftModifier] NineKey , "`" -: KeyChord [ ] GraveKey , "~" -: KeyChord [ShiftModifier] GraveKey , "" -: KeyChord [ ] MinusKey , "-" -: KeyChord [ ] MinusKey --TODO fails , "_" -: KeyChord [ShiftModifier] MinusKey , "=" -: KeyChord [ ] EqualKey , "+" -: KeyChord [ShiftModifier] EqualKey , "[" -: KeyChord [ ] LeftBracketKey , "{" -: KeyChord [ShiftModifier] LeftBracketKey , "]" -: KeyChord [ ] RightBracketKey , "}" -: KeyChord [ShiftModifier] RightBracketKey , "\\" -: KeyChord [ ] BackslashKey , "|" -: KeyChord [ShiftModifier] BackslashKey , ";" -: KeyChord [ ] SemicolonKey , ":" -: KeyChord [ShiftModifier] SemicolonKey , "'" -: KeyChord [ ] QuoteKey , "\"" -: KeyChord [ShiftModifier] QuoteKey , "," -: KeyChord [ ] CommaKey , "<" -: KeyChord [ShiftModifier] CommaKey , "." -: KeyChord [ ] PeriodKey , ">" -: KeyChord [ShiftModifier] PeriodKey , "/" -: KeyChord [ ] SlashKey , "?" -: KeyChord [ShiftModifier] SlashKey , " " -: KeyChord [ ] SpaceKey , "\t" -: KeyChord [ ] TabKey , "\n" -: KeyChord [ ] ReturnKey , ""-: SimpleKeyChord SpaceKey , ""-: SimpleKeyChord TabKey , ""-: SimpleKeyChord ReturnKey , ""-: SimpleKeyChord DeleteKey , ""-: SimpleKeyChord EscapeKey , "" -: SimpleKeyChord UpArrowKey , "" -: SimpleKeyChord DownArrowKey , "" -: SimpleKeyChord LeftArrowKey , ""-: SimpleKeyChord RightArrowKey , "" -: SimpleKeyChord F1Key , "" -: SimpleKeyChord F2Key , "" -: SimpleKeyChord F3Key , "" -: SimpleKeyChord F4Key , "" -: SimpleKeyChord F5Key , "" -: SimpleKeyChord F6Key , "" -: SimpleKeyChord F7Key , "" -: SimpleKeyChord F8Key , "" -: SimpleKeyChord F9Key , ""-: SimpleKeyChord F10Key , ""-: SimpleKeyChord F11Key , ""-: SimpleKeyChord F12Key , ""-: SimpleKeyChord F13Key , ""-: SimpleKeyChord F14Key , ""-: SimpleKeyChord F15Key , ""-: SimpleKeyChord F16Key , ""-: SimpleKeyChord F17Key , ""-: SimpleKeyChord F18Key , ""-: SimpleKeyChord F19Key , ""-: SimpleKeyChord F20Key ] -------------------------------------------------------------------------------- -- | appends modifiers addMods :: [Modifier] -> KeyChord -> KeyChord addMods ms kc = foldr addMod kc ms -- | appends a modifier addMod :: Modifier -> KeyChord -> KeyChord addMod m (ms, k) = (m:ms, k) -- false positive nonexhaustive warning with the KeyChord pattern. fixed in ghc8? -- addMod m (KeyChord ms k) = KeyChord (m:ms) k -------------------------------------------------------------------------------- {-TODO Is The benefit of avoiding a parser library as a dependency worth the awkwardness? -} {- the keychord that would insert the character into the application. >>> char2keychord '@' :: Maybe KeyChord Just ([ShiftModifier], TwoKey) some characters cannot be represented as keypresses, like some non-printable characters (in arbitrary applications, not just the terminal emulator): >>> char2keychord '\0' :: Maybe KeyChord Nothing prop> case char2keychord c of { Just ([],_) -> True; Just ([ShiftModifier],_) -> True; Nothing -> True; _ -> False } -} char2keychord :: (MonadThrow m) => Char -> m KeyChord char2keychord c = case c of 'a' -> return $ KeyChord [ ] AKey 'A' -> return $ KeyChord [ShiftModifier] AKey 'b' -> return $ KeyChord [ ] BKey 'B' -> return $ KeyChord [ShiftModifier] BKey 'c' -> return $ KeyChord [ ] CKey 'C' -> return $ KeyChord [ShiftModifier] CKey 'd' -> return $ KeyChord [ ] DKey 'D' -> return $ KeyChord [ShiftModifier] DKey 'e' -> return $ KeyChord [ ] EKey 'E' -> return $ KeyChord [ShiftModifier] EKey 'f' -> return $ KeyChord [ ] FKey 'F' -> return $ KeyChord [ShiftModifier] FKey 'g' -> return $ KeyChord [ ] GKey 'G' -> return $ KeyChord [ShiftModifier] GKey 'h' -> return $ KeyChord [ ] HKey 'H' -> return $ KeyChord [ShiftModifier] HKey 'i' -> return $ KeyChord [ ] IKey 'I' -> return $ KeyChord [ShiftModifier] IKey 'j' -> return $ KeyChord [ ] JKey 'J' -> return $ KeyChord [ShiftModifier] JKey 'k' -> return $ KeyChord [ ] KKey 'K' -> return $ KeyChord [ShiftModifier] KKey 'l' -> return $ KeyChord [ ] LKey 'L' -> return $ KeyChord [ShiftModifier] LKey 'm' -> return $ KeyChord [ ] MKey 'M' -> return $ KeyChord [ShiftModifier] MKey 'n' -> return $ KeyChord [ ] NKey 'N' -> return $ KeyChord [ShiftModifier] NKey 'o' -> return $ KeyChord [ ] OKey 'O' -> return $ KeyChord [ShiftModifier] OKey 'p' -> return $ KeyChord [ ] PKey 'P' -> return $ KeyChord [ShiftModifier] PKey 'q' -> return $ KeyChord [ ] QKey 'Q' -> return $ KeyChord [ShiftModifier] QKey 'r' -> return $ KeyChord [ ] RKey 'R' -> return $ KeyChord [ShiftModifier] RKey 's' -> return $ KeyChord [ ] SKey 'S' -> return $ KeyChord [ShiftModifier] SKey 't' -> return $ KeyChord [ ] TKey 'T' -> return $ KeyChord [ShiftModifier] TKey 'u' -> return $ KeyChord [ ] UKey 'U' -> return $ KeyChord [ShiftModifier] UKey 'v' -> return $ KeyChord [ ] VKey 'V' -> return $ KeyChord [ShiftModifier] VKey 'w' -> return $ KeyChord [ ] WKey 'W' -> return $ KeyChord [ShiftModifier] WKey 'x' -> return $ KeyChord [ ] XKey 'X' -> return $ KeyChord [ShiftModifier] XKey 'y' -> return $ KeyChord [ ] YKey 'Y' -> return $ KeyChord [ShiftModifier] YKey 'z' -> return $ KeyChord [ ] ZKey 'Z' -> return $ KeyChord [ShiftModifier] ZKey '0' -> return $ KeyChord [ ] ZeroKey ')' -> return $ KeyChord [ShiftModifier] ZeroKey '1' -> return $ KeyChord [ ] OneKey '!' -> return $ KeyChord [ShiftModifier] OneKey '2' -> return $ KeyChord [ ] TwoKey '@' -> return $ KeyChord [ShiftModifier] TwoKey '3' -> return $ KeyChord [ ] ThreeKey '#' -> return $ KeyChord [ShiftModifier] ThreeKey '4' -> return $ KeyChord [ ] FourKey '$' -> return $ KeyChord [ShiftModifier] FourKey '5' -> return $ KeyChord [ ] FiveKey '%' -> return $ KeyChord [ShiftModifier] FiveKey '6' -> return $ KeyChord [ ] SixKey '^' -> return $ KeyChord [ShiftModifier] SixKey '7' -> return $ KeyChord [ ] SevenKey '&' -> return $ KeyChord [ShiftModifier] SevenKey '8' -> return $ KeyChord [ ] EightKey '*' -> return $ KeyChord [ShiftModifier] EightKey '9' -> return $ KeyChord [ ] NineKey '(' -> return $ KeyChord [ShiftModifier] NineKey '`' -> return $ KeyChord [ ] GraveKey '~' -> return $ KeyChord [ShiftModifier] GraveKey '-' -> return $ KeyChord [ ] MinusKey '_' -> return $ KeyChord [ShiftModifier] MinusKey '=' -> return $ KeyChord [ ] EqualKey '+' -> return $ KeyChord [ShiftModifier] EqualKey '[' -> return $ KeyChord [ ] LeftBracketKey '{' -> return $ KeyChord [ShiftModifier] LeftBracketKey ']' -> return $ KeyChord [ ] RightBracketKey '}' -> return $ KeyChord [ShiftModifier] RightBracketKey '\\' -> return $ KeyChord [ ] BackslashKey '|' -> return $ KeyChord [ShiftModifier] BackslashKey ';' -> return $ KeyChord [ ] SemicolonKey ':' -> return $ KeyChord [ShiftModifier] SemicolonKey '\'' -> return $ KeyChord [ ] QuoteKey '"' -> return $ KeyChord [ShiftModifier] QuoteKey ',' -> return $ KeyChord [ ] CommaKey '<' -> return $ KeyChord [ShiftModifier] CommaKey '.' -> return $ KeyChord [ ] PeriodKey '>' -> return $ KeyChord [ShiftModifier] PeriodKey '/' -> return $ KeyChord [ ] SlashKey '?' -> return $ KeyChord [ShiftModifier] SlashKey ' ' -> return $ KeyChord [ ] SpaceKey '\t' -> return $ KeyChord [ ] TabKey '\n' -> return $ KeyChord [ ] ReturnKey _ -> failed $ "{{ char2keychord "++(show c)++" }} not an ASCII, printable character"