From c6faeae064668125721b0d5e60f067f90c538933 Mon Sep 17 00:00:00 2001
From: Austin Seipp <austin@well-typed.com>
Date: Wed, 9 Oct 2013 10:51:31 -0500
Subject: Don't consider StaticFlags when parsing arguments.

Instead, discard any static flags before parsing the command line using
GHC's DynFlags parser.

See http://ghc.haskell.org/trac/ghc/ticket/8276

Based off a patch from Simon Hengel.

Signed-off-by: Austin Seipp <austin@well-typed.com>
---
 src/Haddock.hs | 29 +++++++++++++++++------------
 1 file changed, 17 insertions(+), 12 deletions(-)

(limited to 'src/Haddock.hs')

diff --git a/src/Haddock.hs b/src/Haddock.hs
index a7ac5baf..6d16d601 100644
--- a/src/Haddock.hs
+++ b/src/Haddock.hs
@@ -59,7 +59,7 @@ import Paths_haddock
 import GHC hiding (verbosity)
 import Config
 import DynFlags hiding (verbosity)
-import StaticFlags (saveStaticFlagGlobals, restoreStaticFlagGlobals)
+import StaticFlags (discardStaticFlags)
 import Panic (handleGhcException)
 import Module
 
@@ -313,9 +313,7 @@ readInterfaceFiles name_cache_accessor pairs = do
 -- | Start a GHC session with the -haddock flag set. Also turn off
 -- compilation and linking. Then run the given 'Ghc' action.
 withGhc :: String -> [String] -> (DynFlags -> Ghc a) -> IO a
-withGhc libDir flags ghcActs = saveStaticFlagGlobals >>= \savedFlags -> do
-  -- TODO: handle warnings?
-  (restFlags, _) <- parseStaticFlags (map noLoc flags)
+withGhc libDir flags ghcActs = do
   runGhc (Just libDir) $ do
     dynflags  <- getSessionDynFlags
     let dynflags' = gopt_set dynflags Opt_Haddock
@@ -324,25 +322,32 @@ withGhc libDir flags ghcActs = saveStaticFlagGlobals >>= \savedFlags -> do
         ghcMode   = CompManager,
         ghcLink   = NoLink
       }
-    dynflags''' <- parseGhcFlags dynflags'' restFlags flags
+    dynflags''' <- parseGhcFlags dynflags''
     defaultCleanupHandler dynflags''' $ do
         -- ignore the following return-value, which is a list of packages
         -- that may need to be re-linked: Haddock doesn't do any
         -- dynamic or static linking at all!
         _ <- setSessionDynFlags dynflags'''
         ghcActs dynflags'''
-  `finally` restoreStaticFlagGlobals savedFlags
   where
-    parseGhcFlags :: MonadIO m => DynFlags -> [Located String]
-                  -> [String] -> m DynFlags
-    parseGhcFlags dynflags flags_ origFlags = do
+    parseGhcFlags :: MonadIO m => DynFlags -> m DynFlags
+    parseGhcFlags dynflags = do
       -- TODO: handle warnings?
-      (dynflags', rest, _) <- parseDynamicFlags dynflags flags_
+
+      -- NOTA BENE: We _MUST_ discard any static flags here, because we cannot
+      -- rely on Haddock to parse them, as it only parses the DynFlags. Yet if
+      -- we pass any, Haddock will fail. Since StaticFlags are global to the
+      -- GHC invocation, there's also no way to reparse/save them to set them
+      -- again properly.
+      --
+      -- This is a bit of a hack until we get rid of the rest of the remaining
+      -- StaticFlags. See GHC issue #8276.
+      let flags' = discardStaticFlags flags
+      (dynflags', rest, _) <- parseDynamicFlags dynflags (map noLoc flags')
       if not (null rest)
-        then throwE ("Couldn't parse GHC options: " ++ unwords origFlags)
+        then throwE ("Couldn't parse GHC options: " ++ unwords flags')
         else return dynflags'
 
-
 -------------------------------------------------------------------------------
 -- * Misc
 -------------------------------------------------------------------------------
-- 
cgit v1.2.3