OPTIONS_GHC compiler flags may contain spaces (#4931)

When a .hsc contains `#define FOO "bar baz"`, hsc2hs emits:

    {-# OPTIONS_GHC -optc-DFOO="bar baz" #-}

Make sure GHC can compile this, by tweaking `HeaderInfo.getOptions` a
bit.

Test Plan: driver/T4931

Reviewers: austin, bgamari

Reviewed By: bgamari

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

GHC Trac Issues: #4931

2 files changed, 30 insertions, 16 deletions

diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs
index b4c3f81678..08c761994a 100644
--- a/compiler/main/HeaderInfo.hs
+++ b/compiler/main/HeaderInfo.hs
@@ -236,8 +236,9 @@ getOptions' dflags toks
           parseToks (open:close:xs)
               | IToptions_prag str <- getToken open
               , ITclose_prag       <- getToken close
-              = map (L (getLoc open)) (words str) ++
-                parseToks xs
+              = case toArgs str of
+                  Left err -> panic ("getOptions'.parseToks: " ++ err)
+                  Right args -> map (L (getLoc open)) args ++ parseToks xs
           parseToks (open:close:xs)
               | ITinclude_prag str <- getToken open
               , ITclose_prag       <- getToken close
diff --git a/compiler/utils/Util.hs b/compiler/utils/Util.hs
index e9b9d3f3df..7139eea6e9 100644
--- a/compiler/utils/Util.hs
+++ b/compiler/utils/Util.hs
@@ -872,22 +872,35 @@ toArgs str
                        Left ("Couldn't read " ++ show str ++ "as [String]")
       s -> toArgs' s
  where
+  toArgs' :: String -> Either String [String]
+  -- Remove outer quotes:
+  -- > toArgs' "\"foo\" \"bar baz\""
+  -- Right ["foo", "bar baz"]
+  --
+  -- Keep inner quotes:
+  -- > toArgs' "-DFOO=\"bar baz\""
+  -- Right ["-DFOO=\"bar baz\""]
   toArgs' s = case dropWhile isSpace s of
               [] -> Right []
-              ('"' : _) -> case reads s of
-                           [(arg, rest)]
-                              -- rest must either be [] or start with a space
-                            | all isSpace (take 1 rest) ->
-                               case toArgs' rest of
-                               Left err -> Left err
-                               Right args -> Right (arg : args)
-                           _ ->
-                               Left ("Couldn't read " ++ show s ++ "as String")
-              s' -> case break isSpace s' of
-                    (arg, s'') -> case toArgs' s'' of
-                                  Left err -> Left err
-                                  Right args -> Right (arg : args)
-
+              ('"' : _) -> do
+                    -- readAsString removes outer quotes
+                    (arg, rest) <- readAsString s
+                    (arg:) `fmap` toArgs' rest
+              s' -> case break (isSpace <||> (== '"')) s' of
+                    (argPart1, s''@('"':_)) -> do
+                        (argPart2, rest) <- readAsString s''
+                        -- show argPart2 to keep inner quotes
+                        ((argPart1 ++ show argPart2):) `fmap` toArgs' rest
+                    (arg, s'') -> (arg:) `fmap` toArgs' s''
+
+  readAsString :: String -> Either String (String, String)
+  readAsString s = case reads s of
+                [(arg, rest)]
+                    -- rest must either be [] or start with a space
+                    | all isSpace (take 1 rest) ->
+                    Right (arg, rest)
+                _ ->
+                    Left ("Couldn't read " ++ show s ++ "as String")
 {-
 -- -----------------------------------------------------------------------------
 -- Floats