Add --pick-first-target flag

lukel97 · lukel97 · commit 0dff8a6d7916 · 2020-06-08T17:14:06.000+01:00
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
