{-|
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, folded)
import Control.Lens.TH (abbreviatedFields, makeLensesWith)
import Data.Bifunctor (first)
import Data.Char (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 = Maybe Bool
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 Maybe Bool -> Maybe Bool -> Maybe Bool
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> KeystrokeCfg -> Maybe Bool
_kscIgnoreChildren KeystrokeCfg
t1
  }

instance Monoid KeystrokeCfg where
  mempty :: KeystrokeCfg
mempty = KeystrokeCfg
forall a. Default a => a
def

instance CmbIgnoreChildrenEvts KeystrokeCfg where
  ignoreChildrenEvts_ :: Bool -> KeystrokeCfg
ignoreChildrenEvts_ Bool
ignore = KeystrokeCfg
forall a. Default a => a
def {
    _kscIgnoreChildren = Just 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
(KeyStroke -> KeyStroke -> Bool)
-> (KeyStroke -> KeyStroke -> Bool) -> Eq KeyStroke
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: KeyStroke -> KeyStroke -> Bool
== :: KeyStroke -> KeyStroke -> Bool
$c/= :: KeyStroke -> KeyStroke -> Bool
/= :: KeyStroke -> KeyStroke -> Bool
Eq, Int -> KeyStroke -> ShowS
[KeyStroke] -> ShowS
KeyStroke -> String
(Int -> KeyStroke -> ShowS)
-> (KeyStroke -> String)
-> ([KeyStroke] -> ShowS)
-> Show KeyStroke
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> KeyStroke -> ShowS
showsPrec :: Int -> KeyStroke -> ShowS
$cshow :: KeyStroke -> String
show :: KeyStroke -> String
$cshowList :: [KeyStroke] -> ShowS
showList :: [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 = Set KeyCode
forall a. Set a
Set.empty,
    _kstKsKeysText :: Set Text
_kstKsKeysText = Set Text
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
(KeyStrokeState e -> KeyStrokeState e -> Bool)
-> (KeyStrokeState e -> KeyStrokeState e -> Bool)
-> Eq (KeyStrokeState e)
forall e. Eq e => KeyStrokeState e -> KeyStrokeState e -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$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
/= :: KeyStrokeState e -> KeyStrokeState e -> Bool
Eq)

instance Show (KeyStrokeState e) where
  show :: KeyStrokeState e -> String
show (KeyStrokeState [(KeyStroke, e)]
keys) = [KeyStroke] -> String
forall a. Show a => a -> String
show (((KeyStroke, e) -> KeyStroke) -> [(KeyStroke, e)] -> [KeyStroke]
forall a b. (a -> b) -> [a] -> [b]
map (KeyStroke, e) -> KeyStroke
forall a b. (a, b) -> a
fst [(KeyStroke, e)]
keys)

data KeyEntry
  = KeyEntryCode KeyCode
  | KeyEntryText Text
  deriving (KeyEntry -> KeyEntry -> Bool
(KeyEntry -> KeyEntry -> Bool)
-> (KeyEntry -> KeyEntry -> Bool) -> Eq KeyEntry
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: KeyEntry -> KeyEntry -> Bool
== :: KeyEntry -> KeyEntry -> Bool
$c/= :: KeyEntry -> KeyEntry -> Bool
/= :: KeyEntry -> KeyEntry -> Bool
Eq, Int -> KeyEntry -> ShowS
[KeyEntry] -> ShowS
KeyEntry -> String
(Int -> KeyEntry -> ShowS)
-> (KeyEntry -> String) -> ([KeyEntry] -> ShowS) -> Show KeyEntry
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> KeyEntry -> ShowS
showsPrec :: Int -> KeyEntry -> ShowS
$cshow :: KeyEntry -> String
show :: KeyEntry -> String
$cshowList :: [KeyEntry] -> ShowS
showList :: [KeyEntry] -> ShowS
Show)

makeLensesWith abbreviatedFields ''KeyStroke
makeLensesWith abbreviatedFields ''KeyStrokeState

-- | Creates a keystroke container with a single node as child.
keystroke
  :: WidgetEvent e
  => [(Text, e)]     -- ^ The list of key combinations and events.
  -> WidgetNode s e  -- ^ The child node.
  -> WidgetNode s e  -- ^ The created keystroke container.
keystroke :: forall e s.
WidgetEvent e =>
[(Text, e)] -> WidgetNode s e -> WidgetNode s e
keystroke [(Text, e)]
bindings WidgetNode s e
managed = [(Text, e)] -> [KeystrokeCfg] -> WidgetNode s e -> WidgetNode s e
forall e s.
WidgetEvent e =>
[(Text, e)] -> [KeystrokeCfg] -> WidgetNode s e -> WidgetNode s e
keystroke_ [(Text, e)]
bindings [KeystrokeCfg]
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)]     -- ^ The list of key combinations and events.
  -> [KeystrokeCfg]  -- ^ The config options.
  -> WidgetNode s e  -- ^ The child node.
  -> WidgetNode s e  -- ^ The created keystroke container.
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 = Widget s e -> WidgetNode s e -> WidgetNode s e
forall s e. Widget s e -> WidgetNode s e -> WidgetNode s e
makeNode Widget s e
forall {s}. Widget s e
widget WidgetNode s e
managed where
  config :: KeystrokeCfg
config = [KeystrokeCfg] -> KeystrokeCfg
forall a. Monoid a => [a] -> a
mconcat [KeystrokeCfg]
configs
  newBindings :: [(KeyStroke, e)]
newBindings = ((Text, e) -> (KeyStroke, e)) -> [(Text, e)] -> [(KeyStroke, e)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text -> KeyStroke) -> (Text, e) -> (KeyStroke, e)
forall a b c. (a -> b) -> (a, c) -> (b, c)
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 = [(KeyStroke, e)] -> KeyStrokeState e
forall e. [(KeyStroke, e)] -> KeyStrokeState e
KeyStrokeState []
  widget :: Widget s e
widget = [(KeyStroke, e)] -> KeystrokeCfg -> KeyStrokeState e -> Widget s e
forall e s.
WidgetEvent e =>
[(KeyStroke, e)] -> KeystrokeCfg -> KeyStrokeState e -> Widget s e
makeKeystroke [(KeyStroke, e)]
newBindings KeystrokeCfg
config KeyStrokeState e
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 = WidgetType -> Widget s e -> WidgetNode s e
forall s e. WidgetType -> Widget s e -> WidgetNode s e
defaultWidgetNode WidgetType
"keystroke" Widget s e
widget
  WidgetNode s e
-> (WidgetNode s e -> WidgetNode s e) -> WidgetNode s e
forall a b. a -> (a -> b) -> b
& (WidgetNodeInfo -> Identity WidgetNodeInfo)
-> WidgetNode s e -> Identity (WidgetNode s e)
forall s a. HasInfo s a => Lens' s a
Lens' (WidgetNode s e) WidgetNodeInfo
L.info ((WidgetNodeInfo -> Identity WidgetNodeInfo)
 -> WidgetNode s e -> Identity (WidgetNode s e))
-> ((Bool -> Identity Bool)
    -> WidgetNodeInfo -> Identity WidgetNodeInfo)
-> (Bool -> Identity Bool)
-> WidgetNode s e
-> Identity (WidgetNode s e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Identity Bool)
-> WidgetNodeInfo -> Identity WidgetNodeInfo
forall s a. HasFocusable s a => Lens' s a
Lens' WidgetNodeInfo Bool
L.focusable ((Bool -> Identity Bool)
 -> WidgetNode s e -> Identity (WidgetNode s e))
-> Bool -> WidgetNode s e -> WidgetNode s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
False
  WidgetNode s e
-> (WidgetNode s e -> WidgetNode s e) -> WidgetNode s e
forall a b. a -> (a -> b) -> b
& (Seq (WidgetNode s e) -> Identity (Seq (WidgetNode s e)))
-> WidgetNode s e -> Identity (WidgetNode s e)
forall s a. HasChildren s a => Lens' s a
Lens' (WidgetNode s e) (Seq (WidgetNode s e))
L.children ((Seq (WidgetNode s e) -> Identity (Seq (WidgetNode s e)))
 -> WidgetNode s e -> Identity (WidgetNode s e))
-> Seq (WidgetNode s e) -> WidgetNode s e -> WidgetNode s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ WidgetNode s e -> Seq (WidgetNode s e)
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 = Widget s e
forall {s}. Widget s e
widget where
  widget :: Widget s e
widget = KeyStrokeState e -> Container s e (KeyStrokeState e) -> Widget s e
forall a s e. WidgetModel a => a -> Container s e a -> Widget s e
createContainer KeyStrokeState e
state Container s e (KeyStrokeState e)
forall a. Default a => a
def {
    containerMerge = merge,
    containerHandleEvent = handleEvent
  }

  merge :: p -> WidgetNode s e -> p -> KeyStrokeState e -> WidgetResult s e
merge p
wenv WidgetNode s e
node p
oldNode KeyStrokeState e
oldState = WidgetNode s e -> WidgetResult s e
forall s e. WidgetNode s e -> WidgetResult s e
resultNode WidgetNode s e
newNode where
    newNode :: WidgetNode s e
newNode = WidgetNode s e
node
      WidgetNode s e
-> (WidgetNode s e -> WidgetNode s e) -> WidgetNode s e
forall a b. a -> (a -> b) -> b
& (Widget s e -> Identity (Widget s e))
-> WidgetNode s e -> Identity (WidgetNode s e)
forall s a. HasWidget s a => Lens' s a
Lens' (WidgetNode s e) (Widget s e)
L.widget ((Widget s e -> Identity (Widget s e))
 -> WidgetNode s e -> Identity (WidgetNode s e))
-> Widget s e -> WidgetNode s e -> WidgetNode s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [(KeyStroke, e)] -> KeystrokeCfg -> KeyStrokeState e -> Widget s e
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 -> WidgetResult s e -> Maybe (WidgetResult s e)
forall a. a -> Maybe a
Just WidgetResult s e
result where
        newState :: KeyStrokeState e
newState = [(KeyStroke, e)] -> KeyStrokeState e
forall e. [(KeyStroke, e)] -> KeyStrokeState e
KeyStrokeState []
        newNode :: WidgetNode s e
newNode = WidgetNode s e
node
          WidgetNode s e
-> (WidgetNode s e -> WidgetNode s e) -> WidgetNode s e
forall a b. a -> (a -> b) -> b
& (Widget s e -> Identity (Widget s e))
-> WidgetNode s e -> Identity (WidgetNode s e)
forall s a. HasWidget s a => Lens' s a
Lens' (WidgetNode s e) (Widget s e)
L.widget ((Widget s e -> Identity (Widget s e))
 -> WidgetNode s e -> Identity (WidgetNode s e))
-> Widget s e -> WidgetNode s e -> WidgetNode s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [(KeyStroke, e)] -> KeystrokeCfg -> KeyStrokeState e -> Widget s e
forall e s.
WidgetEvent e =>
[(KeyStroke, e)] -> KeystrokeCfg -> KeyStrokeState e -> Widget s e
makeKeystroke [(KeyStroke, e)]
bindings KeystrokeCfg
config KeyStrokeState e
forall {e}. KeyStrokeState e
newState
        result :: WidgetResult s e
result = WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
forall s e.
WidgetNode s e -> [WidgetRequest s e] -> WidgetResult s e
resultReqs WidgetNode s e
newNode [WidgetRequest s e
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
_ -> Maybe (WidgetResult s e)
forall a. Maybe a
Nothing
    where
      ignoreChildren :: Bool
ignoreChildren = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== KeystrokeCfg -> Maybe Bool
_kscIgnoreChildren KeystrokeCfg
config
      previousMatch :: Text -> Bool
previousMatch Text
t = Text
t Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` KeyStrokeState e -> [(KeyStroke, e)]
forall e. KeyStrokeState e -> [(KeyStroke, e)]
_kssLatest KeyStrokeState e
state [(KeyStroke, e)]
-> Getting (Endo [Text]) [(KeyStroke, e)] Text -> [Text]
forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. ((KeyStroke, e) -> Const (Endo [Text]) (KeyStroke, e))
-> [(KeyStroke, e)] -> Const (Endo [Text]) [(KeyStroke, e)]
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
IndexedFold Int [(KeyStroke, e)] (KeyStroke, e)
folded (((KeyStroke, e) -> Const (Endo [Text]) (KeyStroke, e))
 -> [(KeyStroke, e)] -> Const (Endo [Text]) [(KeyStroke, e)])
-> ((Text -> Const (Endo [Text]) Text)
    -> (KeyStroke, e) -> Const (Endo [Text]) (KeyStroke, e))
-> Getting (Endo [Text]) [(KeyStroke, e)] Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KeyStroke -> Const (Endo [Text]) KeyStroke)
-> (KeyStroke, e) -> Const (Endo [Text]) (KeyStroke, e)
forall s t a b. Field1 s t a b => Lens s t a b
Lens (KeyStroke, e) (KeyStroke, e) KeyStroke KeyStroke
_1 ((KeyStroke -> Const (Endo [Text]) KeyStroke)
 -> (KeyStroke, e) -> Const (Endo [Text]) (KeyStroke, e))
-> ((Text -> Const (Endo [Text]) Text)
    -> KeyStroke -> Const (Endo [Text]) KeyStroke)
-> (Text -> Const (Endo [Text]) Text)
-> (KeyStroke, e)
-> Const (Endo [Text]) (KeyStroke, e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const (Endo [Text]) Text)
-> KeyStroke -> Const (Endo [Text]) KeyStroke
forall s a. HasKsText s a => Lens' s a
Lens' KeyStroke Text
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 = WidgetResult s e -> Maybe (WidgetResult s e)
forall a. a -> Maybe a
Just WidgetResult s e
result where
        newWenv :: WidgetEnv s e
newWenv = WidgetEnv s e
wenv WidgetEnv s e -> (WidgetEnv s e -> WidgetEnv s e) -> WidgetEnv s e
forall a b. a -> (a -> b) -> b
& (InputStatus -> Identity InputStatus)
-> WidgetEnv s e -> Identity (WidgetEnv s e)
forall s a. HasInputStatus s a => Lens' s a
Lens' (WidgetEnv s e) InputStatus
L.inputStatus ((InputStatus -> Identity InputStatus)
 -> WidgetEnv s e -> Identity (WidgetEnv s e))
-> (InputStatus -> InputStatus) -> WidgetEnv s e -> WidgetEnv s e
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ InputStatus -> InputStatus
removeMods
        matches :: [(KeyStroke, e)]
matches = ((KeyStroke, e) -> Bool) -> [(KeyStroke, e)] -> [(KeyStroke, e)]
forall a. (a -> Bool) -> [a] -> [a]
filter (WidgetEnv s e -> KeyEntry -> KeyStroke -> Bool
forall s e. WidgetEnv s e -> KeyEntry -> KeyStroke -> Bool
keyStrokeActive WidgetEnv s e
newWenv KeyEntry
entry (KeyStroke -> Bool)
-> ((KeyStroke, e) -> KeyStroke) -> (KeyStroke, e) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KeyStroke, e) -> KeyStroke
forall a b. (a, b) -> a
fst) [(KeyStroke, e)]
bindings
        newState :: KeyStrokeState e
newState = [(KeyStroke, e)] -> KeyStrokeState e
forall e. [(KeyStroke, e)] -> KeyStrokeState e
KeyStrokeState [(KeyStroke, e)]
matches
        newNode :: WidgetNode s e
newNode = WidgetNode s e
node
          WidgetNode s e
-> (WidgetNode s e -> WidgetNode s e) -> WidgetNode s e
forall a b. a -> (a -> b) -> b
& (Widget s e -> Identity (Widget s e))
-> WidgetNode s e -> Identity (WidgetNode s e)
forall s a. HasWidget s a => Lens' s a
Lens' (WidgetNode s e) (Widget s e)
L.widget ((Widget s e -> Identity (Widget s e))
 -> WidgetNode s e -> Identity (WidgetNode s e))
-> Widget s e -> WidgetNode s e -> WidgetNode s e
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [(KeyStroke, e)] -> KeystrokeCfg -> KeyStrokeState e -> Widget s e
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 = (KeyStroke, e) -> e
forall a b. (a, b) -> b
snd ((KeyStroke, e) -> e) -> [(KeyStroke, e)] -> [e]
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 ([e] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [e]
evts) = [WidgetRequest s e
forall s e. WidgetRequest s e
IgnoreChildrenEvents]
          | Bool
otherwise = []
        result :: WidgetResult s e
result = WidgetNode s e -> [WidgetRequest s e] -> [e] -> WidgetResult s e
forall e s.
Typeable e =>
WidgetNode s e -> [WidgetRequest s e] -> [e] -> WidgetResult s e
resultReqsEvts WidgetNode s e
newNode [WidgetRequest s e]
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 WidgetEnv s e
-> Getting InputStatus (WidgetEnv s e) InputStatus -> InputStatus
forall s a. s -> Getting a s a -> a
^. Getting InputStatus (WidgetEnv s e) InputStatus
forall s a. HasInputStatus s a => Lens' s a
Lens' (WidgetEnv s e) InputStatus
L.inputStatus
  keyMod :: KeyMod
keyMod = InputStatus
status InputStatus -> Getting KeyMod InputStatus KeyMod -> KeyMod
forall s a. s -> Getting a s a -> a
^. Getting KeyMod InputStatus KeyMod
forall s a. HasKeyMod s a => Lens' s a
Lens' InputStatus KeyMod
L.keyMod
  pressedKeys :: Map KeyCode KeyStatus
pressedKeys = (KeyStatus -> Bool)
-> Map KeyCode KeyStatus -> Map KeyCode KeyStatus
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (KeyStatus -> KeyStatus -> Bool
forall a. Eq a => a -> a -> Bool
== KeyStatus
KeyPressed) (InputStatus
status InputStatus
-> Getting
     (Map KeyCode KeyStatus) InputStatus (Map KeyCode KeyStatus)
-> Map KeyCode KeyStatus
forall s a. s -> Getting a s a -> a
^. Getting (Map KeyCode KeyStatus) InputStatus (Map KeyCode KeyStatus)
forall s a. HasKeys s a => Lens' s a
Lens' InputStatus (Map KeyCode KeyStatus)
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 KeyCode -> Set KeyCode -> Bool
forall a. Eq a => a -> Set a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (KeyStroke
ks KeyStroke
-> Getting (Set KeyCode) KeyStroke (Set KeyCode) -> Set KeyCode
forall s a. s -> Getting a s a -> a
^. Getting (Set KeyCode) KeyStroke (Set KeyCode)
forall s a. HasKsKeys s a => Lens' s a
Lens' KeyStroke (Set KeyCode)
ksKeys) Bool -> Bool -> Bool
|| KeyCode
code KeyCode -> [KeyCode] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KeyCode]
modKeys
      pressed :: Bool
pressed = Map KeyCode KeyStatus -> Set KeyCode
forall k a. Map k a -> Set k
M.keysSet Map KeyCode KeyStatus
pressedKeys Set KeyCode -> Set KeyCode -> Bool
forall a. Eq a => a -> a -> Bool
== KeyStroke
ks KeyStroke
-> Getting (Set KeyCode) KeyStroke (Set KeyCode) -> Set KeyCode
forall s a. s -> Getting a s a -> a
^. Getting (Set KeyCode) KeyStroke (Set KeyCode)
forall s a. HasKsKeys s a => Lens' s a
Lens' KeyStroke (Set KeyCode)
ksKeys
    KeyEntryText Text
txt -> (Bool
valid, Bool
True, Bool
True) where
      valid :: Bool
valid = Text
txt Text -> Set Text -> Bool
forall a. Eq a => a -> Set a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (KeyStroke
ks KeyStroke -> Getting (Set Text) KeyStroke (Set Text) -> Set Text
forall s a. s -> Getting a s a -> a
^. Getting (Set Text) KeyStroke (Set Text)
forall s a. HasKsKeysText s a => Lens' s a
Lens' KeyStroke (Set Text)
ksKeysText)

  ctrlPressed :: Bool
ctrlPressed = KeyMod -> Bool
isCtrlPressed KeyMod
keyMod
  cmdPressed :: Bool
cmdPressed = WidgetEnv s e -> Bool
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 KeyStroke -> Getting Bool KeyStroke Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool KeyStroke Bool
forall s a. HasKsC s a => Lens' s a
Lens' KeyStroke Bool
ksC) Bool -> Bool -> Bool
|| KeyStroke
ks KeyStroke -> Getting Bool KeyStroke Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool KeyStroke Bool
forall s a. HasKsC s a => Lens' s a
Lens' KeyStroke Bool
ksC Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== (Bool
ctrlPressed Bool -> Bool -> Bool
|| Bool
cmdPressed)
  validCtrl :: Bool
validCtrl = KeyStroke
ks KeyStroke -> Getting Bool KeyStroke Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool KeyStroke Bool
forall s a. HasKsCtrl s a => Lens' s a
Lens' KeyStroke Bool
ksCtrl Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
ctrlPressed Bool -> Bool -> Bool
|| Bool
ctrlPressed Bool -> Bool -> Bool
&& Bool
validC
  validCmd :: Bool
validCmd = KeyStroke
ks KeyStroke -> Getting Bool KeyStroke Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool KeyStroke Bool
forall s a. HasKsCmd s a => Lens' s a
Lens' KeyStroke Bool
ksCmd Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
cmdPressed Bool -> Bool -> Bool
|| Bool
cmdPressed Bool -> Bool -> Bool
&& Bool
validC
  validShift :: Bool
validShift = KeyStroke
ks KeyStroke -> Getting Bool KeyStroke Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool KeyStroke Bool
forall s a. HasKsShift s a => Lens' s a
Lens' KeyStroke Bool
ksShift Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== KeyMod -> Bool
isShiftPressed KeyMod
keyMod Bool -> Bool -> Bool
|| Bool
ignoreShift
  validAlt :: Bool
validAlt = KeyStroke
ks KeyStroke -> Getting Bool KeyStroke Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool KeyStroke Bool
forall s a. HasKsAlt s a => Lens' s a
Lens' KeyStroke Bool
ksAlt Bool -> Bool -> Bool
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 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
'-') Text
text
  ks :: KeyStroke
ks = (KeyStroke -> Text -> KeyStroke)
-> KeyStroke -> [Text] -> KeyStroke
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' KeyStroke -> Text -> KeyStroke
partToStroke KeyStroke
forall a. Default a => a
def [Text]
parts
    KeyStroke -> (KeyStroke -> KeyStroke) -> KeyStroke
forall a b. a -> (a -> b) -> b
& (Text -> Identity Text) -> KeyStroke -> Identity KeyStroke
forall s a. HasKsText s a => Lens' s a
Lens' KeyStroke Text
ksText ((Text -> Identity Text) -> KeyStroke -> Identity KeyStroke)
-> Text -> KeyStroke -> KeyStroke
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text
text

  errors :: [Text]
errors = KeyStroke
ks KeyStroke -> Getting [Text] KeyStroke [Text] -> [Text]
forall s a. s -> Getting a s a -> a
^. Getting [Text] KeyStroke [Text]
forall s a. HasKsErrors s a => Lens' s a
Lens' KeyStroke [Text]
ksErrors
  errorMsg :: Text
errorMsg = Text
"'" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
text Text -> 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
&& [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
errors = KeyStroke
ks
    | Bool
otherwise = (Text, [Text]) -> KeyStroke -> KeyStroke
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 KeyStroke -> (KeyStroke -> KeyStroke) -> KeyStroke
forall a b. a -> (a -> b) -> b
& (Bool -> Identity Bool) -> KeyStroke -> Identity KeyStroke
forall s a. HasKsAlt s a => Lens' s a
Lens' KeyStroke Bool
ksAlt ((Bool -> Identity Bool) -> KeyStroke -> Identity KeyStroke)
-> Bool -> KeyStroke -> KeyStroke
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True
partToStroke KeyStroke
ks Text
"Alt" = KeyStroke
ks KeyStroke -> (KeyStroke -> KeyStroke) -> KeyStroke
forall a b. a -> (a -> b) -> b
& (Bool -> Identity Bool) -> KeyStroke -> Identity KeyStroke
forall s a. HasKsAlt s a => Lens' s a
Lens' KeyStroke Bool
ksAlt ((Bool -> Identity Bool) -> KeyStroke -> Identity KeyStroke)
-> Bool -> KeyStroke -> KeyStroke
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True
partToStroke KeyStroke
ks Text
"C" = KeyStroke
ks KeyStroke -> (KeyStroke -> KeyStroke) -> KeyStroke
forall a b. a -> (a -> b) -> b
& (Bool -> Identity Bool) -> KeyStroke -> Identity KeyStroke
forall s a. HasKsC s a => Lens' s a
Lens' KeyStroke Bool
ksC ((Bool -> Identity Bool) -> KeyStroke -> Identity KeyStroke)
-> Bool -> KeyStroke -> KeyStroke
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True
partToStroke KeyStroke
ks Text
"Ctrl" = KeyStroke
ks KeyStroke -> (KeyStroke -> KeyStroke) -> KeyStroke
forall a b. a -> (a -> b) -> b
& (Bool -> Identity Bool) -> KeyStroke -> Identity KeyStroke
forall s a. HasKsCtrl s a => Lens' s a
Lens' KeyStroke Bool
ksCtrl ((Bool -> Identity Bool) -> KeyStroke -> Identity KeyStroke)
-> Bool -> KeyStroke -> KeyStroke
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True
partToStroke KeyStroke
ks Text
"Cmd" = KeyStroke
ks KeyStroke -> (KeyStroke -> KeyStroke) -> KeyStroke
forall a b. a -> (a -> b) -> b
& (Bool -> Identity Bool) -> KeyStroke -> Identity KeyStroke
forall s a. HasKsCmd s a => Lens' s a
Lens' KeyStroke Bool
ksCmd ((Bool -> Identity Bool) -> KeyStroke -> Identity KeyStroke)
-> Bool -> KeyStroke -> KeyStroke
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True
partToStroke KeyStroke
ks Text
"O" = KeyStroke
ks KeyStroke -> (KeyStroke -> KeyStroke) -> KeyStroke
forall a b. a -> (a -> b) -> b
& (Bool -> Identity Bool) -> KeyStroke -> Identity KeyStroke
forall s a. HasKsAlt s a => Lens' s a
Lens' KeyStroke Bool
ksAlt ((Bool -> Identity Bool) -> KeyStroke -> Identity KeyStroke)
-> Bool -> KeyStroke -> KeyStroke
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True
partToStroke KeyStroke
ks Text
"Option" = KeyStroke
ks KeyStroke -> (KeyStroke -> KeyStroke) -> KeyStroke
forall a b. a -> (a -> b) -> b
& (Bool -> Identity Bool) -> KeyStroke -> Identity KeyStroke
forall s a. HasKsAlt s a => Lens' s a
Lens' KeyStroke Bool
ksAlt ((Bool -> Identity Bool) -> KeyStroke -> Identity KeyStroke)
-> Bool -> KeyStroke -> KeyStroke
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True
partToStroke KeyStroke
ks Text
"S" = KeyStroke
ks KeyStroke -> (KeyStroke -> KeyStroke) -> KeyStroke
forall a b. a -> (a -> b) -> b
& (Bool -> Identity Bool) -> KeyStroke -> Identity KeyStroke
forall s a. HasKsShift s a => Lens' s a
Lens' KeyStroke Bool
ksShift ((Bool -> Identity Bool) -> KeyStroke -> Identity KeyStroke)
-> Bool -> KeyStroke -> KeyStroke
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True
partToStroke KeyStroke
ks Text
"Shift" = KeyStroke
ks KeyStroke -> (KeyStroke -> KeyStroke) -> KeyStroke
forall a b. a -> (a -> b) -> b
& (Bool -> Identity Bool) -> KeyStroke -> Identity KeyStroke
forall s a. HasKsShift s a => Lens' s a
Lens' KeyStroke Bool
ksShift ((Bool -> Identity Bool) -> KeyStroke -> Identity KeyStroke)
-> Bool -> KeyStroke -> KeyStroke
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True
-- Main keys
partToStroke KeyStroke
ks Text
"Backspace" = KeyStroke
ks KeyStroke -> (KeyStroke -> KeyStroke) -> KeyStroke
forall a b. a -> (a -> b) -> b
& (Set KeyCode -> Identity (Set KeyCode))
-> KeyStroke -> Identity KeyStroke
forall s a. HasKsKeys s a => Lens' s a
Lens' KeyStroke (Set KeyCode)
ksKeys ((Set KeyCode -> Identity (Set KeyCode))
 -> KeyStroke -> Identity KeyStroke)
-> (Set KeyCode -> Set KeyCode) -> KeyStroke -> KeyStroke
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ KeyCode -> Set KeyCode -> Set KeyCode
forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyBackspace
partToStroke KeyStroke
ks Text
"Caps" = KeyStroke
ks KeyStroke -> (KeyStroke -> KeyStroke) -> KeyStroke
forall a b. a -> (a -> b) -> b
& (Set KeyCode -> Identity (Set KeyCode))
-> KeyStroke -> Identity KeyStroke
forall s a. HasKsKeys s a => Lens' s a
Lens' KeyStroke (Set KeyCode)
ksKeys ((Set KeyCode -> Identity (Set KeyCode))
 -> KeyStroke -> Identity KeyStroke)
-> (Set KeyCode -> Set KeyCode) -> KeyStroke -> KeyStroke
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ KeyCode -> Set KeyCode -> Set KeyCode
forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyCapsLock
partToStroke KeyStroke
ks Text
"Delete" = KeyStroke
ks KeyStroke -> (KeyStroke -> KeyStroke) -> KeyStroke
forall a b. a -> (a -> b) -> b
& (Set KeyCode -> Identity (Set KeyCode))
-> KeyStroke -> Identity KeyStroke
forall s a. HasKsKeys s a => Lens' s a
Lens' KeyStroke (Set KeyCode)
ksKeys ((Set KeyCode -> Identity (Set KeyCode))
 -> KeyStroke -> Identity KeyStroke)
-> (Set KeyCode -> Set KeyCode) -> KeyStroke -> KeyStroke
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ KeyCode -> Set KeyCode -> Set KeyCode
forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyDelete
partToStroke KeyStroke
ks Text
"Enter" = KeyStroke
ks KeyStroke -> (KeyStroke -> KeyStroke) -> KeyStroke
forall a b. a -> (a -> b) -> b
& (Set KeyCode -> Identity (Set KeyCode))
-> KeyStroke -> Identity KeyStroke
forall s a. HasKsKeys s a => Lens' s a
Lens' KeyStroke (Set KeyCode)
ksKeys ((Set KeyCode -> Identity (Set KeyCode))
 -> KeyStroke -> Identity KeyStroke)
-> (Set KeyCode -> Set KeyCode) -> KeyStroke -> KeyStroke
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ KeyCode -> Set KeyCode -> Set KeyCode
forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyReturn
partToStroke KeyStroke
ks Text
"KpEnter" = KeyStroke
ks KeyStroke -> (KeyStroke -> KeyStroke) -> KeyStroke
forall a b. a -> (a -> b) -> b
& (Set KeyCode -> Identity (Set KeyCode))
-> KeyStroke -> Identity KeyStroke
forall s a. HasKsKeys s a => Lens' s a
Lens' KeyStroke (Set KeyCode)
ksKeys ((Set KeyCode -> Identity (Set KeyCode))
 -> KeyStroke -> Identity KeyStroke)
-> (Set KeyCode -> Set KeyCode) -> KeyStroke -> KeyStroke
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ KeyCode -> Set KeyCode -> Set KeyCode
forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyPadEnter
partToStroke KeyStroke
ks Text
"Esc" = KeyStroke
ks KeyStroke -> (KeyStroke -> KeyStroke) -> KeyStroke
forall a b. a -> (a -> b) -> b
& (Set KeyCode -> Identity (Set KeyCode))
-> KeyStroke -> Identity KeyStroke
forall s a. HasKsKeys s a => Lens' s a
Lens' KeyStroke (Set KeyCode)
ksKeys ((Set KeyCode -> Identity (Set KeyCode))
 -> KeyStroke -> Identity KeyStroke)
-> (Set KeyCode -> Set KeyCode) -> KeyStroke -> KeyStroke
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ KeyCode -> Set KeyCode -> Set KeyCode
forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyEscape
partToStroke KeyStroke
ks Text
"Return" = KeyStroke
ks KeyStroke -> (KeyStroke -> KeyStroke) -> KeyStroke
forall a b. a -> (a -> b) -> b
& (Set KeyCode -> Identity (Set KeyCode))
-> KeyStroke -> Identity KeyStroke
forall s a. HasKsKeys s a => Lens' s a
Lens' KeyStroke (Set KeyCode)
ksKeys ((Set KeyCode -> Identity (Set KeyCode))
 -> KeyStroke -> Identity KeyStroke)
-> (Set KeyCode -> Set KeyCode) -> KeyStroke -> KeyStroke
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ KeyCode -> Set KeyCode -> Set KeyCode
forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyReturn
partToStroke KeyStroke
ks Text
"Space" = KeyStroke
ks KeyStroke -> (KeyStroke -> KeyStroke) -> KeyStroke
forall a b. a -> (a -> b) -> b
& (Set KeyCode -> Identity (Set KeyCode))
-> KeyStroke -> Identity KeyStroke
forall s a. HasKsKeys s a => Lens' s a
Lens' KeyStroke (Set KeyCode)
ksKeys ((Set KeyCode -> Identity (Set KeyCode))
 -> KeyStroke -> Identity KeyStroke)
-> (Set KeyCode -> Set KeyCode) -> KeyStroke -> KeyStroke
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ KeyCode -> Set KeyCode -> Set KeyCode
forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keySpace
partToStroke KeyStroke
ks Text
"Tab" = KeyStroke
ks KeyStroke -> (KeyStroke -> KeyStroke) -> KeyStroke
forall a b. a -> (a -> b) -> b
& (Set KeyCode -> Identity (Set KeyCode))
-> KeyStroke -> Identity KeyStroke
forall s a. HasKsKeys s a => Lens' s a
Lens' KeyStroke (Set KeyCode)
ksKeys ((Set KeyCode -> Identity (Set KeyCode))
 -> KeyStroke -> Identity KeyStroke)
-> (Set KeyCode -> Set KeyCode) -> KeyStroke -> KeyStroke
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ KeyCode -> Set KeyCode -> Set KeyCode
forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyTab
-- Arrows
partToStroke KeyStroke
ks Text
"Up" = KeyStroke
ks KeyStroke -> (KeyStroke -> KeyStroke) -> KeyStroke
forall a b. a -> (a -> b) -> b
& (Set KeyCode -> Identity (Set KeyCode))
-> KeyStroke -> Identity KeyStroke
forall s a. HasKsKeys s a => Lens' s a
Lens' KeyStroke (Set KeyCode)
ksKeys ((Set KeyCode -> Identity (Set KeyCode))
 -> KeyStroke -> Identity KeyStroke)
-> (Set KeyCode -> Set KeyCode) -> KeyStroke -> KeyStroke
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ KeyCode -> Set KeyCode -> Set KeyCode
forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyUp
partToStroke KeyStroke
ks Text
"Down" = KeyStroke
ks KeyStroke -> (KeyStroke -> KeyStroke) -> KeyStroke
forall a b. a -> (a -> b) -> b
& (Set KeyCode -> Identity (Set KeyCode))
-> KeyStroke -> Identity KeyStroke
forall s a. HasKsKeys s a => Lens' s a
Lens' KeyStroke (Set KeyCode)
ksKeys ((Set KeyCode -> Identity (Set KeyCode))
 -> KeyStroke -> Identity KeyStroke)
-> (Set KeyCode -> Set KeyCode) -> KeyStroke -> KeyStroke
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ KeyCode -> Set KeyCode -> Set KeyCode
forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyDown
partToStroke KeyStroke
ks Text
"Left" = KeyStroke
ks KeyStroke -> (KeyStroke -> KeyStroke) -> KeyStroke
forall a b. a -> (a -> b) -> b
& (Set KeyCode -> Identity (Set KeyCode))
-> KeyStroke -> Identity KeyStroke
forall s a. HasKsKeys s a => Lens' s a
Lens' KeyStroke (Set KeyCode)
ksKeys ((Set KeyCode -> Identity (Set KeyCode))
 -> KeyStroke -> Identity KeyStroke)
-> (Set KeyCode -> Set KeyCode) -> KeyStroke -> KeyStroke
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ KeyCode -> Set KeyCode -> Set KeyCode
forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyLeft
partToStroke KeyStroke
ks Text
"Right" = KeyStroke
ks KeyStroke -> (KeyStroke -> KeyStroke) -> KeyStroke
forall a b. a -> (a -> b) -> b
& (Set KeyCode -> Identity (Set KeyCode))
-> KeyStroke -> Identity KeyStroke
forall s a. HasKsKeys s a => Lens' s a
Lens' KeyStroke (Set KeyCode)
ksKeys ((Set KeyCode -> Identity (Set KeyCode))
 -> KeyStroke -> Identity KeyStroke)
-> (Set KeyCode -> Set KeyCode) -> KeyStroke -> KeyStroke
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ KeyCode -> Set KeyCode -> Set KeyCode
forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyRight
-- Function keys
partToStroke KeyStroke
ks Text
"F1" = KeyStroke
ks KeyStroke -> (KeyStroke -> KeyStroke) -> KeyStroke
forall a b. a -> (a -> b) -> b
& (Set KeyCode -> Identity (Set KeyCode))
-> KeyStroke -> Identity KeyStroke
forall s a. HasKsKeys s a => Lens' s a
Lens' KeyStroke (Set KeyCode)
ksKeys ((Set KeyCode -> Identity (Set KeyCode))
 -> KeyStroke -> Identity KeyStroke)
-> (Set KeyCode -> Set KeyCode) -> KeyStroke -> KeyStroke
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ KeyCode -> Set KeyCode -> Set KeyCode
forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyF1
partToStroke KeyStroke
ks Text
"F2" = KeyStroke
ks KeyStroke -> (KeyStroke -> KeyStroke) -> KeyStroke
forall a b. a -> (a -> b) -> b
& (Set KeyCode -> Identity (Set KeyCode))
-> KeyStroke -> Identity KeyStroke
forall s a. HasKsKeys s a => Lens' s a
Lens' KeyStroke (Set KeyCode)
ksKeys ((Set KeyCode -> Identity (Set KeyCode))
 -> KeyStroke -> Identity KeyStroke)
-> (Set KeyCode -> Set KeyCode) -> KeyStroke -> KeyStroke
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ KeyCode -> Set KeyCode -> Set KeyCode
forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyF2
partToStroke KeyStroke
ks Text
"F3" = KeyStroke
ks KeyStroke -> (KeyStroke -> KeyStroke) -> KeyStroke
forall a b. a -> (a -> b) -> b
& (Set KeyCode -> Identity (Set KeyCode))
-> KeyStroke -> Identity KeyStroke
forall s a. HasKsKeys s a => Lens' s a
Lens' KeyStroke (Set KeyCode)
ksKeys ((Set KeyCode -> Identity (Set KeyCode))
 -> KeyStroke -> Identity KeyStroke)
-> (Set KeyCode -> Set KeyCode) -> KeyStroke -> KeyStroke
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ KeyCode -> Set KeyCode -> Set KeyCode
forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyF3
partToStroke KeyStroke
ks Text
"F4" = KeyStroke
ks KeyStroke -> (KeyStroke -> KeyStroke) -> KeyStroke
forall a b. a -> (a -> b) -> b
& (Set KeyCode -> Identity (Set KeyCode))
-> KeyStroke -> Identity KeyStroke
forall s a. HasKsKeys s a => Lens' s a
Lens' KeyStroke (Set KeyCode)
ksKeys ((Set KeyCode -> Identity (Set KeyCode))
 -> KeyStroke -> Identity KeyStroke)
-> (Set KeyCode -> Set KeyCode) -> KeyStroke -> KeyStroke
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ KeyCode -> Set KeyCode -> Set KeyCode
forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyF4
partToStroke KeyStroke
ks Text
"F5" = KeyStroke
ks KeyStroke -> (KeyStroke -> KeyStroke) -> KeyStroke
forall a b. a -> (a -> b) -> b
& (Set KeyCode -> Identity (Set KeyCode))
-> KeyStroke -> Identity KeyStroke
forall s a. HasKsKeys s a => Lens' s a
Lens' KeyStroke (Set KeyCode)
ksKeys ((Set KeyCode -> Identity (Set KeyCode))
 -> KeyStroke -> Identity KeyStroke)
-> (Set KeyCode -> Set KeyCode) -> KeyStroke -> KeyStroke
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ KeyCode -> Set KeyCode -> Set KeyCode
forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyF5
partToStroke KeyStroke
ks Text
"F6" = KeyStroke
ks KeyStroke -> (KeyStroke -> KeyStroke) -> KeyStroke
forall a b. a -> (a -> b) -> b
& (Set KeyCode -> Identity (Set KeyCode))
-> KeyStroke -> Identity KeyStroke
forall s a. HasKsKeys s a => Lens' s a
Lens' KeyStroke (Set KeyCode)
ksKeys ((Set KeyCode -> Identity (Set KeyCode))
 -> KeyStroke -> Identity KeyStroke)
-> (Set KeyCode -> Set KeyCode) -> KeyStroke -> KeyStroke
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ KeyCode -> Set KeyCode -> Set KeyCode
forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyF6
partToStroke KeyStroke
ks Text
"F7" = KeyStroke
ks KeyStroke -> (KeyStroke -> KeyStroke) -> KeyStroke
forall a b. a -> (a -> b) -> b
& (Set KeyCode -> Identity (Set KeyCode))
-> KeyStroke -> Identity KeyStroke
forall s a. HasKsKeys s a => Lens' s a
Lens' KeyStroke (Set KeyCode)
ksKeys ((Set KeyCode -> Identity (Set KeyCode))
 -> KeyStroke -> Identity KeyStroke)
-> (Set KeyCode -> Set KeyCode) -> KeyStroke -> KeyStroke
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ KeyCode -> Set KeyCode -> Set KeyCode
forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyF7
partToStroke KeyStroke
ks Text
"F8" = KeyStroke
ks KeyStroke -> (KeyStroke -> KeyStroke) -> KeyStroke
forall a b. a -> (a -> b) -> b
& (Set KeyCode -> Identity (Set KeyCode))
-> KeyStroke -> Identity KeyStroke
forall s a. HasKsKeys s a => Lens' s a
Lens' KeyStroke (Set KeyCode)
ksKeys ((Set KeyCode -> Identity (Set KeyCode))
 -> KeyStroke -> Identity KeyStroke)
-> (Set KeyCode -> Set KeyCode) -> KeyStroke -> KeyStroke
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ KeyCode -> Set KeyCode -> Set KeyCode
forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyF8
partToStroke KeyStroke
ks Text
"F9" = KeyStroke
ks KeyStroke -> (KeyStroke -> KeyStroke) -> KeyStroke
forall a b. a -> (a -> b) -> b
& (Set KeyCode -> Identity (Set KeyCode))
-> KeyStroke -> Identity KeyStroke
forall s a. HasKsKeys s a => Lens' s a
Lens' KeyStroke (Set KeyCode)
ksKeys ((Set KeyCode -> Identity (Set KeyCode))
 -> KeyStroke -> Identity KeyStroke)
-> (Set KeyCode -> Set KeyCode) -> KeyStroke -> KeyStroke
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ KeyCode -> Set KeyCode -> Set KeyCode
forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyF9
partToStroke KeyStroke
ks Text
"F10" = KeyStroke
ks KeyStroke -> (KeyStroke -> KeyStroke) -> KeyStroke
forall a b. a -> (a -> b) -> b
& (Set KeyCode -> Identity (Set KeyCode))
-> KeyStroke -> Identity KeyStroke
forall s a. HasKsKeys s a => Lens' s a
Lens' KeyStroke (Set KeyCode)
ksKeys ((Set KeyCode -> Identity (Set KeyCode))
 -> KeyStroke -> Identity KeyStroke)
-> (Set KeyCode -> Set KeyCode) -> KeyStroke -> KeyStroke
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ KeyCode -> Set KeyCode -> Set KeyCode
forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyF10
partToStroke KeyStroke
ks Text
"F11" = KeyStroke
ks KeyStroke -> (KeyStroke -> KeyStroke) -> KeyStroke
forall a b. a -> (a -> b) -> b
& (Set KeyCode -> Identity (Set KeyCode))
-> KeyStroke -> Identity KeyStroke
forall s a. HasKsKeys s a => Lens' s a
Lens' KeyStroke (Set KeyCode)
ksKeys ((Set KeyCode -> Identity (Set KeyCode))
 -> KeyStroke -> Identity KeyStroke)
-> (Set KeyCode -> Set KeyCode) -> KeyStroke -> KeyStroke
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ KeyCode -> Set KeyCode -> Set KeyCode
forall a. Ord a => a -> Set a -> Set a
Set.insert KeyCode
keyF11
partToStroke KeyStroke
ks Text
"F12" = KeyStroke
ks KeyStroke -> (KeyStroke -> KeyStroke) -> KeyStroke
forall a b. a -> (a -> b) -> b
& (Set KeyCode -> Identity (Set KeyCode))
-> KeyStroke -> Identity KeyStroke
forall s a. HasKsKeys s a => Lens' s a
Lens' KeyStroke (Set KeyCode)
ksKeys ((Set KeyCode -> Identity (Set KeyCode))
 -> KeyStroke -> Identity KeyStroke)
-> (Set KeyCode -> Set KeyCode) -> KeyStroke -> KeyStroke
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ KeyCode -> Set KeyCode -> Set KeyCode
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
      KeyStroke -> (KeyStroke -> KeyStroke) -> KeyStroke
forall a b. a -> (a -> b) -> b
& (Set KeyCode -> Identity (Set KeyCode))
-> KeyStroke -> Identity KeyStroke
forall s a. HasKsKeys s a => Lens' s a
Lens' KeyStroke (Set KeyCode)
ksKeys ((Set KeyCode -> Identity (Set KeyCode))
 -> KeyStroke -> Identity KeyStroke)
-> (Set KeyCode -> Set KeyCode) -> KeyStroke -> KeyStroke
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ KeyCode -> Set KeyCode -> Set KeyCode
forall a. Ord a => a -> Set a -> Set a
Set.insert (Int -> KeyCode
KeyCode (Char -> Int
ord Char
txtHead))
      KeyStroke -> (KeyStroke -> KeyStroke) -> KeyStroke
forall a b. a -> (a -> b) -> b
& (Set Text -> Identity (Set Text))
-> KeyStroke -> Identity KeyStroke
forall s a. HasKsKeysText s a => Lens' s a
Lens' KeyStroke (Set Text)
ksKeysText ((Set Text -> Identity (Set Text))
 -> KeyStroke -> Identity KeyStroke)
-> (Set Text -> Set Text) -> KeyStroke -> KeyStroke
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Text -> Set Text -> Set Text
forall a. Ord a => a -> Set a -> Set a
Set.insert Text
txt
  | Bool
otherwise = KeyStroke
ks
      KeyStroke -> (KeyStroke -> KeyStroke) -> KeyStroke
forall a b. a -> (a -> b) -> b
& ([Text] -> Identity [Text]) -> KeyStroke -> Identity KeyStroke
forall s a. HasKsErrors s a => Lens' s a
Lens' KeyStroke [Text]
ksErrors (([Text] -> Identity [Text]) -> KeyStroke -> Identity KeyStroke)
-> ([Text] -> [Text]) -> KeyStroke -> KeyStroke
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ ([Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text
txt])
  where
    txtHead :: Char
txtHead = HasCallStack => Text -> Int -> Char
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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1
  txtHead :: Char
txtHead = HasCallStack => Text -> Int -> Char
Text -> Int -> Char
T.index Text
txt Int
0

removeMods :: InputStatus -> InputStatus
removeMods :: InputStatus -> InputStatus
removeMods InputStatus
status = InputStatus
status
  InputStatus -> (InputStatus -> InputStatus) -> InputStatus
forall a b. a -> (a -> b) -> b
& (Map KeyCode KeyStatus -> Identity (Map KeyCode KeyStatus))
-> InputStatus -> Identity InputStatus
forall s a. HasKeys s a => Lens' s a
Lens' InputStatus (Map KeyCode KeyStatus)
L.keys ((Map KeyCode KeyStatus -> Identity (Map KeyCode KeyStatus))
 -> InputStatus -> Identity InputStatus)
-> (Map KeyCode KeyStatus -> Map KeyCode KeyStatus)
-> InputStatus
-> InputStatus
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (KeyCode -> KeyStatus -> Bool)
-> Map KeyCode KeyStatus -> Map KeyCode KeyStatus
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (\KeyCode
k KeyStatus
v -> KeyCode
k KeyCode -> [KeyCode] -> Bool
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
  ]