Add tests from testsuite/tests/h98

[ghc-base.git] / GHC / ConsoleHandler.hs

diff --git a/GHC/ConsoleHandler.hs b/GHC/ConsoleHandler.hs
index 8cd5d5e..562ef32 100644 (file)
--- a/GHC/ConsoleHandler.hs
+++ b/GHC/ConsoleHandler.hs
@@ -1,4 +1,5 @@
-{-# OPTIONS_GHC -cpp #-}
+{-# LANGUAGE CPP, ForeignFunctionInterface #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  GHC.ConsoleHandler
@@ -18,7 +19,6 @@
 module GHC.ConsoleHandler
 #if !defined(mingw32_HOST_OS) && !defined(__HADDOCK__)
         where
-import Prelude -- necessary to get dependencies right
 #else /* whole file */
         ( Handler(..)
         , installHandler
@@ -27,18 +27,23 @@ import Prelude -- necessary to get dependencies right
         ) 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
@@ -84,6 +89,7 @@ installHandler handler
           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 =
@@ -105,6 +111,7 @@ installHandler handler
          -- 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
@@ -133,10 +140,16 @@ foreign import ccall unsafe "RtsExternal.h rts_ConsoleHandlerDone"
 
 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 */