blob: 24ed240cfc8eafd3f8719bd81833dd56750e5d91 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
|
{-# LANGUAGE TypeFamilies, FlexibleContexts #-}
module Simple.RemovePlugin where
import Control.Monad.IO.Class
import Data.List (intercalate)
import GHC.Driver.Plugins
import GHC.Plugins
import GHC.Data.Bag
import GHC.Tc.Types
import Language.Haskell.Syntax.Extension
import GHC.Hs.Expr
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Types.SrcLoc
import GHC.Hs
import GHC.Hs.Binds
import GHC.Types.Name.Occurrence
import GHC.Types.Name.Reader
import GHC.Types.Name
import GHC.Types.Avail
import GHC.Hs.Dump
plugin :: Plugin
plugin = defaultPlugin { parsedResultAction = parsedPlugin
, typeCheckResultAction = typecheckPlugin
, spliceRunAction = metaPlugin'
, interfaceLoadAction = interfaceLoadPlugin'
}
parsedPlugin :: [CommandLineOption] -> ModSummary
-> ParsedResult -> Hsc ParsedResult
parsedPlugin [name, "parse"] _ (ParsedResult pm msgs)
= return (ParsedResult pm { hpm_module = removeParsedBinding name (hpm_module pm) } msgs)
parsedPlugin _ _ parsed = return parsed
removeParsedBinding :: String -> Located HsModule
-> Located HsModule
removeParsedBinding name (L l m)
= (L l (m { hsmodDecls = filter (notNamedAs name) (hsmodDecls m) } ))
where notNamedAs name (L _ (ValD _ (FunBind { fun_id = L _ fid })))
= occNameString (rdrNameOcc fid) /= name
notNamedAs _ _ = True
typecheckPlugin :: [CommandLineOption] -> ModSummary -> TcGblEnv -> TcM TcGblEnv
typecheckPlugin [name, "typecheck"] _ tc
= return $ tc { tcg_exports = filter (availNotNamedAs name) (tcg_exports tc)
, tcg_binds = filterBag (notNamedAs name) (tcg_binds tc)
}
where notNamedAs name (L _ FunBind { fun_id = L _ fid })
= occNameString (getOccName fid) /= name
notNamedAs name (L _ (XHsBindsLR (AbsBinds { abs_binds = bnds })))
= all (notNamedAs name) bnds
notNamedAs _ (L _ b) = True
typecheckPlugin _ _ tc = return tc
metaPlugin' :: [CommandLineOption] -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
metaPlugin' [name, "meta"] (L l (XExpr (WrapExpr (HsWrap w (HsPar _ _ (L _ (HsApp noExt (L _ (HsVar _ (L _ id))) e)) _ )))))
| occNameString (getOccName id) == name
= return (L l (XExpr (WrapExpr (HsWrap w (unLoc e)))))
-- The test should always match this first case. If the desugaring changes
-- again in the future then the panic is more useful than the previous
-- inscrutable failure.
metaPlugin' _ meta = pprPanic "meta" (showAstData BlankSrcSpan BlankEpAnnotations meta)
interfaceLoadPlugin' :: [CommandLineOption] -> ModIface -> IfM lcl ModIface
interfaceLoadPlugin' [name, "interface"] iface
= return $ iface { mi_exports = filter (availNotNamedAs name)
(mi_exports iface)
}
interfaceLoadPlugin' _ iface = return iface
availNotNamedAs :: String -> AvailInfo -> Bool
availNotNamedAs name avail
= occNameString (getOccName (availName avail)) /= name
|
