{-# 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.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.
--
-- 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.
         Exception e => e -> a
throw :: forall a e. Exception e => e -> a
throw e
e = SomeException -> a
forall a b. a -> b
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 ( 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 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 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 4.0.0.0
instance Exception ErrorCall

-- | @since 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
  [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 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
  SomeException -> IO SomeException
forall a. a -> IO a
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 [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)

-- 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 {Int
String
srcLocPackage :: String
srcLocModule :: String
srcLocFile :: String
srcLocStartLine :: Int
srcLocStartCol :: Int
srcLocEndLine :: Int
srcLocEndCol :: Int
srcLocPackage :: SrcLoc -> String
srcLocModule :: SrcLoc -> String
srcLocFile :: SrcLoc -> String
srcLocStartLine :: SrcLoc -> Int
srcLocStartCol :: SrcLoc -> Int
srcLocEndLine :: SrcLoc -> Int
srcLocEndCol :: SrcLoc -> Int
..}
  = (String -> ShowS) -> String -> [String] -> String
forall a b. (a -> b -> b) -> b -> [a] -> b
foldr String -> ShowS
forall a. [a] -> [a] -> [a]
(++) String
""
      [ String
srcLocFile, String
":"
      , Int -> String
forall a. Show a => a -> String
show Int
srcLocStartLine, String
":"
      , Int -> String
forall a. Show a => a -> String
show Int
srcLocStartCol, String
" in "
      , String
srcLocPackage, String
":", 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 String
"\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 CallStack
cs = case CallStack -> [(String, SrcLoc)]
getCallStack CallStack
cs of
  []  -> []
  [(String, SrcLoc)]
stk -> String
"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
"  " 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 (String
f, SrcLoc
loc) = String
f String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", called at " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SrcLoc -> String
prettySrcLoc SrcLoc
loc