Fix and improve list parser of cabal init cli (#8663)

fendor · mergify[bot] · web-flow · commit 8aad429e1c4a · 2023-01-23T12:03:53.000Z
* Fix cli list parse errors in `cabal init`

Occurrences of `Flag [a]` behave in a slightly unexpected way. The monoid
instance of `Flag` is right associative and discard the value on the
left.
Thus, make sure we merge the contents of the flags, instead of using the
monoid instance of `Flag` itself.

* Document fixes and improvements

Co-authored-by: mergify[bot] &lt;37929162+mergify[bot]@users.noreply.github.com&gt;
diff --git a/cabal-install/src/Distribution/Client/Init/Simple.hs b/cabal-install/src/Distribution/Client/Init/Simple.hs
@@ -16,7 +16,7 @@ import Distribution.Client.Types.SourcePackageDb (SourcePackageDb(..))
 import qualified Data.List.NonEmpty as NEL
 import Distribution.Client.Init.Utils (currentDirPkgName, mkPackageNameDep, fixupDocFiles)
 import Distribution.Client.Init.Defaults
-import Distribution.Simple.Flag (fromFlagOrDefault, flagElim, Flag(..))
+import Distribution.Simple.Flag (fromFlagOrDefault, flagElim, Flag (..))
 import Distribution.Client.Init.FlagExtractors
 import qualified Data.Set as Set
 import Distribution.Types.Dependency
@@ -170,6 +170,6 @@ addBaseDepToFlags pkgIx initFlags = case dependencies initFlags of
       return $ initFlags
         { dependencies = Flag $ based ++ as
         }
-  _ -> do
+  NoFlag -> do
     based <- dependenciesPrompt pkgIx initFlags
     return initFlags { dependencies = Flag based }
diff --git a/cabal-install/src/Distribution/Client/Setup.hs b/cabal-install/src/Distribution/Client/Setup.hs
@@ -112,7 +112,7 @@ import Distribution.Types.PackageVersionConstraint
 import Distribution.Types.UnqualComponentName
          ( unqualComponentNameToPackageName )
 import Distribution.PackageDescription
-         ( BuildType(..), RepoKind(..), LibraryName(..) )
+         ( BuildType(..), RepoKind(..), LibraryName(..), Dependency )
 import Distribution.System ( Platform )
 import Distribution.ReadE
          ( ReadE(..), succeedReadE, parsecToReadE, parsecToReadEErr, unexpectMsgString )
@@ -127,6 +127,8 @@ import Distribution.Client.GlobalFlags
          )
 import Distribution.Client.ManpageFlags (ManpageFlags, defaultManpageFlags, manpageOptions)
 import Distribution.FieldGrammar.Newtypes (SpecVersion (..))
+import Distribution.Parsec
+         ( parsecCommaList  )
 
 import Data.List
          ( deleteFirstsBy )
@@ -2166,12 +2168,14 @@ initOptions _ =
 
   , option ['x'] ["extra-source-file"]
     "Extra source file to be distributed with tarball."
-    IT.extraSrc (\v flags -> flags { IT.extraSrc = v })
+    IT.extraSrc
+    (\v flags -> flags { IT.extraSrc = mergeListFlag (IT.extraSrc flags) v })
     (reqArg' "FILE" (Flag . (:[]))
                     (fromFlagOrDefault []))
   , option [] ["extra-doc-file"]
     "Extra doc file to be distributed with tarball."
-    IT.extraDoc (\v flags -> flags { IT.extraDoc = v })
+    IT.extraDoc
+    (\v flags -> flags { IT.extraDoc = mergeListFlag (IT.extraDoc flags) v })
     (reqArg' "FILE" (Flag . (:[])) (fromFlagOrDefault []))
 
   , option [] ["lib", "is-library"]
@@ -2199,7 +2203,8 @@ initOptions _ =
 
       , option [] ["test-dir"]
         "Directory containing tests."
-        IT.testDirs (\v flags -> flags { IT.testDirs = v })
+        IT.testDirs (\v flags ->
+          flags { IT.testDirs = mergeListFlag (IT.testDirs flags) v })
         (reqArg' "DIR" (Flag . (:[]))
                        (fromFlagOrDefault []))
 
@@ -2226,41 +2231,47 @@ initOptions _ =
   , option ['o'] ["expose-module"]
     "Export a module from the package."
     IT.exposedModules
-    (\v flags -> flags { IT.exposedModules = v })
+    (\v flags -> flags { IT.exposedModules =
+      mergeListFlag (IT.exposedModules flags) v})
     (reqArg "MODULE" (parsecToReadE ("Cannot parse module name: "++)
                                  (Flag . (:[]) <$> parsec))
                      (flagElim [] (fmap prettyShow)))
 
   , option [] ["extension"]
     "Use a LANGUAGE extension (in the other-extensions field)."
     IT.otherExts
-    (\v flags -> flags { IT.otherExts = v })
+    (\v flags -> flags { IT.otherExts =
+      mergeListFlag (IT.otherExts flags) v })
     (reqArg "EXTENSION" (parsecToReadE ("Cannot parse extension: "++)
                                     (Flag . (:[]) <$> parsec))
                         (flagElim [] (fmap prettyShow)))
 
   , option ['d'] ["dependency"]
-    "Package dependency."
-    IT.dependencies (\v flags -> flags { IT.dependencies = v })
-    (reqArg "PACKAGE" (parsecToReadE ("Cannot parse dependency: "++)
-                                  (Flag . (:[]) <$> parsec))
-                      (flagElim [] (fmap prettyShow)))
+    "Package dependencies. Permits comma separated list of dependencies."
+    IT.dependencies
+    (\v flags -> flags { IT.dependencies =
+      mergeListFlag (IT.dependencies flags) v })
+    (reqArg "DEPENDENCIES" (fmap Flag dependenciesReadE)
+                           (fmap prettyShow . fromFlagOrDefault []))
 
   , option [] ["application-dir"]
     "Directory containing package application executable."
-    IT.applicationDirs (\v flags -> flags { IT.applicationDirs = v})
+    IT.applicationDirs (\v flags -> flags { IT.applicationDirs =
+      mergeListFlag (IT.applicationDirs flags) v})
     (reqArg' "DIR" (Flag . (:[]))
                    (fromFlagOrDefault []))
 
   , option [] ["source-dir", "sourcedir"]
     "Directory containing package library source."
-    IT.sourceDirs (\v flags -> flags { IT.sourceDirs = v })
+    IT.sourceDirs (\v flags -> flags { IT.sourceDirs =
+      mergeListFlag (IT.sourceDirs flags) v })
     (reqArg' "DIR" (Flag. (:[]))
                    (fromFlagOrDefault []))
 
   , option [] ["build-tool"]
     "Required external build tool."
-    IT.buildTools (\v flags -> flags { IT.buildTools = v })
+    IT.buildTools (\v flags -> flags { IT.buildTools =
+      mergeListFlag (IT.buildTools flags) v })
     (reqArg' "TOOL" (Flag . (:[]))
                     (fromFlagOrDefault []))
 
@@ -2272,6 +2283,16 @@ initOptions _ =
 
   , optionVerbosity IT.initVerbosity (\v flags -> flags { IT.initVerbosity = v })
   ]
+  where
+    dependenciesReadE :: ReadE [Dependency]
+    dependenciesReadE =
+      parsecToReadE
+        ("Cannot parse dependencies: " ++)
+        (parsecCommaList parsec)
+
+    mergeListFlag :: Flag [a] -> Flag [a] -> Flag [a]
+    mergeListFlag currentFlags v =
+      Flag $ concat (flagToList currentFlags ++ flagToList v)
 
 -- ------------------------------------------------------------
 -- * Copy and Register
diff --git a/cabal-install/tests/UnitTests/Distribution/Client/Init/NonInteractive.hs b/cabal-install/tests/UnitTests/Distribution/Client/Init/NonInteractive.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase #-}
 module UnitTests.Distribution.Client.Init.NonInteractive
   ( tests
   ) where
@@ -24,6 +25,8 @@ import Data.List (foldl')
 import qualified Data.Set as Set
 import Distribution.Client.Init.Utils (mkPackageNameDep, mkStringyDep)
 import Distribution.FieldGrammar.Newtypes
+import Distribution.Simple.Command
+import Distribution.Client.Setup (initCommand)
 
 tests
     :: Verbosity
@@ -43,6 +46,9 @@ tests _v _initFlags comp pkgIx srcDb =
     , testGroup "non-interactive tests"
       [ nonInteractiveTests pkgIx srcDb comp
       ]
+    , testGroup "cli parser tests"
+      [ cliListParserTests
+      ]
     ]
 
 driverFunctionTest
@@ -1265,3 +1271,136 @@ testGo label f g h inputs = testCase label $
   case (_runPrompt $ f emptyFlags) (NEL.fromList inputs) of
     Left  x -> g x
     Right x -> h x
+
+cliListParserTests :: TestTree
+cliListParserTests = testGroup "cli list parser"
+  [ testCase "Single extraSrc" $ do
+      flags <- runParserTest ["-x", "Generated.hs"]
+      flags @?= emptyFlags
+        { extraSrc = Flag ["Generated.hs"]
+        }
+  , testCase "Multiple extraSrc" $ do
+      flags <- runParserTest ["-x", "Gen1.hs", "-x", "Gen2.hs", "-x", "Gen3.hs"]
+      flags @?= emptyFlags
+        { extraSrc = Flag ["Gen1.hs", "Gen2.hs", "Gen3.hs"]
+        }
+  , testCase "Single extraDoc" $ do
+      flags <- runParserTest ["--extra-doc-file", "README"]
+      flags @?= emptyFlags
+        { extraDoc = Flag $ ["README"]
+        }
+  , testCase "Multiple extraDoc" $ do
+      flags <- runParserTest ["--extra-doc-file", "README",
+                              "--extra-doc-file", "CHANGELOG",
+                              "--extra-doc-file", "LICENSE"]
+      flags @?= emptyFlags
+        { extraDoc = Flag $ map fromString ["README", "CHANGELOG", "LICENSE"]
+        }
+  , testCase "Single exposedModules" $ do
+      flags <- runParserTest ["-o", "Test"]
+      flags @?= emptyFlags
+        { exposedModules = Flag $ map fromString ["Test"]
+        }
+  , testCase "Multiple exposedModules" $ do
+      flags <- runParserTest ["-o", "Test", "-o", "Test2", "-o", "Test3"]
+      flags @?= emptyFlags
+        { exposedModules = Flag $ map fromString ["Test", "Test2", "Test3"]
+        }
+  -- there is no otherModules cli flag
+  -- , testCase "Single otherModules" $ do
+  --     flags <- runParserTest ["-o", "Test"]
+  --     flags @?= dummyFlags
+  --       { otherModules = Flag $ map fromString ["Test"]
+  --       }
+  -- , testCase "Multiple otherModules" $ do
+  --     flags <- runParserTest ["-o", "Test", "-o", "Test2", "-o", "Test3"]
+  --     flags @?= dummyFlags
+  --       { otherModules = Flag $ map fromString ["Test", "Test2", "Test3"]
+  --       }
+  , testCase "Single otherExts" $ do
+      flags <- runParserTest ["--extension", "OverloadedStrings"]
+      flags @?= emptyFlags
+        { otherExts = Flag [EnableExtension OverloadedStrings]
+        }
+  , testCase "Multiple otherExts" $ do
+      flags <- runParserTest ["--extension", "OverloadedStrings",
+                              "--extension", "FlexibleInstances",
+                              "--extension", "FlexibleContexts"]
+      flags @?= emptyFlags
+        { otherExts = Flag [EnableExtension OverloadedStrings,
+                            EnableExtension FlexibleInstances,
+                            EnableExtension FlexibleContexts]
+        }
+  , testCase "Single dependency" $ do
+      flags <- runParserTest ["-d", "base"]
+      flags @?= emptyFlags
+        { dependencies = Flag [mkStringyDep "base"]
+        }
+  , testCase "Multiple dependency flags" $ do
+      flags <- runParserTest ["-d", "base", "-d", "vector"]
+      flags @?= emptyFlags
+        { dependencies = Flag $ fmap mkStringyDep ["base", "vector"]
+        }
+  , testCase "Comma separated list of dependencies" $ do
+      flags <- runParserTest ["-d", "base,vector"]
+      flags @?= emptyFlags
+        { dependencies = Flag $ fmap mkStringyDep ["base", "vector"]
+        }
+  , testCase "Single applicationDirs" $ do
+      flags <- runParserTest ["--application-dir", "app"]
+      flags @?= emptyFlags
+        { applicationDirs = Flag ["app"]
+        }
+  , testCase "Multiple applicationDirs" $ do
+      flags <- runParserTest ["--application-dir", "app",
+                              "--application-dir", "exe",
+                              "--application-dir", "srcapp"]
+      flags @?= emptyFlags
+        { applicationDirs = Flag ["app", "exe", "srcapp"]
+        }
+  , testCase "Single sourceDirs" $ do
+      flags <- runParserTest ["--source-dir", "src"]
+      flags @?= emptyFlags
+        { sourceDirs = Flag ["src"]
+        }
+  , testCase "Multiple sourceDirs" $ do
+      flags <- runParserTest ["--source-dir", "src",
+                              "--source-dir", "lib",
+                              "--source-dir", "sources"]
+      flags @?= emptyFlags
+        { sourceDirs = Flag ["src", "lib", "sources"]
+        }
+  , testCase "Single buildTools" $ do
+      flags <- runParserTest ["--build-tool", "happy"]
+      flags @?= emptyFlags
+        { buildTools = Flag ["happy"]
+        }
+  , testCase "Multiple buildTools" $ do
+      flags <- runParserTest ["--build-tool", "happy",
+                              "--build-tool", "alex",
+                              "--build-tool", "make"]
+      flags @?= emptyFlags
+        { buildTools = Flag ["happy", "alex", "make"]
+        }
+  , testCase "Single testDirs" $ do
+      flags <- runParserTest ["--test-dir", "test"]
+      flags @?= emptyFlags
+        { testDirs = Flag ["test"]
+        }
+  , testCase "Multiple testDirs" $ do
+      flags <- runParserTest ["--test-dir", "test",
+                              "--test-dir", "tests",
+                              "--test-dir", "testsuite"]
+      flags @?= emptyFlags
+        { testDirs = Flag ["test", "tests", "testsuite"]
+        }
+  ]
+  where
+    assumeAllParse :: CommandParse (InitFlags -> InitFlags, [String]) -> IO InitFlags
+    assumeAllParse = \case
+      CommandReadyToGo (flagsF, []) -> pure (flagsF emptyFlags)
+      _ -> assertFailure "Expected successful parse"
+
+    runParserTest :: [String] -> IO InitFlags
+    runParserTest opts = do
+      assumeAllParse $ commandParseArgs initCommand False opts
diff --git a/changelog.d/pr-8663 b/changelog.d/pr-8663
@@ -0,0 +1,19 @@
+synopsis:  Fix and improve list parser of cabal init cli
+packages: cabal-install
+prs: #8663
+issues: #8659
+
+description: {
+Occurrences of 'Flag [a]' seem to behave in an unexpected way. The monoid
+instance of 'Flag' is right associative and discard the value on the
+left, but we want to merge the contents of 'Flag'.
+
+Permits:
+- cabal init -d base -d vector -d containers
+
+Fixes for all Flag '[a]' the cli parser in cabal init. Adds cli parser tests.
+
+Adds the feature to specify a comma-separated list of dependencies:
+- cabal init -d base,vector,containers
+
+}
