From adc83da43a357cac5f2b31562a2bddd3084f8f1a Mon Sep 17 00:00:00 2001 From: Matthew Doty Date: Wed, 8 Jan 2020 09:31:30 -0500 Subject: [PATCH] Ergonomic improvements - Avoiding recompile (was always compiling twice) - Only importing `GHC.Stack` when we've modified the AST - Qualified import of `GHC.Stack` as `AutoImported.GHC.Stack`, to avoid any name shadowing - Cleaned up unused imports and binds - More liberal version constraints on ghc in cabal file --- haskell-stack-trace-plugin.cabal | 6 +- src/StackTrace/Plugin.hs | 137 +++++++++++++++++++------------ 2 files changed, 89 insertions(+), 54 deletions(-) diff --git a/haskell-stack-trace-plugin.cabal b/haskell-stack-trace-plugin.cabal index 53b7608..8162357 100644 --- a/haskell-stack-trace-plugin.cabal +++ b/haskell-stack-trace-plugin.cabal @@ -1,5 +1,5 @@ name: haskell-stack-trace-plugin -version: 0.1.0.0 +version: 0.1.0.1 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. homepage: https://github.com/waddlaw/haskell-stack-trace-plugin @@ -23,7 +23,7 @@ library hs-source-dirs: src build-depends: base >=4.12 && <4.13, - ghc==8.6.2 + ghc>=8.6.2 && <8.6.6 exposed-modules: StackTrace.Plugin @@ -38,4 +38,4 @@ executable example -fplugin=StackTrace.Plugin build-depends: base >=4.12 && <4.13, - haskell-stack-trace-plugin \ No newline at end of file + haskell-stack-trace-plugin diff --git a/src/StackTrace/Plugin.hs b/src/StackTrace/Plugin.hs index d7570ae..9a21cbc 100644 --- a/src/StackTrace/Plugin.hs +++ b/src/StackTrace/Plugin.hs @@ -1,74 +1,109 @@ +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} module StackTrace.Plugin (plugin) where - + +import Control.Arrow (first) +import Data.Monoid (Any(Any, getAny)) import GhcPlugins -import TcRnTypes (IfM, TcM, TcGblEnv, tcg_binds, tcg_rn_decls) -import HsExtension (GhcTc, GhcRn) -import HsDecls (HsGroup) -import HsExpr (LHsExpr) import HsSyn -import Data.Maybe +type Traversal s t a b + = forall f. Applicative f => + (a -> f b) -> s -> f t + +type Traversal' s a = Traversal s s a a plugin :: Plugin -plugin = defaultPlugin - { parsedResultAction = parsedPlugin - } +plugin = defaultPlugin {parsedResultAction = parsedPlugin, pluginRecompile = purePlugin} -parsedPlugin :: [CommandLineOption] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule +parsedPlugin :: + [CommandLineOption] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule parsedPlugin _ _ pm = do - dflags <- getDynFlags - - let extract = hsmodImports . unLoc - addGHCStackMod = noLoc $ simpleImportDecl $ mkModuleName "GHC.Stack" - - m = updateHsModule addGHCStackMod updateHsmodDecl <$> hpm_module pm - pm' = pm { hpm_module = m } - + let m = updateHsModule <$> hpm_module pm + pm' = pm {hpm_module = m} return pm' -updateHsModule :: LImportDecl GhcPs -> (LHsDecl GhcPs -> LHsDecl GhcPs) -> HsModule GhcPs -> HsModule GhcPs -updateHsModule importDecl update hsm = hsm - { hsmodImports = importDecl:decls - , hsmodDecls = map update lhss - } +-- Use qualified import for GHC.Stack as "AutoImported.GHC.Stack" +-- ...this should not interfere with other imports... +ghcStackModuleName :: ModuleName +ghcStackModuleName = mkModuleName "AutoImported.GHC.Stack" + +ghcStackImport :: Located (ImportDecl (GhcPass p)) +ghcStackImport = + noLoc $ + (simpleImportDecl $ mkModuleName "GHC.Stack") + {ideclQualified = True, ideclAs = Just $ noLoc ghcStackModuleName} + +updateHsModule :: HsModule GhcPs -> HsModule GhcPs +updateHsModule hsm = + hsm {hsmodImports = hsmodImports', hsmodDecls = hsmodDecls'} where - decls = hsmodImports hsm - lhss = hsmodDecls hsm + -- Traverse the haskell AST; if we have to add some HasStack + -- constraint we set a flag in a (Any,) functor. + -- ...it'd be simpler to check if before == after, but Haskell AST + -- doesn't have Eq instances. + (updatedP, hsmodDecls') = + first getAny $ + (traverse . astTraversal) updateHsType (hsmodDecls hsm) + + -- Only import GHC.Stack if needed for a constraint we introduced + hsmodImports' = + (if updatedP + then [ghcStackImport] + else []) ++ + hsmodImports hsm + + astTraversal :: Traversal' (LHsDecl GhcPs) (HsType GhcPs) + astTraversal = updateHsmodDecl + . updateHsDecl + . updateSig + . updateLHsSigWsType + . updateLHsSigType + . updateLHsType -------------- +updateHsmodDecl :: Traversal' (LHsDecl GhcPs) (HsDecl GhcPs) +updateHsmodDecl = traverse -updateHsmodDecl :: LHsDecl GhcPs -> LHsDecl GhcPs -updateHsmodDecl = fmap updateHsDecl +updateHsDecl :: Traversal' (HsDecl GhcPs) (Sig GhcPs) +updateHsDecl f (SigD xSig s) = SigD xSig <$> f s +updateHsDecl _ sig = pure sig -updateHsDecl :: HsDecl GhcPs -> HsDecl GhcPs -updateHsDecl (SigD xSig s) = SigD xSig (updateSig s) -updateHsDecl decl = decl +updateSig :: Traversal' (Sig GhcPs) (LHsSigWcType GhcPs) +updateSig f (TypeSig xSig ls t) = TypeSig xSig ls <$> f t +updateSig _ sig = pure sig -updateSig :: Sig GhcPs -> Sig GhcPs -updateSig (TypeSig xSig ls t) = TypeSig xSig ls (updateLHsSigWcType t) -updateSig sig = sig +updateLHsSigWsType :: Traversal' (LHsSigWcType GhcPs) (LHsSigType GhcPs) +updateLHsSigWsType f lhs@HsWC {} = + (\x -> lhs {hswc_body = x}) <$> f (hswc_body lhs) +updateLHsSigWsType _ lhs = pure lhs -updateLHsSigWcType :: LHsSigWcType GhcPs -> LHsSigWcType GhcPs -updateLHsSigWcType lhs@HsWC{} = lhs { hswc_body = updateLHsSigType (hswc_body lhs) } -updateLHsSigWcType lhs@XHsWildCardBndrs{} = lhs +updateLHsSigType :: Traversal' (LHsSigType GhcPs) (LHsType GhcPs) +updateLHsSigType f lhs@HsIB {} = + (\x -> lhs {hsib_body = x}) <$> f (hsib_body lhs) +updateLHsSigType _ lhs = pure lhs -updateLHsSigType :: LHsSigType GhcPs -> LHsSigType GhcPs -updateLHsSigType lhs@HsIB{} = lhs { hsib_body = updateLHsType (hsib_body lhs )} -updateLHsSigType lhs@XHsImplicitBndrs{} = lhs - -updateLHsType :: LHsType GhcPs -> LHsType GhcPs -updateLHsType = fmap updateHsType +updateLHsType :: Traversal' (LHsType GhcPs) (HsType GhcPs) +updateLHsType = traverse -- Main process -updateHsType :: HsType GhcPs -> HsType GhcPs -updateHsType ty@(HsQualTy xty ctxt body) = HsQualTy xty (fmap appendHSC ctxt) body -updateHsType ty@HsTyVar{} = HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty) -updateHsType ty@HsAppTy{} = HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty) -updateHsType ty@HsFunTy{} = HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty) -updateHsType ty@HsListTy{} = HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty) -updateHsType ty@HsTupleTy{} = HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty) -updateHsType ty = ty +updateHsType :: HsType GhcPs -> (Any, HsType GhcPs) +updateHsType (HsQualTy xty ctxt body) = + flagASTModified $ HsQualTy xty (fmap appendHSC ctxt) body +updateHsType ty@HsTyVar {} = + flagASTModified $ HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty) +updateHsType ty@HsAppTy {} = + flagASTModified $ HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty) +updateHsType ty@HsFunTy {} = + flagASTModified $ HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty) +updateHsType ty@HsListTy {} = + flagASTModified $ HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty) +updateHsType ty@HsTupleTy {} = + flagASTModified $ HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty) +updateHsType ty = pure ty + +flagASTModified :: a -> (Any, a) +flagASTModified a = (Any True, a) appendHSC :: HsContext GhcPs -> HsContext GhcPs appendHSC cs = mkHSC : cs @@ -78,4 +113,4 @@ mkHSC :: LHsType GhcPs mkHSC = noLoc $ HsTyVar noExt NotPromoted lId lId :: Located (IdP GhcPs) -lId = noLoc $ mkRdrUnqual $ mkClsOcc "HasCallStack" \ No newline at end of file +lId = noLoc $ mkRdrQual ghcStackModuleName $ mkClsOcc "HasCallStack"