[project @ 2002-03-14 12:09:49 by simonmar]
[packages/random.git] / GHC / IOBase.lhs
1 % ------------------------------------------------------------------------------
2 % $Id: IOBase.lhs,v 1.7 2002/03/14 12:09:50 simonmar Exp $
3
4 % (c) The University of Glasgow, 1994-2001
5 %
6
7 % Definitions for the @IO@ monad and its friends.  Everything is exported
8 % concretely; the @IO@ module itself exports abstractly.
9
10 \begin{code}
11 {-# OPTIONS -fno-implicit-prelude #-}
12
13 module GHC.IOBase where
14
15 import GHC.ST
16 import GHC.STRef
17 import GHC.Base
18 import GHC.Num  -- To get fromInteger etc, needed because of -fno-implicit-prelude
19 import Data.Maybe  ( Maybe(..) )
20 import GHC.Show
21 import GHC.List
22 import GHC.Read
23 import {-# SOURCE #-} Data.Dynamic
24
25 -- ---------------------------------------------------------------------------
26 -- The IO Monad
27
28 {-
29 The IO Monad is just an instance of the ST monad, where the state is
30 the real world.  We use the exception mechanism (in GHC.Exception) to
31 implement IO exceptions.
32
33 NOTE: The IO representation is deeply wired in to various parts of the
34 system.  The following list may or may not be exhaustive:
35
36 Compiler  - types of various primitives in PrimOp.lhs
37
38 RTS       - forceIO (StgMiscClosures.hc)
39           - catchzh_fast, (un)?blockAsyncExceptionszh_fast, raisezh_fast 
40             (Exceptions.hc)
41           - raiseAsync (Schedule.c)
42
43 Prelude   - GHC.IOBase.lhs, and several other places including
44             GHC.Exception.lhs.
45
46 Libraries - parts of hslibs/lang.
47
48 --SDM
49 -}
50
51 newtype IO a = IO (State# RealWorld -> (# State# RealWorld, a #))
52
53 unIO :: IO a -> (State# RealWorld -> (# State# RealWorld, a #))
54 unIO (IO a) = a
55
56 instance  Functor IO where
57    fmap f x = x >>= (return . f)
58
59 instance  Monad IO  where
60     {-# INLINE return #-}
61     {-# INLINE (>>)   #-}
62     {-# INLINE (>>=)  #-}
63     m >> k      =  m >>= \ _ -> k
64     return x    = returnIO x
65
66     m >>= k     = bindIO m k
67     fail s      = failIO s
68
69 failIO :: String -> IO a
70 failIO s = ioError (userError s)
71
72 liftIO :: IO a -> State# RealWorld -> STret RealWorld a
73 liftIO (IO m) = \s -> case m s of (# s', r #) -> STret s' r
74
75 bindIO :: IO a -> (a -> IO b) -> IO b
76 bindIO (IO m) k = IO ( \ s ->
77   case m s of 
78     (# new_s, a #) -> unIO (k a) new_s
79   )
80
81 returnIO :: a -> IO a
82 returnIO x = IO (\ s -> (# s, x #))
83
84 -- ---------------------------------------------------------------------------
85 -- Coercions between IO and ST
86
87 --stToIO        :: (forall s. ST s a) -> IO a
88 stToIO        :: ST RealWorld a -> IO a
89 stToIO (ST m) = IO m
90
91 ioToST        :: IO a -> ST RealWorld a
92 ioToST (IO m) = (ST m)
93
94 -- ---------------------------------------------------------------------------
95 -- Unsafe IO operations
96
97 {-# NOINLINE unsafePerformIO #-}
98 unsafePerformIO :: IO a -> a
99 unsafePerformIO (IO m) = case m realWorld# of (# _, r #)   -> r
100
101 {-# NOINLINE unsafeInterleaveIO #-}
102 unsafeInterleaveIO :: IO a -> IO a
103 unsafeInterleaveIO (IO m)
104   = IO ( \ s -> let
105                    r = case m s of (# _, res #) -> res
106                 in
107                 (# s, r #))
108
109 -- ---------------------------------------------------------------------------
110 -- Handle type
111
112 data MVar a = MVar (MVar# RealWorld a)
113
114 -- pull in Eq (Mvar a) too, to avoid GHC.Conc being an orphan-instance module
115 instance Eq (MVar a) where
116         (MVar mvar1#) == (MVar mvar2#) = sameMVar# mvar1# mvar2#
117
118 --  A Handle is represented by (a reference to) a record 
119 --  containing the state of the I/O port/device. We record
120 --  the following pieces of info:
121
122 --    * type (read,write,closed etc.)
123 --    * the underlying file descriptor
124 --    * buffering mode 
125 --    * buffer, and spare buffers
126 --    * user-friendly name (usually the
127 --      FilePath used when IO.openFile was called)
128
129 -- Note: when a Handle is garbage collected, we want to flush its buffer
130 -- and close the OS file handle, so as to free up a (precious) resource.
131
132 data Handle 
133   = FileHandle                          -- A normal handle to a file
134         !(MVar Handle__)
135
136   | DuplexHandle                        -- A handle to a read/write stream
137         !(MVar Handle__)                -- The read side
138         !(MVar Handle__)                -- The write side
139
140 -- NOTES:
141 --    * A 'FileHandle' is seekable.  A 'DuplexHandle' may or may not be
142 --      seekable.
143
144 instance Eq Handle where
145  (FileHandle h1)     == (FileHandle h2)     = h1 == h2
146  (DuplexHandle h1 _) == (DuplexHandle h2 _) = h1 == h2
147  _ == _ = False 
148
149 type FD = Int -- XXX ToDo: should be CInt
150
151 data Handle__
152   = Handle__ {
153       haFD          :: !FD,                  -- file descriptor
154       haType        :: HandleType,           -- type (read/write/append etc.)
155       haIsBin       :: Bool,                 -- binary mode?
156       haIsStream    :: Bool,                 -- is this a stream handle?
157       haBufferMode  :: BufferMode,           -- buffer contains read/write data?
158       haFilePath    :: FilePath,             -- file name, possibly
159       haBuffer      :: !(IORef Buffer),      -- the current buffer
160       haBuffers     :: !(IORef BufferList),  -- spare buffers
161       haOtherSide   :: Maybe (MVar Handle__) -- ptr to the write side of a 
162                                              -- duplex handle.
163     }
164
165 -- ---------------------------------------------------------------------------
166 -- Buffers
167
168 -- The buffer is represented by a mutable variable containing a
169 -- record, where the record contains the raw buffer and the start/end
170 -- points of the filled portion.  We use a mutable variable so that
171 -- the common operation of writing (or reading) some data from (to)
172 -- the buffer doesn't need to modify, and hence copy, the handle
173 -- itself, it just updates the buffer.  
174
175 -- There will be some allocation involved in a simple hPutChar in
176 -- order to create the new Buffer structure (below), but this is
177 -- relatively small, and this only has to be done once per write
178 -- operation.
179
180 -- The buffer contains its size - we could also get the size by
181 -- calling sizeOfMutableByteArray# on the raw buffer, but that tends
182 -- to be rounded up to the nearest Word.
183
184 type RawBuffer = MutableByteArray# RealWorld
185
186 -- INVARIANTS on a Buffer:
187 --
188 --   * A handle *always* has a buffer, even if it is only 1 character long
189 --     (an unbuffered handle needs a 1 character buffer in order to support
190 --      hLookAhead and hIsEOF).
191 --   * r <= w
192 --   * if r == w, then r == 0 && w == 0
193 --   * if state == WriteBuffer, then r == 0
194 --   * a write buffer is never full.  If an operation
195 --     fills up the buffer, it will always flush it before 
196 --     returning.
197 --   * a read buffer may be full as a result of hLookAhead.  In normal
198 --     operation, a read buffer always has at least one character of space.
199
200 data Buffer 
201   = Buffer {
202         bufBuf   :: RawBuffer,
203         bufRPtr  :: !Int,
204         bufWPtr  :: !Int,
205         bufSize  :: !Int,
206         bufState :: BufferState
207   }
208
209 data BufferState = ReadBuffer | WriteBuffer deriving (Eq)
210
211 -- we keep a few spare buffers around in a handle to avoid allocating
212 -- a new one for each hPutStr.  These buffers are *guaranteed* to be the
213 -- same size as the main buffer.
214 data BufferList 
215   = BufferListNil 
216   | BufferListCons RawBuffer BufferList
217
218
219 bufferIsWritable :: Buffer -> Bool
220 bufferIsWritable Buffer{ bufState=WriteBuffer } = True
221 bufferIsWritable _other = False
222
223 bufferEmpty :: Buffer -> Bool
224 bufferEmpty Buffer{ bufRPtr=r, bufWPtr=w } = r == w
225
226 -- only makes sense for a write buffer
227 bufferFull :: Buffer -> Bool
228 bufferFull b@Buffer{ bufWPtr=w } = w >= bufSize b
229
230 --  Internally, we classify handles as being one
231 --  of the following:
232
233 data HandleType
234  = ClosedHandle
235  | SemiClosedHandle
236  | ReadHandle
237  | WriteHandle
238  | AppendHandle
239  | ReadWriteHandle
240
241 isReadableHandleType ReadHandle         = True
242 isReadableHandleType ReadWriteHandle    = True
243 isReadableHandleType _                  = False
244
245 isWritableHandleType AppendHandle    = True
246 isWritableHandleType WriteHandle     = True
247 isWritableHandleType ReadWriteHandle = True
248 isWritableHandleType _               = False
249
250 -- File names are specified using @FilePath@, a OS-dependent
251 -- string that (hopefully, I guess) maps to an accessible file/object.
252
253 type FilePath = String
254
255 -- ---------------------------------------------------------------------------
256 -- Buffering modes
257
258 -- Three kinds of buffering are supported: line-buffering, 
259 -- block-buffering or no-buffering.  These modes have the following
260 -- effects. For output, items are written out from the internal
261 -- buffer according to the buffer mode:
262 --
263 -- * line-buffering  the entire output buffer is written
264 --   out whenever a newline is output, the output buffer overflows, 
265 --   a flush is issued, or the handle is closed.
266 --
267 -- * block-buffering the entire output buffer is written out whenever 
268 --   it overflows, a flush is issued, or the handle
269 --   is closed.
270 --
271 -- * no-buffering output is written immediately, and never stored
272 --   in the output buffer.
273 --
274 -- The output buffer is emptied as soon as it has been written out.
275
276 -- Similarly, input occurs according to the buffer mode for handle {\em hdl}.
277
278 -- * line-buffering when the input buffer for the handle is not empty,
279 --   the next item is obtained from the buffer;
280 --   otherwise, when the input buffer is empty,
281 --   characters up to and including the next newline
282 --   character are read into the buffer.  No characters
283 --   are available until the newline character is
284 --   available.
285 --
286 -- * block-buffering when the input buffer for the handle becomes empty,
287 --   the next block of data is read into this buffer.
288 --
289 -- * no-buffering the next input item is read and returned.
290
291 -- For most implementations, physical files will normally be block-buffered 
292 -- and terminals will normally be line-buffered. (the IO interface provides
293 -- operations for changing the default buffering of a handle tho.)
294
295 data BufferMode  
296  = NoBuffering | LineBuffering | BlockBuffering (Maybe Int)
297    deriving (Eq, Ord, Read, Show)
298
299 -- ---------------------------------------------------------------------------
300 -- IORefs
301
302 newtype IORef a = IORef (STRef RealWorld a) deriving Eq
303
304 newIORef    :: a -> IO (IORef a)
305 newIORef v = stToIO (newSTRef v) >>= \ var -> return (IORef var)
306
307 readIORef   :: IORef a -> IO a
308 readIORef  (IORef var) = stToIO (readSTRef var)
309
310 writeIORef  :: IORef a -> a -> IO ()
311 writeIORef (IORef var) v = stToIO (writeSTRef var v)
312
313 -- ---------------------------------------------------------------------------
314 -- Show instance for Handles
315
316 -- handle types are 'show'n when printing error msgs, so
317 -- we provide a more user-friendly Show instance for it
318 -- than the derived one.
319
320 instance Show HandleType where
321   showsPrec p t =
322     case t of
323       ClosedHandle      -> showString "closed"
324       SemiClosedHandle  -> showString "semi-closed"
325       ReadHandle        -> showString "readable"
326       WriteHandle       -> showString "writable"
327       AppendHandle      -> showString "writable (append)"
328       ReadWriteHandle   -> showString "read-writable"
329
330 instance Show Handle where 
331   showsPrec p (FileHandle   h)   = showHandle p h False
332   showsPrec p (DuplexHandle _ h) = showHandle p h True
333    
334 showHandle p h duplex =
335     let
336      -- (Big) SIGH: unfolded defn of takeMVar to avoid
337      -- an (oh-so) unfortunate module loop with GHC.Conc.
338      hdl_ = unsafePerformIO (IO $ \ s# ->
339              case h                 of { MVar h# ->
340              case takeMVar# h# s#   of { (# s2# , r #) -> 
341              case putMVar# h# r s2# of { s3# ->
342              (# s3#, r #) }}})
343
344      showType | duplex = showString "duplex (read-write)"
345               | otherwise = showsPrec p (haType hdl_)
346     in
347     showChar '{' . 
348     showHdl (haType hdl_) 
349             (showString "loc=" . showString (haFilePath hdl_) . showChar ',' .
350              showString "type=" . showType . showChar ',' .
351              showString "binary=" . showsPrec p (haIsBin hdl_) . showChar ',' .
352              showString "buffering=" . showBufMode (unsafePerformIO (readIORef (haBuffer hdl_))) (haBufferMode hdl_) . showString "}" )
353    where
354
355     showHdl :: HandleType -> ShowS -> ShowS
356     showHdl ht cont = 
357        case ht of
358         ClosedHandle  -> showsPrec p ht . showString "}"
359         _ -> cont
360        
361     showBufMode :: Buffer -> BufferMode -> ShowS
362     showBufMode buf bmo =
363       case bmo of
364         NoBuffering   -> showString "none"
365         LineBuffering -> showString "line"
366         BlockBuffering (Just n) -> showString "block " . showParen True (showsPrec p n)
367         BlockBuffering Nothing  -> showString "block " . showParen True (showsPrec p def)
368       where
369        def :: Int 
370        def = bufSize buf
371
372 -- ------------------------------------------------------------------------
373 -- Exception datatype and operations
374
375 data Exception
376   = IOException         IOException     -- IO exceptions
377   | ArithException      ArithException  -- Arithmetic exceptions
378   | ArrayException      ArrayException  -- Array-related exceptions
379   | ErrorCall           String          -- Calls to 'error'
380   | ExitException       ExitCode        -- Call to System.exitWith
381   | NoMethodError       String          -- A non-existent method was invoked
382   | PatternMatchFail    String          -- A pattern match / guard failure
383   | RecSelError         String          -- Selecting a non-existent field
384   | RecConError         String          -- Field missing in record construction
385   | RecUpdError         String          -- Record doesn't contain updated field
386   | AssertionFailed     String          -- Assertions
387   | DynException        Dynamic         -- Dynamic exceptions
388   | AsyncException      AsyncException  -- Externally generated errors
389   | BlockedOnDeadMVar                   -- Blocking on a dead MVar
390   | Deadlock                            -- no threads can run (raised in main thread)
391   | NonTermination
392
393 data ArithException
394   = Overflow
395   | Underflow
396   | LossOfPrecision
397   | DivideByZero
398   | Denormal
399   deriving (Eq, Ord)
400
401 data AsyncException
402   = StackOverflow
403   | HeapOverflow
404   | ThreadKilled
405   deriving (Eq, Ord)
406
407 data ArrayException
408   = IndexOutOfBounds    String          -- out-of-range array access
409   | UndefinedElement    String          -- evaluating an undefined element
410   deriving (Eq, Ord)
411
412 stackOverflow, heapOverflow :: Exception -- for the RTS
413 stackOverflow = AsyncException StackOverflow
414 heapOverflow  = AsyncException HeapOverflow
415
416 instance Show ArithException where
417   showsPrec _ Overflow        = showString "arithmetic overflow"
418   showsPrec _ Underflow       = showString "arithmetic underflow"
419   showsPrec _ LossOfPrecision = showString "loss of precision"
420   showsPrec _ DivideByZero    = showString "divide by zero"
421   showsPrec _ Denormal        = showString "denormal"
422
423 instance Show AsyncException where
424   showsPrec _ StackOverflow   = showString "stack overflow"
425   showsPrec _ HeapOverflow    = showString "heap overflow"
426   showsPrec _ ThreadKilled    = showString "thread killed"
427
428 instance Show ArrayException where
429   showsPrec _ (IndexOutOfBounds s)
430         = showString "array index out of range"
431         . (if not (null s) then showString ": " . showString s
432                            else id)
433   showsPrec _ (UndefinedElement s)
434         = showString "undefined array element"
435         . (if not (null s) then showString ": " . showString s
436                            else id)
437
438 instance Show Exception where
439   showsPrec _ (IOException err)          = shows err
440   showsPrec _ (ArithException err)       = shows err
441   showsPrec _ (ArrayException err)       = shows err
442   showsPrec _ (ErrorCall err)            = showString err
443   showsPrec _ (ExitException err)        = showString "exit: " . shows err
444   showsPrec _ (NoMethodError err)        = showString err
445   showsPrec _ (PatternMatchFail err)     = showString err
446   showsPrec _ (RecSelError err)          = showString err
447   showsPrec _ (RecConError err)          = showString err
448   showsPrec _ (RecUpdError err)          = showString err
449   showsPrec _ (AssertionFailed err)      = showString err
450   showsPrec _ (DynException _err)        = showString "unknown exception"
451   showsPrec _ (AsyncException e)         = shows e
452   showsPrec _ (BlockedOnDeadMVar)        = showString "thread blocked indefinitely"
453   showsPrec _ (NonTermination)           = showString "<<loop>>"
454   showsPrec _ (Deadlock)                 = showString "<<deadlock>>"
455
456 instance Eq Exception where
457   IOException e1      == IOException e2      = e1 == e2
458   ArithException e1   == ArithException e2   = e1 == e2
459   ArrayException e1   == ArrayException e2   = e1 == e2
460   ErrorCall e1        == ErrorCall e2        = e1 == e2
461   ExitException e1    == ExitException e2    = e1 == e2
462   NoMethodError e1    == NoMethodError e2    = e1 == e2
463   PatternMatchFail e1 == PatternMatchFail e2 = e1 == e2
464   RecSelError e1      == RecSelError e2      = e1 == e2
465   RecConError e1      == RecConError e2      = e1 == e2
466   RecUpdError e1      == RecUpdError e2      = e1 == e2
467   AssertionFailed e1  == AssertionFailed e2  = e1 == e2
468   DynException _      == DynException _      = False -- incomparable
469   AsyncException e1   == AsyncException e2   = e1 == e2
470   BlockedOnDeadMVar   == BlockedOnDeadMVar   = True
471   NonTermination      == NonTermination      = True
472   Deadlock            == Deadlock            = True
473
474 -- -----------------------------------------------------------------------------
475 -- The ExitCode type
476
477 -- The `ExitCode' type defines the exit codes that a program
478 -- can return.  `ExitSuccess' indicates successful termination;
479 -- and `ExitFailure code' indicates program failure
480 -- with value `code'.  The exact interpretation of `code'
481 -- is operating-system dependent.  In particular, some values of 
482 -- `code' may be prohibited (e.g. 0 on a POSIX-compliant system).
483
484 -- We need it here because it is used in ExitException in the
485 -- Exception datatype (above).
486
487 data ExitCode = ExitSuccess | ExitFailure Int 
488                 deriving (Eq, Ord, Read, Show)
489
490 -- --------------------------------------------------------------------------
491 -- Primitive throw
492
493 throw :: Exception -> a
494 throw exception = raise# exception
495
496 ioError         :: Exception -> IO a 
497 ioError err     =  IO $ \s -> throw err s
498
499 ioException     :: IOException -> IO a
500 ioException err =  IO $ \s -> throw (IOException err) s
501
502 -- ---------------------------------------------------------------------------
503 -- IOError type
504
505 -- A value @IOError@ encode errors occurred in the @IO@ monad.
506 -- An @IOError@ records a more specific error type, a descriptive
507 -- string and maybe the handle that was used when the error was
508 -- flagged.
509
510 type IOError = Exception
511
512 data IOException
513  = IOError {
514      ioe_handle   :: Maybe Handle,   -- the handle used by the action flagging 
515                                      -- the error.
516      ioe_type     :: IOErrorType,    -- what it was.
517      ioe_location :: String,         -- location.
518      ioe_descr    :: String,         -- error type specific information.
519      ioe_filename :: Maybe FilePath  -- filename the error is related to.
520    }
521
522 instance Eq IOException where
523   (IOError h1 e1 loc1 str1 fn1) == (IOError h2 e2 loc2 str2 fn2) = 
524     e1==e2 && str1==str2 && h1==h2 && loc1==loc2 && fn1==fn2
525
526 data IOErrorType
527   -- Haskell 98:
528   = AlreadyExists
529   | NoSuchThing
530   | ResourceBusy
531   | ResourceExhausted
532   | EOF
533   | IllegalOperation
534   | PermissionDenied
535   | UserError
536   -- GHC only:
537   | UnsatisfiedConstraints
538   | SystemError
539   | ProtocolError
540   | OtherError
541   | InvalidArgument
542   | InappropriateType
543   | HardwareFault
544   | UnsupportedOperation
545   | TimeExpired
546   | ResourceVanished
547   | Interrupted
548   | DynIOError Dynamic -- cheap&cheerful extensible IO error type.
549
550 instance Eq IOErrorType where
551    x == y = 
552      case x of
553        DynIOError{} -> False -- from a strictness POV, compatible with a derived Eq inst?
554        _ -> getTag# x ==# getTag# y
555  
556 instance Show IOErrorType where
557   showsPrec _ e =
558     showString $
559     case e of
560       AlreadyExists     -> "already exists"
561       NoSuchThing       -> "does not exist"
562       ResourceBusy      -> "resource busy"
563       ResourceExhausted -> "resource exhausted"
564       EOF               -> "end of file"
565       IllegalOperation  -> "illegal operation"
566       PermissionDenied  -> "permission denied"
567       UserError         -> "user error"
568       HardwareFault     -> "hardware fault"
569       InappropriateType -> "inappropriate type"
570       Interrupted       -> "interrupted"
571       InvalidArgument   -> "invalid argument"
572       OtherError        -> "failed"
573       ProtocolError     -> "protocol error"
574       ResourceVanished  -> "resource vanished"
575       SystemError       -> "system error"
576       TimeExpired       -> "timeout"
577       UnsatisfiedConstraints -> "unsatisified constraints" -- ultra-precise!
578       UnsupportedOperation -> "unsupported operation"
579       DynIOError{}      -> "unknown IO error"
580
581 userError       :: String  -> IOError
582 userError str   =  IOException (IOError Nothing UserError "" str Nothing)
583
584 -- ---------------------------------------------------------------------------
585 -- Showing IOErrors
586
587 instance Show IOException where
588     showsPrec p (IOError hdl iot loc s fn) =
589       showsPrec p iot .
590       (case loc of
591          "" -> id
592          _  -> showString "\nAction: " . showString loc) .
593       (case hdl of
594         Nothing -> id
595         Just h  -> showString "\nHandle: " . showsPrec p h) .
596       (case s of
597          "" -> id
598          _  -> showString "\nReason: " . showString s) .
599       (case fn of
600          Nothing -> id
601          Just name -> showString "\nFile: " . showString name)
602 \end{code}