master..0e20658 · typeable/haskell-stack-trace-plugin

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

on 0e20658 help sign in

CHANGELOG.md−5

since splitsnapshots

unifiedsplit

@@ -2,11 +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

5## 0.1.2.0 -- 2021-05-21

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

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

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

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

1cabal-version: 2.4

2name: haskell-stack-trace-plugin

3−version: 0.1.3.0

3+version: 0.1.2.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.18

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

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

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

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

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

src/StackTrace/Plugin.hs+7−67

@@ -5,7 +5,6 @@ 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

8#if __GLASGOW_HASKELL__ >= 900

10import GHC.Plugins

9import GHC.Plugins

11#else

10#else

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

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

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

52ghcStackImport =

51ghcStackImport =

53− L srcSpan $

52+ noLoc $

54 (simpleImportDecl $ mkModuleName "GHC.Stack")

53 (simpleImportDecl $ mkModuleName "GHC.Stack")

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

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

56#if __GLASGOW_HASKELL__ >= 900

63updateHsModule :: HsModule -> HsModule

57updateHsModule :: HsModule -> HsModule

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

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

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

86 astTraversal = updateHsmodDecl

80 astTraversal = updateHsmodDecl

87 . updateHsDecl

81 . updateHsDecl

82+ . updateSig

88 . updateLHsSigWsType

83 . updateLHsSigWsType

89 . updateLHsSigType

84 . updateLHsSigType

90 . updateLHsType

85 . updateLHsType

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

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

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

94updateHsmodDecl = traverse

89updateHsmodDecl = traverse

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

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

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

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

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

99updateHsDecl _ sig = pure sig

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

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

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

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

148updateSig _ sig = pure sig

97updateSig _ sig = pure sig

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

166

115

167-- Main process

116-- Main process

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

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

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

118+updateHsType (HsQualTy xty ctxt body) =

170− if hasHasCallStack (unLoc ctxt)

171− then pure ty

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

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

173updateHsType ty@HsTyVar {} =

120updateHsType ty@HsTyVar {} =

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

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

175updateHsType ty@HsAppTy {} =

122updateHsType ty@HsAppTy {} =

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

196appendHSC :: HsContext GhcPs -> HsContext GhcPs

143appendHSC :: HsContext GhcPs -> HsContext GhcPs

197appendHSC cs = mkHSC : cs

144appendHSC cs = mkHSC : cs

198

145

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

146-- make HasCallStack => constraint

207mkHSC :: LHsType GhcPs

147mkHSC :: LHsType GhcPs

208mkHSC = noLoc $ HsTyVar xQualTy NotPromoted lId

148mkHSC = noLoc $ HsTyVar xQualTy NotPromoted lId

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