ghc-stack-annotations 0.1.0.0 → 0.2.0.0

raw patch · 10 files changed

+604/−218 lines, 10 filesdep +ghc-heapdep +ghc-stack-annotationsdep +tastydep ~basedep ~ghc-experimentaldep ~ghc-internalPVP ok

version bump matches the API change (PVP)

Dependencies added: ghc-heap, ghc-stack-annotations, tasty, tasty-expected-failure, tasty-hunit, unliftio-core

Dependency ranges changed: base, ghc-experimental, ghc-internal

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−1
• cbits/macros.h +15/−0
• ghc-stack-annotations.cabal +54/−15
• src/GHC/Stack/Annotation.hs +3/−202
• src/GHC/Stack/Annotation/Compat.hs +106/−0
• src/GHC/Stack/Annotation/Compat/Class.hs +154/−0
• src/GHC/Stack/Annotation/Types.hs +54/−0
• src/GHC/Stack/Annotation/UnliftIO.hs +30/−0
• test/Compat.hs +40/−0
• test/Main.hs +138/−0

@@ -1,6 +1,15 @@ # Revision history for ghc-stack-annotations -## 0.1.0.0 -- YYYY-mm-dd+## 0.2.0.0 -- 23-06-2026++### Breaking changes++* Support GHC 10.1 and 9.14.2 ([#5](https://github.com/well-typed/ghc-stack-annotations/pull/5)).+  * Supports `stackAnnotationSourceLocation` and `displayStackAnnotationShort` from the updated `StackAnnotation` type class.+* Add stack annotation variants in `MonadUnliftIO` ([#3](https://github.com/well-typed/ghc-stack-annotations/pull/3)).+  * Adds module `GHC.Stack.Annotation.UnliftIO`.++## 0.1.0.0 -- 09-12-2025  * Introduce `GHC.Stack.Annotation`, which is a backwards compatibility module, allowing     users to use `annotateStack*` without having to resort to `CPP` for older GHC versions.

@@ -0,0 +1,15 @@+#if !defined(MIN_VERSION_ghc_experimental)+#define MIN_VERSION_ghc_experimental(x, y, z) false+#endif++#if MIN_VERSION_ghc_experimental(9,1402,0)+#define SUPPORT_STACK_ANN_LATEST+#endif++#if MIN_VERSION_ghc_experimental(9,1402,0)+#define SUPPORT_STACK_ANN_SRCLOC+#endif++#if MIN_VERSION_ghc_experimental(9,1401,0)+#define SUPPORT_STACK_ANN+#endif

@@ -1,17 +1,23 @@ cabal-version: 3.8 name: ghc-stack-annotations-version: 0.1.0.0+version: 0.2.0.0 synopsis: RTS Callstack annotation library-description: A compatibility library for the RTS Callstack annotations introduced in GHC 9.14.-             .-             Allows you to use the stack annotations without having to worry about older GHC versions.-             As stack annotations rely on the newly introduced 'AnnFrame' stack frame type, this library-             is operationally a NO-OP for GHC versions below 9.14.-             .-             For GHC <9.14, this library exposes an API identical to 'GHC.Stack.Annotation.Experimental' including-             data types and type classes for writing 'StackAnnotation' instances, without worrying about backwards-             compatibility.-             For GHC >=9.14, this library re-exports the API of 'GHC.Stack.Annotation.Experimental'.+description:+  A compatibility library for the RTS Callstack annotations introduced in GHC 9.14.+  .+  Allows you to use the stack annotations without having to worry about older GHC versions.+  As stack annotations rely on the newly introduced 'AnnFrame' stack frame type, this library+  is operationally a NO-OP for GHC versions below 9.14.+  .+  For GHC <9.14, this library exposes an API identical to 'GHC.Stack.Annotation.Experimental' of the latest+  supported GHC version.+  For GHC >=9.14, this library exposes an API identical to 'GHC.Stack.Annotation.Experimental' of the latest+  supported GHC version.+  For the latest supported GHC version, we re-export the interface of 'GHC.Stack.Annotation.Experimental'+  .+  This API abstracts over the GHC 'StackAnnotation' type class, thus allows you to write instances for all+  supported GHC versions without any @-XCPP@.+ category: development, BSD license: BSD-3-Clause license-file: LICENSE@@ -21,8 +27,10 @@ extra-doc-files:   CHANGELOG.md   README.md+extra-source-files:+  cbits/macros.h -tested-with: GHC ==9.14 || ==9.12 || ==9.10 || ==9.8+tested-with: ghc ==10.1 || ==9.14 || ==9.12 || ==9.10 || ==9.8  common warnings   ghc-options: -Wall@@ -32,18 +40,49 @@     GADTs     ImplicitParams     RankNTypes+    TypeApplications  library   import: warnings, exts-  exposed-modules: GHC.Stack.Annotation+  exposed-modules:+    GHC.Stack.Annotation+    GHC.Stack.Annotation.UnliftIO++  other-modules:+    GHC.Stack.Annotation.Compat+    GHC.Stack.Annotation.Compat.Class+    GHC.Stack.Annotation.Types+   build-depends:     base >=4.19.1 && <5,+    unliftio-core >=0.1 && <0.3,    if impl(ghc >=9.14)     build-depends:-      ghc-internal >= 9.1400 && <10,-      ghc-experimental >= 9.1400.0 && <10,+      ghc-experimental >=9.1400.0 && <10.200   hs-source-dirs: src+  include-dirs: ./cbits+  default-language: Haskell2010++test-suite ghc-stack-annotation-tests+  import: warnings, exts+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is: Main.hs+  other-modules: Compat+  include-dirs: ./cbits+  build-depends:+    base,+    ghc-heap,+    ghc-stack-annotations,+    tasty >=1.5.4 && <1.6,+    tasty-expected-failure >=0.11 && <0.13,+    tasty-hunit >=0.9 && <0.13,++  if impl(ghc >=9.14)+    build-depends:+      ghc-experimental,+      ghc-internal >=9.1400.0 && <10.200,   default-language: Haskell2010  source-repository head

@@ -34,205 +34,6 @@   annotateCallStack, ) where --#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 914-import GHC.Stack.Annotation.Experimental (-  SomeStackAnnotation(..),-  StackAnnotation(..),-  ShowAnnotation(..),-  StringAnnotation(..),-  CallStackAnnotation(..),-  annotateStackIO,-  annotateStackStringIO,-  annotateStackShowIO,-  annotateCallStackIO,-  annotateStack,-  annotateStackString,-  annotateStackShow,-  annotateCallStack,-  )-#else---- The following source code is a copy of ghc-experimental:---  GHC.Stack.Annotation.Experimental.hs--- The only difference is that no 'annotateStackIO' is simply the 'id' function.------ As such, we reproduce the copyright notice here.---- Copyright (c) 2023, ghc-devs@haskell.org------ All rights reserved.------ Redistribution and use in source and binary forms, with or without--- modification, are permitted provided that the following conditions are met:------     * Redistributions of source code must retain the above copyright---       notice, this list of conditions and the following disclaimer.------     * Redistributions in binary form must reproduce the above---       copyright notice, this list of conditions and the following---       disclaimer in the documentation and/or other materials provided---       with the distribution.------     * Neither the name of ghc-devs@haskell.org nor the names of other---       contributors may be used to endorse or promote products derived---       from this software without specific prior written permission.------ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS--- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT--- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR--- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT--- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,--- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT--- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,--- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY--- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT--- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE--- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.--import Control.Exception-import Data.Typeable-import GHC.Exception-import GHC.Stack (withFrozenCallStack)-import GHC.Stack.Types-import System.IO.Unsafe (unsafePerformIO)---- ------------------------------------------------------------------------------- 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 a) = displayStackAnnotation a--data StringAnnotation where-  StringAnnotation :: String -> StringAnnotation--instance StackAnnotation StringAnnotation where-  displayStackAnnotation (StringAnnotation str) = 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 showAnno) = show showAnno---- | A 'CallStack' stack annotation.-newtype CallStackAnnotation = CallStackAnnotation CallStack--instance Show CallStackAnnotation where-  show (CallStackAnnotation cs) = prettyCallStack cs---- | Displays the first entry of the 'CallStack'-instance StackAnnotation CallStackAnnotation where-  displayStackAnnotation (CallStackAnnotation cs) = case getCallStack cs of-    [] -> "<unknown source location>"-    ((fnName,srcLoc):_) -> fnName ++ ", called at " ++ prettySrcLoc 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 ann b = unsafePerformIO $-  annotateStackIO ann (evaluate 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 b = unsafePerformIO $ withFrozenCallStack $-  annotateCallStackIO (evaluate 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 ann =-  annotateStack (StringAnnotation 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 ann =-  annotateStack (ShowAnnotation 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 _ann = id---- | @'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 ann =-  annotateStackIO (StringAnnotation 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 ann =-  annotateStackIO (ShowAnnotation 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 =-  annotateStackIO (CallStackAnnotation ?callStack)--#endif+import GHC.Stack.Annotation.Compat+import GHC.Stack.Annotation.Compat.Class+import GHC.Stack.Annotation.Types

@@ -0,0 +1,106 @@+{-# 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 ann b = unsafePerformIO $+  annotateStackIO ann (evaluate 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 b = unsafePerformIO $ withFrozenCallStack $+  annotateCallStackIO (evaluate 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 ann =+  annotateStack (StringAnnotation (callStackHeadSrcLoc ?callStack) 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 ann =+  annotateStack (ShowAnnotation (callStackHeadSrcLoc ?callStack) 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 _ann = 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 ann =+  annotateStackIO (StringAnnotation (callStackHeadSrcLoc ?callStack) 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 ann =+  annotateStackIO (ShowAnnotation (callStackHeadSrcLoc ?callStack) 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 =+  annotateStackIO (CallStackAnnotation ?callStack)

@@ -0,0 +1,154 @@+{-# LANGUAGE CPP #-}+module GHC.Stack.Annotation.Compat.Class (+  StackAnnotation(..),+  SomeStackAnnotation(..),+  CompatAnnotation(..),+  ) where++#include "macros.h"++import Data.Typeable ( Typeable )++#if defined(SUPPORT_STACK_ANN_SRCLOC)+import GHC.Stack.Annotation.Experimental (StackAnnotation(..), SomeStackAnnotation(..))+import qualified GHC.Stack.Annotation.Experimental as Annotation+#elif defined(SUPPORT_STACK_ANN)+import GHC.Stack.Annotation.Experimental (SomeStackAnnotation(..))+import qualified GHC.Stack.Annotation.Experimental as Annotation+import GHC.Stack (SrcLoc, prettySrcLoc)+#else+import GHC.Stack (SrcLoc, prettySrcLoc)+#endif++-- The following source code is a partial copy of ghc-internal:+--  GHC.Internal.Stack.Annotation+-- It copies the `StackAnnotation` type class and its documentation.+--+-- As such, we reproduce the copyright notice here.++-- Copyright (c) 2023, ghc-devs@haskell.org+--+-- All rights reserved.+--+-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are met:+--+--     * Redistributions of source code must retain the above copyright+--       notice, this list of conditions and the following disclaimer.+--+--     * Redistributions in binary form must reproduce the above+--       copyright notice, this list of conditions and the following+--       disclaimer in the documentation and/or other materials provided+--       with the distribution.+--+--     * Neither the name of ghc-devs@haskell.org nor the names of other+--       contributors may be used to endorse or promote products derived+--       from this software without specific prior written permission.+--+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+-- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+-- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+-- LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+-- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+-- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+-- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+-- OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+++#if !defined(SUPPORT_STACK_ANN_LATEST)+-- | 'StackAnnotation's are types which can be pushed onto the call stack+-- as the payload of 'AnnFrame' stack frames.+--+class StackAnnotation a where+  -- | Display a human readable string for the 'StackAnnotation'.+  --+  -- This is supposed to be the long version of 'displayStackAnnotationShort'+  -- and may contain a source location.+  --+  -- If not provided, 'displayStackAnnotation' is derived from 'stackAnnotationSourceLocation'+  -- and 'displayStackAnnotationShort'.+  displayStackAnnotation :: a -> String++  -- | Get the 'SrcLoc' of the given 'StackAnnotation'.+  --+  -- This is optional, 'SrcLoc' are not strictly required for 'StackAnnotation', but+  -- it is still heavily encouraged to provide a 'SrcLoc' for better IPE backtraces.+  stackAnnotationSourceLocation :: a -> Maybe SrcLoc++  -- | The description of the StackAnnotation without any metadata such as source locations.+  --+  -- Prefer implementing 'displayStackAnnotationShort' over 'displayStackAnnotation'.+  displayStackAnnotationShort :: a -> String++  {-# MINIMAL displayStackAnnotation | displayStackAnnotationShort #-}++  displayStackAnnotation ann =+    displayStackAnnotationShort ann+      ++ case stackAnnotationSourceLocation ann of+          Nothing -> ""+          Just srcLoc -> ", called at " ++ prettySrcLoc srcLoc++  stackAnnotationSourceLocation _ann = Nothing++  displayStackAnnotationShort = displayStackAnnotation+#endif+++-- Only define this is, if `ghc-experimental` doesn't define it already. Otherwise, just re-export it.++#if !defined(SUPPORT_STACK_ANN)+-- |+-- 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+#endif++#if defined(SUPPORT_STACK_ANN_LATEST)+{- No instance needed -}+#elif defined(SUPPORT_STACK_ANN_SRCLOC)+instance StackAnnotation SomeStackAnnotation where+  displayStackAnnotation (SomeStackAnnotation ann) =+    Annotation.displayStackAnnotation ann+  stackAnnotationSourceLocation (SomeStackAnnotation ann) =+    Annotation.stackAnnotationSourceLocation ann+  displayStackAnnotationShort (SomeStackAnnotation ann) =+    Annotation.displayStackAnnotationShort ann+#elif defined(SUPPORT_STACK_ANN)+instance StackAnnotation SomeStackAnnotation where+  displayStackAnnotation (SomeStackAnnotation ann) =+    Annotation.displayStackAnnotation ann+#else+instance StackAnnotation SomeStackAnnotation where+  displayStackAnnotation (SomeStackAnnotation ann) =+    displayStackAnnotation ann+  stackAnnotationSourceLocation (SomeStackAnnotation ann) =+    stackAnnotationSourceLocation ann+  displayStackAnnotationShort (SomeStackAnnotation ann) =+    displayStackAnnotationShort ann+#endif++-- ----------------------------------------------------------------------------+-- Backwards compatibility wrapper+-- ----------------------------------------------------------------------------++-- | A newtype that bridges the locally defined 'StackAnnotation' to GHC's 'ghc-experimental:StackAnnotation'.+--+newtype CompatAnnotation a = CompatAnnotation a++#if defined(SUPPORT_STACK_ANN)+instance (Typeable a, StackAnnotation a) => Annotation.StackAnnotation (CompatAnnotation a) where+  displayStackAnnotation (CompatAnnotation a) =+    displayStackAnnotation a+#if defined(SUPPORT_STACK_ANN_SRCLOC)+  stackAnnotationSourceLocation (CompatAnnotation a) =+    stackAnnotationSourceLocation a+  displayStackAnnotationShort (CompatAnnotation a) =+    displayStackAnnotationShort a+#endif+#endif

@@ -0,0 +1,54 @@+module GHC.Stack.Annotation.Types where++import GHC.Stack.Annotation.Compat.Class (StackAnnotation(..))+import GHC.Stack++-- | A 'String' only annotation with an optional source location.+data StringAnnotation where+  StringAnnotation :: !(Maybe SrcLoc) -> String -> StringAnnotation++instance StackAnnotation StringAnnotation where+  displayStackAnnotationShort (StringAnnotation _srcLoc str) =+    str++  stackAnnotationSourceLocation (StringAnnotation srcLoc _str) =+    srcLoc++-- | Use the 'Show' instance of a type to display as the 'StackAnnotation'.+data ShowAnnotation where+  ShowAnnotation :: forall a . Show a => !(Maybe SrcLoc) -> a -> ShowAnnotation++instance StackAnnotation ShowAnnotation where+  displayStackAnnotationShort (ShowAnnotation _srcLoc showAnno) =+    show showAnno++  stackAnnotationSourceLocation (ShowAnnotation srcLoc _showAnno) =+    srcLoc++-- | A 'CallStack' stack annotation.+--+-- Captures the whole 'CallStack'.+newtype CallStackAnnotation = CallStackAnnotation CallStack++instance Show CallStackAnnotation where+  show (CallStackAnnotation cs) = prettyCallStack cs++-- | Displays the first entry of the 'CallStack'+instance StackAnnotation CallStackAnnotation where+  stackAnnotationSourceLocation (CallStackAnnotation cs) =+    callStackHeadSrcLoc cs++  displayStackAnnotationShort (CallStackAnnotation cs) =+    callStackHeadFunctionName cs++callStackHeadSrcLoc :: CallStack -> Maybe SrcLoc+callStackHeadSrcLoc cs =+  case getCallStack cs of+    [] -> Nothing+    (_, srcLoc):_ -> Just srcLoc++callStackHeadFunctionName :: CallStack -> String+callStackHeadFunctionName cs =+  case getCallStack cs of+    [] -> "<unknown source location>"+    (fnName, _):_ -> fnName

@@ -0,0 +1,30 @@+module GHC.Stack.Annotation.UnliftIO+  (+  -- * Push stack frame annotations in 'MonadUnliftIO' code.+  --+  annotateStackIO,+  annotateStackStringIO,+  annotateStackShowIO,+  annotateCallStackIO,+  ) where++import qualified GHC.Stack.Annotation as Annotation+import Data.Typeable (Typeable)+import Control.Monad.IO.Unlift (MonadUnliftIO(..))+import GHC.Stack.Types (HasCallStack)++annotateStackIO :: (Typeable a, Annotation.StackAnnotation a, MonadUnliftIO m) => a -> m b -> m b+annotateStackIO anno action =+  withRunInIO $ \runInIO -> Annotation.annotateStackIO anno (runInIO action)++annotateStackStringIO :: MonadUnliftIO m => String -> m b -> m b+annotateStackStringIO msg action =+  withRunInIO $ \runInIO -> Annotation.annotateStackStringIO msg (runInIO action)++annotateStackShowIO :: (Show a, MonadUnliftIO m) => a -> m b -> m b+annotateStackShowIO value action =+  withRunInIO $ \runInIO -> Annotation.annotateStackShowIO value (runInIO action)++annotateCallStackIO :: (HasCallStack, MonadUnliftIO m) => m b -> m b+annotateCallStackIO action =+  withRunInIO $ \runInIO -> Annotation.annotateCallStackIO (runInIO action)

@@ -0,0 +1,40 @@+{-# LANGUAGE CPP #-}++module Compat where++#include "macros.h"++import GHC.Stack.Annotation++#if defined(SUPPORT_STACK_ANN)+import GHC.Stack.CloneStack (cloneMyStack)+import qualified Data.Maybe as Maybe+import GHC.InfoProv+import GHC.Exts.Heap.Closures+import Unsafe.Coerce++-- TODO: We should not depend on ghc-internal, expose decoding functions from ghc-experimental+import qualified GHC.Internal.Stack.Decode as Decode+#endif+++collectStackAnnotations :: IO [SomeStackAnnotation]+collectStackAnnotations = do+#if defined(SUPPORT_STACK_ANN)+  stack <- cloneMyStack+  frames <- Decode.decodeStackWithIpe stack+  pure $ Maybe.mapMaybe go frames+  where+    -- TODO: GHC should expose this decoding function+    go :: (StackFrame, Maybe InfoProv) -> Maybe SomeStackAnnotation+    go (frame, _ipeInfo) = case frame of+      AnnFrame {annotation = Box someStackAnno } ->+        case unsafeCoerce someStackAnno of+          SomeStackAnnotation ann ->+            Just $ SomeStackAnnotation ann+      _  ->+        Nothing+#else+  -- There are no stack annotations in GHC <914+  pure []+#endif

@@ -0,0 +1,138 @@+{-# LANGUAGE CPP #-}++module Main where++#include "macros.h"++import Test.Tasty+import Test.Tasty.HUnit+import GHC.Stack.Annotation+import Compat+import Test.Tasty.ExpectedFailure (ignoreTestBecause)+import qualified Data.Maybe as Maybe+import GHC.Stack.Types (SrcLoc(..), getCallStack)++main :: IO ()+main = do+  defaultMain (needsStackAnnotations tests)++tests :: TestTree+tests = testGroup "tests"+  [ testGroup "simple"+    [ testCase "string" $ do+          annos <- annotateStackStringIO "Test" $ do+            collectStackAnnotations++          length annos @?= 1+    , testCase "show" $ do+        annos <- annotateStackShowIO @(Int, Int) (4, 5) $ do+          collectStackAnnotations++        length annos @?= 1+    , testCase "callstack" $ do+        annos <- annotateCallStackIO $ do+          collectStackAnnotations++        length annos @?= 1+    , testCase "custom" $ do+        annos <- annotateStackIO CustomAnnotation $ do+          collectStackAnnotations++        length annos @?= 1+    , testCase "all" $ do+        annos <-+          annotateStackIO CustomAnnotation $+            annotateCallStackIO $+              annotateStackShowIO @(Int, Int) (4, 5) $+                annotateStackStringIO "Test" $ do+                  collectStackAnnotations++        length annos @?= 4+    ]+  , needsSourceLocations $ testGroup "source locations"+    [ testCase "string" $ do+        annos <- annotateStackStringIO "Test" $ do+          collectStackAnnotations++        length annos @?= 1+        let srcLocs = Maybe.mapMaybe stackAnnotationSourceLocation annos+        length srcLocs @?= 1+        fmap srcLocModule srcLocs @?= ["Main"]+    , testCase "show" $ do+        annos <- annotateStackShowIO @(Int, Int) (4, 5) $ do+          collectStackAnnotations++        length annos @?= 1+        let srcLocs = Maybe.mapMaybe stackAnnotationSourceLocation annos+        length srcLocs @?= 1+        fmap srcLocModule srcLocs @?= ["Main"]+    , testCase "callstack" $ do+        annos <- annotateCallStackIO $ do+          collectStackAnnotations++        length annos @?= 1+        let srcLocs = Maybe.mapMaybe stackAnnotationSourceLocation annos+        length srcLocs @?= 1+        fmap srcLocModule srcLocs @?= ["Main"]+    , testCase "custom" $ do+        annos <- annotateStackIO annoWithSrcLoc $ do+          collectStackAnnotations++        length annos @?= 1+        let srcLocs = Maybe.mapMaybe stackAnnotationSourceLocation annos+        length srcLocs @?= 1+    , testCase "all" $ do+        annos <-+          annotateStackIO CustomAnnotation $+            annotateStackIO annoWithSrcLoc $+              annotateCallStackIO $+                annotateStackShowIO @(Int, Int) (4, 5) $+                  annotateStackStringIO "Test" $ do+                    collectStackAnnotations++        length annos @?= 5+        let srcLocs = Maybe.mapMaybe stackAnnotationSourceLocation annos+        length srcLocs @?= 4+        -- No source location for CustomAnnotation is missing+        fmap srcLocModule srcLocs @?= replicate 4 "Main"+    ]+  ]++data CustomAnnotation = CustomAnnotation++-- This is implicitly a test, that we can define instances compatible with the latest+-- ghc-experimental version of 'StackAnnotation'.+instance StackAnnotation CustomAnnotation where+  displayStackAnnotation CustomAnnotation = "CustomAnnotation"++annoWithSrcLoc :: HasCallStack => CustomAnnotationWithSrcLoc+annoWithSrcLoc =+  CustomAnnotationWithSrcLoc loc+  where+    loc = case getCallStack ?callStack of+      [] -> Nothing+      ((_, srcLoc):_) -> Just srcLoc++data CustomAnnotationWithSrcLoc = CustomAnnotationWithSrcLoc (Maybe SrcLoc)++-- This is implicitly a test, that we can define instances compatible with the latest+-- ghc-experimental version of 'StackAnnotation'.+instance StackAnnotation CustomAnnotationWithSrcLoc where+  displayStackAnnotationShort CustomAnnotationWithSrcLoc{} = "CustomAnnotation"+  stackAnnotationSourceLocation (CustomAnnotationWithSrcLoc loc) = loc++needsStackAnnotations :: TestTree -> TestTree+needsStackAnnotations =+#if defined(SUPPORT_STACK_ANN)+  id+#else+  ignoreTestBecause "Stack Annotations not supported on GHC <9.14"+#endif++needsSourceLocations :: TestTree -> TestTree+needsSourceLocations =+#if !defined(SUPPORT_STACK_ANN_SRCLOC)+  ignoreTestBecause "Stack Annotations not supported on GHC <9.14.2"+#else+  id+#endif