StackAnnotation.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}

module GHC.Debug.Types.StackAnnotation (
  StackAnnotation(..),
  StackAnnotationWithPtrPayload,
  isSomeStackAnnotationConstrDesc,
  ) where

import GHC.Debug.Types.Closures
import GHC.Debug.Types.Ptr
import qualified Data.List as List

-- | 'StackAnnotation' is a closure pushed onto the Haskell callstack
-- via the primop 'annotateStack#'.
--
-- In 'ghc-experimental:GHC.Stack.Annotation.Experimental', we define a type hierarchy
-- for types that can be pushed onto the stack via lifted versions of 'annotateStack#'.
-- The root of this hierarchy is 'SomeStackAnnotation' which this type is representation of.
data StackAnnotation constr dcd tcd cd = StackAnnotation
  { stackAnno_constr :: constr
  , stackAnno_typeableEv :: tcd
  , stackAnno_displayStackAnnoEv :: dcd
  , stackAnno_payload :: cd
  } deriving (Show, Eq, Ord, Functor, Foldable, Traversable)

type StackAnnotationWithPtrPayload = StackAnnotation ConstrDesc ClosurePtr ClosurePtr ClosurePtr

someStackAnnotationConstrDesc :: ConstrDesc
someStackAnnotationConstrDesc =
  ConstrDesc
    { pkg = "ghc-experimental"
    , modl = "GHC.Stack.Annotation.Experimental"
    , name = "SomeStackAnnotation"
    }

isSomeStackAnnotationConstrDesc :: ConstrDesc -> Bool
isSomeStackAnnotationConstrDesc desc = and
  [ pkg someStackAnnotationConstrDesc `List.isPrefixOf` pkg desc
  , modl desc == modl someStackAnnotationConstrDesc
  , name desc == name someStackAnnotationConstrDesc
  ]