|
From: <kr_...@us...> - 2003-02-10 22:42:42
|
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.
|