haskell-stack-trace-plugin 0.1.2.0 → 0.1.3.0
raw patch · 5 files changed
+102/−31 lines, 5 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGELOG.md +5/−0
- Readme.md +26/−20
- example/Main.hs +9/−3
- haskell-stack-trace-plugin.cabal +2/−2
- src/StackTrace/Plugin.hs +60/−6
CHANGELOG.md view
@@ -2,6 +2,11 @@ ## Unreleased changes +## 0.1.3.0++- Added support `where` clause [#11](https://github.com/waddlaw/haskell-stack-trace-plugin/pull/11) (@waddlaw)+- Avoid redundant-constraints warnings [#12](https://github.com/waddlaw/haskell-stack-trace-plugin/pull/12) (@waddlaw)+ ## 0.1.2.0 -- 2021-05-21 - Added support for GHC 8.10 [#7](https://github.com/waddlaw/haskell-stack-trace-plugin/pull/7) (@etorreborre)
Readme.md view
@@ -32,10 +32,10 @@ -- HsQualTy f4 :: Show a => a -> Int-f4 _ = f5 0 0+f4 n = f5 (show n) 0 -- HsFunTy-f5 :: Int -> Int -> Int+f5 :: String -> Int -> Int f5 _ _ = head f6 -- HsListTy@@ -48,8 +48,14 @@ -- HsAppTy f8 :: Maybe Int-f8 = Just fError+f8 = Just f9 +f9 :: Int+f9 = f10+ where+ f10 :: Int+ f10 = fError+ -- HsTyVar fError :: Int fError = error "fError"@@ -58,7 +64,7 @@ This example get error: ```shell-$ cabal new-build+$ cabal build example/Main.hs:15:7: error: Not in scope: type constructor or class ‘HasCallStack’ |@@ -71,10 +77,10 @@ Fix and rebuild! ```shell-$ cabal new-run+$ cabal run example -v0 example: fError CallStack (from HasCallStack):- error, called at example/Main.hs:41:10 in main:Main+ error, called at example/Main.hs:47:10 in main:Main ``` Hmm, it is not useful. But, you will to be happy when enable this plugin.@@ -85,22 +91,22 @@ ``` ```shell-$ cabal new-run-...-+$ cabal run example -v0 example: fError CallStack (from HasCallStack):- error, called at example/Main.hs:40:10 in main:Main- fError, called at example/Main.hs:36:11 in main:Main- f8, called at example/Main.hs:32:16 in main:Main- f7, called at example/Main.hs:28:11 in main:Main- f6, called at example/Main.hs:24:15 in main:Main- f5, called at example/Main.hs:20:8 in main:Main- f4, called at example/Main.hs:16:6 in main:Main- f3, called at example/Main.hs:12:6 in main:Main- f2, called at example/Main.hs:9:6 in main:Main- f1, called at example/Main.hs:6:14 in main:Main- main, called at example/Main.hs:6:1 in main:Main+ error, called at example/Main.hs:47:10 in main:Main+ fError, called at example/Main.hs:43:11 in main:Main+ f10, called at example/Main.hs:40:6 in main:Main+ f9, called at example/Main.hs:37:11 in main:Main+ f8, called at example/Main.hs:33:16 in main:Main+ f7, called at example/Main.hs:29:11 in main:Main+ f6, called at example/Main.hs:25:15 in main:Main+ f5, called at example/Main.hs:21:8 in main:Main+ f4, called at example/Main.hs:17:6 in main:Main+ f3, called at example/Main.hs:13:6 in main:Main+ f2, called at example/Main.hs:10:6 in main:Main+ f1, called at example/Main.hs:7:14 in main:Main+ main, called at example/Main.hs:7:1 in main:Main ``` Great!!!
example/Main.hs view
@@ -18,10 +18,10 @@ -- HsQualTy f4 :: Show a => a -> Int-f4 _ = f5 0 0+f4 n = f5 (show n) 0 -- HsFunTy-f5 :: Int -> Int -> Int+f5 :: String -> Int -> Int f5 _ _ = head f6 -- HsListTy@@ -34,7 +34,13 @@ -- HsAppTy f8 :: Maybe Int-f8 = Just fError+f8 = Just f9++f9 :: Int+f9 = f10+ where+ f10 :: Int+ f10 = fError -- HsTyVar fError :: Int
haskell-stack-trace-plugin.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: haskell-stack-trace-plugin-version: 0.1.2.0+version: 0.1.3.0 synopsis: haskell-stack-trace-plugin description: This plugin allow implicitly add HasCallStack class to every top-level function for all module. Hence, we can to get completely continuous call stack.@@ -72,5 +72,5 @@ import: common-opts main-is: Main.hs hs-source-dirs: example- ghc-options: -fplugin=StackTrace.Plugin+ ghc-options: -fplugin=StackTrace.Plugin -Wredundant-constraints build-depends: haskell-stack-trace-plugin
src/StackTrace/Plugin.hs view
@@ -79,7 +79,6 @@ astTraversal :: Traversal' (LHsDecl GhcPs) (HsType GhcPs) astTraversal = updateHsmodDecl . updateHsDecl- . updateSig . updateLHsSigWsType . updateLHsSigType . updateLHsType@@ -88,10 +87,56 @@ updateHsmodDecl :: Traversal' (LHsDecl GhcPs) (HsDecl GhcPs) updateHsmodDecl = traverse -updateHsDecl :: Traversal' (HsDecl GhcPs) (Sig GhcPs)-updateHsDecl f (SigD xSig s) = SigD xSig <$> f s+updateHsDecl :: Traversal' (HsDecl GhcPs) (LHsSigWcType GhcPs)+updateHsDecl f (SigD xSig s) = SigD xSig <$> updateSig f s+updateHsDecl f (ValD xVal hsBind) = ValD xVal <$> updateHsBind f hsBind updateHsDecl _ sig = pure sig +updateHsBind :: Traversal' (HsBind GhcPs) (LHsSigWcType GhcPs)+updateHsBind f bind@FunBind {} = (\x -> bind {fun_matches = x}) <$> updateMatchGroup f (fun_matches bind)+updateHsBind _ bind = pure bind++updateMatchGroup :: Traversal' (MatchGroup GhcPs (LHsExpr GhcPs)) (LHsSigWcType GhcPs)+updateMatchGroup f mg@MG {} = (\x -> mg {mg_alts = x}) <$> updateLLMatch f (mg_alts mg)+#if __GLASGOW_HASKELL__ < 900+updateMatchGroup _ mg = pure mg+#endif++updateLocated :: Functor f => (a -> b -> f c) -> a -> Located b -> f (Located c)+updateLocated f g (L l e) = L l <$> f g e++updateLLMatch :: Traversal' (Located [LMatch GhcPs (LHsExpr GhcPs)]) (LHsSigWcType GhcPs)+updateLLMatch = updateLocated updateLMatches++updateLMatches :: Traversal' [LMatch GhcPs (LHsExpr GhcPs)] (LHsSigWcType GhcPs)+updateLMatches f = traverse (updateLocated updateMatch f)++updateMatch :: Traversal' (Match GhcPs (LHsExpr GhcPs)) (LHsSigWcType GhcPs)+updateMatch f m@Match {} = (\x -> m {m_grhss = x}) <$> updateGrhss f (m_grhss m)+#if __GLASGOW_HASKELL__ < 900+updateMatch _ m = pure m+#endif++updateGrhss :: Traversal' (GRHSs GhcPs (LHsExpr GhcPs)) (LHsSigWcType GhcPs)+updateGrhss f grhss@GRHSs {} = (\x -> grhss {grhssLocalBinds = x}) <$> updateLHsLocalBinds f (grhssLocalBinds grhss)+#if __GLASGOW_HASKELL__ < 900+updateGrhss _ grhss = pure grhss+#endif++updateLHsLocalBinds :: Traversal' (LHsLocalBinds GhcPs) (LHsSigWcType GhcPs)+updateLHsLocalBinds = updateLocated updateLocalBinds++updateLocalBinds :: Traversal' (HsLocalBinds GhcPs) (LHsSigWcType GhcPs)+updateLocalBinds f (HsValBinds xHsValBinds hsValBindsLR) = HsValBinds xHsValBinds <$> updateHsValBindsLR f hsValBindsLR+updateLocalBinds _ hsValBinds = pure hsValBinds++updateHsValBindsLR :: Traversal' (HsValBindsLR GhcPs GhcPs) (LHsSigWcType GhcPs)+updateHsValBindsLR f (ValBinds xValBinds lHsBindsLR lSigs) = ValBinds xValBinds lHsBindsLR <$> updateLSigs f lSigs+updateHsValBindsLR _ valBinds = pure valBinds++updateLSigs :: Traversal' [LSig GhcPs] (LHsSigWcType GhcPs)+updateLSigs f = traverse (updateLocated updateSig f)+ updateSig :: Traversal' (Sig GhcPs) (LHsSigWcType GhcPs) updateSig f (TypeSig xSig ls t) = TypeSig xSig ls <$> f t updateSig _ sig = pure sig@@ -115,15 +160,17 @@ -- Main process updateHsType :: HsType GhcPs -> (Any, HsType GhcPs)-updateHsType (HsQualTy xty ctxt body) =- flagASTModified $ HsQualTy xty (fmap appendHSC ctxt) body+updateHsType ty@(HsQualTy xty ctxt body) =+ if hasHasCallStack (unLoc ctxt)+ then pure ty+ else flagASTModified $ HsQualTy xty (fmap appendHSC ctxt) body updateHsType ty@HsTyVar {} = flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty) updateHsType ty@HsAppTy {} = flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty) updateHsType ty@HsFunTy {} = flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)-updateHsType ty@HsListTy {} =+updateHsType ty@HsListTy {} = flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty) updateHsType ty@HsTupleTy {} = flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)@@ -142,6 +189,13 @@ appendHSC :: HsContext GhcPs -> HsContext GhcPs appendHSC cs = mkHSC : cs++hasHasCallStack :: HsContext GhcPs -> Bool+hasHasCallStack = any (checkHsType . unLoc)+ where+ checkHsType :: HsType GhcPs -> Bool+ checkHsType (HsTyVar _ _ lid) = unLoc lid == (mkRdrUnqual $ mkClsOcc "HasCallStack")+ checkHsType _ = False -- make HasCallStack => constraint mkHSC :: LHsType GhcPs