git.iko.soy/typeable/haskell-stack-trace-plugin
on master help sign in
swap
6624a5923 ahead, 0 behind
.github/workflows/cabal.yml+16−28
since splitsnapshots
unifiedsplit
@@ -2,13 +2,9 @@ name: cabal
2
2
3on:
3on:
4 push:
4 push:
5− branches:
5+ branches: [ master ]
6− - master
7− tags-ignore:
8− - '*'
9 pull_request:
6 pull_request:
10− branches:
7+ branches: [ '*' ]
11− - '*'
12 schedule:
8 schedule:
13 - cron: "00 15 * * *"
9 - cron: "00 15 * * *"
14
10
@@ -17,40 +13,32 @@ jobs:
17 runs-on: ubuntu-18.04
13 runs-on: ubuntu-18.04
18 strategy:
14 strategy:
19 matrix:
15 matrix:
20− ghc: ["8.6.5", "8.8.1", "8.10.4"]
16+ ghc: ["8.6", "8.8", "8.10", "9.0"]
21− cabal: ["3.0"]
17+ cabal: ["3.2"]
18+ cache-version: ["2021-05-21"]
22
19
23 steps:
20 steps:
24 - uses: actions/checkout@v2
21 - uses: actions/checkout@v2
25− - uses: actions/setup-haskell@v1
22+ - uses: haskell/actions/setup@v1
26 with:
23 with:
27 ghc-version: ${{ matrix.ghc }}
24 ghc-version: ${{ matrix.ghc }}
28 cabal-version: ${{ matrix.cabal }}
25 cabal-version: ${{ matrix.cabal }}
29
26
30− - name: Display ghc & cabal version
31− run: |
32− ghc -V
33− cabal -V
34−
35 - name: Cache ~/.cabal/store
27 - name: Cache ~/.cabal/store
36− uses: actions/cache@v1.1.0
28+ uses: actions/cache@v2
37− with:
38− path: ~/.cabal/store
39− key: ${{ matrix.ghc }}-v0-cabal-store-${{ hashFiles('*.cabal') }}
40−
41− - name: Cache dist-newstyle
42− uses: actions/cache@v1.1.0
43 with:
29 with:
30+ path: |
31+ ~/.cabal/store
44− path: dist-newstyle
32+ dist-newstyle
45− key: ${{ matrix.ghc }}-v0-cabal-dist-${{ hashFiles('*.cabal') }}
33+ key: ${{ runner.os }}-${{ matrix.ghc }}-${{ matrix.cache-version }}-cabal
46
34
47 - name: Install dependencies
35 - name: Install dependencies
48 run: |
36 run: |
49− cabal v2-update
37+ cabal update
50− cabal v2-configure --disable-optimization --enable-tests --write-ghc-environment-files=always -j2
38+ cabal configure --disable-optimization --enable-tests --write-ghc-environment-files=always -j2
51− cabal v2-build --only-dependencies
39+ cabal build --only-dependencies
52
40
53 - name: Build & Test
41 - name: Build & Test
54 run: |
42 run: |
55− cabal v2-build --flag dev
43+ cabal build --flag dev
56− cabal v2-test --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+10
@@ -2,6 +2,16 @@
2
2
3## Unreleased changes
3## Unreleased changes
4
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+
5## 0.1.1.1 -- 2020-01-18
15## 0.1.1.1 -- 2020-01-18
6
16
7- Allow GHC-8.8.1
17- Allow GHC-8.8.1
LICENSE+1−1
@@ -1,4 +1,4 @@
1−Copyright (c) 2018-2020 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+30−22
@@ -5,8 +5,10 @@
5
5
6This 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.
7
7
8−1. (implicitly) Import [GHC.Stack](https://hackage.haskell.org/package/base-4.12.0.0/docs/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.
9−2. Add [HasCallStack](https://hackage.haskell.org/package/base-4.12.0.0/docs/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
10
12
11Requirement: (8.6 <= on GHC)
13Requirement: (8.6 <= on GHC)
12
14
@@ -32,10 +34,10 @@ f3 = f4 0
32
34
33-- HsQualTy
35-- HsQualTy
34f4 :: Show a => a -> Int
36f4 :: Show a => a -> Int
35−f4 _ = f5 0 0
37+f4 n = f5 (show n) 0
36
38
37-- HsFunTy
39-- HsFunTy
38−f5 :: Int -> Int -> Int
40+f5 :: String -> Int -> Int
39f5 _ _ = head f6
41f5 _ _ = head f6
40
42
41-- HsListTy
43-- HsListTy
@@ -48,7 +50,13 @@ f7 = (fromJust f8, fromJust f8)
48
50
49-- HsAppTy
51-- HsAppTy
50f8 :: Maybe Int
52f8 :: Maybe Int
51−f8 = Just fError
53+f8 = Just f9
54+
55+f9 :: Int
56+f9 = f10
57+ where
58+ f10 :: Int
59+ f10 = fError
52
60
53-- HsTyVar
61-- HsTyVar
54fError :: Int
62fError :: Int
@@ -58,7 +66,7 @@ fError = error "fError"
58This example get error:
66This example get error:
59
67
60```shell
68```shell
61−$ cabal new-build
69+$ cabal build
62example/Main.hs:15:7: error:
70example/Main.hs:15:7: error:
63 Not in scope: type constructor or class ‘HasCallStack’
71 Not in scope: type constructor or class ‘HasCallStack’
64 |
72 |
@@ -71,10 +79,10 @@ Yes, add `import GHC.Stack` to above example.
71Fix and rebuild!
79Fix and rebuild!
72
80
73```shell
81```shell
74−$ cabal new-run
82+$ cabal run example -v0
75example: fError
83example: fError
76CallStack (from HasCallStack):
84CallStack (from HasCallStack):
77− error, called at example/Main.hs:41:10 in main:Main
85+ error, called at example/Main.hs:47:10 in main:Main
78```
86```
79
87
80Hmm, 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.
@@ -85,22 +93,22 @@ Hmm, it is not useful. But, you will to be happy when enable this plugin.
85```
93```
86
94
87```shell
95```shell
88−$ cabal new-run
96+$ cabal run example -v0
89−...
90−
91example: fError
97example: fError
92CallStack (from HasCallStack):
98CallStack (from HasCallStack):
93− error, called at example/Main.hs:40:10 in main:Main
99+ error, called at example/Main.hs:47:10 in main:Main
94− 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
95− f8, called at example/Main.hs:32:16 in main:Main
103+ f8, called at example/Main.hs:33:16 in main:Main
96− f7, called at example/Main.hs:28:11 in main:Main
104+ f7, called at example/Main.hs:29:11 in main:Main
97− f6, called at example/Main.hs:24:15 in main:Main
105+ f6, called at example/Main.hs:25:15 in main:Main
98− f5, called at example/Main.hs:20:8 in main:Main
106+ f5, called at example/Main.hs:21:8 in main:Main
99− f4, called at example/Main.hs:16:6 in main:Main
107+ f4, called at example/Main.hs:17:6 in main:Main
100− f3, called at example/Main.hs:12:6 in main:Main
108+ f3, called at example/Main.hs:13:6 in main:Main
101− f2, called at example/Main.hs:9:6 in main:Main
109+ f2, called at example/Main.hs:10:6 in main:Main
102− f1, called at example/Main.hs:6:14 in main:Main
110+ f1, called at example/Main.hs:7:14 in main:Main
103− main, called at example/Main.hs:6:1 in main:Main
111+ main, called at example/Main.hs:7:1 in main:Main
104```
112```
105
113
106Great!!!
114Great!!!
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+12−14
@@ -1,6 +1,6 @@
1cabal-version: 2.4
1cabal-version: 2.4
2name: haskell-stack-trace-plugin
2name: haskell-stack-trace-plugin
3−version: 0.1.2.0
3+version: 0.1.3.0
4synopsis: haskell-stack-trace-plugin
4synopsis: haskell-stack-trace-plugin
5description:
5description:
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.
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.
@@ -12,15 +12,15 @@ bug-reports:
12license: MIT
12license: MIT
13license-file: LICENSE
13license-file: LICENSE
14author: Shinya Yamaguchi
14author: Shinya Yamaguchi
15−maintainer: ingronze@gmail.com
15+maintainer: a@wado.dev
16−copyright: 2018-2020 Shinya Yamaguchi
16+copyright: 2018-2021 Shinya Yamaguchi
17category: Compiler Plugin, Development, Debug
17category: Compiler Plugin, Development, Debug
18build-type: Simple
18build-type: Simple
19extra-source-files:
19extra-source-files:
20 CHANGELOG.md
20 CHANGELOG.md
21 Readme.md
21 Readme.md
22
22
23−tested-with: GHC ==8.6.5 || ==8.8.1 || ==8.10.4
23+tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1
24
24
25source-repository head
25source-repository head
26 type: git
26 type: git
@@ -32,22 +32,20 @@ flag dev
32 default: False
32 default: False
33
33
34common common-opts
34common common-opts
35− build-depends: base >=4.12 && <4.15
35+ build-depends: base >=4.12 && <4.18
36 default-language: Haskell2010
36 default-language: Haskell2010
37
37
38library
38library
39 import: common-opts
39 import: common-opts
40 hs-source-dirs: src
40 hs-source-dirs: src
41− build-depends: ghc ^>=8.6 || ^>=8.8 || ^>=8.10
41+ build-depends: ghc ^>=8.6 || ^>=8.8 || ^>=8.10 || ^>=9.0 || ^>=9.2 || ^>=9.4
42 exposed-modules: StackTrace.Plugin
42 exposed-modules: StackTrace.Plugin
43
43
44 if flag(dev)
44 if flag(dev)
45 ghc-options:
45 ghc-options:
46 -Wall -Werror -Wcompat -Wincomplete-uni-patterns
46 -Wall -Werror -Wcompat -Wincomplete-uni-patterns
47− -Wnoncanonical-monad-instances
47+ -Wnoncanonical-monad-instances -Wno-missing-home-modules
48− -Wno-missing-home-modules
49
48
50− -- -Wincomplete-record-updates
51 else
49 else
52 ghc-options: -Wall
50 ghc-options: -Wall
53
51
@@ -57,11 +55,11 @@ test-suite test
57 hs-source-dirs: test
55 hs-source-dirs: test
58 type: exitcode-stdio-1.0
56 type: exitcode-stdio-1.0
59 build-depends:
57 build-depends:
60− , bytestring ^>=0.10
58+ , bytestring >=0.10 && <0.12
61− , hspec ^>=2.7
59+ , hspec ^>=2.8
62− , typed-process ^>=0.2.6
60+ , typed-process ^>=0.2
63
61
64− build-tool-depends: hspec-discover:hspec-discover ^>=2.7
62+ build-tool-depends: hspec-discover:hspec-discover ^>=2.8
65 other-modules: StackTrace.PluginSpec
63 other-modules: StackTrace.PluginSpec
66
64
67 if flag(dev)
65 if flag(dev)
@@ -74,5 +72,5 @@ executable example
74 import: common-opts
72 import: common-opts
75 main-is: Main.hs
73 main-is: Main.hs
76 hs-source-dirs: example
74 hs-source-dirs: example
77− ghc-options: -fplugin=StackTrace.Plugin
75+ ghc-options: -fplugin=StackTrace.Plugin -Wredundant-constraints
78 build-depends: haskell-stack-trace-plugin
76 build-depends: haskell-stack-trace-plugin
src/StackTrace/Plugin.hs+81−7
@@ -5,7 +5,13 @@ module StackTrace.Plugin (plugin) where
5
5
6import Control.Arrow (first)
6import Control.Arrow (first)
7import Data.Monoid (Any(Any, getAny))
7import Data.Monoid (Any(Any, getAny))
8+import GHC.Types.SrcLoc
9+#if __GLASGOW_HASKELL__ >= 900
10+import GHC.Plugins
11+#else
12+
8import GhcPlugins
13import GhcPlugins
14+#endif
9#if __GLASGOW_HASKELL__ >= 810
15#if __GLASGOW_HASKELL__ >= 810
10import GHC.Hs
16import GHC.Hs
11#endif
17#endif
@@ -44,11 +50,20 @@ importDeclQualified = QualifiedPre
44
50
45ghcStackImport :: Located (ImportDecl (GhcPass p))
51ghcStackImport :: Located (ImportDecl (GhcPass p))
46ghcStackImport =
52ghcStackImport =
47− noLoc $
53+ L srcSpan $
48 (simpleImportDecl $ mkModuleName "GHC.Stack")
54 (simpleImportDecl $ mkModuleName "GHC.Stack")
49− {ideclQualified = importDeclQualified, ideclAs = Just $ noLoc ghcStackModuleName}
55+ { ideclQualified = importDeclQualified, ideclAs = Just $ noLoc ghcStackModuleName }
56+ where
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
50
61
62+#if __GLASGOW_HASKELL__ >= 900
63+updateHsModule :: HsModule -> HsModule
64+#else
51updateHsModule :: HsModule GhcPs -> HsModule GhcPs
65updateHsModule :: HsModule GhcPs -> HsModule GhcPs
66+#endif
52updateHsModule hsm =
67updateHsModule hsm =
53 hsm {hsmodImports = hsmodImports', hsmodDecls = hsmodDecls'}
68 hsm {hsmodImports = hsmodImports', hsmodDecls = hsmodDecls'}
54 where
69 where
@@ -70,7 +85,6 @@ updateHsModule hsm =
70 astTraversal :: Traversal' (LHsDecl GhcPs) (HsType GhcPs)
85 astTraversal :: Traversal' (LHsDecl GhcPs) (HsType GhcPs)
71 astTraversal = updateHsmodDecl
86 astTraversal = updateHsmodDecl
72 . updateHsDecl
87 . updateHsDecl
73− . updateSig
74 . updateLHsSigWsType
88 . updateLHsSigWsType
75 . updateLHsSigType
89 . updateLHsSigType
76 . updateLHsType
90 . updateLHsType
@@ -79,10 +93,56 @@ updateHsModule hsm =
79updateHsmodDecl :: Traversal' (LHsDecl GhcPs) (HsDecl GhcPs)
93updateHsmodDecl :: Traversal' (LHsDecl GhcPs) (HsDecl GhcPs)
80updateHsmodDecl = traverse
94updateHsmodDecl = traverse
81
95
82−updateHsDecl :: Traversal' (HsDecl GhcPs) (Sig GhcPs)
96+updateHsDecl :: Traversal' (HsDecl GhcPs) (LHsSigWcType GhcPs)
83−updateHsDecl f (SigD xSig s) = SigD xSig <$> f s
97+updateHsDecl f (SigD xSig s) = SigD xSig <$> updateSig f s
98+updateHsDecl f (ValD xVal hsBind) = ValD xVal <$> updateHsBind f hsBind
84updateHsDecl _ sig = pure sig
99updateHsDecl _ sig = pure sig
85
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+
86updateSig :: Traversal' (Sig GhcPs) (LHsSigWcType GhcPs)
146updateSig :: Traversal' (Sig GhcPs) (LHsSigWcType GhcPs)
87updateSig f (TypeSig xSig ls t) = TypeSig xSig ls <$> f t
147updateSig f (TypeSig xSig ls t) = TypeSig xSig ls <$> f t
88updateSig _ sig = pure sig
148updateSig _ sig = pure sig
@@ -90,20 +150,26 @@ updateSig _ sig = pure sig
90updateLHsSigWsType :: Traversal' (LHsSigWcType GhcPs) (LHsSigType GhcPs)
150updateLHsSigWsType :: Traversal' (LHsSigWcType GhcPs) (LHsSigType GhcPs)
91updateLHsSigWsType f lhs@HsWC {} =
151updateLHsSigWsType f lhs@HsWC {} =
92 (\x -> lhs {hswc_body = x}) <$> f (hswc_body lhs)
152 (\x -> lhs {hswc_body = x}) <$> f (hswc_body lhs)
153+#if __GLASGOW_HASKELL__ < 900
93updateLHsSigWsType _ lhs = pure lhs
154updateLHsSigWsType _ lhs = pure lhs
155+#endif
94
156
95updateLHsSigType :: Traversal' (LHsSigType GhcPs) (LHsType GhcPs)
157updateLHsSigType :: Traversal' (LHsSigType GhcPs) (LHsType GhcPs)
96updateLHsSigType f lhs@HsIB {} =
158updateLHsSigType f lhs@HsIB {} =
97 (\x -> lhs {hsib_body = x}) <$> f (hsib_body lhs)
159 (\x -> lhs {hsib_body = x}) <$> f (hsib_body lhs)
160+#if __GLASGOW_HASKELL__ < 900
98updateLHsSigType _ lhs = pure lhs
161updateLHsSigType _ lhs = pure lhs
162+#endif
99
163
100updateLHsType :: Traversal' (LHsType GhcPs) (HsType GhcPs)
164updateLHsType :: Traversal' (LHsType GhcPs) (HsType GhcPs)
101updateLHsType = traverse
165updateLHsType = traverse
102
166
103-- Main process
167-- Main process
104updateHsType :: HsType GhcPs -> (Any, HsType GhcPs)
168updateHsType :: HsType GhcPs -> (Any, HsType GhcPs)
105−updateHsType (HsQualTy xty ctxt body) =
169+updateHsType ty@(HsQualTy xty ctxt body) =
170+ if hasHasCallStack (unLoc ctxt)
171+ then pure ty
106− flagASTModified $ HsQualTy xty (fmap appendHSC ctxt) body
172+ else flagASTModified $ HsQualTy xty (fmap appendHSC ctxt) body
107updateHsType ty@HsTyVar {} =
173updateHsType ty@HsTyVar {} =
108 flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
174 flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
109updateHsType ty@HsAppTy {} =
175updateHsType ty@HsAppTy {} =
@@ -117,6 +183,7 @@ updateHsType ty@HsTupleTy {} =
117updateHsType ty = pure ty
183updateHsType ty = pure ty
118
184
119#if __GLASGOW_HASKELL__ < 810
185#if __GLASGOW_HASKELL__ < 810
186+xQualTy :: NoExt
120xQualTy = noExt
187xQualTy = noExt
121#else
188#else
122xQualTy :: NoExtField
189xQualTy :: NoExtField
@@ -129,6 +196,13 @@ flagASTModified a = (Any True, a)
129appendHSC :: HsContext GhcPs -> HsContext GhcPs
196appendHSC :: HsContext GhcPs -> HsContext GhcPs
130appendHSC cs = mkHSC : cs
197appendHSC cs = mkHSC : cs
131
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+
132-- make HasCallStack => constraint
206-- make HasCallStack => constraint
133mkHSC :: LHsType GhcPs
207mkHSC :: LHsType GhcPs
134mkHSC = noLoc $ HsTyVar xQualTy NotPromoted lId
208mkHSC = noLoc $ HsTyVar xQualTy NotPromoted lId
test/resource/ghc.output+4−2
@@ -1,7 +1,9 @@
1example: fError
1example: fError
2CallStack (from HasCallStack):
2CallStack (from HasCallStack):
3− error, called at example/Main.hs:41:10 in main:Main
3+ error, called at example/Main.hs:47:10 in main:Main
4− fError, called at example/Main.hs:37:11 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
5 f8, called at example/Main.hs:33:16 in main:Main
7 f8, called at example/Main.hs:33:16 in main:Main
6 f7, called at example/Main.hs:29:11 in main:Main
8 f7, called at example/Main.hs:29:11 in main:Main
7 f6, called at example/Main.hs:25:15 in main:Main
9 f6, called at example/Main.hs:25:15 in main:Main