HelpMessage.hs

{-# LANGUAGE OverloadedStrings, NamedFieldPuns, ConstraintKinds #-}
module Brick.Widgets.HelpMessage
       ( HelpWidget
       , Title
       , KeyBindings(..)
       , helpWidget
       , renderHelpWidget
       , helpAttr
       , resetHelpWidget
       , handleHelpEvent
       ) where

import Brick
import Brick.Widgets.Border
import Graphics.Vty
import Data.Text (Text)
import Data.List
import Lens.Micro

type Title = Text

-- [(Title, [(Key, Description)])]
newtype KeyBindings = KeyBindings [(Title, [(Text, Text)])]

data HelpWidget n = HelpWidget
  { keyBindings :: KeyBindings
  , name :: n
  }

type Name n = (Ord n, Show n)

helpWidget :: n -> KeyBindings -> HelpWidget n
helpWidget = flip HelpWidget

renderHelpWidget :: Name n => HelpWidget n -> Widget n
renderHelpWidget HelpWidget{keyBindings, name} =
  center $ renderHelpWidget' name keyBindings

center :: Widget n -> Widget n
center w = Widget Fixed Fixed $ do
  c <- getContext
  res <- render w
  let rWidth = res^.imageL.to imageWidth
      rHeight = res^.imageL.to imageHeight
      x = (c^.availWidthL `div` 2) - (rWidth `div` 2)
      y = (c^.availHeightL `div` 2) - (rHeight `div` 2)

  render $ translateBy (Location (x,y)) $ raw (res^.imageL)

renderHelpWidget' :: Name n => n -> KeyBindings -> Widget n
renderHelpWidget' name (KeyBindings bindings) = Widget Fixed Fixed $ do
  c <- getContext

  render $
    hLimit (min 80 $ c^.availWidthL) $
    vLimit (min 30 $ c^.availHeightL) $
    borderWithLabel (txt "Help") $
    viewport name Vertical $
    vBox $ intersperse (txt " ") $
    map (uncurry section) bindings

scroller :: HelpWidget n -> ViewportScroll n
scroller HelpWidget{name} = viewportScroll name

handleHelpEvent :: Event -> EventM n (HelpWidget n) ()
handleHelpEvent (EvKey k _) = case k of
  KChar 'j' -> gets scroller >>= \s -> vScrollBy s 1
  KDown     -> gets scroller >>= \s -> vScrollBy s 1
  KChar 'k' -> gets scroller >>= \s -> vScrollBy s (-1)
  KUp       -> gets scroller >>= \s -> vScrollBy s (-1)
  KChar 'g' -> gets scroller >>= \s -> vScrollToBeginning s
  KHome     -> gets scroller >>= \s -> vScrollToBeginning s
  KChar 'G' -> gets scroller >>= \s -> vScrollToEnd s
  KEnd      -> gets scroller >>= \s -> vScrollToEnd s
  KPageUp   -> gets scroller >>= \s -> vScrollPage s Up
  KPageDown -> gets scroller >>= \s -> vScrollPage s Down
  _         -> return ()
handleHelpEvent _ = return ()


resetHelpWidget :: HelpWidget n -> EventM n s ()
resetHelpWidget = vScrollToBeginning . scroller

key :: Text -> Text -> Widget n
key k h =  withAttr (helpAttr <> attrName "key") (txt ("  " <> k))
       <+> padLeft Max (withAttr (helpAttr <> attrName "description") (txt h))

helpAttr :: AttrName
helpAttr = attrName "help"

section :: Title -> [(Text, Text)] -> Widget n
section title keys =  withAttr (helpAttr <> attrName "title") (txt (title <> ":"))
                  <=> vBox (map (uncurry key) keys)