[project @ 2004-11-06 13:01:18 by panne]

[ghc-base.git] / System / IO.hs

diff --git a/System/IO.hs b/System/IO.hs
index 23e7428..9b5d456 100644 (file)
--- a/System/IO.hs
+++ b/System/IO.hs
@@ -6,7 +6,7 @@
 -- License     :  BSD-style (see the file libraries/base/LICENSE)
 -- 
 -- Maintainer  :  libraries@haskell.org
--- Stability   :  provisional
+-- Stability   :  stable
 -- Portability :  portable
 --
 -- The standard IO library.
@@ -93,7 +93,7 @@ module System.IO (
 
     -- ** Terminal operations
 
-#if !defined(__HUGS__) && !defined(__NHC__)
+#if !defined(__NHC__)
     hIsTerminalDevice,         -- :: Handle -> IO Bool
 
     hSetEcho,                  -- :: Handle -> Bool -> IO ()
@@ -141,14 +141,13 @@ module System.IO (
 
     -- * Binary input and output
 
-#if !defined(__NHC__)
     openBinaryFile,           -- :: FilePath -> IOMode -> IO Handle
-#endif
-
-#if !defined(__HUGS__) && !defined(__NHC__)
     hSetBinaryMode,           -- :: Handle -> Bool -> IO ()
+#if !defined(__NHC__)
     hPutBuf,                  -- :: Handle -> Ptr a -> Int -> IO ()
     hGetBuf,                  -- :: Handle -> Ptr a -> Int -> IO Int
+#endif
+#if !defined(__NHC__) && !defined(__HUGS__)
     hPutBufNonBlocking,               -- :: Handle -> Ptr a -> Int -> IO Int
     hGetBufNonBlocking,               -- :: Handle -> Ptr a -> Int -> IO Int
 #endif
@@ -171,6 +170,9 @@ import GHC.Show
 #ifdef __HUGS__
 import Hugs.IO
 import Hugs.IOExts
+import Hugs.IORef
+import Hugs.Prelude    ( throw, Exception(NonTermination) )
+import System.IO.Unsafe        ( unsafeInterleaveIO )
 #endif
 
 #ifdef __NHC__
@@ -244,7 +246,7 @@ putChar c       =  hPutChar stdout c
 putStr          :: String -> IO ()
 putStr s        =  hPutStr stdout s
 
--- | The same as 'putStrLn', but adds a newline character.
+-- | The same as 'putStr', but adds a newline character.
 
 putStrLn        :: String -> IO ()
 putStrLn s      =  do putStr s
@@ -375,9 +377,24 @@ hPrint hdl         =  hPutStrLn hdl . show
 -- ---------------------------------------------------------------------------
 -- fixIO
 
-#ifdef __GLASGOW_HASKELL__
-fixIO          :: (a -> IO a) -> IO a
-fixIO m         = stToIO (fixST (ioToST . m))
+#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)
+fixIO :: (a -> IO a) -> IO a
+fixIO k = do
+    ref <- newIORef (throw NonTermination)
+    ans <- unsafeInterleaveIO (readIORef ref)
+    result <- k ans
+    writeIORef ref result
+    return result
+
+-- NOTE: we do our own explicit black holing here, because GHC's lazy
+-- blackholing isn't enough.  In an infinite loop, GHC may run the IO
+-- computation a few times before it notices the loop, which is wrong.
+#endif
+
+#if defined(__NHC__)
+-- Assume a unix platform, where text and binary I/O are identical.
+openBinaryFile = openFile
+hSetBinaryMode _ _ = return ()
 #endif
 
 -- $locking