Dialog.hs

{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
-- |This module provides a simple ''dialog'' interface with an ''OK''
-- button and a ''Cancel'' button.  The dialog itself is capable of
-- embedding an arbitrary interface and it exposes ''accept'' and
-- ''cancel'' events which are triggered by the dialog's buttons.
module Graphics.Vty.Widgets.Dialog
    ( Dialog(dialogWidget, setDialogTitle)
    , newDialog
    , onDialogAccept
    , onDialogCancel
    , acceptDialog
    , cancelDialog
    )
where

import qualified Data.Text as T
import Graphics.Vty.Widgets.Centering
import Graphics.Vty.Widgets.Button
import Graphics.Vty.Widgets.Padding
import Graphics.Vty.Widgets.Events
import Graphics.Vty.Widgets.Borders
import Graphics.Vty.Widgets.Box
import Graphics.Vty.Widgets.Core

data Dialog = Dialog { dialogWidget :: Widget (Bordered Padded)
                     , setDialogTitle :: T.Text -> IO ()
                     , dialogAcceptHandlers :: Handlers Dialog
                     , dialogCancelHandlers :: Handlers Dialog
                     }

instance HasNormalAttr Dialog where
    setNormalAttribute d a = setNormalAttribute (dialogWidget d) a

-- |Create a new dialog with the specified embedded interface and
-- title.  Returns the dialog itself and the 'FocusGroup' to which its
-- buttons were added, for use in your application.
newDialog :: (Show a) => Widget a -> T.Text -> IO (Dialog, Widget FocusGroup)
newDialog body title = do
  okB <- newButton $ T.pack "OK"
  cancelB <- newButton $ T.pack "Cancel"

  buttonBox <- (return $ buttonWidget okB) <++> (return $ buttonWidget cancelB)
  setBoxSpacing buttonBox 4

  b <- withPadding (padTopBottom 1) =<<
       ((hCentered body) <--> (hCentered buttonBox) >>= withBoxSpacing 1)

  fg <- newFocusGroup
  addToFocusGroup fg $ buttonWidget okB
  addToFocusGroup fg $ buttonWidget cancelB

  b2 <- bordered b >>=
        withBorderedLabel title

  ahs <- newHandlers
  chs <- newHandlers

  let dlg = Dialog { dialogWidget = b2
                   , setDialogTitle = setBorderedLabel b2
                   , dialogAcceptHandlers = ahs
                   , dialogCancelHandlers = chs
                   }

  okB `onButtonPressed` (const $ acceptDialog dlg)
  cancelB `onButtonPressed` (const $ cancelDialog dlg)

  return (dlg, fg)

-- |Register an event handler for the dialog's acceptance event.
onDialogAccept :: Dialog -> (Dialog -> IO ()) -> IO ()
onDialogAccept = addHandler (return . dialogAcceptHandlers)

-- |Register an event handler for the dialog's cancellation event.
onDialogCancel :: Dialog -> (Dialog -> IO ()) -> IO ()
onDialogCancel = addHandler (return . dialogCancelHandlers)

-- |Programmatically accept the dialog.
acceptDialog :: Dialog -> IO ()
acceptDialog dlg = fireEvent dlg (return . dialogAcceptHandlers) dlg

-- |Programmatically cancel the dialog.
cancelDialog :: Dialog -> IO ()
cancelDialog dlg = fireEvent dlg (return . dialogCancelHandlers) dlg