6d47954...master · typeable/haskell-stack-trace-plugin

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

on master help sign in

CHANGELOG.md+5

since splitsnapshots

unifiedsplit

@@ -2,6 +2,11 @@

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)

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+4−4

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

@@ -32,13 +32,13 @@ flag dev

32 default: False

34common common-opts

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

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 || ^>=9.0

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)

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

72 import: common-opts

73 main-is: Main.hs

74 hs-source-dirs: example

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

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

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

src/StackTrace/Plugin.hs+67−7

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

6import Control.Arrow (first)

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

8+import GHC.Types.SrcLoc

8#if __GLASGOW_HASKELL__ >= 900

9#if __GLASGOW_HASKELL__ >= 900

9import GHC.Plugins

10import GHC.Plugins

10#else

11#else

@@ -49,9 +50,14 @@ importDeclQualified = QualifiedPre

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

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

51ghcStackImport =

52ghcStackImport =

52− noLoc $

53+ L srcSpan $

53 (simpleImportDecl $ mkModuleName "GHC.Stack")

54 (simpleImportDecl $ mkModuleName "GHC.Stack")

54− {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

56#if __GLASGOW_HASKELL__ >= 900

62#if __GLASGOW_HASKELL__ >= 900

57updateHsModule :: HsModule -> HsModule

63updateHsModule :: HsModule -> HsModule

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

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

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

80 astTraversal = updateHsmodDecl

86 astTraversal = updateHsmodDecl

81 . updateHsDecl

87 . updateHsDecl

82− . updateSig

83 . updateLHsSigWsType

88 . updateLHsSigWsType

84 . updateLHsSigType

89 . updateLHsSigType

85 . updateLHsType

90 . updateLHsType

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

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

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

89updateHsmodDecl = traverse

94updateHsmodDecl = traverse

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

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

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

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

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

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

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

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

97updateSig _ sig = pure sig

148updateSig _ sig = pure sig

@@ -115,8 +166,10 @@ updateLHsType = traverse

115

166

116-- Main process

167-- Main process

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

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

118−updateHsType (HsQualTy xty ctxt body) =

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

170+ if hasHasCallStack (unLoc ctxt)

171+ then pure ty

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

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

120updateHsType ty@HsTyVar {} =

173updateHsType ty@HsTyVar {} =

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

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

122updateHsType ty@HsAppTy {} =

175updateHsType ty@HsAppTy {} =

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

143appendHSC :: HsContext GhcPs -> HsContext GhcPs

196appendHSC :: HsContext GhcPs -> HsContext GhcPs

144appendHSC cs = mkHSC : cs

197appendHSC cs = mkHSC : cs

145

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+

146-- make HasCallStack => constraint

206-- make HasCallStack => constraint

147mkHSC :: LHsType GhcPs

207mkHSC :: LHsType GhcPs

148mkHSC = 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