├── .editorconfig ├── .github └── workflows │ └── cabal.yml ├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── Readme.md ├── example └── Main.hs ├── haskell-stack-trace-plugin.cabal ├── src └── StackTrace │ └── Plugin.hs └── test ├── Spec.hs └── StackTrace └── PluginSpec.hs /.editorconfig: -------------------------------------------------------------------------------- 1 | root = true 2 | 3 | [*] 4 | end_of_line = lf 5 | insert_final_newline = true 6 | 7 | [*.hs] 8 | indent_style = space 9 | indent_size = 2 10 | trim_trailing_whitespace = true 11 | insert_final_newline = true 12 | charset = utf-8 13 | end_of_line = lf 14 | 15 | [Makefile] 16 | indent_style = tab 17 | -------------------------------------------------------------------------------- /.github/workflows/cabal.yml: -------------------------------------------------------------------------------- 1 | name: cabal 2 | on: 3 | push: 4 | branches: [main] 5 | pull_request: 6 | branches: ['*'] 7 | jobs: 8 | build: 9 | runs-on: ubuntu-20.04 10 | strategy: 11 | fail-fast: false 12 | matrix: 13 | ghc-version: ["8.6", "8.8", "8.10", "9.4", "9.6", "9.8", "9.10", "9.12"] 14 | cabal-version: ["3.12"] 15 | cache-version: ["2025-01-01"] 16 | steps: 17 | - uses: actions/checkout@v4 18 | - name: Set up GHC ${{ matrix.ghc-version }} 19 | uses: haskell-actions/setup@v2 20 | id: setup 21 | with: 22 | ghc-version: ${{ matrix.ghc-version }} 23 | cabal-version: ${{ matrix.cabal-version }} 24 | cabal-update: true 25 | - name: Configure the build 26 | run: | 27 | cabal configure --enable-tests --disable-documentation --disable-optimization --write-ghc-environment-files=always -j2 28 | cabal build all --dry-run 29 | - name: Restore cached dependencies 30 | uses: actions/cache/restore@v4 31 | id: cache 32 | env: 33 | key: ${{ runner.os }}-ghc-${{ steps.setup.outputs.ghc-version }}-cabal-${{ steps.setup.outputs.cabal-version }}-${{ matrix.cache-version }} 34 | with: 35 | path: ${{ steps.setup.outputs.cabal-store }} 36 | key: ${{ env.key }}-plan-${{ hashFiles('**/plan.json') }} 37 | restore-keys: ${{ env.key }}- 38 | - name: Install dependencies 39 | # If we had an exact cache hit, the dependencies will be up to date. 40 | if: steps.cache.outputs.cache-hit != 'true' 41 | run: cabal build all --only-dependencies 42 | # Cache dependencies already here, so that we do not have to rebuild them should the subsequent steps fail. 43 | - name: Save cached dependencies 44 | uses: actions/cache/save@v4 45 | # If we had an exact cache hit, trying to save the cache would error because of key clash. 46 | if: steps.cache.outputs.cache-hit != 'true' 47 | with: 48 | path: ${{ steps.setup.outputs.cabal-store }} 49 | key: ${{ steps.cache.outputs.cache-primary-key }} 50 | - name: Build 51 | run: cabal build all --flag dev 52 | - name: Run tests 53 | run: cabal test all --flag dev 54 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist/ 2 | dist-*/ 3 | .ghc.environment.* 4 | cabal.project.local 5 | 6 | *~ 7 | tasks.json 8 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Revision history for haskell-stack-trace-pugin 2 | 3 | ## Unreleased changes 4 | 5 | - Warnings of unused imports in GHC-9 [#16](https://github.com/waddlaw/haskell-stack-trace-plugin/issues/16) (@s9gf4ult) 6 | 7 | ## 0.1.3.0 8 | 9 | - Added support `where` clause [#11](https://github.com/waddlaw/haskell-stack-trace-plugin/pull/11) (@waddlaw) 10 | - Avoid redundant-constraints warnings [#12](https://github.com/waddlaw/haskell-stack-trace-plugin/pull/12) (@waddlaw) 11 | 12 | ## 0.1.2.0 -- 2021-05-21 13 | 14 | - Added support for GHC 8.10 [#7](https://github.com/waddlaw/haskell-stack-trace-plugin/pull/7) (@etorreborre) 15 | - Added support for GHC 9.0 @waddlaw 16 | 17 | ## 0.1.1.1 -- 2020-01-18 18 | 19 | - Allow GHC-8.8.1 20 | 21 | ## 0.1.1.0 -- 2020-01-18 22 | 23 | - Ergonomic improvements [#1](https://github.com/waddlaw/haskell-stack-trace-plugin/pull/1) (@khwarizmii) 24 | - Add Integration test 25 | - Add GitHub Action 26 | 27 | ## 0.1.0.0 -- 2018-12-07 28 | 29 | - First version. Released on an unsuspecting world. 30 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2018-2022 Shinya Yamaguchi 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /Readme.md: -------------------------------------------------------------------------------- 1 | # haskell-stack-trace-plugin 2 | 3 | ![](https://github.com/waddlaw/haskell-stack-trace-plugin/workflows/cabal/badge.svg) 4 | [![Hackage](https://img.shields.io/hackage/v/haskell-stack-trace-plugin.svg)](https://hackage.haskell.org/package/haskell-stack-trace-plugin) 5 | 6 | This plugin allow implicitly add `HasCallStack` class to every top-level function for all module. Hence, we can to get completely continuous call stack. 7 | 8 | 1. (implicitly) Import [GHC.Stack](https://hackage.haskell.org/package/base/docs/GHC-Stack.html) for all modules. 9 | 2. Add [HasCallStack](https://hackage.haskell.org/package/base/docs/GHC-Stack.html#t:HasCallStack) constraint for all top-level functions. 10 | 3. Other supported syntaxes 11 | - [x] `where` clause 12 | 13 | Requirement: (8.6 <= on GHC) 14 | 15 | ## Synopsis 16 | 17 | ```haskell 18 | module Main where 19 | 20 | import Data.Maybe (fromJust) 21 | 22 | main :: IO () 23 | main = print f1 24 | 25 | f1 :: Int 26 | f1 = f2 27 | 28 | f2 :: Int 29 | f2 = f3 30 | 31 | -- HsQualTy 32 | f3 :: HasCallStack => Int 33 | f3 = f4 0 34 | 35 | -- HsQualTy 36 | f4 :: Show a => a -> Int 37 | f4 n = f5 (show n) 0 38 | 39 | -- HsFunTy 40 | f5 :: String -> Int -> Int 41 | f5 _ _ = head f6 42 | 43 | -- HsListTy 44 | f6 :: [Int] 45 | f6 = [fst f7] 46 | 47 | -- HsTupleTy 48 | f7 :: (Int, Int) 49 | f7 = (fromJust f8, fromJust f8) 50 | 51 | -- HsAppTy 52 | f8 :: Maybe Int 53 | f8 = Just f9 54 | 55 | f9 :: Int 56 | f9 = f10 57 | where 58 | f10 :: Int 59 | f10 = fError 60 | 61 | -- HsTyVar 62 | fError :: Int 63 | fError = error "fError" 64 | ``` 65 | 66 | This example get error: 67 | 68 | ```shell 69 | $ cabal build 70 | example/Main.hs:15:7: error: 71 | Not in scope: type constructor or class ‘HasCallStack’ 72 | | 73 | 15 | f3 :: HasCallStack => Int 74 | | ^^^^^^^^^^^^ 75 | ``` 76 | 77 | Yes, add `import GHC.Stack` to above example. 78 | 79 | Fix and rebuild! 80 | 81 | ```shell 82 | $ cabal run example -v0 83 | example: fError 84 | CallStack (from HasCallStack): 85 | error, called at example/Main.hs:47:10 in main:Main 86 | ``` 87 | 88 | Hmm, it is not useful. But, you will to be happy when enable this plugin. 89 | 90 | ```cabal 91 | ghc-options: 92 | -fplugin=StackTrace.Plugin 93 | ``` 94 | 95 | ```shell 96 | $ cabal run example -v0 97 | example: fError 98 | CallStack (from HasCallStack): 99 | error, called at example/Main.hs:47:10 in main:Main 100 | fError, called at example/Main.hs:43:11 in main:Main 101 | f10, called at example/Main.hs:40:6 in main:Main 102 | f9, called at example/Main.hs:37:11 in main:Main 103 | f8, called at example/Main.hs:33:16 in main:Main 104 | f7, called at example/Main.hs:29:11 in main:Main 105 | f6, called at example/Main.hs:25:15 in main:Main 106 | f5, called at example/Main.hs:21:8 in main:Main 107 | f4, called at example/Main.hs:17:6 in main:Main 108 | f3, called at example/Main.hs:13:6 in main:Main 109 | f2, called at example/Main.hs:10:6 in main:Main 110 | f1, called at example/Main.hs:7:14 in main:Main 111 | main, called at example/Main.hs:7:1 in main:Main 112 | ``` 113 | 114 | Great!!! 115 | -------------------------------------------------------------------------------- /example/Main.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Data.Maybe (fromJust) 4 | import GHC.Stack 5 | 6 | main :: IO () 7 | main = print f1 8 | 9 | f1 :: Int 10 | f1 = f2 11 | 12 | f2 :: Int 13 | f2 = f3 14 | 15 | -- HsQualTy 16 | f3 :: HasCallStack => Int 17 | f3 = f4 0 18 | 19 | -- HsQualTy 20 | f4 :: Show a => a -> Int 21 | f4 n = f5 (show n) 0 22 | 23 | -- HsFunTy 24 | f5 :: String -> Int -> Int 25 | f5 _ _ = head f6 26 | 27 | -- HsListTy 28 | f6 :: [Int] 29 | f6 = [fst f7] 30 | 31 | -- HsTupleTy 32 | f7 :: (Int, Int) 33 | f7 = (fromJust f8, fromJust f8) 34 | 35 | -- HsAppTy 36 | f8 :: Maybe Int 37 | f8 = Just f9 38 | 39 | f9 :: Int 40 | f9 = f10 41 | where 42 | f10 :: Int 43 | f10 = fError 44 | 45 | -- HsTyVar 46 | fError :: Int 47 | fError = error "fError" 48 | -------------------------------------------------------------------------------- /haskell-stack-trace-plugin.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: haskell-stack-trace-plugin 3 | version: 0.1.3.0 4 | synopsis: haskell-stack-trace-plugin 5 | description: 6 | This plugin allow implicitly add HasCallStack class to every top-level function for all module. Hence, we can to get completely continuous call stack. 7 | 8 | homepage: https://github.com/waddlaw/haskell-stack-trace-plugin 9 | bug-reports: 10 | https://github.com/waddlaw/haskell-stack-trace-plugin/issues 11 | 12 | license: MIT 13 | license-file: LICENSE 14 | author: Shinya Yamaguchi 15 | maintainer: a@wado.dev 16 | copyright: 2018-2022 Shinya Yamaguchi 17 | category: Compiler Plugin, Development, Debug 18 | build-type: Simple 19 | extra-source-files: 20 | CHANGELOG.md 21 | Readme.md 22 | 23 | tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.7 || ==9.4.8 || ==9.6.6 || ==9.8.4 || ==9.10.1 || ==9.12.1 24 | 25 | source-repository head 26 | type: git 27 | location: git://github.com/waddlaw/haskell-stack-trace-plugin 28 | 29 | flag dev 30 | description: Turn on development settings. 31 | manual: True 32 | default: False 33 | 34 | common common-opts 35 | build-depends: base >=4.12 && <4.22 36 | default-language: Haskell2010 37 | 38 | library 39 | import: common-opts 40 | hs-source-dirs: src 41 | build-depends: ghc ^>=8.6 || ^>=8.8 || ^>=8.10 || ^>=9.4 || ^>=9.6 || ^>=9.8 || ^>=9.10 || ^>=9.12 42 | exposed-modules: StackTrace.Plugin 43 | 44 | if flag(dev) 45 | ghc-options: 46 | -Wall -Werror -Wcompat -Wincomplete-uni-patterns 47 | -Wnoncanonical-monad-instances -Wno-missing-home-modules 48 | 49 | else 50 | ghc-options: -Wall 51 | 52 | test-suite test 53 | import: common-opts 54 | main-is: Spec.hs 55 | hs-source-dirs: test 56 | type: exitcode-stdio-1.0 57 | build-depends: 58 | , bytestring >=0.10 59 | , hspec ^>=2.8 || ^>=2.11 60 | , raw-strings-qq ^>=1.1 61 | , regex-tdfa ^>=1.3 62 | , typed-process ^>=0.2 63 | 64 | build-tool-depends: hspec-discover:hspec-discover ^>=2.8 65 | other-modules: StackTrace.PluginSpec 66 | 67 | if flag(dev) 68 | ghc-options: -Wall -Werror 69 | 70 | else 71 | ghc-options: -Wall 72 | 73 | executable example 74 | import: common-opts 75 | main-is: Main.hs 76 | hs-source-dirs: example 77 | ghc-options: -fplugin=StackTrace.Plugin -Wredundant-constraints 78 | build-depends: haskell-stack-trace-plugin 79 | -------------------------------------------------------------------------------- /src/StackTrace/Plugin.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE CPP #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | module StackTrace.Plugin (plugin) where 6 | 7 | import Control.Arrow (first) 8 | import Data.Monoid (Any(Any, getAny)) 9 | 10 | #if __GLASGOW_HASKELL__ >= 900 11 | import GHC.Plugins 12 | #else 13 | import GhcPlugins 14 | #endif 15 | 16 | #if __GLASGOW_HASKELL__ >= 810 17 | import GHC.Hs 18 | #endif 19 | 20 | #if __GLASGOW_HASKELL__ < 810 21 | import HsSyn 22 | #endif 23 | 24 | -- srcSpan now requires strict maybe 25 | #if __GLASGOW_HASKELL__ >= 904 26 | import GHC.Data.Strict as Strict (Maybe (Nothing)) 27 | #endif 28 | 29 | type Traversal s t a b 30 | = forall f. Applicative f => 31 | (a -> f b) -> s -> f t 32 | 33 | type Traversal' s a = Traversal s s a a 34 | 35 | #if __GLASGOW_HASKELL__ < 900 36 | emptyLoc :: e -> Located e 37 | emptyLoc = noLoc 38 | #elif __GLASGOW_HASKELL__ < 910 39 | emptyLoc :: a -> LocatedAn an a 40 | emptyLoc = noLocA 41 | #else 42 | emptyLoc :: (HasAnnotation b) => e -> GenLocated b e 43 | emptyLoc = reLoc . noLoc 44 | #endif 45 | 46 | plugin :: Plugin 47 | plugin = defaultPlugin {parsedResultAction = parsedPlugin, pluginRecompile = purePlugin} 48 | 49 | #if __GLASGOW_HASKELL__ < 904 50 | parsedPlugin :: 51 | [CommandLineOption] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule 52 | parsedPlugin _ _ pm = do 53 | let m = updateHsModule <$> hpm_module pm 54 | pm' = pm {hpm_module = m} 55 | return pm' 56 | #else 57 | parsedPlugin :: 58 | [CommandLineOption] -> ModSummary -> ParsedResult -> Hsc ParsedResult 59 | parsedPlugin _ _ pr = do 60 | let pm = parsedResultModule pr 61 | m = updateHsModule <$> hpm_module pm 62 | pm' = pm {hpm_module = m} 63 | return pr {parsedResultModule = pm'} 64 | #endif 65 | 66 | 67 | -- Use qualified import for GHC.Stack as "AutoImported.GHC.Stack" 68 | -- ...this should not interfere with other imports... 69 | ghcStackModuleName :: ModuleName 70 | ghcStackModuleName = mkModuleName "AutoImported.GHC.Stack" 71 | 72 | #if __GLASGOW_HASKELL__ < 810 73 | importDeclQualified :: Bool 74 | importDeclQualified = True 75 | #else 76 | importDeclQualified :: ImportDeclQualifiedStyle 77 | importDeclQualified = QualifiedPre 78 | #endif 79 | 80 | 81 | #if __GLASGOW_HASKELL__ < 900 82 | ghcStackImport :: Located (ImportDecl GhcPs) 83 | ghcStackImport = 84 | L srcSpan $ 85 | (simpleImportDecl $ mkModuleName "GHC.Stack") 86 | { ideclQualified = importDeclQualified, ideclAs = ideclAs' } 87 | where 88 | ideclAs' = Just $ noLoc ghcStackModuleName 89 | srcSpan = RealSrcSpan (realSrcLocSpan $ mkRealSrcLoc "haskell-stack-trace-plugin:very-unique-file-name-to-avoid-collision" 1 1) 90 | #else 91 | ghcStackImport :: LImportDecl GhcPs 92 | ghcStackImport = 93 | reLoc' $ L srcSpan $ 94 | (simpleImportDecl $ mkModuleName "GHC.Stack") 95 | { ideclQualified = importDeclQualified, ideclAs = ideclAs' } 96 | where 97 | ideclAs' = Just $ emptyLoc ghcStackModuleName 98 | 99 | #if __GLASGOW_HASKELL__ >= 910 100 | reLoc' = reLoc 101 | #else 102 | reLoc' = reLocA 103 | #endif 104 | 105 | -- This is for GHC-9 related problems. @noLoc@ causes GHC to throw warnings 106 | -- about unused imports. Even if the import is used 107 | -- See: https://github.com/waddlaw/haskell-stack-trace-plugin/issues/16 108 | #if __GLASGOW_HASKELL__ >= 904 109 | srcSpan = RealSrcSpan (realSrcLocSpan $ mkRealSrcLoc "haskell-stack-trace-plugin:very-unique-file-name-to-avoid-collision" 1 1) Strict.Nothing 110 | #else 111 | srcSpan = RealSrcSpan (realSrcLocSpan $ mkRealSrcLoc "haskell-stack-trace-plugin:very-unique-file-name-to-avoid-collision" 1 1) Nothing 112 | #endif 113 | #endif 114 | 115 | #if __GLASGOW_HASKELL__ >= 900 && __GLASGOW_HASKELL__ < 906 116 | updateHsModule :: HsModule -> HsModule 117 | #else 118 | updateHsModule :: HsModule GhcPs -> HsModule GhcPs 119 | #endif 120 | updateHsModule hsm = 121 | hsm {hsmodImports = hsmodImports', hsmodDecls = hsmodDecls'} 122 | where 123 | -- Traverse the haskell AST; if we have to add some HasStack 124 | -- constraint we set a flag in a (Any,) functor. 125 | -- ...it'd be simpler to check if before == after, but Haskell AST 126 | -- doesn't have Eq instances. 127 | (updatedP, hsmodDecls') = 128 | first getAny $ 129 | (traverse . astTraversal) updateHsType (hsmodDecls hsm) 130 | 131 | -- Only import GHC.Stack if needed for a constraint we introduced 132 | hsmodImports' = 133 | (if updatedP 134 | then [ghcStackImport] 135 | else []) ++ 136 | hsmodImports hsm 137 | 138 | astTraversal :: Traversal' (LHsDecl GhcPs) (HsType GhcPs) 139 | astTraversal = updateHsmodDecl 140 | . updateHsDecl 141 | . updateLHsSigWsType 142 | . updateLHsSigType 143 | . updateLHsType 144 | 145 | -------------- 146 | updateHsmodDecl :: Traversal' (LHsDecl GhcPs) (HsDecl GhcPs) 147 | updateHsmodDecl = traverse 148 | 149 | updateHsDecl :: Traversal' (HsDecl GhcPs) (LHsSigWcType GhcPs) 150 | updateHsDecl f (SigD xSig s) = SigD xSig <$> updateSig f s 151 | updateHsDecl f (ValD xVal hsBind) = ValD xVal <$> updateHsBind f hsBind 152 | updateHsDecl _ sig = pure sig 153 | 154 | updateHsBind :: Traversal' (HsBind GhcPs) (LHsSigWcType GhcPs) 155 | updateHsBind f bind@FunBind {} = (\x -> bind {fun_matches = x}) <$> updateMatchGroup f (fun_matches bind) 156 | updateHsBind _ bind = pure bind 157 | 158 | updateMatchGroup :: Traversal' (MatchGroup GhcPs (LHsExpr GhcPs)) (LHsSigWcType GhcPs) 159 | updateMatchGroup f mg@MG {} = (\x -> mg {mg_alts = x}) <$> updateLLMatch f (mg_alts mg) 160 | #if __GLASGOW_HASKELL__ < 900 161 | updateMatchGroup _ mg = pure mg 162 | #endif 163 | 164 | #if __GLASGOW_HASKELL__ < 900 165 | updateLocated :: Functor f => (a -> b -> f c) -> a -> Located b -> f (Located c) 166 | updateLocated f g (L l e) = L l <$> f g e 167 | #endif 168 | 169 | #if __GLASGOW_HASKELL__ < 900 170 | updateLLMatch :: Traversal' (Located [LMatch GhcPs (LHsExpr GhcPs)]) (LHsSigWcType GhcPs) 171 | updateLLMatch = updateLocated updateLMatches 172 | #else 173 | updateLLMatch :: Traversal' (XRec GhcPs [LMatch GhcPs (LHsExpr GhcPs)]) (LHsSigWcType GhcPs) 174 | updateLLMatch = traverse . updateLMatches 175 | #endif 176 | 177 | updateLMatches :: Traversal' [LMatch GhcPs (LHsExpr GhcPs)] (LHsSigWcType GhcPs) 178 | #if __GLASGOW_HASKELL__ < 900 179 | updateLMatches f = traverse (updateLocated updateMatch f) 180 | #else 181 | updateLMatches = traverse . traverse . updateMatch 182 | #endif 183 | 184 | updateMatch :: Traversal' (Match GhcPs (LHsExpr GhcPs)) (LHsSigWcType GhcPs) 185 | updateMatch f m@Match {} = (\x -> m {m_grhss = x}) <$> updateGrhss f (m_grhss m) 186 | #if __GLASGOW_HASKELL__ < 900 187 | updateMatch _ m = pure m 188 | #endif 189 | 190 | updateGrhss :: Traversal' (GRHSs GhcPs (LHsExpr GhcPs)) (LHsSigWcType GhcPs) 191 | #if __GLASGOW_HASKELL__ < 900 192 | updateGrhss f grhss@GRHSs {} = (\x -> grhss {grhssLocalBinds = x}) <$> updateLHsLocalBinds f (grhssLocalBinds grhss) 193 | updateGrhss _ grhss = pure grhss 194 | #else 195 | updateGrhss f grhss = (\x -> grhss {grhssLocalBinds = x}) <$> updateLocalBinds f (grhssLocalBinds grhss) 196 | #endif 197 | 198 | #if __GLASGOW_HASKELL__ < 900 199 | updateLHsLocalBinds :: Traversal' (LHsLocalBinds GhcPs) (LHsSigWcType GhcPs) 200 | updateLHsLocalBinds = updateLocated updateLocalBinds 201 | #endif 202 | 203 | updateLocalBinds :: Traversal' (HsLocalBinds GhcPs) (LHsSigWcType GhcPs) 204 | updateLocalBinds f (HsValBinds xHsValBinds hsValBindsLR) = HsValBinds xHsValBinds <$> updateHsValBindsLR f hsValBindsLR 205 | updateLocalBinds _ hsValBinds = pure hsValBinds 206 | 207 | updateHsValBindsLR :: Traversal' (HsValBindsLR GhcPs GhcPs) (LHsSigWcType GhcPs) 208 | updateHsValBindsLR f (ValBinds xValBinds lHsBindsLR lSigs) = ValBinds xValBinds lHsBindsLR <$> updateLSigs f lSigs 209 | updateHsValBindsLR _ valBinds = pure valBinds 210 | 211 | updateLSigs :: Traversal' [LSig GhcPs] (LHsSigWcType GhcPs) 212 | #if __GLASGOW_HASKELL__ < 900 213 | updateLSigs f = traverse (updateLocated updateSig f) 214 | #else 215 | updateLSigs = traverse . traverse . updateSig 216 | #endif 217 | 218 | updateSig :: Traversal' (Sig GhcPs) (LHsSigWcType GhcPs) 219 | updateSig f (TypeSig xSig ls t) = TypeSig xSig ls <$> f t 220 | updateSig _ sig = pure sig 221 | 222 | updateLHsSigWsType :: Traversal' (LHsSigWcType GhcPs) (LHsSigType GhcPs) 223 | updateLHsSigWsType f lhs@HsWC {} = 224 | (\x -> lhs {hswc_body = x}) <$> f (hswc_body lhs) 225 | #if __GLASGOW_HASKELL__ < 900 226 | updateLHsSigWsType _ lhs = pure lhs 227 | #endif 228 | 229 | updateLHsSigType :: Traversal' (LHsSigType GhcPs) (LHsType GhcPs) 230 | #if __GLASGOW_HASKELL__ >= 902 231 | updateLHsSigType = traverse . updateHsSigType 232 | #else 233 | updateLHsSigType f lhs@HsIB {} = 234 | (\x -> lhs {hsib_body = x}) <$> f (hsib_body lhs) 235 | #endif 236 | #if __GLASGOW_HASKELL__ < 900 237 | updateLHsSigType _ lhs = pure lhs 238 | #endif 239 | 240 | 241 | #if __GLASGOW_HASKELL__ >= 902 242 | updateHsSigType :: Traversal' (HsSigType GhcPs) (LHsType GhcPs) 243 | updateHsSigType f hs@HsSig {} = (\x -> hs {sig_body = x}) <$> f (sig_body hs) 244 | #endif 245 | updateLHsType :: Traversal' (LHsType GhcPs) (HsType GhcPs) 246 | updateLHsType = traverse 247 | 248 | -- | Wraps an HsType with a HasStackCall qualifier 249 | wrapInQualTy :: HsType GhcPs -> (Any, HsType GhcPs) 250 | wrapInQualTy ty = 251 | flagASTModified $ HsQualTy xQualTy (emptyLoc $ appendHSC []) (emptyLoc ty) 252 | 253 | -- Main process 254 | updateHsType :: HsType GhcPs -> (Any, HsType GhcPs) 255 | updateHsType ty@(HsQualTy xty ctxt body) = 256 | if hasHasCallStack (unLoc ctxt) 257 | then pure ty 258 | else flagASTModified $ HsQualTy xty (fmap appendHSC ctxt) body 259 | updateHsType ty@HsTyVar {} = wrapInQualTy ty 260 | updateHsType ty@HsAppTy {} = wrapInQualTy ty 261 | updateHsType ty@HsFunTy {} = wrapInQualTy ty 262 | updateHsType ty@HsListTy {} = wrapInQualTy ty 263 | updateHsType ty@HsTupleTy {} = wrapInQualTy ty 264 | updateHsType ty = pure ty 265 | 266 | #if __GLASGOW_HASKELL__ < 810 267 | xQualTy :: NoExt 268 | xQualTy = noExt 269 | #else 270 | xQualTy :: NoExtField 271 | xQualTy = NoExtField 272 | #endif 273 | 274 | flagASTModified :: a -> (Any, a) 275 | flagASTModified a = (Any True, a) 276 | 277 | appendHSC :: HsContext GhcPs -> HsContext GhcPs 278 | appendHSC cs = mkHSC : cs 279 | 280 | hasHasCallStack :: HsContext GhcPs -> Bool 281 | hasHasCallStack = any (checkHsType . unLoc) 282 | where 283 | checkHsType :: HsType GhcPs -> Bool 284 | checkHsType (HsTyVar _ _ lid) = unLoc lid == (mkRdrUnqual $ mkClsOcc "HasCallStack") 285 | checkHsType _ = False 286 | 287 | xTyVar :: XTyVar GhcPs 288 | #if __GLASGOW_HASKELL__ >= 912 289 | xTyVar = NoEpTok 290 | #elif __GLASGOW_HASKELL__ >= 910 291 | xTyVar = [] 292 | #elif __GLASGOW_HASKELL__ >= 900 293 | xTyVar = noAnn 294 | #else 295 | xTyVar = xQualTy 296 | #endif 297 | 298 | -- make HasCallStack => constraint 299 | mkHSC :: LHsType GhcPs 300 | mkHSC = emptyLoc $ HsTyVar xTyVar NotPromoted lId 301 | 302 | 303 | #if __GLASGOW_HASKELL__ < 900 304 | lId :: Located (IdP GhcPs) 305 | lId = noLoc $ mkRdrQual ghcStackModuleName $ mkClsOcc "HasCallStack" 306 | #else 307 | lId :: LIdP GhcPs 308 | lId = emptyLoc $ mkRdrQual ghcStackModuleName $ mkClsOcc "HasCallStack" 309 | #endif 310 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /test/StackTrace/PluginSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE QuasiQuotes #-} 3 | 4 | module StackTrace.PluginSpec (spec) where 5 | 6 | import Data.ByteString.Lazy (ByteString) 7 | import qualified Data.ByteString.Lazy.Char8 as BS 8 | import System.Process.Typed 9 | import Test.Hspec 10 | import Text.RawString.QQ 11 | import Text.Regex.TDFA ((=~)) 12 | 13 | -- | Extracts the function names of all functions that appear in a stack trace 14 | extractStackTraceFunctions :: String -> [String] 15 | extractStackTraceFunctions input = map extractFunctionName matches 16 | where 17 | regex = [r|[ ]*([A-Za-z0-9]+), called at example/Main.hs:[0-9]+:[0-9]+ in [^:]+:Main|] :: String 18 | matches = (input =~ regex) :: [[String]] 19 | extractFunctionName :: [String] -> String 20 | extractFunctionName (_ : name : _) = name 21 | extractFunctionName _ = error "Regex match failed" 22 | 23 | spec :: Spec 24 | spec = do 25 | output <- runIO exe 26 | let outputStr = BS.unpack output 27 | let extractedFunctions = extractStackTraceFunctions outputStr 28 | 29 | -- each of these exceptions should appear in the stack trace 30 | let expectedFunctions = ["error", "fError", "f10", "f9", "f8", "f7", "f6", "f5", "f4", "f3", "f2", "f1", "main"] :: [String] 31 | 32 | it "integration test" $ extractedFunctions `shouldBe` expectedFunctions 33 | 34 | exe :: IO ByteString 35 | exe = do 36 | runProcess_ $ shell "cabal install exe:example --installdir=./dist" 37 | err <- readProcessStderr_ $ shell "./dist/example || true" 38 | runProcess_ $ shell "rm -rf ./dist" 39 | return err 40 | --------------------------------------------------------------------------------