@@ -5,7 +5,13 @@ module StackTrace.Plugin (plugin) where
55
66import Control.Arrow (first)
77import Data.Monoid (Any(Any, getAny))
8+import GHC.Types.SrcLoc
9+#if __GLASGOW_HASKELL__ >= 900
10+import GHC.Plugins
11+#else
12+
813import GhcPlugins
14+#endif
915#if __GLASGOW_HASKELL__ >= 810
1016import GHC.Hs
1117#endif
@@ -44,11 +50,20 @@ importDeclQualified = QualifiedPre
4450
4551ghcStackImport :: Located (ImportDecl (GhcPass p))
4652ghcStackImport =
47− noLoc $
53+ L srcSpan $
4854 (simpleImportDecl $ mkModuleName "GHC.Stack")
49− {ideclQualified = importDeclQualified, ideclAs = Just $ noLoc ghcStackModuleName}
55+ { ideclQualified = importDeclQualified, ideclAs = Just $ noLoc ghcStackModuleName }
56+ where
57+ -- This is for GHC-9 related problems. @noLoc@ causes GHC to throw warnings
58+ -- about unused imports. Even if the import is used
59+ -- See: https://github.com/waddlaw/haskell-stack-trace-plugin/issues/16
60+ srcSpan = RealSrcSpan (realSrcLocSpan $ mkRealSrcLoc "haskell-stack-trace-plugin:very-unique-file-name-to-avoid-collision" 1 1) Nothing
5061
62+#if __GLASGOW_HASKELL__ >= 900
63+updateHsModule :: HsModule -> HsModule
64+#else
5165updateHsModule :: HsModule GhcPs -> HsModule GhcPs
66+#endif
5267updateHsModule hsm =
5368 hsm {hsmodImports = hsmodImports', hsmodDecls = hsmodDecls'}
5469 where
@@ -70,7 +85,6 @@ updateHsModule hsm =
7085 astTraversal :: Traversal' (LHsDecl GhcPs) (HsType GhcPs)
7186 astTraversal = updateHsmodDecl
7287 . updateHsDecl
73− . updateSig
7488 . updateLHsSigWsType
7589 . updateLHsSigType
7690 . updateLHsType
@@ -79,10 +93,56 @@ updateHsModule hsm =
7993updateHsmodDecl :: Traversal' (LHsDecl GhcPs) (HsDecl GhcPs)
8094updateHsmodDecl = traverse
8195
82−updateHsDecl :: Traversal' (HsDecl GhcPs) (Sig GhcPs)
83−updateHsDecl f (SigD xSig s) = SigD xSig <$> f s
96+updateHsDecl :: Traversal' (HsDecl GhcPs) (LHsSigWcType GhcPs)
97+updateHsDecl f (SigD xSig s) = SigD xSig <$> updateSig f s
98+updateHsDecl f (ValD xVal hsBind) = ValD xVal <$> updateHsBind f hsBind
8499updateHsDecl _ sig = pure sig
85100
101+updateHsBind :: Traversal' (HsBind GhcPs) (LHsSigWcType GhcPs)
102+updateHsBind f bind@FunBind {} = (\x -> bind {fun_matches = x}) <$> updateMatchGroup f (fun_matches bind)
103+updateHsBind _ bind = pure bind
104+
105+updateMatchGroup :: Traversal' (MatchGroup GhcPs (LHsExpr GhcPs)) (LHsSigWcType GhcPs)
106+updateMatchGroup f mg@MG {} = (\x -> mg {mg_alts = x}) <$> updateLLMatch f (mg_alts mg)
107+#if __GLASGOW_HASKELL__ < 900
108+updateMatchGroup _ mg = pure mg
109+#endif
110+
111+updateLocated :: Functor f => (a -> b -> f c) -> a -> Located b -> f (Located c)
112+updateLocated f g (L l e) = L l <$> f g e
113+
114+updateLLMatch :: Traversal' (Located [LMatch GhcPs (LHsExpr GhcPs)]) (LHsSigWcType GhcPs)
115+updateLLMatch = updateLocated updateLMatches
116+
117+updateLMatches :: Traversal' [LMatch GhcPs (LHsExpr GhcPs)] (LHsSigWcType GhcPs)
118+updateLMatches f = traverse (updateLocated updateMatch f)
119+
120+updateMatch :: Traversal' (Match GhcPs (LHsExpr GhcPs)) (LHsSigWcType GhcPs)
121+updateMatch f m@Match {} = (\x -> m {m_grhss = x}) <$> updateGrhss f (m_grhss m)
122+#if __GLASGOW_HASKELL__ < 900
123+updateMatch _ m = pure m
124+#endif
125+
126+updateGrhss :: Traversal' (GRHSs GhcPs (LHsExpr GhcPs)) (LHsSigWcType GhcPs)
127+updateGrhss f grhss@GRHSs {} = (\x -> grhss {grhssLocalBinds = x}) <$> updateLHsLocalBinds f (grhssLocalBinds grhss)
128+#if __GLASGOW_HASKELL__ < 900
129+updateGrhss _ grhss = pure grhss
130+#endif
131+
132+updateLHsLocalBinds :: Traversal' (LHsLocalBinds GhcPs) (LHsSigWcType GhcPs)
133+updateLHsLocalBinds = updateLocated updateLocalBinds
134+
135+updateLocalBinds :: Traversal' (HsLocalBinds GhcPs) (LHsSigWcType GhcPs)
136+updateLocalBinds f (HsValBinds xHsValBinds hsValBindsLR) = HsValBinds xHsValBinds <$> updateHsValBindsLR f hsValBindsLR
137+updateLocalBinds _ hsValBinds = pure hsValBinds
138+
139+updateHsValBindsLR :: Traversal' (HsValBindsLR GhcPs GhcPs) (LHsSigWcType GhcPs)
140+updateHsValBindsLR f (ValBinds xValBinds lHsBindsLR lSigs) = ValBinds xValBinds lHsBindsLR <$> updateLSigs f lSigs
141+updateHsValBindsLR _ valBinds = pure valBinds
142+
143+updateLSigs :: Traversal' [LSig GhcPs] (LHsSigWcType GhcPs)
144+updateLSigs f = traverse (updateLocated updateSig f)
145+
86146updateSig :: Traversal' (Sig GhcPs) (LHsSigWcType GhcPs)
87147updateSig f (TypeSig xSig ls t) = TypeSig xSig ls <$> f t
88148updateSig _ sig = pure sig
@@ -90,20 +150,26 @@ updateSig _ sig = pure sig
90150updateLHsSigWsType :: Traversal' (LHsSigWcType GhcPs) (LHsSigType GhcPs)
91151updateLHsSigWsType f lhs@HsWC {} =
92152 (\x -> lhs {hswc_body = x}) <$> f (hswc_body lhs)
153+#if __GLASGOW_HASKELL__ < 900
93154updateLHsSigWsType _ lhs = pure lhs
155+#endif
94156
95157updateLHsSigType :: Traversal' (LHsSigType GhcPs) (LHsType GhcPs)
96158updateLHsSigType f lhs@HsIB {} =
97159 (\x -> lhs {hsib_body = x}) <$> f (hsib_body lhs)
160+#if __GLASGOW_HASKELL__ < 900
98161updateLHsSigType _ lhs = pure lhs
162+#endif
99163
100164updateLHsType :: Traversal' (LHsType GhcPs) (HsType GhcPs)
101165updateLHsType = traverse
102166
103167-- Main process
104168updateHsType :: HsType GhcPs -> (Any, HsType GhcPs)
105−updateHsType (HsQualTy xty ctxt body) =
106− flagASTModified $ HsQualTy xty (fmap appendHSC ctxt) body
169+updateHsType ty@(HsQualTy xty ctxt body) =
170+ if hasHasCallStack (unLoc ctxt)
171+ then pure ty
172+ else flagASTModified $ HsQualTy xty (fmap appendHSC ctxt) body
107173updateHsType ty@HsTyVar {} =
108174 flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
109175updateHsType ty@HsAppTy {} =
@@ -117,6 +183,7 @@ updateHsType ty@HsTupleTy {} =
117183updateHsType ty = pure ty
118184
119185#if __GLASGOW_HASKELL__ < 810
186+xQualTy :: NoExt
120187xQualTy = noExt
121188#else
122189xQualTy :: NoExtField
@@ -129,6 +196,13 @@ flagASTModified a = (Any True, a)
129196appendHSC :: HsContext GhcPs -> HsContext GhcPs
130197appendHSC cs = mkHSC : cs
131198
199+hasHasCallStack :: HsContext GhcPs -> Bool
200+hasHasCallStack = any (checkHsType . unLoc)
201+ where
202+ checkHsType :: HsType GhcPs -> Bool
203+ checkHsType (HsTyVar _ _ lid) = unLoc lid == (mkRdrUnqual $ mkClsOcc "HasCallStack")
204+ checkHsType _ = False
205+
132206-- make HasCallStack => constraint
133207mkHSC :: LHsType GhcPs
134208mkHSC = noLoc $ HsTyVar xQualTy NotPromoted lId