GHC/IOBase.lhs

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