diff --git a/cabal-install/src/Distribution/Client/Init/Simple.hs b/cabal-install/src/Distribution/Client/Init/Simple.hs index 663fe76b66d..1b624b373a3 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 8fd0788e1a3..6db91d9cf98 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 b27a36305b7..3466ac0eb0e 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 00000000000..f70b312fb2b --- /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 + +}