master..64f5a3e · typeable/haskell-stack-trace-plugin

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

on 64f5a3e help sign in

.github/workflows/cabal.ymldeleted−44

since splitsnapshots

unifiedsplit

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

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+1−2

@@ -3,5 +3,4 @@ dist-*/

3.ghc.environment.*

4cabal.project.local

6−*~

6+*~

7−tasks.json

CHANGELOG.md+1−23

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

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

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−

25## 0.1.0.0 -- 2018-12-07

3## 0.1.0.0 -- 2018-12-07

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

5+* 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+23−32

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

1# haskell-stack-trace-plugin

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)

3[![Hackage](https://img.shields.io/hackage/v/haskell-stack-trace-plugin.svg)](https://hackage.haskell.org/package/haskell-stack-trace-plugin)

6This plugin allow implicitly add `HasCallStack` class to every top-level function for all module. Hence, we can to get completely continuous call stack.

5This plugin allow implicitly add `HasCallStack` class to every top-level function for all module. Hence, we can to get completely continuous call stack.

8−1. (implicitly) Import [GHC.Stack](https://hackage.haskell.org/package/base/docs/GHC-Stack.html) for all modules.

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.

9−2. Add [HasCallStack](https://hackage.haskell.org/package/base/docs/GHC-Stack.html#t:HasCallStack) constraint for all top-level functions.

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.

10−3. Other supported syntaxes

11− - [x] `where` clause

13Requirement: (8.6 <= on GHC)

10Requirement: (8.6 <= on GHC)

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

35-- HsQualTy

32-- HsQualTy

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

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

37−f4 n = f5 (show n) 0

34+f4 _ = f5 0 0

39-- HsFunTy

36-- HsFunTy

40−f5 :: String -> Int -> Int

37+f5 :: Int -> Int -> Int

41f5 _ _ = head f6

38f5 _ _ = head f6

43-- HsListTy

40-- HsListTy

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

51-- HsAppTy

48-- HsAppTy

52f8 :: Maybe Int

49f8 :: Maybe Int

53−f8 = Just f9

50+f8 = Just fError

54−

55−f9 :: Int

56−f9 = f10

57− where

58− f10 :: Int

59− f10 = fError

61-- HsTyVar

52-- HsTyVar

62fError :: Int

53fError :: Int

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

66This example get error:

57This example get error:

68```shell

59```shell

69−$ cabal build

60+$ cabal new-build

70example/Main.hs:15:7: error:

61example/Main.hs:15:7: error:

71 Not in scope: type constructor or class ‘HasCallStack’

62 Not in scope: type constructor or class ‘HasCallStack’

72 |

63 |

@@ -79,10 +70,10 @@ Yes, add `import GHC.Stack` to above example.

79Fix and rebuild!

70Fix and rebuild!

81```shell

72```shell

82−$ cabal run example -v0

73+$ cabal new-run

83example: fError

74example: fError

84CallStack (from HasCallStack):

75CallStack (from HasCallStack):

85− error, called at example/Main.hs:47:10 in main:Main

76+ error, called at example/Main.hs:41:10 in main:Main

86```

77```

88Hmm, it is not useful. But, you will to be happy when enable this plugin.

79Hmm, it is not useful. But, you will to be happy when enable this plugin.

@@ -93,22 +84,22 @@ Hmm, it is not useful. But, you will to be happy when enable this plugin.

93```

84```

95```shell

86```shell

96−$ cabal run example -v0

87+$ cabal new-run

88+...

89+

97example: fError

90example: fError

98CallStack (from HasCallStack):

91CallStack (from HasCallStack):

99− error, called at example/Main.hs:47:10 in main:Main

92+ error, called at example/Main.hs:40:10 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

93+ fError, called at example/Main.hs:36:11 in main:Main

103− f8, called at example/Main.hs:33:16 in main:Main

94+ f8, called at example/Main.hs:32:16 in main:Main

104− f7, called at example/Main.hs:29:11 in main:Main

95+ f7, called at example/Main.hs:28:11 in main:Main

105− f6, called at example/Main.hs:25:15 in main:Main

96+ f6, called at example/Main.hs:24:15 in main:Main

106− f5, called at example/Main.hs:21:8 in main:Main

97+ f5, called at example/Main.hs:20:8 in main:Main

107− f4, called at example/Main.hs:17:6 in main:Main

98+ f4, called at example/Main.hs:16:6 in main:Main

108− f3, called at example/Main.hs:13:6 in main:Main

99+ f3, called at example/Main.hs:12:6 in main:Main

109− f2, called at example/Main.hs:10:6 in main:Main

100+ f2, called at example/Main.hs:9:6 in main:Main

110− f1, called at example/Main.hs:7:14 in main:Main

101+ f1, called at example/Main.hs:6:14 in main:Main

111− main, called at example/Main.hs:7:1 in main:Main

102+ main, called at example/Main.hs:6:1 in main:Main

112```

103```

113

104

114−Great!!!

105+Great!!!

example/Main.hs+3−9

@@ -18,10 +18,10 @@ f3 = f4 0

19-- HsQualTy

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

21−f4 n = f5 (show n) 0

21+f4 _ = f5 0 0

23-- HsFunTy

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

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

25f5 _ _ = head f6

27-- HsListTy

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

35-- HsAppTy

36f8 :: Maybe Int

37−f8 = Just f9

37+f8 = Just fError

38−

39−f9 :: Int

40−f9 = f10

41− where

42− f10 :: Int

43− f10 = fError

45-- HsTyVar

39-- HsTyVar

46fError :: Int

40fError :: Int

haskell-stack-trace-plugin.cabal+29−64

@@ -1,76 +1,41 @@

1−cabal-version: 2.4

2−name: haskell-stack-trace-plugin

1+name: haskell-stack-trace-plugin

3−version: 0.1.3.0

2+version: 0.1.0.1

4−synopsis: haskell-stack-trace-plugin

3+synopsis: haskell-stack-trace-plugin

5−description:

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.

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.

7−

8−homepage: https://github.com/waddlaw/haskell-stack-trace-plugin

5+homepage: https://github.com/waddlaw/haskell-stack-trace-plugin

9−bug-reports:

10− https://github.com/waddlaw/haskell-stack-trace-plugin/issues

6+bug-reports: https://github.com/waddlaw/haskell-stack-trace-plugin/issues

11−

12−license: MIT

7+license: MIT

13−license-file: LICENSE

8+license-file: LICENSE

14−author: Shinya Yamaguchi

9+author: Shinya Yamaguchi

15−maintainer: a@wado.dev

10+maintainer: ingronze@gmail.com

16−copyright: 2018-2021 Shinya Yamaguchi

11+copyright: 2018-2020 Shinya Yamaguchi

17−category: Compiler Plugin, Development, Debug

12+category: Compiler Plugin, Development, Debug

18−build-type: Simple

13+build-type: Simple

19−extra-source-files:

14+extra-source-files: CHANGELOG.md, Readme.md

20− CHANGELOG.md

15+cabal-version: >=1.10

21− Readme.md

22−

23−tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.4 || ==9.0.1

16+tested-with: GHC == 8.6.2

25source-repository head

18source-repository head

26 type: git

19 type: git

27 location: git://github.com/waddlaw/haskell-stack-trace-plugin

20 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−

38library

22library

39− import: common-opts

40− hs-source-dirs: src

23+ 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

57 build-depends:

24 build-depends:

58− , bytestring >=0.10 && <0.12

25+ base >=4.12 && <4.13,

59− , hspec ^>=2.8

26+ ghc>=8.6.2 && <8.6.6

60− , typed-process ^>=0.2

61−

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

63− other-modules: StackTrace.PluginSpec

65− if flag(dev)

28+ exposed-modules:

66− ghc-options: -Wall -Werror

29+ StackTrace.Plugin

68− else

31+ default-language: Haskell2010

69− ghc-options: -Wall

71executable example

33executable example

72− import: common-opts

73− main-is: Main.hs

34+ main-is: Main.hs

74 hs-source-dirs: example

35 hs-source-dirs: example

36+ default-language: Haskell2010

37+ ghc-options:

75− ghc-options: -fplugin=StackTrace.Plugin -Wredundant-constraints

38+ -fplugin=StackTrace.Plugin

39+ build-depends:

40+ base >=4.12 && <4.13,

76− build-depends: haskell-stack-trace-plugin

41+ haskell-stack-trace-plugin

src/StackTrace/Plugin.hs+14−109

@@ -1,23 +1,11 @@

1{-# LANGUAGE RankNTypes #-}

2{-# LANGUAGE OverloadedStrings #-}

3−{-# LANGUAGE CPP #-}

4module StackTrace.Plugin (plugin) where

3module StackTrace.Plugin (plugin) where

6import Control.Arrow (first)

5import Control.Arrow (first)

7import Data.Monoid (Any(Any, getAny))

6import Data.Monoid (Any(Any, getAny))

8−import GHC.Types.SrcLoc

9−#if __GLASGOW_HASKELL__ >= 900

10−import GHC.Plugins

11−#else

12−

13import GhcPlugins

7import GhcPlugins

14−#endif

15−#if __GLASGOW_HASKELL__ >= 810

16−import GHC.Hs

17−#endif

18−#if __GLASGOW_HASKELL__ < 810

19import HsSyn

8import HsSyn

20−#endif

22type Traversal s t a b

10type Traversal s t a b

23 = forall f. Applicative f =>

11 = forall f. Applicative f =>

@@ -40,30 +28,13 @@ parsedPlugin _ _ pm = do

40ghcStackModuleName :: ModuleName

28ghcStackModuleName :: ModuleName

41ghcStackModuleName = mkModuleName "AutoImported.GHC.Stack"

29ghcStackModuleName = 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−

51ghcStackImport :: Located (ImportDecl (GhcPass p))

31ghcStackImport :: Located (ImportDecl (GhcPass p))

52ghcStackImport =

32ghcStackImport =

53− L srcSpan $

33+ noLoc $

54 (simpleImportDecl $ mkModuleName "GHC.Stack")

34 (simpleImportDecl $ mkModuleName "GHC.Stack")

55− { ideclQualified = importDeclQualified, ideclAs = Just $ noLoc ghcStackModuleName }

35+ {ideclQualified = True, ideclAs = Just $ noLoc ghcStackModuleName}

56− where

36+

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

65updateHsModule :: HsModule GhcPs -> HsModule GhcPs

37updateHsModule :: HsModule GhcPs -> HsModule GhcPs

66−#endif

67updateHsModule hsm =

38updateHsModule hsm =

68 hsm {hsmodImports = hsmodImports', hsmodDecls = hsmodDecls'}

39 hsm {hsmodImports = hsmodImports', hsmodDecls = hsmodDecls'}

69 where

40 where

@@ -85,6 +56,7 @@ updateHsModule hsm =

85 astTraversal :: Traversal' (LHsDecl GhcPs) (HsType GhcPs)

56 astTraversal :: Traversal' (LHsDecl GhcPs) (HsType GhcPs)

86 astTraversal = updateHsmodDecl

57 astTraversal = updateHsmodDecl

87 . updateHsDecl

58 . updateHsDecl

59+ . updateSig

88 . updateLHsSigWsType

60 . updateLHsSigWsType

89 . updateLHsSigType

61 . updateLHsSigType

90 . updateLHsType

62 . updateLHsType

@@ -93,56 +65,10 @@ updateHsModule hsm =

93updateHsmodDecl :: Traversal' (LHsDecl GhcPs) (HsDecl GhcPs)

65updateHsmodDecl :: Traversal' (LHsDecl GhcPs) (HsDecl GhcPs)

94updateHsmodDecl = traverse

66updateHsmodDecl = traverse

96−updateHsDecl :: Traversal' (HsDecl GhcPs) (LHsSigWcType GhcPs)

68+updateHsDecl :: Traversal' (HsDecl GhcPs) (Sig GhcPs)

97−updateHsDecl f (SigD xSig s) = SigD xSig <$> updateSig f s

69+updateHsDecl f (SigD xSig s) = SigD xSig <$> f s

98−updateHsDecl f (ValD xVal hsBind) = ValD xVal <$> updateHsBind f hsBind

99updateHsDecl _ sig = pure sig

70updateHsDecl _ 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−

146updateSig :: Traversal' (Sig GhcPs) (LHsSigWcType GhcPs)

72updateSig :: Traversal' (Sig GhcPs) (LHsSigWcType GhcPs)

147updateSig f (TypeSig xSig ls t) = TypeSig xSig ls <$> f t

73updateSig f (TypeSig xSig ls t) = TypeSig xSig ls <$> f t

148updateSig _ sig = pure sig

74updateSig _ sig = pure sig

@@ -150,62 +76,41 @@ updateSig _ sig = pure sig

150updateLHsSigWsType :: Traversal' (LHsSigWcType GhcPs) (LHsSigType GhcPs)

76updateLHsSigWsType :: Traversal' (LHsSigWcType GhcPs) (LHsSigType GhcPs)

151updateLHsSigWsType f lhs@HsWC {} =

77updateLHsSigWsType f lhs@HsWC {} =

152 (\x -> lhs {hswc_body = x}) <$> f (hswc_body lhs)

78 (\x -> lhs {hswc_body = x}) <$> f (hswc_body lhs)

153−#if __GLASGOW_HASKELL__ < 900

154updateLHsSigWsType _ lhs = pure lhs

79updateLHsSigWsType _ lhs = pure lhs

155−#endif

156

157updateLHsSigType :: Traversal' (LHsSigType GhcPs) (LHsType GhcPs)

81updateLHsSigType :: Traversal' (LHsSigType GhcPs) (LHsType GhcPs)

158updateLHsSigType f lhs@HsIB {} =

82updateLHsSigType f lhs@HsIB {} =

159 (\x -> lhs {hsib_body = x}) <$> f (hsib_body lhs)

83 (\x -> lhs {hsib_body = x}) <$> f (hsib_body lhs)

160−#if __GLASGOW_HASKELL__ < 900

161updateLHsSigType _ lhs = pure lhs

84updateLHsSigType _ lhs = pure lhs

162−#endif

163

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

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

165updateLHsType = traverse

87updateLHsType = traverse

166

167-- Main process

89-- Main process

168updateHsType :: HsType GhcPs -> (Any, HsType GhcPs)

90updateHsType :: HsType GhcPs -> (Any, HsType GhcPs)

169−updateHsType ty@(HsQualTy xty ctxt body) =

91+updateHsType (HsQualTy xty ctxt body) =

170− if hasHasCallStack (unLoc ctxt)

171− then pure ty

172− else flagASTModified $ HsQualTy xty (fmap appendHSC ctxt) body

92+ flagASTModified $ HsQualTy xty (fmap appendHSC ctxt) body

173updateHsType ty@HsTyVar {} =

93updateHsType ty@HsTyVar {} =

174− flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)

94+ flagASTModified $ HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)

175updateHsType ty@HsAppTy {} =

95updateHsType ty@HsAppTy {} =

176− flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)

96+ flagASTModified $ HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)

177updateHsType ty@HsFunTy {} =

97updateHsType ty@HsFunTy {} =

178− flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)

98+ flagASTModified $ HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)

179updateHsType ty@HsListTy {} =

99updateHsType ty@HsListTy {} =

180− flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)

100+ flagASTModified $ HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)

181updateHsType ty@HsTupleTy {} =

101updateHsType ty@HsTupleTy {} =

182− flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)

102+ flagASTModified $ HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)

183updateHsType ty = pure ty

103updateHsType ty = pure ty

184

104

185−#if __GLASGOW_HASKELL__ < 810

186−xQualTy :: NoExt

187−xQualTy = noExt

188−#else

189−xQualTy :: NoExtField

190−xQualTy = NoExtField

191−#endif

192−

193flagASTModified :: a -> (Any, a)

105flagASTModified :: a -> (Any, a)

194flagASTModified a = (Any True, a)

106flagASTModified a = (Any True, a)

195

107

196appendHSC :: HsContext GhcPs -> HsContext GhcPs

108appendHSC :: HsContext GhcPs -> HsContext GhcPs

197appendHSC cs = mkHSC : cs

109appendHSC cs = mkHSC : cs

198

110

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−

206-- make HasCallStack => constraint

111-- make HasCallStack => constraint

207mkHSC :: LHsType GhcPs

112mkHSC :: LHsType GhcPs

208−mkHSC = noLoc $ HsTyVar xQualTy NotPromoted lId

113+mkHSC = noLoc $ HsTyVar noExt NotPromoted lId

209

114

210lId :: Located (IdP GhcPs)

115lId :: Located (IdP GhcPs)

211lId = noLoc $ mkRdrQual ghcStackModuleName $ mkClsOcc "HasCallStack"

116lId = noLoc $ mkRdrQual ghcStackModuleName $ mkClsOcc "HasCallStack"

test/Spec.hsdeleted−1

@@ -1 +0,0 @@

1−{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

test/StackTrace/PluginSpec.hsdeleted−21

@@ -1,21 +0,0 @@

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.outputdeleted−15

@@ -1,15 +0,0 @@

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