{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE DeriveGeneric, NoImplicitPrelude, MagicHash,
             ExistentialQuantification, ImplicitParams #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}
{-# OPTIONS_HADDOCK not-home #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.Internal.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
--
-- /The API of this module is unstable and not meant to be consumed by the general public./
-- If you absolutely must depend on it, make sure to use a tight upper
-- bound, e.g., @base < 4.X@ rather than @base < 5@, because the interface can
-- change rapidly without much warning.
--
-----------------------------------------------------------------------------

module GHC.Internal.IO.Exception (
  BlockedIndefinitelyOnMVar(..), blockedIndefinitelyOnMVar,
  BlockedIndefinitelyOnSTM(..), blockedIndefinitelyOnSTM,
  Deadlock(..),
  AllocationLimitExceeded(..), allocationLimitExceeded,
  AssertionFailed(..),
  CompactionFailed(..),
  cannotCompactFunction, cannotCompactPinned, cannotCompactMutable,

  SomeAsyncException(..),
  asyncExceptionToException, asyncExceptionFromException,
  AsyncException(..), stackOverflow, heapOverflow,

  ArrayException(..),
  ExitCode(..),
  FixIOException (..),

  ioException,
  ioError,
  IOError,
  IOException(..),
  IOErrorType(..),
  userError,
  assertError,
  unsupportedOperation,
  untangle,
 ) where

import GHC.Internal.Base
import GHC.Internal.Generics
import GHC.Internal.List
import GHC.Internal.IO
import GHC.Internal.Show
import GHC.Internal.Read
import GHC.Internal.Exception
import GHC.Internal.IO.Handle.Types
import GHC.Internal.Stack.Types (HasCallStack)
import {-# SOURCE #-} GHC.Internal.Stack ( withFrozenCallStack )
import GHC.Internal.Foreign.C.Types

import GHC.Internal.Data.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

-- | @since base-4.1.0.0
instance Exception BlockedIndefinitelyOnMVar

-- | @since base-4.1.0.0
instance Show BlockedIndefinitelyOnMVar where
    showsPrec :: Int -> BlockedIndefinitelyOnMVar -> ShowS
showsPrec Int
_ BlockedIndefinitelyOnMVar
BlockedIndefinitelyOnMVar = String -> ShowS
showString String
"thread blocked indefinitely in an MVar operation"

blockedIndefinitelyOnMVar :: SomeException -- for the RTS
blockedIndefinitelyOnMVar :: SomeException
blockedIndefinitelyOnMVar = BlockedIndefinitelyOnMVar -> SomeException
forall e. Exception e => e -> SomeException
toException BlockedIndefinitelyOnMVar
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

-- | @since base-4.1.0.0
instance Exception BlockedIndefinitelyOnSTM

-- | @since base-4.1.0.0
instance Show BlockedIndefinitelyOnSTM where
    showsPrec :: Int -> BlockedIndefinitelyOnSTM -> ShowS
showsPrec Int
_ BlockedIndefinitelyOnSTM
BlockedIndefinitelyOnSTM = String -> ShowS
showString String
"thread blocked indefinitely in an STM transaction"

blockedIndefinitelyOnSTM :: SomeException -- for the RTS
blockedIndefinitelyOnSTM :: SomeException
blockedIndefinitelyOnSTM = BlockedIndefinitelyOnSTM -> SomeException
forall e. Exception e => e -> SomeException
toException BlockedIndefinitelyOnSTM
BlockedIndefinitelyOnSTM

-----

-- |There are no runnable threads, so the program is deadlocked.
-- The @Deadlock@ exception is raised in the main thread only.
data Deadlock = Deadlock

-- | @since base-4.1.0.0
instance Exception Deadlock where
    displayException :: Deadlock -> String
displayException Deadlock
_ = String
"no threads to run:  infinite loop or deadlock?"

-- | @since base-4.1.0.0
instance Show Deadlock where
    showsPrec :: Int -> Deadlock -> ShowS
showsPrec Int
_ Deadlock
Deadlock = String -> ShowS
showString String
"<<deadlock>>"

-----

-- |This thread has exceeded its allocation limit.  See
-- 'GHC.Internal.System.Mem.setAllocationCounter' and
-- 'GHC.Internal.System.Mem.enableAllocationLimit'.
--
-- @since base-4.8.0.0
data AllocationLimitExceeded = AllocationLimitExceeded

-- | @since base-4.8.0.0
instance Exception AllocationLimitExceeded where
  toException :: AllocationLimitExceeded -> SomeException
toException = AllocationLimitExceeded -> SomeException
forall e. Exception e => e -> SomeException
asyncExceptionToException
  fromException :: SomeException -> Maybe AllocationLimitExceeded
fromException = SomeException -> Maybe AllocationLimitExceeded
forall e. Exception e => SomeException -> Maybe e
asyncExceptionFromException

-- | @since base-4.7.1.0
instance Show AllocationLimitExceeded where
    showsPrec :: Int -> AllocationLimitExceeded -> ShowS
showsPrec Int
_ AllocationLimitExceeded
AllocationLimitExceeded =
      String -> ShowS
showString String
"allocation limit exceeded"

allocationLimitExceeded :: SomeException -- for the RTS
allocationLimitExceeded :: SomeException
allocationLimitExceeded = AllocationLimitExceeded -> SomeException
forall e. Exception e => e -> SomeException
toException AllocationLimitExceeded
AllocationLimitExceeded

-----

-- | Compaction found an object that cannot be compacted.  Functions
-- cannot be compacted, nor can mutable objects or pinned objects.
-- See 'GHC.Compact.compact'.
--
-- @since base-4.10.0.0
newtype CompactionFailed = CompactionFailed String

-- | @since base-4.10.0.0
instance Exception CompactionFailed where

-- | @since base-4.10.0.0
instance Show CompactionFailed where
    showsPrec :: Int -> CompactionFailed -> ShowS
showsPrec Int
_ (CompactionFailed String
why) =
      String -> ShowS
showString (String
"compaction failed: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
why)

cannotCompactFunction :: SomeException -- for the RTS
cannotCompactFunction :: SomeException
cannotCompactFunction =
  CompactionFailed -> SomeException
forall e. Exception e => e -> SomeException
toException (String -> CompactionFailed
CompactionFailed String
"cannot compact functions")

cannotCompactPinned :: SomeException -- for the RTS
cannotCompactPinned :: SomeException
cannotCompactPinned =
  CompactionFailed -> SomeException
forall e. Exception e => e -> SomeException
toException (String -> CompactionFailed
CompactionFailed String
"cannot compact pinned objects")

cannotCompactMutable :: SomeException -- for the RTS
cannotCompactMutable :: SomeException
cannotCompactMutable =
  CompactionFailed -> SomeException
forall e. Exception e => e -> SomeException
toException (String -> CompactionFailed
CompactionFailed String
"cannot compact mutable objects")

-----

-- |'assert' was applied to 'False'.
newtype AssertionFailed = AssertionFailed String

-- | @since base-4.1.0.0
instance Exception AssertionFailed

-- | @since base-4.1.0.0
instance Show AssertionFailed where
    showsPrec :: Int -> AssertionFailed -> ShowS
showsPrec Int
_ (AssertionFailed String
err) = String -> ShowS
showString String
err

-----

-- |Superclass for asynchronous exceptions.
--
-- @since base-4.7.0.0
data SomeAsyncException = forall e . Exception e => SomeAsyncException e

-- | @since base-4.7.0.0
instance Show SomeAsyncException where
    showsPrec :: Int -> SomeAsyncException -> ShowS
showsPrec Int
p (SomeAsyncException e
e) = Int -> e -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
p e
e

-- | @since base-4.7.0.0
instance Exception SomeAsyncException

-- | @since base-4.7.0.0
asyncExceptionToException :: Exception e => e -> SomeException
asyncExceptionToException :: forall e. Exception e => e -> SomeException
asyncExceptionToException = SomeAsyncException -> SomeException
forall e. Exception e => e -> SomeException
toException (SomeAsyncException -> SomeException)
-> (e -> SomeAsyncException) -> e -> SomeException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> SomeAsyncException
forall e. Exception e => e -> SomeAsyncException
SomeAsyncException

-- | @since base-4.7.0.0
asyncExceptionFromException :: Exception e => SomeException -> Maybe e
asyncExceptionFromException :: forall e. Exception e => SomeException -> Maybe e
asyncExceptionFromException SomeException
x = do
    SomeAsyncException a <- SomeException -> Maybe SomeAsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
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 throws this to the same thread that
        --     receives 'UserInterrupt', but this may change in the
        --     future.
        --
        --   * The GHC RTS currently can only recover from heap overflow
        --     if it detects that an explicit memory limit (set via RTS flags).
        --     has been exceeded.  Currently, failure to allocate memory from
        --     the operating system results in immediate termination of the
        --     program.
  | 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 ( AsyncException -> AsyncException -> Bool
(AsyncException -> AsyncException -> Bool)
-> (AsyncException -> AsyncException -> Bool) -> Eq AsyncException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AsyncException -> AsyncException -> Bool
== :: AsyncException -> AsyncException -> Bool
$c/= :: AsyncException -> AsyncException -> Bool
/= :: AsyncException -> AsyncException -> Bool
Eq  -- ^ @since base-4.2.0.0
           , Eq AsyncException
Eq AsyncException =>
(AsyncException -> AsyncException -> Ordering)
-> (AsyncException -> AsyncException -> Bool)
-> (AsyncException -> AsyncException -> Bool)
-> (AsyncException -> AsyncException -> Bool)
-> (AsyncException -> AsyncException -> Bool)
-> (AsyncException -> AsyncException -> AsyncException)
-> (AsyncException -> AsyncException -> AsyncException)
-> Ord AsyncException
AsyncException -> AsyncException -> Bool
AsyncException -> AsyncException -> Ordering
AsyncException -> AsyncException -> AsyncException
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: AsyncException -> AsyncException -> Ordering
compare :: AsyncException -> AsyncException -> Ordering
$c< :: AsyncException -> AsyncException -> Bool
< :: AsyncException -> AsyncException -> Bool
$c<= :: AsyncException -> AsyncException -> Bool
<= :: AsyncException -> AsyncException -> Bool
$c> :: AsyncException -> AsyncException -> Bool
> :: AsyncException -> AsyncException -> Bool
$c>= :: AsyncException -> AsyncException -> Bool
>= :: AsyncException -> AsyncException -> Bool
$cmax :: AsyncException -> AsyncException -> AsyncException
max :: AsyncException -> AsyncException -> AsyncException
$cmin :: AsyncException -> AsyncException -> AsyncException
min :: AsyncException -> AsyncException -> AsyncException
Ord -- ^ @since base-4.2.0.0
           )

-- | @since base-4.7.0.0
instance Exception AsyncException where
  toException :: AsyncException -> SomeException
toException = AsyncException -> SomeException
forall e. Exception e => e -> SomeException
asyncExceptionToException
  fromException :: SomeException -> Maybe AsyncException
fromException = SomeException -> Maybe AsyncException
forall e. Exception e => SomeException -> Maybe e
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 ( ArrayException -> ArrayException -> Bool
(ArrayException -> ArrayException -> Bool)
-> (ArrayException -> ArrayException -> Bool) -> Eq ArrayException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ArrayException -> ArrayException -> Bool
== :: ArrayException -> ArrayException -> Bool
$c/= :: ArrayException -> ArrayException -> Bool
/= :: ArrayException -> ArrayException -> Bool
Eq  -- ^ @since base-4.2.0.0
           , Eq ArrayException
Eq ArrayException =>
(ArrayException -> ArrayException -> Ordering)
-> (ArrayException -> ArrayException -> Bool)
-> (ArrayException -> ArrayException -> Bool)
-> (ArrayException -> ArrayException -> Bool)
-> (ArrayException -> ArrayException -> Bool)
-> (ArrayException -> ArrayException -> ArrayException)
-> (ArrayException -> ArrayException -> ArrayException)
-> Ord ArrayException
ArrayException -> ArrayException -> Bool
ArrayException -> ArrayException -> Ordering
ArrayException -> ArrayException -> ArrayException
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ArrayException -> ArrayException -> Ordering
compare :: ArrayException -> ArrayException -> Ordering
$c< :: ArrayException -> ArrayException -> Bool
< :: ArrayException -> ArrayException -> Bool
$c<= :: ArrayException -> ArrayException -> Bool
<= :: ArrayException -> ArrayException -> Bool
$c> :: ArrayException -> ArrayException -> Bool
> :: ArrayException -> ArrayException -> Bool
$c>= :: ArrayException -> ArrayException -> Bool
>= :: ArrayException -> ArrayException -> Bool
$cmax :: ArrayException -> ArrayException -> ArrayException
max :: ArrayException -> ArrayException -> ArrayException
$cmin :: ArrayException -> ArrayException -> ArrayException
min :: ArrayException -> ArrayException -> ArrayException
Ord -- ^ @since base-4.2.0.0
           )

-- | @since base-4.1.0.0
instance Exception ArrayException

-- for the RTS
stackOverflow, heapOverflow :: SomeException
stackOverflow :: SomeException
stackOverflow = AsyncException -> SomeException
forall e. Exception e => e -> SomeException
toException AsyncException
StackOverflow
heapOverflow :: SomeException
heapOverflow  = AsyncException -> SomeException
forall e. Exception e => e -> SomeException
toException AsyncException
HeapOverflow

-- | @since base-4.1.0.0
instance Show AsyncException where
  showsPrec :: Int -> AsyncException -> ShowS
showsPrec Int
_ AsyncException
StackOverflow   = String -> ShowS
showString String
"stack overflow"
  showsPrec Int
_ AsyncException
HeapOverflow    = String -> ShowS
showString String
"heap overflow"
  showsPrec Int
_ AsyncException
ThreadKilled    = String -> ShowS
showString String
"thread killed"
  showsPrec Int
_ AsyncException
UserInterrupt   = String -> ShowS
showString String
"user interrupt"

-- | @since base-4.1.0.0
instance Show ArrayException where
  showsPrec :: Int -> ArrayException -> ShowS
showsPrec Int
_ (IndexOutOfBounds String
s)
        = String -> ShowS
showString String
"array index out of range"
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool -> Bool
not (String -> Bool
forall a. [a] -> Bool
null String
s) then String -> ShowS
showString String
": " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
s
                           else ShowS
forall a. a -> a
id)
  showsPrec Int
_ (UndefinedElement String
s)
        = String -> ShowS
showString String
"undefined array element"
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if Bool -> Bool
not (String -> Bool
forall a. [a] -> Bool
null String
s) then String -> ShowS
showString String
": " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
s
                           else ShowS
forall a. a -> a
id)

-- | The exception thrown when an infinite cycle is detected in
-- 'GHC.Internal.System.IO.fixIO'.
--
-- @since base-4.11.0.0
data FixIOException = FixIOException

-- | @since base-4.11.0.0
instance Exception FixIOException

-- | @since base-4.11.0.0
instance Show FixIOException where
  showsPrec :: Int -> FixIOException -> ShowS
showsPrec Int
_ FixIOException
FixIOException = String -> ShowS
showString String
"cyclic evaluation in fixIO"

-- -----------------------------------------------------------------------------
-- 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 (ExitCode -> ExitCode -> Bool
(ExitCode -> ExitCode -> Bool)
-> (ExitCode -> ExitCode -> Bool) -> Eq ExitCode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ExitCode -> ExitCode -> Bool
== :: ExitCode -> ExitCode -> Bool
$c/= :: ExitCode -> ExitCode -> Bool
/= :: ExitCode -> ExitCode -> Bool
Eq, Eq ExitCode
Eq ExitCode =>
(ExitCode -> ExitCode -> Ordering)
-> (ExitCode -> ExitCode -> Bool)
-> (ExitCode -> ExitCode -> Bool)
-> (ExitCode -> ExitCode -> Bool)
-> (ExitCode -> ExitCode -> Bool)
-> (ExitCode -> ExitCode -> ExitCode)
-> (ExitCode -> ExitCode -> ExitCode)
-> Ord ExitCode
ExitCode -> ExitCode -> Bool
ExitCode -> ExitCode -> Ordering
ExitCode -> ExitCode -> ExitCode
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ExitCode -> ExitCode -> Ordering
compare :: ExitCode -> ExitCode -> Ordering
$c< :: ExitCode -> ExitCode -> Bool
< :: ExitCode -> ExitCode -> Bool
$c<= :: ExitCode -> ExitCode -> Bool
<= :: ExitCode -> ExitCode -> Bool
$c> :: ExitCode -> ExitCode -> Bool
> :: ExitCode -> ExitCode -> Bool
$c>= :: ExitCode -> ExitCode -> Bool
>= :: ExitCode -> ExitCode -> Bool
$cmax :: ExitCode -> ExitCode -> ExitCode
max :: ExitCode -> ExitCode -> ExitCode
$cmin :: ExitCode -> ExitCode -> ExitCode
min :: ExitCode -> ExitCode -> ExitCode
Ord, ReadPrec [ExitCode]
ReadPrec ExitCode
Int -> ReadS ExitCode
ReadS [ExitCode]
(Int -> ReadS ExitCode)
-> ReadS [ExitCode]
-> ReadPrec ExitCode
-> ReadPrec [ExitCode]
-> Read ExitCode
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS ExitCode
readsPrec :: Int -> ReadS ExitCode
$creadList :: ReadS [ExitCode]
readList :: ReadS [ExitCode]
$creadPrec :: ReadPrec ExitCode
readPrec :: ReadPrec ExitCode
$creadListPrec :: ReadPrec [ExitCode]
readListPrec :: ReadPrec [ExitCode]
Read, Int -> ExitCode -> ShowS
[ExitCode] -> ShowS
ExitCode -> String
(Int -> ExitCode -> ShowS)
-> (ExitCode -> String) -> ([ExitCode] -> ShowS) -> Show ExitCode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ExitCode -> ShowS
showsPrec :: Int -> ExitCode -> ShowS
$cshow :: ExitCode -> String
show :: ExitCode -> String
$cshowList :: [ExitCode] -> ShowS
showList :: [ExitCode] -> ShowS
Show, (forall x. ExitCode -> Rep ExitCode x)
-> (forall x. Rep ExitCode x -> ExitCode) -> Generic ExitCode
forall x. Rep ExitCode x -> ExitCode
forall x. ExitCode -> Rep ExitCode x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ExitCode -> Rep ExitCode x
from :: forall x. ExitCode -> Rep ExitCode x
$cto :: forall x. Rep ExitCode x -> ExitCode
to :: forall x. Rep ExitCode x -> ExitCode
Generic)

-- | @since base-4.1.0.0
instance Exception ExitCode

ioException     :: HasCallStack => IOException -> IO a
ioException :: forall a. HasCallStack => IOException -> IO a
ioException IOException
err = (HasCallStack => IO a) -> IO a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => IO a) -> IO a) -> (HasCallStack => IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ IOException -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO IOException
err

-- | Raise an 'IOError' in the 'IO' monad.
ioError         :: HasCallStack => IOError -> IO a
ioError :: forall a. HasCallStack => IOException -> IO a
ioError         =  (HasCallStack => IOException -> IO a) -> IOException -> IO a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack HasCallStack => IOException -> IO a
IOException -> IO a
forall a. HasCallStack => IOException -> IO a
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 {
     IOException -> Maybe Handle
ioe_handle   :: Maybe Handle,   -- ^ the handle used by the action flagging
                                     --   the error.
     IOException -> IOErrorType
ioe_type     :: IOErrorType,    -- ^ what it was.
     IOException -> String
ioe_location :: String,         -- ^ location.
     IOException -> String
ioe_description :: String,      -- ^ error type specific information.
     IOException -> Maybe CInt
ioe_errno    :: Maybe CInt,     -- ^ errno leading to this error, if any.
     IOException -> Maybe String
ioe_filename :: Maybe FilePath  -- ^ filename the error is related to
                                     --   (some libraries may assume different encodings
                                     --   when constructing this field from e.g. 'ByteString'
                                     --   or other types)
   }

-- | @since base-4.1.0.0
instance Exception IOException

-- | @since base-4.1.0.0
instance Eq IOException where
  (IOError Maybe Handle
h1 IOErrorType
e1 String
loc1 String
str1 Maybe CInt
en1 Maybe String
fn1) == :: IOException -> IOException -> Bool
== (IOError Maybe Handle
h2 IOErrorType
e2 String
loc2 String
str2 Maybe CInt
en2 Maybe String
fn2) =
    IOErrorType
e1IOErrorType -> IOErrorType -> Bool
forall a. Eq a => a -> a -> Bool
==IOErrorType
e2 Bool -> Bool -> Bool
&& String
str1String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
str2 Bool -> Bool -> Bool
&& Maybe Handle
h1Maybe Handle -> Maybe Handle -> Bool
forall a. Eq a => a -> a -> Bool
==Maybe Handle
h2 Bool -> Bool -> Bool
&& String
loc1String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
loc2 Bool -> Bool -> Bool
&& Maybe CInt
en1Maybe CInt -> Maybe CInt -> Bool
forall a. Eq a => a -> a -> Bool
==Maybe CInt
en2 Bool -> Bool -> Bool
&& Maybe String
fn1Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
==Maybe String
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

-- | @since base-4.1.0.0
instance Eq IOErrorType where
   IOErrorType
x == :: IOErrorType -> IOErrorType -> Bool
== IOErrorType
y = Int# -> Bool
isTrue# (IOErrorType -> Int#
forall a. DataToTag a => a -> Int#
getTag IOErrorType
x Int# -> Int# -> Int#
==# IOErrorType -> Int#
forall a. DataToTag a => a -> Int#
getTag IOErrorType
y)

-- | @since base-4.1.0.0
instance Show IOErrorType where
  showsPrec :: Int -> IOErrorType -> ShowS
showsPrec Int
_ IOErrorType
e =
    String -> ShowS
showString (String -> ShowS) -> String -> ShowS
forall a b. (a -> b) -> a -> b
$
    case IOErrorType
e of
      IOErrorType
AlreadyExists     -> String
"already exists"
      IOErrorType
NoSuchThing       -> String
"does not exist"
      IOErrorType
ResourceBusy      -> String
"resource busy"
      IOErrorType
ResourceExhausted -> String
"resource exhausted"
      IOErrorType
EOF               -> String
"end of file"
      IOErrorType
IllegalOperation  -> String
"illegal operation"
      IOErrorType
PermissionDenied  -> String
"permission denied"
      IOErrorType
UserError         -> String
"user error"
      IOErrorType
HardwareFault     -> String
"hardware fault"
      IOErrorType
InappropriateType -> String
"inappropriate type"
      IOErrorType
Interrupted       -> String
"interrupted"
      IOErrorType
InvalidArgument   -> String
"invalid argument"
      IOErrorType
OtherError        -> String
"failed"
      IOErrorType
ProtocolError     -> String
"protocol error"
      IOErrorType
ResourceVanished  -> String
"resource vanished"
      IOErrorType
SystemError       -> String
"system error"
      IOErrorType
TimeExpired       -> String
"timeout"
      IOErrorType
UnsatisfiedConstraints -> String
"unsatisfied constraints" -- ultra-precise!
      IOErrorType
UnsupportedOperation -> String
"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 :: String -> IOException
userError String
str   =  Maybe Handle
-> IOErrorType
-> String
-> String
-> Maybe CInt
-> Maybe String
-> IOException
IOError Maybe Handle
forall a. Maybe a
Nothing IOErrorType
UserError String
"" String
str Maybe CInt
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing

-- ---------------------------------------------------------------------------
-- Showing IOErrors

-- | @since base-4.1.0.0
instance Show IOException where
    showsPrec :: Int -> IOException -> ShowS
showsPrec Int
p (IOError Maybe Handle
hdl IOErrorType
iot String
loc String
s Maybe CInt
_ Maybe String
fn) =
      (case Maybe String
fn of
         Maybe String
Nothing -> case Maybe Handle
hdl of
                        Maybe Handle
Nothing -> ShowS
forall a. a -> a
id
                        Just Handle
h  -> Int -> Handle -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
p Handle
h ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
": "
         Just String
name -> String -> ShowS
showString String
name ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
": ") ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      (case String
loc of
         String
"" -> ShowS
forall a. a -> a
id
         String
_  -> String -> ShowS
showString String
loc ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
": ") ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      Int -> IOErrorType -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
p IOErrorType
iot ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      (case String
s of
         String
"" -> ShowS
forall a. a -> a
id
         String
_  -> String -> ShowS
showString String
" (" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
s ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
")")

assertError :: (?callStack :: CallStack) => Bool -> a -> a
assertError :: forall a. HasCallStack => Bool -> a -> a
assertError Bool
predicate a
v
  | Bool
predicate = a
v
  | Bool
otherwise = a -> a
forall a. a -> a
lazy (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ IO a -> a
forall a. IO a -> a
unsafeDupablePerformIO (IO a -> a) -> IO a -> a
forall a b. (a -> b) -> a -> b
$ do -- lazy: See Note [Strictness of assertError]
    AssertionFailed -> IO a
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (String -> AssertionFailed
AssertionFailed String
"Assertion failed")

{- Note [Strictness of assertError]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
It is vital that Demand Analysis does not see `assertError p e` as strict in e.
#5561 details what happens otherwise, tested by libraries/base/tests/assert.hs:

  let e1 i = throw Overflow
  in assertError False (e1 5)

This should *not* throw the Overflow exception; rather it should throw an
AssertionError.
Hence we use GHC.Exts.lazy to make assertError appear lazy in e, so that it
is not called by-value.
(Note that the reason we need `lazy` in the first place is that error has a
bottoming result, which is strict in all free variables.)
The way we achieve this is a bit subtle; before #24625 we defined it as

  assertError p e | p         = lazy e
                  | otherwise = error "assertion"

but this means that in the following example (full code in T24625) we cannot
cancel away the allocation of `Just x` because of the intervening `lazy`:

  case assertError False (Just x) of Just y -> y
  ==> { simplify }
  case lazy (Just x) of Just y -> y

Instead, we put `lazy` in the otherwise branch, thus

  assertError p e | p         = e
                  | otherwise = lazy $ error "assertion"

The effect on #5561 is the same: since the otherwise branch appears lazy in e,
the overall demand on `e` must be lazy as well.
Furthermore, since there is no intervening `lazy` on the expected code path,
the Simplifier may perform case-of-case on e and simplify the `Just x` example
to `x`.
-}

unsupportedOperation :: IOError
unsupportedOperation :: IOException
unsupportedOperation =
   (Maybe Handle
-> IOErrorType
-> String
-> String
-> Maybe CInt
-> Maybe String
-> IOException
IOError Maybe Handle
forall a. Maybe a
Nothing IOErrorType
UnsupportedOperation String
""
        String
"Operation is not supported" Maybe CInt
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing)

{-
(untangle coded message) expects "coded" to be of the form
        "location|details"
It prints
        location message details
-}
untangle :: Addr# -> String -> String
untangle :: Addr# -> ShowS
untangle Addr#
coded String
message
  =  String
location
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": "
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
message
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
details
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n"
  where
    coded_str :: String
coded_str = Addr# -> String
unpackCStringUtf8# Addr#
coded

    (String
location, String
details)
      = case ((Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
not_bar String
coded_str) of { (String
loc, String
rest) ->
        case String
rest of
          (Char
'|':String
det) -> (String
loc, Char
' ' Char -> ShowS
forall a. a -> [a] -> [a]
: String
det)
          String
_         -> (String
loc, String
"")
        }
    not_bar :: Char -> Bool
not_bar Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'|'