ghc/lib/std/PrelIOBase.lhs

   1 % ------------------------------------------------------------------------------
   2 % $Id: PrelIOBase.lhs,v 1.38 2001/05/18 16:54:05 simonmar 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 PrelDynamic
  24
  25 -- ---------------------------------------------------------------------------
  26 -- The IO Monad
  27
  28 {-
  29 The IO Monad is just an instance of the ST monad, where the state is
  30 the real world.  We use the exception mechanism (in PrelException) to
  31 implement IO exceptions.
  32
  33 NOTE: The IO representation is deeply wired in to various parts of the
  34 system.  The following list may or may not be exhaustive:
  35
  36 Compiler  - types of various primitives in PrimOp.lhs
  37
  38 RTS       - forceIO (StgMiscClosures.hc)
  39           - catchzh_fast, (un)?blockAsyncExceptionszh_fast, raisezh_fast
  40             (Exceptions.hc)
  41           - raiseAsync (Schedule.c)
  42
  43 Prelude   - PrelIOBase.lhs, and several other places including
  44             PrelException.lhs.
  45
  46 Libraries - parts of hslibs/lang.
  47
  48 --SDM
  49 -}
  50
  51 newtype IO a = IO (State# RealWorld -> (# State# RealWorld, a #))
  52
  53 unIO :: IO a -> (State# RealWorld -> (# State# RealWorld, a #))
  54 unIO (IO a) = a
  55
  56 instance  Functor IO where
  57    fmap f x = x >>= (return . f)
  58
  59 instance  Monad IO  where
  60     {-# INLINE return #-}
  61     {-# INLINE (>>)   #-}
  62     {-# INLINE (>>=)  #-}
  63     m >> k      =  m >>= \ _ -> k
  64     return x    = returnIO x
  65
  66     m >>= k     = bindIO m k
  67     fail s      = failIO s
  68
  69 failIO :: String -> IO a
  70 failIO s = ioError (userError s)
  71
  72 liftIO :: IO a -> State# RealWorld -> STret RealWorld a
  73 liftIO (IO m) = \s -> case m s of (# s', r #) -> STret s' r
  74
  75 bindIO :: IO a -> (a -> IO b) -> IO b
  76 bindIO (IO m) k = IO ( \ s ->
  77   case m s of
  78     (# new_s, a #) -> unIO (k a) new_s
  79   )
  80
  81 returnIO :: a -> IO a
  82 returnIO x = IO (\ s -> (# s, x #))
  83
  84 -- ---------------------------------------------------------------------------
  85 -- Coercions between IO and ST
  86
  87 --stToIO        :: (forall s. ST s a) -> IO a
  88 stToIO        :: ST RealWorld a -> IO a
  89 stToIO (ST m) = IO m
  90
  91 ioToST        :: IO a -> ST RealWorld a
  92 ioToST (IO m) = (ST m)
  93
  94 -- ---------------------------------------------------------------------------
  95 -- Unsafe IO operations
  96
  97 {-# NOINLINE unsafePerformIO #-}
  98 unsafePerformIO :: IO a -> a
  99 unsafePerformIO (IO m) = case m realWorld# of (# _, r #)   -> r
 100
 101 {-# NOINLINE unsafeInterleaveIO #-}
 102 unsafeInterleaveIO :: IO a -> IO a
 103 unsafeInterleaveIO (IO m)
 104   = IO ( \ s -> let
 105                    r = case m s of (# _, res #) -> res
 106                 in
 107                 (# s, r #))
 108
 109 -- ---------------------------------------------------------------------------
 110 -- Handle type
 111
 112 data MVar a = MVar (MVar# RealWorld a)
 113
 114 -- pull in Eq (Mvar a) too, to avoid PrelConc being an orphan-instance module
 115 instance Eq (MVar a) where
 116         (MVar mvar1#) == (MVar mvar2#) = sameMVar# mvar1# mvar2#
 117
 118 --  A Handle is represented by (a reference to) a record
 119 --  containing the state of the I/O port/device. We record
 120 --  the following pieces of info:
 121
 122 --    * type (read,write,closed etc.)
 123 --    * the underlying file descriptor
 124 --    * buffering mode
 125 --    * buffer, and spare buffers
 126 --    * user-friendly name (usually the
 127 --      FilePath used when IO.openFile was called)
 128
 129 -- Note: when a Handle is garbage collected, we want to flush its buffer
 130 -- and close the OS file handle, so as to free up a (precious) resource.
 131
 132 data Handle
 133   = FileHandle                          -- A normal handle to a file
 134         !(MVar Handle__)
 135
 136   | DuplexHandle                        -- A handle to a read/write stream
 137         !(MVar Handle__)                -- The read side
 138         !(MVar Handle__)                -- The write side
 139
 140 -- NOTES:
 141 --    * A 'FileHandle' is seekable.  A 'DuplexHandle' may or may not be
 142 --      seekable.
 143
 144 instance Eq Handle where
 145  (FileHandle h1)     == (FileHandle h2)     = h1 == h2
 146  (DuplexHandle h1 _) == (DuplexHandle h2 _) = h1 == h2
 147  _ == _ = False
 148
 149 type FD = Int -- XXX ToDo: should be CInt
 150
 151 data Handle__
 152   = Handle__ {
 153       haFD          :: !FD,
 154       haType        :: HandleType,
 155       haBufferMode  :: BufferMode,
 156       haFilePath    :: FilePath,
 157       haBuffer      :: !(IORef Buffer),
 158       haBuffers     :: !(IORef BufferList)
 159     }
 160
 161 -- ---------------------------------------------------------------------------
 162 -- Buffers
 163
 164 -- The buffer is represented by a mutable variable containing a
 165 -- record, where the record contains the raw buffer and the start/end
 166 -- points of the filled portion.  We use a mutable variable so that
 167 -- the common operation of writing (or reading) some data from (to)
 168 -- the buffer doesn't need to modify, and hence copy, the handle
 169 -- itself, it just updates the buffer.
 170
 171 -- There will be some allocation involved in a simple hPutChar in
 172 -- order to create the new Buffer structure (below), but this is
 173 -- relatively small, and this only has to be done once per write
 174 -- operation.
 175
 176 -- The buffer contains its size - we could also get the size by
 177 -- calling sizeOfMutableByteArray# on the raw buffer, but that tends
 178 -- to be rounded up to the nearest Word.
 179
 180 type RawBuffer = MutableByteArray# RealWorld
 181
 182 -- INVARIANTS on a Buffer:
 183 --
 184 --   * A handle *always* has a buffer, even if it is only 1 character long
 185 --     (an unbuffered handle needs a 1 character buffer in order to support
 186 --      hLookAhead and hIsEOF).
 187 --   * r <= w
 188 --   * if r == w, then r == 0 && w == 0
 189 --   * if state == WriteBuffer, then r == 0
 190 --   * a write buffer is never full.  If an operation
 191 --     fills up the buffer, it will always flush it before
 192 --     returning.
 193 --   * a read buffer may be full as a result of hLookAhead.  In normal
 194 --     operation, a read buffer always has at least one character of space.
 195
 196 data Buffer
 197   = Buffer {
 198         bufBuf   :: RawBuffer,
 199         bufRPtr  :: !Int,
 200         bufWPtr  :: !Int,
 201         bufSize  :: !Int,
 202         bufState :: BufferState
 203   }
 204
 205 data BufferState = ReadBuffer | WriteBuffer deriving (Eq)
 206
 207 -- we keep a few spare buffers around in a handle to avoid allocating
 208 -- a new one for each hPutStr.  These buffers are *guaranteed* to be the
 209 -- same size as the main buffer.
 210 data BufferList
 211   = BufferListNil
 212   | BufferListCons RawBuffer BufferList
 213
 214
 215 bufferIsWritable :: Buffer -> Bool
 216 bufferIsWritable Buffer{ bufState=WriteBuffer } = True
 217 bufferIsWritable _other = False
 218
 219 bufferEmpty :: Buffer -> Bool
 220 bufferEmpty Buffer{ bufRPtr=r, bufWPtr=w } | r == w = True
 221 bufferEmpty _other = False
 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, Show)
 287    {- Read instance defined in IO. -}
 288
 289 -- ---------------------------------------------------------------------------
 290 -- IORefs
 291
 292 newtype IORef a = IORef (STRef RealWorld a) deriving Eq
 293
 294 newIORef    :: a -> IO (IORef a)
 295 newIORef v = stToIO (newSTRef v) >>= \ var -> return (IORef var)
 296
 297 readIORef   :: IORef a -> IO a
 298 readIORef  (IORef var) = stToIO (readSTRef var)
 299
 300 writeIORef  :: IORef a -> a -> IO ()
 301 writeIORef (IORef var) v = stToIO (writeSTRef var v)
 302
 303 modifyIORef :: IORef a -> (a -> a) -> IO ()
 304 modifyIORef ref f = readIORef ref >>= \x -> writeIORef ref (f x)
 305
 306 -- deprecated, use modifyIORef
 307 updateIORef :: IORef a -> (a -> a) -> IO ()
 308 updateIORef = modifyIORef
 309
 310 -- ---------------------------------------------------------------------------
 311 -- Show instance for Handles
 312
 313 -- handle types are 'show'n when printing error msgs, so
 314 -- we provide a more user-friendly Show instance for it
 315 -- than the derived one.
 316
 317 instance Show HandleType where
 318   showsPrec p t =
 319     case t of
 320       ClosedHandle      -> showString "closed"
 321       SemiClosedHandle  -> showString "semi-closed"
 322       ReadHandle        -> showString "readable"
 323       WriteHandle       -> showString "writable"
 324       AppendHandle      -> showString "writable (append)"
 325       ReadWriteHandle   -> showString "read-writable"
 326       ReadSideHandle _  -> showString "read-writable (duplex)"
 327
 328 instance Show Handle where
 329   showsPrec p (FileHandle   h)   = showHandle p h
 330   showsPrec p (DuplexHandle h _) = showHandle p h
 331
 332 showHandle p h =
 333     let
 334      -- (Big) SIGH: unfolded defn of takeMVar to avoid
 335      -- an (oh-so) unfortunate module loop with PrelConc.
 336      hdl_ = unsafePerformIO (IO $ \ s# ->
 337              case h                 of { MVar h# ->
 338              case takeMVar# h# s#   of { (# s2# , r #) ->
 339              case putMVar# h# r s2# of { s3# ->
 340              (# s3#, r #) }}})
 341     in
 342     showChar '{' .
 343     showHdl (haType hdl_)
 344             (showString "loc=" . showString (haFilePath hdl_) . showChar ',' .
 345              showString "type=" . showsPrec p (haType hdl_) . showChar ',' .
 346              showString "buffering=" . showBufMode (unsafePerformIO (readIORef (haBuffer hdl_))) (haBufferMode hdl_) . showString "}" )
 347    where
 348     showHdl :: HandleType -> ShowS -> ShowS
 349     showHdl ht cont =
 350        case ht of
 351         ClosedHandle  -> showsPrec p ht . showString "}"
 352         _ -> cont
 353
 354     showBufMode :: Buffer -> BufferMode -> ShowS
 355     showBufMode buf bmo =
 356       case bmo of
 357         NoBuffering   -> showString "none"
 358         LineBuffering -> showString "line"
 359         BlockBuffering (Just n) -> showString "block " . showParen True (showsPrec p n)
 360         BlockBuffering Nothing  -> showString "block " . showParen True (showsPrec p def)
 361       where
 362        def :: Int
 363        def = bufSize buf
 364
 365 -- ------------------------------------------------------------------------
 366 -- Exception datatype and operations
 367
 368 data Exception
 369   = IOException         IOException     -- IO exceptions
 370   | ArithException      ArithException  -- Arithmetic exceptions
 371   | ArrayException      ArrayException  -- Array-related exceptions
 372   | ErrorCall           String          -- Calls to 'error'
 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 _ (NoMethodError err)        = showString err
 436   showsPrec _ (PatternMatchFail err)     = showString err
 437   showsPrec _ (RecSelError err)          = showString err
 438   showsPrec _ (RecConError err)          = showString err
 439   showsPrec _ (RecUpdError err)          = showString err
 440   showsPrec _ (AssertionFailed err)      = showString err
 441   showsPrec _ (DynException _err)        = showString "unknown exception"
 442   showsPrec _ (AsyncException e)         = shows e
 443   showsPrec _ (BlockedOnDeadMVar)        = showString "thread blocked indefinitely"
 444   showsPrec _ (NonTermination)           = showString "<<loop>>"
 445   showsPrec _ (UserError err)            = showString err
 446
 447 -- --------------------------------------------------------------------------
 448 -- Primitive throw
 449
 450 throw :: Exception -> a
 451 throw exception = raise# exception
 452
 453 ioError         :: Exception -> IO a
 454 ioError err     =  IO $ \s -> throw err s
 455
 456 ioException     :: IOException -> IO a
 457 ioException err =  IO $ \s -> throw (IOException err) s
 458
 459 -- ---------------------------------------------------------------------------
 460 -- IOError type
 461
 462 -- A value @IOError@ encode errors occurred in the @IO@ monad.
 463 -- An @IOError@ records a more specific error type, a descriptive
 464 -- string and maybe the handle that was used when the error was
 465 -- flagged.
 466
 467 type IOError = Exception
 468
 469 data IOException
 470  = IOError
 471      (Maybe Handle)   -- the handle used by the action flagging the
 472                       --   the error.
 473      IOErrorType      -- what it was.
 474      String           -- location.
 475      String           -- error type specific information.
 476      (Maybe FilePath) -- filename the error is related to.
 477
 478 instance Eq IOException where
 479   (IOError h1 e1 loc1 str1 fn1) == (IOError h2 e2 loc2 str2 fn2) =
 480     e1==e2 && str1==str2 && h1==h2 && loc1==loc2 && fn1==fn2
 481
 482 data IOErrorType
 483   = AlreadyExists        | HardwareFault
 484   | IllegalOperation     | InappropriateType
 485   | Interrupted          | InvalidArgument
 486   | NoSuchThing          | OtherError
 487   | PermissionDenied     | ProtocolError
 488   | ResourceBusy         | ResourceExhausted
 489   | ResourceVanished     | SystemError
 490   | TimeExpired          | UnsatisfiedConstraints
 491   | UnsupportedOperation
 492   | EOF
 493 #if defined(cygwin32_TARGET_OS) || defined(mingw32_TARGET_OS)
 494   | ComError Int           -- HRESULT
 495 #endif
 496   deriving (Eq)
 497
 498 instance Show IOErrorType where
 499   showsPrec _ e =
 500     showString $
 501     case e of
 502       AlreadyExists     -> "already exists"
 503       HardwareFault     -> "hardware fault"
 504       IllegalOperation  -> "illegal operation"
 505       InappropriateType -> "inappropriate type"
 506       Interrupted       -> "interrupted"
 507       InvalidArgument   -> "invalid argument"
 508       NoSuchThing       -> "does not exist"
 509       OtherError        -> "failed"
 510       PermissionDenied  -> "permission denied"
 511       ProtocolError     -> "protocol error"
 512       ResourceBusy      -> "resource busy"
 513       ResourceExhausted -> "resource exhausted"
 514       ResourceVanished  -> "resource vanished"
 515       SystemError       -> "system error"
 516       TimeExpired       -> "timeout"
 517       UnsatisfiedConstraints -> "unsatisified constraints" -- ultra-precise!
 518       UnsupportedOperation -> "unsupported operation"
 519       EOF               -> "end of file"
 520 #if defined(cygwin32_TARGET_OS) || defined(mingw32_TARGET_OS)
 521       ComError _        -> "COM error"
 522 #endif
 523
 524
 525
 526 userError       :: String  -> IOError
 527 userError str   =  UserError str
 528
 529 -- ---------------------------------------------------------------------------
 530 -- Predicates on IOError
 531
 532 isAlreadyExistsError :: IOError -> Bool
 533 isAlreadyExistsError (IOException (IOError _ AlreadyExists _ _ _)) = True
 534 isAlreadyExistsError _                                             = False
 535
 536 isAlreadyInUseError :: IOError -> Bool
 537 isAlreadyInUseError (IOException (IOError _ ResourceBusy _ _ _)) = True
 538 isAlreadyInUseError _                                            = False
 539
 540 isFullError :: IOError -> Bool
 541 isFullError (IOException (IOError _ ResourceExhausted _ _ _)) = True
 542 isFullError _                                                 = False
 543
 544 isEOFError :: IOError -> Bool
 545 isEOFError (IOException (IOError _ EOF _ _ _)) = True
 546 isEOFError _                                   = False
 547
 548 isIllegalOperation :: IOError -> Bool
 549 isIllegalOperation (IOException (IOError _ IllegalOperation _ _ _)) = True
 550 isIllegalOperation _                                                = False
 551
 552 isPermissionError :: IOError -> Bool
 553 isPermissionError (IOException (IOError _ PermissionDenied _ _ _)) = True
 554 isPermissionError _                                                = False
 555
 556 isDoesNotExistError :: IOError -> Bool
 557 isDoesNotExistError (IOException (IOError _ NoSuchThing _ _ _)) = True
 558 isDoesNotExistError _                                           = False
 559
 560 isUserError :: IOError -> Bool
 561 isUserError (UserError _) = True
 562 isUserError _             = False
 563
 564 -- ---------------------------------------------------------------------------
 565 -- Showing IOErrors
 566
 567 instance Show IOException where
 568     showsPrec p (IOError hdl iot loc s fn) =
 569       showsPrec p iot .
 570       (case loc of
 571          "" -> id
 572          _  -> showString "\nAction: " . showString loc) .
 573       (case hdl of
 574         Nothing -> id
 575         Just h  -> showString "\nHandle: " . showsPrec p h) .
 576       (case s of
 577          "" -> id
 578          _  -> showString "\nReason: " . showString s) .
 579       (case fn of
 580          Nothing -> id
 581          Just name -> showString "\nFile: " . showString name)
 582 \end{code}