From cb4b0d8d24d8c5e0129f8c56315fead2d49a5d49 Mon Sep 17 00:00:00 2001 From: waddlaw Date: Fri, 7 Dec 2018 15:07:07 +0900 Subject: [PATCH] first commit --- .gitignore | 6 ++ CHANGELOG.md | 5 ++ LICENSE | 20 ++++++ Readme.md | 103 +++++++++++++++++++++++++++++++ example/Main.hs | 41 ++++++++++++ haskell-stack-trace-plugin.cabal | 35 +++++++++++ src/StackTrace/Plugin.hs | 81 ++++++++++++++++++++++++ 7 files changed, 291 insertions(+) create mode 100644 .gitignore create mode 100644 CHANGELOG.md create mode 100644 LICENSE create mode 100644 Readme.md create mode 100644 example/Main.hs create mode 100644 haskell-stack-trace-plugin.cabal create mode 100644 src/StackTrace/Plugin.hs diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..1d01a61 --- /dev/null +++ b/.gitignore @@ -0,0 +1,6 @@ +dist/ +dist-*/ +.ghc.environment.* +cabal.project.local + +*~ \ No newline at end of file diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..784434d --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for haskell-stack-trace-pugin + +## 0.1.0.0 -- 2018-12-07 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..f8a6d8c --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2018 Shinya Yamaguchi + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. \ No newline at end of file diff --git a/Readme.md b/Readme.md new file mode 100644 index 0000000..9516a39 --- /dev/null +++ b/Readme.md @@ -0,0 +1,103 @@ +# 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. + +Requirement: (8.6 <= on GHC) + +## Synopsis + +```haskell +module Main where + +import Data.Maybe (fromJust) + +main :: IO () +main = print f1 + +f1 :: Int +f1 = f2 + +f2 :: Int +f2 = f3 + +-- HsQualTy +f3 :: HasCallStack => Int +f3 = f4 0 + +-- HsQualTy +f4 :: Show a => a -> Int +f4 _ = f5 0 0 + +-- HsFunTy +f5 :: Int -> Int -> Int +f5 _ _ = head f6 + +-- HsListTy +f6 :: [Int] +f6 = [fst f7] + +-- HsTupleTy +f7 :: (Int, Int) +f7 = (fromJust f8, fromJust f8) + +-- HsAppTy +f8 :: Maybe Int +f8 = Just fError + +-- HsTyVar +fError :: Int +fError = error "fError" +``` + +This example get error: + +```shell +$ cabal new-build +example/Main.hs:15:7: error: + Not in scope: type constructor or class ‘HasCallStack’ + | +15 | f3 :: HasCallStack => Int + | ^^^^^^^^^^^^ +``` + +Yes, add `import GHC.Stack` to above example. + +Fix and rebuild! + +```shell +$ cabal new-build +example: fError +CallStack (from HasCallStack): + error, called at example/Main.hs:41:10 in main:Main +``` + +Hmm, it is not useful. But, you will to be happy when enable this plugin. + +```cabal + ghc-options: + -fplugin=StackTrace.Plugin +``` + +```shell +$ cabal new-run +... + +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 +``` + +Great!!! \ No newline at end of file diff --git a/example/Main.hs b/example/Main.hs new file mode 100644 index 0000000..80e2e9d --- /dev/null +++ b/example/Main.hs @@ -0,0 +1,41 @@ +module Main where + +import Data.Maybe (fromJust) +import GHC.Stack + +main :: IO () +main = print f1 + +f1 :: Int +f1 = f2 + +f2 :: Int +f2 = f3 + +-- HsQualTy +f3 :: HasCallStack => Int +f3 = f4 0 + +-- HsQualTy +f4 :: Show a => a -> Int +f4 _ = f5 0 0 + +-- HsFunTy +f5 :: Int -> Int -> Int +f5 _ _ = head f6 + +-- HsListTy +f6 :: [Int] +f6 = [fst f7] + +-- HsTupleTy +f7 :: (Int, Int) +f7 = (fromJust f8, fromJust f8) + +-- HsAppTy +f8 :: Maybe Int +f8 = Just fError + +-- HsTyVar +fError :: Int +fError = error "fError" \ No newline at end of file diff --git a/haskell-stack-trace-plugin.cabal b/haskell-stack-trace-plugin.cabal new file mode 100644 index 0000000..eb97102 --- /dev/null +++ b/haskell-stack-trace-plugin.cabal @@ -0,0 +1,35 @@ +name: haskell-stack-trace-plugin +version: 0.1.0.0 +-- synopsis: +-- description: +-- bug-reports: +license: MIT +license-file: LICENSE +author: Shinya Yamaguchi +maintainer: ingronze@gmail.com +copyright: 2018 Shinya Yamaguchi +category: Compiler Plugin +build-type: Simple +extra-source-files: CHANGELOG.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + build-depends: + base >=4.12 && <4.13, + ghc==8.6.2 + + exposed-modules: + StackTrace.Plugin + + default-language: Haskell2010 + +executable example + 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 \ No newline at end of file diff --git a/src/StackTrace/Plugin.hs b/src/StackTrace/Plugin.hs new file mode 100644 index 0000000..d7570ae --- /dev/null +++ b/src/StackTrace/Plugin.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE OverloadedStrings #-} +module StackTrace.Plugin (plugin) where + +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 + +plugin :: Plugin +plugin = defaultPlugin + { parsedResultAction = parsedPlugin + } + +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 } + + 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 + } + where + decls = hsmodImports hsm + lhss = hsmodDecls hsm + +-------------- + +updateHsmodDecl :: LHsDecl GhcPs -> LHsDecl GhcPs +updateHsmodDecl = fmap updateHsDecl + +updateHsDecl :: HsDecl GhcPs -> HsDecl GhcPs +updateHsDecl (SigD xSig s) = SigD xSig (updateSig s) +updateHsDecl decl = decl + +updateSig :: Sig GhcPs -> Sig GhcPs +updateSig (TypeSig xSig ls t) = TypeSig xSig ls (updateLHsSigWcType t) +updateSig sig = sig + +updateLHsSigWcType :: LHsSigWcType GhcPs -> LHsSigWcType GhcPs +updateLHsSigWcType lhs@HsWC{} = lhs { hswc_body = updateLHsSigType (hswc_body lhs) } +updateLHsSigWcType lhs@XHsWildCardBndrs{} = 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 + +-- 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 + +appendHSC :: HsContext GhcPs -> HsContext GhcPs +appendHSC cs = mkHSC : cs + +-- make HasCallStack => constraint +mkHSC :: LHsType GhcPs +mkHSC = noLoc $ HsTyVar noExt NotPromoted lId + +lId :: Located (IdP GhcPs) +lId = noLoc $ mkRdrUnqual $ mkClsOcc "HasCallStack" \ No newline at end of file