pgdl-8.1: src/AskScene.hs

{-# LANGUAGE OverloadedStrings #-}

module AskScene where

import Graphics.Vty.Widgets.All
import Graphics.Vty.Input.Events

import Control.Monad

data AskScene = AskScene { sceneWidget :: Widget (Bordered Padded)
                         , playHand :: Handlers AskScene
                         , downHand :: Handlers AskScene
                         , quitHand :: Handlers AskScene
                         , remvHand :: Handlers AskScene
                         }

newAskScene :: IO (AskScene, Widget FocusGroup)
newAskScene = do
    playB <- newButton "No"
    downB <- newButton "Yes"
    quitB <- newButton "Quit"
    remvB <- newButton "Remov"
    buttonBox <- mkwIO playB <++> mkwIO downB <++> mkwIO quitB <++> mkwIO remvB
    b <- do
        bx <- plainText "    Download it again?" <--> return buttonBox
        setBoxSpacing bx 1
        withPadding (padAll 1) bx
    fg <- newFocusGroup
    mapM_ (addToFocusGroup fg . buttonWidget) [playB, downB, quitB, remvB]
    ui <- withBorderedLabel "File Exists!" =<< bordered b
    [phs, dhs, qhs, rhs] <- replicateM 4 newHandlers
    let sce = AskScene { sceneWidget = ui
                       , playHand = phs
                       , downHand = dhs
                       , quitHand = qhs
                       , remvHand = rhs
                       }
    onButtonPressed playB $ \_ -> 
        fireEvent sce (return . playHand) sce
    onButtonPressed downB $ \_ -> 
        fireEvent sce (return . downHand) sce
    onButtonPressed quitB $ \_ -> 
        fireEvent sce (return . quitHand) sce
    onButtonPressed remvB $ \_ ->
        fireEvent sce (return . remvHand) sce
    setFocusGroupNextKey fg KRight []
    setFocusGroupPrevKey fg KLeft []
    return (sce, fg)
    where mkwIO = return . buttonWidget

onScePlay :: AskScene -> Handler AskScene -> IO ()
onScePlay = addHandler (return . playHand)

onSceDown :: AskScene -> Handler AskScene -> IO ()
onSceDown = addHandler (return . downHand)

onSceQuit :: AskScene -> Handler AskScene -> IO ()
onSceQuit = addHandler (return . quitHand)

onSceRemv :: AskScene -> Handler AskScene -> IO()
onSceRemv = addHandler (return . remvHand)