    {-# LANGUAGE Trustworthy #-}
    {-# LANGUAGE NoImplicitPrelude, AutoDeriveTypeable, 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(..),
      AllocationLimitExceeded(..), allocationLimitExceeded,
      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 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>>"

    -----

    -- |This thread has exceeded its allocation limit.  See
    -- 'GHC.Conc.setAllocationCounter' and
    -- 'GHC.Conc.enableAllocationLimit'.
    --
    -- @since 4.8.0.0
    data AllocationLimitExceeded = AllocationLimitExceeded
        deriving Typeable

    instance Exception AllocationLimitExceeded where
      toException = asyncExceptionToException
      fromException = asyncExceptionFromException

    instance Show AllocationLimitExceeded where
        showsPrec _ AllocationLimitExceeded =
          showString "allocation limit exceeded"

    allocationLimitExceeded :: SomeException -- for the RTS
    allocationLimitExceeded = toException AllocationLimitExceeded

    -----

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

    -- for the RTS
    stackOverflow, heapOverflow :: SomeException
    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 -> "unsatisfied 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 /= '|'