git.iko.soy/typeable/haskell-stack-trace-plugin
on master help sign in
swap
6624a5945 ahead, 0 behind
.github/workflows/cabal.ymlnew file+44
since splitsnapshots
unifiedsplit
@@ -0,0 +1,44 @@
1+name: cabal
2+
3+on:
4+ push:
5+ branches: [ master ]
6+ pull_request:
7+ branches: [ '*' ]
8+ schedule:
9+ - cron: "00 15 * * *"
10+
11+jobs:
12+ build:
13+ runs-on: ubuntu-18.04
14+ strategy:
15+ matrix:
16+ ghc: ["8.6", "8.8", "8.10", "9.0"]
17+ cabal: ["3.2"]
18+ cache-version: ["2021-05-21"]
19+
20+ steps:
21+ - uses: actions/checkout@v2
22+ - uses: haskell/actions/setup@v1
23+ with:
24+ ghc-version: ${{ matrix.ghc }}
25+ cabal-version: ${{ matrix.cabal }}
26+
27+ - name: Cache ~/.cabal/store
28+ uses: actions/cache@v2
29+ with:
30+ path: |
31+ ~/.cabal/store
32+ dist-newstyle
33+ key: ${{ runner.os }}-${{ matrix.ghc }}-${{ matrix.cache-version }}-cabal
34+
35+ - name: Install dependencies
36+ run: |
37+ cabal update
38+ cabal configure --disable-optimization --enable-tests --write-ghc-environment-files=always -j2
39+ cabal build --only-dependencies
40+
41+ - name: Build & Test
42+ run: |
43+ cabal build --flag dev
44+ cabal test --flag dev
.gitignore+2−1
@@ -3,4 +3,5 @@ dist-*/
3.ghc.environment.*
3.ghc.environment.*
4cabal.project.local
4cabal.project.local
5
5
6−*~
6+*~
7+tasks.json
CHANGELOG.md+23−1
@@ -1,5 +1,27 @@
1# Revision history for haskell-stack-trace-pugin
1# Revision history for haskell-stack-trace-pugin
2
2
3+## Unreleased changes
4+
5+## 0.1.3.0
6+
7+- Added support `where` clause [#11](https://github.com/waddlaw/haskell-stack-trace-plugin/pull/11) (@waddlaw)
8+- Avoid redundant-constraints warnings [#12](https://github.com/waddlaw/haskell-stack-trace-plugin/pull/12) (@waddlaw)
9+
10+## 0.1.2.0 -- 2021-05-21
11+
12+- Added support for GHC 8.10 [#7](https://github.com/waddlaw/haskell-stack-trace-plugin/pull/7) (@etorreborre)
13+- Added support for GHC 9.0 @waddlaw
14+
15+## 0.1.1.1 -- 2020-01-18
16+
17+- Allow GHC-8.8.1
18+
19+## 0.1.1.0 -- 2020-01-18
20+
21+- Ergonomic improvements [#1](https://github.com/waddlaw/haskell-stack-trace-plugin/pull/1) (@khwarizmii)
22+- Add Integration test
23+- Add GitHub Action
24+
3## 0.1.0.0 -- 2018-12-07
25## 0.1.0.0 -- 2018-12-07
4
26
5−* First version. Released on an unsuspecting world.
27+- First version. Released on an unsuspecting world.
LICENSE+1−1
@@ -1,4 +1,4 @@
1−Copyright (c) 2018 Shinya Yamaguchi
1+Copyright (c) 2018-2021 Shinya Yamaguchi
2
2
3Permission is hereby granted, free of charge, to any person obtaining
3Permission is hereby granted, free of charge, to any person obtaining
4a copy of this software and associated documentation files (the
4a copy of this software and associated documentation files (the
Readme.md+34−23
@@ -1,9 +1,14 @@
1# haskell-stack-trace-plugin
1# haskell-stack-trace-plugin
2
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+
3This plugin allow implicitly add `HasCallStack` class to every top-level function for all module. Hence, we can to get completely continuous call stack.
6This plugin allow implicitly add `HasCallStack` class to every top-level function for all module. Hence, we can to get completely continuous call stack.
4
7
5−1. (implicitly) Import [GHC.Stack](https://www.stackage.org/haddock/lts-12.21/base-4.11.1.0/GHC-Stack.html) for all modules.
8+1. (implicitly) Import [GHC.Stack](https://hackage.haskell.org/package/base/docs/GHC-Stack.html) for all modules.
6−2. Add [HasCallStack](https://www.stackage.org/haddock/lts-12.21/base-4.11.1.0/GHC-Stack.html#t:HasCallStack) constraint for all top-level functions.
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
7
12
8Requirement: (8.6 <= on GHC)
13Requirement: (8.6 <= on GHC)
9
14
@@ -29,10 +34,10 @@ f3 = f4 0
29
34
30-- HsQualTy
35-- HsQualTy
31f4 :: Show a => a -> Int
36f4 :: Show a => a -> Int
32−f4 _ = f5 0 0
37+f4 n = f5 (show n) 0
33
38
34-- HsFunTy
39-- HsFunTy
35−f5 :: Int -> Int -> Int
40+f5 :: String -> Int -> Int
36f5 _ _ = head f6
41f5 _ _ = head f6
37
42
38-- HsListTy
43-- HsListTy
@@ -45,7 +50,13 @@ f7 = (fromJust f8, fromJust f8)
45
50
46-- HsAppTy
51-- HsAppTy
47f8 :: Maybe Int
52f8 :: Maybe Int
48−f8 = Just fError
53+f8 = Just f9
54+
55+f9 :: Int
56+f9 = f10
57+ where
58+ f10 :: Int
59+ f10 = fError
49
60
50-- HsTyVar
61-- HsTyVar
51fError :: Int
62fError :: Int
@@ -55,7 +66,7 @@ fError = error "fError"
55This example get error:
66This example get error:
56
67
57```shell
68```shell
58−$ cabal new-build
69+$ cabal build
59example/Main.hs:15:7: error:
70example/Main.hs:15:7: error:
60 Not in scope: type constructor or class ‘HasCallStack’
71 Not in scope: type constructor or class ‘HasCallStack’
61 |
72 |
@@ -68,10 +79,10 @@ Yes, add `import GHC.Stack` to above example.
68Fix and rebuild!
79Fix and rebuild!
69
80
70```shell
81```shell
71−$ cabal new-run
82+$ cabal run example -v0
72example: fError
83example: fError
73CallStack (from HasCallStack):
84CallStack (from HasCallStack):
74− error, called at example/Main.hs:41:10 in main:Main
85+ error, called at example/Main.hs:47:10 in main:Main
75```
86```
76
87
77Hmm, it is not useful. But, you will to be happy when enable this plugin.
88Hmm, it is not useful. But, you will to be happy when enable this plugin.
@@ -82,22 +93,22 @@ Hmm, it is not useful. But, you will to be happy when enable this plugin.
82```
93```
83
94
84```shell
95```shell
85−$ cabal new-run
96+$ cabal run example -v0
86−...
87−
88example: fError
97example: fError
89CallStack (from HasCallStack):
98CallStack (from HasCallStack):
90− error, called at example/Main.hs:40:10 in main:Main
99+ error, called at example/Main.hs:47:10 in main:Main
91− fError, called at example/Main.hs:36:11 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
92− f8, called at example/Main.hs:32:16 in main:Main
103+ f8, called at example/Main.hs:33:16 in main:Main
93− f7, called at example/Main.hs:28:11 in main:Main
104+ f7, called at example/Main.hs:29:11 in main:Main
94− f6, called at example/Main.hs:24:15 in main:Main
105+ f6, called at example/Main.hs:25:15 in main:Main
95− f5, called at example/Main.hs:20:8 in main:Main
106+ f5, called at example/Main.hs:21:8 in main:Main
96− f4, called at example/Main.hs:16:6 in main:Main
107+ f4, called at example/Main.hs:17:6 in main:Main
97− f3, called at example/Main.hs:12:6 in main:Main
108+ f3, called at example/Main.hs:13:6 in main:Main
98− f2, called at example/Main.hs:9:6 in main:Main
109+ f2, called at example/Main.hs:10:6 in main:Main
99− f1, called at example/Main.hs:6:14 in main:Main
110+ f1, called at example/Main.hs:7:14 in main:Main
100− main, called at example/Main.hs:6:1 in main:Main
111+ main, called at example/Main.hs:7:1 in main:Main
101```
112```
102
113
103−Great!!!
114+Great!!!
example/Main.hs+9−3
@@ -18,10 +18,10 @@ f3 = f4 0
18
18
19-- HsQualTy
19-- HsQualTy
20f4 :: Show a => a -> Int
20f4 :: Show a => a -> Int
21−f4 _ = f5 0 0
21+f4 n = f5 (show n) 0
22
22
23-- HsFunTy
23-- HsFunTy
24−f5 :: Int -> Int -> Int
24+f5 :: String -> Int -> Int
25f5 _ _ = head f6
25f5 _ _ = head f6
26
26
27-- HsListTy
27-- HsListTy
@@ -34,7 +34,13 @@ f7 = (fromJust f8, fromJust f8)
34
34
35-- HsAppTy
35-- HsAppTy
36f8 :: Maybe Int
36f8 :: Maybe Int
37−f8 = Just fError
37+f8 = Just f9
38+
39+f9 :: Int
40+f9 = f10
41+ where
42+ f10 :: Int
43+ f10 = fError
38
44
39-- HsTyVar
45-- HsTyVar
40fError :: Int
46fError :: Int
haskell-stack-trace-plugin.cabal+64−29
@@ -1,41 +1,76 @@
1+cabal-version: 2.4
1−name: haskell-stack-trace-plugin
2+name: haskell-stack-trace-plugin
2−version: 0.1.0.0
3+version: 0.1.3.0
3−synopsis: haskell-stack-trace-plugin
4+synopsis: haskell-stack-trace-plugin
5+description:
4−description: This plugin allow implicitly add HasCallStack class to every top-level function for all module. Hence, we can to get completely continuous call stack.
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+
5−homepage: https://github.com/waddlaw/haskell-stack-trace-plugin
8+homepage: https://github.com/waddlaw/haskell-stack-trace-plugin
9+bug-reports:
6−bug-reports: https://github.com/waddlaw/haskell-stack-trace-plugin/issues
10+ https://github.com/waddlaw/haskell-stack-trace-plugin/issues
11+
7−license: MIT
12+license: MIT
8−license-file: LICENSE
13+license-file: LICENSE
9−author: Shinya Yamaguchi
14+author: Shinya Yamaguchi
10−maintainer: ingronze@gmail.com
15+maintainer: a@wado.dev
11−copyright: 2018 Shinya Yamaguchi
16+copyright: 2018-2021 Shinya Yamaguchi
12−category: Compiler Plugin, Development, Debug
17+category: Compiler Plugin, Development, Debug
13−build-type: Simple
18+build-type: Simple
14−extra-source-files: CHANGELOG.md, Readme.md
19+extra-source-files:
15−cabal-version: >=1.10
20+ CHANGELOG.md
21+ Readme.md
22+
16−tested-with: GHC == 8.6.2
23+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1
17
24
18source-repository head
25source-repository head
19 type: git
26 type: git
20 location: git://github.com/waddlaw/haskell-stack-trace-plugin
27 location: git://github.com/waddlaw/haskell-stack-trace-plugin
21
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.18
36+ default-language: Haskell2010
37+
22library
38library
39+ import: common-opts
23− hs-source-dirs: src
40+ hs-source-dirs: src
41+ build-depends: ghc ^>=8.6 || ^>=8.8 || ^>=8.10 || ^>=9.0 || ^>=9.2 || ^>=9.4
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
24 build-depends:
57 build-depends:
25− base >=4.12 && <4.13,
58+ , bytestring >=0.10 && <0.12
26− ghc==8.6.2
59+ , hspec ^>=2.8
60+ , typed-process ^>=0.2
27
61
28− exposed-modules:
62+ build-tool-depends: hspec-discover:hspec-discover ^>=2.8
29− StackTrace.Plugin
63+ other-modules: StackTrace.PluginSpec
30
64
31− default-language: Haskell2010
65+ if flag(dev)
66+ ghc-options: -Wall -Werror
67+
68+ else
69+ ghc-options: -Wall
32
70
33executable example
71executable example
72+ import: common-opts
34− main-is: Main.hs
73+ main-is: Main.hs
35 hs-source-dirs: example
74 hs-source-dirs: example
36− default-language: Haskell2010
37− ghc-options:
38− -fplugin=StackTrace.Plugin
75+ ghc-options: -fplugin=StackTrace.Plugin -Wredundant-constraints
39− build-depends:
40− base >=4.12 && <4.13,
41− haskell-stack-trace-plugin
76+ build-depends: haskell-stack-trace-plugin
src/StackTrace/Plugin.hs+187−57
@@ -1,81 +1,211 @@
1+{-# LANGUAGE RankNTypes #-}
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE CPP #-}
2module StackTrace.Plugin (plugin) where
4module StackTrace.Plugin (plugin) where
3−
5+
6+import Control.Arrow (first)
7+import Data.Monoid (Any(Any, getAny))
8+import GHC.Types.SrcLoc
9+#if __GLASGOW_HASKELL__ >= 900
10+import GHC.Plugins
11+#else
12+
4import GhcPlugins
13import GhcPlugins
5−import TcRnTypes (IfM, TcM, TcGblEnv, tcg_binds, tcg_rn_decls)
14+#endif
6−import HsExtension (GhcTc, GhcRn)
15+#if __GLASGOW_HASKELL__ >= 810
7−import HsDecls (HsGroup)
16+import GHC.Hs
8−import HsExpr (LHsExpr)
17+#endif
18+#if __GLASGOW_HASKELL__ < 810
9import HsSyn
19import HsSyn
20+#endif
10
21
11−import Data.Maybe
22+type Traversal s t a b
23+ = forall f. Applicative f =>
24+ (a -> f b) -> s -> f t
25+
26+type Traversal' s a = Traversal s s a a
12
27
13plugin :: Plugin
28plugin :: Plugin
14−plugin = defaultPlugin
15− { parsedResultAction = parsedPlugin
29+plugin = defaultPlugin {parsedResultAction = parsedPlugin, pluginRecompile = purePlugin}
16− }
17
30
31+parsedPlugin ::
18−parsedPlugin :: [CommandLineOption] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule
32+ [CommandLineOption] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule
19parsedPlugin _ _ pm = do
33parsedPlugin _ _ pm = do
20− dflags <- getDynFlags
21−
22− let extract = hsmodImports . unLoc
23− addGHCStackMod = noLoc $ simpleImportDecl $ mkModuleName "GHC.Stack"
24−
25− m = updateHsModule addGHCStackMod updateHsmodDecl <$> hpm_module pm
34+ let m = updateHsModule <$> hpm_module pm
26− pm' = pm { hpm_module = m }
35+ pm' = pm {hpm_module = m}
27−
28 return pm'
36 return pm'
29
37
30−updateHsModule :: LImportDecl GhcPs -> (LHsDecl GhcPs -> LHsDecl GhcPs) -> HsModule GhcPs -> HsModule GhcPs
38+-- Use qualified import for GHC.Stack as "AutoImported.GHC.Stack"
31−updateHsModule importDecl update hsm = hsm
39+-- ...this should not interfere with other imports...
32− { hsmodImports = importDecl:decls
40+ghcStackModuleName :: ModuleName
33− , hsmodDecls = map update lhss
41+ghcStackModuleName = mkModuleName "AutoImported.GHC.Stack"
34− }
42+
43+#if __GLASGOW_HASKELL__ < 810
44+importDeclQualified :: Bool
45+importDeclQualified = True
46+#else
47+importDeclQualified :: ImportDeclQualifiedStyle
48+importDeclQualified = QualifiedPre
49+#endif
50+
51+ghcStackImport :: Located (ImportDecl (GhcPass p))
52+ghcStackImport =
53+ L srcSpan $
54+ (simpleImportDecl $ mkModuleName "GHC.Stack")
55+ { ideclQualified = importDeclQualified, ideclAs = Just $ noLoc ghcStackModuleName }
35 where
56 where
36− decls = hsmodImports hsm
57+ -- This is for GHC-9 related problems. @noLoc@ causes GHC to throw warnings
58+ -- about unused imports. Even if the import is used
59+ -- See: https://github.com/waddlaw/haskell-stack-trace-plugin/issues/16
60+ srcSpan = RealSrcSpan (realSrcLocSpan $ mkRealSrcLoc "haskell-stack-trace-plugin:very-unique-file-name-to-avoid-collision" 1 1) Nothing
61+
62+#if __GLASGOW_HASKELL__ >= 900
63+updateHsModule :: HsModule -> HsModule
64+#else
65+updateHsModule :: HsModule GhcPs -> HsModule GhcPs
66+#endif
67+updateHsModule hsm =
68+ hsm {hsmodImports = hsmodImports', hsmodDecls = hsmodDecls'}
69+ where
70+ -- Traverse the haskell AST; if we have to add some HasStack
71+ -- constraint we set a flag in a (Any,) functor.
72+ -- ...it'd be simpler to check if before == after, but Haskell AST
73+ -- doesn't have Eq instances.
74+ (updatedP, hsmodDecls') =
75+ first getAny $
37− lhss = hsmodDecls hsm
76+ (traverse . astTraversal) updateHsType (hsmodDecls hsm)
77+
78+ -- Only import GHC.Stack if needed for a constraint we introduced
79+ hsmodImports' =
80+ (if updatedP
81+ then [ghcStackImport]
82+ else []) ++
83+ hsmodImports hsm
84+
85+ astTraversal :: Traversal' (LHsDecl GhcPs) (HsType GhcPs)
86+ astTraversal = updateHsmodDecl
87+ . updateHsDecl
88+ . updateLHsSigWsType
89+ . updateLHsSigType
90+ . updateLHsType
38
91
39--------------
92--------------
40−
93+updateHsmodDecl :: Traversal' (LHsDecl GhcPs) (HsDecl GhcPs)
41−updateHsmodDecl :: LHsDecl GhcPs -> LHsDecl GhcPs
94+updateHsmodDecl = traverse
42−updateHsmodDecl = fmap updateHsDecl
95+
43−
96+updateHsDecl :: Traversal' (HsDecl GhcPs) (LHsSigWcType GhcPs)
44−updateHsDecl :: HsDecl GhcPs -> HsDecl GhcPs
97+updateHsDecl f (SigD xSig s) = SigD xSig <$> updateSig f s
45−updateHsDecl (SigD xSig s) = SigD xSig (updateSig s)
98+updateHsDecl f (ValD xVal hsBind) = ValD xVal <$> updateHsBind f hsBind
46−updateHsDecl decl = decl
99+updateHsDecl _ sig = pure sig
47−
100+
101+updateHsBind :: Traversal' (HsBind GhcPs) (LHsSigWcType GhcPs)
102+updateHsBind f bind@FunBind {} = (\x -> bind {fun_matches = x}) <$> updateMatchGroup f (fun_matches bind)
103+updateHsBind _ bind = pure bind
104+
105+updateMatchGroup :: Traversal' (MatchGroup GhcPs (LHsExpr GhcPs)) (LHsSigWcType GhcPs)
106+updateMatchGroup f mg@MG {} = (\x -> mg {mg_alts = x}) <$> updateLLMatch f (mg_alts mg)
107+#if __GLASGOW_HASKELL__ < 900
108+updateMatchGroup _ mg = pure mg
109+#endif
110+
111+updateLocated :: Functor f => (a -> b -> f c) -> a -> Located b -> f (Located c)
112+updateLocated f g (L l e) = L l <$> f g e
113+
114+updateLLMatch :: Traversal' (Located [LMatch GhcPs (LHsExpr GhcPs)]) (LHsSigWcType GhcPs)
115+updateLLMatch = updateLocated updateLMatches
116+
117+updateLMatches :: Traversal' [LMatch GhcPs (LHsExpr GhcPs)] (LHsSigWcType GhcPs)
118+updateLMatches f = traverse (updateLocated updateMatch f)
119+
120+updateMatch :: Traversal' (Match GhcPs (LHsExpr GhcPs)) (LHsSigWcType GhcPs)
121+updateMatch f m@Match {} = (\x -> m {m_grhss = x}) <$> updateGrhss f (m_grhss m)
122+#if __GLASGOW_HASKELL__ < 900
123+updateMatch _ m = pure m
124+#endif
125+
126+updateGrhss :: Traversal' (GRHSs GhcPs (LHsExpr GhcPs)) (LHsSigWcType GhcPs)
127+updateGrhss f grhss@GRHSs {} = (\x -> grhss {grhssLocalBinds = x}) <$> updateLHsLocalBinds f (grhssLocalBinds grhss)
128+#if __GLASGOW_HASKELL__ < 900
129+updateGrhss _ grhss = pure grhss
130+#endif
131+
132+updateLHsLocalBinds :: Traversal' (LHsLocalBinds GhcPs) (LHsSigWcType GhcPs)
133+updateLHsLocalBinds = updateLocated updateLocalBinds
134+
135+updateLocalBinds :: Traversal' (HsLocalBinds GhcPs) (LHsSigWcType GhcPs)
136+updateLocalBinds f (HsValBinds xHsValBinds hsValBindsLR) = HsValBinds xHsValBinds <$> updateHsValBindsLR f hsValBindsLR
137+updateLocalBinds _ hsValBinds = pure hsValBinds
138+
139+updateHsValBindsLR :: Traversal' (HsValBindsLR GhcPs GhcPs) (LHsSigWcType GhcPs)
140+updateHsValBindsLR f (ValBinds xValBinds lHsBindsLR lSigs) = ValBinds xValBinds lHsBindsLR <$> updateLSigs f lSigs
141+updateHsValBindsLR _ valBinds = pure valBinds
142+
143+updateLSigs :: Traversal' [LSig GhcPs] (LHsSigWcType GhcPs)
144+updateLSigs f = traverse (updateLocated updateSig f)
145+
48−updateSig :: Sig GhcPs -> Sig GhcPs
146+updateSig :: Traversal' (Sig GhcPs) (LHsSigWcType GhcPs)
49−updateSig (TypeSig xSig ls t) = TypeSig xSig ls (updateLHsSigWcType t)
147+updateSig f (TypeSig xSig ls t) = TypeSig xSig ls <$> f t
50−updateSig sig = sig
148+updateSig _ sig = pure sig
51−
149+
52−updateLHsSigWcType :: LHsSigWcType GhcPs -> LHsSigWcType GhcPs
150+updateLHsSigWsType :: Traversal' (LHsSigWcType GhcPs) (LHsSigType GhcPs)
151+updateLHsSigWsType f lhs@HsWC {} =
53−updateLHsSigWcType lhs@HsWC{} = lhs { hswc_body = updateLHsSigType (hswc_body lhs) }
152+ (\x -> lhs {hswc_body = x}) <$> f (hswc_body lhs)
54−updateLHsSigWcType lhs@XHsWildCardBndrs{} = lhs
153+#if __GLASGOW_HASKELL__ < 900
55−
154+updateLHsSigWsType _ lhs = pure lhs
155+#endif
156+
56−updateLHsSigType :: LHsSigType GhcPs -> LHsSigType GhcPs
157+updateLHsSigType :: Traversal' (LHsSigType GhcPs) (LHsType GhcPs)
158+updateLHsSigType f lhs@HsIB {} =
57−updateLHsSigType lhs@HsIB{} = lhs { hsib_body = updateLHsType (hsib_body lhs )}
159+ (\x -> lhs {hsib_body = x}) <$> f (hsib_body lhs)
160+#if __GLASGOW_HASKELL__ < 900
58−updateLHsSigType lhs@XHsImplicitBndrs{} = lhs
161+updateLHsSigType _ lhs = pure lhs
59−
162+#endif
163+
60−updateLHsType :: LHsType GhcPs -> LHsType GhcPs
164+updateLHsType :: Traversal' (LHsType GhcPs) (HsType GhcPs)
61−updateLHsType = fmap updateHsType
165+updateLHsType = traverse
62
166
63-- Main process
167-- Main process
64−updateHsType :: HsType GhcPs -> HsType GhcPs
168+updateHsType :: HsType GhcPs -> (Any, HsType GhcPs)
65−updateHsType ty@(HsQualTy xty ctxt body) = HsQualTy xty (fmap appendHSC ctxt) body
169+updateHsType ty@(HsQualTy xty ctxt body) =
170+ if hasHasCallStack (unLoc ctxt)
171+ then pure ty
172+ else flagASTModified $ HsQualTy xty (fmap appendHSC ctxt) body
66−updateHsType ty@HsTyVar{} = HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
173+updateHsType ty@HsTyVar {} =
174+ flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
67−updateHsType ty@HsAppTy{} = HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
175+updateHsType ty@HsAppTy {} =
176+ flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
68−updateHsType ty@HsFunTy{} = HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
177+updateHsType ty@HsFunTy {} =
178+ flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
69−updateHsType ty@HsListTy{} = HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
179+updateHsType ty@HsListTy {} =
180+ flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
70−updateHsType ty@HsTupleTy{} = HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
181+updateHsType ty@HsTupleTy {} =
182+ flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
71−updateHsType ty = ty
183+updateHsType ty = pure ty
184+
185+#if __GLASGOW_HASKELL__ < 810
186+xQualTy :: NoExt
187+xQualTy = noExt
188+#else
189+xQualTy :: NoExtField
190+xQualTy = NoExtField
191+#endif
192+
193+flagASTModified :: a -> (Any, a)
194+flagASTModified a = (Any True, a)
72
195
73appendHSC :: HsContext GhcPs -> HsContext GhcPs
196appendHSC :: HsContext GhcPs -> HsContext GhcPs
74appendHSC cs = mkHSC : cs
197appendHSC cs = mkHSC : cs
75
198
199+hasHasCallStack :: HsContext GhcPs -> Bool
200+hasHasCallStack = any (checkHsType . unLoc)
201+ where
202+ checkHsType :: HsType GhcPs -> Bool
203+ checkHsType (HsTyVar _ _ lid) = unLoc lid == (mkRdrUnqual $ mkClsOcc "HasCallStack")
204+ checkHsType _ = False
205+
76-- make HasCallStack => constraint
206-- make HasCallStack => constraint
77mkHSC :: LHsType GhcPs
207mkHSC :: LHsType GhcPs
78−mkHSC = noLoc $ HsTyVar noExt NotPromoted lId
208+mkHSC = noLoc $ HsTyVar xQualTy NotPromoted lId
79
209
80lId :: Located (IdP GhcPs)
210lId :: Located (IdP GhcPs)
81−lId = noLoc $ mkRdrUnqual $ mkClsOcc "HasCallStack"
211+lId = noLoc $ mkRdrQual ghcStackModuleName $ mkClsOcc "HasCallStack"
test/Spec.hsnew file+1
@@ -0,0 +1 @@
1+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
test/StackTrace/PluginSpec.hsnew file+21
@@ -0,0 +1,21 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module StackTrace.PluginSpec (spec) where
3+
4+import Data.ByteString.Lazy (ByteString)
5+import qualified Data.ByteString.Lazy as BL
6+import Test.Hspec
7+import System.Process.Typed
8+
9+spec :: Spec
10+spec = do
11+ output <- runIO exe
12+ expected <- runIO $ BL.readFile "test/resource/ghc.output"
13+ it "integration test" $ output `shouldBe` expected
14+
15+
16+exe :: IO ByteString
17+exe = do
18+ runProcess_ $ shell "cabal install exe:example --installdir=./dist"
19+ err <- readProcessStderr_ $ shell "./dist/example || true"
20+ runProcess_ $ shell "rm -rf ./dist"
21+ return err
test/resource/ghc.outputnew file+15
@@ -0,0 +1,15 @@
1+example: fError
2+CallStack (from HasCallStack):
3+ error, called at example/Main.hs:47:10 in main:Main
4+ fError, called at example/Main.hs:43:11 in main:Main
5+ f10, called at example/Main.hs:40:6 in main:Main
6+ f9, called at example/Main.hs:37:11 in main:Main
7+ f8, called at example/Main.hs:33:16 in main:Main
8+ f7, called at example/Main.hs:29:11 in main:Main
9+ f6, called at example/Main.hs:25:15 in main:Main
10+ f5, called at example/Main.hs:21:8 in main:Main
11+ f4, called at example/Main.hs:17:6 in main:Main
12+ f3, called at example/Main.hs:13:6 in main:Main
13+ f2, called at example/Main.hs:10:6 in main:Main
14+ f1, called at example/Main.hs:7:14 in main:Main
15+ main, called at example/Main.hs:7:1 in main:Main