% ------------------------------------------------------------------------------
-% $Id: PrelIOBase.lhs,v 1.38 2001/05/18 16:54:05 simonmar Exp $
+% $Id: PrelIOBase.lhs,v 1.47 2002/01/29 17:12:53 simonmar Exp $
%
% (c) The University of Glasgow, 1994-2001
%
\begin{code}
{-# OPTIONS -fno-implicit-prelude #-}
-#include "config.h"
-
module PrelIOBase where
import PrelST
import PrelMaybe ( Maybe(..) )
import PrelShow
import PrelList
+import PrelRead
import PrelDynamic
-- ---------------------------------------------------------------------------
data Handle__
= Handle__ {
- haFD :: !FD,
- haType :: HandleType,
- 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.
}
-- ---------------------------------------------------------------------------
bufferIsWritable _other = False
bufferEmpty :: Buffer -> Bool
-bufferEmpty Buffer{ bufRPtr=r, bufWPtr=w } | r == w = True
-bufferEmpty _other = False
+bufferEmpty Buffer{ bufRPtr=r, bufWPtr=w } = r == w
-- only makes sense for a write buffer
bufferFull :: Buffer -> Bool
| WriteHandle
| AppendHandle
| ReadWriteHandle
- | ReadSideHandle !(MVar Handle__) -- read side of a duplex handle
+
+isReadableHandleType ReadHandle = True
+isReadableHandleType ReadWriteHandle = True
+isReadableHandleType _ = False
+
+isWritableHandleType AppendHandle = True
+isWritableHandleType WriteHandle = True
+isWritableHandleType ReadWriteHandle = True
+isWritableHandleType _ = False
-- File names are specified using @FilePath@, a OS-dependent
-- string that (hopefully, I guess) maps to an accessible file/object.
data BufferMode
= NoBuffering | LineBuffering | BlockBuffering (Maybe Int)
- deriving (Eq, Ord, Show)
- {- Read instance defined in IO. -}
+ deriving (Eq, Ord, Read, Show)
-- ---------------------------------------------------------------------------
-- IORefs
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 PrelConc.
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
| ArithException ArithException -- Arithmetic exceptions
| ArrayException ArrayException -- Array-related exceptions
| ErrorCall String -- Calls to 'error'
+ | ExitException ExitCode -- Call to System.exitWith
| NoMethodError String -- A non-existent method was invoked
| PatternMatchFail String -- A pattern match / guard failure
| RecSelError String -- Selecting a non-existent field
| DynException Dynamic -- Dynamic exceptions
| AsyncException AsyncException -- Externally generated errors
| BlockedOnDeadMVar -- Blocking on a dead MVar
- | NonTermination
+ | NonTermination -- Cyclic data dependency or other loop
+ | Deadlock -- no threads can run (raised in main thread)
| UserError String
data ArithException
showsPrec _ (ArithException err) = shows err
showsPrec _ (ArrayException err) = shows err
showsPrec _ (ErrorCall err) = showString err
+ showsPrec _ (ExitException err) = showString "exit: " . shows err
showsPrec _ (NoMethodError err) = showString err
showsPrec _ (PatternMatchFail err) = showString err
showsPrec _ (RecSelError err) = showString err
showsPrec _ (AsyncException e) = shows e
showsPrec _ (BlockedOnDeadMVar) = showString "thread blocked indefinitely"
showsPrec _ (NonTermination) = showString "<<loop>>"
+ showsPrec _ (Deadlock) = showString "<<deadlock>>"
showsPrec _ (UserError err) = showString err
+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
+ UserError e1 == UserError e2 = e1 == e2
+
+-- -----------------------------------------------------------------------------
+-- The ExitCode type
+
+-- The `ExitCode' type defines the exit codes that a program
+-- can return. `ExitSuccess' indicates successful termination;
+-- and `ExitFailure code' indicates program failure
+-- with value `code'. The exact interpretation of `code'
+-- is operating-system dependent. In particular, some values of
+-- `code' may be prohibited (e.g. 0 on a POSIX-compliant system).
+
+-- We need it here because it is used in ExitException in the
+-- Exception datatype (above).
+
+data ExitCode = ExitSuccess | ExitFailure Int
+ deriving (Eq, Ord, Read, Show)
+
-- --------------------------------------------------------------------------
-- Primitive throw
| TimeExpired | UnsatisfiedConstraints
| UnsupportedOperation
| EOF
-#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 =
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
projects / ghc-hetmet.git / blobdiff