which are supported for them.
\begin{code}
-{-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-}
+{-# OPTIONS -fcompiling-prelude -fno-implicit-prelude -#include "cbits/stgio.h" #-}
#include "cbits/stgerror.h"
#ifndef __HUGS__ /* Hugs just includes this in PreludeBuiltin so no header needed */
module PrelHandle where
+import PrelArr
import PrelBase
import PrelAddr ( Addr, nullAddr )
-import PrelArr ( newVar, readVar, writeVar )
import PrelByteArr ( ByteArray(..), MutableByteArray(..) )
import PrelRead ( Read )
import PrelList ( span )
#ifndef __PARALLEL_HASKELL__
import PrelWeak ( addForeignFinalizer )
#endif
-import Ix
-#ifdef __CONCURRENT_HASKELL__
import PrelConc
-#endif
#ifndef __PARALLEL_HASKELL__
import PrelForeign ( makeForeignObj )
\begin{code}
{-# INLINE newHandle #-}
-{-# INLINE withHandle #-}
newHandle :: Handle__ -> IO Handle
-#if defined(__CONCURRENT_HASKELL__)
-
-- Use MVars for concurrent Haskell
newHandle hc = newMVar hc >>= \ h ->
return (Handle h)
-#else
-
--- Use ordinary MutableVars for non-concurrent Haskell
-newHandle hc = stToIO (newVar hc >>= \ h ->
- return (Handle h))
-#endif
\end{code}
%*********************************************************
but we might want to revisit this in the future --SDM ].
\begin{code}
-#ifdef __CONCURRENT_HASKELL__
withHandle :: Handle -> (Handle__ -> IO (Handle__,a)) -> IO a
+{-# INLINE withHandle #-}
withHandle (Handle h) act = do
h_ <- takeMVar h
(h',v) <- catchException (act h_) (\ ex -> putMVar h h_ >> throw ex)
return v
withHandle_ :: Handle -> (Handle__ -> IO a) -> IO a
+{-# INLINE withHandle_ #-}
withHandle_ (Handle h) act = do
h_ <- takeMVar h
v <- catchException (act h_) (\ ex -> putMVar h h_ >> throw ex)
return v
withHandle__ :: Handle -> (Handle__ -> IO Handle__) -> IO ()
+{-# INLINE withHandle__ #-}
withHandle__ (Handle h) act = do
h_ <- takeMVar h
h' <- catchException (act h_) (\ ex -> putMVar h h_ >> throw ex)
putMVar h h'
return ()
-
-#else
- -- of questionable value to install this exception
- -- handler, but let's do it in the non-concurrent
- -- case too, for now.
-withHandle (Handle h) act = do
- h_ <- stToIO (readVar h)
- v <- catchException (act h_) (\ ex -> stToIO (writeVar h h_) >> throw ex)
- return v
-
-#endif
\end{code}
nullFile__ is only used for closed handles, plugging it in as a null
isWritable _ = False
-#ifndef __PARALLEL_HASKELL__
-getBMode__ :: ForeignObj -> IO (BufferMode, Int)
-#else
-getBMode__ :: Addr -> IO (BufferMode, Int)
-#endif
+getBMode__ :: FILE_OBJECT -> IO (BufferMode, Int)
getBMode__ fo = do
rc <- getBufferMode fo -- ConcHask: SAFE, won't block
case (rc::Int) of
wantRWHandle "hConnectTo" hW $ \ hW_ ->
wantRWHandle "hConnectTo" hR $ \ hR_ -> do
setConnectedTo (haFO__ hR_) (haFO__ hW_) is_tty -- ConcHask: SAFE, won't block
-
-#ifndef __PARALLEL_HASKELL__
-#define FILE_OBJECT ForeignObj
-#else
-#define FILE_OBJECT Addr
-#endif
-
\end{code}
As an extension, we also allow characters to be pushed back.
of IO:
\begin{code}
-#ifndef __PARALLEL_HASKELL__
-mayBlock :: ForeignObj -> IO Int -> IO Int
-#else
-mayBlock :: Addr -> IO Int -> IO Int
-#endif
-
+mayBlock :: FILE_OBJECT -> IO Int -> IO Int
mayBlock fo act = do
rc <- act
case rc of
| BlockWrite Int
| NoBlock Int
-mayBlockRead :: String -> Handle -> (ForeignObj -> IO Int) -> IO Int
+mayBlockRead :: String -> Handle -> (FILE_OBJECT -> IO Int) -> IO Int
mayBlockRead fname handle fn = do
r <- wantReadableHandle fname handle $ \ handle_ -> do
let fo = haFO__ handle_
mayBlockRead fname handle fn
NoBlock c -> return c
-mayBlockWrite :: String -> Handle -> (ForeignObj -> IO Int) -> IO Int
+mayBlockWrite :: String -> Handle -> (FILE_OBJECT -> IO Int) -> IO Int
mayBlockWrite fname handle fn = do
r <- wantWriteableHandle fname handle $ \ handle_ -> do
let fo = haFO__ handle_