diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,11 @@ # Revision history for haskell-stack-trace-pugin +## 0.1.1.0 -- 2020-01-18 + +- Ergonomic improvements [#1](https://github.com/waddlaw/haskell-stack-trace-plugin/pull/1) (@khwarizmii) +- Add Integration test +- Add GitHub Action + ## 0.1.0.0 -- 2018-12-07 -* First version. Released on an unsuspecting world. +- First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2018 Shinya Yamaguchi +Copyright (c) 2018-2020 Shinya Yamaguchi Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the diff --git a/Readme.md b/Readme.md --- a/Readme.md +++ b/Readme.md @@ -1,9 +1,12 @@ # haskell-stack-trace-plugin +![](https://github.com/waddlaw/haskell-stack-trace-plugin/workflows/cabal/badge.svg) +[![Hackage](https://img.shields.io/hackage/v/haskell-stack-trace-plugin.svg)](https://hackage.haskell.org/package/haskell-stack-trace-plugin) + This plugin allow implicitly add `HasCallStack` class to every top-level function for all module. Hence, we can to get completely continuous call stack. -1. (implicitly) Import [GHC.Stack](https://www.stackage.org/haddock/lts-12.21/base-4.11.1.0/GHC-Stack.html) for all modules. -2. Add [HasCallStack](https://www.stackage.org/haddock/lts-12.21/base-4.11.1.0/GHC-Stack.html#t:HasCallStack) constraint for all top-level functions. +1. (implicitly) Import [GHC.Stack](https://hackage.haskell.org/package/base-4.12.0.0/docs/GHC-Stack.html) for all modules. +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. Requirement: (8.6 <= on GHC) diff --git a/haskell-stack-trace-plugin.cabal b/haskell-stack-trace-plugin.cabal --- a/haskell-stack-trace-plugin.cabal +++ b/haskell-stack-trace-plugin.cabal @@ -1,41 +1,78 @@ -name: haskell-stack-trace-plugin -version: 0.1.0.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. -homepage: https://github.com/waddlaw/haskell-stack-trace-plugin -bug-reports: https://github.com/waddlaw/haskell-stack-trace-plugin/issues -license: MIT -license-file: LICENSE -author: Shinya Yamaguchi -maintainer: ingronze@gmail.com -copyright: 2018 Shinya Yamaguchi -category: Compiler Plugin, Development, Debug -build-type: Simple -extra-source-files: CHANGELOG.md, Readme.md -cabal-version: >=1.10 -tested-with: GHC == 8.6.2 +cabal-version: 2.4 +name: haskell-stack-trace-plugin +version: 0.1.1.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. +homepage: https://github.com/waddlaw/haskell-stack-trace-plugin +bug-reports: + https://github.com/waddlaw/haskell-stack-trace-plugin/issues + +license: MIT +license-file: LICENSE +author: Shinya Yamaguchi +maintainer: ingronze@gmail.com +copyright: 2018-2020 Shinya Yamaguchi +category: Compiler Plugin, Development, Debug +build-type: Simple +extra-source-files: + CHANGELOG.md + Readme.md + +tested-with: GHC ==8.6.5 + source-repository head type: git location: git://github.com/waddlaw/haskell-stack-trace-plugin +flag dev + description: Turn on development settings. + manual: True + default: False + +common common-opts + build-depends: base ^>=4.12 + default-language: Haskell2010 + library - hs-source-dirs: src + import: common-opts + hs-source-dirs: src + build-depends: ghc ^>=8.6 + exposed-modules: StackTrace.Plugin + + if flag(dev) + ghc-options: + -Wall -Werror -Wcompat -Wincomplete-uni-patterns + -Wnoncanonical-monad-instances -Wnoncanonical-monadfail-instances + -Wno-missing-home-modules + + -- -Wincomplete-record-updates + else + ghc-options: -O2 -Wall + +test-suite test + import: common-opts + main-is: Spec.hs + hs-source-dirs: test + type: exitcode-stdio-1.0 build-depends: - base >=4.12 && <4.13, - ghc==8.6.2 + , bytestring ^>=0.10 + , hspec ^>=2.7 + , typed-process ^>=0.2.6 - exposed-modules: - StackTrace.Plugin + build-tool-depends: hspec-discover:hspec-discover ^>=2.7 + other-modules: StackTrace.PluginSpec - default-language: Haskell2010 + if flag(dev) + ghc-options: -Wall -Werror + else + ghc-options: -O2 -Wall + executable example - main-is: Main.hs + import: common-opts + main-is: Main.hs hs-source-dirs: example - default-language: Haskell2010 - ghc-options: - -fplugin=StackTrace.Plugin - build-depends: - base >=4.12 && <4.13, - haskell-stack-trace-plugin + ghc-options: -fplugin=StackTrace.Plugin + build-depends: haskell-stack-trace-plugin diff --git a/src/StackTrace/Plugin.hs b/src/StackTrace/Plugin.hs --- a/src/StackTrace/Plugin.hs +++ b/src/StackTrace/Plugin.hs @@ -1,75 +1,110 @@ +{-# 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" + let m = updateHsModule <$> hpm_module pm + pm' = pm {hpm_module = m} + return pm' - m = updateHsModule addGHCStackMod updateHsmodDecl <$> hpm_module pm - pm' = pm { hpm_module = m } +-- Use qualified import for GHC.Stack as "AutoImported.GHC.Stack" +-- ...this should not interfere with other imports... +ghcStackModuleName :: ModuleName +ghcStackModuleName = mkModuleName "AutoImported.GHC.Stack" - return pm' +ghcStackImport :: Located (ImportDecl (GhcPass p)) +ghcStackImport = + noLoc $ + (simpleImportDecl $ mkModuleName "GHC.Stack") + {ideclQualified = True, ideclAs = Just $ noLoc ghcStackModuleName} -updateHsModule :: LImportDecl GhcPs -> (LHsDecl GhcPs -> LHsDecl GhcPs) -> HsModule GhcPs -> HsModule GhcPs -updateHsModule importDecl update hsm = hsm - { hsmodImports = importDecl:decls - , hsmodDecls = map update lhss - } +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 -updateHsmodDecl :: LHsDecl GhcPs -> LHsDecl GhcPs -updateHsmodDecl = fmap updateHsDecl + astTraversal :: Traversal' (LHsDecl GhcPs) (HsType GhcPs) + astTraversal = updateHsmodDecl + . updateHsDecl + . updateSig + . updateLHsSigWsType + . updateLHsSigType + . updateLHsType -updateHsDecl :: HsDecl GhcPs -> HsDecl GhcPs -updateHsDecl (SigD xSig s) = SigD xSig (updateSig s) -updateHsDecl decl = decl +-------------- +updateHsmodDecl :: Traversal' (LHsDecl GhcPs) (HsDecl GhcPs) +updateHsmodDecl = traverse -updateSig :: Sig GhcPs -> Sig GhcPs -updateSig (TypeSig xSig ls t) = TypeSig xSig ls (updateLHsSigWcType t) -updateSig sig = sig +updateHsDecl :: Traversal' (HsDecl GhcPs) (Sig GhcPs) +updateHsDecl f (SigD xSig s) = SigD xSig <$> f s +updateHsDecl _ sig = pure sig -updateLHsSigWcType :: LHsSigWcType GhcPs -> LHsSigWcType GhcPs -updateLHsSigWcType lhs@HsWC{} = lhs { hswc_body = updateLHsSigType (hswc_body lhs) } -updateLHsSigWcType lhs@XHsWildCardBndrs{} = lhs +updateSig :: Traversal' (Sig GhcPs) (LHsSigWcType GhcPs) +updateSig f (TypeSig xSig ls t) = TypeSig xSig ls <$> f t +updateSig _ sig = pure sig -updateLHsSigType :: LHsSigType GhcPs -> LHsSigType GhcPs -updateLHsSigType lhs@HsIB{} = lhs { hsib_body = updateLHsType (hsib_body lhs )} -updateLHsSigType lhs@XHsImplicitBndrs{} = lhs +updateLHsSigWsType :: Traversal' (LHsSigWcType GhcPs) (LHsSigType GhcPs) +updateLHsSigWsType f lhs@HsWC {} = + (\x -> lhs {hswc_body = x}) <$> f (hswc_body lhs) +updateLHsSigWsType _ lhs = pure lhs -updateLHsType :: LHsType GhcPs -> LHsType GhcPs -updateLHsType = fmap updateHsType +updateLHsSigType :: Traversal' (LHsSigType GhcPs) (LHsType GhcPs) +updateLHsSigType f lhs@HsIB {} = + (\x -> lhs {hsib_body = x}) <$> f (hsib_body lhs) +updateLHsSigType _ lhs = pure lhs +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 = noLoc $ HsTyVar noExt NotPromoted lId lId :: Located (IdP GhcPs) -lId = noLoc $ mkRdrUnqual $ mkClsOcc "HasCallStack" +lId = noLoc $ mkRdrQual ghcStackModuleName $ mkClsOcc "HasCallStack" diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/StackTrace/PluginSpec.hs b/test/StackTrace/PluginSpec.hs new file mode 100644 --- /dev/null +++ b/test/StackTrace/PluginSpec.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE OverloadedStrings #-} +module StackTrace.PluginSpec (spec) where + +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as BL +import Test.Hspec +import System.Process.Typed + +spec :: Spec +spec = do + output <- runIO exe + expected <- runIO $ BL.readFile "test/resource/ghc86.output" + it "integration test" $ output `shouldBe` expected + + +exe :: IO ByteString +exe = do + runProcess_ $ shell "cabal install exe:example --installdir=./dist" + err <- readProcessStderr_ $ shell "./dist/example || true" + runProcess_ $ shell "rm -rf ./dist" + return err