Add a dialog type and demo

TODO.txt

@@ -8,7 +8,6 @@ Features:
 - Port widgets from vty-ui:
   - Progress bar?
   - Dir browser?
-  - Dialog?
   - Checkbox?
   - Button?
 - Overlays relative to a specific widget (e.g. drop-downs) using layers

brick.cabal

@@ -42,6 +42,7 @@ library
     Brick.Widgets.Border.Style
     Brick.Widgets.Center
     Brick.Widgets.Core
+    Brick.Widgets.Dialog
     Brick.Widgets.Edit
     Brick.Widgets.List
     Data.Text.Markup
@@ -100,6 +101,18 @@ executable brick-bench
                        containers,
                        vector
 
+executable brick-dialog-demo
+  hs-source-dirs:      programs
+  ghc-options:         -threaded -Wall -fno-warn-unused-do-bind -O3
+  default-language:    Haskell2010
+  main-is:             DialogDemo.hs
+  build-depends:       base,
+                       brick,
+                       vty >= 5.2.9,
+                       data-default,
+                       text,
+                       lens
+
 executable brick-layer-demo
   hs-source-dirs:      programs
   ghc-options:         -threaded -Wall -fno-warn-unused-do-bind -O3

programs/DialogDemo.hs

@@ -0,0 +1,57 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Main where
+
+import Data.Monoid
+import Graphics.Vty hiding (translate)
+
+import Brick.Main
+import Brick.Widgets.Core
+import Brick.Widgets.Dialog
+import Brick.AttrMap
+import Brick.Util
+import Brick.Types
+
+data Choice = Red | Blue | Green
+            deriving Show
+
+drawUI :: Dialog Choice -> [Widget]
+drawUI d = [ui]
+    where
+        ui = renderDialog d $ str "This is the dialog body."
+
+appEvent :: Dialog Choice -> Event -> EventM (Next (Dialog Choice))
+appEvent d ev =
+    case ev of
+        EvKey KEsc [] -> halt d
+        EvKey KEnter [] -> halt d
+        _ -> continue $ handleEvent ev d
+
+initialState :: Dialog Choice
+initialState = dialog "dialog" (Just "Title") (Just (0, choices)) 50
+    where
+        choices = [ ("Red", Red)
+                  , ("Blue", Blue)
+                  , ("Green", Green)
+                  ]
+
+theMap :: AttrMap
+theMap = attrMap defAttr
+    [ (dialogAttr, white `on` blue)
+    , (buttonAttr, black `on` white)
+    , (buttonSelectedAttr, bg yellow)
+    ]
+
+theApp :: App (Dialog Choice) Event
+theApp =
+    App { appDraw = drawUI
+        , appChooseCursor = showFirstCursor
+        , appHandleEvent = appEvent
+        , appStartEvent = return
+        , appAttrMap = const theMap
+        , appMakeVtyEvent = id
+        }
+
+main :: IO ()
+main = do
+    d <- defaultMain theApp initialState
+    putStrLn $ "You chose: " <> show (dialogSelection d)

src/Brick/Widgets/Dialog.hs

@@ -0,0 +1,100 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Brick.Widgets.Dialog
+  ( Dialog
+  , dialog
+  , renderDialog
+  , dialogSelection
+  , dialogAttr
+  , buttonAttr
+  , buttonSelectedAttr
+  )
+where
+
+import Control.Lens
+import Control.Applicative
+import Data.Monoid
+import Data.List (intersperse)
+import Graphics.Vty.Input (Event(..), Key(..))
+
+import Brick.Util (clamp)
+import Brick.Types
+import Brick.Widgets.Core
+import Brick.Widgets.Center
+import Brick.Widgets.Border
+import Brick.AttrMap
+
+data Dialog a =
+    Dialog { dialogName :: Name
+           , dialogTitle :: Maybe String
+           , dialogButtons :: [(String, a)]
+           , dialogSelectedIndex :: Maybe Int
+           , dialogWidth :: Int
+           }
+
+suffixLenses ''Dialog
+
+instance HandleEvent (Dialog a) where
+    handleEvent ev d =
+        case ev of
+            EvKey (KChar '\t') [] -> nextButton d
+            EvKey KBackTab [] -> prevButton d
+            _ -> d
+
+dialog :: Name -> Maybe String -> Maybe (Int, [(String, a)]) -> Int -> Dialog a
+dialog name title buttonData w =
+    let (buttons, idx) = case buttonData of
+          Nothing -> ([], Nothing)
+          Just (_, []) -> ([], Nothing)
+          Just (i, bs) -> (bs, Just $ clamp 0 (length bs - 1) i)
+    in Dialog name title buttons idx w
+
+dialogAttr :: AttrName
+dialogAttr = "dialog"
+
+buttonAttr :: AttrName
+buttonAttr = "button"
+
+buttonSelectedAttr :: AttrName
+buttonSelectedAttr = buttonAttr <> "selected"
+
+renderDialog :: Dialog a -> Widget -> Widget
+renderDialog d body =
+    let buttonPadding = "  "
+        mkButton (i, (s, _)) = let att = if Just i == d^.dialogSelectedIndexL
+                                         then buttonSelectedAttr
+                                         else buttonAttr
+                               in withAttr att $ str $ "  " <> s <> "  "
+        buttons = hBox $ intersperse buttonPadding $
+                         mkButton <$> (zip [0..] (d^.dialogButtonsL))
+
+        doBorder = maybe border borderWithLabel (str <$> d^.dialogTitleL)
+    in center $
+       withDefaultAttr dialogAttr $
+       doBorder $
+       hLimit (d^.dialogWidthL) $
+       vBox [ body
+            , hCenter buttons
+            ]
+
+nextButton :: Dialog a -> Dialog a
+nextButton d =
+    if null (d^.dialogButtonsL)
+    then d
+    else case d^.dialogSelectedIndexL of
+        Nothing -> d & dialogSelectedIndexL .~ (Just 0)
+        Just i -> d & dialogSelectedIndexL .~ (Just $ (i + 1) `mod` (length (d^.dialogButtonsL)))
+
+prevButton :: Dialog a -> Dialog a
+prevButton d =
+    if null (d^.dialogButtonsL)
+    then d
+    else case d^.dialogSelectedIndexL of
+        Nothing -> d & dialogSelectedIndexL .~ (Just 0)
+        Just i -> d & dialogSelectedIndexL .~ (Just $ (i - 1) `mod` (length (d^.dialogButtonsL)))
+
+dialogSelection :: Dialog a -> Maybe a
+dialogSelection d =
+    case d^.dialogSelectedIndexL of
+        Nothing -> Nothing
+        Just i -> Just $ ((d^.dialogButtonsL) !! i)^._2