casui-0.3: Casui/Menu.hs

module Casui.Menu where

import Graphics.UI.Gtk
import Control.Monad

populateMenu :: MenuShellClass a => a -> [SimpleMenu] -> IO ()
populateMenu shell = mapM_ ((menuShellAppend shell =<<) . buildMenu)

buildMenu (LeafM name action) = do
  item <- menuItemNewWithLabel name
  onActivateLeaf item action
  return item
buildMenu SeperatorM = fmap castToMenuItem separatorMenuItemNew
buildMenu (MenuM name children) = do
  item <- menuItemNewWithLabel name
  menu <- menuNew
  menuItemSetSubmenu item menu
  populateMenu menu children
  return item
buildMenu (DynM name mchildren) = do
  item <- menuItemNewWithLabel name
  menu <- menuNew
  menuItemSetSubmenu item menu
  onSelect item $ do
    children <- mchildren
    when (genMenuValue children) $
        do mapM_ (containerRemove menu) =<< containerGetChildren menu
           populateMenu menu $ genMenuItems children
           widgetShowAll menu
  return item


data SimpleMenu = LeafM String (IO ())
                | SeperatorM
                | MenuM String [SimpleMenu]
                | DynM String (IO (GenMenu Bool))

data GenMenu a = GenMenu { genMenuItems :: [SimpleMenu], genMenuValue :: a }

instance Monad GenMenu where
    return = GenMenu []
    GenMenu l a >>= f = case f a of GenMenu k b -> GenMenu (l++k) b

seperator = GenMenu [SeperatorM] ()

leaf a b = GenMenu [LeafM a b] ()

submenu a s = GenMenu [MenuM a $ genMenuItems s] ()

dynamicMenu a s = GenMenu [DynM a s] ()