[htoolkit-cvs] port/src/Port Handlers.hs,1.7,1.8 Types.hs,1.12,1.13 Window.hs,1.4,1.5

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

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

Modified Files:
	Handlers.hs Types.hs Window.hs 
Log Message:
MDI/SDI interface for Windows


Index: Handlers.hs
===================================================================
RCS file: /cvsroot/htoolkit/port/src/Port/Handlers.hs,v
retrieving revision 1.7
retrieving revision 1.8
diff -C2 -d -r1.7 -r1.8
*** Handlers.hs	31 Jan 2003 21:06:13 -0000	1.7
--- Handlers.hs	10 Feb 2003 22:42:08 -0000	1.8
***************
*** 1,10 ****
! {-# OPTIONS -fglasgow-exts  -#include Types.h -#include Timer.h #-}
  
  -----------------------------------------------------------------------------------------
  {-| Module      :  Handlers
!     Copyright   :  (c) Daan Leijen 2003
      License     :  BSD-style
  
!     Maintainer  :  da...@cs...
      Stability   :  provisional
      Portability :  portable
--- 1,10 ----
! {-# OPTIONS -fglasgow-exts  -#include Types.h #-}
  
  -----------------------------------------------------------------------------------------
  {-| Module      :  Handlers
!     Copyright   :  (c) Krasimir Angelov & Daan Leijen 2003
      License     :  BSD-style
  
!     Maintainer  :  ka2...@ya... da...@cs...
      Stability   :  provisional
      Portability :  portable
***************
*** 23,44 ****
      When 'quit' is called, it will close all windows, unregister all event handlers
      and destroy all timers. 'quit' is called automatically when the last window 
!     is destroyed unless 'enableAutoQuit' is called with a 'False' argument.
  -}
  -----------------------------------------------------------------------------------------
  module Graphics.UI.Port.Handlers 
                  (
!                 -- * Quit
!                  quit, enableAutoQuit
! 
!                 -- ** Clean up
!                 ,destroyAllTimers
!                 ,unregisterAllHandlers
!                 ,unregisterAllWindowHandlers
                  
                  -- * Timers
!                 , createTimer, destroyTimer
! 
                  -- * Windows
!                 ,registerWindow 
                  
                  -- ** Register events
--- 23,39 ----
      When 'quit' is called, it will close all windows, unregister all event handlers
      and destroy all timers. 'quit' is called automatically when the last window 
!     is destroyed.
  -}
  -----------------------------------------------------------------------------------------
  module Graphics.UI.Port.Handlers 
                  (
!                 -- * Clean up
!                  unregisterAllWindowHandlers
                  
                  -- * Timers
!                 ,registerTimer,  unregisterTimer, getAllTimerHandles
!                 
                  -- * Windows
!                 ,registerWindow, unregisterWindow, getAllWindowHandles
                  
                  -- ** Register events
***************
*** 52,56 ****
                  ,registerWindowKeyboard  
                  ,registerWindowDeactivate
!                 ,registerWindowActivate  
  
                  -- ** Fire events
--- 47,51 ----
                  ,registerWindowKeyboard  
                  ,registerWindowDeactivate
!                 ,registerWindowActivate                  
  
                  -- ** Fire events
***************
*** 67,71 ****
                  ,unregisterWindowKeyboard     
                  ,unregisterWindowDeactivate   
!                 ,unregisterWindowActivate     
  
                  -- * Commands
--- 62,74 ----
                  ,unregisterWindowKeyboard     
                  ,unregisterWindowDeactivate   
!                 ,unregisterWindowActivate                
!                 
!                 -- * Process
!                 -- ** Register events
!                 ,registerDismissProcess
!                 ,registerDestroyProcess
!                 -- ** Unregister events
!                 ,unregisterDismissProcess
!                 ,unregisterDestroyProcess
  
                  -- * Commands
***************
*** 99,103 ****
  import Prelude hiding (lookup)
  import Graphics.UI.Port.Types
! import Graphics.UI.Port.PtrMap 
  
  import Foreign.C
--- 102,106 ----
  import Prelude hiding (lookup)
  import Graphics.UI.Port.Types
! import Graphics.UI.Port.PtrMap
  
  import Foreign.C
***************
*** 106,110 ****
  import Control.Monad( when )
  import System.IO.Unsafe( unsafePerformIO )
- import System.Mem( performGC )
  
  {-----------------------------------------------------------------------------------------
--- 109,112 ----
***************
*** 112,117 ****
  -----------------------------------------------------------------------------------------}
  safeio :: IO () -> IO ()
! safeio io
!   = io `catch` (\err -> do print err; return ())
  
  invokeHandler :: Ptr a -> MVar (PtrMap a b) -> (b -> IO ()) -> IO ()
--- 114,118 ----
  -----------------------------------------------------------------------------------------}
  safeio :: IO () -> IO ()
! safeio io = io `catch` print
  
  invokeHandler :: Ptr a -> MVar (PtrMap a b) -> (b -> IO ()) -> IO ()
***************
*** 137,183 ****
  
  {-----------------------------------------------------------------------------------------
-   quit
- -----------------------------------------------------------------------------------------}
- -- | 'quit' exits the main event loop, closes any windows and menus, destroys all timers
- -- and unregisters any event handlers. This function is automatically called when all
- -- windows are closed, unless 'enableAutoQuit' has been called with a 'False' argument.
- quit :: IO ()
- quit
-   = do osQuit
-        destroyAllTimers
-        unregisterAllHandlers
-        performGC                -- to release any foreign objects
-        return ()
- foreign import ccall osQuit :: IO ()
- 
- {-----------------------------------------------------------------------------------------
    Unregister many.
  -----------------------------------------------------------------------------------------}
- -- | Unregister all current event handlers (including menu handlers). This function
- -- is called by 'quit' when the GUI event loop terminates.
- unregisterAllHandlers :: IO ()
- unregisterAllHandlers
-   =  do clear handlersWindowDestroy
-         clear handlersWindowReLayout
-         clear handlersWindowDismiss
-         clear handlersWindowPaint    
-         clear handlersWindowResize   
-         clear handlersWindowScroll   
-         clear handlersWindowMouse
-         clear handlersWindowKeyboard
-         clear handlersWindowDeactivate
-         clear handlersWindowActivate 
-         clear handlersPopUpClick     
-         clear handlersListBoxClick   
-         clear handlersRadioBoxClick  
-         clear handlersCheckBoxClick  
-         clear handlersButtonClick            
-         clear handlersMenuCommand     -- menu commands
-         clear handlersMenuUpdate      -- menu updates
-         return ()
-    where
-     clear mvar
-       = do swapMVar mvar empty
-       
  
  -- | Unregister all event handlers and menu handlers associated with a specific window.
--- 138,143 ----
***************
*** 226,231 ****
                              mapM_ unregisterMenuCommand menus
  
- 
- 
  {-----------------------------------------------------------------------------------------
    Keep track of all windows
--- 186,189 ----
***************
*** 246,266 ****
  
  -- returns True when this was the last open window.
! unregisterWindow :: WindowHandle -> IO Bool
  unregisterWindow hwnd
    = do set <- takeMVar windows
!        let set' = delete hwnd set
!        putMVar windows set'
!        return (isEmpty set')
! 
! {-# NOINLINE autoQuit #-}
! autoQuit :: MVar Bool
! autoQuit  = unsafePerformIO (newMVar True)
! 
! -- | If called with 'True', 'quit' is called automatically when all windows are
! -- closed. Returns the previous value.
! enableAutoQuit :: Bool -> IO Bool  
! enableAutoQuit enable
!   = swapMVar autoQuit enable
  
  
  {-----------------------------------------------------------------------------------------
--- 204,214 ----
  
  -- returns True when this was the last open window.
! unregisterWindow :: WindowHandle -> IO ()
  unregisterWindow hwnd
    = do set <- takeMVar windows
!        putMVar windows (delete hwnd set)
  
+ getAllWindowHandles :: IO [WindowHandle]
+ getAllWindowHandles = fmap keys (readMVar windows)
  
  {-----------------------------------------------------------------------------------------
***************
*** 291,298 ****
           Nothing -> return ()
           Just io -> safeio io
!        last <- unregisterWindow hwnd
!        aquit <- readMVar autoQuit
!        when (last && aquit) quit    -- call quit when last window is destroyed (and autoQuit is enabled).
! 
  
  {-----------------------------------------------------------------------------------------
--- 239,243 ----
           Nothing -> return ()
           Just io -> safeio io
!        unregisterWindow hwnd
  
  {-----------------------------------------------------------------------------------------
***************
*** 334,339 ****
    = unregister hwnd handlersWindowDismiss
  
! handleWindowClose :: WindowHandle -> IO ()
! handleWindowClose hwnd
    = invokeHandler hwnd handlersWindowDismiss id
  
--- 279,284 ----
    = unregister hwnd handlersWindowDismiss
  
! handleWindowDismiss :: WindowHandle -> IO ()
! handleWindowDismiss hwnd
    = invokeHandler hwnd handlersWindowDismiss id
  
***************
*** 595,598 ****
--- 540,581 ----
    = invokeHandler hmenu handlersMenuCommand id
  
+ {-----------------------------------------------------------------------------------------
+   Process
+ -----------------------------------------------------------------------------------------}
+ {-# NOINLINE handlersDismissProcess #-}
+ handlersDismissProcess :: MVar (IO ())
+ handlersDismissProcess
+   = unsafePerformIO (newMVar (return ()))
+ 
+ registerDismissProcess :: IO () -> IO ()
+ registerDismissProcess handler = do
+ 	takeMVar handlersDismissProcess
+ 	putMVar handlersDismissProcess handler
+ 
+ unregisterDismissProcess :: IO ()
+ unregisterDismissProcess = do
+ 	takeMVar handlersDismissProcess
+ 	putMVar handlersDismissProcess (return ())
+ 
+ handleDismissProcess :: IO ()
+ handleDismissProcess = readMVar handlersDismissProcess >>= id
+ 
+ {-# NOINLINE handlersDestroyProcess #-}
+ handlersDestroyProcess :: MVar (IO ())
+ handlersDestroyProcess
+   = unsafePerformIO (newMVar (return ()))
+ 
+ registerDestroyProcess :: IO () -> IO ()
+ registerDestroyProcess handler = do
+ 	takeMVar handlersDestroyProcess
+ 	putMVar handlersDestroyProcess handler
+ 
+ unregisterDestroyProcess :: IO ()
+ unregisterDestroyProcess = do
+ 	takeMVar handlersDestroyProcess
+ 	putMVar handlersDestroyProcess (return ())
+ 
+ handleDestroyProcess :: IO ()
+ handleDestroyProcess = readMVar handlersDestroyProcess >>= id
  
  {-----------------------------------------------------------------------------------------
***************
*** 608,639 ****
    = invokeHandler htimer handlersTimer id
  
! -- | Create a timer with a handler that is called on a specified milli-second interval.
! createTimer :: Int -> IO () -> IO TimerHandle
! createTimer msecs handler
!   = do htimer <- osCreateTimer msecs
!        register htimer handler handlersTimer
!        return htimer
! foreign import ccall osCreateTimer :: Int -> IO TimerHandle
! 
! -- | Destroy a timer and automatically unregister its event handler.
! destroyTimer :: TimerHandle -> IO ()
! destroyTimer htimer
!   = do unregister htimer handlersTimer
!        osDestroyTimer htimer
! foreign import ccall osDestroyTimer :: TimerHandle -> IO ()
  
! -- Destroy all timers (called by quit).
! destroyAllTimers :: IO ()
! destroyAllTimers
!   = do map <- readMVar handlersTimer
!        mapM_ destroyTimer (keys map)
!        swapMVar handlersTimer empty     -- paranoia
!        return ()
  
  
  {-----------------------------------------------------------------------------------------
    foreign exports
  -----------------------------------------------------------------------------------------}
! foreign export ccall handleWindowClose :: WindowHandle -> IO ()
  foreign export ccall handleWindowReLayout :: WindowHandle -> IO ()
  foreign export ccall handleWindowDestroy :: WindowHandle -> IO () 
--- 591,609 ----
    = invokeHandler htimer handlersTimer id
  
! registerTimer :: TimerHandle -> IO () -> IO ()
! registerTimer htimer handler
!   = register htimer handler handlersTimer
  
! unregisterTimer :: TimerHandle -> IO ()
! unregisterTimer htimer
!   = unregister htimer handlersTimer
  
+ getAllTimerHandles :: IO [TimerHandle]
+ getAllTimerHandles = fmap keys (readMVar handlersTimer)
  
  {-----------------------------------------------------------------------------------------
    foreign exports
  -----------------------------------------------------------------------------------------}
! foreign export ccall handleWindowDismiss :: WindowHandle -> IO ()
  foreign export ccall handleWindowReLayout :: WindowHandle -> IO ()
  foreign export ccall handleWindowDestroy :: WindowHandle -> IO () 
***************
*** 653,654 ****
--- 623,626 ----
  foreign export ccall handleMenusUpdate :: IO ()
  foreign export ccall handleTimer :: TimerHandle -> IO ()
+ foreign export ccall handleDismissProcess :: IO ()
+ foreign export ccall handleDestroyProcess :: IO ()
\ No newline at end of file

Index: Types.hs
===================================================================
RCS file: /cvsroot/htoolkit/port/src/Port/Types.hs,v
retrieving revision 1.12
retrieving revision 1.13
diff -C2 -d -r1.12 -r1.13
*** Types.hs	31 Jan 2003 01:01:43 -0000	1.12
--- Types.hs	10 Feb 2003 22:42:09 -0000	1.13
***************
*** 77,80 ****
--- 77,83 ----
              , KeyboardEvent(..), Key(..), keyModifiers
              , keyboardKey, keyboardRepeat
+             
+             -- * Document interface
+             , DocumentInterface(..)
  
              -- * Primitive Handles
***************
*** 106,109 ****
--- 109,114 ----
              , fromCMouseEvent
              , fromCKeyboardEvent
+             
+             , toCDocumentInterface
  
              , fromCInt, toCInt 
***************
*** 778,781 ****
--- 783,800 ----
            13 -> KeyLost key
  
+ {-----------------------------------------------------------------------------------------
+   Document interface
+ -----------------------------------------------------------------------------------------}
+ -- | The document interface type of interactive processes.
+ data	DocumentInterface
+ 	= NDI				-- ^ No document interface
+ 	| SDI				-- ^ Single document interface
+ 	| MDI				-- ^ Multiple document interface
+ 	deriving (Eq,Show)
+ 
+ toCDocumentInterface :: DocumentInterface -> CInt
+ toCDocumentInterface NDI = 0
+ toCDocumentInterface SDI = 1
+ toCDocumentInterface MDI = 2
  
  {-----------------------------------------------------------------------------------------

Index: Window.hs
===================================================================
RCS file: /cvsroot/htoolkit/port/src/Port/Window.hs,v
retrieving revision 1.4
retrieving revision 1.5
diff -C2 -d -r1.4 -r1.5
*** Window.hs	8 Feb 2003 08:38:08 -0000	1.4
--- Window.hs	10 Feb 2003 22:42:09 -0000	1.5
***************
*** 2,9 ****
  -----------------------------------------------------------------------------------------
  {-| Module      :  Window
!     Copyright   :  (c) Daan Leijen 2003
      License     :  BSD-style
  
!     Maintainer  :  da...@cs...
      Stability   :  provisional
      Portability :  portable
--- 2,9 ----
  -----------------------------------------------------------------------------------------
  {-| Module      :  Window
!     Copyright   :  (c) Krasimir Angelov & Daan Leijen 2003
      License     :  BSD-style
  
!     Maintainer  :  ka2...@ya... & da...@cs...
      Stability   :  provisional
      Portability :  portable
***************
*** 15,21 ****
               ( 
               -- * Creation
!                createWindow, createDialog, createMDIWindow
               -- * Operations
!              , showWindow, runWindow, closeWindow              
               , scrollWindowTo
               , invalidateWindowFrame
--- 15,23 ----
               ( 
               -- * Creation
!                createWindow, createDialog
               -- * Operations
!              , showWindow, runWindow
!              , dismissWindow, dismissAllWindows
!              , destroyWindow, destroyAllWindows
               , scrollWindowTo
               , invalidateWindowFrame
***************
*** 38,44 ****
  import Foreign.Ptr
  import Foreign.Marshal.Alloc
  import Graphics.UI.Port.Types
  import Graphics.UI.Port.Canvas(initCanvas, doneCanvas, defaultPen, dialogPen)
! import Graphics.UI.Port.Handlers( registerWindow, registerWindowPaint )  
  
  {-----------------------------------------------------------------------------------------
--- 40,49 ----
  import Foreign.Ptr
  import Foreign.Marshal.Alloc
+ import System.IO.Unsafe( unsafePerformIO )
+ import Control.Concurrent.MVar
+ import Graphics.UI.Port.PtrMap
  import Graphics.UI.Port.Types
  import Graphics.UI.Port.Canvas(initCanvas, doneCanvas, defaultPen, dialogPen)
! import Graphics.UI.Port.Handlers( getAllWindowHandles, registerWindow, registerWindowDismiss, registerWindowPaint )
  
  {-----------------------------------------------------------------------------------------
***************
*** 71,81 ****
  -- | Create a new (invisible) window.
  createWindow :: IO WindowHandle
! createWindow
!   = do hwnd <- osCreateWindow
!        registerWindow hwnd
!        registerWindowPaint hwnd onpaint
!        return hwnd
!        where
!        		onpaint canvas rect = do
  			initCanvas defaultPen UnBuffered canvas					
  			doneCanvas canvas
--- 76,87 ----
  -- | Create a new (invisible) window.
  createWindow :: IO WindowHandle
! createWindow = do
! 	hwnd <- osCreateWindow
! 	registerWindow hwnd
! 	registerWindowPaint hwnd onpaint
! 	registerWindowDismiss hwnd (destroyWindow hwnd)
! 	return hwnd
! 	where
! 		onpaint canvas rect = do
  			initCanvas defaultPen UnBuffered canvas					
  			doneCanvas canvas
***************
*** 84,106 ****
  -- | Create a new (invisible) dialog window.
  createDialog :: WindowHandle -> IO WindowHandle
! createDialog hparent
!   = do hwnd <- osCreateDialog hparent
!        registerWindow hwnd
!        registerWindowPaint hwnd onpaint
!        return hwnd
!        where
  		onpaint canvas rect = do
!        			initCanvas dialogPen UnBuffered canvas					
  			doneCanvas canvas
  foreign import ccall osCreateDialog :: WindowHandle -> IO WindowHandle
  
- -- | Create a new (invisible) MDI window.
- createMDIWindow :: WindowHandle -> IO WindowHandle
- createMDIWindow hparent
-   = do hwnd <- osCreateMDIWindow hparent
-        registerWindow hwnd
-        return hwnd
- foreign import ccall osCreateMDIWindow :: WindowHandle -> IO WindowHandle
- 
  -- | Set the default foreground color, background color and hatch style.
  setWindowColor :: WindowHandle -> Color -> Color -> HatchStyle -> IO ()
--- 90,105 ----
  -- | Create a new (invisible) dialog window.
  createDialog :: WindowHandle -> IO WindowHandle
! createDialog hparent = do
! 	hwnd <- osCreateDialog hparent
! 	registerWindow hwnd
!        	registerWindowPaint hwnd onpaint
!        	registerWindowDismiss hwnd (destroyWindow hwnd)
! 	return hwnd
! 	where
  		onpaint canvas rect = do
! 			initCanvas dialogPen UnBuffered canvas
  			doneCanvas canvas
  foreign import ccall osCreateDialog :: WindowHandle -> IO WindowHandle
  
  -- | Set the default foreground color, background color and hatch style.
  setWindowColor :: WindowHandle -> Color -> Color -> HatchStyle -> IO ()
***************
*** 138,143 ****
  foreign import ccall "osRunWindow" runWindow  :: WindowHandle -> IO ()
  
! -- | Close a window.
! foreign import ccall "osCloseWindow" closeWindow :: WindowHandle -> IO ()
  
  -- | Get the size of the view frame.
--- 137,158 ----
  foreign import ccall "osRunWindow" runWindow  :: WindowHandle -> IO ()
  
! -- | Dismiss a window.
! dismissWindow :: WindowHandle -> IO Bool
! dismissWindow hwnd = fmap fromCBool (osDismissWindow hwnd)
! foreign import ccall osDismissWindow :: WindowHandle -> IO CBool
! 
! dismissAllWindows :: IO Bool
! dismissAllWindows = getAllWindowHandles >>= dismiss
! 	where
! 		dismiss [] = return True
! 		dismiss (h:hs) = do
! 			r <- dismissWindow h
! 			if r then dismiss hs else return False
! 
! -- | Destroy a window.
! foreign import ccall "osDestroyWindow" destroyWindow :: WindowHandle -> IO ()
! 
! destroyAllWindows :: IO ()
! destroyAllWindows = getAllWindowHandles >>= mapM_ destroyWindow
  
  -- | Get the size of the view frame.