ghc/lib/std/PrelIOBase.lhs

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