ghc/lib/std/PrelIOBase.lhs

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