CallStack.hs

-- SPDX-FileCopyrightText: 2022 Oxhead Alpha
-- SPDX-License-Identifier: LicenseRef-MIT-OA

{-# OPTIONS_HADDOCK not-home #-}

-- | This module defines 'CallStackAnnotation' and required helpers and
-- instances to use it with 'ExceptionAnnotation'.
module Test.Cleveland.Internal.Exceptions.CallStack
  ( CallStackAnnotation(..)
  , addCallStack
  ) where

import Fmt (build, unlinesF)
import GHC.Exception (SrcLoc(..), fromCallSiteList)
import GHC.Stack (popCallStack)

import Test.Cleveland.Internal.Exceptions.Annotated

-- | Newtype wrapper for 'CallStack' to avoid orphan instances.
--
-- Has instance of 'ExceptionAnnotation'.
newtype CallStackAnnotation = CallStackAnnotation { unCallStackAnnotation :: CallStack }
  deriving stock Show

-- | A convenience synonym for @annotateExceptions (CallStackAnnotation callStack)@.
addCallStack :: (MonadCatch m, HasCallStack) => m a -> m a
addCallStack = annotateExceptions (CallStackAnnotation $ popCallStack callStack)
-- NB: 'popCallStack' is required to hide 'addCallStack' itself from the stack.

instance ExceptionAnnotation CallStackAnnotation where
  displayAnnotation cs acc = unlinesF
    [ acc
    , ""
    , build $ prettyCallStack $ unCallStackAnnotation cs
    ]
  annotationPriority = -1000
  -- NB: we want call stacks to be basically printed last.

instance Semigroup CallStackAnnotation where
  a <> b = CallStackAnnotation $ unCallStackAnnotation a `mergeCallStacks` unCallStackAnnotation b

-- | Merge two 'CallStack's, removing duplicates, but keeping the ordering.
mergeCallStacks :: CallStack -> CallStack -> CallStack
mergeCallStacks a b = fromCallSiteList
  $ fmap (fmap unOrdSrcLoc)
  $ ordNub
  $ fmap (fmap OrdSrcLoc)
  $ getCallStack a <> getCallStack b

newtype OrdSrcLoc = OrdSrcLoc { unOrdSrcLoc :: SrcLoc }
  deriving newtype Eq

instance Ord OrdSrcLoc where
  compare (OrdSrcLoc (SrcLoc a b c d e f g)) (OrdSrcLoc (SrcLoc a' b' c' d' e' f' g'))
    = compare (a, b, c, d, e, f, g) (a', b', c', d', e', f', g')