refactor: Move ConstraintSource back to cabal-install

Braching off the discussion at haskell#9578 (comment)

The solver should not know anything about project configuration as it is
only a cabal-install concept.  The caller should instead be able to add
arbitrary annotation to the global constraints it passes to the solver.

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

@@ -78,7 +78,6 @@ library
     Distribution.Solver.Modular.Version
     Distribution.Solver.Modular.WeightedPSQ
     Distribution.Solver.Types.ComponentDeps
-    Distribution.Solver.Types.ConstraintSource
     Distribution.Solver.Types.DependencyResolver
     Distribution.Solver.Types.Flag
     Distribution.Solver.Types.InstalledPreference

cabal-install-solver/src/Distribution/Solver/Modular.hs

@@ -58,7 +58,7 @@ import Distribution.Verbosity
 
 -- | Ties the two worlds together: classic cabal-install vs. the modular
 -- solver. Performs the necessary translations before and after.
-modularResolver :: SolverConfig -> DependencyResolver loc
+modularResolver :: (Typeable cs, Show cs, Eq cs) => SolverConfig -> DependencyResolver loc cs
 modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns =
   uncurry postprocess <$> -- convert install plan
   solve' sc cinfo idx pkgConfigDB pprefs gcs pns
@@ -113,12 +113,13 @@ modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns
 -- Using the full log from a rerun of the solver ensures that the log is
 -- complete, i.e., it shows the whole chain of dependencies from the user
 -- targets to the conflicting packages.
-solve' :: SolverConfig
+solve' :: (Typeable cs, Eq cs, Show cs)
+       => SolverConfig
        -> CompilerInfo
        -> Index
        -> PkgConfigDb
        -> (PN -> PackagePreferences)
-       -> Map PN [LabeledPackageConstraint]
+       -> Map PN [LabeledPackageConstraint cs]
        -> Set PN
        -> Progress String String (Assignment, RevDepMap)
 solve' sc cinfo idx pkgConfigDB pprefs gcs pns =

cabal-install-solver/src/Distribution/Solver/Modular/IndexConversion.hs

@@ -53,7 +53,7 @@ import Distribution.Solver.Modular.Version
 -- resolving these situations. However, the right thing to do is to
 -- fix the problem there, so for now, shadowing is only activated if
 -- explicitly requested.
-convPIs :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint]
+convPIs :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint cs]
         -> ShadowPkgs -> StrongFlags -> SolveExecutables
         -> SI.InstalledPackageIndex -> CI.PackageIndex (SourcePackage loc)
         -> Index
@@ -153,14 +153,14 @@ convIPId dr comp idx ipid =
 
 -- | Convert a cabal-install source package index to the simpler,
 -- more uniform index format of the solver.
-convSPI' :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint]
+convSPI' :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint cs]
          -> StrongFlags -> SolveExecutables
          -> CI.PackageIndex (SourcePackage loc) -> [(PN, I, PInfo)]
 convSPI' os arch cinfo constraints strfl solveExes =
     L.map (convSP os arch cinfo constraints strfl solveExes) . CI.allPackages
 
 -- | Convert a single source package into the solver-specific format.
-convSP :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint]
+convSP :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint cs]
        -> StrongFlags -> SolveExecutables -> SourcePackage loc -> (PN, I, PInfo)
 convSP os arch cinfo constraints strfl solveExes (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) =
   let i = I pv InRepo
@@ -172,7 +172,7 @@ convSP os arch cinfo constraints strfl solveExes (SourcePackage (PackageIdentifi
 -- want to keep the condition tree, but simplify much of the test.
 
 -- | Convert a generic package description to a solver-specific 'PInfo'.
-convGPD :: OS -> Arch -> CompilerInfo -> [LabeledPackageConstraint]
+convGPD :: OS -> Arch -> CompilerInfo -> [LabeledPackageConstraint cs]
         -> StrongFlags -> SolveExecutables -> PN -> GenericPackageDescription
         -> PInfo
 convGPD os arch cinfo constraints strfl solveExes pn
@@ -249,7 +249,7 @@ convGPD os arch cinfo constraints strfl solveExes pn
 testConditionForComponent :: OS
                           -> Arch
                           -> CompilerInfo
-                          -> [LabeledPackageConstraint]
+                          -> [LabeledPackageConstraint cs]
                           -> (a -> Bool)
                           -> CondTree ConfVar [Dependency] a
                           -> Maybe Bool

cabal-install-solver/src/Distribution/Solver/Modular/Message.hs

@@ -28,7 +28,6 @@ import Distribution.Solver.Modular.Package
 import Distribution.Solver.Modular.Tree
          ( FailReason(..), POption(..), ConflictingDep(..) )
 import Distribution.Solver.Modular.Version
-import Distribution.Solver.Types.ConstraintSource
 import Distribution.Solver.Types.PackagePath
 import Distribution.Solver.Types.Progress
 import Distribution.Types.LibraryName
@@ -311,10 +310,10 @@ showFR _ NotExplicit                      = " (not a user-provided goal nor ment
 showFR _ Shadowed                         = " (shadowed by another installed package with same version)"
 showFR _ (Broken u)                       = " (package is broken, missing dependency " ++ prettyShow u ++ ")"
 showFR _ UnknownPackage                   = " (unknown package)"
-showFR _ (GlobalConstraintVersion vr src) = " (" ++ constraintSource src ++ " requires " ++ prettyShow vr ++ ")"
-showFR _ (GlobalConstraintInstalled src)  = " (" ++ constraintSource src ++ " requires installed instance)"
-showFR _ (GlobalConstraintSource src)     = " (" ++ constraintSource src ++ " requires source instance)"
-showFR _ (GlobalConstraintFlag src)       = " (" ++ constraintSource src ++ " requires opposite flag selection)"
+showFR _ (GlobalConstraintVersion vr src) = " (constraint from " ++ show src ++ " requires " ++ prettyShow vr ++ ")"
+showFR _ (GlobalConstraintInstalled src)  = " (constraint from " ++ show src ++ " requires installed instance)"
+showFR _ (GlobalConstraintSource src)     = " (constraint from " ++ show src ++ " requires source instance)"
+showFR _ (GlobalConstraintFlag src)       = " (constraint from " ++ show src ++ " requires opposite flag selection)"
 showFR _ ManualFlag                       = " (manual flag can only be changed explicitly)"
 showFR c Backjump                         = " (backjumping, conflict set: " ++ showConflictSet c ++ ")"
 showFR _ MultipleInstances                = " (multiple instances)"
@@ -333,9 +332,6 @@ showExposedComponent (ExposedLib LMainLibName)       = "library"
 showExposedComponent (ExposedLib (LSubLibName name)) = "library '" ++ unUnqualComponentName name ++ "'"
 showExposedComponent (ExposedExe name)               = "executable '" ++ unUnqualComponentName name ++ "'"
 
-constraintSource :: ConstraintSource -> String
-constraintSource src = "constraint from " ++ showConstraintSource src
-
 showConflictingDep :: ConflictingDep -> String
 showConflictingDep (ConflictingDep dr (PkgComponent qpn comp) ci) =
   let DependencyReason qpn' _ _ = dr

cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs

@@ -172,10 +172,11 @@ preferPackageStanzaPreferences pcs = go
 -- given instance for a P-node. Translates the constraint into a
 -- tree-transformer that either leaves the subtree untouched, or replaces it
 -- with an appropriate failure node.
-processPackageConstraintP :: forall d c. QPN
+processPackageConstraintP :: forall d c cs. (Eq cs, Show cs, Typeable cs)
+                          => QPN
                           -> ConflictSet
                           -> I
-                          -> LabeledPackageConstraint
+                          -> LabeledPackageConstraint cs
                           -> Tree d c
                           -> Tree d c
 processPackageConstraintP qpn c i (LabeledPackageConstraint (PackageConstraint scope prop) src) r =
@@ -186,24 +187,25 @@ processPackageConstraintP qpn c i (LabeledPackageConstraint (PackageConstraint s
     go :: I -> PackageProperty -> Tree d c
     go (I v _) (PackagePropertyVersion vr)
         | checkVR vr v  = r
-        | otherwise     = Fail c (GlobalConstraintVersion vr src)
+        | otherwise     = Fail c (GlobalConstraintVersion vr (SomeSrc src))
     go _       PackagePropertyInstalled
         | instI i       = r
-        | otherwise     = Fail c (GlobalConstraintInstalled src)
+        | otherwise     = Fail c (GlobalConstraintInstalled (SomeSrc src))
     go _       PackagePropertySource
         | not (instI i) = r
-        | otherwise     = Fail c (GlobalConstraintSource src)
+        | otherwise     = Fail c (GlobalConstraintSource (SomeSrc src))
     go _       _        = r
 
 -- | Helper function that tries to enforce a single package constraint on a
 -- given flag setting for an F-node. Translates the constraint into a
 -- tree-transformer that either leaves the subtree untouched, or replaces it
 -- with an appropriate failure node.
-processPackageConstraintF :: forall d c. QPN
+processPackageConstraintF :: forall d c cs . (Eq cs, Show cs, Typeable cs)
+                          => QPN
                           -> Flag
                           -> ConflictSet
                           -> Bool
-                          -> LabeledPackageConstraint
+                          -> LabeledPackageConstraint cs
                           -> Tree d c
                           -> Tree d c
 processPackageConstraintF qpn f c b' (LabeledPackageConstraint (PackageConstraint scope prop) src) r =
@@ -216,18 +218,19 @@ processPackageConstraintF qpn f c b' (LabeledPackageConstraint (PackageConstrain
         case lookupFlagAssignment f fa of
           Nothing            -> r
           Just b | b == b'   -> r
-                 | otherwise -> Fail c (GlobalConstraintFlag src)
+                 | otherwise -> Fail c (GlobalConstraintFlag (SomeSrc src))
     go _                             = r
 
 -- | Helper function that tries to enforce a single package constraint on a
 -- given flag setting for an F-node. Translates the constraint into a
 -- tree-transformer that either leaves the subtree untouched, or replaces it
 -- with an appropriate failure node.
-processPackageConstraintS :: forall d c. QPN
+processPackageConstraintS :: forall d c cs. (Typeable cs, Eq cs, Show cs)
+                          => QPN
                           -> OptionalStanza
                           -> ConflictSet
                           -> Bool
-                          -> LabeledPackageConstraint
+                          -> LabeledPackageConstraint cs
                           -> Tree d c
                           -> Tree d c
 processPackageConstraintS qpn s c b' (LabeledPackageConstraint (PackageConstraint scope prop) src) r =
@@ -237,14 +240,15 @@ processPackageConstraintS qpn s c b' (LabeledPackageConstraint (PackageConstrain
   where
     go :: PackageProperty -> Tree d c
     go (PackagePropertyStanzas ss) =
-        if not b' && s `elem` ss then Fail c (GlobalConstraintFlag src)
+        if not b' && s `elem` ss then Fail c (GlobalConstraintFlag (SomeSrc src))
                                  else r
     go _                               = r
 
 -- | Traversal that tries to establish various kinds of user constraints. Works
 -- by selectively disabling choices that have been ruled out by global user
 -- constraints.
-enforcePackageConstraints :: M.Map PN [LabeledPackageConstraint]
+enforcePackageConstraints :: (Typeable cs, Eq cs, Show cs)
+                          => M.Map PN [LabeledPackageConstraint cs]
                           -> EndoTreeTrav d c
 enforcePackageConstraints pcs = go
   where
@@ -291,7 +295,7 @@ enforcePackageConstraints pcs = go
 --
 -- This function does not enforce any of the constraints, since that is done by
 -- 'enforcePackageConstraints'.
-enforceManualFlags :: M.Map PN [LabeledPackageConstraint] -> EndoTreeTrav d c
+enforceManualFlags :: M.Map PN [LabeledPackageConstraint cs] -> EndoTreeTrav d c
 enforceManualFlags pcs = go
   where
     go (FChoiceF qfn@(FN (Q _ pn) fn) rdm gr tr Manual d ts) =

cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs

@@ -88,12 +88,13 @@ newtype PruneAfterFirstSuccess = PruneAfterFirstSuccess Bool
 -- has been added relatively recently. Cycles are only removed directly
 -- before exploration.
 --
-solve :: SolverConfig                         -- ^ solver parameters
+solve :: (Eq cs, Show cs, Typeable cs)
+      => SolverConfig                         -- ^ solver parameters
       -> CompilerInfo
       -> Index                                -- ^ all available packages as an index
       -> PkgConfigDb                          -- ^ available pkg-config pkgs
       -> (PN -> PackagePreferences)           -- ^ preferences
-      -> M.Map PN [LabeledPackageConstraint]  -- ^ global constraints
+      -> M.Map PN [LabeledPackageConstraint cs]  -- ^ global constraints
       -> S.Set PN                             -- ^ global goals
       -> RetryLog Message SolverFailure (Assignment, RevDepMap)
 solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals =

cabal-install-solver/src/Distribution/Solver/Modular/Tree.hs

@@ -1,10 +1,13 @@
 {-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}
+{-# LANGUAGE GADTs #-}
+
 module Distribution.Solver.Modular.Tree
     ( POption(..)
     , Tree(..)
     , TreeF(..)
     , Weight
     , FailReason(..)
+    , SomeSrc(..)
     , ConflictingDep(..)
     , ana
     , cata
@@ -21,16 +24,16 @@ module Distribution.Solver.Modular.Tree
 import Control.Monad hiding (mapM, sequence)
 import Data.Foldable
 import Data.Traversable
+import Type.Reflection (Typeable, eqTypeRep, typeOf, (:~~:) (..))
 import Prelude hiding (foldr, mapM, sequence)
 
 import Distribution.Solver.Modular.Dependency
 import Distribution.Solver.Modular.Flag
-import Distribution.Solver.Modular.Package
 import Distribution.Solver.Modular.PSQ (PSQ)
+import Distribution.Solver.Modular.Package
 import Distribution.Solver.Modular.Version
 import Distribution.Solver.Modular.WeightedPSQ (WeightedPSQ)
 import qualified Distribution.Solver.Modular.WeightedPSQ as W
-import Distribution.Solver.Types.ConstraintSource
 import Distribution.Solver.Types.Flag
 import Distribution.Solver.Types.PackagePath
 import Distribution.Types.PkgconfigVersionRange
@@ -115,10 +118,10 @@ data FailReason = UnsupportedExtension Extension
                 | Shadowed
                 | Broken UnitId
                 | UnknownPackage
-                | GlobalConstraintVersion VR ConstraintSource
-                | GlobalConstraintInstalled ConstraintSource
-                | GlobalConstraintSource ConstraintSource
-                | GlobalConstraintFlag ConstraintSource
+                | GlobalConstraintVersion VR SomeSrc
+                | GlobalConstraintInstalled SomeSrc
+                | GlobalConstraintSource SomeSrc
+                | GlobalConstraintFlag SomeSrc
                 | ManualFlag
                 | MalformedFlagChoice QFN
                 | MalformedStanzaChoice QSN
@@ -128,7 +131,18 @@ data FailReason = UnsupportedExtension Extension
                 | DependenciesNotLinked String
                 | CyclicDependencies
                 | UnsupportedSpecVer Ver
-  deriving (Eq, Show)
+                deriving (Eq, Show)
+
+data SomeSrc = forall src. (Typeable src, Eq src, Show src) => SomeSrc src
+
+instance Eq SomeSrc where
+  SomeSrc lhs == SomeSrc rhs =
+    case eqTypeRep (typeOf lhs) (typeOf rhs) of
+      Nothing -> False
+      Just HRefl -> lhs == rhs
+
+instance Show SomeSrc where
+  showsPrec d (SomeSrc lhs) = showsPrec d lhs
 
 -- | Information about a dependency involved in a conflict, for error messages.
 data ConflictingDep = ConflictingDep (DependencyReason QPN) (PkgComponent QPN) CI

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

@@ -26,12 +26,12 @@ import Distribution.System ( Platform )
 -- solving the package dependency problem and we want to make it easy to swap
 -- in alternatives.
 --
-type DependencyResolver loc = Platform
+type DependencyResolver loc cs = Platform
                            -> CompilerInfo
                            -> InstalledPackageIndex
                            -> PackageIndex (SourcePackage loc)
                            -> PkgConfigDb
                            -> (PackageName -> PackagePreferences)
-                           -> [LabeledPackageConstraint]
+                           -> [LabeledPackageConstraint cs]
                            -> Set PackageName
                            -> Progress String String [ResolverPackage loc]

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

@@ -3,12 +3,11 @@ module Distribution.Solver.Types.LabeledPackageConstraint
     , unlabelPackageConstraint
     ) where
 
-import Distribution.Solver.Types.ConstraintSource
 import Distribution.Solver.Types.PackageConstraint
 
 -- | 'PackageConstraint' labeled with its source.
-data LabeledPackageConstraint
-   = LabeledPackageConstraint PackageConstraint ConstraintSource
+data LabeledPackageConstraint cs
+   = LabeledPackageConstraint PackageConstraint cs
 
-unlabelPackageConstraint :: LabeledPackageConstraint -> PackageConstraint
+unlabelPackageConstraint :: LabeledPackageConstraint cs -> PackageConstraint
 unlabelPackageConstraint (LabeledPackageConstraint pc _) = pc