Rewrite of the IO library, including Unicode support

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

diff --git a/GHC/ConsoleHandler.hs b/GHC/ConsoleHandler.hs
index 7587d94..af115b8 100644 (file)
--- a/GHC/ConsoleHandler.hs
+++ b/GHC/ConsoleHandler.hs
@@ -34,10 +34,13 @@ 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.Exception (onException)
+import Control.Concurrent.MVar
+import Data.Typeable
 
 data Handler
  = Default
@@ -134,19 +137,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 (fromIntegral (fdFD fd))
 
 foreign import ccall unsafe "consUtils.h flush_input_console__"
         flush_console_fd :: CInt -> IO CInt
 
--- XXX Copied from Control.Concurrent.MVar
-modifyMVar :: MVar a -> (a -> IO (a,b)) -> IO b
-modifyMVar m io =
-  block $ do
-    a      <- takeMVar m
-    (a',b) <- unblock (io a) `onException` putMVar m a
-    putMVar m a'
-    return b
 #endif /* mingw32_HOST_OS */