[commit: ghc] master: OPTIONS_GHC compiler flags may contain spaces (#4931) (fbc2537)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/fbc2537c0b2cbe947684bb39669643f1ef9d96c0/ghc

>---------------------------------------------------------------

commit fbc2537c0b2cbe947684bb39669643f1ef9d96c0
Author: Thomas Miedema <thomasmiedema at gmail.com>
Date:   Wed Nov 11 11:05:16 2015 +0100

    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


>---------------------------------------------------------------

fbc2537c0b2cbe947684bb39669643f1ef9d96c0
 compiler/main/HeaderInfo.hs         |  5 +++--
 compiler/utils/Util.hs              | 41 ++++++++++++++++++++++++-------------
 testsuite/tests/driver/T4931.hs     |  8 ++++++++
 testsuite/tests/driver/T4931.stdout |  1 +
 testsuite/tests/driver/all.T        |  1 +
 5 files changed, 40 insertions(+), 16 deletions(-)

diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs
index b4c3f81..08c7619 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 e9b9d3f..7139eea 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
diff --git a/testsuite/tests/driver/T4931.hs b/testsuite/tests/driver/T4931.hs
new file mode 100644
index 0000000..08b583a
--- /dev/null
+++ b/testsuite/tests/driver/T4931.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -DFOO="bar baz" #-}
+main = print FOO
+
+-- Test that GHC can compile option pragmas containing spaces.
+-- When a .hsc contains `#define FOO "bar baz"`, hsc2hs emits:
+--
+--     {-# OPTIONS_GHC -optc-DFOO="bar baz" #-}
diff --git a/testsuite/tests/driver/T4931.stdout b/testsuite/tests/driver/T4931.stdout
new file mode 100644
index 0000000..447cd7a
--- /dev/null
+++ b/testsuite/tests/driver/T4931.stdout
@@ -0,0 +1 @@
+"bar baz"
diff --git a/testsuite/tests/driver/all.T b/testsuite/tests/driver/all.T
index 7c74cb6..5c0de6e 100644
--- a/testsuite/tests/driver/all.T
+++ b/testsuite/tests/driver/all.T
@@ -459,3 +459,4 @@ test('T9360b', normal, run_command, ['{compiler} -e "" --interactive'])
 
 test('T10970', normal, compile_and_run, ['-hide-all-packages -package base -package containers'])
 test('T10970a', normal, compile_and_run, [''])
+test('T4931', normal, compile_and_run, [''])