{-# Language RankNTypes, OverloadedStrings #-}
{-|
Module      : Client.EventLoop.Actions
Description : Programmable keyboard actions
Copyright   : (c) Eric Mertens, 2016
License     : ISC
Maintainer  : emertens@gmail.com

-}

module Client.EventLoop.Actions
  ( Action(..)
  , KeyMap
  , keyToAction
  , initialKeyMap
  , addKeyBinding
  , removeKeyBinding
  , keyMapEntries

  -- * Keys as text
  , parseKey
  , prettyModifierKey
  , actionName
  ) where

import           Graphics.Vty.Input.Events
import           Config.Schema.Spec
import           Control.Applicative
import           Control.Lens
import           Data.Char (showLitChar)
import           Data.Functor.Compose
import           Data.List
import           Data.Map (Map)
import qualified Data.Map as Map
import           Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as HashMap
import           Data.Text (Text)
import qualified Data.Text as Text
import           Text.Read

-- | Actions that can be invoked using the keyboard.
data Action

  = ActBackspace
  | ActDelete
  | ActLeft
  | ActRight
  | ActHome
  | ActEnd
  | ActOlderLine
  | ActNewerLine
  | ActScrollUp
  | ActScrollDown
  | ActScrollUpSmall
  | ActScrollDownSmall
  | ActBackWord
  | ActForwardWord

  | ActYank
  | ActKillHome
  | ActKillEnd
  | ActKillWordBack
  | ActKillWordForward
  | ActToggle

  | ActBold
  | ActColor
  | ActItalic
  | ActUnderline
  | ActStrikethrough
  | ActReverseVideo
  | ActMonospace
  | ActClearFormat
  | ActInsertEnter
  | ActDigraph

  | ActRetreatFocus
  | ActAdvanceFocus
  | ActAdvanceNetwork
  | ActJumpToActivity
  | ActJumpPrevious
  | ActJump Char

  | ActTabComplete
  | ActTabCompleteBack

  | ActEnter
  | ActReset
  | ActRefresh
  | ActCommand Text
  | ActInsert Char
  | ActIgnored
  deriving (Action -> Action -> Bool
(Action -> Action -> Bool)
-> (Action -> Action -> Bool) -> Eq Action
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Action -> Action -> Bool
$c/= :: Action -> Action -> Bool
== :: Action -> Action -> Bool
$c== :: Action -> Action -> Bool
Eq, Eq Action
Eq Action
-> (Action -> Action -> Ordering)
-> (Action -> Action -> Bool)
-> (Action -> Action -> Bool)
-> (Action -> Action -> Bool)
-> (Action -> Action -> Bool)
-> (Action -> Action -> Action)
-> (Action -> Action -> Action)
-> Ord Action
Action -> Action -> Bool
Action -> Action -> Ordering
Action -> Action -> Action
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Action -> Action -> Action
$cmin :: Action -> Action -> Action
max :: Action -> Action -> Action
$cmax :: Action -> Action -> Action
>= :: Action -> Action -> Bool
$c>= :: Action -> Action -> Bool
> :: Action -> Action -> Bool
$c> :: Action -> Action -> Bool
<= :: Action -> Action -> Bool
$c<= :: Action -> Action -> Bool
< :: Action -> Action -> Bool
$c< :: Action -> Action -> Bool
compare :: Action -> Action -> Ordering
$ccompare :: Action -> Action -> Ordering
$cp1Ord :: Eq Action
Ord, ReadPrec [Action]
ReadPrec Action
Int -> ReadS Action
ReadS [Action]
(Int -> ReadS Action)
-> ReadS [Action]
-> ReadPrec Action
-> ReadPrec [Action]
-> Read Action
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Action]
$creadListPrec :: ReadPrec [Action]
readPrec :: ReadPrec Action
$creadPrec :: ReadPrec Action
readList :: ReadS [Action]
$creadList :: ReadS [Action]
readsPrec :: Int -> ReadS Action
$creadsPrec :: Int -> ReadS Action
Read, Int -> Action -> ShowS
[Action] -> ShowS
Action -> String
(Int -> Action -> ShowS)
-> (Action -> String) -> ([Action] -> ShowS) -> Show Action
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Action] -> ShowS
$cshowList :: [Action] -> ShowS
show :: Action -> String
$cshow :: Action -> String
showsPrec :: Int -> Action -> ShowS
$cshowsPrec :: Int -> Action -> ShowS
Show)

-- | Lookup table for keyboard events to actions. Use with
-- keyToAction.
newtype KeyMap = KeyMap (Map [Modifier] (Map Key Action))
  deriving (Int -> KeyMap -> ShowS
[KeyMap] -> ShowS
KeyMap -> String
(Int -> KeyMap -> ShowS)
-> (KeyMap -> String) -> ([KeyMap] -> ShowS) -> Show KeyMap
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [KeyMap] -> ShowS
$cshowList :: [KeyMap] -> ShowS
show :: KeyMap -> String
$cshow :: KeyMap -> String
showsPrec :: Int -> KeyMap -> ShowS
$cshowsPrec :: Int -> KeyMap -> ShowS
Show)

keyMapEntries :: KeyMap -> [([Modifier], Key, Action)]
keyMapEntries :: KeyMap -> [([Modifier], Key, Action)]
keyMapEntries (KeyMap Map [Modifier] (Map Key Action)
m) =
  [ ([Modifier]
mods, Key
k, Action
a)
     | ([Modifier]
mods, Map Key Action
m1) <- Map [Modifier] (Map Key Action) -> [([Modifier], Map Key Action)]
forall k a. Map k a -> [(k, a)]
Map.toList Map [Modifier] (Map Key Action)
m
     , (Key
k,Action
a) <- Map Key Action -> [(Key, Action)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Key Action
m1
     ]

instance HasSpec Action where
  anySpec :: ValueSpec Action
anySpec = Text
-> ValueSpec Text
-> (Text -> Either Text Action)
-> ValueSpec Action
forall a b.
Text -> ValueSpec a -> (a -> Either Text b) -> ValueSpec b
customSpec Text
"action" ValueSpec Text
anyAtomSpec
          ((Text -> Either Text Action) -> ValueSpec Action)
-> (Text -> Either Text Action) -> ValueSpec Action
forall a b. (a -> b) -> a -> b
$ \Text
a -> case Text
-> HashMap Text (Action, [([Modifier], Key)])
-> Maybe (Action, [([Modifier], Key)])
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
a HashMap Text (Action, [([Modifier], Key)])
actionInfos of
                    Maybe (Action, [([Modifier], Key)])
Nothing -> Text -> Either Text Action
forall a b. a -> Either a b
Left Text
"unknown action"
                    Just (Action, [([Modifier], Key)])
x  -> Action -> Either Text Action
forall a b. b -> Either a b
Right ((Action, [([Modifier], Key)]) -> Action
forall a b. (a, b) -> a
fst (Action, [([Modifier], Key)])
x)


-- | Names and default key bindings for each action.
--
-- Note that Jump, Insert and Ignored are excluded. These will
-- be computed on demand by keyToAction.
actionInfos :: HashMap Text (Action, [([Modifier],Key)])
actionInfos :: HashMap Text (Action, [([Modifier], Key)])
actionInfos =
  let norm :: b -> ([a], b)
norm = (,) [     ]
      ctrl :: b -> ([Modifier], b)
ctrl = (,) [Modifier
MCtrl]
      meta :: b -> ([Modifier], b)
meta = (,) [Modifier
MMeta] in

  [(Text, (Action, [([Modifier], Key)]))]
-> HashMap Text (Action, [([Modifier], Key)])
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList

  [(Text
"delete"            , (Action
ActDelete           , [Key -> ([Modifier], Key)
forall b. b -> ([Modifier], b)
ctrl (Char -> Key
KChar Char
'd'), Key -> ([Modifier], Key)
forall b a. b -> ([a], b)
norm Key
KDel]))
  ,(Text
"backspace"         , (Action
ActBackspace        , [Key -> ([Modifier], Key)
forall b a. b -> ([a], b)
norm Key
KBS]))
  ,(Text
"home"              , (Action
ActHome             , [Key -> ([Modifier], Key)
forall b a. b -> ([a], b)
norm Key
KHome, Key -> ([Modifier], Key)
forall b. b -> ([Modifier], b)
ctrl (Char -> Key
KChar Char
'a')]))
  ,(Text
"end"               , (Action
ActEnd              , [Key -> ([Modifier], Key)
forall b a. b -> ([a], b)
norm Key
KEnd , Key -> ([Modifier], Key)
forall b. b -> ([Modifier], b)
ctrl (Char -> Key
KChar Char
'e')]))
  ,(Text
"kill-home"         , (Action
ActKillHome         , [Key -> ([Modifier], Key)
forall b. b -> ([Modifier], b)
ctrl (Char -> Key
KChar Char
'u')]))
  ,(Text
"kill-end"          , (Action
ActKillEnd          , [Key -> ([Modifier], Key)
forall b. b -> ([Modifier], b)
ctrl (Char -> Key
KChar Char
'k')]))
  ,(Text
"yank"              , (Action
ActYank             , [Key -> ([Modifier], Key)
forall b. b -> ([Modifier], b)
ctrl (Char -> Key
KChar Char
'y')]))
  ,(Text
"toggle"            , (Action
ActToggle           , [Key -> ([Modifier], Key)
forall b. b -> ([Modifier], b)
ctrl (Char -> Key
KChar Char
't')]))
  ,(Text
"kill-word-left"    , (Action
ActKillWordBack     , [Key -> ([Modifier], Key)
forall b. b -> ([Modifier], b)
ctrl (Char -> Key
KChar Char
'w'), Key -> ([Modifier], Key)
forall b. b -> ([Modifier], b)
meta Key
KBS]))
  ,(Text
"kill-word-right"   , (Action
ActKillWordForward  , [Key -> ([Modifier], Key)
forall b. b -> ([Modifier], b)
meta (Char -> Key
KChar Char
'd')]))

  ,(Text
"bold"              , (Action
ActBold             , [Key -> ([Modifier], Key)
forall b. b -> ([Modifier], b)
ctrl (Char -> Key
KChar Char
'b')]))
  ,(Text
"color"             , (Action
ActColor            , [Key -> ([Modifier], Key)
forall b. b -> ([Modifier], b)
ctrl (Char -> Key
KChar Char
'c')]))
  ,(Text
"italic"            , (Action
ActItalic           , [Key -> ([Modifier], Key)
forall b. b -> ([Modifier], b)
ctrl (Char -> Key
KChar Char
']')]))
  ,(Text
"strikethrough"     , (Action
ActStrikethrough    , [Key -> ([Modifier], Key)
forall b. b -> ([Modifier], b)
ctrl (Char -> Key
KChar Char
'^')]))
  ,(Text
"underline"         , (Action
ActUnderline        , [Key -> ([Modifier], Key)
forall b. b -> ([Modifier], b)
ctrl (Char -> Key
KChar Char
'_')]))
  ,(Text
"clear-format"      , (Action
ActClearFormat      , [Key -> ([Modifier], Key)
forall b. b -> ([Modifier], b)
ctrl (Char -> Key
KChar Char
'o')]))
  ,(Text
"reverse-video"     , (Action
ActReverseVideo     , [Key -> ([Modifier], Key)
forall b. b -> ([Modifier], b)
ctrl (Char -> Key
KChar Char
'v')]))
  ,(Text
"monospace"         , (Action
ActMonospace        , [Key -> ([Modifier], Key)
forall b. b -> ([Modifier], b)
ctrl (Char -> Key
KChar Char
'q')]))

  ,(Text
"insert-newline"    , (Action
ActInsertEnter      , [Key -> ([Modifier], Key)
forall b. b -> ([Modifier], b)
meta Key
KEnter]))
  ,(Text
"insert-digraph"    , (Action
ActDigraph          , [Key -> ([Modifier], Key)
forall b. b -> ([Modifier], b)
meta (Char -> Key
KChar Char
'k')]))

  ,(Text
"next-window"       , (Action
ActAdvanceFocus     , [Key -> ([Modifier], Key)
forall b. b -> ([Modifier], b)
ctrl (Char -> Key
KChar Char
'n')]))
  ,(Text
"prev-window"       , (Action
ActRetreatFocus     , [Key -> ([Modifier], Key)
forall b. b -> ([Modifier], b)
ctrl (Char -> Key
KChar Char
'p')]))
  ,(Text
"next-network"      , (Action
ActAdvanceNetwork   , [Key -> ([Modifier], Key)
forall b. b -> ([Modifier], b)
ctrl (Char -> Key
KChar Char
'x')]))
  ,(Text
"refresh"           , (Action
ActRefresh          , [Key -> ([Modifier], Key)
forall b. b -> ([Modifier], b)
ctrl (Char -> Key
KChar Char
'l')]))
  ,(Text
"jump-to-activity"  , (Action
ActJumpToActivity   , [Key -> ([Modifier], Key)
forall b. b -> ([Modifier], b)
meta (Char -> Key
KChar Char
'a')]))
  ,(Text
"jump-to-previous"  , (Action
ActJumpPrevious     , [Key -> ([Modifier], Key)
forall b. b -> ([Modifier], b)
meta (Char -> Key
KChar Char
's')]))

  ,(Text
"reset"             , (Action
ActReset            , [Key -> ([Modifier], Key)
forall b a. b -> ([a], b)
norm Key
KEsc]))

  ,(Text
"left-word"         , (Action
ActBackWord         , [Key -> ([Modifier], Key)
forall b. b -> ([Modifier], b)
meta Key
KLeft, Key -> ([Modifier], Key)
forall b. b -> ([Modifier], b)
meta (Char -> Key
KChar Char
'b')]))
  ,(Text
"right-word"        , (Action
ActForwardWord      , [Key -> ([Modifier], Key)
forall b. b -> ([Modifier], b)
meta Key
KRight, Key -> ([Modifier], Key)
forall b. b -> ([Modifier], b)
meta (Char -> Key
KChar Char
'f')]))
  ,(Text
"left"              , (Action
ActLeft             , [Key -> ([Modifier], Key)
forall b a. b -> ([a], b)
norm Key
KLeft]))
  ,(Text
"right"             , (Action
ActRight            , [Key -> ([Modifier], Key)
forall b a. b -> ([a], b)
norm Key
KRight]))
  ,(Text
"up"                , (Action
ActOlderLine        , [Key -> ([Modifier], Key)
forall b a. b -> ([a], b)
norm Key
KUp]))
  ,(Text
"down"              , (Action
ActNewerLine        , [Key -> ([Modifier], Key)
forall b a. b -> ([a], b)
norm Key
KDown]))
  ,(Text
"scroll-up"         , (Action
ActScrollUp         , [Key -> ([Modifier], Key)
forall b a. b -> ([a], b)
norm Key
KPageUp]))
  ,(Text
"scroll-down"       , (Action
ActScrollDown       , [Key -> ([Modifier], Key)
forall b a. b -> ([a], b)
norm Key
KPageDown]))
  ,(Text
"scroll-up-small"   , (Action
ActScrollUpSmall    , [Key -> ([Modifier], Key)
forall b. b -> ([Modifier], b)
meta Key
KPageUp]))
  ,(Text
"scroll-down-small" , (Action
ActScrollDownSmall  , [Key -> ([Modifier], Key)
forall b. b -> ([Modifier], b)
meta Key
KPageDown]))
  ,(Text
"enter"             , (Action
ActEnter            , [Key -> ([Modifier], Key)
forall b a. b -> ([a], b)
norm Key
KEnter]))
  ,(Text
"word-complete-back", (Action
ActTabCompleteBack  , [Key -> ([Modifier], Key)
forall b a. b -> ([a], b)
norm Key
KBackTab]))
  ,(Text
"word-complete"     , (Action
ActTabComplete      , [Key -> ([Modifier], Key)
forall b a. b -> ([a], b)
norm (Char -> Key
KChar Char
'\t')]))
  ]


actionNames :: Map Action Text
actionNames :: Map Action Text
actionNames = [(Action, Text)] -> Map Action Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
  [ (Action
action, Text
name) | (Text
name, (Action
action,[([Modifier], Key)]
_)) <- HashMap Text (Action, [([Modifier], Key)])
-> [(Text, (Action, [([Modifier], Key)]))]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList HashMap Text (Action, [([Modifier], Key)])
actionInfos ]


-- | Render action as human-readable text.
actionName :: Action -> Text
actionName :: Action -> Text
actionName (ActCommand Text
txt) = Text
"command: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
txt
actionName Action
a = Text -> Action -> Map Action Text -> Text
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault (String -> Text
Text.pack (Action -> String
forall a. Show a => a -> String
show Action
a)) Action
a Map Action Text
actionNames


keyMapLens :: [Modifier] -> Key -> Lens' KeyMap (Maybe Action)
keyMapLens :: [Modifier] -> Key -> Lens' KeyMap (Maybe Action)
keyMapLens [Modifier]
mods Key
key Maybe Action -> f (Maybe Action)
f (KeyMap Map [Modifier] (Map Key Action)
m) =
  Map [Modifier] (Map Key Action) -> KeyMap
KeyMap (Map [Modifier] (Map Key Action) -> KeyMap)
-> f (Map [Modifier] (Map Key Action)) -> f KeyMap
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Index (Map [Modifier] (Map Key Action))
-> Lens'
     (Map [Modifier] (Map Key Action))
     (Maybe (IxValue (Map [Modifier] (Map Key Action))))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at ([Modifier] -> [Modifier]
normalizeModifiers [Modifier]
mods) ((Maybe (Map Key Action) -> f (Maybe (Map Key Action)))
 -> Map [Modifier] (Map Key Action)
 -> f (Map [Modifier] (Map Key Action)))
-> ((Maybe Action -> f (Maybe Action))
    -> Maybe (Map Key Action) -> f (Maybe (Map Key Action)))
-> (Maybe Action -> f (Maybe Action))
-> Map [Modifier] (Map Key Action)
-> f (Map [Modifier] (Map Key Action))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. APrism' (Map Key Action) ()
-> Iso' (Maybe (Map Key Action)) (Map Key Action)
forall a. APrism' a () -> Iso' (Maybe a) a
non' APrism' (Map Key Action) ()
forall a. AsEmpty a => Prism' a ()
_Empty ((Map Key Action -> f (Map Key Action))
 -> Maybe (Map Key Action) -> f (Maybe (Map Key Action)))
-> ((Maybe Action -> f (Maybe Action))
    -> Map Key Action -> f (Map Key Action))
-> (Maybe Action -> f (Maybe Action))
-> Maybe (Map Key Action)
-> f (Maybe (Map Key Action))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map Key Action)
-> Lens' (Map Key Action) (Maybe (IxValue (Map Key Action)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map Key Action)
Key
key) Maybe Action -> f (Maybe Action)
f Map [Modifier] (Map Key Action)
m


-- | Lookup the action to perform in response to a particular key event.
keyToAction ::
  KeyMap     {- ^ actions         -} ->
  [Modifier] {- ^ jump modifier   -} ->
  Text       {- ^ window names    -} ->
  [Modifier] {- ^ actual modifier -} ->
  Key        {- ^ key             -} ->
  Action     {- ^ action          -}
keyToAction :: KeyMap -> [Modifier] -> Text -> [Modifier] -> Key -> Action
keyToAction KeyMap
_ [Modifier]
jumpMods Text
names [Modifier]
mods (KChar Char
c)
  | [Modifier] -> [Modifier]
normalizeModifiers [Modifier]
jumpMods [Modifier] -> [Modifier] -> Bool
forall a. Eq a => a -> a -> Bool
== [Modifier] -> [Modifier]
normalizeModifiers [Modifier]
mods
  , Char -> Text
Text.singleton Char
c Text -> Text -> Bool
`Text.isInfixOf` Text
names = Char -> Action
ActJump Char
c
keyToAction KeyMap
m [Modifier]
_ Text
_ [Modifier]
modifier Key
key =
  case KeyMap
m KeyMap
-> Getting (Maybe Action) KeyMap (Maybe Action) -> Maybe Action
forall s a. s -> Getting a s a -> a
^. [Modifier] -> Key -> Lens' KeyMap (Maybe Action)
keyMapLens [Modifier]
modifier Key
key of
    Just Action
a -> Action
a
    Maybe Action
Nothing | KChar Char
c <- Key
key, [Modifier] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Modifier]
modifier -> Char -> Action
ActInsert Char
c
            | Bool
otherwise                     -> Action
ActIgnored


-- | Bind a keypress event to a new action.
addKeyBinding ::
  [Modifier] {- ^ modifiers -} ->
  Key        {- ^ key       -} ->
  Action     {- ^ action    -} ->
  KeyMap     {- ^ actions   -} ->
  KeyMap
addKeyBinding :: [Modifier] -> Key -> Action -> KeyMap -> KeyMap
addKeyBinding [Modifier]
mods Key
k Action
a = [Modifier] -> Key -> Lens' KeyMap (Maybe Action)
keyMapLens [Modifier]
mods Key
k ((Maybe Action -> Identity (Maybe Action))
 -> KeyMap -> Identity KeyMap)
-> Action -> KeyMap -> KeyMap
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Action
a

-- | Unbind the action associated with a key.
removeKeyBinding ::
  [Modifier] {- ^ modifiers -} ->
  Key        {- ^ key       -} ->
  KeyMap     {- ^ actions   -} ->
  KeyMap
removeKeyBinding :: [Modifier] -> Key -> KeyMap -> KeyMap
removeKeyBinding [Modifier]
mods Key
k = ((Maybe Action -> Identity (Maybe Action))
 -> KeyMap -> Identity KeyMap)
-> Maybe Action -> KeyMap -> KeyMap
forall s t a b. ASetter s t a b -> b -> s -> t
set ([Modifier] -> Key -> Lens' KeyMap (Maybe Action)
keyMapLens [Modifier]
mods Key
k) Maybe Action
forall a. Maybe a
Nothing


normalizeModifiers :: [Modifier] -> [Modifier]
normalizeModifiers :: [Modifier] -> [Modifier]
normalizeModifiers = [Modifier] -> [Modifier]
forall a. Eq a => [a] -> [a]
nub ([Modifier] -> [Modifier])
-> ([Modifier] -> [Modifier]) -> [Modifier] -> [Modifier]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Modifier] -> [Modifier]
forall a. Ord a => [a] -> [a]
sort


-- | Default key bindings
initialKeyMap :: KeyMap
initialKeyMap :: KeyMap
initialKeyMap = Map [Modifier] (Map Key Action) -> KeyMap
KeyMap (Map [Modifier] (Map Key Action) -> KeyMap)
-> Map [Modifier] (Map Key Action) -> KeyMap
forall a b. (a -> b) -> a -> b
$
  (Map Key Action -> Map Key Action -> Map Key Action)
-> [([Modifier], Map Key Action)]
-> Map [Modifier] (Map Key Action)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Map Key Action -> Map Key Action -> Map Key Action
forall k a. Ord k => Map k a -> Map k a -> Map k a
Map.union ([([Modifier], Map Key Action)] -> Map [Modifier] (Map Key Action))
-> [([Modifier], Map Key Action)]
-> Map [Modifier] (Map Key Action)
forall a b. (a -> b) -> a -> b
$

   ([], [(Key, Action)] -> Map Key Action
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
          [ (Int -> Key
KFun Int
2, Text -> Action
ActCommand Text
"toggle-detail")
          , (Int -> Key
KFun Int
3, Text -> Action
ActCommand Text
"toggle-activity-bar")
          , (Int -> Key
KFun Int
4, Text -> Action
ActCommand Text
"toggle-metadata")
          , (Int -> Key
KFun Int
5, Text -> Action
ActCommand Text
"toggle-layout")
          , (Int -> Key
KFun Int
6, Text -> Action
ActCommand Text
"toggle-editor")
          , (Int -> Key
KFun Int
7, Text -> Action
ActCommand Text
"toggle-edit-lock")
          ])
    ([Modifier], Map Key Action)
-> [([Modifier], Map Key Action)] -> [([Modifier], Map Key Action)]
forall a. a -> [a] -> [a]
:

    [ ([Modifier]
mods, Key -> Action -> Map Key Action
forall k a. k -> a -> Map k a
Map.singleton Key
k Action
act)
      | (Action
act, [([Modifier], Key)]
mks) <- HashMap Text (Action, [([Modifier], Key)])
-> [(Action, [([Modifier], Key)])]
forall k v. HashMap k v -> [v]
HashMap.elems HashMap Text (Action, [([Modifier], Key)])
actionInfos
      , ([Modifier]
mods, Key
k)  <- [([Modifier], Key)]
mks
      ]


parseKey :: String -> Maybe ([Modifier], Key)
parseKey :: String -> Maybe ([Modifier], Key)
parseKey = Compose Maybe ((,) [Modifier]) Key -> Maybe ([Modifier], Key)
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (Compose Maybe ((,) [Modifier]) Key -> Maybe ([Modifier], Key))
-> (String -> Compose Maybe ((,) [Modifier]) Key)
-> String
-> Maybe ([Modifier], Key)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Compose Maybe ((,) [Modifier]) Key
go
  where
    modifier :: a -> Compose Maybe ((,) [a]) ()
modifier a
x   = Maybe ([a], ()) -> Compose Maybe ((,) [a]) ()
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (([a], ()) -> Maybe ([a], ())
forall a. a -> Maybe a
Just ([a
x], ()))
    liftMaybe :: f a -> Compose f ((,) [a]) a
liftMaybe f a
mb = f ([a], a) -> Compose f ((,) [a]) a
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose ((,)[] (a -> ([a], a)) -> f a -> f ([a], a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
mb)
    go :: String -> Compose Maybe ((,) [Modifier]) Key
go String
str =
      case String
str of
        String
"Space"     -> Key -> Compose Maybe ((,) [Modifier]) Key
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char -> Key
KChar Char
' ')
        String
"Tab"       -> Key -> Compose Maybe ((,) [Modifier]) Key
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char -> Key
KChar Char
'\t')
        String
"BackTab"   -> Key -> Compose Maybe ((,) [Modifier]) Key
forall (f :: * -> *) a. Applicative f => a -> f a
pure Key
KBackTab
        String
"Enter"     -> Key -> Compose Maybe ((,) [Modifier]) Key
forall (f :: * -> *) a. Applicative f => a -> f a
pure Key
KEnter
        String
"Home"      -> Key -> Compose Maybe ((,) [Modifier]) Key
forall (f :: * -> *) a. Applicative f => a -> f a
pure Key
KHome
        String
"End"       -> Key -> Compose Maybe ((,) [Modifier]) Key
forall (f :: * -> *) a. Applicative f => a -> f a
pure Key
KEnd
        String
"Esc"       -> Key -> Compose Maybe ((,) [Modifier]) Key
forall (f :: * -> *) a. Applicative f => a -> f a
pure Key
KEsc
        String
"PageUp"    -> Key -> Compose Maybe ((,) [Modifier]) Key
forall (f :: * -> *) a. Applicative f => a -> f a
pure Key
KPageUp
        String
"PageDown"  -> Key -> Compose Maybe ((,) [Modifier]) Key
forall (f :: * -> *) a. Applicative f => a -> f a
pure Key
KPageDown
        String
"Backspace" -> Key -> Compose Maybe ((,) [Modifier]) Key
forall (f :: * -> *) a. Applicative f => a -> f a
pure Key
KBS
        String
"Delete"    -> Key -> Compose Maybe ((,) [Modifier]) Key
forall (f :: * -> *) a. Applicative f => a -> f a
pure Key
KDel
        String
"Left"      -> Key -> Compose Maybe ((,) [Modifier]) Key
forall (f :: * -> *) a. Applicative f => a -> f a
pure Key
KLeft
        String
"Right"     -> Key -> Compose Maybe ((,) [Modifier]) Key
forall (f :: * -> *) a. Applicative f => a -> f a
pure Key
KRight
        String
"Up"        -> Key -> Compose Maybe ((,) [Modifier]) Key
forall (f :: * -> *) a. Applicative f => a -> f a
pure Key
KUp
        String
"Down"      -> Key -> Compose Maybe ((,) [Modifier]) Key
forall (f :: * -> *) a. Applicative f => a -> f a
pure Key
KDown
        [Char
c]         -> Key -> Compose Maybe ((,) [Modifier]) Key
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Char -> Key
KChar Char
c)
        Char
'F':String
xs      -> Int -> Key
KFun (Int -> Key)
-> Compose Maybe ((,) [Modifier]) Int
-> Compose Maybe ((,) [Modifier]) Key
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int -> Compose Maybe ((,) [Modifier]) Int
forall (f :: * -> *) a a. Functor f => f a -> Compose f ((,) [a]) a
liftMaybe (String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe String
xs)
        Char
'C':Char
'-':String
xs  -> Modifier -> Compose Maybe ((,) [Modifier]) ()
forall a. a -> Compose Maybe ((,) [a]) ()
modifier Modifier
MCtrl  Compose Maybe ((,) [Modifier]) ()
-> Compose Maybe ((,) [Modifier]) Key
-> Compose Maybe ((,) [Modifier]) Key
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> String -> Compose Maybe ((,) [Modifier]) Key
go String
xs
        Char
'M':Char
'-':String
xs  -> Modifier -> Compose Maybe ((,) [Modifier]) ()
forall a. a -> Compose Maybe ((,) [a]) ()
modifier Modifier
MMeta  Compose Maybe ((,) [Modifier]) ()
-> Compose Maybe ((,) [Modifier]) Key
-> Compose Maybe ((,) [Modifier]) Key
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> String -> Compose Maybe ((,) [Modifier]) Key
go String
xs
        Char
'S':Char
'-':String
xs  -> Modifier -> Compose Maybe ((,) [Modifier]) ()
forall a. a -> Compose Maybe ((,) [a]) ()
modifier Modifier
MShift Compose Maybe ((,) [Modifier]) ()
-> Compose Maybe ((,) [Modifier]) Key
-> Compose Maybe ((,) [Modifier]) Key
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> String -> Compose Maybe ((,) [Modifier]) Key
go String
xs
        Char
'A':Char
'-':String
xs  -> Modifier -> Compose Maybe ((,) [Modifier]) ()
forall a. a -> Compose Maybe ((,) [a]) ()
modifier Modifier
MAlt   Compose Maybe ((,) [Modifier]) ()
-> Compose Maybe ((,) [Modifier]) Key
-> Compose Maybe ((,) [Modifier]) Key
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> String -> Compose Maybe ((,) [Modifier]) Key
go String
xs
        String
_           -> Compose Maybe ((,) [Modifier]) Key
forall (f :: * -> *) a. Alternative f => f a
empty


prettyModifierKey :: [Modifier] -> Key -> String
prettyModifierKey :: [Modifier] -> Key -> String
prettyModifierKey [Modifier]
mods Key
k
  = (Modifier -> ShowS) -> String -> [Modifier] -> String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Modifier -> ShowS
prettyModifier (Key -> String
prettyKey Key
k) [Modifier]
mods

prettyModifier :: Modifier -> ShowS
prettyModifier :: Modifier -> ShowS
prettyModifier Modifier
MCtrl  = String -> ShowS
showString String
"C-"
prettyModifier Modifier
MMeta  = String -> ShowS
showString String
"M-"
prettyModifier Modifier
MShift = String -> ShowS
showString String
"S-"
prettyModifier Modifier
MAlt   = String -> ShowS
showString String
"A-"

prettyKey :: Key -> String
prettyKey :: Key -> String
prettyKey (KChar Char
' ') = String
"Space"
prettyKey (KChar Char
'\t') = String
"Tab"
prettyKey (KChar Char
c) = Char -> ShowS
showLitChar Char
c String
"" -- escapes anything non-ascii
prettyKey (KFun Int
n)  = Char
'F' Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
n
prettyKey Key
KBackTab  = String
"BackTab"
prettyKey Key
KEnter    = String
"Enter"
prettyKey Key
KEsc      = String
"Esc"
prettyKey Key
KHome     = String
"Home"
prettyKey Key
KEnd      = String
"End"
prettyKey Key
KPageUp   = String
"PageUp"
prettyKey Key
KPageDown = String
"PageDn"
prettyKey Key
KDel      = String
"Delete"
prettyKey Key
KBS       = String
"Backspace"
prettyKey Key
KLeft     = String
"Left"
prettyKey Key
KRight    = String
"Right"
prettyKey Key
KUp       = String
"Up"
prettyKey Key
KDown     = String
"Down"
prettyKey Key
k         = Key -> String
forall a. Show a => a -> String
show Key
k