{-# LANGUAGE OverloadedStrings #-}
-- | This module provides functions for pretty-printing key bindings
-- and for generating Markdown, plain text, and Brick displays of event
-- handler key binding configurations.
module Brick.Keybindings.Pretty
  (
  -- * Generating help output
    keybindingTextTable
  , keybindingMarkdownTable
  , keybindingHelpWidget

  -- * Pretty-printing primitives
  , ppBinding
  , ppMaybeBinding
  , ppKey
  , ppModifier

  -- * Attributes for Widget rendering
  , 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
              | Comment T.Text

-- | Generate a Markdown document of sections indicating the key binding
-- state for each event handler.
keybindingMarkdownTable :: (Ord k)
                        => KeyConfig k
                        -- ^ The key binding configuration in use.
                        -> [(T.Text, [KeyEventHandler k m])]
                        -- ^ Key event handlers by named section.
                        -> 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 forall a. Semigroup a => a -> a -> a
<> Text
keybindSectionStrings
    where title :: Text
title = Text
"# Keybindings\n"
          keybindSectionStrings :: Text
keybindSectionStrings = [Text] -> Text
T.concat forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *}. (Text, [KeyEventHandler k m]) -> Text
sectionText 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) =
              forall {a}. (Semigroup a, IsString a) => a -> a
mkHeading Text
heading forall a. Semigroup a => a -> a -> a
<>
              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# " forall a. Semigroup a => a -> a -> a
<> a
n forall a. Semigroup a => a -> a -> a
<>
              a
"\n| Keybinding | Event Name | Description |" forall a. Semigroup a => a -> a -> a
<>
              a
"\n| ---------- | ---------- | ----------- |\n"

-- | Generate a plain text document of sections indicating the key
-- binding state for each event handler.
keybindingTextTable :: (Ord k)
                    => KeyConfig k
                    -- ^ The key binding configuration in use.
                    -> [(T.Text, [KeyEventHandler k m])]
                    -- ^ Key event handlers by named section.
                    -> 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 forall a. Semigroup a => a -> a -> a
<> Text
keybindSectionStrings
    where title :: Text
title = Text
"Keybindings\n===========\n"
          keybindSectionStrings :: Text
keybindSectionStrings = [Text] -> Text
T.concat forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *}. (Text, [KeyEventHandler k m]) -> Text
sectionText 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 forall a. Semigroup a => a -> a -> a
<>
              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" forall a. Semigroup a => a -> a -> a
<> Text
n forall a. Semigroup a => a -> a -> a
<>
              Text
"\n" forall a. Semigroup a => a -> a -> a
<> (Int -> Text -> Text
T.replicate (Text -> Int
T.length Text
n) 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
", " forall a b. (a -> b) -> a -> b
$ TextHunk -> Text
getText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TextHunk]
evs) forall a. Semigroup a => a -> a -> a
<> Text
" " forall a. Semigroup a => a -> a -> a
<>
       Int -> Text -> Text
padTo Int
eventNameWidth (TextHunk -> Text
getText TextHunk
evName) forall a. Semigroup a => a -> a -> a
<> 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 forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.replicate (Int
n 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 forall a b. (a -> b) -> a -> b
$ (TextHunk, Text, [TextHunk]) -> a
mkKeybindHelpFunc forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall k (m :: * -> *).
Ord k =>
KeyConfig k -> KeyEventHandler k m -> (TextHunk, Text, [TextHunk])
mkKeybindEventHelp KeyConfig k
kc 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
"`" forall a. Semigroup a => a -> a -> a
<> a
s forall a. Semigroup a => a -> a -> a
<> a
"`"
        format :: TextHunk -> Text
format (Comment Text
s) = Text
s
        format (Verbatim Text
s) = 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 -> forall {a}. (Semigroup a, IsString a) => a -> a
quote Text
s
    in Text
"| " forall a. Semigroup a => a -> a -> a
<> (Text -> [Text] -> Text
T.intercalate Text
", " forall a b. (a -> b) -> a -> b
$ TextHunk -> Text
format forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TextHunk]
evs) forall a. Semigroup a => a -> a -> a
<>
       Text
" | " forall a. Semigroup a => a -> a -> a
<> Text
name forall a. Semigroup a => a -> a -> a
<>
       Text
" | " forall a. Semigroup a => a -> a -> a
<> Text
desc 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 = 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 forall a b. (a -> b) -> a -> b
$ Binding -> Text
ppBinding Binding
b])
          ByEvent k
ev ->
              let name :: Text
name = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall k. Ord k => KeyEvents k -> k -> Maybe Text
keyEventName (forall k. KeyConfig k -> KeyEvents k
keyConfigEvents KeyConfig k
kc) k
ev
              in case forall k. Ord k => KeyConfig k -> k -> Maybe BindingState
lookupKeyConfigBindings KeyConfig k
kc k
ev of
                  Maybe BindingState
Nothing ->
                      if Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null (forall k. Ord k => KeyConfig k -> k -> [Binding]
allDefaultBindings KeyConfig k
kc k
ev))
                      then (Text -> TextHunk
Verbatim Text
name, Text -> TextHunk
Verbatim forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Binding -> Text
ppBinding forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Binding]
bs)
                                   then Text -> TextHunk
Verbatim forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Binding -> Text
ppBinding 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, forall (m :: * -> *). Handler m -> Text
handlerDescription forall a b. (a -> b) -> a -> b
$ forall k (m :: * -> *). KeyEventHandler k m -> Handler m
kehHandler KeyEventHandler k m
h, [TextHunk]
evText)

-- | Build a 'Widget' displaying key binding information for a single
-- related group of event handlers. This is provided for convenience
-- so that basic help text for the application's event handlers can be
-- produced and embedded in the UI.
--
-- The resulting widget lists the key events (and keys) bound to the
-- specified handlers, along with the events' names and the list of
-- available key bindings for each handler.
keybindingHelpWidget :: (Ord k)
                     => KeyConfig k
                     -- ^ The key binding configuration in use.
                     -> [KeyEventHandler k m]
                     -- ^ The list of the event handlers to include in
                     -- the help display.
                     -> Widget n
keybindingHelpWidget :: forall k (m :: * -> *) n.
Ord k =>
KeyConfig k -> [KeyEventHandler k m] -> Widget n
keybindingHelpWidget KeyConfig k
kc =
    forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
keybindingHelpBaseAttr forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall k a (m :: * -> *).
Ord k =>
KeyConfig k
-> ((TextHunk, Text, [TextHunk]) -> a)
-> ([a] -> a)
-> [KeyEventHandler k m]
-> a
mkKeybindEventSectionHelp KeyConfig k
kc forall n. (TextHunk, Text, [TextHunk]) -> Widget n
keybindEventHelpWidget (forall n. [Widget n] -> Widget n
vBox forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> [a] -> [a]
intersperse (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 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 = forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
eventNameAttr forall a b. (a -> b) -> a -> b
$ case TextHunk
evName of
            Comment Text
s -> forall n. Text -> Widget n
txt Text
s -- TODO: was "; " <> s
            Verbatim Text
s -> forall n. Text -> Widget n
txt Text
s -- TODO: was: emph $ txt s
    in forall n. [Widget n] -> Widget n
vBox [ forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
eventDescriptionAttr forall a b. (a -> b) -> a -> b
$ forall n. Text -> Widget n
txt Text
desc
            , forall {n}. Widget n
label forall n. Widget n -> Widget n -> Widget n
<+> forall n. Text -> Widget n
txt Text
" = " forall n. Widget n -> Widget n -> Widget n
<+> forall n. AttrName -> Widget n -> Widget n
withDefAttr AttrName
keybindingAttr (forall n. Text -> Widget n
txt Text
evText)
            ]

-- | Pretty-print a 'Binding' in the same format that is parsed by
-- 'Brick.Keybindings.Parse.parseBinding'.
ppBinding :: Binding -> T.Text
ppBinding :: Binding -> Text
ppBinding (Binding Key
k Set Modifier
mods) =
    Text -> [Text] -> Text
T.intercalate Text
"-" forall a b. (a -> b) -> a -> b
$ (Modifier -> Text
ppModifier forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Modifier -> [Modifier]
modifierList Set Modifier
mods) forall a. Semigroup a => a -> a -> a
<> [Key -> Text
ppKey Key
k]

modifierList :: S.Set Vty.Modifier -> [Vty.Modifier]
modifierList :: Set Modifier -> [Modifier]
modifierList = forall a. Ord a => [a] -> [a]
sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Set a -> [a]
S.toList

-- | Pretty-print a 'Binding' in the same format that is parsed by
-- 'Brick.Keybindings.Parse.parseBinding'; if no binding is given,
-- produce a message indicating no binding.
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

-- | Pretty-print a 'Vty.Key' in the same format that is parsed by
-- 'Brick.Keybindings.Parse.parseBinding'.
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" forall a. Semigroup a => a -> a -> a
<> (String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ 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"

-- | Pretty-print a character in the same format that is parsed by
-- 'Brick.Keybindings.Parse.parseBinding'.
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

-- | Pretty-print a 'Vty.Modifier' in the same format that is parsed by
-- 'Brick.Keybindings.Parse.parseBinding'.
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"

-- | The base attribute for 'Widget' keybinding help.
keybindingHelpBaseAttr :: AttrName
keybindingHelpBaseAttr :: AttrName
keybindingHelpBaseAttr = String -> AttrName
attrName String
"keybindingHelp"

-- | The attribute for event names in keybinding help 'Widget's.
eventNameAttr :: AttrName
eventNameAttr :: AttrName
eventNameAttr = AttrName
keybindingHelpBaseAttr forall a. Semigroup a => a -> a -> a
<> String -> AttrName
attrName String
"eventName"

-- | The attribute for event descriptions in keybinding help 'Widget's.
eventDescriptionAttr :: AttrName
eventDescriptionAttr :: AttrName
eventDescriptionAttr = AttrName
keybindingHelpBaseAttr forall a. Semigroup a => a -> a -> a
<> String -> AttrName
attrName String
"eventDescription"

-- | The attribute for keybinding lists in keybinding help 'Widget's.
keybindingAttr :: AttrName
keybindingAttr :: AttrName
keybindingAttr = AttrName
keybindingHelpBaseAttr forall a. Semigroup a => a -> a -> a
<> String -> AttrName
attrName String
"keybinding"