{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE ImplicitParams #-}
-- |
-- Module      : GHC.Stack.Annotation.Experimental
-- Description : Push annotation stack frames onto the Haskell call stack
-- Copyright   : (c) The GHC Team
-- License     : see libraries/ghc-experimental/LICENSE
-- Maintainer  : ghc-devs@haskell.org
-- Stability   : experimental
-- Portability : non-portable (GHC Extensions)
--
-- Push user-defined annotation stack frames into the Haskell call stack.
-- Annotation stack frames may be decoded when unwinding the call stack, allowing
-- the user to gain more control over what an IPE stack trace looks like.
--
-- The main advantages of stack frame annotations over other 'Backtraces':
-- * Function signatures don't need to be modified to improve stack traces (e.g. via 'HasCallStack').
-- * Annotation are arbitrary user-defined datatypes, not just source locations.
-- * Stack frame annotations are always present and do not require recompilation (e.g. @-prof@ or @-g3@).
module GHC.Stack.Annotation.Experimental (
  -- * The root of Stack Annotation Types
  SomeStackAnnotation(..),
  -- * Displaying Stack Annotations
  StackAnnotation(..),
  -- * Annotation helpers
  ShowAnnotation(..),
  StringAnnotation(..),
  -- * 'CallStack' annotations
  CallStackAnnotation(..),
  -- * Push stack frame annotations in 'IO' code.
  --
  --
  annotateStackIO,
  annotateStackStringIO,
  annotateStackShowIO,
  annotateCallStackIO,
  -- * Push stack frame annotations in non-'IO' code.
  --
  -- These variants all evaluate the code to be annotated to WHNF.
  -- Otherwise, the stack annotations will not be shown in stack traces,
  -- as the computation is immediately "evaluated" to a thunk, popping the
  -- annotation frames from the stack.
  -- If the pure computation throws an exception later, the annotation frame
  -- will not be present, thus missing in the stack trace.
  --
  -- Note, you will encounter similar issues if the exception is thrown
  -- during evaluation of a nested value, for example @Just (error "Oh, no!")@.
  annotateStack,
  annotateStackString,
  annotateStackShow,
  annotateCallStack,
  ) where

import Data.Typeable
import GHC.Exts
import GHC.IO
import GHC.Internal.Stack

-- Note [User-defined stack annotations for better stack traces]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- The primop 'annotateStack#' allows users to push arbitrary data onto
-- the Haskell-native call stack.
-- These annotations can later be discovered when unwinding and decoding the stack, for
-- example when an exception is thrown.
-- The annotations can add information to the call stack, such as source locations,
-- without needing 'HasCallStack' constraints in the calling function.
--
-- The feature is implemented via the stack frame 'AnnFrame', which consists of
-- nothing but an info table and a generic payload.
-- The 'AnnFrame' is semantically a no-op, and serves no further purpose than to
-- push user-defined annotations onto the Haskell-native call stack.
--
-- We provide a wrapper API for the primop 'annotateStack#' which allows users to annotate their
-- call stack in programs.
-- There are wrappers using 'IO', as well as wrappers that are pure.
-- Annotation stack frames are most reliable in the 'IO' monad, while
-- the pure variations can behave in ways that are hard to predict.
--
-- See Note [Stack annotations in pure code] for more details.
--
-- At last, stack annotations are tricky to use with 'error'.
-- See Note [Pushing annotation frames on 'error'] for why this is the case.

-- Note [Stack annotations in pure code]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- In lazy, non-IO code, the execution stack is quite confusing due to laziness
-- and doesn't follow any obvious intuition.
-- To make the pure API slightly more predictable, we evaluate the annotated value to WHNF.
-- This makes sure that stack annotations are present when we would intuitively expect them.
--
-- For example:
--
-- @
--  annotateStackShow (5 @Int) (fib 20 + throw (ErrorCall "Oh no!"))
-- @
--
-- Without forcing the result of @(fib 20 + throw (ErrorCall "Oh no!"))@, the computation
-- will simply return a thunk, and the stack annotation would be popped off the stack.
-- Once the thunk is evaluated, the exception is raised, but no stack annotation will be found!
-- If we force the result of @(fib 20 + throw (ErrorCall "Oh no!"))@, then the stack
-- annotations remain on the stack, and are displayed in the stack trace.
--
-- Naturally, this only holds if no imprecise exceptions are thrown during evaluation of any
-- nested value, for example in 'annotateStackShow 5 (Just $ throw (ErrorCall "Oh no!"))', the
-- stack trace will not include the value @5@.
--
-- See how we preferred @throw (ErrorCall ...)@ over @error@?
-- See Note [Pushing annotation frames on 'error'] for why we do this.

-- Note [Pushing annotation frames on 'error']
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Examples so far have not been using 'error' at all.
-- The reason is that 'error' is extraordinarily difficult to use correctly with stack annotation frames.
-- See Note [Capturing the backtrace in throw] for a detailed discussion of how 'throw'
-- manages to capture 'Backtraces'.
--
-- Long story short, 'error' does not do the same thing as 'throw' and is subtly different
-- in terms of evaluation, cause it to bypass the stack annotation frames, especially in
-- pure code.
--
-- However, even in 'IO' code, it is difficult to use 'error' and obtain stack annotation frames
-- close to the call site due to the same issue of laziness and backtrace collection.
--
-- This means, right now, if you want to reliably capture stack frame annotations,
-- in both pure and impure code, prefer 'throw' and 'throwIO' variants over 'error'.

-- ----------------------------------------------------------------------------
-- StackAnnotation
-- ----------------------------------------------------------------------------

-- | 'StackAnnotation's are types which can be pushed onto the call stack
-- as the payload of 'AnnFrame' stack frames.
--
class StackAnnotation a where
  displayStackAnnotation :: a -> String

-- ----------------------------------------------------------------------------
-- Annotations
-- ----------------------------------------------------------------------------

-- |
-- The @SomeStackAnnotation@ type is the root of the stack annotation type hierarchy.
-- When the call stack is annotated with a value of type @a@, behind the scenes it is
-- encapsulated in a @SomeStackAnnotation@.
--
data SomeStackAnnotation where
  SomeStackAnnotation :: forall a. (Typeable a, StackAnnotation a) => a -> SomeStackAnnotation

instance StackAnnotation SomeStackAnnotation where
  displayStackAnnotation :: SomeStackAnnotation -> String
displayStackAnnotation (SomeStackAnnotation a
a) = a -> String
forall a. StackAnnotation a => a -> String
displayStackAnnotation a
a

data StringAnnotation where
  StringAnnotation :: String -> StringAnnotation

instance StackAnnotation StringAnnotation where
  displayStackAnnotation :: StringAnnotation -> String
displayStackAnnotation (StringAnnotation String
str) = String
str

-- | Use the 'Show' instance of a type to display as the 'StackAnnotation'.
data ShowAnnotation where
  ShowAnnotation :: forall a . Show a => a -> ShowAnnotation

instance StackAnnotation ShowAnnotation where
  displayStackAnnotation :: ShowAnnotation -> String
displayStackAnnotation (ShowAnnotation a
showAnno) = a -> String
forall a. Show a => a -> String
show a
showAnno

-- | A 'CallStack' stack annotation.
newtype CallStackAnnotation = CallStackAnnotation CallStack

instance Show CallStackAnnotation where
  show :: CallStackAnnotation -> String
show (CallStackAnnotation CallStack
cs) = CallStack -> String
prettyCallStack CallStack
cs

-- | Displays the first entry of the 'CallStack'
instance StackAnnotation CallStackAnnotation where
  displayStackAnnotation :: CallStackAnnotation -> String
displayStackAnnotation (CallStackAnnotation CallStack
cs) = case CallStack -> [(String, SrcLoc)]
getCallStack CallStack
cs of
    [] -> String
"<unknown source location>"
    ((String
_,SrcLoc
srcLoc):[(String, SrcLoc)]
_) -> SrcLoc -> String
prettySrcLoc SrcLoc
srcLoc

-- ----------------------------------------------------------------------------
-- 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. (Typeable a, StackAnnotation a) => a -> b -> b
annotateStack :: forall a b. (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. (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 . String -> b -> b
annotateStackString :: forall b. String -> b -> b
annotateStackString String
ann =
  StringAnnotation -> b -> b
forall a b. (Typeable a, StackAnnotation a) => a -> b -> b
annotateStack (String -> StringAnnotation
StringAnnotation 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 . (Typeable a, Show a) => a -> b -> b
annotateStackShow :: forall a b. (Typeable a, Show a) => a -> b -> b
annotateStackShow a
ann =
  ShowAnnotation -> b -> b
forall a b. (Typeable a, StackAnnotation a) => a -> b -> b
annotateStack (a -> ShowAnnotation
forall a. Show a => a -> ShowAnnotation
ShowAnnotation 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 . (Typeable a, StackAnnotation a) => a -> IO b -> IO b
annotateStackIO :: forall a b. (Typeable a, StackAnnotation a) => a -> IO b -> IO b
annotateStackIO a
ann (IO State# RealWorld -> (# State# RealWorld, b #)
act) =
  (State# RealWorld -> (# State# RealWorld, b #)) -> IO b
forall a. (State# RealWorld -> (# State# RealWorld, a #)) -> IO a
IO ((State# RealWorld -> (# State# RealWorld, b #)) -> IO b)
-> (State# RealWorld -> (# State# RealWorld, b #)) -> IO b
forall a b. (a -> b) -> a -> b
$ \State# RealWorld
s -> SomeStackAnnotation
-> (State# RealWorld -> (# State# RealWorld, b #))
-> State# RealWorld
-> (# State# RealWorld, b #)
forall b d a.
b
-> (State# d -> (# State# d, a #)) -> State# d -> (# State# d, a #)
annotateStack# (a -> SomeStackAnnotation
forall a.
(Typeable a, StackAnnotation a) =>
a -> SomeStackAnnotation
SomeStackAnnotation a
ann) State# RealWorld -> (# State# RealWorld, b #)
act State# RealWorld
s
{-# NOINLINE annotateStackIO #-}

-- | @'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 . String -> IO b -> IO b
annotateStackStringIO :: forall b. String -> IO b -> IO b
annotateStackStringIO String
ann =
  StringAnnotation -> IO b -> IO b
forall a b. (Typeable a, StackAnnotation a) => a -> IO b -> IO b
annotateStackIO (String -> StringAnnotation
StringAnnotation 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 . (Show a) => a -> IO b -> IO b
annotateStackShowIO :: forall a b. Show a => a -> IO b -> IO b
annotateStackShowIO a
ann =
  ShowAnnotation -> IO b -> IO b
forall a b. (Typeable a, StackAnnotation a) => a -> IO b -> IO b
annotateStackIO (a -> ShowAnnotation
forall a. Show a => a -> ShowAnnotation
ShowAnnotation 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. (Typeable a, StackAnnotation a) => a -> IO b -> IO b
annotateStackIO (CallStack -> CallStackAnnotation
CallStackAnnotation CallStack
forall (x :: Symbol) a. IP x a => a
?callStack)