{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude
           , ExistentialQuantification
           , MagicHash
           , PatternSynonyms
  #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# OPTIONS_HADDOCK not-home #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.Internal.Exception
-- Copyright   :  (c) The University of Glasgow, 1998-2002
-- License     :  see libraries/base/LICENSE
--
-- Maintainer  :  ghc-devs@haskell.org
-- Stability   :  internal
-- Portability :  non-portable (GHC extensions)
--
-- Exceptions and exception-handling 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.Exception
    ( -- * 'Exception' class
      Exception(..)

      -- * 'SomeException'
    , SomeException(..)

      -- * Exception context
    , someExceptionContext
    , addExceptionContext

      -- * Throwing
    , throw

      -- * Concrete exceptions
      -- ** Arithmetic exceptions
    , ArithException(..)
    , divZeroException
    , overflowException
    , ratioZeroDenomException
    , underflowException
      -- ** 'ErrorCall'
    , ErrorCall(..,ErrorCall)
    , errorCallException
    , errorCallWithCallStackException
    , toExceptionWithBacktrace

      -- * Reexports
      -- Re-export CallStack and SrcLoc from GHC.Types
    , CallStack, fromCallSiteList, getCallStack, prettyCallStack
    , prettyCallStackLines, showCCSStack
    , SrcLoc(..), prettySrcLoc
    ) where

import GHC.Internal.Base
import GHC.Internal.Show
import GHC.Internal.Stack.Types
import GHC.Internal.Data.OldList
import GHC.Internal.IO.Unsafe
import {-# SOURCE #-} GHC.Internal.Stack.CCS
import {-# SOURCE #-} GHC.Internal.Stack (prettyCallStackLines, prettyCallStack, prettySrcLoc)
import {-# SOURCE #-} GHC.Internal.Exception.Backtrace (collectBacktraces)
import GHC.Internal.Exception.Type

-- | Throw an exception.  Exceptions may be thrown from purely
-- functional code, but may only be caught within the 'IO' monad.
--
-- WARNING: You may want to use 'throwIO' instead so that your pure code
-- stays exception-free.
throw :: forall (r :: RuntimeRep). forall (a :: TYPE r). forall e.
         (?callStack :: CallStack, Exception e) => e -> a
throw :: forall a e. (HasCallStack, Exception e) => e -> a
throw e
e =
    let !se :: SomeException
se = IO SomeException -> SomeException
forall a. IO a -> a
unsafePerformIO (e -> IO SomeException
forall e. (HasCallStack, Exception e) => e -> IO SomeException
toExceptionWithBacktrace e
e)
    in SomeException -> a
forall a b. a -> b
raise# SomeException
se

-- | @since base-4.20.0.0
toExceptionWithBacktrace :: (HasCallStack, Exception e)
                         => e -> IO SomeException
toExceptionWithBacktrace :: forall e. (HasCallStack, Exception e) => e -> IO SomeException
toExceptionWithBacktrace e
e
  | e -> Bool
forall e. Exception e => e -> Bool
backtraceDesired e
e = do
      bt <- IO Backtraces
HasCallStack => IO Backtraces
collectBacktraces
      return (addExceptionContext bt (toException e))
  | Bool
otherwise = SomeException -> IO SomeException
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (e -> SomeException
forall e. Exception e => e -> SomeException
toException e
e)

-- | This is thrown when the user calls 'error'. The first @String@ is the
-- argument given to 'error', second @String@ is the location.
data ErrorCall = ErrorCallWithLocation String String
    deriving ( ErrorCall -> ErrorCall -> Bool
(ErrorCall -> ErrorCall -> Bool)
-> (ErrorCall -> ErrorCall -> Bool) -> Eq ErrorCall
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ErrorCall -> ErrorCall -> Bool
== :: ErrorCall -> ErrorCall -> Bool
$c/= :: ErrorCall -> ErrorCall -> Bool
/= :: ErrorCall -> ErrorCall -> Bool
Eq  -- ^ @since base-4.7.0.0
             , Eq ErrorCall
Eq ErrorCall =>
(ErrorCall -> ErrorCall -> Ordering)
-> (ErrorCall -> ErrorCall -> Bool)
-> (ErrorCall -> ErrorCall -> Bool)
-> (ErrorCall -> ErrorCall -> Bool)
-> (ErrorCall -> ErrorCall -> Bool)
-> (ErrorCall -> ErrorCall -> ErrorCall)
-> (ErrorCall -> ErrorCall -> ErrorCall)
-> Ord ErrorCall
ErrorCall -> ErrorCall -> Bool
ErrorCall -> ErrorCall -> Ordering
ErrorCall -> ErrorCall -> ErrorCall
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 :: ErrorCall -> ErrorCall -> Ordering
compare :: ErrorCall -> ErrorCall -> Ordering
$c< :: ErrorCall -> ErrorCall -> Bool
< :: ErrorCall -> ErrorCall -> Bool
$c<= :: ErrorCall -> ErrorCall -> Bool
<= :: ErrorCall -> ErrorCall -> Bool
$c> :: ErrorCall -> ErrorCall -> Bool
> :: ErrorCall -> ErrorCall -> Bool
$c>= :: ErrorCall -> ErrorCall -> Bool
>= :: ErrorCall -> ErrorCall -> Bool
$cmax :: ErrorCall -> ErrorCall -> ErrorCall
max :: ErrorCall -> ErrorCall -> ErrorCall
$cmin :: ErrorCall -> ErrorCall -> ErrorCall
min :: ErrorCall -> ErrorCall -> ErrorCall
Ord -- ^ @since base-4.7.0.0
             )

pattern ErrorCall :: String -> ErrorCall
pattern $mErrorCall :: forall {r}. ErrorCall -> (String -> r) -> ((# #) -> r) -> r
$bErrorCall :: String -> ErrorCall
ErrorCall err <- ErrorCallWithLocation err _ where
  ErrorCall String
err = String -> String -> ErrorCall
ErrorCallWithLocation String
err String
""

{-# COMPLETE ErrorCall #-}

-- | @since base-4.0.0.0
instance Exception ErrorCall

-- | @since base-4.0.0.0
instance Show ErrorCall where
  showsPrec :: Int -> ErrorCall -> ShowS
showsPrec Int
_ (ErrorCallWithLocation String
err String
"") = String -> ShowS
showString String
err
  showsPrec Int
_ (ErrorCallWithLocation String
err String
loc) =
      String -> ShowS
showString String
err ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'\n' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
loc

errorCallException :: String -> SomeException
errorCallException :: String -> SomeException
errorCallException String
s = ErrorCall -> SomeException
forall e. Exception e => e -> SomeException
toException (String -> ErrorCall
ErrorCall String
s)

errorCallWithCallStackException :: String -> CallStack -> SomeException
errorCallWithCallStackException :: String -> CallStack -> SomeException
errorCallWithCallStackException String
s CallStack
stk = IO SomeException -> SomeException
forall a. IO a -> a
unsafeDupablePerformIO (IO SomeException -> SomeException)
-> IO SomeException -> SomeException
forall a b. (a -> b) -> a -> b
$ do
  ccsStack <- IO [String]
currentCallStack
  let
    implicitParamCallStack = CallStack -> [String]
prettyCallStackLines CallStack
stk
    ccsCallStack = [String] -> [String]
showCCSStack [String]
ccsStack
    stack = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String]
implicitParamCallStack [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
ccsCallStack
  toExceptionWithBacktrace (ErrorCallWithLocation s stack)

showCCSStack :: [String] -> [String]
showCCSStack :: [String] -> [String]
showCCSStack [] = []
showCCSStack [String]
stk = String
"CallStack (from -prof):" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"  " String -> ShowS
forall a. [a] -> [a] -> [a]
++) ([String] -> [String]
forall a. [a] -> [a]
reverse [String]
stk)