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

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

on 093a052 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", "9.0"]

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

17 cabal: ["3.2"]

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

CHANGELOG.md−6

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

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)

13−- Added support for GHC 9.0 @waddlaw

15## 0.1.1.1 -- 2020-01-18

9## 0.1.1.1 -- 2020-01-18

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

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

@@ -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 || ==9.0.1

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

25source-repository head

26 type: git

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

32 default: False

34common common-opts

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

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

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

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−

49 else

48 else

50 ghc-options: -Wall

49 ghc-options: -Wall

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

72 import: common-opts

71 import: common-opts

73 main-is: Main.hs

72 main-is: Main.hs

74 hs-source-dirs: example

73 hs-source-dirs: example

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

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

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

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

src/StackTrace/Plugin.hs+7−81

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

13import GhcPlugins

8import GhcPlugins

14−#endif

15#if __GLASGOW_HASKELL__ >= 810

9#if __GLASGOW_HASKELL__ >= 810

16import GHC.Hs

10import GHC.Hs

17#endif

11#endif

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

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

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

52ghcStackImport =

46ghcStackImport =

53− L srcSpan $

47+ noLoc $

54 (simpleImportDecl $ mkModuleName "GHC.Stack")

48 (simpleImportDecl $ mkModuleName "GHC.Stack")

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

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

65updateHsModule :: HsModule GhcPs -> HsModule GhcPs

51updateHsModule :: HsModule GhcPs -> HsModule GhcPs

66−#endif

67updateHsModule hsm =

52updateHsModule hsm =

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

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

69 where

54 where

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

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

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

86 astTraversal = updateHsmodDecl

71 astTraversal = updateHsmodDecl

87 . updateHsDecl

72 . updateHsDecl

73+ . updateSig

88 . updateLHsSigWsType

74 . updateLHsSigWsType

89 . updateLHsSigType

75 . updateLHsSigType

90 . updateLHsType

76 . updateLHsType

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

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

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

94updateHsmodDecl = traverse

80updateHsmodDecl = traverse

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

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

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

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

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

99updateHsDecl _ sig = pure sig

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

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

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

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

148updateSig _ sig = pure sig

88updateSig _ sig = pure sig

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

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

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

151updateLHsSigWsType f lhs@HsWC {} =

91updateLHsSigWsType f lhs@HsWC {} =

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

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

153−#if __GLASGOW_HASKELL__ < 900

154updateLHsSigWsType _ lhs = pure lhs

93updateLHsSigWsType _ lhs = pure lhs

155−#endif

156

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

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

158updateLHsSigType f lhs@HsIB {} =

96updateLHsSigType f lhs@HsIB {} =

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

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

160−#if __GLASGOW_HASKELL__ < 900

161updateLHsSigType _ lhs = pure lhs

98updateLHsSigType _ lhs = pure lhs

162−#endif

163

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

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

165updateLHsType = traverse

101updateLHsType = traverse

166

102

167-- Main process

103-- Main process

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

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

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

105+updateHsType (HsQualTy xty ctxt body) =

170− if hasHasCallStack (unLoc ctxt)

171− then pure ty

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

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

173updateHsType ty@HsTyVar {} =

107updateHsType ty@HsTyVar {} =

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

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

175updateHsType ty@HsAppTy {} =

109updateHsType ty@HsAppTy {} =

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

183updateHsType ty = pure ty

117updateHsType ty = pure ty

184

118

185#if __GLASGOW_HASKELL__ < 810

119#if __GLASGOW_HASKELL__ < 810

186−xQualTy :: NoExt

187xQualTy = noExt

120xQualTy = noExt

188#else

121#else

189xQualTy :: NoExtField

122xQualTy :: NoExtField

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

196appendHSC :: HsContext GhcPs -> HsContext GhcPs

129appendHSC :: HsContext GhcPs -> HsContext GhcPs

197appendHSC cs = mkHSC : cs

130appendHSC cs = mkHSC : cs

198

131

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

132-- make HasCallStack => constraint

207mkHSC :: LHsType GhcPs

133mkHSC :: LHsType GhcPs

208mkHSC = noLoc $ HsTyVar xQualTy NotPromoted lId

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