mirror of
https://github.com/typeable/haskell-stack-trace-plugin.git
synced 2024-09-19 07:58:11 +03:00
added support for GHC 8.10
This commit is contained in:
parent
50a8d04b88
commit
f42e35a844
2
.github/workflows/cabal.yml
vendored
2
.github/workflows/cabal.yml
vendored
@ -17,7 +17,7 @@ jobs:
|
|||||||
runs-on: ubuntu-18.04
|
runs-on: ubuntu-18.04
|
||||||
strategy:
|
strategy:
|
||||||
matrix:
|
matrix:
|
||||||
ghc: ["8.6.5", "8.8.1"]
|
ghc: ["8.6.5", "8.8.1", "8.10.4"]
|
||||||
cabal: ["3.0"]
|
cabal: ["3.0"]
|
||||||
|
|
||||||
steps:
|
steps:
|
||||||
|
@ -1,6 +1,6 @@
|
|||||||
cabal-version: 2.4
|
cabal-version: 2.4
|
||||||
name: haskell-stack-trace-plugin
|
name: haskell-stack-trace-plugin
|
||||||
version: 0.1.1.1
|
version: 0.1.2.0
|
||||||
synopsis: haskell-stack-trace-plugin
|
synopsis: haskell-stack-trace-plugin
|
||||||
description:
|
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.
|
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
|
CHANGELOG.md
|
||||||
Readme.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
|
source-repository head
|
||||||
type: git
|
type: git
|
||||||
@ -32,13 +32,13 @@ flag dev
|
|||||||
default: False
|
default: False
|
||||||
|
|
||||||
common common-opts
|
common common-opts
|
||||||
build-depends: base >=4.12 && <4.14
|
build-depends: base >=4.12 && <4.15
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
|
||||||
library
|
library
|
||||||
import: common-opts
|
import: common-opts
|
||||||
hs-source-dirs: src
|
hs-source-dirs: src
|
||||||
build-depends: ghc ^>=8.6 || ^>=8.8
|
build-depends: ghc ^>=8.6 || ^>=8.8 || ^>=8.10
|
||||||
exposed-modules: StackTrace.Plugin
|
exposed-modules: StackTrace.Plugin
|
||||||
|
|
||||||
if flag(dev)
|
if flag(dev)
|
||||||
|
@ -1,11 +1,17 @@
|
|||||||
{-# LANGUAGE RankNTypes #-}
|
{-# LANGUAGE RankNTypes #-}
|
||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
|
{-# LANGUAGE CPP #-}
|
||||||
module StackTrace.Plugin (plugin) where
|
module StackTrace.Plugin (plugin) where
|
||||||
|
|
||||||
import Control.Arrow (first)
|
import Control.Arrow (first)
|
||||||
import Data.Monoid (Any(Any, getAny))
|
import Data.Monoid (Any(Any, getAny))
|
||||||
import GhcPlugins
|
import GhcPlugins
|
||||||
|
#if __GLASGOW_HASKELL__ >= 810
|
||||||
|
import GHC.Hs
|
||||||
|
#endif
|
||||||
|
#if __GLASGOW_HASKELL__ < 810
|
||||||
import HsSyn
|
import HsSyn
|
||||||
|
#endif
|
||||||
|
|
||||||
type Traversal s t a b
|
type Traversal s t a b
|
||||||
= forall f. Applicative f =>
|
= forall f. Applicative f =>
|
||||||
@ -28,11 +34,19 @@ parsedPlugin _ _ pm = do
|
|||||||
ghcStackModuleName :: ModuleName
|
ghcStackModuleName :: ModuleName
|
||||||
ghcStackModuleName = mkModuleName "AutoImported.GHC.Stack"
|
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 :: Located (ImportDecl (GhcPass p))
|
||||||
ghcStackImport =
|
ghcStackImport =
|
||||||
noLoc $
|
noLoc $
|
||||||
(simpleImportDecl $ mkModuleName "GHC.Stack")
|
(simpleImportDecl $ mkModuleName "GHC.Stack")
|
||||||
{ideclQualified = True, ideclAs = Just $ noLoc ghcStackModuleName}
|
{ideclQualified = importDeclQualified, ideclAs = Just $ noLoc ghcStackModuleName}
|
||||||
|
|
||||||
updateHsModule :: HsModule GhcPs -> HsModule GhcPs
|
updateHsModule :: HsModule GhcPs -> HsModule GhcPs
|
||||||
updateHsModule hsm =
|
updateHsModule hsm =
|
||||||
@ -91,17 +105,24 @@ updateHsType :: HsType GhcPs -> (Any, HsType GhcPs)
|
|||||||
updateHsType (HsQualTy xty ctxt body) =
|
updateHsType (HsQualTy xty ctxt body) =
|
||||||
flagASTModified $ HsQualTy xty (fmap appendHSC ctxt) body
|
flagASTModified $ HsQualTy xty (fmap appendHSC ctxt) body
|
||||||
updateHsType ty@HsTyVar {} =
|
updateHsType ty@HsTyVar {} =
|
||||||
flagASTModified $ HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
|
flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
|
||||||
updateHsType ty@HsAppTy {} =
|
updateHsType ty@HsAppTy {} =
|
||||||
flagASTModified $ HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
|
flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
|
||||||
updateHsType ty@HsFunTy {} =
|
updateHsType ty@HsFunTy {} =
|
||||||
flagASTModified $ HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
|
flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
|
||||||
updateHsType ty@HsListTy {} =
|
updateHsType ty@HsListTy {} =
|
||||||
flagASTModified $ HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
|
flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
|
||||||
updateHsType ty@HsTupleTy {} =
|
updateHsType ty@HsTupleTy {} =
|
||||||
flagASTModified $ HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
|
flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
|
||||||
updateHsType ty = pure ty
|
updateHsType ty = pure ty
|
||||||
|
|
||||||
|
#if __GLASGOW_HASKELL__ < 810
|
||||||
|
xQualTy = noExt
|
||||||
|
#else
|
||||||
|
xQualTy :: NoExtField
|
||||||
|
xQualTy = NoExtField
|
||||||
|
#endif
|
||||||
|
|
||||||
flagASTModified :: a -> (Any, a)
|
flagASTModified :: a -> (Any, a)
|
||||||
flagASTModified a = (Any True, a)
|
flagASTModified a = (Any True, a)
|
||||||
|
|
||||||
@ -110,7 +131,7 @@ appendHSC cs = mkHSC : cs
|
|||||||
|
|
||||||
-- make HasCallStack => constraint
|
-- make HasCallStack => constraint
|
||||||
mkHSC :: LHsType GhcPs
|
mkHSC :: LHsType GhcPs
|
||||||
mkHSC = noLoc $ HsTyVar noExt NotPromoted lId
|
mkHSC = noLoc $ HsTyVar xQualTy NotPromoted lId
|
||||||
|
|
||||||
lId :: Located (IdP GhcPs)
|
lId :: Located (IdP GhcPs)
|
||||||
lId = noLoc $ mkRdrQual ghcStackModuleName $ mkClsOcc "HasCallStack"
|
lId = noLoc $ mkRdrQual ghcStackModuleName $ mkClsOcc "HasCallStack"
|
||||||
|
Loading…
Reference in New Issue
Block a user