ghc/lib/std/PrelIOBase.lhs

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