Keystroke.hs

{-|
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 {
  _kscIgnoreChildren :: Maybe Bool
}

instance Default KeystrokeCfg where
  def = KeystrokeCfg {
    _kscIgnoreChildren = Nothing
  }

instance Semigroup KeystrokeCfg where
  (<>) t1 t2 = KeystrokeCfg {
    _kscIgnoreChildren = _kscIgnoreChildren t2 <|> _kscIgnoreChildren t1
  }

instance Monoid KeystrokeCfg where
  mempty = def

instance CmbIgnoreChildrenEvts KeystrokeCfg where
  ignoreChildrenEvts_ ignore = def {
    _kscIgnoreChildren = Just ignore
  }

data KeyStroke = KeyStroke {
  _kstKsText :: Text,
  _kstKsC :: Bool,
  _kstKsCtrl :: Bool,
  _kstKsCmd :: Bool,
  _kstKsAlt :: Bool,
  _kstKsShift :: Bool,
  _kstKsKeys :: Set KeyCode,
  _kstKsKeysText :: Set Text,
  _kstKsErrors :: [Text]
} deriving (Eq, Show)

instance Default KeyStroke where
  def = KeyStroke {
    _kstKsText = "",
    _kstKsC = False,
    _kstKsCtrl = False,
    _kstKsCmd = False,
    _kstKsAlt = False,
    _kstKsShift = False,
    _kstKsKeys = Set.empty,
    _kstKsKeysText = Set.empty,
    _kstKsErrors = []
  }

newtype KeyStrokeState e = KeyStrokeState {
  _kssLatest :: [(KeyStroke, e)]
} deriving (Eq)

instance Show (KeyStrokeState e) where
  show (KeyStrokeState keys) = show (map fst keys)

data KeyEntry
  = KeyEntryCode KeyCode
  | KeyEntryText Text
  deriving (Eq, 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 bindings managed = keystroke_ bindings def 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_ bindings configs managed = makeNode widget managed where
  config = mconcat configs
  newBindings = fmap (first textToStroke) bindings
  state = KeyStrokeState []
  widget = makeKeystroke newBindings config state

makeNode :: Widget s e -> WidgetNode s e -> WidgetNode s e
makeNode widget managedWidget = defaultWidgetNode "keystroke" widget
  & L.info . L.focusable .~ False
  & L.children .~ Seq.singleton managedWidget

makeKeystroke
  :: WidgetEvent e
  => [(KeyStroke, e)]
  -> KeystrokeCfg
  -> KeyStrokeState e
  -> Widget s e
makeKeystroke bindings config state = widget where
  widget = createContainer state def {
    containerMerge = merge,
    containerHandleEvent = handleEvent
  }

  merge wenv node oldNode oldState = resultNode newNode where
    newNode = node
      & L.widget .~ makeKeystroke bindings config oldState

  handleEvent wenv node target evt = case evt of
    KeyAction mod code KeyPressed -> result where
      result = handleKeystroke (KeyEntryCode code)
    TextInput text
      | ignoreChildren && ignorePrevious text -> Just result where
        newState = KeyStrokeState []
        newNode = node
          & L.widget .~ makeKeystroke bindings config newState
        result = resultReqs newNode [IgnoreChildrenEvents]
    TextInput text
      | not (previousMatch text) -> result where
        result = handleKeystroke (KeyEntryText text)
    _ -> Nothing
    where
      ignoreChildren = Just True == _kscIgnoreChildren config
      previousMatch t = t `elem` _kssLatest state ^.. folded . _1 . ksText
      ignorePrevious t = isTextValidCode t && previousMatch t

      handleKeystroke entry = Just result where
        newWenv = wenv & L.inputStatus %~ removeMods
        matches = filter (keyStrokeActive newWenv entry . fst) bindings
        newState = KeyStrokeState matches
        newNode = node
          & L.widget .~ makeKeystroke bindings config newState
        evts = snd <$> matches
        reqs
          | ignoreChildren && not (null evts) = [IgnoreChildrenEvents]
          | otherwise = []
        result = resultReqsEvts newNode reqs evts

keyStrokeActive :: WidgetEnv s e -> KeyEntry -> KeyStroke -> Bool
keyStrokeActive wenv entry ks = currValid && allPressed && validMods where
  status = wenv ^. L.inputStatus
  keyMod = status ^. L.keyMod
  pressedKeys = M.filter (== KeyPressed) (status ^. L.keys)

  (currValid, allPressed, ignoreShift) = case entry of
    KeyEntryCode code -> (valid, pressed, False) where
      valid = code `elem` (ks ^. ksKeys) || code `elem` modKeys
      pressed = M.keysSet pressedKeys == ks ^. ksKeys
    KeyEntryText txt -> (valid, True, True) where
      valid = txt `elem` (ks ^. ksKeysText)

  ctrlPressed = isCtrlPressed keyMod
  cmdPressed = isMacOS wenv && isGUIPressed keyMod

  validC = not (ks ^. ksC) || ks ^. ksC == (ctrlPressed || cmdPressed)
  validCtrl = ks ^. ksCtrl == ctrlPressed || ctrlPressed && validC
  validCmd = ks ^. ksCmd == cmdPressed || cmdPressed && validC
  validShift = ks ^. ksShift == isShiftPressed keyMod || ignoreShift
  validAlt = ks ^. ksAlt == isAltPressed keyMod

  validMods = (validC && validCtrl && validCmd) && validShift && validAlt

textToStroke :: Text -> KeyStroke
textToStroke text = result where
  parts = T.split (=='-') text
  ks = foldl' partToStroke def parts
    & ksText .~ text

  errors = ks ^. ksErrors
  errorMsg = "'" <> text <> "' is not valid. Invalid parts: "

  result
    | not (T.null text) && null errors = ks
    | otherwise = traceShow (errorMsg, errors) ks

partToStroke :: KeyStroke -> Text -> KeyStroke
partToStroke ks "A" = ks & ksAlt .~ True
partToStroke ks "Alt" = ks & ksAlt .~ True
partToStroke ks "C" = ks & ksC .~ True
partToStroke ks "Ctrl" = ks & ksCtrl .~ True
partToStroke ks "Cmd" = ks & ksCmd .~ True
partToStroke ks "O" = ks & ksAlt .~ True
partToStroke ks "Option" = ks & ksAlt .~ True
partToStroke ks "S" = ks & ksShift .~ True
partToStroke ks "Shift" = ks & ksShift .~ True
-- Main keys
partToStroke ks "Backspace" = ks & ksKeys %~ Set.insert keyBackspace
partToStroke ks "Caps" = ks & ksKeys %~ Set.insert keyCapsLock
partToStroke ks "Delete" = ks & ksKeys %~ Set.insert keyDelete
partToStroke ks "Enter" = ks & ksKeys %~ Set.insert keyReturn
partToStroke ks "KpEnter" = ks & ksKeys %~ Set.insert keyPadEnter
partToStroke ks "Esc" = ks & ksKeys %~ Set.insert keyEscape
partToStroke ks "Return" = ks & ksKeys %~ Set.insert keyReturn
partToStroke ks "Space" = ks & ksKeys %~ Set.insert keySpace
partToStroke ks "Tab" = ks & ksKeys %~ Set.insert keyTab
-- Arrows
partToStroke ks "Up" = ks & ksKeys %~ Set.insert keyUp
partToStroke ks "Down" = ks & ksKeys %~ Set.insert keyDown
partToStroke ks "Left" = ks & ksKeys %~ Set.insert keyLeft
partToStroke ks "Right" = ks & ksKeys %~ Set.insert keyRight
-- Function keys
partToStroke ks "F1" = ks & ksKeys %~ Set.insert keyF1
partToStroke ks "F2" = ks & ksKeys %~ Set.insert keyF2
partToStroke ks "F3" = ks & ksKeys %~ Set.insert keyF3
partToStroke ks "F4" = ks & ksKeys %~ Set.insert keyF4
partToStroke ks "F5" = ks & ksKeys %~ Set.insert keyF5
partToStroke ks "F6" = ks & ksKeys %~ Set.insert keyF6
partToStroke ks "F7" = ks & ksKeys %~ Set.insert keyF7
partToStroke ks "F8" = ks & ksKeys %~ Set.insert keyF8
partToStroke ks "F9" = ks & ksKeys %~ Set.insert keyF9
partToStroke ks "F10" = ks & ksKeys %~ Set.insert keyF10
partToStroke ks "F11" = ks & ksKeys %~ Set.insert keyF11
partToStroke ks "F12" = ks & ksKeys %~ Set.insert keyF12
-- Other keys (numbers, letters, points, etc)
partToStroke ks "Dash" = partToStroke ks "-"
partToStroke ks txt
  | isTextValidCode txt = ks
      & ksKeys %~ Set.insert (KeyCode (ord txtHead))
      & ksKeysText %~ Set.insert txt
  | otherwise = ks
      & ksErrors %~ (++ [txt])
  where
    txtHead = T.index txt 0

isTextValidCode :: Text -> Bool
isTextValidCode txt = validLen && isAscii txtHead && isPrint txtHead where
  validLen = T.length txt == 1
  txtHead = T.index txt 0

removeMods :: InputStatus -> InputStatus
removeMods status = status
  & L.keys %~ M.filterWithKey (\k v -> k `notElem` modKeys)

modKeys :: [KeyCode]
modKeys = [
    keyLAlt, keyRAlt, keyLCtrl, keyRCtrl, keyLGUI, keyRGUI, keyLShift, keyRShift
  ]