Basic response file support

Here we introduce support into our command-line parsing infrastructure
and driver for handling gnu-style response file arguments,
typically used to work around platform command-line length limitations.

Fixes #16476.

6 files changed, 111 insertions, 45 deletions

diff --git a/compiler/GHC.hs b/compiler/GHC.hs
index b573f2769e..d3e9d3978d 100644
--- a/compiler/GHC.hs
+++ b/compiler/GHC.hs
@@ -1900,7 +1900,7 @@ interpretPackageEnv logger dflags = do
       Just envfile -> do
         content <- readFile envfile
         compilationProgressMsg logger (text "Loaded package environment from " <> text envfile)
-        let (_, dflags') = runCmdLine (runEwM (setFlagsFromEnvFile envfile content)) dflags
+        let (_, dflags') = runCmdLineP (runEwM (setFlagsFromEnvFile envfile content)) dflags
 
         return dflags'
   where
diff --git a/compiler/GHC/Driver/CmdLine.hs b/compiler/GHC/Driver/CmdLine.hs
index 539f27c53e..0c4ed95618 100644
--- a/compiler/GHC/Driver/CmdLine.hs
+++ b/compiler/GHC/Driver/CmdLine.hs
@@ -1,5 +1,4 @@
-
-{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE RankNTypes #-}
 
 -------------------------------------------------------------------------------
 --
@@ -13,9 +12,8 @@
 
 module GHC.Driver.CmdLine
     (
-      processArgs, OptKind(..), GhcFlagMode(..),
-      CmdLineP(..), getCmdLineState, putCmdLineState,
-      Flag(..), defFlag, defGhcFlag, defGhciFlag, defHiddenFlag,
+      processArgs, parseResponseFile, OptKind(..), GhcFlagMode(..),
+      Flag(..), defFlag, defGhcFlag, defGhciFlag, defHiddenFlag, hoistFlag,
       errorsToGhcException,
 
       Err(..), Warn(..), WarnReason(..),
@@ -38,7 +36,10 @@ import GHC.Types.Error ( DiagnosticReason(..) )
 import Data.Function
 import Data.List (sortBy, intercalate, stripPrefix)
 
+import GHC.ResponseFile
+import Control.Exception (IOException, catch)
 import Control.Monad (liftM, ap)
+import Control.Monad.IO.Class
 
 --------------------------------------------------------
 --         The Flag and OptKind types
@@ -62,6 +63,24 @@ defGhciFlag name optKind = Flag name optKind OnlyGhci
 defHiddenFlag :: String -> OptKind m -> Flag m
 defHiddenFlag name optKind = Flag name optKind HiddenFlag
 
+hoistFlag :: forall m n. (forall a. m a -> n a) -> Flag m -> Flag n
+hoistFlag f (Flag a b c) = Flag a (go b) c
+  where
+      go (NoArg k)  = NoArg (go2 k)
+      go (HasArg k) = HasArg (\s -> go2 (k s))
+      go (SepArg k) = SepArg (\s -> go2 (k s))
+      go (Prefix k) = Prefix (\s -> go2 (k s))
+      go (OptPrefix k) = OptPrefix (\s -> go2 (k s))
+      go (OptIntSuffix k) = OptIntSuffix (\n -> go2 (k n))
+      go (IntSuffix k) = IntSuffix (\n -> go2 (k n))
+      go (WordSuffix k) = WordSuffix (\s -> go2 (k s))
+      go (FloatSuffix k) = FloatSuffix (\s -> go2 (k s))
+      go (PassFlag k) = PassFlag (\s -> go2 (k s))
+      go (AnySuffix k) = AnySuffix (\s -> go2 (k s))
+
+      go2 :: EwM m a -> EwM n a
+      go2 (EwM g) = EwM $ \loc es ws -> f (g loc es ws)
+
 -- | GHC flag modes describing when a flag has an effect.
 data GhcFlagMode
     = OnlyGhc  -- ^ The flag only affects the non-interactive GHC
@@ -130,6 +149,8 @@ instance Monad m => Applicative (EwM m) where
 instance Monad m => Monad (EwM m) where
     (EwM f) >>= k = EwM (\l e w -> do (e', w', r) <- f l e w
                                       unEwM (k r) l e' w')
+instance MonadIO m => MonadIO (EwM m) where
+    liftIO = liftEwM . liftIO
 
 runEwM :: EwM m a -> m (Errs, Warns, a)
 runEwM action = unEwM action (panic "processArgs: no arg yet") emptyBag emptyBag
@@ -158,40 +179,17 @@ liftEwM action = EwM (\_ es ws -> do { r <- action; return (es, ws, r) })
 
 
 --------------------------------------------------------
--- A state monad for use in the command-line parser
---------------------------------------------------------
-
--- (CmdLineP s) typically instantiates the 'm' in (EwM m) and (OptKind m)
-newtype CmdLineP s a = CmdLineP { runCmdLine :: s -> (a, s) }
-    deriving (Functor)
-
-instance Applicative (CmdLineP s) where
-    pure a = CmdLineP $ \s -> (a, s)
-    (<*>) = ap
-
-instance Monad (CmdLineP s) where
-    m >>= k = CmdLineP $ \s ->
-                  let (a, s') = runCmdLine m s
-                  in runCmdLine (k a) s'
-
-
-getCmdLineState :: CmdLineP s s
-getCmdLineState   = CmdLineP $ \s -> (s,s)
-putCmdLineState :: s -> CmdLineP s ()
-putCmdLineState s = CmdLineP $ \_ -> ((),s)
-
-
---------------------------------------------------------
 --         Processing arguments
 --------------------------------------------------------
 
 processArgs :: Monad m
-            => [Flag m]               -- cmdline parser spec
-            -> [Located String]       -- args
+            => [Flag m]               -- ^ cmdline parser spec
+            -> [Located String]       -- ^ args
+            -> (FilePath -> EwM m [Located String]) -- ^ response file handler
             -> m ( [Located String],  -- spare args
                    [Err],  -- errors
                    [Warn] ) -- warnings
-processArgs spec args = do
+processArgs spec args handleRespFile = do
     (errs, warns, spare) <- runEwM action
     return (spare, bagToList errs, bagToList warns)
   where
@@ -200,6 +198,10 @@ processArgs spec args = do
     -- process :: [Located String] -> [Located String] -> EwM m [Located String]
     process [] spare = return (reverse spare)
 
+    process (L _ ('@' : resp_file) : args) spare = do
+        resp_args <- handleRespFile resp_file
+        process (resp_args ++ args) spare
+
     process (locArg@(L _ ('-' : arg)) : args) spare =
         case findArg spec arg of
             Just (rest, opt_kind) ->
@@ -319,6 +321,14 @@ missingArgErr f = Left ("missing argument for flag: " ++ f)
 -- Utils
 --------------------------------------------------------
 
+-- | Parse a response file into arguments.
+parseResponseFile :: MonadIO m => FilePath -> EwM m [Located String]
+parseResponseFile path = do
+  res <- liftIO $ fmap Right (readFile path) `catch`
+    \(e :: IOException) -> pure (Left e)
+  case res of
+    Left _err -> addErr "Could not open response file" >> return []
+    Right resp_file -> return $ map (mkGeneralLocated path) (unescapeArgs resp_file)
 
 -- See Note [Handling errors when parsing command-line flags]
 errorsToGhcException :: [(String,    -- Location
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index c9a785b4f5..e6e0557492 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -160,6 +160,11 @@ module GHC.Driver.Session (
         impliedOffGFlags,
         impliedXFlags,
 
+        -- ** State
+        CmdLineP(..), runCmdLineP,
+        getCmdLineState, putCmdLineState,
+        processCmdLineP,
+
         -- ** Parsing DynFlags
         parseDynamicFlagsCmdLine,
         parseDynamicFilePragma,
@@ -262,6 +267,8 @@ import Control.Monad.Trans.Class
 import Control.Monad.Trans.Writer
 import Control.Monad.Trans.Reader
 import Control.Monad.Trans.Except
+import Control.Monad.Trans.State as State
+import Data.Functor.Identity
 
 import Data.Ord
 import Data.Char
@@ -1864,20 +1871,56 @@ parseDynamicFilePragma :: MonadIO m => DynFlags -> [Located String]
                           -- list of warnings.
 parseDynamicFilePragma = parseDynamicFlagsFull flagsDynamic False
 
+newtype CmdLineP s a = CmdLineP (forall m. (Monad m) => StateT s m a)
+
+instance Monad (CmdLineP s) where
+    CmdLineP k >>= f = CmdLineP (k >>= \x -> case f x of CmdLineP g -> g)
+    return = pure
+
+instance Applicative (CmdLineP s) where
+    pure x = CmdLineP (pure x)
+    (<*>) = ap
+
+instance Functor (CmdLineP s) where
+    fmap f (CmdLineP k) = CmdLineP (fmap f k)
+
+getCmdLineState :: CmdLineP s s
+getCmdLineState = CmdLineP State.get
+
+putCmdLineState :: s -> CmdLineP s ()
+putCmdLineState x = CmdLineP (State.put x)
+
+runCmdLineP :: CmdLineP s a -> s -> (a, s)
+runCmdLineP (CmdLineP k) s0 = runIdentity $ runStateT k s0
+
+-- | A helper to parse a set of flags from a list of command-line arguments, handling
+-- response files.
+processCmdLineP
+    :: forall s m. MonadIO m
+    => [Flag (CmdLineP s)]  -- ^ valid flags to match against
+    -> s                    -- ^ current state
+    -> [Located String]     -- ^ arguments to parse
+    -> m (([Located String], [Err], [Warn]), s)
+                            -- ^ (leftovers, errors, warnings)
+processCmdLineP activeFlags s0 args =
+    runStateT (processArgs (map (hoistFlag getCmdLineP) activeFlags) args parseResponseFile) s0
+  where
+    getCmdLineP :: CmdLineP s a -> StateT s m a
+    getCmdLineP (CmdLineP k) = k
 
 -- | Parses the dynamically set flags for GHC. This is the most general form of
 -- the dynamic flag parser that the other methods simply wrap. It allows
 -- saying which flags are valid flags and indicating if we are parsing
 -- arguments from the command line or from a file pragma.
-parseDynamicFlagsFull :: MonadIO m
-                  => [Flag (CmdLineP DynFlags)]    -- ^ valid flags to match against
-                  -> Bool                          -- ^ are the arguments from the command line?
-                  -> DynFlags                      -- ^ current dynamic flags
-                  -> [Located String]              -- ^ arguments to parse
-                  -> m (DynFlags, [Located String], [Warn])
+parseDynamicFlagsFull
+    :: forall m. MonadIO m
+    => [Flag (CmdLineP DynFlags)]    -- ^ valid flags to match against
+    -> Bool                          -- ^ are the arguments from the command line?
+    -> DynFlags                      -- ^ current dynamic flags
+    -> [Located String]              -- ^ arguments to parse
+    -> m (DynFlags, [Located String], [Warn])
 parseDynamicFlagsFull activeFlags cmdline dflags0 args = do
-  let ((leftover, errs, warns), dflags1)
-          = runCmdLine (processArgs activeFlags args) dflags0
+  ((leftover, errs, warns), dflags1) <- processCmdLineP activeFlags dflags0 args
 
   -- See Note [Handling errors when parsing command-line flags]
   let rdr = renderWithContext (initSDocContext dflags0 defaultUserStyle)
diff --git a/docs/users_guide/9.4.1-notes.rst b/docs/users_guide/9.4.1-notes.rst
index cea17cac60..0273859173 100644
--- a/docs/users_guide/9.4.1-notes.rst
+++ b/docs/users_guide/9.4.1-notes.rst
@@ -60,6 +60,9 @@ Language
 Compiler
 ~~~~~~~~
 
+- The compiler now accepts arguments via GNU-style response files
+  (:ghc-ticket:`16476`).
+
 - New :ghc-flag:`-Wredundant-strictness-flags` that checks for strictness flags
   (``!``) applied to unlifted types, which are always strict.
 
diff --git a/docs/users_guide/using.rst b/docs/users_guide/using.rst
index 628dfab0f3..ee61a89ce1 100644
--- a/docs/users_guide/using.rst
+++ b/docs/users_guide/using.rst
@@ -85,6 +85,17 @@ all files; you cannot, for example, invoke
 ``ghc -c -O1 Foo.hs -O2 Bar.hs`` to apply different optimisation levels
 to the files ``Foo.hs`` and ``Bar.hs``.
 
+In addition to passing arguments via the command-line, arguments can be passed
+via GNU-style response files. For instance,
+
+.. code-block:: bash
+
+    $ cat response-file
+    -O1
+    Hello.hs
+    -o Hello
+    $ ghc @response-file
+
 .. note::
 
     .. index::
diff --git a/ghc/Main.hs b/ghc/Main.hs
index 3cb71b77e8..8e30d1a765 100644
--- a/ghc/Main.hs
+++ b/ghc/Main.hs
@@ -560,10 +560,9 @@ parseModeFlags :: [Located String]
                       [Located String],
                       [Warn])
 parseModeFlags args = do
-  let ((leftover, errs1, warns), (mModeFlag, units, errs2, flags')) =
-          runCmdLine (processArgs mode_flags args)
-                     (Nothing, [], [], [])
-      mode = case mModeFlag of
+  ((leftover, errs1, warns), (mModeFlag, units, errs2, flags')) <-
+        processCmdLineP mode_flags (Nothing, [], [], []) args
+  let mode = case mModeFlag of
              Nothing     -> doMakeMode
              Just (m, _) -> m