{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude
           , ExistentialQuantification
           , MagicHash
           , RecordWildCards
           , PatternSynonyms
  #-}
{-# LANGUAGE TypeInType #-}
{-# OPTIONS_HADDOCK not-home #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.Exception
-- Copyright   :  (c) The University of Glasgow, 1998-2002
-- License     :  see libraries/base/LICENSE
--
-- Maintainer  :  cvs-ghc@haskell.org
-- Stability   :  internal
-- Portability :  non-portable (GHC extensions)
--
-- Exceptions and exception-handling functions.
--
-----------------------------------------------------------------------------

module GHC.Exception
       ( module GHC.Exception.Type
       , throw
       , ErrorCall(..,ErrorCall)
       , errorCallException
       , errorCallWithCallStackException
         -- re-export CallStack and SrcLoc from GHC.Types
       , CallStack, fromCallSiteList, getCallStack, prettyCallStack
       , prettyCallStackLines, showCCSStack
       , SrcLoc(..), prettySrcLoc
       ) where

import GHC.Base
import GHC.Show
import GHC.Stack.Types
import GHC.OldList
import GHC.Prim
import GHC.IO.Unsafe
import {-# SOURCE #-} GHC.Stack.CCS
import GHC.Exception.Type

-- | Throw an exception.  Exceptions may be thrown from purely
-- functional code, but may only be caught within the 'IO' monad.
throw :: forall (r :: RuntimeRep). forall (a :: TYPE r). forall e.
         Exception e => e -> a
throw :: e -> a
throw e :: e
e = SomeException -> a
forall b a. b -> a
raise# (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 ( Eq  -- ^ @since 4.7.0.0
             , Ord -- ^ @since 4.7.0.0
             )

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

{-# COMPLETE ErrorCall #-}

-- | @since 4.0.0.0
instance Exception ErrorCall

-- | @since 4.0.0.0
instance Show ErrorCall where
  showsPrec :: Int -> ErrorCall -> ShowS
showsPrec _ (ErrorCallWithLocation err :: String
err "") = String -> ShowS
showString String
err
  showsPrec _ (ErrorCallWithLocation err :: String
err loc :: String
loc) =
      String -> ShowS
showString String
err ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar '\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 s :: 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 s :: String
s stk :: 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
  [String]
ccsStack <- IO [String]
currentCallStack
  let
    implicitParamCallStack :: [String]
implicitParamCallStack = CallStack -> [String]
prettyCallStackLines CallStack
stk
    ccsCallStack :: [String]
ccsCallStack = [String] -> [String]
showCCSStack [String]
ccsStack
    stack :: String
stack = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "\n" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String]
implicitParamCallStack [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
ccsCallStack
  SomeException -> IO SomeException
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeException -> IO SomeException)
-> SomeException -> IO SomeException
forall a b. (a -> b) -> a -> b
$ ErrorCall -> SomeException
forall e. Exception e => e -> SomeException
toException (String -> String -> ErrorCall
ErrorCallWithLocation String
s String
stack)

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

-- prettySrcLoc and prettyCallStack are defined here to avoid hs-boot
-- files. See Note [Definition of CallStack]

-- | Pretty print a 'SrcLoc'.
--
-- @since 4.9.0.0
prettySrcLoc :: SrcLoc -> String
prettySrcLoc :: SrcLoc -> String
prettySrcLoc SrcLoc {..}
  = (String -> ShowS) -> String -> [String] -> String
forall a b. (a -> b -> b) -> b -> [a] -> b
foldr String -> ShowS
forall a. [a] -> [a] -> [a]
(++) ""
      [ String
srcLocFile, ":"
      , Int -> String
forall a. Show a => a -> String
show Int
srcLocStartLine, ":"
      , Int -> String
forall a. Show a => a -> String
show Int
srcLocStartCol, " in "
      , String
srcLocPackage, ":", String
srcLocModule
      ]

-- | Pretty print a 'CallStack'.
--
-- @since 4.9.0.0
prettyCallStack :: CallStack -> String
prettyCallStack :: CallStack -> String
prettyCallStack = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "\n" ([String] -> String)
-> (CallStack -> [String]) -> CallStack -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallStack -> [String]
prettyCallStackLines

prettyCallStackLines :: CallStack -> [String]
prettyCallStackLines :: CallStack -> [String]
prettyCallStackLines cs :: CallStack
cs = case CallStack -> [(String, SrcLoc)]
getCallStack CallStack
cs of
  []  -> []
  stk :: [(String, SrcLoc)]
stk -> "CallStack (from HasCallStack):"
       String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ((String, SrcLoc) -> String) -> [(String, SrcLoc)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (("  " String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ((String, SrcLoc) -> String) -> (String, SrcLoc) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, SrcLoc) -> String
prettyCallSite) [(String, SrcLoc)]
stk
  where
    prettyCallSite :: (String, SrcLoc) -> String
prettyCallSite (f :: String
f, loc :: SrcLoc
loc) = String
f String -> ShowS
forall a. [a] -> [a] -> [a]
++ ", called at " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SrcLoc -> String
prettySrcLoc SrcLoc
loc