Override imported package version equalities

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

@@ -16,6 +16,7 @@ import Prelude ()
 import Distribution.Solver.Compat.Prelude
 
 import qualified Data.Map as M
+import qualified Data.List as L
 import Data.Set (isSubsetOf)
 import Distribution.Compat.Graph
          ( IsNode(..) )
@@ -66,7 +67,9 @@ modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns
       -- Indices have to be converted into solver-specific uniform index.
       idx    = convPIs os arch cinfo gcs (shadowPkgs sc) (strongFlags sc) (solveExecutables sc) iidx sidx
       -- Constraints have to be converted into a finite map indexed by PN.
-      gcs    = M.fromListWith (++) (map pair pcs)
+      -- Preserve the order of the constraints, countering fromListWith
+      -- reversing the order by using flip (++).
+      gcs    = M.fromListWith (flip (++)) (map pair pcs)
         where
           pair lpc = (pcName $ unlabelPackageConstraint lpc, [lpc])
 
@@ -122,23 +125,33 @@ solve' :: SolverConfig
        -> Set PN
        -> Progress String String (Assignment, RevDepMap)
 solve' sc cinfo idx pkgConfigDB pprefs gcs pns =
-    toProgress $ retry (runSolver printFullLog sc) createErrorMsg
+    toProgress $
+    let gcs' = versionWin (solverVersionWin sc) <$> gcs
+        diff = concat (M.elems gcs) L.\\ concat (M.elems gcs')
+        msg =
+          if null diff then "Overriding doesn't remove any constraints." else
+          "Overriding constraints by "
+          ++ showVersionWin (solverVersionWin sc) ++ " removes these " ++ show (length diff) ++ " constraints:"
+          ++ showGroupedConstraints diff
+    in
+      continueWith msg $
+      retry (runSolver printFullLog gcs' sc) createErrorMsg
   where
-    runSolver :: Bool -> SolverConfig
+    runSolver :: Bool -> Map PN [LabeledPackageConstraint] -> SolverConfig
               -> RetryLog String SolverFailure (Assignment, RevDepMap)
-    runSolver keepLog sc' =
+    runSolver keepLog gcs' sc' =
         displayLogMessages keepLog $
-        solve sc' cinfo idx pkgConfigDB pprefs gcs pns
+        solve sc' cinfo idx pkgConfigDB pprefs gcs' pns
 
     createErrorMsg :: SolverFailure
                    -> RetryLog String String (Assignment, RevDepMap)
     createErrorMsg failure@(ExhaustiveSearch cs cm) =
-      if asBool $ minimizeConflictSet sc
+      if asBool (minimizeConflictSet sc)
       then continueWith ("Found no solution after exhaustively searching the "
                           ++ "dependency tree. Rerunning the dependency solver "
                           ++ "to minimize the conflict set ({"
                           ++ showConflictSet cs ++ "}).") $
-           retry (tryToMinimizeConflictSet (runSolver printFullLog) sc cs cm) $
+           retry (tryToMinimizeConflictSet (runSolver printFullLog gcs) sc cs cm) $
                \case
                   ExhaustiveSearch cs' cm' ->
                       fromProgress $ Fail $
@@ -151,14 +164,16 @@ solve' sc cinfo idx pkgConfigDB pprefs gcs pns =
                        ++ "Original error message:\n"
                        ++ rerunSolverForErrorMsg cs
                        ++ finalErrorMsg sc failure
+
       else fromProgress $ Fail $
            rerunSolverForErrorMsg cs ++ finalErrorMsg sc failure
+
     createErrorMsg failure@BackjumpLimitReached     =
         continueWith
              ("Backjump limit reached. Rerunning dependency solver to generate "
               ++ "a final conflict set for the search tree containing the "
               ++ "first backjump.") $
-        retry (runSolver printFullLog sc { pruneAfterFirstSuccess = PruneAfterFirstSuccess True }) $
+        retry (runSolver printFullLog gcs sc { pruneAfterFirstSuccess = PruneAfterFirstSuccess True }) $
             \case
                ExhaustiveSearch cs _ ->
                    fromProgress $ Fail $
@@ -181,7 +196,7 @@ solve' sc cinfo idx pkgConfigDB pprefs gcs pns =
           -- original goal order.
           goalOrder' = preferGoalsFromConflictSet cs <> fromMaybe mempty (goalOrder sc)
 
-      in unlines ("Could not resolve dependencies:" : messages (toProgress (runSolver True sc')))
+      in unlines ("Could not resolve dependencies:" : messages (toProgress (runSolver True gcs sc')))
 
     printFullLog = solverVerbosity sc >= verbose
 

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

@@ -67,6 +67,7 @@ data SolverConfig = SolverConfig {
   shadowPkgs             :: ShadowPkgs,
   strongFlags            :: StrongFlags,
   onlyConstrained        :: OnlyConstrained,
+  solverVersionWin       :: VersionWin,
   maxBackjumps           :: Maybe Int,
   enableBackjumping      :: EnableBackjumping,
   solveExecutables       :: SolveExecutables,

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

@@ -1,20 +1,34 @@
 {-# LANGUAGE DeriveGeneric #-}
 module Distribution.Solver.Types.ConstraintSource
     ( ConstraintSource(..)
+    , ProjectConfigImport(..)
     , showConstraintSource
     ) where
 
 import Distribution.Solver.Compat.Prelude
 import Prelude ()
 
+data ProjectConfigImport =
+  ProjectConfigImport
+    { importDepth :: Int
+    -- ^ Depth of the import. The main project config file has depth 0, and each
+    -- import increases the depth by 1.
+    , importPath :: FilePath
+    -- ^ Path to the imported file contributing to the project config.
+    }
+    deriving (Eq, Show, Generic)
+
+instance Binary ProjectConfigImport
+instance Structured ProjectConfigImport
+
 -- | Source of a 'PackageConstraint'.
 data ConstraintSource =
 
   -- | Main config file, which is ~/.cabal/config by default.
   ConstraintSourceMainConfig FilePath
 
   -- | Local cabal.project file
-  | ConstraintSourceProjectConfig FilePath
+  | ConstraintSourceProjectConfig ProjectConfigImport
 
   -- | User config file, which is ./cabal.config by default.
   | ConstraintSourceUserConfig FilePath
@@ -59,8 +73,8 @@ instance Structured ConstraintSource
 showConstraintSource :: ConstraintSource -> String
 showConstraintSource (ConstraintSourceMainConfig path) =
     "main config " ++ path
-showConstraintSource (ConstraintSourceProjectConfig path) =
-    "project config " ++ path
+showConstraintSource (ConstraintSourceProjectConfig projectConfig) =
+    "project config " ++ show projectConfig
 showConstraintSource (ConstraintSourceUserConfig path)= "user config " ++ path
 showConstraintSource ConstraintSourceCommandlineFlag = "command line flag"
 showConstraintSource ConstraintSourceUserTarget = "user target"

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

@@ -1,14 +1,185 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE ViewPatterns #-}
+
 module Distribution.Solver.Types.LabeledPackageConstraint
     ( LabeledPackageConstraint(..)
+    , VersionWin (..)
     , unlabelPackageConstraint
+    , versionWin
+    , showVersionWin
+    , showGroupedConstraints
+    , showLabeledConstraint
+    , showLabeledConstraints
     ) where
 
+import Distribution.Compat.Prelude
+import Prelude ()
 import Distribution.Solver.Types.ConstraintSource
 import Distribution.Solver.Types.PackageConstraint
+import Distribution.Pretty ( Pretty(pretty) )
+import Distribution.Parsec ( Parsec(parsec) )
+
+import qualified Distribution.Compat.CharParsing as P
+import qualified Text.PrettyPrint as PP
+import Distribution.Types.VersionRange
+import qualified Data.Map.Strict as Map
+import qualified Data.List as L (elemIndex, groupBy)
+
+data VersionWin = ShallowWins | LastWins deriving (Eq, Generic)
+
+instance Binary VersionWin
+instance Structured VersionWin
+
+instance Show VersionWin where
+    show = showVersionWin
+
+versionWin :: VersionWin -> [LabeledPackageConstraint] -> [LabeledPackageConstraint]
+versionWin ShallowWins = shallowConstraintsWin
+versionWin LastWins = laterConstraintsWin
+
+showVersionWin :: VersionWin -> String
+showVersionWin ShallowWins = "shallow wins"
+showVersionWin LastWins = "last wins"
+
+instance Pretty VersionWin where
+  pretty ShallowWins  = PP.text "shallowest"
+  pretty LastWins = PP.text "latest"
+
+instance Parsec VersionWin where
+  parsec = P.choice
+    [ P.string "latest"  >> return LastWins
+    , P.string "shallowest" >> return ShallowWins
+    ]
 
 -- | 'PackageConstraint' labeled with its source.
 data LabeledPackageConstraint
    = LabeledPackageConstraint PackageConstraint ConstraintSource
+   deriving Eq
 
 unlabelPackageConstraint :: LabeledPackageConstraint -> PackageConstraint
 unlabelPackageConstraint (LabeledPackageConstraint pc _) = pc
+
+unscopePackageConstraint :: PackageConstraint -> ConstraintScope
+unscopePackageConstraint (PackageConstraint scope _) = scope
+
+showLabeledConstraint :: LabeledPackageConstraint -> String
+showLabeledConstraint (LabeledPackageConstraint pc src) =
+    showPackageConstraint pc ++ " (" ++ showConstraintSource src ++ ")"
+
+showLabeledConstraints :: [LabeledPackageConstraint] -> String
+showLabeledConstraints = concatMap (("\n  " ++) . showLabeledConstraint)
+
+showGroupedConstraints :: [LabeledPackageConstraint] -> String
+showGroupedConstraints xs = concat
+    [ concatMap (("\n  " ++) . showLabeledConstraint) vs
+    | (_, vs) <- groupConstraints xs
+    ]
+
+groupConstraints :: [LabeledPackageConstraint] -> [(String, [LabeledPackageConstraint])]
+groupConstraints xs =
+    let toKeyValues :: [(String, LabeledPackageConstraint)] -> (String, [LabeledPackageConstraint])
+        toKeyValues kvs = (case kvs of (s, _) : _ -> (s,); [] -> ("",)) $ snd <$> kvs
+    in
+        toKeyValues <$> L.groupBy (\x y -> EQ == (comparing fst) x y)
+            [ (show . unscopePackageConstraint $ unlabelPackageConstraint x, x)
+            | x <- xs
+            ]
+
+-- | Later constraints win over earlier constraints. Preserves the original
+-- order of the input constraints in the output constraints.
+laterConstraintsWin :: [LabeledPackageConstraint] -> [LabeledPackageConstraint]
+laterConstraintsWin [] = []
+laterConstraintsWin lpcs@[_] = lpcs
+laterConstraintsWin lpcsIn =
+    let keepers =
+            (\(xs, (us, ys)) -> weedByOrder (weedByUser us xs) ++ us ++ ys)
+            . fmap (partition isUserVersionEquality)
+            $ partition (\c -> isProjectVersionInstalled c || isProjectVersionEquality c) lpcsIn
+
+    in snd <$> sortBy (comparing fst) [(fromMaybe (negate 1) (L.elemIndex k lpcsIn), k) | k <- keepers]
+
+-- | Weed out potential package version conflicts for each package by picking
+-- any user targets to win if they exist. Otherwise pick version equality
+-- constraints with the lowest import depth to win. Discard the rest of the
+-- version equality and installed constraints.  Constraints for flags and
+-- stanzas are untouched by this weeding.
+-- 
+-- Flags that may have applied to weeded versions of a package may be orphaned.
+shallowConstraintsWin :: [LabeledPackageConstraint] -> [LabeledPackageConstraint]
+shallowConstraintsWin =
+    (\(xs, (us, ys)) ->
+        let xsGrouped = groupConstraints xs
+            xsWeeded = (weedByDepth . weedByUser us . sortByImportDepth) <$> Map.fromList xsGrouped
+        in concat (Map.elems xsWeeded) ++ us ++ ys
+    )
+    . fmap (partition isUserVersionEquality)
+    . partition (\c -> isProjectVersionInstalled c || isProjectVersionEquality c)
+
+isUserVersionEquality :: LabeledPackageConstraint -> Bool
+isUserVersionEquality (LabeledPackageConstraint constraint source)
+    | ConstraintSourceUserTarget{} <- source
+    , PackageConstraint _ (PackagePropertyVersion versionRange) <- constraint
+    , ThisVersionF _ <- projectVersionRange versionRange = True
+    | otherwise = False
+
+isProjectVersionEquality :: LabeledPackageConstraint -> Bool
+isProjectVersionEquality (LabeledPackageConstraint constraint source)
+    | ConstraintSourceProjectConfig{} <- source
+    , PackageConstraint _ (PackagePropertyVersion versionRange) <- constraint
+    , ThisVersionF _ <- projectVersionRange versionRange = True
+    | otherwise = False
+
+isProjectVersionInstalled :: LabeledPackageConstraint -> Bool
+isProjectVersionInstalled (LabeledPackageConstraint constraint source)
+    | ConstraintSourceProjectConfig{} <- source
+    , PackageConstraint _ PackagePropertyInstalled <- constraint = True
+    | otherwise = False
+
+-- | Sort by import depth, ascending.
+sortByImportDepth :: [LabeledPackageConstraint] -> [LabeledPackageConstraint]
+sortByImportDepth = sortBy (comparing (\(LabeledPackageConstraint _ src) -> case src of
+    ConstraintSourceProjectConfig pci -> importDepth pci
+    _ -> maxBound))
+
+-- | Weed out any conflicts by picking user constraints over project
+-- constraints.
+weedByUser :: [LabeledPackageConstraint] -> [LabeledPackageConstraint] -> [LabeledPackageConstraint]
+weedByUser us xs = case us of
+    [] -> xs
+    (toName -> uName) : us' -> weedByUser us' $ filter (\x -> uName /= toName x) xs
+    where
+        toName = scopeToPackageName . unscopePackageConstraint . unlabelPackageConstraint
+
+-- | Weed out any conflicts by picking project constraints with the lowest
+-- import depth, assuming the input is sorted by import depth.
+weedByDepth :: [LabeledPackageConstraint] -> [LabeledPackageConstraint]
+weedByDepth xs = case xs of
+    [] -> []
+    (LabeledPackageConstraint _ srcX) : _ -> case srcX of
+        ConstraintSourceProjectConfig ProjectConfigImport{importDepth = dX} ->
+            filter
+                (\(LabeledPackageConstraint _ srcY) -> case srcY of
+                    ConstraintSourceProjectConfig ProjectConfigImport{importDepth = dY} ->
+                        dX == dY
+                    _ -> False)
+                xs
+        _ -> xs
+
+-- | Weed out any conflicts by picking the last project constraints, assuming
+-- the input list is in definition order.
+weedByOrder :: [LabeledPackageConstraint] -> [LabeledPackageConstraint]
+weedByOrder [] = []
+weedByOrder xs@[_] = xs
+weedByOrder (reverse -> xs) = reverse $ go (nub $ toName <$> xs) xs where
+    toName = scopeToPackageName . unscopePackageConstraint . unlabelPackageConstraint
+
+    go [] ys = ys
+    go (n : ns) ys =
+        let sameNames = filter ((== n) . toName) ys
+            winner = take 1 sameNames
+        in
+            go ns (winner ++ filter ((/= n) . toName) ys)

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

@@ -423,6 +423,7 @@ instance Semigroup SavedConfig where
           , installStrongFlags = combine installStrongFlags
           , installAllowBootLibInstalls = combine installAllowBootLibInstalls
           , installOnlyConstrained = combine installOnlyConstrained
+          , installVersionWin = combine installVersionWin
           , installReinstall = combine installReinstall
           , installAvoidReinstalls = combine installAvoidReinstalls
           , installOverrideReinstall = combine installOverrideReinstall