@@ -5,13 +5,7 @@ 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−
138import GhcPlugins
14−#endif
159#if __GLASGOW_HASKELL__ >= 810
1610import GHC.Hs
1711#endif
@@ -50,20 +44,11 @@ importDeclQualified = QualifiedPre
5044
5145ghcStackImport :: Located (ImportDecl (GhcPass p))
5246ghcStackImport =
53− L srcSpan $
47+ noLoc $
5448 (simpleImportDecl $ mkModuleName "GHC.Stack")
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
49+ {ideclQualified = importDeclQualified, ideclAs = Just $ noLoc ghcStackModuleName}
6150
62−#if __GLASGOW_HASKELL__ >= 900
63−updateHsModule :: HsModule -> HsModule
64−#else
6551updateHsModule :: HsModule GhcPs -> HsModule GhcPs
66−#endif
6752updateHsModule hsm =
6853 hsm {hsmodImports = hsmodImports', hsmodDecls = hsmodDecls'}
6954 where
@@ -85,6 +70,7 @@ updateHsModule hsm =
8570 astTraversal :: Traversal' (LHsDecl GhcPs) (HsType GhcPs)
8671 astTraversal = updateHsmodDecl
8772 . updateHsDecl
73+ . updateSig
8874 . updateLHsSigWsType
8975 . updateLHsSigType
9076 . updateLHsType
@@ -93,56 +79,10 @@ updateHsModule hsm =
9379updateHsmodDecl :: Traversal' (LHsDecl GhcPs) (HsDecl GhcPs)
9480updateHsmodDecl = traverse
9581
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
82+updateHsDecl :: Traversal' (HsDecl GhcPs) (Sig GhcPs)
83+updateHsDecl f (SigD xSig s) = SigD xSig <$> f s
9984updateHsDecl _ sig = pure sig
10085
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−
14686updateSig :: Traversal' (Sig GhcPs) (LHsSigWcType GhcPs)
14787updateSig f (TypeSig xSig ls t) = TypeSig xSig ls <$> f t
14888updateSig _ sig = pure sig
@@ -150,26 +90,20 @@ updateSig _ sig = pure sig
15090updateLHsSigWsType :: Traversal' (LHsSigWcType GhcPs) (LHsSigType GhcPs)
15191updateLHsSigWsType f lhs@HsWC {} =
15292 (\x -> lhs {hswc_body = x}) <$> f (hswc_body lhs)
153−#if __GLASGOW_HASKELL__ < 900
15493updateLHsSigWsType _ lhs = pure lhs
155−#endif
15694
15795updateLHsSigType :: Traversal' (LHsSigType GhcPs) (LHsType GhcPs)
15896updateLHsSigType f lhs@HsIB {} =
15997 (\x -> lhs {hsib_body = x}) <$> f (hsib_body lhs)
160−#if __GLASGOW_HASKELL__ < 900
16198updateLHsSigType _ lhs = pure lhs
162−#endif
16399
164100updateLHsType :: Traversal' (LHsType GhcPs) (HsType GhcPs)
165101updateLHsType = traverse
166102
167103-- Main process
168104updateHsType :: HsType GhcPs -> (Any, HsType GhcPs)
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
105+updateHsType (HsQualTy xty ctxt body) =
106+ flagASTModified $ HsQualTy xty (fmap appendHSC ctxt) body
173107updateHsType ty@HsTyVar {} =
174108 flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
175109updateHsType ty@HsAppTy {} =
@@ -183,7 +117,6 @@ updateHsType ty@HsTupleTy {} =
183117updateHsType ty = pure ty
184118
185119#if __GLASGOW_HASKELL__ < 810
186−xQualTy :: NoExt
187120xQualTy = noExt
188121#else
189122xQualTy :: NoExtField
@@ -196,13 +129,6 @@ flagASTModified a = (Any True, a)
196129appendHSC :: HsContext GhcPs -> HsContext GhcPs
197130appendHSC cs = mkHSC : cs
198131
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−
206132-- make HasCallStack => constraint
207133mkHSC :: LHsType GhcPs
208134mkHSC = noLoc $ HsTyVar xQualTy NotPromoted lId