StackWidget.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.StackWidget (
    StackWidget,
    stackWidgetNew,
    stackWidgetAdd,
    stackWidgetGet,
    stackWidgetShow,
    stackWidgetGetVisible
) where

import qualified System.Glib.Types as Gtk
import qualified Graphics.UI.Gtk as Gtk
import qualified Data.Map.Strict as Map

import Control.Monad

import Coin.Utils.IORef

data StackWidget = StackWidget {
    stackContainer :: Gtk.VBox,
    stackWidgetMap :: IORef (Map.Map String Gtk.Widget)
}

instance Gtk.GObjectClass StackWidget where
    toGObject = Gtk.toGObject . stackContainer
    unsafeCastGObject = undefined

instance Gtk.WidgetClass StackWidget

stackWidgetNew :: IO StackWidget
stackWidgetNew = do
    box <- Gtk.vBoxNew False 0
    Gtk.widgetShow box
    ref <- newIORef Map.empty
    return $ StackWidget box ref

stackWidgetAdd :: Gtk.WidgetClass cls => StackWidget -> String -> cls -> IO ()
stackWidgetAdd stack name widget = do
    Gtk.boxPackStart (stackContainer stack) widget Gtk.PackGrow 0
    atomicModifyIORef_' (stackWidgetMap stack) $ Map.insert name (Gtk.castToWidget widget)
    Gtk.widgetHide widget

stackWidgetGet :: StackWidget -> String -> IO Gtk.Widget
stackWidgetGet stack name = do
    (Just w) <- Map.lookup name <$> atomicReadIORef' (stackWidgetMap stack)
    return w

stackWidgetShow :: StackWidget -> String -> IO ()
stackWidgetShow stack name = do
    m <- readIORef $ stackWidgetMap stack
    case Map.lookup name m of
        Just widget -> do
            forM_ (Map.elems m) Gtk.widgetHide
            Gtk.widgetShow widget
        Nothing     -> return ()

stackWidgetGetVisible :: StackWidget -> IO (Maybe String)
stackWidgetGetVisible stack = do
    m <- readIORef $ stackWidgetMap stack

    foldM (\rval (name, widget) ->
              case rval of
                  j@(Just _) ->
                      return j
                  Nothing -> do
                      visible <- Gtk.widgetGetVisible widget
                      if visible then return $ Just name
                      else return Nothing
          )
          Nothing
          (Map.toList m)