@@ -1,81 +1,211 @@
1+{-# LANGUAGE RankNTypes #-}
1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
2module StackTrace.Plugin (plugin) where
4module StackTrace.Plugin (plugin) where
6+import Control.Arrow (first)
7+import Data.Monoid (Any(Any, getAny))
8+import GHC.Types.SrcLoc
9+#if __GLASGOW_HASKELL__ >= 900
4import GhcPlugins
13import GhcPlugins
5−import TcRnTypes (IfM, TcM, TcGblEnv, tcg_binds, tcg_rn_decls)
14+#endif
6−import HsExtension (GhcTc, GhcRn)
15+#if __GLASGOW_HASKELL__ >= 810
7−import HsDecls (HsGroup)
16+import GHC.Hs
8−import HsExpr (LHsExpr)
17+#endif
18+#if __GLASGOW_HASKELL__ < 810
9import HsSyn
19import HsSyn
11−import Data.Maybe
22+type Traversal s t a b
23+ = forall f. Applicative f =>
24+ (a -> f b) -> s -> f t
26+type Traversal' s a = Traversal s s a a
13plugin :: Plugin
28plugin :: Plugin
14−plugin = defaultPlugin
15− { parsedResultAction = parsedPlugin
29+plugin = defaultPlugin {parsedResultAction = parsedPlugin, pluginRecompile = purePlugin}
18−parsedPlugin :: [CommandLineOption] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule
32+ [CommandLineOption] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule
19parsedPlugin _ _ pm = do
33parsedPlugin _ _ pm = do
20− dflags <- getDynFlags
22− let extract = hsmodImports . unLoc
23− addGHCStackMod = noLoc $ simpleImportDecl $ mkModuleName "GHC.Stack"
25− m = updateHsModule addGHCStackMod updateHsmodDecl <$> hpm_module pm
34+ let m = updateHsModule <$> hpm_module pm
26− pm' = pm { hpm_module = m }
35+ pm' = pm {hpm_module = m}
28 return pm'
36 return pm'
30−updateHsModule :: LImportDecl GhcPs -> (LHsDecl GhcPs -> LHsDecl GhcPs) -> HsModule GhcPs -> HsModule GhcPs
38+-- Use qualified import for GHC.Stack as "AutoImported.GHC.Stack"
31−updateHsModule importDecl update hsm = hsm
39+-- ...this should not interfere with other imports...
32− { hsmodImports = importDecl:decls
40+ghcStackModuleName :: ModuleName
33− , hsmodDecls = map update lhss
41+ghcStackModuleName = mkModuleName "AutoImported.GHC.Stack"
43+#if __GLASGOW_HASKELL__ < 810
44+importDeclQualified :: Bool
45+importDeclQualified = True
47+importDeclQualified :: ImportDeclQualifiedStyle
48+importDeclQualified = QualifiedPre
51+ghcStackImport :: Located (ImportDecl (GhcPass p))
54+ (simpleImportDecl $ mkModuleName "GHC.Stack")
55+ { ideclQualified = importDeclQualified, ideclAs = Just $ noLoc ghcStackModuleName }
36− decls = hsmodImports hsm
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
62+#if __GLASGOW_HASKELL__ >= 900
63+updateHsModule :: HsModule -> HsModule
65+updateHsModule :: HsModule GhcPs -> HsModule GhcPs
68+ hsm {hsmodImports = hsmodImports', hsmodDecls = hsmodDecls'}
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') =
37− lhss = hsmodDecls hsm
76+ (traverse . astTraversal) updateHsType (hsmodDecls hsm)
78+ -- Only import GHC.Stack if needed for a constraint we introduced
81+ then [ghcStackImport]
85+ astTraversal :: Traversal' (LHsDecl GhcPs) (HsType GhcPs)
86+ astTraversal = updateHsmodDecl
39--------------
92--------------
40−
93+updateHsmodDecl :: Traversal' (LHsDecl GhcPs) (HsDecl GhcPs)
41−updateHsmodDecl :: LHsDecl GhcPs -> LHsDecl GhcPs
94+updateHsmodDecl = traverse
42−updateHsmodDecl = fmap updateHsDecl
95+
43−
96+updateHsDecl :: Traversal' (HsDecl GhcPs) (LHsSigWcType GhcPs)
44−updateHsDecl :: HsDecl GhcPs -> HsDecl GhcPs
97+updateHsDecl f (SigD xSig s) = SigD xSig <$> updateSig f s
45−updateHsDecl (SigD xSig s) = SigD xSig (updateSig s)
98+updateHsDecl f (ValD xVal hsBind) = ValD xVal <$> updateHsBind f hsBind
46−updateHsDecl decl = decl
99+updateHsDecl _ sig = pure sig
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
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
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
114+updateLLMatch :: Traversal' (Located [LMatch GhcPs (LHsExpr GhcPs)]) (LHsSigWcType GhcPs)
115+updateLLMatch = updateLocated updateLMatches
117+updateLMatches :: Traversal' [LMatch GhcPs (LHsExpr GhcPs)] (LHsSigWcType GhcPs)
118+updateLMatches f = traverse (updateLocated updateMatch f)
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
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
132+updateLHsLocalBinds :: Traversal' (LHsLocalBinds GhcPs) (LHsSigWcType GhcPs)
133+updateLHsLocalBinds = updateLocated updateLocalBinds
135+updateLocalBinds :: Traversal' (HsLocalBinds GhcPs) (LHsSigWcType GhcPs)
136+updateLocalBinds f (HsValBinds xHsValBinds hsValBindsLR) = HsValBinds xHsValBinds <$> updateHsValBindsLR f hsValBindsLR
137+updateLocalBinds _ hsValBinds = pure hsValBinds
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
143+updateLSigs :: Traversal' [LSig GhcPs] (LHsSigWcType GhcPs)
144+updateLSigs f = traverse (updateLocated updateSig f)
48−updateSig :: Sig GhcPs -> Sig GhcPs
146+updateSig :: Traversal' (Sig GhcPs) (LHsSigWcType GhcPs)
49−updateSig (TypeSig xSig ls t) = TypeSig xSig ls (updateLHsSigWcType t)
147+updateSig f (TypeSig xSig ls t) = TypeSig xSig ls <$> f t
50−updateSig sig = sig
148+updateSig _ sig = pure sig
52−updateLHsSigWcType :: LHsSigWcType GhcPs -> LHsSigWcType GhcPs
150+updateLHsSigWsType :: Traversal' (LHsSigWcType GhcPs) (LHsSigType GhcPs)
151+updateLHsSigWsType f lhs@HsWC {} =
53−updateLHsSigWcType lhs@HsWC{} = lhs { hswc_body = updateLHsSigType (hswc_body lhs) }
152+ (\x -> lhs {hswc_body = x}) <$> f (hswc_body lhs)
54−updateLHsSigWcType lhs@XHsWildCardBndrs{} = lhs
153+#if __GLASGOW_HASKELL__ < 900
55−
154+updateLHsSigWsType _ lhs = pure lhs
56−updateLHsSigType :: LHsSigType GhcPs -> LHsSigType GhcPs
157+updateLHsSigType :: Traversal' (LHsSigType GhcPs) (LHsType GhcPs)
158+updateLHsSigType f lhs@HsIB {} =
57−updateLHsSigType lhs@HsIB{} = lhs { hsib_body = updateLHsType (hsib_body lhs )}
159+ (\x -> lhs {hsib_body = x}) <$> f (hsib_body lhs)
160+#if __GLASGOW_HASKELL__ < 900
58−updateLHsSigType lhs@XHsImplicitBndrs{} = lhs
161+updateLHsSigType _ lhs = pure lhs
60−updateLHsType :: LHsType GhcPs -> LHsType GhcPs
164+updateLHsType :: Traversal' (LHsType GhcPs) (HsType GhcPs)
61−updateLHsType = fmap updateHsType
165+updateLHsType = traverse
63-- Main process
167-- Main process
64−updateHsType :: HsType GhcPs -> HsType GhcPs
168+updateHsType :: HsType GhcPs -> (Any, HsType GhcPs)
65−updateHsType ty@(HsQualTy xty ctxt body) = HsQualTy xty (fmap appendHSC ctxt) body
169+updateHsType ty@(HsQualTy xty ctxt body) =
170+ if hasHasCallStack (unLoc ctxt)
172+ else flagASTModified $ HsQualTy xty (fmap appendHSC ctxt) body
66−updateHsType ty@HsTyVar{} = HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
173+updateHsType ty@HsTyVar {} =
174+ flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
67−updateHsType ty@HsAppTy{} = HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
175+updateHsType ty@HsAppTy {} =
176+ flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
68−updateHsType ty@HsFunTy{} = HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
177+updateHsType ty@HsFunTy {} =
178+ flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
69−updateHsType ty@HsListTy{} = HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
179+updateHsType ty@HsListTy {} =
180+ flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
70−updateHsType ty@HsTupleTy{} = HsQualTy noExt (noLoc $ appendHSC []) (noLoc ty)
181+updateHsType ty@HsTupleTy {} =
182+ flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
71−updateHsType ty = ty
183+updateHsType ty = pure ty
185+#if __GLASGOW_HASKELL__ < 810
189+xQualTy :: NoExtField
193+flagASTModified :: a -> (Any, a)
194+flagASTModified a = (Any True, a)
73appendHSC :: HsContext GhcPs -> HsContext GhcPs
196appendHSC :: HsContext GhcPs -> HsContext GhcPs
74appendHSC cs = mkHSC : cs
197appendHSC cs = mkHSC : cs
199+hasHasCallStack :: HsContext GhcPs -> Bool
200+hasHasCallStack = any (checkHsType . unLoc)
202+ checkHsType :: HsType GhcPs -> Bool
203+ checkHsType (HsTyVar _ _ lid) = unLoc lid == (mkRdrUnqual $ mkClsOcc "HasCallStack")
204+ checkHsType _ = False
76-- make HasCallStack => constraint
206-- make HasCallStack => constraint
77mkHSC :: LHsType GhcPs
207mkHSC :: LHsType GhcPs
78−mkHSC = noLoc $ HsTyVar noExt NotPromoted lId
208+mkHSC = noLoc $ HsTyVar xQualTy NotPromoted lId
80lId :: Located (IdP GhcPs)
210lId :: Located (IdP GhcPs)
81−lId = noLoc $ mkRdrUnqual $ mkClsOcc "HasCallStack"
211+lId = noLoc $ mkRdrQual ghcStackModuleName $ mkClsOcc "HasCallStack"