packages feed

haskell-stack-trace-plugin 0.1.0.0 → 0.1.1.0

raw patch · 7 files changed

+186/−83 lines, 7 filesdep +bytestringdep +hspecdep +typed-processdep ~basedep ~ghc

Dependencies added: bytestring, hspec, typed-process

Dependency ranges changed: base, ghc

Files

CHANGELOG.md view
@@ -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.
LICENSE view
@@ -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
Readme.md view
@@ -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)
haskell-stack-trace-plugin.cabal view
@@ -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
src/StackTrace/Plugin.hs view
@@ -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"
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ test/StackTrace/PluginSpec.hs view
@@ -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