Update of /cvsroot/htoolkit/port/src/Port
In directory sc8-pr-cvs1:/tmp/cvs-serv28624/port/src/Port
Modified Files:
Controls.hs Handlers.hs
Log Message:
Add support for icons in Notebook
Index: Controls.hs
===================================================================
RCS file: /cvsroot/htoolkit/port/src/Port/Controls.hs,v
retrieving revision 1.19
retrieving revision 1.20
diff -C2 -d -r1.19 -r1.20
*** Controls.hs 24 Aug 2003 13:57:34 -0000 1.19
--- Controls.hs 30 Aug 2003 22:57:46 -0000 1.20
***************
*** 95,99 ****
-- * NotebookPage
, insertNotebookPage
! , getNotebookPageTitle, setNotebookPageTitle
, getNotebookPagePos
, destroyNotebookPage
--- 95,100 ----
-- * NotebookPage
, insertNotebookPage
! , getNotebookPageTitle, setNotebookPageTitle
! , getNotebookPageBitmap, setNotebookPageBitmap
, getNotebookPagePos
, destroyNotebookPage
***************
*** 103,109 ****
import Foreign
import Foreign.C
import Graphics.UI.Port.Types
import Graphics.UI.Port.Handlers -- just for haddock
! import Data.Maybe(fromMaybe)
-----------------------------------------------------------------------------------------
--- 104,112 ----
import Foreign
import Foreign.C
+ import Control.Concurrent.MVar
+ import Data.Maybe(fromMaybe)
import Graphics.UI.Port.Types
import Graphics.UI.Port.Handlers -- just for haddock
! import Graphics.UI.Port.PtrMap as PtrMap
-----------------------------------------------------------------------------------------
***************
*** 500,501 ****
--- 503,520 ----
getNotebookPageSize hwnd = withCSizeResult (osGetNotebookPageSize hwnd)
foreign import ccall osGetNotebookPageSize :: WindowHandle -> Ptr CInt -> IO ()
+
+ setNotebookPageBitmap :: WindowHandle -> Maybe Bitmap -> IO ()
+ setNotebookPageBitmap hwnd (Just bmp) = do
+ map <- takeMVar windowBitmaps
+ withCBitmap bmp (osSetNotebookPageBitmap hwnd)
+ putMVar windowBitmaps (insert hwnd bmp map)
+ setNotebookPageBitmap hwnd Nothing = do
+ map <- takeMVar windowBitmaps
+ osSetNotebookPageBitmap hwnd nullPtr
+ putMVar windowBitmaps (delete hwnd map)
+ foreign import ccall osSetNotebookPageBitmap :: WindowHandle -> BitmapHandle -> IO ()
+
+ getNotebookPageBitmap :: WindowHandle -> IO (Maybe Bitmap)
+ getNotebookPageBitmap hwnd = do
+ map <- readMVar windowBitmaps
+ return (PtrMap.lookup hwnd map)
Index: Handlers.hs
===================================================================
RCS file: /cvsroot/htoolkit/port/src/Port/Handlers.hs,v
retrieving revision 1.28
retrieving revision 1.29
diff -C2 -d -r1.28 -r1.29
*** Handlers.hs 25 Aug 2003 17:35:49 -0000 1.28
--- Handlers.hs 30 Aug 2003 22:57:46 -0000 1.29
***************
*** 60,71 ****
,setMenuUpdateHandler, setMenuUpdateDefHandler, getMenuUpdateHandler
,setMenuDestroyHandler, setMenuDestroyDefHandler, getMenuDestroyHandler
! -- ** Internals
! ,menuBitmaps
!
-- * ToolBar events
,setToolCommandHandler, setToolCommandDefHandler, getToolCommandHandler
,setToolDestroyHandler, setToolDestroyDefHandler, getToolDestroyHandler
-- ** Internals
! ,toolBitmaps
) where
--- 60,70 ----
,setMenuUpdateHandler, setMenuUpdateDefHandler, getMenuUpdateHandler
,setMenuDestroyHandler, setMenuDestroyDefHandler, getMenuDestroyHandler
!
-- * ToolBar events
,setToolCommandHandler, setToolCommandDefHandler, getToolCommandHandler
,setToolDestroyHandler, setToolDestroyDefHandler, getToolDestroyHandler
+
-- ** Internals
! ,toolBitmaps, menuBitmaps, windowBitmaps
) where
***************
*** 167,170 ****
--- 166,173 ----
= unsafePerformIO (newMVar empty)
+ {-# NOINLINE windowBitmaps #-}
+ windowBitmaps :: MVar (PtrMap WindowHandle Bitmap)
+ windowBitmaps = unsafePerformIO (newMVar empty)
+
setWindowDestroyHandler :: WindowHandle -> IO () -> IO ()
setWindowDestroyHandler hwnd handler
***************
*** 189,192 ****
--- 192,197 ----
Nothing -> return ()
Just io -> safeio io
+ map <- takeMVar windowBitmaps
+ putMVar windowBitmaps (delete hwnd map)
unregisterWindow hwnd
|
