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