Menu
▾
▴
[htoolkit-cvs] port/src/Port Action.hs,NONE,1.1 Handlers.hs,1.32,1.33 Menu.hs,1.12,1.13 ToolBar.hs,1.6,1.7 Types.hs,1.37,1.38
|
From: <kr_...@us...> - 2004-05-12 20:42:50
|
Update of /cvsroot/htoolkit/port/src/Port In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv5356/port/src/Port Modified Files: Handlers.hs Menu.hs ToolBar.hs Types.hs Added Files: Action.hs Log Message: This is a major rewrite of menu and toolbar support. The main feature is that the new API provides action based menu and toolbar. The another advantage is that now the code is more simpler and shorter. The low lever API is implemented only under Linux for now. --- NEW FILE: Action.hs --- {-# OPTIONS -fffi -#include Action.h #-} ----------------------------------------------------------------------------------------- {-| Module : Action Copyright : (c) Krasimir Angelov 2003 License : BSD-style Maintainer : ka2...@ya... Stability : provisional Portability : portable Actions represent operations that the user can be perform, along with some information how it should be presented in the interface. There are functions which allows to create menu and toolbar items from a given action. As well as the event that is fired when the action gets activated, the following also gets associated with the action: a label, an accelerator, a tooltip and a toolbar label (usually shorter than label). Apart from regular actions, there are check actions, which can be toggled between two states and radio actions, of which only one in a group can be in the 'selected' state. -} ----------------------------------------------------------------------------------------- module Graphics.UI.Port.Action ( createAction , createCheckAction , createRadioAction , createDropDownAction , setActionRadioGroup , setActionBitmap, getActionBitmap , setActionEnabled, getActionEnabled , setActionTip, getActionTip , setActionText, getActionText , setActionShortText, getActionShortText , setActionChecked, getActionChecked , setActionAccel, getActionAccel , destroyAction ) where import Graphics.UI.Port.Types import Graphics.UI.Port.Handlers import Graphics.UI.Port.PtrMap as PtrMap import Foreign import Foreign.C import Control.Concurrent.MVar foreign import ccall "osCreateAction" createAction :: IO ActionHandle foreign import ccall "osCreateCheckAction" createCheckAction :: IO ActionHandle foreign import ccall "osCreateRadioAction" createRadioAction :: IO ActionHandle foreign import ccall "osCreateDropDownAction" createDropDownAction :: MenuHandle -> IO ActionHandle setActionRadioGroup :: [ActionHandle] -> IO () setActionRadioGroup handles = withArray0 nullHandle handles osSetActionRadioGroup foreign import ccall osSetActionRadioGroup :: Ptr ActionHandle -> IO () setActionBitmap :: ActionHandle -> Maybe Bitmap -> IO () setActionBitmap haction (Just bmp) = do map <- takeMVar actionBitmaps withCBitmap bmp (osSetActionBitmap haction) putMVar actionBitmaps (insert haction bmp map) setActionBitmap haction Nothing = do map <- takeMVar actionBitmaps osSetActionBitmap haction nullPtr putMVar actionBitmaps (delete haction map) foreign import ccall osSetActionBitmap :: ActionHandle -> BitmapHandle -> IO () getActionBitmap :: ActionHandle -> IO (Maybe Bitmap) getActionBitmap haction = do map <- readMVar actionBitmaps return (PtrMap.lookup haction map) foreign import ccall "osSetActionEnabled" setActionEnabled :: ActionHandle -> Bool -> IO () foreign import ccall "osGetActionEnabled" getActionEnabled :: ActionHandle -> IO Bool setActionTip :: ActionHandle -> String -> IO () setActionTip haction tip = withCString tip (osSetActionTip haction) foreign import ccall osSetActionTip :: ActionHandle -> CString -> IO () getActionTip :: ActionHandle -> IO String getActionTip haction = resultCString (osGetActionTip haction) foreign import ccall osGetActionTip :: ActionHandle -> IO CString setActionText :: ActionHandle -> String -> IO () setActionText haction tip = withCString tip (osSetActionText haction) foreign import ccall osSetActionText :: ActionHandle -> CString -> IO () getActionText :: ActionHandle -> IO String getActionText haction = resultCString (osGetActionText haction) foreign import ccall osGetActionText :: ActionHandle -> IO CString setActionShortText :: ActionHandle -> String -> IO () setActionShortText haction tip = withCString tip (osSetActionShortText haction) foreign import ccall osSetActionShortText :: ActionHandle -> CString -> IO () getActionShortText :: ActionHandle -> IO String getActionShortText haction = resultCString (osGetActionShortText haction) foreign import ccall osGetActionShortText :: ActionHandle -> IO CString foreign import ccall "osSetActionChecked" setActionChecked :: ActionHandle -> Bool -> IO () foreign import ccall "osGetActionChecked" getActionChecked :: ActionHandle -> IO Bool getActionAccel :: ActionHandle -> IO Key getActionAccel haction = alloca $ \pckey -> alloca $ \pcmods -> do osGetActionAccel haction pckey pcmods ckey <- peek pckey cmods <- peek pcmods return (fromCKey ckey cmods) foreign import ccall osGetActionAccel :: ActionHandle -> Ptr CInt -> Ptr CWord -> IO () setActionAccel :: ActionHandle -> Key -> IO () setActionAccel haction key = let (ckey,cmods) = toCKey key in osSetActionAccel haction ckey cmods foreign import ccall osSetActionAccel :: ActionHandle -> CInt -> CWord -> IO () foreign import ccall "osDestroyAction" destroyAction :: ActionHandle -> IO () Index: Handlers.hs =================================================================== RCS file: /cvsroot/htoolkit/port/src/Port/Handlers.hs,v retrieving revision 1.32 retrieving revision 1.33 diff -C2 -d -r1.32 -r1.33 *** Handlers.hs 23 Nov 2003 10:23:13 -0000 1.32 --- Handlers.hs 12 May 2004 20:42:34 -0000 1.33 *************** *** 22,36 **** -- * Clean up unregisterAllWindowHandlers ! -- * Timers ! ,registerTimer, unregisterTimer, getAllTimerHandles ! -- ** Events ,setTimerHandler, setTimerDefHandler, getTimerHandler ,setTimerDestroyHandler, setTimerDestroyDefHandler, getTimerDestroyHandler ! -- * Windows ,registerWindow, unregisterWindow, getAllWindowHandles ! -- ** Events ,setContainerReLayoutHandler,setContainerReLayoutDefHandler,getContainerReLayoutHandler --- 22,36 ---- -- * Clean up unregisterAllWindowHandlers ! -- * Timers ! ,registerTimer, unregisterTimer, getAllTimerHandles ! -- ** Events ,setTimerHandler, setTimerDefHandler, getTimerHandler ,setTimerDestroyHandler, setTimerDestroyDefHandler, getTimerDestroyHandler ! -- * Windows ,registerWindow, unregisterWindow, getAllWindowHandles ! -- ** Events ,setContainerReLayoutHandler,setContainerReLayoutDefHandler,getContainerReLayoutHandler *************** *** 41,50 **** ,setWindowScrollHandler, setWindowScrollDefHandler, getWindowScrollHandler ,setWindowMouseHandler, setWindowMouseDefHandler, getWindowMouseHandler ! ,setWindowKeyboardHandler, setWindowKeyboardDefHandler, getWindowKeyboardHandler ,setWindowActivateHandler, setWindowActivateDefHandler, getWindowActivateHandler ,setWindowDeactivateHandler, setWindowDeactivateDefHandler, getWindowDeactivateHandler ,setWindowContextMenuHandler,setWindowContextMenuDefHandler,getWindowContextMenuHandler - -- * Process events ,setProcessDismissHandler, setProcessDismissDefHandler, getProcessDismissHandler --- 41,49 ---- ,setWindowScrollHandler, setWindowScrollDefHandler, getWindowScrollHandler ,setWindowMouseHandler, setWindowMouseDefHandler, getWindowMouseHandler ! ,setWindowKeyboardHandler, setWindowKeyboardDefHandler, getWindowKeyboardHandler ,setWindowActivateHandler, setWindowActivateDefHandler, getWindowActivateHandler ,setWindowDeactivateHandler, setWindowDeactivateDefHandler, getWindowDeactivateHandler ,setWindowContextMenuHandler,setWindowContextMenuDefHandler,getWindowContextMenuHandler -- * Process events ,setProcessDismissHandler, setProcessDismissDefHandler, getProcessDismissHandler *************** *** 53,57 **** -- * Control commands ,setControlCommandHandler, setControlCommandDefHandler, getControlCommandHandler ! -- * TrackBar Increment\/Decrement events ,setTrackBarIncrementHandler, setTrackBarIncrementDefHandler, getTrackBarIncrementHandler --- 52,56 ---- -- * Control commands ,setControlCommandHandler, setControlCommandDefHandler, getControlCommandHandler ! -- * TrackBar Increment\/Decrement events ,setTrackBarIncrementHandler, setTrackBarIncrementDefHandler, getTrackBarIncrementHandler *************** *** 59,69 **** -- * Menu events - ,setMenuCommandHandler, setMenuCommandDefHandler, getMenuCommandHandler - ,setMenuUpdateHandler, setMenuUpdateDefHandler, getMenuUpdateHandler ,setMenuDestroyHandler, setMenuDestroyDefHandler, getMenuDestroyHandler -- * ToolBar events ! ,setToolCommandHandler, setToolCommandDefHandler, getToolCommandHandler ! ,setToolDestroyHandler, setToolDestroyDefHandler, getToolDestroyHandler -- * Indicator events --- 58,70 ---- -- * Menu events ,setMenuDestroyHandler, setMenuDestroyDefHandler, getMenuDestroyHandler -- * ToolBar events ! ,setToolDestroyHandler, setToolDestroyDefHandler, getToolDestroyHandler ! ! -- * Action events ! ,setActionCommandHandler, setActionCommandDefHandler, getActionCommandHandler ! ,setActionUpdateHandler, setActionUpdateDefHandler, getActionUpdateHandler ! ,setActionDestroyHandler, setActionDestroyDefHandler, getActionDestroyHandler -- * Indicator events *************** *** 72,76 **** -- ** Internals ! ,toolBitmaps, menuBitmaps, windowBitmaps ) where --- 73,77 ---- -- ** Internals ! ,actionBitmaps, windowBitmaps ) where *************** *** 94,100 **** invokeHandler :: Ptr a -> MVar (PtrMap a b) -> (b -> IO ()) -> IO () invokeHandler handle varMap f ! = do map <- readMVar varMap case lookup handle map of ! Just x -> safeio (f x) Nothing -> return () --- 95,101 ---- invokeHandler :: Ptr a -> MVar (PtrMap a b) -> (b -> IO ()) -> IO () invokeHandler handle varMap f ! = do map <- readMVar varMap case lookup handle map of ! Just x -> safeio (f x) Nothing -> return () *************** *** 527,587 **** ----------------------------------------------------------------------------------------- - -- MenuUpdate - ----------------------------------------------------------------------------------------- - - {-# NOINLINE handlersMenuUpdate #-} - handlersMenuUpdate :: MVar (PtrMap MenuHandle (IO ())) - handlersMenuUpdate - = unsafePerformIO (newMVar empty) - - setMenuUpdateHandler :: MenuHandle -> IO () -> IO () - setMenuUpdateHandler hmenu handler - = setHandler hmenu handler handlersMenuUpdate - - setMenuUpdateDefHandler :: MenuHandle -> IO () - setMenuUpdateDefHandler hmenu - = setDefHandler hmenu handlersMenuUpdate - - getMenuUpdateHandler :: MenuHandle -> IO (IO ()) - getMenuUpdateHandler hmenu - = getHandler hmenu (return ()) handlersMenuUpdate - - handleMenuUpdate :: MenuHandle -> IO () - handleMenuUpdate hmenu - = invokeHandler hmenu handlersMenuUpdate id - - ----------------------------------------------------------------------------------------- - -- MenuCommand - ----------------------------------------------------------------------------------------- - - {-# NOINLINE handlersMenuCommand #-} - handlersMenuCommand :: MVar (PtrMap MenuHandle (IO ())) - handlersMenuCommand - = unsafePerformIO (newMVar empty) - - setMenuCommandHandler :: MenuHandle -> IO () -> IO () - setMenuCommandHandler hmenu handler - = setHandler hmenu handler handlersMenuCommand - - setMenuCommandDefHandler :: MenuHandle -> IO () - setMenuCommandDefHandler hmenu - = setDefHandler hmenu handlersMenuCommand - - getMenuCommandHandler :: MenuHandle -> IO (IO ()) - getMenuCommandHandler hmenu - = getHandler hmenu (return ()) handlersMenuCommand - - handleMenuCommand :: MenuHandle -> IO () - handleMenuCommand hmenu - = invokeHandler hmenu handlersMenuCommand id - - ----------------------------------------------------------------------------------------- -- MenuDestroy ----------------------------------------------------------------------------------------- - {-# NOINLINE menuBitmaps #-} - menuBitmaps :: MVar (PtrMap MenuHandle Bitmap) - menuBitmaps = unsafePerformIO (newMVar empty) - {-# NOINLINE handlersMenuDestroy #-} handlersMenuDestroy :: MVar (PtrMap MenuHandle (IO ())) --- 528,534 ---- *************** *** 604,611 **** handleMenuDestroy hmenu = do map <- takeMVar handlersMenuDestroy - bmps <- takeMVar toolBitmaps - putMVar toolBitmaps (delete hmenu bmps) - setMenuCommandDefHandler hmenu - setMenuUpdateDefHandler hmenu putMVar handlersMenuDestroy (delete hmenu map) case lookup hmenu map of --- 551,554 ---- *************** *** 613,616 **** --- 556,646 ---- Just io -> safeio io + ----------------------------------------------------------------------------------------- + -- ActionUpdate + ----------------------------------------------------------------------------------------- + + {-# NOINLINE handlersActionUpdate #-} + handlersActionUpdate :: MVar (PtrMap ActionHandle (IO ())) + handlersActionUpdate + = unsafePerformIO (newMVar empty) + + setActionUpdateHandler :: ActionHandle -> IO () -> IO () + setActionUpdateHandler haction handler + = setHandler haction handler handlersActionUpdate + + setActionUpdateDefHandler :: ActionHandle -> IO () + setActionUpdateDefHandler haction + = setDefHandler haction handlersActionUpdate + + getActionUpdateHandler :: ActionHandle -> IO (IO ()) + getActionUpdateHandler haction + = getHandler haction (return ()) handlersActionUpdate + + handleActionUpdate :: ActionHandle -> IO () + handleActionUpdate haction + = invokeHandler haction handlersActionUpdate id + + ----------------------------------------------------------------------------------------- + -- ActionCommand + ----------------------------------------------------------------------------------------- + + {-# NOINLINE handlersActionCommand #-} + handlersActionCommand :: MVar (PtrMap ActionHandle (IO ())) + handlersActionCommand + = unsafePerformIO (newMVar empty) + + setActionCommandHandler :: ActionHandle -> IO () -> IO () + setActionCommandHandler haction handler + = setHandler haction handler handlersActionCommand + + setActionCommandDefHandler :: ActionHandle -> IO () + setActionCommandDefHandler haction + = setDefHandler haction handlersActionCommand + + getActionCommandHandler :: ActionHandle -> IO (IO ()) + getActionCommandHandler haction + = getHandler haction (return ()) handlersActionCommand + + handleActionCommand :: ActionHandle -> IO () + handleActionCommand haction + = invokeHandler haction handlersActionCommand id + + ----------------------------------------------------------------------------------------- + -- ActionDestroy + ----------------------------------------------------------------------------------------- + + {-# NOINLINE actionBitmaps #-} + actionBitmaps :: MVar (PtrMap ActionHandle Bitmap) + actionBitmaps = unsafePerformIO (newMVar empty) + + {-# NOINLINE handlersActionDestroy #-} + handlersActionDestroy :: MVar (PtrMap ActionHandle (IO ())) + handlersActionDestroy + = unsafePerformIO (newMVar empty) + + setActionDestroyHandler :: ActionHandle -> IO () -> IO () + setActionDestroyHandler haction handler + = setHandler haction handler handlersActionDestroy + + setActionDestroyDefHandler :: ActionHandle -> IO () + setActionDestroyDefHandler haction + = setDefHandler haction handlersActionDestroy + + getActionDestroyHandler :: ActionHandle -> IO (IO ()) + getActionDestroyHandler haction + = getHandler haction (return ()) handlersActionDestroy + + handleActionDestroy :: ActionHandle -> IO () + handleActionDestroy haction + = do map <- takeMVar handlersActionDestroy + bmps <- takeMVar actionBitmaps + putMVar actionBitmaps (delete haction bmps) + setActionCommandDefHandler haction + setActionUpdateDefHandler haction + putMVar handlersActionDestroy (delete haction map) + case lookup haction map of + Nothing -> return () + Just io -> safeio io + {----------------------------------------------------------------------------------------- ProcessDismiss *************** *** 743,778 **** ----------------------------------------------------------------------------------------- - -- ToolCommand - ----------------------------------------------------------------------------------------- - - {-# NOINLINE handlersToolCommand #-} - handlersToolCommand :: MVar (PtrMap ToolHandle (IO ())) - handlersToolCommand - = unsafePerformIO (newMVar empty) - - handleToolCommand :: ToolHandle -> IO () - handleToolCommand htool - = invokeHandler htool handlersToolCommand id - - setToolCommandHandler :: ToolHandle -> IO () -> IO () - setToolCommandHandler htool handler - = setHandler htool handler handlersToolCommand - - setToolCommandDefHandler :: ToolHandle -> IO () - setToolCommandDefHandler htool - = setDefHandler htool handlersToolCommand - - getToolCommandHandler :: ToolHandle -> IO (IO ()) - getToolCommandHandler htool - = getHandler htool (return ()) handlersToolCommand - - ----------------------------------------------------------------------------------------- -- ToolDestroy ----------------------------------------------------------------------------------------- - {-# NOINLINE toolBitmaps #-} - toolBitmaps :: MVar (PtrMap WindowHandle Bitmap) - toolBitmaps = unsafePerformIO (newMVar empty) - {-# NOINLINE handlersToolDestroy #-} handlersToolDestroy :: MVar (PtrMap ToolHandle (IO ())) --- 773,779 ---- *************** *** 795,801 **** handleToolDestroy htool = do map <- takeMVar handlersToolDestroy - bmps <- takeMVar toolBitmaps - putMVar toolBitmaps (delete htool bmps) - setToolCommandDefHandler htool putMVar handlersToolDestroy (delete htool map) case lookup htool map of --- 796,799 ---- *************** *** 881,893 **** foreign export ccall handleTrackBarIncrement :: WindowHandle -> IO () foreign export ccall handleTrackBarDecrement :: WindowHandle -> IO () - foreign export ccall handleMenuCommand :: MenuHandle -> IO () - foreign export ccall handleMenuUpdate :: MenuHandle -> IO () foreign export ccall handleMenuDestroy :: MenuHandle -> IO () foreign export ccall handleTimer :: TimerHandle -> IO () foreign export ccall handleTimerDestroy :: TimerHandle -> IO () foreign export ccall handleProcessDismiss :: IO () foreign export ccall handleProcessDestroy :: IO () - foreign export ccall handleToolCommand :: ToolHandle -> IO () - foreign export ccall handleToolDestroy :: ToolHandle -> IO () foreign export ccall handleIndicatorCommand :: IndicatorHandle -> IO () foreign export ccall handleIndicatorDestroy :: IndicatorHandle -> IO () --- 879,891 ---- foreign export ccall handleTrackBarIncrement :: WindowHandle -> IO () foreign export ccall handleTrackBarDecrement :: WindowHandle -> IO () foreign export ccall handleMenuDestroy :: MenuHandle -> IO () + foreign export ccall handleToolDestroy :: ToolHandle -> IO () + foreign export ccall handleActionCommand :: ActionHandle -> IO () + foreign export ccall handleActionUpdate :: ActionHandle -> IO () + foreign export ccall handleActionDestroy :: ActionHandle -> IO () foreign export ccall handleTimer :: TimerHandle -> IO () foreign export ccall handleTimerDestroy :: TimerHandle -> IO () foreign export ccall handleProcessDismiss :: IO () foreign export ccall handleProcessDestroy :: IO () foreign export ccall handleIndicatorCommand :: IndicatorHandle -> IO () foreign export ccall handleIndicatorDestroy :: IndicatorHandle -> IO () Index: Menu.hs =================================================================== RCS file: /cvsroot/htoolkit/port/src/Port/Menu.hs,v retrieving revision 1.12 retrieving revision 1.13 diff -C2 -d -r1.12 -r1.13 *** Menu.hs 15 Nov 2003 10:31:49 -0000 1.12 --- Menu.hs 12 May 2004 20:42:34 -0000 1.13 *************** *** 10,17 **** The module contains all functions for creation and management of menus. ! A menu is a list of items that specify options or groups of options (a submenu). ! Clicking a menu item opens a submenu or causes the application to carry out a command. ! A menu is arranged in a hierarchy. At the top level of the hierarchy is the menu bar; ! which contains a list of menus, which in turn can contain submenus. -} ----------------------------------------------------------------------------------------- --- 10,17 ---- The module contains all functions for creation and management of menus. ! A menu is a list of items that specify options or groups of options (a submenu). ! Clicking a menu item opens a submenu or causes the application to carry out a command. ! A menu is arranged in a hierarchy. At the top level of the hierarchy is the menu bar; ! which contains a list of menus, which in turn can contain submenus. -} ----------------------------------------------------------------------------------------- *************** *** 29,44 **** , insertMenuItem , insertMenuSeparatorItem - , insertMenuCheckItem - , insertMenuRadioItem - , setMenuRadioGroup - , setMenuItemAccel, getMenuItemAccel - , setMenuItemEnabled, getMenuItemEnabled - , setMenuItemChecked, getMenuItemChecked - , setMenuItemBitmap, getMenuItemBitmap -- * Common functions , destroyMenu , getMenuItemPos ! , setMenuLabel, getMenuLabel ! , setMenuTip, getMenuTip ) where --- 29,37 ---- , insertMenuItem , insertMenuSeparatorItem -- * Common functions , destroyMenu , getMenuItemPos ! , setMenuItemEnabled, getMenuItemEnabled ! , setMenuLabel, getMenuLabel ) where *************** *** 64,70 **** ----------------------------------------------------------------------------------------- ! -- | The 'insertMenu' function creates and inserts an item with submenu in the parent menu. ! -- The created submenu is initially empty. You can insert or append menu items by using the ! -- 'insertMenuItem', 'insertMenuCheckItem', 'insertMenuRadioItem' or 'insertMenuSeparatorItem' -- functions. Using the 'insertMenu' you can create nested submenus. insertMenu :: MenuHandle -- ^ The handle of the parent menu. --- 57,63 ---- ----------------------------------------------------------------------------------------- ! -- | The 'insertMenu' function creates and inserts an item with submenu in the parent menu. ! -- The created submenu is initially empty. You can insert or append menu items by using the ! -- 'insertMenuItem', 'insertMenuCheckItem', 'insertMenuRadioItem' or 'insertMenuSeparatorItem' -- functions. Using the 'insertMenu' you can create nested submenus. insertMenu :: MenuHandle -- ^ The handle of the parent menu. *************** *** 77,81 **** foreign import ccall osInsertMenu :: MenuHandle -> Int -> IO MenuHandle ! -- | The 'getMenuItemCount' function determines the number of items in the -- specified popup or sub menu. foreign import ccall "osGetMenuItemCount" getMenuItemCount :: MenuHandle -> IO Int --- 70,74 ---- foreign import ccall osInsertMenu :: MenuHandle -> Int -> IO MenuHandle ! -- | The 'getMenuItemCount' function determines the number of items in the -- specified popup or sub menu. foreign import ccall "osGetMenuItemCount" getMenuItemCount :: MenuHandle -> IO Int *************** *** 91,95 **** foreign import ccall "osCreatePopupMenu" createPopupMenu :: IO MenuHandle -- ^ The handle of the created popup menu. ! -- | The 'trackPopupMenu' function displays a shortcut menu at the specified location in the -- window and tracks the selection of items on the menu. trackPopupMenu :: MenuHandle -- ^ The handle of the popup menu --- 84,88 ---- foreign import ccall "osCreatePopupMenu" createPopupMenu :: IO MenuHandle -- ^ The handle of the created popup menu. ! -- | The 'trackPopupMenu' function displays a shortcut menu at the specified location in the -- window and tracks the selection of items on the menu. trackPopupMenu :: MenuHandle -- ^ The handle of the popup menu *************** *** 106,128 **** -- | Add a menu item. An event handler for a menu item can be -- installed with 'setMenuCommandHandler'. ! insertMenuItem :: MenuHandle -> Maybe Int -> IO MenuHandle ! insertMenuItem handle pos = osInsertMenuItem handle (fromMaybe (-1) pos) ! foreign import ccall osInsertMenuItem :: MenuHandle -> Int -> IO MenuHandle ! ! -- | Add a checkable menu item. An event handler for a menu item can be ! -- installed with 'setMenuCommandHandler'. ! insertMenuCheckItem :: MenuHandle -> Maybe Int -> IO MenuHandle ! insertMenuCheckItem handle pos = osInsertMenuCheckItem handle (fromMaybe (-1) pos) ! foreign import ccall osInsertMenuCheckItem :: MenuHandle -> Int -> IO MenuHandle ! ! -- | Add a menu radio item. . An event handler for a menu item can be ! -- installed with 'setMenuCommandHandler'. ! insertMenuRadioItem :: MenuHandle -> Maybe Int -> IO MenuHandle ! insertMenuRadioItem handle pos = osInsertMenuRadioItem handle (fromMaybe (-1) pos) ! foreign import ccall osInsertMenuRadioItem :: MenuHandle -> Int -> IO MenuHandle ! ! setMenuRadioGroup :: [MenuHandle] -> IO () ! setMenuRadioGroup handles = withArray0 nullHandle handles osSetMenuRadioGroup ! foreign import ccall osSetMenuRadioGroup :: Ptr MenuHandle -> IO () -- | Add a menu item separator line. --- 99,105 ---- -- | Add a menu item. An event handler for a menu item can be -- installed with 'setMenuCommandHandler'. ! insertMenuItem :: ActionHandle -> MenuHandle -> Maybe Int -> IO MenuHandle ! insertMenuItem haction hmenu pos = osInsertMenuItem haction hmenu (fromMaybe (-1) pos) ! foreign import ccall osInsertMenuItem :: ActionHandle -> MenuHandle -> Int -> IO MenuHandle -- | Add a menu item separator line. *************** *** 131,178 **** foreign import ccall osInsertMenuSeparatorItem :: MenuHandle -> Int -> IO MenuHandle - getMenuItemAccel :: MenuHandle -> IO Key - getMenuItemAccel hmenu - = alloca $ \pckey -> - alloca $ \pcmods -> - do osGetMenuItemAccel hmenu pckey pcmods - ckey <- peek pckey - cmods <- peek pcmods - return (fromCKey ckey cmods) - foreign import ccall osGetMenuItemAccel :: MenuHandle -> Ptr CInt -> Ptr CWord -> IO () - - setMenuItemAccel :: MenuHandle -> Key -> IO () - setMenuItemAccel hmenu key - = let (ckey,cmods) = toCKey key - in osSetMenuItemAccel hmenu ckey cmods - foreign import ccall osSetMenuItemAccel :: MenuHandle -> CInt -> CWord -> IO () - - -- | Enable or disable a menu item. - foreign import ccall "osSetMenuItemEnabled" setMenuItemEnabled :: MenuHandle -> Bool -> IO () - - -- | returns True if the menu item is enabled. - foreign import ccall "osGetMenuItemEnabled" getMenuItemEnabled :: MenuHandle -> IO Bool - - -- | Check or uncheck a checkable menu item. - foreign import ccall "osSetMenuItemChecked" setMenuItemChecked :: MenuHandle -> Bool -> IO () - - -- | returns True if the menu item is checked. - foreign import ccall "osGetMenuItemChecked" getMenuItemChecked :: MenuHandle -> IO Bool - - setMenuItemBitmap :: MenuHandle -> Maybe Bitmap -> IO () - setMenuItemBitmap hmenu (Just bmp) = do - map <- takeMVar menuBitmaps - withCBitmap bmp (osSetMenuItemBitmap hmenu) - putMVar menuBitmaps (insert hmenu bmp map) - setMenuItemBitmap hmenu Nothing = do - map <- takeMVar menuBitmaps - osSetMenuItemBitmap hmenu nullPtr - putMVar menuBitmaps (delete hmenu map) - foreign import ccall osSetMenuItemBitmap :: MenuHandle -> BitmapHandle -> IO () - - getMenuItemBitmap :: MenuHandle -> IO (Maybe Bitmap) - getMenuItemBitmap hmenu = do - map <- readMVar menuBitmaps - return (PtrMap.lookup hmenu map) - ----------------------------------------------------------------------------------------- -- Common functions --- 108,111 ---- *************** *** 181,215 **** -- | The destroyMenu function deletes an item from the specified menu. If the menu item opens a menu or submenu, -- this function destroys the handle to the menu or submenu and frees the memory used by the menu or submenu. ! destroyMenu :: MenuHandle -> IO () ! destroyMenu hmenu = do ! map <- takeMVar menuBitmaps ! osDestroyMenu hmenu ! putMVar menuBitmaps (delete hmenu map) ! foreign import ccall osDestroyMenu :: MenuHandle -> IO () -- | Returns the position of the item in the parent menu foreign import ccall "osGetMenuItemPos" getMenuItemPos :: MenuHandle -> IO Int -- | Change the label of a menu item (or checkable menu item). setMenuLabel :: MenuHandle -> String -> IO () ! setMenuLabel hmenu title ! = withCString title (osSetMenuLabel hmenu) foreign import ccall osSetMenuLabel :: MenuHandle -> CString -> IO () -- | Returns the label of a menu item (or checkable menu item). getMenuLabel :: MenuHandle -> IO String ! getMenuLabel hmenu ! = resultCString (osGetMenuLabel hmenu) foreign import ccall osGetMenuLabel :: MenuHandle -> IO CString - - -- | Change the tooltip of a menu item (or checkable menu item). - setMenuTip :: MenuHandle -> String -> IO () - setMenuTip hmenu tip - = withCString tip (osSetMenuTip hmenu) - foreign import ccall osSetMenuTip :: MenuHandle -> CString -> IO () - - -- | Returns the tooltip of a menu item (or checkable menu item). - getMenuTip :: MenuHandle -> IO String - getMenuTip hmenu - = resultCString (osGetMenuTip hmenu) - foreign import ccall osGetMenuTip :: MenuHandle -> IO CString --- 114,135 ---- -- | The destroyMenu function deletes an item from the specified menu. If the menu item opens a menu or submenu, -- this function destroys the handle to the menu or submenu and frees the memory used by the menu or submenu. ! foreign import ccall "osDestroyMenu" destroyMenu :: MenuHandle -> IO () -- | Returns the position of the item in the parent menu foreign import ccall "osGetMenuItemPos" getMenuItemPos :: MenuHandle -> IO Int + -- | Enable or disable a menu item. + foreign import ccall "osSetMenuItemEnabled" setMenuItemEnabled :: MenuHandle -> Bool -> IO () + + -- | returns True if the menu item is enabled. + foreign import ccall "osGetMenuItemEnabled" getMenuItemEnabled :: MenuHandle -> IO Bool + -- | Change the label of a menu item (or checkable menu item). setMenuLabel :: MenuHandle -> String -> IO () ! setMenuLabel hmenu title = withCString title (osSetMenuLabel hmenu) foreign import ccall osSetMenuLabel :: MenuHandle -> CString -> IO () -- | Returns the label of a menu item (or checkable menu item). getMenuLabel :: MenuHandle -> IO String ! getMenuLabel hmenu = resultCString (osGetMenuLabel hmenu) foreign import ccall osGetMenuLabel :: MenuHandle -> IO CString Index: ToolBar.hs =================================================================== RCS file: /cvsroot/htoolkit/port/src/Port/ToolBar.hs,v retrieving revision 1.6 retrieving revision 1.7 diff -C2 -d -r1.6 -r1.7 *** ToolBar.hs 31 Aug 2003 12:56:26 -0000 1.6 --- ToolBar.hs 12 May 2004 20:42:34 -0000 1.7 *************** *** 20,33 **** , insertToolButton - , insertToolCheckButton - , insertToolRadioButton - , insertToolDropDownButton , insertToolLine - , setToolRadioGroup - , setToolButtonBitmap, getToolButtonBitmap - , setToolButtonEnabled, getToolButtonEnabled - , setToolButtonTip, getToolButtonTip - , setToolButtonText, getToolButtonText - , setToolButtonChecked, getToolButtonChecked , getToolItemPos , destroyToolItem --- 20,24 ---- *************** *** 52,74 **** foreign import ccall "osGetToolBarButtonCount" getToolBarButtonCount :: WindowHandle -> IO Int ! insertToolButton :: WindowHandle -> Maybe Int -> IO ToolHandle ! insertToolButton toolBar pos = osInsertToolButton toolBar (fromMaybe (-1) pos) ! foreign import ccall osInsertToolButton :: WindowHandle -> Int -> IO ToolHandle ! ! insertToolCheckButton :: WindowHandle -> Maybe Int -> IO ToolHandle ! insertToolCheckButton toolBar pos = osInsertToolCheckButton toolBar (fromMaybe (-1) pos) ! foreign import ccall osInsertToolCheckButton :: WindowHandle -> Int -> IO ToolHandle ! ! insertToolRadioButton :: WindowHandle -> Maybe Int -> IO ToolHandle ! insertToolRadioButton toolBar pos = osInsertToolRadioButton toolBar (fromMaybe (-1) pos) ! foreign import ccall osInsertToolRadioButton :: WindowHandle -> Int -> IO ToolHandle ! ! setToolRadioGroup :: [ToolHandle] -> IO () ! setToolRadioGroup handles = withArray0 nullHandle handles osSetToolRadioGroup ! foreign import ccall osSetToolRadioGroup :: Ptr ToolHandle -> IO () ! ! insertToolDropDownButton :: WindowHandle -> MenuHandle -> Maybe Int -> IO ToolHandle ! insertToolDropDownButton toolBar menu pos = osInsertToolDropDownButton toolBar menu (fromMaybe (-1) pos) ! foreign import ccall osInsertToolDropDownButton :: WindowHandle -> MenuHandle -> Int -> IO ToolHandle insertToolLine :: WindowHandle -> Maybe Int -> IO ToolHandle --- 43,49 ---- foreign import ccall "osGetToolBarButtonCount" getToolBarButtonCount :: WindowHandle -> IO Int ! insertToolButton :: ActionHandle -> WindowHandle -> Maybe Int -> IO ToolHandle ! insertToolButton action toolBar pos = osInsertToolButton action toolBar (fromMaybe (-1) pos) ! foreign import ccall osInsertToolButton :: ActionHandle -> WindowHandle -> Int -> IO ToolHandle insertToolLine :: WindowHandle -> Maybe Int -> IO ToolHandle *************** *** 76,117 **** foreign import ccall osInsertToolLine :: WindowHandle -> Int -> IO ToolHandle - setToolButtonBitmap :: ToolHandle -> Maybe Bitmap -> IO () - setToolButtonBitmap htool (Just bmp) = do - map <- takeMVar toolBitmaps - withCBitmap bmp (osSetToolButtonBitmap htool) - putMVar toolBitmaps (insert htool bmp map) - setToolButtonBitmap htool Nothing = do - map <- takeMVar toolBitmaps - osSetToolButtonBitmap htool nullPtr - putMVar toolBitmaps (delete htool map) - foreign import ccall osSetToolButtonBitmap :: ToolHandle -> BitmapHandle -> IO () - - getToolButtonBitmap :: ToolHandle -> IO (Maybe Bitmap) - getToolButtonBitmap htool = do - map <- readMVar toolBitmaps - return (PtrMap.lookup htool map) - - foreign import ccall "osSetToolButtonEnabled" setToolButtonEnabled :: ToolHandle -> Bool -> IO () - foreign import ccall "osGetToolButtonEnabled" getToolButtonEnabled :: ToolHandle -> IO Bool - - setToolButtonTip :: ToolHandle -> String -> IO () - setToolButtonTip htool tip = withCString tip (osSetToolButtonTip htool) - foreign import ccall osSetToolButtonTip :: ToolHandle -> CString -> IO () - - getToolButtonTip :: ToolHandle -> IO String - getToolButtonTip htool = resultCString (osGetToolButtonTip htool) - foreign import ccall osGetToolButtonTip :: ToolHandle -> IO CString - - setToolButtonText :: ToolHandle -> String -> IO () - setToolButtonText htool tip = withCString tip (osSetToolButtonText htool) - foreign import ccall osSetToolButtonText :: ToolHandle -> CString -> IO () - - getToolButtonText :: ToolHandle -> IO String - getToolButtonText htool = resultCString (osGetToolButtonText htool) - foreign import ccall osGetToolButtonText :: ToolHandle -> IO CString - - foreign import ccall "osSetToolButtonChecked" setToolButtonChecked :: ToolHandle -> Bool -> IO () - foreign import ccall "osGetToolButtonChecked" getToolButtonChecked :: ToolHandle -> IO Bool - foreign import ccall "osGetToolItemPos" getToolItemPos :: ToolHandle -> IO Int --- 51,54 ---- Index: Types.hs =================================================================== RCS file: /cvsroot/htoolkit/port/src/Port/Types.hs,v retrieving revision 1.37 retrieving revision 1.38 diff -C2 -d -r1.37 -r1.38 *** Types.hs 7 May 2004 07:57:10 -0000 1.37 --- Types.hs 12 May 2004 20:42:34 -0000 1.38 *************** *** 86,89 **** --- 86,90 ---- , TimerHandle , ToolHandle + , ActionHandle , IndicatorHandle , nullHandle *************** *** 156,163 **** data TH = TH ! -- | Abstract handle to a tool type ToolHandle = Ptr TLH data TLH = TLH -- | Abstract handle to a indicator in the status bar type IndicatorHandle = Ptr IH --- 157,168 ---- data TH = TH ! -- | Abstract handle to a tool button type ToolHandle = Ptr TLH data TLH = TLH + -- | Abstract handle to an action + type ActionHandle = Ptr ACT + data ACT = ACT + -- | Abstract handle to a indicator in the status bar type IndicatorHandle = Ptr IH |
