Implement TH addCorePlugin.
authorFacundo Domínguez <facundo.dominguez@tweag.io>
Thu, 21 Sep 2017 22:04:56 +0000 (18:04 -0400)
committerBen Gamari <ben@smart-cactus.org>
Fri, 22 Sep 2017 00:13:04 +0000 (20:13 -0400)
This allows template-haskell code to add plugins to the compilation
pipeline. Otherwise, the user would have to pass -fplugin=... to ghc.

For now, plugin modules in the current package can't be used. This is
because when TH runs, it is too late to let GHC know that the plugin
modules needed to be compiled first.

Test Plan: ./validate

Reviewers: simonpj, bgamari, austin, goldfire

Reviewed By: bgamari

Subscribers: angerman, rwbarton, mboes, thomie

GHC Trac Issues: #13608

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

15 files changed:
compiler/main/DynFlags.hs
compiler/main/GHC.hs
compiler/main/HscMain.hs
compiler/typecheck/TcRnMonad.hs
compiler/typecheck/TcRnTypes.hs
compiler/typecheck/TcSplice.hs
docs/users_guide/extending_ghc.rst
libraries/ghci/GHCi/Message.hs
libraries/ghci/GHCi/TH.hs
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
testsuite/tests/plugins/Makefile
testsuite/tests/plugins/all.T
testsuite/tests/plugins/plugins08.hs [new file with mode: 0644]
testsuite/tests/plugins/plugins08.stderr [new file with mode: 0644]
testsuite/tests/plugins/plugins08.stdout [new file with mode: 0644]

index 0bc54be..4c62a0d 100644 (file)
@@ -91,6 +91,7 @@ module DynFlags (
         opt_windres, opt_lo, opt_lc, opt_lcc,
 
         -- ** Manipulating DynFlags
+        addPluginModuleName,
         defaultDynFlags,                -- Settings -> DynFlags
         defaultWays,
         interpWays,
index 63c1551..343ef37 100644 (file)
@@ -1032,16 +1032,19 @@ compileCore simplify fn = do
      Just modSummary -> do
        -- Now we have the module name;
        -- parse, typecheck and desugar the module
-       mod_guts <- coreModule `fmap`
-                      -- TODO: space leaky: call hsc* directly?
-                      (desugarModule =<< typecheckModule =<< parseModule modSummary)
+       (tcg, mod_guts) <- -- TODO: space leaky: call hsc* directly?
+         do tm <- typecheckModule =<< parseModule modSummary
+            let tcg = fst (tm_internals tm)
+            (,) tcg . coreModule <$> desugarModule tm
        liftM (gutsToCoreModule (mg_safe_haskell mod_guts)) $
          if simplify
           then do
              -- If simplify is true: simplify (hscSimplify), then tidy
              -- (tidyProgram).
              hsc_env <- getSession
-             simpl_guts <- liftIO $ hscSimplify hsc_env mod_guts
+             simpl_guts <- liftIO $ do
+               plugins <- readIORef (tcg_th_coreplugins tcg)
+               hscSimplify hsc_env plugins mod_guts
              tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts
              return $ Left tidy_guts
           else
index f7a7933..8040b1d 100644 (file)
@@ -85,6 +85,7 @@ module HscMain
 import GhcPrelude
 
 import Data.Data hiding (Fixity, TyCon)
+import DynFlags         (addPluginModuleName)
 import Id
 import GHCi             ( addSptEntry )
 import GHCi.RemoteTypes ( ForeignHValue )
@@ -753,7 +754,8 @@ finish hsc_env summary tc_result mb_old_hash = do
           -- and generate a simple interface.
           then mk_simple_iface
           else do
-            desugared_guts <- hscSimplify' desugared_guts0
+            plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result)
+            desugared_guts <- hscSimplify' plugins desugared_guts0
             (iface, changed, details, cgguts) <-
               liftIO $ hscNormalIface hsc_env desugared_guts mb_old_hash
             return (iface, changed, details, HscRecomp cgguts summary)
@@ -1188,14 +1190,18 @@ hscGetSafeMode tcg_env = do
 -- Simplifiers
 --------------------------------------------------------------
 
-hscSimplify :: HscEnv -> ModGuts -> IO ModGuts
-hscSimplify hsc_env modguts = runHsc hsc_env $ hscSimplify' modguts
+hscSimplify :: HscEnv -> [String] -> ModGuts -> IO ModGuts
+hscSimplify hsc_env plugins modguts =
+    runHsc hsc_env $ hscSimplify' plugins modguts
 
-hscSimplify' :: ModGuts -> Hsc ModGuts
-hscSimplify' ds_result = do
+hscSimplify' :: [String] -> ModGuts -> Hsc ModGuts
+hscSimplify' plugins ds_result = do
     hsc_env <- getHscEnv
+    let hsc_env_with_plugins = hsc_env
+          { hsc_dflags = foldr addPluginModuleName (hsc_dflags hsc_env) plugins
+          }
     {-# SCC "Core2Core" #-}
-      liftIO $ core2core hsc_env ds_result
+      liftIO $ core2core hsc_env_with_plugins ds_result
 
 --------------------------------------------------------------
 -- Interface generators
@@ -1578,7 +1584,9 @@ hscDeclsWithLocation hsc_env0 str source linenumber =
     ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv
 
     {- Simplify -}
-    simpl_mg <- liftIO $ hscSimplify hsc_env ds_result
+    simpl_mg <- liftIO $ do
+      plugins <- readIORef (tcg_th_coreplugins tc_gblenv)
+      hscSimplify hsc_env plugins ds_result
 
     {- Tidy -}
     (tidy_cg, mod_details) <- liftIO $ tidyProgram hsc_env simpl_mg
index fba0f5d..0e88e23 100644 (file)
@@ -221,6 +221,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
         th_foreign_files_var <- newIORef [] ;
         th_topnames_var      <- newIORef emptyNameSet ;
         th_modfinalizers_var <- newIORef [] ;
+        th_coreplugins_var <- newIORef [] ;
         th_state_var         <- newIORef Map.empty ;
         th_remote_state_var  <- newIORef Nothing ;
         let {
@@ -237,6 +238,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
                 tcg_th_foreign_files = th_foreign_files_var,
                 tcg_th_topnames      = th_topnames_var,
                 tcg_th_modfinalizers = th_modfinalizers_var,
+                tcg_th_coreplugins = th_coreplugins_var,
                 tcg_th_state         = th_state_var,
                 tcg_th_remote_state  = th_remote_state_var,
 
index a29ad92..4c708dd 100644 (file)
@@ -651,6 +651,9 @@ data TcGblEnv
         -- They are computations in the @TcM@ monad rather than @Q@ because we
         -- set them to use particular local environments.
 
+        tcg_th_coreplugins :: TcRef [String],
+        -- ^ Core plugins added by Template Haskell code.
+
         tcg_th_state :: TcRef (Map TypeRep Dynamic),
         tcg_th_remote_state :: TcRef (Maybe (ForeignRef (IORef QState))),
         -- ^ Template Haskell state
index 9e10213..a010227 100644 (file)
@@ -35,6 +35,7 @@ import GhcPrelude
 
 import HsSyn
 import Annotations
+import Finder
 import Name
 import TcRnMonad
 import TcType
@@ -920,6 +921,22 @@ instance TH.Quasi TcM where
       fref <- liftIO $ mkForeignRef r (freeRemoteRef r)
       addModFinalizerRef fref
 
+  qAddCorePlugin plugin = do
+      hsc_env <- env_top <$> getEnv
+      r <- liftIO $ findHomeModule hsc_env (mkModuleName plugin)
+      let err = hang
+            (text "addCorePlugin: invalid plugin module "
+               <+> text (show plugin)
+            )
+            2
+            (text "Plugins in the current package can't be specified.")
+      case r of
+        Found {} -> addErr err
+        FoundMultiple {} -> addErr err
+        _ -> return ()
+      th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv
+      updTcRef th_coreplugins_var (plugin:)
+
   qGetQ :: forall a. Typeable a => TcM (Maybe a)
   qGetQ = do
       th_state_var <- fmap tcg_th_state getGblEnv
@@ -1104,6 +1121,7 @@ handleTHMessage msg = case msg of
   AddModFinalizer r -> do
     hsc_env <- env_top <$> getEnv
     wrapTHResult $ liftIO (mkFinalizedHValue hsc_env r) >>= addModFinalizerRef
+  AddCorePlugin str -> wrapTHResult $ TH.qAddCorePlugin str
   AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs
   AddForeignFile lang str -> wrapTHResult $ TH.qAddForeignFile lang str
   IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext
index e9543eb..8af5989 100644 (file)
@@ -230,6 +230,18 @@ would invoke GHC like this:
     Linking Test ...
     $
 
+Alternatively, core plugins can be specified with Template Haskell.
+
+::
+
+   addCorePlugin "Foo.Plugin"
+
+This inserts the plugin as a core-to-core pass. Unlike `-fplugin=(module)`,
+the plugin module can't reside in the same package as the module calling
+:th-ref:`Language.Haskell.TH.Syntax.addCorePlugin`. This way, the
+implementation can expect the plugin to be built by the time
+it is needed.
+
 Plugin modules live in a separate namespace from
 the user import namespace.  By default, these two namespaces are
 the same; however, there are a few command line options which
index fe63d64..de91c5b 100644 (file)
@@ -240,6 +240,7 @@ data THMessage a where
 
   AddDependentFile :: FilePath -> THMessage (THResult ())
   AddModFinalizer :: RemoteRef (TH.Q ()) -> THMessage (THResult ())
+  AddCorePlugin :: String -> THMessage (THResult ())
   AddTopDecls :: [TH.Dec] -> THMessage (THResult ())
   AddForeignFile :: ForeignSrcLang -> String -> THMessage (THResult ())
   IsExtEnabled :: Extension -> THMessage (THResult Bool)
@@ -278,7 +279,8 @@ getTHMessage = do
     15 -> THMsg <$> EndRecover <$> get
     16 -> return (THMsg RunTHDone)
     17 -> THMsg <$> AddModFinalizer <$> get
-    _  -> THMsg <$> (AddForeignFile <$> get <*> get)
+    18 -> THMsg <$> (AddForeignFile <$> get <*> get)
+    _  -> THMsg <$> AddCorePlugin <$> get
 
 putTHMessage :: THMessage a -> Put
 putTHMessage m = case m of
@@ -301,6 +303,7 @@ putTHMessage m = case m of
   RunTHDone                   -> putWord8 16
   AddModFinalizer a           -> putWord8 17 >> put a
   AddForeignFile lang a       -> putWord8 18 >> put lang >> put a
+  AddCorePlugin a             -> putWord8 19 >> put a
 
 
 data EvalOpts = EvalOpts
index 09fbca7..905e003 100644 (file)
@@ -199,6 +199,7 @@ instance TH.Quasi GHCiQ where
   qAddForeignFile str lang = ghcCmd (AddForeignFile str lang)
   qAddModFinalizer fin = GHCiQ (\s -> mkRemoteRef fin >>= return . (, s)) >>=
                          ghcCmd . AddModFinalizer
+  qAddCorePlugin str = ghcCmd (AddCorePlugin str)
   qGetQ = GHCiQ $ \s ->
     let lookup :: forall a. Typeable a => Map TypeRep Dynamic -> Maybe a
         lookup m = fromDynamic =<< M.lookup (typeOf (undefined::a)) m
index 3087c69..419d944 100644 (file)
@@ -90,6 +90,8 @@ class (MonadIO m, Fail.MonadFail m) => Quasi m where
 
   qAddModFinalizer :: Q () -> m ()
 
+  qAddCorePlugin :: String -> m ()
+
   qGetQ :: Typeable a => m (Maybe a)
 
   qPutQ :: Typeable a => a -> m ()
@@ -129,6 +131,7 @@ instance Quasi IO where
   qAddTopDecls _        = badIO "addTopDecls"
   qAddForeignFile _ _   = badIO "addForeignFile"
   qAddModFinalizer _    = badIO "addModFinalizer"
+  qAddCorePlugin _      = badIO "addCorePlugin"
   qGetQ                 = badIO "getQ"
   qPutQ _               = badIO "putQ"
   qIsExtEnabled _       = badIO "isExtEnabled"
@@ -476,6 +479,16 @@ addForeignFile lang str = Q (qAddForeignFile lang str)
 addModFinalizer :: Q () -> Q ()
 addModFinalizer act = Q (qAddModFinalizer (unQ act))
 
+-- | Adds a core plugin to the compilation pipeline.
+--
+-- @addCorePlugin m@ has almost the same effect as passing @-fplugin=m@ to ghc
+-- in the command line. The major difference is that the plugin module @m@
+-- must not belong to the current package. When TH executes, it is too late
+-- to tell the compiler that we needed to compile first a plugin module in the
+-- current package.
+addCorePlugin :: String -> Q ()
+addCorePlugin plugin = Q (qAddCorePlugin plugin)
+
 -- | Get state from the 'Q' monad. Note that the state is local to the
 -- Haskell module in which the Template Haskell expression is executed.
 getQ :: Typeable a => Q (Maybe a)
@@ -514,6 +527,7 @@ instance Quasi Q where
   qAddTopDecls        = addTopDecls
   qAddForeignFile     = addForeignFile
   qAddModFinalizer    = addModFinalizer
+  qAddCorePlugin      = addCorePlugin
   qGetQ               = getQ
   qPutQ               = putQ
   qIsExtEnabled       = isExtEnabled
index efe17ef..1ff8d40 100644 (file)
@@ -16,6 +16,11 @@ plugins07:
        "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) --make -v0 -O plugins07.hs -package-db rule-defining-plugin/pkg.plugins07/local.package.conf -hide-all-packages -package base -plugin-package rule-defining-plugin -fplugin=RuleDefiningPlugin
        ./plugins07
 
+.PHONY: plugins08
+plugins08:
+       "$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) --make -v0 plugins08.hs -package-db simple-plugin/pkg.plugins08/local.package.conf
+       ./plugins08
+
 # -package (should work for backwards compatibility)
 .PHONY: T10420
 T10420:
index 9e17eb4..5f53531 100644 (file)
@@ -34,6 +34,11 @@ test('plugins07',
       pre_cmd('$MAKE -s --no-print-directory -C rule-defining-plugin package.plugins07 TOP={top}')],
      run_command, ['$MAKE -s --no-print-directory plugins07'])
 
+test('plugins08',
+     [extra_files(['simple-plugin/']),
+      pre_cmd('$MAKE -s --no-print-directory -C simple-plugin package.plugins08 TOP={top}')],
+     run_command, ['$MAKE -s --no-print-directory plugins08'])
+
 test('T10420',
      [extra_files(['rule-defining-plugin/']),
       pre_cmd('$MAKE -s --no-print-directory -C rule-defining-plugin package.T10420 TOP={top}')],
diff --git a/testsuite/tests/plugins/plugins08.hs b/testsuite/tests/plugins/plugins08.hs
new file mode 100644 (file)
index 0000000..403d81f
--- /dev/null
@@ -0,0 +1,18 @@
+-- Tests a plugin added with TH.addCorePlugin
+{-# LANGUAGE TemplateHaskell #-}
+module Main where
+
+import Simple.DataStructures
+import Language.Haskell.TH.Syntax
+
+do addCorePlugin "Simple.Plugin"
+   return []
+
+{-# ANN theMessage (ReplaceWith "Right") #-}
+{-# NOINLINE theMessage #-}
+theMessage = "Wrong"
+
+main = do
+    putStrLn "Program Started"
+    putStrLn theMessage
+    putStrLn "Program Ended"
diff --git a/testsuite/tests/plugins/plugins08.stderr b/testsuite/tests/plugins/plugins08.stderr
new file mode 100644 (file)
index 0000000..72667a0
--- /dev/null
@@ -0,0 +1,4 @@
+Simple Plugin Passes Queried
+Got options:
+Simple Plugin Pass Run
+Performing Replacement
diff --git a/testsuite/tests/plugins/plugins08.stdout b/testsuite/tests/plugins/plugins08.stdout
new file mode 100644 (file)
index 0000000..5633757
--- /dev/null
@@ -0,0 +1,3 @@
+Program Started
+Right
+Program Ended