[htoolkit-cvs] port/src/Port Handlers.hs,1.20,1.21 Menu.hs,1.6,1.7

[<kr_...@us...>]

Update of /cvsroot/htoolkit/port/src/Port
In directory sc8-pr-cvs1:/tmp/cvs-serv26873/port/src/Port

Modified Files:
	Handlers.hs Menu.hs 
Log Message:
Complete implementation for Menu with both GTK and Win32.
Supported:
   - command menu items with bitmaps
   - checked menu items
   - radio menu items
   - sepparators
   - sub menus



Index: Handlers.hs
===================================================================
RCS file: /cvsroot/htoolkit/port/src/Port/Handlers.hs,v
retrieving revision 1.20
retrieving revision 1.21
diff -C2 -d -r1.20 -r1.21
*** Handlers.hs	14 Apr 2003 18:22:32 -0000	1.20
--- Handlers.hs	23 Apr 2003 21:48:49 -0000	1.21
***************
*** 68,71 ****
--- 68,72 ----
                  ,setMenuCommandHandler, setMenuCommandDefHandler, getMenuCommandHandler
                  ,setMenuUpdateHandler,  setMenuUpdateDefHandler,  getMenuUpdateHandler
+                 ,setMenuDestroyHandler, setMenuDestroyDefHandler, getMenuDestroyHandler
                  ) where
  
***************
*** 498,505 ****
    = getHandler hmenu (return ()) handlersMenuUpdate
  
! handleMenusUpdate :: IO ()
! handleMenusUpdate 
!   = do map <- readMVar handlersMenuUpdate
!        sequence_ (elems map)
  
  -----------------------------------------------------------------------------------------
--- 499,505 ----
    = getHandler hmenu (return ()) handlersMenuUpdate
  
! handleMenuUpdate :: MenuHandle -> IO ()
! handleMenuUpdate hmenu
!   = invokeHandler hmenu handlersMenuUpdate id
  
  -----------------------------------------------------------------------------------------
***************
*** 528,531 ****
--- 528,562 ----
    = invokeHandler hmenu handlersMenuCommand id
  
+ -----------------------------------------------------------------------------------------
+ -- MenuDestroy
+ -----------------------------------------------------------------------------------------
+ 
+ {-# NOINLINE handlersMenuDestroy #-}
+ handlersMenuDestroy :: MVar (PtrMap MenuHandle (IO ()))
+ handlersMenuDestroy
+   = unsafePerformIO (newMVar empty)
+ 
+ setMenuDestroyHandler :: MenuHandle -> IO () -> IO ()
+ setMenuDestroyHandler hmenu handler
+   = setHandler hmenu handler handlersMenuDestroy
+ 
+ setMenuDestroyDefHandler :: MenuHandle -> IO ()
+ setMenuDestroyDefHandler hmenu
+   = setDefHandler hmenu handlersMenuDestroy
+   
+ getMenuDestroyHandler :: MenuHandle -> IO (IO ())
+ getMenuDestroyHandler hmenu
+   = getHandler hmenu (return ()) handlersMenuDestroy
+ 
+ handleMenuDestroy :: MenuHandle -> IO ()
+ handleMenuDestroy hmenu
+   = do map <- takeMVar handlersMenuDestroy
+        setMenuCommandDefHandler hmenu
+        setMenuUpdateDefHandler hmenu
+        putMVar handlersMenuDestroy (delete hmenu map)
+        case lookup hmenu map of
+          Nothing -> return ()
+          Just io -> safeio io
+ 
  {-----------------------------------------------------------------------------------------
    ProcessDismiss
***************
*** 673,677 ****
  foreign export ccall handleControlCommand :: WindowHandle -> IO () 
  foreign export ccall handleMenuCommand :: MenuHandle -> IO ()
! foreign export ccall handleMenusUpdate :: IO ()
  foreign export ccall handleTimer :: TimerHandle -> IO ()
  foreign export ccall handleTimerDestroy :: TimerHandle -> IO ()
--- 704,709 ----
  foreign export ccall handleControlCommand :: 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 ()

Index: Menu.hs
===================================================================
RCS file: /cvsroot/htoolkit/port/src/Port/Menu.hs,v
retrieving revision 1.6
retrieving revision 1.7
diff -C2 -d -r1.6 -r1.7
*** Menu.hs	1 Apr 2003 23:54:20 -0000	1.6
--- Menu.hs	23 Apr 2003 21:48:49 -0000	1.7
***************
*** 13,41 ****
  -----------------------------------------------------------------------------------------
  module Graphics.UI.Port.Menu
!            ( 
             -- * Menu bar
               mainMenu
-            , drawMenuBar
             -- * Sub menus
!            , addMenu
             -- * Menu items
!            , addMenuItem
!            , addMenuSeparatorItem
!            , addMenuCheckItem
             , setMenuItemEnabled, getMenuItemEnabled
-            , setMenuItemLabel
             , setMenuItemChecked, getMenuItemChecked
             ) where
  
  import Foreign.C
  import Graphics.UI.Port.Types
  import Graphics.UI.Port.Handlers  -- just for haddock
  
! 
! {-----------------------------------------------------------------------------------------
!   Wrappers
! -----------------------------------------------------------------------------------------}
! -- | Redraw the menubar. Must be called before menu changes become visible.
! foreign import ccall "osDrawMenuBar" drawMenuBar :: WindowHandle -> IO ()
  
  -- | The handle of the main application menu
--- 13,52 ----
  -----------------------------------------------------------------------------------------
  module Graphics.UI.Port.Menu
!            (
             -- * Menu bar
               mainMenu
             -- * Sub menus
!            , insertMenu
!            , getMenuItemCount
             -- * Menu items
!            , insertMenuItem
!            , insertMenuSeparatorItem
!            , insertMenuCheckItem           
!            , setMenuItemAccel,   getMenuItemAccel
             , setMenuItemEnabled, getMenuItemEnabled
             , setMenuItemChecked, getMenuItemChecked
+            , setMenuItemBitmap,  getMenuItemBitmap
+            -- * Radio groups and radio items
+            , insertMenuRadioGroup
+            , insertMenuRadioItem
+            , setMenuRadioGroupSelection, getMenuRadioGroupSelection
+            -- * Common functions
+            , destroyMenu
+            , getMenuItemPos
+            , setMenuLabel,       getMenuLabel
             ) where
  
+ import Foreign
  import Foreign.C
+ import Data.Maybe( fromMaybe )
+ import Control.Concurrent.MVar
  import Graphics.UI.Port.Types
  import Graphics.UI.Port.Handlers  -- just for haddock
+ import Graphics.UI.Port.PtrMap as PtrMap
+ import System.IO.Unsafe( unsafePerformIO )
  
! -----------------------------------------------------------------------------------------
! --  Menu bar
! -----------------------------------------------------------------------------------------
  
  -- | The handle of the main application menu
***************
*** 43,93 ****
  mainMenu = nullHandle
  
  -- | Add a sub menu.
! addMenu :: MenuHandle -> String -> IO MenuHandle
! addMenu hmenu title = withCString title (osAddMenu hmenu)
! foreign import ccall osAddMenu    :: MenuHandle -> CString -> IO MenuHandle
  
  -- | Add a menu item. Use a null character ('keyNull') if no
  -- short-cut key should be registered. An event handler for a menu item can be
  -- installed with 'registerMenuCommand'.
! addMenuItem :: MenuHandle -> Key -> String -> IO MenuHandle
! addMenuItem hmenu key title
!   = withCString title $ \ctitle ->
!     let (ckey,cmods) = toCKey key
!     in osAddMenuItem hmenu ckey cmods ctitle
! foreign import ccall osAddMenuItem   :: MenuHandle -> CInt -> CWord -> CString -> IO MenuHandle
  
  -- | Add a checkable menu item. An event handler for a menu item can be
  -- installed with 'registerMenuCommand'.
! addMenuCheckItem :: MenuHandle -> Key -> String -> IO MenuHandle
! addMenuCheckItem hmenu key title
!   = withCString title $ \ctitle ->
!     let (ckey,cmods) = toCKey key
!     in osAddMenuCheckItem hmenu ckey cmods ctitle
! foreign import ccall osAddMenuCheckItem :: MenuHandle -> CInt -> CWord -> CString -> IO MenuHandle
  
  -- | Add a menu item separator line.
! addMenuSeparatorItem :: MenuHandle -> IO ()
! addMenuSeparatorItem hmenu 
!   = osAddMenuSeparatorItem hmenu 
! foreign import ccall osAddMenuSeparatorItem :: MenuHandle -> IO ()
  
! -- | Change the label (and short-cut key) of a menu item (or checkable menu item).
! setMenuItemLabel :: MenuHandle -> MenuHandle -> Key -> String -> IO ()
! setMenuItemLabel hparent hmenu key title
!   = withCString title $ \ctitle ->
!     let (ckey,cmods) = toCKey key
!     in osSetMenuItemLabel hparent hmenu ckey cmods ctitle
! foreign import ccall osSetMenuItemLabel :: MenuHandle -> MenuHandle -> CInt -> CWord -> CString -> IO ()
  
  -- | Enable or disable a menu item.
! foreign import ccall unsafe "osSetMenuItemEnabled" setMenuItemEnabled :: MenuHandle -> MenuHandle -> Bool -> IO ()
  
  -- | returns True if the menu item is enabled.
! foreign import ccall unsafe "osGetMenuItemEnabled" getMenuItemEnabled :: MenuHandle -> MenuHandle -> IO Bool
  
  -- | Check or uncheck a checkable menu item.
! foreign import ccall "osSetMenuItemChecked" setMenuItemChecked :: MenuHandle -> MenuHandle -> Bool -> IO ()
  
  -- | returns True if the menu item is checked.
! foreign import ccall "osGetMenuItemChecked" getMenuItemChecked :: MenuHandle -> MenuHandle -> IO Bool
--- 54,184 ----
  mainMenu = nullHandle
  
+ -----------------------------------------------------------------------------------------
+ --  Sub menus
+ -----------------------------------------------------------------------------------------
+ 
  -- | Add a sub menu.
! insertMenu :: MenuHandle -> Maybe Int -> IO MenuHandle
! insertMenu handle pos = osInsertMenu handle (fromMaybe (-1) pos)
! foreign import ccall osInsertMenu :: MenuHandle -> Int -> IO MenuHandle
! 
! -- | The getMenuItemsCount function determines the number of items in the specified menu.
! foreign import ccall "osGetMenuItemCount" getMenuItemCount :: MenuHandle -> IO Int
! 
! -----------------------------------------------------------------------------------------
! --  Menu items
! -----------------------------------------------------------------------------------------
  
  -- | Add a menu item. Use a null character ('keyNull') if no
  -- short-cut key should be registered. An event handler for a menu item can be
  -- installed with 'registerMenuCommand'.
! 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 'registerMenuCommand'.
! 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 item separator line.
! insertMenuSeparatorItem :: MenuHandle -> Maybe Int -> IO MenuHandle
! insertMenuSeparatorItem handle pos = osInsertMenuSeparatorItem handle (fromMaybe (-1) pos)
! 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
! 
! {-# NOINLINE menuBitmaps #-}
! menuBitmaps :: MVar (PtrMap MenuHandle Bitmap)
! menuBitmaps = unsafePerformIO (newMVar empty)
! 
! 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)
! 
! -----------------------------------------------------------------------------------------
! -- Radio groups and radio items
! -----------------------------------------------------------------------------------------
! 
! -- | Add a radio group to the menu.
! insertMenuRadioGroup :: MenuHandle -> Maybe Int -> IO MenuHandle
! insertMenuRadioGroup handle pos = osInsertMenuRadioGroup handle (fromMaybe (-1) pos)
! foreign import ccall osInsertMenuRadioGroup :: MenuHandle -> Int -> IO MenuHandle
! 
! -- | Add a menu radio item to the radio group.
! insertMenuRadioItem :: MenuHandle -> Maybe Int -> IO MenuHandle
! insertMenuRadioItem handle pos = osInsertMenuRadioItem handle (fromMaybe (-1) pos)
! foreign import ccall osInsertMenuRadioItem :: MenuHandle -> Int -> IO MenuHandle
! 
! -- | Select an active item in the radio group.
! foreign import ccall "osSetMenuRadioGroupSelection" setMenuRadioGroupSelection :: MenuHandle -> Int -> IO ()
! 
! -- | returns an index of the currently selected radio item.
! foreign import ccall "osGetMenuRadioGroupSelection" getMenuRadioGroupSelection :: MenuHandle -> IO Int
! 
! -----------------------------------------------------------------------------------------
! -- Common functions
! -----------------------------------------------------------------------------------------
! 
! -- | 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