% -----------------------------------------------------------------------------
-% $Id: PrelIOBase.lhs,v 1.13 1999/09/19 19:12:41 sof Exp $
+% $Id: PrelIOBase.lhs,v 1.23 2000/04/14 15:28:24 rrt Exp $
%
% (c) The AQUA Project, Glasgow University, 1994-1998
%
\begin{code}
{-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-}
-#include "cbits/error.h"
+#include "cbits/stgerror.h"
+#include "config.h"
#ifndef __HUGS__ /* Hugs just includes this in PreludeBuiltin so no header needed */
module PrelIOBase where
import PrelST
import PrelBase
import {-# SOURCE #-} PrelException ( ioError )
-import PrelST ( ST(..), STret(..) )
import PrelMaybe ( Maybe(..) )
import PrelAddr ( Addr(..), nullAddr )
-import PrelPack ( unpackCString )
+import PrelPack ( unpackCString )
import PrelShow
#if !defined(__CONCURRENT_HASKELL__)
the real world. We use the exception mechanism (in PrelException) to
implement IO exceptions.
+NOTE: The IO representation is deeply wired in to various parts of the
+system. The following list may or may not be exhaustive:
+
+Compiler - types of various primitives in PrimOp.lhs
+
+RTS - forceIO (StgMiscClosures.hc)
+ - catchzh_fast, (un)?blockAsyncExceptionszh_fast, raisezh_fast
+ (Exceptions.hc)
+ - raiseAsync (Schedule.c)
+
+Prelude - PrelIOBase.lhs, and several other places including
+ PrelException.lhs.
+
+Libraries - parts of hslibs/lang.
+
+--SDM
+
\begin{code}
#ifndef __HUGS__
newtype IO a = IO (State# RealWorld -> (# State# RealWorld, a #))
{-# INLINE (>>) #-}
{-# INLINE (>>=) #-}
m >> k = m >>= \ _ -> k
- return x = IO $ \ s -> (# s, x #)
+ return x = returnIO x
m >>= k = bindIO m k
fail s = error s -- not ioError?
- -- not required but worth having around
-fixIO :: (a -> IO a) -> IO a
-fixIO m = stToIO (fixST (ioToST . m))
-
liftIO :: IO a -> State# RealWorld -> STret RealWorld a
liftIO (IO m) = \s -> case m s of (# s', r #) -> STret s' r
(# new_s, a #) -> unIO (k a) new_s
)
+returnIO :: a -> IO a
+returnIO x = IO (\ s -> (# s, x #))
#endif
\end{code}
String -- location
String -- error type specific information.
+instance Eq IOError where
+ (IOError h1 e1 loc1 str1) == (IOError h2 e2 loc2 str2) =
+ e1==e2 && str1==str2 && h1==h2 && loc1 == loc2
data IOErrorType
= AlreadyExists | HardwareFault
| TimeExpired | UnsatisfiedConstraints
| UnsupportedOperation | UserError
| EOF
-#ifdef _WIN32
+#if defined(cygwin32_TARGET_OS) || defined(mingw32_TARGET_OS)
| ComError Int -- HRESULT
#endif
deriving (Eq)
UserError -> "failed"
UnsupportedOperation -> "unsupported operation"
EOF -> "end of file"
-#ifdef _WIN32
+#if defined(cygwin32_TARGET_OS) || defined(mingw32_TARGET_OS)
ComError _ -> "COM error"
#endif
-}
data MVar a = MVar (MVar# RealWorld a)
+-- pull in Eq (Mvar a) too, to avoid PrelConc being an orphan-instance module
+instance Eq (MVar a) where
+ (MVar mvar1#) == (MVar mvar2#) = sameMVar# mvar1# mvar2#
+
{-
Double sigh - ForeignObj is needed here too to break a cycle.
-}
data ForeignObj = ForeignObj ForeignObj# -- another one
instance CCallable ForeignObj
-instance CCallable ForeignObj#
+
+eqForeignObj :: ForeignObj -> ForeignObj -> Bool
+eqForeignObj mp1 mp2
+ = unsafePerformIO (primEqForeignObj mp1 mp2) /= (0::Int)
+
+foreign import "eqForeignObj" unsafe primEqForeignObj :: ForeignObj -> ForeignObj -> IO Int
+
+instance Eq ForeignObj where
+ p == q = eqForeignObj p q
+ p /= q = not (eqForeignObj p q)
#endif /* ndef __HUGS__ */
#if defined(__CONCURRENT_HASKELL__)
newtype Handle = Handle (MutableVar RealWorld Handle__)
#endif
+instance Eq Handle where
+ (Handle h1) == (Handle h2) = h1 == h2
+
{-
A Handle is represented by (a reference to) a record
containing the state of the I/O port/device. We record
haFO__ :: FILE_OBJECT,
haType__ :: Handle__Type,
haBufferMode__ :: BufferMode,
- haFilePath__ :: FilePath
- }
+ haFilePath__ :: FilePath,
+ haBuffers__ :: [Addr]
+ }
{-
Internally, we classify handles as being one