1 % ------------------------------------------------------------------------------
2 % $Id: PrelIOBase.lhs,v 1.26 2000/07/07 11:03:58 simonmar Exp $
4 % (c) The University of Glasgow, 1994-2000
7 \section[PrelIOBase]{Module @PrelIOBase@}
9 Definitions for the @IO@ monad and its friends. Everything is exported
10 concretely; the @IO@ module itself exports abstractly.
13 {-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-}
15 #include "cbits/stgerror.h"
17 #ifndef __HUGS__ /* Hugs just includes this in PreludeBuiltin so no header needed */
18 module PrelIOBase where
20 import {-# SOURCE #-} PrelErr ( error )
24 import PrelMaybe ( Maybe(..) )
25 import PrelAddr ( Addr(..) )
29 import PrelPack ( unpackCString )
31 #if !defined(__CONCURRENT_HASKELL__)
32 import PrelArr ( MutableVar, readVar )
37 #define __CONCURRENT_HASKELL__
39 #define unpackCString primUnpackString
42 #ifndef __PARALLEL_HASKELL__
43 #define FILE_OBJECT ForeignObj
45 #define FILE_OBJECT Addr
49 %*********************************************************
51 \subsection{The @IO@ monad}
53 %*********************************************************
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.
59 NOTE: The IO representation is deeply wired in to various parts of the
60 system. The following list may or may not be exhaustive:
62 Compiler - types of various primitives in PrimOp.lhs
64 RTS - forceIO (StgMiscClosures.hc)
65 - catchzh_fast, (un)?blockAsyncExceptionszh_fast, raisezh_fast
67 - raiseAsync (Schedule.c)
69 Prelude - PrelIOBase.lhs, and several other places including
72 Libraries - parts of hslibs/lang.
78 newtype IO a = IO (State# RealWorld -> (# State# RealWorld, a #))
80 unIO :: IO a -> (State# RealWorld -> (# State# RealWorld, a #))
83 instance Functor IO where
84 fmap f x = x >>= (return . f)
86 instance Monad IO where
90 m >> k = m >>= \ _ -> k
94 fail s = error s -- not ioError?
96 liftIO :: IO a -> State# RealWorld -> STret RealWorld a
97 liftIO (IO m) = \s -> case m s of (# s', r #) -> STret s' r
99 bindIO :: IO a -> (a -> IO b) -> IO b
100 bindIO (IO m) k = IO ( \ s ->
102 (# new_s, a #) -> unIO (k a) new_s
105 returnIO :: a -> IO a
106 returnIO x = IO (\ s -> (# s, x #))
110 %*********************************************************
112 \subsection{Coercions to @ST@}
114 %*********************************************************
118 /* Hugs doesn't distinguish these types so no coercion required) */
120 stToIO :: ST RealWorld a -> IO a
121 stToIO (ST m) = (IO m)
123 ioToST :: IO a -> ST RealWorld a
124 ioToST (IO m) = (ST m)
128 %*********************************************************
130 \subsection{Unsafe @IO@ operations}
132 %*********************************************************
136 {-# NOINLINE unsafePerformIO #-}
137 unsafePerformIO :: IO a -> a
138 unsafePerformIO (IO m) = case m realWorld# of (# _, r #) -> r
140 unsafeInterleaveIO :: IO a -> IO a
141 unsafeInterleaveIO = stToIO . unsafeInterleaveST . ioToST
145 %*********************************************************
147 \subsection{Types @Handle@, @Handle__@}
149 %*********************************************************
151 The type for @Handle@ is defined rather than in @IOHandle@
152 module, as the @IOError@ type uses it..all operations over
153 a handles reside in @IOHandle@.
159 Sigh, the MVar ops in ConcBase depend on IO, the IO
160 representation here depend on MVars for handles (when
161 compiling in a concurrent way). Break the cycle by having
162 the definition of MVars go here:
165 data MVar a = MVar (MVar# RealWorld a)
167 -- pull in Eq (Mvar a) too, to avoid PrelConc being an orphan-instance module
168 instance Eq (MVar a) where
169 (MVar mvar1#) == (MVar mvar2#) = sameMVar# mvar1# mvar2#
172 Double sigh - ForeignObj is needed here too to break a cycle.
174 data ForeignObj = ForeignObj ForeignObj# -- another one
175 instance CCallable ForeignObj
177 eqForeignObj :: ForeignObj -> ForeignObj -> Bool
179 = unsafePerformIO (primEqForeignObj mp1 mp2) /= (0::Int)
181 foreign import "eqForeignObj" unsafe primEqForeignObj :: ForeignObj -> ForeignObj -> IO Int
183 instance Eq ForeignObj where
184 p == q = eqForeignObj p q
185 p /= q = not (eqForeignObj p q)
186 #endif /* ndef __HUGS__ */
188 #if defined(__CONCURRENT_HASKELL__)
189 newtype Handle = Handle (MVar Handle__)
191 newtype Handle = Handle (MutableVar RealWorld Handle__)
194 instance Eq Handle where
195 (Handle h1) == (Handle h2) = h1 == h2
198 A Handle is represented by (a reference to) a record
199 containing the state of the I/O port/device. We record
200 the following pieces of info:
202 * type (read,write,closed etc.)
203 * pointer to the external file object.
205 * user-friendly name (usually the
206 FilePath used when IO.openFile was called)
208 Note: when a Handle is garbage collected, we want to flush its buffer
209 and close the OS file handle, so as to free up a (precious) resource.
213 haFO__ :: FILE_OBJECT,
214 haType__ :: Handle__Type,
215 haBufferMode__ :: BufferMode,
216 haFilePath__ :: FilePath,
217 haBuffers__ :: [Addr]
221 Internally, we classify handles as being one
225 = ErrorHandle IOException
234 -- File names are specified using @FilePath@, a OS-dependent
235 -- string that (hopefully, I guess) maps to an accessible file/object.
237 type FilePath = String
240 %*********************************************************
242 \subsection[Show-Handle]{Show instance for Handles}
244 %*********************************************************
247 -- handle types are 'show'ed when printing error msgs, so
248 -- we provide a more user-friendly Show instance for it
249 -- than the derived one.
250 instance Show Handle__Type where
253 ErrorHandle iot -> showString "error " . showsPrec p iot
254 ClosedHandle -> showString "closed"
255 SemiClosedHandle -> showString "semi-closed"
256 ReadHandle -> showString "readable"
257 WriteHandle -> showString "writeable"
258 AppendHandle -> showString "writeable (append)"
259 ReadWriteHandle -> showString "read-writeable"
261 instance Show Handle where
262 showsPrec p (Handle h) =
264 #if defined(__CONCURRENT_HASKELL__)
266 hdl_ = unsafePerformIO (primTakeMVar h)
268 -- (Big) SIGH: unfolded defn of takeMVar to avoid
269 -- an (oh-so) unfortunate module loop with PrelConc.
270 hdl_ = unsafePerformIO (IO $ \ s# ->
271 case h of { MVar h# ->
272 case takeMVar# h# s# of { (# s2# , r #) ->
276 hdl_ = unsafePerformIO (stToIO (readVar h))
280 showHdl (haType__ hdl_)
281 (showString "loc=" . showString (haFilePath__ hdl_) . showChar ',' .
282 showString "type=" . showsPrec p (haType__ hdl_) . showChar ',' .
283 showString "buffering=" . showBufMode (haFO__ hdl_) (haBufferMode__ hdl_) . showString "}\n" )
285 showHdl :: Handle__Type -> ShowS -> ShowS
288 ClosedHandle -> showsPrec p ht . showString "}\n"
289 ErrorHandle _ -> showsPrec p ht . showString "}\n"
292 showBufMode :: FILE_OBJECT -> BufferMode -> ShowS
295 NoBuffering -> showString "none"
296 LineBuffering -> showString "line"
297 BlockBuffering (Just n) -> showString "block " . showParen True (showsPrec p n)
298 BlockBuffering Nothing -> showString "block " . showParen True (showsPrec p def)
301 def = unsafePerformIO (getBufSize fo)
304 %*********************************************************
306 \subsection[BufferMode]{Buffering modes}
308 %*********************************************************
310 Three kinds of buffering are supported: line-buffering,
311 block-buffering or no-buffering. These modes have the following
312 effects. For output, items are written out from the internal
313 buffer according to the buffer mode:
316 \item[line-buffering] the entire output buffer is written
317 out whenever a newline is output, the output buffer overflows,
318 a flush is issued, or the handle is closed.
320 \item[block-buffering] the entire output buffer is written out whenever
321 it overflows, a flush is issued, or the handle
324 \item[no-buffering] output is written immediately, and never stored
325 in the output buffer.
328 The output buffer is emptied as soon as it has been written out.
330 Similarly, input occurs according to the buffer mode for handle {\em hdl}.
332 \item[line-buffering] when the input buffer for {\em hdl} is not empty,
333 the next item is obtained from the buffer;
334 otherwise, when the input buffer is empty,
335 characters up to and including the next newline
336 character are read into the buffer. No characters
337 are available until the newline character is
339 \item[block-buffering] when the input buffer for {\em hdl} becomes empty,
340 the next block of data is read into this buffer.
341 \item[no-buffering] the next input item is read and returned.
344 For most implementations, physical files will normally be block-buffered
345 and terminals will normally be line-buffered. (the IO interface provides
346 operations for changing the default buffering of a handle tho.)
350 = NoBuffering | LineBuffering | BlockBuffering (Maybe Int)
351 deriving (Eq, Ord, Show)
352 {- Read instance defined in IO. -}
356 Foreign import declarations to helper routines:
359 foreign import "libHS_cbits" "getErrStr__" unsafe getErrStr__ :: IO Addr
360 foreign import "libHS_cbits" "getErrNo__" unsafe getErrNo__ :: IO Int
361 foreign import "libHS_cbits" "getErrType__" unsafe getErrType__ :: IO Int
363 foreign import "libHS_cbits" "allocMemory__" unsafe
364 allocMemory__ :: Int -> IO Addr
365 foreign import "libHS_cbits" "getBufSize" unsafe
366 getBufSize :: FILE_OBJECT -> IO Int
367 foreign import "libHS_cbits" "setBuf" unsafe
368 setBuf :: FILE_OBJECT -> Addr -> Int -> IO ()
372 %*********************************************************
374 \subsection{Exception datatype and operations}
376 %*********************************************************
380 = IOException IOException -- IO exceptions
381 | ArithException ArithException -- Arithmetic exceptions
382 | ArrayException ArrayException -- Array-related exceptions
383 | ErrorCall String -- Calls to 'error'
384 | NoMethodError String -- A non-existent method was invoked
385 | PatternMatchFail String -- A pattern match / guard failure
386 | RecSelError String -- Selecting a non-existent field
387 | RecConError String -- Field missing in record construction
388 | RecUpdError String -- Record doesn't contain updated field
389 | AssertionFailed String -- Assertions
390 | DynException Dynamic -- Dynamic exceptions
391 | AsyncException AsyncException -- Externally generated errors
392 | PutFullMVar -- Put on a full MVar
393 | BlockedOnDeadMVar -- Blocking on a dead MVar
412 = IndexOutOfBounds String -- out-of-range array access
413 | UndefinedElement String -- evaluating an undefined element
416 stackOverflow, heapOverflow :: Exception -- for the RTS
417 stackOverflow = AsyncException StackOverflow
418 heapOverflow = AsyncException HeapOverflow
420 instance Show ArithException where
421 showsPrec _ Overflow = showString "arithmetic overflow"
422 showsPrec _ Underflow = showString "arithmetic underflow"
423 showsPrec _ LossOfPrecision = showString "loss of precision"
424 showsPrec _ DivideByZero = showString "divide by zero"
425 showsPrec _ Denormal = showString "denormal"
427 instance Show AsyncException where
428 showsPrec _ StackOverflow = showString "stack overflow"
429 showsPrec _ HeapOverflow = showString "heap overflow"
430 showsPrec _ ThreadKilled = showString "thread killed"
432 instance Show ArrayException where
433 showsPrec _ (IndexOutOfBounds s)
434 = showString "array index out of range"
435 . (if not (null s) then showString ": " . showString s
437 showsPrec _ (UndefinedElement s)
438 = showString "undefined array element"
439 . (if not (null s) then showString ": " . showString s
442 instance Show Exception where
443 showsPrec _ (IOException err) = shows err
444 showsPrec _ (ArithException err) = shows err
445 showsPrec _ (ArrayException err) = shows err
446 showsPrec _ (ErrorCall err) = showString err
447 showsPrec _ (NoMethodError err) = showString err
448 showsPrec _ (PatternMatchFail err) = showString err
449 showsPrec _ (RecSelError err) = showString err
450 showsPrec _ (RecConError err) = showString err
451 showsPrec _ (RecUpdError err) = showString err
452 showsPrec _ (AssertionFailed err) = showString err
453 showsPrec _ (AsyncException e) = shows e
454 showsPrec _ (DynException _err) = showString "unknown exception"
455 showsPrec _ (PutFullMVar) = showString "putMVar: full MVar"
456 showsPrec _ (BlockedOnDeadMVar) = showString "thread blocked indefinitely"
457 showsPrec _ (NonTermination) = showString "<<loop>>"
460 %*********************************************************
462 \subsection{Primitive throw}
464 %*********************************************************
467 throw :: Exception -> a
468 throw exception = raise# exception
470 ioError :: Exception -> IO a
471 ioError err = IO $ \s -> throw err s
473 ioException :: IOException -> IO a
474 ioException err = IO $ \s -> throw (IOException err) s
477 %*********************************************************
479 \subsection{Type @IOError@}
481 %*********************************************************
483 A value @IOError@ encode errors occurred in the @IO@ monad.
484 An @IOError@ records a more specific error type, a descriptive
485 string and maybe the handle that was used when the error was
489 type IOError = Exception
493 (Maybe Handle) -- the handle used by the action flagging the
495 IOErrorType -- what it was.
497 String -- error type specific information.
499 instance Eq IOException where
500 (IOError h1 e1 loc1 str1) == (IOError h2 e2 loc2 str2) =
501 e1==e2 && str1==str2 && h1==h2 && loc1 == loc2
504 = AlreadyExists | HardwareFault
505 | IllegalOperation | InappropriateType
506 | Interrupted | InvalidArgument
507 | NoSuchThing | OtherError
508 | PermissionDenied | ProtocolError
509 | ResourceBusy | ResourceExhausted
510 | ResourceVanished | SystemError
511 | TimeExpired | UnsatisfiedConstraints
512 | UnsupportedOperation
514 #if defined(cygwin32_TARGET_OS) || defined(mingw32_TARGET_OS)
515 | ComError Int -- HRESULT
519 instance Show IOErrorType where
523 AlreadyExists -> "already exists"
524 HardwareFault -> "hardware fault"
525 IllegalOperation -> "illegal operation"
526 InappropriateType -> "inappropriate type"
527 Interrupted -> "interrupted"
528 InvalidArgument -> "invalid argument"
529 NoSuchThing -> "does not exist"
530 OtherError -> "failed"
531 PermissionDenied -> "permission denied"
532 ProtocolError -> "protocol error"
533 ResourceBusy -> "resource busy"
534 ResourceExhausted -> "resource exhausted"
535 ResourceVanished -> "resource vanished"
536 SystemError -> "system error"
537 TimeExpired -> "timeout"
538 UnsatisfiedConstraints -> "unsatisified constraints" -- ultra-precise!
539 UnsupportedOperation -> "unsupported operation"
541 #if defined(cygwin32_TARGET_OS) || defined(mingw32_TARGET_OS)
542 ComError _ -> "COM error"
547 userError :: String -> IOError
548 userError str = UserError str
551 Predicates on IOError; little effort made on these so far...
555 isAlreadyExistsError :: IOError -> Bool
556 isAlreadyExistsError (IOException (IOError _ AlreadyExists _ _)) = True
557 isAlreadyExistsError _ = False
559 isAlreadyInUseError :: IOError -> Bool
560 isAlreadyInUseError (IOException (IOError _ ResourceBusy _ _)) = True
561 isAlreadyInUseError _ = False
563 isFullError :: IOError -> Bool
564 isFullError (IOException (IOError _ ResourceExhausted _ _)) = True
565 isFullError _ = False
567 isEOFError :: IOError -> Bool
568 isEOFError (IOException (IOError _ EOF _ _)) = True
571 isIllegalOperation :: IOError -> Bool
572 isIllegalOperation (IOException (IOError _ IllegalOperation _ _)) = True
573 isIllegalOperation _ = False
575 isPermissionError :: IOError -> Bool
576 isPermissionError (IOException (IOError _ PermissionDenied _ _)) = True
577 isPermissionError _ = False
579 isDoesNotExistError :: IOError -> Bool
580 isDoesNotExistError (IOException (IOError _ NoSuchThing _ _)) = True
581 isDoesNotExistError _ = False
583 isUserError :: IOError -> Bool
584 isUserError (UserError _) = True
585 isUserError _ = False
592 -- For now we give a fairly uninformative error message which just happens to
593 -- be like the ones that Hugs used to give.
594 instance Show IOException where
595 showsPrec p (IOError hdl iot loc s) = showString s . showChar '\n'
597 instance Show IOException where
598 showsPrec p (IOError hdl iot loc s) =
603 _ -> showString "Action: " . showString loc . showChar '\n') .
607 _ -> showString "Reason: " . showString s)
612 Just h -> showString "Handle: " . showsPrec p h
617 The @String@ part of an @IOError@ is platform-dependent. However, to
618 provide a uniform mechanism for distinguishing among errors within
619 these broad categories, each platform-specific standard shall specify
620 the exact strings to be used for particular errors. For errors not
621 explicitly mentioned in the standard, any descriptive string may be
625 constructErrorAndFail :: String -> IO a
626 constructErrorAndFail call_site
627 = constructError call_site >>= \ io_error ->
628 ioError (IOException io_error)
630 constructErrorAndFailWithInfo :: String -> String -> IO a
631 constructErrorAndFailWithInfo call_site reason
632 = constructErrorMsg call_site (Just reason) >>= \ io_error ->
633 ioError (IOException io_error)
637 This doesn't seem to be documented/spelled out anywhere,
640 The implementation of the IO prelude uses various C stubs
641 to do the actual interaction with the OS. The bandwidth
642 \tr{C<->Haskell} is somewhat limited, so the general strategy
643 for flaggging any errors (apart from possibly using the
644 return code of the external call), is to set the @ghc_errtype@
645 to a value that is one of the \tr{#define}s in @includes/error.h@.
646 @ghc_errstr@ holds a character string providing error-specific
647 information. Error constructing functions will then reach out
648 and grab these values when generating
651 constructError :: String -> IO IOException
652 constructError call_site = constructErrorMsg call_site Nothing
654 constructErrorMsg :: String -> Maybe String -> IO IOException
655 constructErrorMsg call_site reason =
656 getErrType__ >>= \ errtype ->
657 getErrStr__ >>= \ str ->
660 case (errtype::Int) of
661 ERR_ALREADYEXISTS -> AlreadyExists
662 ERR_HARDWAREFAULT -> HardwareFault
663 ERR_ILLEGALOPERATION -> IllegalOperation
664 ERR_INAPPROPRIATETYPE -> InappropriateType
665 ERR_INTERRUPTED -> Interrupted
666 ERR_INVALIDARGUMENT -> InvalidArgument
667 ERR_NOSUCHTHING -> NoSuchThing
668 ERR_OTHERERROR -> OtherError
669 ERR_PERMISSIONDENIED -> PermissionDenied
670 ERR_PROTOCOLERROR -> ProtocolError
671 ERR_RESOURCEBUSY -> ResourceBusy
672 ERR_RESOURCEEXHAUSTED -> ResourceExhausted
673 ERR_RESOURCEVANISHED -> ResourceVanished
674 ERR_SYSTEMERROR -> SystemError
675 ERR_TIMEEXPIRED -> TimeExpired
676 ERR_UNSATISFIEDCONSTRAINTS -> UnsatisfiedConstraints
677 ERR_UNSUPPORTEDOPERATION -> UnsupportedOperation
684 OtherError -> "(error code: " ++ show errtype ++ ")"
690 return (IOError Nothing iot call_site msg)