GHC/IO/Exception.hs

{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude, DeriveDataTypeable, MagicHash,
 ExistentialQuantification #-}
{-# OPTIONS_GHC -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 (
 BlockedIndefinitelyOnMVar(..), blockedIndefinitelyOnMVar,
 BlockedIndefinitelyOnSTM(..), blockedIndefinitelyOnSTM,
 Deadlock(..),
 AssertionFailed(..),

 SomeAsyncException(..),
 asyncExceptionToException, asyncExceptionFromException,
 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, cast )

-- ------------------------------------------------------------------------
-- 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 BlockedIndefinitelyOnMVar = BlockedIndefinitelyOnMVar
 deriving Typeable

instance Exception BlockedIndefinitelyOnMVar

instance Show BlockedIndefinitelyOnMVar where
 showsPrec _ BlockedIndefinitelyOnMVar = showString "thread blocked indefinitely in an MVar operation"

blockedIndefinitelyOnMVar :: SomeException -- for the RTS
blockedIndefinitelyOnMVar = toException BlockedIndefinitelyOnMVar

-----

-- |The thread is waiting to retry an STM transaction, but there are no
-- other references to any @TVar@s involved, so it can't ever continue.
data BlockedIndefinitelyOnSTM = BlockedIndefinitelyOnSTM
 deriving Typeable

instance Exception BlockedIndefinitelyOnSTM

instance Show BlockedIndefinitelyOnSTM where
 showsPrec _ BlockedIndefinitelyOnSTM = showString "thread blocked indefinitely in an STM transaction"

blockedIndefinitelyOnSTM :: SomeException -- for the RTS
blockedIndefinitelyOnSTM = toException BlockedIndefinitelyOnSTM

-----

-- |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>>"

-----

-- |'assert' was applied to 'False'.
data AssertionFailed = AssertionFailed String
 deriving Typeable

instance Exception AssertionFailed

instance Show AssertionFailed where
 showsPrec _ (AssertionFailed err) = showString err

-----

-- |Superclass for asynchronous exceptions.
--
-- /Since: 4.7.0.0/
data SomeAsyncException = forall e . Exception e => SomeAsyncException e
 deriving Typeable

instance Show SomeAsyncException where
 show (SomeAsyncException e) = show e

 instance Exception SomeAsyncException

-- |/Since: 4.7.0.0/
asyncExceptionToException :: Exception e => e -> SomeException
asyncExceptionToException = toException . SomeAsyncException

-- |/Since: 4.7.0.0/
asyncExceptionFromException :: Exception e => SomeException -> Maybe e
asyncExceptionFromException x = do
 SomeAsyncException a <- fromException x
 cast a


-- |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 where
 toException = asyncExceptionToException
 fromException = asyncExceptionFromException

-- | 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).

-- | Defines the exit codes that a program can return.
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 2010 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 2010, 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 2010:
 = 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 = isTrue# (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 ")")

-- Note the use of "lazy". This means that
-- assert False (throw e)
-- will throw the assertion failure rather than e. See trac #5561.
assertError :: Addr# -> Bool -> a -> a
assertError str predicate v
 | predicate = lazy 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 /= '|'