-- 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
  ( module Test.Cleveland.Internal.Exceptions.CallStack
  ) 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 { CallStackAnnotation -> CallStack
unCallStackAnnotation :: CallStack }
  deriving stock Int -> CallStackAnnotation -> ShowS
[CallStackAnnotation] -> ShowS
CallStackAnnotation -> [Char]
(Int -> CallStackAnnotation -> ShowS)
-> (CallStackAnnotation -> [Char])
-> ([CallStackAnnotation] -> ShowS)
-> Show CallStackAnnotation
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [CallStackAnnotation] -> ShowS
$cshowList :: [CallStackAnnotation] -> ShowS
show :: CallStackAnnotation -> [Char]
$cshow :: CallStackAnnotation -> [Char]
showsPrec :: Int -> CallStackAnnotation -> ShowS
$cshowsPrec :: Int -> CallStackAnnotation -> ShowS
Show

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

instance ExceptionAnnotation CallStackAnnotation where
  displayAnnotation :: CallStackAnnotation -> Builder -> Builder
displayAnnotation CallStackAnnotation
cs Builder
acc = [Builder] -> Builder
forall (f :: * -> *) a. (Foldable f, Buildable a) => f a -> Builder
unlinesF
    [ Builder
acc
    , Builder
""
    , [Char] -> Builder
forall p. Buildable p => p -> Builder
build ([Char] -> Builder) -> [Char] -> Builder
forall a b. (a -> b) -> a -> b
$ CallStack -> [Char]
prettyCallStack (CallStack -> [Char]) -> CallStack -> [Char]
forall a b. (a -> b) -> a -> b
$ CallStackAnnotation -> CallStack
unCallStackAnnotation CallStackAnnotation
cs
    ]
  annotationPriority :: Int
annotationPriority = Int
-1000
  -- NB: we want call stacks to be basically printed last.

instance Semigroup CallStackAnnotation where
  CallStackAnnotation
a <> :: CallStackAnnotation -> CallStackAnnotation -> CallStackAnnotation
<> CallStackAnnotation
b = CallStack -> CallStackAnnotation
CallStackAnnotation (CallStack -> CallStackAnnotation)
-> CallStack -> CallStackAnnotation
forall a b. (a -> b) -> a -> b
$ CallStackAnnotation -> CallStack
unCallStackAnnotation CallStackAnnotation
a CallStack -> CallStack -> CallStack
`mergeCallStacks` CallStackAnnotation -> CallStack
unCallStackAnnotation CallStackAnnotation
b

-- | Merge two 'CallStack's, removing duplicates, but keeping the ordering.
mergeCallStacks :: CallStack -> CallStack -> CallStack
mergeCallStacks :: CallStack -> CallStack -> CallStack
mergeCallStacks CallStack
a CallStack
b = [([Char], SrcLoc)] -> CallStack
fromCallSiteList
  ([([Char], SrcLoc)] -> CallStack)
-> [([Char], SrcLoc)] -> CallStack
forall a b. (a -> b) -> a -> b
$ (([Char], OrdSrcLoc) -> ([Char], SrcLoc))
-> [([Char], OrdSrcLoc)] -> [([Char], SrcLoc)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((OrdSrcLoc -> SrcLoc) -> ([Char], OrdSrcLoc) -> ([Char], SrcLoc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap OrdSrcLoc -> SrcLoc
unOrdSrcLoc)
  ([([Char], OrdSrcLoc)] -> [([Char], SrcLoc)])
-> [([Char], OrdSrcLoc)] -> [([Char], SrcLoc)]
forall a b. (a -> b) -> a -> b
$ [([Char], OrdSrcLoc)] -> [([Char], OrdSrcLoc)]
forall a. Ord a => [a] -> [a]
ordNub
  ([([Char], OrdSrcLoc)] -> [([Char], OrdSrcLoc)])
-> [([Char], OrdSrcLoc)] -> [([Char], OrdSrcLoc)]
forall a b. (a -> b) -> a -> b
$ (([Char], SrcLoc) -> ([Char], OrdSrcLoc))
-> [([Char], SrcLoc)] -> [([Char], OrdSrcLoc)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((SrcLoc -> OrdSrcLoc) -> ([Char], SrcLoc) -> ([Char], OrdSrcLoc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SrcLoc -> OrdSrcLoc
OrdSrcLoc)
  ([([Char], SrcLoc)] -> [([Char], OrdSrcLoc)])
-> [([Char], SrcLoc)] -> [([Char], OrdSrcLoc)]
forall a b. (a -> b) -> a -> b
$ CallStack -> [([Char], SrcLoc)]
getCallStack CallStack
a [([Char], SrcLoc)] -> [([Char], SrcLoc)] -> [([Char], SrcLoc)]
forall a. Semigroup a => a -> a -> a
<> CallStack -> [([Char], SrcLoc)]
getCallStack CallStack
b

newtype OrdSrcLoc = OrdSrcLoc { OrdSrcLoc -> SrcLoc
unOrdSrcLoc :: SrcLoc }
  deriving newtype OrdSrcLoc -> OrdSrcLoc -> Bool
(OrdSrcLoc -> OrdSrcLoc -> Bool)
-> (OrdSrcLoc -> OrdSrcLoc -> Bool) -> Eq OrdSrcLoc
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OrdSrcLoc -> OrdSrcLoc -> Bool
$c/= :: OrdSrcLoc -> OrdSrcLoc -> Bool
== :: OrdSrcLoc -> OrdSrcLoc -> Bool
$c== :: OrdSrcLoc -> OrdSrcLoc -> Bool
Eq

instance Ord OrdSrcLoc where
  compare :: OrdSrcLoc -> OrdSrcLoc -> Ordering
compare (OrdSrcLoc (SrcLoc [Char]
a [Char]
b [Char]
c Int
d Int
e Int
f Int
g)) (OrdSrcLoc (SrcLoc [Char]
a' [Char]
b' [Char]
c' Int
d' Int
e' Int
f' Int
g'))
    = ([Char], [Char], [Char], Int, Int, Int, Int)
-> ([Char], [Char], [Char], Int, Int, Int, Int) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare ([Char]
a, [Char]
b, [Char]
c, Int
d, Int
e, Int
f, Int
g) ([Char]
a', [Char]
b', [Char]
c', Int
d', Int
e', Int
f', Int
g')