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
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)
onDialogAccept :: Dialog -> (Dialog -> IO ()) -> IO ()
onDialogAccept = addHandler (return . dialogAcceptHandlers)
onDialogCancel :: Dialog -> (Dialog -> IO ()) -> IO ()
onDialogCancel = addHandler (return . dialogCancelHandlers)
acceptDialog :: Dialog -> IO ()
acceptDialog dlg = fireEvent dlg (return . dialogAcceptHandlers) dlg
cancelDialog :: Dialog -> IO ()
cancelDialog dlg = fireEvent dlg (return . dialogCancelHandlers) dlg