Reject unconstrained dependency = none|all|eq

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

@@ -56,6 +56,7 @@ import Distribution.Types.UnqualComponentName
     ( unUnqualComponentName )
 
 import Text.PrettyPrint ( nest, render )
+import Distribution.Solver.Types.Settings (OnlyConstrained(..))
 
 -- A data type to hold log information from the modular solver.
 data Message =
@@ -311,7 +312,7 @@ showFR _ (PackageRequiresMissingComponent qpn comp) = " (requires " ++ showExpos
 showFR _ (PackageRequiresPrivateComponent qpn comp) = " (requires " ++ showExposedComponent comp ++ " from " ++ showQPN qpn ++ ", but the component is private)"
 showFR _ (PackageRequiresUnbuildableComponent qpn comp) = " (requires " ++ showExposedComponent comp ++ " from " ++ showQPN qpn ++ ", but the component is not buildable in the current environment)"
 showFR _ CannotReinstall                  = " (avoiding to reinstall a package with same version but new dependencies)"
-showFR _ NotExplicit                      = " (not a user-provided goal nor mentioned as a constraint, but reject-unconstrained-dependencies was set)"
+showFR _ (NotExplicit oc)                 = showNotExplicit oc
 showFR _ Shadowed                         = " (shadowed by another installed package with same version)"
 showFR _ (Broken u)                       = " (package is broken, missing dependency " ++ prettyShow u ++ ")"
 showFR _ UnknownPackage                   = " (unknown package)"
@@ -334,6 +335,11 @@ showFR _ (MalformedFlagChoice qfn)        = " (INTERNAL ERROR: MALFORMED FLAG CH
 showFR _ (MalformedStanzaChoice qsn)      = " (INTERNAL ERROR: MALFORMED STANZA CHOICE: " ++ showQSN qsn ++ ")"
 showFR _ EmptyGoalChoice                  = " (INTERNAL ERROR: EMPTY GOAL CHOICE)"
 
+showNotExplicit :: OnlyConstrained -> String
+showNotExplicit oc = if oc == OnlyConstrainedNone
+  then " (INTERNAL ERROR: NOT EXPLICIT when reject-unconstrained-dependencies=" ++ prettyShow oc ++ " was set)"
+  else " (not a user-provided goal nor mentioned as a constraint, but reject-unconstrained-dependencies=" ++ prettyShow oc ++ " was set)"
+
 showExposedComponent :: ExposedComponent -> String
 showExposedComponent (ExposedLib LMainLibName)       = "library"
 showExposedComponent (ExposedLib (LSubLibName name)) = "library '" ++ unUnqualComponentName name ++ "'"

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

@@ -43,6 +43,7 @@ import Distribution.Solver.Modular.Tree
 import Distribution.Solver.Modular.Version
 import qualified Distribution.Solver.Modular.ConflictSet as CS
 import qualified Distribution.Solver.Modular.WeightedPSQ as W
+import Distribution.Solver.Types.Settings (OnlyConstrained(..))
 
 -- | Update the weights of children under 'PChoice' nodes. 'addWeights' takes a
 -- list of weight-calculating functions in order to avoid sorting the package
@@ -351,13 +352,13 @@ avoidReinstalls p = go
     go x          = x
 
 -- | Require all packages to be mentioned in a constraint or as a goal.
-onlyConstrained :: (PN -> Bool) -> EndoTreeTrav d QGoalReason
-onlyConstrained p = go
+onlyConstrained :: OnlyConstrained -> (PN -> Bool) -> EndoTreeTrav d QGoalReason
+onlyConstrained oc p = go
   where
     go (PChoiceF v@(Q _ pn) _ gr _) | not (p pn)
       = FailF
         (varToConflictSet (P v) `CS.union` goalReasonToConflictSetWithConflict v gr)
-        NotExplicit
+        (NotExplicit oc)
     go x
       = x
 

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

@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
 #ifdef DEBUG_TRACETREE
 {-# LANGUAGE FlexibleInstances #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
@@ -11,6 +12,7 @@ module Distribution.Solver.Modular.Solver
 
 import Distribution.Solver.Compat.Prelude
 import Prelude ()
+import Data.Function ((&))
 
 import qualified Data.Map as M
 import qualified Data.List as L
@@ -19,10 +21,12 @@ import Distribution.Verbosity
 
 import Distribution.Compiler (CompilerInfo)
 
+import Distribution.Version
 import Distribution.Solver.Types.PackagePath
 import Distribution.Solver.Types.PackagePreferences
 import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb)
 import Distribution.Solver.Types.LabeledPackageConstraint
+import Distribution.Solver.Types.PackageConstraint (PackageConstraint(..), PackageProperty(..))
 import Distribution.Solver.Types.Settings
 import Distribution.Solver.Types.Variable
 
@@ -139,18 +143,15 @@ solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals =
                        validateLinking idx .
                        validateTree cinfo idx pkgConfigDB
     prunePhase       = (if asBool (avoidReinstalls sc) then P.avoidReinstalls (const True) else id) .
-                       (case onlyConstrained sc of
-                          OnlyConstrainedAll ->
-                            P.onlyConstrained pkgIsExplicit
-                          OnlyConstrainedNone ->
-                            id)
+                       (let oc = onlyConstrained sc in oc & \case
+                          OnlyConstrainedEq -> P.onlyConstrained oc (`S.member` allExplicitEq)
+                          OnlyConstrainedAll -> P.onlyConstrained oc (`S.member` allExplicit)
+                          OnlyConstrainedNone -> id)
     buildPhase       = buildTree idx (independentGoals sc) (S.toList userGoals)
 
+    allExplicitEq = M.keysSet (filterThisVersion userConstraints) `S.union` userGoals
     allExplicit = M.keysSet userConstraints `S.union` userGoals
 
-    pkgIsExplicit :: PN -> Bool
-    pkgIsExplicit pn = S.member pn allExplicit
-
     -- When --reorder-goals is set, we use preferReallyEasyGoalChoices, which
     -- prefers (keeps) goals only if the have 0 or 1 enabled choice.
     --
@@ -167,6 +168,15 @@ solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals =
       | asBool (reorderGoals sc) = P.preferReallyEasyGoalChoices
       | otherwise                = id {- P.firstGoal -}
 
+-- | Keep version ranges that normalise to equality version constraints (== v).
+filterThisVersion :: M.Map PN [LabeledPackageConstraint] -> M.Map PN [LabeledPackageConstraint]
+filterThisVersion = M.filter (not . null) . M.map (filter isThisVersion) where
+  normalise = fromVersionIntervals . toVersionIntervals
+  isThisVersion lpc
+    | LabeledPackageConstraint (PackageConstraint _ (PackagePropertyVersion vr)) _ <- lpc
+    , ThisVersionF _ <- projectVersionRange $ normalise vr = True
+    | otherwise = False
+
 -- | Dump solver tree to a file (in debugging mode)
 --
 -- This only does something if the @debug-tracetree@ configure argument was

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

@@ -36,6 +36,7 @@ import Distribution.Solver.Types.PackagePath
 import Distribution.Types.PkgconfigVersionRange
 import Distribution.Types.UnitId (UnitId)
 import Language.Haskell.Extension (Extension, Language)
+import Distribution.Solver.Types.Settings (OnlyConstrained(..))
 
 type Weight = Double
 
@@ -112,7 +113,7 @@ data FailReason = UnsupportedExtension Extension
                 | PackageRequiresPrivateComponent QPN ExposedComponent
                 | PackageRequiresUnbuildableComponent QPN ExposedComponent
                 | CannotReinstall
-                | NotExplicit
+                | NotExplicit OnlyConstrained
                 | Shadowed
                 | Broken UnitId
                 | UnknownPackage

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

@@ -61,6 +61,7 @@ newtype AllowBootLibInstalls = AllowBootLibInstalls Bool
 data OnlyConstrained
   = OnlyConstrainedNone
   | OnlyConstrainedAll
+  | OnlyConstrainedEq
   deriving (Eq, Generic, Show)
 
 newtype EnableBackjumping = EnableBackjumping Bool
@@ -108,12 +109,14 @@ instance NFData AllowBootLibInstalls
 instance NFData OnlyConstrained
 
 instance Pretty OnlyConstrained where
+  pretty OnlyConstrainedEq  = PP.text "eq"
   pretty OnlyConstrainedAll  = PP.text "all"
   pretty OnlyConstrainedNone = PP.text "none"
 
 instance Parsec OnlyConstrained where
   parsec = P.choice
-    [ P.string "all"  >> return OnlyConstrainedAll
+    [ P.string "eq"  >> return OnlyConstrainedEq
+    , P.string "all"  >> return OnlyConstrainedAll
     , P.string "none" >> return OnlyConstrainedNone
     ]
 

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

@@ -3736,9 +3736,9 @@ optionSolverFlags
         getoc
         setoc
         ( reqArg
-            "none|all"
+            "none|all|eq"
             ( parsecToReadE
-                (const "reject-unconstrained-dependencies must be 'none' or 'all'")
+                (const "reject-unconstrained-dependencies must be 'none', 'all', or 'eq'")
                 (toFlag `fmap` parsec)
             )
             (flagToList . fmap prettyShow)

cabal-install/tests/UnitTests/Distribution/Solver/Modular/DSL/TestCaseUtils.hs

@@ -2,7 +2,7 @@
 
 -- | Utilities for creating HUnit test cases with the solver DSL.
 module UnitTests.Distribution.Solver.Modular.DSL.TestCaseUtils
-  ( SolverTest
+  ( SolverTest (..)
   , SolverResult (..)
   , maxBackjumps
   , disableFineGrainedConflicts
@@ -80,9 +80,9 @@ allowBootLibInstalls :: SolverTest -> SolverTest
 allowBootLibInstalls test =
   test{testAllowBootLibInstalls = AllowBootLibInstalls True}
 
-onlyConstrained :: SolverTest -> SolverTest
-onlyConstrained test =
-  test{testOnlyConstrained = OnlyConstrainedAll}
+onlyConstrained :: OnlyConstrained -> SolverTest -> SolverTest
+onlyConstrained oc test =
+  test{testOnlyConstrained = oc}
 
 disableBackjumping :: SolverTest -> SolverTest
 disableBackjumping test =