{-|
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. 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
- Lowercase letters (uppercase keys are reserved for mod and action keys)
- Numbers

These can be combined, for example:

- Copy: "Ctrl-c" or "C-c"
- App config: "Ctrl-Shift-p" or "C-S-p"
-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}

module Monomer.Widgets.Containers.Keystroke (
  -- * Configuration
  KeystrokeCfg,
  -- * Constructors
  keystroke,
  keystroke_
) where

import Control.Applicative ((<|>))
import Control.Lens ((&), (^.), (.~), (%~), at)
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.Maybe
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 :: Maybe Bool -> KeystrokeCfg
KeystrokeCfg {
    _kscIgnoreChildren :: Maybe Bool
_kscIgnoreChildren = Maybe Bool
forall a. Maybe a
Nothing
  }

instance Semigroup KeystrokeCfg where
  <> :: KeystrokeCfg -> KeystrokeCfg -> KeystrokeCfg
(<>) KeystrokeCfg
t1 KeystrokeCfg
t2 = KeystrokeCfg :: Maybe Bool -> KeystrokeCfg
KeystrokeCfg {
    _kscIgnoreChildren :: Maybe Bool
_kscIgnoreChildren = KeystrokeCfg -> Maybe Bool
_kscIgnoreChildren KeystrokeCfg
t2 Maybe Bool -> Maybe Bool -> Maybe Bool
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 :: Maybe Bool
_kscIgnoreChildren = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
ignore
  }

data KeyStroke = KeyStroke {
  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
} deriving (KeyStroke -> KeyStroke -> Bool
(KeyStroke -> KeyStroke -> Bool)
-> (KeyStroke -> KeyStroke -> Bool) -> Eq KeyStroke
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
(Int -> KeyStroke -> ShowS)
-> (KeyStroke -> String)
-> ([KeyStroke] -> ShowS)
-> Show KeyStroke
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 :: Bool -> Bool -> Bool -> Bool -> Bool -> Set KeyCode -> KeyStroke
KeyStroke {
    _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
  }

makeLensesWith abbreviatedFields ''KeyStroke

-- | Creates a keystroke container with a single node as child.
keystroke :: WidgetEvent e => [(Text, e)] -> WidgetNode s e -> WidgetNode s e
keystroke :: [(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)]
  -> [KeystrokeCfg]
  -> WidgetNode s e
  -> WidgetNode s e
keystroke_ :: [(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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text -> KeyStroke) -> (Text, e) -> (KeyStroke, e)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> KeyStroke
textToStroke) [(Text, e)]
bindings
  widget :: Widget s e
widget = [(KeyStroke, e)] -> KeystrokeCfg -> Widget s e
forall e s.
WidgetEvent e =>
[(KeyStroke, e)] -> KeystrokeCfg -> Widget s e
makeKeystroke [(KeyStroke, e)]
newBindings KeystrokeCfg
config

makeNode :: Widget s e -> WidgetNode s e -> WidgetNode s e
makeNode :: 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
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
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
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 -> Widget s e
makeKeystroke :: [(KeyStroke, e)] -> KeystrokeCfg -> Widget s e
makeKeystroke [(KeyStroke, e)]
bindings KeystrokeCfg
config = Widget s e
forall s. Widget s e
widget where
  widget :: Widget s e
widget = () -> Container s e () -> Widget s e
forall a s e. WidgetModel a => a -> Container s e a -> Widget s e
createContainer () Container s e ()
forall a. Default a => a
def {
    containerHandleEvent :: ContainerEventHandler s e
containerHandleEvent = ContainerEventHandler s e
forall s e s p.
WidgetEnv s e
-> WidgetNode s e -> p -> SystemEvent -> Maybe (WidgetResult s e)
handleEvent
  }

  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 -> WidgetResult s e -> Maybe (WidgetResult s e)
forall a. a -> Maybe a
Just WidgetResult s e
result 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
      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
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
      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) -> Bool) -> [(KeyStroke, e)] -> [(KeyStroke, e)]
forall a. (a -> Bool) -> [a] -> [a]
filter (WidgetEnv s e -> KeyCode -> KeyStroke -> Bool
forall s e. WidgetEnv s e -> KeyCode -> KeyStroke -> Bool
keyStrokeActive WidgetEnv s e
newWenv KeyCode
code (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
      reqs :: [WidgetRequest s e]
reqs
        | Bool
ignoreChildren Bool -> Bool -> Bool
&& Bool -> Bool
not ([e] -> 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
node [WidgetRequest s e]
forall s e. [WidgetRequest s e]
reqs [e]
evts
    SystemEvent
_ -> Maybe (WidgetResult s e)
forall a. Maybe a
Nothing

keyStrokeActive :: WidgetEnv s e -> KeyCode -> KeyStroke -> Bool
keyStrokeActive :: WidgetEnv s e -> KeyCode -> KeyStroke -> Bool
keyStrokeActive WidgetEnv s e
wenv KeyCode
code 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
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
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
L.keys)

  currValid :: Bool
currValid = KeyCode
code KeyCode -> Set KeyCode -> 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
ksKeys) Bool -> Bool -> Bool
|| KeyCode
code KeyCode -> [KeyCode] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [KeyCode]
modKeys
  allPressed :: Bool
allPressed = 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
ksKeys

  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
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
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
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
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
ksShift Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== KeyMod -> Bool
isShiftPressed KeyMod
keyMod
  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
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
ks 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 (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

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
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
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
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
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
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
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
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
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
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
"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
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
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
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
"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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
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
txt
  | Bool
isValid = 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
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))
  | Bool
otherwise = KeyStroke
ks
  where
    isValid :: Bool
isValid = Text -> Int
T.length Text
txt Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& Char -> Bool
isAscii Char
txtHead Bool -> Bool -> Bool
&& Char -> Bool
isPrint Char
txtHead
    txtHead :: Char
txtHead = 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
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
  ]