% -----------------------------------------------------------------------------
-% $Id: PrelIOBase.lhs,v 1.6 1998/12/02 13:27:03 simonm Exp $
+% $Id: PrelIOBase.lhs,v 1.17 2000/01/30 10:11:32 simonmar 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"
#ifndef __HUGS__ /* Hugs just includes this in PreludeBuiltin so no header needed */
module PrelIOBase where
import PrelST
import PrelBase
-import {-# SOURCE #-} PrelException ( fail )
+import {-# SOURCE #-} PrelException ( ioError )
import PrelST ( ST(..), STret(..) )
import PrelMaybe ( Maybe(..) )
import PrelAddr ( Addr(..), nullAddr )
import PrelPack ( unpackCString )
+import PrelShow
+
+#if !defined(__CONCURRENT_HASKELL__)
import PrelArr ( MutableVar, readVar )
#endif
+#endif
#ifdef __HUGS__
-#define cat2(x,y) x/**/y
-#define CCALL(fun) cat2(prim_,fun)
#define __CONCURRENT_HASKELL__
#define stToIO id
#define unpackCString primUnpackString
-#else
-#define CCALL(fun) _ccall_ fun
-#define ref_freeStdFileObject (``&freeStdFileObject''::Addr)
#endif
#ifndef __PARALLEL_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 #))
+unIO :: IO a -> (State# RealWorld -> (# State# RealWorld, a #))
unIO (IO a) = a
instance Functor IO where
- map f x = x >>= (return . f)
+ fmap f x = x >>= (return . f)
instance Monad IO where
{-# INLINE return #-}
return x = IO $ \ s -> (# s, x #)
m >>= k = bindIO m k
-
- -- not required but worth having around
-fixIO :: (a -> IO a) -> IO a
-fixIO m = stToIO (fixST (ioToST . m))
+ fail s = error s -- not ioError?
liftIO :: IO a -> State# RealWorld -> STret RealWorld a
liftIO (IO m) = \s -> case m s of (# s', r #) -> STret s' r
\end{code}
%*********************************************************
-%* *
-\subsection{Utility functions}
-%* *
-%*********************************************************
-
-I'm not sure why this little function is here...
-
-\begin{code}
---fputs :: Addr{-FILE*-} -> String -> IO Bool
-
-userError :: String -> IOError
-userError str = IOError Nothing (UserError Nothing) "" str
-
-{-
-fputs stream (c : cs)
- = CCALL(filePutc) stream c >>
- fputs stream cs
--}
-\end{code}
-
-%*********************************************************
%* *
\subsection{Unsafe @IO@ operations}
%* *
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
| ResourceBusy | ResourceExhausted
| ResourceVanished | SystemError
| TimeExpired | UnsatisfiedConstraints
- | UnsupportedOperation | UserError (Maybe Addr)
+ | UnsupportedOperation | UserError
| EOF
+#ifdef _WIN32
+ | ComError Int -- HRESULT
+#endif
deriving (Eq)
instance Show IOErrorType where
- showsPrec d e =
+ showsPrec _ e =
showString $
case e of
AlreadyExists -> "already exists"
SystemError -> "system error"
TimeExpired -> "timeout"
UnsatisfiedConstraints -> "unsatisified constraints" -- ultra-precise!
- UserError _ -> "failed"
+ UserError -> "failed"
+ UnsupportedOperation -> "unsupported operation"
EOF -> "end of file"
+#ifdef _WIN32
+ ComError _ -> "COM error"
+#endif
+
+
+userError :: String -> IOError
+userError str = IOError Nothing UserError "" str
\end{code}
Predicates on IOError; little effort made on these so far...
\begin{code}
+isAlreadyExistsError :: IOError -> Bool
isAlreadyExistsError (IOError _ AlreadyExists _ _) = True
isAlreadyExistsError _ = False
+isAlreadyInUseError :: IOError -> Bool
isAlreadyInUseError (IOError _ ResourceBusy _ _) = True
isAlreadyInUseError _ = False
+isFullError :: IOError -> Bool
isFullError (IOError _ ResourceExhausted _ _) = True
isFullError _ = False
+isEOFError :: IOError -> Bool
isEOFError (IOError _ EOF _ _) = True
isEOFError _ = False
+isIllegalOperation :: IOError -> Bool
isIllegalOperation (IOError _ IllegalOperation _ _) = True
isIllegalOperation _ = False
+isPermissionError :: IOError -> Bool
isPermissionError (IOError _ PermissionDenied _ _) = True
isPermissionError _ = False
+isDoesNotExistError :: IOError -> Bool
isDoesNotExistError (IOError _ NoSuchThing _ _) = True
isDoesNotExistError _ = False
-isUserError (IOError _ (UserError _) _ _) = True
-isUserError _ = False
+isUserError :: IOError -> Bool
+isUserError (IOError _ UserError _ _) = True
+isUserError _ = False
\end{code}
Showing @IOError@s
constructErrorAndFail :: String -> IO a
constructErrorAndFail call_site
= constructError call_site >>= \ io_error ->
- fail io_error
+ ioError io_error
constructErrorAndFailWithInfo :: String -> String -> IO a
constructErrorAndFailWithInfo call_site reason
= constructErrorMsg call_site (Just reason) >>= \ io_error ->
- fail io_error
+ ioError io_error
\end{code}
constructErrorMsg :: String -> Maybe String -> IO IOError
constructErrorMsg call_site reason =
- CCALL(getErrType__) >>= \ errtype ->
- CCALL(getErrStr__) >>= \ str ->
+ getErrType__ >>= \ errtype ->
+ getErrStr__ >>= \ str ->
let
iot =
- case errtype of
+ case (errtype::Int) of
ERR_ALREADYEXISTS -> AlreadyExists
ERR_HARDWAREFAULT -> HardwareFault
ERR_ILLEGALOPERATION -> IllegalOperation
-}
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
BlockBuffering Nothing -> showString "block " . showParen True (showsPrec p def)
where
def :: Int
- def = unsafePerformIO (CCALL(getBufSize) fo)
+ def = unsafePerformIO (getBufSize fo)
mkBuffer__ :: FILE_OBJECT -> Int -> IO ()
mkBuffer__ fo sz_in_bytes = do
case sz_in_bytes of
0 -> return nullAddr -- this has the effect of overwriting the pointer to the old buffer.
_ -> do
- chunk <- CCALL(allocMemory__) sz_in_bytes
+ chunk <- allocMemory__ sz_in_bytes
if chunk == nullAddr
- then fail (IOError Nothing ResourceExhausted "mkBuffer__" "not enough virtual memory")
+ then ioError (IOError Nothing ResourceExhausted "mkBuffer__" "not enough virtual memory")
else return chunk
- CCALL(setBuf) fo chunk sz_in_bytes
+ setBuf fo chunk sz_in_bytes
\end{code}
{- Read instance defined in IO. -}
\end{code}
+
+Foreign import declarations to helper routines:
+
+\begin{code}
+foreign import "libHS_cbits" "getErrStr__" unsafe getErrStr__ :: IO Addr
+foreign import "libHS_cbits" "getErrNo__" unsafe getErrNo__ :: IO Int
+foreign import "libHS_cbits" "getErrType__" unsafe getErrType__ :: IO Int
+
+foreign import "libHS_cbits" "allocMemory__" unsafe
+ allocMemory__ :: Int -> IO Addr
+foreign import "libHS_cbits" "getBufSize" unsafe
+ getBufSize :: FILE_OBJECT -> IO Int
+foreign import "libHS_cbits" "setBuf" unsafe
+ setBuf :: FILE_OBJECT -> Addr -> Int -> IO ()
+
+\end{code}
projects / ghc-hetmet.git / blobdiff