git.iko.soy/typeable/haskell-stack-trace-plugin
on master help sign in
Merge pull request #7 from etorreborre/master
d18c37aShinya Yamaguchi
.github/workflows/cabal.yml+2−2
compare with master
unifiedsplit
@@ -17,7 +17,7 @@ jobs:
17 runs-on: ubuntu-18.04
17 runs-on: ubuntu-18.04
18 strategy:
18 strategy:
19 matrix:
19 matrix:
20− ghc: ["8.6.5", "8.8.1"]
20+ ghc: ["8.6.5", "8.8.1", "8.10.4"]
21 cabal: ["3.0"]
21 cabal: ["3.0"]
22
22
23 steps:
23 steps:
@@ -53,4 +53,4 @@ jobs:
53 - name: Build & Test
53 - name: Build & Test
54 run: |
54 run: |
55 cabal v2-build --flag dev
55 cabal v2-build --flag dev
56− cabal v2-test --flag dev
56+ cabal v2-test --flag dev
haskell-stack-trace-plugin.cabal+4−4
@@ -1,6 +1,6 @@
1cabal-version: 2.4
1cabal-version: 2.4
2name: haskell-stack-trace-plugin
2name: haskell-stack-trace-plugin
3−version: 0.1.1.1
3+version: 0.1.2.0
4synopsis: haskell-stack-trace-plugin
4synopsis: haskell-stack-trace-plugin
5description:
5description:
6 This plugin allow implicitly add HasCallStack class to every top-level function for all module. Hence, we can to get completely continuous call stack.
6 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:
20 CHANGELOG.md
20 CHANGELOG.md
21 Readme.md
21 Readme.md
22
22
23−tested-with: GHC ==8.6.5 || ==8.8.1
23+tested-with: GHC ==8.6.5 || ==8.8.1 || ==8.10.4
24
24
25source-repository head
25source-repository head
26 type: git
26 type: git
@@ -32,13 +32,13 @@ flag dev
32 default: False
32 default: False
33
33
34common common-opts
34common common-opts
35− build-depends: base >=4.12 && <4.14
35+ build-depends: base >=4.12 && <4.15
36 default-language: Haskell2010
36 default-language: Haskell2010
37
37
38library
38library
39 import: common-opts
39 import: common-opts
40 hs-source-dirs: src
40 hs-source-dirs: src
41− build-depends: ghc ^>=8.6 || ^>=8.8
41+ build-depends: ghc ^>=8.6 || ^>=8.8 || ^>=8.10
42 exposed-modules: StackTrace.Plugin
42 exposed-modules: StackTrace.Plugin
43
43
44 if flag(dev)
44 if flag(dev)
src/StackTrace/Plugin.hs+28−7
@@ -1,11 +1,17 @@
1{-# LANGUAGE RankNTypes #-}
1{-# LANGUAGE RankNTypes #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE CPP #-}
3module StackTrace.Plugin (plugin) where
4module StackTrace.Plugin (plugin) where
4
5
5import Control.Arrow (first)
6import Control.Arrow (first)
6import Data.Monoid (Any(Any, getAny))
7import Data.Monoid (Any(Any, getAny))
7import GhcPlugins
8import GhcPlugins
9+#if __GLASGOW_HASKELL__ >= 810
10+import GHC.Hs
11+#endif
12+#if __GLASGOW_HASKELL__ < 810
8import HsSyn
13import HsSyn
14+#endif
9
15
10type Traversal s t a b
16type Traversal s t a b
11 = forall f. Applicative f =>
17 = forall f. Applicative f =>
@@ -28,11 +34,19 @@ parsedPlugin _ _ pm = do
28ghcStackModuleName :: ModuleName
34ghcStackModuleName :: ModuleName
29ghcStackModuleName = mkModuleName "AutoImported.GHC.Stack"
35ghcStackModuleName = mkModuleName "AutoImported.GHC.Stack"
30
36
37+#if __GLASGOW_HASKELL__ < 810
38+importDeclQualified :: Bool
39+importDeclQualified = True
40+#else
41+importDeclQualified :: ImportDeclQualifiedStyle
42+importDeclQualified = QualifiedPre
43+#endif
44+
31ghcStackImport :: Located (ImportDecl (GhcPass p))
45ghcStackImport :: Located (ImportDecl (GhcPass p))
32ghcStackImport =
46ghcStackImport =
33 noLoc $
47 noLoc $
34 (simpleImportDecl $ mkModuleName "GHC.Stack")
48 (simpleImportDecl $ mkModuleName "GHC.Stack")
35− {ideclQualified = True, ideclAs = Just $ noLoc ghcStackModuleName}
49+ {ideclQualified = importDeclQualified, ideclAs = Just $ noLoc ghcStackModuleName}
36
50
37updateHsModule :: HsModule GhcPs -> HsModule GhcPs
51updateHsModule :: HsModule GhcPs -> HsModule GhcPs
38updateHsModule hsm =
52updateHsModule hsm =
@@ -91,17 +105,24 @@ updateHsType :: HsType GhcPs -> (Any, HsType GhcPs)
91updateHsType (HsQualTy xty ctxt body) =
105updateHsType (HsQualTy xty ctxt body) =
92 flagASTModified $ HsQualTy xty (fmap appendHSC ctxt) body
106 flagASTModified $ HsQualTy xty (fmap appendHSC ctxt) body
93updateHsType ty@HsTyVar {} =
107updateHsType ty@HsTyVar {} =
94− flagASTModified $ HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
108+ flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
95updateHsType ty@HsAppTy {} =
109updateHsType ty@HsAppTy {} =
96− flagASTModified $ HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
110+ flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
97updateHsType ty@HsFunTy {} =
111updateHsType ty@HsFunTy {} =
98− flagASTModified $ HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
112+ flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
99updateHsType ty@HsListTy {} =
113updateHsType ty@HsListTy {} =
100− flagASTModified $ HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
114+ flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
101updateHsType ty@HsTupleTy {} =
115updateHsType ty@HsTupleTy {} =
102− flagASTModified $ HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
116+ flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
103updateHsType ty = pure ty
117updateHsType ty = pure ty
104
118
119+#if __GLASGOW_HASKELL__ < 810
120+xQualTy = noExt
121+#else
122+xQualTy :: NoExtField
123+xQualTy = NoExtField
124+#endif
125+
105flagASTModified :: a -> (Any, a)
126flagASTModified :: a -> (Any, a)
106flagASTModified a = (Any True, a)
127flagASTModified a = (Any True, a)
107
128
@@ -110,7 +131,7 @@ appendHSC cs = mkHSC : cs
110
131
111-- make HasCallStack => constraint
132-- make HasCallStack => constraint
112mkHSC :: LHsType GhcPs
133mkHSC :: LHsType GhcPs
113−mkHSC = noLoc $ HsTyVar noExt NotPromoted lId
134+mkHSC = noLoc $ HsTyVar xQualTy NotPromoted lId
114
135
115lId :: Located (IdP GhcPs)
136lId :: Located (IdP GhcPs)
116lId = noLoc $ mkRdrQual ghcStackModuleName $ mkClsOcc "HasCallStack"
137lId = noLoc $ mkRdrQual ghcStackModuleName $ mkClsOcc "HasCallStack"