diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/cabal-install-solver.cabal b/cabal-install-solver.cabal --- a/cabal-install-solver.cabal +++ b/cabal-install-solver.cabal @@ -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 -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 diff --git a/src/Distribution/Solver/Modular.hs b/src/Distribution/Solver/Modular.hs --- a/src/Distribution/Solver/Modular.hs +++ b/src/Distribution/Solver/Modular.hs @@ -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 ++ "\"" diff --git a/src/Distribution/Solver/Modular/ConflictSet.hs b/src/Distribution/Solver/Modular/ConflictSet.hs --- a/src/Distribution/Solver/Modular/ConflictSet.hs +++ b/src/Distribution/Solver/Modular/ConflictSet.hs @@ -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 - diff --git a/src/Distribution/Solver/Modular/Linking.hs b/src/Distribution/Solver/Modular/Linking.hs --- a/src/Distribution/Solver/Modular/Linking.hs +++ b/src/Distribution/Solver/Modular/Linking.hs @@ -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 diff --git a/src/Distribution/Solver/Modular/Message.hs b/src/Distribution/Solver/Modular/Message.hs --- a/src/Distribution/Solver/Modular/Message.hs +++ b/src/Distribution/Solver/Modular/Message.hs @@ -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) diff --git a/src/Distribution/Solver/Modular/Preference.hs b/src/Distribution/Solver/Modular/Preference.hs --- a/src/Distribution/Solver/Modular/Preference.hs +++ b/src/Distribution/Solver/Modular/Preference.hs @@ -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. -- diff --git a/src/Distribution/Solver/Modular/Solver.hs b/src/Distribution/Solver/Modular/Solver.hs --- a/src/Distribution/Solver/Modular/Solver.hs +++ b/src/Distribution/Solver/Modular/Solver.hs @@ -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. diff --git a/src/Distribution/Solver/Modular/Tree.hs b/src/Distribution/Solver/Modular/Tree.hs --- a/src/Distribution/Solver/Modular/Tree.hs +++ b/src/Distribution/Solver/Modular/Tree.hs @@ -110,7 +110,6 @@ | PackageRequiresMissingComponent QPN ExposedComponent | PackageRequiresPrivateComponent QPN ExposedComponent | PackageRequiresUnbuildableComponent QPN ExposedComponent - | CannotInstall | CannotReinstall | NotExplicit | Shadowed diff --git a/src/Distribution/Solver/Modular/Validate.hs b/src/Distribution/Solver/Modular/Validate.hs --- a/src/Distribution/Solver/Modular/Validate.hs +++ b/src/Distribution/Solver/Modular/Validate.hs @@ -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 = diff --git a/src/Distribution/Solver/Types/ComponentDeps.hs b/src/Distribution/Solver/Types/ComponentDeps.hs --- a/src/Distribution/Solver/Types/ComponentDeps.hs +++ b/src/Distribution/Solver/Types/ComponentDeps.hs @@ -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 diff --git a/src/Distribution/Solver/Types/ConstraintSource.hs b/src/Distribution/Solver/Types/ConstraintSource.hs --- a/src/Distribution/Solver/Types/ConstraintSource.hs +++ b/src/Distribution/Solver/Types/ConstraintSource.hs @@ -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" diff --git a/src/Distribution/Solver/Types/PkgConfigDb.hs b/src/Distribution/Solver/Types/PkgConfigDb.hs --- a/src/Distribution/Solver/Types/PkgConfigDb.hs +++ b/src/Distribution/Solver/Types/PkgConfigDb.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 diff --git a/src/Distribution/Solver/Types/ProjectConfigPath.hs b/src/Distribution/Solver/Types/ProjectConfigPath.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Types/ProjectConfigPath.hs @@ -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"