git.iko.soy/typeable/haskell-stack-trace-plugin
on master help sign in
typeable/haskell-stack-trace-plugin/src/StackTrace/Plugin.hs
211 lines 7.4 kB history raw
1{-# LANGUAGE RankNTypes #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE CPP #-}
4module StackTrace.Plugin (plugin) where
6import Control.Arrow (first)
7import Data.Monoid (Any(Any, getAny))
8import GHC.Types.SrcLoc
9#if __GLASGOW_HASKELL__ >= 900
10import GHC.Plugins
11#else
13import GhcPlugins
14#endif
15#if __GLASGOW_HASKELL__ >= 810
16import GHC.Hs
17#endif
18#if __GLASGOW_HASKELL__ < 810
19import HsSyn
20#endif
22type Traversal s t a b
23 = forall f. Applicative f =>
24 (a -> f b) -> s -> f t
26type Traversal' s a = Traversal s s a a
28plugin :: Plugin
29plugin = defaultPlugin {parsedResultAction = parsedPlugin, pluginRecompile = purePlugin}
31parsedPlugin ::
32 [CommandLineOption] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule
33parsedPlugin _ _ pm = do
34 let m = updateHsModule <$> hpm_module pm
35 pm' = pm {hpm_module = m}
36 return pm'
38-- Use qualified import for GHC.Stack as "AutoImported.GHC.Stack"
39-- ...this should not interfere with other imports...
40ghcStackModuleName :: ModuleName
41ghcStackModuleName = mkModuleName "AutoImported.GHC.Stack"
43#if __GLASGOW_HASKELL__ < 810
44importDeclQualified :: Bool
45importDeclQualified = True
46#else
47importDeclQualified :: ImportDeclQualifiedStyle
48importDeclQualified = QualifiedPre
49#endif
51ghcStackImport :: Located (ImportDecl (GhcPass p))
52ghcStackImport =
53 L srcSpan $
54 (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
62#if __GLASGOW_HASKELL__ >= 900
63updateHsModule :: HsModule -> HsModule
64#else
65updateHsModule :: HsModule GhcPs -> HsModule GhcPs
66#endif
67updateHsModule 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)
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
85 astTraversal :: Traversal' (LHsDecl GhcPs) (HsType GhcPs)
86 astTraversal = updateHsmodDecl
87 . updateHsDecl
88 . updateLHsSigWsType
89 . updateLHsSigType
90 . updateLHsType
92--------------
93updateHsmodDecl :: Traversal' (LHsDecl GhcPs) (HsDecl GhcPs)
94updateHsmodDecl = traverse
96updateHsDecl :: Traversal' (HsDecl GhcPs) (LHsSigWcType GhcPs)
97updateHsDecl f (SigD xSig s) = SigD xSig <$> updateSig f s
98updateHsDecl f (ValD xVal hsBind) = ValD xVal <$> updateHsBind f hsBind
99updateHsDecl _ sig = pure sig
101updateHsBind :: Traversal' (HsBind GhcPs) (LHsSigWcType GhcPs)
102updateHsBind f bind@FunBind {} = (\x -> bind {fun_matches = x}) <$> updateMatchGroup f (fun_matches bind)
103updateHsBind _ bind = pure bind
105updateMatchGroup :: Traversal' (MatchGroup GhcPs (LHsExpr GhcPs)) (LHsSigWcType GhcPs)
106updateMatchGroup f mg@MG {} = (\x -> mg {mg_alts = x}) <$> updateLLMatch f (mg_alts mg)
107#if __GLASGOW_HASKELL__ < 900
108updateMatchGroup _ mg = pure mg
109#endif
111updateLocated :: Functor f => (a -> b -> f c) -> a -> Located b -> f (Located c)
112updateLocated f g (L l e) = L l <$> f g e
114updateLLMatch :: Traversal' (Located [LMatch GhcPs (LHsExpr GhcPs)]) (LHsSigWcType GhcPs)
115updateLLMatch = updateLocated updateLMatches
117updateLMatches :: Traversal' [LMatch GhcPs (LHsExpr GhcPs)] (LHsSigWcType GhcPs)
118updateLMatches f = traverse (updateLocated updateMatch f)
120updateMatch :: Traversal' (Match GhcPs (LHsExpr GhcPs)) (LHsSigWcType GhcPs)
121updateMatch f m@Match {} = (\x -> m {m_grhss = x}) <$> updateGrhss f (m_grhss m)
122#if __GLASGOW_HASKELL__ < 900
123updateMatch _ m = pure m
124#endif
126updateGrhss :: Traversal' (GRHSs GhcPs (LHsExpr GhcPs)) (LHsSigWcType GhcPs)
127updateGrhss f grhss@GRHSs {} = (\x -> grhss {grhssLocalBinds = x}) <$> updateLHsLocalBinds f (grhssLocalBinds grhss)
128#if __GLASGOW_HASKELL__ < 900
129updateGrhss _ grhss = pure grhss
130#endif
132updateLHsLocalBinds :: Traversal' (LHsLocalBinds GhcPs) (LHsSigWcType GhcPs)
133updateLHsLocalBinds = updateLocated updateLocalBinds
135updateLocalBinds :: Traversal' (HsLocalBinds GhcPs) (LHsSigWcType GhcPs)
136updateLocalBinds f (HsValBinds xHsValBinds hsValBindsLR) = HsValBinds xHsValBinds <$> updateHsValBindsLR f hsValBindsLR
137updateLocalBinds _ hsValBinds = pure hsValBinds
139updateHsValBindsLR :: Traversal' (HsValBindsLR GhcPs GhcPs) (LHsSigWcType GhcPs)
140updateHsValBindsLR f (ValBinds xValBinds lHsBindsLR lSigs) = ValBinds xValBinds lHsBindsLR <$> updateLSigs f lSigs
141updateHsValBindsLR _ valBinds = pure valBinds
143updateLSigs :: Traversal' [LSig GhcPs] (LHsSigWcType GhcPs)
144updateLSigs f = traverse (updateLocated updateSig f)
146updateSig :: Traversal' (Sig GhcPs) (LHsSigWcType GhcPs)
147updateSig f (TypeSig xSig ls t) = TypeSig xSig ls <$> f t
148updateSig _ sig = pure sig
150updateLHsSigWsType :: Traversal' (LHsSigWcType GhcPs) (LHsSigType GhcPs)
151updateLHsSigWsType f lhs@HsWC {} =
152 (\x -> lhs {hswc_body = x}) <$> f (hswc_body lhs)
153#if __GLASGOW_HASKELL__ < 900
154updateLHsSigWsType _ lhs = pure lhs
155#endif
157updateLHsSigType :: Traversal' (LHsSigType GhcPs) (LHsType GhcPs)
158updateLHsSigType f lhs@HsIB {} =
159 (\x -> lhs {hsib_body = x}) <$> f (hsib_body lhs)
160#if __GLASGOW_HASKELL__ < 900
161updateLHsSigType _ lhs = pure lhs
162#endif
164updateLHsType :: Traversal' (LHsType GhcPs) (HsType GhcPs)
165updateLHsType = traverse
167-- Main process
168updateHsType :: HsType GhcPs -> (Any, HsType GhcPs)
169updateHsType ty@(HsQualTy xty ctxt body) =
170 if hasHasCallStack (unLoc ctxt)
171 then pure ty
172 else flagASTModified $ HsQualTy xty (fmap appendHSC ctxt) body
173updateHsType ty@HsTyVar {} =
174 flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
175updateHsType ty@HsAppTy {} =
176 flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
177updateHsType ty@HsFunTy {} =
178 flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
179updateHsType ty@HsListTy {} =
180 flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
181updateHsType ty@HsTupleTy {} =
182 flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
183updateHsType ty = pure ty
185#if __GLASGOW_HASKELL__ < 810
186xQualTy :: NoExt
187xQualTy = noExt
188#else
189xQualTy :: NoExtField
190xQualTy = NoExtField
191#endif
193flagASTModified :: a -> (Any, a)
194flagASTModified a = (Any True, a)
196appendHSC :: HsContext GhcPs -> HsContext GhcPs
197appendHSC cs = mkHSC : cs
199hasHasCallStack :: HsContext GhcPs -> Bool
200hasHasCallStack = any (checkHsType . unLoc)
201 where
202 checkHsType :: HsType GhcPs -> Bool
203 checkHsType (HsTyVar _ _ lid) = unLoc lid == (mkRdrUnqual $ mkClsOcc "HasCallStack")
204 checkHsType _ = False
206-- make HasCallStack => constraint
207mkHSC :: LHsType GhcPs
208mkHSC = noLoc $ HsTyVar xQualTy NotPromoted lId
210lId :: Located (IdP GhcPs)
211lId = noLoc $ mkRdrQual ghcStackModuleName $ mkClsOcc "HasCallStack"