Support registering Plugins through the GHC API
authorDaniel Gröber <dxld@darkboxed.org>
Tue, 11 Dec 2018 18:24:12 +0000 (13:24 -0500)
committerBen Gamari <ben@smart-cactus.org>
Tue, 11 Dec 2018 19:23:22 +0000 (14:23 -0500)
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

compiler/deSugar/Desugar.hs
compiler/iface/MkIface.hs
compiler/main/DynFlags.hs
compiler/main/DynamicLoading.hs
compiler/main/Plugins.hs
compiler/main/Plugins.hs-boot
compiler/typecheck/TcRnDriver.hs
testsuite/tests/plugins/all.T
testsuite/tests/plugins/static-plugins-module.hs [new file with mode: 0644]
testsuite/tests/plugins/static-plugins.hs [new file with mode: 0644]
testsuite/tests/plugins/static-plugins.stdout [new file with mode: 0644]

index 0ed35f2..aa24ee0 100644 (file)
@@ -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
 
index aba14ba..7b66472 100644 (file)
@@ -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
index 3fb3874..48c7103 100644 (file)
@@ -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,
index 7420f7c..0a5264e 100644 (file)
@@ -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 ]
index 430b079..de04415 100644 (file)
@@ -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 ()
index 4ccd3d8..c90c6eb 100644 (file)
@@ -7,3 +7,4 @@ import GhcPrelude ()
 data Plugin
 
 data LoadedPlugin
+data StaticPlugin
index 3b12837..0a6d7e5 100644 (file)
@@ -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
index 9a1a7ea..72a42da 100644 (file)
@@ -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 (file)
index 0000000..4aafd0d
--- /dev/null
@@ -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 (file)
index 0000000..36e18b8
--- /dev/null
@@ -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 (file)
index 0000000..f7520a7
--- /dev/null
@@ -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)