Show constraint sources in dependency solver errors

cabal-install-solver/cabal-install-solver.cabal

@@ -76,11 +76,13 @@ library
     Distribution.Solver.Modular.WeightedPSQ
     Distribution.Solver.Types.ComponentDeps
     Distribution.Solver.Types.ConstraintSource
+    Distribution.Solver.Types.WithConstraintSource
     Distribution.Solver.Types.DependencyResolver
     Distribution.Solver.Types.Flag
     Distribution.Solver.Types.InstalledPreference
     Distribution.Solver.Types.InstSolverPackage
     Distribution.Solver.Types.LabeledPackageConstraint
+    Distribution.Solver.Types.NamedPackage
     Distribution.Solver.Types.OptionalStanza
     Distribution.Solver.Types.PackageConstraint
     Distribution.Solver.Types.PackageFixedDeps

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

@@ -56,7 +56,11 @@ data ConstraintSource =
   -- | An internal constraint due to compatibility issues with the Setup.hs
   -- command line interface requires a maximum upper bound on Cabal
   | ConstraintSetupCabalMaxVersion
-  deriving (Show, Eq, Generic)
+
+  -- | An implicit constraint added by Cabal, for example if no targets are
+  -- listed on the command line.
+  | ConstraintSourceImplicitTarget
+  deriving (Show, Eq, Ord, Generic)
 
 instance Binary ConstraintSource
 instance Structured ConstraintSource
@@ -88,3 +92,5 @@ instance Pretty ConstraintSource where
       text "minimum version of Cabal used by Setup.hs"
     ConstraintSetupCabalMaxVersion ->
       text "maximum version of Cabal used by Setup.hs"
+    ConstraintSourceImplicitTarget ->
+      text "implicit target"

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

@@ -0,0 +1,28 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Distribution.Solver.Types.NamedPackage
+  ( NamedPackage (..)
+  , NamedPackageConstraint
+  ) where
+
+import Distribution.Solver.Compat.Prelude
+import Prelude ()
+
+import Distribution.Types.PackageName (PackageName)
+import Distribution.Solver.Types.PackageConstraint (PackageProperty)
+import Distribution.Solver.Types.WithConstraintSource (WithConstraintSource)
+import Distribution.Pretty (Pretty (pretty), commaSpaceSep)
+import Text.PrettyPrint
+
+-- | A package, identified by a name and properties.
+data NamedPackage = NamedPackage PackageName [PackageProperty]
+  deriving (Show, Eq, Ord, Generic)
+
+instance Binary NamedPackage
+instance Structured NamedPackage
+
+instance Pretty NamedPackage where
+  pretty (NamedPackage name properties) =
+    pretty name <+> parens (commaSpaceSep properties)
+
+type NamedPackageConstraint = WithConstraintSource NamedPackage

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

@@ -93,7 +93,7 @@ data PackageProperty
    | PackagePropertySource
    | PackagePropertyFlags     FlagAssignment
    | PackagePropertyStanzas   [OptionalStanza]
-  deriving (Eq, Show, Generic)
+  deriving (Eq, Ord, Show, Generic)
 
 instance Binary PackageProperty
 instance Structured PackageProperty

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

@@ -1,4 +1,6 @@
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveFunctor #-}
+
 module Distribution.Solver.Types.SourcePackage
     ( PackageDescriptionOverride
     , SourcePackage(..)
@@ -24,7 +26,7 @@ data SourcePackage loc = SourcePackage
   , srcpkgSource        :: loc
   , srcpkgDescrOverride :: PackageDescriptionOverride
   }
-  deriving (Eq, Show, Generic)
+  deriving (Eq, Show, Functor, Generic)
 
 instance Binary loc => Binary (SourcePackage loc)
 instance Structured loc => Structured (SourcePackage loc)

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

@@ -0,0 +1,48 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE NamedFieldPuns #-}
+
+module Distribution.Solver.Types.WithConstraintSource
+  ( WithConstraintSource (..)
+  , showWithConstraintSource
+  , withUnknownConstraint
+  ) where
+
+import Distribution.Solver.Compat.Prelude
+
+import Distribution.Solver.Types.ConstraintSource (ConstraintSource (..), showConstraintSource)
+import Distribution.Pretty (Pretty (pretty))
+import Text.PrettyPrint
+
+-- | A package bundled with a `ConstraintSource`.
+data WithConstraintSource pkg =
+  WithConstraintSource
+    { constraintInner :: pkg
+      -- ^ The package.
+    , constraintSource :: ConstraintSource
+      -- ^ The constraint source for the package.
+    }
+  deriving (Show, Functor, Eq, Ord, Traversable, Foldable, Generic)
+
+instance Binary pkg => Binary (WithConstraintSource pkg)
+instance Structured pkg => Structured (WithConstraintSource pkg)
+
+withUnknownConstraint :: pkg -> WithConstraintSource pkg
+withUnknownConstraint constraintInner =
+  WithConstraintSource
+    { constraintInner
+    , constraintSource = ConstraintSourceUnknown
+    }
+
+showWithConstraintSource :: (pkg -> String) -> WithConstraintSource pkg -> String
+showWithConstraintSource
+  showPackage
+  (WithConstraintSource { constraintInner, constraintSource }) =
+    showPackage constraintInner ++ " (" ++ showConstraintSource constraintSource ++ ")"
+
+instance Pretty pkg => Pretty (WithConstraintSource pkg) where
+  pretty (WithConstraintSource { constraintInner, constraintSource = ConstraintSourceUnknown })
+    = pretty constraintInner
+  pretty (WithConstraintSource { constraintInner, constraintSource })
+    = pretty constraintInner
+      <+> parens (text "from" <+> pretty constraintSource)

cabal-install/cabal-install.cabal

@@ -248,6 +248,7 @@ library
         zlib       >= 0.5.3    && < 0.8,
         hackage-security >= 0.6.2.0 && < 0.7,
         text       >= 1.2.3    && < 1.3 || >= 2.0 && < 2.2,
+        transformers >= 0.2    && <0.7,
         parsec     >= 3.1.13.0 && < 3.2,
         open-browser >= 0.2.1.0 && < 0.3,
         regex-base  >= 0.94.0.0 && <0.95,

cabal-install/src/Distribution/Client/BuildReports/Storage.hs

@@ -39,6 +39,9 @@ import Distribution.Client.Types
 
 import qualified Distribution.Solver.Types.ComponentDeps as CD
 import Distribution.Solver.Types.SourcePackage
+import Distribution.Solver.Types.WithConstraintSource
+  ( WithConstraintSource (..)
+  )
 
 import Distribution.Compiler
   ( CompilerId (..)
@@ -200,8 +203,16 @@ fromPlanPackage
       , extractRepo srcPkg
       )
     where
-      extractRepo (SourcePackage{srcpkgSource = RepoTarballPackage repo _ _}) =
-        Just repo
+      extractRepo
+        ( SourcePackage
+            { srcpkgSource =
+              WithConstraintSource
+                { constraintInner =
+                  RepoTarballPackage repo _ _
+                }
+            }
+          ) =
+          Just repo
       extractRepo _ = Nothing
 fromPlanPackage _ _ _ _ = Nothing
 

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

@@ -56,6 +56,12 @@ import Distribution.Simple.Utils
   , warn
   , wrapText
   )
+import Distribution.Solver.Types.ConstraintSource
+  ( ConstraintSource (..)
+  )
+import Distribution.Solver.Types.WithConstraintSource
+  ( WithConstraintSource (..)
+  )
 import Distribution.Verbosity
   ( normal
   )
@@ -115,8 +121,11 @@ benchAction flags@NixStyleFlags{..} targetStrings globalFlags = do
   baseCtx <- establishProjectBaseContext verbosity cliConfig OtherCommand
 
   targetSelectors <-
-    either (reportTargetSelectorProblems verbosity) return
-      =<< readTargetSelectors (localPackages baseCtx) (Just BenchKind) targetStrings
+    either (reportTargetSelectorProblems verbosity . map constraintInner) return
+      =<< readTargetSelectors
+        (localPackages baseCtx)
+        (Just BenchKind)
+        (map (\target -> WithConstraintSource{constraintInner = target, constraintSource = ConstraintSourceUserTarget}) targetStrings)
 
   buildCtx <-
     runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do
@@ -131,7 +140,7 @@ benchAction flags@NixStyleFlags{..} targetStrings globalFlags = do
       -- Interpret the targets on the command line as bench targets
       -- (as opposed to say build or haddock targets).
       targets <-
-        either (reportTargetProblems verbosity) return $
+        either (reportTargetProblems verbosity . map constraintInner) return $
           resolveTargets
             selectPackageTargets
             selectComponentTarget

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

@@ -25,6 +25,12 @@ import Distribution.Client.TargetProblem
   ( TargetProblem (..)
   , TargetProblem'
   )
+import Distribution.Solver.Types.ConstraintSource
+  ( ConstraintSource (..)
+  )
+import Distribution.Solver.Types.WithConstraintSource
+  ( WithConstraintSource (..)
+  )
 
 import qualified Data.Map as Map
 import Distribution.Client.Errors
@@ -135,7 +141,7 @@ defaultBuildFlags =
 -- "Distribution.Client.ProjectOrchestration"
 buildAction :: NixStyleFlags BuildFlags -> [String] -> GlobalFlags -> IO ()
 buildAction flags@NixStyleFlags{extraFlags = buildFlags, ..} targetStrings globalFlags =
-  withContextAndSelectors RejectNoTargets Nothing flags targetStrings globalFlags BuildCommand $ \targetCtx ctx targetSelectors -> do
+  withContextAndSelectors RejectNoTargets Nothing flags constraintTargets globalFlags BuildCommand $ \targetCtx ctx targetSelectors -> do
     -- TODO: This flags defaults business is ugly
     let onlyConfigure =
           fromFlag
@@ -156,7 +162,7 @@ buildAction flags@NixStyleFlags{extraFlags = buildFlags, ..} targetStrings globa
         -- Interpret the targets on the command line as build targets
         -- (as opposed to say repl or haddock targets).
         targets <-
-          either (reportBuildTargetProblems verbosity) return $
+          either (reportBuildTargetProblems verbosity . map constraintInner) return $
             resolveTargets
               selectPackageTargets
               selectComponentTarget
@@ -186,6 +192,15 @@ buildAction flags@NixStyleFlags{extraFlags = buildFlags, ..} targetStrings globa
     runProjectPostBuildPhase verbosity baseCtx buildCtx buildOutcomes
   where
     verbosity = fromFlagOrDefault normal (setupVerbosity $ configCommonFlags configFlags)
+    constraintTargets =
+      map
+        ( \target ->
+            WithConstraintSource
+              { constraintInner = target
+              , constraintSource = ConstraintSourceUserTarget
+              }
+        )
+        targetStrings
 
 -- | This defines what a 'TargetSelector' means for the @bench@ command.
 -- It selects the 'AvailableTarget's that the 'TargetSelector' refers to,

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

@@ -38,6 +38,9 @@ import Distribution.Solver.Types.ConstraintSource
 import Distribution.Solver.Types.PackageConstraint
   ( PackageProperty (..)
   )
+import Distribution.Solver.Types.WithConstraintSource
+  ( WithConstraintSource (..)
+  )
 
 import Distribution.Client.Setup
   ( CommonSetupFlags (setupVerbosity)
@@ -192,7 +195,7 @@ projectFreezeConfig elaboratedPlan totalIndexState activeRepos0 =
 -- solver picks the same solution again in future in different environments.
 projectFreezeConstraints
   :: ElaboratedInstallPlan
-  -> Map PackageName [(UserConstraint, ConstraintSource)]
+  -> Map PackageName [WithConstraintSource UserConstraint]
 projectFreezeConstraints plan =
   --
   -- TODO: [required eventually] this is currently an underapproximation
@@ -211,14 +214,14 @@ projectFreezeConstraints plan =
   deleteLocalPackagesVersionConstraints
     (Map.unionWith (++) versionConstraints flagConstraints)
   where
-    versionConstraints :: Map PackageName [(UserConstraint, ConstraintSource)]
+    versionConstraints :: Map PackageName [WithConstraintSource UserConstraint]
     versionConstraints =
       Map.mapWithKey
         ( \p v ->
-            [
-              ( UserConstraint (UserAnyQualifier p) (PackagePropertyVersion v)
-              , ConstraintSourceFreeze
-              )
+            [ WithConstraintSource
+                { constraintInner = UserConstraint (UserAnyQualifier p) (PackagePropertyVersion v)
+                , constraintSource = ConstraintSourceFreeze
+                }
             ]
         )
         versionRanges
@@ -234,14 +237,14 @@ projectFreezeConstraints plan =
                | InstallPlan.Configured pkg <- InstallPlan.toList plan
                ]
 
-    flagConstraints :: Map PackageName [(UserConstraint, ConstraintSource)]
+    flagConstraints :: Map PackageName [WithConstraintSource UserConstraint]
     flagConstraints =
       Map.mapWithKey
         ( \p f ->
-            [
-              ( UserConstraint (UserQualified UserQualToplevel p) (PackagePropertyFlags f)
-              , ConstraintSourceFreeze
-              )
+            [ WithConstraintSource
+                { constraintInner = UserConstraint (UserQualified UserQualToplevel p) (PackagePropertyFlags f)
+                , constraintSource = ConstraintSourceFreeze
+                }
             ]
         )
         flagAssignments
@@ -259,12 +262,12 @@ projectFreezeConstraints plan =
     -- As described above, remove the version constraints on local packages,
     -- but leave any flag constraints.
     deleteLocalPackagesVersionConstraints
-      :: Map PackageName [(UserConstraint, ConstraintSource)]
-      -> Map PackageName [(UserConstraint, ConstraintSource)]
+      :: Map PackageName [WithConstraintSource UserConstraint]
+      -> Map PackageName [WithConstraintSource UserConstraint]
     deleteLocalPackagesVersionConstraints =
       Map.mergeWithKey
         ( \_pkgname () constraints ->
-            case filter (not . isVersionConstraint . fst) constraints of
+            case filter (not . isVersionConstraint . constraintInner) constraints of
               [] -> Nothing
               constraints' -> Just constraints'
         )

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

@@ -65,6 +65,12 @@ import Distribution.Simple.Utils
   , notice
   , wrapText
   )
+import Distribution.Solver.Types.ConstraintSource
+  ( ConstraintSource (..)
+  )
+import Distribution.Solver.Types.WithConstraintSource
+  ( WithConstraintSource (..)
+  )
 import Distribution.Verbosity
   ( normal
   )
@@ -164,8 +170,11 @@ haddockAction relFlags targetStrings globalFlags = do
   let baseCtx = relBaseCtx{projectConfig = absProjectConfig}
 
   targetSelectors <-
-    either (reportTargetSelectorProblems verbosity) return
-      =<< readTargetSelectors (localPackages baseCtx) Nothing targetStrings
+    either (reportTargetSelectorProblems verbosity . map constraintInner) return
+      =<< readTargetSelectors
+        (localPackages baseCtx)
+        Nothing
+        (map (\target -> WithConstraintSource{constraintInner = target, constraintSource = ConstraintSourceUserTarget}) targetStrings)
 
   buildCtx <-
     runProjectPreBuildPhase verbosity baseCtx $ \elaboratedPlan -> do
@@ -175,7 +184,7 @@ haddockAction relFlags targetStrings globalFlags = do
       -- When we interpret the targets on the command line, interpret them as
       -- haddock targets
       targets <-
-        either (reportBuildDocumentationTargetProblems verbosity) return $
+        either (reportBuildDocumentationTargetProblems verbosity . map constraintInner) return $
           resolveTargets
             (selectPackageTargets haddockFlags)
             selectComponentTarget

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

@@ -51,6 +51,12 @@ import Distribution.Client.Setup
   , GlobalFlags (..)
   )
 import Distribution.Client.TargetProblem (TargetProblem (..))
+import Distribution.Solver.Types.ConstraintSource
+  ( ConstraintSource (..)
+  )
+import Distribution.Solver.Types.WithConstraintSource
+  ( WithConstraintSource (..)
+  )
 
 import Distribution.Simple.BuildPaths
   ( haddockBenchmarkDirPath
@@ -127,7 +133,7 @@ haddockProjectAction flags _extraArgs globalFlags = do
     RejectNoTargets
     Nothing
     (commandDefaultFlags CmdBuild.buildCommand)
-    ["all"]
+    [WithConstraintSource{constraintInner = "all", constraintSource = ConstraintSourceImplicitTarget}]
     globalFlags
     HaddockCommand
     $ \targetCtx ctx targetSelectors -> do