Support registering Plugins through the GHC API

This allows tooling using the GHC API to use plugins internally.
Hopefully this will make it possible to decouple the development of
useful plugins from (currently) kitchen-sink type tooling projects
such as ghc-mod or HIE -- at least to some extent.

Test Plan: validate

Reviewers: bgamari, mpickering

Subscribers: mpickering, alanz, rwbarton, carter

GHC Trac Issues: #15826

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

11 files changed, 178 insertions, 36 deletions

diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs
index 0ed35f2d4c..aa24ee0a5d 100644
--- a/compiler/deSugar/Desugar.hs
+++ b/compiler/deSugar/Desugar.hs
@@ -169,7 +169,7 @@ deSugar hsc_env
 
         ; let used_names = mkUsedNames tcg_env
               pluginModules =
-                map lpModule (plugins (hsc_dflags hsc_env))
+                map lpModule (cachedPlugins (hsc_dflags hsc_env))
         ; deps <- mkDependencies (thisInstalledUnitId (hsc_dflags hsc_env))
                                  (map mi_module pluginModules) tcg_env
 
diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs
index aba14baa2d..7b66472d7a 100644
--- a/compiler/iface/MkIface.hs
+++ b/compiler/iface/MkIface.hs
@@ -119,7 +119,8 @@ import Data.Ord
 import Data.IORef
 import System.Directory
 import System.FilePath
-import Plugins ( PluginRecompile(..), Plugin(..), LoadedPlugin(..))
+import Plugins ( PluginRecompile(..), PluginWithArgs(..), LoadedPlugin(..),
+                 pluginRecompile', plugins )
 
 --Qualified import so we can define a Semigroup instance
 -- but it doesn't clash with Outputable.<>
@@ -189,7 +190,7 @@ mkIfaceTc hsc_env maybe_old_fingerprint safe_mode mod_details
   = do
           let used_names = mkUsedNames tc_result
           let pluginModules =
-                map lpModule (plugins (hsc_dflags hsc_env))
+                map lpModule (cachedPlugins (hsc_dflags hsc_env))
           deps <- mkDependencies
                     (thisInstalledUnitId (hsc_dflags hsc_env))
                     (map mi_module pluginModules) tc_result
@@ -1324,17 +1325,16 @@ checkPlugins :: HscEnv -> ModIface -> IfG RecompileRequired
 checkPlugins hsc iface = liftIO $ do
   -- [(ModuleName, Plugin, [Opts])]
   let old_fingerprint = mi_plugin_hash iface
-      loaded_plugins = plugins (hsc_dflags hsc)
-  res <- mconcat <$> mapM checkPlugin loaded_plugins
+  res <- mconcat <$> mapM pluginRecompile' (plugins (hsc_dflags hsc))
   return (pluginRecompileToRecompileRequired old_fingerprint res)
 
 fingerprintPlugins :: HscEnv -> IO Fingerprint
 fingerprintPlugins hsc_env = do
-  fingerprintPlugins' (plugins (hsc_dflags hsc_env))
+  fingerprintPlugins' $ plugins(hsc_dflags hsc_env)
 
-fingerprintPlugins' :: [LoadedPlugin] -> IO Fingerprint
+fingerprintPlugins' :: [PluginWithArgs] -> IO Fingerprint
 fingerprintPlugins' plugins = do
-  res <- mconcat <$> mapM checkPlugin plugins
+  res <- mconcat <$> mapM pluginRecompile' plugins
   return $ case res of
       NoForceRecompile ->  fingerprintString "NoForceRecompile"
       ForceRecompile   -> fingerprintString "ForceRecompile"
@@ -1344,10 +1344,6 @@ fingerprintPlugins' plugins = do
       (MaybeRecompile fp) -> fp
 
 
-
-checkPlugin :: LoadedPlugin -> IO PluginRecompile
-checkPlugin (LoadedPlugin plugin _ opts) = pluginRecompile plugin opts
-
 pluginRecompileToRecompileRequired :: Fingerprint -> PluginRecompile -> RecompileRequired
 pluginRecompileToRecompileRequired old_fp pr =
   case pr of
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 3fb3874c63..48c7103dd9 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -984,12 +984,18 @@ data DynFlags = DynFlags {
   frontendPluginOpts    :: [String],
     -- ^ the @-ffrontend-opt@ flags given on the command line, in *reverse*
     -- order that they're specified on the command line.
-  plugins               :: [LoadedPlugin],
-    -- ^ plugins loaded after processing arguments. What will be loaded here
-    -- is directed by pluginModNames. Arguments are loaded from
+  cachedPlugins         :: [LoadedPlugin],
+    -- ^ plugins dynamically loaded after processing arguments. What will be
+    -- loaded here is directed by pluginModNames. Arguments are loaded from
     -- pluginModNameOpts. The purpose of this field is to cache the plugins so
-    -- they don't have to be loaded each time they are needed.
-    -- See 'DynamicLoading.initializePlugins'.
+    -- they don't have to be loaded each time they are needed.  See
+    -- 'DynamicLoading.initializePlugins'.
+  staticPlugins            :: [StaticPlugin],
+    -- ^ staic plugins which do not need dynamic loading. These plugins are
+    -- intended to be added by GHC API users directly to this list.
+    --
+    -- To add dynamically loaded plugins through the GHC API see
+    -- 'addPluginModuleName' instead.
 
   -- GHC API hooks
   hooks                 :: Hooks,
@@ -1917,7 +1923,8 @@ defaultDynFlags mySettings (myLlvmTargets, myLlvmPasses) =
         pluginModNames          = [],
         pluginModNameOpts       = [],
         frontendPluginOpts      = [],
-        plugins                 = [],
+        cachedPlugins           = [],
+        staticPlugins           = [],
         hooks                   = emptyHooks,
 
         outputFile              = Nothing,
diff --git a/compiler/main/DynamicLoading.hs b/compiler/main/DynamicLoading.hs
index 7420f7cc01..0a5264e3f2 100644
--- a/compiler/main/DynamicLoading.hs
+++ b/compiler/main/DynamicLoading.hs
@@ -83,13 +83,15 @@ initializePlugins _ df
        return df
 #else
 initializePlugins hsc_env df
-  | map lpModuleName (plugins df) == pluginModNames df -- plugins not changed
-     && all (\p -> lpArguments p == argumentsForPlugin p (pluginModNameOpts df))
-            (plugins df) -- arguments not changed
+  | map lpModuleName (cachedPlugins df)
+         == pluginModNames df -- plugins not changed
+     && all (\p -> paArguments (lpPlugin p)
+                       == argumentsForPlugin p (pluginModNameOpts df))
+            (cachedPlugins df) -- arguments not changed
   = return df -- no need to reload plugins
   | otherwise
   = do loadedPlugins <- loadPlugins (hsc_env { hsc_dflags = df })
-       return $ df { plugins = loadedPlugins }
+       return $ df { cachedPlugins = loadedPlugins }
   where argumentsForPlugin p = map snd . filter ((== lpModuleName p) . fst)
 #endif
 
@@ -106,7 +108,8 @@ loadPlugins hsc_env
     dflags  = hsc_dflags hsc_env
     to_load = pluginModNames dflags
 
-    attachOptions mod_nm (plug, mod) = LoadedPlugin plug mod (reverse options)
+    attachOptions mod_nm (plug, mod) =
+        LoadedPlugin (PluginWithArgs plug (reverse options)) mod
       where
         options = [ option | (opt_mod_nm, option) <- pluginModNameOpts dflags
                             , opt_mod_nm == mod_nm ]
diff --git a/compiler/main/Plugins.hs b/compiler/main/Plugins.hs
index 430b0790f9..de04415244 100644
--- a/compiler/main/Plugins.hs
+++ b/compiler/main/Plugins.hs
@@ -32,8 +32,10 @@ module Plugins (
     , keepRenamedSource
 
       -- * Internal
+    , PluginWithArgs(..), plugins, pluginRecompile'
     , LoadedPlugin(..), lpModuleName
-    , withPlugins, withPlugins_
+    , StaticPlugin(..)
+    , mapPlugins, withPlugins, withPlugins_
     ) where
 
 import GhcPrelude
@@ -120,20 +122,33 @@ data Plugin = Plugin {
 -- For the full discussion, check the full proposal at:
 -- https://ghc.haskell.org/trac/ghc/wiki/ExtendedPluginsProposal
 
+data PluginWithArgs = PluginWithArgs
+  { paPlugin :: Plugin
+    -- ^ the actual callable plugin
+  , paArguments :: [CommandLineOption]
+    -- ^ command line arguments for the plugin
+  }
 
 -- | A plugin with its arguments. The result of loading the plugin.
-data LoadedPlugin = LoadedPlugin {
-    lpPlugin :: Plugin
-    -- ^ the actual callable plugin
+data LoadedPlugin = LoadedPlugin
+  { lpPlugin :: PluginWithArgs
+  -- ^ the actual plugin together with its commandline arguments
   , lpModule :: ModIface
-    -- ^ the module containing the plugin
-  , lpArguments :: [CommandLineOption]
-    -- ^ command line arguments for the plugin
+  -- ^ the module containing the plugin
+  }
+
+-- | A static plugin with its arguments. For registering compiled-in plugins
+-- through the GHC API.
+data StaticPlugin = StaticPlugin
+  { spPlugin :: PluginWithArgs
+  -- ^ the actual plugin together with its commandline arguments
   }
 
 lpModuleName :: LoadedPlugin -> ModuleName
 lpModuleName = moduleName . mi_module . lpModule
 
+pluginRecompile' :: PluginWithArgs -> IO PluginRecompile
+pluginRecompile' (PluginWithArgs plugin args) = pluginRecompile plugin args
 
 data PluginRecompile = ForceRecompile | NoForceRecompile | MaybeRecompile Fingerprint
 
@@ -196,16 +211,24 @@ keepRenamedSource _ gbl_env group =
 type PluginOperation m a = Plugin -> [CommandLineOption] -> a -> m a
 type ConstPluginOperation m a = Plugin -> [CommandLineOption] -> a -> m ()
 
+plugins :: DynFlags -> [PluginWithArgs]
+plugins df =
+  map lpPlugin (cachedPlugins df) ++
+  map spPlugin (staticPlugins df)
+
 -- | Perform an operation by using all of the plugins in turn.
 withPlugins :: Monad m => DynFlags -> PluginOperation m a -> a -> m a
-withPlugins df transformation input
-  = foldM (\arg (LoadedPlugin p _ opts) -> transformation p opts arg)
-          input (plugins df)
+withPlugins df transformation input = foldM go input (plugins df)
+  where
+    go arg (PluginWithArgs p opts) = transformation p opts arg
+
+mapPlugins :: DynFlags -> (Plugin -> [CommandLineOption] -> a) -> [a]
+mapPlugins df f = map (\(PluginWithArgs p opts) -> f p opts) (plugins df)
 
 -- | Perform a constant operation by using all of the plugins in turn.
 withPlugins_ :: Monad m => DynFlags -> ConstPluginOperation m a -> a -> m ()
 withPlugins_ df transformation input
-  = mapM_ (\(LoadedPlugin p _ opts) -> transformation p opts input)
+  = mapM_ (\(PluginWithArgs p opts) -> transformation p opts input)
           (plugins df)
 
 type FrontendPluginAction = [String] -> [(String, Maybe Phase)] -> Ghc ()
diff --git a/compiler/main/Plugins.hs-boot b/compiler/main/Plugins.hs-boot
index 4ccd3d8402..c90c6ebaf7 100644
--- a/compiler/main/Plugins.hs-boot
+++ b/compiler/main/Plugins.hs-boot
@@ -7,3 +7,4 @@ import GhcPrelude ()
 data Plugin
 
 data LoadedPlugin
+data StaticPlugin
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index 3b12837bdc..0a6d7e5bb2 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -2832,8 +2832,7 @@ withTcPlugins hsc_env m =
        return (solve s, stop s)
 
 getTcPlugins :: DynFlags -> [TcRnMonad.TcPlugin]
-getTcPlugins dflags = catMaybes $ map get_plugin (plugins dflags)
-  where get_plugin p = tcPlugin (lpPlugin p) (lpArguments p)
+getTcPlugins dflags = catMaybes $ mapPlugins dflags (\p args -> tcPlugin p args)
 
 runRenamerPlugin :: TcGblEnv
                  -> HsGroup GhcRn
diff --git a/testsuite/tests/plugins/all.T b/testsuite/tests/plugins/all.T
index 9a1a7ea398..72a42da91a 100644
--- a/testsuite/tests/plugins/all.T
+++ b/testsuite/tests/plugins/all.T
@@ -193,3 +193,9 @@ test('plugin-recomp-change-prof',
       when(not config.have_profiling,skip)
       ],
      run_command, ['$MAKE -s --no-print-directory plugin-recomp-change-prof'])
+
+test('static-plugins',
+     [extra_files(['simple-plugin/']),
+      extra_run_opts('"' + config.libdir + '"')],
+     compile_and_run,
+     ['-package ghc -isimple-plugin/'])
diff --git a/testsuite/tests/plugins/static-plugins-module.hs b/testsuite/tests/plugins/static-plugins-module.hs
new file mode 100644
index 0000000000..4aafd0de8a
--- /dev/null
+++ b/testsuite/tests/plugins/static-plugins-module.hs
@@ -0,0 +1,2 @@
+module Main where
+main = print "Hello world!"
diff --git a/testsuite/tests/plugins/static-plugins.hs b/testsuite/tests/plugins/static-plugins.hs
new file mode 100644
index 0000000000..36e18b86b5
--- /dev/null
+++ b/testsuite/tests/plugins/static-plugins.hs
@@ -0,0 +1,80 @@
+module Main where
+
+import Avail
+import Control.Monad.IO.Class
+import DynFlags
+  (getDynFlags, parseDynamicFlagsCmdLine, defaultFatalMessager, defaultFlushOut)
+import GHC
+import GHC.Fingerprint.Type
+import HsDecls
+import HsDoc
+import HsExpr
+import HsExtension
+import HsImpExp
+import HscTypes
+import Outputable
+import Plugins
+import System.Environment
+import TcRnTypes
+
+import Simple.SourcePlugin (plugin)
+
+main = do
+  libdir:args <- getArgs
+  defaultErrorHandler defaultFatalMessager defaultFlushOut $ do
+    runGhc (Just libdir) $ do
+      dflags <- getSessionDynFlags
+      -- liftIO $ print args
+      -- (dflags,_,_)
+      --     <- parseDynamicFlagsCmdLine dflags (map noLoc args)
+      -- we need to LinkInMemory otherwise `setTarget [] >> load LoadAllTargets`
+      -- below will fail.
+      setSessionDynFlags dflags { ghcLink = LinkInMemory}
+
+      -- Start with a pure plugin, this should trigger recomp.
+      liftIO $ putStrLn "==pure.0"
+      loadWithPlugins [StaticPlugin $ PluginWithArgs plugin0_pure []]
+
+      -- The same (or a different) pure plugin shouldn't trigger recomp.
+      liftIO $ putStrLn "==pure.1"
+      loadWithPlugins [StaticPlugin $ PluginWithArgs plugin0_pure []]
+
+      -- Next try with a fingerprint plugin, should trigger recomp.
+      liftIO $ putStrLn "==fp0.0"
+      loadWithPlugins [StaticPlugin $ PluginWithArgs plugin_fp0 []]
+
+      -- With the same fingerprint plugin, should not trigger recomp.
+      liftIO $ putStrLn "==fp0.1"
+      loadWithPlugins [StaticPlugin $ PluginWithArgs plugin_fp0 []]
+
+      -- Change the plugin fingerprint, should trigger recomp.
+      liftIO $ putStrLn "==fp1"
+      loadWithPlugins [StaticPlugin $ PluginWithArgs plugin_fp1 []]
+
+      -- TODO: this currently doesn't work, patch pending
+      -- -- Even though the plugin is now pure we should still recomp since we
+      -- -- used a potentially impure plugin before
+      -- liftIO $ putStrLn "pure.2"
+      -- loadWithPlugins [StaticPlugin $ PluginWithArgs plugin0_pure []]
+
+  where
+    loadWithPlugins the_plugins = do
+      -- first unload (like GHCi :load does)
+      GHC.setTargets []
+      _ <- GHC.load LoadAllTargets
+
+      target <- guessTarget "static-plugins-module.hs" Nothing
+      setTargets [target]
+
+      dflags <- getSessionDynFlags
+      setSessionDynFlags dflags { staticPlugins = the_plugins
+                                , outputFile = Nothing }
+      load LoadAllTargets
+
+
+plugin_fp0   =
+  plugin { pluginRecompile = \_ -> pure $ MaybeRecompile $ Fingerprint 0 0 }
+plugin_fp1   =
+  plugin { pluginRecompile = \_ -> pure $ MaybeRecompile $ Fingerprint 0 1 }
+plugin0_pure =
+  plugin { pluginRecompile = \_ -> pure $ NoForceRecompile }
diff --git a/testsuite/tests/plugins/static-plugins.stdout b/testsuite/tests/plugins/static-plugins.stdout
new file mode 100644
index 0000000000..f7520a7cfb
--- /dev/null
+++ b/testsuite/tests/plugins/static-plugins.stdout
@@ -0,0 +1,25 @@
+==pure.0
+parsePlugin()
+interfacePlugin: Prelude
+interfacePlugin: GHC.Float
+interfacePlugin: GHC.Base
+interfacePlugin: System.IO
+typeCheckPlugin (rn)
+interfacePlugin: GHC.Prim
+interfacePlugin: GHC.Show
+interfacePlugin: GHC.Types
+interfacePlugin: GHC.TopHandler
+typeCheckPlugin (tc)
+interfacePlugin: GHC.CString
+interfacePlugin: GHC.Integer.Type
+interfacePlugin: GHC.Natural
+==pure.1
+==fp0.0
+parsePlugin()
+typeCheckPlugin (rn)
+typeCheckPlugin (tc)
+==fp0.1
+==fp1
+parsePlugin()
+typeCheckPlugin (rn)
+typeCheckPlugin (tc)