% ------------------------------------------------------------------------------
-% $Id: PrelIOBase.lhs,v 1.30 2001/01/10 16:28:15 qrczak Exp $
+% $Id: PrelIOBase.lhs,v 1.35 2001/02/22 13:17:58 simonpj Exp $
%
% (c) The University of Glasgow, 1994-2000
%
import PrelST
import PrelBase
-import PrelNum ( fromInteger ) -- Integer literals
+import PrelNum -- To get fromInteger etc, needed because of -fno-implicit-prelude
import PrelMaybe ( Maybe(..) )
-import PrelAddr ( Addr(..), nullAddr )
import PrelShow
import PrelList
import PrelDynamic
+import PrelPtr
import PrelPack ( unpackCString )
#if !defined(__CONCURRENT_HASKELL__)
#endif
#ifndef __PARALLEL_HASKELL__
-#define FILE_OBJECT ForeignObj
+#define FILE_OBJECT (ForeignPtr ())
#else
-#define FILE_OBJECT Addr
+#define FILE_OBJECT (Ptr ())
+
#endif
\end{code}
#ifdef __HUGS__
/* Hugs doesn't distinguish these types so no coercion required) */
#else
+-- stToIO :: (forall s. ST s a) -> IO a
stToIO :: ST RealWorld a -> IO a
-stToIO (ST m) = (IO m)
+stToIO (ST m) = IO m
ioToST :: IO a -> ST RealWorld a
ioToST (IO m) = (ST m)
unsafePerformIO :: IO a -> a
unsafePerformIO (IO m) = case m realWorld# of (# _, r #) -> r
+{-# NOINLINE unsafeInterleaveIO #-}
unsafeInterleaveIO :: IO a -> IO a
-unsafeInterleaveIO = stToIO . unsafeInterleaveST . ioToST
+unsafeInterleaveIO (IO m)
+ = IO ( \ s -> let
+ r = case m s of (# _, res #) -> res
+ in
+ (# s, r #))
#endif
\end{code}
(MVar mvar1#) == (MVar mvar2#) = sameMVar# mvar1# mvar2#
{-
- Double sigh - ForeignObj is needed here too to break a cycle.
+ Double sigh - ForeignPtr is needed here too to break a cycle.
-}
-data ForeignObj = ForeignObj ForeignObj# -- another one
-instance CCallable ForeignObj
+data ForeignPtr a = ForeignPtr ForeignObj#
+instance CCallable (ForeignPtr a)
-eqForeignObj :: ForeignObj -> ForeignObj -> Bool
-eqForeignObj mp1 mp2
- = unsafePerformIO (primEqForeignObj mp1 mp2) /= (0::Int)
+eqForeignPtr :: ForeignPtr a -> ForeignPtr a -> Bool
+eqForeignPtr mp1 mp2
+ = unsafePerformIO (primEqForeignPtr mp1 mp2) /= (0::Int)
-foreign import "eqForeignObj" unsafe primEqForeignObj :: ForeignObj -> ForeignObj -> IO Int
+foreign import "eqForeignObj" unsafe
+ primEqForeignPtr :: ForeignPtr a -> ForeignPtr a -> IO Int
-instance Eq ForeignObj where
- p == q = eqForeignObj p q
- p /= q = not (eqForeignObj p q)
+instance Eq (ForeignPtr a) where
+ p == q = eqForeignPtr p q
+ p /= q = not (eqForeignPtr p q)
#endif /* ndef __HUGS__ */
#if defined(__CONCURRENT_HASKELL__)
haType__ :: Handle__Type,
haBufferMode__ :: BufferMode,
haFilePath__ :: FilePath,
- haBuffers__ :: [Addr]
+ haBuffers__ :: [Ptr ()]
}
{-
-- (Big) SIGH: unfolded defn of takeMVar to avoid
-- an (oh-so) unfortunate module loop with PrelConc.
hdl_ = unsafePerformIO (IO $ \ s# ->
- case h of { MVar h# ->
- case takeMVar# h# s# of { (# s2# , r #) ->
- (# s2#, r #) }})
+ case h of { MVar h# ->
+ case takeMVar# h# s# of { (# s2# , r #) ->
+ case putMVar# h# r s2# of { s3# ->
+ (# s3#, r #) }}})
#endif
#else
hdl_ = unsafePerformIO (stToIO (readVar h))
Foreign import declarations to helper routines:
\begin{code}
-foreign import "libHS_cbits" "getErrStr__" unsafe getErrStr__ :: IO Addr
+foreign import "libHS_cbits" "getErrStr__" unsafe getErrStr__ :: IO (Ptr ())
foreign import "libHS_cbits" "getErrNo__" unsafe getErrNo__ :: IO Int
foreign import "libHS_cbits" "getErrType__" unsafe getErrType__ :: IO Int
-malloc :: Int -> IO Addr
+-- ToDo: use mallocBytes from PrelMarshal?
+malloc :: Int -> IO (Ptr ())
malloc sz = do
a <- _malloc sz
- if (a == nullAddr)
- then ioException (IOError Nothing ResourceExhausted "malloc" "")
+ if (a == nullPtr)
+ then ioException (IOError Nothing ResourceExhausted
+ "malloc" "out of memory" Nothing)
else return a
-foreign import "malloc" unsafe _malloc :: Int -> IO Addr
+foreign import "malloc" unsafe _malloc :: Int -> IO (Ptr ())
foreign import "libHS_cbits" "getBufSize" unsafe
getBufSize :: FILE_OBJECT -> IO Int
foreign import "libHS_cbits" "setBuf" unsafe
- setBuf :: FILE_OBJECT -> Addr -> Int -> IO ()
+ setBuf :: FILE_OBJECT -> Ptr () -> Int -> IO ()
\end{code}
data IOException
= IOError
- (Maybe Handle) -- the handle used by the action flagging the
- -- the error.
- IOErrorType -- what it was.
- String -- location
- String -- error type specific information.
+ (Maybe Handle) -- the handle used by the action flagging the
+ -- the error.
+ IOErrorType -- what it was.
+ String -- location.
+ String -- error type specific information.
+ (Maybe FilePath) -- filename the error is related to.
instance Eq IOException where
- (IOError h1 e1 loc1 str1) == (IOError h2 e2 loc2 str2) =
- e1==e2 && str1==str2 && h1==h2 && loc1 == loc2
+ (IOError h1 e1 loc1 str1 fn1) == (IOError h2 e2 loc2 str2 fn2) =
+ e1==e2 && str1==str2 && h1==h2 && loc1==loc2 && fn1==fn2
data IOErrorType
= AlreadyExists | HardwareFault
\begin{code}
isAlreadyExistsError :: IOError -> Bool
-isAlreadyExistsError (IOException (IOError _ AlreadyExists _ _)) = True
-isAlreadyExistsError _ = False
+isAlreadyExistsError (IOException (IOError _ AlreadyExists _ _ _)) = True
+isAlreadyExistsError _ = False
isAlreadyInUseError :: IOError -> Bool
-isAlreadyInUseError (IOException (IOError _ ResourceBusy _ _)) = True
-isAlreadyInUseError _ = False
+isAlreadyInUseError (IOException (IOError _ ResourceBusy _ _ _)) = True
+isAlreadyInUseError _ = False
isFullError :: IOError -> Bool
-isFullError (IOException (IOError _ ResourceExhausted _ _)) = True
-isFullError _ = False
+isFullError (IOException (IOError _ ResourceExhausted _ _ _)) = True
+isFullError _ = False
isEOFError :: IOError -> Bool
-isEOFError (IOException (IOError _ EOF _ _)) = True
-isEOFError _ = False
+isEOFError (IOException (IOError _ EOF _ _ _)) = True
+isEOFError _ = False
isIllegalOperation :: IOError -> Bool
-isIllegalOperation (IOException (IOError _ IllegalOperation _ _)) = True
-isIllegalOperation _ = False
+isIllegalOperation (IOException (IOError _ IllegalOperation _ _ _)) = True
+isIllegalOperation _ = False
isPermissionError :: IOError -> Bool
-isPermissionError (IOException (IOError _ PermissionDenied _ _)) = True
-isPermissionError _ = False
+isPermissionError (IOException (IOError _ PermissionDenied _ _ _)) = True
+isPermissionError _ = False
isDoesNotExistError :: IOError -> Bool
-isDoesNotExistError (IOException (IOError _ NoSuchThing _ _)) = True
-isDoesNotExistError _ = False
+isDoesNotExistError (IOException (IOError _ NoSuchThing _ _ _)) = True
+isDoesNotExistError _ = False
isUserError :: IOError -> Bool
isUserError (UserError _) = True
-isUserError _ = False
+isUserError _ = False
\end{code}
Showing @IOError@s
-- For now we give a fairly uninformative error message which just happens to
-- be like the ones that Hugs used to give.
instance Show IOException where
- showsPrec p (IOError hdl iot loc s) = showString s . showChar '\n'
+ showsPrec p (IOError _ _ _ s _) = showString s . showChar '\n'
#else
instance Show IOException where
- showsPrec p (IOError hdl iot loc s) =
+ showsPrec p (IOError hdl iot loc s fn) =
showsPrec p iot .
- showChar '\n' .
(case loc of
"" -> id
- _ -> showString "Action: " . showString loc . showChar '\n') .
+ _ -> showString "\nAction: " . showString loc) .
showHdl .
(case s of
"" -> id
- _ -> showString "Reason: " . showString s)
+ _ -> showString "\nReason: " . showString s) .
+ (case fn of
+ Nothing -> id
+ Just name -> showString "\nFile: " . showString name)
where
showHdl =
case hdl of
Nothing -> id
- Just h -> showString "Handle: " . showsPrec p h
+ Just h -> showString "\nHandle: " . showsPrec p h
#endif
\end{code}
ioError (IOException io_error)
constructErrorAndFailWithInfo :: String -> String -> IO a
-constructErrorAndFailWithInfo call_site reason
- = constructErrorMsg call_site (Just reason) >>= \ io_error ->
+constructErrorAndFailWithInfo call_site fn
+ = constructErrorMsg call_site (Just fn) >>= \ io_error ->
ioError (IOException io_error)
\end{code}
constructError call_site = constructErrorMsg call_site Nothing
constructErrorMsg :: String -> Maybe String -> IO IOException
-constructErrorMsg call_site reason =
+constructErrorMsg call_site fn =
getErrType__ >>= \ errtype ->
getErrStr__ >>= \ str ->
let
unpackCString str ++
(case iot of
OtherError -> "(error code: " ++ show errtype ++ ")"
- _ -> "") ++
- (case reason of
- Nothing -> ""
- Just m -> ": "++m)
+ _ -> "")
in
- return (IOError Nothing iot call_site msg)
+ return (IOError Nothing iot call_site msg fn)
\end{code}
projects / ghc-hetmet.git / blobdiff