git.iko.soy/typeable/haskell-stack-trace-plugin
on master help sign in
support `where` clause
commitf5e9de97cd18dd547c64304a21fc66c197612de4 authorwaddlaw <ingronze@gmail.com> dateTue 25 May 2021, 11:24 (5 years ago) parent4266957
6 files changed+78−13
compare with master
unifiedsplit
CHANGELOG.md+4 Readme.md+13−5 example/Main.hs+7−1 haskell-stack-trace-plugin.cabal+1−1 src/StackTrace/Plugin.hs+49−4 test/resource/ghc.output+4−2
CHANGELOG.md+4
@@ -2,6 +2,10 @@
22
33## Unreleased changes
44
5+## 0.1.3.0
6+
7+- Added support `where` clause [#11](https://github.com/waddlaw/haskell-stack-trace-plugin/pull/11) (@waddlaw)
8+
59## 0.1.2.0 -- 2021-05-21
610
711- Added support for GHC 8.10 [#7](https://github.com/waddlaw/haskell-stack-trace-plugin/pull/7) (@etorreborre)
Readme.md+13−5
@@ -48,7 +48,13 @@ f7 = (fromJust f8, fromJust f8)
4848
4949-- HsAppTy
5050f8 :: Maybe Int
51−f8 = Just fError
51+f8 = Just f9
52+
53+f9 :: Int
54+f9 = f10
55+ where
56+ f10 :: Int
57+ f10 = fError
5258
5359-- HsTyVar
5460fError :: Int
@@ -58,7 +64,7 @@ fError = error "fError"
5864This example get error:
5965
6066```shell
61−$ cabal new-build
67+$ cabal build
6268example/Main.hs:15:7: error:
6369 Not in scope: type constructor or class ‘HasCallStack’
6470 |
@@ -74,7 +80,7 @@ Fix and rebuild!
7480$ cabal run example -v0
7581example: fError
7682CallStack (from HasCallStack):
77− error, called at example/Main.hs:41:10 in main:Main
83+ error, called at example/Main.hs:47:10 in main:Main
7884```
7985
8086Hmm, it is not useful. But, you will to be happy when enable this plugin.
@@ -88,8 +94,10 @@ Hmm, it is not useful. But, you will to be happy when enable this plugin.
8894$ cabal run example -v0
8995example: fError
9096CallStack (from HasCallStack):
91− error, called at example/Main.hs:41:10 in main:Main
92− fError, called at example/Main.hs:37:11 in main:Main
97+ error, called at example/Main.hs:47:10 in main:Main
98+ fError, called at example/Main.hs:43:11 in main:Main
99+ f10, called at example/Main.hs:40:6 in main:Main
100+ f9, called at example/Main.hs:37:11 in main:Main
93101 f8, called at example/Main.hs:33:16 in main:Main
94102 f7, called at example/Main.hs:29:11 in main:Main
95103 f6, called at example/Main.hs:25:15 in main:Main
example/Main.hs+7−1
@@ -34,7 +34,13 @@ f7 = (fromJust f8, fromJust f8)
3434
3535-- HsAppTy
3636f8 :: 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
3844
3945-- HsTyVar
4046fError :: Int
haskell-stack-trace-plugin.cabal+1−1
@@ -1,6 +1,6 @@
11cabal-version: 2.4
22name: haskell-stack-trace-plugin
3−version: 0.1.2.0
3+version: 0.1.3.0
44synopsis: haskell-stack-trace-plugin
55description:
66 This plugin allow implicitly add HasCallStack class to every top-level function for all module. Hence, we can to get completely continuous call stack.
src/StackTrace/Plugin.hs+49−4
@@ -79,7 +79,6 @@ updateHsModule hsm =
7979 astTraversal :: Traversal' (LHsDecl GhcPs) (HsType GhcPs)
8080 astTraversal = updateHsmodDecl
8181 . updateHsDecl
82− . updateSig
8382 . updateLHsSigWsType
8483 . updateLHsSigType
8584 . updateLHsType
@@ -88,10 +87,56 @@ updateHsModule hsm =
8887updateHsmodDecl :: Traversal' (LHsDecl GhcPs) (HsDecl GhcPs)
8988updateHsmodDecl = traverse
9089
91−updateHsDecl :: Traversal' (HsDecl GhcPs) (Sig GhcPs)
92−updateHsDecl f (SigD xSig s) = SigD xSig <$> f s
90+updateHsDecl :: Traversal' (HsDecl GhcPs) (LHsSigWcType GhcPs)
91+updateHsDecl f (SigD xSig s) = SigD xSig <$> updateSig f s
92+updateHsDecl f (ValD xVal hsBind) = ValD xVal <$> updateHsBind f hsBind
9393updateHsDecl _ sig = pure sig
9494
95+updateHsBind :: Traversal' (HsBind GhcPs) (LHsSigWcType GhcPs)
96+updateHsBind f bind@FunBind {} = (\x -> bind {fun_matches = x}) <$> updateMatchGroup f (fun_matches bind)
97+updateHsBind _ bind = pure bind
98+
99+updateMatchGroup :: Traversal' (MatchGroup GhcPs (LHsExpr GhcPs)) (LHsSigWcType GhcPs)
100+updateMatchGroup f mg@MG {} = (\x -> mg {mg_alts = x}) <$> updateLLMatch f (mg_alts mg)
101+#if __GLASGOW_HASKELL__ < 900
102+updateMatchGroup _ mg = pure mg
103+#endif
104+
105+updateLocated :: Functor f => (a -> b -> f c) -> a -> Located b -> f (Located c)
106+updateLocated f g (L l e) = L l <$> f g e
107+
108+updateLLMatch :: Traversal' (Located [LMatch GhcPs (LHsExpr GhcPs)]) (LHsSigWcType GhcPs)
109+updateLLMatch = updateLocated updateLMatches
110+
111+updateLMatches :: Traversal' [LMatch GhcPs (LHsExpr GhcPs)] (LHsSigWcType GhcPs)
112+updateLMatches f = traverse (updateLocated updateMatch f)
113+
114+updateMatch :: Traversal' (Match GhcPs (LHsExpr GhcPs)) (LHsSigWcType GhcPs)
115+updateMatch f m@Match {} = (\x -> m {m_grhss = x}) <$> updateGrhss f (m_grhss m)
116+#if __GLASGOW_HASKELL__ < 900
117+updateMatch _ m = pure m
118+#endif
119+
120+updateGrhss :: Traversal' (GRHSs GhcPs (LHsExpr GhcPs)) (LHsSigWcType GhcPs)
121+updateGrhss f grhss@GRHSs {} = (\x -> grhss {grhssLocalBinds = x}) <$> updateLHsLocalBinds f (grhssLocalBinds grhss)
122+#if __GLASGOW_HASKELL__ < 900
123+updateGrhss _ grhss = pure grhss
124+#endif
125+
126+updateLHsLocalBinds :: Traversal' (LHsLocalBinds GhcPs) (LHsSigWcType GhcPs)
127+updateLHsLocalBinds = updateLocated updateLocalBinds
128+
129+updateLocalBinds :: Traversal' (HsLocalBinds GhcPs) (LHsSigWcType GhcPs)
130+updateLocalBinds f (HsValBinds xHsValBinds hsValBindsLR) = HsValBinds xHsValBinds <$> updateHsValBindsLR f hsValBindsLR
131+updateLocalBinds _ hsValBinds = pure hsValBinds
132+
133+updateHsValBindsLR :: Traversal' (HsValBindsLR GhcPs GhcPs) (LHsSigWcType GhcPs)
134+updateHsValBindsLR f (ValBinds xValBinds lHsBindsLR lSigs) = ValBinds xValBinds lHsBindsLR <$> updateLSigs f lSigs
135+updateHsValBindsLR _ valBinds = pure valBinds
136+
137+updateLSigs :: Traversal' [LSig GhcPs] (LHsSigWcType GhcPs)
138+updateLSigs f = traverse (updateLocated updateSig f)
139+
95140updateSig :: Traversal' (Sig GhcPs) (LHsSigWcType GhcPs)
96141updateSig f (TypeSig xSig ls t) = TypeSig xSig ls <$> f t
97142updateSig _ sig = pure sig
@@ -123,7 +168,7 @@ updateHsType ty@HsAppTy {} =
123168 flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
124169updateHsType ty@HsFunTy {} =
125170 flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
126−updateHsType ty@HsListTy {} =
171+updateHsType ty@HsListTy {} =
127172 flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
128173updateHsType ty@HsTupleTy {} =
129174 flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
test/resource/ghc.output+4−2
@@ -1,7 +1,9 @@
11example: fError
22CallStack (from HasCallStack):
3− error, called at example/Main.hs:41:10 in main:Main
4− fError, called at example/Main.hs:37:11 in main:Main
3+ error, called at example/Main.hs:47:10 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
57 f8, called at example/Main.hs:33:16 in main:Main
68 f7, called at example/Main.hs:29:11 in main:Main
79 f6, called at example/Main.hs:25:15 in main:Main