ghc/lib/std/PrelIOBase.lhs

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