Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Disambiguate selectors by the command being used #5461

Merged
merged 3 commits into from
Jul 27, 2018
Merged

Disambiguate selectors by the command being used #5461

Show file tree
Hide file tree
Changes from 2 commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
a946a90
Disambiguate selectors by the command being used
typedrat Jul 27, 2018
8c1e650
Fix changelog clairvoyance failure
typedrat Jul 27, 2018
be362ee
Add comment explaining filter parameter
typedrat Jul 27, 2018
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 1 addition & 1 deletion cabal-install/Distribution/Client/CmdBench.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -81,7 +81,7 @@ benchAction (configFlags, configExFlags, installFlags, haddockFlags)
baseCtx <- establishProjectBaseContext verbosity cliConfig

targetSelectors <- either (reportTargetSelectorProblems verbosity) return
=<< readTargetSelectors (localPackages baseCtx) targetStrings
=<< readTargetSelectors (localPackages baseCtx) (Just BenchKind) targetStrings

buildCtx <-
runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do
Expand Down
2 changes: 1 addition & 1 deletion cabal-install/Distribution/Client/CmdBuild.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -78,7 +78,7 @@ buildAction (configFlags, configExFlags, installFlags, haddockFlags)
baseCtx <- establishProjectBaseContext verbosity cliConfig

targetSelectors <- either (reportTargetSelectorProblems verbosity) return
=<< readTargetSelectors (localPackages baseCtx) targetStrings
=<< readTargetSelectors (localPackages baseCtx) Nothing targetStrings

buildCtx <-
runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do
Expand Down
2 changes: 1 addition & 1 deletion cabal-install/Distribution/Client/CmdHaddock.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -77,7 +77,7 @@ haddockAction (configFlags, configExFlags, installFlags, haddockFlags)
baseCtx <- establishProjectBaseContext verbosity cliConfig

targetSelectors <- either (reportTargetSelectorProblems verbosity) return
=<< readTargetSelectors (localPackages baseCtx) targetStrings
=<< readTargetSelectors (localPackages baseCtx) Nothing targetStrings

buildCtx <-
runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do
Expand Down
2 changes: 1 addition & 1 deletion cabal-install/Distribution/Client/CmdInstall.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -269,7 +269,7 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags, newInstal
then return (packageSpecifiers, packageTargets, projectConfig localBaseCtx)
else do
targetSelectors <- either (reportTargetSelectorProblems verbosity) return
=<< readTargetSelectors (localPackages localBaseCtx) targetStrings'
=<< readTargetSelectors (localPackages localBaseCtx) Nothing targetStrings'

(specs, selectors) <- withInstallPlan verbosity' localBaseCtx $ \elaboratedPlan -> do
-- Split into known targets and hackage packages.
Expand Down
2 changes: 1 addition & 1 deletion cabal-install/Distribution/Client/CmdRepl.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -108,7 +108,7 @@ replAction (configFlags, configExFlags, installFlags, haddockFlags, replArgs)
baseCtx <- establishProjectBaseContext verbosity cliConfig

targetSelectors <- either (reportTargetSelectorProblems verbosity) return
=<< readTargetSelectors (localPackages baseCtx) targetStrings
=<< readTargetSelectors (localPackages baseCtx) Nothing targetStrings

buildCtx' <-
runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do
Expand Down
2 changes: 1 addition & 1 deletion cabal-install/Distribution/Client/CmdRun.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -110,7 +110,7 @@ runAction (configFlags, configExFlags, installFlags, haddockFlags)
baseCtx <- establishProjectBaseContext verbosity cliConfig

targetSelectors <- either (reportTargetSelectorProblems verbosity) return
=<< readTargetSelectors (localPackages baseCtx)
=<< readTargetSelectors (localPackages baseCtx) (Just ExeKind)
(take 1 targetStrings) -- Drop the exe's args.

buildCtx <-
Expand Down
2 changes: 1 addition & 1 deletion cabal-install/Distribution/Client/CmdSdist.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -171,7 +171,7 @@ sdistAction SdistFlags{..} targetStrings globalFlags = do
let localPkgs = localPackages baseCtx

targetSelectors <- either (reportTargetSelectorProblems verbosity) return
=<< readTargetSelectors localPkgs targetStrings
=<< readTargetSelectors localPkgs Nothing targetStrings

mOutputPath' <- case mOutputPath of
Just "-" -> return (Just "-")
Expand Down
2 changes: 1 addition & 1 deletion cabal-install/Distribution/Client/CmdTest.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -87,7 +87,7 @@ testAction (configFlags, configExFlags, installFlags, haddockFlags)
baseCtx <- establishProjectBaseContext verbosity cliConfig

targetSelectors <- either (reportTargetSelectorProblems verbosity) return
=<< readTargetSelectors (localPackages baseCtx) targetStrings
=<< readTargetSelectors (localPackages baseCtx) (Just TestKind) targetStrings

buildCtx <-
runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do
Expand Down
42 changes: 33 additions & 9 deletions cabal-install/Distribution/Client/TargetSelector.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -84,7 +84,8 @@ import qualified Data.Map.Lazy as Map.Lazy
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Control.Arrow ((&&&))
import Control.Monad
import Control.Monad
hiding ( mfilter )
import qualified Distribution.Compat.ReadP as Parse
import Distribution.Compat.ReadP
( (+++), (<++) )
Expand Down Expand Up @@ -201,20 +202,22 @@ instance Binary SubComponentTarget
-- the available packages (and their locations).
--
readTargetSelectors :: [PackageSpecifier (SourcePackage (PackageLocation a))]
-> Maybe ComponentKindFilter
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Please add a comment here explaining what this parameter does.

-> [String]
-> IO (Either [TargetSelectorProblem] [TargetSelector])
readTargetSelectors = readTargetSelectorsWith defaultDirActions

readTargetSelectorsWith :: (Applicative m, Monad m) => DirActions m
-> [PackageSpecifier (SourcePackage (PackageLocation a))]
-> Maybe ComponentKindFilter
-> [String]
-> m (Either [TargetSelectorProblem] [TargetSelector])
readTargetSelectorsWith dirActions@DirActions{..} pkgs targetStrs =
readTargetSelectorsWith dirActions@DirActions{..} pkgs mfilter targetStrs =
case parseTargetStrings targetStrs of
([], usertargets) -> do
usertargets' <- mapM (getTargetStringFileStatus dirActions) usertargets
knowntargets <- getKnownTargets dirActions pkgs
case resolveTargetSelectors knowntargets usertargets' of
case resolveTargetSelectors knowntargets usertargets' mfilter of
([], btargets) -> return (Right btargets)
(problems, _) -> return (Left problems)
(strs, _) -> return (Left (map TargetSelectorUnrecognised strs))
Expand Down Expand Up @@ -435,29 +438,31 @@ forgetFileStatus t = case t of
--
resolveTargetSelectors :: KnownTargets
-> [TargetStringFileStatus]
-> Maybe ComponentKindFilter
-> ([TargetSelectorProblem],
[TargetSelector])
-- default local dir target if there's no given target:
resolveTargetSelectors (KnownTargets{knownPackagesAll = []}) [] =
resolveTargetSelectors (KnownTargets{knownPackagesAll = []}) [] _ =
([TargetSelectorNoTargetsInProject], [])

resolveTargetSelectors (KnownTargets{knownPackagesPrimary = []}) [] =
resolveTargetSelectors (KnownTargets{knownPackagesPrimary = []}) [] _ =
([TargetSelectorNoTargetsInCwd], [])

resolveTargetSelectors (KnownTargets{knownPackagesPrimary}) [] =
resolveTargetSelectors (KnownTargets{knownPackagesPrimary}) [] _ =
([], [TargetPackage TargetImplicitCwd pkgids Nothing])
where
pkgids = [ pinfoId | KnownPackage{pinfoId} <- knownPackagesPrimary ]

resolveTargetSelectors knowntargets targetStrs =
resolveTargetSelectors knowntargets targetStrs mfilter =
partitionEithers
. map (resolveTargetSelector knowntargets)
. map (resolveTargetSelector knowntargets mfilter)
$ targetStrs

resolveTargetSelector :: KnownTargets
-> Maybe ComponentKindFilter
-> TargetStringFileStatus
-> Either TargetSelectorProblem TargetSelector
resolveTargetSelector knowntargets@KnownTargets{..} targetStrStatus =
resolveTargetSelector knowntargets@KnownTargets{..} mfilter targetStrStatus =
case findMatch (matcher targetStrStatus) of

Unambiguous _
Expand All @@ -472,6 +477,10 @@ resolveTargetSelector knowntargets@KnownTargets{..} targetStrStatus =
| projectIsEmpty -> Left TargetSelectorNoTargetsInProject
| otherwise -> Left (classifyMatchErrors errs)

Ambiguous _ targets
| Just kfilter <- mfilter
, [target] <- applyKindFilter kfilter targets -> Right target

Ambiguous exactMatch targets ->
case disambiguateTargetSelectors
matcher targetStrStatus exactMatch
Expand Down Expand Up @@ -531,6 +540,21 @@ resolveTargetSelector knowntargets@KnownTargets{..} targetStrStatus =
= innerErr (Just (kind,thing)) m
innerErr c m = (c,m)

applyKindFilter :: ComponentKindFilter -> [TargetSelector] -> [TargetSelector]
applyKindFilter kfilter = filter go
where
go (TargetPackage _ _ (Just filter')) = kfilter == filter'
go (TargetPackageNamed _ (Just filter')) = kfilter == filter'
go (TargetAllPackages (Just filter')) = kfilter == filter'
go (TargetComponent _ cname _)
| CLibName <- cname = kfilter == LibKind
| CSubLibName _ <- cname = kfilter == LibKind
| CFLibName _ <- cname = kfilter == FLibKind
| CExeName _ <- cname = kfilter == ExeKind
| CTestName _ <- cname = kfilter == TestKind
| CBenchName _ <- cname = kfilter == BenchKind
go _ = True

-- | The various ways that trying to resolve a 'TargetString' to a
-- 'TargetSelector' can fail.
--
Expand Down
3 changes: 3 additions & 0 deletions cabal-install/changelog
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,6 +1,9 @@
-*-change-log-*-

2.4.0.0 (current development version)
* 'new-run', 'new-test', and 'new-bench' now will attempt to resolve
ambiguous selectors by filtering out selectors that would be invalid.
(#4679, #5461)
* 'new-install' now supports installing libraries and local
components. (#5399)
* Drop support for GHC 7.4, since it is out of our support window
Expand Down
10 changes: 7 additions & 3 deletions cabal-install/tests/IntegrationTests2.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -150,6 +150,7 @@ testTargetSelectors reportSubCase = do
(_, _, _, localPackages, _) <- configureProject testdir config
let readTargetSelectors' = readTargetSelectorsWith (dirActions testdir)
localPackages
Nothing

reportSubCase "cwd"
do Right ts <- readTargetSelectors' []
Expand Down Expand Up @@ -257,7 +258,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 targets
Left errs <- readTargetSelectors localPackages Nothing targets
zipWithM_ (@?=) errs (map TargetSelectorUnrecognised targets)
cleanProject testdir
where
Expand Down Expand Up @@ -378,6 +379,7 @@ testTargetSelectorAmbiguous reportSubCase = do
res <- readTargetSelectorsWith
fakeDirActions
(map SpecificSourcePackage pkgs)
Nothing
[str]
case res of
Left [TargetSelectorAmbiguous _ tss'] ->
Expand All @@ -393,6 +395,7 @@ testTargetSelectorAmbiguous reportSubCase = do
res <- readTargetSelectorsWith
fakeDirActions
(map SpecificSourcePackage pkgs)
Nothing
[str]
case res of
Right [ts'] -> ts' @?= ts
Expand Down Expand Up @@ -472,6 +475,7 @@ testTargetSelectorNoCurrentPackage = do
(_, _, _, localPackages, _) <- configureProject testdir config
let readTargetSelectors' = readTargetSelectorsWith (dirActions testdir)
localPackages
Nothing
targets = [ "libs", ":cwd:libs"
, "flibs", ":cwd:flibs"
, "exes", ":cwd:exes"
Expand All @@ -492,7 +496,7 @@ testTargetSelectorNoCurrentPackage = do
testTargetSelectorNoTargets :: Assertion
testTargetSelectorNoTargets = do
(_, _, _, localPackages, _) <- configureProject testdir config
Left errs <- readTargetSelectors localPackages []
Left errs <- readTargetSelectors localPackages Nothing []
errs @?= [TargetSelectorNoTargetsInCwd]
cleanProject testdir
where
Expand All @@ -503,7 +507,7 @@ testTargetSelectorNoTargets = do
testTargetSelectorProjectEmpty :: Assertion
testTargetSelectorProjectEmpty = do
(_, _, _, localPackages, _) <- configureProject testdir config
Left errs <- readTargetSelectors localPackages []
Left errs <- readTargetSelectors localPackages Nothing []
errs @?= [TargetSelectorNoTargetsInProject]
cleanProject testdir
where
Expand Down