[project @ 2000-05-18 12:42:20 by simonmar]

[ghc-hetmet.git] / ghc / lib / std / PrelHandle.lhs

diff --git a/ghc/lib/std/PrelHandle.lhs b/ghc/lib/std/PrelHandle.lhs
index caa59db..d3b1320 100644 (file)
--- a/ghc/lib/std/PrelHandle.lhs
+++ b/ghc/lib/std/PrelHandle.lhs
@@ -1108,10 +1108,10 @@ mayBlock fo act = do
      _ -> do
         return rc
 
-data MayBlock
+data MayBlock a
   = BlockRead Int
   | BlockWrite Int
-  | NoBlock Int
+  | NoBlock a
 
 mayBlockRead :: String -> Handle -> (FILE_OBJECT -> IO Int) -> IO Int
 mayBlockRead fname handle fn = do
@@ -1141,6 +1141,38 @@ mayBlockRead fname handle fn = do
           mayBlockRead fname handle fn
        NoBlock c -> return c
 
+mayBlockRead' :: String -> Handle
+       -> (FILE_OBJECT -> IO Int)
+       -> (FILE_OBJECT -> Int -> IO a)
+       -> IO a
+mayBlockRead' fname handle fn io = do
+    r <- wantReadableHandle fname handle $ \ handle_ -> do
+        let fo = haFO__ handle_
+         rc <- fn fo
+         case rc of
+           -5 -> do  -- (possibly blocking) read
+             fd <- getFileFd fo
+             return (BlockRead fd)
+          -6 -> do  -- (possibly blocking) write
+            fd <- getFileFd fo
+             return (BlockWrite fd)
+          -7 -> do  -- (possibly blocking) write on connected handle
+            fd <- getConnFileFd fo
+            return (BlockWrite fd)
+           _ ->
+             if rc >= 0
+                 then do a <- io fo rc 
+                         return (NoBlock a)
+                 else constructErrorAndFail fname
+    case r of
+       BlockRead fd -> do
+          threadWaitRead fd
+          mayBlockRead' fname handle fn io
+       BlockWrite fd -> do
+          threadWaitWrite fd
+          mayBlockRead' fname handle fn io
+       NoBlock c -> return c
+
 mayBlockWrite :: String -> Handle -> (FILE_OBJECT -> IO Int) -> IO Int
 mayBlockWrite fname handle fn = do
     r <- wantWriteableHandle fname handle $ \ handle_ -> do