-----------------------------------------------------------------------------
-- |
-- 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
{-
import Foreign
import Foreign.C
+import GHC.IOBase
+import GHC.Handle
+import Data.Typeable
data Handler
= Default
-- 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
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 */