-% ------------------------------------------------------------------------------
-% $Id: IOBase.lhs,v 1.4 2001/09/13 15:34:17 simonmar Exp $
-%
-% (c) The University of Glasgow, 1994-2001
-%
-
-% Definitions for the @IO@ monad and its friends. Everything is exported
-% concretely; the @IO@ module itself exports abstractly.
-
\begin{code}
{-# OPTIONS -fno-implicit-prelude #-}
-#include "config.h"
+-----------------------------------------------------------------------------
+-- |
+-- Module : GHC.IOBase
+-- Copyright : (c) The University of Glasgow 1994-2002
+-- License : see libraries/base/LICENSE
+--
+-- Maintainer : cvs-ghc@haskell.org
+-- Stability : internal
+-- Portability : non-portable (GHC Extensions)
+--
+-- Definitions for the 'IO' monad and its friends.
+--
+-----------------------------------------------------------------------------
module GHC.IOBase where
import GHC.Show
import GHC.List
import GHC.Read
-import GHC.Dynamic
+import {-# SOURCE #-} Data.Dynamic
-- ---------------------------------------------------------------------------
-- The IO Monad
(# new_s, a #) -> unIO (k a) new_s
)
+thenIO :: IO a -> IO b -> IO b
+thenIO (IO m) k = IO ( \ s ->
+ case m s of
+ (# new_s, a #) -> unIO k new_s
+ )
+
returnIO :: a -> IO a
returnIO x = IO (\ s -> (# s, x #))
data Handle__
= Handle__ {
- haFD :: !FD,
- haType :: HandleType,
- haIsBin :: Bool,
- haBufferMode :: BufferMode,
- haFilePath :: FilePath,
- haBuffer :: !(IORef Buffer),
- haBuffers :: !(IORef BufferList)
+ haFD :: !FD, -- file descriptor
+ haType :: HandleType, -- type (read/write/append etc.)
+ haIsBin :: Bool, -- binary mode?
+ haIsStream :: Bool, -- is this a stream handle?
+ haBufferMode :: BufferMode, -- buffer contains read/write data?
+ haFilePath :: FilePath, -- file name, possibly
+ haBuffer :: !(IORef Buffer), -- the current buffer
+ haBuffers :: !(IORef BufferList), -- spare buffers
+ haOtherSide :: Maybe (MVar Handle__) -- ptr to the write side of a
+ -- duplex handle.
}
-- ---------------------------------------------------------------------------
| WriteHandle
| AppendHandle
| ReadWriteHandle
- | ReadSideHandle !(MVar Handle__) -- read side of a duplex handle
isReadableHandleType ReadHandle = True
isReadableHandleType ReadWriteHandle = True
-isReadableHandleType (ReadSideHandle _) = True
isReadableHandleType _ = False
isWritableHandleType AppendHandle = True
WriteHandle -> showString "writable"
AppendHandle -> showString "writable (append)"
ReadWriteHandle -> showString "read-writable"
- ReadSideHandle _ -> showString "read-writable (duplex)"
instance Show Handle where
- showsPrec p (FileHandle h) = showHandle p h
- showsPrec p (DuplexHandle h _) = showHandle p h
+ showsPrec p (FileHandle h) = showHandle p h False
+ showsPrec p (DuplexHandle _ h) = showHandle p h True
-showHandle p h =
+showHandle p h duplex =
let
-- (Big) SIGH: unfolded defn of takeMVar to avoid
-- an (oh-so) unfortunate module loop with GHC.Conc.
case takeMVar# h# s# of { (# s2# , r #) ->
case putMVar# h# r s2# of { s3# ->
(# s3#, r #) }}})
+
+ showType | duplex = showString "duplex (read-write)"
+ | otherwise = showsPrec p (haType hdl_)
in
showChar '{' .
showHdl (haType hdl_)
(showString "loc=" . showString (haFilePath hdl_) . showChar ',' .
- showString "type=" . showsPrec p (haType hdl_) . showChar ',' .
+ showString "type=" . showType . showChar ',' .
showString "binary=" . showsPrec p (haIsBin hdl_) . showChar ',' .
showString "buffering=" . showBufMode (unsafePerformIO (readIORef (haBuffer hdl_))) (haBufferMode hdl_) . showString "}" )
where
+
showHdl :: HandleType -> ShowS -> ShowS
showHdl ht cont =
case ht of
| DynException Dynamic -- Dynamic exceptions
| AsyncException AsyncException -- Externally generated errors
| BlockedOnDeadMVar -- Blocking on a dead MVar
+ | Deadlock -- no threads can run (raised in main thread)
| NonTermination
- | UserError String
data ArithException
= Overflow
showsPrec _ (AsyncException e) = shows e
showsPrec _ (BlockedOnDeadMVar) = showString "thread blocked indefinitely"
showsPrec _ (NonTermination) = showString "<<loop>>"
- showsPrec _ (UserError err) = showString err
+ showsPrec _ (Deadlock) = showString "<<deadlock>>"
+
+instance Eq Exception where
+ IOException e1 == IOException e2 = e1 == e2
+ ArithException e1 == ArithException e2 = e1 == e2
+ ArrayException e1 == ArrayException e2 = e1 == e2
+ ErrorCall e1 == ErrorCall e2 = e1 == e2
+ ExitException e1 == ExitException e2 = e1 == e2
+ NoMethodError e1 == NoMethodError e2 = e1 == e2
+ PatternMatchFail e1 == PatternMatchFail e2 = e1 == e2
+ RecSelError e1 == RecSelError e2 = e1 == e2
+ RecConError e1 == RecConError e2 = e1 == e2
+ RecUpdError e1 == RecUpdError e2 = e1 == e2
+ AssertionFailed e1 == AssertionFailed e2 = e1 == e2
+ DynException _ == DynException _ = False -- incomparable
+ AsyncException e1 == AsyncException e2 = e1 == e2
+ BlockedOnDeadMVar == BlockedOnDeadMVar = True
+ NonTermination == NonTermination = True
+ Deadlock == Deadlock = True
-- -----------------------------------------------------------------------------
-- The ExitCode type
type IOError = Exception
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 FilePath) -- filename the error is related to.
+ = IOError {
+ ioe_handle :: Maybe Handle, -- the handle used by the action flagging
+ -- the error.
+ ioe_type :: IOErrorType, -- what it was.
+ ioe_location :: String, -- location.
+ ioe_descr :: String, -- error type specific information.
+ ioe_filename :: Maybe FilePath -- filename the error is related to.
+ }
instance Eq IOException where
(IOError h1 e1 loc1 str1 fn1) == (IOError h2 e2 loc2 str2 fn2) =
data IOErrorType
-- Haskell 98:
= AlreadyExists
- | EOF
- | IllegalOperation
| NoSuchThing
- | PermissionDenied
| ResourceBusy
| ResourceExhausted
+ | EOF
+ | IllegalOperation
+ | PermissionDenied
+ | UserError
-- GHC only:
| UnsatisfiedConstraints
| SystemError
| TimeExpired
| ResourceVanished
| Interrupted
-#if defined(cygwin32_TARGET_OS) || defined(mingw32_TARGET_OS)
- | ComError Int -- HRESULT
-#endif
- deriving (Eq)
-
+ | DynIOError Dynamic -- cheap&cheerful extensible IO error type.
+
+instance Eq IOErrorType where
+ x == y =
+ case x of
+ DynIOError{} -> False -- from a strictness POV, compatible with a derived Eq inst?
+ _ -> getTag# x ==# getTag# y
+
instance Show IOErrorType where
showsPrec _ e =
showString $
case e of
AlreadyExists -> "already exists"
- HardwareFault -> "hardware fault"
+ NoSuchThing -> "does not exist"
+ ResourceBusy -> "resource busy"
+ ResourceExhausted -> "resource exhausted"
+ EOF -> "end of file"
IllegalOperation -> "illegal operation"
+ PermissionDenied -> "permission denied"
+ UserError -> "user error"
+ HardwareFault -> "hardware fault"
InappropriateType -> "inappropriate type"
Interrupted -> "interrupted"
InvalidArgument -> "invalid argument"
- NoSuchThing -> "does not exist"
OtherError -> "failed"
- PermissionDenied -> "permission denied"
ProtocolError -> "protocol error"
- ResourceBusy -> "resource busy"
- ResourceExhausted -> "resource exhausted"
ResourceVanished -> "resource vanished"
SystemError -> "system error"
TimeExpired -> "timeout"
UnsatisfiedConstraints -> "unsatisified constraints" -- ultra-precise!
UnsupportedOperation -> "unsupported operation"
- EOF -> "end of file"
-#if defined(cygwin32_TARGET_OS) || defined(mingw32_TARGET_OS)
- ComError _ -> "COM error"
-#endif
+ DynIOError{} -> "unknown IO error"
userError :: String -> IOError
-userError str = UserError str
-
--- ---------------------------------------------------------------------------
--- Predicates on IOError
-
-isAlreadyExistsError :: IOError -> Bool
-isAlreadyExistsError (IOException (IOError _ AlreadyExists _ _ _)) = True
-isAlreadyExistsError _ = False
-
-isAlreadyInUseError :: IOError -> Bool
-isAlreadyInUseError (IOException (IOError _ ResourceBusy _ _ _)) = True
-isAlreadyInUseError _ = False
-
-isFullError :: IOError -> Bool
-isFullError (IOException (IOError _ ResourceExhausted _ _ _)) = True
-isFullError _ = False
-
-isEOFError :: IOError -> Bool
-isEOFError (IOException (IOError _ EOF _ _ _)) = True
-isEOFError _ = False
-
-isIllegalOperation :: IOError -> Bool
-isIllegalOperation (IOException (IOError _ IllegalOperation _ _ _)) = True
-isIllegalOperation _ = False
-
-isPermissionError :: IOError -> Bool
-isPermissionError (IOException (IOError _ PermissionDenied _ _ _)) = True
-isPermissionError _ = False
-
-isDoesNotExistError :: IOError -> Bool
-isDoesNotExistError (IOException (IOError _ NoSuchThing _ _ _)) = True
-isDoesNotExistError _ = False
-
-isUserError :: IOError -> Bool
-isUserError (UserError _) = True
-isUserError _ = False
+userError str = IOException (IOError Nothing UserError "" str Nothing)
-- ---------------------------------------------------------------------------
-- Showing IOErrors
projects / ghc-base.git / blobdiff