git.iko.soy/typeable/haskell-stack-trace-plugin
on master help sign in
swap
6624a5934 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"]
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+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-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+32−23
@@ -1,11 +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)
3[![Hackage](https://img.shields.io/hackage/v/haskell-stack-trace-plugin.svg)](https://hackage.haskell.org/package/haskell-stack-trace-plugin)
4[![Hackage](https://img.shields.io/hackage/v/haskell-stack-trace-plugin.svg)](https://hackage.haskell.org/package/haskell-stack-trace-plugin)
4
5
5This 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.
6
7
7−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.
8−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
9
12
10Requirement: (8.6 <= on GHC)
13Requirement: (8.6 <= on GHC)
11
14
@@ -31,10 +34,10 @@ f3 = f4 0
31
34
32-- HsQualTy
35-- HsQualTy
33f4 :: Show a => a -> Int
36f4 :: Show a => a -> Int
34−f4 _ = f5 0 0
37+f4 n = f5 (show n) 0
35
38
36-- HsFunTy
39-- HsFunTy
37−f5 :: Int -> Int -> Int
40+f5 :: String -> Int -> Int
38f5 _ _ = head f6
41f5 _ _ = head f6
39
42
40-- HsListTy
43-- HsListTy
@@ -47,7 +50,13 @@ f7 = (fromJust f8, fromJust f8)
47
50
48-- HsAppTy
51-- HsAppTy
49f8 :: Maybe Int
52f8 :: Maybe Int
50−f8 = Just fError
53+f8 = Just f9
54+
55+f9 :: Int
56+f9 = f10
57+ where
58+ f10 :: Int
59+ f10 = fError
51
60
52-- HsTyVar
61-- HsTyVar
53fError :: Int
62fError :: Int
@@ -57,7 +66,7 @@ fError = error "fError"
57This example get error:
66This example get error:
58
67
59```shell
68```shell
60−$ cabal new-build
69+$ cabal build
61example/Main.hs:15:7: error:
70example/Main.hs:15:7: error:
62 Not in scope: type constructor or class ‘HasCallStack’
71 Not in scope: type constructor or class ‘HasCallStack’
63 |
72 |
@@ -70,10 +79,10 @@ Yes, add `import GHC.Stack` to above example.
70Fix and rebuild!
79Fix and rebuild!
71
80
72```shell
81```shell
73−$ cabal new-run
82+$ cabal run example -v0
74example: fError
83example: fError
75CallStack (from HasCallStack):
84CallStack (from HasCallStack):
76− error, called at example/Main.hs:41:10 in main:Main
85+ error, called at example/Main.hs:47:10 in main:Main
77```
86```
78
87
79Hmm, 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.
@@ -84,22 +93,22 @@ Hmm, it is not useful. But, you will to be happy when enable this plugin.
84```
93```
85
94
86```shell
95```shell
87−$ cabal new-run
96+$ cabal run example -v0
88−...
89−
90example: fError
97example: fError
91CallStack (from HasCallStack):
98CallStack (from HasCallStack):
92− error, called at example/Main.hs:40:10 in main:Main
99+ error, called at example/Main.hs:47:10 in main:Main
93− 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
94− f8, called at example/Main.hs:32:16 in main:Main
103+ f8, called at example/Main.hs:33:16 in main:Main
95− f7, called at example/Main.hs:28:11 in main:Main
104+ f7, called at example/Main.hs:29:11 in main:Main
96− f6, called at example/Main.hs:24:15 in main:Main
105+ f6, called at example/Main.hs:25:15 in main:Main
97− f5, called at example/Main.hs:20:8 in main:Main
106+ f5, called at example/Main.hs:21:8 in main:Main
98− f4, called at example/Main.hs:16:6 in main:Main
107+ f4, called at example/Main.hs:17:6 in main:Main
99− f3, called at example/Main.hs:12:6 in main:Main
108+ f3, called at example/Main.hs:13:6 in main:Main
100− f2, called at example/Main.hs:9:6 in main:Main
109+ f2, called at example/Main.hs:10:6 in main:Main
101− f1, called at example/Main.hs:6:14 in main:Main
110+ f1, called at example/Main.hs:7:14 in main:Main
102− main, called at example/Main.hs:6:1 in main:Main
111+ main, called at example/Main.hs:7:1 in main:Main
103```
112```
104
113
105−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+52−53
@@ -1,77 +1,76 @@
1+cabal-version: 2.4
1−name: haskell-stack-trace-plugin
2+name: haskell-stack-trace-plugin
2−version: 0.1.0.1
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-2020 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.5
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
22flag dev
29flag dev
23− description: Turn on development settings.
30+ description: Turn on development settings.
24− manual: True
31+ manual: True
25− default: False
32+ default: False
26
33
27−library
34+common common-opts
28− hs-source-dirs: src
29− build-depends:
35+ build-depends: base >=4.12 && <4.18
30− base >=4.12 && <4.13,
36+ default-language: Haskell2010
31− ghc>=8.6.2 && <8.6.6
32
37
33− exposed-modules:
38+library
39+ import: common-opts
40+ hs-source-dirs: src
41+ build-depends: ghc ^>=8.6 || ^>=8.8 || ^>=8.10 || ^>=9.0 || ^>=9.2 || ^>=9.4
34− StackTrace.Plugin
42+ exposed-modules: StackTrace.Plugin
35
43
36 if flag(dev)
44 if flag(dev)
37− ghc-options: -Wall -Werror -Wcompat
45+ ghc-options:
38− -- -Wincomplete-record-updates
39− -Wincomplete-uni-patterns
46+ -Wall -Werror -Wcompat -Wincomplete-uni-patterns
40− -Wnoncanonical-monad-instances
47+ -Wnoncanonical-monad-instances -Wno-missing-home-modules
41− -Wnoncanonical-monadfail-instances
48+
42− -Wno-missing-home-modules
43 else
49 else
44− ghc-options: -O2 -Wall
50+ ghc-options: -Wall
45− default-language: Haskell2010
46
51
47test-suite test
52test-suite test
53+ import: common-opts
48 main-is: Spec.hs
54 main-is: Spec.hs
49 hs-source-dirs: test
55 hs-source-dirs: test
50 type: exitcode-stdio-1.0
56 type: exitcode-stdio-1.0
51 build-depends:
57 build-depends:
52− base >=4.12 && <4.13,
53− bytestring >= 0.10.8 && <0.11,
58+ , bytestring >=0.10 && <0.12
54− hspec >= 2.7 && <2.8,
59+ , hspec ^>=2.8
55− typed-process >= 0.2.6 && <0.2.9
60+ , typed-process ^>=0.2
56−
57− build-tool-depends:
58− hspec-discover:hspec-discover >= 2.7 && <2.8
59
61
62+ build-tool-depends: hspec-discover:hspec-discover ^>=2.8
60− other-modules: StackTrace.PluginSpec
63+ other-modules: StackTrace.PluginSpec
61
64
62 if flag(dev)
65 if flag(dev)
63− ghc-options: -Wall -Werror
66+ ghc-options: -Wall -Werror
64− else
65− ghc-options: -O2 -Wall
66
67
67− default-language: Haskell2010
68+ else
69+ ghc-options: -Wall
68
70
69executable example
71executable example
72+ import: common-opts
70− main-is: Main.hs
73+ main-is: Main.hs
71 hs-source-dirs: example
74 hs-source-dirs: example
72− default-language: Haskell2010
73− ghc-options:
74− -fplugin=StackTrace.Plugin
75+ ghc-options: -fplugin=StackTrace.Plugin -Wredundant-constraints
75− build-depends:
76− base >=4.12 && <4.13,
77− haskell-stack-trace-plugin
76+ build-depends: haskell-stack-trace-plugin
src/StackTrace/Plugin.hs+109−14
@@ -1,11 +1,23 @@
1{-# LANGUAGE RankNTypes #-}
1{-# LANGUAGE RankNTypes #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE CPP #-}
3module StackTrace.Plugin (plugin) where
4module StackTrace.Plugin (plugin) where
4
5
5import Control.Arrow (first)
6import Control.Arrow (first)
6import 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+
7import GhcPlugins
13import GhcPlugins
14+#endif
15+#if __GLASGOW_HASKELL__ >= 810
16+import GHC.Hs
17+#endif
18+#if __GLASGOW_HASKELL__ < 810
8import HsSyn
19import HsSyn
20+#endif
9
21
10type Traversal s t a b
22type Traversal s t a b
11 = forall f. Applicative f =>
23 = forall f. Applicative f =>
@@ -28,13 +40,30 @@ parsedPlugin _ _ pm = do
28ghcStackModuleName :: ModuleName
40ghcStackModuleName :: ModuleName
29ghcStackModuleName = mkModuleName "AutoImported.GHC.Stack"
41ghcStackModuleName = mkModuleName "AutoImported.GHC.Stack"
30
42
43+#if __GLASGOW_HASKELL__ < 810
44+importDeclQualified :: Bool
45+importDeclQualified = True
46+#else
47+importDeclQualified :: ImportDeclQualifiedStyle
48+importDeclQualified = QualifiedPre
49+#endif
50+
31ghcStackImport :: Located (ImportDecl (GhcPass p))
51ghcStackImport :: Located (ImportDecl (GhcPass p))
32ghcStackImport =
52ghcStackImport =
33− noLoc $
53+ L srcSpan $
34 (simpleImportDecl $ mkModuleName "GHC.Stack")
54 (simpleImportDecl $ mkModuleName "GHC.Stack")
35− {ideclQualified = True, ideclAs = Just $ noLoc ghcStackModuleName}
55+ { ideclQualified = importDeclQualified, ideclAs = Just $ noLoc ghcStackModuleName }
36−
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
61+
62+#if __GLASGOW_HASKELL__ >= 900
63+updateHsModule :: HsModule -> HsModule
64+#else
37updateHsModule :: HsModule GhcPs -> HsModule GhcPs
65updateHsModule :: HsModule GhcPs -> HsModule GhcPs
66+#endif
38updateHsModule hsm =
67updateHsModule hsm =
39 hsm {hsmodImports = hsmodImports', hsmodDecls = hsmodDecls'}
68 hsm {hsmodImports = hsmodImports', hsmodDecls = hsmodDecls'}
40 where
69 where
@@ -56,7 +85,6 @@ updateHsModule hsm =
56 astTraversal :: Traversal' (LHsDecl GhcPs) (HsType GhcPs)
85 astTraversal :: Traversal' (LHsDecl GhcPs) (HsType GhcPs)
57 astTraversal = updateHsmodDecl
86 astTraversal = updateHsmodDecl
58 . updateHsDecl
87 . updateHsDecl
59− . updateSig
60 . updateLHsSigWsType
88 . updateLHsSigWsType
61 . updateLHsSigType
89 . updateLHsSigType
62 . updateLHsType
90 . updateLHsType
@@ -65,10 +93,56 @@ updateHsModule hsm =
65updateHsmodDecl :: Traversal' (LHsDecl GhcPs) (HsDecl GhcPs)
93updateHsmodDecl :: Traversal' (LHsDecl GhcPs) (HsDecl GhcPs)
66updateHsmodDecl = traverse
94updateHsmodDecl = traverse
67
95
68−updateHsDecl :: Traversal' (HsDecl GhcPs) (Sig GhcPs)
96+updateHsDecl :: Traversal' (HsDecl GhcPs) (LHsSigWcType GhcPs)
69−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
70updateHsDecl _ sig = pure sig
99updateHsDecl _ sig = pure sig
71
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+
72updateSig :: Traversal' (Sig GhcPs) (LHsSigWcType GhcPs)
146updateSig :: Traversal' (Sig GhcPs) (LHsSigWcType GhcPs)
73updateSig f (TypeSig xSig ls t) = TypeSig xSig ls <$> f t
147updateSig f (TypeSig xSig ls t) = TypeSig xSig ls <$> f t
74updateSig _ sig = pure sig
148updateSig _ sig = pure sig
@@ -76,41 +150,62 @@ updateSig _ sig = pure sig
76updateLHsSigWsType :: Traversal' (LHsSigWcType GhcPs) (LHsSigType GhcPs)
150updateLHsSigWsType :: Traversal' (LHsSigWcType GhcPs) (LHsSigType GhcPs)
77updateLHsSigWsType f lhs@HsWC {} =
151updateLHsSigWsType f lhs@HsWC {} =
78 (\x -> lhs {hswc_body = x}) <$> f (hswc_body lhs)
152 (\x -> lhs {hswc_body = x}) <$> f (hswc_body lhs)
153+#if __GLASGOW_HASKELL__ < 900
79updateLHsSigWsType _ lhs = pure lhs
154updateLHsSigWsType _ lhs = pure lhs
155+#endif
80
156
81updateLHsSigType :: Traversal' (LHsSigType GhcPs) (LHsType GhcPs)
157updateLHsSigType :: Traversal' (LHsSigType GhcPs) (LHsType GhcPs)
82updateLHsSigType f lhs@HsIB {} =
158updateLHsSigType f lhs@HsIB {} =
83 (\x -> lhs {hsib_body = x}) <$> f (hsib_body lhs)
159 (\x -> lhs {hsib_body = x}) <$> f (hsib_body lhs)
160+#if __GLASGOW_HASKELL__ < 900
84updateLHsSigType _ lhs = pure lhs
161updateLHsSigType _ lhs = pure lhs
162+#endif
85
163
86updateLHsType :: Traversal' (LHsType GhcPs) (HsType GhcPs)
164updateLHsType :: Traversal' (LHsType GhcPs) (HsType GhcPs)
87updateLHsType = traverse
165updateLHsType = traverse
88
166
89-- Main process
167-- Main process
90updateHsType :: HsType GhcPs -> (Any, HsType GhcPs)
168updateHsType :: HsType GhcPs -> (Any, HsType GhcPs)
91−updateHsType (HsQualTy xty ctxt body) =
169+updateHsType ty@(HsQualTy xty ctxt body) =
170+ if hasHasCallStack (unLoc ctxt)
171+ then pure ty
92− flagASTModified $ HsQualTy xty (fmap appendHSC ctxt) body
172+ else flagASTModified $ HsQualTy xty (fmap appendHSC ctxt) body
93updateHsType ty@HsTyVar {} =
173updateHsType ty@HsTyVar {} =
94− flagASTModified $ HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
174+ flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
95updateHsType ty@HsAppTy {} =
175updateHsType ty@HsAppTy {} =
96− flagASTModified $ HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
176+ flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
97updateHsType ty@HsFunTy {} =
177updateHsType ty@HsFunTy {} =
98− flagASTModified $ HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
178+ flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
99updateHsType ty@HsListTy {} =
179updateHsType ty@HsListTy {} =
100− flagASTModified $ HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
180+ flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
101updateHsType ty@HsTupleTy {} =
181updateHsType ty@HsTupleTy {} =
102− flagASTModified $ HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
182+ flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
103updateHsType ty = pure ty
183updateHsType ty = pure ty
104
184
185+#if __GLASGOW_HASKELL__ < 810
186+xQualTy :: NoExt
187+xQualTy = noExt
188+#else
189+xQualTy :: NoExtField
190+xQualTy = NoExtField
191+#endif
192+
105flagASTModified :: a -> (Any, a)
193flagASTModified :: a -> (Any, a)
106flagASTModified a = (Any True, a)
194flagASTModified a = (Any True, a)
107
195
108appendHSC :: HsContext GhcPs -> HsContext GhcPs
196appendHSC :: HsContext GhcPs -> HsContext GhcPs
109appendHSC cs = mkHSC : cs
197appendHSC cs = mkHSC : cs
110
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+
111-- make HasCallStack => constraint
206-- make HasCallStack => constraint
112mkHSC :: LHsType GhcPs
207mkHSC :: LHsType GhcPs
113−mkHSC = noLoc $ HsTyVar noExt NotPromoted lId
208+mkHSC = noLoc $ HsTyVar xQualTy NotPromoted lId
114
209
115lId :: Located (IdP GhcPs)
210lId :: Located (IdP GhcPs)
116lId = noLoc $ mkRdrQual ghcStackModuleName $ mkClsOcc "HasCallStack"
211lId = noLoc $ mkRdrQual ghcStackModuleName $ mkClsOcc "HasCallStack"
test/StackTrace/PluginSpec.hs+1−1
@@ -9,7 +9,7 @@ import System.Process.Typed
9spec :: Spec
9spec :: Spec
10spec = do
10spec = do
11 output <- runIO exe
11 output <- runIO exe
12− expected <- runIO $ BL.readFile "test/resource/ghc86.output"
12+ expected <- runIO $ BL.readFile "test/resource/ghc.output"
13 it "integration test" $ output `shouldBe` expected
13 it "integration test" $ output `shouldBe` expected
14
14
15
15
test/resource/ghc86.output → test/resource/ghc.outputrenamed+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