ghc/lib/std/PrelIOBase.lhs

   1 % ------------------------------------------------------------------------------
   2 % $Id: PrelIOBase.lhs,v 1.42 2001/06/01 13:06:01 sewardj 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       haIsBin       :: Bool,
 157       haBufferMode  :: BufferMode,
 158       haFilePath    :: FilePath,
 159       haBuffer      :: !(IORef Buffer),
 160       haBuffers     :: !(IORef BufferList)
 161     }
 162
 163 -- ---------------------------------------------------------------------------
 164 -- Buffers
 165
 166 -- The buffer is represented by a mutable variable containing a
 167 -- record, where the record contains the raw buffer and the start/end
 168 -- points of the filled portion.  We use a mutable variable so that
 169 -- the common operation of writing (or reading) some data from (to)
 170 -- the buffer doesn't need to modify, and hence copy, the handle
 171 -- itself, it just updates the buffer.
 172
 173 -- There will be some allocation involved in a simple hPutChar in
 174 -- order to create the new Buffer structure (below), but this is
 175 -- relatively small, and this only has to be done once per write
 176 -- operation.
 177
 178 -- The buffer contains its size - we could also get the size by
 179 -- calling sizeOfMutableByteArray# on the raw buffer, but that tends
 180 -- to be rounded up to the nearest Word.
 181
 182 type RawBuffer = MutableByteArray# RealWorld
 183
 184 -- INVARIANTS on a Buffer:
 185 --
 186 --   * A handle *always* has a buffer, even if it is only 1 character long
 187 --     (an unbuffered handle needs a 1 character buffer in order to support
 188 --      hLookAhead and hIsEOF).
 189 --   * r <= w
 190 --   * if r == w, then r == 0 && w == 0
 191 --   * if state == WriteBuffer, then r == 0
 192 --   * a write buffer is never full.  If an operation
 193 --     fills up the buffer, it will always flush it before
 194 --     returning.
 195 --   * a read buffer may be full as a result of hLookAhead.  In normal
 196 --     operation, a read buffer always has at least one character of space.
 197
 198 data Buffer
 199   = Buffer {
 200         bufBuf   :: RawBuffer,
 201         bufRPtr  :: !Int,
 202         bufWPtr  :: !Int,
 203         bufSize  :: !Int,
 204         bufState :: BufferState
 205   }
 206
 207 data BufferState = ReadBuffer | WriteBuffer deriving (Eq)
 208
 209 -- we keep a few spare buffers around in a handle to avoid allocating
 210 -- a new one for each hPutStr.  These buffers are *guaranteed* to be the
 211 -- same size as the main buffer.
 212 data BufferList
 213   = BufferListNil
 214   | BufferListCons RawBuffer BufferList
 215
 216
 217 bufferIsWritable :: Buffer -> Bool
 218 bufferIsWritable Buffer{ bufState=WriteBuffer } = True
 219 bufferIsWritable _other = False
 220
 221 bufferEmpty :: Buffer -> Bool
 222 bufferEmpty Buffer{ bufRPtr=r, bufWPtr=w } = r == w
 223
 224 -- only makes sense for a write buffer
 225 bufferFull :: Buffer -> Bool
 226 bufferFull b@Buffer{ bufWPtr=w } = w >= bufSize b
 227
 228 --  Internally, we classify handles as being one
 229 --  of the following:
 230
 231 data HandleType
 232  = ClosedHandle
 233  | SemiClosedHandle
 234  | ReadHandle
 235  | WriteHandle
 236  | AppendHandle
 237  | ReadWriteHandle
 238  | ReadSideHandle  !(MVar Handle__)     -- read side of a duplex handle
 239
 240 isReadableHandleType ReadHandle         = True
 241 isReadableHandleType ReadWriteHandle    = True
 242 isReadableHandleType (ReadSideHandle _) = True
 243 isReadableHandleType _                  = False
 244
 245 isWritableHandleType AppendHandle    = True
 246 isWritableHandleType WriteHandle     = True
 247 isWritableHandleType ReadWriteHandle = True
 248 isWritableHandleType _               = False
 249
 250 -- File names are specified using @FilePath@, a OS-dependent
 251 -- string that (hopefully, I guess) maps to an accessible file/object.
 252
 253 type FilePath = String
 254
 255 -- ---------------------------------------------------------------------------
 256 -- Buffering modes
 257
 258 -- Three kinds of buffering are supported: line-buffering,
 259 -- block-buffering or no-buffering.  These modes have the following
 260 -- effects. For output, items are written out from the internal
 261 -- buffer according to the buffer mode:
 262 --
 263 -- * line-buffering  the entire output buffer is written
 264 --   out whenever a newline is output, the output buffer overflows,
 265 --   a flush is issued, or the handle is closed.
 266 --
 267 -- * block-buffering the entire output buffer is written out whenever
 268 --   it overflows, a flush is issued, or the handle
 269 --   is closed.
 270 --
 271 -- * no-buffering output is written immediately, and never stored
 272 --   in the output buffer.
 273 --
 274 -- The output buffer is emptied as soon as it has been written out.
 275
 276 -- Similarly, input occurs according to the buffer mode for handle {\em hdl}.
 277
 278 -- * line-buffering when the input buffer for the handle is not empty,
 279 --   the next item is obtained from the buffer;
 280 --   otherwise, when the input buffer is empty,
 281 --   characters up to and including the next newline
 282 --   character are read into the buffer.  No characters
 283 --   are available until the newline character is
 284 --   available.
 285 --
 286 -- * block-buffering when the input buffer for the handle becomes empty,
 287 --   the next block of data is read into this buffer.
 288 --
 289 -- * no-buffering the next input item is read and returned.
 290
 291 -- For most implementations, physical files will normally be block-buffered
 292 -- and terminals will normally be line-buffered. (the IO interface provides
 293 -- operations for changing the default buffering of a handle tho.)
 294
 295 data BufferMode
 296  = NoBuffering | LineBuffering | BlockBuffering (Maybe Int)
 297    deriving (Eq, Ord, Read, Show)
 298
 299 -- ---------------------------------------------------------------------------
 300 -- IORefs
 301
 302 newtype IORef a = IORef (STRef RealWorld a) deriving Eq
 303
 304 newIORef    :: a -> IO (IORef a)
 305 newIORef v = stToIO (newSTRef v) >>= \ var -> return (IORef var)
 306
 307 readIORef   :: IORef a -> IO a
 308 readIORef  (IORef var) = stToIO (readSTRef var)
 309
 310 writeIORef  :: IORef a -> a -> IO ()
 311 writeIORef (IORef var) v = stToIO (writeSTRef var v)
 312
 313 modifyIORef :: IORef a -> (a -> a) -> IO ()
 314 modifyIORef ref f = readIORef ref >>= \x -> writeIORef ref (f x)
 315
 316 -- deprecated, use modifyIORef
 317 updateIORef :: IORef a -> (a -> a) -> IO ()
 318 updateIORef = modifyIORef
 319
 320 -- ---------------------------------------------------------------------------
 321 -- Show instance for Handles
 322
 323 -- handle types are 'show'n when printing error msgs, so
 324 -- we provide a more user-friendly Show instance for it
 325 -- than the derived one.
 326
 327 instance Show HandleType where
 328   showsPrec p t =
 329     case t of
 330       ClosedHandle      -> showString "closed"
 331       SemiClosedHandle  -> showString "semi-closed"
 332       ReadHandle        -> showString "readable"
 333       WriteHandle       -> showString "writable"
 334       AppendHandle      -> showString "writable (append)"
 335       ReadWriteHandle   -> showString "read-writable"
 336       ReadSideHandle _  -> showString "read-writable (duplex)"
 337
 338 instance Show Handle where
 339   showsPrec p (FileHandle   h)   = showHandle p h
 340   showsPrec p (DuplexHandle h _) = showHandle p h
 341
 342 showHandle p h =
 343     let
 344      -- (Big) SIGH: unfolded defn of takeMVar to avoid
 345      -- an (oh-so) unfortunate module loop with PrelConc.
 346      hdl_ = unsafePerformIO (IO $ \ s# ->
 347              case h                 of { MVar h# ->
 348              case takeMVar# h# s#   of { (# s2# , r #) ->
 349              case putMVar# h# r s2# of { s3# ->
 350              (# s3#, r #) }}})
 351     in
 352     showChar '{' .
 353     showHdl (haType hdl_)
 354             (showString "loc=" . showString (haFilePath hdl_) . showChar ',' .
 355              showString "type=" . showsPrec p (haType hdl_) . showChar ',' .
 356              showString "binary=" . showsPrec p (haIsBin hdl_) . showChar ',' .
 357              showString "buffering=" . showBufMode (unsafePerformIO (readIORef (haBuffer hdl_))) (haBufferMode hdl_) . showString "}" )
 358    where
 359     showHdl :: HandleType -> ShowS -> ShowS
 360     showHdl ht cont =
 361        case ht of
 362         ClosedHandle  -> showsPrec p ht . showString "}"
 363         _ -> cont
 364
 365     showBufMode :: Buffer -> BufferMode -> ShowS
 366     showBufMode buf bmo =
 367       case bmo of
 368         NoBuffering   -> showString "none"
 369         LineBuffering -> showString "line"
 370         BlockBuffering (Just n) -> showString "block " . showParen True (showsPrec p n)
 371         BlockBuffering Nothing  -> showString "block " . showParen True (showsPrec p def)
 372       where
 373        def :: Int
 374        def = bufSize buf
 375
 376 -- ------------------------------------------------------------------------
 377 -- Exception datatype and operations
 378
 379 data Exception
 380   = IOException         IOException     -- IO exceptions
 381   | ArithException      ArithException  -- Arithmetic exceptions
 382   | ArrayException      ArrayException  -- Array-related exceptions
 383   | ErrorCall           String          -- Calls to 'error'
 384   | ExitException       ExitCode        -- Call to System.exitWith
 385   | NoMethodError       String          -- A non-existent method was invoked
 386   | PatternMatchFail    String          -- A pattern match / guard failure
 387   | RecSelError         String          -- Selecting a non-existent field
 388   | RecConError         String          -- Field missing in record construction
 389   | RecUpdError         String          -- Record doesn't contain updated field
 390   | AssertionFailed     String          -- Assertions
 391   | DynException        Dynamic         -- Dynamic exceptions
 392   | AsyncException      AsyncException  -- Externally generated errors
 393   | BlockedOnDeadMVar                   -- Blocking on a dead MVar
 394   | NonTermination
 395   | UserError           String
 396
 397 data ArithException
 398   = Overflow
 399   | Underflow
 400   | LossOfPrecision
 401   | DivideByZero
 402   | Denormal
 403   deriving (Eq, Ord)
 404
 405 data AsyncException
 406   = StackOverflow
 407   | HeapOverflow
 408   | ThreadKilled
 409   deriving (Eq, Ord)
 410
 411 data ArrayException
 412   = IndexOutOfBounds    String          -- out-of-range array access
 413   | UndefinedElement    String          -- evaluating an undefined element
 414   deriving (Eq, Ord)
 415
 416 stackOverflow, heapOverflow :: Exception -- for the RTS
 417 stackOverflow = AsyncException StackOverflow
 418 heapOverflow  = AsyncException HeapOverflow
 419
 420 instance Show ArithException where
 421   showsPrec _ Overflow        = showString "arithmetic overflow"
 422   showsPrec _ Underflow       = showString "arithmetic underflow"
 423   showsPrec _ LossOfPrecision = showString "loss of precision"
 424   showsPrec _ DivideByZero    = showString "divide by zero"
 425   showsPrec _ Denormal        = showString "denormal"
 426
 427 instance Show AsyncException where
 428   showsPrec _ StackOverflow   = showString "stack overflow"
 429   showsPrec _ HeapOverflow    = showString "heap overflow"
 430   showsPrec _ ThreadKilled    = showString "thread killed"
 431
 432 instance Show ArrayException where
 433   showsPrec _ (IndexOutOfBounds s)
 434         = showString "array index out of range"
 435         . (if not (null s) then showString ": " . showString s
 436                            else id)
 437   showsPrec _ (UndefinedElement s)
 438         = showString "undefined array element"
 439         . (if not (null s) then showString ": " . showString s
 440                            else id)
 441
 442 instance Show Exception where
 443   showsPrec _ (IOException err)          = shows err
 444   showsPrec _ (ArithException err)       = shows err
 445   showsPrec _ (ArrayException err)       = shows err
 446   showsPrec _ (ErrorCall err)            = showString err
 447   showsPrec _ (ExitException err)        = showString "exit: " . shows err
 448   showsPrec _ (NoMethodError err)        = showString err
 449   showsPrec _ (PatternMatchFail err)     = showString err
 450   showsPrec _ (RecSelError err)          = showString err
 451   showsPrec _ (RecConError err)          = showString err
 452   showsPrec _ (RecUpdError err)          = showString err
 453   showsPrec _ (AssertionFailed err)      = showString err
 454   showsPrec _ (DynException _err)        = showString "unknown exception"
 455   showsPrec _ (AsyncException e)         = shows e
 456   showsPrec _ (BlockedOnDeadMVar)        = showString "thread blocked indefinitely"
 457   showsPrec _ (NonTermination)           = showString "<<loop>>"
 458   showsPrec _ (UserError err)            = showString err
 459
 460 -- -----------------------------------------------------------------------------
 461 -- The ExitCode type
 462
 463 -- The `ExitCode' type defines the exit codes that a program
 464 -- can return.  `ExitSuccess' indicates successful termination;
 465 -- and `ExitFailure code' indicates program failure
 466 -- with value `code'.  The exact interpretation of `code'
 467 -- is operating-system dependent.  In particular, some values of
 468 -- `code' may be prohibited (e.g. 0 on a POSIX-compliant system).
 469
 470 -- We need it here because it is used in ExitException in the
 471 -- Exception datatype (above).
 472
 473 data ExitCode = ExitSuccess | ExitFailure Int
 474                 deriving (Eq, Ord, Read, Show)
 475
 476 -- --------------------------------------------------------------------------
 477 -- Primitive throw
 478
 479 throw :: Exception -> a
 480 throw exception = raise# exception
 481
 482 ioError         :: Exception -> IO a
 483 ioError err     =  IO $ \s -> throw err s
 484
 485 ioException     :: IOException -> IO a
 486 ioException err =  IO $ \s -> throw (IOException err) s
 487
 488 -- ---------------------------------------------------------------------------
 489 -- IOError type
 490
 491 -- A value @IOError@ encode errors occurred in the @IO@ monad.
 492 -- An @IOError@ records a more specific error type, a descriptive
 493 -- string and maybe the handle that was used when the error was
 494 -- flagged.
 495
 496 type IOError = Exception
 497
 498 data IOException
 499  = IOError
 500      (Maybe Handle)   -- the handle used by the action flagging the
 501                       --   the error.
 502      IOErrorType      -- what it was.
 503      String           -- location.
 504      String           -- error type specific information.
 505      (Maybe FilePath) -- filename the error is related to.
 506
 507 instance Eq IOException where
 508   (IOError h1 e1 loc1 str1 fn1) == (IOError h2 e2 loc2 str2 fn2) =
 509     e1==e2 && str1==str2 && h1==h2 && loc1==loc2 && fn1==fn2
 510
 511 data IOErrorType
 512   = AlreadyExists        | HardwareFault
 513   | IllegalOperation     | InappropriateType
 514   | Interrupted          | InvalidArgument
 515   | NoSuchThing          | OtherError
 516   | PermissionDenied     | ProtocolError
 517   | ResourceBusy         | ResourceExhausted
 518   | ResourceVanished     | SystemError
 519   | TimeExpired          | UnsatisfiedConstraints
 520   | UnsupportedOperation
 521   | EOF
 522 #if defined(cygwin32_TARGET_OS) || defined(mingw32_TARGET_OS)
 523   | ComError Int           -- HRESULT
 524 #endif
 525   deriving (Eq)
 526
 527 instance Show IOErrorType where
 528   showsPrec _ e =
 529     showString $
 530     case e of
 531       AlreadyExists     -> "already exists"
 532       HardwareFault     -> "hardware fault"
 533       IllegalOperation  -> "illegal operation"
 534       InappropriateType -> "inappropriate type"
 535       Interrupted       -> "interrupted"
 536       InvalidArgument   -> "invalid argument"
 537       NoSuchThing       -> "does not exist"
 538       OtherError        -> "failed"
 539       PermissionDenied  -> "permission denied"
 540       ProtocolError     -> "protocol error"
 541       ResourceBusy      -> "resource busy"
 542       ResourceExhausted -> "resource exhausted"
 543       ResourceVanished  -> "resource vanished"
 544       SystemError       -> "system error"
 545       TimeExpired       -> "timeout"
 546       UnsatisfiedConstraints -> "unsatisified constraints" -- ultra-precise!
 547       UnsupportedOperation -> "unsupported operation"
 548       EOF               -> "end of file"
 549 #if defined(cygwin32_TARGET_OS) || defined(mingw32_TARGET_OS)
 550       ComError _        -> "COM error"
 551 #endif
 552
 553
 554
 555 userError       :: String  -> IOError
 556 userError str   =  UserError str
 557
 558 -- ---------------------------------------------------------------------------
 559 -- Predicates on IOError
 560
 561 isAlreadyExistsError :: IOError -> Bool
 562 isAlreadyExistsError (IOException (IOError _ AlreadyExists _ _ _)) = True
 563 isAlreadyExistsError _                                             = False
 564
 565 isAlreadyInUseError :: IOError -> Bool
 566 isAlreadyInUseError (IOException (IOError _ ResourceBusy _ _ _)) = True
 567 isAlreadyInUseError _                                            = False
 568
 569 isFullError :: IOError -> Bool
 570 isFullError (IOException (IOError _ ResourceExhausted _ _ _)) = True
 571 isFullError _                                                 = False
 572
 573 isEOFError :: IOError -> Bool
 574 isEOFError (IOException (IOError _ EOF _ _ _)) = True
 575 isEOFError _                                   = False
 576
 577 isIllegalOperation :: IOError -> Bool
 578 isIllegalOperation (IOException (IOError _ IllegalOperation _ _ _)) = True
 579 isIllegalOperation _                                                = False
 580
 581 isPermissionError :: IOError -> Bool
 582 isPermissionError (IOException (IOError _ PermissionDenied _ _ _)) = True
 583 isPermissionError _                                                = False
 584
 585 isDoesNotExistError :: IOError -> Bool
 586 isDoesNotExistError (IOException (IOError _ NoSuchThing _ _ _)) = True
 587 isDoesNotExistError _                                           = False
 588
 589 isUserError :: IOError -> Bool
 590 isUserError (UserError _) = True
 591 isUserError _             = False
 592
 593 -- ---------------------------------------------------------------------------
 594 -- Showing IOErrors
 595
 596 instance Show IOException where
 597     showsPrec p (IOError hdl iot loc s fn) =
 598       showsPrec p iot .
 599       (case loc of
 600          "" -> id
 601          _  -> showString "\nAction: " . showString loc) .
 602       (case hdl of
 603         Nothing -> id
 604         Just h  -> showString "\nHandle: " . showsPrec p h) .
 605       (case s of
 606          "" -> id
 607          _  -> showString "\nReason: " . showString s) .
 608       (case fn of
 609          Nothing -> id
 610          Just name -> showString "\nFile: " . showString name)
 611 \end{code}