{-# LANGUAGE CPP #-}
module GHC.Stack.Annotation.Compat where

#include "macros.h"
import Control.Exception
import Data.Typeable
import GHC.Stack (withFrozenCallStack)
import GHC.Stack.Types
import System.IO.Unsafe (unsafePerformIO)
import GHC.Stack.Annotation.Compat.Class
import GHC.Stack.Annotation.Types
#if defined(SUPPORT_STACK_ANN)
import qualified GHC.Stack.Annotation.Experimental as Annotation
#endif

-- ----------------------------------------------------------------------------
-- Annotate the CallStack with custom data
-- ----------------------------------------------------------------------------

-- See Note [User-defined stack annotations for better stack traces]

-- | @'annotateStack' anno b@ annotates the evaluation stack of @b@
-- with the value of @anno@.
--
-- When decoding the call stack, the annotation frames can be used to add more
-- information to stack traces.
--
-- WARNING: forces the evaluation of @b@ to WHNF.
{-# NOINLINE annotateStack #-}
annotateStack :: forall a b. (HasCallStack, Typeable a, StackAnnotation a) => a -> b -> b
annotateStack :: forall a b.
(HasCallStack, Typeable a, StackAnnotation a) =>
a -> b -> b
annotateStack a
ann b
b = IO b -> b
forall a. IO a -> a
unsafePerformIO (IO b -> b) -> IO b -> b
forall a b. (a -> b) -> a -> b
$
  a -> IO b -> IO b
forall a b.
(HasCallStack, Typeable a, StackAnnotation a) =>
a -> IO b -> IO b
annotateStackIO a
ann (b -> IO b
forall a. a -> IO a
evaluate b
b)

-- | @'annotateCallStack' b@ annotates the evaluation stack of @b@
-- with the current 'callstack'.
--
-- When decoding the call stack, the annotation frames can be used to add more
-- information to stack traces.
--
-- WARNING: forces the evaluation of @b@ to WHNF.
{-# NOINLINE annotateCallStack #-}
annotateCallStack :: HasCallStack => b -> b
annotateCallStack :: forall b. HasCallStack => b -> b
annotateCallStack b
b = IO b -> b
forall a. IO a -> a
unsafePerformIO (IO b -> b) -> IO b -> b
forall a b. (a -> b) -> a -> b
$ (HasCallStack => IO b) -> IO b
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => IO b) -> IO b) -> (HasCallStack => IO b) -> IO b
forall a b. (a -> b) -> a -> b
$
  IO b -> IO b
forall a. HasCallStack => IO a -> IO a
annotateCallStackIO (b -> IO b
forall a. a -> IO a
evaluate b
b)


-- | @'annotateStackString' msg b@ annotates the evaluation stack of @b@
-- with the value @msg@.
--
-- When decoding the call stack, the annotation frames can be used to add more
-- information to stack traces.
--
-- WARNING: forces the evaluation of @b@ to WHNF.
annotateStackString :: forall b . HasCallStack => String -> b -> b
annotateStackString :: forall b. HasCallStack => String -> b -> b
annotateStackString String
ann =
  StringAnnotation -> b -> b
forall a b.
(HasCallStack, Typeable a, StackAnnotation a) =>
a -> b -> b
annotateStack (Maybe SrcLoc -> String -> StringAnnotation
StringAnnotation (CallStack -> Maybe SrcLoc
callStackHeadSrcLoc HasCallStack
CallStack
?callStack) String
ann)

-- | @'annotateStackShow' showable b@ annotates the evaluation stack of @b@
-- with the value @showable@.
--
-- When decoding the call stack, the annotation frames can be used to add more
-- information to stack traces.
--
-- WARNING: forces the evaluation of @b@ to WHNF.
annotateStackShow :: forall a b . (HasCallStack, Typeable a, Show a) => a -> b -> b
annotateStackShow :: forall a b. (HasCallStack, Typeable a, Show a) => a -> b -> b
annotateStackShow a
ann =
  ShowAnnotation -> b -> b
forall a b.
(HasCallStack, Typeable a, StackAnnotation a) =>
a -> b -> b
annotateStack (Maybe SrcLoc -> a -> ShowAnnotation
forall a. Show a => Maybe SrcLoc -> a -> ShowAnnotation
ShowAnnotation (CallStack -> Maybe SrcLoc
callStackHeadSrcLoc HasCallStack
CallStack
?callStack) a
ann)

-- | @'annotateStackIO' showable b@ annotates the evaluation stack of @b@
-- with the value @showable@.
--
-- When decoding the call stack, the annotation frames can be used to add more
-- information to stack traces.
annotateStackIO :: forall a b . (HasCallStack, Typeable a, StackAnnotation a) => a -> IO b -> IO b
#if defined(SUPPORT_STACK_ANN)
annotateStackIO ann act = Annotation.annotateStackIO (CompatAnnotation ann) act
#else
annotateStackIO :: forall a b.
(HasCallStack, Typeable a, StackAnnotation a) =>
a -> IO b -> IO b
annotateStackIO a
_ann = IO b -> IO b
forall a. a -> a
id
#endif

-- | @'annotateStackStringIO' msg b@ annotates the evaluation stack of @b@
-- with the value @msg@.
--
-- When decoding the call stack, the annotation frames can be used to add more
-- information to stack traces.
annotateStackStringIO :: forall b . HasCallStack => String -> IO b -> IO b
annotateStackStringIO :: forall b. HasCallStack => String -> IO b -> IO b
annotateStackStringIO String
ann =
  StringAnnotation -> IO b -> IO b
forall a b.
(HasCallStack, Typeable a, StackAnnotation a) =>
a -> IO b -> IO b
annotateStackIO (Maybe SrcLoc -> String -> StringAnnotation
StringAnnotation (CallStack -> Maybe SrcLoc
callStackHeadSrcLoc HasCallStack
CallStack
?callStack) String
ann)

-- | @'annotateStackShowIO' msg b@ annotates the evaluation stack of @b@
-- with the value @msg@.
--
-- When decoding the call stack, the annotation frames can be used to add more
-- information to stack traces.
annotateStackShowIO :: forall a b . (HasCallStack, Show a) => a -> IO b -> IO b
annotateStackShowIO :: forall a b. (HasCallStack, Show a) => a -> IO b -> IO b
annotateStackShowIO a
ann =
  ShowAnnotation -> IO b -> IO b
forall a b.
(HasCallStack, Typeable a, StackAnnotation a) =>
a -> IO b -> IO b
annotateStackIO (Maybe SrcLoc -> a -> ShowAnnotation
forall a. Show a => Maybe SrcLoc -> a -> ShowAnnotation
ShowAnnotation (CallStack -> Maybe SrcLoc
callStackHeadSrcLoc HasCallStack
CallStack
?callStack) a
ann)

-- | @'annotateCallStackIO' b@ annotates the evaluation stack of @b@ with the
-- current 'callstack'.
--
-- When decoding the call stack, the annotation frames can be used to add more
-- information to stack traces.
annotateCallStackIO :: HasCallStack => IO a -> IO a
annotateCallStackIO :: forall a. HasCallStack => IO a -> IO a
annotateCallStackIO =
  CallStackAnnotation -> IO a -> IO a
forall a b.
(HasCallStack, Typeable a, StackAnnotation a) =>
a -> IO b -> IO b
annotateStackIO (CallStack -> CallStackAnnotation
CallStackAnnotation HasCallStack
CallStack
?callStack)