first commit

.gitignore

@@ -0,0 +1,6 @@
+dist/
+dist-*/
+.ghc.environment.*
+cabal.project.local
+
+*~

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.

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.

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!!!

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"

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

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"