aklsdgjlk

cabal-install-solver/src/Distribution/Solver/Types/WithConstraintSource.hs

@@ -45,4 +45,4 @@ instance Pretty pkg => Pretty (WithConstraintSource pkg) where
     = pretty constraintPackage
   pretty (WithConstraintSource { constraintPackage, constraintConstraint })
     = pretty constraintPackage
-      <+> parens (text $ showConstraintSource constraintConstraint)
+      <+> parens (text "from" <+> pretty constraintConstraint)

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

@@ -265,7 +265,7 @@ type InstallAction =
   Verbosity
   -> OverwritePolicy
   -> InstallExe
-  -> (UnitId, [(ComponentTarget, NonEmpty TargetSelector)])
+  -> (UnitId, [(ComponentTarget, NonEmpty (WithConstraintSource TargetSelector))])
   -> IO ()
 
 data InstallCfg = InstallCfg
@@ -610,7 +610,7 @@ withProject verbosity cliConfig targetStrings installLibs = do
   -- We want to apply the local configuration only to the actual targets.
   let config =
         addLocalConfigToPkgs (projectConfig baseCtx) $
-          concatMap (targetPkgNames $ localPackages baseCtx) targetSelectors
+          concatMap (targetPkgNames (localPackages baseCtx) . constraintPackage) targetSelectors
   return (pkgSpecs, targetSelectors, config)
   where
     reducedVerbosity = lessVerbose verbosity
@@ -663,7 +663,7 @@ resolveTargetSelectorsInProjectBaseContext verbosity baseCtx targetStrings targe
   targetSelectors <-
     readTargetSelectors (localPackages baseCtx) Nothing targetStrings
       >>= \case
-        Left problems -> reportTargetSelectorProblems verbosity problems
+        Left problems -> reportTargetSelectorProblems verbosity (map constraintPackage problems)
         Right ts -> return ts
 
   getSpecsAndTargetSelectors
@@ -714,7 +714,7 @@ withoutProject verbosity globalConfig targetStrings = do
       buildSettings
       (getSourcePackages verbosity)
 
-  for_ (concatMap woPackageNames tss) $ \name -> do
+  for_ (concatMap (woPackageNames . constraintPackage) tss) $ \name -> do
     when (null (lookupPackageName packageIndex name)) $ do
       let xs = searchByName packageIndex (unPackageName name)
       let emptyIf True _ = []
@@ -728,14 +728,20 @@ withoutProject verbosity globalConfig targetStrings = do
       dieWithException verbosity $ WithoutProject (unPackageName name) str2
 
   let
-    packageSpecifiers :: [PackageSpecifier UnresolvedSourcePackage]
-    (uris, packageSpecifiers) = partitionEithers $ map woPackageSpecifiers tss
-    packageTargets = map woPackageTargets tss
+    outerEither :: WithConstraintSource (Either a b) -> Either (WithConstraintSource a) (WithConstraintSource b)
+    outerEither (withConstraint@WithConstraintSource{constraintPackage = either'}) =
+      case either' of
+        Left inner -> Left (withConstraint{constraintPackage=inner})
+        Right inner -> Right (withConstraint{constraintPackage=inner})
+
+    packageSpecifiers :: [WithConstraintSource (PackageSpecifier UnresolvedSourcePackage)]
+    (uris, packageSpecifiers) = partitionEithers $ map (outerEither . fmap woPackageSpecifiers) tss
+    packageTargets = map (fmap woPackageTargets) tss
 
   -- Apply the local configuration (e.g. cli flags) to all direct targets of install command,
   -- see note in 'installAction'
-  let config = addLocalConfigToPkgs globalConfig (concatMap woPackageNames tss)
-  return (packageSpecifiers, uris, packageTargets, config)
+  let config = addLocalConfigToPkgs globalConfig (concatMap (woPackageNames . constraintPackage) tss)
+  return (map constraintPackage packageSpecifiers, uris, packageTargets, config)
 
 addLocalConfigToPkgs :: ProjectConfig -> [PackageName] -> ProjectConfig
 addLocalConfigToPkgs config pkgs =
@@ -790,11 +796,11 @@ getSpecsAndTargetSelectors
   :: Verbosity
   -> Verbosity
   -> SourcePackageDb
-  -> [TargetSelector]
+  -> [WithConstraintSource TargetSelector]
   -> DistDirLayout
   -> ProjectBaseContext
   -> Maybe ComponentKindFilter
-  -> IO ([PackageSpecifier UnresolvedSourcePackage], [TargetSelector])
+  -> IO ([PackageSpecifier UnresolvedSourcePackage], [WithConstraintSource TargetSelector])
 getSpecsAndTargetSelectors verbosity reducedVerbosity sourcePkgDb targetSelectors distDirLayout baseCtx targetFilter =
   withInstallPlan reducedVerbosity baseCtx $ \elaboratedPlan _ -> do
     -- Split into known targets and hackage packages.
@@ -832,7 +838,7 @@ getSpecsAndTargetSelectors verbosity reducedVerbosity sourcePkgDb targetSelector
       localTargets = map gatherTargets (Map.keys targetsMap)
 
       hackagePkgs :: [PackageSpecifier UnresolvedSourcePackage]
-      hackagePkgs = [NamedPackage pn [] | pn <- hackageNames]
+      hackagePkgs = [Named (WithConstraintSource {constraintPackage=pn}) | pn <- hackageNames]
 
       hackageTargets :: [TargetSelector]
       hackageTargets = [TargetPackageNamed pn targetFilter | pn <- hackageNames]
@@ -867,7 +873,7 @@ partitionToKnownTargetsAndHackagePackages
   :: Verbosity
   -> SourcePackageDb
   -> ElaboratedInstallPlan
-  -> [TargetSelector]
+  -> [WithConstraintSource TargetSelector]
   -> IO (TargetsMap, [PackageName])
 partitionToKnownTargetsAndHackagePackages verbosity pkgDb elaboratedPlan targetSelectors = do
   let mTargets =
@@ -884,7 +890,7 @@ partitionToKnownTargetsAndHackagePackages verbosity pkgDb elaboratedPlan targetS
     Left errs -> do
       -- Not everything is local.
       let
-        (errs', hackageNames) = partitionEithers . flip fmap errs $ \case
+        (errs', hackageNames) = partitionEithers . flip fmap (map constraintPackage $ errs) $ \case
           TargetAvailableInIndex name -> Right name
           err -> Left err
 
@@ -900,7 +906,7 @@ partitionToKnownTargetsAndHackagePackages verbosity pkgDb elaboratedPlan targetS
       when (not . null $ errs') $ reportBuildTargetProblems verbosity errs'
 
       let
-        targetSelectors' = flip filter targetSelectors $ \case
+        targetSelectors' = flip filter (map constraintPackage targetSelectors) $ \case
           TargetComponentUnknown name _ _
             | name `elem` hackageNames -> False
           TargetPackageNamed name _
@@ -910,7 +916,7 @@ partitionToKnownTargetsAndHackagePackages verbosity pkgDb elaboratedPlan targetS
       -- This can't fail, because all of the errors are
       -- removed (or we've given up).
       targets <-
-        either (reportBuildTargetProblems verbosity) return $
+        either (reportBuildTargetProblems verbosity . map constraintPackage) return $
           resolveTargets
             selectPackageTargets
             selectComponentTarget
@@ -924,7 +930,7 @@ constructProjectBuildContext
   :: Verbosity
   -> ProjectBaseContext
   -- ^ The synthetic base context to use to produce the full build context.
-  -> [TargetSelector]
+  -> [WithConstraintSource TargetSelector]
   -> IO ProjectBuildContext
 constructProjectBuildContext verbosity baseCtx targetSelectors = do
   runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do

cabal-install/src/Distribution/Client/CmdListBin.hs

@@ -64,6 +64,8 @@ import Distribution.Client.Errors
 import qualified Distribution.Client.InstallPlan as IP
 import qualified Distribution.Simple.InstallDirs as InstallDirs
 import qualified Distribution.Solver.Types.ComponentDeps as CD
+import Distribution.Solver.Types.WithConstraintSource (WithConstraintSource(..))
+import Distribution.Solver.Types.ConstraintSource (ConstraintSource (..))
 
 -------------------------------------------------------------------------------
 -- Command
@@ -96,8 +98,14 @@ listbinAction flags@NixStyleFlags{..} args globalFlags = do
     [x] -> return x
     _ -> dieWithException verbosity OneTargetRequired
 
+  let targetProvenance = 
+        WithConstraintSource
+          { constraintPackage = target
+          , constraintConstraint = ConstraintSourceCommandlineFlag
+          }
+
   -- configure and elaborate target selectors
-  withContextAndSelectors RejectNoTargets (Just ExeKind) flags [target] globalFlags OtherCommand $ \targetCtx ctx targetSelectors -> do
+  withContextAndSelectors RejectNoTargets (Just ExeKind) flags [targetProvenance] globalFlags OtherCommand $ \targetCtx ctx targetSelectors -> do
     baseCtx <- case targetCtx of
       ProjectContext -> return ctx
       GlobalContext -> return ctx
@@ -108,7 +116,7 @@ listbinAction flags@NixStyleFlags{..} args globalFlags = do
         -- Interpret the targets on the command line as build targets
         -- (as opposed to say repl or haddock targets).
         targets <-
-          either (reportTargetProblems verbosity) return $
+          either (reportTargetProblems verbosity . map constraintPackage) return $
             resolveTargets
               selectPackageTargets
               selectComponentTarget