module Matterhorn.Events.Keybindings
  ( defaultBindings
  , lookupKeybinding
  , firstActiveBinding

  , mkKb
  , staticKb
  , mkKeybindings

  , handleKeyboardEvent

  , EventHandler(..)
  , KeyHandler(..)
  , KeyEventHandler(..)
  , KeyEventTrigger(..)
  , KeyHandlerMap(..)

  -- Re-exports:
  , KeyEvent (..)
  , KeyConfig
  , allEvents
  , parseBinding
  , keyEventName
  , keyEventFromName

  , ensureKeybindingConsistency
  )
where

import           Prelude ()
import           Matterhorn.Prelude

import qualified Data.Text as T
import qualified Data.Map.Strict as M
import qualified Graphics.Vty as Vty

import           Matterhorn.Types
import           Matterhorn.Types.KeyEvents


-- * Keybindings

-- | An 'EventHandler' represents a event handler.
data EventHandler =
    EH { EventHandler -> Text
ehDescription :: Text
       -- ^ The description of this handler's behavior.
       , EventHandler -> MH ()
ehAction :: MH ()
       -- ^ The action to take when this handler is invoked.
       }

-- | A trigger for a key event.
data KeyEventTrigger =
    Static Vty.Event
    -- ^ The key event is always triggered by a specific key.
    | ByEvent KeyEvent
    -- ^ The key event is always triggered by an abstract key event (and
    -- thus configured to be bound to specific key(s) in the KeyConfig).
    deriving (Int -> KeyEventTrigger -> ShowS
[KeyEventTrigger] -> ShowS
KeyEventTrigger -> String
(Int -> KeyEventTrigger -> ShowS)
-> (KeyEventTrigger -> String)
-> ([KeyEventTrigger] -> ShowS)
-> Show KeyEventTrigger
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [KeyEventTrigger] -> ShowS
$cshowList :: [KeyEventTrigger] -> ShowS
show :: KeyEventTrigger -> String
$cshow :: KeyEventTrigger -> String
showsPrec :: Int -> KeyEventTrigger -> ShowS
$cshowsPrec :: Int -> KeyEventTrigger -> ShowS
Show, KeyEventTrigger -> KeyEventTrigger -> Bool
(KeyEventTrigger -> KeyEventTrigger -> Bool)
-> (KeyEventTrigger -> KeyEventTrigger -> Bool)
-> Eq KeyEventTrigger
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: KeyEventTrigger -> KeyEventTrigger -> Bool
$c/= :: KeyEventTrigger -> KeyEventTrigger -> Bool
== :: KeyEventTrigger -> KeyEventTrigger -> Bool
$c== :: KeyEventTrigger -> KeyEventTrigger -> Bool
Eq, Eq KeyEventTrigger
Eq KeyEventTrigger
-> (KeyEventTrigger -> KeyEventTrigger -> Ordering)
-> (KeyEventTrigger -> KeyEventTrigger -> Bool)
-> (KeyEventTrigger -> KeyEventTrigger -> Bool)
-> (KeyEventTrigger -> KeyEventTrigger -> Bool)
-> (KeyEventTrigger -> KeyEventTrigger -> Bool)
-> (KeyEventTrigger -> KeyEventTrigger -> KeyEventTrigger)
-> (KeyEventTrigger -> KeyEventTrigger -> KeyEventTrigger)
-> Ord KeyEventTrigger
KeyEventTrigger -> KeyEventTrigger -> Bool
KeyEventTrigger -> KeyEventTrigger -> Ordering
KeyEventTrigger -> KeyEventTrigger -> KeyEventTrigger
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 :: KeyEventTrigger -> KeyEventTrigger -> KeyEventTrigger
$cmin :: KeyEventTrigger -> KeyEventTrigger -> KeyEventTrigger
max :: KeyEventTrigger -> KeyEventTrigger -> KeyEventTrigger
$cmax :: KeyEventTrigger -> KeyEventTrigger -> KeyEventTrigger
>= :: KeyEventTrigger -> KeyEventTrigger -> Bool
$c>= :: KeyEventTrigger -> KeyEventTrigger -> Bool
> :: KeyEventTrigger -> KeyEventTrigger -> Bool
$c> :: KeyEventTrigger -> KeyEventTrigger -> Bool
<= :: KeyEventTrigger -> KeyEventTrigger -> Bool
$c<= :: KeyEventTrigger -> KeyEventTrigger -> Bool
< :: KeyEventTrigger -> KeyEventTrigger -> Bool
$c< :: KeyEventTrigger -> KeyEventTrigger -> Bool
compare :: KeyEventTrigger -> KeyEventTrigger -> Ordering
$ccompare :: KeyEventTrigger -> KeyEventTrigger -> Ordering
$cp1Ord :: Eq KeyEventTrigger
Ord)

-- | A handler for an abstract key event.
data KeyEventHandler =
    KEH { KeyEventHandler -> EventHandler
kehHandler :: EventHandler
        -- ^ The handler to invoke.
        , KeyEventHandler -> KeyEventTrigger
kehEventTrigger :: KeyEventTrigger
        -- ^ The trigger for the handler.
        }

-- | A handler for a specific key.
data KeyHandler =
    KH { KeyHandler -> KeyEventHandler
khHandler :: KeyEventHandler
       -- ^ The handler to invoke.
       , KeyHandler -> Event
khKey :: Vty.Event
       -- ^ The specific key that should trigger this handler.
       }

newtype KeyHandlerMap = KeyHandlerMap (M.Map Vty.Event KeyHandler)

-- | Find a keybinding that matches a Vty Event
lookupKeybinding :: Vty.Event -> KeyHandlerMap -> Maybe KeyHandler
lookupKeybinding :: Event -> KeyHandlerMap -> Maybe KeyHandler
lookupKeybinding Event
e (KeyHandlerMap Map Event KeyHandler
m) = Event -> Map Event KeyHandler -> Maybe KeyHandler
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Event
e Map Event KeyHandler
m

-- | Handle a keyboard event by looking it up in a map of bindings and
-- invoking the matching binding's handler. Return True if the key event
-- was handled with a matching binding; False if not (the fallback
-- case).
handleKeyboardEvent :: (KeyConfig -> KeyHandlerMap)
                    -- ^ The function to build a key handler map from a
                    -- key configuration.
                    -> Vty.Event
                    -- ^ The event to handle.
                    -> MH Bool
handleKeyboardEvent :: (KeyConfig -> KeyHandlerMap) -> Event -> MH Bool
handleKeyboardEvent KeyConfig -> KeyHandlerMap
mkKeyMap Event
e = do
  Config
conf <- Getting Config ChatState Config -> MH Config
forall s (m :: * -> *) a. MonadState s m => Getting a s a -> m a
use ((ChatResources -> Const Config ChatResources)
-> ChatState -> Const Config ChatState
Lens' ChatState ChatResources
csResources((ChatResources -> Const Config ChatResources)
 -> ChatState -> Const Config ChatState)
-> ((Config -> Const Config Config)
    -> ChatResources -> Const Config ChatResources)
-> Getting Config ChatState Config
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Config -> Const Config Config)
-> ChatResources -> Const Config ChatResources
Lens' ChatResources Config
crConfiguration)
  let keyMap :: KeyHandlerMap
keyMap = KeyConfig -> KeyHandlerMap
mkKeyMap (Config -> KeyConfig
configUserKeys Config
conf)
  case Event -> KeyHandlerMap -> Maybe KeyHandler
lookupKeybinding Event
e KeyHandlerMap
keyMap of
    Just KeyHandler
kh -> (EventHandler -> MH ()
ehAction (EventHandler -> MH ()) -> EventHandler -> MH ()
forall a b. (a -> b) -> a -> b
$ KeyEventHandler -> EventHandler
kehHandler (KeyEventHandler -> EventHandler)
-> KeyEventHandler -> EventHandler
forall a b. (a -> b) -> a -> b
$ KeyHandler -> KeyEventHandler
khHandler KeyHandler
kh) MH () -> MH Bool -> MH Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> MH Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    Maybe KeyHandler
Nothing -> Bool -> MH Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

mkHandler :: Text -> MH () -> EventHandler
mkHandler :: Text -> MH () -> EventHandler
mkHandler Text
msg MH ()
action =
    EH :: Text -> MH () -> EventHandler
EH { ehDescription :: Text
ehDescription = Text
msg
       , ehAction :: MH ()
ehAction = MH ()
action
       }

mkKb :: KeyEvent -> Text -> MH () -> KeyEventHandler
mkKb :: KeyEvent -> Text -> MH () -> KeyEventHandler
mkKb KeyEvent
ev Text
msg MH ()
action =
    KEH :: EventHandler -> KeyEventTrigger -> KeyEventHandler
KEH { kehHandler :: EventHandler
kehHandler = Text -> MH () -> EventHandler
mkHandler Text
msg MH ()
action
        , kehEventTrigger :: KeyEventTrigger
kehEventTrigger = KeyEvent -> KeyEventTrigger
ByEvent KeyEvent
ev
        }

keyHandlerFromConfig :: KeyConfig -> KeyEventHandler -> [KeyHandler]
keyHandlerFromConfig :: KeyConfig -> KeyEventHandler -> [KeyHandler]
keyHandlerFromConfig KeyConfig
conf KeyEventHandler
eh =
    case KeyEventHandler -> KeyEventTrigger
kehEventTrigger KeyEventHandler
eh of
        Static Event
key ->
            [ KeyEventHandler -> Event -> KeyHandler
KH KeyEventHandler
eh Event
key ]
        ByEvent KeyEvent
ev ->
            [ KeyEventHandler -> Event -> KeyHandler
KH KeyEventHandler
eh (Binding -> Event
bindingToEvent Binding
b) | Binding
b <- [Binding]
allBindings ]
            where allBindings :: [Binding]
allBindings | Just (BindingList [Binding]
ks) <- KeyEvent -> KeyConfig -> Maybe BindingState
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup KeyEvent
ev KeyConfig
conf = [Binding]
ks
                              | Just BindingState
Unbound <- KeyEvent -> KeyConfig -> Maybe BindingState
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup KeyEvent
ev KeyConfig
conf = []
                              | Bool
otherwise = KeyEvent -> [Binding]
defaultBindings KeyEvent
ev

staticKb :: Text -> Vty.Event -> MH () -> KeyEventHandler
staticKb :: Text -> Event -> MH () -> KeyEventHandler
staticKb Text
msg Event
event MH ()
action =
    KEH :: EventHandler -> KeyEventTrigger -> KeyEventHandler
KEH { kehHandler :: EventHandler
kehHandler = Text -> MH () -> EventHandler
mkHandler Text
msg MH ()
action
        , kehEventTrigger :: KeyEventTrigger
kehEventTrigger = Event -> KeyEventTrigger
Static Event
event
        }

mkKeybindings :: [KeyEventHandler] -> KeyConfig -> KeyHandlerMap
mkKeybindings :: [KeyEventHandler] -> KeyConfig -> KeyHandlerMap
mkKeybindings [KeyEventHandler]
ks KeyConfig
conf = Map Event KeyHandler -> KeyHandlerMap
KeyHandlerMap (Map Event KeyHandler -> KeyHandlerMap)
-> Map Event KeyHandler -> KeyHandlerMap
forall a b. (a -> b) -> a -> b
$ [(Event, KeyHandler)] -> Map Event KeyHandler
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Event, KeyHandler)] -> Map Event KeyHandler)
-> [(Event, KeyHandler)] -> Map Event KeyHandler
forall a b. (a -> b) -> a -> b
$ [KeyEventHandler] -> KeyConfig -> [(Event, KeyHandler)]
keyHandlerMapPairs [KeyEventHandler]
ks KeyConfig
conf

keyHandlerMapPairs :: [KeyEventHandler] -> KeyConfig -> [(Vty.Event, KeyHandler)]
keyHandlerMapPairs :: [KeyEventHandler] -> KeyConfig -> [(Event, KeyHandler)]
keyHandlerMapPairs [KeyEventHandler]
ks KeyConfig
conf = [(Event, KeyHandler)]
pairs
    where
        pairs :: [(Event, KeyHandler)]
pairs = KeyHandler -> (Event, KeyHandler)
mkPair (KeyHandler -> (Event, KeyHandler))
-> [KeyHandler] -> [(Event, KeyHandler)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [KeyHandler]
handlers
        mkPair :: KeyHandler -> (Event, KeyHandler)
mkPair KeyHandler
h = (KeyHandler -> Event
khKey KeyHandler
h, KeyHandler
h)
        handlers :: [KeyHandler]
handlers = [[KeyHandler]] -> [KeyHandler]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[KeyHandler]] -> [KeyHandler]) -> [[KeyHandler]] -> [KeyHandler]
forall a b. (a -> b) -> a -> b
$ KeyConfig -> KeyEventHandler -> [KeyHandler]
keyHandlerFromConfig KeyConfig
conf (KeyEventHandler -> [KeyHandler])
-> [KeyEventHandler] -> [[KeyHandler]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [KeyEventHandler]
ks

bindingToEvent :: Binding -> Vty.Event
bindingToEvent :: Binding -> Event
bindingToEvent Binding
binding =
  Key -> [Modifier] -> Event
Vty.EvKey (Binding -> Key
kbKey Binding
binding) (Binding -> [Modifier]
kbMods Binding
binding)

firstActiveBinding :: KeyConfig -> KeyEvent -> Binding
firstActiveBinding :: KeyConfig -> KeyEvent -> Binding
firstActiveBinding KeyConfig
kc KeyEvent
ev = Binding -> Maybe Binding -> Binding
forall a. a -> Maybe a -> a
fromMaybe (KeyEvent -> Binding
getFirstDefaultBinding KeyEvent
ev) (Maybe Binding -> Binding) -> Maybe Binding -> Binding
forall a b. (a -> b) -> a -> b
$ do
    BindingState
bState <- KeyEvent -> KeyConfig -> Maybe BindingState
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup KeyEvent
ev KeyConfig
kc
    case BindingState
bState of
        BindingList (Binding
b:[Binding]
_) -> Binding -> Maybe Binding
forall a. a -> Maybe a
Just Binding
b
        BindingState
_ -> Maybe Binding
forall a. Maybe a
Nothing

getFirstDefaultBinding :: KeyEvent -> Binding
getFirstDefaultBinding :: KeyEvent -> Binding
getFirstDefaultBinding KeyEvent
ev =
    case KeyEvent -> [Binding]
defaultBindings KeyEvent
ev of
        [] -> String -> Binding
forall a. HasCallStack => String -> a
error (String -> Binding) -> String -> Binding
forall a b. (a -> b) -> a -> b
$ String
"BUG: event " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> KeyEvent -> String
forall a. Show a => a -> String
show KeyEvent
ev String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" has no default bindings!"
        (Binding
b:[Binding]
_) -> Binding
b

defaultBindings :: KeyEvent -> [Binding]
defaultBindings :: KeyEvent -> [Binding]
defaultBindings KeyEvent
ev =
  let meta :: Binding -> Binding
meta Binding
binding = Binding
binding { kbMods :: [Modifier]
kbMods = Modifier
Vty.MMeta Modifier -> [Modifier] -> [Modifier]
forall a. a -> [a] -> [a]
: Binding -> [Modifier]
kbMods Binding
binding }
      ctrl :: Binding -> Binding
ctrl Binding
binding = Binding
binding { kbMods :: [Modifier]
kbMods = Modifier
Vty.MCtrl Modifier -> [Modifier] -> [Modifier]
forall a. a -> [a] -> [a]
: Binding -> [Modifier]
kbMods Binding
binding }
      shift :: Binding -> Binding
shift Binding
binding = Binding
binding { kbMods :: [Modifier]
kbMods = Modifier
Vty.MShift Modifier -> [Modifier] -> [Modifier]
forall a. a -> [a] -> [a]
: Binding -> [Modifier]
kbMods Binding
binding }
      kb :: Key -> Binding
kb Key
k = Binding :: [Modifier] -> Key -> Binding
Binding { kbMods :: [Modifier]
kbMods = [], kbKey :: Key
kbKey = Key
k }
      key :: Char -> Binding
key Char
c = Binding :: [Modifier] -> Key -> Binding
Binding { kbMods :: [Modifier]
kbMods = [], kbKey :: Key
kbKey = Char -> Key
Vty.KChar Char
c }
      fn :: Int -> Binding
fn Int
n = Binding :: [Modifier] -> Key -> Binding
Binding { kbMods :: [Modifier]
kbMods = [], kbKey :: Key
kbKey = Int -> Key
Vty.KFun Int
n }
  in case KeyEvent
ev of
        KeyEvent
VtyRefreshEvent               -> [ Binding -> Binding
ctrl (Char -> Binding
key Char
'l') ]
        KeyEvent
ShowHelpEvent                 -> [ Int -> Binding
fn Int
1 ]
        KeyEvent
EnterSelectModeEvent          -> [ Binding -> Binding
ctrl (Char -> Binding
key Char
's') ]
        KeyEvent
ReplyRecentEvent              -> [ Binding -> Binding
ctrl (Char -> Binding
key Char
'r') ]
        KeyEvent
ToggleMessagePreviewEvent     -> [ Binding -> Binding
meta (Char -> Binding
key Char
'p') ]
        KeyEvent
InvokeEditorEvent             -> [ Binding -> Binding
meta (Char -> Binding
key Char
'k') ]
        KeyEvent
EnterFastSelectModeEvent      -> [ Binding -> Binding
ctrl (Char -> Binding
key Char
'g') ]
        KeyEvent
QuitEvent                     -> [ Binding -> Binding
ctrl (Char -> Binding
key Char
'q') ]
        KeyEvent
NextChannelEvent              -> [ Binding -> Binding
ctrl (Char -> Binding
key Char
'n') ]
        KeyEvent
PrevChannelEvent              -> [ Binding -> Binding
ctrl (Char -> Binding
key Char
'p') ]
        KeyEvent
NextChannelEventAlternate     -> [ Key -> Binding
kb Key
Vty.KDown ]
        KeyEvent
PrevChannelEventAlternate     -> [ Key -> Binding
kb Key
Vty.KUp ]
        KeyEvent
NextUnreadChannelEvent        -> [ Binding -> Binding
meta (Char -> Binding
key Char
'a') ]
        KeyEvent
ShowAttachmentListEvent       -> [ Binding -> Binding
ctrl (Char -> Binding
key Char
'x') ]
        KeyEvent
ChangeMessageEditorFocus      -> [ Binding -> Binding
meta (Char -> Binding
key Char
'o') ]
        KeyEvent
NextUnreadUserOrChannelEvent  -> [ ]
        KeyEvent
LastChannelEvent              -> [ Binding -> Binding
meta (Char -> Binding
key Char
's') ]
        KeyEvent
EnterOpenURLModeEvent         -> [ Binding -> Binding
ctrl (Char -> Binding
key Char
'o') ]
        KeyEvent
ClearUnreadEvent              -> [ Binding -> Binding
meta (Char -> Binding
key Char
'l') ]
        KeyEvent
ToggleMultiLineEvent          -> [ Binding -> Binding
meta (Char -> Binding
key Char
'e') ]
        KeyEvent
EnterFlaggedPostsEvent        -> [ Binding -> Binding
meta (Char -> Binding
key Char
'8') ]
        KeyEvent
ToggleChannelListVisibleEvent -> [ Int -> Binding
fn Int
2 ]
        KeyEvent
ToggleExpandedChannelTopicsEvent -> [ Int -> Binding
fn Int
3 ]
        KeyEvent
CycleChannelListSorting       -> [ Int -> Binding
fn Int
4 ]
        KeyEvent
SelectNextTabEvent            -> [ Char -> Binding
key Char
'\t' ]
        KeyEvent
SelectPreviousTabEvent        -> [ Key -> Binding
kb Key
Vty.KBackTab ]
        KeyEvent
SaveAttachmentEvent           -> [ Char -> Binding
key Char
's' ]
        KeyEvent
LoadMoreEvent                 -> [ Binding -> Binding
ctrl (Char -> Binding
key Char
'b') ]
        KeyEvent
ScrollUpEvent                 -> [ Key -> Binding
kb Key
Vty.KUp ]
        KeyEvent
ScrollDownEvent               -> [ Key -> Binding
kb Key
Vty.KDown ]
        KeyEvent
ScrollLeftEvent               -> [ Key -> Binding
kb Key
Vty.KLeft ]
        KeyEvent
ScrollRightEvent              -> [ Key -> Binding
kb Key
Vty.KRight ]
        KeyEvent
ChannelListScrollUpEvent      -> [ Binding -> Binding
ctrl (Key -> Binding
kb Key
Vty.KUp) ]
        KeyEvent
ChannelListScrollDownEvent    -> [ Binding -> Binding
ctrl (Key -> Binding
kb Key
Vty.KDown) ]
        KeyEvent
PageUpEvent                   -> [ Key -> Binding
kb Key
Vty.KPageUp ]
        KeyEvent
PageDownEvent                 -> [ Key -> Binding
kb Key
Vty.KPageDown ]
        KeyEvent
PageLeftEvent                 -> [ Binding -> Binding
shift (Key -> Binding
kb Key
Vty.KLeft) ]
        KeyEvent
PageRightEvent                -> [ Binding -> Binding
shift (Key -> Binding
kb Key
Vty.KRight) ]
        KeyEvent
ScrollTopEvent                -> [ Key -> Binding
kb Key
Vty.KHome, Binding -> Binding
meta (Binding -> Binding) -> Binding -> Binding
forall a b. (a -> b) -> a -> b
$ Char -> Binding
key Char
'<' ]
        KeyEvent
ScrollBottomEvent             -> [ Key -> Binding
kb Key
Vty.KEnd, Binding -> Binding
meta (Binding -> Binding) -> Binding -> Binding
forall a b. (a -> b) -> a -> b
$ Char -> Binding
key Char
'>' ]
        KeyEvent
SelectOldestMessageEvent      -> [ Binding -> Binding
shift (Key -> Binding
kb Key
Vty.KHome) ]
        KeyEvent
SelectUpEvent                 -> [ Char -> Binding
key Char
'k', Key -> Binding
kb Key
Vty.KUp ]
        KeyEvent
SelectDownEvent               -> [ Char -> Binding
key Char
'j', Key -> Binding
kb Key
Vty.KDown ]
        KeyEvent
ActivateListItemEvent         -> [ Key -> Binding
kb Key
Vty.KEnter ]
        KeyEvent
SearchSelectUpEvent           -> [ Binding -> Binding
ctrl (Char -> Binding
key Char
'p'), Key -> Binding
kb Key
Vty.KUp ]
        KeyEvent
SearchSelectDownEvent         -> [ Binding -> Binding
ctrl (Char -> Binding
key Char
'n'), Key -> Binding
kb Key
Vty.KDown ]
        KeyEvent
ViewMessageEvent              -> [ Char -> Binding
key Char
'v' ]
        KeyEvent
FillGapEvent                  -> [ Key -> Binding
kb Key
Vty.KEnter ]
        KeyEvent
CopyPostLinkEvent             -> [ Char -> Binding
key Char
'l' ]
        KeyEvent
FlagMessageEvent              -> [ Char -> Binding
key Char
'f' ]
        KeyEvent
OpenThreadEvent               -> [ Char -> Binding
key Char
't' ]
        KeyEvent
PinMessageEvent               -> [ Char -> Binding
key Char
'p' ]
        KeyEvent
YankMessageEvent              -> [ Char -> Binding
key Char
'y' ]
        KeyEvent
YankWholeMessageEvent         -> [ Char -> Binding
key Char
'Y' ]
        KeyEvent
DeleteMessageEvent            -> [ Char -> Binding
key Char
'd' ]
        KeyEvent
EditMessageEvent              -> [ Char -> Binding
key Char
'e' ]
        KeyEvent
ReplyMessageEvent             -> [ Char -> Binding
key Char
'r' ]
        KeyEvent
ReactToMessageEvent           -> [ Char -> Binding
key Char
'a' ]
        KeyEvent
OpenMessageURLEvent           -> [ Char -> Binding
key Char
'o' ]
        KeyEvent
AttachmentListAddEvent        -> [ Char -> Binding
key Char
'a' ]
        KeyEvent
AttachmentListDeleteEvent     -> [ Char -> Binding
key Char
'd' ]
        KeyEvent
AttachmentOpenEvent           -> [ Char -> Binding
key Char
'o' ]
        KeyEvent
CancelEvent                   -> [ Key -> Binding
kb Key
Vty.KEsc, Binding -> Binding
ctrl (Char -> Binding
key Char
'c') ]
        KeyEvent
EditorBolEvent                -> [ Binding -> Binding
ctrl (Char -> Binding
key Char
'a') ]
        KeyEvent
EditorEolEvent                -> [ Binding -> Binding
ctrl (Char -> Binding
key Char
'e') ]
        KeyEvent
EditorTransposeCharsEvent     -> [ Binding -> Binding
ctrl (Char -> Binding
key Char
't') ]
        KeyEvent
EditorDeleteCharacter         -> [ Binding -> Binding
ctrl (Char -> Binding
key Char
'd') ]
        KeyEvent
EditorKillToBolEvent          -> [ Binding -> Binding
ctrl (Char -> Binding
key Char
'u') ]
        KeyEvent
EditorKillToEolEvent          -> [ Binding -> Binding
ctrl (Char -> Binding
key Char
'k') ]
        KeyEvent
EditorPrevCharEvent           -> [ Binding -> Binding
ctrl (Char -> Binding
key Char
'b') ]
        KeyEvent
EditorNextCharEvent           -> [ Binding -> Binding
ctrl (Char -> Binding
key Char
'f') ]
        KeyEvent
EditorPrevWordEvent           -> [ Binding -> Binding
meta (Char -> Binding
key Char
'b') ]
        KeyEvent
EditorNextWordEvent           -> [ Binding -> Binding
meta (Char -> Binding
key Char
'f') ]
        KeyEvent
EditorDeleteNextWordEvent     -> [ Binding -> Binding
meta (Char -> Binding
key Char
'd') ]
        KeyEvent
EditorDeletePrevWordEvent     -> [ Binding -> Binding
ctrl (Char -> Binding
key Char
'w'), Binding -> Binding
meta (Key -> Binding
kb Key
Vty.KBS) ]
        KeyEvent
EditorHomeEvent               -> [ Key -> Binding
kb Key
Vty.KHome ]
        KeyEvent
EditorEndEvent                -> [ Key -> Binding
kb Key
Vty.KEnd ]
        KeyEvent
EditorYankEvent               -> [ Binding -> Binding
ctrl (Char -> Binding
key Char
'y') ]
        KeyEvent
FileBrowserBeginSearchEvent      -> [ Char -> Binding
key Char
'/' ]
        KeyEvent
FileBrowserSelectEnterEvent      -> [ Key -> Binding
kb Key
Vty.KEnter ]
        KeyEvent
FileBrowserSelectCurrentEvent    -> [ Key -> Binding
kb (Char -> Key
Vty.KChar Char
' ') ]
        KeyEvent
FileBrowserListPageUpEvent       -> [ Binding -> Binding
ctrl (Char -> Binding
key Char
'b'), Key -> Binding
kb Key
Vty.KPageUp ]
        KeyEvent
FileBrowserListPageDownEvent     -> [ Binding -> Binding
ctrl (Char -> Binding
key Char
'f'), Key -> Binding
kb Key
Vty.KPageDown ]
        KeyEvent
FileBrowserListHalfPageUpEvent   -> [ Binding -> Binding
ctrl (Char -> Binding
key Char
'u') ]
        KeyEvent
FileBrowserListHalfPageDownEvent -> [ Binding -> Binding
ctrl (Char -> Binding
key Char
'd') ]
        KeyEvent
FileBrowserListTopEvent          -> [ Char -> Binding
key Char
'g', Key -> Binding
kb Key
Vty.KHome, Binding -> Binding
meta (Binding -> Binding) -> Binding -> Binding
forall a b. (a -> b) -> a -> b
$ Char -> Binding
key Char
'<' ]
        KeyEvent
FileBrowserListBottomEvent       -> [ Char -> Binding
key Char
'G', Key -> Binding
kb Key
Vty.KEnd, Binding -> Binding
meta (Binding -> Binding) -> Binding -> Binding
forall a b. (a -> b) -> a -> b
$ Char -> Binding
key Char
'>' ]
        KeyEvent
FileBrowserListNextEvent         -> [ Char -> Binding
key Char
'j', Binding -> Binding
ctrl (Char -> Binding
key Char
'n'), Key -> Binding
kb Key
Vty.KDown ]
        KeyEvent
FileBrowserListPrevEvent         -> [ Char -> Binding
key Char
'k', Binding -> Binding
ctrl (Char -> Binding
key Char
'p'), Key -> Binding
kb Key
Vty.KUp ]
        KeyEvent
FormSubmitEvent               -> [ Key -> Binding
kb Key
Vty.KEnter ]
        KeyEvent
NextTeamEvent                 -> [ Binding -> Binding
ctrl (Key -> Binding
kb Key
Vty.KRight) ]
        KeyEvent
PrevTeamEvent                 -> [ Binding -> Binding
ctrl (Key -> Binding
kb Key
Vty.KLeft) ]
        KeyEvent
MoveCurrentTeamLeftEvent      -> [ ]
        KeyEvent
MoveCurrentTeamRightEvent     -> [ ]

-- | Given a configuration, we want to check it for internal consistency
-- (i.e. that a given keybinding isn't associated with multiple events
-- which both need to get generated in the same UI mode) and also for
-- basic usability (i.e. we shouldn't be binding events which can appear
-- in the main UI to a key like @e@, which would prevent us from being
-- able to type messages containing an @e@ in them!
ensureKeybindingConsistency :: KeyConfig -> [(T.Text, [KeyEventHandler])] -> Either String ()
ensureKeybindingConsistency :: KeyConfig -> [(Text, [KeyEventHandler])] -> Either String ()
ensureKeybindingConsistency KeyConfig
kc [(Text, [KeyEventHandler])]
modeMaps = ([(Binding, (Bool, KeyEvent))] -> Either String ())
-> [[(Binding, (Bool, KeyEvent))]] -> Either String ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ [(Binding, (Bool, KeyEvent))] -> Either String ()
checkGroup [[(Binding, (Bool, KeyEvent))]]
allBindings
  where
    -- This is a list of lists, grouped by keybinding, of all the
    -- keybinding/event associations that are going to be used with the
    -- provided key configuration.
    allBindings :: [[(Binding, (Bool, KeyEvent))]]
allBindings = ((Binding, (Bool, KeyEvent)) -> Binding)
-> [(Binding, (Bool, KeyEvent))] -> [[(Binding, (Bool, KeyEvent))]]
forall b a. Ord b => (a -> b) -> [a] -> [[a]]
groupWith (Binding, (Bool, KeyEvent)) -> Binding
forall a b. (a, b) -> a
fst ([(Binding, (Bool, KeyEvent))] -> [[(Binding, (Bool, KeyEvent))]])
-> [(Binding, (Bool, KeyEvent))] -> [[(Binding, (Bool, KeyEvent))]]
forall a b. (a -> b) -> a -> b
$ [[(Binding, (Bool, KeyEvent))]] -> [(Binding, (Bool, KeyEvent))]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [ case KeyEvent -> KeyConfig -> Maybe BindingState
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup KeyEvent
ev KeyConfig
kc of
          Maybe BindingState
Nothing -> [Binding] -> [(Bool, KeyEvent)] -> [(Binding, (Bool, KeyEvent))]
forall a b. [a] -> [b] -> [(a, b)]
zip (KeyEvent -> [Binding]
defaultBindings KeyEvent
ev) ((Bool, KeyEvent) -> [(Bool, KeyEvent)]
forall a. a -> [a]
repeat (Bool
False, KeyEvent
ev))
          Just (BindingList [Binding]
bs) -> [Binding] -> [(Bool, KeyEvent)] -> [(Binding, (Bool, KeyEvent))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Binding]
bs ((Bool, KeyEvent) -> [(Bool, KeyEvent)]
forall a. a -> [a]
repeat (Bool
True, KeyEvent
ev))
          Just BindingState
Unbound -> []
      | KeyEvent
ev <- [KeyEvent]
allEvents
      ]

    -- The invariant here is that each call to checkGroup is made with a
    -- list where the first element of every list is the same binding.
    -- The Bool value in these is True if the event was associated with
    -- the binding by the user, and False if it's a Matterhorn default.
    checkGroup :: [(Binding, (Bool, KeyEvent))] -> Either String ()
    checkGroup :: [(Binding, (Bool, KeyEvent))] -> Either String ()
checkGroup [] = String -> Either String ()
forall a. HasCallStack => String -> a
error String
"[ensureKeybindingConsistency: unreachable]"
    checkGroup evs :: [(Binding, (Bool, KeyEvent))]
evs@((Binding
b, (Bool, KeyEvent)
_):[(Binding, (Bool, KeyEvent))]
_) = do

      -- We find out which modes an event can be used in and then invert
      -- the map, so this is a map from mode to the events contains
      -- which are bound by the binding included above.
      let modesFor :: M.Map T.Text [(Bool, KeyEvent)]
          modesFor :: Map Text [(Bool, KeyEvent)]
modesFor = ([(Bool, KeyEvent)] -> [(Bool, KeyEvent)] -> [(Bool, KeyEvent)])
-> [Map Text [(Bool, KeyEvent)]] -> Map Text [(Bool, KeyEvent)]
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
(a -> a -> a) -> f (Map k a) -> Map k a
M.unionsWith [(Bool, KeyEvent)] -> [(Bool, KeyEvent)] -> [(Bool, KeyEvent)]
forall a. [a] -> [a] -> [a]
(++)
            [ [(Text, [(Bool, KeyEvent)])] -> Map Text [(Bool, KeyEvent)]
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [ (Text
m, [(Bool
i, KeyEvent
ev)]) | Text
m <- KeyEvent -> [Text]
modeMap KeyEvent
ev ]
            | (Binding
_, (Bool
i, KeyEvent
ev)) <- [(Binding, (Bool, KeyEvent))]
evs
            ]

      -- If there is ever a situation where the same key is bound to two
      -- events which can appear in the same mode, then we want to throw
      -- an error, and also be informative about why. It is still okay
      -- to bind the same key to two events, so long as those events
      -- never appear in the same UI mode.
      [(Text, [(Bool, KeyEvent)])]
-> ((Text, [(Bool, KeyEvent)]) -> Either String ())
-> Either String ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map Text [(Bool, KeyEvent)] -> [(Text, [(Bool, KeyEvent)])]
forall k a. Map k a -> [(k, a)]
M.assocs Map Text [(Bool, KeyEvent)]
modesFor) (((Text, [(Bool, KeyEvent)]) -> Either String ())
 -> Either String ())
-> ((Text, [(Bool, KeyEvent)]) -> Either String ())
-> Either String ()
forall a b. (a -> b) -> a -> b
$ \ (Text
_, [(Bool, KeyEvent)]
vs) ->
         Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([(Bool, KeyEvent)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Bool, KeyEvent)]
vs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
           String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
             String
"Multiple overlapping key events bound to `" String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
             Text -> String
T.unpack (Binding -> Text
ppBinding Binding
b) String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
             String
"`:\n" String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
             [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [ String
" - `"
                      , Text -> String
T.unpack (KeyEvent -> Text
keyEventName KeyEvent
ev)
                      , String
"` "
                      , if Bool
isFromUser
                          then String
"(via user configuration)"
                          else String
"(matterhorn default)"
                      , String
"\n"
                      ]
                    | (Bool
isFromUser, KeyEvent
ev) <- [(Bool, KeyEvent)]
vs
                    ]

      -- Check for overlap a set of built-in keybindings when we're in a
      -- mode where the user is typing. (These are perfectly fine when
      -- we're in other modes.)
      Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
"main" Text -> Map Text [(Bool, KeyEvent)] -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` Map Text [(Bool, KeyEvent)]
modesFor Bool -> Bool -> Bool
&& Binding -> Bool
isBareBinding Binding
b) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$ do
        String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
          [ String
"The keybinding `"
          , Text -> String
T.unpack (Binding -> Text
ppBinding Binding
b)
          , String
"` is bound to the "
          , case ((Binding, (Bool, KeyEvent)) -> String)
-> [(Binding, (Bool, KeyEvent))] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (KeyEvent -> String
ppEvent (KeyEvent -> String)
-> ((Binding, (Bool, KeyEvent)) -> KeyEvent)
-> (Binding, (Bool, KeyEvent))
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, KeyEvent) -> KeyEvent
forall a b. (a, b) -> b
snd ((Bool, KeyEvent) -> KeyEvent)
-> ((Binding, (Bool, KeyEvent)) -> (Bool, KeyEvent))
-> (Binding, (Bool, KeyEvent))
-> KeyEvent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Binding, (Bool, KeyEvent)) -> (Bool, KeyEvent)
forall a b. (a, b) -> b
snd) [(Binding, (Bool, KeyEvent))]
evs of
              [] -> ShowS
forall a. HasCallStack => String -> a
error String
"unreachable"
              [String
e] -> String
"event " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
e
              [String]
es  -> String
"events " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" and " [String]
es
          , String
"\n"
          , String
"This is probably not what you want, as it will interfere "
          , String
"with the ability to write messages!\n"
          ]

    -- Events get some nice formatting!
    ppEvent :: KeyEvent -> String
ppEvent KeyEvent
ev = String
"`" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
T.unpack (KeyEvent -> Text
keyEventName KeyEvent
ev) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"`"

    -- This check should get more nuanced, but as a first approximation,
    -- we shouldn't bind to any bare character key in the main mode.
    isBareBinding :: Binding -> Bool
isBareBinding (Binding [] (Vty.KChar {})) = Bool
True
    isBareBinding Binding
_ = Bool
False

    -- We generate the which-events-are-valid-in-which-modes map from
    -- our actual keybinding set, so this should never get out of date.
    modeMap :: KeyEvent -> [T.Text]
    modeMap :: KeyEvent -> [Text]
modeMap KeyEvent
ev =
      let matches :: KeyHandler -> Bool
matches KeyHandler
kh = KeyEvent -> KeyEventTrigger
ByEvent KeyEvent
ev KeyEventTrigger -> KeyEventTrigger -> Bool
forall a. Eq a => a -> a -> Bool
== (KeyEventHandler -> KeyEventTrigger
kehEventTrigger (KeyEventHandler -> KeyEventTrigger)
-> KeyEventHandler -> KeyEventTrigger
forall a b. (a -> b) -> a -> b
$ KeyHandler -> KeyEventHandler
khHandler KeyHandler
kh)
      in [ Text
mode
         | (Text
mode, [KeyEventHandler]
handlers) <- [(Text, [KeyEventHandler])]
modeMaps
         , let pairs :: [(Event, KeyHandler)]
pairs = [KeyEventHandler] -> KeyConfig -> [(Event, KeyHandler)]
keyHandlerMapPairs [KeyEventHandler]
handlers KeyConfig
kc
           in Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [KeyHandler] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([KeyHandler] -> Bool) -> [KeyHandler] -> Bool
forall a b. (a -> b) -> a -> b
$ (KeyHandler -> Bool) -> [KeyHandler] -> [KeyHandler]
forall a. (a -> Bool) -> [a] -> [a]
filter KeyHandler -> Bool
matches ([KeyHandler] -> [KeyHandler]) -> [KeyHandler] -> [KeyHandler]
forall a b. (a -> b) -> a -> b
$ (Event, KeyHandler) -> KeyHandler
forall a b. (a, b) -> b
snd ((Event, KeyHandler) -> KeyHandler)
-> [(Event, KeyHandler)] -> [KeyHandler]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Event, KeyHandler)]
pairs
         ]