-{-# OPTIONS_GHC -cpp #-}
+{-# LANGUAGE CPP, ForeignFunctionInterface #-}
+
-----------------------------------------------------------------------------
-- |
-- Module : GHC.ConsoleHandler
module GHC.ConsoleHandler
#if !defined(mingw32_HOST_OS) && !defined(__HADDOCK__)
where
-import Prelude -- necessary to get dependencies right
#else /* whole file */
( Handler(..)
, installHandler
) where
{-
-#include "Signals.h"
+#include "rts/Signals.h"
-}
-import Prelude -- necessary to get dependencies right
-
import Foreign
import Foreign.C
-import GHC.IOBase
+import GHC.IO.FD
+import GHC.IO.Exception
+import GHC.IO.Handle.Types
+import GHC.IO.Handle.Internals
import GHC.Conc
-import GHC.Handle
+import Control.Concurrent.MVar
import Data.Typeable
-import Control.Concurrent
+
+#ifdef mingw32_HOST_OS
+import Data.Maybe
+import GHC.Base
+#endif
data Handler
= Default
STG_SIG_DFL -> return Default
STG_SIG_IGN -> return Ignore
STG_SIG_HAN -> return (Catch old_h)
+ _ -> error "installHandler: Bad threaded rc value"
return (new_h, prev_handler)
| otherwise =
-- stable pointer is no longer in use, free it.
freeStablePtr osptr
return (Catch (\ ev -> oldh (fromConsoleEvent ev)))
+ _ -> error "installHandler: Bad non-threaded rc value"
where
fromConsoleEvent ev =
case ev of
flushConsole :: Handle -> IO ()
flushConsole h =
- wantReadableHandle "flushConsole" h $ \ h_ ->
- throwErrnoIfMinus1Retry_ "flushConsole"
- (flush_console_fd (fromIntegral (haFD h_)))
+ wantReadableHandle_ "flushConsole" h $ \ Handle__{haDevice=dev} ->
+ case cast dev of
+ Nothing -> ioException $
+ IOError (Just h) IllegalOperation "flushConsole"
+ "handle is not a file descriptor" Nothing Nothing
+ Just fd -> do
+ throwErrnoIfMinus1Retry_ "flushConsole" $
+ flush_console_fd (fdFD fd)
foreign import ccall unsafe "consUtils.h flush_input_console__"
flush_console_fd :: CInt -> IO CInt
+
#endif /* mingw32_HOST_OS */