[project @ 2004-08-19 08:23:01 by simonmar]

[haskell-directory.git] / System / IO.hs

diff --git a/System/IO.hs b/System/IO.hs
index eee562c..aed2eb7 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 ()
@@ -143,13 +143,14 @@ module System.IO (
 
 #if !defined(__NHC__)
     openBinaryFile,           -- :: FilePath -> IOMode -> IO Handle
-#endif
-
-#if !defined(__HUGS__) && !defined(__NHC__)
     hSetBinaryMode,           -- :: Handle -> Bool -> IO ()
     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
 
     module System.IO.Error,
   ) where
@@ -169,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__
@@ -204,7 +208,7 @@ import IO
   , IO ()
   , FilePath                  -- :: String
   )
-import NHC.Internal (unsafePerformIO)
+import NHC.IOExtras (fixIO)
 #endif
 
 import System.IO.Error (
@@ -242,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
@@ -341,7 +345,7 @@ readIO s        =  case (do { (x,t) <- reads s ;
 #endif  /* __HUGS__ */
 
 -- | Computation 'hReady' @hdl@ indicates whether at least one item is
--- available for input from handle "hdl".
+-- available for input from handle @hdl@.
 -- 
 -- This operation may fail with:
 --
@@ -373,13 +377,18 @@ hPrint hdl        =  hPutStrLn hdl . show
 -- ---------------------------------------------------------------------------
 -- fixIO
 
-#ifdef __GLASGOW_HASKELL__
-fixIO          :: (a -> IO a) -> IO a
-fixIO m         = stToIO (fixST (ioToST . m))
-#endif
-#ifdef __NHC__
-fixIO           :: (a -> IO a) -> IO a
-fixIO f         = let x = unsafePerformIO (f x) in return x
+#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
 
 -- $locking