Incorporate keybinding machinery from Matterhorn

This commit is contained in:
Jonathan Daugherty 2022-07-10 09:37:16 -07:00
parent b23c40d82a
commit 04676115e6
7 changed files with 604 additions and 0 deletions

View File

@ -88,6 +88,12 @@ library
Brick.AttrMap Brick.AttrMap
Brick.BChan Brick.BChan
Brick.BorderMap Brick.BorderMap
Brick.Keybindings
Brick.Keybindings.KeyConfig
Brick.Keybindings.KeyEvents
Brick.Keybindings.KeyHandlerMap
Brick.Keybindings.Parse
Brick.Keybindings.Pretty
Brick.Focus Brick.Focus
Brick.Forms Brick.Forms
Brick.Main Brick.Main
@ -114,6 +120,7 @@ library
build-depends: base >= 4.9.0.0 && < 4.17.0.0, build-depends: base >= 4.9.0.0 && < 4.17.0.0,
vty >= 5.36, vty >= 5.36,
transformers, transformers,
bimap >= 0.5 && < 0.6,
data-clist >= 0.1, data-clist >= 0.1,
directory >= 1.2.5.0, directory >= 1.2.5.0,
dlist, dlist,

10
src/Brick/Keybindings.hs Normal file
View File

@ -0,0 +1,10 @@
module Brick.Keybindings
( module Brick.Keybindings.KeyEvents
, module Brick.Keybindings.KeyConfig
, module Brick.Keybindings.KeyHandlerMap
)
where
import Brick.Keybindings.KeyEvents
import Brick.Keybindings.KeyConfig
import Brick.Keybindings.KeyHandlerMap

View File

@ -0,0 +1,144 @@
module Brick.Keybindings.KeyConfig
( KeyConfig(keyConfigEvents)
, Binding(..)
, BindingState(..)
, newKeyConfig
, lookupKeyConfigBindings
-- * Specifying bindings
, ToBinding(..)
, key
, fn
, char
, meta
, ctrl
, shift
-- * Querying KeyConfigs
, getFirstDefaultBinding
, firstActiveBinding
, allDefaultBindings
)
where
import Control.Applicative ((<|>))
import qualified Data.Map.Strict as M
import Data.Maybe (fromMaybe)
import qualified Graphics.Vty as Vty
import Brick.Keybindings.KeyEvents
data Binding =
Binding { kbKey :: Vty.Key
, kbMods :: [Vty.Modifier]
} deriving (Eq, Show, Ord)
data BindingState =
BindingList [Binding]
| Unbound
deriving (Show, Eq, Ord)
-- | A configuration of custom key bindings. A 'KeyConfig' stores
-- everything needed to resolve a key event into one or more key
-- bindings. Make a 'KeyConfig' with 'newKeyConfig', then use it to
-- dispatch to 'KeyEventHandler's with 'mkKeybindings'.
data KeyConfig e =
KeyConfig { keyConfigBindingMap :: M.Map e BindingState
-- ^ The map of custom bindings for events with custom
-- bindings
, keyConfigEvents :: KeyEvents e
-- ^ The base mapping of events and their names that is
-- used in this configuration
, keyConfigDefaultBindings :: M.Map e [Binding]
-- ^ A mapping of events and their default key bindings,
-- if any
}
deriving (Show, Eq)
newKeyConfig :: (Ord e)
=> KeyEvents e
-- ^ The base mapping of key events to use
-> [(e, BindingState)]
-- ^ Custom bindings by key event, such as from a
-- configuration file
-> [(e, [Binding])]
-- ^ Default bindings by key event, such as from a
-- configuration file or embedded code
-> KeyConfig e
newKeyConfig evs bindings defaults =
KeyConfig { keyConfigBindingMap = M.fromList bindings
, keyConfigEvents = evs
, keyConfigDefaultBindings = M.fromList defaults
}
lookupKeyConfigBindings :: (Ord e) => KeyConfig e -> e -> Maybe BindingState
lookupKeyConfigBindings kc e = M.lookup e $ keyConfigBindingMap kc
getFirstDefaultBinding :: (Show e, Ord e) => KeyConfig e -> e -> Maybe Binding
getFirstDefaultBinding kc ev = do
bs <- M.lookup ev (keyConfigDefaultBindings kc)
case bs of
(b:_) -> Just b
_ -> Nothing
allDefaultBindings :: (Ord e) => KeyConfig e -> e -> [Binding]
allDefaultBindings kc ev =
fromMaybe [] $ M.lookup ev (keyConfigDefaultBindings kc)
firstActiveBinding :: (Show e, Ord e) => KeyConfig e -> e -> Maybe Binding
firstActiveBinding kc ev = foundBinding <|> defaultBinding
where
defaultBinding = getFirstDefaultBinding kc ev
foundBinding = do
bState <- lookupKeyConfigBindings kc ev
case bState of
BindingList (b:_) -> Just b
_ -> Nothing
-- | The class of types that can be converted into 'Binding's.
--
-- This is provided to make it easy to write and modify bindings in less
-- verbose ways.
class ToBinding a where
-- | Binding constructor.
toBinding :: a -> Binding
instance ToBinding Vty.Key where
toBinding k = Binding { kbMods = [], kbKey = k }
instance ToBinding Char where
toBinding = toBinding . Vty.KChar
instance ToBinding Binding where
toBinding = id
-- | Add Meta to a binding.
meta :: (ToBinding a) => a -> Binding
meta val =
let binding = toBinding val
in binding { kbMods = Vty.MMeta : kbMods binding }
-- | Add Ctrl to a binding.
ctrl :: (ToBinding a) => a -> Binding
ctrl val =
let binding = toBinding val
in binding { kbMods = Vty.MCtrl : kbMods binding }
-- | Add Shift to a binding.
shift :: (ToBinding a) => a -> Binding
shift val =
let binding = toBinding val
in binding { kbMods = Vty.MShift : kbMods binding }
-- | Make a binding from any Vty key.
key :: Vty.Key -> Binding
key = toBinding
-- | Make a binding from any character (subject to what the keyboard can
-- actually produce).
char :: Char -> Binding
char = toBinding
-- | Function key binding.
fn :: Int -> Binding
fn = toBinding . Vty.KFun

View File

@ -0,0 +1,26 @@
module Brick.Keybindings.KeyEvents
( KeyEvents
, keyEvents
, keyEventsList
, lookupKeyEvent
, keyEventName
)
where
import qualified Data.Bimap as B
import qualified Data.Text as T
data KeyEvents e = KeyEvents (B.Bimap T.Text e)
deriving (Eq, Show)
keyEvents :: (Ord e) => [(T.Text, e)] -> KeyEvents e
keyEvents pairs = KeyEvents $ B.fromList pairs
keyEventsList :: KeyEvents e -> [(T.Text, e)]
keyEventsList (KeyEvents m) = B.toList m
lookupKeyEvent :: (Ord e) => KeyEvents e -> T.Text -> Maybe e
lookupKeyEvent (KeyEvents m) name = B.lookup name m
keyEventName :: (Ord e) => KeyEvents e -> e -> Maybe T.Text
keyEventName (KeyEvents m) e = B.lookupR e m

View File

@ -0,0 +1,173 @@
module Brick.Keybindings.KeyHandlerMap
( KeyHandlerMap
, mkKeybindings
, lookupVtyEvent
, Handler(..)
, KeyHandler(..)
, KeyEventHandler(..)
, EventTrigger(..)
, onEvent
, onKey
, keyHandlerMapToList
, handleKeyboardEvent
)
where
import Brick
import Data.Maybe (fromJust)
import qualified Data.Bimap as B
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import qualified Graphics.Vty as Vty
import Brick.Keybindings.KeyConfig
-- | A set of handlers for specific keys with handlers that run in the
-- monad @m@.
newtype KeyHandlerMap e m = KeyHandlerMap (M.Map Binding (KeyHandler e m))
-- | An 'Handler' represents a handler implementation to be invoked in
-- response to some event.
--
-- In general, you should never need to make one of these manually.
-- Instead, use 'onEvent' and 'onKey'.
data Handler m =
EH { ehDescription :: T.Text
-- ^ The description of this handler's behavior.
, ehAction :: m ()
-- ^ The action to take when this handler is invoked.
}
-- | A handler for a specific key.
--
-- In general, you should never need to create one of these. The
-- internals are exposed to make inspection easy.
data KeyHandler e m =
KH { khHandler :: KeyEventHandler e m
-- ^ The handler to invoke. Note that this maintains the original
-- key abstract key event handler; this allows us to obtain
-- the original 'EventTrigger' for the 'KeyEventHandler' upon
-- which this 'KeyHandler' is built. This can be important for
-- keybinding consistency checks or collision checks as well as
-- help text generation.
, khKey :: Binding
-- ^ The specific key that should trigger this handler.
}
-- | Find a key handler that matches a Vty Event, if any.
lookupVtyEvent :: Vty.Event -> KeyHandlerMap e m -> Maybe (KeyHandler e m)
lookupVtyEvent (Vty.EvKey k mods) (KeyHandlerMap m) = M.lookup (Binding k mods) m
lookupVtyEvent _ _ = Nothing
-- | 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 no matching binding was
-- found (the fallback case).
handleKeyboardEvent :: (Monad m)
=> KeyHandlerMap e m
-- ^ The handler map to query for a handler for this
-- event.
-> Vty.Event
-- ^ The event to handle.
-> m Bool
handleKeyboardEvent handlerMap e = do
case lookupVtyEvent e handlerMap of
Just kh -> (ehAction $ kehHandler $ khHandler kh) >> return True
Nothing -> return False
-- | Build a 'KeyHandlerMap'.
--
-- This works by taking a list of abstract key event handlers and
-- building a map of event handlers based on specific Vty keys, using
-- the provided 'KeyConfig' to map between abstract key events and Vty
-- keys.
--
-- Once you have a 'KeyHandlerMap', you can dispatch a key event to it
-- and invoke the corresponding handler with 'handleKeyboardEvent'.
mkKeybindings :: (Ord e)
=> [KeyEventHandler e m]
-> KeyConfig e
-> KeyHandlerMap e m
mkKeybindings ks conf = KeyHandlerMap $ M.fromList $ buildKeyHandlerMapPairs ks conf
keyHandlerMapToList :: KeyHandlerMap e m
-> [(Binding, KeyHandler e m)]
keyHandlerMapToList (KeyHandlerMap m) = M.toList m
buildKeyHandlerMapPairs :: (Ord e)
=> [KeyEventHandler e m]
-> KeyConfig e
-> [(Binding, KeyHandler e m)]
buildKeyHandlerMapPairs ks conf = pairs
where
pairs = mkPair <$> handlers
mkPair h = (khKey h, h)
handlers = concat $ keyHandlersFromConfig conf <$> ks
keyHandlersFromConfig :: (Ord e)
=> KeyConfig e
-> KeyEventHandler e m
-> [KeyHandler e m]
keyHandlersFromConfig kc eh =
case kehEventTrigger eh of
Static binding ->
[ KH eh binding ]
ByEvent ev ->
[ KH eh b | b <- allBindings ]
where allBindings | Just (BindingList ks) <- lookupKeyConfigBindings kc ev = ks
| Just Unbound <- lookupKeyConfigBindings kc ev = []
| otherwise = allDefaultBindings kc ev
mkHandler :: T.Text -> m () -> Handler m
mkHandler msg action =
EH { ehDescription = msg
, ehAction = action
}
-- | Specify a handler for the specified key event.
onEvent :: e
-- ^ The key event whose bindings should trigger this handler.
-> T.Text
-- ^ The description of the handler.
-> m ()
-- ^ The handler to invoke.
-> KeyEventHandler e m
onEvent ev msg action =
KEH { kehHandler = mkHandler msg action
, kehEventTrigger = ByEvent ev
}
-- | Specify a handler for the specified key.
onKey :: (ToBinding a)
=> a
-- ^ The binding that should trigger this handler.
-> T.Text
-- ^ The description of the handler.
-> m ()
-- ^ The handler to invoke.
-> KeyEventHandler e m
onKey b msg action =
KEH { kehHandler = mkHandler msg action
, kehEventTrigger = Static $ toBinding b
}
-- | A trigger for an event handler.
data EventTrigger e =
Static Binding
-- ^ The key event is always triggered by a specific key.
| ByEvent e
-- ^ The trigger is an abstract key event.
deriving (Show, Eq, Ord)
-- | A handler for an abstract key event.
--
-- In general, you should never need to create these manually. Instead,
-- use 'onEvent' and 'onKey'.
data KeyEventHandler e m =
KEH { kehHandler :: Handler m
-- ^ The handler to invoke.
, kehEventTrigger :: EventTrigger e
-- ^ The trigger for the handler.
}

View File

@ -0,0 +1,123 @@
{-# LANGUAGE OverloadedStrings #-}
module Brick.Keybindings.Parse
( parseBinding
, parseBindingList
, ppBinding
, ppMaybeBinding
, ppKey
, ppModifier
)
where
import qualified Data.Text as T
import qualified Graphics.Vty as Vty
import Text.Read (readMaybe)
import Brick.Keybindings.KeyConfig
parseBindingList :: T.Text -> Either String BindingState
parseBindingList t =
if T.toLower t == "unbound"
then return Unbound
else BindingList <$> mapM (parseBinding . T.strip) (T.splitOn "," t)
parseBinding :: T.Text -> Either String Binding
parseBinding s = go (T.splitOn "-" $ T.toLower s) []
where go [k] mods = do
k' <- pKey k
return Binding { kbMods = mods, kbKey = k' }
go (k:ks) mods = do
m <- case k of
"s" -> return Vty.MShift
"shift" -> return Vty.MShift
"m" -> return Vty.MMeta
"meta" -> return Vty.MMeta
"a" -> return Vty.MAlt
"alt" -> return Vty.MAlt
"c" -> return Vty.MCtrl
"ctrl" -> return Vty.MCtrl
"control" -> return Vty.MCtrl
_ -> Left ("Unknown modifier prefix: " ++ show k)
go ks (m:mods)
go [] _ = Left "Empty keybinding not allowed"
pKey "esc" = return Vty.KEsc
pKey "backspace" = return Vty.KBS
pKey "enter" = return Vty.KEnter
pKey "left" = return Vty.KLeft
pKey "right" = return Vty.KRight
pKey "up" = return Vty.KUp
pKey "down" = return Vty.KDown
pKey "upleft" = return Vty.KUpLeft
pKey "upright" = return Vty.KUpRight
pKey "downleft" = return Vty.KDownLeft
pKey "downright" = return Vty.KDownRight
pKey "center" = return Vty.KCenter
pKey "backtab" = return Vty.KBackTab
pKey "printscreen" = return Vty.KPrtScr
pKey "pause" = return Vty.KPause
pKey "insert" = return Vty.KIns
pKey "home" = return Vty.KHome
pKey "pgup" = return Vty.KPageUp
pKey "del" = return Vty.KDel
pKey "end" = return Vty.KEnd
pKey "pgdown" = return Vty.KPageDown
pKey "begin" = return Vty.KBegin
pKey "menu" = return Vty.KMenu
pKey "space" = return (Vty.KChar ' ')
pKey "tab" = return (Vty.KChar '\t')
pKey t
| Just (c, "") <- T.uncons t =
return (Vty.KChar c)
| Just n <- T.stripPrefix "f" t =
case readMaybe (T.unpack n) of
Nothing -> Left ("Unknown keybinding: " ++ show t)
Just i -> return (Vty.KFun i)
| otherwise = Left ("Unknown keybinding: " ++ show t)
ppBinding :: Binding -> T.Text
ppBinding (Binding k mods) =
T.intercalate "-" $ (ppModifier <$> mods) <> [ppKey k]
ppMaybeBinding :: Maybe Binding -> T.Text
ppMaybeBinding Nothing =
"(no binding)"
ppMaybeBinding (Just b) =
ppBinding b
ppKey :: Vty.Key -> T.Text
ppKey (Vty.KChar c) = ppChar c
ppKey (Vty.KFun n) = "F" <> (T.pack $ show n)
ppKey Vty.KBackTab = "BackTab"
ppKey Vty.KEsc = "Esc"
ppKey Vty.KBS = "Backspace"
ppKey Vty.KEnter = "Enter"
ppKey Vty.KUp = "Up"
ppKey Vty.KDown = "Down"
ppKey Vty.KLeft = "Left"
ppKey Vty.KRight = "Right"
ppKey Vty.KHome = "Home"
ppKey Vty.KEnd = "End"
ppKey Vty.KPageUp = "PgUp"
ppKey Vty.KPageDown = "PgDown"
ppKey Vty.KDel = "Del"
ppKey Vty.KUpLeft = "UpLeft"
ppKey Vty.KUpRight = "UpRight"
ppKey Vty.KDownLeft = "DownLeft"
ppKey Vty.KDownRight = "DownRight"
ppKey Vty.KCenter = "Center"
ppKey Vty.KPrtScr = "PrintScreen"
ppKey Vty.KPause = "Pause"
ppKey Vty.KIns = "Insert"
ppKey Vty.KBegin = "Begin"
ppKey Vty.KMenu = "Menu"
ppChar :: Char -> T.Text
ppChar '\t' = "Tab"
ppChar ' ' = "Space"
ppChar c = T.singleton c
ppModifier :: Vty.Modifier -> T.Text
ppModifier Vty.MMeta = "M"
ppModifier Vty.MAlt = "A"
ppModifier Vty.MCtrl = "C"
ppModifier Vty.MShift = "S"

View File

@ -0,0 +1,121 @@
{-# LANGUAGE OverloadedStrings #-}
module Brick.Keybindings.Pretty
( keybindingTextTable
, keybindingMarkdownTable
, keybindingHelpWidget
)
where
import Brick
import Data.Maybe (fromJust)
import qualified Data.Text as T
import Brick.Keybindings.Parse
import Brick.Keybindings.KeyEvents
import Brick.Keybindings.KeyConfig
import Brick.Keybindings.KeyHandlerMap
data TextHunk = Verbatim T.Text
| Comment T.Text
keybindingMarkdownTable :: (Ord e) => KeyConfig e -> [(T.Text, [KeyEventHandler e m])] -> T.Text
keybindingMarkdownTable kc sections = title <> keybindSectionStrings
where title = "# Keybindings\n"
keybindSectionStrings = T.concat $ sectionText <$> sections
sectionText = mkKeybindEventSectionHelp kc keybindEventHelpMarkdown T.unlines mkHeading
mkHeading n =
"\n# " <> n <>
"\n| Keybinding | Event Name | Description |" <>
"\n| ---------- | ---------- | ----------- |"
keybindingTextTable :: (Ord e) => KeyConfig e -> [(T.Text, [KeyEventHandler e m])] -> T.Text
keybindingTextTable kc sections = title <> keybindSectionStrings
where title = "Keybindings\n===========\n"
keybindSectionStrings = T.concat $ sectionText <$> sections
sectionText = mkKeybindEventSectionHelp kc (keybindEventHelpText keybindingWidth eventNameWidth) T.unlines mkHeading
keybindingWidth = 15
eventNameWidth = 30
mkHeading n =
"\n" <> n <>
"\n" <> (T.replicate (T.length n) "=")
keybindEventHelpText :: Int -> Int -> (TextHunk, T.Text, [TextHunk]) -> T.Text
keybindEventHelpText width eventNameWidth (evName, desc, evs) =
let getText (Comment s) = s
getText (Verbatim s) = s
in padTo width (T.intercalate ", " $ getText <$> evs) <> " " <>
padTo eventNameWidth (getText evName) <> " " <>
desc
padTo :: Int -> T.Text -> T.Text
padTo n s = s <> T.replicate (n - T.length s) " "
mkKeybindEventSectionHelp :: (Ord e)
=> KeyConfig e
-> ((TextHunk, T.Text, [TextHunk]) -> a)
-> ([a] -> a)
-> (T.Text -> a)
-> (T.Text, [KeyEventHandler e m])
-> a
mkKeybindEventSectionHelp kc mkKeybindHelpFunc vertCat mkHeading (sectionName, kbs) =
vertCat $ (mkHeading sectionName) :
(mkKeybindHelpFunc <$> (mkKeybindEventHelp kc <$> kbs))
keybindEventHelpMarkdown :: (TextHunk, T.Text, [TextHunk]) -> T.Text
keybindEventHelpMarkdown (evName, desc, evs) =
let quote s = "`" <> s <> "`"
format (Comment s) = s
format (Verbatim s) = quote s
name = case evName of
Comment s -> s
Verbatim s -> quote s
in "| " <> (T.intercalate ", " $ format <$> evs) <>
" | " <> name <>
" | " <> desc <>
" |"
mkKeybindEventHelp :: (Ord e)
=> KeyConfig e
-> KeyEventHandler e m
-> (TextHunk, T.Text, [TextHunk])
mkKeybindEventHelp kc h =
let trig = kehEventTrigger h
unbound = [Comment "(unbound)"]
(label, evText) = case trig of
Static binding -> (Comment "(non-customizable key)", [Verbatim $ ppBinding binding])
ByEvent ev ->
let name = fromJust $ keyEventName (keyConfigEvents kc) ev
in case lookupKeyConfigBindings kc ev of
Nothing ->
if not (null (allDefaultBindings kc ev))
then (Verbatim name, Verbatim <$> ppBinding <$> allDefaultBindings kc ev)
else (Verbatim name, unbound)
Just Unbound ->
(Verbatim name, unbound)
Just (BindingList bs) ->
let result = if not (null bs)
then Verbatim <$> ppBinding <$> bs
else unbound
in (Verbatim name, result)
in (label, ehDescription $ kehHandler h, evText)
keybindingHelpWidget :: (Ord e)
=> KeyConfig e
-> (T.Text -> Widget n)
-> (T.Text, [KeyEventHandler e m])
-> Widget n
keybindingHelpWidget kc = mkKeybindEventSectionHelp kc keybindEventHelpWidget vBox
keybindEventHelpWidget :: (TextHunk, T.Text, [TextHunk]) -> Widget n
keybindEventHelpWidget (evName, desc, evs) =
let evText = T.intercalate ", " (getText <$> evs)
getText (Comment s) = s
getText (Verbatim s) = s
label = case evName of
Comment s -> txt $ "; " <> s
Verbatim s -> txt s -- TODO: was: emph $ txt s
in padBottom (Pad 1) $
vBox [ txtWrap ("; " <> desc)
, label <+> txt (" = " <> evText)
]