typeable/haskell-stack-trace-plugin
1
0
Fork 0
mirror of https://github.com/typeable/haskell-stack-trace-plugin.git synced 2024-09-11 04:05:42 +03:00
Code Issues Packages Projects Releases Wiki Activity

added support for GHC 8.10

Browse Source
This commit is contained in:
Eric Torreborre 2021-05-19 10:11:24 +02:00
parent 50a8d04b88
commit f42e35a844
3 changed files with 34 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.github/workflows/cabal.yml vendored
View File

@ -17,7 +17,7 @@ jobs:
runs-on: ubuntu-18.04
strategy:
matrix:
ghc: ["8.6.5", "8.8.1"]
ghc: ["8.6.5", "8.8.1", "8.10.4"]
cabal: ["3.0"]
steps:
@ -53,4 +53,4 @@ jobs:
- name: Build & Test
run: |
cabal v2-build --flag dev
cabal v2-test --flag dev
cabal v2-test --flag dev

8
haskell-stack-trace-plugin.cabal
View File

@ -1,6 +1,6 @@
cabal-version: 2.4
name: haskell-stack-trace-plugin
version: 0.1.1.1
version: 0.1.2.0
synopsis: haskell-stack-trace-plugin
description:
This plugin allow implicitly add HasCallStack class to every top-level function for all module. Hence, we can to get completely continuous call stack.
@ -20,7 +20,7 @@ extra-source-files:
CHANGELOG.md
Readme.md
tested-with: GHC ==8.6.5 || ==8.8.1
tested-with: GHC ==8.6.5 || ==8.8.1 || ==8.10.4
source-repository head
type: git
@ -32,13 +32,13 @@ flag dev
default: False
common common-opts
build-depends: base >=4.12 && <4.14
build-depends: base >=4.12 && <4.15
default-language: Haskell2010
library
import: common-opts
hs-source-dirs: src
build-depends: ghc ^>=8.6 || ^>=8.8
build-depends: ghc ^>=8.6 || ^>=8.8 || ^>=8.10
exposed-modules: StackTrace.Plugin
if flag(dev)

35
src/StackTrace/Plugin.hs
View File

@ -1,11 +1,17 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
module StackTrace.Plugin (plugin) where
import Control.Arrow (first)
import Data.Monoid (Any(Any, getAny))
import GhcPlugins
#if __GLASGOW_HASKELL__ >= 810
import GHC.Hs
#endif
#if __GLASGOW_HASKELL__ < 810
import HsSyn
#endif
type Traversal s t a b
= forall f. Applicative f =>
@ -28,11 +34,19 @@ parsedPlugin _ _ pm = do
ghcStackModuleName :: ModuleName
ghcStackModuleName = mkModuleName "AutoImported.GHC.Stack"
#if __GLASGOW_HASKELL__ < 810
importDeclQualified :: Bool
importDeclQualified = True
#else
importDeclQualified :: ImportDeclQualifiedStyle
importDeclQualified = QualifiedPre
#endif
ghcStackImport :: Located (ImportDecl (GhcPass p))
ghcStackImport =
noLoc $
(simpleImportDecl $ mkModuleName "GHC.Stack")
{ideclQualified = True, ideclAs = Just $ noLoc ghcStackModuleName}
{ideclQualified = importDeclQualified, ideclAs = Just $ noLoc ghcStackModuleName}
updateHsModule :: HsModule GhcPs -> HsModule GhcPs
updateHsModule hsm =
@ -91,17 +105,24 @@ updateHsType :: HsType GhcPs -> (Any, HsType GhcPs)
updateHsType (HsQualTy xty ctxt body) =
flagASTModified $ HsQualTy xty (fmap appendHSC ctxt) body
updateHsType ty@HsTyVar {} =
flagASTModified $ HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
updateHsType ty@HsAppTy {} =
flagASTModified $ HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
updateHsType ty@HsFunTy {} =
flagASTModified $ HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
updateHsType ty@HsListTy {} =
flagASTModified $ HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
updateHsType ty@HsTupleTy {} =
flagASTModified $ HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
updateHsType ty = pure ty
#if __GLASGOW_HASKELL__ < 810
xQualTy = noExt
#else
xQualTy :: NoExtField
xQualTy = NoExtField
#endif
flagASTModified :: a -> (Any, a)
flagASTModified a = (Any True, a)
@ -110,7 +131,7 @@ appendHSC cs = mkHSC : cs
-- make HasCallStack => constraint
mkHSC :: LHsType GhcPs
mkHSC = noLoc $ HsTyVar noExt NotPromoted lId
mkHSC = noLoc $ HsTyVar xQualTy NotPromoted lId
lId :: Located (IdP GhcPs)
lId = noLoc $ mkRdrQual ghcStackModuleName $ mkClsOcc "HasCallStack"