ghc/lib/std/PrelIOBase.lhs

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