ghc/lib/std/PrelIOBase.lhs

   1 %
   2 % (c) The AQUA Project, Glasgow University, 1994-1996
   3 %
   4
   5 \section[PrelIOBase]{Module @PrelIOBase@}
   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 -#include "cbits/stgio.h" #-}
  12 #include "error.h"
  13
  14 module PrelIOBase where
  15
  16 import {-# SOURCE #-} PrelErr ( error )
  17 import PrelBase
  18 import PrelST     ( ST(..), STret(..), StateAndPtr#(..) )
  19 import PrelMaybe  ( Maybe(..) )
  20 import PrelAddr   ( Addr(..), nullAddr )
  21 import PrelPack   ( unpackCString )
  22 import PrelArr    ( MutableVar, readVar )
  23
  24 \end{code}
  25
  26 %*********************************************************
  27 %*                                                      *
  28 \subsection{The @IO@ monad}
  29 %*                                                      *
  30 %*********************************************************
  31
  32 IO is no longer built on top of PrimIO (which used to be a specialised
  33 version of the ST monad), instead it is now has its own type.  This is
  34 purely for efficiency purposes, since we get to remove several levels
  35 of lifting in the type of the monad.
  36
  37 \begin{code}
  38 newtype IO a = IO (State# RealWorld -> IOResult a)
  39
  40 {-# INLINE unIO #-}
  41 unIO (IO a) = a
  42
  43 data IOResult a = IOok   (State# RealWorld) a
  44                 | IOfail (State# RealWorld) IOError
  45
  46 instance  Functor IO where
  47    map f x = x >>= (return . f)
  48
  49 instance  Monad IO  where
  50     {-# INLINE return #-}
  51     {-# INLINE (>>)   #-}
  52     {-# INLINE (>>=)  #-}
  53     m >> k      =  m >>= \ _ -> k
  54     return x    = IO $ \ s -> IOok s x
  55
  56     (IO m) >>= k =
  57         IO $ \s ->
  58         case m s of
  59             IOfail new_s err -> IOfail new_s err
  60             IOok   new_s a   -> unIO (k a) new_s
  61
  62 fixIO :: (a -> IO a) -> IO a
  63     -- not required but worth having around
  64
  65 fixIO k = IO $ \ s ->
  66     let
  67         (IO k_loop) = k loop
  68         result      = k_loop s
  69         IOok _ loop = result
  70     in
  71     result
  72
  73 fail            :: IOError -> IO a
  74 fail err        =  IO $ \ s -> IOfail s err
  75
  76 userError       :: String  -> IOError
  77 userError str   =  IOError Nothing (UserError Nothing) "" str
  78
  79 catch           :: IO a    -> (IOError -> IO a) -> IO a
  80 catch (IO m) k  = IO $ \ s ->
  81   case m s of
  82     IOok   new_s a -> IOok new_s a
  83     IOfail new_s e -> unIO (k e) new_s
  84
  85 instance  Show (IO a)  where
  86     showsPrec p f  = showString "<<IO action>>"
  87     showList       = showList__ (showsPrec 0)
  88 \end{code}
  89
  90 %*********************************************************
  91 %*                                                      *
  92 \subsection{Coercions to @ST@}
  93 %*                                                      *
  94 %*********************************************************
  95
  96 \begin{code}
  97 stToIO     :: ST RealWorld a -> IO a
  98 stToIO (ST m) = IO $ \ s -> case (m s) of STret new_s r -> IOok new_s r
  99
 100 ioToST     :: IO a -> ST RealWorld a
 101 ioToST (IO io) = ST $ \ s ->
 102     case (io s) of
 103       IOok   new_s a -> STret new_s a
 104       IOfail new_s e -> error ("I/O Error (ioToST): " ++ showsPrec 0 e "\n")
 105 \end{code}
 106
 107 %*********************************************************
 108 %*                                                      *
 109 \subsection{Type @IOError@}
 110 %*                                                      *
 111 %*********************************************************
 112
 113 A value @IOError@ encode errors occurred in the @IO@ monad.
 114 An @IOError@ records a more specific error type, a descriptive
 115 string and maybe the handle that was used when the error was
 116 flagged.
 117
 118 \begin{code}
 119 data IOError
 120  = IOError
 121      (Maybe Handle)  -- the handle used by the action flagging the
 122                      -- the error.
 123      IOErrorType     -- what it was.
 124      String          -- location
 125      String          -- error type specific information.
 126
 127
 128 data IOErrorType
 129   = AlreadyExists        | HardwareFault
 130   | IllegalOperation     | InappropriateType
 131   | Interrupted          | InvalidArgument
 132   | NoSuchThing          | OtherError
 133   | PermissionDenied     | ProtocolError
 134   | ResourceBusy         | ResourceExhausted
 135   | ResourceVanished     | SystemError
 136   | TimeExpired          | UnsatisfiedConstraints
 137   | UnsupportedOperation | UserError (Maybe Addr)
 138   | EOF
 139   deriving (Eq)
 140
 141 instance Show IOErrorType where
 142   showsPrec d e =
 143     showString $
 144     case e of
 145       AlreadyExists     -> "already exists"
 146       HardwareFault     -> "hardware fault"
 147       IllegalOperation  -> "illegal operation"
 148       InappropriateType -> "inappropriate type"
 149       Interrupted       -> "interrupted"
 150       InvalidArgument   -> "invalid argument"
 151       NoSuchThing       -> "does not exist"
 152       OtherError        -> "failed"
 153       PermissionDenied  -> "permission denied"
 154       ProtocolError     -> "protocol error"
 155       ResourceBusy      -> "resource busy"
 156       ResourceExhausted -> "resource exhausted"
 157       ResourceVanished  -> "resource vanished"
 158       SystemError       -> "system error"
 159       TimeExpired       -> "timeout"
 160       UnsatisfiedConstraints -> "unsatisified constraints" -- ultra-precise!
 161       UserError _       -> "failed"
 162       EOF               -> "end of file"
 163
 164 \end{code}
 165
 166 Predicates on IOError; little effort made on these so far...
 167
 168 \begin{code}
 169
 170 isAlreadyExistsError (IOError _ AlreadyExists _ _) = True
 171 isAlreadyExistsError _                             = False
 172
 173 isAlreadyInUseError (IOError _ ResourceBusy _ _) = True
 174 isAlreadyInUseError _                            = False
 175
 176 isFullError (IOError _ ResourceExhausted _ _) = True
 177 isFullError _                                 = False
 178
 179 isEOFError (IOError _ EOF _ _) = True
 180 isEOFError _                   = False
 181
 182 isIllegalOperation (IOError _ IllegalOperation _ _) = True
 183 isIllegalOperation _                                = False
 184
 185 isPermissionError (IOError _ PermissionDenied _ _) = True
 186 isPermissionError _                                = False
 187
 188 isDoesNotExistError (IOError _ NoSuchThing _ _) = True
 189 isDoesNotExistError _                           = False
 190
 191 isUserError (IOError _ (UserError _) _ _) = True
 192 isUserError _                             = False
 193 \end{code}
 194
 195 Showing @IOError@s
 196
 197 \begin{code}
 198 instance Show IOError where
 199     showsPrec p (IOError hdl iot loc s) =
 200       showsPrec p iot .
 201       showChar '\n' .
 202       (case loc of
 203          "" -> id
 204          _  -> showString "Action: " . showString loc . showChar '\n') .
 205       showHdl .
 206       (case s of
 207          "" -> id
 208          _  -> showString "Reason: " . showString s)
 209      where
 210       showHdl =
 211        case hdl of
 212         Nothing -> id
 213         Just h  -> showString "Handle: " . showsPrec p h
 214
 215
 216 \end{code}
 217
 218 The @String@ part of an @IOError@ is platform-dependent.  However, to
 219 provide a uniform mechanism for distinguishing among errors within
 220 these broad categories, each platform-specific standard shall specify
 221 the exact strings to be used for particular errors.  For errors not
 222 explicitly mentioned in the standard, any descriptive string may be
 223 used.
 224
 225 \begin{code}
 226 constructErrorAndFail :: String -> IO a
 227 constructErrorAndFail call_site
 228   = constructError call_site >>= \ io_error ->
 229     fail io_error
 230
 231 constructErrorAndFailWithInfo :: String -> String -> IO a
 232 constructErrorAndFailWithInfo call_site reason
 233   = constructErrorMsg call_site (Just reason) >>= \ io_error ->
 234     fail io_error
 235
 236 \end{code}
 237
 238 This doesn't seem to be documented/spelled out anywhere,
 239 so here goes: (SOF)
 240
 241 The implementation of the IO prelude uses various C stubs
 242 to do the actual interaction with the OS. The bandwidth
 243 \tr{C<->Haskell} is somewhat limited, so the general strategy
 244 for flaggging any errors (apart from possibly using the
 245 return code of the external call), is to set the @ghc_errtype@
 246 to a value that is one of the \tr{#define}s in @includes/error.h@.
 247 @ghc_errstr@ holds a character string providing error-specific
 248 information. Error constructing functions will then reach out
 249 and grab these values when generating
 250
 251 \begin{code}
 252 constructError        :: String -> IO IOError
 253 constructError call_site = constructErrorMsg call_site Nothing
 254
 255 constructErrorMsg             :: String -> Maybe String -> IO IOError
 256 constructErrorMsg call_site reason =
 257  _ccall_ getErrType__            >>= \ (I# errtype#) ->
 258  _ccall_ getErrStr__             >>= \ str ->
 259  let
 260   iot =
 261    case errtype# of
 262      ERR_ALREADYEXISTS#          -> AlreadyExists
 263      ERR_HARDWAREFAULT#          -> HardwareFault
 264      ERR_ILLEGALOPERATION#       -> IllegalOperation
 265      ERR_INAPPROPRIATETYPE#      -> InappropriateType
 266      ERR_INTERRUPTED#            -> Interrupted
 267      ERR_INVALIDARGUMENT#        -> InvalidArgument
 268      ERR_NOSUCHTHING#            -> NoSuchThing
 269      ERR_OTHERERROR#             -> OtherError
 270      ERR_PERMISSIONDENIED#       -> PermissionDenied
 271      ERR_PROTOCOLERROR#          -> ProtocolError
 272      ERR_RESOURCEBUSY#           -> ResourceBusy
 273      ERR_RESOURCEEXHAUSTED#      -> ResourceExhausted
 274      ERR_RESOURCEVANISHED#       -> ResourceVanished
 275      ERR_SYSTEMERROR#            -> SystemError
 276      ERR_TIMEEXPIRED#            -> TimeExpired
 277      ERR_UNSATISFIEDCONSTRAINTS# -> UnsatisfiedConstraints
 278      ERR_UNSUPPORTEDOPERATION#   -> UnsupportedOperation
 279      ERR_EOF#                    -> EOF
 280      _                           -> OtherError
 281
 282   msg =
 283    unpackCString str ++
 284    (case iot of
 285      OtherError -> "(error code: " ++ show (I# errtype#) ++ ")"
 286      _ -> "") ++
 287    (case reason of
 288       Nothing -> ""
 289       Just m  -> ' ':m)
 290  in
 291  return (IOError Nothing iot call_site msg)
 292 \end{code}
 293
 294 %*********************************************************
 295 %*                                                      *
 296 \subsection{Types @Handle@, @Handle__@}
 297 %*                                                      *
 298 %*********************************************************
 299
 300 The type for @Handle@ is defined rather than in @IOHandle@
 301 module, as the @IOError@ type uses it..all operations over
 302 a handles reside in @IOHandle@.
 303
 304 \begin{code}
 305
 306 {-
 307  Sigh, the MVar ops in ConcBase depend on IO, the IO
 308  representation here depend on MVars for handles (when
 309  compiling in a concurrent way). Break the cycle by having
 310  the definition of MVars go here:
 311
 312 -}
 313 data MVar a = MVar (SynchVar# RealWorld a)
 314
 315 {-
 316   Double sigh - ForeignObj is needed here too to break a cycle.
 317 -}
 318 data ForeignObj = ForeignObj ForeignObj#   -- another one
 319 instance CCallable ForeignObj
 320 instance CCallable ForeignObj#
 321
 322 makeForeignObj  :: Addr        -> Addr       -> IO ForeignObj
 323 makeForeignObj (A# obj) (A# finaliser) = IO ( \ s# ->
 324     case makeForeignObj# obj finaliser s# of
 325       StateAndForeignObj# s1# fo# -> IOok s1# (ForeignObj fo#))
 326
 327 data StateAndForeignObj# s  = StateAndForeignObj# (State# s) ForeignObj#
 328
 329
 330 #if defined(__CONCURRENT_HASKELL__)
 331 newtype Handle = Handle (MVar Handle__)
 332 #else
 333 newtype Handle = Handle (MutableVar RealWorld Handle__)
 334 #endif
 335
 336 #ifndef __PARALLEL_HASKELL__
 337 #define FILE_OBJECT         ForeignObj
 338 #else
 339 #define FILE_OBJECT         Addr
 340 #endif
 341
 342 {-
 343   A Handle is represented by (a reference to) a record
 344   containing the state of the I/O port/device. We record
 345   the following pieces of info:
 346
 347     * type (read,write,closed etc.)
 348     * pointer to the external file object.
 349     * buffering mode
 350     * user-friendly name (usually the
 351       FilePath used when IO.openFile was called)
 352
 353 Note: when a Handle is garbage collected, we want to flush its buffer
 354 and close the OS file handle, so as to free up a (precious) resource.
 355
 356 This means that the finaliser for the handle needs to have access to
 357 the buffer and the OS file handle. The current implementation of foreign
 358 objects requires that the finaliser is implemented in C, so to
 359 arrange for this to happen, openFile() returns a pointer to a structure
 360 big enough to hold the OS file handle and a pointer to the buffer.
 361 This pointer is then wrapped up inside a ForeignObj, and finalised
 362 as desired.
 363
 364 -}
 365 data Handle__
 366   = Handle__ {
 367       haFO__          :: FILE_OBJECT,
 368       haType__        :: Handle__Type,
 369       haBufferMode__  :: BufferMode,
 370       haFilePath__    :: String
 371     }
 372
 373 {-
 374   Internally, we classify handles as being one
 375   of the following:
 376
 377 -}
 378 data Handle__Type
 379  = ErrorHandle  IOError
 380  | ClosedHandle
 381  | SemiClosedHandle
 382  | ReadHandle
 383  | WriteHandle
 384  | AppendHandle
 385  | ReadWriteHandle
 386
 387
 388 -- handle types are 'show'ed when printing error msgs, so
 389 -- we provide a more user-friendly Show instance for it
 390 -- than the derived one.
 391 instance Show Handle__Type where
 392   showsPrec p t =
 393     case t of
 394       ErrorHandle iot   -> showString "error " . showsPrec p iot
 395       ClosedHandle      -> showString "closed"
 396       SemiClosedHandle  -> showString "semi-closed"
 397       ReadHandle        -> showString "readable"
 398       WriteHandle       -> showString "writeable"
 399       AppendHandle      -> showString "writeable (append)"
 400       ReadWriteHandle   -> showString "read-writeable"
 401
 402 instance Show Handle where
 403   showsPrec p (Handle h) =
 404     let
 405 #if defined(__CONCURRENT_HASKELL__)
 406      -- (Big) SIGH: unfolded defn of takeMVar to avoid
 407      -- an (oh-so) unfortunate module loop with PrelConc.
 408      hdl_ = unsafePerformIO (IO $ \ s# ->
 409              case h               of { MVar h# ->
 410              case takeMVar# h# s# of { StateAndPtr# s2# r ->
 411                     IOok s2# r }})
 412 #else
 413      hdl_ = unsafePerformIO (stToIO (readVar h))
 414 #endif
 415     in
 416     showChar '{' .
 417     showHdl (haType__ hdl_)
 418             (showString "loc=" . showString (haFilePath__ hdl_) . showChar ',' .
 419              showString "type=" . showsPrec p (haType__ hdl_) . showChar ',' .
 420              showString "buffering=" . showBufMode (haFO__ hdl_) (haBufferMode__ hdl_) . showString "}\n" )
 421    where
 422     showHdl :: Handle__Type -> ShowS -> ShowS
 423     showHdl ht cont =
 424        case ht of
 425         ClosedHandle  -> showsPrec p ht . showString "}\n"
 426         ErrorHandle _ -> showsPrec p ht . showString "}\n"
 427         _ -> cont
 428
 429     showBufMode :: FILE_OBJECT -> BufferMode -> ShowS
 430     showBufMode fo bmo =
 431       case bmo of
 432         NoBuffering   -> showString "none"
 433         LineBuffering -> showString "line"
 434         BlockBuffering (Just n) -> showString "block " . showParen True (showsPrec p n)
 435         BlockBuffering Nothing  -> showString "block " . showParen True (showsPrec p def)
 436       where
 437        def :: Int
 438        def = unsafePerformIO (_ccall_ getBufSize fo)
 439
 440
 441 {-
 442  nullFile__ is only used for closed handles, plugging it in as
 443  a null file object reference.
 444 -}
 445 nullFile__ :: FILE_OBJECT
 446 nullFile__ =
 447 #ifndef __PARALLEL_HASKELL__
 448     unsafePerformIO (makeForeignObj nullAddr nullAddr{-i.e., don't finalise-})
 449 #else
 450     nullAddr
 451 #endif
 452
 453
 454 mkClosedHandle__ :: Handle__
 455 mkClosedHandle__ =
 456   Handle__
 457            nullFile__
 458            ClosedHandle
 459            NoBuffering
 460            "closed file"
 461
 462 mkErrorHandle__ :: IOError -> Handle__
 463 mkErrorHandle__ ioe =
 464   Handle__
 465            nullFile__
 466            (ErrorHandle ioe)
 467            NoBuffering
 468            "error handle"
 469
 470 mkBuffer__ :: FILE_OBJECT -> Int -> IO ()
 471 mkBuffer__ fo sz_in_bytes = do
 472  chunk <-
 473   case sz_in_bytes of
 474     0 -> return nullAddr  -- this has the effect of overwriting the pointer to the old buffer.
 475     _ -> do
 476      chunk <- _ccall_ allocMemory__ sz_in_bytes
 477      if chunk == nullAddr
 478       then fail (IOError Nothing ResourceExhausted "mkBuffer__" "not enough virtual memory")
 479       else return chunk
 480  _ccall_ setBuf fo chunk sz_in_bytes
 481
 482 \end{code}
 483
 484 %*********************************************************
 485 %*                                                      *
 486 \subsection[BufferMode]{Buffering modes}
 487 %*                                                      *
 488 %*********************************************************
 489
 490 Three kinds of buffering are supported: line-buffering,
 491 block-buffering or no-buffering.  These modes have the following
 492 effects. For output, items are written out from the internal
 493 buffer according to the buffer mode:
 494
 495 \begin{itemize}
 496 \item[line-buffering]  the entire output buffer is written
 497 out whenever a newline is output, the output buffer overflows,
 498 a flush is issued, or the handle is closed.
 499
 500 \item[block-buffering] the entire output buffer is written out whenever
 501 it overflows, a flush is issued, or the handle
 502 is closed.
 503
 504 \item[no-buffering] output is written immediately, and never stored
 505 in the output buffer.
 506 \end{itemize}
 507
 508 The output buffer is emptied as soon as it has been written out.
 509
 510 Similarly, input occurs according to the buffer mode for handle {\em hdl}.
 511 \begin{itemize}
 512 \item[line-buffering] when the input buffer for {\em hdl} is not empty,
 513 the next item is obtained from the buffer;
 514 otherwise, when the input buffer is empty,
 515 characters up to and including the next newline
 516 character are read into the buffer.  No characters
 517 are available until the newline character is
 518 available.
 519 \item[block-buffering] when the input buffer for {\em hdl} becomes empty,
 520 the next block of data is read into this buffer.
 521 \item[no-buffering] the next input item is read and returned.
 522 \end{itemize}
 523
 524 For most implementations, physical files will normally be block-buffered
 525 and terminals will normally be line-buffered. (the IO interface provides
 526 operations for changing the default buffering of a handle tho.)
 527
 528 \begin{code}
 529 data BufferMode
 530  = NoBuffering | LineBuffering | BlockBuffering (Maybe Int)
 531    deriving (Eq, Ord, Show)
 532    {- Read instance defined in IO. -}
 533
 534 \end{code}
 535
 536 %*********************************************************
 537 %*                                                      *
 538 \subsection{Unsafe @IO@ operations}
 539 %*                                                      *
 540 %*********************************************************
 541
 542 \begin{code}
 543 {-# NOINLINE unsafePerformIO #-}
 544 unsafePerformIO :: IO a -> a
 545 unsafePerformIO (IO m)
 546   = case m realWorld# of
 547       IOok _ r   -> r
 548       IOfail _ e -> error ("unsafePerformIO: I/O error: " ++ show e ++ "\n")
 549
 550 {-# NOINLINE unsafeInterleaveIO #-}
 551 unsafeInterleaveIO :: IO a -> IO a
 552 unsafeInterleaveIO (IO m) = IO ( \ s ->
 553         let
 554             IOok _ r = m s
 555         in
 556         IOok s r)
 557
 558 \end{code}