ghc/lib/std/PrelIOBase.lhs

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