{-# 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 = forall a b c. (a -> b -> c) -> b -> a -> c
flip 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 :: KeyBindings
keyBindings :: forall n. HelpWidget n -> KeyBindings
keyBindings, n
name :: n
name :: forall n. HelpWidget n -> n
name} =
  forall n. Widget n -> Widget n
center forall a b. (a -> b) -> a -> b
$ 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 = forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget Size
Fixed Size
Fixed forall a b. (a -> b) -> a -> b
$ do
  Context n
c <- forall n. RenderM n (Context n)
getContext
  Result n
res <- forall n. Widget n -> RenderM n (Result n)
render Widget n
w
  let rWidth :: Int
rWidth = Result n
resforall s a. s -> Getting a s a -> a
^.forall n. Lens' (Result n) Image
imageLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to Image -> Int
imageWidth
      rHeight :: Int
rHeight = Result n
resforall s a. s -> Getting a s a -> a
^.forall n. Lens' (Result n) Image
imageLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to Image -> Int
imageHeight
      x :: Int
x = (Context n
cforall s a. s -> Getting a s a -> a
^.forall n. Lens' (Context n) Int
availWidthL forall a. Integral a => a -> a -> a
`div` Int
2) forall a. Num a => a -> a -> a
- (Int
rWidth forall a. Integral a => a -> a -> a
`div` Int
2)
      y :: Int
y = (Context n
cforall s a. s -> Getting a s a -> a
^.forall n. Lens' (Context n) Int
availHeightL forall a. Integral a => a -> a -> a
`div` Int
2) forall a. Num a => a -> a -> a
- (Int
rHeight forall a. Integral a => a -> a -> a
`div` Int
2)

  forall n. Widget n -> RenderM n (Result n)
render forall a b. (a -> b) -> a -> b
$ forall n. Location -> Widget n -> Widget n
translateBy ((Int, Int) -> Location
Location (Int
x,Int
y)) forall a b. (a -> b) -> a -> b
$ forall n. Image -> Widget n
raw (Result n
resforall s a. s -> Getting a s a -> a
^.forall n. Lens' (Result n) Image
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) = forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget Size
Fixed Size
Fixed forall a b. (a -> b) -> a -> b
$ do
  Context n
c <- forall n. RenderM n (Context n)
getContext

  forall n. Widget n -> RenderM n (Result n)
render forall a b. (a -> b) -> a -> b
$
    forall n. Int -> Widget n -> Widget n
hLimit (forall a. Ord a => a -> a -> a
min Int
80 forall a b. (a -> b) -> a -> b
$ Context n
cforall s a. s -> Getting a s a -> a
^.forall n. Lens' (Context n) Int
availWidthL) forall a b. (a -> b) -> a -> b
$
    forall n. Int -> Widget n -> Widget n
vLimit (forall a. Ord a => a -> a -> a
min Int
30 forall a b. (a -> b) -> a -> b
$ Context n
cforall s a. s -> Getting a s a -> a
^.forall n. Lens' (Context n) Int
availHeightL) forall a b. (a -> b) -> a -> b
$
    forall n. Widget n -> Widget n -> Widget n
borderWithLabel (forall n. Text -> Widget n
txt Text
"Help") forall a b. (a -> b) -> a -> b
$
    forall n.
(Ord n, Show n) =>
n -> ViewportType -> Widget n -> Widget n
viewport n
name ViewportType
Vertical forall a b. (a -> b) -> a -> b
$
    forall n. [Widget n] -> Widget n
vBox forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse (forall n. Text -> Widget n
txt Text
" ") forall a b. (a -> b) -> a -> b
$
    forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry 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 :: n
name :: forall n. HelpWidget n -> n
name} = 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' -> forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall n. HelpWidget n -> ViewportScroll n
scroller forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ViewportScroll n
s -> forall n. ViewportScroll n -> forall s. Int -> EventM n s ()
vScrollBy ViewportScroll n
s Int
1
  Key
KDown     -> forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall n. HelpWidget n -> ViewportScroll n
scroller forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ViewportScroll n
s -> forall n. ViewportScroll n -> forall s. Int -> EventM n s ()
vScrollBy ViewportScroll n
s Int
1
  KChar Char
'k' -> forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall n. HelpWidget n -> ViewportScroll n
scroller forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ViewportScroll n
s -> forall n. ViewportScroll n -> forall s. Int -> EventM n s ()
vScrollBy ViewportScroll n
s (-Int
1)
  Key
KUp       -> forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall n. HelpWidget n -> ViewportScroll n
scroller forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ViewportScroll n
s -> forall n. ViewportScroll n -> forall s. Int -> EventM n s ()
vScrollBy ViewportScroll n
s (-Int
1)
  KChar Char
'g' -> forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall n. HelpWidget n -> ViewportScroll n
scroller forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ViewportScroll n
s -> forall n. ViewportScroll n -> forall s. EventM n s ()
vScrollToBeginning ViewportScroll n
s
  Key
KHome     -> forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall n. HelpWidget n -> ViewportScroll n
scroller forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ViewportScroll n
s -> forall n. ViewportScroll n -> forall s. EventM n s ()
vScrollToBeginning ViewportScroll n
s
  KChar Char
'G' -> forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall n. HelpWidget n -> ViewportScroll n
scroller forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ViewportScroll n
s -> forall n. ViewportScroll n -> forall s. EventM n s ()
vScrollToEnd ViewportScroll n
s
  Key
KEnd      -> forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall n. HelpWidget n -> ViewportScroll n
scroller forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ViewportScroll n
s -> forall n. ViewportScroll n -> forall s. EventM n s ()
vScrollToEnd ViewportScroll n
s
  Key
KPageUp   -> forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall n. HelpWidget n -> ViewportScroll n
scroller forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ViewportScroll n
s -> forall n. ViewportScroll n -> forall s. Direction -> EventM n s ()
vScrollPage ViewportScroll n
s Direction
Up
  Key
KPageDown -> forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall n. HelpWidget n -> ViewportScroll n
scroller forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ViewportScroll n
s -> forall n. ViewportScroll n -> forall s. Direction -> EventM n s ()
vScrollPage ViewportScroll n
s Direction
Down
  Key
_         -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
handleHelpEvent Event
_ = 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 = forall n. ViewportScroll n -> forall s. EventM n s ()
vScrollToBeginning (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 =  forall n. AttrName -> Widget n -> Widget n
withAttr (AttrName
helpAttr forall a. Semigroup a => a -> a -> a
<> String -> AttrName
attrName String
"key") (forall n. Text -> Widget n
txt (Text
"  " forall a. Semigroup a => a -> a -> a
<> Text
k))
       forall n. Widget n -> Widget n -> Widget n
<+> forall n. Padding -> Widget n -> Widget n
padLeft Padding
Max (forall n. AttrName -> Widget n -> Widget n
withAttr (AttrName
helpAttr forall a. Semigroup a => a -> a -> a
<> String -> AttrName
attrName String
"description") (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 =  forall n. AttrName -> Widget n -> Widget n
withAttr (AttrName
helpAttr forall a. Semigroup a => a -> a -> a
<> String -> AttrName
attrName String
"title") (forall n. Text -> Widget n
txt (Text
title forall a. Semigroup a => a -> a -> a
<> Text
":"))
                  forall n. Widget n -> Widget n -> Widget n
<=> forall n. [Widget n] -> Widget n
vBox (forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall n. Text -> Text -> Widget n
key) [(Text, Text)]
keys)