[htoolkit-cvs] port/src/Port ToolBar.hs,NONE,1.1 Handlers.hs,1.23,1.24 Types.hs,1.21,1.22

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

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

Modified Files:
	Handlers.hs Types.hs 
Added Files:
	ToolBar.hs 
Log Message:
Added implementation for ToolBar. The Windows version is still in very basic
state.


--- NEW FILE: ToolBar.hs ---
{-# OPTIONS -fffi -#include ToolBar.h #-}
-----------------------------------------------------------------------------------------
{-| Module      :  ToolBar
    Copyright   :  (c) Krasimir Angelov 2003
    License     :  BSD-style

    Maintainer  :  ka2...@ya...
    Stability   :  provisional
    Portability :  portable

    ToolBar.
-}
-----------------------------------------------------------------------------------------
module Graphics.UI.Port.ToolBar
		(
		-- * Creation
		  createToolBar
		, destroyToolBar

		, DockPlace(..)
		, insertToolButton
		, insertToolCheckButton
		, insertToolLine
		, setToolButtonBitmap,  getToolButtonBitmap
		, setToolButtonEnabled, getToolButtonEnabled
		, setToolButtonTip,        getToolButtonTip
		, setToolButtonText,      getToolButtonText
		, setToolButtonChecked,getToolButtonChecked
		, getToolItemPos
		, destroyToolItem
             	) where

import Graphics.UI.Port.Types
import Graphics.UI.Port.PtrMap as PtrMap
import Foreign.Ptr
import Foreign.C
import Control.Concurrent.MVar
import Data.Maybe
import System.IO.Unsafe( unsafePerformIO )

data DockPlace = DockLeft | DockTop | DockRight | DockBottom

toCDockPlace :: DockPlace -> Int
toCDockPlace DockLeft   = 0
toCDockPlace DockTop    = 1
toCDockPlace DockRight  = 2
toCDockPlace DockBottom = 3

createToolBar :: String -> DockPlace -> Int -> Int -> Int -> IO WindowHandle
createToolBar name place band_num band_position offset =
	withCString name (\cname -> osCreateToolBar cname (toCDockPlace place) band_num band_position offset)
foreign import ccall osCreateToolBar :: CString -> Int -> Int -> Int -> Int -> IO WindowHandle

foreign import ccall "osDestroyToolBar" destroyToolBar :: WindowHandle -> IO ()

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

insertToolLine :: WindowHandle -> Maybe Int -> IO ToolHandle
insertToolLine toolBar pos = osInsertToolLine toolBar (fromMaybe (-1) pos)
foreign import ccall osInsertToolLine :: WindowHandle -> Int -> IO ToolHandle

{-# NOINLINE toolBitmaps #-}
toolBitmaps :: MVar (PtrMap WindowHandle Bitmap)
toolBitmaps = unsafePerformIO (newMVar empty)

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

foreign import ccall "osDestroyToolItem" destroyToolItem :: ToolHandle -> IO ()

Index: Handlers.hs
===================================================================
RCS file: /cvsroot/htoolkit/port/src/Port/Handlers.hs,v
retrieving revision 1.23
retrieving revision 1.24
diff -C2 -d -r1.23 -r1.24
*** Handlers.hs	8 Jun 2003 19:42:14 -0000	1.23
--- Handlers.hs	8 Jul 2003 20:31:29 -0000	1.24
***************
*** 64,71 ****
                  ,setControlCommandHandler, setControlCommandDefHandler, getControlCommandHandler
  
!                 -- ** Register commands
                  ,setMenuCommandHandler, setMenuCommandDefHandler, getMenuCommandHandler
                  ,setMenuUpdateHandler,  setMenuUpdateDefHandler,  getMenuUpdateHandler
                  ,setMenuDestroyHandler, setMenuDestroyDefHandler, getMenuDestroyHandler
                  ) where
  
--- 64,75 ----
                  ,setControlCommandHandler, setControlCommandDefHandler, getControlCommandHandler
  
!                 -- * Menu events
                  ,setMenuCommandHandler, setMenuCommandDefHandler, getMenuCommandHandler
                  ,setMenuUpdateHandler,  setMenuUpdateDefHandler,  getMenuUpdateHandler
                  ,setMenuDestroyHandler, setMenuDestroyDefHandler, getMenuDestroyHandler
+                 
+                 -- * ToolBar events
+                 ,setToolCommandHandler, setToolCommandDefHandler, getToolCommandHandler
+ 		,setToolDestroyHandler,     setToolDestroyDefHandler,    getToolDestroyHandler
                  ) where
  
***************
*** 551,555 ****
  setMenuDestroyDefHandler hmenu
    = setDefHandler hmenu handlersMenuDestroy
!   
  getMenuDestroyHandler :: MenuHandle -> IO (IO ())
  getMenuDestroyHandler hmenu
--- 555,559 ----
  setMenuDestroyDefHandler hmenu
    = setDefHandler hmenu handlersMenuDestroy
! 
  getMenuDestroyHandler :: MenuHandle -> IO (IO ())
  getMenuDestroyHandler hmenu
***************
*** 695,698 ****
--- 699,757 ----
    = getHandler htimer (return ()) handlersTimerDestroy
  
+ -----------------------------------------------------------------------------------------
+ -- 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 handlersToolDestroy #-}
+ handlersToolDestroy :: MVar (PtrMap ToolHandle (IO ()))
+ handlersToolDestroy
+   = unsafePerformIO (newMVar empty)
+ 
+ setToolDestroyHandler :: ToolHandle -> IO () -> IO ()
+ setToolDestroyHandler htool handler
+   = setHandler htool handler handlersToolDestroy
+ 
+ setToolDestroyDefHandler :: ToolHandle -> IO ()
+ setToolDestroyDefHandler htool
+   = setDefHandler htool handlersToolDestroy
+ 
+ getToolDestroyHandler :: ToolHandle -> IO (IO ())
+ getToolDestroyHandler htool
+   = getHandler htool (return ()) handlersToolDestroy
+ 
+ handleToolDestroy :: ToolHandle -> IO ()
+ handleToolDestroy htool
+   = do map <- takeMVar handlersToolDestroy
+        setToolCommandDefHandler htool
+        putMVar handlersToolDestroy (delete htool map)
+        case lookup htool map of
+          Nothing -> return ()
+          Just io -> safeio io
+ 
  {-----------------------------------------------------------------------------------------
    foreign exports
***************
*** 700,704 ****
  foreign export ccall handleWindowDismiss :: WindowHandle -> IO ()
  foreign export ccall handleWindowReLayout :: WindowHandle -> IO ()
! foreign export ccall handleWindowDestroy :: WindowHandle -> IO () 
  foreign export ccall handleWindowPaint :: WindowHandle -> CanvasHandle -> CInt -> CInt -> CInt -> CInt -> IO ()
  foreign export ccall handleWindowResize :: WindowHandle -> CInt -> CInt -> IO ()
--- 759,763 ----
  foreign export ccall handleWindowDismiss :: WindowHandle -> IO ()
  foreign export ccall handleWindowReLayout :: WindowHandle -> IO ()
! foreign export ccall handleWindowDestroy :: WindowHandle -> IO ()
  foreign export ccall handleWindowPaint :: WindowHandle -> CanvasHandle -> CInt -> CInt -> CInt -> CInt -> IO ()
  foreign export ccall handleWindowResize :: WindowHandle -> CInt -> CInt -> IO ()
***************
*** 711,715 ****
  foreign export ccall handleDialogActivate :: WindowHandle -> IO ()
  foreign export ccall handleWindowContextMenu :: WindowHandle -> CInt -> CInt -> CWord -> IO ()
! foreign export ccall handleControlCommand :: WindowHandle -> IO () 
  foreign export ccall handleMenuCommand :: MenuHandle -> IO ()
  foreign export ccall handleMenuUpdate :: MenuHandle -> IO ()
--- 770,774 ----
  foreign export ccall handleDialogActivate :: WindowHandle -> IO ()
  foreign export ccall handleWindowContextMenu :: WindowHandle -> CInt -> CInt -> CWord -> IO ()
! foreign export ccall handleControlCommand :: WindowHandle -> IO ()
  foreign export ccall handleMenuCommand :: MenuHandle -> IO ()
  foreign export ccall handleMenuUpdate :: MenuHandle -> IO ()
***************
*** 719,720 ****
--- 778,781 ----
  foreign export ccall handleProcessDismiss :: IO ()
  foreign export ccall handleProcessDestroy :: IO ()
+ foreign export ccall handleToolCommand :: ToolHandle -> IO ()
+ foreign export ccall handleToolDestroy :: ToolHandle -> IO ()
\ No newline at end of file

Index: Types.hs
===================================================================
RCS file: /cvsroot/htoolkit/port/src/Port/Types.hs,v
retrieving revision 1.21
retrieving revision 1.22
diff -C2 -d -r1.21 -r1.22
*** Types.hs	2 Jul 2003 17:48:03 -0000	1.21
--- Types.hs	8 Jul 2003 20:31:29 -0000	1.22
***************
*** 1,5 ****
  {-# OPTIONS -fglasgow-exts -#include Font.h -#include Bitmap.h #-}
  -- the previous line is just needed for "osDeleteFont" and "osDeleteBitmap" :-(
! -- #hide 
  -----------------------------------------------------------------------------------------
  {-| Module      :  Types
--- 1,5 ----
  {-# OPTIONS -fglasgow-exts -#include Font.h -#include Bitmap.h #-}
  -- the previous line is just needed for "osDeleteFont" and "osDeleteBitmap" :-(
! -- #hide
  -----------------------------------------------------------------------------------------
  {-| Module      :  Types
***************
*** 15,35 ****
  -----------------------------------------------------------------------------------------
  module Graphics.UI.Port.Types
!             ( 
              -- * Geometry
!             
              -- ** Points
                Point(..), pt, pointMove, pointAdd, pointSub, pointScale
!               
  	    -- ** Sizes
              , Size(..), sz, sizeEncloses, maxSize, addh, addv, sizeDistance
!             
              -- ** Rectangles
              , Rect(..), topLeft, topRight, bottomLeft, bottomRight
              , rect, rectAt, rectSize, rectOfSize, rectIsEmpty
!             , pointInRect, rectMove, rectMoveTo, pointToRect, centralPoint, centralRect, rectStretchTo 
              , disjointRects, rectsDiff, rectUnion, rectSect
!   
              -- * Render
!             
              -- ** Colors
              , module Graphics.UI.Port.Colors
--- 15,35 ----
  -----------------------------------------------------------------------------------------
  module Graphics.UI.Port.Types
!             (
              -- * Geometry
! 
              -- ** Points
                Point(..), pt, pointMove, pointAdd, pointSub, pointScale
! 
  	    -- ** Sizes
              , Size(..), sz, sizeEncloses, maxSize, addh, addv, sizeDistance
! 
              -- ** Rectangles
              , Rect(..), topLeft, topRight, bottomLeft, bottomRight
              , rect, rectAt, rectSize, rectOfSize, rectIsEmpty
!             , pointInRect, rectMove, rectMoveTo, pointToRect, centralPoint, centralRect, rectStretchTo
              , disjointRects, rectsDiff, rectUnion, rectSect
! 
              -- * Render
! 
              -- ** Colors
              , module Graphics.UI.Port.Colors
***************
*** 39,43 ****
              , Codec(..)
  
!             -- ** Canvas 
              , DrawMode(..)
              , BufferMode(..)
--- 39,43 ----
              , Codec(..)
  
!             -- ** Canvas
              , DrawMode(..)
              , BufferMode(..)
***************
*** 48,52 ****
  
              -- ** Fonts
!             , Font 
              , fontDef
              , FontDef(..), FontName, FontSize, FontWeight, FontStyle(..)
--- 48,52 ----
  
              -- ** Fonts
!             , Font
              , fontDef
              , FontDef(..), FontName, FontSize, FontWeight, FontStyle(..)
***************
*** 60,64 ****
              , Modifiers(..)
              , noneDown, justShift, justAlt, justControl, noModifiers
!             
              -- ** Mouse events
              , MouseEvent(..)
--- 60,64 ----
              , Modifiers(..)
              , noneDown, justShift, justAlt, justControl, noModifiers
! 
              -- ** Mouse events
              , MouseEvent(..)
***************
*** 68,72 ****
              , KeyboardEvent(..), Key(..), keyModifiers
              , keyboardKey, keyboardRepeat
!             
              -- * Document interface
              , DocumentInterface(..)
--- 68,72 ----
              , KeyboardEvent(..), Key(..), keyModifiers
              , keyboardKey, keyboardRepeat
! 
              -- * Document interface
              , DocumentInterface(..)
***************
*** 79,84 ****
              , BitmapHandle
              , TimerHandle
              , nullHandle
!             
              -- * Marshalling to C
              , toCDrawMode, toCBufferMode
--- 79,85 ----
              , BitmapHandle
              , TimerHandle
+ 	    , ToolHandle
              , nullHandle
! 
              -- * Marshalling to C
              , toCDrawMode, toCBufferMode
***************
*** 143,146 ****
--- 144,151 ----
  type TimerHandle = Ptr TH
  data TH = TH
+ 
+ -- | Abstract handle to a tool
+ type ToolHandle = Ptr TLH
+ data TLH = TLH
  
  -- | A null handle. Use with care.