mirror of
https://github.com/jtdaugherty/brick.git
synced 2024-11-26 09:06:56 +03:00
Incorporate keybinding machinery from Matterhorn
This commit is contained in:
parent
b23c40d82a
commit
04676115e6
@ -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
10
src/Brick/Keybindings.hs
Normal 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
|
144
src/Brick/Keybindings/KeyConfig.hs
Normal file
144
src/Brick/Keybindings/KeyConfig.hs
Normal 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
|
26
src/Brick/Keybindings/KeyEvents.hs
Normal file
26
src/Brick/Keybindings/KeyEvents.hs
Normal 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
|
173
src/Brick/Keybindings/KeyHandlerMap.hs
Normal file
173
src/Brick/Keybindings/KeyHandlerMap.hs
Normal 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.
|
||||||
|
}
|
||||||
|
|
123
src/Brick/Keybindings/Parse.hs
Normal file
123
src/Brick/Keybindings/Parse.hs
Normal 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"
|
121
src/Brick/Keybindings/Pretty.hs
Normal file
121
src/Brick/Keybindings/Pretty.hs
Normal 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)
|
||||||
|
]
|
Loading…
Reference in New Issue
Block a user