ghc/lib/std/PrelIOBase.lhs

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