--- /dev/null
+{-# OPTIONS_GHC -fno-implicit-prelude -funbox-strict-fields #-}
+{-# OPTIONS_HADDOCK hide #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : GHC.IO.Exception
+-- Copyright : (c) The University of Glasgow, 2009
+-- License : see libraries/base/LICENSE
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : internal
+-- Portability : non-portable
+--
+-- IO-related Exception types and functions
+--
+-----------------------------------------------------------------------------
+
+module GHC.IO.Exception (
+ BlockedOnDeadMVar(..), blockedOnDeadMVar,
+ BlockedIndefinitely(..), blockedIndefinitely,
+ Deadlock(..),
+ AssertionFailed(..),
+ AsyncException(..), stackOverflow, heapOverflow,
+ ArrayException(..),
+ ExitCode(..),
+
+ ioException,
+ ioError,
+ IOError,
+ IOException(..),
+ IOErrorType(..),
+ userError,
+ assertError,
+ unsupportedOperation,
+ untangle,
+ ) where
+
+import GHC.Base
+import GHC.List
+import GHC.IO
+import GHC.Show
+import GHC.Read
+import GHC.Exception
+import Data.Maybe
+import GHC.IO.Handle.Types
+import Foreign.C.Types
+
+import Data.Typeable ( Typeable )
+
+-- ------------------------------------------------------------------------
+-- Exception datatypes and operations
+
+-- |The thread is blocked on an @MVar@, but there are no other references
+-- to the @MVar@ so it can't ever continue.
+data BlockedOnDeadMVar = BlockedOnDeadMVar
+ deriving Typeable
+
+instance Exception BlockedOnDeadMVar
+
+instance Show BlockedOnDeadMVar where
+ showsPrec _ BlockedOnDeadMVar = showString "thread blocked indefinitely"
+
+blockedOnDeadMVar :: SomeException -- for the RTS
+blockedOnDeadMVar = toException BlockedOnDeadMVar
+
+-----
+
+-- |The thread is awiting to retry an STM transaction, but there are no
+-- other references to any @TVar@s involved, so it can't ever continue.
+data BlockedIndefinitely = BlockedIndefinitely
+ deriving Typeable
+
+instance Exception BlockedIndefinitely
+
+instance Show BlockedIndefinitely where
+ showsPrec _ BlockedIndefinitely = showString "thread blocked indefinitely"
+
+blockedIndefinitely :: SomeException -- for the RTS
+blockedIndefinitely = toException BlockedIndefinitely
+
+-----
+
+-- |There are no runnable threads, so the program is deadlocked.
+-- The @Deadlock@ exception is raised in the main thread only.
+data Deadlock = Deadlock
+ deriving Typeable
+
+instance Exception Deadlock
+
+instance Show Deadlock where
+ showsPrec _ Deadlock = showString "<<deadlock>>"
+
+-----
+
+-- |There are no runnable threads, so the program is deadlocked.
+-- The @Deadlock@ exception is raised in the main thread only.
+data AssertionFailed = AssertionFailed String
+ deriving Typeable
+
+instance Exception AssertionFailed
+
+instance Show AssertionFailed where
+ showsPrec _ (AssertionFailed err) = showString err
+
+-----
+
+-- |Asynchronous exceptions.
+data AsyncException
+ = StackOverflow
+ -- ^The current thread\'s stack exceeded its limit.
+ -- Since an exception has been raised, the thread\'s stack
+ -- will certainly be below its limit again, but the
+ -- programmer should take remedial action
+ -- immediately.
+ | HeapOverflow
+ -- ^The program\'s heap is reaching its limit, and
+ -- the program should take action to reduce the amount of
+ -- live data it has. Notes:
+ --
+ -- * It is undefined which thread receives this exception.
+ --
+ -- * GHC currently does not throw 'HeapOverflow' exceptions.
+ | ThreadKilled
+ -- ^This exception is raised by another thread
+ -- calling 'Control.Concurrent.killThread', or by the system
+ -- if it needs to terminate the thread for some
+ -- reason.
+ | UserInterrupt
+ -- ^This exception is raised by default in the main thread of
+ -- the program when the user requests to terminate the program
+ -- via the usual mechanism(s) (e.g. Control-C in the console).
+ deriving (Eq, Ord, Typeable)
+
+instance Exception AsyncException
+
+-- | Exceptions generated by array operations
+data ArrayException
+ = IndexOutOfBounds String
+ -- ^An attempt was made to index an array outside
+ -- its declared bounds.
+ | UndefinedElement String
+ -- ^An attempt was made to evaluate an element of an
+ -- array that had not been initialized.
+ deriving (Eq, Ord, Typeable)
+
+instance Exception ArrayException
+
+stackOverflow, heapOverflow :: SomeException -- for the RTS
+stackOverflow = toException StackOverflow
+heapOverflow = toException HeapOverflow
+
+instance Show AsyncException where
+ showsPrec _ StackOverflow = showString "stack overflow"
+ showsPrec _ HeapOverflow = showString "heap overflow"
+ showsPrec _ ThreadKilled = showString "thread killed"
+ showsPrec _ UserInterrupt = showString "user interrupt"
+
+instance Show ArrayException where
+ showsPrec _ (IndexOutOfBounds s)
+ = showString "array index out of range"
+ . (if not (null s) then showString ": " . showString s
+ else id)
+ showsPrec _ (UndefinedElement s)
+ = showString "undefined array element"
+ . (if not (null s) then showString ": " . showString s
+ else id)
+
+-- -----------------------------------------------------------------------------
+-- The ExitCode type
+
+-- We need it here because it is used in ExitException in the
+-- Exception datatype (above).
+
+data ExitCode
+ = ExitSuccess -- ^ indicates successful termination;
+ | ExitFailure Int
+ -- ^ indicates program failure with an exit code.
+ -- The exact interpretation of the code is
+ -- operating-system dependent. In particular, some values
+ -- may be prohibited (e.g. 0 on a POSIX-compliant system).
+ deriving (Eq, Ord, Read, Show, Typeable)
+
+instance Exception ExitCode
+
+ioException :: IOException -> IO a
+ioException err = throwIO err
+
+-- | Raise an 'IOError' in the 'IO' monad.
+ioError :: IOError -> IO a
+ioError = ioException
+
+-- ---------------------------------------------------------------------------
+-- IOError type
+
+-- | The Haskell 98 type for exceptions in the 'IO' monad.
+-- Any I\/O operation may raise an 'IOError' instead of returning a result.
+-- For a more general type of exception, including also those that arise
+-- in pure code, see 'Control.Exception.Exception'.
+--
+-- In Haskell 98, this is an opaque type.
+type IOError = IOException
+
+-- |Exceptions that occur in the @IO@ monad.
+-- An @IOException@ records a more specific error type, a descriptive
+-- string and maybe the handle that was used when the error was
+-- flagged.
+data IOException
+ = IOError {
+ ioe_handle :: Maybe Handle, -- the handle used by the action flagging
+ -- the error.
+ ioe_type :: IOErrorType, -- what it was.
+ ioe_location :: String, -- location.
+ ioe_description :: String, -- error type specific information.
+ ioe_errno :: Maybe CInt, -- errno leading to this error, if any.
+ ioe_filename :: Maybe FilePath -- filename the error is related to.
+ }
+ deriving Typeable
+
+instance Exception IOException
+
+instance Eq IOException where
+ (IOError h1 e1 loc1 str1 en1 fn1) == (IOError h2 e2 loc2 str2 en2 fn2) =
+ e1==e2 && str1==str2 && h1==h2 && loc1==loc2 && en1==en2 && fn1==fn2
+
+-- | An abstract type that contains a value for each variant of 'IOError'.
+data IOErrorType
+ -- Haskell 98:
+ = AlreadyExists
+ | NoSuchThing
+ | ResourceBusy
+ | ResourceExhausted
+ | EOF
+ | IllegalOperation
+ | PermissionDenied
+ | UserError
+ -- GHC only:
+ | UnsatisfiedConstraints
+ | SystemError
+ | ProtocolError
+ | OtherError
+ | InvalidArgument
+ | InappropriateType
+ | HardwareFault
+ | UnsupportedOperation
+ | TimeExpired
+ | ResourceVanished
+ | Interrupted
+
+instance Eq IOErrorType where
+ x == y = getTag x ==# getTag y
+
+instance Show IOErrorType where
+ showsPrec _ e =
+ showString $
+ case e of
+ AlreadyExists -> "already exists"
+ NoSuchThing -> "does not exist"
+ ResourceBusy -> "resource busy"
+ ResourceExhausted -> "resource exhausted"
+ EOF -> "end of file"
+ IllegalOperation -> "illegal operation"
+ PermissionDenied -> "permission denied"
+ UserError -> "user error"
+ HardwareFault -> "hardware fault"
+ InappropriateType -> "inappropriate type"
+ Interrupted -> "interrupted"
+ InvalidArgument -> "invalid argument"
+ OtherError -> "failed"
+ ProtocolError -> "protocol error"
+ ResourceVanished -> "resource vanished"
+ SystemError -> "system error"
+ TimeExpired -> "timeout"
+ UnsatisfiedConstraints -> "unsatisified constraints" -- ultra-precise!
+ UnsupportedOperation -> "unsupported operation"
+
+-- | Construct an 'IOError' value with a string describing the error.
+-- The 'fail' method of the 'IO' instance of the 'Monad' class raises a
+-- 'userError', thus:
+--
+-- > instance Monad IO where
+-- > ...
+-- > fail s = ioError (userError s)
+--
+userError :: String -> IOError
+userError str = IOError Nothing UserError "" str Nothing Nothing
+
+-- ---------------------------------------------------------------------------
+-- Showing IOErrors
+
+instance Show IOException where
+ showsPrec p (IOError hdl iot loc s _ fn) =
+ (case fn of
+ Nothing -> case hdl of
+ Nothing -> id
+ Just h -> showsPrec p h . showString ": "
+ Just name -> showString name . showString ": ") .
+ (case loc of
+ "" -> id
+ _ -> showString loc . showString ": ") .
+ showsPrec p iot .
+ (case s of
+ "" -> id
+ _ -> showString " (" . showString s . showString ")")
+
+assertError :: Addr# -> Bool -> a -> a
+assertError str predicate v
+ | predicate = v
+ | otherwise = throw (AssertionFailed (untangle str "Assertion failed"))
+
+unsupportedOperation :: IOError
+unsupportedOperation =
+ (IOError Nothing UnsupportedOperation ""
+ "Operation is not supported" Nothing Nothing)
+
+{-
+(untangle coded message) expects "coded" to be of the form
+ "location|details"
+It prints
+ location message details
+-}
+untangle :: Addr# -> String -> String
+untangle coded message
+ = location
+ ++ ": "
+ ++ message
+ ++ details
+ ++ "\n"
+ where
+ coded_str = unpackCStringUtf8# coded
+
+ (location, details)
+ = case (span not_bar coded_str) of { (loc, rest) ->
+ case rest of
+ ('|':det) -> (loc, ' ' : det)
+ _ -> (loc, "")
+ }
+ not_bar c = c /= '|'
projects / ghc-base.git / blobdiff