(original) (raw)

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

module GHC.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.Base import GHC.Generics import GHC.List import GHC.IO import GHC.Show import GHC.Read import GHC.Exception import GHC.IO.Handle.Types import GHC.OldList ( intercalate ) import {-# SOURCE #-} GHC.Stack.CCS import Foreign.C.Types

import Data.Typeable ( cast )

data BlockedIndefinitelyOnMVar = BlockedIndefinitelyOnMVar

instance Exception BlockedIndefinitelyOnMVar

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

blockedIndefinitelyOnMVar :: SomeException blockedIndefinitelyOnMVar = toException BlockedIndefinitelyOnMVar

data BlockedIndefinitelyOnSTM = BlockedIndefinitelyOnSTM

instance Exception BlockedIndefinitelyOnSTM

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

blockedIndefinitelyOnSTM :: SomeException blockedIndefinitelyOnSTM = toException BlockedIndefinitelyOnSTM

data Deadlock = Deadlock

instance Exception Deadlock

instance Show Deadlock where showsPrec _ Deadlock = showString "<>"

data AllocationLimitExceeded = AllocationLimitExceeded

instance Exception AllocationLimitExceeded where toException = asyncExceptionToException fromException = asyncExceptionFromException

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

allocationLimitExceeded :: SomeException allocationLimitExceeded = toException AllocationLimitExceeded

newtype CompactionFailed = CompactionFailed String

instance Exception CompactionFailed where

instance Show CompactionFailed where showsPrec _ (CompactionFailed why) = showString ("compaction failed: " ++ why)

cannotCompactFunction :: SomeException cannotCompactFunction = toException (CompactionFailed "cannot compact functions")

cannotCompactPinned :: SomeException cannotCompactPinned = toException (CompactionFailed "cannot compact pinned objects")

cannotCompactMutable :: SomeException cannotCompactMutable = toException (CompactionFailed "cannot compact mutable objects")

newtype AssertionFailed = AssertionFailed String

instance Exception AssertionFailed

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

data SomeAsyncException = forall e . Exception e => SomeAsyncException e

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

instance Exception SomeAsyncException

asyncExceptionToException :: Exception e => e -> SomeException asyncExceptionToException = toException . SomeAsyncException

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

data AsyncException = StackOverflow

| HeapOverflow

| ThreadKilled

| UserInterrupt

deriving ( Eq
, Ord )

instance Exception AsyncException where toException = asyncExceptionToException fromException = asyncExceptionFromException

data ArrayException = IndexOutOfBounds String

| UndefinedElement String

deriving ( Eq
, Ord )

instance Exception ArrayException

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)

data FixIOException = FixIOException

instance Exception FixIOException

instance Show FixIOException where showsPrec _ FixIOException = showString "cyclic evaluation in fixIO"

data ExitCode = ExitSuccess | ExitFailure Int

deriving (Eq, Ord, Read, Show, Generic)

instance Exception ExitCode

ioException :: IOException -> IO a ioException err = throwIO err

ioError :: IOError -> IO a ioError = ioException

type IOError = IOException

data IOException = IOError { ioe_handle :: Maybe Handle,

 [ioe_type](GHC.IO.Exception.html#ioe%5Ftype)     :: [IOErrorType](GHC.IO.Exception.html#IOErrorType),    
 [ioe_location](GHC.IO.Exception.html#ioe%5Flocation) :: [String](GHC.Base.html#String),         
 [ioe_description](GHC.IO.Exception.html#ioe%5Fdescription) :: [String](GHC.Base.html#String),      
 [ioe_errno](GHC.IO.Exception.html#ioe%5Ferrno)    :: [Maybe](GHC.Maybe.html#Maybe) [CInt](Foreign.C.Types.html#CInt),     
 [ioe_filename](GHC.IO.Exception.html#ioe%5Ffilename) :: [Maybe](GHC.Maybe.html#Maybe) [FilePath](GHC.IO.html#FilePath)  

}

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

data IOErrorType

= AlreadyExists | NoSuchThing | ResourceBusy | ResourceExhausted | EOF | IllegalOperation | PermissionDenied | UserError

| 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" UnsupportedOperation -> "unsupported operation"

userError :: String -> IOError userError str = IOError Nothing UserError "" str Nothing Nothing

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 :: (?callStack :: CallStack) => Bool -> a -> a assertError predicate v | predicate = lazy v | otherwise = unsafeDupablePerformIO $ do ccsStack <- currentCallStack let implicitParamCallStack = prettyCallStackLines ?callStack ccsCallStack = showCCSStack ccsStack stack = intercalate "\n" $ implicitParamCallStack ++ ccsCallStack throwIO (AssertionFailed ("Assertion failed\n" ++ stack))

unsupportedOperation :: IOError unsupportedOperation = (IOError Nothing UnsupportedOperation "" "Operation is not supported" Nothing Nothing)

untangle :: Addr# -> String -> String untangle coded message = location ++ ": " ++ message ++ details ++ "\n" where coded_str = unpackCStringUtf8# coded

([location](#local-6989586621679267398), [details](#local-6989586621679267399))
  = case ([span](GHC.List.html#span) [not_bar](#local-6989586621679267400) [coded_str](#local-6989586621679267397)) of { ([loc](#local-6989586621679267401), [rest](#local-6989586621679267402)) ->
    case [rest](#local-6989586621679267402) of
      ('|':[det](#local-6989586621679267403)) -> ([loc](#local-6989586621679267401), ' ' : [det](#local-6989586621679267403))
      _         -> ([loc](#local-6989586621679267401), "")
    }
[not_bar](#local-6989586621679267400) [c](#local-6989586621679267404) = [c](#local-6989586621679267404) /= '|'