Skip to content

Commit fb02daa

Browse files
lukel97lukel97
committed
Add --pick-first-target flag
1 parent 4b93757 commit fb02daa

14 files changed

+103
-48
lines changed

‎cabal-install/Distribution/Client/CmdBench.hs

+2-2
Original file line numberDiff line numberDiff line change
@@ -22,7 +22,7 @@ import Distribution.Client.ProjectOrchestration
2222
import Distribution.Client.CmdErrorMessages
2323
( renderTargetSelector, showTargetSelector, renderTargetProblem,
2424
renderTargetProblemNoTargets, plural, targetSelectorPluralPkgs,
25-
targetSelectorFilter, AmbiguityResolver(..) )
25+
targetSelectorFilter )
2626
import Distribution.Client.TargetProblem
2727
( TargetProblem (..) )
2828
import Distribution.Client.NixStyleOptions
@@ -88,7 +88,7 @@ benchAction flags@NixStyleFlags {..} targetStrings globalFlags = do
8888

8989
targetSelectors <- either (reportTargetSelectorProblems verbosity) return
9090
=<< readTargetSelectors (localPackages baseCtx)
91-
(AmbiguityResolverKind BenchKind) targetStrings
91+
(Just BenchKind) flags targetStrings
9292

9393
buildCtx <-
9494
runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do

‎cabal-install/Distribution/Client/CmdBuild.hs

+1-1
Original file line numberDiff line numberDiff line change
@@ -107,7 +107,7 @@ buildAction flags@NixStyleFlags { extraFlags = buildFlags, ..} targetStrings glo
107107
targetSelectors <-
108108
either (reportTargetSelectorProblems verbosity) return
109109
=<< readTargetSelectors (localPackages baseCtx)
110-
AmbiguityResolverNone targetStrings
110+
Nothing flags targetStrings
111111

112112
buildCtx <-
113113
runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do

‎cabal-install/Distribution/Client/CmdErrorMessages.hs

+1-1
Original file line numberDiff line numberDiff line change
@@ -21,7 +21,7 @@ import Distribution.Client.TargetSelector
2121
import Distribution.Client.TargetProblem
2222
( TargetProblem(..), TargetProblem' )
2323
import Distribution.Client.TargetSelector
24-
( ComponentKind(..), AmbiguityResolver(..), TargetSelector(..),
24+
( ComponentKind(..), TargetSelector(..),
2525
componentKind, showTargetSelector )
2626

2727
import Distribution.Package

‎cabal-install/Distribution/Client/CmdHaddock.hs

+2-2
Original file line numberDiff line numberDiff line change
@@ -76,8 +76,8 @@ haddockAction flags@NixStyleFlags {..} targetStrings globalFlags = do
7676
baseCtx <- establishProjectBaseContext verbosity cliConfig HaddockCommand
7777

7878
targetSelectors <- either (reportTargetSelectorProblems verbosity) return
79-
=<< readTargetSelectors (localPackages baseCtx)
80-
AmbiguityResolverNone targetStrings
79+
=<< readTargetSelectors (localPackages baseCtx) Nothing flags
80+
targetStrings
8181

8282
buildCtx <-
8383
runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do

‎cabal-install/Distribution/Client/CmdInstall.hs

+2-2
Original file line numberDiff line numberDiff line change
@@ -240,8 +240,8 @@ installAction flags@NixStyleFlags { extraFlags = clientInstallFlags', .. } targe
240240
else do
241241
targetSelectors <-
242242
either (reportTargetSelectorProblems verbosity) return
243-
=<< readTargetSelectors (localPackages localBaseCtx)
244-
AmbiguityResolverNone targetStrings''
243+
=<< readTargetSelectors (localPackages localBaseCtx) Nothing flags
244+
targetStrings''
245245

246246
(specs, selectors) <-
247247
getSpecsAndTargetSelectors

‎cabal-install/Distribution/Client/CmdRepl.hs

+6-5
Original file line numberDiff line numberDiff line change
@@ -26,7 +26,7 @@ import qualified Distribution.Types.Lens as L
2626
import Distribution.Client.NixStyleOptions
2727
( NixStyleFlags (..), nixStyleOptions, defaultNixStyleFlags )
2828
import Distribution.Client.CmdErrorMessages
29-
( renderTargetSelector, showTargetSelector, AmbiguityResolver(..),
29+
( renderTargetSelector, showTargetSelector,
3030
renderTargetProblem,
3131
targetSelectorRefersToPkgs,
3232
renderComponentKind, renderListCommaAnd, renderListSemiAnd,
@@ -204,7 +204,7 @@ replCommand = Client.installCommand {
204204
replAction :: NixStyleFlags (ReplFlags, EnvFlags) -> [String] -> GlobalFlags -> IO ()
205205
replAction flags@NixStyleFlags { extraFlags = (replFlags, envFlags), ..} targetStrings globalFlags = do
206206
let
207-
with = withProject cliConfig verbosity targetStrings
207+
with = withProject flags cliConfig verbosity targetStrings
208208
without config = withoutProject (config <> cliConfig) verbosity targetStrings
209209

210210
(baseCtx, targetSelectors, finalizer, replType) <-
@@ -338,13 +338,14 @@ data ReplType = ProjectRepl
338338
-- 7.6, though. 🙁
339339
deriving (Show, Eq)
340340

341-
withProject :: ProjectConfig -> Verbosity -> [String]
341+
withProject :: NixStyleFlags a -> ProjectConfig -> Verbosity -> [String]
342342
-> IO (ProjectBaseContext, [TargetSelector], IO (), ReplType)
343-
withProject cliConfig verbosity targetStrings = do
343+
withProject flags cliConfig verbosity targetStrings = do
344344
baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand
345345

346346
targetSelectors <- either (reportTargetSelectorProblems verbosity) return
347-
=<< readTargetSelectors (localPackages baseCtx) (AmbiguityResolverKind LibKind) targetStrings
347+
=<< readTargetSelectors (localPackages baseCtx) (Just LibKind)
348+
flags targetStrings
348349

349350
return (baseCtx, targetSelectors, return (), ProjectRepl)
350351

‎cabal-install/Distribution/Client/CmdRun.hs

+2-2
Original file line numberDiff line numberDiff line change
@@ -59,7 +59,7 @@ import Distribution.Client.ProjectPlanning
5959
import Distribution.Client.ProjectPlanning.Types
6060
( dataDirsEnvironmentForPlan )
6161
import Distribution.Client.TargetSelector
62-
( TargetSelectorProblem(..), TargetString(..), AmbiguityResolver(..) )
62+
( TargetSelectorProblem(..), TargetString(..) )
6363
import Distribution.Client.InstallPlan
6464
( toList, foldPlanPackage )
6565
import Distribution.Types.UnqualComponentName
@@ -182,7 +182,7 @@ runAction flags@NixStyleFlags {..} targetStrings globalFlags = do
182182
else reportTargetSelectorProblems verbosity err
183183

184184
(baseCtx', targetSelectors) <-
185-
readTargetSelectors (localPackages baseCtx) (AmbiguityResolverKind ExeKind) (take 1 targetStrings)
185+
readTargetSelectors (localPackages baseCtx) (Just ExeKind) flags (take 1 targetStrings)
186186
>>= \case
187187
Left err@(TargetSelectorNoTargetsInProject:_)
188188
| (script:_) <- targetStrings -> scriptOrError script err

‎cabal-install/Distribution/Client/CmdSdist.hs

+3-3
Original file line numberDiff line numberDiff line change
@@ -18,8 +18,8 @@ import Distribution.Client.ProjectOrchestration
1818
import Distribution.Client.NixStyleOptions
1919
( NixStyleFlags (..), defaultNixStyleFlags )
2020
import Distribution.Client.TargetSelector
21-
( TargetSelector(..), ComponentKind, AmbiguityResolver(..)
22-
, readTargetSelectors, reportTargetSelectorProblems )
21+
( TargetSelector(..), ComponentKind
22+
, readTargetSelectors', reportTargetSelectorProblems )
2323
import Distribution.Client.Setup
2424
( GlobalFlags(..) )
2525
import Distribution.Solver.Types.SourcePackage
@@ -151,7 +151,7 @@ sdistAction (ProjectFlags{..}, SdistFlags{..}) targetStrings globalFlags = do
151151
let localPkgs = localPackages baseCtx
152152

153153
targetSelectors <- either (reportTargetSelectorProblems verbosity) return
154-
=<< readTargetSelectors localPkgs AmbiguityResolverNone targetStrings
154+
=<< readTargetSelectors' localPkgs Nothing targetStrings
155155

156156
-- elaborate path, create target directory
157157
mOutputPath' <- case mOutputPath of

‎cabal-install/Distribution/Client/CmdShowBuildInfo.hs

+3-1
Original file line numberDiff line numberDiff line change
@@ -114,7 +114,7 @@ showBuildInfoAction flags@NixStyleFlags { extraFlags = (ShowBuildInfoFlags fileO
114114
}
115115

116116
targetSelectors <- either (reportTargetSelectorProblems verbosity) return
117-
=<< readTargetSelectors (localPackages baseCtx') AmbiguityResolverFirst targetStrings
117+
=<< readTargetSelectors (localPackages baseCtx') Nothing flags targetStrings
118118

119119
buildCtx <-
120120
runProjectPreBuildPhase verbosity baseCtx' $ \elaboratedPlan -> do
@@ -155,6 +155,8 @@ showBuildInfoAction flags@NixStyleFlags { extraFlags = (ShowBuildInfoFlags fileO
155155

156156
showTargets :: Maybe FilePath -> Maybe [String] -> Verbosity -> ProjectBaseContext -> ProjectBuildContext -> Lock -> IO ()
157157
showTargets fileOutput unitIds verbosity baseCtx buildCtx lock = do
158+
159+
-- TODO: can we use --disable-per-component so that we only get one package?
158160
let configured = [p | InstallPlan.Configured p <- InstallPlan.toList (elaboratedPlanOriginal buildCtx)]
159161
targets = maybe (fst <$> (Map.toList . targetsMap $ buildCtx)) (map mkUnitId) unitIds
160162

‎cabal-install/Distribution/Client/CmdTest.hs

+3-4
Original file line numberDiff line numberDiff line change
@@ -22,8 +22,7 @@ import Distribution.Client.ProjectOrchestration
2222
import Distribution.Client.CmdErrorMessages
2323
( renderTargetSelector, showTargetSelector, targetSelectorFilter, plural,
2424
renderTargetProblem,
25-
renderTargetProblemNoTargets, targetSelectorPluralPkgs,
26-
AmbiguityResolver(..) )
25+
renderTargetProblemNoTargets, targetSelectorPluralPkgs )
2726
import Distribution.Client.TargetProblem
2827
( TargetProblem (..) )
2928
import Distribution.Client.NixStyleOptions
@@ -100,8 +99,8 @@ testAction flags@NixStyleFlags {..} targetStrings globalFlags = do
10099
baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand
101100

102101
targetSelectors <- either (reportTargetSelectorProblems verbosity) return
103-
=<< readTargetSelectors (localPackages baseCtx)
104-
(AmbiguityResolverKind TestKind) targetStrings
102+
=<< readTargetSelectors (localPackages baseCtx)
103+
(Just TestKind) flags targetStrings
105104

106105
buildCtx <-
107106
runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do

‎cabal-install/Distribution/Client/Config.hs

+3-1
Original file line numberDiff line numberDiff line change
@@ -428,7 +428,9 @@ instance Semigroup SavedConfig where
428428
configAllowOlder =
429429
combineMonoid savedConfigureExFlags configAllowOlder,
430430
configWriteGhcEnvironmentFilesPolicy
431-
= combine configWriteGhcEnvironmentFilesPolicy
431+
= combine configWriteGhcEnvironmentFilesPolicy,
432+
configPickFirstTarget
433+
= combine configPickFirstTarget
432434
}
433435
where
434436
combine = combine' savedConfigureExFlags

‎cabal-install/Distribution/Client/ProjectConfig/Legacy.hs

+4-2
Original file line numberDiff line numberDiff line change
@@ -83,7 +83,7 @@ import qualified Distribution.Deprecated.ParseUtils as ParseUtils
8383
import Distribution.Deprecated.ParseUtils
8484
( ParseResult(..), PError(..), syntaxError, PWarning(..)
8585
, commaNewLineListFieldParsec, newLineListField, parseTokenQ
86-
, parseHaskellString, showToken
86+
, parseHaskellString, showToken
8787
, simpleFieldParsec
8888
)
8989
import Distribution.Client.ParseUtils
@@ -603,7 +603,9 @@ convertToLegacySharedConfig
603603
configAllowOlder = projectConfigAllowOlder,
604604
configAllowNewer = projectConfigAllowNewer,
605605
configWriteGhcEnvironmentFilesPolicy
606-
= projectConfigWriteGhcEnvironmentFilesPolicy
606+
= projectConfigWriteGhcEnvironmentFilesPolicy,
607+
configPickFirstTarget
608+
= mempty
607609
}
608610

609611
installFlags = InstallFlags {

‎cabal-install/Distribution/Client/Setup.hs

+12-2
Original file line numberDiff line numberDiff line change
@@ -624,12 +624,15 @@ data ConfigExFlags = ConfigExFlags {
624624
configAllowNewer :: Maybe AllowNewer,
625625
configAllowOlder :: Maybe AllowOlder,
626626
configWriteGhcEnvironmentFilesPolicy
627-
:: Flag WriteGhcEnvironmentFilesPolicy
627+
:: Flag WriteGhcEnvironmentFilesPolicy,
628+
configPickFirstTarget
629+
:: Flag Bool
628630
}
629631
deriving (Eq, Show, Generic)
630632

631633
defaultConfigExFlags :: ConfigExFlags
632-
defaultConfigExFlags = mempty { configSolver = Flag defaultSolver }
634+
defaultConfigExFlags = mempty { configSolver = Flag defaultSolver
635+
, configPickFirstTarget = Flag False }
633636

634637
configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags)
635638
configureExCommand = configureCommand {
@@ -697,6 +700,13 @@ configureExOptions _showOrParseArgs src =
697700
(reqArg "always|never|ghc8.4.4+"
698701
writeGhcEnvironmentFilesPolicyParser
699702
writeGhcEnvironmentFilesPolicyPrinter)
703+
704+
, option [] ["pick-first-target"]
705+
("If there's an amibguity in the target selector, then resolve it by"
706+
++ " choosing the first")
707+
configPickFirstTarget
708+
(\v flags -> flags { configPickFirstTarget = v})
709+
trueArg
700710
]
701711

702712

‎cabal-install/Distribution/Client/TargetSelector.hs

+59-20
Original file line numberDiff line numberDiff line change
@@ -19,13 +19,13 @@ module Distribution.Client.TargetSelector (
1919
TargetSelector(..),
2020
TargetImplicitCwd(..),
2121
ComponentKind(..),
22-
AmbiguityResolver(..),
2322
SubComponentTarget(..),
2423
QualLevel(..),
2524
componentKind,
2625

2726
-- * Reading target selectors
2827
readTargetSelectors,
28+
readTargetSelectors',
2929
TargetSelectorProblem(..),
3030
reportTargetSelectorProblems,
3131
showTargetSelector,
@@ -66,6 +66,12 @@ import Distribution.Simple.LocalBuildInfo
6666
, pkgComponents, componentName, componentBuildInfo )
6767
import Distribution.Types.ForeignLib
6868

69+
import Distribution.Client.NixStyleOptions
70+
import Distribution.Client.Setup
71+
( ConfigExFlags(..) )
72+
import Distribution.Simple.Setup
73+
( fromFlagOrDefault )
74+
6975
import Distribution.Simple.Utils
7076
( die', lowercase, ordNub )
7177
import Distribution.Client.Utils
@@ -176,6 +182,7 @@ data AmbiguityResolver =
176182
| AmbiguityResolverFirst
177183
-- | Choose the target component with the specific kind
178184
| AmbiguityResolverKind ComponentKind
185+
| AmbiguityResolverKindFirst ComponentKind
179186
deriving (Eq, Ord, Show)
180187

181188
-- | Either the component as a whole or detail about a file or module target
@@ -208,36 +215,54 @@ instance Structured SubComponentTarget
208215
-- the available packages (and their locations).
209216
--
210217
readTargetSelectors :: [PackageSpecifier (SourcePackage (PackageLocation a))]
211-
-> AmbiguityResolver
218+
-> Maybe ComponentKind
212219
-- ^ This parameter is used when there are ambiguous selectors.
213-
-- If it is 'AmbiguityResolverKind', then we attempt to resolve
214-
-- ambiguitiy by applying it, since otherwise there is no
215-
-- way to allow contextually valid yet syntactically ambiguous
220+
-- If it is 'Just', then we attempt to resolve ambiguitiy
221+
-- by applying it, since otherwise there is no way to
222+
-- allow contextually valid yet syntactically ambiguous
216223
-- selectors.
217224
-- (#4676, #5461)
218-
-- If it is 'AmbiguityResolverFirst', then we resolve it by
219-
-- choosing just the first target. This is used by
220-
-- the show-build-info command.
221-
-- Otherwise, if it is 'AmbiguityResolverNone', we make
222-
-- ambiguity a 'TargetSelectorProblem'.
225+
-> NixStyleFlags b
226+
-- ^ Used in case @--pick-first-target@ was passed.
223227
-> [String]
224228
-> IO (Either [TargetSelectorProblem] [TargetSelector])
225-
readTargetSelectors = readTargetSelectorsWith defaultDirActions
229+
readTargetSelectors pkgs mfilter NixStyleFlags{configExFlags}
230+
= readTargetSelectorsWith defaultDirActions pkgs mfilter
231+
(fromFlagOrDefault False (configPickFirstTarget configExFlags))
232+
233+
234+
-- | Same as 'readTargetSelectors' but in case you don't have 'NixStyleFlags'.
235+
readTargetSelectors' :: [PackageSpecifier (SourcePackage (PackageLocation a))]
236+
-> Maybe ComponentKind
237+
-> [String]
238+
-> IO (Either [TargetSelectorProblem] [TargetSelector])
239+
readTargetSelectors' pkgs mfilter =
240+
readTargetSelectorsWith defaultDirActions pkgs mfilter False
226241

227242
readTargetSelectorsWith :: (Applicative m, Monad m) => DirActions m
228243
-> [PackageSpecifier (SourcePackage (PackageLocation a))]
229-
-> AmbiguityResolver
244+
-> Maybe ComponentKind
245+
-- ^ Filter the target to resolve ambiguity?
246+
-> Bool
247+
-- ^ Pick the first target to resolve ambiguity?
230248
-> [String]
231249
-> m (Either [TargetSelectorProblem] [TargetSelector])
232-
readTargetSelectorsWith dirActions@DirActions{} pkgs mfilter targetStrs =
250+
readTargetSelectorsWith dirActions@DirActions{} pkgs mfilter pickFirst targetStrs =
233251
case parseTargetStrings targetStrs of
234252
([], usertargets) -> do
235253
usertargets' <- traverse (getTargetStringFileStatus dirActions) usertargets
236254
knowntargets <- getKnownTargets dirActions pkgs
237-
case resolveTargetSelectors knowntargets usertargets' mfilter of
255+
case resolveTargetSelectors knowntargets usertargets' resolver of
238256
([], btargets) -> return (Right btargets)
239257
(problems, _) -> return (Left problems)
240258
(strs, _) -> return (Left (map TargetSelectorUnrecognised strs))
259+
where
260+
resolver
261+
| Just kind <- mfilter
262+
, pickFirst = AmbiguityResolverKindFirst kind
263+
| Just kind <- mfilter = AmbiguityResolverKind kind
264+
| pickFirst = AmbiguityResolverFirst
265+
| otherwise = AmbiguityResolverNone
241266

242267

243268
data DirActions m = DirActions {
@@ -496,7 +521,7 @@ resolveTargetSelector :: KnownTargets
496521
-> AmbiguityResolver
497522
-> TargetStringFileStatus
498523
-> Either TargetSelectorProblem TargetSelector
499-
resolveTargetSelector knowntargets@KnownTargets{..} mfilter targetStrStatus =
524+
resolveTargetSelector knowntargets@KnownTargets{..} resolver targetStrStatus =
500525
case findMatch (matcher targetStrStatus) of
501526

502527
Unambiguous _
@@ -511,18 +536,32 @@ resolveTargetSelector knowntargets@KnownTargets{..} mfilter targetStrStatus =
511536
| projectIsEmpty -> Left TargetSelectorNoTargetsInProject
512537
| otherwise -> Left (classifyMatchErrors errs)
513538

539+
-- Try to resolve the ambiguity with a kind filter
514540
Ambiguous _ targets
515-
| AmbiguityResolverKind kfilter <- mfilter
541+
| AmbiguityResolverKind kfilter <- resolver
516542
, [target] <- applyKindFilter kfilter targets -> Right target
517543

544+
-- If we have a filter and want to pick from the first
545+
Ambiguous _ targets
546+
| AmbiguityResolverKindFirst kfilter <- resolver
547+
, target:_ <- applyKindFilter kfilter targets -> Right target
548+
549+
-- Same case as above, except there weren't any filter matches
550+
Ambiguous _ targets
551+
| AmbiguityResolverKindFirst _ <- resolver
552+
, target:_ <- targets -> Right target
553+
554+
-- Just pick the first of any
555+
Ambiguous _ targets
556+
| AmbiguityResolverFirst <- resolver
557+
, target:_ <- targets -> Right target
558+
559+
-- A truly, unresolvable ambiguity
518560
Ambiguous exactMatch targets ->
519561
case disambiguateTargetSelectors
520562
matcher targetStrStatus exactMatch
521563
targets of
522-
Right targets' ->
523-
case (targets', mfilter) of
524-
((_,t):_, AmbiguityResolverFirst) -> Right t
525-
_ -> Left (TargetSelectorAmbiguous targetStr targets')
564+
Right targets' -> Left (TargetSelectorAmbiguous targetStr targets')
526565
Left ((m, ms):_) -> Left (MatchingInternalError targetStr m ms)
527566
Left [] -> internalError "resolveTargetSelector"
528567
where

0 commit comments

Comments
 (0)