Make the GHC API a little more powerful.

1 files changed, 19 insertions, 6 deletions

diff --git a/compiler/main/StaticFlagParser.hs b/compiler/main/StaticFlagParser.hs
index 88e92a7c03..b927f12d2c 100644
--- a/compiler/main/StaticFlagParser.hs
+++ b/compiler/main/StaticFlagParser.hs
@@ -9,7 +9,11 @@
 --
 -----------------------------------------------------------------------------
 
-module StaticFlagParser (parseStaticFlags) where
+module StaticFlagParser (
+        parseStaticFlags,
+        parseStaticFlagsFull,
+        flagsStatic
+    ) where
 
 #include "HsVersions.h"
 
@@ -46,11 +50,18 @@ import Data.List
 -- XXX: can we add an auto-generated list of static flags here?
 --
 parseStaticFlags :: [Located String] -> IO ([Located String], [Located String])
-parseStaticFlags args = do
+parseStaticFlags = parseStaticFlagsFull flagsStatic
+
+-- | Parse GHC's static flags as @parseStaticFlags@ does. However it also
+-- takes a list of available static flags, such that certain flags can be
+-- enabled or disabled through this argument.
+parseStaticFlagsFull :: [Flag IO] -> [Located String]
+                     -> IO ([Located String], [Located String])
+parseStaticFlagsFull flagsAvailable args = do
   ready <- readIORef v_opt_C_ready
   when ready $ ghcError (ProgramError "Too late for parseStaticFlags: call it before newSession")
 
-  (leftover, errs, warns1) <- processArgs static_flags args
+  (leftover, errs, warns1) <- processArgs flagsAvailable args
   when (not (null errs)) $ ghcError $ errorsToGhcException errs
 
     -- deal with the way flags: the way (eg. prof) gives rise to
@@ -62,8 +73,10 @@ parseStaticFlags args = do
   let unreg_flags | cGhcUnregisterised == "YES" = unregFlags
                   | otherwise = []
 
+    -- as these are GHC generated flags, we parse them with all static flags
+    -- in scope, regardless of what availableFlags are passed in.
   (more_leftover, errs, warns2) <-
-      processArgs static_flags (unreg_flags ++ way_flags')
+      processArgs flagsStatic (unreg_flags ++ way_flags')
 
     -- see sanity code in staticOpts
   writeIORef v_opt_C_ready True
@@ -88,7 +101,7 @@ parseStaticFlags args = do
   return (excess_prec ++ cg_flags ++ more_leftover ++ leftover,
           warns1 ++ warns2)
 
-static_flags :: [Flag IO]
+flagsStatic :: [Flag IO]
 -- All the static flags should appear in this list.  It describes how each
 -- static flag should be processed.  Two main purposes:
 -- (a) if a command-line flag doesn't appear in the list, GHC can complain
@@ -102,7 +115,7 @@ static_flags :: [Flag IO]
 -- is a prefix flag (i.e. HasArg, Prefix, OptPrefix, AnySuffix) will override
 -- flags further down the list with the same prefix.
 
-static_flags = [
+flagsStatic = [
         ------- ways --------------------------------------------------------
     Flag "prof"           (NoArg (addWay WayProf))
   , Flag "eventlog"       (NoArg (addWay WayEventLog))