diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/cbits/macros.h b/cbits/macros.h new file mode 100644 --- /dev/null +++ b/cbits/macros.h @@ -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 diff --git a/ghc-stack-annotations.cabal b/ghc-stack-annotations.cabal --- a/ghc-stack-annotations.cabal +++ b/ghc-stack-annotations.cabal @@ -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 diff --git a/src/GHC/Stack/Annotation.hs b/src/GHC/Stack/Annotation.hs --- a/src/GHC/Stack/Annotation.hs +++ b/src/GHC/Stack/Annotation.hs @@ -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 - [] -> "" - ((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 diff --git a/src/GHC/Stack/Annotation/Compat.hs b/src/GHC/Stack/Annotation/Compat.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Stack/Annotation/Compat.hs @@ -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) diff --git a/src/GHC/Stack/Annotation/Compat/Class.hs b/src/GHC/Stack/Annotation/Compat/Class.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Stack/Annotation/Compat/Class.hs @@ -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 diff --git a/src/GHC/Stack/Annotation/Types.hs b/src/GHC/Stack/Annotation/Types.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Stack/Annotation/Types.hs @@ -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 + [] -> "" + (fnName, _):_ -> fnName diff --git a/src/GHC/Stack/Annotation/UnliftIO.hs b/src/GHC/Stack/Annotation/UnliftIO.hs new file mode 100644 --- /dev/null +++ b/src/GHC/Stack/Annotation/UnliftIO.hs @@ -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) diff --git a/test/Compat.hs b/test/Compat.hs new file mode 100644 --- /dev/null +++ b/test/Compat.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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