git.iko.soy/typeable/haskell-stack-trace-plugin
on b96a3bb help sign in
typeable/haskell-stack-trace-plugin/src/StackTrace/Plugin.hs
205 lines 7.0 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))
8#if __GLASGOW_HASKELL__ >= 900
9import GHC.Plugins
10#else
12import GhcPlugins
13#endif
14#if __GLASGOW_HASKELL__ >= 810
15import GHC.Hs
16#endif
17#if __GLASGOW_HASKELL__ < 810
18import HsSyn
19#endif
21type Traversal s t a b
22 = forall f. Applicative f =>
23 (a -> f b) -> s -> f t
25type Traversal' s a = Traversal s s a a
27plugin :: Plugin
28plugin = defaultPlugin {parsedResultAction = parsedPlugin, pluginRecompile = purePlugin}
30parsedPlugin ::
31 [CommandLineOption] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule
32parsedPlugin _ _ pm = do
33 let m = updateHsModule <$> hpm_module pm
34 pm' = pm {hpm_module = m}
35 return pm'
37-- Use qualified import for GHC.Stack as "AutoImported.GHC.Stack"
38-- ...this should not interfere with other imports...
39ghcStackModuleName :: ModuleName
40ghcStackModuleName = mkModuleName "AutoImported.GHC.Stack"
42#if __GLASGOW_HASKELL__ < 810
43importDeclQualified :: Bool
44importDeclQualified = True
45#else
46importDeclQualified :: ImportDeclQualifiedStyle
47importDeclQualified = QualifiedPre
48#endif
50ghcStackImport :: Located (ImportDecl (GhcPass p))
51ghcStackImport =
52 noLoc $
53 (simpleImportDecl $ mkModuleName "GHC.Stack")
54 {ideclQualified = importDeclQualified, ideclAs = Just $ noLoc ghcStackModuleName}
56#if __GLASGOW_HASKELL__ >= 900
57updateHsModule :: HsModule -> HsModule
58#else
59updateHsModule :: HsModule GhcPs -> HsModule GhcPs
60#endif
61updateHsModule hsm =
62 hsm {hsmodImports = hsmodImports', hsmodDecls = hsmodDecls'}
63 where
64 -- Traverse the haskell AST; if we have to add some HasStack
65 -- constraint we set a flag in a (Any,) functor.
66 -- ...it'd be simpler to check if before == after, but Haskell AST
67 -- doesn't have Eq instances.
68 (updatedP, hsmodDecls') =
69 first getAny $
70 (traverse . astTraversal) updateHsType (hsmodDecls hsm)
72 -- Only import GHC.Stack if needed for a constraint we introduced
73 hsmodImports' =
74 (if updatedP
75 then [ghcStackImport]
76 else []) ++
77 hsmodImports hsm
79 astTraversal :: Traversal' (LHsDecl GhcPs) (HsType GhcPs)
80 astTraversal = updateHsmodDecl
81 . updateHsDecl
82 . updateLHsSigWsType
83 . updateLHsSigType
84 . updateLHsType
86--------------
87updateHsmodDecl :: Traversal' (LHsDecl GhcPs) (HsDecl GhcPs)
88updateHsmodDecl = traverse
90updateHsDecl :: Traversal' (HsDecl GhcPs) (LHsSigWcType GhcPs)
91updateHsDecl f (SigD xSig s) = SigD xSig <$> updateSig f s
92updateHsDecl f (ValD xVal hsBind) = ValD xVal <$> updateHsBind f hsBind
93updateHsDecl _ sig = pure sig
95updateHsBind :: Traversal' (HsBind GhcPs) (LHsSigWcType GhcPs)
96updateHsBind f bind@FunBind {} = (\x -> bind {fun_matches = x}) <$> updateMatchGroup f (fun_matches bind)
97updateHsBind _ bind = pure bind
99updateMatchGroup :: Traversal' (MatchGroup GhcPs (LHsExpr GhcPs)) (LHsSigWcType GhcPs)
100updateMatchGroup f mg@MG {} = (\x -> mg {mg_alts = x}) <$> updateLLMatch f (mg_alts mg)
101#if __GLASGOW_HASKELL__ < 900
102updateMatchGroup _ mg = pure mg
103#endif
105updateLocated :: Functor f => (a -> b -> f c) -> a -> Located b -> f (Located c)
106updateLocated f g (L l e) = L l <$> f g e
108updateLLMatch :: Traversal' (Located [LMatch GhcPs (LHsExpr GhcPs)]) (LHsSigWcType GhcPs)
109updateLLMatch = updateLocated updateLMatches
111updateLMatches :: Traversal' [LMatch GhcPs (LHsExpr GhcPs)] (LHsSigWcType GhcPs)
112updateLMatches f = traverse (updateLocated updateMatch f)
114updateMatch :: Traversal' (Match GhcPs (LHsExpr GhcPs)) (LHsSigWcType GhcPs)
115updateMatch f m@Match {} = (\x -> m {m_grhss = x}) <$> updateGrhss f (m_grhss m)
116#if __GLASGOW_HASKELL__ < 900
117updateMatch _ m = pure m
118#endif
120updateGrhss :: Traversal' (GRHSs GhcPs (LHsExpr GhcPs)) (LHsSigWcType GhcPs)
121updateGrhss f grhss@GRHSs {} = (\x -> grhss {grhssLocalBinds = x}) <$> updateLHsLocalBinds f (grhssLocalBinds grhss)
122#if __GLASGOW_HASKELL__ < 900
123updateGrhss _ grhss = pure grhss
124#endif
126updateLHsLocalBinds :: Traversal' (LHsLocalBinds GhcPs) (LHsSigWcType GhcPs)
127updateLHsLocalBinds = updateLocated updateLocalBinds
129updateLocalBinds :: Traversal' (HsLocalBinds GhcPs) (LHsSigWcType GhcPs)
130updateLocalBinds f (HsValBinds xHsValBinds hsValBindsLR) = HsValBinds xHsValBinds <$> updateHsValBindsLR f hsValBindsLR
131updateLocalBinds _ hsValBinds = pure hsValBinds
133updateHsValBindsLR :: Traversal' (HsValBindsLR GhcPs GhcPs) (LHsSigWcType GhcPs)
134updateHsValBindsLR f (ValBinds xValBinds lHsBindsLR lSigs) = ValBinds xValBinds lHsBindsLR <$> updateLSigs f lSigs
135updateHsValBindsLR _ valBinds = pure valBinds
137updateLSigs :: Traversal' [LSig GhcPs] (LHsSigWcType GhcPs)
138updateLSigs f = traverse (updateLocated updateSig f)
140updateSig :: Traversal' (Sig GhcPs) (LHsSigWcType GhcPs)
141updateSig f (TypeSig xSig ls t) = TypeSig xSig ls <$> f t
142updateSig _ sig = pure sig
144updateLHsSigWsType :: Traversal' (LHsSigWcType GhcPs) (LHsSigType GhcPs)
145updateLHsSigWsType f lhs@HsWC {} =
146 (\x -> lhs {hswc_body = x}) <$> f (hswc_body lhs)
147#if __GLASGOW_HASKELL__ < 900
148updateLHsSigWsType _ lhs = pure lhs
149#endif
151updateLHsSigType :: Traversal' (LHsSigType GhcPs) (LHsType GhcPs)
152updateLHsSigType f lhs@HsIB {} =
153 (\x -> lhs {hsib_body = x}) <$> f (hsib_body lhs)
154#if __GLASGOW_HASKELL__ < 900
155updateLHsSigType _ lhs = pure lhs
156#endif
158updateLHsType :: Traversal' (LHsType GhcPs) (HsType GhcPs)
159updateLHsType = traverse
161-- Main process
162updateHsType :: HsType GhcPs -> (Any, HsType GhcPs)
163updateHsType ty@(HsQualTy xty ctxt body) =
164 if hasHasCallStack (unLoc ctxt)
165 then pure ty
166 else flagASTModified $ HsQualTy xty (fmap appendHSC ctxt) body
167updateHsType ty@HsTyVar {} =
168 flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
169updateHsType ty@HsAppTy {} =
170 flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
171updateHsType ty@HsFunTy {} =
172 flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
173updateHsType ty@HsListTy {} =
174 flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
175updateHsType ty@HsTupleTy {} =
176 flagASTModified $ HsQualTy xQualTy (noLoc $ appendHSC []) (noLoc ty)
177updateHsType ty = pure ty
179#if __GLASGOW_HASKELL__ < 810
180xQualTy :: NoExt
181xQualTy = noExt
182#else
183xQualTy :: NoExtField
184xQualTy = NoExtField
185#endif
187flagASTModified :: a -> (Any, a)
188flagASTModified a = (Any True, a)
190appendHSC :: HsContext GhcPs -> HsContext GhcPs
191appendHSC cs = mkHSC : cs
193hasHasCallStack :: HsContext GhcPs -> Bool
194hasHasCallStack = any (checkHsType . unLoc)
195 where
196 checkHsType :: HsType GhcPs -> Bool
197 checkHsType (HsTyVar _ _ lid) = unLoc lid == (mkRdrUnqual $ mkClsOcc "HasCallStack")
198 checkHsType _ = False
200-- make HasCallStack => constraint
201mkHSC :: LHsType GhcPs
202mkHSC = noLoc $ HsTyVar xQualTy NotPromoted lId
204lId :: Located (IdP GhcPs)
205lId = noLoc $ mkRdrQual ghcStackModuleName $ mkClsOcc "HasCallStack"