{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE GADTs #-}
{-# OPTIONS_HADDOCK not-home #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.Internal.Exception.Context
-- 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)
--
-- Exception context type.
--
-----------------------------------------------------------------------------

module GHC.Internal.Exception.Context
    ( -- * Exception context
      ExceptionContext(..)
    , emptyExceptionContext
    , addExceptionAnnotation
    , getExceptionAnnotations
    , getAllExceptionAnnotations
    , mergeExceptionContext
    , displayExceptionContext
      -- * Exception annotations
    , SomeExceptionAnnotation(..)
    , ExceptionAnnotation(..)
    ) where

import GHC.Internal.Data.OldList (intersperse)
import GHC.Internal.Base (($), map, (++), return, String, Maybe(..), Semigroup(..), Monoid(..))
import GHC.Internal.Show (Show(..))
import GHC.Internal.Data.Typeable.Internal (Typeable, typeRep, eqTypeRep)
import GHC.Internal.Data.Type.Equality ( (:~~:)(HRefl) )

-- | Exception context represents a list of 'ExceptionAnnotation's. These are
-- attached to 'SomeException's via 'Control.Exception.addExceptionContext' and
-- can be used to capture various ad-hoc metadata about the exception including
-- backtraces and application-specific context.
--
-- 'ExceptionContext's can be merged via concatenation using the 'Semigroup'
-- instance or 'mergeExceptionContext'.
--
-- Note that GHC will automatically solve implicit constraints of type 'ExceptionContext'
-- with 'emptyExceptionContext'.
data ExceptionContext = ExceptionContext [SomeExceptionAnnotation]

instance Semigroup ExceptionContext where
    <> :: ExceptionContext -> ExceptionContext -> ExceptionContext
(<>) = ExceptionContext -> ExceptionContext -> ExceptionContext
mergeExceptionContext

instance Monoid ExceptionContext where
    mempty :: ExceptionContext
mempty = ExceptionContext
emptyExceptionContext

-- | An 'ExceptionContext' containing no annotations.
--
-- @since base-4.20.0.0
emptyExceptionContext :: ExceptionContext
emptyExceptionContext :: ExceptionContext
emptyExceptionContext = [SomeExceptionAnnotation] -> ExceptionContext
ExceptionContext []

-- | Construct a singleton 'ExceptionContext' from an 'ExceptionAnnotation'.
--
-- @since base-4.20.0.0
addExceptionAnnotation :: ExceptionAnnotation a => a -> ExceptionContext -> ExceptionContext
addExceptionAnnotation :: forall a.
ExceptionAnnotation a =>
a -> ExceptionContext -> ExceptionContext
addExceptionAnnotation a
x (ExceptionContext [SomeExceptionAnnotation]
xs) = [SomeExceptionAnnotation] -> ExceptionContext
ExceptionContext (a -> SomeExceptionAnnotation
forall a. ExceptionAnnotation a => a -> SomeExceptionAnnotation
SomeExceptionAnnotation a
x SomeExceptionAnnotation
-> [SomeExceptionAnnotation] -> [SomeExceptionAnnotation]
forall a. a -> [a] -> [a]
: [SomeExceptionAnnotation]
xs)

-- | Retrieve all 'ExceptionAnnotation's of the given type from an 'ExceptionContext'.
--
-- @since base-4.20.0.0
getExceptionAnnotations :: forall a. ExceptionAnnotation a => ExceptionContext -> [a]
getExceptionAnnotations :: forall a. ExceptionAnnotation a => ExceptionContext -> [a]
getExceptionAnnotations (ExceptionContext [SomeExceptionAnnotation]
xs) =
    [ a
a
x
    | SomeExceptionAnnotation (a
x :: b) <- [SomeExceptionAnnotation]
xs
    , Just a :~~: a
HRefl <- Maybe (a :~~: a) -> [Maybe (a :~~: a)]
forall a. a -> [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Typeable a => TypeRep a
forall {k} (a :: k). Typeable a => TypeRep a
typeRep @a TypeRep a -> TypeRep a -> Maybe (a :~~: a)
forall k1 k2 (a :: k1) (b :: k2).
TypeRep a -> TypeRep b -> Maybe (a :~~: b)
`eqTypeRep` forall a. Typeable a => TypeRep a
forall {k} (a :: k). Typeable a => TypeRep a
typeRep @b)
    ]

getAllExceptionAnnotations :: ExceptionContext -> [SomeExceptionAnnotation]
getAllExceptionAnnotations :: ExceptionContext -> [SomeExceptionAnnotation]
getAllExceptionAnnotations (ExceptionContext [SomeExceptionAnnotation]
xs) = [SomeExceptionAnnotation]
xs

-- | Merge two 'ExceptionContext's via concatenation
--
-- @since base-4.20.0.0
mergeExceptionContext :: ExceptionContext -> ExceptionContext -> ExceptionContext
mergeExceptionContext :: ExceptionContext -> ExceptionContext -> ExceptionContext
mergeExceptionContext (ExceptionContext [SomeExceptionAnnotation]
a) (ExceptionContext [SomeExceptionAnnotation]
b) = [SomeExceptionAnnotation] -> ExceptionContext
ExceptionContext ([SomeExceptionAnnotation]
a [SomeExceptionAnnotation]
-> [SomeExceptionAnnotation] -> [SomeExceptionAnnotation]
forall a. [a] -> [a] -> [a]
++ [SomeExceptionAnnotation]
b)

-- | Render 'ExceptionContext' to a human-readable 'String'.
--
-- @since base-4.20.0.0
displayExceptionContext :: ExceptionContext -> String
displayExceptionContext :: ExceptionContext -> String
displayExceptionContext (ExceptionContext [SomeExceptionAnnotation]
anns0) = [String] -> String
forall a. Monoid a => [a] -> a
mconcat ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
"\n" ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (SomeExceptionAnnotation -> String)
-> [SomeExceptionAnnotation] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map SomeExceptionAnnotation -> String
go [SomeExceptionAnnotation]
anns0
  where
    go :: SomeExceptionAnnotation -> String
go (SomeExceptionAnnotation a
ann) = a -> String
forall a. ExceptionAnnotation a => a -> String
displayExceptionAnnotation a
ann

data SomeExceptionAnnotation = forall a. ExceptionAnnotation a => SomeExceptionAnnotation a

-- | 'ExceptionAnnotation's are types which can decorate exceptions as
-- 'ExceptionContext'.
--
-- @since base-4.20.0.0
class (Typeable a) => ExceptionAnnotation a where
    -- | Render the annotation for display to the user.
    displayExceptionAnnotation :: a -> String

    default displayExceptionAnnotation :: Show a => a -> String
    displayExceptionAnnotation = a -> String
forall a. Show a => a -> String
show