From 54d9edbb47657ba67b5b1c5248f295c772bf2948 Mon Sep 17 00:00:00 2001
From: David Waern <davve@dtek.chalmers.se>
Date: Wed, 17 Oct 2007 16:02:28 +0000
Subject: Add --optghc=.. style flag passing to GHC

---
 src/Haddock/GHC.hs     | 42 +++++++++++++++---------------------------
 src/Haddock/Options.hs | 13 +++++++++----
 src/Main.hs            | 10 +++-------
 3 files changed, 27 insertions(+), 38 deletions(-)

(limited to 'src')

diff --git a/src/Haddock/GHC.hs b/src/Haddock/GHC.hs
index b4b9dd3f..8c83912a 100644
--- a/src/Haddock/GHC.hs
+++ b/src/Haddock/GHC.hs
@@ -8,8 +8,6 @@
 module Haddock.GHC (
   startGhc,
   loadPackages,
-  tryParseStaticFlags,
-  parseGhcFlags,
   module Haddock.GHC.Typecheck,
   module Haddock.GHC.Utils
 ) where
@@ -32,18 +30,20 @@ import StaticFlags
 
 -- | Start a GHC session with the -haddock flag set. Also turn off 
 -- compilation and linking.  
-startGhc :: String -> IO (Session, DynFlags)
-startGhc libDir = do
-  session <- newSession (Just libDir)
-  flags   <- getSessionDynFlags session
-  let flags' = dopt_set flags Opt_Haddock
-  let flags'' = flags' {
+startGhc :: String -> [String] -> IO (Session, DynFlags)
+startGhc libDir flags = do
+  restFlags <- parseStaticFlags flags
+  session   <- newSession (Just libDir)
+  dynflags  <- getSessionDynFlags session
+  let dynflags' = dopt_set dynflags Opt_Haddock
+  let dynflags'' = dynflags' {
       hscTarget = HscNothing,
       ghcMode   = CompManager,
       ghcLink   = NoLink
     }
-  setSessionDynFlags session flags''
-  return (session, flags'')
+  dynflags''' <- parseGhcFlags dynflags'' restFlags flags
+  setSessionDynFlags session dynflags'''
+  return (session, dynflags''')
 
 
 -- | Expose the list of packages to GHC. Then initialize GHC's package state
@@ -88,21 +88,9 @@ loadPackages session pkgStrs = do
     handleParse Nothing = throwE "Could not parse package identifier"
 
 
--- | Filter out the GHC specific flags and try to parse and set them as static 
--- flags. Return a list of flags that couldn't be parsed. 
-tryParseStaticFlags flags = do
-  let ghcFlags = [ str | Flag_GhcFlag str <- flags ]
-  parseStaticFlags ghcFlags
-
-
 -- | Try to parse dynamic GHC flags
-parseGhcFlags session ghcFlags = do
-  dflags <- getSessionDynFlags session
-  foldlM parseFlag dflags (map words ghcFlags)
-  where 
-    -- try to parse a flag as either a dynamic or static GHC flag
-    parseFlag dynflags ghcFlag = do
-      (dynflags', rest) <- parseDynamicFlags dynflags ghcFlag
-      when (rest == ghcFlag) $
-          throwE ("Couldn't parse GHC flag: " ++ (unwords ghcFlag))           
-      return dynflags'
+parseGhcFlags dynflags flags origFlags = do
+  (dynflags', rest) <- parseDynamicFlags dynflags flags
+  if not (null rest)
+    then throwE ("Couldn't parse GHC options: " ++ (unwords origFlags))
+    else return dynflags'
diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs
index c330f35e..89850f9c 100644
--- a/src/Haddock/Options.hs
+++ b/src/Haddock/Options.hs
@@ -8,7 +8,8 @@
 module Haddock.Options (
   parseHaddockOpts,
   Flag(..),
-  getUsage
+  getUsage,
+  makeGhcFlags
 ) where
 
 
@@ -35,6 +36,10 @@ parseHaddockOpts words =
       throwE (concat errors ++ usage)
 
 
+makeGhcFlags :: [Flag] -> [String]
+makeGhcFlags flags = [ option | Flag_OptGhc option <- flags ]
+
+
 data Flag
   = Flag_CSS String
   | Flag_Debug
@@ -64,7 +69,7 @@ data Flag
   | Flag_IgnoreAllExports
   | Flag_HideModule String
   | Flag_UsePackage String
-  | Flag_GhcFlag String
+  | Flag_OptGhc String
   | Flag_GhcLibDir String
   deriving (Eq)
 
@@ -131,6 +136,6 @@ options backwardsCompat =
 	"behave as if MODULE has the hide attribute",
     Option [] ["use-package"] (ReqArg Flag_UsePackage "PACKAGE")
 	"the modules being processed depend on PACKAGE",
-    Option ['g'] [] (ReqArg Flag_GhcFlag "FLAGS + ARGS")
- 	("send a flag to GHC")
+    Option [] ["optghc"] (ReqArg Flag_OptGhc "OPTION")
+ 	"Forward option to GHC"
    ]
diff --git a/src/Main.hs b/src/Main.hs
index 980e2023..c900529c 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -104,13 +104,9 @@ main = handleTopExceptions $ do
   (flags, fileArgs) <- parseHaddockOpts args
   libDir <- handleEasyFlags flags fileArgs
   
-  -- initialize GHC 
-  restGhcFlags <- tryParseStaticFlags flags
-  (session, _) <- startGhc libDir
-
-  -- parse and set the GHC flags
-  dynflags <- parseGhcFlags session restGhcFlags
-  setSessionDynFlags session dynflags
+  -- initialize GHC
+  let ghcFlags = makeGhcFlags flags
+  (session, dynflags) <- startGhc libDir ghcFlags
 
   -- get the -use-package packages, load them in GHC,
   -- and try to get the corresponding installed HaddockPackages
-- 
cgit v1.2.3