ghc/lib/std/PrelIOBase.lhs

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