From 0dff8a6d7916df549cbe073ca1367cc7e0d59a34 Mon Sep 17 00:00:00 2001 From: Luke Lau Date: Mon, 8 Jun 2020 16:51:06 +0100 Subject: [PATCH] Add --pick-first-target flag --- cabal-install/Distribution/Client/CmdBench.hs | 4 +- cabal-install/Distribution/Client/CmdBuild.hs | 2 +- .../Distribution/Client/CmdErrorMessages.hs | 2 +- .../Distribution/Client/CmdHaddock.hs | 4 +- .../Distribution/Client/CmdInstall.hs | 4 +- cabal-install/Distribution/Client/CmdRepl.hs | 11 +-- cabal-install/Distribution/Client/CmdRun.hs | 4 +- cabal-install/Distribution/Client/CmdSdist.hs | 6 +- .../Distribution/Client/CmdShowBuildInfo.hs | 4 +- cabal-install/Distribution/Client/CmdTest.hs | 7 +- cabal-install/Distribution/Client/Config.hs | 4 +- .../Client/ProjectConfig/Legacy.hs | 6 +- cabal-install/Distribution/Client/Setup.hs | 14 +++- .../Distribution/Client/TargetSelector.hs | 79 ++++++++++++++----- cabal-install/tests/IntegrationTests2.hs | 58 ++++++++++---- 15 files changed, 146 insertions(+), 63 deletions(-) diff --git a/cabal-install/Distribution/Client/CmdBench.hs b/cabal-install/Distribution/Client/CmdBench.hs index 5b6d10ddf6e..a66ed7b86ab 100644 --- a/cabal-install/Distribution/Client/CmdBench.hs +++ b/cabal-install/Distribution/Client/CmdBench.hs @@ -22,7 +22,7 @@ import Distribution.Client.ProjectOrchestration import Distribution.Client.CmdErrorMessages ( renderTargetSelector, showTargetSelector, renderTargetProblem, renderTargetProblemNoTargets, plural, targetSelectorPluralPkgs, - targetSelectorFilter, AmbiguityResolver(..) ) + targetSelectorFilter ) import Distribution.Client.TargetProblem ( TargetProblem (..) ) import Distribution.Client.NixStyleOptions @@ -88,7 +88,7 @@ benchAction flags@NixStyleFlags {..} targetStrings globalFlags = do targetSelectors <- either (reportTargetSelectorProblems verbosity) return =<< readTargetSelectors (localPackages baseCtx) - (AmbiguityResolverKind BenchKind) targetStrings + (Just BenchKind) flags targetStrings buildCtx <- runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do diff --git a/cabal-install/Distribution/Client/CmdBuild.hs b/cabal-install/Distribution/Client/CmdBuild.hs index 76ba3bb0faa..ea086a80151 100644 --- a/cabal-install/Distribution/Client/CmdBuild.hs +++ b/cabal-install/Distribution/Client/CmdBuild.hs @@ -107,7 +107,7 @@ buildAction flags@NixStyleFlags { extraFlags = buildFlags, ..} targetStrings glo targetSelectors <- either (reportTargetSelectorProblems verbosity) return =<< readTargetSelectors (localPackages baseCtx) - AmbiguityResolverNone targetStrings + Nothing flags targetStrings buildCtx <- runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do diff --git a/cabal-install/Distribution/Client/CmdErrorMessages.hs b/cabal-install/Distribution/Client/CmdErrorMessages.hs index 033a8eb9588..bbd2058a719 100644 --- a/cabal-install/Distribution/Client/CmdErrorMessages.hs +++ b/cabal-install/Distribution/Client/CmdErrorMessages.hs @@ -21,7 +21,7 @@ import Distribution.Client.TargetSelector import Distribution.Client.TargetProblem ( TargetProblem(..), TargetProblem' ) import Distribution.Client.TargetSelector - ( ComponentKind(..), AmbiguityResolver(..), TargetSelector(..), + ( ComponentKind(..), TargetSelector(..), componentKind, showTargetSelector ) import Distribution.Package diff --git a/cabal-install/Distribution/Client/CmdHaddock.hs b/cabal-install/Distribution/Client/CmdHaddock.hs index caa896aa041..04a83dd0e88 100644 --- a/cabal-install/Distribution/Client/CmdHaddock.hs +++ b/cabal-install/Distribution/Client/CmdHaddock.hs @@ -76,8 +76,8 @@ haddockAction flags@NixStyleFlags {..} targetStrings globalFlags = do baseCtx <- establishProjectBaseContext verbosity cliConfig HaddockCommand targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages baseCtx) - AmbiguityResolverNone targetStrings + =<< readTargetSelectors (localPackages baseCtx) Nothing flags + targetStrings buildCtx <- runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do diff --git a/cabal-install/Distribution/Client/CmdInstall.hs b/cabal-install/Distribution/Client/CmdInstall.hs index 69ac1fc28e7..5fb6662f00b 100644 --- a/cabal-install/Distribution/Client/CmdInstall.hs +++ b/cabal-install/Distribution/Client/CmdInstall.hs @@ -240,8 +240,8 @@ installAction flags@NixStyleFlags { extraFlags = clientInstallFlags', .. } targe else do targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages localBaseCtx) - AmbiguityResolverNone targetStrings'' + =<< readTargetSelectors (localPackages localBaseCtx) Nothing flags + targetStrings'' (specs, selectors) <- getSpecsAndTargetSelectors diff --git a/cabal-install/Distribution/Client/CmdRepl.hs b/cabal-install/Distribution/Client/CmdRepl.hs index 8953aacbcec..08861620ad7 100644 --- a/cabal-install/Distribution/Client/CmdRepl.hs +++ b/cabal-install/Distribution/Client/CmdRepl.hs @@ -26,7 +26,7 @@ import qualified Distribution.Types.Lens as L import Distribution.Client.NixStyleOptions ( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags ) import Distribution.Client.CmdErrorMessages - ( renderTargetSelector, showTargetSelector, AmbiguityResolver(..), + ( renderTargetSelector, showTargetSelector, renderTargetProblem, targetSelectorRefersToPkgs, renderComponentKind, renderListCommaAnd, renderListSemiAnd, @@ -204,7 +204,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) <- @@ -338,13 +338,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) (AmbiguityResolverKind LibKind) targetStrings + =<< readTargetSelectors (localPackages baseCtx) (Just LibKind) + flags targetStrings return (baseCtx, targetSelectors, return (), ProjectRepl) diff --git a/cabal-install/Distribution/Client/CmdRun.hs b/cabal-install/Distribution/Client/CmdRun.hs index 1880d143300..a6ece8d7439 100644 --- a/cabal-install/Distribution/Client/CmdRun.hs +++ b/cabal-install/Distribution/Client/CmdRun.hs @@ -59,7 +59,7 @@ import Distribution.Client.ProjectPlanning import Distribution.Client.ProjectPlanning.Types ( dataDirsEnvironmentForPlan ) import Distribution.Client.TargetSelector - ( TargetSelectorProblem(..), TargetString(..), AmbiguityResolver(..) ) + ( TargetSelectorProblem(..), TargetString(..) ) import Distribution.Client.InstallPlan ( toList, foldPlanPackage ) import Distribution.Types.UnqualComponentName @@ -182,7 +182,7 @@ runAction flags@NixStyleFlags {..} targetStrings globalFlags = do else reportTargetSelectorProblems verbosity err (baseCtx', targetSelectors) <- - readTargetSelectors (localPackages baseCtx) (AmbiguityResolverKind 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/Distribution/Client/CmdSdist.hs b/cabal-install/Distribution/Client/CmdSdist.hs index dd537179e71..a1e18770309 100644 --- a/cabal-install/Distribution/Client/CmdSdist.hs +++ b/cabal-install/Distribution/Client/CmdSdist.hs @@ -18,8 +18,8 @@ import Distribution.Client.ProjectOrchestration import Distribution.Client.NixStyleOptions ( NixStyleFlags (..), defaultNixStyleFlags ) import Distribution.Client.TargetSelector - ( TargetSelector(..), ComponentKind, AmbiguityResolver(..) - , readTargetSelectors, reportTargetSelectorProblems ) + ( TargetSelector(..), ComponentKind + , readTargetSelectors', reportTargetSelectorProblems ) import Distribution.Client.Setup ( GlobalFlags(..) ) import Distribution.Solver.Types.SourcePackage @@ -151,7 +151,7 @@ sdistAction (ProjectFlags{..}, SdistFlags{..}) targetStrings globalFlags = do let localPkgs = localPackages baseCtx targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors localPkgs AmbiguityResolverNone targetStrings + =<< readTargetSelectors' localPkgs Nothing targetStrings -- elaborate path, create target directory mOutputPath' <- case mOutputPath of diff --git a/cabal-install/Distribution/Client/CmdShowBuildInfo.hs b/cabal-install/Distribution/Client/CmdShowBuildInfo.hs index 76c83ead864..9a5a1505dfe 100644 --- a/cabal-install/Distribution/Client/CmdShowBuildInfo.hs +++ b/cabal-install/Distribution/Client/CmdShowBuildInfo.hs @@ -114,7 +114,7 @@ showBuildInfoAction flags@NixStyleFlags { extraFlags = (ShowBuildInfoFlags fileO } targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages baseCtx') AmbiguityResolverFirst targetStrings + =<< readTargetSelectors (localPackages baseCtx') Nothing flags targetStrings buildCtx <- runProjectPreBuildPhase verbosity baseCtx' $ \elaboratedPlan -> do @@ -155,6 +155,8 @@ showBuildInfoAction flags@NixStyleFlags { extraFlags = (ShowBuildInfoFlags fileO showTargets :: Maybe FilePath -> Maybe [String] -> Verbosity -> ProjectBaseContext -> ProjectBuildContext -> Lock -> IO () showTargets fileOutput unitIds verbosity baseCtx buildCtx lock = do + + -- TODO: can we use --disable-per-component so that we only get one package? let configured = [p | InstallPlan.Configured p <- InstallPlan.toList (elaboratedPlanOriginal buildCtx)] targets = maybe (fst <$> (Map.toList . targetsMap $ buildCtx)) (map mkUnitId) unitIds diff --git a/cabal-install/Distribution/Client/CmdTest.hs b/cabal-install/Distribution/Client/CmdTest.hs index e9f53f1e084..6ebf2215aee 100644 --- a/cabal-install/Distribution/Client/CmdTest.hs +++ b/cabal-install/Distribution/Client/CmdTest.hs @@ -22,8 +22,7 @@ import Distribution.Client.ProjectOrchestration import Distribution.Client.CmdErrorMessages ( renderTargetSelector, showTargetSelector, targetSelectorFilter, plural, renderTargetProblem, - renderTargetProblemNoTargets, targetSelectorPluralPkgs, - AmbiguityResolver(..) ) + renderTargetProblemNoTargets, targetSelectorPluralPkgs ) import Distribution.Client.TargetProblem ( TargetProblem (..) ) import Distribution.Client.NixStyleOptions @@ -100,8 +99,8 @@ testAction flags@NixStyleFlags {..} targetStrings globalFlags = do baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand targetSelectors <- either (reportTargetSelectorProblems verbosity) return - =<< readTargetSelectors (localPackages baseCtx) - (AmbiguityResolverKind TestKind) targetStrings + =<< readTargetSelectors (localPackages baseCtx) + (Just TestKind) flags targetStrings buildCtx <- runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do diff --git a/cabal-install/Distribution/Client/Config.hs b/cabal-install/Distribution/Client/Config.hs index e1c63a8c354..c3f3c45990e 100644 --- a/cabal-install/Distribution/Client/Config.hs +++ b/cabal-install/Distribution/Client/Config.hs @@ -428,7 +428,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/Distribution/Client/ProjectConfig/Legacy.hs b/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs index 39a0342aa08..df1d2319c72 100644 --- a/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs +++ b/cabal-install/Distribution/Client/ProjectConfig/Legacy.hs @@ -83,7 +83,7 @@ import qualified Distribution.Deprecated.ParseUtils as ParseUtils import Distribution.Deprecated.ParseUtils ( ParseResult(..), PError(..), syntaxError, PWarning(..) , commaNewLineListFieldParsec, newLineListField, parseTokenQ - , parseHaskellString, showToken + , parseHaskellString, showToken , simpleFieldParsec ) import Distribution.Client.ParseUtils @@ -603,7 +603,9 @@ convertToLegacySharedConfig configAllowOlder = projectConfigAllowOlder, configAllowNewer = projectConfigAllowNewer, configWriteGhcEnvironmentFilesPolicy - = projectConfigWriteGhcEnvironmentFilesPolicy + = projectConfigWriteGhcEnvironmentFilesPolicy, + configPickFirstTarget + = mempty } installFlags = InstallFlags { diff --git a/cabal-install/Distribution/Client/Setup.hs b/cabal-install/Distribution/Client/Setup.hs index efb15fccf52..61950bbaffd 100644 --- a/cabal-install/Distribution/Client/Setup.hs +++ b/cabal-install/Distribution/Client/Setup.hs @@ -624,12 +624,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 { @@ -697,6 +700,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/Distribution/Client/TargetSelector.hs b/cabal-install/Distribution/Client/TargetSelector.hs index e9cb519d7d2..6773f821a20 100644 --- a/cabal-install/Distribution/Client/TargetSelector.hs +++ b/cabal-install/Distribution/Client/TargetSelector.hs @@ -19,13 +19,13 @@ module Distribution.Client.TargetSelector ( TargetSelector(..), TargetImplicitCwd(..), ComponentKind(..), - AmbiguityResolver(..), 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 @@ -176,6 +182,7 @@ data AmbiguityResolver = | 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 @@ -208,36 +215,54 @@ instance Structured SubComponentTarget -- the available packages (and their locations). -- readTargetSelectors :: [PackageSpecifier (SourcePackage (PackageLocation a))] - -> AmbiguityResolver + -> Maybe ComponentKind -- ^ This parameter is used when there are ambiguous selectors. - -- If it is 'AmbiguityResolverKind', then we attempt to resolve - -- ambiguitiy by applying it, since otherwise there is no - -- way to allow contextually valid yet syntactically ambiguous + -- 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. -- (#4676, #5461) - -- If it is 'AmbiguityResolverFirst', then we resolve it by - -- choosing just the first target. This is used by - -- the show-build-info command. - -- Otherwise, if it is 'AmbiguityResolverNone', we make - -- ambiguity a 'TargetSelectorProblem'. + -> 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))] - -> AmbiguityResolver + -> 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 { @@ -496,7 +521,7 @@ resolveTargetSelector :: KnownTargets -> AmbiguityResolver -> TargetStringFileStatus -> Either TargetSelectorProblem TargetSelector -resolveTargetSelector knowntargets@KnownTargets{..} mfilter targetStrStatus = +resolveTargetSelector knowntargets@KnownTargets{..} resolver targetStrStatus = case findMatch (matcher targetStrStatus) of Unambiguous _ @@ -511,18 +536,32 @@ resolveTargetSelector knowntargets@KnownTargets{..} mfilter targetStrStatus = | projectIsEmpty -> Left TargetSelectorNoTargetsInProject | otherwise -> Left (classifyMatchErrors errs) + -- Try to resolve the ambiguity with a kind filter Ambiguous _ targets - | AmbiguityResolverKind 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 targets of - Right targets' -> - case (targets', mfilter) of - ((_,t):_, AmbiguityResolverFirst) -> Right t - _ -> Left (TargetSelectorAmbiguous targetStr targets') + Right targets' -> Left (TargetSelectorAmbiguous targetStr targets') Left ((m, ms):_) -> Left (MatchingInternalError targetStr m ms) Left [] -> internalError "resolveTargetSelector" where diff --git a/cabal-install/tests/IntegrationTests2.hs b/cabal-install/tests/IntegrationTests2.hs index 1e0854c0eed..9749f0718a6 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