Context.hs

{-# 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.Base ((++), 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
    (<>) = mergeExceptionContext

instance Monoid ExceptionContext where
    mempty = emptyExceptionContext

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

-- | Construct a singleton 'ExceptionContext' from an 'ExceptionAnnotation'.
--
-- @since base-4.20.0.0
addExceptionAnnotation :: ExceptionAnnotation a => a -> ExceptionContext -> ExceptionContext
addExceptionAnnotation x (ExceptionContext xs) = ExceptionContext (SomeExceptionAnnotation x : 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 (ExceptionContext xs) =
    [ x
    | SomeExceptionAnnotation (x :: b) <- xs
    , Just HRefl <- return (typeRep @a `eqTypeRep` typeRep @b)
    ]

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

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

-- | Render 'ExceptionContext' to a human-readable 'String'.
--
-- @since base-4.20.0.0
displayExceptionContext :: ExceptionContext -> String
displayExceptionContext (ExceptionContext anns0) = go anns0
  where
    go (SomeExceptionAnnotation ann : anns) = displayExceptionAnnotation ann ++ "\n" ++ go anns
    go [] = "\n"

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 = show