master..50a8d04 · typeable/haskell-stack-trace-plugin

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

on 50a8d04 help sign in

.github/workflows/cabal.yml+28−16

since splitsnapshots

unifiedsplit

@@ -2,9 +2,13 @@ name: cabal

3on:

4 push:

5− branches: [ master ]

5+ branches:

6+ - master

7+ tags-ignore:

8+ - '*'

6 pull_request:

9 pull_request:

7− branches: [ '*' ]

10+ branches:

11+ - '*'

8 schedule:

12 schedule:

9 - cron: "00 15 * * *"

13 - cron: "00 15 * * *"

@@ -13,32 +17,40 @@ jobs:

13 runs-on: ubuntu-18.04

17 runs-on: ubuntu-18.04

14 strategy:

18 strategy:

15 matrix:

19 matrix:

16− ghc: ["8.6", "8.8", "8.10", "9.0"]

20+ ghc: ["8.6.5", "8.8.1"]

17− cabal: ["3.2"]

21+ cabal: ["3.0"]

18− cache-version: ["2021-05-21"]

20 steps:

23 steps:

21 - uses: actions/checkout@v2

24 - uses: actions/checkout@v2

22− - uses: haskell/actions/setup@v1

25+ - uses: actions/setup-haskell@v1

23 with:

26 with:

24 ghc-version: ${{ matrix.ghc }}

27 ghc-version: ${{ matrix.ghc }}

25 cabal-version: ${{ matrix.cabal }}

28 cabal-version: ${{ matrix.cabal }}

30+ - name: Display ghc & cabal version

31+ run: |

32+ ghc -V

33+ cabal -V

34+

27 - name: Cache ~/.cabal/store

35 - name: Cache ~/.cabal/store

28− uses: actions/cache@v2

36+ uses: actions/cache@v1.1.0

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

29 with:

43 with:

30− path: |

31− ~/.cabal/store

32− dist-newstyle

44+ path: dist-newstyle

33− key: ${{ runner.os }}-${{ matrix.ghc }}-${{ matrix.cache-version }}-cabal

45+ key: ${{ matrix.ghc }}-v0-cabal-dist-${{ hashFiles('*.cabal') }}

35 - name: Install dependencies

47 - name: Install dependencies

36 run: |

48 run: |

37− cabal update

49+ cabal v2-update

38− cabal configure --disable-optimization --enable-tests --write-ghc-environment-files=always -j2

50+ cabal v2-configure --disable-optimization --enable-tests --write-ghc-environment-files=always -j2

39− cabal build --only-dependencies

51+ cabal v2-build --only-dependencies

41 - name: Build & Test

53 - name: Build & Test

42 run: |

54 run: |

43− cabal build --flag dev

55+ cabal v2-build --flag dev

44− cabal test --flag dev

56+ cabal v2-test --flag dev

.gitignore+1−2

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

3.ghc.environment.*

4cabal.project.local

6−*~

6+*~

7−tasks.json

CHANGELOG.md−10

@@ -2,16 +2,6 @@

3## Unreleased changes

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

5## 0.1.1.1 -- 2020-01-18

17- Allow GHC-8.8.1

7- Allow GHC-8.8.1

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+22−30

@@ -5,10 +5,8 @@

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

8+1. (implicitly) Import [GHC.Stack](https://hackage.haskell.org/package/base-4.12.0.0/docs/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.

9+2. Add [HasCallStack](https://hackage.haskell.org/package/base-4.12.0.0/docs/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)

11Requirement: (8.6 <= on GHC)

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

35-- HsQualTy

33-- HsQualTy

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

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

37−f4 n = f5 (show n) 0

35+f4 _ = f5 0 0

39-- HsFunTy

37-- HsFunTy

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

38+f5 :: Int -> Int -> Int

41f5 _ _ = head f6

39f5 _ _ = head f6

43-- HsListTy

41-- HsListTy

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

51-- HsAppTy

49-- HsAppTy

52f8 :: Maybe Int

50f8 :: Maybe Int

53−f8 = Just f9

51+f8 = Just fError

54−

55−f9 :: Int

56−f9 = f10

57− where

58− f10 :: Int

59− f10 = fError

61-- HsTyVar

53-- HsTyVar

62fError :: Int

54fError :: Int

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

66This example get error:

58This example get error:

68```shell

60```shell

69−$ cabal build

61+$ cabal new-build

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

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

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

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

72 |

64 |

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

79Fix and rebuild!

71Fix and rebuild!

81```shell

73```shell

82−$ cabal run example -v0

74+$ cabal new-run

83example: fError

75example: fError

84CallStack (from HasCallStack):

76CallStack (from HasCallStack):

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

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

86```

78```

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

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

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

93```

85```

95```shell

87```shell

96−$ cabal run example -v0

88+$ cabal new-run

89+...

90+

97example: fError

91example: fError

98CallStack (from HasCallStack):

92CallStack (from HasCallStack):

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

112```

104```

113

105

114Great!!!

106Great!!!

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+14−12

@@ -1,6 +1,6 @@

1cabal-version: 2.4

2name: haskell-stack-trace-plugin

3−version: 0.1.3.0

3+version: 0.1.1.1

4synopsis: haskell-stack-trace-plugin

5description:

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.

@@ -12,15 +12,15 @@ bug-reports:

12license: MIT

13license-file: LICENSE

14author: Shinya Yamaguchi

15−maintainer: a@wado.dev

15+maintainer: ingronze@gmail.com

16−copyright: 2018-2021 Shinya Yamaguchi

16+copyright: 2018-2020 Shinya Yamaguchi

17category: Compiler Plugin, Development, Debug

18build-type: Simple

19extra-source-files:

20 CHANGELOG.md

21 Readme.md

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

23+tested-with: GHC ==8.6.5 || ==8.8.1

25source-repository head

26 type: git

@@ -32,20 +32,22 @@ flag dev

32 default: False

34common common-opts

35− build-depends: base >=4.12 && <4.18

35+ build-depends: base >=4.12 && <4.14

36 default-language: Haskell2010

38library

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

41+ build-depends: ghc ^>=8.6 || ^>=8.8

42 exposed-modules: StackTrace.Plugin

44 if flag(dev)

45 ghc-options:

46 -Wall -Werror -Wcompat -Wincomplete-uni-patterns

47− -Wnoncanonical-monad-instances -Wno-missing-home-modules

47+ -Wnoncanonical-monad-instances

48+ -Wno-missing-home-modules

50+ -- -Wincomplete-record-updates

49 else

51 else

50 ghc-options: -Wall

52 ghc-options: -Wall

@@ -55,11 +57,11 @@ test-suite test

55 hs-source-dirs: test

57 hs-source-dirs: test

56 type: exitcode-stdio-1.0

58 type: exitcode-stdio-1.0

57 build-depends:

59 build-depends:

58− , bytestring >=0.10 && <0.12

60+ , bytestring ^>=0.10

59− , hspec ^>=2.8

61+ , hspec ^>=2.7

60− , typed-process ^>=0.2

62+ , typed-process ^>=0.2.6

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

64+ build-tool-depends: hspec-discover:hspec-discover ^>=2.7

63 other-modules: StackTrace.PluginSpec

65 other-modules: StackTrace.PluginSpec

65 if flag(dev)

67 if flag(dev)

@@ -72,5 +74,5 @@ executable example

72 import: common-opts

74 import: common-opts

73 main-is: Main.hs

75 main-is: Main.hs

74 hs-source-dirs: example

76 hs-source-dirs: example

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

77+ ghc-options: -fplugin=StackTrace.Plugin

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

78 build-depends: 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/resource/ghc.output+2−4

@@ -1,9 +1,7 @@

1example: fError

2CallStack (from HasCallStack):

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

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

4− fError, called at example/Main.hs:43:11 in main:Main

4+ fError, called at example/Main.hs:37: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

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

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

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

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

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