git.iko.soy/typeable/haskell-stack-trace-plugin
on master help sign in
first commit
commitcb4b0d8d24d8c5e0129f8c56315fead2d49a5d49 authorwaddlaw <ingronze@gmail.com> dateFri 7 Dec 2018, 15:07 (8 years ago)
7 files changed+291
compare with master
unifiedsplit
.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
.gitignorenew file+6
@@ -0,0 +1,6 @@
1+dist/
2+dist-*/
3+.ghc.environment.*
4+cabal.project.local
5+
6+*~
CHANGELOG.mdnew file+5
@@ -0,0 +1,5 @@
1+# Revision history for haskell-stack-trace-pugin
2+
3+## 0.1.0.0 -- 2018-12-07
4+
5+* First version. Released on an unsuspecting world.
LICENSEnew file+20
@@ -0,0 +1,20 @@
1+Copyright (c) 2018 Shinya Yamaguchi
2+
3+Permission is hereby granted, free of charge, to any person obtaining
4+a copy of this software and associated documentation files (the
5+"Software"), to deal in the Software without restriction, including
6+without limitation the rights to use, copy, modify, merge, publish,
7+distribute, sublicense, and/or sell copies of the Software, and to
8+permit persons to whom the Software is furnished to do so, subject to
9+the following conditions:
10+
11+The above copyright notice and this permission notice shall be included
12+in all copies or substantial portions of the Software.
13+
14+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
15+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
16+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
17+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
18+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
19+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
20+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
Readme.mdnew file+103
@@ -0,0 +1,103 @@
1+# haskell-stack-trace-plugin
2+
3+This plugin allow implicitly add `HasCallStack` class to every top-level function for all module. Hence, we can to get completely continuous call stack.
4+
5+1. (implicitly) Import [GHC.Stack](https://www.stackage.org/haddock/lts-12.21/base-4.11.1.0/GHC-Stack.html) for all modules.
6+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.
7+
8+Requirement: (8.6 <= on GHC)
9+
10+## Synopsis
11+
12+```haskell
13+module Main where
14+
15+import Data.Maybe (fromJust)
16+
17+main :: IO ()
18+main = print f1
19+
20+f1 :: Int
21+f1 = f2
22+
23+f2 :: Int
24+f2 = f3
25+
26+-- HsQualTy
27+f3 :: HasCallStack => Int
28+f3 = f4 0
29+
30+-- HsQualTy
31+f4 :: Show a => a -> Int
32+f4 _ = f5 0 0
33+
34+-- HsFunTy
35+f5 :: Int -> Int -> Int
36+f5 _ _ = head f6
37+
38+-- HsListTy
39+f6 :: [Int]
40+f6 = [fst f7]
41+
42+-- HsTupleTy
43+f7 :: (Int, Int)
44+f7 = (fromJust f8, fromJust f8)
45+
46+-- HsAppTy
47+f8 :: Maybe Int
48+f8 = Just fError
49+
50+-- HsTyVar
51+fError :: Int
52+fError = error "fError"
53+```
54+
55+This example get error:
56+
57+```shell
58+$ cabal new-build
59+example/Main.hs:15:7: error:
60+ Not in scope: type constructor or class ‘HasCallStack’
61+ |
62+15 | f3 :: HasCallStack => Int
63+ | ^^^^^^^^^^^^
64+```
65+
66+Yes, add `import GHC.Stack` to above example.
67+
68+Fix and rebuild!
69+
70+```shell
71+$ cabal new-build
72+example: fError
73+CallStack (from HasCallStack):
74+ error, called at example/Main.hs:41:10 in main:Main
75+```
76+
77+Hmm, it is not useful. But, you will to be happy when enable this plugin.
78+
79+```cabal
80+ ghc-options:
81+ -fplugin=StackTrace.Plugin
82+```
83+
84+```shell
85+$ cabal new-run
86+...
87+
88+example: fError
89+CallStack (from HasCallStack):
90+ error, called at example/Main.hs:40:10 in main:Main
91+ fError, called at example/Main.hs:36:11 in main:Main
92+ f8, called at example/Main.hs:32:16 in main:Main
93+ f7, called at example/Main.hs:28:11 in main:Main
94+ f6, called at example/Main.hs:24:15 in main:Main
95+ f5, called at example/Main.hs:20:8 in main:Main
96+ f4, called at example/Main.hs:16:6 in main:Main
97+ f3, called at example/Main.hs:12:6 in main:Main
98+ f2, called at example/Main.hs:9:6 in main:Main
99+ f1, called at example/Main.hs:6:14 in main:Main
100+ main, called at example/Main.hs:6:1 in main:Main
101+```
102+
103+Great!!!
example/Main.hsnew file+41
@@ -0,0 +1,41 @@
1+module Main where
2+
3+import Data.Maybe (fromJust)
4+import GHC.Stack
5+
6+main :: IO ()
7+main = print f1
8+
9+f1 :: Int
10+f1 = f2
11+
12+f2 :: Int
13+f2 = f3
14+
15+-- HsQualTy
16+f3 :: HasCallStack => Int
17+f3 = f4 0
18+
19+-- HsQualTy
20+f4 :: Show a => a -> Int
21+f4 _ = f5 0 0
22+
23+-- HsFunTy
24+f5 :: Int -> Int -> Int
25+f5 _ _ = head f6
26+
27+-- HsListTy
28+f6 :: [Int]
29+f6 = [fst f7]
30+
31+-- HsTupleTy
32+f7 :: (Int, Int)
33+f7 = (fromJust f8, fromJust f8)
34+
35+-- HsAppTy
36+f8 :: Maybe Int
37+f8 = Just fError
38+
39+-- HsTyVar
40+fError :: Int
41+fError = error "fError"
haskell-stack-trace-plugin.cabalnew file+35
@@ -0,0 +1,35 @@
1+name: haskell-stack-trace-plugin
2+version: 0.1.0.0
3+-- synopsis:
4+-- description:
5+-- bug-reports:
6+license: MIT
7+license-file: LICENSE
8+author: Shinya Yamaguchi
9+maintainer: ingronze@gmail.com
10+copyright: 2018 Shinya Yamaguchi
11+category: Compiler Plugin
12+build-type: Simple
13+extra-source-files: CHANGELOG.md
14+cabal-version: >=1.10
15+
16+library
17+ hs-source-dirs: src
18+ build-depends:
19+ base >=4.12 && <4.13,
20+ ghc==8.6.2
21+
22+ exposed-modules:
23+ StackTrace.Plugin
24+
25+ default-language: Haskell2010
26+
27+executable example
28+ main-is: Main.hs
29+ hs-source-dirs: example
30+ default-language: Haskell2010
31+ ghc-options:
32+ -fplugin=StackTrace.Plugin
33+ build-depends:
34+ base >=4.12 && <4.13,
35+ haskell-stack-trace-plugin
src/StackTrace/Plugin.hsnew file+81
@@ -0,0 +1,81 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+module StackTrace.Plugin (plugin) where
3+
4+import GhcPlugins
5+import TcRnTypes (IfM, TcM, TcGblEnv, tcg_binds, tcg_rn_decls)
6+import HsExtension (GhcTc, GhcRn)
7+import HsDecls (HsGroup)
8+import HsExpr (LHsExpr)
9+import HsSyn
10+
11+import Data.Maybe
12+
13+plugin :: Plugin
14+plugin = defaultPlugin
15+ { parsedResultAction = parsedPlugin
16+ }
17+
18+parsedPlugin :: [CommandLineOption] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule
19+parsedPlugin _ _ pm = do
20+ dflags <- getDynFlags
21+
22+ let extract = hsmodImports . unLoc
23+ addGHCStackMod = noLoc $ simpleImportDecl $ mkModuleName "GHC.Stack"
24+
25+ m = updateHsModule addGHCStackMod updateHsmodDecl <$> hpm_module pm
26+ pm' = pm { hpm_module = m }
27+
28+ return pm'
29+
30+updateHsModule :: LImportDecl GhcPs -> (LHsDecl GhcPs -> LHsDecl GhcPs) -> HsModule GhcPs -> HsModule GhcPs
31+updateHsModule importDecl update hsm = hsm
32+ { hsmodImports = importDecl:decls
33+ , hsmodDecls = map update lhss
34+ }
35+ where
36+ decls = hsmodImports hsm
37+ lhss = hsmodDecls hsm
38+
39+--------------
40+
41+updateHsmodDecl :: LHsDecl GhcPs -> LHsDecl GhcPs
42+updateHsmodDecl = fmap updateHsDecl
43+
44+updateHsDecl :: HsDecl GhcPs -> HsDecl GhcPs
45+updateHsDecl (SigD xSig s) = SigD xSig (updateSig s)
46+updateHsDecl decl = decl
47+
48+updateSig :: Sig GhcPs -> Sig GhcPs
49+updateSig (TypeSig xSig ls t) = TypeSig xSig ls (updateLHsSigWcType t)
50+updateSig sig = sig
51+
52+updateLHsSigWcType :: LHsSigWcType GhcPs -> LHsSigWcType GhcPs
53+updateLHsSigWcType lhs@HsWC{} = lhs { hswc_body = updateLHsSigType (hswc_body lhs) }
54+updateLHsSigWcType lhs@XHsWildCardBndrs{} = lhs
55+
56+updateLHsSigType :: LHsSigType GhcPs -> LHsSigType GhcPs
57+updateLHsSigType lhs@HsIB{} = lhs { hsib_body = updateLHsType (hsib_body lhs )}
58+updateLHsSigType lhs@XHsImplicitBndrs{} = lhs
59+
60+updateLHsType :: LHsType GhcPs -> LHsType GhcPs
61+updateLHsType = fmap updateHsType
62+
63+-- Main process
64+updateHsType :: HsType GhcPs -> HsType GhcPs
65+updateHsType ty@(HsQualTy xty ctxt body) = HsQualTy xty (fmap appendHSC ctxt) body
66+updateHsType ty@HsTyVar{} = HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
67+updateHsType ty@HsAppTy{} = HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
68+updateHsType ty@HsFunTy{} = HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
69+updateHsType ty@HsListTy{} = HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
70+updateHsType ty@HsTupleTy{} = HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
71+updateHsType ty = ty
72+
73+appendHSC :: HsContext GhcPs -> HsContext GhcPs
74+appendHSC cs = mkHSC : cs
75+
76+-- make HasCallStack => constraint
77+mkHSC :: LHsType GhcPs
78+mkHSC = noLoc $ HsTyVar noExt NotPromoted lId
79+
80+lId :: Located (IdP GhcPs)
81+lId = noLoc $ mkRdrUnqual $ mkClsOcc "HasCallStack"