module Matterhorn.Events.Keybindings
( defaultBindings
, lookupKeybinding
, getFirstDefaultBinding
, mkKb
, staticKb
, mkKeybindings
, handleKeyboardEvent
, EventHandler(..)
, KeyHandler(..)
, KeyEventHandler(..)
, KeyEventTrigger(..)
, KeyHandlerMap(..)
, 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
data EventHandler =
EH { ehDescription :: Text
, ehAction :: MH ()
}
data KeyEventTrigger =
Static Vty.Event
| ByEvent KeyEvent
deriving (Show, Eq, Ord)
data KeyEventHandler =
KEH { kehHandler :: EventHandler
, kehEventTrigger :: KeyEventTrigger
}
data KeyHandler =
KH { khHandler :: KeyEventHandler
, khKey :: Vty.Event
}
newtype KeyHandlerMap = KeyHandlerMap (M.Map Vty.Event KeyHandler)
lookupKeybinding :: Vty.Event -> KeyHandlerMap -> Maybe KeyHandler
lookupKeybinding e (KeyHandlerMap m) = M.lookup e m
handleKeyboardEvent :: (KeyConfig -> KeyHandlerMap)
-> (Vty.Event -> MH ())
-> Vty.Event
-> MH Bool
handleKeyboardEvent mkKeyMap fallthrough e = do
conf <- use (csResources.crConfiguration)
let keyMap = mkKeyMap (configUserKeys conf)
case lookupKeybinding e keyMap of
Just kh -> (ehAction $ kehHandler $ khHandler kh) >> return True
Nothing -> fallthrough e >> return False
mkHandler :: Text -> MH () -> EventHandler
mkHandler msg action =
EH { ehDescription = msg
, ehAction = action
}
mkKb :: KeyEvent -> Text -> MH () -> KeyEventHandler
mkKb ev msg action =
KEH { kehHandler = mkHandler msg action
, kehEventTrigger = ByEvent ev
}
keyHandlerFromConfig :: KeyConfig -> KeyEventHandler -> [KeyHandler]
keyHandlerFromConfig conf eh =
case kehEventTrigger eh of
Static key ->
[ KH eh key ]
ByEvent ev ->
[ KH eh (bindingToEvent b) | b <- allBindings ]
where allBindings | Just (BindingList ks) <- M.lookup ev conf = ks
| Just Unbound <- M.lookup ev conf = []
| otherwise = defaultBindings ev
staticKb :: Text -> Vty.Event -> MH () -> KeyEventHandler
staticKb msg event action =
KEH { kehHandler = mkHandler msg action
, kehEventTrigger = Static event
}
mkKeybindings :: [KeyEventHandler] -> KeyConfig -> KeyHandlerMap
mkKeybindings ks conf = KeyHandlerMap $ M.fromList pairs
where
pairs = mkPair <$> handlers
mkPair h = (khKey h, h)
handlers = concat $ keyHandlerFromConfig conf <$> ks
bindingToEvent :: Binding -> Vty.Event
bindingToEvent binding =
Vty.EvKey (kbKey binding) (kbMods binding)
getFirstDefaultBinding :: KeyEvent -> Binding
getFirstDefaultBinding ev =
case defaultBindings ev of
[] -> error $ "BUG: event " <> show ev <> " has no default bindings!"
(b:_) -> b
defaultBindings :: KeyEvent -> [Binding]
defaultBindings ev =
let meta binding = binding { kbMods = Vty.MMeta : kbMods binding }
ctrl binding = binding { kbMods = Vty.MCtrl : kbMods binding }
shift binding = binding { kbMods = Vty.MShift : kbMods binding }
kb k = Binding { kbMods = [], kbKey = k }
key c = Binding { kbMods = [], kbKey = Vty.KChar c }
fn n = Binding { kbMods = [], kbKey = Vty.KFun n }
in case ev of
VtyRefreshEvent -> [ ctrl (key 'l') ]
ShowHelpEvent -> [ fn 1 ]
EnterSelectModeEvent -> [ ctrl (key 's') ]
ReplyRecentEvent -> [ ctrl (key 'r') ]
ToggleMessagePreviewEvent -> [ meta (key 'p') ]
InvokeEditorEvent -> [ meta (key 'k') ]
EnterFastSelectModeEvent -> [ ctrl (key 'g') ]
QuitEvent -> [ ctrl (key 'q') ]
NextChannelEvent -> [ ctrl (key 'n') ]
PrevChannelEvent -> [ ctrl (key 'p') ]
NextChannelEventAlternate -> [ kb Vty.KDown ]
PrevChannelEventAlternate -> [ kb Vty.KUp ]
NextUnreadChannelEvent -> [ meta (key 'a') ]
ShowAttachmentListEvent -> [ ctrl (key 'x') ]
NextUnreadUserOrChannelEvent -> [ ]
LastChannelEvent -> [ meta (key 's') ]
EnterOpenURLModeEvent -> [ ctrl (key 'o') ]
ClearUnreadEvent -> [ meta (key 'l') ]
ToggleMultiLineEvent -> [ meta (key 'e') ]
EnterFlaggedPostsEvent -> [ meta (key '8') ]
ToggleChannelListVisibleEvent -> [ fn 2 ]
ToggleExpandedChannelTopicsEvent -> [ fn 3 ]
SelectNextTabEvent -> [ key '\t' ]
SelectPreviousTabEvent -> [ kb Vty.KBackTab ]
LoadMoreEvent -> [ ctrl (key 'b') ]
ScrollUpEvent -> [ kb Vty.KUp ]
ScrollDownEvent -> [ kb Vty.KDown ]
ScrollLeftEvent -> [ kb Vty.KLeft ]
ScrollRightEvent -> [ kb Vty.KRight ]
PageUpEvent -> [ kb Vty.KPageUp ]
PageDownEvent -> [ kb Vty.KPageDown ]
PageLeftEvent -> [ shift (kb Vty.KLeft) ]
PageRightEvent -> [ shift (kb Vty.KRight) ]
ScrollTopEvent -> [ kb Vty.KHome ]
ScrollBottomEvent -> [ kb Vty.KEnd ]
SelectOldestMessageEvent -> [ shift (kb Vty.KHome) ]
SelectUpEvent -> [ key 'k', kb Vty.KUp ]
SelectDownEvent -> [ key 'j', kb Vty.KDown ]
ActivateListItemEvent -> [ kb Vty.KEnter ]
SearchSelectUpEvent -> [ ctrl (key 'p'), kb Vty.KUp ]
SearchSelectDownEvent -> [ ctrl (key 'n'), kb Vty.KDown ]
ViewMessageEvent -> [ key 'v' ]
FillGapEvent -> [ kb Vty.KEnter ]
FlagMessageEvent -> [ key 'f' ]
PinMessageEvent -> [ key 'p' ]
YankMessageEvent -> [ key 'y' ]
YankWholeMessageEvent -> [ key 'Y' ]
DeleteMessageEvent -> [ key 'd' ]
EditMessageEvent -> [ key 'e' ]
ReplyMessageEvent -> [ key 'r' ]
ReactToMessageEvent -> [ key 'a' ]
OpenMessageURLEvent -> [ key 'o' ]
AttachmentListAddEvent -> [ key 'a' ]
AttachmentListDeleteEvent -> [ key 'd' ]
AttachmentOpenEvent -> [ key 'o' ]
CancelEvent -> [ kb Vty.KEsc, ctrl (key 'c') ]
EditorBolEvent -> [ ctrl (key 'a') ]
EditorEolEvent -> [ ctrl (key 'e') ]
EditorTransposeCharsEvent -> [ ctrl (key 't') ]
EditorDeleteCharacter -> [ ctrl (key 'd') ]
EditorKillToBolEvent -> [ ctrl (key 'u') ]
EditorKillToEolEvent -> [ ctrl (key 'k') ]
EditorPrevCharEvent -> [ ctrl (key 'b') ]
EditorNextCharEvent -> [ ctrl (key 'f') ]
EditorPrevWordEvent -> [ meta (key 'b') ]
EditorNextWordEvent -> [ meta (key 'f') ]
EditorDeleteNextWordEvent -> [ meta (key 'd') ]
EditorDeletePrevWordEvent -> [ ctrl (key 'w'), meta (kb Vty.KBS) ]
EditorHomeEvent -> [ kb Vty.KHome ]
EditorEndEvent -> [ kb Vty.KEnd ]
EditorYankEvent -> [ ctrl (key 'y') ]
FormSubmitEvent -> [ kb Vty.KEnter ]
ensureKeybindingConsistency :: KeyConfig -> [(String, KeyConfig -> KeyHandlerMap)] -> Either String ()
ensureKeybindingConsistency kc modeMaps = mapM_ checkGroup allBindings
where
allBindings = groupWith fst $ concat
[ case M.lookup ev kc of
Nothing -> zip (defaultBindings ev) (repeat (False, ev))
Just (BindingList bs) -> zip bs (repeat (True, ev))
Just Unbound -> []
| ev <- allEvents
]
checkGroup :: [(Binding, (Bool, KeyEvent))] -> Either String ()
checkGroup [] = error "[ensureKeybindingConsistency: unreachable]"
checkGroup evs@((b, _):_) = do
let modesFor :: M.Map String [(Bool, KeyEvent)]
modesFor = M.unionsWith (++)
[ M.fromList [ (m, [(i, ev)]) | m <- modeMap ev ]
| (_, (i, ev)) <- evs
]
forM_ (M.assocs modesFor) $ \ (_, vs) ->
when (length vs > 1) $
Left $ concat $
"Multiple overlapping events bound to `" :
T.unpack (ppBinding b) :
"`:\n" :
concat [ [ " - `"
, T.unpack (keyEventName ev)
, "` "
, if isFromUser
then "(via user override)"
else "(matterhorn default)"
, "\n"
]
| (isFromUser, ev) <- vs
]
when ("main" `M.member` modesFor && isBareBinding b) $ do
Left $ concat $
[ "The keybinding `"
, T.unpack (ppBinding b)
, "` is bound to the "
, case map (ppEvent . snd . snd) evs of
[] -> error "unreachable"
[e] -> "event " ++ e
es -> "events " ++ intercalate " and " es
, "\n"
, "This is probably not what you want, as it will interfere "
, "with the ability to write messages!\n"
]
ppEvent ev = "`" ++ T.unpack (keyEventName ev) ++ "`"
isBareBinding (Binding [] (Vty.KChar {})) = True
isBareBinding _ = False
modeMap :: KeyEvent -> [String]
modeMap ev =
let matches kh = ByEvent ev == (kehEventTrigger $ khHandler kh)
in [ mode
| (mode, mkBindings) <- modeMaps
, let KeyHandlerMap m = mkBindings kc
in not $ null $ M.filter matches m
]