{-|
Module      : Monomer.Widgets.Containers.Keystroke
Copyright   : (c) 2018 Francisco Vallarino
License     : BSD-3-Clause (see the LICENSE file)
Maintainer  : fjvallarino@gmail.com
Stability   : experimental
Portability : non-portable

Container which generates user provided events when combinations of keys occur.
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, 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

The keys can be combined, for example:

- Copy: "Ctrl-c" or "C-c"
- App config: "Ctrl-Shift-p" or "C-S-p"

@
keystroke [("Esc", CancelEditing)] $ hstack [
    label "Username:",
    spacer,
    textField userLens
  ]
@

Note 1: Following the pattern explained in 'CmbIgnoreChildrenEvts', this widget
by default allows children widgets (i.e., focused widgets) that may receive the
events to respond to the pressed keys. If you want to avoid this, and only keep
the keystroke widgets's response when a combination matches, add the
'ignoreChildrenEvts' config option. To clarify: the only keypress event that
will be filtered is the one that causes a combination to match (the last one).

Note 2: Except in the specific cases mentioned here (Ctrl, Cmd, etc), the keys
must be single characters.

Note 3: 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 4: 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 #-}

module Monomer.Widgets.Containers.Keystroke (
  -- * Configuration
  KeystrokeCfg,
  -- * Constructors
  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

{-|
Configuration options for keystroke:

- 'ignoreChildrenEvts': If True, when a shortcut is detected, the KeyAction
  event will not be passed down to children.
-}
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

-- | Creates a keystroke container with a single node as child.
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

-- | Creates a keystroke container with a single node as child. Accepts config,
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
-- Main keys
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
-- Arrows
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
-- Function keys
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
-- Other keys (numbers, letters, points, etc)
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
  ]