{-# LANGUAGE OverloadedStrings #-}
module Brick.Keybindings.Pretty
(
keybindingTextTable
, keybindingMarkdownTable
, keybindingHelpWidget
, ppBinding
, ppMaybeBinding
, ppKey
, ppModifier
, keybindingHelpBaseAttr
, eventNameAttr
, eventDescriptionAttr
, keybindingAttr
)
where
import Brick
import Data.List (sort, intersperse)
import Data.Maybe (fromJust)
#if !(MIN_VERSION_base(4,11,0))
import Data.Monoid ((<>))
#endif
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Graphics.Vty as Vty
import Brick.Keybindings.KeyEvents
import Brick.Keybindings.KeyConfig
import Brick.Keybindings.KeyDispatcher
data TextHunk = Verbatim T.Text
| T.Text
keybindingMarkdownTable :: (Ord k)
=> KeyConfig k
-> [(T.Text, [KeyEventHandler k m])]
-> T.Text
keybindingMarkdownTable :: forall k (m :: * -> *).
Ord k =>
KeyConfig k -> [(Text, [KeyEventHandler k m])] -> Text
keybindingMarkdownTable KeyConfig k
kc [(Text, [KeyEventHandler k m])]
sections = Text
title Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
keybindSectionStrings
where title :: Text
title = Text
"# Keybindings\n"
keybindSectionStrings :: Text
keybindSectionStrings = [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text, [KeyEventHandler k m]) -> Text
forall {m :: * -> *}. (Text, [KeyEventHandler k m]) -> Text
sectionText ((Text, [KeyEventHandler k m]) -> Text)
-> [(Text, [KeyEventHandler k m])] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, [KeyEventHandler k m])]
sections
sectionText :: (Text, [KeyEventHandler k m]) -> Text
sectionText (Text
heading, [KeyEventHandler k m]
handlers) =
Text -> Text
forall {a}. (Semigroup a, IsString a) => a -> a
mkHeading Text
heading Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
KeyConfig k
-> ((TextHunk, Text, [TextHunk]) -> Text)
-> ([Text] -> Text)
-> [KeyEventHandler k m]
-> Text
forall k a (m :: * -> *).
Ord k =>
KeyConfig k
-> ((TextHunk, Text, [TextHunk]) -> a)
-> ([a] -> a)
-> [KeyEventHandler k m]
-> a
mkKeybindEventSectionHelp KeyConfig k
kc (TextHunk, Text, [TextHunk]) -> Text
keybindEventHelpMarkdown [Text] -> Text
T.unlines [KeyEventHandler k m]
handlers
mkHeading :: a -> a
mkHeading a
n =
a
"\n# " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
n a -> a -> a
forall a. Semigroup a => a -> a -> a
<>
a
"\n| Keybinding | Event Name | Description |" a -> a -> a
forall a. Semigroup a => a -> a -> a
<>
a
"\n| ---------- | ---------- | ----------- |\n"
keybindingTextTable :: (Ord k)
=> KeyConfig k
-> [(T.Text, [KeyEventHandler k m])]
-> T.Text
keybindingTextTable :: forall k (m :: * -> *).
Ord k =>
KeyConfig k -> [(Text, [KeyEventHandler k m])] -> Text
keybindingTextTable KeyConfig k
kc [(Text, [KeyEventHandler k m])]
sections = Text
title Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
keybindSectionStrings
where title :: Text
title = Text
"Keybindings\n===========\n"
keybindSectionStrings :: Text
keybindSectionStrings = [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text, [KeyEventHandler k m]) -> Text
forall {m :: * -> *}. (Text, [KeyEventHandler k m]) -> Text
sectionText ((Text, [KeyEventHandler k m]) -> Text)
-> [(Text, [KeyEventHandler k m])] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, [KeyEventHandler k m])]
sections
sectionText :: (Text, [KeyEventHandler k m]) -> Text
sectionText (Text
heading, [KeyEventHandler k m]
handlers) =
Text -> Text
mkHeading Text
heading Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
KeyConfig k
-> ((TextHunk, Text, [TextHunk]) -> Text)
-> ([Text] -> Text)
-> [KeyEventHandler k m]
-> Text
forall k a (m :: * -> *).
Ord k =>
KeyConfig k
-> ((TextHunk, Text, [TextHunk]) -> a)
-> ([a] -> a)
-> [KeyEventHandler k m]
-> a
mkKeybindEventSectionHelp KeyConfig k
kc (Int -> Int -> (TextHunk, Text, [TextHunk]) -> Text
keybindEventHelpText Int
keybindingWidth Int
eventNameWidth) [Text] -> Text
T.unlines [KeyEventHandler k m]
handlers
keybindingWidth :: Int
keybindingWidth = Int
15
eventNameWidth :: Int
eventNameWidth = Int
30
mkHeading :: Text -> Text
mkHeading Text
n =
Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
n Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Int -> Text -> Text
T.replicate (Text -> Int
T.length Text
n) Text
"=") Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
Text
"\n"
keybindEventHelpText :: Int -> Int -> (TextHunk, T.Text, [TextHunk]) -> T.Text
keybindEventHelpText :: Int -> Int -> (TextHunk, Text, [TextHunk]) -> Text
keybindEventHelpText Int
width Int
eventNameWidth (TextHunk
evName, Text
desc, [TextHunk]
evs) =
let getText :: TextHunk -> Text
getText (Comment Text
s) = Text
s
getText (Verbatim Text
s) = Text
s
in Int -> Text -> Text
padTo Int
width (Text -> [Text] -> Text
T.intercalate Text
", " ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ TextHunk -> Text
getText (TextHunk -> Text) -> [TextHunk] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TextHunk]
evs) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
Int -> Text -> Text
padTo Int
eventNameWidth (TextHunk -> Text
getText TextHunk
evName) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
Text
desc
padTo :: Int -> T.Text -> T.Text
padTo :: Int -> Text -> Text
padTo Int
n Text
s = Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.replicate (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
s) Text
" "
mkKeybindEventSectionHelp :: (Ord k)
=> KeyConfig k
-> ((TextHunk, T.Text, [TextHunk]) -> a)
-> ([a] -> a)
-> [KeyEventHandler k m]
-> a
mkKeybindEventSectionHelp :: forall k a (m :: * -> *).
Ord k =>
KeyConfig k
-> ((TextHunk, Text, [TextHunk]) -> a)
-> ([a] -> a)
-> [KeyEventHandler k m]
-> a
mkKeybindEventSectionHelp KeyConfig k
kc (TextHunk, Text, [TextHunk]) -> a
mkKeybindHelpFunc [a] -> a
vertCat [KeyEventHandler k m]
kbs =
[a] -> a
vertCat ([a] -> a) -> [a] -> a
forall a b. (a -> b) -> a -> b
$ (TextHunk, Text, [TextHunk]) -> a
mkKeybindHelpFunc ((TextHunk, Text, [TextHunk]) -> a)
-> [(TextHunk, Text, [TextHunk])] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (KeyConfig k -> KeyEventHandler k m -> (TextHunk, Text, [TextHunk])
forall k (m :: * -> *).
Ord k =>
KeyConfig k -> KeyEventHandler k m -> (TextHunk, Text, [TextHunk])
mkKeybindEventHelp KeyConfig k
kc (KeyEventHandler k m -> (TextHunk, Text, [TextHunk]))
-> [KeyEventHandler k m] -> [(TextHunk, Text, [TextHunk])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [KeyEventHandler k m]
kbs)
keybindEventHelpMarkdown :: (TextHunk, T.Text, [TextHunk]) -> T.Text
keybindEventHelpMarkdown :: (TextHunk, Text, [TextHunk]) -> Text
keybindEventHelpMarkdown (TextHunk
evName, Text
desc, [TextHunk]
evs) =
let quote :: a -> a
quote a
s = a
"`" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
s a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"`"
format :: TextHunk -> Text
format (Comment Text
s) = Text
s
format (Verbatim Text
s) = Text -> Text
forall {a}. (Semigroup a, IsString a) => a -> a
quote Text
s
name :: Text
name = case TextHunk
evName of
Comment Text
s -> Text
s
Verbatim Text
s -> Text -> Text
forall {a}. (Semigroup a, IsString a) => a -> a
quote Text
s
in Text
"| " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Text -> [Text] -> Text
T.intercalate Text
", " ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ TextHunk -> Text
format (TextHunk -> Text) -> [TextHunk] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TextHunk]
evs) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
Text
" | " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
Text
" | " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
desc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>
Text
" |"
mkKeybindEventHelp :: (Ord k)
=> KeyConfig k
-> KeyEventHandler k m
-> (TextHunk, T.Text, [TextHunk])
mkKeybindEventHelp :: forall k (m :: * -> *).
Ord k =>
KeyConfig k -> KeyEventHandler k m -> (TextHunk, Text, [TextHunk])
mkKeybindEventHelp KeyConfig k
kc KeyEventHandler k m
h =
let trig :: EventTrigger k
trig = KeyEventHandler k m -> EventTrigger k
forall k (m :: * -> *). KeyEventHandler k m -> EventTrigger k
kehEventTrigger KeyEventHandler k m
h
unbound :: [TextHunk]
unbound = [Text -> TextHunk
Comment Text
"(unbound)"]
(TextHunk
label, [TextHunk]
evText) = case EventTrigger k
trig of
ByKey Binding
b ->
(Text -> TextHunk
Comment Text
"(non-customizable key)", [Text -> TextHunk
Verbatim (Text -> TextHunk) -> Text -> TextHunk
forall a b. (a -> b) -> a -> b
$ Binding -> Text
ppBinding Binding
b])
ByEvent k
ev ->
let name :: Text
name = Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ KeyEvents k -> k -> Maybe Text
forall k. Ord k => KeyEvents k -> k -> Maybe Text
keyEventName (KeyConfig k -> KeyEvents k
forall k. KeyConfig k -> KeyEvents k
keyConfigEvents KeyConfig k
kc) k
ev
in case KeyConfig k -> k -> Maybe BindingState
forall k. Ord k => KeyConfig k -> k -> Maybe BindingState
lookupKeyConfigBindings KeyConfig k
kc k
ev of
Maybe BindingState
Nothing ->
if Bool -> Bool
not ([Binding] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (KeyConfig k -> k -> [Binding]
forall k. Ord k => KeyConfig k -> k -> [Binding]
allDefaultBindings KeyConfig k
kc k
ev))
then (Text -> TextHunk
Verbatim Text
name, Text -> TextHunk
Verbatim (Text -> TextHunk) -> (Binding -> Text) -> Binding -> TextHunk
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Binding -> Text
ppBinding (Binding -> TextHunk) -> [Binding] -> [TextHunk]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> KeyConfig k -> k -> [Binding]
forall k. Ord k => KeyConfig k -> k -> [Binding]
allDefaultBindings KeyConfig k
kc k
ev)
else (Text -> TextHunk
Verbatim Text
name, [TextHunk]
unbound)
Just BindingState
Unbound ->
(Text -> TextHunk
Verbatim Text
name, [TextHunk]
unbound)
Just (BindingList [Binding]
bs) ->
let result :: [TextHunk]
result = if Bool -> Bool
not ([Binding] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Binding]
bs)
then Text -> TextHunk
Verbatim (Text -> TextHunk) -> (Binding -> Text) -> Binding -> TextHunk
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Binding -> Text
ppBinding (Binding -> TextHunk) -> [Binding] -> [TextHunk]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Binding]
bs
else [TextHunk]
unbound
in (Text -> TextHunk
Verbatim Text
name, [TextHunk]
result)
in (TextHunk
label, Handler m -> Text
forall (m :: * -> *). Handler m -> Text
handlerDescription (Handler m -> Text) -> Handler m -> Text
forall a b. (a -> b) -> a -> b
$ KeyEventHandler k m -> Handler m
forall k (m :: * -> *). KeyEventHandler k m -> Handler m
kehHandler KeyEventHandler k m
h, [TextHunk]
evText)
keybindingHelpWidget :: (Ord k)
=> KeyConfig k
-> [KeyEventHandler k m]
-> Widget n
keybindingHelpWidget :: forall k (m :: * -> *) n.
Ord k =>
KeyConfig k -> [KeyEventHandler k m] -> Widget n
keybindingHelpWidget KeyConfig k
kc =
AttrName -> Widget n -> Widget n
forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
keybindingHelpBaseAttr (Widget n -> Widget n)
-> ([KeyEventHandler k m] -> Widget n)
-> [KeyEventHandler k m]
-> Widget n
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
KeyConfig k
-> ((TextHunk, Text, [TextHunk]) -> Widget n)
-> ([Widget n] -> Widget n)
-> [KeyEventHandler k m]
-> Widget n
forall k a (m :: * -> *).
Ord k =>
KeyConfig k
-> ((TextHunk, Text, [TextHunk]) -> a)
-> ([a] -> a)
-> [KeyEventHandler k m]
-> a
mkKeybindEventSectionHelp KeyConfig k
kc (TextHunk, Text, [TextHunk]) -> Widget n
forall n. (TextHunk, Text, [TextHunk]) -> Widget n
keybindEventHelpWidget ([Widget n] -> Widget n
forall n. [Widget n] -> Widget n
vBox ([Widget n] -> Widget n)
-> ([Widget n] -> [Widget n]) -> [Widget n] -> Widget n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Widget n -> [Widget n] -> [Widget n]
forall a. a -> [a] -> [a]
intersperse (String -> Widget n
forall n. String -> Widget n
str String
" "))
keybindEventHelpWidget :: (TextHunk, T.Text, [TextHunk]) -> Widget n
keybindEventHelpWidget :: forall n. (TextHunk, Text, [TextHunk]) -> Widget n
keybindEventHelpWidget (TextHunk
evName, Text
desc, [TextHunk]
evs) =
let evText :: Text
evText = Text -> [Text] -> Text
T.intercalate Text
", " (TextHunk -> Text
getText (TextHunk -> Text) -> [TextHunk] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TextHunk]
evs)
getText :: TextHunk -> Text
getText (Comment Text
s) = Text
s
getText (Verbatim Text
s) = Text
s
label :: Widget n
label = AttrName -> Widget n -> Widget n
forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
eventNameAttr (Widget n -> Widget n) -> Widget n -> Widget n
forall a b. (a -> b) -> a -> b
$ case TextHunk
evName of
Comment Text
s -> Text -> Widget n
forall n. Text -> Widget n
txt Text
s
Verbatim Text
s -> Text -> Widget n
forall n. Text -> Widget n
txt Text
s
in [Widget n] -> Widget n
forall n. [Widget n] -> Widget n
vBox [ AttrName -> Widget n -> Widget n
forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
eventDescriptionAttr (Widget n -> Widget n) -> Widget n -> Widget n
forall a b. (a -> b) -> a -> b
$ Text -> Widget n
forall n. Text -> Widget n
txt Text
desc
, Widget n
forall {n}. Widget n
label Widget n -> Widget n -> Widget n
forall n. Widget n -> Widget n -> Widget n
<+> Text -> Widget n
forall n. Text -> Widget n
txt Text
" = " Widget n -> Widget n -> Widget n
forall n. Widget n -> Widget n -> Widget n
<+> AttrName -> Widget n -> Widget n
forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
keybindingAttr (Text -> Widget n
forall n. Text -> Widget n
txt Text
evText)
]
ppBinding :: Binding -> T.Text
ppBinding :: Binding -> Text
ppBinding (Binding Key
k Set Modifier
mods) =
Text -> [Text] -> Text
T.intercalate Text
"-" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Modifier -> Text
ppModifier (Modifier -> Text) -> [Modifier] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Modifier -> [Modifier]
modifierList Set Modifier
mods) [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Key -> Text
ppKey Key
k]
modifierList :: S.Set Vty.Modifier -> [Vty.Modifier]
modifierList :: Set Modifier -> [Modifier]
modifierList = [Modifier] -> [Modifier]
forall a. Ord a => [a] -> [a]
sort ([Modifier] -> [Modifier])
-> (Set Modifier -> [Modifier]) -> Set Modifier -> [Modifier]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Modifier -> [Modifier]
forall a. Set a -> [a]
S.toList
ppMaybeBinding :: Maybe Binding -> T.Text
ppMaybeBinding :: Maybe Binding -> Text
ppMaybeBinding Maybe Binding
Nothing =
Text
"(no binding)"
ppMaybeBinding (Just Binding
b) =
Binding -> Text
ppBinding Binding
b
ppKey :: Vty.Key -> T.Text
ppKey :: Key -> Text
ppKey (Vty.KChar Char
c) = Char -> Text
ppChar Char
c
ppKey (Vty.KFun Int
n) = Text
"F" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
n)
ppKey Key
Vty.KBackTab = Text
"BackTab"
ppKey Key
Vty.KEsc = Text
"Esc"
ppKey Key
Vty.KBS = Text
"Backspace"
ppKey Key
Vty.KEnter = Text
"Enter"
ppKey Key
Vty.KUp = Text
"Up"
ppKey Key
Vty.KDown = Text
"Down"
ppKey Key
Vty.KLeft = Text
"Left"
ppKey Key
Vty.KRight = Text
"Right"
ppKey Key
Vty.KHome = Text
"Home"
ppKey Key
Vty.KEnd = Text
"End"
ppKey Key
Vty.KPageUp = Text
"PgUp"
ppKey Key
Vty.KPageDown = Text
"PgDown"
ppKey Key
Vty.KDel = Text
"Del"
ppKey Key
Vty.KUpLeft = Text
"UpLeft"
ppKey Key
Vty.KUpRight = Text
"UpRight"
ppKey Key
Vty.KDownLeft = Text
"DownLeft"
ppKey Key
Vty.KDownRight = Text
"DownRight"
ppKey Key
Vty.KCenter = Text
"Center"
ppKey Key
Vty.KPrtScr = Text
"PrintScreen"
ppKey Key
Vty.KPause = Text
"Pause"
ppKey Key
Vty.KIns = Text
"Insert"
ppKey Key
Vty.KBegin = Text
"Begin"
ppKey Key
Vty.KMenu = Text
"Menu"
ppChar :: Char -> T.Text
ppChar :: Char -> Text
ppChar Char
'\t' = Text
"Tab"
ppChar Char
' ' = Text
"Space"
ppChar Char
c = Char -> Text
T.singleton Char
c
ppModifier :: Vty.Modifier -> T.Text
ppModifier :: Modifier -> Text
ppModifier Modifier
Vty.MMeta = Text
"M"
ppModifier Modifier
Vty.MAlt = Text
"A"
ppModifier Modifier
Vty.MCtrl = Text
"C"
ppModifier Modifier
Vty.MShift = Text
"S"
keybindingHelpBaseAttr :: AttrName
keybindingHelpBaseAttr :: AttrName
keybindingHelpBaseAttr = String -> AttrName
attrName String
"keybindingHelp"
eventNameAttr :: AttrName
eventNameAttr :: AttrName
eventNameAttr = AttrName
keybindingHelpBaseAttr AttrName -> AttrName -> AttrName
forall a. Semigroup a => a -> a -> a
<> String -> AttrName
attrName String
"eventName"
eventDescriptionAttr :: AttrName
eventDescriptionAttr :: AttrName
eventDescriptionAttr = AttrName
keybindingHelpBaseAttr AttrName -> AttrName -> AttrName
forall a. Semigroup a => a -> a -> a
<> String -> AttrName
attrName String
"eventDescription"
keybindingAttr :: AttrName
keybindingAttr :: AttrName
keybindingAttr = AttrName
keybindingHelpBaseAttr AttrName -> AttrName -> AttrName
forall a. Semigroup a => a -> a -> a
<> String -> AttrName
attrName String
"keybinding"