093a052..master · typeable/haskell-stack-trace-plugin

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

on master help sign in

.github/workflows/cabal.yml+1−1

since splitsnapshots

unifiedsplit

@@ -13,7 +13,7 @@ jobs:

13 runs-on: ubuntu-18.04

14 strategy:

15 matrix:

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

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

17 cabal: ["3.2"]

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

CHANGELOG.md+6

@@ -2,9 +2,15 @@

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)

5## 0.1.2.0 -- 2021-05-21

10## 0.1.2.0 -- 2021-05-21

7- Added support for GHC 8.10 [#7](https://github.com/waddlaw/haskell-stack-trace-plugin/pull/7) (@etorreborre)

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

9## 0.1.1.1 -- 2020-01-18

15## 0.1.1.1 -- 2020-01-18

Readme.md+30−22

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

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-4.12.0.0/docs/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.

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.

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

11Requirement: (8.6 <= on GHC)

13Requirement: (8.6 <= on GHC)

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

33-- HsQualTy

35-- HsQualTy

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

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

35−f4 _ = f5 0 0

37+f4 n = f5 (show n) 0

37-- HsFunTy

39-- HsFunTy

38−f5 :: Int -> Int -> Int

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

39f5 _ _ = head f6

41f5 _ _ = head f6

41-- HsListTy

43-- HsListTy

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

49-- HsAppTy

51-- HsAppTy

50f8 :: Maybe Int

52f8 :: Maybe Int

51−f8 = Just fError

53+f8 = Just f9

54+

55+f9 :: Int

56+f9 = f10

57+ where

58+ f10 :: Int

59+ f10 = fError

53-- HsTyVar

61-- HsTyVar

54fError :: Int

62fError :: Int

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

58This example get error:

66This example get error:

60```shell

68```shell

61−$ cabal new-build

69+$ cabal build

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

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

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

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

64 |

72 |

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

71Fix and rebuild!

79Fix and rebuild!

73```shell

81```shell

74−$ cabal new-run

82+$ cabal run example -v0

75example: fError

83example: fError

76CallStack (from HasCallStack):

84CallStack (from HasCallStack):

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

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

78```

86```

80Hmm, 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.

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

85```

93```

87```shell

95```shell

88−$ cabal new-run

96+$ cabal run example -v0

89−...

90−

91example: fError

97example: fError

92CallStack (from HasCallStack):

98CallStack (from HasCallStack):

93− error, called at example/Main.hs:40:10 in main:Main

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

104```

112```

105

113

106Great!!!

114Great!!!

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+6−5

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

1cabal-version: 2.4

2name: haskell-stack-trace-plugin

3−version: 0.1.2.0

3+version: 0.1.3.0

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.

@@ -20,7 +20,7 @@ extra-source-files:

20 CHANGELOG.md

21 Readme.md

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

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

25source-repository head

26 type: git

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

32 default: False

34common common-opts

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

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

36 default-language: Haskell2010

38library

39 import: common-opts

40 hs-source-dirs: src

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

41+ build-depends: ghc ^>=8.6 || ^>=8.8 || ^>=8.10 || ^>=9.0 || ^>=9.2 || ^>=9.4

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

48+

48 else

49 else

49 ghc-options: -Wall

50 ghc-options: -Wall

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

71 import: common-opts

72 import: common-opts

72 main-is: Main.hs

73 main-is: Main.hs

73 hs-source-dirs: example

74 hs-source-dirs: example

74− ghc-options: -fplugin=StackTrace.Plugin

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

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

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

src/StackTrace/Plugin.hs+81−7

@@ -5,7 +5,13 @@ module StackTrace.Plugin (plugin) where

6import Control.Arrow (first)

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

8+import GHC.Types.SrcLoc

9+#if __GLASGOW_HASKELL__ >= 900

10+import GHC.Plugins

11+#else

12+

8import GhcPlugins

13import GhcPlugins

14+#endif

9#if __GLASGOW_HASKELL__ >= 810

15#if __GLASGOW_HASKELL__ >= 810

10import GHC.Hs

16import GHC.Hs

11#endif

17#endif

@@ -44,11 +50,20 @@ importDeclQualified = QualifiedPre

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

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

46ghcStackImport =

52ghcStackImport =

47− noLoc $

53+ L srcSpan $

48 (simpleImportDecl $ mkModuleName "GHC.Stack")

54 (simpleImportDecl $ mkModuleName "GHC.Stack")

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

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

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

62+#if __GLASGOW_HASKELL__ >= 900

63+updateHsModule :: HsModule -> HsModule

64+#else

51updateHsModule :: HsModule GhcPs -> HsModule GhcPs

65updateHsModule :: HsModule GhcPs -> HsModule GhcPs

66+#endif

52updateHsModule hsm =

67updateHsModule hsm =

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

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

54 where

69 where

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

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

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

71 astTraversal = updateHsmodDecl

86 astTraversal = updateHsmodDecl

72 . updateHsDecl

87 . updateHsDecl

73− . updateSig

74 . updateLHsSigWsType

88 . updateLHsSigWsType

75 . updateLHsSigType

89 . updateLHsSigType

76 . updateLHsType

90 . updateLHsType

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

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

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

80updateHsmodDecl = traverse

94updateHsmodDecl = traverse

82−updateHsDecl :: Traversal' (HsDecl GhcPs) (Sig GhcPs)

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

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

84updateHsDecl _ 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+

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

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

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

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

88updateSig _ sig = pure sig

148updateSig _ sig = pure sig

@@ -90,20 +150,26 @@ updateSig _ sig = pure sig

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

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

91updateLHsSigWsType f lhs@HsWC {} =

151updateLHsSigWsType f lhs@HsWC {} =

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

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

153+#if __GLASGOW_HASKELL__ < 900

93updateLHsSigWsType _ lhs = pure lhs

154updateLHsSigWsType _ lhs = pure lhs

155+#endif

156

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

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

96updateLHsSigType f lhs@HsIB {} =

158updateLHsSigType f lhs@HsIB {} =

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

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

160+#if __GLASGOW_HASKELL__ < 900

98updateLHsSigType _ lhs = pure lhs

161updateLHsSigType _ lhs = pure lhs

162+#endif

163

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

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

101updateLHsType = traverse

165updateLHsType = traverse

102

166

103-- Main process

167-- Main process

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

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

105−updateHsType (HsQualTy xty ctxt body) =

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

170+ if hasHasCallStack (unLoc ctxt)

171+ then pure ty

106− flagASTModified $ HsQualTy xty (fmap appendHSC ctxt) body

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

107updateHsType ty@HsTyVar {} =

173updateHsType ty@HsTyVar {} =

108 flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)

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

109updateHsType ty@HsAppTy {} =

175updateHsType ty@HsAppTy {} =

@@ -117,6 +183,7 @@ updateHsType ty@HsTupleTy {} =

117updateHsType ty = pure ty

183updateHsType ty = pure ty

118

184

119#if __GLASGOW_HASKELL__ < 810

185#if __GLASGOW_HASKELL__ < 810

186+xQualTy :: NoExt

120xQualTy = noExt

187xQualTy = noExt

121#else

188#else

122xQualTy :: NoExtField

189xQualTy :: NoExtField

@@ -129,6 +196,13 @@ flagASTModified a = (Any True, a)

129appendHSC :: HsContext GhcPs -> HsContext GhcPs

196appendHSC :: HsContext GhcPs -> HsContext GhcPs

130appendHSC cs = mkHSC : cs

197appendHSC cs = mkHSC : cs

131

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+

132-- make HasCallStack => constraint

206-- make HasCallStack => constraint

133mkHSC :: LHsType GhcPs

207mkHSC :: LHsType GhcPs

134mkHSC = noLoc $ HsTyVar xQualTy NotPromoted lId

208mkHSC = noLoc $ HsTyVar xQualTy NotPromoted lId

test/resource/ghc.output+4−2

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

1example: fError

2CallStack (from HasCallStack):

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

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

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

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

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

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

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

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

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