{-# 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
  { forall n. HelpWidget n -> KeyBindings
keyBindings :: KeyBindings
  , forall n. HelpWidget n -> n
name :: n
  }

type Name n = (Ord n, Show n)

helpWidget :: n -> KeyBindings -> HelpWidget n
helpWidget :: forall n. n -> KeyBindings -> HelpWidget n
helpWidget = (KeyBindings -> n -> HelpWidget n)
-> n -> KeyBindings -> HelpWidget n
forall a b c. (a -> b -> c) -> b -> a -> c
flip KeyBindings -> n -> HelpWidget n
forall n. KeyBindings -> n -> HelpWidget n
HelpWidget

renderHelpWidget :: Name n => HelpWidget n -> Widget n
renderHelpWidget :: forall n. Name n => HelpWidget n -> Widget n
renderHelpWidget HelpWidget{KeyBindings
keyBindings :: forall n. HelpWidget n -> KeyBindings
keyBindings :: KeyBindings
keyBindings, n
name :: forall n. HelpWidget n -> n
name :: n
name} =
  Widget n -> Widget n
forall n. Widget n -> Widget n
center (Widget n -> Widget n) -> Widget n -> Widget n
forall a b. (a -> b) -> a -> b
$ n -> KeyBindings -> Widget n
forall n. Name n => n -> KeyBindings -> Widget n
renderHelpWidget' n
name KeyBindings
keyBindings

center :: Widget n -> Widget n
center :: forall n. Widget n -> Widget n
center Widget n
w = Size -> Size -> RenderM n (Result n) -> Widget n
forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget Size
Fixed Size
Fixed (RenderM n (Result n) -> Widget n)
-> RenderM n (Result n) -> Widget n
forall a b. (a -> b) -> a -> b
$ do
  Context n
c <- RenderM n (Context n)
forall n. RenderM n (Context n)
getContext
  Result n
res <- Widget n -> RenderM n (Result n)
forall n. Widget n -> RenderM n (Result n)
render Widget n
w
  let rWidth :: Int
rWidth = Result n
resResult n -> Getting Int (Result n) Int -> Int
forall s a. s -> Getting a s a -> a
^.(Image -> Const Int Image) -> Result n -> Const Int (Result n)
forall n (f :: * -> *).
Functor f =>
(Image -> f Image) -> Result n -> f (Result n)
imageL((Image -> Const Int Image) -> Result n -> Const Int (Result n))
-> ((Int -> Const Int Int) -> Image -> Const Int Image)
-> Getting Int (Result n) Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Image -> Int) -> SimpleGetter Image Int
forall s a. (s -> a) -> SimpleGetter s a
to Image -> Int
imageWidth
      rHeight :: Int
rHeight = Result n
resResult n -> Getting Int (Result n) Int -> Int
forall s a. s -> Getting a s a -> a
^.(Image -> Const Int Image) -> Result n -> Const Int (Result n)
forall n (f :: * -> *).
Functor f =>
(Image -> f Image) -> Result n -> f (Result n)
imageL((Image -> Const Int Image) -> Result n -> Const Int (Result n))
-> ((Int -> Const Int Int) -> Image -> Const Int Image)
-> Getting Int (Result n) Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Image -> Int) -> SimpleGetter Image Int
forall s a. (s -> a) -> SimpleGetter s a
to Image -> Int
imageHeight
      x :: Int
x = (Context n
cContext n -> Getting Int (Context n) Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int (Context n) Int
forall n (f :: * -> *).
Functor f =>
(Int -> f Int) -> Context n -> f (Context n)
availWidthL Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Int
rWidth Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2)
      y :: Int
y = (Context n
cContext n -> Getting Int (Context n) Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int (Context n) Int
forall n (f :: * -> *).
Functor f =>
(Int -> f Int) -> Context n -> f (Context n)
availHeightL Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Int
rHeight Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2)

  Widget n -> RenderM n (Result n)
forall n. Widget n -> RenderM n (Result n)
render (Widget n -> RenderM n (Result n))
-> Widget n -> RenderM n (Result n)
forall a b. (a -> b) -> a -> b
$ Location -> Widget n -> Widget n
forall n. Location -> Widget n -> Widget n
translateBy ((Int, Int) -> Location
Location (Int
x,Int
y)) (Widget n -> Widget n) -> Widget n -> Widget n
forall a b. (a -> b) -> a -> b
$ Image -> Widget n
forall n. Image -> Widget n
raw (Result n
resResult n -> Getting Image (Result n) Image -> Image
forall s a. s -> Getting a s a -> a
^.Getting Image (Result n) Image
forall n (f :: * -> *).
Functor f =>
(Image -> f Image) -> Result n -> f (Result n)
imageL)

renderHelpWidget' :: Name n => n -> KeyBindings -> Widget n
renderHelpWidget' :: forall n. Name n => n -> KeyBindings -> Widget n
renderHelpWidget' n
name (KeyBindings [(Text, [(Text, Text)])]
bindings) = Size -> Size -> RenderM n (Result n) -> Widget n
forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget Size
Fixed Size
Fixed (RenderM n (Result n) -> Widget n)
-> RenderM n (Result n) -> Widget n
forall a b. (a -> b) -> a -> b
$ do
  Context n
c <- RenderM n (Context n)
forall n. RenderM n (Context n)
getContext

  Widget n -> RenderM n (Result n)
forall n. Widget n -> RenderM n (Result n)
render (Widget n -> RenderM n (Result n))
-> Widget n -> RenderM n (Result n)
forall a b. (a -> b) -> a -> b
$
    Int -> Widget n -> Widget n
forall n. Int -> Widget n -> Widget n
hLimit (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
80 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Context n
cContext n -> Getting Int (Context n) Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int (Context n) Int
forall n (f :: * -> *).
Functor f =>
(Int -> f Int) -> Context n -> f (Context n)
availWidthL) (Widget n -> Widget n) -> Widget n -> Widget n
forall a b. (a -> b) -> a -> b
$
    Int -> Widget n -> Widget n
forall n. Int -> Widget n -> Widget n
vLimit (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
30 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Context n
cContext n -> Getting Int (Context n) Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int (Context n) Int
forall n (f :: * -> *).
Functor f =>
(Int -> f Int) -> Context n -> f (Context n)
availHeightL) (Widget n -> Widget n) -> Widget n -> Widget n
forall a b. (a -> b) -> a -> b
$
    Widget n -> Widget n -> Widget n
forall n. Widget n -> Widget n -> Widget n
borderWithLabel (Text -> Widget n
forall n. Text -> Widget n
txt Text
"Help") (Widget n -> Widget n) -> Widget n -> Widget n
forall a b. (a -> b) -> a -> b
$
    n -> ViewportType -> Widget n -> Widget n
forall n.
(Ord n, Show n) =>
n -> ViewportType -> Widget n -> Widget n
viewport n
name ViewportType
Vertical (Widget n -> Widget n) -> Widget n -> Widget n
forall a b. (a -> b) -> a -> b
$
    [Widget n] -> Widget n
forall n. [Widget n] -> Widget n
vBox ([Widget n] -> Widget n) -> [Widget n] -> Widget n
forall a b. (a -> b) -> a -> b
$ Widget n -> [Widget n] -> [Widget n]
forall a. a -> [a] -> [a]
intersperse (Text -> Widget n
forall n. Text -> Widget n
txt Text
" ") ([Widget n] -> [Widget n]) -> [Widget n] -> [Widget n]
forall a b. (a -> b) -> a -> b
$
    ((Text, [(Text, Text)]) -> Widget n)
-> [(Text, [(Text, Text)])] -> [Widget n]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> [(Text, Text)] -> Widget n)
-> (Text, [(Text, Text)]) -> Widget n
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> [(Text, Text)] -> Widget n
forall n. Text -> [(Text, Text)] -> Widget n
section) [(Text, [(Text, Text)])]
bindings

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

handleHelpEvent :: Event -> EventM n (HelpWidget n) ()
handleHelpEvent :: forall n. Event -> EventM n (HelpWidget n) ()
handleHelpEvent (EvKey Key
k [Modifier]
_) = case Key
k of
  KChar Char
'j' -> (HelpWidget n -> ViewportScroll n)
-> EventM n (HelpWidget n) (ViewportScroll n)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets HelpWidget n -> ViewportScroll n
forall n. HelpWidget n -> ViewportScroll n
scroller EventM n (HelpWidget n) (ViewportScroll n)
-> (ViewportScroll n -> EventM n (HelpWidget n) ())
-> EventM n (HelpWidget n) ()
forall a b.
EventM n (HelpWidget n) a
-> (a -> EventM n (HelpWidget n) b) -> EventM n (HelpWidget n) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ViewportScroll n
s -> ViewportScroll n -> forall s. Int -> EventM n s ()
forall n. ViewportScroll n -> forall s. Int -> EventM n s ()
vScrollBy ViewportScroll n
s Int
1
  Key
KDown     -> (HelpWidget n -> ViewportScroll n)
-> EventM n (HelpWidget n) (ViewportScroll n)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets HelpWidget n -> ViewportScroll n
forall n. HelpWidget n -> ViewportScroll n
scroller EventM n (HelpWidget n) (ViewportScroll n)
-> (ViewportScroll n -> EventM n (HelpWidget n) ())
-> EventM n (HelpWidget n) ()
forall a b.
EventM n (HelpWidget n) a
-> (a -> EventM n (HelpWidget n) b) -> EventM n (HelpWidget n) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ViewportScroll n
s -> ViewportScroll n -> forall s. Int -> EventM n s ()
forall n. ViewportScroll n -> forall s. Int -> EventM n s ()
vScrollBy ViewportScroll n
s Int
1
  KChar Char
'k' -> (HelpWidget n -> ViewportScroll n)
-> EventM n (HelpWidget n) (ViewportScroll n)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets HelpWidget n -> ViewportScroll n
forall n. HelpWidget n -> ViewportScroll n
scroller EventM n (HelpWidget n) (ViewportScroll n)
-> (ViewportScroll n -> EventM n (HelpWidget n) ())
-> EventM n (HelpWidget n) ()
forall a b.
EventM n (HelpWidget n) a
-> (a -> EventM n (HelpWidget n) b) -> EventM n (HelpWidget n) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ViewportScroll n
s -> ViewportScroll n -> forall s. Int -> EventM n s ()
forall n. ViewportScroll n -> forall s. Int -> EventM n s ()
vScrollBy ViewportScroll n
s (-Int
1)
  Key
KUp       -> (HelpWidget n -> ViewportScroll n)
-> EventM n (HelpWidget n) (ViewportScroll n)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets HelpWidget n -> ViewportScroll n
forall n. HelpWidget n -> ViewportScroll n
scroller EventM n (HelpWidget n) (ViewportScroll n)
-> (ViewportScroll n -> EventM n (HelpWidget n) ())
-> EventM n (HelpWidget n) ()
forall a b.
EventM n (HelpWidget n) a
-> (a -> EventM n (HelpWidget n) b) -> EventM n (HelpWidget n) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ViewportScroll n
s -> ViewportScroll n -> forall s. Int -> EventM n s ()
forall n. ViewportScroll n -> forall s. Int -> EventM n s ()
vScrollBy ViewportScroll n
s (-Int
1)
  KChar Char
'g' -> (HelpWidget n -> ViewportScroll n)
-> EventM n (HelpWidget n) (ViewportScroll n)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets HelpWidget n -> ViewportScroll n
forall n. HelpWidget n -> ViewportScroll n
scroller EventM n (HelpWidget n) (ViewportScroll n)
-> (ViewportScroll n -> EventM n (HelpWidget n) ())
-> EventM n (HelpWidget n) ()
forall a b.
EventM n (HelpWidget n) a
-> (a -> EventM n (HelpWidget n) b) -> EventM n (HelpWidget n) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ViewportScroll n
s -> ViewportScroll n -> forall s. EventM n s ()
forall n. ViewportScroll n -> forall s. EventM n s ()
vScrollToBeginning ViewportScroll n
s
  Key
KHome     -> (HelpWidget n -> ViewportScroll n)
-> EventM n (HelpWidget n) (ViewportScroll n)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets HelpWidget n -> ViewportScroll n
forall n. HelpWidget n -> ViewportScroll n
scroller EventM n (HelpWidget n) (ViewportScroll n)
-> (ViewportScroll n -> EventM n (HelpWidget n) ())
-> EventM n (HelpWidget n) ()
forall a b.
EventM n (HelpWidget n) a
-> (a -> EventM n (HelpWidget n) b) -> EventM n (HelpWidget n) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ViewportScroll n
s -> ViewportScroll n -> forall s. EventM n s ()
forall n. ViewportScroll n -> forall s. EventM n s ()
vScrollToBeginning ViewportScroll n
s
  KChar Char
'G' -> (HelpWidget n -> ViewportScroll n)
-> EventM n (HelpWidget n) (ViewportScroll n)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets HelpWidget n -> ViewportScroll n
forall n. HelpWidget n -> ViewportScroll n
scroller EventM n (HelpWidget n) (ViewportScroll n)
-> (ViewportScroll n -> EventM n (HelpWidget n) ())
-> EventM n (HelpWidget n) ()
forall a b.
EventM n (HelpWidget n) a
-> (a -> EventM n (HelpWidget n) b) -> EventM n (HelpWidget n) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ViewportScroll n
s -> ViewportScroll n -> forall s. EventM n s ()
forall n. ViewportScroll n -> forall s. EventM n s ()
vScrollToEnd ViewportScroll n
s
  Key
KEnd      -> (HelpWidget n -> ViewportScroll n)
-> EventM n (HelpWidget n) (ViewportScroll n)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets HelpWidget n -> ViewportScroll n
forall n. HelpWidget n -> ViewportScroll n
scroller EventM n (HelpWidget n) (ViewportScroll n)
-> (ViewportScroll n -> EventM n (HelpWidget n) ())
-> EventM n (HelpWidget n) ()
forall a b.
EventM n (HelpWidget n) a
-> (a -> EventM n (HelpWidget n) b) -> EventM n (HelpWidget n) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ViewportScroll n
s -> ViewportScroll n -> forall s. EventM n s ()
forall n. ViewportScroll n -> forall s. EventM n s ()
vScrollToEnd ViewportScroll n
s
  Key
KPageUp   -> (HelpWidget n -> ViewportScroll n)
-> EventM n (HelpWidget n) (ViewportScroll n)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets HelpWidget n -> ViewportScroll n
forall n. HelpWidget n -> ViewportScroll n
scroller EventM n (HelpWidget n) (ViewportScroll n)
-> (ViewportScroll n -> EventM n (HelpWidget n) ())
-> EventM n (HelpWidget n) ()
forall a b.
EventM n (HelpWidget n) a
-> (a -> EventM n (HelpWidget n) b) -> EventM n (HelpWidget n) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ViewportScroll n
s -> ViewportScroll n -> forall s. Direction -> EventM n s ()
forall n. ViewportScroll n -> forall s. Direction -> EventM n s ()
vScrollPage ViewportScroll n
s Direction
Up
  Key
KPageDown -> (HelpWidget n -> ViewportScroll n)
-> EventM n (HelpWidget n) (ViewportScroll n)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets HelpWidget n -> ViewportScroll n
forall n. HelpWidget n -> ViewportScroll n
scroller EventM n (HelpWidget n) (ViewportScroll n)
-> (ViewportScroll n -> EventM n (HelpWidget n) ())
-> EventM n (HelpWidget n) ()
forall a b.
EventM n (HelpWidget n) a
-> (a -> EventM n (HelpWidget n) b) -> EventM n (HelpWidget n) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ViewportScroll n
s -> ViewportScroll n -> forall s. Direction -> EventM n s ()
forall n. ViewportScroll n -> forall s. Direction -> EventM n s ()
vScrollPage ViewportScroll n
s Direction
Down
  Key
_         -> () -> EventM n (HelpWidget n) ()
forall a. a -> EventM n (HelpWidget n) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
handleHelpEvent Event
_ = () -> EventM n (HelpWidget n) ()
forall a. a -> EventM n (HelpWidget n) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()


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

key :: Text -> Text -> Widget n
key :: forall n. Text -> Text -> Widget n
key Text
k Text
h =  AttrName -> Widget n -> Widget n
forall n. AttrName -> Widget n -> Widget n
withAttr (AttrName
helpAttr AttrName -> AttrName -> AttrName
forall a. Semigroup a => a -> a -> a
<> String -> AttrName
attrName String
"key") (Text -> Widget n
forall n. Text -> Widget n
txt (Text
"  " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
k))
       Widget n -> Widget n -> Widget n
forall n. Widget n -> Widget n -> Widget n
<+> Padding -> Widget n -> Widget n
forall n. Padding -> Widget n -> Widget n
padLeft Padding
Max (AttrName -> Widget n -> Widget n
forall n. AttrName -> Widget n -> Widget n
withAttr (AttrName
helpAttr AttrName -> AttrName -> AttrName
forall a. Semigroup a => a -> a -> a
<> String -> AttrName
attrName String
"description") (Text -> Widget n
forall n. Text -> Widget n
txt Text
h))

helpAttr :: AttrName
helpAttr :: AttrName
helpAttr = String -> AttrName
attrName String
"help"

section :: Title -> [(Text, Text)] -> Widget n
section :: forall n. Text -> [(Text, Text)] -> Widget n
section Text
title [(Text, Text)]
keys =  AttrName -> Widget n -> Widget n
forall n. AttrName -> Widget n -> Widget n
withAttr (AttrName
helpAttr AttrName -> AttrName -> AttrName
forall a. Semigroup a => a -> a -> a
<> String -> AttrName
attrName String
"title") (Text -> Widget n
forall n. Text -> Widget n
txt (Text
title Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":"))
                  Widget n -> Widget n -> Widget n
forall n. Widget n -> Widget n -> Widget n
<=> [Widget n] -> Widget n
forall n. [Widget n] -> Widget n
vBox (((Text, Text) -> Widget n) -> [(Text, Text)] -> [Widget n]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> Text -> Widget n) -> (Text, Text) -> Widget n
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> Text -> Widget n
forall n. Text -> Text -> Widget n
key) [(Text, Text)]
keys)