@@ -1,11 +1,17 @@
11{-# LANGUAGE RankNTypes #-}
22{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE CPP #-}
34module StackTrace.Plugin (plugin) where
45
56import Control.Arrow (first)
67import Data.Monoid (Any(Any, getAny))
78import GhcPlugins
9+#if __GLASGOW_HASKELL__ >= 810
10+import GHC.Hs
11+#endif
12+#if __GLASGOW_HASKELL__ < 810
813import HsSyn
14+#endif
915
1016type Traversal s t a b
1117 = forall f. Applicative f =>
@@ -28,11 +34,19 @@ parsedPlugin _ _ pm = do
2834ghcStackModuleName :: ModuleName
2935ghcStackModuleName = mkModuleName "AutoImported.GHC.Stack"
3036
37+#if __GLASGOW_HASKELL__ < 810
38+importDeclQualified :: Bool
39+importDeclQualified = True
40+#else
41+importDeclQualified :: ImportDeclQualifiedStyle
42+importDeclQualified = QualifiedPre
43+#endif
44+
3145ghcStackImport :: Located (ImportDecl (GhcPass p))
3246ghcStackImport =
3347 noLoc $
3448 (simpleImportDecl $ mkModuleName "GHC.Stack")
35− {ideclQualified = True, ideclAs = Just $ noLoc ghcStackModuleName}
49+ {ideclQualified = importDeclQualified, ideclAs = Just $ noLoc ghcStackModuleName}
3650
3751updateHsModule :: HsModule GhcPs -> HsModule GhcPs
3852updateHsModule hsm =
@@ -91,17 +105,24 @@ updateHsType :: HsType GhcPs -> (Any, HsType GhcPs)
91105updateHsType (HsQualTy xty ctxt body) =
92106 flagASTModified $ HsQualTy xty (fmap appendHSC ctxt) body
93107updateHsType ty@HsTyVar {} =
94− flagASTModified $ HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
108+ flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
95109updateHsType ty@HsAppTy {} =
96− flagASTModified $ HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
110+ flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
97111updateHsType ty@HsFunTy {} =
98− flagASTModified $ HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
112+ flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
99113updateHsType ty@HsListTy {} =
100− flagASTModified $ HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
114+ flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
101115updateHsType ty@HsTupleTy {} =
102− flagASTModified $ HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
116+ flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
103117updateHsType ty = pure ty
104118
119+#if __GLASGOW_HASKELL__ < 810
120+xQualTy = noExt
121+#else
122+xQualTy :: NoExtField
123+xQualTy = NoExtField
124+#endif
125+
105126flagASTModified :: a -> (Any, a)
106127flagASTModified a = (Any True, a)
107128
@@ -110,7 +131,7 @@ appendHSC cs = mkHSC : cs
110131
111132-- make HasCallStack => constraint
112133mkHSC :: LHsType GhcPs
113−mkHSC = noLoc $ HsTyVar noExt NotPromoted lId
134+mkHSC = noLoc $ HsTyVar xQualTy NotPromoted lId
114135
115136lId :: Located (IdP GhcPs)
116137lId = noLoc $ mkRdrQual ghcStackModuleName $ mkClsOcc "HasCallStack"