cabal-install-solver 3.10.3.0 → 3.12.1.0

raw patch · 15 files changed

+385/−188 lines, 15 filesdep +directorydep +network-uridep ~Cabaldep ~Cabal-syntaxdep ~basenew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: directory, network-uri

Dependency ranges changed: Cabal, Cabal-syntax, base, tasty-quickcheck

API changes (from Hackage documentation)

Files

• ChangeLog.md +1/−1
• LICENSE +1/−1
• cabal-install-solver.cabal +11/−16
• src/Distribution/Solver/Modular.hs +2/−2
• src/Distribution/Solver/Modular/ConflictSet.hs +10/−89
• src/Distribution/Solver/Modular/Linking.hs +3/−3
• src/Distribution/Solver/Modular/Message.hs +94/−21
• src/Distribution/Solver/Modular/Preference.hs +0/−13
• src/Distribution/Solver/Modular/Solver.hs +0/−21
• src/Distribution/Solver/Modular/Tree.hs +0/−1
• src/Distribution/Solver/Modular/Validate.hs +1/−13
• src/Distribution/Solver/Types/ComponentDeps.hs +5/−0
• src/Distribution/Solver/Types/ConstraintSource.hs +13/−6
• src/Distribution/Solver/Types/PkgConfigDb.hs +1/−1
• src/Distribution/Solver/Types/ProjectConfigPath.hs +243/−0

@@ -1,1 +1,1 @@-Please see https://github.com/haskell/cabal/blob/master/release-notes/cabal-install-3.10.3.0.md+Please see https://github.com/haskell/cabal/blob/master/release-notes/cabal-install-3.12.1.0.md

@@ -1,4 +1,4 @@-Copyright (c) 2003-2023, Cabal Development Team.+Copyright (c) 2003-2024, Cabal Development Team. See the AUTHORS file for the full list of copyright holders.  See */LICENSE for the copyright holders of the subcomponents.

@@ -1,6 +1,6 @@ cabal-version: 2.2 name:          cabal-install-solver-version:       3.10.3.0+version:       3.12.1.0 synopsis:      The command-line interface for Cabal and Hackage. description:   The solver component used in cabal-install command-line program@@ -11,7 +11,7 @@ license-file:  LICENSE author:        Cabal Development Team (see AUTHORS file) maintainer:    Cabal Development Team <cabal-devel@haskell.org>-copyright:     2003-2023, Cabal Development Team+copyright:     2003-2024, Cabal Development Team category:      Distribution build-type:    Simple extra-doc-files:@@ -27,11 +27,6 @@   default:     False   manual:      True -flag debug-conflict-sets-  description: Add additional information to ConflictSets-  default:     False-  manual:      True- flag debug-tracetree   description: Compile in support for tracetree (used to debug the solver)   default:     False@@ -47,6 +42,7 @@    if impl(ghc <8.8)     ghc-options: -Wnoncanonical-monadfail-instances+   if impl(ghc >=8.10)     ghc-options: -Wunused-packages @@ -96,6 +92,7 @@     Distribution.Solver.Types.PackagePreferences     Distribution.Solver.Types.PkgConfigDb     Distribution.Solver.Types.Progress+    Distribution.Solver.Types.ProjectConfigPath     Distribution.Solver.Types.ResolverPackage     Distribution.Solver.Types.Settings     Distribution.Solver.Types.SolverId@@ -105,14 +102,16 @@    build-depends:     , array         >=0.4      && <0.6-    , base          >=4.10     && <4.20+    , base          >=4.11     && <4.21     , bytestring    >=0.10.6.0 && <0.13-    , Cabal         ^>=3.10-    , Cabal-syntax  ^>=3.10+    , Cabal         ^>=3.12.1.0+    , Cabal-syntax  ^>=3.12.1.0     , containers    >=0.5.6.2  && <0.8     , edit-distance ^>= 0.2.2+    , directory     >= 1.3.7.0  && < 1.4     , filepath      ^>=1.4.0.0 || ^>=1.5.0.0     , mtl           >=2.0      && <2.4+    , network-uri   >= 2.6.0.2 && < 2.7     , pretty        ^>=1.1     , transformers  >=0.4.2.0  && <0.7     , text          (>= 1.2.3.0  && < 1.3) || (>= 2.0 && < 2.2)@@ -120,10 +119,6 @@   if flag(debug-expensive-assertions)     cpp-options: -DDEBUG_EXPENSIVE_ASSERTIONS -  if flag(debug-conflict-sets)-    cpp-options:   -DDEBUG_CONFLICT_SETS-    build-depends: base >=4.9-   if flag(debug-tracetree)     cpp-options:   -DDEBUG_TRACETREE     build-depends: tracetree ^>=0.1@@ -139,10 +134,10 @@      UnitTests.Distribution.Solver.Modular.MessageUtils     build-depends:-     , base        >= 4.10  && <4.20+     , base        >= 4.11  && <4.21      , Cabal      , Cabal-syntax      , cabal-install-solver      , tasty       >= 1.2.3 && <1.6-     , tasty-quickcheck+     , tasty-quickcheck <0.11      , tasty-hunit >= 0.10

@@ -60,7 +60,7 @@ -- solver. Performs the necessary translations before and after. modularResolver :: SolverConfig -> DependencyResolver loc modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns =-  fmap (uncurry postprocess) $ -- convert install plan+  uncurry postprocess <$> -- convert install plan   solve' sc cinfo idx pkgConfigDB pprefs gcs pns     where       -- Indices have to be converted into solver-specific uniform index.@@ -275,7 +275,7 @@                              ++ "conflict set: " ++ showCS cs') $                   ExhaustiveSearch smallestKnownCS smallestKnownCM             BackjumpLimitReached ->-                failWith ("Reached backjump limit while minimizing conflict set.")+                failWith "Reached backjump limit while minimizing conflict set."                          BackjumpLimitReached       where         varStr = "\"" ++ showVar v ++ "\""

@@ -1,7 +1,3 @@-{-# LANGUAGE CPP #-}-#ifdef DEBUG_CONFLICT_SETS-{-# LANGUAGE ImplicitParams #-}-#endif -- | Conflict sets -- -- Intended for double import@@ -13,9 +9,6 @@   , Conflict(..)   , ConflictMap   , OrderedVersionRange(..)-#ifdef DEBUG_CONFLICT_SETS-  , conflictSetOrigin-#endif   , showConflictSet   , showCSSortedByFrequency   , showCSWithFrequency@@ -44,36 +37,17 @@ import qualified Data.Map.Strict as M import qualified Data.Set as S -#ifdef DEBUG_CONFLICT_SETS-import Data.Tree-import GHC.Stack-#endif- import Distribution.Solver.Modular.Var import Distribution.Solver.Modular.Version import Distribution.Solver.Types.PackagePath  -- | The set of variables involved in a solver conflict, each paired with -- details about the conflict.-data ConflictSet = CS {+newtype ConflictSet = CS {     -- | The set of variables involved in the conflict-    conflictSetToMap :: !(Map (Var QPN) (Set Conflict))--#ifdef DEBUG_CONFLICT_SETS-    -- | The origin of the conflict set-    ---    -- When @DEBUG_CONFLICT_SETS@ is defined @(-f debug-conflict-sets)@,-    -- we record the origin of every conflict set. For new conflict sets-    -- ('empty', 'fromVars', ..) we just record the 'CallStack'; for operations-    -- that construct new conflict sets from existing conflict sets ('union',-    -- 'filter', ..)  we record the 'CallStack' to the call to the combinator-    -- as well as the 'CallStack's of the input conflict sets.-    ---    -- Requires @GHC >= 7.10@.-  , conflictSetOrigin :: Tree CallStack-#endif+    conflictSetToMap :: Map (Var QPN) (Set Conflict)   }-  deriving (Show)+  deriving (Eq, Show)  -- | More detailed information about how a conflict set variable caused a -- conflict. This information can be used to determine whether a second value@@ -112,12 +86,6 @@ instance Ord OrderedVersionRange where   compare = compare `on` show -instance Eq ConflictSet where-  (==) = (==) `on` conflictSetToMap--instance Ord ConflictSet where-  compare = compare `on` conflictSetToMap- showConflictSet :: ConflictSet -> String showConflictSet = intercalate ", " . map showVar . toList @@ -147,40 +115,19 @@ toList :: ConflictSet -> [Var QPN] toList = M.keys . conflictSetToMap -union ::-#ifdef DEBUG_CONFLICT_SETS-  (?loc :: CallStack) =>-#endif-  ConflictSet -> ConflictSet -> ConflictSet+union :: ConflictSet -> ConflictSet -> ConflictSet union cs cs' = CS {       conflictSetToMap = M.unionWith S.union (conflictSetToMap cs) (conflictSetToMap cs')-#ifdef DEBUG_CONFLICT_SETS-    , conflictSetOrigin = Node ?loc (map conflictSetOrigin [cs, cs'])-#endif     } -unions ::-#ifdef DEBUG_CONFLICT_SETS-  (?loc :: CallStack) =>-#endif-  [ConflictSet] -> ConflictSet+unions :: [ConflictSet] -> ConflictSet unions css = CS {       conflictSetToMap = M.unionsWith S.union (map conflictSetToMap css)-#ifdef DEBUG_CONFLICT_SETS-    , conflictSetOrigin = Node ?loc (map conflictSetOrigin css)-#endif     } -insert ::-#ifdef DEBUG_CONFLICT_SETS-  (?loc :: CallStack) =>-#endif-  Var QPN -> ConflictSet -> ConflictSet+insert :: Var QPN -> ConflictSet -> ConflictSet insert var cs = CS {       conflictSetToMap = M.insert var (S.singleton OtherConflict) (conflictSetToMap cs)-#ifdef DEBUG_CONFLICT_SETS-    , conflictSetOrigin = Node ?loc [conflictSetOrigin cs]-#endif     }  delete :: Var QPN -> ConflictSet -> ConflictSet@@ -188,35 +135,17 @@       conflictSetToMap = M.delete var (conflictSetToMap cs)     } -empty ::-#ifdef DEBUG_CONFLICT_SETS-  (?loc :: CallStack) =>-#endif-  ConflictSet+empty :: ConflictSet empty = CS {       conflictSetToMap = M.empty-#ifdef DEBUG_CONFLICT_SETS-    , conflictSetOrigin = Node ?loc []-#endif     } -singleton ::-#ifdef DEBUG_CONFLICT_SETS-  (?loc :: CallStack) =>-#endif-  Var QPN -> ConflictSet+singleton :: Var QPN -> ConflictSet singleton var = singletonWithConflict var OtherConflict -singletonWithConflict ::-#ifdef DEBUG_CONFLICT_SETS-  (?loc :: CallStack) =>-#endif-  Var QPN -> Conflict -> ConflictSet+singletonWithConflict :: Var QPN -> Conflict -> ConflictSet singletonWithConflict var conflict = CS {       conflictSetToMap = M.singleton var (S.singleton conflict)-#ifdef DEBUG_CONFLICT_SETS-    , conflictSetOrigin = Node ?loc []-#endif     }  size :: ConflictSet -> Int@@ -228,17 +157,9 @@ lookup :: Var QPN -> ConflictSet -> Maybe (Set Conflict) lookup var = M.lookup var . conflictSetToMap -fromList ::-#ifdef DEBUG_CONFLICT_SETS-  (?loc :: CallStack) =>-#endif-  [Var QPN] -> ConflictSet+fromList :: [Var QPN] -> ConflictSet fromList vars = CS {       conflictSetToMap = M.fromList [(var, S.singleton OtherConflict) | var <- vars]-#ifdef DEBUG_CONFLICT_SETS-    , conflictSetOrigin = Node ?loc []-#endif     }  type ConflictMap = Map (Var QPN) Int-

@@ -85,11 +85,11 @@     go :: Tree d c -> Validate (Tree d c)      go (PChoice qpn rdm gr       cs) =-      PChoice qpn rdm gr       <$> (W.traverseWithKey (goP qpn) $ fmap go cs)+      PChoice qpn rdm gr       <$> W.traverseWithKey (goP qpn) (fmap go cs)     go (FChoice qfn rdm gr t m d cs) =-      FChoice qfn rdm gr t m d <$> (W.traverseWithKey (goF qfn) $ fmap go cs)+      FChoice qfn rdm gr t m d <$> W.traverseWithKey (goF qfn) (fmap go cs)     go (SChoice qsn rdm gr t     cs) =-      SChoice qsn rdm gr t     <$> (W.traverseWithKey (goS qsn) $ fmap go cs)+      SChoice qsn rdm gr t     <$> W.traverseWithKey (goS qsn) (fmap go cs)      -- For the other nodes we just recurse     go (GoalChoice rdm           cs) = GoalChoice rdm <$> T.traverse go cs

@@ -1,4 +1,6 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ViewPatterns #-}  module Distribution.Solver.Modular.Message (     Message(..),@@ -10,14 +12,15 @@ import qualified Data.Map as M import Data.Set (Set) import qualified Data.Set as S-import Data.Maybe (catMaybes, mapMaybe)+import Data.Maybe (catMaybes, mapMaybe, isJust) import Prelude hiding (pi)  import Distribution.Pretty (prettyShow) -- from Cabal  import qualified Distribution.Solver.Modular.ConflictSet as CS import Distribution.Solver.Modular.Dependency-import Distribution.Solver.Modular.Flag+import Distribution.Solver.Modular.Flag ( QFN, QSN )+import qualified Distribution.Solver.Modular.Flag as Flag ( showQFN, showQFNBool, showQSN, showQSNBool ) import Distribution.Solver.Modular.MessageUtils          (showUnsupportedExtension, showUnsupportedLanguage) import Distribution.Solver.Modular.Package@@ -27,8 +30,10 @@ import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.Progress+import Distribution.Solver.Types.ProjectConfigPath (docProjectConfigPathFailReason) import Distribution.Types.LibraryName import Distribution.Types.UnqualComponentName+import Text.PrettyPrint (nest, render)  data Message =     Enter           -- ^ increase indentation level@@ -60,24 +65,24 @@     go !l (Step (TryP qpn i) (Step Enter (Step (Skip conflicts) (Step Leave ms)))) =         goPSkip l qpn [i] conflicts ms     go !l (Step (TryF qfn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =-        (atLevel l $ "rejecting: " ++ showQFNBool qfn b ++ showFR c fr) (go l ms)+        (atLevel l $ blurbQFNBool Rejecting qfn b ++ showFR c fr) (go l ms)     go !l (Step (TryS qsn b) (Step Enter (Step (Failure c fr) (Step Leave ms)))) =-        (atLevel l $ "rejecting: " ++ showQSNBool qsn b ++ showFR c fr) (go l ms)+        (atLevel l $ blurbQSNBool Rejecting qsn b ++ showFR c fr) (go l ms)     go !l (Step (Next (Goal (P _  ) gr)) (Step (TryP qpn' i) ms@(Step Enter (Step (Next _) _)))) =-        (atLevel l $ "trying: " ++ showQPNPOpt qpn' i ++ showGR gr) (go l ms)+        (atLevel l $ blurbOption Trying qpn' i ++ showGR gr) (go l ms)     go !l (Step (Next (Goal (P qpn) gr)) (Step (Failure _c UnknownPackage) ms)) =-        (atLevel l $ "unknown package: " ++ showQPN qpn ++ showGR gr) $ go l ms+        atLevel l ("unknown package: " ++ showQPN qpn ++ showGR gr) $ go l ms     -- standard display     go !l (Step Enter                    ms) = go (l+1) ms     go !l (Step Leave                    ms) = go (l-1) ms-    go !l (Step (TryP qpn i)             ms) = (atLevel l $ "trying: " ++ showQPNPOpt qpn i) (go l ms)-    go !l (Step (TryF qfn b)             ms) = (atLevel l $ "trying: " ++ showQFNBool qfn b) (go l ms)-    go !l (Step (TryS qsn b)             ms) = (atLevel l $ "trying: " ++ showQSNBool qsn b) (go l ms)+    go !l (Step (TryP qpn i)             ms) = (atLevel l $ blurbOption Trying qpn i) (go l ms)+    go !l (Step (TryF qfn b)             ms) = (atLevel l $ blurbQFNBool Trying qfn b) (go l ms)+    go !l (Step (TryS qsn b)             ms) = (atLevel l $ blurbQSNBool Trying qsn b) (go l ms)     go !l (Step (Next (Goal (P qpn) gr)) ms) = (atLevel l $ showPackageGoal qpn gr) (go l ms)     go !l (Step (Next _)                 ms) = go l     ms -- ignore flag goals in the log     go !l (Step (Skip conflicts)         ms) =         -- 'Skip' should always be handled by 'goPSkip' in the case above.-        (atLevel l $ "skipping: " ++ showConflicts conflicts) (go l ms)+        (atLevel l $ blurb Skipping ++ showConflicts conflicts) (go l ms)     go !l (Step (Success)                ms) = (atLevel l $ "done") (go l ms)     go !l (Step (Failure c fr)           ms) = (atLevel l $ showFailure c fr) (go l ms) @@ -96,9 +101,12 @@               -> Progress Message a b               -> Progress String a b     goPReject l qpn is c fr (Step (TryP qpn' i) (Step Enter (Step (Failure _ fr') (Step Leave ms))))-      | qpn == qpn' && fr == fr' = goPReject l qpn (i : is) c fr ms+      | qpn == qpn' && fr == fr' =+        -- By prepending (i : is) we reverse the order of the instances.+        goPReject l qpn (i : is) c fr ms     goPReject l qpn is c fr ms =-        (atLevel l $ "rejecting: " ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr) (go l ms)+        (atLevel l $ blurbOptions Rejecting qpn (reverse is) ++ showFR c fr)+        (go l ms)      -- Handle many subsequent skipped package instances.     goPSkip :: Int@@ -108,11 +116,11 @@             -> Progress Message a b             -> Progress String a b     goPSkip l qpn is conflicts (Step (TryP qpn' i) (Step Enter (Step (Skip conflicts') (Step Leave ms))))-      | qpn == qpn' && conflicts == conflicts' = goPSkip l qpn (i : is) conflicts ms+      | qpn == qpn' && conflicts == conflicts' =+        -- By prepending (i : is) we reverse the order of the instances.+        goPSkip l qpn (i : is) conflicts ms     goPSkip l qpn is conflicts ms =-      let msg = "skipping: "-                 ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is))-                 ++ showConflicts conflicts+      let msg = blurbOptions Skipping qpn (reverse is) ++ showConflicts conflicts       in atLevel l msg (go l ms)      -- write a message with the current level number@@ -206,12 +214,63 @@   , versionConflict :: Maybe VR   } -showQPNPOpt :: QPN -> POption -> String-showQPNPOpt qpn@(Q _pp pn) (POption i linkedTo) =+data ProgressAction =+    Trying+  | Skipping+  | Rejecting++blurb :: ProgressAction -> String+blurb = \case+  Trying -> "trying: "+  Skipping -> "skipping: "+  Rejecting -> "rejecting: "++blurbQFNBool :: ProgressAction -> QFN -> Bool -> String+blurbQFNBool a q b = blurb a ++ Flag.showQFNBool q b++blurbQSNBool :: ProgressAction -> QSN -> Bool -> String+blurbQSNBool a q b = blurb a ++ Flag.showQSNBool q b++blurbOption :: ProgressAction -> QPN -> POption -> String+blurbOption a q p = blurb a ++ showOption q p++blurbOptions :: ProgressAction -> QPN -> [POption] -> String+blurbOptions a q ps = blurb a ++ showOptions q ps++showOption :: QPN -> POption -> String+showOption qpn@(Q _pp pn) (POption i linkedTo) =   case linkedTo of     Nothing  -> showPI (PI qpn i) -- Consistent with prior to POption     Just pp' -> showQPN qpn ++ "~>" ++ showPI (PI (Q pp' pn) i) +-- | Shows a mixed list of instances and versions in a human-friendly way,+-- abbreviated.+-- >>> showOptions foobarQPN [v0, v1]+-- "foo-bar; 0, 1"+-- >>> showOptions foobarQPN [v0]+-- "foo-bar-0"+-- >>> showOptions foobarQPN [i0, i1]+-- "foo-bar; 0/installed-inplace, 1/installed-inplace"+-- >>> showOptions foobarQPN [i0, v1]+-- "foo-bar; 0/installed-inplace, 1"+-- >>> showOptions foobarQPN [v0, i1]+-- "foo-bar; 0, 1/installed-inplace"+-- >>> showOptions foobarQPN []+-- "unexpected empty list of versions"+-- >>> showOptions foobarQPN [k1, k2]+-- "foo-bar; foo-bar~>bazqux.foo-bar-1, foo-bar~>bazqux.foo-bar-2"+-- >>> showOptions foobarQPN [v0, i1, k2]+-- "foo-bar; 0, 1/installed-inplace, foo-bar~>bazqux.foo-bar-2"+showOptions :: QPN -> [POption] -> String+showOptions _ [] = "unexpected empty list of versions"+showOptions q [x] = showOption q x+showOptions q xs = showQPN q ++ "; " ++ (L.intercalate ", "+  [if isJust linkedTo+    then showOption q x+    else showI i -- Don't show the package, just the version+  | x@(POption i linkedTo) <- xs+  ])+ showGR :: QGoalReason -> String showGR UserGoal            = " (user goal)" showGR (DependencyGoal dr) = " (dependency of " ++ showDependencyReason dr ++ ")"@@ -228,12 +287,12 @@ showFR _ (PackageRequiresMissingComponent qpn comp) = " (requires " ++ showExposedComponent comp ++ " from " ++ showQPN qpn ++ ", but the component does not exist)" 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 _ CannotInstall                    = " (only already installed instances can be used)" 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 _ 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 (ConstraintSourceProjectConfig pc)) = '\n' : (render . nest 6 $ docProjectConfigPathFailReason vr pc) 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)"@@ -247,8 +306,8 @@ -- The following are internal failures. They should not occur. In the -- interest of not crashing unnecessarily, we still just print an error -- message though.-showFR _ (MalformedFlagChoice qfn)        = " (INTERNAL ERROR: MALFORMED FLAG CHOICE: " ++ showQFN qfn ++ ")"-showFR _ (MalformedStanzaChoice qsn)      = " (INTERNAL ERROR: MALFORMED STANZA CHOICE: " ++ showQSN qsn ++ ")"+showFR _ (MalformedFlagChoice qfn)        = " (INTERNAL ERROR: MALFORMED FLAG CHOICE: " ++ Flag.showQFN qfn ++ ")"+showFR _ (MalformedStanzaChoice qsn)      = " (INTERNAL ERROR: MALFORMED STANZA CHOICE: " ++ Flag.showQSN qsn ++ ")" showFR _ EmptyGoalChoice                  = " (INTERNAL ERROR: EMPTY GOAL CHOICE)"  showExposedComponent :: ExposedComponent -> String@@ -271,3 +330,17 @@                          showQPN qpn ++ componentStr ++ "==" ++ showI i        Constrained vr -> showDependencyReason dr ++ " => " ++ showQPN qpn ++                          componentStr ++ showVR vr++-- $setup+-- >>> import Distribution.Solver.Types.PackagePath+-- >>> import Distribution.Types.Version+-- >>> import Distribution.Types.UnitId+-- >>> let foobarPN = PackagePath DefaultNamespace QualToplevel+-- >>> let bazquxPN = PackagePath (Independent $ mkPackageName "bazqux") QualToplevel+-- >>> let foobarQPN = Q foobarPN (mkPackageName "foo-bar")+-- >>> let v0 = POption (I (mkVersion [0]) InRepo) Nothing+-- >>> let v1 = POption (I (mkVersion [1]) InRepo) Nothing+-- >>> let i0 = POption (I (mkVersion [0]) (Inst $ mkUnitId "foo-bar-0-inplace")) Nothing+-- >>> let i1 = POption (I (mkVersion [1]) (Inst $ mkUnitId "foo-bar-1-inplace")) Nothing+-- >>> let k1 = POption (I (mkVersion [1]) InRepo) (Just bazquxPN)+-- >>> let k2 = POption (I (mkVersion [2]) InRepo) (Just bazquxPN)

@@ -12,7 +12,6 @@     , preferLinked     , preferPackagePreferences     , preferReallyEasyGoalChoices-    , requireInstalled     , onlyConstrained     , sortGoals     , pruneAfterFirstSuccess@@ -317,18 +316,6 @@        in W.mapWithKey (restrictToggling d flagConstraintValues) ts     go x                                                            = x---- | Require installed packages.-requireInstalled :: (PN -> Bool) -> EndoTreeTrav d c-requireInstalled p = go-  where-    go (PChoiceF v@(Q _ pn) rdm gr cs)-      | p pn      = PChoiceF v rdm gr (W.mapWithKey installed cs)-      | otherwise = PChoiceF v rdm gr                         cs-      where-        installed (POption (I _ (Inst _)) _) x = x-        installed _ _ = Fail (varToConflictSet (P v)) CannotInstall-    go x          = x  -- | Avoid reinstalls. --

@@ -66,7 +66,6 @@   avoidReinstalls        :: AvoidReinstalls,   shadowPkgs             :: ShadowPkgs,   strongFlags            :: StrongFlags,-  allowBootLibInstalls   :: AllowBootLibInstalls,   onlyConstrained        :: OnlyConstrained,   maxBackjumps           :: Maybe Int,   enableBackjumping      :: EnableBackjumping,@@ -140,9 +139,6 @@                        validateLinking idx .                        validateTree cinfo idx pkgConfigDB     prunePhase       = (if asBool (avoidReinstalls sc) then P.avoidReinstalls (const True) else id) .-                       (if asBool (allowBootLibInstalls sc)-                        then id-                        else P.requireInstalled (`elem` nonInstallable)) .                        (case onlyConstrained sc of                           OnlyConstrainedAll ->                             P.onlyConstrained pkgIsExplicit@@ -154,23 +150,6 @@      pkgIsExplicit :: PN -> Bool     pkgIsExplicit pn = S.member pn allExplicit--    -- packages that can never be installed or upgraded-    -- If you change this enumeration, make sure to update the list in-    -- "Distribution.Client.Dependency" as well-    nonInstallable :: [PackageName]-    nonInstallable =-        L.map mkPackageName-             [ "base"-             , "ghc-bignum"-             , "ghc-prim"-             , "ghc-boot"-             , "ghc"-             , "ghci"-             , "integer-gmp"-             , "integer-simple"-             , "template-haskell"-             ]      -- When --reorder-goals is set, we use preferReallyEasyGoalChoices, which     -- prefers (keeps) goals only if the have 0 or 1 enabled choice.

@@ -110,7 +110,6 @@                 | PackageRequiresMissingComponent QPN ExposedComponent                 | PackageRequiresPrivateComponent QPN ExposedComponent                 | PackageRequiresUnbuildableComponent QPN ExposedComponent-                | CannotInstall                 | CannotReinstall                 | NotExplicit                 | Shadowed

@@ -1,9 +1,5 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE CPP #-}-#ifdef DEBUG_CONFLICT_SETS-{-# LANGUAGE ImplicitParams #-}-#endif module Distribution.Solver.Modular.Validate (validateTree) where  -- Validation of the tree.@@ -40,10 +36,6 @@ import Distribution.Types.LibraryName import Distribution.Types.PkgconfigVersionRange -#ifdef DEBUG_CONFLICT_SETS-import GHC.Stack (CallStack)-#endif- -- In practice, most constraints are implication constraints (IF we have made -- a number of choices, THEN we also have to ensure that). We call constraints -- that for which the preconditions are fulfilled ACTIVE. We maintain a set@@ -450,11 +442,7 @@ -- set in the sense the it contains variables that allow us to backjump -- further. We might apply some heuristics here, such as to change the -- order in which we check the constraints.-merge ::-#ifdef DEBUG_CONFLICT_SETS-  (?loc :: CallStack) =>-#endif-  MergedPkgDep -> PkgDep -> Either (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep+merge :: MergedPkgDep -> PkgDep -> Either (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep merge (MergedDepFixed comp1 vs1 i1) (PkgDep vs2 (PkgComponent p comp2) ci@(Fixed i2))   | i1 == i2  = Right $ MergedDepFixed comp1 vs1 i1   | otherwise =

@@ -24,6 +24,7 @@   , insert   , zip   , filterDeps+  , mapDeps   , fromLibraryDeps   , fromSetupDeps   , fromInstalled@@ -148,6 +149,10 @@ -- | Keep only selected components (and their associated deps info). filterDeps :: (Component -> a -> Bool) -> ComponentDeps a -> ComponentDeps a filterDeps p = ComponentDeps . Map.filterWithKey p . unComponentDeps++-- | Keep only selected components (and their associated deps info).+mapDeps :: (Component -> a -> b) -> ComponentDeps a -> ComponentDeps b+mapDeps p = ComponentDeps . Map.mapWithKey p . unComponentDeps  -- | ComponentDeps containing library dependencies only fromLibraryDeps :: a -> ComponentDeps a

@@ -5,7 +5,8 @@     ) where  import Distribution.Solver.Compat.Prelude-import Prelude ()+import Distribution.Solver.Types.ProjectConfigPath (ProjectConfigPath, docProjectConfigPath)+import Text.PrettyPrint (render)  -- | Source of a 'PackageConstraint'. data ConstraintSource =@@ -14,7 +15,7 @@   ConstraintSourceMainConfig FilePath    -- | Local cabal.project file-  | ConstraintSourceProjectConfig FilePath+  | ConstraintSourceProjectConfig ProjectConfigPath    -- | User config file, which is ./cabal.config by default.   | ConstraintSourceUserConfig FilePath@@ -27,7 +28,7 @@   | ConstraintSourceUserTarget    -- | Internal requirement to use installed versions of packages like ghc-prim.-  | ConstraintSourceNonUpgradeablePackage+  | ConstraintSourceNonReinstallablePackage    -- | Internal constraint used by @cabal freeze@.   | ConstraintSourceFreeze@@ -36,6 +37,10 @@   -- target, when a more specific source is not known.   | ConstraintSourceConfigFlagOrTarget +  -- | Constraint introduced by --enable-multi-repl, which requires features+  -- from Cabal >= 3.11+  | ConstraintSourceMultiRepl+   -- | The source of the constraint is not specified.   | ConstraintSourceUnknown @@ -56,15 +61,17 @@ showConstraintSource (ConstraintSourceMainConfig path) =     "main config " ++ path showConstraintSource (ConstraintSourceProjectConfig path) =-    "project config " ++ path+    "project config " ++ render (docProjectConfigPath path) showConstraintSource (ConstraintSourceUserConfig path)= "user config " ++ path showConstraintSource ConstraintSourceCommandlineFlag = "command line flag" showConstraintSource ConstraintSourceUserTarget = "user target"-showConstraintSource ConstraintSourceNonUpgradeablePackage =-    "non-upgradeable package"+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 ConstraintSourceUnknown = "unknown source" showConstraintSource ConstraintSetupCabalMinVersion =     "minimum version of Cabal used by Setup.hs"

@@ -133,7 +133,7 @@     getIndividualVersion pkgConfig pkg = do        (pkgVersion, _errs, exitCode) <-                getProgramInvocationOutputAndErrors verbosity-                 (programInvocation pkgConfig ["--modversion",pkg])+                 (programInvocation pkgConfig ["--modversion", pkg])        return $ case exitCode of          ExitSuccess -> Just (pkg, pkgVersion)          _ -> Nothing

@@ -0,0 +1,243 @@+{-# LANGUAGE DeriveGeneric #-}++module Distribution.Solver.Types.ProjectConfigPath+    (+    -- * Project Config Path Manipulation+      ProjectConfigPath(..)+    , projectConfigPathRoot+    , nullProjectConfigPath+    , consProjectConfigPath++    -- * Messages+    , docProjectConfigPath+    , docProjectConfigPaths+    , cyclicalImportMsg+    , docProjectConfigPathFailReason++    -- * Checks and Normalization+    , isCyclicConfigPath+    , canonicalizeConfigPath+    ) where++import Distribution.Solver.Compat.Prelude hiding (toList, (<>))+import Prelude (sequence)++import Data.Coerce (coerce)+import Data.List.NonEmpty ((<|))+import Network.URI (parseURI)+import System.Directory+import System.FilePath+import qualified Data.List.NonEmpty as NE+import Distribution.Solver.Modular.Version (VR)+import Distribution.Pretty (prettyShow)+import Text.PrettyPrint++-- | Path to a configuration file, either a singleton project root, or a longer+-- list representing a path to an import.  The path is a non-empty list that we+-- build up by prepending relative imports with @consProjectConfigPath@.+--+-- An import can be a URI, such as [a stackage+-- cabal.config](https://www.stackage.org/nightly/cabal.config), but we do not+-- support URIs in the middle of the path, URIs that import other URIs, or URIs+-- that import local files.+--+-- List elements are relative to each other but once canonicalized, elements are+-- relative to the directory of the project root.+newtype ProjectConfigPath = ProjectConfigPath (NonEmpty FilePath)+    deriving (Eq, Ord, Show, Generic)++instance Binary ProjectConfigPath+instance Structured ProjectConfigPath++-- | Renders the path like this;+-- @+-- D.config+--   imported by: C.config+--   imported by: B.config+--   imported by: A.project+-- @+-- >>> render . docProjectConfigPath $ ProjectConfigPath $ "D.config" :| ["C.config", "B.config", "A.project"]+-- "D.config\n  imported by: C.config\n  imported by: B.config\n  imported by: A.project"+docProjectConfigPath :: ProjectConfigPath -> Doc+docProjectConfigPath (ProjectConfigPath (p :| [])) = text p+docProjectConfigPath (ProjectConfigPath (p :| ps)) = vcat $+    text p : [ text " " <+> text "imported by:" <+> text l | l <- ps ]++-- | Renders the paths as a list without showing which path imports another,+-- like this;+-- @+-- - cabal.project+-- - project-cabal/constraints.config+-- - project-cabal/ghc-latest.config+-- - project-cabal/ghc-options.config+-- - project-cabal/pkgs.config+-- - project-cabal/pkgs/benchmarks.config+-- - project-cabal/pkgs/buildinfo.config+-- - project-cabal/pkgs/cabal.config+-- - project-cabal/pkgs/install.config+-- - project-cabal/pkgs/integration-tests.config+-- - project-cabal/pkgs/tests.config+-- @+--+-- >>> :{+--   do+--     let ps =+--              [ ProjectConfigPath ("cabal.project" :| [])+--              , ProjectConfigPath ("project-cabal/constraints.config" :| ["cabal.project"])+--              , ProjectConfigPath ("project-cabal/ghc-latest.config" :| ["cabal.project"])+--              , ProjectConfigPath ("project-cabal/ghc-options.config" :| ["cabal.project"])+--              , ProjectConfigPath ("project-cabal/pkgs.config" :| ["cabal.project"])+--              , ProjectConfigPath ("project-cabal/pkgs/benchmarks.config" :| ["project-cabal/pkgs.config","cabal.project"])+--              , ProjectConfigPath ("project-cabal/pkgs/buildinfo.config" :| ["project-cabal/pkgs.config","cabal.project"])+--              , ProjectConfigPath ("project-cabal/pkgs/cabal.config" :| ["project-cabal/pkgs.config","cabal.project"])+--              , ProjectConfigPath ("project-cabal/pkgs/install.config" :| ["project-cabal/pkgs.config","cabal.project"])+--              , ProjectConfigPath ("project-cabal/pkgs/integration-tests.config" :| ["project-cabal/pkgs.config","cabal.project"])+--              , ProjectConfigPath ("project-cabal/pkgs/tests.config" :| ["project-cabal/pkgs.config","cabal.project"])+--              ]+--     return . render $ docProjectConfigPaths ps+-- :}+-- "- cabal.project\n- project-cabal/constraints.config\n- project-cabal/ghc-latest.config\n- project-cabal/ghc-options.config\n- project-cabal/pkgs.config\n- project-cabal/pkgs/benchmarks.config\n- project-cabal/pkgs/buildinfo.config\n- project-cabal/pkgs/cabal.config\n- project-cabal/pkgs/install.config\n- project-cabal/pkgs/integration-tests.config\n- project-cabal/pkgs/tests.config"+docProjectConfigPaths :: [ProjectConfigPath] -> Doc+docProjectConfigPaths ps = vcat+    [ text "-" <+> text p | ProjectConfigPath (p :| _) <- ps ]++-- | A message for a cyclical import, assuming the head of the path is the+-- duplicate.+cyclicalImportMsg :: ProjectConfigPath -> Doc+cyclicalImportMsg path@(ProjectConfigPath (duplicate :| _)) =+    vcat+    [ text "cyclical import of" <+> text duplicate <> semi+    , nest 2 (docProjectConfigPath path)+    ]++docProjectConfigPathFailReason :: VR -> ProjectConfigPath -> Doc+docProjectConfigPathFailReason vr pcp+    | ProjectConfigPath (p :| []) <- pcp =+        constraint p+    | ProjectConfigPath (p :| ps) <- pcp = vcat+        [ constraint p+        , cat [nest 2 $ text "imported by:" <+> text l | l <- ps ]+        ]+    where+        pathRequiresVersion p = text p <+> text "requires" <+> text (prettyShow vr)+        constraint p = parens $ text "constraint from" <+> pathRequiresVersion p++-- | The root of the path, the project itself.+projectConfigPathRoot :: ProjectConfigPath -> FilePath+projectConfigPathRoot (ProjectConfigPath xs) = last xs++-- | Used by some tests as a dummy "unused" project root.+nullProjectConfigPath :: ProjectConfigPath+nullProjectConfigPath = ProjectConfigPath $ "unused" :| []++-- | Check if the path has duplicates. A cycle of imports is not allowed. This+-- check should only be done after the path has been canonicalized with+-- @canonicalizeConfigPath@. This is because the import path may contain paths+-- that are the same in relation to their importers but different in relation to+-- the project root directory.+isCyclicConfigPath :: ProjectConfigPath -> Bool+isCyclicConfigPath (ProjectConfigPath p) = length p /= length (NE.nub p)++-- | Prepends the path of the importee to the importer path.+consProjectConfigPath :: FilePath -> ProjectConfigPath -> ProjectConfigPath+consProjectConfigPath p ps = ProjectConfigPath (p <| coerce ps)++-- | Make paths relative to the directory of the root of the project, not+-- relative to the file they were imported from.+makeRelativeConfigPath :: FilePath -> ProjectConfigPath -> ProjectConfigPath+makeRelativeConfigPath dir (ProjectConfigPath p) =+    ProjectConfigPath+    $ (\segment -> (if isURI segment then segment else makeRelative dir segment))+    <$> p++-- | Normalizes and canonicalizes a path removing '.' and '..' indirections.+-- Makes the path relative to the given directory (typically the project root)+-- instead of relative to the file it was imported from.+--+-- It converts paths like this:+-- @+-- └─ hops-0.project+--    └─ hops/hops-1.config+--       └─ ../hops-2.config+--          └─ hops/hops-3.config+--             └─ ../hops-4.config+--                └─ hops/hops-5.config+--                   └─ ../hops-6.config+--                      └─ hops/hops-7.config+--                         └─ ../hops-8.config+--                            └─ hops/hops-9.config+-- @+--+-- Into paths like this:+-- @+-- └─ hops-0.project+--    └─ hops/hops-1.config+--       └─ hops-2.config+--          └─ hops/hops-3.config+--             └─ hops-4.config+--                └─ hops/hops-5.config+--                   └─ hops-6.config+--                      └─ hops/hops-7.config+--                         └─ hops-8.config+--                            └─ hops/hops-9.config+-- @+--+-- That way we have @hops-8.config@ instead of+-- @./hops/../hops/../hops/../hops/../hops-8.config@.+--+-- Let's see how @canonicalizePath@ works that is used in the implementation+-- then we'll see how @canonicalizeConfigPath@ works.+--+-- >>> let d = testDir+-- >>> makeRelative d <$> canonicalizePath (d </> "hops/../hops/../hops/../hops/../hops-8.config")+-- "hops-8.config"+--+-- >>> let d = testDir+-- >>> p <- canonicalizeConfigPath d (ProjectConfigPath $ (d </> "hops/../hops/../hops/../hops/../hops-8.config") :| [])+-- >>> render $ docProjectConfigPath p+-- "hops-8.config"+--+-- >>> :{+--   do+--     let expected = unlines+--           [ "hops/hops-9.config"+--           , "  imported by: hops-8.config"+--           , "  imported by: hops/hops-7.config"+--           , "  imported by: hops-6.config"+--           , "  imported by: hops/hops-5.config"+--           , "  imported by: hops-4.config"+--           , "  imported by: hops/hops-3.config"+--           , "  imported by: hops-2.config"+--           , "  imported by: hops/hops-1.config"+--           , "  imported by: hops-0.project"+--           ]+--     let d = testDir+--     let configPath = ProjectConfigPath ("hops/hops-9.config" :|+--           [ "../hops-8.config"+--           , "hops/hops-7.config"+--           , "../hops-6.config"+--           , "hops/hops-5.config"+--           , "../hops-4.config"+--           , "hops/hops-3.config"+--           , "../hops-2.config"+--           , "hops/hops-1.config"+--           , d </> "hops-0.project"])+--     p <- canonicalizeConfigPath d configPath+--     return $ expected == render (docProjectConfigPath p) ++ "\n"+-- :}+-- True+canonicalizeConfigPath :: FilePath -> ProjectConfigPath -> IO ProjectConfigPath+canonicalizeConfigPath d (ProjectConfigPath p) = do+    xs <- sequence $ NE.scanr (\importee -> (>>= \importer ->+            if isURI importee+                then pure importee+                else canonicalizePath $ d </> takeDirectory importer </> importee))+            (pure ".") p+    return . makeRelativeConfigPath d . ProjectConfigPath . NE.fromList $ NE.init xs++isURI :: FilePath -> Bool+isURI = isJust . parseURI++-- $setup+-- >>> import Data.List+-- >>> testDir <- makeAbsolute =<< canonicalizePath "../cabal-testsuite/PackageTests/ConditionalAndImport"