Pretty.hs

{-# 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)
#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 kc sections = title <> keybindSectionStrings
    where title = "# Keybindings\n"
          keybindSectionStrings = T.concat $ sectionText <$> sections
          sectionText (heading, handlers) =
              mkHeading heading <>
              mkKeybindEventSectionHelp kc keybindEventHelpMarkdown T.unlines handlers
          mkHeading n =
              "\n# " <> n <>
              "\n| Keybinding | Event Name | Description |" <>
              "\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 kc sections = title <> keybindSectionStrings
    where title = "Keybindings\n===========\n"
          keybindSectionStrings = T.concat $ sectionText <$> sections
          sectionText (heading, handlers) =
              mkHeading heading <>
              mkKeybindEventSectionHelp kc (keybindEventHelpText keybindingWidth eventNameWidth) T.unlines handlers
          keybindingWidth = 15
          eventNameWidth = 30
          mkHeading n =
              "\n" <> n <>
              "\n" <> (T.replicate (T.length n) "=") <>
              "\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 k)
                          => KeyConfig k
                          -> ((TextHunk, T.Text, [TextHunk]) -> a)
                          -> ([a] -> a)
                          -> [KeyEventHandler k m]
                          -> a
mkKeybindEventSectionHelp kc mkKeybindHelpFunc vertCat kbs =
  vertCat $ 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 k)
                   => KeyConfig k
                   -> KeyEventHandler k m
                   -> (TextHunk, T.Text, [TextHunk])
mkKeybindEventHelp kc h =
  let trig = kehEventTrigger h
      unbound = [Comment "(unbound)"]
      (label, evText) = case trig of
          ByKey b ->
              (Comment "(non-customizable key)", [Verbatim $ ppBinding b])
          ByEvent ev ->
              let name = maybe (Comment "(unnamed)") Verbatim $ keyEventName (keyConfigEvents kc) ev
              in case lookupKeyConfigBindings kc ev of
                  Nothing ->
                      if not (null (allDefaultBindings kc ev))
                      then (name, Verbatim <$> ppBinding <$> allDefaultBindings kc ev)
                      else (name, unbound)
                  Just Unbound ->
                      (name, unbound)
                  Just (BindingList bs) ->
                      let result = if not (null bs)
                                   then Verbatim <$> ppBinding <$> bs
                                   else unbound
                      in (name, result)
  in (label, handlerDescription $ kehHandler h, 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 kc =
    withDefAttr keybindingHelpBaseAttr .
    mkKeybindEventSectionHelp kc keybindEventHelpWidget (vBox . intersperse (str " "))

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 = withDefAttr eventNameAttr $ case evName of
            Comment s -> txt s
            Verbatim s -> txt s
    in vBox [ withDefAttr eventDescriptionAttr $ txt desc
            , label <+> txt " = " <+> withDefAttr keybindingAttr (txt evText)
            ]

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

modifierList :: S.Set Vty.Modifier -> [Vty.Modifier]
modifierList = sort . 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 Nothing =
    "(no binding)"
ppMaybeBinding (Just b) =
    ppBinding b

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

-- | Pretty-print a character in the same format that is parsed by
-- 'Brick.Keybindings.Parse.parseBinding'.
ppChar :: Char -> T.Text
ppChar '\t' = "Tab"
ppChar ' '  = "Space"
ppChar c    = T.singleton c

-- | Pretty-print a 'Vty.Modifier' in the same format that is parsed by
-- 'Brick.Keybindings.Parse.parseBinding'.
ppModifier :: Vty.Modifier -> T.Text
ppModifier Vty.MMeta  = "M"
ppModifier Vty.MAlt   = "A"
ppModifier Vty.MCtrl  = "C"
ppModifier Vty.MShift = "S"

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

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

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

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