-----------------------------------------------------------------------------
-- |
-- 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
data Handler
= Default
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 */