MessageBox.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.MessageBox (
    messageBoxNew,
    messageBoxNew_
) where

import Graphics.UI.Gtk

import Coin.UI.Builder.GtkUIBuilder
import Coin.Locale.Translate
import Coin.UI.Widgets.ResponseButtons
import Coin.UI.Utils.CssUtils
import Coin.Config.Version

messageBoxNew :: MessageType -> ButtonsType -> String -> (ResponseId -> IO ()) -> IO ()
messageBoxNew mType bType msg fun = do
    responseButtons <- responseButtonsNew bType

    let labelCss =
            [ if gtkVersionOld then ".label {" else "label {"
            , "    font-size: 1.2em;"
            , "    padding: 5px;"
            , "}"
            ]
    (_, root) <- uiBuildGtk $ do
        windowAttrs [ windowModal := True, windowTypeHint := WindowTypeHintDialog, windowResizable := False ]
        window Nothing (messageBoxGetTitle mType) $ do
            vbox Nothing False 0 $ do
                packing PackGrow 5
                hbox Nothing False 0 $ do
                    packing PackNatural 5
                    imageFromStock Nothing (messageBoxGetImage mType) IconSizeDialog
                    labelAttrs [ cssStyle := labelCss ]
                    label Nothing msg
                packDefault $ hseparator Nothing
                putWidget responseButtons

    responseButtonsOnActivated responseButtons $ \r -> do
        widgetDestroy root
        fun r

    widgetShowAll root

    return ()

messageBoxNew_ :: MessageType -> ButtonsType -> String -> IO ()
messageBoxNew_ mType bType msg = messageBoxNew mType bType msg $ \_ -> do return ()

messageBoxGetImage :: MessageType -> StockId
messageBoxGetImage mType =
    case mType of
        MessageInfo     -> stockDialogInfo
        MessageWarning  -> stockDialogWarning
        MessageQuestion -> stockDialogQuestion
        MessageError    -> stockDialogError
        _               -> stockMissingImage

messageBoxGetTitle :: MessageType -> String
messageBoxGetTitle mType =
    case mType of
        MessageInfo     -> __ "Info"
        MessageWarning  -> __ "Warning"
        MessageQuestion -> __ "Question"
        MessageError    -> __ "Error"
        _               -> ""