@@ -1,211 +1,81 @@
1−{-# LANGUAGE RankNTypes #-}
21{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE CPP #-}
42module StackTrace.Plugin (plugin) where
5−
6−import Control.Arrow (first)
7−import Data.Monoid (Any(Any, getAny))
8−import GHC.Types.SrcLoc
9−#if __GLASGOW_HASKELL__ >= 900
10−import GHC.Plugins
11−#else
12−
3+
134import GhcPlugins
14−#endif
15−#if __GLASGOW_HASKELL__ >= 810
16−import GHC.Hs
17−#endif
18−#if __GLASGOW_HASKELL__ < 810
5+import TcRnTypes (IfM, TcM, TcGblEnv, tcg_binds, tcg_rn_decls)
6+import HsExtension (GhcTc, GhcRn)
7+import HsDecls (HsGroup)
8+import HsExpr (LHsExpr)
199import HsSyn
20−#endif
2110
22−type Traversal s t a b
23− = forall f. Applicative f =>
24− (a -> f b) -> s -> f t
25−
26−type Traversal' s a = Traversal s s a a
11+import Data.Maybe
2712
2813plugin :: Plugin
29−plugin = defaultPlugin {parsedResultAction = parsedPlugin, pluginRecompile = purePlugin}
14+plugin = defaultPlugin
15+ { parsedResultAction = parsedPlugin
16+ }
3017
31−parsedPlugin ::
32− [CommandLineOption] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule
18+parsedPlugin :: [CommandLineOption] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule
3319parsedPlugin _ _ pm = do
34− let m = updateHsModule <$> hpm_module pm
35− pm' = pm {hpm_module = m}
20+ dflags <- getDynFlags
21+
22+ let extract = hsmodImports . unLoc
23+ addGHCStackMod = noLoc $ simpleImportDecl $ mkModuleName "GHC.Stack"
24+
25+ m = updateHsModule addGHCStackMod updateHsmodDecl <$> hpm_module pm
26+ pm' = pm { hpm_module = m }
27+
3628 return pm'
3729
38−-- Use qualified import for GHC.Stack as "AutoImported.GHC.Stack"
39−-- ...this should not interfere with other imports...
40−ghcStackModuleName :: ModuleName
41−ghcStackModuleName = mkModuleName "AutoImported.GHC.Stack"
42−
43−#if __GLASGOW_HASKELL__ < 810
44−importDeclQualified :: Bool
45−importDeclQualified = True
46−#else
47−importDeclQualified :: ImportDeclQualifiedStyle
48−importDeclQualified = QualifiedPre
49−#endif
50−
51−ghcStackImport :: Located (ImportDecl (GhcPass p))
52−ghcStackImport =
53− L srcSpan $
54− (simpleImportDecl $ mkModuleName "GHC.Stack")
55− { ideclQualified = importDeclQualified, ideclAs = Just $ noLoc ghcStackModuleName }
30+updateHsModule :: LImportDecl GhcPs -> (LHsDecl GhcPs -> LHsDecl GhcPs) -> HsModule GhcPs -> HsModule GhcPs
31+updateHsModule importDecl update hsm = hsm
32+ { hsmodImports = importDecl:decls
33+ , hsmodDecls = map update lhss
34+ }
5635 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
61−
62−#if __GLASGOW_HASKELL__ >= 900
63−updateHsModule :: HsModule -> HsModule
64−#else
65−updateHsModule :: HsModule GhcPs -> HsModule GhcPs
66−#endif
67−updateHsModule hsm =
68− hsm {hsmodImports = hsmodImports', hsmodDecls = hsmodDecls'}
69− where
70− -- Traverse the haskell AST; if we have to add some HasStack
71− -- constraint we set a flag in a (Any,) functor.
72− -- ...it'd be simpler to check if before == after, but Haskell AST
73− -- doesn't have Eq instances.
74− (updatedP, hsmodDecls') =
75− first getAny $
76− (traverse . astTraversal) updateHsType (hsmodDecls hsm)
77−
78− -- Only import GHC.Stack if needed for a constraint we introduced
79− hsmodImports' =
80− (if updatedP
81− then [ghcStackImport]
82− else []) ++
83− hsmodImports hsm
84−
85− astTraversal :: Traversal' (LHsDecl GhcPs) (HsType GhcPs)
86− astTraversal = updateHsmodDecl
87− . updateHsDecl
88− . updateLHsSigWsType
89− . updateLHsSigType
90− . updateLHsType
36+ decls = hsmodImports hsm
37+ lhss = hsmodDecls hsm
9138
9239--------------
93−updateHsmodDecl :: Traversal' (LHsDecl GhcPs) (HsDecl GhcPs)
94−updateHsmodDecl = traverse
95−
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
99−updateHsDecl _ sig = pure sig
100−
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−
146−updateSig :: Traversal' (Sig GhcPs) (LHsSigWcType GhcPs)
147−updateSig f (TypeSig xSig ls t) = TypeSig xSig ls <$> f t
148−updateSig _ sig = pure sig
149−
150−updateLHsSigWsType :: Traversal' (LHsSigWcType GhcPs) (LHsSigType GhcPs)
151−updateLHsSigWsType f lhs@HsWC {} =
152− (\x -> lhs {hswc_body = x}) <$> f (hswc_body lhs)
153−#if __GLASGOW_HASKELL__ < 900
154−updateLHsSigWsType _ lhs = pure lhs
155−#endif
156−
157−updateLHsSigType :: Traversal' (LHsSigType GhcPs) (LHsType GhcPs)
158−updateLHsSigType f lhs@HsIB {} =
159− (\x -> lhs {hsib_body = x}) <$> f (hsib_body lhs)
160−#if __GLASGOW_HASKELL__ < 900
161−updateLHsSigType _ lhs = pure lhs
162−#endif
163−
164−updateLHsType :: Traversal' (LHsType GhcPs) (HsType GhcPs)
165−updateLHsType = traverse
40+
41+updateHsmodDecl :: LHsDecl GhcPs -> LHsDecl GhcPs
42+updateHsmodDecl = fmap updateHsDecl
43+
44+updateHsDecl :: HsDecl GhcPs -> HsDecl GhcPs
45+updateHsDecl (SigD xSig s) = SigD xSig (updateSig s)
46+updateHsDecl decl = decl
47+
48+updateSig :: Sig GhcPs -> Sig GhcPs
49+updateSig (TypeSig xSig ls t) = TypeSig xSig ls (updateLHsSigWcType t)
50+updateSig sig = sig
51+
52+updateLHsSigWcType :: LHsSigWcType GhcPs -> LHsSigWcType GhcPs
53+updateLHsSigWcType lhs@HsWC{} = lhs { hswc_body = updateLHsSigType (hswc_body lhs) }
54+updateLHsSigWcType lhs@XHsWildCardBndrs{} = lhs
55+
56+updateLHsSigType :: LHsSigType GhcPs -> LHsSigType GhcPs
57+updateLHsSigType lhs@HsIB{} = lhs { hsib_body = updateLHsType (hsib_body lhs )}
58+updateLHsSigType lhs@XHsImplicitBndrs{} = lhs
59+
60+updateLHsType :: LHsType GhcPs -> LHsType GhcPs
61+updateLHsType = fmap updateHsType
16662
16763-- Main process
168−updateHsType :: 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
173−updateHsType ty@HsTyVar {} =
174− flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
175−updateHsType ty@HsAppTy {} =
176− flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
177−updateHsType ty@HsFunTy {} =
178− flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
179−updateHsType ty@HsListTy {} =
180− flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
181−updateHsType ty@HsTupleTy {} =
182− flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
183−updateHsType ty = pure ty
184−
185−#if __GLASGOW_HASKELL__ < 810
186−xQualTy :: NoExt
187−xQualTy = noExt
188−#else
189−xQualTy :: NoExtField
190−xQualTy = NoExtField
191−#endif
192−
193−flagASTModified :: a -> (Any, a)
194−flagASTModified a = (Any True, a)
64+updateHsType :: HsType GhcPs -> HsType GhcPs
65+updateHsType ty@(HsQualTy xty ctxt body) = HsQualTy xty (fmap appendHSC ctxt) body
66+updateHsType ty@HsTyVar{} = HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
67+updateHsType ty@HsAppTy{} = HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
68+updateHsType ty@HsFunTy{} = HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
69+updateHsType ty@HsListTy{} = HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
70+updateHsType ty@HsTupleTy{} = HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
71+updateHsType ty = ty
19572
19673appendHSC :: HsContext GhcPs -> HsContext GhcPs
19774appendHSC cs = mkHSC : cs
19875
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−
20676-- make HasCallStack => constraint
20777mkHSC :: LHsType GhcPs
208−mkHSC = noLoc $ HsTyVar xQualTy NotPromoted lId
78+mkHSC = noLoc $ HsTyVar noExt NotPromoted lId
20979
21080lId :: Located (IdP GhcPs)
211−lId = noLoc $ mkRdrQual ghcStackModuleName $ mkClsOcc "HasCallStack"
81+lId = noLoc $ mkRdrUnqual $ mkClsOcc "HasCallStack"