git.iko.soy/typeable/haskell-stack-trace-plugin
on master help sign in
swap
6624a5942 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+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+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.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 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 && <8.6.6
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+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/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