[WIP] 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

@@ -6,7 +6,8 @@ module Distribution.Solver.Types.ConstraintSource
 
 import Distribution.Solver.Compat.Prelude
 import Distribution.Solver.Types.ProjectConfigPath (ProjectConfigPath, docProjectConfigPath)
-import Text.PrettyPrint (render)
+import Distribution.Pretty (Pretty(pretty), prettyShow)
+import Text.PrettyPrint (text)
 
 -- | Source of a 'PackageConstraint'.
 data ConstraintSource =
@@ -55,31 +56,40 @@ 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 (Eq, Show, Generic)
+
+  -- | An implicit constraint added by Cabal.
+  | ConstraintSourceImplicit
+  deriving (Show, Eq, Ord, Generic, Typeable)
 
 instance Binary ConstraintSource
 instance Structured ConstraintSource
 
 -- | Description of a 'ConstraintSource'.
 showConstraintSource :: ConstraintSource -> String
-showConstraintSource (ConstraintSourceMainConfig path) =
-    "main config " ++ path
-showConstraintSource (ConstraintSourceProjectConfig path) =
-    "project config " ++ render (docProjectConfigPath path)
-showConstraintSource (ConstraintSourceUserConfig path)= "user config " ++ path
-showConstraintSource ConstraintSourceCommandlineFlag = "command line flag"
-showConstraintSource ConstraintSourceUserTarget = "user target"
-showConstraintSource ConstraintSourceNonReinstallablePackage =
-    "non-reinstallable package"
-showConstraintSource ConstraintSourceFreeze = "cabal freeze"
-showConstraintSource ConstraintSourceConfigFlagOrTarget =
-    "config file, command line flag, or user target"
-showConstraintSource ConstraintSourceMultiRepl =
-    "--enable-multi-repl"
-showConstraintSource ConstraintSourceProfiledDynamic =
-    "--enable-profiling-shared"
-showConstraintSource ConstraintSourceUnknown = "unknown source"
-showConstraintSource ConstraintSetupCabalMinVersion =
-    "minimum version of Cabal used by Setup.hs"
-showConstraintSource ConstraintSetupCabalMaxVersion =
-    "maximum version of Cabal used by Setup.hs"
+showConstraintSource = prettyShow
+
+instance Pretty ConstraintSource where
+  pretty constraintSource = case constraintSource of
+    (ConstraintSourceMainConfig path) ->
+      text "main config" <+> text path
+    (ConstraintSourceProjectConfig path) ->
+      text "project config" <+> docProjectConfigPath path
+    (ConstraintSourceUserConfig path)-> text "user config " <+> text path
+    ConstraintSourceCommandlineFlag -> text "command line flag"
+    ConstraintSourceUserTarget -> text "user target"
+    ConstraintSourceNonReinstallablePackage ->
+      text "non-reinstallable package"
+    ConstraintSourceFreeze -> text "cabal freeze"
+    ConstraintSourceConfigFlagOrTarget ->
+      text "config file, command line flag, or user target"
+    ConstraintSourceMultiRepl ->
+      text "--enable-multi-repl"
+    ConstraintSourceProfiledDynamic ->
+      text "--enable-profiling-shared"
+    ConstraintSourceUnknown -> text "unknown source"
+    ConstraintSetupCabalMinVersion ->
+      text "minimum version of Cabal used by Setup.hs"
+    ConstraintSetupCabalMaxVersion ->
+      text "maximum version of Cabal used by Setup.hs"
+    ConstraintSourceImplicit ->
+      text "implicit target"

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

@@ -0,0 +1,30 @@
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveFunctor #-}
+
+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, Typeable)
+
+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

@@ -11,9 +11,7 @@ module Distribution.Solver.Types.PackageConstraint (
     scopeToPackageName,
     constraintScopeMatches,
     PackageProperty(..),
-    dispPackageProperty,
     PackageConstraint(..),
-    dispPackageConstraint,
     showPackageConstraint,
     packageConstraintToDependency
   ) where
@@ -23,7 +21,7 @@ import Prelude ()
 
 import Distribution.Package                        (PackageName)
 import Distribution.PackageDescription             (FlagAssignment, dispFlagAssignment)
-import Distribution.Pretty                         (flatStyle, pretty)
+import Distribution.Pretty                         (flatStyle, Pretty(pretty))
 import Distribution.Types.PackageVersionConstraint (PackageVersionConstraint (..))
 import Distribution.Version                        (VersionRange, simplifyVersionRange)
 
@@ -82,12 +80,11 @@ constraintScopeMatches (ScopeAnySetupQualifier pn) (Q pp pn') =
   in setup pp && pn == pn'
 constraintScopeMatches (ScopeAnyQualifier pn) (Q _ pn') = pn == pn'
 
--- | Pretty-prints a constraint scope.
-dispConstraintScope :: ConstraintScope -> Disp.Doc
-dispConstraintScope (ScopeTarget pn) = pretty pn <<>> Disp.text "." <<>> pretty pn
-dispConstraintScope (ScopeQualified q pn) = dispQualifier q <<>> pretty pn
-dispConstraintScope (ScopeAnySetupQualifier pn) = Disp.text "setup." <<>> pretty pn
-dispConstraintScope (ScopeAnyQualifier pn) = Disp.text "any." <<>> pretty pn
+instance Pretty ConstraintScope where
+  pretty (ScopeTarget pn) = pretty pn <<>> Disp.text "." <<>> pretty pn
+  pretty (ScopeQualified q pn) = dispQualifier q <<>> pretty pn
+  pretty (ScopeAnySetupQualifier pn) = Disp.text "setup." <<>> pretty pn
+  pretty (ScopeAnyQualifier pn) = Disp.text "any." <<>> pretty pn
 
 -- | A package property is a logical predicate on packages.
 data PackageProperty
@@ -96,37 +93,35 @@ data PackageProperty
    | PackagePropertySource
    | PackagePropertyFlags     FlagAssignment
    | PackagePropertyStanzas   [OptionalStanza]
-  deriving (Eq, Show, Generic)
+  deriving (Eq, Ord, Show, Generic)
 
 instance Binary PackageProperty
 instance Structured PackageProperty
 
--- | Pretty-prints a package property.
-dispPackageProperty :: PackageProperty -> Disp.Doc
-dispPackageProperty (PackagePropertyVersion verrange) = pretty verrange
-dispPackageProperty PackagePropertyInstalled          = Disp.text "installed"
-dispPackageProperty PackagePropertySource             = Disp.text "source"
-dispPackageProperty (PackagePropertyFlags flags)      = dispFlagAssignment flags
-dispPackageProperty (PackagePropertyStanzas stanzas)  =
-  Disp.hsep $ map (Disp.text . showStanza) stanzas
+instance Pretty PackageProperty where
+  pretty (PackagePropertyVersion verrange) = pretty verrange
+  pretty PackagePropertyInstalled          = Disp.text "installed"
+  pretty PackagePropertySource             = Disp.text "source"
+  pretty (PackagePropertyFlags flags)      = dispFlagAssignment flags
+  pretty (PackagePropertyStanzas stanzas)  =
+    Disp.hsep $ map (Disp.text . showStanza) stanzas
 
 -- | A package constraint consists of a scope plus a property
 -- that must hold for all packages within that scope.
 data PackageConstraint = PackageConstraint ConstraintScope PackageProperty
   deriving (Eq, Show)
 
--- | Pretty-prints a package constraint.
-dispPackageConstraint :: PackageConstraint -> Disp.Doc
-dispPackageConstraint (PackageConstraint scope prop) =
-  dispConstraintScope scope <+> dispPackageProperty prop
+instance Pretty PackageConstraint where
+  pretty (PackageConstraint scope prop) =
+    pretty scope <+> pretty prop
 
 -- | Alternative textual representation of a package constraint
 -- for debugging purposes (slightly more verbose than that
 -- produced by 'dispPackageConstraint').
 --
 showPackageConstraint :: PackageConstraint -> String
 showPackageConstraint pc@(PackageConstraint scope prop) =
-  Disp.renderStyle flatStyle . postprocess $ dispPackageConstraint pc2
+  Disp.renderStyle flatStyle . postprocess $ pretty pc2
   where
     pc2 = case prop of
       PackagePropertyVersion vr ->

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

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

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

@@ -0,0 +1,50 @@
+{-# LANGUAGE DeriveFoldable #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# 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
+    { constraintPackage :: pkg
+      -- ^ The package.
+    , constraintConstraint :: ConstraintSource
+      -- ^ The constraint source for the package.
+    }
+  deriving (Show, Functor, Eq, Ord, Traversable, Foldable, Generic, Typeable)
+
+instance Binary pkg => Binary (WithConstraintSource pkg)
+instance Structured pkg => Structured (WithConstraintSource pkg)
+
+withUnknownConstraint :: pkg -> WithConstraintSource pkg
+withUnknownConstraint constraintPackage =
+  WithConstraintSource
+    { constraintPackage
+    , constraintConstraint = ConstraintSourceUnknown
+    }
+
+showWithConstraintSource :: (pkg -> String) -> WithConstraintSource pkg -> String
+showWithConstraintSource
+  showPackage
+  (WithConstraintSource { constraintPackage, constraintConstraint }) =
+    showPackage constraintPackage ++ " (" ++ showConstraintSource constraintConstraint ++ ")"
+
+instance Pretty pkg => Pretty (WithConstraintSource pkg) where
+  pretty (WithConstraintSource { constraintPackage, constraintConstraint = ConstraintSourceUnknown })
+    = pretty constraintPackage
+  pretty (WithConstraintSource { constraintPackage, constraintConstraint })
+    = pretty constraintPackage
+      <+> parens (text "from" <+> pretty constraintConstraint)

cabal-install/cabal-install.cabal

@@ -244,6 +244,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,
@@ -393,6 +394,9 @@ test-suite integration-tests2
   hs-source-dirs: tests
   default-language: Haskell2010
 
+  other-modules:
+    IntegrationTests2.CPP
+
   build-depends:
         bytestring,
         cabal-install,

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
+                { constraintPackage =
+                  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 constraintPackage) return
+      =<< readTargetSelectors
+        (localPackages baseCtx)
+        (Just BenchKind)
+        (map (\target -> WithConstraintSource{constraintPackage = target, constraintConstraint = ConstraintSourceCommandlineFlag}) 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 constraintPackage) 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 (map (\target -> WithConstraintSource{constraintPackage = target, constraintConstraint = ConstraintSourceCommandlineFlag}) targetStrings) 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 constraintPackage) return $
             resolveTargets
               selectPackageTargets
               selectComponentTarget