Frontend plugins.

Summary:
Frontend plugins enable users to write plugins to replace
GHC major modes.  E.g. instead of saying

    ghc --make A B C

a user can now say

    ghc --frontend GHC.Frontend.Shake A B C

which might provide an alternative implementation of a multi-module
build.  For more details, see the manual entry.

Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>

Test Plan: validate

Reviewers: simonmar, bgamari, austin, simonpj

Subscribers: thomie

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

GHC Trac Issues: #11194

12 files changed, 179 insertions, 7 deletions

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 4aedc43054..3dfd1ef660 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -780,6 +780,7 @@ data DynFlags = DynFlags {
   -- Plugins
   pluginModNames        :: [ModuleName],
   pluginModNameOpts     :: [(ModuleName,String)],
+  frontendPluginOpts    :: [String],
 
   -- GHC API hooks
   hooks                 :: Hooks,
@@ -1504,6 +1505,7 @@ defaultDynFlags mySettings =
 
         pluginModNames          = [],
         pluginModNameOpts       = [],
+        frontendPluginOpts      = [],
         hooks                   = emptyHooks,
 
         outputFile              = Nothing,
@@ -1986,6 +1988,9 @@ addPluginModuleNameOption optflag d = d { pluginModNameOpts = (mkModuleName m, o
           [] -> "" -- should probably signal an error
           (_:plug_opt) -> plug_opt -- ignore the ':' from break
 
+addFrontendPluginOption :: String -> DynFlags -> DynFlags
+addFrontendPluginOption s d = d { frontendPluginOpts = s : frontendPluginOpts d }
+
 parseDynLibLoaderMode f d =
  case splitAt 8 f of
    ("deploy", "")       -> d{ dynLibLoader = Deployable }
@@ -2594,6 +2599,7 @@ dynamic_flags = [
         ------ Plugin flags ------------------------------------------------
   , defGhcFlag "fplugin-opt" (hasArg addPluginModuleNameOption)
   , defGhcFlag "fplugin"     (hasArg addPluginModuleName)
+  , defGhcFlag "ffrontend-opt" (hasArg addFrontendPluginOption)
 
         ------ Optimisation flags ------------------------------------------
   , defGhcFlag "O"      (noArgM (setOptLevel 1))
diff --git a/compiler/main/DynamicLoading.hs b/compiler/main/DynamicLoading.hs
index 5942d6c91c..0d4b84252f 100644
--- a/compiler/main/DynamicLoading.hs
+++ b/compiler/main/DynamicLoading.hs
@@ -5,6 +5,7 @@ module DynamicLoading (
 #ifdef GHCI
         -- * Loading plugins
         loadPlugins,
+        loadFrontendPlugin,
 
         -- * Force loading information
         forceLoadModuleInterfaces,
@@ -30,11 +31,11 @@ import LoadIface        ( loadPluginInterface )
 import RdrName          ( RdrName, ImportSpec(..), ImpDeclSpec(..)
                         , ImpItemSpec(..), mkGlobalRdrEnv, lookupGRE_RdrName
                         , gre_name, mkRdrQual )
-import OccName          ( mkVarOcc )
+import OccName          ( OccName, mkVarOcc )
 import RnNames          ( gresFromAvails )
 import DynFlags
-import Plugins          ( Plugin, CommandLineOption )
-import PrelNames        ( pluginTyConName )
+import Plugins          ( Plugin, FrontendPlugin, CommandLineOption )
+import PrelNames        ( pluginTyConName, frontendPluginTyConName )
 
 import HscTypes
 import BasicTypes       ( HValue )
@@ -68,8 +69,14 @@ loadPlugins hsc_env
                             , opt_mod_nm == mod_nm ]
 
 loadPlugin :: HscEnv -> ModuleName -> IO Plugin
-loadPlugin hsc_env mod_name
-  = do { let plugin_rdr_name = mkRdrQual mod_name (mkVarOcc "plugin")
+loadPlugin = loadPlugin' (mkVarOcc "plugin") pluginTyConName
+
+loadFrontendPlugin :: HscEnv -> ModuleName -> IO FrontendPlugin
+loadFrontendPlugin = loadPlugin' (mkVarOcc "frontendPlugin") frontendPluginTyConName
+
+loadPlugin' :: OccName -> Name -> HscEnv -> ModuleName -> IO a
+loadPlugin' occ_name plugin_name hsc_env mod_name
+  = do { let plugin_rdr_name = mkRdrQual mod_name occ_name
              dflags = hsc_dflags hsc_env
        ; mb_name <- lookupRdrNameInModuleForPlugins hsc_env mod_name
                         plugin_rdr_name
@@ -81,7 +88,7 @@ loadPlugin hsc_env mod_name
                           , ppr plugin_rdr_name ]) ;
             Just name ->
 
-     do { plugin_tycon <- forceLoadTyCon hsc_env pluginTyConName
+     do { plugin_tycon <- forceLoadTyCon hsc_env plugin_name
         ; mb_plugin <- getValueSafely hsc_env name (mkTyConTy plugin_tycon)
         ; case mb_plugin of
             Nothing ->
diff --git a/compiler/main/Plugins.hs b/compiler/main/Plugins.hs
index d936e288b4..6a8c761db8 100644
--- a/compiler/main/Plugins.hs
+++ b/compiler/main/Plugins.hs
@@ -1,10 +1,13 @@
 module Plugins (
+    FrontendPlugin(..), defaultFrontendPlugin,
     Plugin(..), CommandLineOption,
     defaultPlugin
     ) where
 
 import CoreMonad ( CoreToDo, CoreM )
 import TcRnTypes ( TcPlugin )
+import GhcMonad
+import DriverPhases
 
 
 -- | Command line options gathered from the -PModule.Name:stuff syntax
@@ -36,3 +39,10 @@ defaultPlugin = Plugin {
         installCoreToDos = const return
       , tcPlugin         = const Nothing
     }
+
+type FrontendPluginAction = [String] -> [(String, Maybe Phase)] -> Ghc ()
+data FrontendPlugin = FrontendPlugin {
+      frontend :: FrontendPluginAction
+    }
+defaultFrontendPlugin :: FrontendPlugin
+defaultFrontendPlugin = FrontendPlugin { frontend = \_ _ -> return () }
diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs
index a9b43227f5..a963a07f30 100644
--- a/compiler/prelude/PrelNames.hs
+++ b/compiler/prelude/PrelNames.hs
@@ -345,6 +345,7 @@ basicKnownKeyNames
 
         -- Plugins
         , pluginTyConName
+        , frontendPluginTyConName
 
         -- Generics
         , genClassName, gen1ClassName
@@ -1347,6 +1348,8 @@ pLUGINS :: Module
 pLUGINS = mkThisGhcModule (fsLit "Plugins")
 pluginTyConName :: Name
 pluginTyConName = tcQual pLUGINS (fsLit "Plugin") pluginTyConKey
+frontendPluginTyConName :: Name
+frontendPluginTyConName = tcQual pLUGINS (fsLit "FrontendPlugin") frontendPluginTyConKey
 
 -- Static pointers
 staticPtrInfoTyConName :: Name
@@ -1606,8 +1609,9 @@ constraintKindTyConKey                  = mkPreludeTyConUnique 92
 starKindTyConKey                        = mkPreludeTyConUnique 93
 unicodeStarKindTyConKey                 = mkPreludeTyConUnique 94
 
-pluginTyConKey :: Unique
+pluginTyConKey, frontendPluginTyConKey :: Unique
 pluginTyConKey                          = mkPreludeTyConUnique 102
+frontendPluginTyConKey                  = mkPreludeTyConUnique 103
 
 unknownTyConKey, unknown1TyConKey, unknown2TyConKey, unknown3TyConKey,
     opaqueTyConKey :: Unique
diff --git a/docs/users_guide/extending_ghc.rst b/docs/users_guide/extending_ghc.rst
index a0c3bd1665..bb127957df 100644
--- a/docs/users_guide/extending_ghc.rst
+++ b/docs/users_guide/extending_ghc.rst
@@ -533,3 +533,53 @@ typechecking, and can be checked by ``-dcore-lint``. It is possible for
 the plugin to create equality axioms for use in evidence terms, but GHC
 does not check their consistency, and inconsistent axiom sets may lead
 to segfaults or other runtime misbehaviour.
+
+.. _frontend_plugins:
+
+Frontend plugins
+~~~~~~~~~~~~~~~~
+
+A frontend plugin allows you to add new major modes to GHC.  You may prefer
+this over a traditional program which calls the GHC API, as GHC manages a lot
+of parsing flags and administrative nonsense which can be difficult to
+manage manually.  To load a frontend plugin exported by ``Foo.FrontendPlugin``,
+we just invoke GHC as follows:
+
+::
+
+    $ ghc --frontend Foo.FrontendPlugin ...other options...
+
+Frontend plugins, like compiler plugins, are exported by registered plugins.
+However, unlike compiler modules, frontend plugins are modules that export
+at least a single identifier ``frontendPlugin`` of type
+``GhcPlugins.FrontendPlugin``.
+
+``FrontendPlugin`` exports a field ``frontend``, which is a function
+``[String] -> [(String, Maybe Phase)] -> Ghc ()``.  The first argument
+is a list of extra flags passed to the frontend with ``-ffrontend-opt``;
+the second argument is the list of arguments, usually source files
+and module names to be compiled (the ``Phase`` indicates if an ``-x``
+flag was set), and a frontend simply executes some operation in the
+``Ghc`` monad (which, among other things, has a ``Session``).
+
+As a quick example, here is a frontend plugin that prints the arguments that
+were passed to it, and then exits.
+
+::
+
+    module DoNothing.FrontendPlugin (frontendPlugin) where
+    import GhcPlugins
+
+    frontendPlugin :: FrontendPlugin
+    frontendPlugin = defaultFrontendPlugin {
+      frontend = doNothing
+      }
+
+    doNothing :: [String] -> [(String, Maybe Phase)] -> Ghc ()
+    doNothing flags args = do
+        liftIO $ print flags
+        liftIO $ print args
+
+Provided you have compiled this plugin and registered it in a package,
+you can just use it by specifying ``--frontend DoNothing.FrontendPlugin``
+on the command line to GHC.
diff --git a/ghc/Main.hs b/ghc/Main.hs
index d14a897dc7..c85f0b3a8b 100644
--- a/ghc/Main.hs
+++ b/ghc/Main.hs
@@ -28,6 +28,13 @@ import DriverMkDepend   ( doMkDependHS )
 import InteractiveUI    ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings )
 #endif
 
+-- Frontend plugins
+#ifdef GHCI
+import DynamicLoading
+import Plugins
+#endif
+import Module           ( ModuleName )
+
 
 -- Various other random stuff that we need
 import Config
@@ -253,6 +260,7 @@ main' postLoadMode dflags0 args flagWarnings = do
        DoEval exprs           -> ghciUI srcs $ Just $ reverse exprs
        DoAbiHash              -> abiHash (map fst srcs)
        ShowPackages           -> liftIO $ showPackages dflags6
+       DoFrontend f           -> doFrontend f srcs
 
   liftIO $ dumpFinalStats dflags6
 
@@ -457,6 +465,7 @@ data PostLoadMode
   | DoEval [String]         -- ghc -e foo -e bar => DoEval ["bar", "foo"]
   | DoAbiHash               -- ghc --abi-hash
   | ShowPackages            -- ghc --show-packages
+  | DoFrontend ModuleName   -- ghc --frontend Plugin.Module
 
 doMkDependHSMode, doMakeMode, doInteractiveMode,
   doAbiHashMode, showPackagesMode :: Mode
@@ -475,6 +484,9 @@ stopBeforeMode phase = mkPostLoadMode (StopBefore phase)
 doEvalMode :: String -> Mode
 doEvalMode str = mkPostLoadMode (DoEval [str])
 
+doFrontendMode :: String -> Mode
+doFrontendMode str = mkPostLoadMode (DoFrontend (mkModuleName str))
+
 mkPostLoadMode :: PostLoadMode -> Mode
 mkPostLoadMode = Right . Right
 
@@ -607,6 +619,7 @@ mode_flags =
   , defFlag "-interactive" (PassFlag (setMode doInteractiveMode))
   , defFlag "-abi-hash"    (PassFlag (setMode doAbiHashMode))
   , defFlag "e"            (SepArg   (\s -> setMode (doEvalMode s) "-e"))
+  , defFlag "-frontend"    (SepArg   (\s -> setMode (doFrontendMode s) "-frontend"))
   ]
 
 setMode :: Mode -> String -> EwM ModeM ()
@@ -830,6 +843,20 @@ dumpPackages       dflags = putMsg dflags (pprPackages dflags)
 dumpPackagesSimple dflags = putMsg dflags (pprPackagesSimple dflags)
 
 -- -----------------------------------------------------------------------------
+-- Frontend plugin support
+
+doFrontend :: ModuleName -> [(String, Maybe Phase)] -> Ghc ()
+#ifndef GHCI
+doFrontend _ _ =
+    throwGhcException (CmdLineError "not built for interactive use")
+#else
+doFrontend modname srcs = do
+    hsc_env <- getSession
+    frontend_plugin <- liftIO $ loadFrontendPlugin hsc_env modname
+    frontend frontend_plugin (frontendPluginOpts (hsc_dflags hsc_env)) srcs
+#endif
+
+-- -----------------------------------------------------------------------------
 -- ABI hash support
 
 {-
diff --git a/testsuite/.gitignore b/testsuite/.gitignore
index 07bf0bc630..0bb80823f6 100644
--- a/testsuite/.gitignore
+++ b/testsuite/.gitignore
@@ -1237,6 +1237,7 @@ mk/ghcconfig*_test___spaces_ghc*.exe.mk
 /tests/plugins/T10420
 /tests/plugins/annotation-plugin/pkg.T10294/
 /tests/plugins/annotation-plugin/pkg.T10294a/
+/tests/plugins/frontend01
 /tests/plugins/plugins01
 /tests/plugins/plugins05
 /tests/plugins/plugins06
diff --git a/testsuite/tests/plugins/FrontendPlugin.hs b/testsuite/tests/plugins/FrontendPlugin.hs
new file mode 100644
index 0000000000..9a6c5d0514
--- /dev/null
+++ b/testsuite/tests/plugins/FrontendPlugin.hs
@@ -0,0 +1,52 @@
+module FrontendPlugin where
+
+import GhcPlugins
+import qualified GHC
+import GHC              ( Ghc, LoadHowMuch(..) )
+
+import DriverPipeline hiding ( hsc_env )
+import DriverPhases
+import System.Exit
+import Control.Monad
+import Data.List
+
+frontendPlugin :: FrontendPlugin
+frontendPlugin = defaultFrontendPlugin {
+        frontend = doMake
+    }
+
+-- Copypasted from ghc/Main.hs
+doMake :: [String] -> [(String,Maybe Phase)] -> Ghc ()
+doMake opts srcs  = do
+    liftIO $ print opts
+    let (hs_srcs, non_hs_srcs) = partition haskellish srcs
+
+        haskellish (f,Nothing) =
+          looksLikeModuleName f || isHaskellUserSrcFilename f || '.' `notElem` f
+        haskellish (_,Just phase) =
+          phase `notElem` [ As True, As False, Cc, Cobjc, Cobjcxx, CmmCpp, Cmm
+                          , StopLn]
+
+    hsc_env <- GHC.getSession
+
+    -- if we have no haskell sources from which to do a dependency
+    -- analysis, then just do one-shot compilation and/or linking.
+    -- This means that "ghc Foo.o Bar.o -o baz" links the program as
+    -- we expect.
+    if (null hs_srcs)
+       then liftIO (oneShot hsc_env StopLn srcs)
+       else do
+
+    o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x)
+                 non_hs_srcs
+    dflags <- GHC.getSessionDynFlags
+    let dflags' = dflags { ldInputs = map (FileOption "") o_files
+                                      ++ ldInputs dflags }
+    _ <- GHC.setSessionDynFlags dflags'
+
+    targets <- mapM (uncurry GHC.guessTarget) hs_srcs
+    GHC.setTargets targets
+    ok_flag <- GHC.load LoadAllTargets
+
+    when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1))
+    return ()
diff --git a/testsuite/tests/plugins/Makefile b/testsuite/tests/plugins/Makefile
index 42a4d1af0a..c12c33c9c7 100644
--- a/testsuite/tests/plugins/Makefile
+++ b/testsuite/tests/plugins/Makefile
@@ -24,3 +24,10 @@ T10294:
 .PHONY: T10294a
 T10294a:
 	"$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) -c -v0 T10294a.hs -package-db annotation-plugin/pkg.T10294a/local.package.conf -package annotation-plugin -fplugin=SayAnnNames
+
+.PHONY: frontend01
+frontend01:
+	$(RM) FrontendPlugin.hi FrontendPlugin.o frontend01 frontend01.hi frontend.o
+	"$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) -Wall -package ghc -c FrontendPlugin.hs
+	"$(TEST_HC)" $(TEST_HC_OPTS) $(ghcPluginWayFlags) --frontend FrontendPlugin -ffrontend-opt foobar frontend01
+	./frontend01
diff --git a/testsuite/tests/plugins/all.T b/testsuite/tests/plugins/all.T
index bc3bcfa2dd..2e4aacf29c 100644
--- a/testsuite/tests/plugins/all.T
+++ b/testsuite/tests/plugins/all.T
@@ -62,3 +62,6 @@ test('T10294a',
       clean_cmd('$MAKE -s --no-print-directory -C annotation-plugin clean.T10294a')],
      run_command,
      ['$MAKE -s --no-print-directory T10294a'])
+
+test('frontend01', [ extra_clean(['FrontendPlugin.hi', 'FrontendPlugin.o', 'frontend01', 'frontend01.o', 'frontend01.hi']) ],
+     run_command, ['$MAKE -s --no-print-directory frontend01'])
diff --git a/testsuite/tests/plugins/frontend01.hs b/testsuite/tests/plugins/frontend01.hs
new file mode 100644
index 0000000000..db014568d4
--- /dev/null
+++ b/testsuite/tests/plugins/frontend01.hs
@@ -0,0 +1 @@
+main = putStrLn "hello world"
diff --git a/testsuite/tests/plugins/frontend01.stdout b/testsuite/tests/plugins/frontend01.stdout
new file mode 100644
index 0000000000..84950bcbc9
--- /dev/null
+++ b/testsuite/tests/plugins/frontend01.stdout
@@ -0,0 +1,4 @@
+["foobar"]
+[1 of 1] Compiling Main             ( frontend01.hs, frontend01.o )
+Linking frontend01 ...
+hello world