ghc/lib/std/PrelIOBase.lhs

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