module HTk.Toolkit.HTkMenu(
HTkMenu(..),
compileHTkMenu,
) where
import Util.Computation
import Events.Events
import HTk.Kernel.Core(HasCommand(..))
import HTk.Kernel.Packer(Container)
import HTk.Kernel.Configuration(HasText(..))
import HTk.Menuitems.Menu
import HTk.Widgets.MenuButton
import HTk.Menuitems.MenuCascade
import HTk.Menuitems.MenuSeparator
import HTk.Menuitems.MenuCommand
import HTk.Toolkit.MenuType hiding (MenuPrim(Menu))
import qualified HTk.Toolkit.MenuType as MenuType (MenuPrim(Menu))
newtype HTkMenu value = HTkMenu (MenuType.MenuPrim String value)
compileHTkMenu :: Container parent => parent -> HTkMenu value
-> IO (MenuButton,Event value)
compileHTkMenu parent htkMenu =
do
let (title,subMenus) = normalise htkMenu
menuButton <- newMenuButton parent [text title]
topMenu <- createMenu menuButton tearoff []
menuButton # menu topMenu
clickEvents <- mapM (compileMenuPrim topMenu) subMenus
return (menuButton,choose clickEvents)
normalise :: HTkMenu value -> (String,[MenuType.MenuPrim String value])
normalise (HTkMenu menuPrim) =
case menuPrim of
MenuType.Menu title subMenus -> (title,subMenus)
Button s value -> (s,[menuPrim])
Blank -> ("",[Blank])
tearoff :: Bool
tearoff = False
compileMenuPrim :: Menu -> MenuType.MenuPrim String value -> IO (Event value)
compileMenuPrim parent menuPrim =
case menuPrim of
Button string value ->
do
menuCommand <- createMenuCommand parent [text string]
event <- clicked menuCommand
return (event >> return value)
Blank ->
do
menuSeparator <- createMenuSeparator parent []
return never
MenuType.Menu title subMenuPrims ->
do
cascade <- createMenuCascade parent [text title]
innerMenu <- createMenu parent tearoff []
cascade # menu innerMenu
events <- mapM (compileMenuPrim innerMenu) subMenuPrims
return (choose events)