diff --git a/cabal-install/src/Distribution/Client/Init/Simple.hs b/cabal-install/src/Distribution/Client/Init/Simple.hs
index 663fe76b66d31356c9fb6937785cb3feabc16b81..1b624b373a3e9c15a90cfaf7b4151ab6c9df5680 100644
--- 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
index 8fd0788e1a3244b863befb9c95850dc1003e0d34..6db91d9cf98f3be482a717fd2418be02f97d3b4f 100644
--- 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,7 +2231,8 @@ 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)))
@@ -2234,33 +2240,38 @@ initOptions _ =
, 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
index b27a36305b7445b9d75dbf2078964a78776b72e8..3466ac0eb0eb5bb442f024239b2eafab91bc058f 100644
--- 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
new file mode 100644
index 0000000000000000000000000000000000000000..f70b312fb2b901bd547483e5fc275450a46d13fc
--- /dev/null
+++ 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
+
+}