{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} -------------------------------------------------------------------------------- {-| Module : Menu Copyright : (c) Daan Leijen 2003 (c) Shelarcy (shelarcy@gmail.com) 2006 License : wxWindows Maintainer : wxhaskell-devel@lists.sourceforge.net Stability : provisional Portability : portable Defines Menus, toolbars, and statusbars. The function 'menuPane' is used to create a menu that can contain 'menuItem's. Menu items can contain event handlers using ('on' 'command'), but they can also be set, using the 'menu' function, on a frame or (mdi) window so that the menu command is handled in the context of the active window instead of the context of the entire application. > do frame <- frame [text := "Demo"] > file <- menuPane [text := "&File"] > mclose <- menuItem file [text := "&Close\tCtrl+C", help := "Close the document"] > set frame [menuBar := [file] > ,on (menu mclose) := ...] -} -------------------------------------------------------------------------------- module Graphics.UI.WX.Menu ( -- * Menu -- ** Menu containers MenuBar, Menu, menuBar, menuPopup, menuPane, menuHelp , menuRes, menuBarLoadRes -- ** Menu events , menu, menuId -- ** Menu items , MenuItem, menuItem, menuQuit, menuAbout, menuItemEx , menuItemOnCommandRes, menuLine, menuSub, menuRadioItem -- * Tool bar , ToolBar, toolBar, toolBarEx , ToolBarItem, toolMenu, toolMenuFromBitmap, toolItem, toolControl, tool -- * Status bar , StatusField, statusBar, statusField, statusWidth -- * Deprecated , menuList, menubar, statusbar ) where import Data.Char( toUpper ) import Data.List( partition, intersperse ) import System.IO.Unsafe (unsafePerformIO) import Foreign.Ptr( nullPtr ) import Graphics.UI.WXCore hiding (Event) import Graphics.UI.WX.Types import Graphics.UI.WX.Attributes import Graphics.UI.WX.Layout import Graphics.UI.WX.Classes import Graphics.UI.WX.Events {-------------------------------------------------------------------------------- Menubar --------------------------------------------------------------------------------} {-# DEPRECATED menubar "Use menuBar instead" #-} -- | /Deprecated/: use 'menuBar'. menubar :: WriteAttr (Frame a) [Menu ()] menubar = menuBar -- | Set the menu bar of a frame. menuBar :: WriteAttr (Frame a) [Menu ()] menuBar = writeAttr "menubar" setter where setter frame menus = do mb <- menuBarCreate wxMB_DOCKABLE mapM_ (append mb) menus frameSetMenuBar frame mb -- set delayed menu handlers on the frame mapM_ (evtHandlerSetAndResetMenuCommands frame) menus -- work around menu bug in wxMac 2.5.1 vis <- windowIsShown frame if (vis && wxToolkit == WxMac && (div wxVersion 100) >= 25) then do windowHide frame windowShow frame return () else return () append mb menu = do title <- menuGetTitle menu menuSetTitle menu "" menuBarAppend mb menu title -- | Retrieve a menu bar instance which has been constructed by loading -- a resource file for a given top level window. menuBarLoadRes :: Window a -> FilePath -> String -> IO (MenuBar ()) menuBarLoadRes parent rc name = do res <- xmlResourceCreateFromFile rc wxXRC_USE_LOCALE m <- xmlResourceLoadMenuBar res parent name return m -- | Show a popup menu for a certain window. menuPopup :: Menu b -> Point -> Window a -> IO () menuPopup menu pt parent = do windowPopupMenu parent menu pt return () {-------------------------------------------------------------------------------- Menu --------------------------------------------------------------------------------} {-# DEPRECATED menuList "Use menuPane instead" #-} -- | /Deprecated/: use 'menuPane'. menuList :: [Prop (Menu ())] -> IO (Menu ()) menuList = menuPane -- | Create a new menu with a certain title (corresponds with 'text' attribute). -- -- * Instances: 'Textual' -- menuPane :: [Prop (Menu ())] -> IO (Menu ()) menuPane props = do m <- menuCreate "" wxMENU_TEAROFF set m props return m -- | Append a /help/ menu item (@"&Help"@). On some platforms, -- the /help/ menu is handled specially menuHelp :: [Prop (Menu ())] -> IO (Menu ()) menuHelp props = menuPane ([text := "&Help"] ++ props) -- | Complete the construction of a menu which has been loaded -- from a resource file. -- | Get a menu by name from a menu loaded from a resource file, -- given the frame which owns the menu. You -- can directly set properties on the item as part of the call, which -- enables simple connection of event handlers (e.g. on command). menuRes :: Window a -> String -> [Prop (Menu ())] -> IO (Menu ()) menuRes parent menu_name props = do menu <- xmlResourceGetMenu parent menu_name set menu props return menu instance Textual (Menu a) where text = newAttr "text" menuGetTitle menuSetTitle {-------------------------------------------------------------------------------- Menu items --------------------------------------------------------------------------------} -- | Create a submenu item. menuSub :: Menu b -> Menu a -> [Prop (MenuItem ())] -> IO (MenuItem ()) menuSub parent menu props = do id <- idCreate label <- case (findProperty text "" props) of Just (txt,_) -> return txt Nothing -> do title <- menuGetTitle menu if (null title) then return "" else return title menuSetTitle menu "" -- remove title on submenus menuAppendSub parent id label menu "" menuPropagateEvtHandlers menu -- move the evtHandlers to the parent item <- menuFindItem parent id set item props return item -- | Add a menu seperator. menuLine :: Menu a -> IO () menuLine menu = menuAppendSeparator menu -- | Append a menu item. The label can contain -- menu accellerators by using an ampersand. It can also contain keyboard accellerators -- after a tab (@'\\t'@) character. -- -- > menuItem menu [text := "&Open\tCtrl+O", help := "Opens an existing document"] -- -- You can create a checkable menu item by setting 'checkable' to 'True' in the -- properties of a menu item. -- -- Note: on GTK, it is required to set the 'text' attribute immediately at creation time. -- -- * Events: 'menu', 'menuId' -- -- * Instances: 'Textual', 'Able', 'Help', 'Checkable', 'Identity', 'Commanding'. -- menuItem :: Menu a -> [Prop (MenuItem ())] -> IO (MenuItem ()) menuItem menu props = do let kind = case (findProperty checkable False props) of Just (True,_) -> wxITEM_CHECK _ -> wxITEM_NORMAL menuItemKind menu kind props -- | Append a radio menu item. These items are 'checkable' by default. -- A sequence of radio menu items form automatically a group. -- A different kind of menu item, like a 'menuLine', terminates the group. -- Note: one sometimes has to set the first selected radio item -- specifically after setting the "menubar" property, or otherwise the -- radio item bullet is not displayed on windows. -- See 'menuItem' for other properties of menu radio items. menuRadioItem :: Menu a -> [Prop (MenuItem ())] -> IO (MenuItem ()) menuRadioItem menu props = menuItemKind menu wxITEM_RADIO ([checked := True] ++ props) menuItemKind menu kind props = do id <- idCreate let label = case (findProperty text "" props) of Nothing -> "" Just (txt,_) -> txt menuItemEx menu id label kind props -- | Append an /about/ menu item (@"&About..."@). On some platforms, -- the /about/ menu is handled specially. -- -- * Events: 'menu', 'menuId' -- -- * Instances: 'Textual', 'Able', 'Help', 'Checkable', 'Identity', 'Commanding'. -- menuAbout :: Menu a -> [Prop (MenuItem ())] -> IO (MenuItem ()) menuAbout menu props = menuItemId menu wxID_ABOUT "&About..." props -- | Append an /quit/ menu item (@"&Quit\tCtrl+Q"@). On some platforms, -- the /quit/ menu is handled specially -- -- * Events: 'menu', 'menuId' -- -- * Instances: 'Textual', 'Able', 'Help', 'Checkable', 'Identity', 'Commanding'. -- menuQuit :: Menu a -> [Prop (MenuItem ())] -> IO (MenuItem ()) menuQuit menu props = menuItemId menu wxID_EXIT "&Quit\tCtrl+Q" props -- | Append a menu item with a specific id and label. -- -- * Events: 'menu', 'menuId' -- -- * Instances: 'Textual', 'Able', 'Help', 'Checkable', 'Identity', 'Commanding'. -- menuItemId :: Menu a -> Id -> String -> [Prop (MenuItem ())] -> IO (MenuItem ()) menuItemId menu id label props = menuItemEx menu id label wxITEM_NORMAL props -- | Append a menu item with a specific id, label, and kind (like 'wxITEM_CHECK'). -- -- * Events: 'menu', 'menuId' -- -- * Instances: 'Textual', 'Able', 'Help', 'Checkable', 'Identity', 'Commanding'. -- menuItemEx :: Menu a -> Id -> String -> Int -> [Prop (MenuItem ())] -> IO (MenuItem ()) menuItemEx menu id label kind props = do if (kind == wxITEM_RADIO) then menuAppendRadioItem menu id label "" else menuAppend menu id label "" (kind == wxITEM_CHECK) item <- menuFindItem menu id set item props return item instance Able (MenuItem a) where enabled = newAttr "enabled" menuItemIsEnabled menuItemEnable instance Textual (MenuItem a) where text = reflectiveAttr "text" menuItemGetItemLabel menuItemSetItemLabel instance Help (MenuItem a) where help = newAttr "help" menuItemGetHelp menuItemSetHelp instance Checkable (MenuItem a) where checkable = reflectiveAttr "checkable" menuItemIsCheckable (\m c -> menuItemSetCheckable m c) checked = newAttr "checked" menuItemIsChecked menuItemCheck instance Identity (MenuItem a) where identity = newAttr "identity" menuItemGetId menuItemSetId {-------------------------------------------------------------------------------- Events --------------------------------------------------------------------------------} -- | React to menu events. menu :: MenuItem a -> Event (Window w) (IO ()) menu item = let id = unsafePerformIO (get item identity) in menuId id -- | React to a menu event based on identity. menuId :: Id -> Event (Window w) (IO ()) menuId id = newEvent "menu" (\w -> evtHandlerGetOnMenuCommand w id) (\w h -> evtHandlerOnMenuCommand w id h) {-------------------------------------------------------------------------------- Menu commands: Ok, we would like to set command handlers in two ways: 1) As an "on command" on the menu item itself. 2) With an "on (menu xxx)" on a window. Unfortunately, wxWidgets does not support method (1) for menus that are part of a menubar and assumes they are set on using (2) on the associated frame. We can't tell whether a menu is part of a menubar or popup menu until the user sets it. Thus we both set the event handlers always directly on the top level menu (this is good enough for popup menus) and we maintain a list of menu item id's and associated event handler as client data on the top level menu. When the menu is set as part of a menu bar, we install the handlers on the associated frame. --------------------------------------------------------------------------------} instance Commanding (MenuItem a) where command = newEvent "command" menuItemGetOnCommand menuItemOnCommand menuItemGetOnCommand :: MenuItem a -> IO (IO ()) menuItemGetOnCommand item = do id <- get item identity topmenu <- menuItemGetTopMenu item evtHandlerGetOnMenuCommand topmenu id menuItemOnCommand :: MenuItem a -> IO () -> IO () menuItemOnCommand item io = do id <- get item identity topmenu <- menuItemGetTopMenu item -- always set it on the menu itself (has only effect on popup menus) evtHandlerOnMenuCommand topmenu id io -- update the Haskell event handler list for delayed frame installation menuUpdateEvtHandlers topmenu (insert id io) -- and set it directly on the frame if already instantiated. frame <- menuGetFrame topmenu when (not (objectIsNull frame)) (evtHandlerOnMenuCommand frame id io) where insert key val [] = [(key,val)] insert key val ((k,v):xs) | key == k = (key,val):xs | otherwise = (k,v):insert key val xs -- | When setting event handlers on menu items which have been loaded from -- XRC resource files, properties cannot be used as the menu item -- instances are opaque to wxHaskell. -- -- This function offers a convenient way to attach menu item event -- handlers, given the identity of the window which owns the menu containing -- the menu item, and the name of the menu item menuItemOnCommandRes :: Window a -> String -> IO () -> IO () menuItemOnCommandRes win item_name handler = do res <- xmlResourceGet item_id <- xmlResourceGetXRCID res item_name evtHandlerOnMenuCommand win item_id handler -- Propagate the (delayed) event handlers of a submenu to the parent menu. -- This is necessary for event handlers set on menu items in a submenu that -- was not yet assigned to a parent menu. menuPropagateEvtHandlers :: Menu a -> IO () menuPropagateEvtHandlers menu = do parent <- menuGetTopMenu menu handlers <- menuGetEvtHandlers menu menuSetEvtHandlers menu [] menuSetEvtHandlers parent handlers -- Get associated frame of a menu in a menubar. Returns NULL for popup and sub menus. menuGetFrame :: Menu a -> IO (Frame ()) menuGetFrame menu = do menubar <- menuGetMenuBar menu if (objectIsNull menubar) then return objectNull else menuBarGetFrame menubar -- Get top level menu of a menu item (never null) menuItemGetTopMenu :: MenuItem a -> IO (Menu ()) menuItemGetTopMenu item = do menu <- menuItemGetMenu item menuGetTopMenu menu -- Get the top level menu of a possible sub menu menuGetTopMenu :: Menu a -> IO (Menu ()) menuGetTopMenu menu = do parent <- menuGetParent menu if (objectIsNull parent) then return (downcastMenu menu) else menuGetTopMenu parent -- Set all menu event handlers on a certain window (EvtHandler) evtHandlerSetAndResetMenuCommands :: EvtHandler a -> Menu b -> IO () evtHandlerSetAndResetMenuCommands evtHandler menu = do handlers <- menuGetEvtHandlers menu menuSetEvtHandlers menu [] mapM_ (\(id,io) -> evtHandlerOnMenuCommand evtHandler id io) handlers -- Update the menu event handler list. menuUpdateEvtHandlers menu f = do hs <- menuGetEvtHandlers menu menuSetEvtHandlers menu (f hs) menuGetEvtHandlers :: Menu a -> IO [(Id,IO ())] menuGetEvtHandlers menu = do mbHandlers <- unsafeEvtHandlerGetClientData menu case mbHandlers of Nothing -> return [] Just hs -> return hs menuSetEvtHandlers :: Menu a -> [(Id,IO ())] -> IO () menuSetEvtHandlers menu hs = evtHandlerSetClientData menu (return ()) hs {-------------------------------------------------------------------------------- Toolbar --------------------------------------------------------------------------------} -- | Create a toolbar window with a divider and text labels. -- Normally, you can use 'toolMenu' to add tools in the toolbar -- that behave like normal menu items. -- -- > tbar <- toolBar f [] -- > toolMenu tbar open "Open" "open.png" [] -- > toolMenu tbar about "About" "about.png" [] -- toolBar :: Frame a -> [Prop (ToolBar ())] -> IO (ToolBar ()) toolBar parent props = toolBarEx parent True True props -- | Create a toolbar window. The second argument specifies whether text labels -- should be shown, and the third argument whether a divider line is present -- above the toolbar. toolBarEx :: Frame a -> Bool -> Bool -> [Prop (ToolBar ())] -> IO (ToolBar ()) toolBarEx parent showText showDivider props = do let style = ( wxTB_DOCKABLE .+. wxTB_FLAT .+. (if showText then wxTB_TEXT else 0) .+. (if showDivider then 0 else wxTB_NODIVIDER) ) t <- toolBarCreate parent idAny rectNull style frameSetToolBar parent t {- t <- frameCreateToolBar parent style -} set t props return t -- | A tool in a toolbar. -- -- * Events: 'tool' -- -- * Instances: 'Able', 'Help', 'Tipped', 'Checkable', 'Identity', 'Commanding'. -- data ToolBarItem = ToolBarItem (ToolBar ()) Id Bool instance Able ToolBarItem where enabled = newAttr "enabled" getter setter where getter (ToolBarItem toolbar id isToggle) = toolBarGetToolEnabled toolbar id setter (ToolBarItem toolbar id isToggle) enable = toolBarEnableTool toolbar id enable instance Tipped ToolBarItem where tooltip = newAttr "tooltip" getter setter where getter (ToolBarItem toolbar id isToggle) = toolBarGetToolShortHelp toolbar id setter (ToolBarItem toolbar id isToggle) txt = toolBarSetToolShortHelp toolbar id txt instance Help ToolBarItem where help = newAttr "help" getter setter where getter (ToolBarItem toolbar id isToggle) = toolBarGetToolLongHelp toolbar id setter (ToolBarItem toolbar id isToggle) txt = toolBarSetToolLongHelp toolbar id txt instance Checkable ToolBarItem where checkable = readAttr "checkable" getter where getter (ToolBarItem toolbar id isToggle) = return isToggle checked = newAttr "checked" getter setter where getter (ToolBarItem toolbar id isToggle) = toolBarGetToolState toolbar id setter (ToolBarItem toolbar id isToggle) toggle = toolBarToggleTool toolbar id toggle instance Identity ToolBarItem where identity = readAttr "identity" getter where getter (ToolBarItem toolbar id isToggle) = return id instance Commanding ToolBarItem where command = newEvent "command" getter setter where getter (ToolBarItem toolbar id isToggle) = evtHandlerGetOnMenuCommand toolbar id setter (ToolBarItem toolbar id isToggle) io = evtHandlerOnMenuCommand toolbar id io -- | React on tool event. (normally handled by 'menu' though, so only use this -- for orphan toolbar items). tool :: ToolBarItem -> Event (Window w) (IO ()) tool (ToolBarItem toolbar id isToggle) = newEvent "tool" getter setter where getter w = evtHandlerGetOnMenuCommand w id setter w io = evtHandlerOnMenuCommand w id io -- | Create a tool bar item based on a menu. Takes a a relevant menu -- item, a label and an image file (bmp, png, gif, ico, etc.) as arguments. The image -- file is normally 16x15 pixels. -- The toolbar item will fire the relevant menu items just as if the menu has been selected. -- Checkable menus will give a checkable toolbar item. Beware though that checkable tools -- normally require a specific @on command@ handler to keep them synchronised with the -- corresponding menu item. toolMenu :: ToolBar a -> MenuItem a -> String -> FilePath -> [Prop ToolBarItem] -> IO ToolBarItem toolMenu toolbar menuitem label bitmapPath props = withBitmapFromFile bitmapPath $ \bitmap -> toolMenuFromBitmap toolbar menuitem label bitmap props -- | This is a generalized version of 'toolMenu' function. You can specify 'Bitmap' that is -- loaded from any other place instead of using 'FilePath' directly. toolMenuFromBitmap :: ToolBar a -> MenuItem a -> String -> Bitmap b -> [Prop ToolBarItem] -> IO ToolBarItem toolMenuFromBitmap toolbar menuitem label bitmap props = do isToggle <- get menuitem checkable id <- get menuitem identity lhelp <- get menuitem help shelp <- get menuitem help toolBarAddTool2 toolbar id label bitmap nullBitmap (if isToggle then wxITEM_CHECK else wxITEM_NORMAL) shelp lhelp let t = ToolBarItem (downcastToolBar toolbar) id isToggle set t props toolBarRealize toolbar return t -- | Create an /orphan/ toolbar item that is unassociated with a menu. Takes a -- label, a flag that is 'True' when the item is 'checkable' and a path to an image -- (bmp, png, gif, ico, etc.) as arguments. toolItem :: ToolBar a -> String -> Bool -> FilePath -> [Prop ToolBarItem] -> IO ToolBarItem toolItem toolbar label isCheckable bitmapPath props = withBitmapFromFile bitmapPath $ \bitmap -> do id <- idCreate toolBarAddTool2 toolbar id label bitmap nullBitmap (if isCheckable then wxITEM_CHECK else wxITEM_NORMAL) "" "" let t = ToolBarItem (downcastToolBar toolbar) id isCheckable set t props toolBarRealize toolbar return t -- | Add an arbitrary control to a toolbar (typically a 'ComboBox'). The control -- must be created with the toolbar as the parent. toolControl :: ToolBar a -> Control b -> IO () toolControl toolbar control = do toolBarAddControl toolbar control return () {-------------------------------------------------------------------------------- Statusbar --------------------------------------------------------------------------------} -- | A field in a status bar. -- -- * Instances: 'Textual' -- data StatusField = SF (Var Int) (Var (StatusBar ())) (Var Int) (Var String) -- | The status width attribute determines the width of a status bar field. -- A negative width makes the field stretchable. The width than determines -- the amount of stretch in relation to other fields. The default -- status width is @-1@, ie. all fields stretch evenly. -- -- Here is an example of a status bar -- with three fields, where the last field is 50 pixels wide, the first takes -- 66% of the remaining space and the second field 33%. -- -- > field1 <- statusField [statusWidth := -2] -- > field2 <- statusField [text := "hi"] -- > field3 <- statusField [statusWidth := 50] -- > set frame [statusBar := [field1,field2,field3]] -- statusWidth :: Attr StatusField Int statusWidth = newAttr "statusWidth" getter setter where getter (SF vwidth _ _ _) = varGet vwidth setter (SF vwidth _ _ _) w = varSet vwidth w -- | Create a status field. statusField :: [Prop StatusField] -> IO StatusField statusField props = do vwidth<- varCreate (-1) vsbar <- varCreate objectNull vidx <- varCreate (-1) vtext <- varCreate "" let sf = SF vwidth vsbar vidx vtext set sf props return sf instance Textual StatusField where text = newAttr "text" get set where get (SF _ vsbar vidx vtext) = varGet vtext set (SF _ vsbar vidx vtext) text = do varSet vtext text idx <- varGet vidx if (idx >= 0) then do sbar <- varGet vsbar statusBarSetStatusText sbar text idx else return () {-# DEPRECATED statusbar "Use statusBar instead" #-} -- | /Deprecated/: use 'statusBar'. statusbar :: WriteAttr (Frame a) [StatusField] statusbar = statusBar -- | Specify the statusbar of a frame. statusBar :: WriteAttr (Frame a) [StatusField] statusBar = writeAttr "statusbar" set where set f fields = do ws <- mapM (\field -> get field statusWidth) fields sb <- statusBarCreateFields f ws mapM_ (setsb sb) (zip [0..] fields ) setsb sb (idx,SF _ vsbar vidx vtext) = do varSet vsbar sb varSet vidx idx text <- varGet vtext statusBarSetStatusText sb text idx -- initialize