70854be...master · typeable/haskell-stack-trace-plugin

git.iko.soy/typeable/haskell-stack-trace-plugin

on master help sign in

.github/workflows/cabal.ymlnew file+44

since splitsnapshots

unifiedsplit

@@ -0,0 +1,44 @@

1+name: cabal

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.*

4cabal.project.local

6−*~

6+*~

7+tasks.json

CHANGELOG.md+23−1

@@ -1,5 +1,27 @@

1# Revision history for haskell-stack-trace-pugin

3+## Unreleased changes

5+## 0.1.3.0

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)

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

5−* First version. Released on an unsuspecting world.

27+- First version. Released on an unsuspecting world.

LICENSE+1−1

@@ -1,4 +1,4 @@

3Permission is hereby granted, free of charge, to any person obtaining

4a copy of this software and associated documentation files (the

Readme.md+32−23

@@ -1,11 +1,14 @@

1# haskell-stack-trace-plugin

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)

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.

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

10Requirement: (8.6 <= on GHC)

13Requirement: (8.6 <= on GHC)

@@ -31,10 +34,10 @@ f3 = f4 0

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

36-- HsFunTy

39-- HsFunTy

37−f5 :: Int -> Int -> Int

40+f5 :: String -> Int -> Int

38f5 _ _ = head f6

41f5 _ _ = head f6

40-- HsListTy

43-- HsListTy

@@ -47,7 +50,13 @@ f7 = (fromJust f8, fromJust f8)

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

52-- HsTyVar

61-- HsTyVar

53fError :: Int

62fError :: Int

@@ -57,7 +66,7 @@ fError = error "fError"

57This example get error:

66This example get error:

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!

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```

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```

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

19-- HsQualTy

20f4 :: Show a => a -> Int

21−f4 _ = f5 0 0

21+f4 n = f5 (show n) 0

23-- HsFunTy

24−f5 :: Int -> Int -> Int

24+f5 :: String -> Int -> Int

25f5 _ _ = head f6

27-- HsListTy

@@ -34,7 +34,13 @@ f7 = (fromJust f8, fromJust f8)

35-- HsAppTy

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

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.

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

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

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

28− exposed-modules:

62+ build-tool-depends: hspec-discover:hspec-discover ^>=2.8

29− StackTrace.Plugin

63+ other-modules: StackTrace.PluginSpec

31− default-language: Haskell2010

65+ if flag(dev)

66+ ghc-options: -Wall -Werror

67+

68+ else

69+ ghc-options: -Wall

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 #-}

2{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE CPP #-}

3module StackTrace.Plugin (plugin) where

4module StackTrace.Plugin (plugin) where

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

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"

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

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

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

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

163

86updateLHsType :: Traversal' (LHsType GhcPs) (HsType GhcPs)

164updateLHsType :: Traversal' (LHsType GhcPs) (HsType GhcPs)

87updateLHsType = traverse

165updateLHsType = traverse

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

4+import Data.ByteString.Lazy (ByteString)

5+import qualified Data.ByteString.Lazy as BL

6+import Test.Hspec

7+import System.Process.Typed

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