master..0568fe5 · typeable/haskell-stack-trace-plugin

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

on 0568fe5 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−34

@@ -1,14 +1,9 @@

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)

5−

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

3This 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.

5+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.

6+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)

8Requirement: (8.6 <= on GHC)

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

35-- HsQualTy

30-- HsQualTy

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

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

37−f4 n = f5 (show n) 0

32+f4 _ = f5 0 0

39-- HsFunTy

34-- HsFunTy

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

35+f5 :: Int -> Int -> Int

41f5 _ _ = head f6

36f5 _ _ = head f6

43-- HsListTy

38-- HsListTy

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

51-- HsAppTy

46-- HsAppTy

52f8 :: Maybe Int

47f8 :: Maybe Int

53−f8 = Just f9

48+f8 = Just fError

54−

55−f9 :: Int

56−f9 = f10

57− where

58− f10 :: Int

59− f10 = fError

61-- HsTyVar

50-- HsTyVar

62fError :: Int

51fError :: Int

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

66This example get error:

55This example get error:

68```shell

57```shell

69−$ cabal build

58+$ cabal new-build

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

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

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

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

72 |

61 |

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

79Fix and rebuild!

68Fix and rebuild!

81```shell

70```shell

82−$ cabal run example -v0

71+$ cabal new-run

83example: fError

72example: fError

84CallStack (from HasCallStack):

73CallStack (from HasCallStack):

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

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

86```

75```

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

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

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

93```

82```

95```shell

84```shell

96−$ cabal run example -v0

85+$ cabal new-run

86+...

87+

97example: fError

88example: fError

98CallStack (from HasCallStack):

89CallStack (from HasCallStack):

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

112```

101```

113

102

114−Great!!!

103+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.0

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

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+57−187

@@ -1,211 +1,81 @@

1−{-# LANGUAGE RankNTypes #-}

2{-# LANGUAGE OverloadedStrings #-}

1{-# LANGUAGE OverloadedStrings #-}

3−{-# LANGUAGE CPP #-}

4module StackTrace.Plugin (plugin) where

2module StackTrace.Plugin (plugin) where

5−

6−import Control.Arrow (first)

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

8−import GHC.Types.SrcLoc

9−#if __GLASGOW_HASKELL__ >= 900

10−import GHC.Plugins

11−#else

12−

13import GhcPlugins

4import GhcPlugins

14−#endif

5+import TcRnTypes (IfM, TcM, TcGblEnv, tcg_binds, tcg_rn_decls)

15−#if __GLASGOW_HASKELL__ >= 810

6+import HsExtension (GhcTc, GhcRn)

16−import GHC.Hs

7+import HsDecls (HsGroup)

17−#endif

8+import HsExpr (LHsExpr)

18−#if __GLASGOW_HASKELL__ < 810

19import HsSyn

9import HsSyn

20−#endif

22−type Traversal s t a b

11+import Data.Maybe

23− = forall f. Applicative f =>

24− (a -> f b) -> s -> f t

25−

26−type Traversal' s a = Traversal s s a a

28plugin :: Plugin

13plugin :: Plugin

14+plugin = defaultPlugin

29−plugin = defaultPlugin {parsedResultAction = parsedPlugin, pluginRecompile = purePlugin}

15+ { parsedResultAction = parsedPlugin

16+ }

31−parsedPlugin ::

32− [CommandLineOption] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule

18+parsedPlugin :: [CommandLineOption] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule

33parsedPlugin _ _ pm = do

19parsedPlugin _ _ pm = do

20+ dflags <- getDynFlags

21+

22+ let extract = hsmodImports . unLoc

23+ addGHCStackMod = noLoc $ simpleImportDecl $ mkModuleName "GHC.Stack"

24+

34− let m = updateHsModule <$> hpm_module pm

25+ m = updateHsModule addGHCStackMod updateHsmodDecl <$> hpm_module pm

35− pm' = pm {hpm_module = m}

26+ pm' = pm { hpm_module = m }

27+

36 return pm'

28 return pm'

38−-- Use qualified import for GHC.Stack as "AutoImported.GHC.Stack"

30+updateHsModule :: LImportDecl GhcPs -> (LHsDecl GhcPs -> LHsDecl GhcPs) -> HsModule GhcPs -> HsModule GhcPs

39−-- ...this should not interfere with other imports...

31+updateHsModule importDecl update hsm = hsm

40−ghcStackModuleName :: ModuleName

32+ { hsmodImports = importDecl:decls

41−ghcStackModuleName = mkModuleName "AutoImported.GHC.Stack"

33+ , hsmodDecls = map update lhss

42−

34+ }

43−#if __GLASGOW_HASKELL__ < 810

44−importDeclQualified :: Bool

45−importDeclQualified = True

46−#else

47−importDeclQualified :: ImportDeclQualifiedStyle

48−importDeclQualified = QualifiedPre

49−#endif

50−

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

52−ghcStackImport =

53− L srcSpan $

54− (simpleImportDecl $ mkModuleName "GHC.Stack")

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

56 where

35 where

57− -- This is for GHC-9 related problems. @noLoc@ causes GHC to throw warnings

36+ decls = hsmodImports hsm

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

65−updateHsModule :: HsModule GhcPs -> HsModule GhcPs

66−#endif

67−updateHsModule hsm =

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

69− where

70− -- Traverse the haskell AST; if we have to add some HasStack

71− -- constraint we set a flag in a (Any,) functor.

72− -- ...it'd be simpler to check if before == after, but Haskell AST

73− -- doesn't have Eq instances.

74− (updatedP, hsmodDecls') =

75− first getAny $

76− (traverse . astTraversal) updateHsType (hsmodDecls hsm)

37+ lhss = hsmodDecls hsm

77−

78− -- Only import GHC.Stack if needed for a constraint we introduced

79− hsmodImports' =

80− (if updatedP

81− then [ghcStackImport]

82− else []) ++

83− hsmodImports hsm

84−

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

86− astTraversal = updateHsmodDecl

87− . updateHsDecl

88− . updateLHsSigWsType

89− . updateLHsSigType

90− . updateLHsType

92--------------

39--------------

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

40+

94−updateHsmodDecl = traverse

41+updateHsmodDecl :: LHsDecl GhcPs -> LHsDecl GhcPs

95−

42+updateHsmodDecl = fmap updateHsDecl

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

43+

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

44+updateHsDecl :: HsDecl GhcPs -> HsDecl GhcPs

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

45+updateHsDecl (SigD xSig s) = SigD xSig (updateSig s)

99−updateHsDecl _ sig = pure sig

46+updateHsDecl decl = decl

100−

47+

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−

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

48+updateSig :: Sig GhcPs -> Sig GhcPs

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

49+updateSig (TypeSig xSig ls t) = TypeSig xSig ls (updateLHsSigWcType t)

148−updateSig _ sig = pure sig

50+updateSig sig = sig

149−

51+

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

52+updateLHsSigWcType :: LHsSigWcType GhcPs -> LHsSigWcType GhcPs

151−updateLHsSigWsType f lhs@HsWC {} =

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

53+updateLHsSigWcType lhs@HsWC{} = lhs { hswc_body = updateLHsSigType (hswc_body lhs) }

153−#if __GLASGOW_HASKELL__ < 900

54+updateLHsSigWcType lhs@XHsWildCardBndrs{} = lhs

154−updateLHsSigWsType _ lhs = pure lhs

55+

155−#endif

156−

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

56+updateLHsSigType :: LHsSigType GhcPs -> LHsSigType GhcPs

158−updateLHsSigType f lhs@HsIB {} =

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

57+updateLHsSigType lhs@HsIB{} = lhs { hsib_body = updateLHsType (hsib_body lhs )}

160−#if __GLASGOW_HASKELL__ < 900

161−updateLHsSigType _ lhs = pure lhs

58+updateLHsSigType lhs@XHsImplicitBndrs{} = lhs

162−#endif

59+

163−

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

60+updateLHsType :: LHsType GhcPs -> LHsType GhcPs

165−updateLHsType = traverse

61+updateLHsType = fmap updateHsType

166

167-- Main process

63-- Main process

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

64+updateHsType :: HsType GhcPs -> HsType GhcPs

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

65+updateHsType ty@(HsQualTy xty ctxt body) = HsQualTy xty (fmap appendHSC ctxt) body

170− if hasHasCallStack (unLoc ctxt)

171− then pure ty

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

173−updateHsType ty@HsTyVar {} =

66+updateHsType ty@HsTyVar{} = HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)

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

175−updateHsType ty@HsAppTy {} =

67+updateHsType ty@HsAppTy{} = HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)

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

177−updateHsType ty@HsFunTy {} =

68+updateHsType ty@HsFunTy{} = HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)

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

179−updateHsType ty@HsListTy {} =

69+updateHsType ty@HsListTy{} = HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)

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

181−updateHsType ty@HsTupleTy {} =

70+updateHsType ty@HsTupleTy{} = HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)

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

183−updateHsType ty = pure ty

71+updateHsType ty = ty

184−

185−#if __GLASGOW_HASKELL__ < 810

186−xQualTy :: NoExt

187−xQualTy = noExt

188−#else

189−xQualTy :: NoExtField

190−xQualTy = NoExtField

191−#endif

192−

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

194−flagASTModified a = (Any True, a)

195

196appendHSC :: HsContext GhcPs -> HsContext GhcPs

73appendHSC :: HsContext GhcPs -> HsContext GhcPs

197appendHSC cs = mkHSC : cs

74appendHSC cs = mkHSC : cs

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−

206-- make HasCallStack => constraint

76-- make HasCallStack => constraint

207mkHSC :: LHsType GhcPs

77mkHSC :: LHsType GhcPs

208−mkHSC = noLoc $ HsTyVar xQualTy NotPromoted lId

78+mkHSC = noLoc $ HsTyVar noExt NotPromoted lId

209

210lId :: Located (IdP GhcPs)

80lId :: Located (IdP GhcPs)

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

81+lId = noLoc $ mkRdrUnqual $ 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