mirror of
https://github.com/typeable/haskell-stack-trace-plugin.git
synced 2024-09-17 15:07:15 +03:00
first commit
This commit is contained in:
commit
cb4b0d8d24
6
.gitignore
vendored
Normal file
6
.gitignore
vendored
Normal file
@ -0,0 +1,6 @@
|
|||||||
|
dist/
|
||||||
|
dist-*/
|
||||||
|
.ghc.environment.*
|
||||||
|
cabal.project.local
|
||||||
|
|
||||||
|
*~
|
5
CHANGELOG.md
Normal file
5
CHANGELOG.md
Normal file
@ -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.
|
20
LICENSE
Normal file
20
LICENSE
Normal file
@ -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.
|
103
Readme.md
Normal file
103
Readme.md
Normal file
@ -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!!!
|
41
example/Main.hs
Normal file
41
example/Main.hs
Normal file
@ -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"
|
35
haskell-stack-trace-plugin.cabal
Normal file
35
haskell-stack-trace-plugin.cabal
Normal file
@ -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
|
81
src/StackTrace/Plugin.hs
Normal file
81
src/StackTrace/Plugin.hs
Normal file
@ -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"
|
Loading…
Reference in New Issue
Block a user