Extended the plugin system to run plugins on more representations

Extend GHC plugins to access parsed, type checked representation,
interfaces that are loaded. And splices that are evaluated. The goal is
to enable development tools to access the GHC representation in the
pre-existing build environment.

See the full proposal here:
https://ghc.haskell.org/trac/ghc/wiki/ExtendedPluginsProposal

Reviewers: goldfire, bgamari, ezyang, angerman, mpickering

Reviewed By: mpickering

Subscribers: ezyang, angerman, mpickering, ulysses4ever, rwbarton, thomie, carter

GHC Trac Issues: #14709

Differential Revision: https://phabricator.haskell.org/D4342

2 files changed, 121 insertions, 0 deletions

diff --git a/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs b/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs
new file mode 100644
index 0000000000..c64b62f8a7
--- /dev/null
+++ b/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs
@@ -0,0 +1,69 @@
+{-# LANGUAGE TypeFamilies, FlexibleContexts #-}
+module Simple.RemovePlugin where
+
+import Control.Monad.IO.Class
+import Data.List (intercalate)
+import Plugins
+import Bag
+import HscTypes
+import TcRnTypes
+import HsExtension
+import HsExpr
+import Outputable
+import SrcLoc
+import HsSyn
+import HsBinds
+import OccName
+import RdrName
+import Name
+import Avail
+
+plugin :: Plugin
+plugin = defaultPlugin { parsedResultAction = parsedPlugin
+                       , typeCheckResultAction = typecheckPlugin
+                       , spliceRunAction = metaPlugin'
+                       , interfaceLoadAction = interfaceLoadPlugin'
+                       }
+
+parsedPlugin :: [CommandLineOption] -> ModSummary -> HsParsedModule
+                  -> Hsc HsParsedModule
+parsedPlugin [name, "parse"] _ pm
+  = return $ pm { hpm_module = removeParsedBinding name (hpm_module pm) }
+parsedPlugin _ _ pm = return pm
+
+removeParsedBinding :: String -> Located (HsModule GhcPs)
+                         -> Located (HsModule GhcPs)
+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 -> Hsc 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 _ 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 _ (HsApp noExt (L l (HsVar _ (L _ id))) e))
+  | occNameString (getOccName id) == name
+  = return e
+metaPlugin' _ meta = return 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
diff --git a/testsuite/tests/plugins/simple-plugin/Simple/SourcePlugin.hs b/testsuite/tests/plugins/simple-plugin/Simple/SourcePlugin.hs
new file mode 100644
index 0000000000..d5c9dd1856
--- /dev/null
+++ b/testsuite/tests/plugins/simple-plugin/Simple/SourcePlugin.hs
@@ -0,0 +1,52 @@
+module Simple.SourcePlugin where
+
+import Control.Monad.IO.Class
+import Data.List (intercalate)
+import Data.Maybe (isJust)
+import Plugins
+import HscTypes
+import TcRnTypes
+import HsExtension
+import Avail
+import HsExpr
+import Outputable
+import HsImpExp
+import HsDecls
+import HsDoc
+
+plugin :: Plugin
+plugin = defaultPlugin { parsedResultAction = parsedPlugin
+                       , typeCheckResultAction = typecheckPlugin
+                       , spliceRunAction = metaPlugin'
+                       , interfaceLoadAction = interfaceLoadPlugin'
+                       , renamedResultAction = Just renamedAction
+                       }
+
+parsedPlugin :: [CommandLineOption] -> ModSummary -> HsParsedModule
+                  -> Hsc HsParsedModule
+parsedPlugin opts _ pm
+  = do liftIO $ putStrLn $ "parsePlugin(" ++ intercalate "," opts ++ ")"
+       return pm
+
+renamedAction :: [CommandLineOption] -> ModSummary
+                    -> ( HsGroup GhcRn, [LImportDecl GhcRn]
+                       , Maybe [(LIE GhcRn, Avails)], Maybe LHsDocString )
+                    -> Hsc ()
+renamedAction _ _ ( gr, _, _, _ )
+  = liftIO $ putStrLn "typeCheckPlugin (rn)"
+
+typecheckPlugin :: [CommandLineOption] -> ModSummary -> TcGblEnv -> Hsc TcGblEnv
+typecheckPlugin _ _ tc
+  = do liftIO $ putStrLn "typeCheckPlugin (tc)"
+       return tc
+
+metaPlugin' :: [CommandLineOption] -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)
+metaPlugin' _ meta
+  = do liftIO $ putStrLn $ "metaPlugin: " ++ (showSDocUnsafe $ ppr meta)
+       return meta
+
+interfaceLoadPlugin' :: [CommandLineOption] -> ModIface -> IfM lcl ModIface
+interfaceLoadPlugin' _ iface
+  = do liftIO $ putStrLn $ "interfacePlugin: "
+                              ++ (showSDocUnsafe $ ppr $ mi_module iface)
+       return iface