ResponseButtons.hs

{-
 *  Programmer:	Piotr Borek
 *  E-mail:     piotrborek@op.pl
 *  Copyright 2015 Piotr Borek
 *
 *  Distributed under the terms of the GPL (GNU Public License)
 *
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or
 *  (at your option) any later version.
 *
 *  This program is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License
 *  along with this program; if not, write to the Free Software
 *  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
-}

module Coin.UI.Widgets.ResponseButtons (
    responseButtonsNew,
    responseButtonsOnActivated
) where

import System.Glib.Types
import Graphics.UI.Gtk

import Control.Monad

import Coin.UI.Builder.GtkUIBuilder
import Coin.UI.Utils.CssUtils

data ResponseButtonsWidget = ResponseButtonsWidget {
    widgetContainer :: HBox,
    button1         :: Maybe Button,
    button2         :: Maybe Button,
    buttonType      :: ButtonsType
}

instance GObjectClass ResponseButtonsWidget where
    toGObject = toGObject . widgetContainer
    unsafeCastGObject = undefined

instance WidgetClass ResponseButtonsWidget

responseButtonsNew :: ButtonsType -> IO ResponseButtonsWidget
responseButtonsNew bType = do
    (getObject, root) <-uiBuildGtk $ do
        hbox Nothing False 0 $ do
            label Nothing ""
            packing PackNatural 5
            hbox Nothing True 0 $ do
                packing PackGrow 0
                myButtonsNew bType

    let b1 = castToButton `liftM` getObject "button1"
    let b2 = castToButton `liftM` getObject "button2"

    return $ ResponseButtonsWidget (castToHBox root) b1 b2 bType

responseButtonsOnActivated :: ResponseButtonsWidget -> (ResponseId -> IO ()) -> IO ()
responseButtonsOnActivated w f = do
    case button1 w of
        Just b1 ->
            case buttonType w of
                ButtonsYesNo    -> do
                    _ <- on b1 buttonActivated $ f ResponseYes
                    return ()
                ButtonsOkCancel -> do
                    _ <- on b1 buttonActivated $ f ResponseOk
                    return ()
                _               ->
                    return ()
        Nothing ->
            return ()

    case button2 w of
        Just b2 ->
            case buttonType w of
                ButtonsYesNo    -> do
                    _ <- on b2 buttonActivated $ f ResponseNo
                    return ()
                ButtonsOkCancel -> do
                    _ <- on b2 buttonActivated $ f ResponseCancel
                    return ()
                ButtonsOk     -> do
                    _ <- on b2 buttonActivated $ f ResponseOk
                    return ()
                ButtonsClose  -> do
                    _ <- on b2 buttonActivated $ f ResponseClose
                    return ()
                ButtonsCancel -> do
                    _ <- on b2 buttonActivated $ f ResponseCancel
                    return ()
                _             ->
                    return ()
        Nothing ->
            return ()

myButtonsNew :: ButtonsType -> UIBuilder a
myButtonsNew bType = do
    let buttonCss =
            [ "button {"
            , "    padding-left: 15px;"
            , "    padding-right: 15px;"
            , "}"
            ]
    case bType of
        ButtonsNone     -> do
            label Nothing ""
            label Nothing ""
        ButtonsOk       -> do
            label Nothing ""
            buttonAttrs [ cssStyle := buttonCss ]
            buttonFromStock (Just "button2") stockOk
        ButtonsClose    -> do
            label Nothing ""
            buttonAttrs [ cssStyle := buttonCss ]
            buttonFromStock (Just "button2") stockClose
        ButtonsCancel   -> do
            label Nothing ""
            buttonAttrs [ cssStyle := buttonCss ]
            buttonFromStock (Just "button2") stockCancel
        ButtonsYesNo    -> do
            buttonAttrs [ cssStyle := buttonCss ]
            buttonFromStock (Just "button1") stockYes
            buttonAttrs [ cssStyle := buttonCss ]
            buttonFromStock (Just "button2") stockNo
        ButtonsOkCancel -> do
            buttonAttrs [ cssStyle := buttonCss ]
            buttonFromStock (Just "button1") stockOk
            buttonAttrs [ cssStyle := buttonCss ]
            buttonFromStock (Just "button2") stockCancel