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

import Brick
import Brick.Markup
import Brick.Widgets.Border
import Graphics.Vty
import Data.Text (Text)
import Data.Monoid ((<>))
import Data.List
import Lens.Micro

type Title = Text

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

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

type Name n = (Ord n, Show n)

helpWidget :: n -> KeyBindings -> HelpWidget n
helpWidget :: 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 :: 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} =
  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 :: 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
c <- RenderM n Context
forall n. RenderM n Context
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. Lens' (Result n) Image
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. Lens' (Result n) Image
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
cContext -> Getting Int Context Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int Context Int
Lens' Context Int
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
cContext -> Getting Int Context Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int Context Int
Lens' Context Int
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. Lens' (Result n) Image
imageL)

renderHelpWidget' :: Name n => n -> KeyBindings -> Widget n
renderHelpWidget' :: n -> KeyBindings -> Widget n
renderHelpWidget' n
name (KeyBindings [(Title, [(Title, Title)])]
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
c <- RenderM n Context
forall n. RenderM n Context
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
cContext -> Getting Int Context Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int Context Int
Lens' Context Int
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
cContext -> Getting Int Context Int -> Int
forall s a. s -> Getting a s a -> a
^.Getting Int Context Int
Lens' Context Int
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 (Title -> Widget n
forall n. Title -> Widget n
txt Title
"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 (Title -> Widget n
forall n. Title -> Widget n
txt Title
" ") ([Widget n] -> [Widget n]) -> [Widget n] -> [Widget n]
forall a b. (a -> b) -> a -> b
$
    ((Title, [(Title, Title)]) -> Widget n)
-> [(Title, [(Title, Title)])] -> [Widget n]
forall a b. (a -> b) -> [a] -> [b]
map ((Title -> [(Title, Title)] -> Widget n)
-> (Title, [(Title, Title)]) -> Widget n
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Title -> [(Title, Title)] -> Widget n
forall n. Title -> [(Title, Title)] -> Widget n
section) [(Title, [(Title, Title)])]
bindings

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

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


resetHelpWidget :: HelpWidget n -> EventM n ()
resetHelpWidget :: HelpWidget n -> EventM n ()
resetHelpWidget = ViewportScroll n -> EventM n ()
forall n. ViewportScroll n -> EventM n ()
vScrollToBeginning (ViewportScroll n -> EventM n ())
-> (HelpWidget n -> ViewportScroll n)
-> HelpWidget n
-> EventM n ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HelpWidget n -> ViewportScroll n
forall n. HelpWidget n -> ViewportScroll n
scroller

key :: Text -> Text -> Widget n
key :: Title -> Title -> Widget n
key Title
k Title
h =  Markup AttrName -> Widget n
forall a n. (Eq a, GetAttr a) => Markup a -> Widget n
markup ((Title
"  " Title -> Title -> Title
forall a. Semigroup a => a -> a -> a
<> Title
k) Title -> AttrName -> Markup AttrName
@? (AttrName
helpAttr AttrName -> AttrName -> AttrName
forall a. Semigroup a => a -> a -> a
<> AttrName
"key"))
       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 (Markup AttrName -> Widget n
forall a n. (Eq a, GetAttr a) => Markup a -> Widget n
markup (Title
h Title -> AttrName -> Markup AttrName
@? (AttrName
helpAttr AttrName -> AttrName -> AttrName
forall a. Semigroup a => a -> a -> a
<> AttrName
"description")))

helpAttr :: AttrName
helpAttr :: AttrName
helpAttr = AttrName
"help"

section :: Title -> [(Text, Text)] -> Widget n
section :: Title -> [(Title, Title)] -> Widget n
section Title
title [(Title, Title)]
keys =  Markup AttrName -> Widget n
forall a n. (Eq a, GetAttr a) => Markup a -> Widget n
markup ((Title
title Title -> Title -> Title
forall a. Semigroup a => a -> a -> a
<> Title
":") Title -> AttrName -> Markup AttrName
@? (AttrName
helpAttr AttrName -> AttrName -> AttrName
forall a. Semigroup a => a -> a -> a
<> AttrName
"title"))
                  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 (((Title, Title) -> Widget n) -> [(Title, Title)] -> [Widget n]
forall a b. (a -> b) -> [a] -> [b]
map ((Title -> Title -> Widget n) -> (Title, Title) -> Widget n
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Title -> Title -> Widget n
forall n. Title -> Title -> Widget n
key) [(Title, Title)]
keys)