ghc/lib/std/PrelIOBase.lhs

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