Fix splitArgs function.

- Closes haskell#8090.
ulysses4ever · Jun 8, 2022 · 8d30712 · 8d30712
1 parent a155b07
commit 8d30712
Show file tree

Hide file tree

Showing 2 changed files with 34 additions and 9 deletions.
diff --git a/Cabal-tests/tests/UnitTests/Distribution/Simple/Command.hs b/Cabal-tests/tests/UnitTests/Distribution/Simple/Command.hs
@@ -4,27 +4,45 @@ module UnitTests.Distribution.Simple.Command
 
 import Distribution.Simple.Command
 import qualified Distribution.Simple.Flag as Flag
-import Distribution.Simple.Setup (optionVerbosity)
+import Distribution.Simple.Setup (optionVerbosity, testOptions, testCommand, splitArgs)
 import qualified Distribution.Verbosity as Verbosity
+import Distribution.Simple.InstallDirs (toPathTemplate)
 import Test.Tasty
 import Test.Tasty.HUnit
 
 argumentTests :: [TestTree]
 argumentTests =
   [ testCase "parses verbosity successfully" $ do
       let p = commandParseArgs cmdUI isGlobal ["-v2"]
-      assertEqual "expected verbose" (Right verbose) $ evalParse p
+      assertEqual "expected verbose" (Right verbose) $ evalParseWith Flag.NoFlag p
   , testCase "handles argument parse error gracefully" $ do
       let p = commandParseArgs cmdUI isGlobal ["-v=2"]
-      assertEqual "expected error" (Left "errors") $ evalParse p
+      assertEqual "expected error" (Left "errors") $ evalParseWith Flag.NoFlag p
+  , testCase "handles test-options successfully" $ do
+      let p = commandParseArgs testCommand isGlobal ["--test-options=-p 'find root'"]
+      assertEqual "expected test options split" (Right $ fmap toPathTemplate ["-p", "find root"]) $
+        (fmap testOptions (evalParseWith (commandDefaultFlags testCommand) p))
+  , testCase "handles test-options successfully" $ do
+      let p = commandParseArgs testCommand isGlobal ["--test-options=-p \"find root\""]
+      assertEqual "expected test options split" (Right $ fmap toPathTemplate ["-p", "find root"]) $
+        (fmap testOptions (evalParseWith (commandDefaultFlags testCommand) p))
+  , testCase "handle quoted things sensibly in options" $
+      assertEqual "expect options to be split" ["--foo=C:/Program Files/Bar/", "--baz"] $
+        splitArgs "--foo=\"C:/Program Files/Bar/\" --baz"
+  , testCase "handle quoted things sensibly in options" $
+      assertEqual "expect options to be split" ["-DMSGSTR=\"foo bar\"", "--baz"] $
+        splitArgs "\"-DMSGSTR=\\\"foo bar\\\"\" --baz"
+  , testCase "handle quoted things sensibly in options" $
+      assertEqual "expect options to be split" ["-p", "find root"] $
+        splitArgs "-p 'find root'"
   ]
   where
     -- evaluate command parse result, to force possible exceptions in 'f'
-    evalParse p = case p of
+    evalParseWith fs p = case p of
       CommandErrors _         -> Left "errors"
       CommandHelp _           -> Left "help"
       CommandList _           -> Left "list"
-      CommandReadyToGo (f, _) -> Right $ f Flag.NoFlag
+      CommandReadyToGo (f, _) -> Right $ f fs
     verbose = Flag.Flag Verbosity.verbose
     isGlobal = True
     cmdUI = CommandUI

diff --git a/Cabal/src/Distribution/Simple/Setup.hs b/Cabal/src/Distribution/Simple/Setup.hs
@@ -2262,11 +2262,11 @@ configureProg verbosity programDb prog = do
 -- | Helper function to split a string into a list of arguments.
 -- It's supposed to handle quoted things sensibly, eg:
 --
--- > splitArgs "--foo=\"C:/Program Files/Bar/" --baz"
--- >   = ["--foo=C:/Program Files/Bar", "--baz"]
+-- >>> splitArgs "--foo=\"C:/Program Files/Bar/" --baz"
+-- ["--foo=C:/Program Files/Bar", "--baz"]
 --
--- > splitArgs "\"-DMSGSTR=\\\"foo bar\\\"\" --baz"
--- >   = ["-DMSGSTR=\"foo bar\"","--baz"]
+-- >>> splitArgs "\"-DMSGSTR=\\\"foo bar\\\"\" --baz"
+-- ["-DMSGSTR=\"foo bar\"","--baz"]
 --
 splitArgs :: String -> [String]
 splitArgs  = space []
@@ -2276,8 +2276,14 @@ splitArgs  = space []
     space w ( c :s)
         | isSpace c = word w (space [] s)
     space w ('"':s) = string w s
+    space w ('\'':s) = singlyQuotedString w s
     space w s       = nonstring w s
 
+    singlyQuotedString :: String -> String -> [String]
+    singlyQuotedString w [] = word w []
+    singlyQuotedString w ('\'':s) = space w s
+    singlyQuotedString w (c:s) = singlyQuotedString (c:w) s
+
     string :: String -> String -> [String]
     string w []      = word w []
     string w ('"':s) = space w s
@@ -2286,6 +2292,7 @@ splitArgs  = space []
 
     nonstring :: String -> String -> [String]
     nonstring w  []      = word w []
+    nonstring w  ('\'':s) = singlyQuotedString w s
     nonstring w  ('"':s) = string w s
     nonstring w  ( c :s) = space (c:w) s