ghc/lib/std/PrelIOBase.lhs

   1 % ------------------------------------------------------------------------------
   2 % $Id: PrelIOBase.lhs,v 1.40 2001/05/22 19:25:49 qrczak Exp $
   3 %
   4 % (c) The University of Glasgow, 1994-2001
   5 %
   6
   7 % Definitions for the @IO@ monad and its friends.  Everything is exported
   8 % concretely; the @IO@ module itself exports abstractly.
   9
  10 \begin{code}
  11 {-# OPTIONS -fno-implicit-prelude #-}
  12 #include "config.h"
  13
  14 module PrelIOBase where
  15
  16 import PrelST
  17 import PrelArr
  18 import PrelBase
  19 import PrelNum  -- To get fromInteger etc, needed because of -fno-implicit-prelude
  20 import PrelMaybe  ( Maybe(..) )
  21 import PrelShow
  22 import PrelList
  23 import PrelRead
  24 import PrelDynamic
  25
  26 -- ---------------------------------------------------------------------------
  27 -- The IO Monad
  28
  29 {-
  30 The IO Monad is just an instance of the ST monad, where the state is
  31 the real world.  We use the exception mechanism (in PrelException) to
  32 implement IO exceptions.
  33
  34 NOTE: The IO representation is deeply wired in to various parts of the
  35 system.  The following list may or may not be exhaustive:
  36
  37 Compiler  - types of various primitives in PrimOp.lhs
  38
  39 RTS       - forceIO (StgMiscClosures.hc)
  40           - catchzh_fast, (un)?blockAsyncExceptionszh_fast, raisezh_fast
  41             (Exceptions.hc)
  42           - raiseAsync (Schedule.c)
  43
  44 Prelude   - PrelIOBase.lhs, and several other places including
  45             PrelException.lhs.
  46
  47 Libraries - parts of hslibs/lang.
  48
  49 --SDM
  50 -}
  51
  52 newtype IO a = IO (State# RealWorld -> (# State# RealWorld, a #))
  53
  54 unIO :: IO a -> (State# RealWorld -> (# State# RealWorld, a #))
  55 unIO (IO a) = a
  56
  57 instance  Functor IO where
  58    fmap f x = x >>= (return . f)
  59
  60 instance  Monad IO  where
  61     {-# INLINE return #-}
  62     {-# INLINE (>>)   #-}
  63     {-# INLINE (>>=)  #-}
  64     m >> k      =  m >>= \ _ -> k
  65     return x    = returnIO x
  66
  67     m >>= k     = bindIO m k
  68     fail s      = failIO s
  69
  70 failIO :: String -> IO a
  71 failIO s = ioError (userError s)
  72
  73 liftIO :: IO a -> State# RealWorld -> STret RealWorld a
  74 liftIO (IO m) = \s -> case m s of (# s', r #) -> STret s' r
  75
  76 bindIO :: IO a -> (a -> IO b) -> IO b
  77 bindIO (IO m) k = IO ( \ s ->
  78   case m s of
  79     (# new_s, a #) -> unIO (k a) new_s
  80   )
  81
  82 returnIO :: a -> IO a
  83 returnIO x = IO (\ s -> (# s, x #))
  84
  85 -- ---------------------------------------------------------------------------
  86 -- Coercions between IO and ST
  87
  88 --stToIO        :: (forall s. ST s a) -> IO a
  89 stToIO        :: ST RealWorld a -> IO a
  90 stToIO (ST m) = IO m
  91
  92 ioToST        :: IO a -> ST RealWorld a
  93 ioToST (IO m) = (ST m)
  94
  95 -- ---------------------------------------------------------------------------
  96 -- Unsafe IO operations
  97
  98 {-# NOINLINE unsafePerformIO #-}
  99 unsafePerformIO :: IO a -> a
 100 unsafePerformIO (IO m) = case m realWorld# of (# _, r #)   -> r
 101
 102 {-# NOINLINE unsafeInterleaveIO #-}
 103 unsafeInterleaveIO :: IO a -> IO a
 104 unsafeInterleaveIO (IO m)
 105   = IO ( \ s -> let
 106                    r = case m s of (# _, res #) -> res
 107                 in
 108                 (# s, r #))
 109
 110 -- ---------------------------------------------------------------------------
 111 -- Handle type
 112
 113 data MVar a = MVar (MVar# RealWorld a)
 114
 115 -- pull in Eq (Mvar a) too, to avoid PrelConc being an orphan-instance module
 116 instance Eq (MVar a) where
 117         (MVar mvar1#) == (MVar mvar2#) = sameMVar# mvar1# mvar2#
 118
 119 --  A Handle is represented by (a reference to) a record
 120 --  containing the state of the I/O port/device. We record
 121 --  the following pieces of info:
 122
 123 --    * type (read,write,closed etc.)
 124 --    * the underlying file descriptor
 125 --    * buffering mode
 126 --    * buffer, and spare buffers
 127 --    * user-friendly name (usually the
 128 --      FilePath used when IO.openFile was called)
 129
 130 -- Note: when a Handle is garbage collected, we want to flush its buffer
 131 -- and close the OS file handle, so as to free up a (precious) resource.
 132
 133 data Handle
 134   = FileHandle                          -- A normal handle to a file
 135         !(MVar Handle__)
 136
 137   | DuplexHandle                        -- A handle to a read/write stream
 138         !(MVar Handle__)                -- The read side
 139         !(MVar Handle__)                -- The write side
 140
 141 -- NOTES:
 142 --    * A 'FileHandle' is seekable.  A 'DuplexHandle' may or may not be
 143 --      seekable.
 144
 145 instance Eq Handle where
 146  (FileHandle h1)     == (FileHandle h2)     = h1 == h2
 147  (DuplexHandle h1 _) == (DuplexHandle h2 _) = h1 == h2
 148  _ == _ = False
 149
 150 type FD = Int -- XXX ToDo: should be CInt
 151
 152 data Handle__
 153   = Handle__ {
 154       haFD          :: !FD,
 155       haType        :: HandleType,
 156       haBufferMode  :: BufferMode,
 157       haFilePath    :: FilePath,
 158       haBuffer      :: !(IORef Buffer),
 159       haBuffers     :: !(IORef BufferList)
 160     }
 161
 162 -- ---------------------------------------------------------------------------
 163 -- Buffers
 164
 165 -- The buffer is represented by a mutable variable containing a
 166 -- record, where the record contains the raw buffer and the start/end
 167 -- points of the filled portion.  We use a mutable variable so that
 168 -- the common operation of writing (or reading) some data from (to)
 169 -- the buffer doesn't need to modify, and hence copy, the handle
 170 -- itself, it just updates the buffer.
 171
 172 -- There will be some allocation involved in a simple hPutChar in
 173 -- order to create the new Buffer structure (below), but this is
 174 -- relatively small, and this only has to be done once per write
 175 -- operation.
 176
 177 -- The buffer contains its size - we could also get the size by
 178 -- calling sizeOfMutableByteArray# on the raw buffer, but that tends
 179 -- to be rounded up to the nearest Word.
 180
 181 type RawBuffer = MutableByteArray# RealWorld
 182
 183 -- INVARIANTS on a Buffer:
 184 --
 185 --   * A handle *always* has a buffer, even if it is only 1 character long
 186 --     (an unbuffered handle needs a 1 character buffer in order to support
 187 --      hLookAhead and hIsEOF).
 188 --   * r <= w
 189 --   * if r == w, then r == 0 && w == 0
 190 --   * if state == WriteBuffer, then r == 0
 191 --   * a write buffer is never full.  If an operation
 192 --     fills up the buffer, it will always flush it before
 193 --     returning.
 194 --   * a read buffer may be full as a result of hLookAhead.  In normal
 195 --     operation, a read buffer always has at least one character of space.
 196
 197 data Buffer
 198   = Buffer {
 199         bufBuf   :: RawBuffer,
 200         bufRPtr  :: !Int,
 201         bufWPtr  :: !Int,
 202         bufSize  :: !Int,
 203         bufState :: BufferState
 204   }
 205
 206 data BufferState = ReadBuffer | WriteBuffer deriving (Eq)
 207
 208 -- we keep a few spare buffers around in a handle to avoid allocating
 209 -- a new one for each hPutStr.  These buffers are *guaranteed* to be the
 210 -- same size as the main buffer.
 211 data BufferList
 212   = BufferListNil
 213   | BufferListCons RawBuffer BufferList
 214
 215
 216 bufferIsWritable :: Buffer -> Bool
 217 bufferIsWritable Buffer{ bufState=WriteBuffer } = True
 218 bufferIsWritable _other = False
 219
 220 bufferEmpty :: Buffer -> Bool
 221 bufferEmpty Buffer{ bufRPtr=r, bufWPtr=w } = r == w
 222
 223 -- only makes sense for a write buffer
 224 bufferFull :: Buffer -> Bool
 225 bufferFull b@Buffer{ bufWPtr=w } = w >= bufSize b
 226
 227 --  Internally, we classify handles as being one
 228 --  of the following:
 229
 230 data HandleType
 231  = ClosedHandle
 232  | SemiClosedHandle
 233  | ReadHandle
 234  | WriteHandle
 235  | AppendHandle
 236  | ReadWriteHandle
 237  | ReadSideHandle  !(MVar Handle__)     -- read side of a duplex handle
 238
 239 -- File names are specified using @FilePath@, a OS-dependent
 240 -- string that (hopefully, I guess) maps to an accessible file/object.
 241
 242 type FilePath = String
 243
 244 -- ---------------------------------------------------------------------------
 245 -- Buffering modes
 246
 247 -- Three kinds of buffering are supported: line-buffering,
 248 -- block-buffering or no-buffering.  These modes have the following
 249 -- effects. For output, items are written out from the internal
 250 -- buffer according to the buffer mode:
 251 --
 252 -- * line-buffering  the entire output buffer is written
 253 --   out whenever a newline is output, the output buffer overflows,
 254 --   a flush is issued, or the handle is closed.
 255 --
 256 -- * block-buffering the entire output buffer is written out whenever
 257 --   it overflows, a flush is issued, or the handle
 258 --   is closed.
 259 --
 260 -- * no-buffering output is written immediately, and never stored
 261 --   in the output buffer.
 262 --
 263 -- The output buffer is emptied as soon as it has been written out.
 264
 265 -- Similarly, input occurs according to the buffer mode for handle {\em hdl}.
 266
 267 -- * line-buffering when the input buffer for the handle is not empty,
 268 --   the next item is obtained from the buffer;
 269 --   otherwise, when the input buffer is empty,
 270 --   characters up to and including the next newline
 271 --   character are read into the buffer.  No characters
 272 --   are available until the newline character is
 273 --   available.
 274 --
 275 -- * block-buffering when the input buffer for the handle becomes empty,
 276 --   the next block of data is read into this buffer.
 277 --
 278 -- * no-buffering the next input item is read and returned.
 279
 280 -- For most implementations, physical files will normally be block-buffered
 281 -- and terminals will normally be line-buffered. (the IO interface provides
 282 -- operations for changing the default buffering of a handle tho.)
 283
 284 data BufferMode
 285  = NoBuffering | LineBuffering | BlockBuffering (Maybe Int)
 286    deriving (Eq, Ord, Read, Show)
 287
 288 -- ---------------------------------------------------------------------------
 289 -- IORefs
 290
 291 newtype IORef a = IORef (STRef RealWorld a) deriving Eq
 292
 293 newIORef    :: a -> IO (IORef a)
 294 newIORef v = stToIO (newSTRef v) >>= \ var -> return (IORef var)
 295
 296 readIORef   :: IORef a -> IO a
 297 readIORef  (IORef var) = stToIO (readSTRef var)
 298
 299 writeIORef  :: IORef a -> a -> IO ()
 300 writeIORef (IORef var) v = stToIO (writeSTRef var v)
 301
 302 modifyIORef :: IORef a -> (a -> a) -> IO ()
 303 modifyIORef ref f = readIORef ref >>= \x -> writeIORef ref (f x)
 304
 305 -- deprecated, use modifyIORef
 306 updateIORef :: IORef a -> (a -> a) -> IO ()
 307 updateIORef = modifyIORef
 308
 309 -- ---------------------------------------------------------------------------
 310 -- Show instance for Handles
 311
 312 -- handle types are 'show'n when printing error msgs, so
 313 -- we provide a more user-friendly Show instance for it
 314 -- than the derived one.
 315
 316 instance Show HandleType where
 317   showsPrec p t =
 318     case t of
 319       ClosedHandle      -> showString "closed"
 320       SemiClosedHandle  -> showString "semi-closed"
 321       ReadHandle        -> showString "readable"
 322       WriteHandle       -> showString "writable"
 323       AppendHandle      -> showString "writable (append)"
 324       ReadWriteHandle   -> showString "read-writable"
 325       ReadSideHandle _  -> showString "read-writable (duplex)"
 326
 327 instance Show Handle where
 328   showsPrec p (FileHandle   h)   = showHandle p h
 329   showsPrec p (DuplexHandle h _) = showHandle p h
 330
 331 showHandle p h =
 332     let
 333      -- (Big) SIGH: unfolded defn of takeMVar to avoid
 334      -- an (oh-so) unfortunate module loop with PrelConc.
 335      hdl_ = unsafePerformIO (IO $ \ s# ->
 336              case h                 of { MVar h# ->
 337              case takeMVar# h# s#   of { (# s2# , r #) ->
 338              case putMVar# h# r s2# of { s3# ->
 339              (# s3#, r #) }}})
 340     in
 341     showChar '{' .
 342     showHdl (haType hdl_)
 343             (showString "loc=" . showString (haFilePath hdl_) . showChar ',' .
 344              showString "type=" . showsPrec p (haType hdl_) . showChar ',' .
 345              showString "buffering=" . showBufMode (unsafePerformIO (readIORef (haBuffer hdl_))) (haBufferMode hdl_) . showString "}" )
 346    where
 347     showHdl :: HandleType -> ShowS -> ShowS
 348     showHdl ht cont =
 349        case ht of
 350         ClosedHandle  -> showsPrec p ht . showString "}"
 351         _ -> cont
 352
 353     showBufMode :: Buffer -> BufferMode -> ShowS
 354     showBufMode buf bmo =
 355       case bmo of
 356         NoBuffering   -> showString "none"
 357         LineBuffering -> showString "line"
 358         BlockBuffering (Just n) -> showString "block " . showParen True (showsPrec p n)
 359         BlockBuffering Nothing  -> showString "block " . showParen True (showsPrec p def)
 360       where
 361        def :: Int
 362        def = bufSize buf
 363
 364 -- ------------------------------------------------------------------------
 365 -- Exception datatype and operations
 366
 367 data Exception
 368   = IOException         IOException     -- IO exceptions
 369   | ArithException      ArithException  -- Arithmetic exceptions
 370   | ArrayException      ArrayException  -- Array-related exceptions
 371   | ErrorCall           String          -- Calls to 'error'
 372   | ExitException       ExitCode        -- Call to System.exitWith
 373   | NoMethodError       String          -- A non-existent method was invoked
 374   | PatternMatchFail    String          -- A pattern match / guard failure
 375   | RecSelError         String          -- Selecting a non-existent field
 376   | RecConError         String          -- Field missing in record construction
 377   | RecUpdError         String          -- Record doesn't contain updated field
 378   | AssertionFailed     String          -- Assertions
 379   | DynException        Dynamic         -- Dynamic exceptions
 380   | AsyncException      AsyncException  -- Externally generated errors
 381   | BlockedOnDeadMVar                   -- Blocking on a dead MVar
 382   | NonTermination
 383   | UserError           String
 384
 385 data ArithException
 386   = Overflow
 387   | Underflow
 388   | LossOfPrecision
 389   | DivideByZero
 390   | Denormal
 391   deriving (Eq, Ord)
 392
 393 data AsyncException
 394   = StackOverflow
 395   | HeapOverflow
 396   | ThreadKilled
 397   deriving (Eq, Ord)
 398
 399 data ArrayException
 400   = IndexOutOfBounds    String          -- out-of-range array access
 401   | UndefinedElement    String          -- evaluating an undefined element
 402   deriving (Eq, Ord)
 403
 404 stackOverflow, heapOverflow :: Exception -- for the RTS
 405 stackOverflow = AsyncException StackOverflow
 406 heapOverflow  = AsyncException HeapOverflow
 407
 408 instance Show ArithException where
 409   showsPrec _ Overflow        = showString "arithmetic overflow"
 410   showsPrec _ Underflow       = showString "arithmetic underflow"
 411   showsPrec _ LossOfPrecision = showString "loss of precision"
 412   showsPrec _ DivideByZero    = showString "divide by zero"
 413   showsPrec _ Denormal        = showString "denormal"
 414
 415 instance Show AsyncException where
 416   showsPrec _ StackOverflow   = showString "stack overflow"
 417   showsPrec _ HeapOverflow    = showString "heap overflow"
 418   showsPrec _ ThreadKilled    = showString "thread killed"
 419
 420 instance Show ArrayException where
 421   showsPrec _ (IndexOutOfBounds s)
 422         = showString "array index out of range"
 423         . (if not (null s) then showString ": " . showString s
 424                            else id)
 425   showsPrec _ (UndefinedElement s)
 426         = showString "undefined array element"
 427         . (if not (null s) then showString ": " . showString s
 428                            else id)
 429
 430 instance Show Exception where
 431   showsPrec _ (IOException err)          = shows err
 432   showsPrec _ (ArithException err)       = shows err
 433   showsPrec _ (ArrayException err)       = shows err
 434   showsPrec _ (ErrorCall err)            = showString err
 435   showsPrec _ (ExitException err)        = showString "exit: " . shows err
 436   showsPrec _ (NoMethodError err)        = showString err
 437   showsPrec _ (PatternMatchFail err)     = showString err
 438   showsPrec _ (RecSelError err)          = showString err
 439   showsPrec _ (RecConError err)          = showString err
 440   showsPrec _ (RecUpdError err)          = showString err
 441   showsPrec _ (AssertionFailed err)      = showString err
 442   showsPrec _ (DynException _err)        = showString "unknown exception"
 443   showsPrec _ (AsyncException e)         = shows e
 444   showsPrec _ (BlockedOnDeadMVar)        = showString "thread blocked indefinitely"
 445   showsPrec _ (NonTermination)           = showString "<<loop>>"
 446   showsPrec _ (UserError err)            = showString err
 447
 448 -- -----------------------------------------------------------------------------
 449 -- The ExitCode type
 450
 451 -- The `ExitCode' type defines the exit codes that a program
 452 -- can return.  `ExitSuccess' indicates successful termination;
 453 -- and `ExitFailure code' indicates program failure
 454 -- with value `code'.  The exact interpretation of `code'
 455 -- is operating-system dependent.  In particular, some values of
 456 -- `code' may be prohibited (e.g. 0 on a POSIX-compliant system).
 457
 458 -- We need it here because it is used in ExitException in the
 459 -- Exception datatype (above).
 460
 461 data ExitCode = ExitSuccess | ExitFailure Int
 462                 deriving (Eq, Ord, Read, Show)
 463
 464 -- --------------------------------------------------------------------------
 465 -- Primitive throw
 466
 467 throw :: Exception -> a
 468 throw exception = raise# exception
 469
 470 ioError         :: Exception -> IO a
 471 ioError err     =  IO $ \s -> throw err s
 472
 473 ioException     :: IOException -> IO a
 474 ioException err =  IO $ \s -> throw (IOException err) s
 475
 476 -- ---------------------------------------------------------------------------
 477 -- IOError type
 478
 479 -- A value @IOError@ encode errors occurred in the @IO@ monad.
 480 -- An @IOError@ records a more specific error type, a descriptive
 481 -- string and maybe the handle that was used when the error was
 482 -- flagged.
 483
 484 type IOError = Exception
 485
 486 data IOException
 487  = IOError
 488      (Maybe Handle)   -- the handle used by the action flagging the
 489                       --   the error.
 490      IOErrorType      -- what it was.
 491      String           -- location.
 492      String           -- error type specific information.
 493      (Maybe FilePath) -- filename the error is related to.
 494
 495 instance Eq IOException where
 496   (IOError h1 e1 loc1 str1 fn1) == (IOError h2 e2 loc2 str2 fn2) =
 497     e1==e2 && str1==str2 && h1==h2 && loc1==loc2 && fn1==fn2
 498
 499 data IOErrorType
 500   = AlreadyExists        | HardwareFault
 501   | IllegalOperation     | InappropriateType
 502   | Interrupted          | InvalidArgument
 503   | NoSuchThing          | OtherError
 504   | PermissionDenied     | ProtocolError
 505   | ResourceBusy         | ResourceExhausted
 506   | ResourceVanished     | SystemError
 507   | TimeExpired          | UnsatisfiedConstraints
 508   | UnsupportedOperation
 509   | EOF
 510 #if defined(cygwin32_TARGET_OS) || defined(mingw32_TARGET_OS)
 511   | ComError Int           -- HRESULT
 512 #endif
 513   deriving (Eq)
 514
 515 instance Show IOErrorType where
 516   showsPrec _ e =
 517     showString $
 518     case e of
 519       AlreadyExists     -> "already exists"
 520       HardwareFault     -> "hardware fault"
 521       IllegalOperation  -> "illegal operation"
 522       InappropriateType -> "inappropriate type"
 523       Interrupted       -> "interrupted"
 524       InvalidArgument   -> "invalid argument"
 525       NoSuchThing       -> "does not exist"
 526       OtherError        -> "failed"
 527       PermissionDenied  -> "permission denied"
 528       ProtocolError     -> "protocol error"
 529       ResourceBusy      -> "resource busy"
 530       ResourceExhausted -> "resource exhausted"
 531       ResourceVanished  -> "resource vanished"
 532       SystemError       -> "system error"
 533       TimeExpired       -> "timeout"
 534       UnsatisfiedConstraints -> "unsatisified constraints" -- ultra-precise!
 535       UnsupportedOperation -> "unsupported operation"
 536       EOF               -> "end of file"
 537 #if defined(cygwin32_TARGET_OS) || defined(mingw32_TARGET_OS)
 538       ComError _        -> "COM error"
 539 #endif
 540
 541
 542
 543 userError       :: String  -> IOError
 544 userError str   =  UserError str
 545
 546 -- ---------------------------------------------------------------------------
 547 -- Predicates on IOError
 548
 549 isAlreadyExistsError :: IOError -> Bool
 550 isAlreadyExistsError (IOException (IOError _ AlreadyExists _ _ _)) = True
 551 isAlreadyExistsError _                                             = False
 552
 553 isAlreadyInUseError :: IOError -> Bool
 554 isAlreadyInUseError (IOException (IOError _ ResourceBusy _ _ _)) = True
 555 isAlreadyInUseError _                                            = False
 556
 557 isFullError :: IOError -> Bool
 558 isFullError (IOException (IOError _ ResourceExhausted _ _ _)) = True
 559 isFullError _                                                 = False
 560
 561 isEOFError :: IOError -> Bool
 562 isEOFError (IOException (IOError _ EOF _ _ _)) = True
 563 isEOFError _                                   = False
 564
 565 isIllegalOperation :: IOError -> Bool
 566 isIllegalOperation (IOException (IOError _ IllegalOperation _ _ _)) = True
 567 isIllegalOperation _                                                = False
 568
 569 isPermissionError :: IOError -> Bool
 570 isPermissionError (IOException (IOError _ PermissionDenied _ _ _)) = True
 571 isPermissionError _                                                = False
 572
 573 isDoesNotExistError :: IOError -> Bool
 574 isDoesNotExistError (IOException (IOError _ NoSuchThing _ _ _)) = True
 575 isDoesNotExistError _                                           = False
 576
 577 isUserError :: IOError -> Bool
 578 isUserError (UserError _) = True
 579 isUserError _             = False
 580
 581 -- ---------------------------------------------------------------------------
 582 -- Showing IOErrors
 583
 584 instance Show IOException where
 585     showsPrec p (IOError hdl iot loc s fn) =
 586       showsPrec p iot .
 587       (case loc of
 588          "" -> id
 589          _  -> showString "\nAction: " . showString loc) .
 590       (case hdl of
 591         Nothing -> id
 592         Just h  -> showString "\nHandle: " . showsPrec p h) .
 593       (case s of
 594          "" -> id
 595          _  -> showString "\nReason: " . showString s) .
 596       (case fn of
 597          Nothing -> id
 598          Just name -> showString "\nFile: " . showString name)
 599 \end{code}