From f602cd0b334d0bba4a0867f60f6154d618a695a5 Mon Sep 17 00:00:00 2001 From: Fendor Date: Mon, 12 Jul 2021 09:36:30 +0200 Subject: [PATCH] Add AmbiguityResolver to decide how to resolve ambiguity Add --pick-first-target flag Every other command defaults to what they used to do. show-build-info now just chooses the first choice, since it doesn't care about ambiguity. --- .../src/Distribution/Client/CmdBench.hs | 5 +- .../src/Distribution/Client/CmdBuild.hs | 3 +- .../Distribution/Client/CmdErrorMessages.hs | 4 +- .../src/Distribution/Client/CmdHaddock.hs | 3 +- .../src/Distribution/Client/CmdInstall.hs | 6 +- .../src/Distribution/Client/CmdListBin.hs | 2 +- .../src/Distribution/Client/CmdRepl.hs | 9 +- .../src/Distribution/Client/CmdRun.hs | 2 +- .../src/Distribution/Client/CmdSdist.hs | 4 +- .../src/Distribution/Client/CmdTest.hs | 3 +- .../src/Distribution/Client/Config.hs | 4 +- .../Client/ProjectConfig/Legacy.hs | 4 +- .../src/Distribution/Client/Setup.hs | 14 ++- .../src/Distribution/Client/TargetProblem.hs | 2 +- .../src/Distribution/Client/TargetSelector.hs | 91 +++++++++++++++---- cabal-install/tests/IntegrationTests2.hs | 58 +++++++++--- 16 files changed, 159 insertions(+), 55 deletions(-) diff --git a/cabal-install/src/Distribution/Client/CmdBench.hs b/cabal-install/src/Distribution/Client/CmdBench.hs index 7e65034e05a..68d3eecfd17 100644 --- a/cabal-install/src/Distribution/Client/CmdBench.hs +++ b/cabal-install/src/Distribution/Client/CmdBench.hs @@ -85,7 +85,8 @@ benchAction flags@NixStyleFlags {..} targetStrings globalFlags = do baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages baseCtx) (Just BenchKind) targetStrings + =<< readTargetSelectors (localPackages baseCtx) + (Just BenchKind) flags targetStrings buildCtx <- runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do @@ -118,7 +119,7 @@ benchAction flags@NixStyleFlags {..} targetStrings globalFlags = do runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes where verbosity = fromFlagOrDefault normal (configVerbosity configFlags) - cliConfig = commandLineFlagsToProjectConfig globalFlags flags + cliConfig = commandLineFlagsToProjectConfig globalFlags flags mempty -- ClientInstallFlags, not needed here -- | This defines what a 'TargetSelector' means for the @bench@ command. diff --git a/cabal-install/src/Distribution/Client/CmdBuild.hs b/cabal-install/src/Distribution/Client/CmdBuild.hs index ea59acfff19..e32325c5ec2 100644 --- a/cabal-install/src/Distribution/Client/CmdBuild.hs +++ b/cabal-install/src/Distribution/Client/CmdBuild.hs @@ -107,7 +107,8 @@ buildAction flags@NixStyleFlags { extraFlags = buildFlags, ..} targetStrings glo targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages baseCtx) Nothing targetStrings + =<< readTargetSelectors (localPackages baseCtx) + Nothing flags targetStrings buildCtx <- runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do diff --git a/cabal-install/src/Distribution/Client/CmdErrorMessages.hs b/cabal-install/src/Distribution/Client/CmdErrorMessages.hs index ae805bad899..be4e6d772a9 100644 --- a/cabal-install/src/Distribution/Client/CmdErrorMessages.hs +++ b/cabal-install/src/Distribution/Client/CmdErrorMessages.hs @@ -21,7 +21,7 @@ import Distribution.Client.TargetSelector import Distribution.Client.TargetProblem ( TargetProblem(..), TargetProblem' ) import Distribution.Client.TargetSelector - ( ComponentKind(..), ComponentKindFilter, TargetSelector(..), + ( ComponentKind(..), TargetSelector(..), componentKind, showTargetSelector ) import Distribution.Package @@ -170,7 +170,7 @@ targetSelectorRefersToPkgs (TargetPackageNamed _ mkfilter) = isNothing mkfilter targetSelectorRefersToPkgs TargetComponent{} = False targetSelectorRefersToPkgs TargetComponentUnknown{} = False -targetSelectorFilter :: TargetSelector -> Maybe ComponentKindFilter +targetSelectorFilter :: TargetSelector -> Maybe ComponentKind targetSelectorFilter (TargetPackage _ _ mkfilter) = mkfilter targetSelectorFilter (TargetPackageNamed _ mkfilter) = mkfilter targetSelectorFilter (TargetAllPackages mkfilter) = mkfilter diff --git a/cabal-install/src/Distribution/Client/CmdHaddock.hs b/cabal-install/src/Distribution/Client/CmdHaddock.hs index d179873f127..5e771892bfe 100644 --- a/cabal-install/src/Distribution/Client/CmdHaddock.hs +++ b/cabal-install/src/Distribution/Client/CmdHaddock.hs @@ -74,7 +74,8 @@ haddockAction flags@NixStyleFlags {..} targetStrings globalFlags = do baseCtx <- establishProjectBaseContext verbosity cliConfig HaddockCommand targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages baseCtx) Nothing targetStrings + =<< readTargetSelectors (localPackages baseCtx) Nothing flags + targetStrings buildCtx <- runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do diff --git a/cabal-install/src/Distribution/Client/CmdInstall.hs b/cabal-install/src/Distribution/Client/CmdInstall.hs index 0e9965a918e..6368fec7cda 100644 --- a/cabal-install/src/Distribution/Client/CmdInstall.hs +++ b/cabal-install/src/Distribution/Client/CmdInstall.hs @@ -238,8 +238,8 @@ installAction flags@NixStyleFlags { extraFlags = clientInstallFlags', .. } targe else do targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages localBaseCtx) - Nothing targetStrings'' + =<< readTargetSelectors (localPackages localBaseCtx) Nothing flags + targetStrings'' (specs, selectors) <- getSpecsAndTargetSelectors @@ -429,7 +429,7 @@ getSpecsAndTargetSelectors -> [TargetSelector] -> DistDirLayout -> ProjectBaseContext - -> Maybe ComponentKindFilter + -> Maybe ComponentKind -> IO ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector]) getSpecsAndTargetSelectors verbosity reducedVerbosity pkgDb targetSelectors localDistDirLayout localBaseCtx targetFilter = withInstallPlan reducedVerbosity localBaseCtx $ \elaboratedPlan _ -> do diff --git a/cabal-install/src/Distribution/Client/CmdListBin.hs b/cabal-install/src/Distribution/Client/CmdListBin.hs index 7a91f87b971..00141f8fbeb 100644 --- a/cabal-install/src/Distribution/Client/CmdListBin.hs +++ b/cabal-install/src/Distribution/Client/CmdListBin.hs @@ -77,7 +77,7 @@ listbinAction flags@NixStyleFlags{..} args globalFlags = do -- elaborate target selectors targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors localPkgs (Just ExeKind) [target] + =<< readTargetSelectors localPkgs (Just ExeKind) flags [target] buildCtx <- runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do diff --git a/cabal-install/src/Distribution/Client/CmdRepl.hs b/cabal-install/src/Distribution/Client/CmdRepl.hs index 076010b9bcb..3435bfb405e 100644 --- a/cabal-install/src/Distribution/Client/CmdRepl.hs +++ b/cabal-install/src/Distribution/Client/CmdRepl.hs @@ -199,7 +199,7 @@ replCommand = Client.installCommand { replAction :: NixStyleFlags (ReplFlags, EnvFlags) -> [String] -> GlobalFlags -> IO () replAction flags@NixStyleFlags { extraFlags = (replFlags, envFlags), ..} targetStrings globalFlags = do let - with = withProject cliConfig verbosity targetStrings + with = withProject flags cliConfig verbosity targetStrings without config = withoutProject (config <> cliConfig) verbosity targetStrings (baseCtx, targetSelectors, finalizer, replType) <- @@ -333,13 +333,14 @@ data ReplType = ProjectRepl -- 7.6, though. 🙁 deriving (Show, Eq) -withProject :: ProjectConfig -> Verbosity -> [String] +withProject :: NixStyleFlags a -> ProjectConfig -> Verbosity -> [String] -> IO (ProjectBaseContext, [TargetSelector], IO (), ReplType) -withProject cliConfig verbosity targetStrings = do +withProject flags cliConfig verbosity targetStrings = do baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages baseCtx) (Just LibKind) targetStrings + =<< readTargetSelectors (localPackages baseCtx) (Just LibKind) + flags targetStrings return (baseCtx, targetSelectors, return (), ProjectRepl) diff --git a/cabal-install/src/Distribution/Client/CmdRun.hs b/cabal-install/src/Distribution/Client/CmdRun.hs index 6f44200640c..da28da7f3a7 100644 --- a/cabal-install/src/Distribution/Client/CmdRun.hs +++ b/cabal-install/src/Distribution/Client/CmdRun.hs @@ -180,7 +180,7 @@ runAction flags@NixStyleFlags {..} targetStrings globalFlags = do else reportTargetSelectorProblems verbosity err (baseCtx', targetSelectors) <- - readTargetSelectors (localPackages baseCtx) (Just ExeKind) (take 1 targetStrings) + readTargetSelectors (localPackages baseCtx) (Just ExeKind) flags (take 1 targetStrings) >>= \case Left err@(TargetSelectorNoTargetsInProject:_) | (script:_) <- targetStrings -> scriptOrError script err diff --git a/cabal-install/src/Distribution/Client/CmdSdist.hs b/cabal-install/src/Distribution/Client/CmdSdist.hs index 24d38f19b68..46a88c89877 100644 --- a/cabal-install/src/Distribution/Client/CmdSdist.hs +++ b/cabal-install/src/Distribution/Client/CmdSdist.hs @@ -19,7 +19,7 @@ import Distribution.Client.NixStyleOptions ( NixStyleFlags (..), defaultNixStyleFlags ) import Distribution.Client.TargetSelector ( TargetSelector(..), ComponentKind - , readTargetSelectors, reportTargetSelectorProblems ) + , readTargetSelectors', reportTargetSelectorProblems ) import Distribution.Client.Setup ( GlobalFlags(..) ) import Distribution.Solver.Types.SourcePackage @@ -143,7 +143,7 @@ sdistAction (ProjectFlags{..}, SdistFlags{..}) targetStrings globalFlags = do let localPkgs = localPackages baseCtx targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors localPkgs Nothing targetStrings + =<< readTargetSelectors' localPkgs Nothing targetStrings -- elaborate path, create target directory mOutputPath' <- case mOutputPath of diff --git a/cabal-install/src/Distribution/Client/CmdTest.hs b/cabal-install/src/Distribution/Client/CmdTest.hs index 8e17485a9a0..646be2c9503 100644 --- a/cabal-install/src/Distribution/Client/CmdTest.hs +++ b/cabal-install/src/Distribution/Client/CmdTest.hs @@ -97,7 +97,8 @@ testAction flags@NixStyleFlags {..} targetStrings globalFlags = do baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages baseCtx) (Just TestKind) targetStrings + =<< readTargetSelectors (localPackages baseCtx) + (Just TestKind) flags targetStrings buildCtx <- runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do diff --git a/cabal-install/src/Distribution/Client/Config.hs b/cabal-install/src/Distribution/Client/Config.hs index 90815035e8d..e9989ab3a2c 100644 --- a/cabal-install/src/Distribution/Client/Config.hs +++ b/cabal-install/src/Distribution/Client/Config.hs @@ -431,7 +431,9 @@ instance Semigroup SavedConfig where configAllowOlder = combineMonoid savedConfigureExFlags configAllowOlder, configWriteGhcEnvironmentFilesPolicy - = combine configWriteGhcEnvironmentFilesPolicy + = combine configWriteGhcEnvironmentFilesPolicy, + configPickFirstTarget + = combine configPickFirstTarget } where combine = combine' savedConfigureExFlags diff --git a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs index d6f3924df85..8c8b0ac1153 100644 --- a/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs +++ b/cabal-install/src/Distribution/Client/ProjectConfig/Legacy.hs @@ -607,7 +607,9 @@ convertToLegacySharedConfig configAllowOlder = projectConfigAllowOlder, configAllowNewer = projectConfigAllowNewer, configWriteGhcEnvironmentFilesPolicy - = projectConfigWriteGhcEnvironmentFilesPolicy + = projectConfigWriteGhcEnvironmentFilesPolicy, + configPickFirstTarget + = mempty } installFlags = InstallFlags { diff --git a/cabal-install/src/Distribution/Client/Setup.hs b/cabal-install/src/Distribution/Client/Setup.hs index c710b4a384e..c54b0c9effc 100644 --- a/cabal-install/src/Distribution/Client/Setup.hs +++ b/cabal-install/src/Distribution/Client/Setup.hs @@ -604,12 +604,15 @@ data ConfigExFlags = ConfigExFlags { configAllowNewer :: Maybe AllowNewer, configAllowOlder :: Maybe AllowOlder, configWriteGhcEnvironmentFilesPolicy - :: Flag WriteGhcEnvironmentFilesPolicy + :: Flag WriteGhcEnvironmentFilesPolicy, + configPickFirstTarget + :: Flag Bool } deriving (Eq, Show, Generic) defaultConfigExFlags :: ConfigExFlags -defaultConfigExFlags = mempty { configSolver = Flag defaultSolver } +defaultConfigExFlags = mempty { configSolver = Flag defaultSolver + , configPickFirstTarget = Flag False } configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags) configureExCommand = configureCommand { @@ -685,6 +688,13 @@ configureExOptions _showOrParseArgs src = (reqArg "always|never|ghc8.4.4+" writeGhcEnvironmentFilesPolicyParser writeGhcEnvironmentFilesPolicyPrinter) + + , option [] ["pick-first-target"] + ("If there's an amibguity in the target selector, then resolve it by" + ++ " choosing the first") + configPickFirstTarget + (\v flags -> flags { configPickFirstTarget = v}) + trueArg ] diff --git a/cabal-install/src/Distribution/Client/TargetProblem.hs b/cabal-install/src/Distribution/Client/TargetProblem.hs index 14004d50abd..eb059b1ecb0 100644 --- a/cabal-install/src/Distribution/Client/TargetProblem.hs +++ b/cabal-install/src/Distribution/Client/TargetProblem.hs @@ -45,8 +45,8 @@ data TargetProblem a | TargetProblemNoSuchPackage PackageId | TargetProblemNoSuchComponent PackageId ComponentName - -- | A custom target problem | CustomTargetProblem a + -- ^ A custom target problem deriving (Eq, Show, Functor) -- | Type alias for a 'TargetProblem' with no user-defined problems/errors. diff --git a/cabal-install/src/Distribution/Client/TargetSelector.hs b/cabal-install/src/Distribution/Client/TargetSelector.hs index 9122ef8b709..aae1f5712e7 100644 --- a/cabal-install/src/Distribution/Client/TargetSelector.hs +++ b/cabal-install/src/Distribution/Client/TargetSelector.hs @@ -19,13 +19,13 @@ module Distribution.Client.TargetSelector ( TargetSelector(..), TargetImplicitCwd(..), ComponentKind(..), - ComponentKindFilter, SubComponentTarget(..), QualLevel(..), componentKind, -- * Reading target selectors readTargetSelectors, + readTargetSelectors', TargetSelectorProblem(..), reportTargetSelectorProblems, showTargetSelector, @@ -66,6 +66,12 @@ import Distribution.Simple.LocalBuildInfo , pkgComponents, componentName, componentBuildInfo ) import Distribution.Types.ForeignLib +import Distribution.Client.NixStyleOptions +import Distribution.Client.Setup + ( ConfigExFlags(..) ) +import Distribution.Simple.Setup + ( fromFlagOrDefault ) + import Distribution.Simple.Utils ( die', lowercase, ordNub ) import Distribution.Client.Utils @@ -131,18 +137,18 @@ data TargetSelector = -- These are always packages that are local to the project. In the case -- that there is more than one, they all share the same directory location. -- - TargetPackage TargetImplicitCwd [PackageId] (Maybe ComponentKindFilter) + TargetPackage TargetImplicitCwd [PackageId] (Maybe ComponentKind) -- | A package specified by name. This may refer to @extra-packages@ from -- the @cabal.project@ file, or a dependency of a known project package or -- could refer to a package from a hackage archive. It needs further -- context to resolve to a specific package. -- - | TargetPackageNamed PackageName (Maybe ComponentKindFilter) + | TargetPackageNamed PackageName (Maybe ComponentKind) -- | All packages, or all components of a particular kind in all packages. -- - | TargetAllPackages (Maybe ComponentKindFilter) + | TargetAllPackages (Maybe ComponentKind) -- | A specific component in a package within the project. -- @@ -168,7 +174,17 @@ data TargetImplicitCwd = TargetImplicitCwd | TargetExplicitNamed data ComponentKind = LibKind | FLibKind | ExeKind | TestKind | BenchKind deriving (Eq, Ord, Enum, Show) -type ComponentKindFilter = ComponentKind +-- | Whenever there is an ambiguous TargetSelector from some user input, how +-- should it be resolved? +data AmbiguityResolver = + -- | Treat ambiguity as an error + AmbiguityResolverNone + -- | Choose the first target + | AmbiguityResolverFirst + -- | Choose the target component with the specific kind + | AmbiguityResolverKind ComponentKind + | AmbiguityResolverKindFirst ComponentKind + deriving (Eq, Ord, Show) -- | Either the component as a whole or detail about a file or module target -- within a component. @@ -200,30 +216,54 @@ instance Structured SubComponentTarget -- the available packages (and their locations). -- readTargetSelectors :: [PackageSpecifier (SourcePackage (PackageLocation a))] - -> Maybe ComponentKindFilter + -> Maybe ComponentKind -- ^ This parameter is used when there are ambiguous selectors. -- If it is 'Just', then we attempt to resolve ambiguitiy - -- by applying it, since otherwise there is no way to allow - -- contextually valid yet syntactically ambiguous selectors. + -- by applying it, since otherwise there is no way to + -- allow contextually valid yet syntactically ambiguous + -- selectors. -- (#4676, #5461) + -> NixStyleFlags b + -- ^ Used in case @--pick-first-target@ was passed. -> [String] -> IO (Either [TargetSelectorProblem] [TargetSelector]) -readTargetSelectors = readTargetSelectorsWith defaultDirActions +readTargetSelectors pkgs mfilter NixStyleFlags{configExFlags} + = readTargetSelectorsWith defaultDirActions pkgs mfilter + (fromFlagOrDefault False (configPickFirstTarget configExFlags)) + + +-- | Same as 'readTargetSelectors' but in case you don't have 'NixStyleFlags'. +readTargetSelectors' :: [PackageSpecifier (SourcePackage (PackageLocation a))] + -> Maybe ComponentKind + -> [String] + -> IO (Either [TargetSelectorProblem] [TargetSelector]) +readTargetSelectors' pkgs mfilter = + readTargetSelectorsWith defaultDirActions pkgs mfilter False readTargetSelectorsWith :: (Applicative m, Monad m) => DirActions m -> [PackageSpecifier (SourcePackage (PackageLocation a))] - -> Maybe ComponentKindFilter + -> Maybe ComponentKind + -- ^ Filter the target to resolve ambiguity? + -> Bool + -- ^ Pick the first target to resolve ambiguity? -> [String] -> m (Either [TargetSelectorProblem] [TargetSelector]) -readTargetSelectorsWith dirActions@DirActions{} pkgs mfilter targetStrs = +readTargetSelectorsWith dirActions@DirActions{} pkgs mfilter pickFirst targetStrs = case parseTargetStrings targetStrs of ([], usertargets) -> do usertargets' <- traverse (getTargetStringFileStatus dirActions) usertargets knowntargets <- getKnownTargets dirActions pkgs - case resolveTargetSelectors knowntargets usertargets' mfilter of + case resolveTargetSelectors knowntargets usertargets' resolver of ([], btargets) -> return (Right btargets) (problems, _) -> return (Left problems) (strs, _) -> return (Left (map TargetSelectorUnrecognised strs)) + where + resolver + | Just kind <- mfilter + , pickFirst = AmbiguityResolverKindFirst kind + | Just kind <- mfilter = AmbiguityResolverKind kind + | pickFirst = AmbiguityResolverFirst + | otherwise = AmbiguityResolverNone data DirActions m = DirActions { @@ -458,7 +498,7 @@ copyFileStatus src dst = -- resolveTargetSelectors :: KnownTargets -> [TargetStringFileStatus] - -> Maybe ComponentKindFilter + -> AmbiguityResolver -> ([TargetSelectorProblem], [TargetSelector]) -- default local dir target if there's no given target: @@ -479,10 +519,10 @@ resolveTargetSelectors knowntargets targetStrs mfilter = $ targetStrs resolveTargetSelector :: KnownTargets - -> Maybe ComponentKindFilter + -> AmbiguityResolver -> TargetStringFileStatus -> Either TargetSelectorProblem TargetSelector -resolveTargetSelector knowntargets@KnownTargets{..} mfilter targetStrStatus = +resolveTargetSelector knowntargets@KnownTargets{..} resolver targetStrStatus = case findMatch (matcher targetStrStatus) of Unambiguous _ @@ -497,10 +537,27 @@ resolveTargetSelector knowntargets@KnownTargets{..} mfilter targetStrStatus = | projectIsEmpty -> Left TargetSelectorNoTargetsInProject | otherwise -> Left (classifyMatchErrors errs) + -- Try to resolve the ambiguity with a kind filter Ambiguous _ targets - | Just kfilter <- mfilter + | AmbiguityResolverKind kfilter <- resolver , [target] <- applyKindFilter kfilter targets -> Right target + -- If we have a filter and want to pick from the first + Ambiguous _ targets + | AmbiguityResolverKindFirst kfilter <- resolver + , target:_ <- applyKindFilter kfilter targets -> Right target + + -- Same case as above, except there weren't any filter matches + Ambiguous _ targets + | AmbiguityResolverKindFirst _ <- resolver + , target:_ <- targets -> Right target + + -- Just pick the first of any + Ambiguous _ targets + | AmbiguityResolverFirst <- resolver + , target:_ <- targets -> Right target + + -- A truly, unresolvable ambiguity Ambiguous exactMatch targets -> case disambiguateTargetSelectors matcher targetStrStatus exactMatch @@ -560,7 +617,7 @@ resolveTargetSelector knowntargets@KnownTargets{..} mfilter targetStrStatus = = innerErr (Just (kind,thing)) m innerErr c m = (c,m) - applyKindFilter :: ComponentKindFilter -> [TargetSelector] -> [TargetSelector] + applyKindFilter :: ComponentKind -> [TargetSelector] -> [TargetSelector] applyKindFilter kfilter = filter go where go (TargetPackage _ _ (Just filter')) = kfilter == filter' diff --git a/cabal-install/tests/IntegrationTests2.hs b/cabal-install/tests/IntegrationTests2.hs index 19c4aa48461..1fbba85a40c 100644 --- a/cabal-install/tests/IntegrationTests2.hs +++ b/cabal-install/tests/IntegrationTests2.hs @@ -158,21 +158,22 @@ testExceptionFindProjectRoot = do testTargetSelectors :: (String -> IO ()) -> Assertion testTargetSelectors reportSubCase = do (_, _, _, localPackages, _) <- configureProject testdir config - let readTargetSelectors' = readTargetSelectorsWith (dirActions testdir) + let readTargetSelectors'' = readTargetSelectorsWith (dirActions testdir) localPackages Nothing + False reportSubCase "cwd" - do Right ts <- readTargetSelectors' [] + do Right ts <- readTargetSelectors'' [] ts @?= [TargetPackage TargetImplicitCwd ["p-0.1"] Nothing] reportSubCase "all" - do Right ts <- readTargetSelectors' + do Right ts <- readTargetSelectors'' ["all", ":all"] ts @?= replicate 2 (TargetAllPackages Nothing) reportSubCase "filter" - do Right ts <- readTargetSelectors' + do Right ts <- readTargetSelectors'' [ "libs", ":cwd:libs" , "flibs", ":cwd:flibs" , "exes", ":cwd:exes" @@ -184,7 +185,7 @@ testTargetSelectors reportSubCase = do ] reportSubCase "all:filter" - do Right ts <- readTargetSelectors' + do Right ts <- readTargetSelectors'' [ "all:libs", ":all:libs" , "all:flibs", ":all:flibs" , "all:exes", ":all:exes" @@ -196,14 +197,14 @@ testTargetSelectors reportSubCase = do ] reportSubCase "pkg" - do Right ts <- readTargetSelectors' + do Right ts <- readTargetSelectors'' [ ":pkg:p", ".", "./", "p.cabal" , "q", ":pkg:q", "q/", "./q/", "q/q.cabal"] ts @?= replicate 4 (mkTargetPackage "p-0.1") ++ replicate 5 (mkTargetPackage "q-0.1") reportSubCase "pkg:filter" - do Right ts <- readTargetSelectors' + do Right ts <- readTargetSelectors'' [ "p:libs", ".:libs", ":pkg:p:libs" , "p:flibs", ".:flibs", ":pkg:p:flibs" , "p:exes", ".:exes", ":pkg:p:exes" @@ -223,14 +224,14 @@ testTargetSelectors reportSubCase = do ] reportSubCase "component" - do Right ts <- readTargetSelectors' + do Right ts <- readTargetSelectors'' [ "p", "lib:p", "p:lib:p", ":pkg:p:lib:p" , "lib:q", "q:lib:q", ":pkg:q:lib:q" ] ts @?= replicate 4 (TargetComponent "p-0.1" (CLibName LMainLibName) WholeComponent) ++ replicate 3 (TargetComponent "q-0.1" (CLibName LMainLibName) WholeComponent) reportSubCase "module" - do Right ts <- readTargetSelectors' + do Right ts <- readTargetSelectors'' [ "P", "lib:p:P", "p:p:P", ":pkg:p:lib:p:module:P" , "QQ", "lib:q:QQ", "q:q:QQ", ":pkg:q:lib:q:module:QQ" , "pexe:PMain" -- p:P or q:QQ would be ambiguous here @@ -243,7 +244,7 @@ testTargetSelectors reportSubCase = do ] reportSubCase "file" - do Right ts <- readTargetSelectors' + do Right ts <- readTargetSelectors'' [ "./P.hs", "p:P.lhs", "lib:p:P.hsc", "p:p:P.hsc", ":pkg:p:lib:p:file:P.y" , "q/QQ.hs", "q:QQ.lhs", "lib:q:QQ.hsc", "q:q:QQ.hsc", @@ -274,7 +275,7 @@ testTargetSelectorBadSyntax = do , "foo:", "foo::bar" , "foo: ", "foo: :bar" , "a:b:c:d:e:f", "a:b:c:d:e:f:g:h" ] - Left errs <- readTargetSelectors localPackages Nothing targets + Left errs <- readTargetSelectors' localPackages Nothing targets zipWithM_ (@?=) errs (map TargetSelectorUnrecognised targets) cleanProject testdir where @@ -379,6 +380,14 @@ testTargetSelectorAmbiguous reportSubCase = do [ mkpkg "foo" [ mkexe "bar" `withModules` ["Bar"] `withHsSrcDirs` ["src"] , mkexe "bar2" `withModules` ["Bar"] `withHsSrcDirs` ["src"] ] ] + reportSubCase "ambiguous: --pick-first-target resolves" + assertUnambiguousPickFirst "Bar.hs" + [ mkTargetFile "foo" (CExeName "bar") "Bar" + , mkTargetFile "foo" (CExeName "bar2") "Bar" + ] + [ mkpkg "foo" [ mkexe "bar" `withModules` ["Bar"] + , mkexe "bar2" `withModules` ["Bar"] ] + ] -- non-exact case packages and components are ambiguous reportSubCase "ambiguous: non-exact-case pkg names" @@ -414,6 +423,7 @@ testTargetSelectorAmbiguous reportSubCase = do fakeDirActions (map SpecificSourcePackage pkgs) Nothing + False [str] case res of Left [TargetSelectorAmbiguous _ tss'] -> @@ -430,12 +440,29 @@ testTargetSelectorAmbiguous reportSubCase = do fakeDirActions (map SpecificSourcePackage pkgs) Nothing + False [str] case res of Right [ts'] -> ts' @?= ts _ -> assertFailure $ "expected Right [Target...], " ++ "got " ++ show res + assertUnambiguousPickFirst :: String + -> [TargetSelector] + -> [SourcePackage (PackageLocation a)] + -> Assertion + assertUnambiguousPickFirst str ts pkgs = do + res <- readTargetSelectorsWith + fakeDirActions + (map SpecificSourcePackage pkgs) + Nothing + True + [str] + case res of + Right [ts'] -> (ts' `elem` ts) @? "unexpected target selector" + _ -> assertFailure $ "expected Right [Target...], " + ++ "got " ++ show res + fakeDirActions = TS.DirActions { TS.doesFileExist = \_p -> return True, TS.doesDirectoryExist = \_p -> return True, @@ -512,15 +539,16 @@ instance IsString PackageIdentifier where testTargetSelectorNoCurrentPackage :: Assertion testTargetSelectorNoCurrentPackage = do (_, _, _, localPackages, _) <- configureProject testdir config - let readTargetSelectors' = readTargetSelectorsWith (dirActions testdir) + let readTargetSelectors'' = readTargetSelectorsWith (dirActions testdir) localPackages Nothing + False targets = [ "libs", ":cwd:libs" , "flibs", ":cwd:flibs" , "exes", ":cwd:exes" , "tests", ":cwd:tests" , "benchmarks", ":cwd:benchmarks"] - Left errs <- readTargetSelectors' targets + Left errs <- readTargetSelectors'' targets zipWithM_ (@?=) errs [ TargetSelectorNoCurrentPackage ts | target <- targets @@ -535,7 +563,7 @@ testTargetSelectorNoCurrentPackage = do testTargetSelectorNoTargets :: Assertion testTargetSelectorNoTargets = do (_, _, _, localPackages, _) <- configureProject testdir config - Left errs <- readTargetSelectors localPackages Nothing [] + Left errs <- readTargetSelectors' localPackages Nothing [] errs @?= [TargetSelectorNoTargetsInCwd] cleanProject testdir where @@ -546,7 +574,7 @@ testTargetSelectorNoTargets = do testTargetSelectorProjectEmpty :: Assertion testTargetSelectorProjectEmpty = do (_, _, _, localPackages, _) <- configureProject testdir config - Left errs <- readTargetSelectors localPackages Nothing [] + Left errs <- readTargetSelectors' localPackages Nothing [] errs @?= [TargetSelectorNoTargetsInProject] cleanProject testdir where