update to current master againwip/T13904

3 files changed, 125 insertions, 3 deletions

diff --git a/testsuite/tests/plugins/simple-plugin/Simple/Plugin.hs b/testsuite/tests/plugins/simple-plugin/Simple/Plugin.hs
index e8c2435849..94cb74b151 100644
--- a/testsuite/tests/plugins/simple-plugin/Simple/Plugin.hs
+++ b/testsuite/tests/plugins/simple-plugin/Simple/Plugin.hs
@@ -16,14 +16,15 @@ import qualified Language.Haskell.TH as TH
 
 plugin :: Plugin
 plugin = defaultPlugin {
-    installCoreToDos = install
+    installCoreToDos = install,
+    pluginRecompile  = purePlugin
   }
 
 install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
 install options todos = do
     putMsgS $ "Simple Plugin Passes Queried"
     putMsgS $ "Got options: " ++ unwords options
-    
+
     -- Create some actual passes to continue the test.
     return $ CoreDoPluginPass "Main pass" mainPass
              : todos
@@ -36,7 +37,7 @@ findNameBind target (NonRec b e) = findNameBndr target b
 findNameBind target (Rec bes) = mconcat (map (findNameBndr target . fst) bes)
 
 findNameBndr :: String -> CoreBndr -> First Name
-findNameBndr target b 
+findNameBndr target b
   = if getOccString (varName b) == target
     then First (Just (varName b))
     else First Nothing
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..2d14eeaf85
--- /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 -> 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 _ 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..b9bdaeb37a
--- /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 = renamedAction
+                       }
+
+parsedPlugin :: [CommandLineOption] -> ModSummary -> HsParsedModule
+                  -> Hsc HsParsedModule
+parsedPlugin opts _ pm
+  = do liftIO $ putStrLn $ "parsePlugin(" ++ intercalate "," opts ++ ")"
+       return pm
+
+renamedAction :: [CommandLineOption]
+                    -> TcGblEnv -> HsGroup GhcRn
+                    -> TcM (TcGblEnv, HsGroup GhcRn)
+renamedAction _ env grp
+  = do liftIO $ putStrLn "typeCheckPlugin (rn)"
+       return (env, grp)
+
+typecheckPlugin :: [CommandLineOption] -> ModSummary -> TcGblEnv -> TcM 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