add System.Posix.Types to default nhc98 build

[haskell-directory.git] / GHC / ConsoleHandler.hs

diff --git a/GHC/ConsoleHandler.hs b/GHC/ConsoleHandler.hs
index 8a9e2e0..3c3d2f4 100644 (file)
--- a/GHC/ConsoleHandler.hs
+++ b/GHC/ConsoleHandler.hs
@@ -2,24 +2,28 @@
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  GHC.ConsoleHandler
--- Copyright   :  whatevah
+-- Copyright   :  (c) The University of Glasgow
 -- License     :  see libraries/base/LICENSE
 -- 
 -- Maintainer  :  cvs-ghc@haskell.org
 -- Stability   :  internal
 -- Portability :  non-portable (GHC extensions)
 --
+-- NB. the contents of this module are only available on Windows.
+--
 -- Installing Win32 console handlers.
 -- 
 -----------------------------------------------------------------------------
+
 module GHC.ConsoleHandler
-#ifndef mingw32_HOST_OS
+#if !defined(mingw32_HOST_OS) && !defined(__HADDOCK__)
        where
 import Prelude -- necessary to get dependencies right
 #else /* whole file */
        ( Handler(..)
        , installHandler
        , ConsoleEvent(..)
+       , flushConsole
        ) where
 
 {-
@@ -30,6 +34,9 @@ import Prelude -- necessary to get dependencies right
 
 import Foreign
 import Foreign.C
+import GHC.IOBase
+import GHC.Handle
+import Data.Typeable
 
 data Handler
  = Default
@@ -43,7 +50,27 @@ data ConsoleEvent
     -- these are sent to Services only.
  | Logoff
  | Shutdown
+ deriving (Eq, Ord, Enum, Show, Read, Typeable)
 
+-- | Allows Windows console events to be caught and handled.  To
+-- handle a console event, call 'installHandler' passing the
+-- appropriate 'Handler' value.  When the event is received, if the
+-- 'Handler' value is @Catch f@, then a new thread will be spawned by
+-- the system to execute @f e@, where @e@ is the 'ConsoleEvent' that
+-- was received.
+--
+-- Note that console events can only be received by an application
+-- running in a Windows console.  Certain environments that look like consoles
+-- do not support console events, these include:
+--
+--  * Cygwin shells with @CYGWIN=tty@ set (if you don't set @CYGWIN=tty@,
+--    then a Cygwin shell behaves like a Windows console).
+--  * Cygwin xterm and rxvt windows
+--  * MSYS rxvt windows
+--
+-- In order for your application to receive console events, avoid running
+-- it in one of these environments.
+--
 installHandler :: Handler -> IO Handler
 installHandler handler = 
   alloca $ \ p_sp -> do
@@ -83,9 +110,23 @@ installHandler handler =
 
    toHandler hdlr ev = do
       case toConsoleEvent ev of
-        Just x  -> hdlr x
+        -- see rts/win32/ConsoleHandler.c for comments as to why
+        -- rts_ConsoleHandlerDone is called here.
+        Just x  -> hdlr x >> rts_ConsoleHandlerDone ev
        Nothing -> return () -- silently ignore..
 
-foreign import ccall unsafe "Signals.h stg_InstallConsoleEvent" 
+foreign import ccall unsafe "RtsExternal.h rts_InstallConsoleEvent" 
   rts_installHandler :: CInt -> Ptr (StablePtr (CInt -> IO ())) -> IO CInt
+foreign import ccall unsafe "RtsExternal.h rts_ConsoleHandlerDone"
+  rts_ConsoleHandlerDone :: CInt -> IO ()
+
+
+flushConsole :: Handle -> IO ()
+flushConsole h = 
+  wantReadableHandle "flushConsole" h $ \ h_ -> 
+     throwErrnoIfMinus1Retry_ "flushConsole"
+      (flush_console_fd (fromIntegral (haFD h_)))
+
+foreign import ccall unsafe "consUtils.h flush_input_console__"
+       flush_console_fd :: CInt -> IO CInt
 #endif /* mingw32_HOST_OS */