cabal-install-solver-3.8.1.0/0000755000000000000000000000000007346545000014070 5ustar0000000000000000cabal-install-solver-3.8.1.0/ChangeLog.md0000644000000000000000000000010707346545000016237 0ustar0000000000000000Please see https://hackage.haskell.org/package/cabal-install/changelog cabal-install-solver-3.8.1.0/LICENSE0000644000000000000000000000317507346545000015103 0ustar0000000000000000Copyright (c) 2003-2022, Cabal Development Team. See the AUTHORS file for the full list of copyright holders. See */LICENSE for the copyright holders of the subcomponents. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Isaac Jones nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. cabal-install-solver-3.8.1.0/Setup.hs0000644000000000000000000000007407346545000015525 0ustar0000000000000000import Distribution.Simple main :: IO () main = defaultMain cabal-install-solver-3.8.1.0/cabal-install-solver.cabal0000644000000000000000000001123407346545000021073 0ustar0000000000000000cabal-version: 2.2 name: cabal-install-solver version: 3.8.1.0 synopsis: The command-line interface for Cabal and Hackage. description: The solver component used in cabal-install command-line program homepage: http://www.haskell.org/cabal/ bug-reports: https://github.com/haskell/cabal/issues license: BSD-3-Clause license-file: LICENSE author: Cabal Development Team (see AUTHORS file) maintainer: Cabal Development Team copyright: 2003-2022, Cabal Development Team category: Distribution build-type: Simple Extra-Source-Files: ChangeLog.md source-repository head type: git location: https://github.com/haskell/cabal/ subdir: cabal-install-solver flag debug-expensive-assertions description: Enable expensive assertions for testing or debugging 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 manual: True library default-language: Haskell2010 hs-source-dirs: src hs-source-dirs: src-assertion ghc-options: -Wall -Wcompat -Wnoncanonical-monad-instances -fwarn-tabs -fwarn-incomplete-uni-patterns if impl(ghc <8.8) ghc-options: -Wnoncanonical-monadfail-instances if impl(ghc >=8.10) ghc-options: -Wunused-packages exposed-modules: Distribution.Client.Utils.Assertion Distribution.Solver.Compat.Prelude Distribution.Solver.Modular Distribution.Solver.Modular.Assignment Distribution.Solver.Modular.Builder Distribution.Solver.Modular.Configured Distribution.Solver.Modular.ConfiguredConversion Distribution.Solver.Modular.ConflictSet Distribution.Solver.Modular.Cycles Distribution.Solver.Modular.Dependency Distribution.Solver.Modular.Explore Distribution.Solver.Modular.Flag Distribution.Solver.Modular.Index Distribution.Solver.Modular.IndexConversion Distribution.Solver.Modular.LabeledGraph Distribution.Solver.Modular.Linking Distribution.Solver.Modular.Log Distribution.Solver.Modular.Message Distribution.Solver.Modular.MessageUtils Distribution.Solver.Modular.Package Distribution.Solver.Modular.Preference Distribution.Solver.Modular.PSQ Distribution.Solver.Modular.RetryLog Distribution.Solver.Modular.Solver Distribution.Solver.Modular.Tree Distribution.Solver.Modular.Validate Distribution.Solver.Modular.Var Distribution.Solver.Modular.Version Distribution.Solver.Modular.WeightedPSQ Distribution.Solver.Types.ComponentDeps Distribution.Solver.Types.ConstraintSource Distribution.Solver.Types.DependencyResolver Distribution.Solver.Types.Flag Distribution.Solver.Types.InstalledPreference Distribution.Solver.Types.InstSolverPackage Distribution.Solver.Types.LabeledPackageConstraint Distribution.Solver.Types.OptionalStanza Distribution.Solver.Types.PackageConstraint Distribution.Solver.Types.PackageFixedDeps Distribution.Solver.Types.PackageIndex Distribution.Solver.Types.PackagePath Distribution.Solver.Types.PackagePreferences Distribution.Solver.Types.PkgConfigDb Distribution.Solver.Types.Progress Distribution.Solver.Types.ResolverPackage Distribution.Solver.Types.Settings Distribution.Solver.Types.SolverId Distribution.Solver.Types.SolverPackage Distribution.Solver.Types.SourcePackage Distribution.Solver.Types.Variable build-depends: , array >=0.4 && <0.6 , base >=4.10 && <4.17 , bytestring >=0.10.6.0 && <0.12 , Cabal ^>=3.8 , Cabal-syntax ^>=3.8 , containers >=0.5.6.2 && <0.7 , edit-distance ^>= 0.2.2 , filepath ^>=1.4.0.0 , mtl >=2.0 && <2.3 , pretty ^>=1.1 , transformers >=0.4.2.0 && <0.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.8 if flag(debug-tracetree) cpp-options: -DDEBUG_TRACETREE build-depends: tracetree ^>=0.1 Test-Suite unit-tests default-language: Haskell2010 ghc-options: -rtsopts -threaded type: exitcode-stdio-1.0 main-is: UnitTests.hs hs-source-dirs: tests other-modules: UnitTests.Distribution.Solver.Modular.MessageUtils build-depends: , base >= 4.10 && <4.17 , Cabal , Cabal-syntax , cabal-install-solver , tasty >= 1.2.3 && <1.5 , tasty-quickcheck , tasty-hunit >= 0.10 cabal-install-solver-3.8.1.0/src-assertion/Distribution/Client/Utils/0000755000000000000000000000000007346545000023661 5ustar0000000000000000cabal-install-solver-3.8.1.0/src-assertion/Distribution/Client/Utils/Assertion.hs0000644000000000000000000000115407346545000026165 0ustar0000000000000000{-# LANGUAGE CPP #-} module Distribution.Client.Utils.Assertion (expensiveAssert) where #ifdef DEBUG_EXPENSIVE_ASSERTIONS import Prelude (Bool) import Control.Exception (assert) import Distribution.Compat.Stack #else import Prelude (Bool, id) #endif -- | Like 'assert', but only enabled with -fdebug-expensive-assertions. This -- function can be used for expensive assertions that should only be turned on -- during testing or debugging. #ifdef DEBUG_EXPENSIVE_ASSERTIONS expensiveAssert :: WithCallStack (Bool -> a -> a) expensiveAssert = assert #else expensiveAssert :: Bool -> a -> a expensiveAssert _ = id #endif cabal-install-solver-3.8.1.0/src/Distribution/Solver/Compat/0000755000000000000000000000000007346545000022033 5ustar0000000000000000cabal-install-solver-3.8.1.0/src/Distribution/Solver/Compat/Prelude.hs0000644000000000000000000000103007346545000023761 0ustar0000000000000000-- to suppress WARNING in "Distribution.Compat.Prelude.Internal" {-# OPTIONS_GHC -fno-warn-deprecations #-} -- | This module does two things: -- -- * Acts as a compatibility layer, like @base-compat@. -- -- * Provides commonly used imports. -- -- This module is a superset of "Distribution.Compat.Prelude" (which -- this module re-exports) -- module Distribution.Solver.Compat.Prelude ( module Distribution.Compat.Prelude.Internal , Prelude.IO ) where import Prelude (IO) import Distribution.Compat.Prelude.Internal hiding (IO) cabal-install-solver-3.8.1.0/src/Distribution/Solver/0000755000000000000000000000000007346545000020610 5ustar0000000000000000cabal-install-solver-3.8.1.0/src/Distribution/Solver/Modular.hs0000644000000000000000000004016407346545000022554 0ustar0000000000000000{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} module Distribution.Solver.Modular ( modularResolver, SolverConfig(..), PruneAfterFirstSuccess(..) ) where -- Here, we try to map between the external cabal-install solver -- interface and the internal interface that the solver actually -- expects. There are a number of type conversions to perform: we -- have to convert the package indices to the uniform index used -- by the solver; we also have to convert the initial constraints; -- and finally, we have to convert back the resulting install -- plan. import Prelude () import Distribution.Solver.Compat.Prelude import qualified Data.Map as M import Data.Set (isSubsetOf) import Distribution.Compat.Graph ( IsNode(..) ) import Distribution.Compiler ( CompilerInfo ) import Distribution.Solver.Modular.Assignment ( Assignment, toCPs ) import Distribution.Solver.Modular.ConfiguredConversion ( convCP ) import qualified Distribution.Solver.Modular.ConflictSet as CS import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Index import Distribution.Solver.Modular.IndexConversion ( convPIs ) import Distribution.Solver.Modular.Log ( SolverFailure(..), displayLogMessages ) import Distribution.Solver.Modular.Package ( PN ) import Distribution.Solver.Modular.RetryLog import Distribution.Solver.Modular.Solver ( SolverConfig(..), PruneAfterFirstSuccess(..), solve ) import Distribution.Solver.Types.DependencyResolver import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.PackageConstraint import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.PackagePreferences import Distribution.Solver.Types.PkgConfigDb ( PkgConfigDb ) import Distribution.Solver.Types.Progress import Distribution.Solver.Types.Variable import Distribution.System ( Platform(..) ) import Distribution.Simple.Setup ( BooleanFlag(..) ) import Distribution.Simple.Utils ( ordNubBy ) import Distribution.Verbosity -- | Ties the two worlds together: classic cabal-install vs. the modular -- solver. Performs the necessary translations before and after. modularResolver :: SolverConfig -> DependencyResolver loc modularResolver sc (Platform arch os) cinfo iidx sidx pkgConfigDB pprefs pcs pns = fmap (uncurry postprocess) $ -- convert install plan solve' sc cinfo idx pkgConfigDB pprefs gcs pns where -- 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) where pair lpc = (pcName $ unlabelPackageConstraint lpc, [lpc]) -- Results have to be converted into an install plan. 'convCP' removes -- package qualifiers, which means that linked packages become duplicates -- and can be removed. postprocess a rdm = ordNubBy nodeKey $ map (convCP iidx sidx) (toCPs a rdm) -- Helper function to extract the PN from a constraint. pcName :: PackageConstraint -> PN pcName (PackageConstraint scope _) = scopeToPackageName scope -- | Run 'D.S.Modular.Solver.solve' and then produce a summarized log to display -- in the error case. -- -- When there is no solution, we produce the error message by rerunning the -- solver but making it prefer the goals from the final conflict set from the -- first run (or a subset of the final conflict set with -- --minimize-conflict-set). We also set the backjump limit to 0, so that the -- log stops at the first backjump and is relatively short. Preferring goals -- from the final conflict set increases the probability that the log to the -- first backjump contains package, flag, and stanza choices that are relevant -- to the final failure. The solver shouldn't need to choose any packages that -- aren't in the final conflict set. (For every variable in the final conflict -- set, the final conflict set should also contain the variable that introduced -- that variable. The solver can then follow that chain of variables in reverse -- order from the user target to the conflict.) However, it is possible that the -- conflict set contains unnecessary variables. -- -- Producing an error message when the solver reaches the backjump limit is more -- complicated. There is no final conflict set, so we create one for the minimal -- subtree containing the path that the solver took to the first backjump. This -- conflict set helps explain why the solver reached the backjump limit, because -- the first backjump contributes to reaching the backjump limit. Additionally, -- the solver is much more likely to be able to finish traversing this subtree -- before the backjump limit, since its size is linear (not exponential) in the -- number of goal choices. We create it by pruning all children after the first -- successful child under each node in the original tree, so that there is at -- most one valid choice at each level. Then we use the final conflict set from -- that run to generate an error message, as in the case where the solver found -- that there was no solution. -- -- Using the full log from a rerun of the solver ensures that the log is -- complete, i.e., it shows the whole chain of dependencies from the user -- targets to the conflicting packages. solve' :: SolverConfig -> CompilerInfo -> Index -> PkgConfigDb -> (PN -> PackagePreferences) -> Map PN [LabeledPackageConstraint] -> Set PN -> Progress String String (Assignment, RevDepMap) solve' sc cinfo idx pkgConfigDB pprefs gcs pns = toProgress $ retry (runSolver printFullLog sc) createErrorMsg where runSolver :: Bool -> SolverConfig -> RetryLog String SolverFailure (Assignment, RevDepMap) runSolver keepLog sc' = displayLogMessages keepLog $ solve sc' cinfo idx pkgConfigDB pprefs gcs pns createErrorMsg :: SolverFailure -> RetryLog String String (Assignment, RevDepMap) createErrorMsg failure@(ExhaustiveSearch cs cm) = 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) $ \case ExhaustiveSearch cs' cm' -> fromProgress $ Fail $ rerunSolverForErrorMsg cs' ++ finalErrorMsg sc (ExhaustiveSearch cs' cm') BackjumpLimitReached -> fromProgress $ Fail $ "Reached backjump limit while trying to minimize the " ++ "conflict set to create a better error message. " ++ "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 }) $ \case ExhaustiveSearch cs _ -> fromProgress $ Fail $ rerunSolverForErrorMsg cs ++ finalErrorMsg sc failure BackjumpLimitReached -> -- This case is possible when the number of goals involved in -- conflicts is greater than the backjump limit. fromProgress $ Fail $ finalErrorMsg sc failure ++ "Failed to generate a summarized dependency solver " ++ "log due to low backjump limit." rerunSolverForErrorMsg :: ConflictSet -> String rerunSolverForErrorMsg cs = let sc' = sc { goalOrder = Just goalOrder' , maxBackjumps = Just 0 } -- Preferring goals from the conflict set takes precedence over the -- original goal order. goalOrder' = preferGoalsFromConflictSet cs <> fromMaybe mempty (goalOrder sc) in unlines ("Could not resolve dependencies:" : messages (toProgress (runSolver True sc'))) printFullLog = solverVerbosity sc >= verbose messages :: Progress step fail done -> [step] messages = foldProgress (:) (const []) (const []) -- | Try to remove variables from the given conflict set to create a minimal -- conflict set. -- -- Minimal means that no proper subset of the conflict set is also a conflict -- set, though there may be other possible conflict sets with fewer variables. -- This function minimizes the input by trying to remove one variable at a time. -- It only makes one pass over the variables, so it runs the solver at most N -- times when given a conflict set of size N. Only one pass is necessary, -- because every superset of a conflict set is also a conflict set, meaning that -- failing to remove variable X from a conflict set in one step means that X -- cannot be removed from any subset of that conflict set in a subsequent step. -- -- Example steps: -- -- Start with {A, B, C}. -- Try to remove A from {A, B, C} and fail. -- Try to remove B from {A, B, C} and succeed. -- Try to remove C from {A, C} and fail. -- Return {A, C} -- -- This function can fail for two reasons: -- -- 1. The solver can reach the backjump limit on any run. In this case the -- returned RetryLog ends with BackjumpLimitReached. -- TODO: Consider applying the backjump limit to all solver runs combined, -- instead of each individual run. For example, 10 runs with 10 backjumps -- each should count as 100 backjumps. -- 2. Since this function works by rerunning the solver, it is possible for the -- solver to add new unnecessary variables to the conflict set. This function -- discards the result from any run that adds new variables to the conflict -- set, but the end result may not be completely minimized. tryToMinimizeConflictSet :: forall a . (SolverConfig -> RetryLog String SolverFailure a) -> SolverConfig -> ConflictSet -> ConflictMap -> RetryLog String SolverFailure a tryToMinimizeConflictSet runSolver sc cs cm = foldl (\r v -> retryNoSolution r $ tryToRemoveOneVar v) (fromProgress $ Fail $ ExhaustiveSearch cs cm) (CS.toList cs) where -- This function runs the solver and makes it prefer goals in the following -- order: -- -- 1. variables in 'smallestKnownCS', excluding 'v' -- 2. 'v' -- 3. all other variables -- -- If 'v' is not necessary, then the solver will find that there is no -- solution before starting to solve for 'v', and the new final conflict set -- will be very likely to not contain 'v'. If 'v' is necessary, the solver -- will most likely need to try solving for 'v' before finding that there is -- no solution, and the new final conflict set will still contain 'v'. -- However, this method isn't perfect, because it is possible for the solver -- to add new unnecessary variables to the conflict set on any run. This -- function prevents the conflict set from growing by checking that the new -- conflict set is a subset of the old one and falling back to using the old -- conflict set when that check fails. tryToRemoveOneVar :: Var QPN -> ConflictSet -> ConflictMap -> RetryLog String SolverFailure a tryToRemoveOneVar v smallestKnownCS smallestKnownCM -- Check whether v is still present, because it may have already been -- removed in a previous solver rerun. | not (v `CS.member` smallestKnownCS) = fromProgress $ Fail $ ExhaustiveSearch smallestKnownCS smallestKnownCM | otherwise = continueWith ("Trying to remove variable " ++ varStr ++ " from the " ++ "conflict set.") $ retry (runSolver sc') $ \case err@(ExhaustiveSearch cs' _) | CS.toSet cs' `isSubsetOf` CS.toSet smallestKnownCS -> let msg = if not $ CS.member v cs' then "Successfully removed " ++ varStr ++ " from " ++ "the conflict set." else "Failed to remove " ++ varStr ++ " from the " ++ "conflict set." in -- Use the new conflict set, even if v wasn't removed, -- because other variables may have been removed. failWith (msg ++ " Continuing with " ++ showCS cs' ++ ".") err | otherwise -> failWith ("Failed to find a smaller conflict set. The new " ++ "conflict set is not a subset of the previous " ++ "conflict set: " ++ showCS cs') $ ExhaustiveSearch smallestKnownCS smallestKnownCM BackjumpLimitReached -> failWith ("Reached backjump limit while minimizing conflict set.") BackjumpLimitReached where varStr = "\"" ++ showVar v ++ "\"" showCS cs' = "{" ++ showConflictSet cs' ++ "}" sc' = sc { goalOrder = Just goalOrder' } goalOrder' = preferGoalsFromConflictSet (v `CS.delete` smallestKnownCS) <> preferGoal v <> fromMaybe mempty (goalOrder sc) -- Like 'retry', except that it only applies the input function when the -- backjump limit has not been reached. retryNoSolution :: RetryLog step SolverFailure done -> (ConflictSet -> ConflictMap -> RetryLog step SolverFailure done) -> RetryLog step SolverFailure done retryNoSolution lg f = retry lg $ \case ExhaustiveSearch cs' cm' -> f cs' cm' BackjumpLimitReached -> fromProgress (Fail BackjumpLimitReached) -- | Goal ordering that chooses goals contained in the conflict set before -- other goals. preferGoalsFromConflictSet :: ConflictSet -> Variable QPN -> Variable QPN -> Ordering preferGoalsFromConflictSet cs = comparing $ \v -> not $ CS.member (toVar v) cs -- | Goal ordering that chooses the given goal first. preferGoal :: Var QPN -> Variable QPN -> Variable QPN -> Ordering preferGoal preferred = comparing $ \v -> toVar v /= preferred toVar :: Variable QPN -> Var QPN toVar (PackageVar qpn) = P qpn toVar (FlagVar qpn fn) = F (FN qpn fn) toVar (StanzaVar qpn sn) = S (SN qpn sn) finalErrorMsg :: SolverConfig -> SolverFailure -> String finalErrorMsg sc failure = case failure of ExhaustiveSearch cs cm -> "After searching the rest of the dependency tree exhaustively, " ++ "these were the goals I've had most trouble fulfilling: " ++ showCS cm cs ++ flagSuggestion where showCS = if solverVerbosity sc > normal then CS.showCSWithFrequency else CS.showCSSortedByFrequency flagSuggestion = -- Don't suggest --minimize-conflict-set if the conflict set is -- already small, because it is unlikely to be reduced further. if CS.size cs > 3 && not (asBool (minimizeConflictSet sc)) then "\nTry running with --minimize-conflict-set to improve the " ++ "error message." else "" BackjumpLimitReached -> "Backjump limit reached (" ++ currlimit (maxBackjumps sc) ++ "change with --max-backjumps or try to run with --reorder-goals).\n" where currlimit (Just n) = "currently " ++ show n ++ ", " currlimit Nothing = "" cabal-install-solver-3.8.1.0/src/Distribution/Solver/Modular/0000755000000000000000000000000007346545000022213 5ustar0000000000000000cabal-install-solver-3.8.1.0/src/Distribution/Solver/Modular/Assignment.hs0000644000000000000000000000703707346545000024666 0ustar0000000000000000module Distribution.Solver.Modular.Assignment ( Assignment(..) , PAssignment , FAssignment , SAssignment , toCPs ) where import Prelude () import Distribution.Solver.Compat.Prelude hiding (pi) import qualified Data.Array as A import qualified Data.List as L import qualified Data.Map as M import Data.Maybe (fromJust) import Distribution.PackageDescription (FlagAssignment, mkFlagAssignment) -- from Cabal import Distribution.Solver.Types.ComponentDeps (ComponentDeps, Component) import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PackagePath import Distribution.Solver.Modular.Configured import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.LabeledGraph import Distribution.Solver.Modular.Package -- | A (partial) package assignment. Qualified package names -- are associated with instances. type PAssignment = Map QPN I type FAssignment = Map QFN Bool type SAssignment = Map QSN Bool -- | A (partial) assignment of variables. data Assignment = A PAssignment FAssignment SAssignment deriving (Show, Eq) -- | Delivers an ordered list of fully configured packages. -- -- TODO: This function is (sort of) ok. However, there's an open bug -- w.r.t. unqualification. There might be several different instances -- of one package version chosen by the solver, which will lead to -- clashes. toCPs :: Assignment -> RevDepMap -> [CP QPN] toCPs (A pa fa sa) rdm = let -- get hold of the graph g :: Graph Component vm :: Vertex -> ((), QPN, [(Component, QPN)]) cvm :: QPN -> Maybe Vertex -- Note that the RevDepMap contains duplicate dependencies. Therefore the nub. (g, vm, cvm) = graphFromEdges (L.map (\ (x, xs) -> ((), x, nub xs)) (M.toList rdm)) tg :: Graph Component tg = transposeG g -- Topsort the dependency graph, yielding a list of pkgs in the right order. -- The graph will still contain all the installed packages, and it might -- contain duplicates, because several variables might actually resolve to -- the same package in the presence of qualified package names. ps :: [PI QPN] ps = L.map ((\ (_, x, _) -> PI x (pa M.! x)) . vm) $ topSort g -- Determine the flags per package, by walking over and regrouping the -- complete flag assignment by package. fapp :: Map QPN FlagAssignment fapp = M.fromListWith mappend $ L.map (\ ((FN qpn fn), b) -> (qpn, mkFlagAssignment [(fn, b)])) $ M.toList $ fa -- Stanzas per package. sapp :: Map QPN OptionalStanzaSet sapp = M.fromListWith mappend $ L.map (\ ((SN qpn sn), b) -> (qpn, if b then optStanzaSetSingleton sn else mempty)) $ M.toList sa -- Dependencies per package. depp :: QPN -> [(Component, PI QPN)] depp qpn = let v :: Vertex v = fromJust (cvm qpn) -- TODO: why this is safe? dvs :: [(Component, Vertex)] dvs = tg A.! v in L.map (\ (comp, dv) -> case vm dv of (_, x, _) -> (comp, PI x (pa M.! x))) dvs -- Translated to PackageDeps depp' :: QPN -> ComponentDeps [PI QPN] depp' = CD.fromList . L.map (\(comp, d) -> (comp, [d])) . depp in L.map (\ pi@(PI qpn _) -> CP pi (M.findWithDefault mempty qpn fapp) (M.findWithDefault mempty qpn sapp) (depp' qpn)) ps cabal-install-solver-3.8.1.0/src/Distribution/Solver/Modular/Builder.hs0000644000000000000000000003312407346545000024140 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} module Distribution.Solver.Modular.Builder ( buildTree , splits -- for testing ) where -- Building the search tree. -- -- In this phase, we build a search tree that is too large, i.e, it contains -- invalid solutions. We keep track of the open goals at each point. We -- nondeterministically pick an open goal (via a goal choice node), create -- subtrees according to the index and the available solutions, and extend the -- set of open goals by superficially looking at the dependencies recorded in -- the index. -- -- For each goal, we keep track of all the *reasons* why it is being -- introduced. These are for debugging and error messages, mainly. A little bit -- of care has to be taken due to the way we treat flags. If a package has -- flag-guarded dependencies, we cannot introduce them immediately. Instead, we -- store the entire dependency. import qualified Data.List as L import qualified Data.Map as M import qualified Data.Set as S import Prelude import qualified Distribution.Solver.Modular.ConflictSet as CS import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Index import Distribution.Solver.Modular.Package import qualified Distribution.Solver.Modular.PSQ as P import Distribution.Solver.Modular.Tree import qualified Distribution.Solver.Modular.WeightedPSQ as W import Distribution.Solver.Types.ComponentDeps import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.Settings -- | All state needed to build and link the search tree. It has a type variable -- because the linking phase doesn't need to know about the state used to build -- the tree. data Linker a = Linker { buildState :: a, linkingState :: LinkingState } -- | The state needed to build the search tree without creating any linked nodes. data BuildState = BS { index :: Index, -- ^ information about packages and their dependencies rdeps :: RevDepMap, -- ^ set of all package goals, completed and open, with reverse dependencies open :: [OpenGoal], -- ^ set of still open goals (flag and package goals) next :: BuildType, -- ^ kind of node to generate next qualifyOptions :: QualifyOptions -- ^ qualification options } -- | Map of available linking targets. type LinkingState = M.Map (PN, I) [PackagePath] -- | Extend the set of open goals with the new goals listed. -- -- We also adjust the map of overall goals, and keep track of the -- reverse dependencies of each of the goals. extendOpen :: QPN -> [FlaggedDep QPN] -> BuildState -> BuildState extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs where go :: RevDepMap -> [OpenGoal] -> [FlaggedDep QPN] -> BuildState go g o [] = s { rdeps = g, open = o } go g o ((Flagged fn@(FN qpn _) fInfo t f) : ngs) = go g (FlagGoal fn fInfo t f (flagGR qpn) : o) ngs -- Note: for 'Flagged' goals, we always insert, so later additions win. -- This is important, because in general, if a goal is inserted twice, -- the later addition will have better dependency information. go g o ((Stanza sn@(SN qpn _) t) : ngs) = go g (StanzaGoal sn t (flagGR qpn) : o) ngs go g o ((Simple (LDep dr (Dep (PkgComponent qpn _) _)) c) : ngs) | qpn == qpn' = -- We currently only add a self-dependency to the graph if it is -- between a package and its setup script. The edge creates a cycle -- and causes the solver to backtrack and choose a different -- instance for the setup script. We may need to track other -- self-dependencies once we implement component-based solving. case c of ComponentSetup -> go (M.adjust (addIfAbsent (ComponentSetup, qpn')) qpn g) o ngs _ -> go g o ngs | qpn `M.member` g = go (M.adjust (addIfAbsent (c, qpn')) qpn g) o ngs | otherwise = go (M.insert qpn [(c, qpn')] g) (PkgGoal qpn (DependencyGoal dr) : o) ngs -- code above is correct; insert/adjust have different arg order go g o ((Simple (LDep _dr (Ext _ext )) _) : ngs) = go g o ngs go g o ((Simple (LDep _dr (Lang _lang))_) : ngs) = go g o ngs go g o ((Simple (LDep _dr (Pkg _pn _vr))_) : ngs) = go g o ngs addIfAbsent :: Eq a => a -> [a] -> [a] addIfAbsent x xs = if x `elem` xs then xs else x : xs -- GoalReason for a flag or stanza. Each flag/stanza is introduced only by -- its containing package. flagGR :: qpn -> GoalReason qpn flagGR qpn = DependencyGoal (DependencyReason qpn M.empty S.empty) -- | Given the current scope, qualify all the package names in the given set of -- dependencies and then extend the set of open goals accordingly. scopedExtendOpen :: QPN -> FlaggedDeps PN -> FlagInfo -> BuildState -> BuildState scopedExtendOpen qpn fdeps fdefs s = extendOpen qpn gs s where -- Qualify all package names qfdeps = qualifyDeps (qualifyOptions s) qpn fdeps -- Introduce all package flags qfdefs = L.map (\ (fn, b) -> Flagged (FN qpn fn) b [] []) $ M.toList fdefs -- Combine new package and flag goals gs = qfdefs ++ qfdeps -- NOTE: -- -- In the expression @qfdefs ++ qfdeps@ above, flags occur potentially -- multiple times, both via the flag declaration and via dependencies. -- | Datatype that encodes what to build next data BuildType = Goals -- ^ build a goal choice node | OneGoal OpenGoal -- ^ build a node for this goal | Instance QPN PInfo -- ^ build a tree for a concrete instance build :: Linker BuildState -> Tree () QGoalReason build = ana go where go :: Linker BuildState -> TreeF () QGoalReason (Linker BuildState) go s = addLinking (linkingState s) $ addChildren (buildState s) addChildren :: BuildState -> TreeF () QGoalReason BuildState -- If we have a choice between many goals, we just record the choice in -- the tree. We select each open goal in turn, and before we descend, remove -- it from the queue of open goals. addChildren bs@(BS { rdeps = rdm, open = gs, next = Goals }) | L.null gs = DoneF rdm () | otherwise = GoalChoiceF rdm $ P.fromList $ L.map (\ (g, gs') -> (close g, bs { next = OneGoal g, open = gs' })) $ splits gs -- If we have already picked a goal, then the choice depends on the kind -- of goal. -- -- For a package, we look up the instances available in the global info, -- and then handle each instance in turn. addChildren bs@(BS { rdeps = rdm, index = idx, next = OneGoal (PkgGoal qpn@(Q _ pn) gr) }) = case M.lookup pn idx of Nothing -> FailF (varToConflictSet (P qpn) `CS.union` goalReasonToConflictSetWithConflict qpn gr) UnknownPackage Just pis -> PChoiceF qpn rdm gr (W.fromList (L.map (\ (i, info) -> ([], POption i Nothing, bs { next = Instance qpn info })) (M.toList pis))) -- TODO: data structure conversion is rather ugly here -- For a flag, we create only two subtrees, and we create them in the order -- that is indicated by the flag default. addChildren bs@(BS { rdeps = rdm, next = OneGoal (FlagGoal qfn@(FN qpn _) (FInfo b m w) t f gr) }) = FChoiceF qfn rdm gr weak m b (W.fromList [([if b then 0 else 1], True, (extendOpen qpn t bs) { next = Goals }), ([if b then 1 else 0], False, (extendOpen qpn f bs) { next = Goals })]) where trivial = L.null t && L.null f weak = WeakOrTrivial $ unWeakOrTrivial w || trivial -- For a stanza, we also create only two subtrees. The order is initially -- False, True. This can be changed later by constraints (force enabling -- the stanza by replacing the False branch with failure) or preferences -- (try enabling the stanza if possible by moving the True branch first). addChildren bs@(BS { rdeps = rdm, next = OneGoal (StanzaGoal qsn@(SN qpn _) t gr) }) = SChoiceF qsn rdm gr trivial (W.fromList [([0], False, bs { next = Goals }), ([1], True, (extendOpen qpn t bs) { next = Goals })]) where trivial = WeakOrTrivial (L.null t) -- For a particular instance, we change the state: we update the scope, -- and furthermore we update the set of goals. -- -- TODO: We could inline this above. addChildren bs@(BS { next = Instance qpn (PInfo fdeps _ fdefs _) }) = addChildren ((scopedExtendOpen qpn fdeps fdefs bs) { next = Goals }) {------------------------------------------------------------------------------- Add linking -------------------------------------------------------------------------------} -- | Introduce link nodes into the tree -- -- Linking is a phase that adapts package choice nodes and adds the option to -- link wherever appropriate: Package goals are called "related" if they are for -- the same instance of the same package (but have different prefixes). A link -- option is available in a package choice node whenever we can choose an -- instance that has already been chosen for a related goal at a higher position -- in the tree. We only create link options for related goals that are not -- themselves linked, because the choice to link to a linked goal is the same as -- the choice to link to the target of that goal's linking. -- -- The code here proceeds by maintaining a finite map recording choices that -- have been made at higher positions in the tree. For each pair of package name -- and instance, it stores the prefixes at which we have made a choice for this -- package instance. Whenever we make an unlinked choice, we extend the map. -- Whenever we find a choice, we look into the map in order to find out what -- link options we have to add. -- -- A separate tree traversal would be simpler. However, 'addLinking' creates -- linked nodes from existing unlinked nodes, which leads to sharing between the -- nodes. If we copied the nodes when they were full trees of type -- 'Tree () QGoalReason', then the sharing would cause a space leak during -- exploration of the tree. Instead, we only copy the 'BuildState', which is -- relatively small, while the tree is being constructed. See -- https://github.com/haskell/cabal/issues/2899 addLinking :: LinkingState -> TreeF () c a -> TreeF () c (Linker a) -- The only nodes of interest are package nodes addLinking ls (PChoiceF qpn@(Q pp pn) rdm gr cs) = let linkedCs = fmap (\bs -> Linker bs ls) $ W.fromList $ concatMap (linkChoices ls qpn) (W.toList cs) unlinkedCs = W.mapWithKey goP cs allCs = unlinkedCs `W.union` linkedCs -- Recurse underneath package choices. Here we just need to make sure -- that we record the package choice so that it is available below goP :: POption -> a -> Linker a goP (POption i Nothing) bs = Linker bs $ M.insertWith (++) (pn, i) [pp] ls goP _ _ = alreadyLinked in PChoiceF qpn rdm gr allCs addLinking ls t = fmap (\bs -> Linker bs ls) t linkChoices :: forall a w . LinkingState -> QPN -> (w, POption, a) -> [(w, POption, a)] linkChoices related (Q _pp pn) (weight, POption i Nothing, subtree) = L.map aux (M.findWithDefault [] (pn, i) related) where aux :: PackagePath -> (w, POption, a) aux pp = (weight, POption i (Just pp), subtree) linkChoices _ _ (_, POption _ (Just _), _) = alreadyLinked alreadyLinked :: a alreadyLinked = error "addLinking called on tree that already contains linked nodes" ------------------------------------------------------------------------------- -- | Interface to the tree builder. Just takes an index and a list of package names, -- and computes the initial state and then the tree from there. buildTree :: Index -> IndependentGoals -> [PN] -> Tree () QGoalReason buildTree idx (IndependentGoals ind) igs = build Linker { buildState = BS { index = idx , rdeps = M.fromList (L.map (\ qpn -> (qpn, [])) qpns) , open = L.map topLevelGoal qpns , next = Goals , qualifyOptions = defaultQualifyOptions idx } , linkingState = M.empty } where topLevelGoal qpn = PkgGoal qpn UserGoal qpns | ind = L.map makeIndependent igs | otherwise = L.map (Q (PackagePath DefaultNamespace QualToplevel)) igs {------------------------------------------------------------------------------- Goals -------------------------------------------------------------------------------} -- | Information needed about a dependency before it is converted into a Goal. data OpenGoal = FlagGoal (FN QPN) FInfo (FlaggedDeps QPN) (FlaggedDeps QPN) QGoalReason | StanzaGoal (SN QPN) (FlaggedDeps QPN) QGoalReason | PkgGoal QPN QGoalReason -- | Closes a goal, i.e., removes all the extraneous information that we -- need only during the build phase. close :: OpenGoal -> Goal QPN close (FlagGoal qfn _ _ _ gr) = Goal (F qfn) gr close (StanzaGoal qsn _ gr) = Goal (S qsn) gr close (PkgGoal qpn gr) = Goal (P qpn) gr {------------------------------------------------------------------------------- Auxiliary -------------------------------------------------------------------------------} -- | Pairs each element of a list with the list resulting from removal of that -- element from the original list. splits :: [a] -> [(a, [a])] splits = go id where go :: ([a] -> [a]) -> [a] -> [(a, [a])] go _ [] = [] go f (x : xs) = (x, f xs) : go (f . (x :)) xs cabal-install-solver-3.8.1.0/src/Distribution/Solver/Modular/Configured.hs0000644000000000000000000000073607346545000024642 0ustar0000000000000000module Distribution.Solver.Modular.Configured ( CP(..) ) where import Distribution.PackageDescription (FlagAssignment) import Distribution.Solver.Modular.Package import Distribution.Solver.Types.ComponentDeps (ComponentDeps) import Distribution.Solver.Types.OptionalStanza -- | A configured package is a package instance together with -- a flag assignment and complete dependencies. data CP qpn = CP (PI qpn) FlagAssignment OptionalStanzaSet (ComponentDeps [PI qpn]) cabal-install-solver-3.8.1.0/src/Distribution/Solver/Modular/ConfiguredConversion.hs0000644000000000000000000000561307346545000026707 0ustar0000000000000000module Distribution.Solver.Modular.ConfiguredConversion ( convCP ) where import Data.Maybe import Prelude hiding (pi) import Data.Either (partitionEithers) import Distribution.Package (UnitId, packageId) import qualified Distribution.Simple.PackageIndex as SI import Distribution.Solver.Modular.Configured import Distribution.Solver.Modular.Package import Distribution.Solver.Types.ComponentDeps (ComponentDeps) import qualified Distribution.Solver.Types.PackageIndex as CI import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.ResolverPackage import Distribution.Solver.Types.SolverId import Distribution.Solver.Types.SolverPackage import Distribution.Solver.Types.InstSolverPackage import Distribution.Solver.Types.SourcePackage -- | Converts from the solver specific result @CP QPN@ into -- a 'ResolverPackage', which can then be converted into -- the install plan. convCP :: SI.InstalledPackageIndex -> CI.PackageIndex (SourcePackage loc) -> CP QPN -> ResolverPackage loc convCP iidx sidx (CP qpi fa es ds) = case convPI qpi of Left pi -> PreExisting $ InstSolverPackage { instSolverPkgIPI = fromJust $ SI.lookupUnitId iidx pi, instSolverPkgLibDeps = fmap fst ds', instSolverPkgExeDeps = fmap snd ds' } Right pi -> Configured $ SolverPackage { solverPkgSource = srcpkg, solverPkgFlags = fa, solverPkgStanzas = es, solverPkgLibDeps = fmap fst ds', solverPkgExeDeps = fmap snd ds' } where srcpkg = fromMaybe (error "convCP: lookupPackageId failed") $ CI.lookupPackageId sidx pi where ds' :: ComponentDeps ([SolverId] {- lib -}, [SolverId] {- exe -}) ds' = fmap (partitionEithers . map convConfId) ds convPI :: PI QPN -> Either UnitId PackageId convPI (PI _ (I _ (Inst pi))) = Left pi convPI pi = Right (packageId (either id id (convConfId pi))) convConfId :: PI QPN -> Either SolverId {- is lib -} SolverId {- is exe -} convConfId (PI (Q (PackagePath _ q) pn) (I v loc)) = case loc of Inst pi -> Left (PreExistingId sourceId pi) _otherwise | QualExe _ pn' <- q -- NB: the dependencies of the executable are also -- qualified. So the way to tell if this is an executable -- dependency is to make sure the qualifier is pointing -- at the actual thing. Fortunately for us, I was -- silly and didn't allow arbitrarily nested build-tools -- dependencies, so a shallow check works. , pn == pn' -> Right (PlannedId sourceId) | otherwise -> Left (PlannedId sourceId) where sourceId = PackageIdentifier pn v cabal-install-solver-3.8.1.0/src/Distribution/Solver/Modular/ConflictSet.hs0000644000000000000000000001574207346545000024775 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifdef DEBUG_CONFLICT_SETS {-# LANGUAGE ImplicitParams #-} #endif -- | Conflict sets -- -- Intended for double import -- -- > import Distribution.Solver.Modular.ConflictSet (ConflictSet) -- > import qualified Distribution.Solver.Modular.ConflictSet as CS module Distribution.Solver.Modular.ConflictSet ( ConflictSet -- opaque , Conflict(..) , ConflictMap , OrderedVersionRange(..) #ifdef DEBUG_CONFLICT_SETS , conflictSetOrigin #endif , showConflictSet , showCSSortedByFrequency , showCSWithFrequency -- Set-like operations , toSet , toList , union , unions , insert , delete , empty , singleton , singletonWithConflict , size , member , lookup , filter , fromList ) where import Prelude hiding (lookup) import Data.List (intercalate, sortBy) import Data.Map (Map) import Data.Set (Set) import Data.Function (on) 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 { -- | 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 } deriving (Show) -- | More detailed information about how a conflict set variable caused a -- conflict. This information can be used to determine whether a second value -- for that variable would lead to the same conflict. -- -- TODO: Handle dependencies under flags or stanzas. data Conflict = -- | The conflict set variable represents a package which depends on the -- specified problematic package. For example, the conflict set entry -- '(P x, GoalConflict y)' means that package x introduced package y, and y -- led to a conflict. GoalConflict QPN -- | The conflict set variable represents a package with a constraint that -- excluded the specified package and version. For example, the conflict set -- entry '(P x, VersionConstraintConflict y (mkVersion [2, 0]))' means that -- package x's constraint on y excluded y-2.0. | VersionConstraintConflict QPN Ver -- | The conflict set variable represents a package that was excluded by a -- constraint from the specified package. For example, the conflict set -- entry '(P x, VersionConflict y (orLaterVersion (mkVersion [2, 0])))' -- means that package y's constraint 'x >= 2.0' excluded some version of x. | VersionConflict QPN OrderedVersionRange -- | Any other conflict. | OtherConflict deriving (Eq, Ord, Show) -- | Version range with an 'Ord' instance. newtype OrderedVersionRange = OrderedVersionRange VR deriving (Eq, Show) -- TODO: Avoid converting the version ranges to strings. 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 showCSSortedByFrequency :: ConflictMap -> ConflictSet -> String showCSSortedByFrequency = showCS False showCSWithFrequency :: ConflictMap -> ConflictSet -> String showCSWithFrequency = showCS True showCS :: Bool -> ConflictMap -> ConflictSet -> String showCS showCount cm = intercalate ", " . map showWithFrequency . indexByFrequency where indexByFrequency = sortBy (flip compare `on` snd) . map (\c -> (c, M.lookup c cm)) . toList showWithFrequency (conflict, maybeFrequency) = case maybeFrequency of Just frequency | showCount -> showVar conflict ++ " (" ++ show frequency ++ ")" _ -> showVar conflict {------------------------------------------------------------------------------- Set-like operations -------------------------------------------------------------------------------} toSet :: ConflictSet -> Set (Var QPN) toSet = M.keysSet . conflictSetToMap toList :: ConflictSet -> [Var QPN] toList = M.keys . conflictSetToMap union :: #ifdef DEBUG_CONFLICT_SETS (?loc :: CallStack) => #endif 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 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 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 delete var cs = CS { conflictSetToMap = M.delete var (conflictSetToMap cs) } empty :: #ifdef DEBUG_CONFLICT_SETS (?loc :: CallStack) => #endif 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 = singletonWithConflict var OtherConflict singletonWithConflict :: #ifdef DEBUG_CONFLICT_SETS (?loc :: CallStack) => #endif 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 size = M.size . conflictSetToMap member :: Var QPN -> ConflictSet -> Bool member var = M.member var . conflictSetToMap 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 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 cabal-install-solver-3.8.1.0/src/Distribution/Solver/Modular/Cycles.hs0000644000000000000000000001174207346545000023776 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} module Distribution.Solver.Modular.Cycles ( detectCyclesPhase ) where import Prelude hiding (cycle) import qualified Data.Map as M import qualified Data.Set as S import qualified Distribution.Compat.Graph as G import Distribution.Simple.Utils (ordNub) import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Tree import qualified Distribution.Solver.Modular.ConflictSet as CS import Distribution.Solver.Types.ComponentDeps (Component) import Distribution.Solver.Types.PackagePath -- | Find and reject any nodes with cyclic dependencies detectCyclesPhase :: Tree d c -> Tree d c detectCyclesPhase = go where -- Only check children of choice nodes. go :: Tree d c -> Tree d c go (PChoice qpn rdm gr cs) = PChoice qpn rdm gr $ fmap (checkChild qpn) (fmap go cs) go (FChoice qfn@(FN qpn _) rdm gr w m d cs) = FChoice qfn rdm gr w m d $ fmap (checkChild qpn) (fmap go cs) go (SChoice qsn@(SN qpn _) rdm gr w cs) = SChoice qsn rdm gr w $ fmap (checkChild qpn) (fmap go cs) go (GoalChoice rdm cs) = GoalChoice rdm (fmap go cs) go x@(Fail _ _) = x go x@(Done _ _) = x checkChild :: QPN -> Tree d c -> Tree d c checkChild qpn x@(PChoice _ rdm _ _) = failIfCycle qpn rdm x checkChild qpn x@(FChoice _ rdm _ _ _ _ _) = failIfCycle qpn rdm x checkChild qpn x@(SChoice _ rdm _ _ _) = failIfCycle qpn rdm x checkChild qpn x@(GoalChoice rdm _) = failIfCycle qpn rdm x checkChild _ x@(Fail _ _) = x checkChild qpn x@(Done rdm _) = failIfCycle qpn rdm x failIfCycle :: QPN -> RevDepMap -> Tree d c -> Tree d c failIfCycle qpn rdm x = case findCycles qpn rdm of Nothing -> x Just relSet -> Fail relSet CyclicDependencies -- | Given the reverse dependency map from a node in the tree, check -- if the solution is cyclic. If it is, return the conflict set containing -- all decisions that could potentially break the cycle. -- -- TODO: The conflict set should also contain flag and stanza variables. findCycles :: QPN -> RevDepMap -> Maybe ConflictSet findCycles pkg rdm = -- This function has two parts: a faster cycle check that is called at every -- step and a slower calculation of the conflict set. -- -- 'hasCycle' checks for cycles incrementally by only looking for cycles -- containing the current package, 'pkg'. It searches for cycles in the -- 'RevDepMap', which is the data structure used to store reverse -- dependencies in the search tree. We store the reverse dependencies in a -- map, because Data.Map is smaller and/or has better sharing than -- Distribution.Compat.Graph. -- -- If there is a cycle, we call G.cycles to find a strongly connected -- component. Then we choose one cycle from the component to use for the -- conflict set. Choosing only one cycle can lead to a smaller conflict set, -- such as when a choice to enable testing introduces many cycles at once. -- In that case, all cycles contain the current package and are in one large -- strongly connected component. -- if hasCycle then let scc :: G.Graph RevDepMapNode scc = case G.cycles $ revDepMapToGraph rdm of [] -> findCyclesError "cannot find a strongly connected component" c : _ -> G.fromDistinctList c next :: QPN -> QPN next p = case G.neighbors scc p of Just (n : _) -> G.nodeKey n _ -> findCyclesError "cannot find next node in the cycle" -- This function also assumes that all cycles contain 'pkg'. oneCycle :: [QPN] oneCycle = case iterate next pkg of [] -> findCyclesError "empty cycle" x : xs -> x : takeWhile (/= x) xs in Just $ CS.fromList $ map P oneCycle else Nothing where hasCycle :: Bool hasCycle = pkg `S.member` closure (neighbors pkg) closure :: [QPN] -> S.Set QPN closure = foldl go S.empty where go :: S.Set QPN -> QPN -> S.Set QPN go s x = if x `S.member` s then s else foldl go (S.insert x s) $ neighbors x neighbors :: QPN -> [QPN] neighbors x = case x `M.lookup` rdm of Nothing -> findCyclesError "cannot find node" Just xs -> map snd xs findCyclesError = error . ("Distribution.Solver.Modular.Cycles.findCycles: " ++) data RevDepMapNode = RevDepMapNode QPN [(Component, QPN)] instance G.IsNode RevDepMapNode where type Key RevDepMapNode = QPN nodeKey (RevDepMapNode qpn _) = qpn nodeNeighbors (RevDepMapNode _ ns) = ordNub $ map snd ns revDepMapToGraph :: RevDepMap -> G.Graph RevDepMapNode revDepMapToGraph rdm = G.fromDistinctList [RevDepMapNode qpn ns | (qpn, ns) <- M.toList rdm] cabal-install-solver-3.8.1.0/src/Distribution/Solver/Modular/Dependency.hs0000644000000000000000000003571607346545000024641 0ustar0000000000000000{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE RecordWildCards #-} module Distribution.Solver.Modular.Dependency ( -- * Variables Var(..) , showVar , varPN -- * Conflict sets , ConflictSet , ConflictMap , CS.showConflictSet -- * Constrained instances , CI(..) -- * Flagged dependencies , FlaggedDeps , FlaggedDep(..) , LDep(..) , Dep(..) , PkgComponent(..) , ExposedComponent(..) , DependencyReason(..) , showDependencyReason , flattenFlaggedDeps , QualifyOptions(..) , qualifyDeps , unqualifyDeps -- * Reverse dependency map , RevDepMap -- * Goals , Goal(..) , GoalReason(..) , QGoalReason , goalToVar , varToConflictSet , goalReasonToConflictSet , goalReasonToConflictSetWithConflict , dependencyReasonToConflictSet , dependencyReasonToConflictSetWithVersionConstraintConflict , dependencyReasonToConflictSetWithVersionConflict ) where import Prelude () import qualified Data.Map as M import qualified Data.Set as S import Distribution.Solver.Compat.Prelude hiding (pi) import Language.Haskell.Extension (Extension(..), Language(..)) import Distribution.Solver.Modular.ConflictSet (ConflictSet, ConflictMap) import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Package import Distribution.Solver.Modular.Var import Distribution.Solver.Modular.Version import qualified Distribution.Solver.Modular.ConflictSet as CS import Distribution.Solver.Types.ComponentDeps (Component(..)) import Distribution.Solver.Types.PackagePath import Distribution.Types.LibraryName import Distribution.Types.PkgconfigVersionRange import Distribution.Types.UnqualComponentName {------------------------------------------------------------------------------- Constrained instances -------------------------------------------------------------------------------} -- | Constrained instance. It represents the allowed instances for a package, -- which can be either a fixed instance or a version range. data CI = Fixed I | Constrained VR deriving (Eq, Show) {------------------------------------------------------------------------------- Flagged dependencies -------------------------------------------------------------------------------} -- | Flagged dependencies -- -- 'FlaggedDeps' is the modular solver's view of a packages dependencies: -- rather than having the dependencies indexed by component, each dependency -- defines what component it is in. -- -- Note that each dependency is associated with a Component. We must know what -- component the dependencies belong to, or else we won't be able to construct -- fine-grained reverse dependencies. type FlaggedDeps qpn = [FlaggedDep qpn] -- | Flagged dependencies can either be plain dependency constraints, -- or flag-dependent dependency trees. data FlaggedDep qpn = -- | Dependencies which are conditional on a flag choice. Flagged (FN qpn) FInfo (TrueFlaggedDeps qpn) (FalseFlaggedDeps qpn) -- | Dependencies which are conditional on whether or not a stanza -- (e.g., a test suite or benchmark) is enabled. | Stanza (SN qpn) (TrueFlaggedDeps qpn) -- | Dependencies which are always enabled, for the component 'comp'. | Simple (LDep qpn) Component -- | Conservatively flatten out flagged dependencies -- -- NOTE: We do not filter out duplicates. flattenFlaggedDeps :: FlaggedDeps qpn -> [(LDep qpn, Component)] flattenFlaggedDeps = concatMap aux where aux :: FlaggedDep qpn -> [(LDep qpn, Component)] aux (Flagged _ _ t f) = flattenFlaggedDeps t ++ flattenFlaggedDeps f aux (Stanza _ t) = flattenFlaggedDeps t aux (Simple d c) = [(d, c)] type TrueFlaggedDeps qpn = FlaggedDeps qpn type FalseFlaggedDeps qpn = FlaggedDeps qpn -- | A 'Dep' labeled with the reason it was introduced. -- -- 'LDep' intentionally has no 'Functor' instance because the type variable -- is used both to record the dependencies as well as who's doing the -- depending; having a 'Functor' instance makes bugs where we don't distinguish -- these two far too likely. (By rights 'LDep' ought to have two type variables.) data LDep qpn = LDep (DependencyReason qpn) (Dep qpn) -- | A dependency (constraint) associates a package name with a constrained -- instance. It can also represent other types of dependencies, such as -- dependencies on language extensions. data Dep qpn = Dep (PkgComponent qpn) CI -- ^ dependency on a package component | Ext Extension -- ^ dependency on a language extension | Lang Language -- ^ dependency on a language version | Pkg PkgconfigName PkgconfigVersionRange -- ^ dependency on a pkg-config package deriving Functor -- | An exposed component within a package. This type is used to represent -- build-depends and build-tool-depends dependencies. data PkgComponent qpn = PkgComponent qpn ExposedComponent deriving (Eq, Ord, Functor, Show) -- | A component that can be depended upon by another package, i.e., a library -- or an executable. data ExposedComponent = ExposedLib LibraryName | ExposedExe UnqualComponentName deriving (Eq, Ord, Show) -- | The reason that a dependency is active. It identifies the package and any -- flag and stanza choices that introduced the dependency. It contains -- everything needed for creating ConflictSets or describing conflicts in solver -- log messages. data DependencyReason qpn = DependencyReason qpn (Map Flag FlagValue) (S.Set Stanza) deriving (Functor, Eq, Show) -- | Print the reason that a dependency was introduced. showDependencyReason :: DependencyReason QPN -> String showDependencyReason (DependencyReason qpn flags stanzas) = intercalate " " $ showQPN qpn : map (uncurry showFlagValue) (M.toList flags) ++ map (\s -> showSBool s True) (S.toList stanzas) -- | Options for goal qualification (used in 'qualifyDeps') -- -- See also 'defaultQualifyOptions' data QualifyOptions = QO { -- | Do we have a version of base relying on another version of base? qoBaseShim :: Bool -- Should dependencies of the setup script be treated as independent? , qoSetupIndependent :: Bool } deriving Show -- | Apply built-in rules for package qualifiers -- -- Although the behaviour of 'qualifyDeps' depends on the 'QualifyOptions', -- it is important that these 'QualifyOptions' are _static_. Qualification -- does NOT depend on flag assignment; in other words, it behaves the same no -- matter which choices the solver makes (modulo the global 'QualifyOptions'); -- we rely on this in 'linkDeps' (see comment there). -- -- NOTE: It's the _dependencies_ of a package that may or may not be independent -- from the package itself. Package flag choices must of course be consistent. qualifyDeps :: QualifyOptions -> QPN -> FlaggedDeps PN -> FlaggedDeps QPN qualifyDeps QO{..} (Q pp@(PackagePath ns q) pn) = go where go :: FlaggedDeps PN -> FlaggedDeps QPN go = map go1 go1 :: FlaggedDep PN -> FlaggedDep QPN go1 (Flagged fn nfo t f) = Flagged (fmap (Q pp) fn) nfo (go t) (go f) go1 (Stanza sn t) = Stanza (fmap (Q pp) sn) (go t) go1 (Simple dep comp) = Simple (goLDep dep comp) comp -- Suppose package B has a setup dependency on package A. -- This will be recorded as something like -- -- > LDep (DependencyReason "B") (Dep (PkgComponent "A" (ExposedLib LMainLibName)) (Constrained AnyVersion)) -- -- Observe that when we qualify this dependency, we need to turn that -- @"A"@ into @"B-setup.A"@, but we should not apply that same qualifier -- to the DependencyReason. goLDep :: LDep PN -> Component -> LDep QPN goLDep (LDep dr dep) comp = LDep (fmap (Q pp) dr) (goD dep comp) goD :: Dep PN -> Component -> Dep QPN goD (Ext ext) _ = Ext ext goD (Lang lang) _ = Lang lang goD (Pkg pkn vr) _ = Pkg pkn vr goD (Dep dep@(PkgComponent qpn (ExposedExe _)) ci) _ = Dep (Q (PackagePath ns (QualExe pn qpn)) <$> dep) ci goD (Dep dep@(PkgComponent qpn (ExposedLib _)) ci) comp | qBase qpn = Dep (Q (PackagePath ns (QualBase pn)) <$> dep) ci | qSetup comp = Dep (Q (PackagePath ns (QualSetup pn)) <$> dep) ci | otherwise = Dep (Q (PackagePath ns inheritedQ ) <$> dep) ci -- If P has a setup dependency on Q, and Q has a regular dependency on R, then -- we say that the 'Setup' qualifier is inherited: P has an (indirect) setup -- dependency on R. We do not do this for the base qualifier however. -- -- The inherited qualifier is only used for regular dependencies; for setup -- and base dependencies we override the existing qualifier. See #3160 for -- a detailed discussion. inheritedQ :: Qualifier inheritedQ = case q of QualSetup _ -> q QualExe _ _ -> q QualToplevel -> q QualBase _ -> QualToplevel -- Should we qualify this goal with the 'Base' package path? qBase :: PN -> Bool qBase dep = qoBaseShim && unPackageName dep == "base" -- Should we qualify this goal with the 'Setup' package path? qSetup :: Component -> Bool qSetup comp = qoSetupIndependent && comp == ComponentSetup -- | Remove qualifiers from set of dependencies -- -- This is used during link validation: when we link package @Q.A@ to @Q'.A@, -- then all dependencies @Q.B@ need to be linked to @Q'.B@. In order to compute -- what to link these dependencies to, we need to requalify @Q.B@ to become -- @Q'.B@; we do this by first removing all qualifiers and then calling -- 'qualifyDeps' again. unqualifyDeps :: FlaggedDeps QPN -> FlaggedDeps PN unqualifyDeps = go where go :: FlaggedDeps QPN -> FlaggedDeps PN go = map go1 go1 :: FlaggedDep QPN -> FlaggedDep PN go1 (Flagged fn nfo t f) = Flagged (fmap unq fn) nfo (go t) (go f) go1 (Stanza sn t) = Stanza (fmap unq sn) (go t) go1 (Simple dep comp) = Simple (goLDep dep) comp goLDep :: LDep QPN -> LDep PN goLDep (LDep dr dep) = LDep (fmap unq dr) (fmap unq dep) unq :: QPN -> PN unq (Q _ pn) = pn {------------------------------------------------------------------------------- Reverse dependency map -------------------------------------------------------------------------------} -- | A map containing reverse dependencies between qualified -- package names. type RevDepMap = Map QPN [(Component, QPN)] {------------------------------------------------------------------------------- Goals -------------------------------------------------------------------------------} -- | A goal is just a solver variable paired with a reason. -- The reason is only used for tracing. data Goal qpn = Goal (Var qpn) (GoalReason qpn) deriving (Eq, Show, Functor) -- | Reason why a goal is being added to a goal set. data GoalReason qpn = UserGoal -- introduced by a build target | DependencyGoal (DependencyReason qpn) -- introduced by a package deriving (Eq, Show, Functor) type QGoalReason = GoalReason QPN goalToVar :: Goal a -> Var a goalToVar (Goal v _) = v -- | Compute a singleton conflict set from a 'Var' varToConflictSet :: Var QPN -> ConflictSet varToConflictSet = CS.singleton -- | Convert a 'GoalReason' to a 'ConflictSet' that can be used when the goal -- leads to a conflict. goalReasonToConflictSet :: GoalReason QPN -> ConflictSet goalReasonToConflictSet UserGoal = CS.empty goalReasonToConflictSet (DependencyGoal dr) = dependencyReasonToConflictSet dr -- | Convert a 'GoalReason' to a 'ConflictSet' containing the reason that the -- conflict occurred, namely the conflict set variables caused a conflict by -- introducing the given package goal. See the documentation for 'GoalConflict'. -- -- This function currently only specifies the reason for the conflict in the -- simple case where the 'GoalReason' does not involve any flags or stanzas. -- Otherwise, it falls back to calling 'goalReasonToConflictSet'. goalReasonToConflictSetWithConflict :: QPN -> GoalReason QPN -> ConflictSet goalReasonToConflictSetWithConflict goal (DependencyGoal (DependencyReason qpn flags stanzas)) | M.null flags && S.null stanzas = CS.singletonWithConflict (P qpn) $ CS.GoalConflict goal goalReasonToConflictSetWithConflict _ gr = goalReasonToConflictSet gr -- | This function returns the solver variables responsible for the dependency. -- It drops the values chosen for flag and stanza variables, which are only -- needed for log messages. dependencyReasonToConflictSet :: DependencyReason QPN -> ConflictSet dependencyReasonToConflictSet (DependencyReason qpn flags stanzas) = CS.fromList $ P qpn : flagVars ++ map stanzaToVar (S.toList stanzas) where -- Filter out any flags that introduced the dependency with both values. -- They don't need to be included in the conflict set, because changing the -- flag value can't remove the dependency. flagVars :: [Var QPN] flagVars = [F (FN qpn fn) | (fn, fv) <- M.toList flags, fv /= FlagBoth] stanzaToVar :: Stanza -> Var QPN stanzaToVar = S . SN qpn -- | Convert a 'DependencyReason' to a 'ConflictSet' specifying that the -- conflict occurred because the conflict set variables introduced a problematic -- version constraint. See the documentation for 'VersionConstraintConflict'. -- -- This function currently only specifies the reason for the conflict in the -- simple case where the 'DependencyReason' does not involve any flags or -- stanzas. Otherwise, it falls back to calling 'dependencyReasonToConflictSet'. dependencyReasonToConflictSetWithVersionConstraintConflict :: QPN -> Ver -> DependencyReason QPN -> ConflictSet dependencyReasonToConflictSetWithVersionConstraintConflict dependency excludedVersion dr@(DependencyReason qpn flags stanzas) | M.null flags && S.null stanzas = CS.singletonWithConflict (P qpn) $ CS.VersionConstraintConflict dependency excludedVersion | otherwise = dependencyReasonToConflictSet dr -- | Convert a 'DependencyReason' to a 'ConflictSet' specifying that the -- conflict occurred because the conflict set variables introduced a version of -- a package that was excluded by a version constraint. See the documentation -- for 'VersionConflict'. -- -- This function currently only specifies the reason for the conflict in the -- simple case where the 'DependencyReason' does not involve any flags or -- stanzas. Otherwise, it falls back to calling 'dependencyReasonToConflictSet'. dependencyReasonToConflictSetWithVersionConflict :: QPN -> CS.OrderedVersionRange -> DependencyReason QPN -> ConflictSet dependencyReasonToConflictSetWithVersionConflict pkgWithVersionConstraint constraint dr@(DependencyReason qpn flags stanzas) | M.null flags && S.null stanzas = CS.singletonWithConflict (P qpn) $ CS.VersionConflict pkgWithVersionConstraint constraint | otherwise = dependencyReasonToConflictSet dr cabal-install-solver-3.8.1.0/src/Distribution/Solver/Modular/Explore.hs0000644000000000000000000004235707346545000024200 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} module Distribution.Solver.Modular.Explore (backjumpAndExplore) where import Distribution.Solver.Compat.Prelude import Prelude () import qualified Distribution.Solver.Types.Progress as P import qualified Data.List as L (foldl') import qualified Data.Map.Strict as M import qualified Data.Set as S import Distribution.Simple.Setup (asBool) import Distribution.Solver.Modular.Assignment import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Index import Distribution.Solver.Modular.Log import Distribution.Solver.Modular.Message import Distribution.Solver.Modular.Package import qualified Distribution.Solver.Modular.PSQ as P import qualified Distribution.Solver.Modular.ConflictSet as CS import Distribution.Solver.Modular.RetryLog import Distribution.Solver.Modular.Tree import Distribution.Solver.Modular.Version import qualified Distribution.Solver.Modular.WeightedPSQ as W import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.Settings (CountConflicts(..), EnableBackjumping(..), FineGrainedConflicts(..)) import Distribution.Types.VersionRange (anyVersion) -- | This function takes the variable we're currently considering, a -- last conflict set and a list of children's logs. Each log yields -- either a solution or a conflict set. The result is a combined log for -- the parent node that has explored a prefix of the children. -- -- We can stop traversing the children's logs if we find an individual -- conflict set that does not contain the current variable. In this -- case, we can just lift the conflict set to the current level, -- because the current level cannot possibly have contributed to this -- conflict, so no other choice at the current level would avoid the -- conflict. -- -- If any of the children might contain a successful solution, we can -- return it immediately. If all children contain conflict sets, we can -- take the union as the combined conflict set. -- -- The last conflict set corresponds to the justification that we -- have to choose this goal at all. There is a reason why we have -- introduced the goal in the first place, and this reason is in conflict -- with the (virtual) option not to choose anything for the current -- variable. See also the comments for 'avoidSet'. -- -- We can also skip a child if it does not resolve any of the conflicts paired -- with the current variable in the previous child's conflict set. 'backjump' -- takes a function to determine whether a child can be skipped. If the child -- can be skipped, the function returns a new conflict set to be merged with the -- previous conflict set. -- backjump :: forall w k a . Maybe Int -> EnableBackjumping -> FineGrainedConflicts -> (k -> S.Set CS.Conflict -> Maybe ConflictSet) -- ^ Function that determines whether the given choice could resolve -- the given conflict. It indicates false by returning 'Just', -- with the new conflicts to be added to the conflict set. -> (k -> ConflictSet -> ExploreState -> ConflictSetLog a) -- ^ Function that logs the given choice that was skipped. -> Var QPN -- ^ The current variable. -> ConflictSet -- ^ Conflict set representing the reason that the goal -- was introduced. -> W.WeightedPSQ w k (ExploreState -> ConflictSetLog a) -- ^ List of children's logs. -> ExploreState -> ConflictSetLog a backjump mbj enableBj fineGrainedConflicts couldResolveConflicts logSkippedChoice var lastCS xs = foldr combine avoidGoal [(k, v) | (_, k, v) <- W.toList xs] CS.empty Nothing where combine :: (k, ExploreState -> ConflictSetLog a) -> (ConflictSet -> Maybe ConflictSet -> ExploreState -> ConflictSetLog a) -> ConflictSet -> Maybe ConflictSet -> ExploreState -> ConflictSetLog a combine (k, x) f csAcc mPreviousCS es = case (asBool fineGrainedConflicts, mPreviousCS) of (True, Just previousCS) -> case CS.lookup var previousCS of Just conflicts -> case couldResolveConflicts k conflicts of Nothing -> retryNoSolution (x es) next Just newConflicts -> skipChoice (previousCS `CS.union` newConflicts) _ -> skipChoice previousCS _ -> retryNoSolution (x es) next where next :: ConflictSet -> ExploreState -> ConflictSetLog a next !cs es' = if asBool enableBj && not (var `CS.member` cs) then skipLoggingBackjump cs es' else f (csAcc `CS.union` cs) (Just cs) es' -- This function is for skipping the choice when it cannot resolve any -- of the previous conflicts. skipChoice :: ConflictSet -> ConflictSetLog a skipChoice newCS = retryNoSolution (logSkippedChoice k newCS es) $ \cs' es' -> f (csAcc `CS.union` cs') (Just cs') $ -- Update the conflict map with the conflict set, to make up for -- skipping the whole subtree. es' { esConflictMap = updateCM cs' (esConflictMap es') } -- This function represents the option to not choose a value for this goal. avoidGoal :: ConflictSet -> Maybe ConflictSet -> ExploreState -> ConflictSetLog a avoidGoal cs _mPreviousCS !es = logBackjump mbj (cs `CS.union` lastCS) $ -- Use 'lastCS' below instead of 'cs' since we do not want to -- double-count the additionally accumulated conflicts. es { esConflictMap = updateCM lastCS (esConflictMap es) } -- The solver does not count or log backjumps at levels where the conflict -- set does not contain the current variable. Otherwise, there would be many -- consecutive log messages about backjumping with the same conflict set. skipLoggingBackjump :: ConflictSet -> ExploreState -> ConflictSetLog a skipLoggingBackjump cs es = fromProgress $ P.Fail (NoSolution cs es) -- | Creates a failing ConflictSetLog representing a backjump. It inserts a -- "backjumping" message, checks whether the backjump limit has been reached, -- and increments the backjump count. logBackjump :: Maybe Int -> ConflictSet -> ExploreState -> ConflictSetLog a logBackjump mbj cs es = failWith (Failure cs Backjump) $ if reachedBjLimit (esBackjumps es) then BackjumpLimit else NoSolution cs es { esBackjumps = esBackjumps es + 1 } where reachedBjLimit = case mbj of Nothing -> const False Just limit -> (>= limit) -- | Like 'retry', except that it only applies the input function when the -- backjump limit has not been reached. retryNoSolution :: ConflictSetLog a -> (ConflictSet -> ExploreState -> ConflictSetLog a) -> ConflictSetLog a retryNoSolution lg f = retry lg $ \case BackjumpLimit -> fromProgress (P.Fail BackjumpLimit) NoSolution cs es -> f cs es -- | The state that is read and written while exploring the search tree. data ExploreState = ES { esConflictMap :: !ConflictMap , esBackjumps :: !Int } data IntermediateFailure = NoSolution ConflictSet ExploreState | BackjumpLimit type ConflictSetLog = RetryLog Message IntermediateFailure getBestGoal :: ConflictMap -> P.PSQ (Goal QPN) a -> (Goal QPN, a) getBestGoal cm = P.maximumBy ( flip (M.findWithDefault 0) cm . (\ (Goal v _) -> v) ) getFirstGoal :: P.PSQ (Goal QPN) a -> (Goal QPN, a) getFirstGoal ts = P.casePSQ ts (error "getFirstGoal: empty goal choice") -- empty goal choice is an internal error (\ k v _xs -> (k, v)) -- commit to the first goal choice updateCM :: ConflictSet -> ConflictMap -> ConflictMap updateCM cs cm = L.foldl' (\ cmc k -> M.insertWith (+) k 1 cmc) cm (CS.toList cs) -- | Record complete assignments on 'Done' nodes. assign :: Tree d c -> Tree Assignment c assign tree = go tree (A M.empty M.empty M.empty) where go :: Tree d c -> Assignment -> Tree Assignment c go (Fail c fr) _ = Fail c fr go (Done rdm _) a = Done rdm a go (PChoice qpn rdm y ts) (A pa fa sa) = PChoice qpn rdm y $ W.mapWithKey f (fmap go ts) where f (POption k _) r = r (A (M.insert qpn k pa) fa sa) go (FChoice qfn rdm y t m d ts) (A pa fa sa) = FChoice qfn rdm y t m d $ W.mapWithKey f (fmap go ts) where f k r = r (A pa (M.insert qfn k fa) sa) go (SChoice qsn rdm y t ts) (A pa fa sa) = SChoice qsn rdm y t $ W.mapWithKey f (fmap go ts) where f k r = r (A pa fa (M.insert qsn k sa)) go (GoalChoice rdm ts) a = GoalChoice rdm $ fmap ($ a) (fmap go ts) -- | A tree traversal that simultaneously propagates conflict sets up -- the tree from the leaves and creates a log. exploreLog :: Maybe Int -> EnableBackjumping -> FineGrainedConflicts -> CountConflicts -> Index -> Tree Assignment QGoalReason -> ConflictSetLog (Assignment, RevDepMap) exploreLog mbj enableBj fineGrainedConflicts (CountConflicts countConflicts) idx t = para go t initES where getBestGoal' :: P.PSQ (Goal QPN) a -> ConflictMap -> (Goal QPN, a) getBestGoal' | asBool countConflicts = \ ts cm -> getBestGoal cm ts | otherwise = \ ts _ -> getFirstGoal ts go :: TreeF Assignment QGoalReason (ExploreState -> ConflictSetLog (Assignment, RevDepMap), Tree Assignment QGoalReason) -> (ExploreState -> ConflictSetLog (Assignment, RevDepMap)) go (FailF c fr) = \ !es -> let es' = es { esConflictMap = updateCM c (esConflictMap es) } in failWith (Failure c fr) (NoSolution c es') go (DoneF rdm a) = \ _ -> succeedWith Success (a, rdm) go (PChoiceF qpn _ gr ts) = backjump mbj enableBj fineGrainedConflicts (couldResolveConflicts qpn) (logSkippedPackage qpn) (P qpn) (avoidSet (P qpn) gr) $ -- try children in order, W.mapWithKey -- when descending ... (\ k r es -> tryWith (TryP qpn k) (r es)) (fmap fst ts) go (FChoiceF qfn _ gr _ _ _ ts) = backjump mbj enableBj fineGrainedConflicts (\_ _ -> Nothing) (const logSkippedChoiceSimple) (F qfn) (avoidSet (F qfn) gr) $ -- try children in order, W.mapWithKey -- when descending ... (\ k r es -> tryWith (TryF qfn k) (r es)) (fmap fst ts) go (SChoiceF qsn _ gr _ ts) = backjump mbj enableBj fineGrainedConflicts (\_ _ -> Nothing) (const logSkippedChoiceSimple) (S qsn) (avoidSet (S qsn) gr) $ -- try children in order, W.mapWithKey -- when descending ... (\ k r es -> tryWith (TryS qsn k) (r es)) (fmap fst ts) go (GoalChoiceF _ ts) = \ es -> let (k, (v, tree)) = getBestGoal' ts (esConflictMap es) in continueWith (Next k) $ -- Goal choice nodes are normally not counted as backjumps, since the -- solver always explores exactly one choice, which means that the -- backjump from the goal choice would be redundant with the backjump -- from the PChoice, FChoice, or SChoice below. The one case where the -- backjump is not redundant is when the chosen goal is a failure node, -- so we log a backjump in that case. case tree of Fail _ _ -> retryNoSolution (v es) $ logBackjump mbj _ -> v es initES = ES { esConflictMap = M.empty , esBackjumps = 0 } -- Is it possible for this package instance (QPN and POption) to resolve any -- of the conflicts that were caused by the previous instance? The default -- is true, because it is always safe to explore a package instance. -- Skipping it is an optimization. If false, it returns a new conflict set -- to be merged with the previous one. couldResolveConflicts :: QPN -> POption -> S.Set CS.Conflict -> Maybe ConflictSet couldResolveConflicts currentQPN@(Q _ pn) (POption i@(I v _) _) conflicts = let (PInfo deps _ _ _) = idx M.! pn M.! i qdeps = qualifyDeps (defaultQualifyOptions idx) currentQPN deps couldBeResolved :: CS.Conflict -> Maybe ConflictSet couldBeResolved CS.OtherConflict = Nothing couldBeResolved (CS.GoalConflict conflictingDep) = -- Check whether this package instance also has 'conflictingDep' -- as a dependency (ignoring flag and stanza choices). if null [() | Simple (LDep _ (Dep (PkgComponent qpn _) _)) _ <- qdeps, qpn == conflictingDep] then Nothing else Just CS.empty couldBeResolved (CS.VersionConstraintConflict dep excludedVersion) = -- Check whether this package instance also excludes version -- 'excludedVersion' of 'dep' (ignoring flag and stanza choices). let vrs = [vr | Simple (LDep _ (Dep (PkgComponent qpn _) (Constrained vr))) _ <- qdeps, qpn == dep ] vrIntersection = L.foldl' (.&&.) anyVersion vrs in if checkVR vrIntersection excludedVersion then Nothing else -- If we skip this package instance, we need to update the -- conflict set to say that 'dep' was also excluded by -- this package instance's constraint. Just $ CS.singletonWithConflict (P dep) $ CS.VersionConflict currentQPN (CS.OrderedVersionRange vrIntersection) couldBeResolved (CS.VersionConflict reverseDep (CS.OrderedVersionRange excludingVR)) = -- Check whether this package instance's version is also excluded -- by 'excludingVR'. if checkVR excludingVR v then Nothing else -- If we skip this version, we need to update the conflict -- set to say that the reverse dependency also excluded this -- version. Just $ CS.singletonWithConflict (P reverseDep) (CS.VersionConstraintConflict currentQPN v) in fmap CS.unions $ traverse couldBeResolved (S.toList conflicts) logSkippedPackage :: QPN -> POption -> ConflictSet -> ExploreState -> ConflictSetLog a logSkippedPackage qpn pOption cs es = tryWith (TryP qpn pOption) $ failWith (Skip (fromMaybe S.empty $ CS.lookup (P qpn) cs)) $ NoSolution cs es -- This function is used for flag and stanza choices, but it should not be -- called, because there is currently no way to skip a value for a flag or -- stanza. logSkippedChoiceSimple :: ConflictSet -> ExploreState -> ConflictSetLog a logSkippedChoiceSimple cs es = fromProgress $ P.Fail $ NoSolution cs es -- | Build a conflict set corresponding to the (virtual) option not to -- choose a solution for a goal at all. -- -- In the solver, the set of goals is not statically determined, but depends -- on the choices we make. Therefore, when dealing with conflict sets, we -- always have to consider that we could perhaps make choices that would -- avoid the existence of the goal completely. -- -- Whenever we actually introduce a choice in the tree, we have already established -- that the goal cannot be avoided. This is tracked in the "goal reason". -- The choice to avoid the goal therefore is a conflict between the goal itself -- and its goal reason. We build this set here, and pass it to the 'backjump' -- function as the last conflict set. -- -- This has two effects: -- -- - In a situation where there are no choices available at all (this happens -- if an unknown package is requested), the last conflict set becomes the -- actual conflict set. -- -- - In a situation where all of the children's conflict sets contain the -- current variable, the goal reason of the current node will be added to the -- conflict set. -- avoidSet :: Var QPN -> QGoalReason -> ConflictSet avoidSet var@(P qpn) gr = CS.union (CS.singleton var) (goalReasonToConflictSetWithConflict qpn gr) avoidSet var gr = CS.union (CS.singleton var) (goalReasonToConflictSet gr) -- | Interface. -- -- Takes as an argument a limit on allowed backjumps. If the limit is 'Nothing', -- then infinitely many backjumps are allowed. If the limit is 'Just 0', -- backtracking is completely disabled. backjumpAndExplore :: Maybe Int -> EnableBackjumping -> FineGrainedConflicts -> CountConflicts -> Index -> Tree d QGoalReason -> RetryLog Message SolverFailure (Assignment, RevDepMap) backjumpAndExplore mbj enableBj fineGrainedConflicts countConflicts idx = mapFailure convertFailure . exploreLog mbj enableBj fineGrainedConflicts countConflicts idx . assign where convertFailure (NoSolution cs es) = ExhaustiveSearch cs (esConflictMap es) convertFailure BackjumpLimit = BackjumpLimitReached cabal-install-solver-3.8.1.0/src/Distribution/Solver/Modular/Flag.hs0000644000000000000000000000615407346545000023426 0ustar0000000000000000{-# LANGUAGE DeriveFunctor #-} module Distribution.Solver.Modular.Flag ( FInfo(..) , Flag , FlagInfo , FN(..) , QFN , QSN , Stanza , SN(..) , WeakOrTrivial(..) , FlagValue(..) , mkFlag , showQFN , showQFNBool , showFlagValue , showQSN , showQSNBool , showSBool ) where import Data.Map as M import Prelude hiding (pi) import qualified Distribution.PackageDescription as P -- from Cabal import Distribution.Solver.Types.Flag import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PackagePath -- | Flag name. Consists of a package instance and the flag identifier itself. data FN qpn = FN qpn Flag deriving (Eq, Ord, Show, Functor) -- | Flag identifier. Just a string. type Flag = P.FlagName -- | Stanza identifier. type Stanza = OptionalStanza unFlag :: Flag -> String unFlag = P.unFlagName mkFlag :: String -> Flag mkFlag = P.mkFlagName -- | Flag info. Default value, whether the flag is manual, and -- whether the flag is weak. Manual flags can only be set explicitly. -- Weak flags are typically deferred by the solver. data FInfo = FInfo { fdefault :: Bool, fmanual :: FlagType, fweak :: WeakOrTrivial } deriving (Eq, Show) -- | Flag defaults. type FlagInfo = Map Flag FInfo -- | Qualified flag name. type QFN = FN QPN -- | Stanza name. Paired with a package name, much like a flag. data SN qpn = SN qpn Stanza deriving (Eq, Ord, Show, Functor) -- | Qualified stanza name. type QSN = SN QPN -- | A property of flag and stanza choices that determines whether the -- choice should be deferred in the solving process. -- -- A choice is called weak if we do want to defer it. This is the -- case for flags that should be implied by what's currently installed on -- the system, as opposed to flags that are used to explicitly enable or -- disable some functionality. -- -- A choice is called trivial if it clearly does not matter. The -- special case of triviality we actually consider is if there are no new -- dependencies introduced by the choice. newtype WeakOrTrivial = WeakOrTrivial { unWeakOrTrivial :: Bool } deriving (Eq, Ord, Show) -- | Value shown for a flag in a solver log message. The message can refer to -- only the true choice, only the false choice, or both choices. data FlagValue = FlagTrue | FlagFalse | FlagBoth deriving (Eq, Show) showQFNBool :: QFN -> Bool -> String showQFNBool qfn@(FN qpn _f) b = showQPN qpn ++ ":" ++ showFBool qfn b showQSNBool :: QSN -> Bool -> String showQSNBool (SN qpn s) b = showQPN qpn ++ ":" ++ showSBool s b showFBool :: FN qpn -> Bool -> String showFBool (FN _ f) v = P.showFlagValue (f, v) -- | String representation of a flag-value pair. showFlagValue :: P.FlagName -> FlagValue -> String showFlagValue f FlagTrue = '+' : unFlag f showFlagValue f FlagFalse = '-' : unFlag f showFlagValue f FlagBoth = "+/-" ++ unFlag f showSBool :: Stanza -> Bool -> String showSBool s True = "*" ++ showStanza s showSBool s False = "!" ++ showStanza s showQFN :: QFN -> String showQFN (FN qpn f) = showQPN qpn ++ ":" ++ unFlag f showQSN :: QSN -> String showQSN (SN qpn s) = showQPN qpn ++ ":" ++ showStanza s cabal-install-solver-3.8.1.0/src/Distribution/Solver/Modular/Index.hs0000644000000000000000000000530207346545000023616 0ustar0000000000000000module Distribution.Solver.Modular.Index ( Index , PInfo(..) , ComponentInfo(..) , IsVisible(..) , IsBuildable(..) , defaultQualifyOptions , mkIndex ) where import Prelude hiding (pi) import Data.Map (Map) import qualified Data.List as L import qualified Data.Map as M import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Package import Distribution.Solver.Modular.Tree -- | An index contains information about package instances. This is a nested -- dictionary. Package names are mapped to instances, which in turn is mapped -- to info. type Index = Map PN (Map I PInfo) -- | Info associated with a package instance. -- Currently, dependencies, component names, flags and failure reasons. -- The component map records whether any components are unbuildable in the -- current environment (compiler, os, arch, and global flag constraints). -- Packages that have a failure reason recorded for them are disabled -- globally, for reasons external to the solver. We currently use this -- for shadowing which essentially is a GHC limitation, and for -- installed packages that are broken. data PInfo = PInfo (FlaggedDeps PN) (Map ExposedComponent ComponentInfo) FlagInfo (Maybe FailReason) -- | Info associated with each library and executable in a package instance. data ComponentInfo = ComponentInfo { compIsVisible :: IsVisible , compIsBuildable :: IsBuildable } deriving Show -- | Whether a component is visible in the current environment. newtype IsVisible = IsVisible Bool deriving (Eq, Show) -- | Whether a component is made unbuildable by a "buildable: False" field. newtype IsBuildable = IsBuildable Bool deriving (Eq, Show) mkIndex :: [(PN, I, PInfo)] -> Index mkIndex xs = M.map M.fromList (groupMap (L.map (\ (pn, i, pi) -> (pn, (i, pi))) xs)) groupMap :: Ord a => [(a, b)] -> Map a [b] groupMap xs = M.fromListWith (flip (++)) (L.map (\ (x, y) -> (x, [y])) xs) defaultQualifyOptions :: Index -> QualifyOptions defaultQualifyOptions idx = QO { qoBaseShim = or [ dep == base | -- Find all versions of base .. Just is <- [M.lookup base idx] -- .. which are installed .. , (I _ver (Inst _), PInfo deps _comps _flagNfo _fr) <- M.toList is -- .. and flatten all their dependencies .. , (LDep _ (Dep (PkgComponent dep _) _ci), _comp) <- flattenFlaggedDeps deps ] , qoSetupIndependent = True } where base = mkPackageName "base" cabal-install-solver-3.8.1.0/src/Distribution/Solver/Modular/IndexConversion.hs0000644000000000000000000006550307346545000025675 0ustar0000000000000000module Distribution.Solver.Modular.IndexConversion ( convPIs ) where import Distribution.Solver.Compat.Prelude import Prelude () import qualified Data.List as L import qualified Data.Map.Strict as M import qualified Distribution.Compat.NonEmptySet as NonEmptySet import qualified Data.Set as S import qualified Distribution.InstalledPackageInfo as IPI import Distribution.Compiler import Distribution.Package -- from Cabal import Distribution.Simple.BuildToolDepends -- from Cabal import Distribution.Types.ExeDependency -- from Cabal import Distribution.Types.PkgconfigDependency -- from Cabal import Distribution.Types.ComponentName -- from Cabal import Distribution.Types.CondTree -- from Cabal import Distribution.Types.MungedPackageId -- from Cabal import Distribution.Types.MungedPackageName -- from Cabal import Distribution.PackageDescription -- from Cabal import Distribution.PackageDescription.Configuration import qualified Distribution.Simple.PackageIndex as SI import Distribution.System import Distribution.Solver.Types.ComponentDeps ( Component(..), componentNameToComponent ) import Distribution.Solver.Types.Flag import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PackageConstraint import qualified Distribution.Solver.Types.PackageIndex as CI import Distribution.Solver.Types.Settings import Distribution.Solver.Types.SourcePackage import Distribution.Solver.Modular.Dependency as D import Distribution.Solver.Modular.Flag as F import Distribution.Solver.Modular.Index import Distribution.Solver.Modular.Package import Distribution.Solver.Modular.Tree import Distribution.Solver.Modular.Version -- | Convert both the installed package index and the source package -- index into one uniform solver index. -- -- We use 'allPackagesBySourcePackageId' for the installed package index -- because that returns us several instances of the same package and version -- in order of preference. This allows us in principle to \"shadow\" -- packages if there are several installed packages of the same version. -- There are currently some shortcomings in both GHC and Cabal in -- resolving these situations. However, the right thing to do is to -- fix the problem there, so for now, shadowing is only activated if -- explicitly requested. convPIs :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint] -> ShadowPkgs -> StrongFlags -> SolveExecutables -> SI.InstalledPackageIndex -> CI.PackageIndex (SourcePackage loc) -> Index convPIs os arch comp constraints sip strfl solveExes iidx sidx = mkIndex $ convIPI' sip iidx ++ convSPI' os arch comp constraints strfl solveExes sidx -- | Convert a Cabal installed package index to the simpler, -- more uniform index format of the solver. convIPI' :: ShadowPkgs -> SI.InstalledPackageIndex -> [(PN, I, PInfo)] convIPI' (ShadowPkgs sip) idx = -- apply shadowing whenever there are multiple installed packages with -- the same version [ maybeShadow (convIP idx pkg) -- IMPORTANT to get internal libraries. See -- Note [Index conversion with internal libraries] | (_, pkgs) <- SI.allPackagesBySourcePackageIdAndLibName idx , (maybeShadow, pkg) <- zip (id : repeat shadow) pkgs ] where -- shadowing is recorded in the package info shadow (pn, i, PInfo fdeps comps fds _) | sip = (pn, i, PInfo fdeps comps fds (Just Shadowed)) shadow x = x -- | Extract/recover the package ID from an installed package info, and convert it to a solver's I. convId :: IPI.InstalledPackageInfo -> (PN, I) convId ipi = (pn, I ver $ Inst $ IPI.installedUnitId ipi) where MungedPackageId mpn ver = mungedId ipi -- HACK. See Note [Index conversion with internal libraries] pn = encodeCompatPackageName mpn -- | Convert a single installed package into the solver-specific format. convIP :: SI.InstalledPackageIndex -> IPI.InstalledPackageInfo -> (PN, I, PInfo) convIP idx ipi = case traverse (convIPId (DependencyReason pn M.empty S.empty) comp idx) (IPI.depends ipi) of Left u -> (pn, i, PInfo [] M.empty M.empty (Just (Broken u))) Right fds -> (pn, i, PInfo fds components M.empty Nothing) where -- TODO: Handle sub-libraries and visibility. components = M.singleton (ExposedLib LMainLibName) ComponentInfo { compIsVisible = IsVisible True , compIsBuildable = IsBuildable True } (pn, i) = convId ipi -- 'sourceLibName' is unreliable, but for now we only really use this for -- primary libs anyways comp = componentNameToComponent $ CLibName $ IPI.sourceLibName ipi -- TODO: Installed packages should also store their encapsulations! -- Note [Index conversion with internal libraries] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- Something very interesting happens when we have internal libraries -- in our index. In this case, we maybe have p-0.1, which itself -- depends on the internal library p-internal ALSO from p-0.1. -- Here's the danger: -- -- - If we treat both of these packages as having PN "p", -- then the solver will try to pick one or the other, -- but never both. -- -- - If we drop the internal packages, now p-0.1 has a -- dangling dependency on an "installed" package we know -- nothing about. Oops. -- -- An expedient hack is to put p-internal into cabal-install's -- index as a MUNGED package name, so that it doesn't conflict -- with anyone else (except other instances of itself). But -- yet, we ought NOT to say that PNs in the solver are munged -- package names, because they're not; for source packages, -- we really will never see munged package names. -- -- The tension here is that the installed package index is actually -- per library, but the solver is per package. We need to smooth -- it over, and munging the package names is a pretty good way to -- do it. -- | Convert dependencies specified by an installed package id into -- flagged dependencies of the solver. -- -- May return Nothing if the package can't be found in the index. That -- indicates that the original package having this dependency is broken -- and should be ignored. convIPId :: DependencyReason PN -> Component -> SI.InstalledPackageIndex -> UnitId -> Either UnitId (FlaggedDep PN) convIPId dr comp idx ipid = case SI.lookupUnitId idx ipid of Nothing -> Left ipid Just ipi -> let (pn, i) = convId ipi name = ExposedLib LMainLibName -- TODO: Handle sub-libraries. in Right (D.Simple (LDep dr (Dep (PkgComponent pn name) (Fixed i))) comp) -- NB: something we pick up from the -- InstalledPackageIndex is NEVER an executable -- | Convert a cabal-install source package index to the simpler, -- more uniform index format of the solver. convSPI' :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint] -> StrongFlags -> SolveExecutables -> CI.PackageIndex (SourcePackage loc) -> [(PN, I, PInfo)] convSPI' os arch cinfo constraints strfl solveExes = L.map (convSP os arch cinfo constraints strfl solveExes) . CI.allPackages -- | Convert a single source package into the solver-specific format. convSP :: OS -> Arch -> CompilerInfo -> Map PN [LabeledPackageConstraint] -> StrongFlags -> SolveExecutables -> SourcePackage loc -> (PN, I, PInfo) convSP os arch cinfo constraints strfl solveExes (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) = let i = I pv InRepo pkgConstraints = fromMaybe [] $ M.lookup pn constraints in (pn, i, convGPD os arch cinfo pkgConstraints strfl solveExes pn gpd) -- We do not use 'flattenPackageDescription' or 'finalizePD' -- from 'Distribution.PackageDescription.Configuration' here, because we -- want to keep the condition tree, but simplify much of the test. -- | Convert a generic package description to a solver-specific 'PInfo'. convGPD :: OS -> Arch -> CompilerInfo -> [LabeledPackageConstraint] -> StrongFlags -> SolveExecutables -> PN -> GenericPackageDescription -> PInfo convGPD os arch cinfo constraints strfl solveExes pn (GenericPackageDescription pkg scannedVersion flags mlib sub_libs flibs exes tests benchs) = let fds = flagInfo strfl flags conv :: Monoid a => Component -> (a -> BuildInfo) -> DependencyReason PN -> CondTree ConfVar [Dependency] a -> FlaggedDeps PN conv comp getInfo dr = convCondTree M.empty dr pkg os arch cinfo pn fds comp getInfo solveExes . addBuildableCondition getInfo initDR = DependencyReason pn M.empty S.empty flagged_deps = concatMap (\ds -> conv ComponentLib libBuildInfo initDR ds) (maybeToList mlib) ++ concatMap (\(nm, ds) -> conv (ComponentSubLib nm) libBuildInfo initDR ds) sub_libs ++ concatMap (\(nm, ds) -> conv (ComponentFLib nm) foreignLibBuildInfo initDR ds) flibs ++ concatMap (\(nm, ds) -> conv (ComponentExe nm) buildInfo initDR ds) exes ++ prefix (Stanza (SN pn TestStanzas)) (L.map (\(nm, ds) -> conv (ComponentTest nm) testBuildInfo (addStanza TestStanzas initDR) ds) tests) ++ prefix (Stanza (SN pn BenchStanzas)) (L.map (\(nm, ds) -> conv (ComponentBench nm) benchmarkBuildInfo (addStanza BenchStanzas initDR) ds) benchs) ++ maybe [] (convSetupBuildInfo pn) (setupBuildInfo pkg) addStanza :: Stanza -> DependencyReason pn -> DependencyReason pn addStanza s (DependencyReason pn' fs ss) = DependencyReason pn' fs (S.insert s ss) -- | A too-new specVersion is turned into a global 'FailReason' -- which prevents the solver from selecting this release (and if -- forced to, emit a meaningful solver error message). fr = case scannedVersion of Just ver -> Just (UnsupportedSpecVer ver) Nothing -> Nothing components :: Map ExposedComponent ComponentInfo components = M.fromList $ libComps ++ subLibComps ++ exeComps where libComps = [ (ExposedLib LMainLibName, libToComponentInfo lib) | lib <- maybeToList mlib ] subLibComps = [ (ExposedLib (LSubLibName name), libToComponentInfo lib) | (name, lib) <- sub_libs ] exeComps = [ ( ExposedExe name , ComponentInfo { compIsVisible = IsVisible True , compIsBuildable = IsBuildable $ testCondition (buildable . buildInfo) exe /= Just False } ) | (name, exe) <- exes ] libToComponentInfo lib = ComponentInfo { compIsVisible = IsVisible $ testCondition (isPrivate . libVisibility) lib /= Just True , compIsBuildable = IsBuildable $ testCondition (buildable . libBuildInfo) lib /= Just False } testCondition = testConditionForComponent os arch cinfo constraints isPrivate LibraryVisibilityPrivate = True isPrivate LibraryVisibilityPublic = False in PInfo flagged_deps components fds fr -- | Applies the given predicate (for example, testing buildability or -- visibility) to the given component and environment. Values are combined with -- AND. This function returns 'Nothing' when the result cannot be determined -- before dependency solving. Additionally, this function only considers flags -- that are set by unqualified flag constraints, and it doesn't check the -- intra-package dependencies of a component. testConditionForComponent :: OS -> Arch -> CompilerInfo -> [LabeledPackageConstraint] -> (a -> Bool) -> CondTree ConfVar [Dependency] a -> Maybe Bool testConditionForComponent os arch cinfo constraints p tree = case go $ extractCondition p tree of Lit True -> Just True Lit False -> Just False _ -> Nothing where flagAssignment :: [(FlagName, Bool)] flagAssignment = mconcat [ unFlagAssignment fa | PackageConstraint (ScopeAnyQualifier _) (PackagePropertyFlags fa) <- L.map unlabelPackageConstraint constraints] -- Simplify the condition, using the current environment. Most of this -- function was copied from convBranch and -- Distribution.Types.Condition.simplifyCondition. go :: Condition ConfVar -> Condition ConfVar go (Var (OS os')) = Lit (os == os') go (Var (Arch arch')) = Lit (arch == arch') go (Var (Impl cf cvr)) | matchImpl (compilerInfoId cinfo) || -- fixme: Nothing should be treated as unknown, rather than empty -- list. This code should eventually be changed to either -- support partial resolution of compiler flags or to -- complain about incompletely configured compilers. any matchImpl (fromMaybe [] $ compilerInfoCompat cinfo) = Lit True | otherwise = Lit False where matchImpl (CompilerId cf' cv) = cf == cf' && checkVR cvr cv go (Var (PackageFlag f)) | Just b <- L.lookup f flagAssignment = Lit b go (Var v) = Var v go (Lit b) = Lit b go (CNot c) = case go c of Lit True -> Lit False Lit False -> Lit True c' -> CNot c' go (COr c d) = case (go c, go d) of (Lit False, d') -> d' (Lit True, _) -> Lit True (c', Lit False) -> c' (_, Lit True) -> Lit True (c', d') -> COr c' d' go (CAnd c d) = case (go c, go d) of (Lit False, _) -> Lit False (Lit True, d') -> d' (_, Lit False) -> Lit False (c', Lit True) -> c' (c', d') -> CAnd c' d' -- | Create a flagged dependency tree from a list @fds@ of flagged -- dependencies, using @f@ to form the tree node (@f@ will be -- something like @Stanza sn@). prefix :: (FlaggedDeps qpn -> FlaggedDep qpn) -> [FlaggedDeps qpn] -> FlaggedDeps qpn prefix _ [] = [] prefix f fds = [f (concat fds)] -- | Convert flag information. Automatic flags are now considered weak -- unless strong flags have been selected explicitly. flagInfo :: StrongFlags -> [PackageFlag] -> FlagInfo flagInfo (StrongFlags strfl) = M.fromList . L.map (\ (MkPackageFlag fn _ b m) -> (fn, FInfo b (flagType m) (weak m))) where weak m = WeakOrTrivial $ not (strfl || m) flagType m = if m then Manual else Automatic -- | Convert condition trees to flagged dependencies. Mutually -- recursive with 'convBranch'. See 'convBranch' for an explanation -- of all arguments preceding the input 'CondTree'. convCondTree :: Map FlagName Bool -> DependencyReason PN -> PackageDescription -> OS -> Arch -> CompilerInfo -> PN -> FlagInfo -> Component -> (a -> BuildInfo) -> SolveExecutables -> CondTree ConfVar [Dependency] a -> FlaggedDeps PN convCondTree flags dr pkg os arch cinfo pn fds comp getInfo solveExes@(SolveExecutables solveExes') (CondNode info ds branches) = -- Merge all library and build-tool dependencies at every level in -- the tree of flagged dependencies. Otherwise 'extractCommon' -- could create duplicate dependencies, and the number of -- duplicates could grow exponentially from the leaves to the root -- of the tree. mergeSimpleDeps $ [ D.Simple singleDep comp | dep <- ds , singleDep <- convLibDeps dr dep ] -- unconditional package dependencies ++ L.map (\e -> D.Simple (LDep dr (Ext e)) comp) (allExtensions bi) -- unconditional extension dependencies ++ L.map (\l -> D.Simple (LDep dr (Lang l)) comp) (allLanguages bi) -- unconditional language dependencies ++ L.map (\(PkgconfigDependency pkn vr) -> D.Simple (LDep dr (Pkg pkn vr)) comp) (pkgconfigDepends bi) -- unconditional pkg-config dependencies ++ concatMap (convBranch flags dr pkg os arch cinfo pn fds comp getInfo solveExes) branches -- build-tools dependencies -- NB: Only include these dependencies if SolveExecutables -- is True. It might be false in the legacy solver -- codepath, in which case there won't be any record of -- an executable we need. ++ [ D.Simple (convExeDep dr exeDep) comp | solveExes' , exeDep <- getAllToolDependencies pkg bi , not $ isInternal pkg exeDep ] where bi = getInfo info data SimpleFlaggedDepKey qpn = SimpleFlaggedDepKey (PkgComponent qpn) Component deriving (Eq, Ord) data SimpleFlaggedDepValue qpn = SimpleFlaggedDepValue (DependencyReason qpn) VR -- | Merge 'Simple' dependencies that apply to the same library or build-tool. -- This function should be able to merge any two dependencies that can be merged -- by extractCommon, in order to prevent the exponential growth of dependencies. -- -- Note that this function can merge dependencies that have different -- DependencyReasons, which can make the DependencyReasons less precise. This -- loss of precision only affects performance and log messages, not correctness. -- However, when 'mergeSimpleDeps' is only called on dependencies at a single -- location in the dependency tree, the only difference between -- DependencyReasons should be flags that have value FlagBoth. Adding extra -- flags with value FlagBoth should not affect performance, since they are not -- added to the conflict set. The only downside is the possibility of the log -- incorrectly saying that the flag contributed to excluding a specific version -- of a dependency. For example, if +/-flagA introduces pkg >=2 and +/-flagB -- introduces pkg <5, the merged dependency would mean that -- +/-flagA and +/-flagB introduce pkg >=2 && <5, which would incorrectly imply -- that +/-flagA excludes pkg-6. mergeSimpleDeps :: Ord qpn => FlaggedDeps qpn -> FlaggedDeps qpn mergeSimpleDeps deps = L.map (uncurry toFlaggedDep) (M.toList merged) ++ unmerged where (merged, unmerged) = L.foldl' f (M.empty, []) deps where f :: Ord qpn => (Map (SimpleFlaggedDepKey qpn) (SimpleFlaggedDepValue qpn), FlaggedDeps qpn) -> FlaggedDep qpn -> (Map (SimpleFlaggedDepKey qpn) (SimpleFlaggedDepValue qpn), FlaggedDeps qpn) f (merged', unmerged') (D.Simple (LDep dr (Dep dep (Constrained vr))) comp) = ( M.insertWith mergeValues (SimpleFlaggedDepKey dep comp) (SimpleFlaggedDepValue dr vr) merged' , unmerged') f (merged', unmerged') unmergeableDep = (merged', unmergeableDep : unmerged') mergeValues :: SimpleFlaggedDepValue qpn -> SimpleFlaggedDepValue qpn -> SimpleFlaggedDepValue qpn mergeValues (SimpleFlaggedDepValue dr1 vr1) (SimpleFlaggedDepValue dr2 vr2) = SimpleFlaggedDepValue (unionDRs dr1 dr2) (vr1 .&&. vr2) toFlaggedDep :: SimpleFlaggedDepKey qpn -> SimpleFlaggedDepValue qpn -> FlaggedDep qpn toFlaggedDep (SimpleFlaggedDepKey dep comp) (SimpleFlaggedDepValue dr vr) = D.Simple (LDep dr (Dep dep (Constrained vr))) comp -- | Branch interpreter. Mutually recursive with 'convCondTree'. -- -- Here, we try to simplify one of Cabal's condition tree branches into the -- solver's flagged dependency format, which is weaker. Condition trees can -- contain complex logical expression composed from flag choices and special -- flags (such as architecture, or compiler flavour). We try to evaluate the -- special flags and subsequently simplify to a tree that only depends on -- simple flag choices. -- -- This function takes a number of arguments: -- -- 1. A map of flag values that have already been chosen. It allows -- convBranch to avoid creating nested FlaggedDeps that are -- controlled by the same flag and avoid creating DependencyReasons with -- conflicting values for the same flag. -- -- 2. The DependencyReason calculated at this point in the tree of -- conditionals. The flag values in the DependencyReason are similar to -- the values in the map above, except for the use of FlagBoth. -- -- 3. Some pre dependency-solving known information ('OS', 'Arch', -- 'CompilerInfo') for @os()@, @arch()@ and @impl()@ variables, -- -- 4. The package name @'PN'@ which this condition tree -- came from, so that we can correctly associate @flag()@ -- variables with the correct package name qualifier, -- -- 5. The flag defaults 'FlagInfo' so that we can populate -- 'Flagged' dependencies with 'FInfo', -- -- 6. The name of the component 'Component' so we can record where -- the fine-grained information about where the component came -- from (see 'convCondTree'), and -- -- 7. A selector to extract the 'BuildInfo' from the leaves of -- the 'CondTree' (which actually contains the needed -- dependency information.) -- -- 8. The set of package names which should be considered internal -- dependencies, and thus not handled as dependencies. convBranch :: Map FlagName Bool -> DependencyReason PN -> PackageDescription -> OS -> Arch -> CompilerInfo -> PN -> FlagInfo -> Component -> (a -> BuildInfo) -> SolveExecutables -> CondBranch ConfVar [Dependency] a -> FlaggedDeps PN convBranch flags dr pkg os arch cinfo pn fds comp getInfo solveExes (CondBranch c' t' mf') = go c' (\flags' dr' -> convCondTree flags' dr' pkg os arch cinfo pn fds comp getInfo solveExes t') (\flags' dr' -> maybe [] (convCondTree flags' dr' pkg os arch cinfo pn fds comp getInfo solveExes) mf') flags dr where go :: Condition ConfVar -> (Map FlagName Bool -> DependencyReason PN -> FlaggedDeps PN) -> (Map FlagName Bool -> DependencyReason PN -> FlaggedDeps PN) -> Map FlagName Bool -> DependencyReason PN -> FlaggedDeps PN go (Lit True) t _ = t go (Lit False) _ f = f go (CNot c) t f = go c f t go (CAnd c d) t f = go c (go d t f) f go (COr c d) t f = go c t (go d t f) go (Var (PackageFlag fn)) t f = \flags' -> case M.lookup fn flags' of Just True -> t flags' Just False -> f flags' Nothing -> \dr' -> -- Add each flag to the DependencyReason for all dependencies below, -- including any extracted dependencies. Extracted dependencies are -- introduced by both flag values (FlagBoth). Note that we don't -- actually need to add the flag to the extracted dependencies for -- correct backjumping; the information only improves log messages -- by giving the user the full reason for each dependency. let addFlagValue v = addFlagToDependencyReason fn v dr' addFlag v = M.insert fn v flags' in extractCommon (t (addFlag True) (addFlagValue FlagBoth)) (f (addFlag False) (addFlagValue FlagBoth)) ++ [ Flagged (FN pn fn) (fds M.! fn) (t (addFlag True) (addFlagValue FlagTrue)) (f (addFlag False) (addFlagValue FlagFalse)) ] go (Var (OS os')) t f | os == os' = t | otherwise = f go (Var (Arch arch')) t f | arch == arch' = t | otherwise = f go (Var (Impl cf cvr)) t f | matchImpl (compilerInfoId cinfo) || -- fixme: Nothing should be treated as unknown, rather than empty -- list. This code should eventually be changed to either -- support partial resolution of compiler flags or to -- complain about incompletely configured compilers. any matchImpl (fromMaybe [] $ compilerInfoCompat cinfo) = t | otherwise = f where matchImpl (CompilerId cf' cv) = cf == cf' && checkVR cvr cv addFlagToDependencyReason :: FlagName -> FlagValue -> DependencyReason pn -> DependencyReason pn addFlagToDependencyReason fn v (DependencyReason pn' fs ss) = DependencyReason pn' (M.insert fn v fs) ss -- If both branches contain the same package as a simple dep, we lift it to -- the next higher-level, but with the union of version ranges. This -- heuristic together with deferring flag choices will then usually first -- resolve this package, and try an already installed version before imposing -- a default flag choice that might not be what we want. -- -- Note that we make assumptions here on the form of the dependencies that -- can occur at this point. In particular, no occurrences of Fixed, as all -- dependencies below this point have been generated using 'convLibDep'. -- -- WARNING: This is quadratic! extractCommon :: Eq pn => FlaggedDeps pn -> FlaggedDeps pn -> FlaggedDeps pn extractCommon ps ps' = -- Union the DependencyReasons, because the extracted dependency can be -- avoided by removing the dependency from either side of the -- conditional. [ D.Simple (LDep (unionDRs vs1 vs2) (Dep dep1 (Constrained $ vr1 .||. vr2))) comp | D.Simple (LDep vs1 (Dep dep1 (Constrained vr1))) _ <- ps , D.Simple (LDep vs2 (Dep dep2 (Constrained vr2))) _ <- ps' , dep1 == dep2 ] -- | Merge DependencyReasons by unioning their variables. unionDRs :: DependencyReason pn -> DependencyReason pn -> DependencyReason pn unionDRs (DependencyReason pn' fs1 ss1) (DependencyReason _ fs2 ss2) = DependencyReason pn' (M.union fs1 fs2) (S.union ss1 ss2) -- | Convert a Cabal dependency on a set of library components (from a single -- package) to solver-specific dependencies. convLibDeps :: DependencyReason PN -> Dependency -> [LDep PN] convLibDeps dr (Dependency pn vr libs) = [ LDep dr $ Dep (PkgComponent pn (ExposedLib lib)) (Constrained vr) | lib <- NonEmptySet.toList libs ] -- | Convert a Cabal dependency on an executable (build-tools) to a solver-specific dependency. convExeDep :: DependencyReason PN -> ExeDependency -> LDep PN convExeDep dr (ExeDependency pn exe vr) = LDep dr $ Dep (PkgComponent pn (ExposedExe exe)) (Constrained vr) -- | Convert setup dependencies convSetupBuildInfo :: PN -> SetupBuildInfo -> FlaggedDeps PN convSetupBuildInfo pn nfo = [ D.Simple singleDep ComponentSetup | dep <- setupDepends nfo , singleDep <- convLibDeps (DependencyReason pn M.empty S.empty) dep ] cabal-install-solver-3.8.1.0/src/Distribution/Solver/Modular/LabeledGraph.hs0000644000000000000000000000717307346545000025071 0ustar0000000000000000-- | Wrapper around Data.Graph with support for edge labels {-# LANGUAGE ScopedTypeVariables #-} module Distribution.Solver.Modular.LabeledGraph ( -- * Graphs Graph , Vertex -- ** Building graphs , graphFromEdges , graphFromEdges' , buildG , transposeG -- ** Graph properties , vertices , edges -- ** Operations on the underlying unlabeled graph , forgetLabels , topSort ) where import Distribution.Solver.Compat.Prelude import Prelude () import Data.Array import Data.Graph (Vertex, Bounds) import qualified Data.Graph as G {------------------------------------------------------------------------------- Types -------------------------------------------------------------------------------} type Graph e = Array Vertex [(e, Vertex)] type Edge e = (Vertex, e, Vertex) {------------------------------------------------------------------------------- Building graphs -------------------------------------------------------------------------------} -- | Construct an edge-labeled graph -- -- This is a simple adaptation of the definition in Data.Graph graphFromEdges :: forall key node edge. Ord key => [ (node, key, [(edge, key)]) ] -> ( Graph edge , Vertex -> (node, key, [(edge, key)]) , key -> Maybe Vertex ) graphFromEdges edges0 = (graph, \v -> vertex_map ! v, key_vertex) where max_v = length edges0 - 1 bounds0 = (0, max_v) :: (Vertex, Vertex) sorted_edges = sortBy lt edges0 edges1 = zip [0..] sorted_edges graph = array bounds0 [(v, (mapMaybe mk_edge ks)) | (v, (_, _, ks)) <- edges1] key_map = array bounds0 [(v, k ) | (v, (_, k, _ )) <- edges1] vertex_map = array bounds0 edges1 (_,k1,_) `lt` (_,k2,_) = k1 `compare` k2 mk_edge :: (edge, key) -> Maybe (edge, Vertex) mk_edge (edge, key) = do v <- key_vertex key ; return (edge, v) -- returns Nothing for non-interesting vertices key_vertex :: key -> Maybe Vertex key_vertex k = findVertex 0 max_v where findVertex a b | a > b = Nothing | otherwise = case compare k (key_map ! mid) of LT -> findVertex a (mid-1) EQ -> Just mid GT -> findVertex (mid+1) b where mid = a + (b - a) `div` 2 graphFromEdges' :: Ord key => [ (node, key, [(edge, key)]) ] -> ( Graph edge , Vertex -> (node, key, [(edge, key)]) ) graphFromEdges' x = (a,b) where (a,b,_) = graphFromEdges x transposeG :: Graph e -> Graph e transposeG g = buildG (bounds g) (reverseE g) buildG :: Bounds -> [Edge e] -> Graph e buildG bounds0 edges0 = accumArray (flip (:)) [] bounds0 (map reassoc edges0) where reassoc (v, e, w) = (v, (e, w)) reverseE :: Graph e -> [Edge e] reverseE g = [ (w, e, v) | (v, e, w) <- edges g ] {------------------------------------------------------------------------------- Graph properties -------------------------------------------------------------------------------} vertices :: Graph e -> [Vertex] vertices = indices edges :: Graph e -> [Edge e] edges g = [ (v, e, w) | v <- vertices g, (e, w) <- g!v ] {------------------------------------------------------------------------------- Operations on the underlying unlabelled graph -------------------------------------------------------------------------------} forgetLabels :: Graph e -> G.Graph forgetLabels = fmap (map snd) topSort :: Graph e -> [Vertex] topSort = G.topSort . forgetLabels cabal-install-solver-3.8.1.0/src/Distribution/Solver/Modular/Linking.hs0000644000000000000000000005074607346545000024156 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} -- TODO: remove this {-# OPTIONS -fno-warn-incomplete-uni-patterns #-} module Distribution.Solver.Modular.Linking ( validateLinking ) where import Prelude () import Distribution.Solver.Compat.Prelude hiding (get,put) import Control.Exception (assert) import Control.Monad.Reader import Control.Monad.State import Data.Map ((!)) import qualified Data.Map as M import qualified Data.Set as S import qualified Data.Traversable as T import Distribution.Client.Utils.Assertion import Distribution.Solver.Modular.Assignment import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Index import Distribution.Solver.Modular.Package import Distribution.Solver.Modular.Tree import qualified Distribution.Solver.Modular.ConflictSet as CS import qualified Distribution.Solver.Modular.WeightedPSQ as W import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PackagePath import Distribution.Types.Flag (unFlagName) {------------------------------------------------------------------------------- Validation Validation of links is a separate pass that's performed after normal validation. Validation of links checks that if the tree indicates that a package is linked, then everything underneath that choice really matches the package we have linked to. This is interesting because it isn't unidirectional. Consider that we've chosen a.foo to be version 1 and later decide that b.foo should link to a.foo. Now foo depends on bar. Because a.foo and b.foo are linked, it's required that a.bar and b.bar are also linked. However, it's not required that we actually choose a.bar before b.bar. Goal choice order is relatively free. It's possible that we choose a.bar first, but also possible that we choose b.bar first. In both cases, we have to recognize that we have freedom of choice for the first of the two, but no freedom of choice for the second. This is what LinkGroups are all about. Using LinkGroup, we can record (in the situation above) that a.bar and b.bar need to be linked even if we haven't chosen either of them yet. -------------------------------------------------------------------------------} data ValidateState = VS { vsIndex :: Index , vsLinks :: Map QPN LinkGroup , vsFlags :: FAssignment , vsStanzas :: SAssignment , vsQualifyOptions :: QualifyOptions -- Saved qualified dependencies. Every time 'validateLinking' makes a -- package choice, it qualifies the package's dependencies and saves them in -- this map. Then the qualified dependencies are available for subsequent -- flag and stanza choices for the same package. , vsSaved :: Map QPN (FlaggedDeps QPN) } type Validate = Reader ValidateState -- | Validate linked packages -- -- Verify that linked packages have -- -- * Linked dependencies, -- * Equal flag assignments -- * Equal stanza assignments validateLinking :: Index -> Tree d c -> Tree d c validateLinking index = (`runReader` initVS) . go where 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) go (FChoice qfn rdm gr t m d 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) -- For the other nodes we just recurse go (GoalChoice rdm cs) = GoalChoice rdm <$> T.traverse go cs go (Done revDepMap s) = return $ Done revDepMap s go (Fail conflictSet failReason) = return $ Fail conflictSet failReason -- Package choices goP :: QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c) goP qpn@(Q _pp pn) opt@(POption i _) r = do vs <- ask let PInfo deps _ _ _ = vsIndex vs ! pn ! i qdeps = qualifyDeps (vsQualifyOptions vs) qpn deps newSaved = M.insert qpn qdeps (vsSaved vs) case execUpdateState (pickPOption qpn opt qdeps) vs of Left (cs, err) -> return $ Fail cs (DependenciesNotLinked err) Right vs' -> local (const vs' { vsSaved = newSaved }) r -- Flag choices goF :: QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c) goF qfn b r = do vs <- ask case execUpdateState (pickFlag qfn b) vs of Left (cs, err) -> return $ Fail cs (DependenciesNotLinked err) Right vs' -> local (const vs') r -- Stanza choices (much the same as flag choices) goS :: QSN -> Bool -> Validate (Tree d c) -> Validate (Tree d c) goS qsn b r = do vs <- ask case execUpdateState (pickStanza qsn b) vs of Left (cs, err) -> return $ Fail cs (DependenciesNotLinked err) Right vs' -> local (const vs') r initVS :: ValidateState initVS = VS { vsIndex = index , vsLinks = M.empty , vsFlags = M.empty , vsStanzas = M.empty , vsQualifyOptions = defaultQualifyOptions index , vsSaved = M.empty } {------------------------------------------------------------------------------- Updating the validation state -------------------------------------------------------------------------------} type Conflict = (ConflictSet, String) newtype UpdateState a = UpdateState { unUpdateState :: StateT ValidateState (Either Conflict) a } deriving (Functor, Applicative, Monad) instance MonadState ValidateState UpdateState where get = UpdateState $ get put st = UpdateState $ do expensiveAssert (lgInvariant $ vsLinks st) $ return () put st lift' :: Either Conflict a -> UpdateState a lift' = UpdateState . lift conflict :: Conflict -> UpdateState a conflict = lift' . Left execUpdateState :: UpdateState () -> ValidateState -> Either Conflict ValidateState execUpdateState = execStateT . unUpdateState pickPOption :: QPN -> POption -> FlaggedDeps QPN -> UpdateState () pickPOption qpn (POption i Nothing) _deps = pickConcrete qpn i pickPOption qpn (POption i (Just pp')) deps = pickLink qpn i pp' deps pickConcrete :: QPN -> I -> UpdateState () pickConcrete qpn@(Q pp _) i = do vs <- get case M.lookup qpn (vsLinks vs) of -- Package is not yet in a LinkGroup. Create a new singleton link group. Nothing -> do let lg = lgSingleton qpn (Just $ PI pp i) updateLinkGroup lg -- Package is already in a link group. Since we are picking a concrete -- instance here, it must by definition be the canonical package. Just lg -> makeCanonical lg qpn i pickLink :: QPN -> I -> PackagePath -> FlaggedDeps QPN -> UpdateState () pickLink qpn@(Q _pp pn) i pp' deps = do vs <- get -- The package might already be in a link group -- (because one of its reverse dependencies is) let lgSource = case M.lookup qpn (vsLinks vs) of Nothing -> lgSingleton qpn Nothing Just lg -> lg -- Find the link group for the package we are linking to -- -- Since the builder never links to a package without having first picked a -- concrete instance for that package, and since we create singleton link -- groups for concrete instances, this link group must exist (and must -- in fact already have a canonical member). let target = Q pp' pn lgTarget = vsLinks vs ! target -- Verify here that the member we add is in fact for the same package and -- matches the version of the canonical instance. However, violations of -- these checks would indicate a bug in the linker, not a true conflict. let sanityCheck :: Maybe (PI PackagePath) -> Bool sanityCheck Nothing = False sanityCheck (Just (PI _ canonI)) = pn == lgPackage lgTarget && i == canonI assert (sanityCheck (lgCanon lgTarget)) $ return () -- Merge the two link groups (updateLinkGroup will propagate the change) lgTarget' <- lift' $ lgMerge CS.empty lgSource lgTarget updateLinkGroup lgTarget' -- Make sure all dependencies are linked as well linkDeps target deps makeCanonical :: LinkGroup -> QPN -> I -> UpdateState () makeCanonical lg qpn@(Q pp _) i = case lgCanon lg of -- There is already a canonical member. Fail. Just _ -> conflict ( CS.insert (P qpn) (lgConflictSet lg) , "cannot make " ++ showQPN qpn ++ " canonical member of " ++ showLinkGroup lg ) Nothing -> do let lg' = lg { lgCanon = Just (PI pp i) } updateLinkGroup lg' -- | Link the dependencies of linked parents. -- -- When we decide to link one package against another we walk through the -- package's direct dependencies and make sure that they're all linked to each -- other by merging their link groups (or creating new singleton link groups if -- they don't have link groups yet). We do not need to do this recursively, -- because having the direct dependencies in a link group means that we must -- have already made or will make sooner or later a link choice for one of these -- as well, and cover their dependencies at that point. linkDeps :: QPN -> FlaggedDeps QPN -> UpdateState () linkDeps target = \deps -> do -- linkDeps is called in two places: when we first link one package to -- another, and when we discover more dependencies of an already linked -- package after doing some flag assignment. It is therefore important that -- flag assignments cannot influence _how_ dependencies are qualified; -- fortunately this is a documented property of 'qualifyDeps'. rdeps <- requalify deps go deps rdeps where go :: FlaggedDeps QPN -> FlaggedDeps QPN -> UpdateState () go = zipWithM_ go1 go1 :: FlaggedDep QPN -> FlaggedDep QPN -> UpdateState () go1 dep rdep = case (dep, rdep) of (Simple (LDep dr1 (Dep (PkgComponent qpn _) _)) _, ~(Simple (LDep dr2 (Dep (PkgComponent qpn' _) _)) _)) -> do vs <- get let lg = M.findWithDefault (lgSingleton qpn Nothing) qpn $ vsLinks vs lg' = M.findWithDefault (lgSingleton qpn' Nothing) qpn' $ vsLinks vs lg'' <- lift' $ lgMerge ((CS.union `on` dependencyReasonToConflictSet) dr1 dr2) lg lg' updateLinkGroup lg'' (Flagged fn _ t f, ~(Flagged _ _ t' f')) -> do vs <- get case M.lookup fn (vsFlags vs) of Nothing -> return () -- flag assignment not yet known Just True -> go t t' Just False -> go f f' (Stanza sn t, ~(Stanza _ t')) -> do vs <- get case M.lookup sn (vsStanzas vs) of Nothing -> return () -- stanza assignment not yet known Just True -> go t t' Just False -> return () -- stanza not enabled; no new deps -- For extensions and language dependencies, there is nothing to do. -- No choice is involved, just checking, so there is nothing to link. -- The same goes for pkg-config constraints. (Simple (LDep _ (Ext _)) _, _) -> return () (Simple (LDep _ (Lang _)) _, _) -> return () (Simple (LDep _ (Pkg _ _)) _, _) -> return () requalify :: FlaggedDeps QPN -> UpdateState (FlaggedDeps QPN) requalify deps = do vs <- get return $ qualifyDeps (vsQualifyOptions vs) target (unqualifyDeps deps) pickFlag :: QFN -> Bool -> UpdateState () pickFlag qfn b = do modify $ \vs -> vs { vsFlags = M.insert qfn b (vsFlags vs) } verifyFlag qfn linkNewDeps (F qfn) b pickStanza :: QSN -> Bool -> UpdateState () pickStanza qsn b = do modify $ \vs -> vs { vsStanzas = M.insert qsn b (vsStanzas vs) } verifyStanza qsn linkNewDeps (S qsn) b -- | Link dependencies that we discover after making a flag or stanza choice. -- -- When we make a flag choice for a package, then new dependencies for that -- package might become available. If the package under consideration is in a -- non-trivial link group, then these new dependencies have to be linked as -- well. In linkNewDeps, we compute such new dependencies and make sure they are -- linked. linkNewDeps :: Var QPN -> Bool -> UpdateState () linkNewDeps var b = do vs <- get let qpn@(Q pp pn) = varPN var qdeps = vsSaved vs ! qpn lg = vsLinks vs ! qpn newDeps = findNewDeps vs qdeps linkedTo = S.delete pp (lgMembers lg) forM_ (S.toList linkedTo) $ \pp' -> linkDeps (Q pp' pn) newDeps where findNewDeps :: ValidateState -> FlaggedDeps QPN -> FlaggedDeps QPN findNewDeps vs = concatMap (findNewDeps' vs) findNewDeps' :: ValidateState -> FlaggedDep QPN -> FlaggedDeps QPN findNewDeps' _ (Simple _ _) = [] findNewDeps' vs (Flagged qfn _ t f) = case (F qfn == var, M.lookup qfn (vsFlags vs)) of (True, _) -> if b then t else f (_, Nothing) -> [] -- not yet known (_, Just b') -> findNewDeps vs (if b' then t else f) findNewDeps' vs (Stanza qsn t) = case (S qsn == var, M.lookup qsn (vsStanzas vs)) of (True, _) -> if b then t else [] (_, Nothing) -> [] -- not yet known (_, Just b') -> findNewDeps vs (if b' then t else []) updateLinkGroup :: LinkGroup -> UpdateState () updateLinkGroup lg = do verifyLinkGroup lg modify $ \vs -> vs { vsLinks = M.fromList (map aux (S.toList (lgMembers lg))) `M.union` vsLinks vs } where aux pp = (Q pp (lgPackage lg), lg) {------------------------------------------------------------------------------- Verification -------------------------------------------------------------------------------} verifyLinkGroup :: LinkGroup -> UpdateState () verifyLinkGroup lg = case lgInstance lg of -- No instance picked yet. Nothing to verify Nothing -> return () -- We picked an instance. Verify flags and stanzas -- TODO: The enumeration of OptionalStanza names is very brittle; -- if a constructor is added to the datatype we won't notice it here Just i -> do vs <- get let PInfo _deps _exes finfo _ = vsIndex vs ! lgPackage lg ! i flags = M.keys finfo stanzas = [TestStanzas, BenchStanzas] forM_ flags $ \fn -> do let flag = FN (lgPackage lg) fn verifyFlag' flag lg forM_ stanzas $ \sn -> do let stanza = SN (lgPackage lg) sn verifyStanza' stanza lg verifyFlag :: QFN -> UpdateState () verifyFlag (FN qpn@(Q _pp pn) fn) = do vs <- get -- We can only pick a flag after picking an instance; link group must exist verifyFlag' (FN pn fn) (vsLinks vs ! qpn) verifyStanza :: QSN -> UpdateState () verifyStanza (SN qpn@(Q _pp pn) sn) = do vs <- get -- We can only pick a stanza after picking an instance; link group must exist verifyStanza' (SN pn sn) (vsLinks vs ! qpn) -- | Verify that all packages in the link group agree on flag assignments -- -- For the given flag and the link group, obtain all assignments for the flag -- that have already been made for link group members, and check that they are -- equal. verifyFlag' :: FN PN -> LinkGroup -> UpdateState () verifyFlag' (FN pn fn) lg = do vs <- get let flags = map (\pp' -> FN (Q pp' pn) fn) (S.toList (lgMembers lg)) vals = map (`M.lookup` vsFlags vs) flags if allEqual (catMaybes vals) -- We ignore not-yet assigned flags then return () else conflict ( CS.fromList (map F flags) `CS.union` lgConflictSet lg , "flag \"" ++ unFlagName fn ++ "\" incompatible" ) -- | Verify that all packages in the link group agree on stanza assignments -- -- For the given stanza and the link group, obtain all assignments for the -- stanza that have already been made for link group members, and check that -- they are equal. -- -- This function closely mirrors 'verifyFlag''. verifyStanza' :: SN PN -> LinkGroup -> UpdateState () verifyStanza' (SN pn sn) lg = do vs <- get let stanzas = map (\pp' -> SN (Q pp' pn) sn) (S.toList (lgMembers lg)) vals = map (`M.lookup` vsStanzas vs) stanzas if allEqual (catMaybes vals) -- We ignore not-yet assigned stanzas then return () else conflict ( CS.fromList (map S stanzas) `CS.union` lgConflictSet lg , "stanza \"" ++ showStanza sn ++ "\" incompatible" ) {------------------------------------------------------------------------------- Link groups -------------------------------------------------------------------------------} -- | Set of packages that must be linked together -- -- A LinkGroup is between several qualified package names. In the validation -- state, we maintain a map vsLinks from qualified package names to link groups. -- There is an invariant that for all members of a link group, vsLinks must map -- to the same link group. The function updateLinkGroup can be used to -- re-establish this invariant after creating or expanding a LinkGroup. data LinkGroup = LinkGroup { -- | The name of the package of this link group lgPackage :: PN -- | The canonical member of this link group (the one where we picked -- a concrete instance). Once we have picked a canonical member, all -- other packages must link to this one. -- -- We may not know this yet (if we are constructing link groups -- for dependencies) , lgCanon :: Maybe (PI PackagePath) -- | The members of the link group , lgMembers :: Set PackagePath -- | The set of variables that should be added to the conflict set if -- something goes wrong with this link set (in addition to the members -- of the link group itself) , lgBlame :: ConflictSet } deriving (Show, Eq) -- | Invariant for the set of link groups: every element in the link group -- must be pointing to the /same/ link group lgInvariant :: Map QPN LinkGroup -> Bool lgInvariant links = all invGroup (M.elems links) where invGroup :: LinkGroup -> Bool invGroup lg = allEqual $ map (`M.lookup` links) members where members :: [QPN] members = map (`Q` lgPackage lg) $ S.toList (lgMembers lg) -- | Package version of this group -- -- This is only known once we have picked a canonical element. lgInstance :: LinkGroup -> Maybe I lgInstance = fmap (\(PI _ i) -> i) . lgCanon showLinkGroup :: LinkGroup -> String showLinkGroup lg = "{" ++ intercalate "," (map showMember (S.toList (lgMembers lg))) ++ "}" where showMember :: PackagePath -> String showMember pp = case lgCanon lg of Just (PI pp' _i) | pp == pp' -> "*" _otherwise -> "" ++ case lgInstance lg of Nothing -> showQPN (qpn pp) Just i -> showPI (PI (qpn pp) i) qpn :: PackagePath -> QPN qpn pp = Q pp (lgPackage lg) -- | Creates a link group that contains a single member. lgSingleton :: QPN -> Maybe (PI PackagePath) -> LinkGroup lgSingleton (Q pp pn) canon = LinkGroup { lgPackage = pn , lgCanon = canon , lgMembers = S.singleton pp , lgBlame = CS.empty } lgMerge :: ConflictSet -> LinkGroup -> LinkGroup -> Either Conflict LinkGroup lgMerge blame lg lg' = do canon <- pick (lgCanon lg) (lgCanon lg') return LinkGroup { lgPackage = lgPackage lg , lgCanon = canon , lgMembers = lgMembers lg `S.union` lgMembers lg' , lgBlame = CS.unions [blame, lgBlame lg, lgBlame lg'] } where pick :: Eq a => Maybe a -> Maybe a -> Either Conflict (Maybe a) pick Nothing Nothing = Right Nothing pick (Just x) Nothing = Right $ Just x pick Nothing (Just y) = Right $ Just y pick (Just x) (Just y) = if x == y then Right $ Just x else Left ( CS.unions [ blame , lgConflictSet lg , lgConflictSet lg' ] , "cannot merge " ++ showLinkGroup lg ++ " and " ++ showLinkGroup lg' ) lgConflictSet :: LinkGroup -> ConflictSet lgConflictSet lg = CS.fromList (map aux (S.toList (lgMembers lg))) `CS.union` lgBlame lg where aux pp = P (Q pp (lgPackage lg)) {------------------------------------------------------------------------------- Auxiliary -------------------------------------------------------------------------------} allEqual :: Eq a => [a] -> Bool allEqual [] = True allEqual [_] = True allEqual (x:y:ys) = x == y && allEqual (y:ys) cabal-install-solver-3.8.1.0/src/Distribution/Solver/Modular/Log.hs0000644000000000000000000000172207346545000023272 0ustar0000000000000000module Distribution.Solver.Modular.Log ( displayLogMessages , SolverFailure(..) ) where import Prelude () import Distribution.Solver.Compat.Prelude import Distribution.Solver.Types.Progress import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Message import Distribution.Solver.Modular.RetryLog -- | Information about a dependency solver failure. data SolverFailure = ExhaustiveSearch ConflictSet ConflictMap | BackjumpLimitReached -- | Postprocesses a log file. This function discards all log messages and -- avoids calling 'showMessages' if the log isn't needed (specified by -- 'keepLog'), for efficiency. displayLogMessages :: Bool -> RetryLog Message SolverFailure a -> RetryLog String SolverFailure a displayLogMessages keepLog lg = fromProgress $ if keepLog then showMessages progress else foldProgress (const id) Fail Done progress where progress = toProgress lg cabal-install-solver-3.8.1.0/src/Distribution/Solver/Modular/Message.hs0000644000000000000000000003541707346545000024145 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} module Distribution.Solver.Modular.Message ( Message(..), showMessages ) where import qualified Data.List as L import Data.Map (Map) import qualified Data.Map as M import Data.Set (Set) import qualified Data.Set as S import Data.Maybe (catMaybes, mapMaybe) 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.MessageUtils (showUnsupportedExtension, showUnsupportedLanguage) import Distribution.Solver.Modular.Package import Distribution.Solver.Modular.Tree ( FailReason(..), POption(..), ConflictingDep(..) ) import Distribution.Solver.Modular.Version import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.Progress import Distribution.Types.LibraryName import Distribution.Types.UnqualComponentName data Message = Enter -- ^ increase indentation level | Leave -- ^ decrease indentation level | TryP QPN POption | TryF QFN Bool | TryS QSN Bool | Next (Goal QPN) | Skip (Set CS.Conflict) | Success | Failure ConflictSet FailReason -- | Transforms the structured message type to actual messages (strings). -- -- The log contains level numbers, which are useful for any trace that involves -- backtracking, because only the level numbers will allow to keep track of -- backjumps. showMessages :: Progress Message a b -> Progress String a b showMessages = go 0 where -- 'go' increments the level for a recursive call when it encounters -- 'TryP', 'TryF', or 'TryS' and decrements the level when it encounters 'Leave'. go :: Int -> Progress Message a b -> Progress String a b go !_ (Done x) = Done x go !_ (Fail x) = Fail x -- complex patterns go !l (Step (TryP qpn i) (Step Enter (Step (Failure c fr) (Step Leave ms)))) = goPReject l qpn [i] c fr ms 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) 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) 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) go !l (Step (Next (Goal (P qpn) gr)) (Step (Failure _c UnknownPackage) 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 (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) 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) showPackageGoal :: QPN -> QGoalReason -> String showPackageGoal qpn gr = "next goal: " ++ showQPN qpn ++ showGR gr showFailure :: ConflictSet -> FailReason -> String showFailure c fr = "fail" ++ showFR c fr -- special handler for many subsequent package rejections goPReject :: Int -> QPN -> [POption] -> ConflictSet -> FailReason -> 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 goPReject l qpn is c fr ms = (atLevel l $ "rejecting: " ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) ++ showFR c fr) (go l ms) -- Handle many subsequent skipped package instances. goPSkip :: Int -> QPN -> [POption] -> Set CS.Conflict -> 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 goPSkip l qpn is conflicts ms = let msg = "skipping: " ++ L.intercalate ", " (map (showQPNPOpt qpn) (reverse is)) ++ showConflicts conflicts in atLevel l msg (go l ms) -- write a message with the current level number atLevel :: Int -> String -> Progress String a b -> Progress String a b atLevel l x xs = let s = show l in Step ("[" ++ replicate (3 - length s) '_' ++ s ++ "] " ++ x) xs -- | Display the set of 'Conflicts' for a skipped package version. showConflicts :: Set CS.Conflict -> String showConflicts conflicts = " (has the same characteristics that caused the previous version to fail: " ++ conflictMsg ++ ")" where conflictMsg :: String conflictMsg = if S.member CS.OtherConflict conflicts then -- This case shouldn't happen, because an unknown conflict should not -- cause a version to be skipped. "unknown conflict" else let mergedConflicts = [ showConflict qpn conflict | (qpn, conflict) <- M.toList (mergeConflicts conflicts) ] in if L.null mergedConflicts then -- This case shouldn't happen unless backjumping is turned off. "none" else L.intercalate "; " mergedConflicts -- Merge conflicts to simplify the log message. mergeConflicts :: Set CS.Conflict -> Map QPN MergedPackageConflict mergeConflicts = M.fromListWith mergeConflict . mapMaybe toMergedConflict . S.toList where mergeConflict :: MergedPackageConflict -> MergedPackageConflict -> MergedPackageConflict mergeConflict mergedConflict1 mergedConflict2 = MergedPackageConflict { isGoalConflict = isGoalConflict mergedConflict1 || isGoalConflict mergedConflict2 , versionConstraintConflict = L.nub $ versionConstraintConflict mergedConflict1 ++ versionConstraintConflict mergedConflict2 , versionConflict = mergeVersionConflicts (versionConflict mergedConflict1) (versionConflict mergedConflict2) } where mergeVersionConflicts (Just vr1) (Just vr2) = Just (vr1 .||. vr2) mergeVersionConflicts (Just vr1) Nothing = Just vr1 mergeVersionConflicts Nothing (Just vr2) = Just vr2 mergeVersionConflicts Nothing Nothing = Nothing toMergedConflict :: CS.Conflict -> Maybe (QPN, MergedPackageConflict) toMergedConflict (CS.GoalConflict qpn) = Just (qpn, MergedPackageConflict True [] Nothing) toMergedConflict (CS.VersionConstraintConflict qpn v) = Just (qpn, MergedPackageConflict False [v] Nothing) toMergedConflict (CS.VersionConflict qpn (CS.OrderedVersionRange vr)) = Just (qpn, MergedPackageConflict False [] (Just vr)) toMergedConflict CS.OtherConflict = Nothing showConflict :: QPN -> MergedPackageConflict -> String showConflict qpn mergedConflict = L.intercalate "; " conflictStrings where conflictStrings = catMaybes [ case () of () | isGoalConflict mergedConflict -> Just $ "depends on '" ++ showQPN qpn ++ "'" ++ (if null (versionConstraintConflict mergedConflict) then "" else " but excludes " ++ showVersions (versionConstraintConflict mergedConflict)) | not $ L.null (versionConstraintConflict mergedConflict) -> Just $ "excludes '" ++ showQPN qpn ++ "' " ++ showVersions (versionConstraintConflict mergedConflict) | otherwise -> Nothing , (\vr -> "excluded by constraint '" ++ showVR vr ++ "' from '" ++ showQPN qpn ++ "'") <$> versionConflict mergedConflict ] showVersions [] = "no versions" showVersions [v] = "version " ++ showVer v showVersions vs = "versions " ++ L.intercalate ", " (map showVer vs) -- | All conflicts related to one package, used for simplifying the display of -- a 'Set CS.Conflict'. data MergedPackageConflict = MergedPackageConflict { isGoalConflict :: Bool , versionConstraintConflict :: [Ver] , versionConflict :: Maybe VR } showQPNPOpt :: QPN -> POption -> String showQPNPOpt 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) showGR :: QGoalReason -> String showGR UserGoal = " (user goal)" showGR (DependencyGoal dr) = " (dependency of " ++ showDependencyReason dr ++ ")" showFR :: ConflictSet -> FailReason -> String showFR _ (UnsupportedExtension ext) = " (conflict: requires " ++ showUnsupportedExtension ext ++ ")" showFR _ (UnsupportedLanguage lang) = " (conflict: requires " ++ showUnsupportedLanguage lang ++ ")" showFR _ (MissingPkgconfigPackage pn vr) = " (conflict: pkg-config package " ++ prettyShow pn ++ prettyShow vr ++ ", not found in the pkg-config database)" showFR _ (NewPackageDoesNotMatchExistingConstraint d) = " (conflict: " ++ showConflictingDep d ++ ")" showFR _ (ConflictingConstraints d1 d2) = " (conflict: " ++ L.intercalate ", " (L.map showConflictingDep [d1, d2]) ++ ")" showFR _ (NewPackageIsMissingRequiredComponent comp dr) = " (does not contain " ++ showExposedComponent comp ++ ", which is required by " ++ showDependencyReason dr ++ ")" showFR _ (NewPackageHasPrivateRequiredComponent comp dr) = " (" ++ showExposedComponent comp ++ " is private, but it is required by " ++ showDependencyReason dr ++ ")" showFR _ (NewPackageHasUnbuildableRequiredComponent comp dr) = " (" ++ showExposedComponent comp ++ " is not buildable in the current environment, but it is required by " ++ showDependencyReason dr ++ ")" 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 src) = " (" ++ constraintSource src ++ " requires " ++ prettyShow vr ++ ")" showFR _ (GlobalConstraintInstalled src) = " (" ++ constraintSource src ++ " requires installed instance)" showFR _ (GlobalConstraintSource src) = " (" ++ constraintSource src ++ " requires source instance)" showFR _ (GlobalConstraintFlag src) = " (" ++ constraintSource src ++ " requires opposite flag selection)" showFR _ ManualFlag = " (manual flag can only be changed explicitly)" showFR c Backjump = " (backjumping, conflict set: " ++ showConflictSet c ++ ")" showFR _ MultipleInstances = " (multiple instances)" showFR c (DependenciesNotLinked msg) = " (dependencies not linked: " ++ msg ++ "; conflict set: " ++ showConflictSet c ++ ")" showFR c CyclicDependencies = " (cyclic dependencies; conflict set: " ++ showConflictSet c ++ ")" showFR _ (UnsupportedSpecVer ver) = " (unsupported spec-version " ++ prettyShow ver ++ ")" -- 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 _ EmptyGoalChoice = " (INTERNAL ERROR: EMPTY GOAL CHOICE)" showExposedComponent :: ExposedComponent -> String showExposedComponent (ExposedLib LMainLibName) = "library" showExposedComponent (ExposedLib (LSubLibName name)) = "library '" ++ unUnqualComponentName name ++ "'" showExposedComponent (ExposedExe name) = "executable '" ++ unUnqualComponentName name ++ "'" constraintSource :: ConstraintSource -> String constraintSource src = "constraint from " ++ showConstraintSource src showConflictingDep :: ConflictingDep -> String showConflictingDep (ConflictingDep dr (PkgComponent qpn comp) ci) = let DependencyReason qpn' _ _ = dr componentStr = case comp of ExposedExe exe -> " (exe " ++ unUnqualComponentName exe ++ ")" ExposedLib LMainLibName -> "" ExposedLib (LSubLibName lib) -> " (lib " ++ unUnqualComponentName lib ++ ")" in case ci of Fixed i -> (if qpn /= qpn' then showDependencyReason dr ++ " => " else "") ++ showQPN qpn ++ componentStr ++ "==" ++ showI i Constrained vr -> showDependencyReason dr ++ " => " ++ showQPN qpn ++ componentStr ++ showVR vr cabal-install-solver-3.8.1.0/src/Distribution/Solver/Modular/MessageUtils.hs0000644000000000000000000000465307346545000025164 0ustar0000000000000000-- | Utility functions providing extra context to cabal error messages module Distribution.Solver.Modular.MessageUtils ( allKnownExtensions, cutoffRange, mostSimilarElement, showUnsupportedExtension, showUnsupportedLanguage, withinRange ) where import Data.Foldable (minimumBy) import Data.Ord (comparing) import Distribution.Pretty (prettyShow) -- from Cabal import Language.Haskell.Extension ( Extension(..), Language(..), knownLanguages, knownExtensions ) import Text.EditDistance ( defaultEditCosts, levenshteinDistance ) showUnsupportedExtension :: Extension -> String showUnsupportedExtension (UnknownExtension extStr) = formatMessage cutoffRange "extension" extStr (mostSimilarElement extStr allKnownExtensions) showUnsupportedExtension extension = unwords [prettyShow extension, "which is not supported"] showUnsupportedLanguage :: Language -> String showUnsupportedLanguage (UnknownLanguage langStr) = formatMessage cutoffRange "language" langStr (mostSimilarElement langStr (show <$> knownLanguages)) showUnsupportedLanguage knownLanguage = unwords [prettyShow knownLanguage, "which is not supported"] allKnownExtensions :: [String] allKnownExtensions = enabledExtensions ++ disabledExtensions where enabledExtensions = map (prettyShow . EnableExtension) knownExtensions disabledExtensions = map (prettyShow . DisableExtension) knownExtensions -- Measure the Levenshtein distance between two strings distance :: String -> String -> Int distance = levenshteinDistance defaultEditCosts -- Given an `unknownElement` and a list of `elements` return the element -- from the list with the closest Levenshtein distance to the `unknownElement` mostSimilarElement :: String -> [String] -> String mostSimilarElement unknownElement elements = fst . minimumBy (comparing snd) . map mapDist $ elements where mapDist element = (element, distance unknownElement element) -- Cutoff range for giving a suggested spelling cutoffRange :: Int cutoffRange = 10 formatMessage :: Int -> String -> String -> String -> String formatMessage range elementType element suggestion | withinRange range element suggestion = unwords ["unknown", elementType, element ++ ";", "did you mean", suggestion ++ "?"] | otherwise = unwords ["unknown", elementType, element] -- Check whether the strings are within cutoff range withinRange :: Int -> String -> String -> Bool withinRange range element suggestion = distance element suggestion <= range cabal-install-solver-3.8.1.0/src/Distribution/Solver/Modular/PSQ.hs0000644000000000000000000001011207346545000023205 0ustar0000000000000000{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} module Distribution.Solver.Modular.PSQ ( PSQ(..) -- Unit test needs constructor access , casePSQ , cons , length , lookup , filter , filterIfAny , filterIfAnyByKeys , filterKeys , firstOnly , fromList , isZeroOrOne , keys , map , mapKeys , mapWithKey , maximumBy , minimumBy , null , prefer , preferByKeys , snoc , sortBy , sortByKeys , toList , union ) where -- Priority search queues. -- -- I am not yet sure what exactly is needed. But we need a data structure with -- key-based lookup that can be sorted. We're using a sequence right now with -- (inefficiently implemented) lookup, because I think that queue-based -- operations and sorting turn out to be more efficiency-critical in practice. import Control.Arrow (first, second) import qualified Data.Foldable as F import Data.Function import qualified Data.List as S import Data.Ord (comparing) import Data.Traversable import Prelude hiding (foldr, length, lookup, filter, null, map) newtype PSQ k v = PSQ [(k, v)] deriving (Eq, Show, Functor, F.Foldable, Traversable) -- Qualified Foldable to avoid issues with FTP keys :: PSQ k v -> [k] keys (PSQ xs) = fmap fst xs lookup :: Eq k => k -> PSQ k v -> Maybe v lookup k (PSQ xs) = S.lookup k xs map :: (v1 -> v2) -> PSQ k v1 -> PSQ k v2 map f (PSQ xs) = PSQ (fmap (second f) xs) mapKeys :: (k1 -> k2) -> PSQ k1 v -> PSQ k2 v mapKeys f (PSQ xs) = PSQ (fmap (first f) xs) mapWithKey :: (k -> a -> b) -> PSQ k a -> PSQ k b mapWithKey f (PSQ xs) = PSQ (fmap (\ (k, v) -> (k, f k v)) xs) fromList :: [(k, a)] -> PSQ k a fromList = PSQ cons :: k -> a -> PSQ k a -> PSQ k a cons k x (PSQ xs) = PSQ ((k, x) : xs) snoc :: PSQ k a -> k -> a -> PSQ k a snoc (PSQ xs) k x = PSQ (xs ++ [(k, x)]) casePSQ :: PSQ k a -> r -> (k -> a -> PSQ k a -> r) -> r casePSQ (PSQ xs) n c = case xs of [] -> n (k, v) : ys -> c k v (PSQ ys) sortBy :: (a -> a -> Ordering) -> PSQ k a -> PSQ k a sortBy cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` snd) xs) sortByKeys :: (k -> k -> Ordering) -> PSQ k a -> PSQ k a sortByKeys cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` fst) xs) maximumBy :: (k -> Int) -> PSQ k a -> (k, a) maximumBy sel (PSQ xs) = S.minimumBy (flip (comparing (sel . fst))) xs minimumBy :: (a -> Int) -> PSQ k a -> PSQ k a minimumBy sel (PSQ xs) = PSQ [snd (S.minimumBy (comparing fst) (S.map (\ x -> (sel (snd x), x)) xs))] -- | Sort the list so that values satisfying the predicate are first. prefer :: (a -> Bool) -> PSQ k a -> PSQ k a prefer p = sortBy $ flip (comparing p) -- | Sort the list so that keys satisfying the predicate are first. preferByKeys :: (k -> Bool) -> PSQ k a -> PSQ k a preferByKeys p = sortByKeys $ flip (comparing p) -- | Will partition the list according to the predicate. If -- there is any element that satisfies the predicate, then only -- the elements satisfying the predicate are returned. -- Otherwise, the rest is returned. -- filterIfAny :: (a -> Bool) -> PSQ k a -> PSQ k a filterIfAny p (PSQ xs) = let (pro, con) = S.partition (p . snd) xs in if S.null pro then PSQ con else PSQ pro -- | Variant of 'filterIfAny' that takes a predicate on the keys -- rather than on the values. -- filterIfAnyByKeys :: (k -> Bool) -> PSQ k a -> PSQ k a filterIfAnyByKeys p (PSQ xs) = let (pro, con) = S.partition (p . fst) xs in if S.null pro then PSQ con else PSQ pro filterKeys :: (k -> Bool) -> PSQ k a -> PSQ k a filterKeys p (PSQ xs) = PSQ (S.filter (p . fst) xs) filter :: (a -> Bool) -> PSQ k a -> PSQ k a filter p (PSQ xs) = PSQ (S.filter (p . snd) xs) length :: PSQ k a -> Int length (PSQ xs) = S.length xs null :: PSQ k a -> Bool null (PSQ xs) = S.null xs isZeroOrOne :: PSQ k a -> Bool isZeroOrOne (PSQ []) = True isZeroOrOne (PSQ [_]) = True isZeroOrOne _ = False firstOnly :: PSQ k a -> PSQ k a firstOnly (PSQ []) = PSQ [] firstOnly (PSQ (x : _)) = PSQ [x] toList :: PSQ k a -> [(k, a)] toList (PSQ xs) = xs union :: PSQ k a -> PSQ k a -> PSQ k a union (PSQ xs) (PSQ ys) = PSQ (xs ++ ys) cabal-install-solver-3.8.1.0/src/Distribution/Solver/Modular/Package.hs0000644000000000000000000000601007346545000024077 0ustar0000000000000000{-# LANGUAGE DeriveFunctor #-} module Distribution.Solver.Modular.Package ( I(..) , Loc(..) , PackageId , PackageIdentifier(..) , PackageName, mkPackageName, unPackageName , PkgconfigName, mkPkgconfigName, unPkgconfigName , PI(..) , PN , QPV , instI , makeIndependent , primaryPP , setupPP , showI , showPI , unPN ) where import Prelude () import Distribution.Solver.Compat.Prelude import Distribution.Package -- from Cabal import Distribution.Pretty (prettyShow) import Distribution.Solver.Modular.Version import Distribution.Solver.Types.PackagePath -- | A package name. type PN = PackageName -- | Unpacking a package name. unPN :: PN -> String unPN = unPackageName -- | Package version. A package name plus a version number. type PV = PackageId -- | Qualified package version. type QPV = Qualified PV -- | Package id. Currently just a black-box string. type PId = UnitId -- | Location. Info about whether a package is installed or not, and where -- exactly it is located. For installed packages, uniquely identifies the -- package instance via its 'PId'. -- -- TODO: More information is needed about the repo. data Loc = Inst PId | InRepo deriving (Eq, Ord, Show) -- | Instance. A version number and a location. data I = I Ver Loc deriving (Eq, Ord, Show) -- | String representation of an instance. showI :: I -> String showI (I v InRepo) = showVer v showI (I v (Inst uid)) = showVer v ++ "/installed" ++ extractPackageAbiHash uid where extractPackageAbiHash xs = case first reverse $ break (=='-') $ reverse (prettyShow xs) of (ys, []) -> ys (ys, _) -> '-' : ys -- | Package instance. A package name and an instance. data PI qpn = PI qpn I deriving (Eq, Ord, Show, Functor) -- | String representation of a package instance. showPI :: PI QPN -> String showPI (PI qpn i) = showQPN qpn ++ "-" ++ showI i instI :: I -> Bool instI (I _ (Inst _)) = True instI _ = False -- | Is the package in the primary group of packages. This is used to -- determine (1) if we should try to establish stanza preferences -- for this goal, and (2) whether or not a user specified @--constraint@ -- should apply to this dependency (grep 'primaryPP' to see the -- use sites). In particular this does not include packages pulled in -- as setup deps. -- primaryPP :: PackagePath -> Bool primaryPP (PackagePath _ns q) = go q where go QualToplevel = True go (QualBase _) = True go (QualSetup _) = False go (QualExe _ _) = False -- | Is the package a dependency of a setup script. This is used to -- establish whether or not certain constraints should apply to this -- dependency (grep 'setupPP' to see the use sites). -- setupPP :: PackagePath -> Bool setupPP (PackagePath _ns (QualSetup _)) = True setupPP (PackagePath _ns _) = False -- | Qualify a target package with its own name so that its dependencies are not -- required to be consistent with other targets. makeIndependent :: PN -> QPN makeIndependent pn = Q (PackagePath (Independent pn) QualToplevel) pn cabal-install-solver-3.8.1.0/src/Distribution/Solver/Modular/Preference.hs0000644000000000000000000005230507346545000024632 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} -- | Reordering or pruning the tree in order to prefer or make certain choices. module Distribution.Solver.Modular.Preference ( avoidReinstalls , deferSetupExeChoices , deferWeakFlagChoices , enforceManualFlags , enforcePackageConstraints , enforceSingleInstanceRestriction , firstGoal , preferBaseGoalChoice , preferLinked , preferPackagePreferences , preferReallyEasyGoalChoices , requireInstalled , onlyConstrained , sortGoals , pruneAfterFirstSuccess ) where import Prelude () import Distribution.Solver.Compat.Prelude import qualified Data.List as L import qualified Data.Map as M import Control.Monad.Trans.Reader (Reader, runReader, ask, local) import Distribution.PackageDescription (lookupFlagAssignment, unFlagAssignment) -- from Cabal import Distribution.Solver.Types.Flag import Distribution.Solver.Types.InstalledPreference import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PackageConstraint import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.PackagePreferences import Distribution.Solver.Types.Variable import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Package import qualified Distribution.Solver.Modular.PSQ as P 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 -- | Update the weights of children under 'PChoice' nodes. 'addWeights' takes a -- list of weight-calculating functions in order to avoid sorting the package -- choices multiple times. Each function takes the package name, sorted list of -- children's versions, and package option. 'addWeights' prepends the new -- weights to the existing weights, which gives precedence to preferences that -- are applied later. addWeights :: [PN -> [Ver] -> POption -> Weight] -> EndoTreeTrav d c addWeights fs = go where go :: TreeF d c (Tree d c) -> TreeF d c (Tree d c) go (PChoiceF qpn@(Q _ pn) rdm x cs) = let sortedVersions = L.sortBy (flip compare) $ L.map version (W.keys cs) weights k = [f pn sortedVersions k | f <- fs] elemsToWhnf :: [a] -> () elemsToWhnf = foldr seq () in PChoiceF qpn rdm x -- Evaluate the children's versions before evaluating any of the -- subtrees, so that 'sortedVersions' doesn't hold onto all of the -- subtrees (referenced by cs) and cause a space leak. (elemsToWhnf sortedVersions `seq` W.mapWeightsWithKey (\k w -> weights k ++ w) cs) go x = x addWeight :: (PN -> [Ver] -> POption -> Weight) -> EndoTreeTrav d c addWeight f = addWeights [f] version :: POption -> Ver version (POption (I v _) _) = v -- | Prefer to link packages whenever possible. preferLinked :: EndoTreeTrav d c preferLinked = addWeight (const (const linked)) where linked (POption _ Nothing) = 1 linked (POption _ (Just _)) = 0 -- Works by setting weights on choice nodes. Also applies stanza preferences. preferPackagePreferences :: (PN -> PackagePreferences) -> EndoTreeTrav d c preferPackagePreferences pcs = preferPackageStanzaPreferences pcs . addWeights [ \pn _ opt -> preferred pn opt -- Note that we always rank installed before uninstalled, and later -- versions before earlier, but we can change the priority of the -- two orderings. , \pn vs opt -> case preference pn of PreferInstalled -> installed opt PreferLatest -> latest vs opt , \pn vs opt -> case preference pn of PreferInstalled -> latest vs opt PreferLatest -> installed opt ] where -- Prefer packages with higher version numbers over packages with -- lower version numbers. latest :: [Ver] -> POption -> Weight latest sortedVersions opt = let l = length sortedVersions index = fromMaybe l $ L.findIndex (<= version opt) sortedVersions in fromIntegral index / fromIntegral l preference :: PN -> InstalledPreference preference pn = let PackagePreferences _ ipref _ = pcs pn in ipref -- | Prefer versions satisfying more preferred version ranges. preferred :: PN -> POption -> Weight preferred pn opt = let PackagePreferences vrs _ _ = pcs pn in fromIntegral . negate . L.length $ L.filter (flip checkVR (version opt)) vrs -- Prefer installed packages over non-installed packages. installed :: POption -> Weight installed (POption (I _ (Inst _)) _) = 0 installed _ = 1 -- | Traversal that tries to establish package stanza enable\/disable -- preferences. Works by reordering the branches of stanza choices. -- Note that this works on packages lower in the path as well as at the top level. -- This is because stanza preferences apply to local packages only -- and for local packages, a single version is fixed, which means -- (for now) that all stanza preferences must be uniform at all levels. -- Further, even when we can have multiple versions of the same package, -- the build plan will be more efficient if we can attempt to keep -- stanza preferences aligned at all levels. preferPackageStanzaPreferences :: (PN -> PackagePreferences) -> EndoTreeTrav d c preferPackageStanzaPreferences pcs = go where go (SChoiceF qsn@(SN (Q _pp pn) s) rdm gr _tr ts) | enableStanzaPref pn s = -- move True case first to try enabling the stanza let ts' = W.mapWeightsWithKey (\k w -> weight k : w) ts weight k = if k then 0 else 1 -- defer the choice by setting it to weak in SChoiceF qsn rdm gr (WeakOrTrivial True) ts' go x = x enableStanzaPref :: PN -> OptionalStanza -> Bool enableStanzaPref pn s = let PackagePreferences _ _ spref = pcs pn in s `elem` spref -- | Helper function that tries to enforce a single package constraint on a -- given instance for a P-node. Translates the constraint into a -- tree-transformer that either leaves the subtree untouched, or replaces it -- with an appropriate failure node. processPackageConstraintP :: forall d c. QPN -> ConflictSet -> I -> LabeledPackageConstraint -> Tree d c -> Tree d c processPackageConstraintP qpn c i (LabeledPackageConstraint (PackageConstraint scope prop) src) r = if constraintScopeMatches scope qpn then go i prop else r where go :: I -> PackageProperty -> Tree d c go (I v _) (PackagePropertyVersion vr) | checkVR vr v = r | otherwise = Fail c (GlobalConstraintVersion vr src) go _ PackagePropertyInstalled | instI i = r | otherwise = Fail c (GlobalConstraintInstalled src) go _ PackagePropertySource | not (instI i) = r | otherwise = Fail c (GlobalConstraintSource src) go _ _ = r -- | Helper function that tries to enforce a single package constraint on a -- given flag setting for an F-node. Translates the constraint into a -- tree-transformer that either leaves the subtree untouched, or replaces it -- with an appropriate failure node. processPackageConstraintF :: forall d c. QPN -> Flag -> ConflictSet -> Bool -> LabeledPackageConstraint -> Tree d c -> Tree d c processPackageConstraintF qpn f c b' (LabeledPackageConstraint (PackageConstraint scope prop) src) r = if constraintScopeMatches scope qpn then go prop else r where go :: PackageProperty -> Tree d c go (PackagePropertyFlags fa) = case lookupFlagAssignment f fa of Nothing -> r Just b | b == b' -> r | otherwise -> Fail c (GlobalConstraintFlag src) go _ = r -- | Helper function that tries to enforce a single package constraint on a -- given flag setting for an F-node. Translates the constraint into a -- tree-transformer that either leaves the subtree untouched, or replaces it -- with an appropriate failure node. processPackageConstraintS :: forall d c. QPN -> OptionalStanza -> ConflictSet -> Bool -> LabeledPackageConstraint -> Tree d c -> Tree d c processPackageConstraintS qpn s c b' (LabeledPackageConstraint (PackageConstraint scope prop) src) r = if constraintScopeMatches scope qpn then go prop else r where go :: PackageProperty -> Tree d c go (PackagePropertyStanzas ss) = if not b' && s `elem` ss then Fail c (GlobalConstraintFlag src) else r go _ = r -- | Traversal that tries to establish various kinds of user constraints. Works -- by selectively disabling choices that have been ruled out by global user -- constraints. enforcePackageConstraints :: M.Map PN [LabeledPackageConstraint] -> EndoTreeTrav d c enforcePackageConstraints pcs = go where go (PChoiceF qpn@(Q _ pn) rdm gr ts) = let c = varToConflictSet (P qpn) -- compose the transformation functions for each of the relevant constraint g = \ (POption i _) -> foldl (\ h pc -> h . processPackageConstraintP qpn c i pc) id (M.findWithDefault [] pn pcs) in PChoiceF qpn rdm gr (W.mapWithKey g ts) go (FChoiceF qfn@(FN qpn@(Q _ pn) f) rdm gr tr m d ts) = let c = varToConflictSet (F qfn) -- compose the transformation functions for each of the relevant constraint g = \ b -> foldl (\ h pc -> h . processPackageConstraintF qpn f c b pc) id (M.findWithDefault [] pn pcs) in FChoiceF qfn rdm gr tr m d (W.mapWithKey g ts) go (SChoiceF qsn@(SN qpn@(Q _ pn) f) rdm gr tr ts) = let c = varToConflictSet (S qsn) -- compose the transformation functions for each of the relevant constraint g = \ b -> foldl (\ h pc -> h . processPackageConstraintS qpn f c b pc) id (M.findWithDefault [] pn pcs) in SChoiceF qsn rdm gr tr (W.mapWithKey g ts) go x = x -- | Transformation that tries to enforce the rule that manual flags can only be -- set by the user. -- -- If there are no constraints on a manual flag, this function prunes all but -- the default value. If there are constraints, then the flag is allowed to have -- the values specified by the constraints. Note that the type used for flag -- values doesn't need to be Bool. -- -- This function makes an exception for the case where there are multiple goals -- for a single package (with different qualifiers), and flag constraints for -- manual flag x only apply to some of those goals. In that case, we allow the -- unconstrained goals to use the default value for x OR any of the values in -- the constraints on x (even though the constraints don't apply), in order to -- allow the unconstrained goals to be linked to the constrained goals. See -- https://github.com/haskell/cabal/issues/4299. Removing the single instance -- restriction (SIR) would also fix #4299, so we may want to remove this -- exception and only let the user toggle manual flags if we remove the SIR. -- -- This function does not enforce any of the constraints, since that is done by -- 'enforcePackageConstraints'. enforceManualFlags :: M.Map PN [LabeledPackageConstraint] -> EndoTreeTrav d c enforceManualFlags pcs = go where go (FChoiceF qfn@(FN (Q _ pn) fn) rdm gr tr Manual d ts) = FChoiceF qfn rdm gr tr Manual d $ let -- A list of all values specified by constraints on 'fn'. -- We ignore the constraint scope in order to handle issue #4299. flagConstraintValues :: [Bool] flagConstraintValues = [ flagVal | let lpcs = M.findWithDefault [] pn pcs , (LabeledPackageConstraint (PackageConstraint _ (PackagePropertyFlags fa)) _) <- lpcs , (fn', flagVal) <- unFlagAssignment fa , fn' == fn ] -- Prune flag values that are not the default and do not match any -- of the constraints. restrictToggling :: Eq a => a -> [a] -> a -> Tree d c -> Tree d c restrictToggling flagDefault constraintVals flagVal r = if flagVal `elem` constraintVals || flagVal == flagDefault then r else Fail (varToConflictSet (F qfn)) ManualFlag 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. -- -- This is a tricky strategy. If a package version is installed already and the -- same version is available from a repo, the repo version will never be chosen. -- This would result in a reinstall (either destructively, or potentially, -- shadowing). The old instance won't be visible or even present anymore, but -- other packages might have depended on it. -- -- TODO: It would be better to actually check the reverse dependencies of installed -- packages. If they're not depended on, then reinstalling should be fine. Even if -- they are, perhaps this should just result in trying to reinstall those other -- packages as well. However, doing this all neatly in one pass would require to -- change the builder, or at least to change the goal set after building. avoidReinstalls :: (PN -> Bool) -> EndoTreeTrav d c avoidReinstalls p = go where go (PChoiceF qpn@(Q _ pn) rdm gr cs) | p pn = PChoiceF qpn rdm gr disableReinstalls | otherwise = PChoiceF qpn rdm gr cs where disableReinstalls = let installed = [ v | (_, POption (I v (Inst _)) _, _) <- W.toList cs ] in W.mapWithKey (notReinstall installed) cs notReinstall vs (POption (I v InRepo) _) _ | v `elem` vs = Fail (varToConflictSet (P qpn)) CannotReinstall notReinstall _ _ x = x 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 where go (PChoiceF v@(Q _ pn) _ gr _) | not (p pn) = FailF (varToConflictSet (P v) `CS.union` goalReasonToConflictSetWithConflict v gr) NotExplicit go x = x -- | Sort all goals using the provided function. sortGoals :: (Variable QPN -> Variable QPN -> Ordering) -> EndoTreeTrav d c sortGoals variableOrder = go where go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.sortByKeys goalOrder xs) go x = x goalOrder :: Goal QPN -> Goal QPN -> Ordering goalOrder = variableOrder `on` (varToVariable . goalToVar) varToVariable :: Var QPN -> Variable QPN varToVariable (P qpn) = PackageVar qpn varToVariable (F (FN qpn fn)) = FlagVar qpn fn varToVariable (S (SN qpn stanza)) = StanzaVar qpn stanza -- | Reduce the branching degree of the search tree by removing all choices -- after the first successful choice at each level. The returned tree is the -- minimal subtree containing the path to the first backjump. pruneAfterFirstSuccess :: EndoTreeTrav d c pruneAfterFirstSuccess = go where go (PChoiceF qpn rdm gr ts) = PChoiceF qpn rdm gr (W.takeUntil active ts) go (FChoiceF qfn rdm gr w m d ts) = FChoiceF qfn rdm gr w m d (W.takeUntil active ts) go (SChoiceF qsn rdm gr w ts) = SChoiceF qsn rdm gr w (W.takeUntil active ts) go x = x -- | Always choose the first goal in the list next, abandoning all -- other choices. -- -- This is unnecessary for the default search strategy, because -- it descends only into the first goal choice anyway, -- but may still make sense to just reduce the tree size a bit. firstGoal :: EndoTreeTrav d c firstGoal = go where go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.firstOnly xs) go x = x -- Note that we keep empty choice nodes, because they mean success. -- | Transformation that tries to make a decision on base as early as -- possible by pruning all other goals when base is available. In nearly -- all cases, there's a single choice for the base package. Also, fixing -- base early should lead to better error messages. preferBaseGoalChoice :: EndoTreeTrav d c preferBaseGoalChoice = go where go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.filterIfAnyByKeys isBase xs) go x = x isBase :: Goal QPN -> Bool isBase (Goal (P (Q _pp pn)) _) = unPN pn == "base" isBase _ = False -- | Deal with setup and build-tool-depends dependencies after regular dependencies, -- so we will link setup/exe dependencies against package dependencies when possible deferSetupExeChoices :: EndoTreeTrav d c deferSetupExeChoices = go where go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.preferByKeys noSetupOrExe xs) go x = x noSetupOrExe :: Goal QPN -> Bool noSetupOrExe (Goal (P (Q (PackagePath _ns (QualSetup _)) _)) _) = False noSetupOrExe (Goal (P (Q (PackagePath _ns (QualExe _ _)) _)) _) = False noSetupOrExe _ = True -- | Transformation that tries to avoid making weak flag choices early. -- Weak flags are trivial flags (not influencing dependencies) or such -- flags that are explicitly declared to be weak in the index. deferWeakFlagChoices :: EndoTreeTrav d c deferWeakFlagChoices = go where go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.prefer noWeakFlag (P.prefer noWeakStanza xs)) go x = x noWeakStanza :: Tree d c -> Bool noWeakStanza (SChoice _ _ _ (WeakOrTrivial True) _) = False noWeakStanza _ = True noWeakFlag :: Tree d c -> Bool noWeakFlag (FChoice _ _ _ (WeakOrTrivial True) _ _ _) = False noWeakFlag _ = True -- | Transformation that prefers goals with lower branching degrees. -- -- When a goal choice node has at least one goal with zero or one children, this -- function prunes all other goals. This transformation can help the solver find -- a solution in fewer steps by allowing it to backtrack sooner when it is -- exploring a subtree with no solutions. However, each step is more expensive. preferReallyEasyGoalChoices :: EndoTreeTrav d c preferReallyEasyGoalChoices = go where go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.filterIfAny zeroOrOneChoices xs) go x = x -- | Monad used internally in enforceSingleInstanceRestriction -- -- For each package instance we record the goal for which we picked a concrete -- instance. The SIR means that for any package instance there can only be one. type EnforceSIR = Reader (Map (PI PN) QPN) -- | Enforce ghc's single instance restriction -- -- From the solver's perspective, this means that for any package instance -- (that is, package name + package version) there can be at most one qualified -- goal resolving to that instance (there may be other goals _linking_ to that -- instance however). enforceSingleInstanceRestriction :: Tree d c -> Tree d c enforceSingleInstanceRestriction = (`runReader` M.empty) . go where go :: Tree d c -> EnforceSIR (Tree d c) -- We just verify package choices. go (PChoice qpn rdm gr cs) = PChoice qpn rdm gr <$> sequenceA (W.mapWithKey (goP qpn) (fmap go cs)) go (FChoice qfn rdm y t m d ts) = FChoice qfn rdm y t m d <$> traverse go ts go (SChoice qsn rdm y t ts) = SChoice qsn rdm y t <$> traverse go ts go (GoalChoice rdm ts) = GoalChoice rdm <$> traverse go ts go x@(Fail _ _) = return x go x@(Done _ _) = return x -- The check proper goP :: QPN -> POption -> EnforceSIR (Tree d c) -> EnforceSIR (Tree d c) goP qpn@(Q _ pn) (POption i linkedTo) r = do let inst = PI pn i env <- ask case (linkedTo, M.lookup inst env) of (Just _, _) -> -- For linked nodes we don't check anything r (Nothing, Nothing) -> -- Not linked, not already used local (M.insert inst qpn) r (Nothing, Just qpn') -> do -- Not linked, already used. This is an error return $ Fail (CS.union (varToConflictSet (P qpn)) (varToConflictSet (P qpn'))) MultipleInstances cabal-install-solver-3.8.1.0/src/Distribution/Solver/Modular/RetryLog.hs0000644000000000000000000000471607346545000024326 0ustar0000000000000000{-# LANGUAGE Rank2Types #-} module Distribution.Solver.Modular.RetryLog ( RetryLog , toProgress , fromProgress , mapFailure , retry , failWith , succeedWith , continueWith , tryWith ) where import Distribution.Solver.Compat.Prelude import Prelude () import Distribution.Solver.Modular.Message import Distribution.Solver.Types.Progress -- | 'Progress' as a difference list that allows efficient appends at failures. newtype RetryLog step fail done = RetryLog { unRetryLog :: forall fail2 . (fail -> Progress step fail2 done) -> Progress step fail2 done } -- | /O(1)/. Convert a 'RetryLog' to a 'Progress'. toProgress :: RetryLog step fail done -> Progress step fail done toProgress (RetryLog f) = f Fail -- | /O(N)/. Convert a 'Progress' to a 'RetryLog'. fromProgress :: Progress step fail done -> RetryLog step fail done fromProgress l = RetryLog $ \f -> go f l where go :: (fail1 -> Progress step fail2 done) -> Progress step fail1 done -> Progress step fail2 done go _ (Done d) = Done d go f (Fail failure) = f failure go f (Step m ms) = Step m (go f ms) -- | /O(1)/. Apply a function to the failure value in a log. mapFailure :: (fail1 -> fail2) -> RetryLog step fail1 done -> RetryLog step fail2 done mapFailure f l = retry l $ \failure -> RetryLog $ \g -> g (f failure) -- | /O(1)/. If the first log leads to failure, continue with the second. retry :: RetryLog step fail1 done -> (fail1 -> RetryLog step fail2 done) -> RetryLog step fail2 done retry (RetryLog f) g = RetryLog $ \extendLog -> f $ \failure -> unRetryLog (g failure) extendLog -- | /O(1)/. Create a log with one message before a failure. failWith :: step -> fail -> RetryLog step fail done failWith m failure = RetryLog $ \f -> Step m (f failure) -- | /O(1)/. Create a log with one message before a success. succeedWith :: step -> done -> RetryLog step fail done succeedWith m d = RetryLog $ const $ Step m (Done d) -- | /O(1)/. Prepend a message to a log. continueWith :: step -> RetryLog step fail done -> RetryLog step fail done continueWith m (RetryLog f) = RetryLog $ Step m . f -- | /O(1)/. Prepend the given message and 'Enter' to the log, and insert -- 'Leave' before the failure if the log fails. tryWith :: Message -> RetryLog Message fail done -> RetryLog Message fail done tryWith m f = RetryLog $ Step m . Step Enter . unRetryLog (retry f (failWith Leave)) cabal-install-solver-3.8.1.0/src/Distribution/Solver/Modular/Solver.hs0000644000000000000000000002513107346545000024023 0ustar0000000000000000{-# LANGUAGE CPP #-} #ifdef DEBUG_TRACETREE {-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} #endif module Distribution.Solver.Modular.Solver ( SolverConfig(..) , solve , PruneAfterFirstSuccess(..) ) where import Distribution.Solver.Compat.Prelude import Prelude () import qualified Data.Map as M import qualified Data.List as L import qualified Data.Set as S import Distribution.Verbosity import Distribution.Compiler (CompilerInfo) 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.Settings import Distribution.Solver.Types.Variable import Distribution.Solver.Modular.Assignment import Distribution.Solver.Modular.Builder import Distribution.Solver.Modular.Cycles import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Explore import Distribution.Solver.Modular.Index import Distribution.Solver.Modular.Log import Distribution.Solver.Modular.Message import Distribution.Solver.Modular.Package import qualified Distribution.Solver.Modular.Preference as P import Distribution.Solver.Modular.Validate import Distribution.Solver.Modular.Linking import Distribution.Solver.Modular.PSQ (PSQ) import Distribution.Solver.Modular.RetryLog import Distribution.Solver.Modular.Tree import qualified Distribution.Solver.Modular.PSQ as PSQ import Distribution.Simple.Setup (BooleanFlag(..)) #ifdef DEBUG_TRACETREE import qualified Distribution.Solver.Modular.ConflictSet as CS import qualified Distribution.Solver.Modular.WeightedPSQ as W import qualified Distribution.Deprecated.Text as T import Debug.Trace.Tree (gtraceJson) import Debug.Trace.Tree.Simple import Debug.Trace.Tree.Generic import Debug.Trace.Tree.Assoc (Assoc(..)) #endif -- | Various options for the modular solver. data SolverConfig = SolverConfig { reorderGoals :: ReorderGoals, countConflicts :: CountConflicts, fineGrainedConflicts :: FineGrainedConflicts, minimizeConflictSet :: MinimizeConflictSet, independentGoals :: IndependentGoals, avoidReinstalls :: AvoidReinstalls, shadowPkgs :: ShadowPkgs, strongFlags :: StrongFlags, allowBootLibInstalls :: AllowBootLibInstalls, onlyConstrained :: OnlyConstrained, maxBackjumps :: Maybe Int, enableBackjumping :: EnableBackjumping, solveExecutables :: SolveExecutables, goalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering), solverVerbosity :: Verbosity, pruneAfterFirstSuccess :: PruneAfterFirstSuccess } -- | Whether to remove all choices after the first successful choice at each -- level in the search tree. newtype PruneAfterFirstSuccess = PruneAfterFirstSuccess Bool -- | Run all solver phases. -- -- In principle, we have a valid tree after 'validationPhase', which -- means that every 'Done' node should correspond to valid solution. -- -- There is one exception, though, and that is cycle detection, which -- has been added relatively recently. Cycles are only removed directly -- before exploration. -- solve :: SolverConfig -- ^ solver parameters -> CompilerInfo -> Index -- ^ all available packages as an index -> PkgConfigDb -- ^ available pkg-config pkgs -> (PN -> PackagePreferences) -- ^ preferences -> M.Map PN [LabeledPackageConstraint] -- ^ global constraints -> S.Set PN -- ^ global goals -> RetryLog Message SolverFailure (Assignment, RevDepMap) solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals = explorePhase . traceTree "cycles.json" id . detectCycles . traceTree "heuristics.json" id . trav ( heuristicsPhase . preferencesPhase . validationPhase ) . traceTree "semivalidated.json" id . validationCata . traceTree "pruned.json" id . trav prunePhase . traceTree "build.json" id $ buildPhase where explorePhase = backjumpAndExplore (maxBackjumps sc) (enableBackjumping sc) (fineGrainedConflicts sc) (countConflicts sc) idx detectCycles = detectCyclesPhase heuristicsPhase = let sortGoals = case goalOrder sc of Nothing -> goalChoiceHeuristics . P.deferSetupExeChoices . P.deferWeakFlagChoices . P.preferBaseGoalChoice Just order -> P.firstGoal . P.sortGoals order PruneAfterFirstSuccess prune = pruneAfterFirstSuccess sc in sortGoals . (if prune then P.pruneAfterFirstSuccess else id) preferencesPhase = P.preferLinked . P.preferPackagePreferences userPrefs validationPhase = P.enforcePackageConstraints userConstraints . P.enforceManualFlags userConstraints validationCata = P.enforceSingleInstanceRestriction . 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 OnlyConstrainedNone -> id) buildPhase = buildTree idx (independentGoals sc) (S.toList userGoals) allExplicit = M.keysSet userConstraints `S.union` userGoals 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-prim" , "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. -- -- In the past, we furthermore used P.firstGoal to trim down the goal choice nodes -- to just a single option. This was a way to work around a space leak that was -- unnecessary and is now fixed, so we no longer do it. -- -- If --count-conflicts is active, it will then choose among the remaining goals -- the one that has been responsible for the most conflicts so far. -- -- Otherwise, we simply choose the first remaining goal. -- goalChoiceHeuristics | asBool (reorderGoals sc) = P.preferReallyEasyGoalChoices | otherwise = id {- P.firstGoal -} -- | Dump solver tree to a file (in debugging mode) -- -- This only does something if the @debug-tracetree@ configure argument was -- given; otherwise this is just the identity function. traceTree :: #ifdef DEBUG_TRACETREE GSimpleTree a => #endif FilePath -- ^ Output file -> (a -> a) -- ^ Function to summarize the tree before dumping -> a -> a #ifdef DEBUG_TRACETREE traceTree = gtraceJson #else traceTree _ _ = id #endif #ifdef DEBUG_TRACETREE instance GSimpleTree (Tree d c) where fromGeneric = go where go :: Tree d c -> SimpleTree go (PChoice qpn _ _ psq) = Node "P" $ Assoc $ L.map (uncurry (goP qpn)) $ psqToList psq go (FChoice _ _ _ _ _ _ psq) = Node "F" $ Assoc $ L.map (uncurry goFS) $ psqToList psq go (SChoice _ _ _ _ psq) = Node "S" $ Assoc $ L.map (uncurry goFS) $ psqToList psq go (GoalChoice _ psq) = Node "G" $ Assoc $ L.map (uncurry goG) $ PSQ.toList psq go (Done _rdm _s) = Node "D" $ Assoc [] go (Fail cs _reason) = Node "X" $ Assoc [("CS", Leaf $ goCS cs)] psqToList :: W.WeightedPSQ w k v -> [(k, v)] psqToList = L.map (\(_, k, v) -> (k, v)) . W.toList -- Show package choice goP :: QPN -> POption -> Tree d c -> (String, SimpleTree) goP _ (POption (I ver _loc) Nothing) subtree = (T.display ver, go subtree) goP (Q _ pn) (POption _ (Just pp)) subtree = (showQPN (Q pp pn), go subtree) -- Show flag or stanza choice goFS :: Bool -> Tree d c -> (String, SimpleTree) goFS val subtree = (show val, go subtree) -- Show goal choice goG :: Goal QPN -> Tree d c -> (String, SimpleTree) goG (Goal var gr) subtree = (showVar var ++ " (" ++ shortGR gr ++ ")", go subtree) -- Variation on 'showGR' that produces shorter strings -- (Actually, QGoalReason records more info than necessary: we only need -- to know the variable that introduced the goal, not the value assigned -- to that variable) shortGR :: QGoalReason -> String shortGR UserGoal = "user" shortGR (DependencyGoal dr) = showDependencyReason dr -- Show conflict set goCS :: ConflictSet -> String goCS cs = "{" ++ (intercalate "," . L.map showVar . CS.toList $ cs) ++ "}" #endif -- | Replace all goal reasons with a dummy goal reason in the tree -- -- This is useful for debugging (when experimenting with the impact of GRs) _removeGR :: Tree d c -> Tree d QGoalReason _removeGR = trav go where go :: TreeF d c (Tree d QGoalReason) -> TreeF d QGoalReason (Tree d QGoalReason) go (PChoiceF qpn rdm _ psq) = PChoiceF qpn rdm dummy psq go (FChoiceF qfn rdm _ a b d psq) = FChoiceF qfn rdm dummy a b d psq go (SChoiceF qsn rdm _ a psq) = SChoiceF qsn rdm dummy a psq go (GoalChoiceF rdm psq) = GoalChoiceF rdm (goG psq) go (DoneF rdm s) = DoneF rdm s go (FailF cs reason) = FailF cs reason goG :: PSQ (Goal QPN) (Tree d QGoalReason) -> PSQ (Goal QPN) (Tree d QGoalReason) goG = PSQ.fromList . L.map (\(Goal var _, subtree) -> (Goal var dummy, subtree)) . PSQ.toList dummy :: QGoalReason dummy = DependencyGoal $ DependencyReason (Q (PackagePath DefaultNamespace QualToplevel) (mkPackageName "$")) M.empty S.empty cabal-install-solver-3.8.1.0/src/Distribution/Solver/Modular/Tree.hs0000644000000000000000000002125207346545000023450 0ustar0000000000000000{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} module Distribution.Solver.Modular.Tree ( POption(..) , Tree(..) , TreeF(..) , Weight , FailReason(..) , ConflictingDep(..) , ana , cata , inn , innM , para , trav , zeroOrOneChoices , active , TreeTrav , EndoTreeTrav ) where import Control.Monad hiding (mapM, sequence) import Data.Foldable import Data.Traversable import Prelude hiding (foldr, mapM, sequence) import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Package import Distribution.Solver.Modular.PSQ (PSQ) import Distribution.Solver.Modular.Version import Distribution.Solver.Modular.WeightedPSQ (WeightedPSQ) import qualified Distribution.Solver.Modular.WeightedPSQ as W import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.Flag import Distribution.Solver.Types.PackagePath import Distribution.Types.PkgconfigVersionRange import Distribution.Types.UnitId (UnitId) import Language.Haskell.Extension (Extension, Language) type Weight = Double -- | Type of the search tree. Inlining the choice nodes for now. Weights on -- package, flag, and stanza choices control the traversal order. -- -- The tree can hold additional data on 'Done' nodes (type 'd') and choice nodes -- (type 'c'). For example, during the final traversal, choice nodes contain the -- variables that introduced the choices, and 'Done' nodes contain the -- assignments for all variables. -- -- TODO: The weight type should be changed from [Double] to Double to avoid -- giving too much weight to preferences that are applied later. data Tree d c = -- | Choose a version for a package (or choose to link) PChoice QPN RevDepMap c (WeightedPSQ [Weight] POption (Tree d c)) -- | Choose a value for a flag -- -- The Bool is the default value. | FChoice QFN RevDepMap c WeakOrTrivial FlagType Bool (WeightedPSQ [Weight] Bool (Tree d c)) -- | Choose whether or not to enable a stanza | SChoice QSN RevDepMap c WeakOrTrivial (WeightedPSQ [Weight] Bool (Tree d c)) -- | Choose which choice to make next -- -- Invariants: -- -- * PSQ should never be empty -- * For each choice we additionally record the 'QGoalReason' why we are -- introducing that goal into tree. Note that most of the time we are -- working with @Tree QGoalReason@; in that case, we must have the -- invariant that the 'QGoalReason' cached in the 'PChoice', 'FChoice' -- or 'SChoice' directly below a 'GoalChoice' node must equal the reason -- recorded on that 'GoalChoice' node. | GoalChoice RevDepMap (PSQ (Goal QPN) (Tree d c)) -- | We're done -- we found a solution! | Done RevDepMap d -- | We failed to find a solution in this path through the tree | Fail ConflictSet FailReason -- | A package option is a package instance with an optional linking annotation -- -- The modular solver has a number of package goals to solve for, and can only -- pick a single package version for a single goal. In order to allow to -- install multiple versions of the same package as part of a single solution -- the solver uses qualified goals. For example, @0.P@ and @1.P@ might both -- be qualified goals for @P@, allowing to pick a difference version of package -- @P@ for @0.P@ and @1.P@. -- -- Linking is an essential part of this story. In addition to picking a specific -- version for @1.P@, the solver can also decide to link @1.P@ to @0.P@ (or -- vice versa). It means that @1.P@ and @0.P@ really must be the very same package -- (and hence must have the same build time configuration, and their -- dependencies must also be the exact same). -- -- See for details. data POption = POption I (Maybe PackagePath) deriving (Eq, Show) data FailReason = UnsupportedExtension Extension | UnsupportedLanguage Language | MissingPkgconfigPackage PkgconfigName PkgconfigVersionRange | NewPackageDoesNotMatchExistingConstraint ConflictingDep | ConflictingConstraints ConflictingDep ConflictingDep | NewPackageIsMissingRequiredComponent ExposedComponent (DependencyReason QPN) | NewPackageHasPrivateRequiredComponent ExposedComponent (DependencyReason QPN) | NewPackageHasUnbuildableRequiredComponent ExposedComponent (DependencyReason QPN) | PackageRequiresMissingComponent QPN ExposedComponent | PackageRequiresPrivateComponent QPN ExposedComponent | PackageRequiresUnbuildableComponent QPN ExposedComponent | CannotInstall | CannotReinstall | NotExplicit | Shadowed | Broken UnitId | UnknownPackage | GlobalConstraintVersion VR ConstraintSource | GlobalConstraintInstalled ConstraintSource | GlobalConstraintSource ConstraintSource | GlobalConstraintFlag ConstraintSource | ManualFlag | MalformedFlagChoice QFN | MalformedStanzaChoice QSN | EmptyGoalChoice | Backjump | MultipleInstances | DependenciesNotLinked String | CyclicDependencies | UnsupportedSpecVer Ver deriving (Eq, Show) -- | Information about a dependency involved in a conflict, for error messages. data ConflictingDep = ConflictingDep (DependencyReason QPN) (PkgComponent QPN) CI deriving (Eq, Show) -- | Functor for the tree type. 'a' is the type of nodes' children. 'd' and 'c' -- have the same meaning as in 'Tree'. data TreeF d c a = PChoiceF QPN RevDepMap c (WeightedPSQ [Weight] POption a) | FChoiceF QFN RevDepMap c WeakOrTrivial FlagType Bool (WeightedPSQ [Weight] Bool a) | SChoiceF QSN RevDepMap c WeakOrTrivial (WeightedPSQ [Weight] Bool a) | GoalChoiceF RevDepMap (PSQ (Goal QPN) a) | DoneF RevDepMap d | FailF ConflictSet FailReason deriving (Functor, Foldable, Traversable) out :: Tree d c -> TreeF d c (Tree d c) out (PChoice p s i ts) = PChoiceF p s i ts out (FChoice p s i b m d ts) = FChoiceF p s i b m d ts out (SChoice p s i b ts) = SChoiceF p s i b ts out (GoalChoice s ts) = GoalChoiceF s ts out (Done x s ) = DoneF x s out (Fail c x ) = FailF c x inn :: TreeF d c (Tree d c) -> Tree d c inn (PChoiceF p s i ts) = PChoice p s i ts inn (FChoiceF p s i b m d ts) = FChoice p s i b m d ts inn (SChoiceF p s i b ts) = SChoice p s i b ts inn (GoalChoiceF s ts) = GoalChoice s ts inn (DoneF x s ) = Done x s inn (FailF c x ) = Fail c x innM :: Monad m => TreeF d c (m (Tree d c)) -> m (Tree d c) innM (PChoiceF p s i ts) = liftM (PChoice p s i ) (sequence ts) innM (FChoiceF p s i b m d ts) = liftM (FChoice p s i b m d) (sequence ts) innM (SChoiceF p s i b ts) = liftM (SChoice p s i b ) (sequence ts) innM (GoalChoiceF s ts) = liftM (GoalChoice s ) (sequence ts) innM (DoneF x s ) = return $ Done x s innM (FailF c x ) = return $ Fail c x -- | Determines whether a tree is active, i.e., isn't a failure node. active :: Tree d c -> Bool active (Fail _ _) = False active _ = True -- | Approximates the number of active choices that are available in a node. -- Note that we count goal choices as having one choice, always. zeroOrOneChoices :: Tree d c -> Bool zeroOrOneChoices (PChoice _ _ _ ts) = W.isZeroOrOne (W.filter active ts) zeroOrOneChoices (FChoice _ _ _ _ _ _ ts) = W.isZeroOrOne (W.filter active ts) zeroOrOneChoices (SChoice _ _ _ _ ts) = W.isZeroOrOne (W.filter active ts) zeroOrOneChoices (GoalChoice _ _ ) = True zeroOrOneChoices (Done _ _ ) = True zeroOrOneChoices (Fail _ _ ) = True -- | Catamorphism on trees. cata :: (TreeF d c a -> a) -> Tree d c -> a cata phi x = (phi . fmap (cata phi) . out) x type TreeTrav d c a = TreeF d c (Tree d a) -> TreeF d a (Tree d a) type EndoTreeTrav d c = TreeTrav d c c trav :: TreeTrav d c a -> Tree d c -> Tree d a trav psi x = cata (inn . psi) x -- | Paramorphism on trees. para :: (TreeF d c (a, Tree d c) -> a) -> Tree d c -> a para phi = phi . fmap (\ x -> (para phi x, x)) . out -- | Anamorphism on trees. ana :: (a -> TreeF d c a) -> a -> Tree d c ana psi = inn . fmap (ana psi) . psi cabal-install-solver-3.8.1.0/src/Distribution/Solver/Modular/Validate.hs0000644000000000000000000007202107346545000024302 0ustar0000000000000000{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE CPP #-} #ifdef DEBUG_CONFLICT_SETS {-# LANGUAGE ImplicitParams #-} #endif module Distribution.Solver.Modular.Validate (validateTree) where -- Validation of the tree. -- -- The task here is to make sure all constraints hold. After validation, any -- assignment returned by exploration of the tree should be a complete valid -- assignment, i.e., actually constitute a solution. import Control.Monad.Reader import Data.Either (lefts) import Data.Function (on) import qualified Data.List as L import qualified Data.Set as S import Language.Haskell.Extension (Extension, Language) import Data.Map.Strict as M import Distribution.Compiler (CompilerInfo(..)) import Distribution.Solver.Modular.Assignment import qualified Distribution.Solver.Modular.ConflictSet as CS import Distribution.Solver.Modular.Dependency import Distribution.Solver.Modular.Flag import Distribution.Solver.Modular.Index import Distribution.Solver.Modular.Package import Distribution.Solver.Modular.Tree import Distribution.Solver.Modular.Version import qualified Distribution.Solver.Modular.WeightedPSQ as W import Distribution.Solver.Types.PackagePath import Distribution.Solver.Types.PkgConfigDb (PkgConfigDb, pkgConfigPkgIsPresent) 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 -- of currently active constraints that we pass down the node. -- -- We aim at detecting inconsistent states as early as possible. -- -- Whenever we make a choice, there are two things that need to happen: -- -- (1) We must check that the choice is consistent with the currently -- active constraints. -- -- (2) The choice increases the set of active constraints. For the new -- active constraints, we must check that they are consistent with -- the current state. -- -- We can actually merge (1) and (2) by saying the current choice is -- a new active constraint, fixing the choice. -- -- If a test fails, we have detected an inconsistent state. We can -- disable the current subtree and do not have to traverse it any further. -- -- We need a good way to represent the current state, i.e., the current -- set of active constraints. Since the main situation where we have to -- search in it is (1), it seems best to store the state by package: for -- every package, we store which versions are still allowed. If for any -- package, we have inconsistent active constraints, we can also stop. -- This is a particular way to read task (2): -- -- (2, weak) We only check if the new constraints are consistent with -- the choices we've already made, and add them to the active set. -- -- (2, strong) We check if the new constraints are consistent with the -- choices we've already made, and the constraints we already have. -- -- It currently seems as if we're implementing the weak variant. However, -- when used together with 'preferEasyGoalChoices', we will find an -- inconsistent state in the very next step. -- -- What do we do about flags? -- -- Like for packages, we store the flag choices we have already made. -- Now, regarding (1), we only have to test whether we've decided the -- current flag before. Regarding (2), the interesting bit is in discovering -- the new active constraints. To this end, we look up the constraints for -- the package the flag belongs to, and traverse its flagged dependencies. -- Wherever we find the flag in question, we start recording dependencies -- underneath as new active dependencies. If we encounter other flags, we -- check if we've chosen them already and either proceed or stop. -- | The state needed during validation. data ValidateState = VS { supportedExt :: Extension -> Bool, supportedLang :: Language -> Bool, presentPkgs :: PkgconfigName -> PkgconfigVersionRange -> Bool, index :: Index, -- Saved, scoped, dependencies. Every time 'validate' makes a package choice, -- it qualifies the package's dependencies and saves them in this map. Then -- the qualified dependencies are available for subsequent flag and stanza -- choices for the same package. saved :: Map QPN (FlaggedDeps QPN), pa :: PreAssignment, -- Map from package name to the components that are provided by the chosen -- instance of that package, and whether those components are visible and -- buildable. availableComponents :: Map QPN (Map ExposedComponent ComponentInfo), -- Map from package name to the components that are required from that -- package. requiredComponents :: Map QPN ComponentDependencyReasons, qualifyOptions :: QualifyOptions } newtype Validate a = Validate (Reader ValidateState a) deriving (Functor, Applicative, Monad, MonadReader ValidateState) runValidate :: Validate a -> ValidateState -> a runValidate (Validate r) = runReader r -- | A preassignment comprises knowledge about variables, but not -- necessarily fixed values. data PreAssignment = PA PPreAssignment FAssignment SAssignment -- | A (partial) package preassignment. Qualified package names -- are associated with MergedPkgDeps. type PPreAssignment = Map QPN MergedPkgDep -- | A dependency on a component, including its DependencyReason. data PkgDep = PkgDep (DependencyReason QPN) (PkgComponent QPN) CI -- | Map from component name to one of the reasons that the component is -- required. type ComponentDependencyReasons = Map ExposedComponent (DependencyReason QPN) -- | MergedPkgDep records constraints about the instances that can still be -- chosen, and in the extreme case fixes a concrete instance. Otherwise, it is a -- list of version ranges paired with the goals / variables that introduced -- them. It also records whether a package is a build-tool dependency, for each -- reason that it was introduced. -- -- It is important to store the component name with the version constraint, for -- error messages, because whether something is a build-tool dependency affects -- its qualifier, which affects which constraint is applied. data MergedPkgDep = MergedDepFixed ExposedComponent (DependencyReason QPN) I | MergedDepConstrained [VROrigin] -- | Version ranges paired with origins. type VROrigin = (VR, ExposedComponent, DependencyReason QPN) -- | The information needed to create a 'Fail' node. type Conflict = (ConflictSet, FailReason) validate :: Tree d c -> Validate (Tree d c) validate = go where go :: Tree d c -> Validate (Tree d c) go (PChoice qpn rdm gr ts) = PChoice qpn rdm gr <$> W.traverseWithKey (\k -> goP qpn k . go) ts go (FChoice qfn rdm gr b m d ts) = do -- Flag choices may occur repeatedly (because they can introduce new constraints -- in various places). However, subsequent choices must be consistent. We thereby -- collapse repeated flag choice nodes. PA _ pfa _ <- asks pa -- obtain current flag-preassignment case M.lookup qfn pfa of Just rb -> -- flag has already been assigned; collapse choice to the correct branch case W.lookup rb ts of Just t -> goF qfn rb (go t) Nothing -> return $ Fail (varToConflictSet (F qfn)) (MalformedFlagChoice qfn) Nothing -> -- flag choice is new, follow both branches FChoice qfn rdm gr b m d <$> W.traverseWithKey (\k -> goF qfn k . go) ts go (SChoice qsn rdm gr b ts) = do -- Optional stanza choices are very similar to flag choices. PA _ _ psa <- asks pa -- obtain current stanza-preassignment case M.lookup qsn psa of Just rb -> -- stanza choice has already been made; collapse choice to the correct branch case W.lookup rb ts of Just t -> goS qsn rb (go t) Nothing -> return $ Fail (varToConflictSet (S qsn)) (MalformedStanzaChoice qsn) Nothing -> -- stanza choice is new, follow both branches SChoice qsn rdm gr b <$> W.traverseWithKey (\k -> goS qsn k . go) ts -- We don't need to do anything for goal choices or failure nodes. go (GoalChoice rdm ts) = GoalChoice rdm <$> traverse go ts go (Done rdm s ) = pure (Done rdm s) go (Fail c fr ) = pure (Fail c fr) -- What to do for package nodes ... goP :: QPN -> POption -> Validate (Tree d c) -> Validate (Tree d c) goP qpn@(Q _pp pn) (POption i _) r = do PA ppa pfa psa <- asks pa -- obtain current preassignment extSupported <- asks supportedExt -- obtain the supported extensions langSupported <- asks supportedLang -- obtain the supported languages pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs idx <- asks index -- obtain the index svd <- asks saved -- obtain saved dependencies aComps <- asks availableComponents rComps <- asks requiredComponents qo <- asks qualifyOptions -- obtain dependencies and index-dictated exclusions introduced by the choice let (PInfo deps comps _ mfr) = idx ! pn ! i -- qualify the deps in the current scope let qdeps = qualifyDeps qo qpn deps -- the new active constraints are given by the instance we have chosen, -- plus the dependency information we have for that instance let newactives = extractAllDeps pfa psa qdeps -- We now try to extend the partial assignment with the new active constraints. let mnppa = extend extSupported langSupported pkgPresent newactives =<< extendWithPackageChoice (PI qpn i) ppa -- In case we continue, we save the scoped dependencies let nsvd = M.insert qpn qdeps svd case mfr of Just fr -> -- The index marks this as an invalid choice. We can stop. return (Fail (varToConflictSet (P qpn)) fr) Nothing -> let newDeps :: Either Conflict (PPreAssignment, Map QPN ComponentDependencyReasons) newDeps = do nppa <- mnppa rComps' <- extendRequiredComponents qpn aComps rComps newactives checkComponentsInNewPackage (M.findWithDefault M.empty qpn rComps) qpn comps return (nppa, rComps') in case newDeps of Left (c, fr) -> -- We have an inconsistency. We can stop. return (Fail c fr) Right (nppa, rComps') -> -- We have an updated partial assignment for the recursive validation. local (\ s -> s { pa = PA nppa pfa psa , saved = nsvd , availableComponents = M.insert qpn comps aComps , requiredComponents = rComps' }) r -- What to do for flag nodes ... goF :: QFN -> Bool -> Validate (Tree d c) -> Validate (Tree d c) goF qfn@(FN qpn _f) b r = do PA ppa pfa psa <- asks pa -- obtain current preassignment extSupported <- asks supportedExt -- obtain the supported extensions langSupported <- asks supportedLang -- obtain the supported languages pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs svd <- asks saved -- obtain saved dependencies aComps <- asks availableComponents rComps <- asks requiredComponents -- Note that there should be saved dependencies for the package in question, -- because while building, we do not choose flags before we see the packages -- that define them. let qdeps = svd ! qpn -- We take the *saved* dependencies, because these have been qualified in the -- correct scope. -- -- Extend the flag assignment let npfa = M.insert qfn b pfa -- We now try to get the new active dependencies we might learn about because -- we have chosen a new flag. let newactives = extractNewDeps (F qfn) b npfa psa qdeps mNewRequiredComps = extendRequiredComponents qpn aComps rComps newactives -- As in the package case, we try to extend the partial assignment. let mnppa = extend extSupported langSupported pkgPresent newactives ppa case liftM2 (,) mnppa mNewRequiredComps of Left (c, fr) -> return (Fail c fr) -- inconsistency found Right (nppa, rComps') -> local (\ s -> s { pa = PA nppa npfa psa, requiredComponents = rComps' }) r -- What to do for stanza nodes (similar to flag nodes) ... goS :: QSN -> Bool -> Validate (Tree d c) -> Validate (Tree d c) goS qsn@(SN qpn _f) b r = do PA ppa pfa psa <- asks pa -- obtain current preassignment extSupported <- asks supportedExt -- obtain the supported extensions langSupported <- asks supportedLang -- obtain the supported languages pkgPresent <- asks presentPkgs -- obtain the present pkg-config pkgs svd <- asks saved -- obtain saved dependencies aComps <- asks availableComponents rComps <- asks requiredComponents -- Note that there should be saved dependencies for the package in question, -- because while building, we do not choose flags before we see the packages -- that define them. let qdeps = svd ! qpn -- We take the *saved* dependencies, because these have been qualified in the -- correct scope. -- -- Extend the flag assignment let npsa = M.insert qsn b psa -- We now try to get the new active dependencies we might learn about because -- we have chosen a new flag. let newactives = extractNewDeps (S qsn) b pfa npsa qdeps mNewRequiredComps = extendRequiredComponents qpn aComps rComps newactives -- As in the package case, we try to extend the partial assignment. let mnppa = extend extSupported langSupported pkgPresent newactives ppa case liftM2 (,) mnppa mNewRequiredComps of Left (c, fr) -> return (Fail c fr) -- inconsistency found Right (nppa, rComps') -> local (\ s -> s { pa = PA nppa pfa npsa, requiredComponents = rComps' }) r -- | Check that a newly chosen package instance contains all components that -- are required from that package so far. The components must also be visible -- and buildable. checkComponentsInNewPackage :: ComponentDependencyReasons -> QPN -> Map ExposedComponent ComponentInfo -> Either Conflict () checkComponentsInNewPackage required qpn providedComps = case M.toList $ deleteKeys (M.keys providedComps) required of (missingComp, dr) : _ -> Left $ mkConflict missingComp dr NewPackageIsMissingRequiredComponent [] -> let failures = lefts [ case () of _ | compIsVisible compInfo == IsVisible False -> Left $ mkConflict comp dr NewPackageHasPrivateRequiredComponent | compIsBuildable compInfo == IsBuildable False -> Left $ mkConflict comp dr NewPackageHasUnbuildableRequiredComponent | otherwise -> Right () | let merged = M.intersectionWith (,) required providedComps , (comp, (dr, compInfo)) <- M.toList merged ] in case failures of failure : _ -> Left failure [] -> Right () where mkConflict :: ExposedComponent -> DependencyReason QPN -> (ExposedComponent -> DependencyReason QPN -> FailReason) -> Conflict mkConflict comp dr mkFailure = (CS.insert (P qpn) (dependencyReasonToConflictSet dr), mkFailure comp dr) deleteKeys :: Ord k => [k] -> Map k v -> Map k v deleteKeys ks m = L.foldr M.delete m ks -- | We try to extract as many concrete dependencies from the given flagged -- dependencies as possible. We make use of all the flag knowledge we have -- already acquired. extractAllDeps :: FAssignment -> SAssignment -> FlaggedDeps QPN -> [LDep QPN] extractAllDeps fa sa deps = do d <- deps case d of Simple sd _ -> return sd Flagged qfn _ td fd -> case M.lookup qfn fa of Nothing -> mzero Just True -> extractAllDeps fa sa td Just False -> extractAllDeps fa sa fd Stanza qsn td -> case M.lookup qsn sa of Nothing -> mzero Just True -> extractAllDeps fa sa td Just False -> [] -- | We try to find new dependencies that become available due to the given -- flag or stanza choice. We therefore look for the choice in question, and then call -- 'extractAllDeps' for everything underneath. extractNewDeps :: Var QPN -> Bool -> FAssignment -> SAssignment -> FlaggedDeps QPN -> [LDep QPN] extractNewDeps v b fa sa = go where go :: FlaggedDeps QPN -> [LDep QPN] go deps = do d <- deps case d of Simple _ _ -> mzero Flagged qfn' _ td fd | v == F qfn' -> if b then extractAllDeps fa sa td else extractAllDeps fa sa fd | otherwise -> case M.lookup qfn' fa of Nothing -> mzero Just True -> go td Just False -> go fd Stanza qsn' td | v == S qsn' -> if b then extractAllDeps fa sa td else [] | otherwise -> case M.lookup qsn' sa of Nothing -> mzero Just True -> go td Just False -> [] -- | Extend a package preassignment. -- -- Takes the variable that causes the new constraints, a current preassignment -- and a set of new dependency constraints. -- -- We're trying to extend the preassignment with each dependency one by one. -- Each dependency is for a particular variable. We check if we already have -- constraints for that variable in the current preassignment. If so, we're -- trying to merge the constraints. -- -- Either returns a witness of the conflict that would arise during the merge, -- or the successfully extended assignment. extend :: (Extension -> Bool) -- ^ is a given extension supported -> (Language -> Bool) -- ^ is a given language supported -> (PkgconfigName -> PkgconfigVersionRange -> Bool) -- ^ is a given pkg-config requirement satisfiable -> [LDep QPN] -> PPreAssignment -> Either Conflict PPreAssignment extend extSupported langSupported pkgPresent newactives ppa = foldM extendSingle ppa newactives where extendSingle :: PPreAssignment -> LDep QPN -> Either Conflict PPreAssignment extendSingle a (LDep dr (Ext ext )) = if extSupported ext then Right a else Left (dependencyReasonToConflictSet dr, UnsupportedExtension ext) extendSingle a (LDep dr (Lang lang)) = if langSupported lang then Right a else Left (dependencyReasonToConflictSet dr, UnsupportedLanguage lang) extendSingle a (LDep dr (Pkg pn vr)) = if pkgPresent pn vr then Right a else Left (dependencyReasonToConflictSet dr, MissingPkgconfigPackage pn vr) extendSingle a (LDep dr (Dep dep@(PkgComponent qpn _) ci)) = let mergedDep = M.findWithDefault (MergedDepConstrained []) qpn a in case (\ x -> M.insert qpn x a) <$> merge mergedDep (PkgDep dr dep ci) of Left (c, (d, d')) -> Left (c, ConflictingConstraints d d') Right x -> Right x -- | Extend a package preassignment with a package choice. For example, when -- the solver chooses foo-2.0, it tries to add the constraint foo==2.0. -- -- TODO: The new constraint is implemented as a dependency from foo to foo's -- main library. That isn't correct, because foo might only be needed as a build -- tool dependency. The implementation may need to change when we support -- component-based dependency solving. extendWithPackageChoice :: PI QPN -> PPreAssignment -> Either Conflict PPreAssignment extendWithPackageChoice (PI qpn i) ppa = let mergedDep = M.findWithDefault (MergedDepConstrained []) qpn ppa newChoice = PkgDep (DependencyReason qpn M.empty S.empty) (PkgComponent qpn (ExposedLib LMainLibName)) (Fixed i) in case (\ x -> M.insert qpn x ppa) <$> merge mergedDep newChoice of Left (c, (d, _d')) -> -- Don't include the package choice in the -- FailReason, because it is redundant. Left (c, NewPackageDoesNotMatchExistingConstraint d) Right x -> Right x -- | Merge constrained instances. We currently adopt a lazy strategy for -- merging, i.e., we only perform actual checking if one of the two choices -- is fixed. If the merge fails, we return a conflict set indicating the -- variables responsible for the failure, as well as the two conflicting -- fragments. -- -- Note that while there may be more than one conflicting pair of version -- ranges, we only return the first we find. -- -- The ConflictingDeps are returned in order, i.e., the first describes the -- conflicting part of the MergedPkgDep, and the second describes the PkgDep. -- -- TODO: Different pairs might have different conflict sets. We're -- obviously interested to return a conflict that has a "better" conflict -- 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 (MergedDepFixed comp1 vs1 i1) (PkgDep vs2 (PkgComponent p comp2) ci@(Fixed i2)) | i1 == i2 = Right $ MergedDepFixed comp1 vs1 i1 | otherwise = Left ( (CS.union `on` dependencyReasonToConflictSet) vs1 vs2 , ( ConflictingDep vs1 (PkgComponent p comp1) (Fixed i1) , ConflictingDep vs2 (PkgComponent p comp2) ci ) ) merge (MergedDepFixed comp1 vs1 i@(I v _)) (PkgDep vs2 (PkgComponent p comp2) ci@(Constrained vr)) | checkVR vr v = Right $ MergedDepFixed comp1 vs1 i | otherwise = Left ( createConflictSetForVersionConflict p v vs1 vr vs2 , ( ConflictingDep vs1 (PkgComponent p comp1) (Fixed i) , ConflictingDep vs2 (PkgComponent p comp2) ci ) ) merge (MergedDepConstrained vrOrigins) (PkgDep vs2 (PkgComponent p comp2) ci@(Fixed i@(I v _))) = go vrOrigins -- I tried "reverse vrOrigins" here, but it seems to slow things down ... where go :: [VROrigin] -> Either (ConflictSet, (ConflictingDep, ConflictingDep)) MergedPkgDep go [] = Right (MergedDepFixed comp2 vs2 i) go ((vr, comp1, vs1) : vros) | checkVR vr v = go vros | otherwise = Left ( createConflictSetForVersionConflict p v vs2 vr vs1 , ( ConflictingDep vs1 (PkgComponent p comp1) (Constrained vr) , ConflictingDep vs2 (PkgComponent p comp2) ci ) ) merge (MergedDepConstrained vrOrigins) (PkgDep vs2 (PkgComponent _ comp2) (Constrained vr)) = Right (MergedDepConstrained $ -- TODO: This line appends the new version range, to preserve the order used -- before a refactoring. Consider prepending the version range, if there is -- no negative performance impact. vrOrigins ++ [(vr, comp2, vs2)]) -- | Creates a conflict set representing a conflict between a version constraint -- and the fixed version chosen for a package. createConflictSetForVersionConflict :: QPN -> Ver -> DependencyReason QPN -> VR -> DependencyReason QPN -> ConflictSet createConflictSetForVersionConflict pkg conflictingVersion versionDR@(DependencyReason p1 _ _) conflictingVersionRange versionRangeDR@(DependencyReason p2 _ _) = let hasFlagsOrStanzas (DependencyReason _ fs ss) = not (M.null fs) || not (S.null ss) in -- The solver currently only optimizes the case where there is a conflict -- between the version chosen for a package and a version constraint that -- is not under any flags or stanzas. Here is how we check for this case: -- -- (1) Choosing a specific version for a package foo is implemented as -- adding a dependency from foo to that version of foo (See -- extendWithPackageChoice), so we check that the DependencyReason -- contains the current package and no flag or stanza choices. -- -- (2) We check that the DependencyReason for the version constraint also -- contains no flag or stanza choices. -- -- When these criteria are not met, we fall back to calling -- dependencyReasonToConflictSet. if p1 == pkg && not (hasFlagsOrStanzas versionDR) && not (hasFlagsOrStanzas versionRangeDR) then let cs1 = dependencyReasonToConflictSetWithVersionConflict p2 (CS.OrderedVersionRange conflictingVersionRange) versionDR cs2 = dependencyReasonToConflictSetWithVersionConstraintConflict pkg conflictingVersion versionRangeDR in cs1 `CS.union` cs2 else dependencyReasonToConflictSet versionRangeDR `CS.union` dependencyReasonToConflictSet versionDR -- | Takes a list of new dependencies and uses it to try to update the map of -- known component dependencies. It returns a failure when a new dependency -- requires a component that is missing, private, or unbuildable in a previously -- chosen package. extendRequiredComponents :: QPN -- ^ package we extend -> Map QPN (Map ExposedComponent ComponentInfo) -> Map QPN ComponentDependencyReasons -> [LDep QPN] -> Either Conflict (Map QPN ComponentDependencyReasons) extendRequiredComponents eqpn available = foldM extendSingle where extendSingle :: Map QPN ComponentDependencyReasons -> LDep QPN -> Either Conflict (Map QPN ComponentDependencyReasons) extendSingle required (LDep dr (Dep (PkgComponent qpn comp) _)) = let compDeps = M.findWithDefault M.empty qpn required success = Right $ M.insertWith M.union qpn (M.insert comp dr compDeps) required in -- Only check for the existence of the component if its package has -- already been chosen. case M.lookup qpn available of Just comps -> case M.lookup comp comps of Nothing -> Left $ mkConflict qpn comp dr PackageRequiresMissingComponent Just compInfo | compIsVisible compInfo == IsVisible False , eqpn /= qpn -- package components can depend on other components -> Left $ mkConflict qpn comp dr PackageRequiresPrivateComponent | compIsBuildable compInfo == IsBuildable False -> Left $ mkConflict qpn comp dr PackageRequiresUnbuildableComponent | otherwise -> success Nothing -> success extendSingle required _ = Right required mkConflict :: QPN -> ExposedComponent -> DependencyReason QPN -> (QPN -> ExposedComponent -> FailReason) -> Conflict mkConflict qpn comp dr mkFailure = (CS.insert (P qpn) (dependencyReasonToConflictSet dr), mkFailure qpn comp) -- | Interface. validateTree :: CompilerInfo -> Index -> PkgConfigDb -> Tree d c -> Tree d c validateTree cinfo idx pkgConfigDb t = runValidate (validate t) VS { supportedExt = maybe (const True) -- if compiler has no list of extensions, we assume everything is supported (\ es -> let s = S.fromList es in \ x -> S.member x s) (compilerInfoExtensions cinfo) , supportedLang = maybe (const True) (flip L.elem) -- use list lookup because language list is small and no Ord instance (compilerInfoLanguages cinfo) , presentPkgs = pkgConfigPkgIsPresent pkgConfigDb , index = idx , saved = M.empty , pa = PA M.empty M.empty M.empty , availableComponents = M.empty , requiredComponents = M.empty , qualifyOptions = defaultQualifyOptions idx } cabal-install-solver-3.8.1.0/src/Distribution/Solver/Modular/Var.hs0000644000000000000000000000203307346545000023275 0ustar0000000000000000{-# LANGUAGE DeriveFunctor #-} module Distribution.Solver.Modular.Var ( Var(..) , showVar , varPN ) where import Prelude hiding (pi) import Distribution.Solver.Modular.Flag import Distribution.Solver.Types.PackagePath {------------------------------------------------------------------------------- Variables -------------------------------------------------------------------------------} -- | The type of variables that play a role in the solver. -- Note that the tree currently does not use this type directly, -- and rather has separate tree nodes for the different types of -- variables. This fits better with the fact that in most cases, -- these have to be treated differently. data Var qpn = P qpn | F (FN qpn) | S (SN qpn) deriving (Eq, Ord, Show, Functor) showVar :: Var QPN -> String showVar (P qpn) = showQPN qpn showVar (F qfn) = showQFN qfn showVar (S qsn) = showQSN qsn -- | Extract the package name from a Var varPN :: Var qpn -> qpn varPN (P qpn) = qpn varPN (F (FN qpn _)) = qpn varPN (S (SN qpn _)) = qpn cabal-install-solver-3.8.1.0/src/Distribution/Solver/Modular/Version.hs0000644000000000000000000000234307346545000024176 0ustar0000000000000000module Distribution.Solver.Modular.Version ( Ver , VR , anyVR , checkVR , eqVR , showVer , showVR , simplifyVR , (.&&.) , (.||.) ) where import Distribution.Solver.Compat.Prelude import Prelude () import qualified Distribution.Version as CV -- from Cabal import Distribution.Pretty (prettyShow) -- | Preliminary type for versions. type Ver = CV.Version -- | String representation of a version. showVer :: Ver -> String showVer = prettyShow -- | Version range. Consists of a lower and upper bound. type VR = CV.VersionRange -- | String representation of a version range. showVR :: VR -> String showVR = prettyShow -- | Unconstrained version range. anyVR :: VR anyVR = CV.anyVersion -- | Version range fixing a single version. eqVR :: Ver -> VR eqVR = CV.thisVersion -- | Intersect two version ranges. (.&&.) :: VR -> VR -> VR v1 .&&. v2 = simplifyVR $ CV.intersectVersionRanges v1 v2 -- | Union of two version ranges. (.||.) :: VR -> VR -> VR v1 .||. v2 = simplifyVR $ CV.unionVersionRanges v1 v2 -- | Simplify a version range. simplifyVR :: VR -> VR simplifyVR = CV.simplifyVersionRange -- | Checking a version against a version range. checkVR :: VR -> Ver -> Bool checkVR = flip CV.withinRange cabal-install-solver-3.8.1.0/src/Distribution/Solver/Modular/WeightedPSQ.hs0000644000000000000000000000707607346545000024705 0ustar0000000000000000{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} module Distribution.Solver.Modular.WeightedPSQ ( WeightedPSQ , fromList , toList , keys , weights , isZeroOrOne , filter , lookup , mapWithKey , mapWeightsWithKey , traverseWithKey , union , takeUntil ) where import qualified Data.Foldable as F import qualified Data.List as L import Data.Ord (comparing) import qualified Data.Traversable as T import Prelude hiding (filter, lookup) -- | An association list that is sorted by weight. -- -- Each element has a key ('k'), value ('v'), and weight ('w'). All operations -- that add elements or modify weights stably sort the elements by weight. newtype WeightedPSQ w k v = WeightedPSQ [(w, k, v)] deriving (Eq, Show, Functor, F.Foldable, T.Traversable) -- | /O(N)/. filter :: (v -> Bool) -> WeightedPSQ k w v -> WeightedPSQ k w v filter p (WeightedPSQ xs) = WeightedPSQ (L.filter (p . triple_3) xs) -- | /O(1)/. Return @True@ if the @WeightedPSQ@ contains zero or one elements. isZeroOrOne :: WeightedPSQ w k v -> Bool isZeroOrOne (WeightedPSQ []) = True isZeroOrOne (WeightedPSQ [_]) = True isZeroOrOne _ = False -- | /O(1)/. Return the elements in order. toList :: WeightedPSQ w k v -> [(w, k, v)] toList (WeightedPSQ xs) = xs -- | /O(N log N)/. fromList :: Ord w => [(w, k, v)] -> WeightedPSQ w k v fromList = WeightedPSQ . L.sortBy (comparing triple_1) -- | /O(N)/. Return the weights in order. weights :: WeightedPSQ w k v -> [w] weights (WeightedPSQ xs) = L.map triple_1 xs -- | /O(N)/. Return the keys in order. keys :: WeightedPSQ w k v -> [k] keys (WeightedPSQ xs) = L.map triple_2 xs -- | /O(N)/. Return the value associated with the first occurrence of the give -- key, if it exists. lookup :: Eq k => k -> WeightedPSQ w k v -> Maybe v lookup k (WeightedPSQ xs) = triple_3 `fmap` L.find ((k ==) . triple_2) xs -- | /O(N log N)/. Update the weights. mapWeightsWithKey :: Ord w2 => (k -> w1 -> w2) -> WeightedPSQ w1 k v -> WeightedPSQ w2 k v mapWeightsWithKey f (WeightedPSQ xs) = fromList $ L.map (\ (w, k, v) -> (f k w, k, v)) xs -- | /O(N)/. Update the values. mapWithKey :: (k -> v1 -> v2) -> WeightedPSQ w k v1 -> WeightedPSQ w k v2 mapWithKey f (WeightedPSQ xs) = WeightedPSQ $ L.map (\ (w, k, v) -> (w, k, f k v)) xs -- | /O(N)/. Traverse and update values in some applicative functor. traverseWithKey :: Applicative f => (k -> v -> f v') -> WeightedPSQ w k v -> f (WeightedPSQ w k v') traverseWithKey f (WeightedPSQ q) = WeightedPSQ <$> traverse (\(w,k,v) -> (w,k,) <$> f k v) q -- | /O((N + M) log (N + M))/. Combine two @WeightedPSQ@s, preserving all -- elements. Elements from the first @WeightedPSQ@ come before elements in the -- second when they have the same weight. union :: Ord w => WeightedPSQ w k v -> WeightedPSQ w k v -> WeightedPSQ w k v union (WeightedPSQ xs) (WeightedPSQ ys) = fromList (xs ++ ys) -- | /O(N)/. Return the prefix of values ending with the first element that -- satisfies p, or all elements if none satisfy p. takeUntil :: forall w k v. (v -> Bool) -> WeightedPSQ w k v -> WeightedPSQ w k v takeUntil p (WeightedPSQ xs) = WeightedPSQ (go xs) where go :: [(w, k, v)] -> [(w, k, v)] go [] = [] go (y : ys) = y : if p (triple_3 y) then [] else go ys triple_1 :: (x, y, z) -> x triple_1 (x, _, _) = x triple_2 :: (x, y, z) -> y triple_2 (_, y, _) = y triple_3 :: (x, y, z) -> z triple_3 (_, _, z) = z cabal-install-solver-3.8.1.0/src/Distribution/Solver/Types/0000755000000000000000000000000007346545000021714 5ustar0000000000000000cabal-install-solver-3.8.1.0/src/Distribution/Solver/Types/ComponentDeps.hs0000644000000000000000000001556207346545000025037 0ustar0000000000000000{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} -- | Fine-grained package dependencies -- -- Like many others, this module is meant to be "double-imported": -- -- > import Distribution.Solver.Types.ComponentDeps ( -- > Component -- > , ComponentDep -- > , ComponentDeps -- > ) -- > import qualified Distribution.Solver.Types.ComponentDeps as CD module Distribution.Solver.Types.ComponentDeps ( -- * Fine-grained package dependencies Component(..) , componentNameToComponent , ComponentDep , ComponentDeps -- opaque -- ** Constructing ComponentDeps , empty , fromList , singleton , insert , zip , filterDeps , fromLibraryDeps , fromSetupDeps , fromInstalled -- ** Deconstructing ComponentDeps , toList , flatDeps , nonSetupDeps , libraryDeps , setupDeps , select , components ) where import Prelude () import Distribution.Types.UnqualComponentName import Distribution.Solver.Compat.Prelude hiding (empty,toList,zip) import qualified Data.Map as Map import Data.Foldable (fold) import Distribution.Pretty (Pretty (..)) import qualified Distribution.Types.ComponentName as CN import qualified Distribution.Types.LibraryName as LN import qualified Text.PrettyPrint as PP {------------------------------------------------------------------------------- Types -------------------------------------------------------------------------------} -- | Component of a package. data Component = ComponentLib | ComponentSubLib UnqualComponentName | ComponentFLib UnqualComponentName | ComponentExe UnqualComponentName | ComponentTest UnqualComponentName | ComponentBench UnqualComponentName | ComponentSetup deriving (Show, Eq, Ord, Generic) instance Binary Component instance Structured Component instance Pretty Component where pretty ComponentLib = PP.text "lib" pretty (ComponentSubLib n) = PP.text "lib:" <<>> pretty n pretty (ComponentFLib n) = PP.text "flib:" <<>> pretty n pretty (ComponentExe n) = PP.text "exe:" <<>> pretty n pretty (ComponentTest n) = PP.text "test:" <<>> pretty n pretty (ComponentBench n) = PP.text "bench:" <<>> pretty n pretty ComponentSetup = PP.text "setup" -- | Dependency for a single component. type ComponentDep a = (Component, a) -- | Fine-grained dependencies for a package. -- -- Typically used as @ComponentDeps [Dependency]@, to represent the list of -- dependencies for each named component within a package. -- newtype ComponentDeps a = ComponentDeps { unComponentDeps :: Map Component a } deriving (Show, Functor, Eq, Ord, Generic) instance Semigroup a => Monoid (ComponentDeps a) where mempty = ComponentDeps Map.empty mappend = (<>) instance Semigroup a => Semigroup (ComponentDeps a) where ComponentDeps d <> ComponentDeps d' = ComponentDeps (Map.unionWith (<>) d d') instance Foldable ComponentDeps where foldMap f = foldMap f . unComponentDeps instance Traversable ComponentDeps where traverse f = fmap ComponentDeps . traverse f . unComponentDeps instance Binary a => Binary (ComponentDeps a) instance Structured a => Structured (ComponentDeps a) componentNameToComponent :: CN.ComponentName -> Component componentNameToComponent (CN.CLibName LN.LMainLibName) = ComponentLib componentNameToComponent (CN.CLibName (LN.LSubLibName s)) = ComponentSubLib s componentNameToComponent (CN.CFLibName s) = ComponentFLib s componentNameToComponent (CN.CExeName s) = ComponentExe s componentNameToComponent (CN.CTestName s) = ComponentTest s componentNameToComponent (CN.CBenchName s) = ComponentBench s {------------------------------------------------------------------------------- Construction -------------------------------------------------------------------------------} empty :: ComponentDeps a empty = ComponentDeps $ Map.empty fromList :: Monoid a => [ComponentDep a] -> ComponentDeps a fromList = ComponentDeps . Map.fromListWith mappend singleton :: Component -> a -> ComponentDeps a singleton comp = ComponentDeps . Map.singleton comp insert :: Monoid a => Component -> a -> ComponentDeps a -> ComponentDeps a insert comp a = ComponentDeps . Map.alter aux comp . unComponentDeps where aux Nothing = Just a aux (Just a') = Just $ a `mappend` a' -- | Zip two 'ComponentDeps' together by 'Component', using 'mempty' -- as the neutral element when a 'Component' is present only in one. zip :: (Monoid a, Monoid b) => ComponentDeps a -> ComponentDeps b -> ComponentDeps (a, b) zip (ComponentDeps d1) (ComponentDeps d2) = ComponentDeps $ Map.mergeWithKey (\_ a b -> Just (a,b)) (fmap (\a -> (a, mempty))) (fmap (\b -> (mempty, b))) d1 d2 -- | Keep only selected components (and their associated deps info). filterDeps :: (Component -> a -> Bool) -> ComponentDeps a -> ComponentDeps a filterDeps p = ComponentDeps . Map.filterWithKey p . unComponentDeps -- | ComponentDeps containing library dependencies only fromLibraryDeps :: a -> ComponentDeps a fromLibraryDeps = singleton ComponentLib -- | ComponentDeps containing setup dependencies only. fromSetupDeps :: a -> ComponentDeps a fromSetupDeps = singleton ComponentSetup -- | ComponentDeps for installed packages. -- -- We assume that installed packages only record their library dependencies. fromInstalled :: a -> ComponentDeps a fromInstalled = fromLibraryDeps {------------------------------------------------------------------------------- Deconstruction -------------------------------------------------------------------------------} toList :: ComponentDeps a -> [ComponentDep a] toList = Map.toList . unComponentDeps -- | All dependencies of a package. -- -- This is just a synonym for 'fold', but perhaps a use of 'flatDeps' is more -- obvious than a use of 'fold', and moreover this avoids introducing lots of -- @#ifdef@s for 7.10 just for the use of 'fold'. flatDeps :: Monoid a => ComponentDeps a -> a flatDeps = fold -- | All dependencies except the setup dependencies. -- -- Prior to the introduction of setup dependencies in version 1.24 this -- would have been _all_ dependencies. nonSetupDeps :: Monoid a => ComponentDeps a -> a nonSetupDeps = select (/= ComponentSetup) -- | Library dependencies proper only. (Includes dependencies -- of internal libraries.) libraryDeps :: Monoid a => ComponentDeps a -> a libraryDeps = select (\c -> case c of ComponentSubLib _ -> True ComponentLib -> True _ -> False) -- | List components components :: ComponentDeps a -> Set Component components = Map.keysSet . unComponentDeps -- | Setup dependencies. setupDeps :: Monoid a => ComponentDeps a -> a setupDeps = select (== ComponentSetup) -- | Select dependencies satisfying a given predicate. select :: Monoid a => (Component -> Bool) -> ComponentDeps a -> a select p = foldMap snd . filter (p . fst) . toList cabal-install-solver-3.8.1.0/src/Distribution/Solver/Types/ConstraintSource.hs0000644000000000000000000000522307346545000025557 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} module Distribution.Solver.Types.ConstraintSource ( ConstraintSource(..) , showConstraintSource ) where import Distribution.Solver.Compat.Prelude import Prelude () -- | Source of a 'PackageConstraint'. data ConstraintSource = -- | Main config file, which is ~/.cabal/config by default. ConstraintSourceMainConfig FilePath -- | Local cabal.project file | ConstraintSourceProjectConfig FilePath -- | User config file, which is ./cabal.config by default. | ConstraintSourceUserConfig FilePath -- | Flag specified on the command line. | ConstraintSourceCommandlineFlag -- | Target specified by the user, e.g., @cabal install package-0.1.0.0@ -- implies @package==0.1.0.0@. | ConstraintSourceUserTarget -- | Internal requirement to use installed versions of packages like ghc-prim. | ConstraintSourceNonUpgradeablePackage -- | Internal constraint used by @cabal freeze@. | ConstraintSourceFreeze -- | Constraint specified by a config file, a command line flag, or a user -- target, when a more specific source is not known. | ConstraintSourceConfigFlagOrTarget -- | The source of the constraint is not specified. | ConstraintSourceUnknown -- | An internal constraint due to compatibility issues with the Setup.hs -- command line interface requires a minimum lower bound on Cabal | ConstraintSetupCabalMinVersion -- | An internal constraint due to compatibility issues with the Setup.hs -- command line interface requires a maximum upper bound on Cabal | ConstraintSetupCabalMaxVersion deriving (Eq, Show, Generic) instance Binary ConstraintSource instance Structured ConstraintSource -- | Description of a 'ConstraintSource'. showConstraintSource :: ConstraintSource -> String showConstraintSource (ConstraintSourceMainConfig path) = "main config " ++ path showConstraintSource (ConstraintSourceProjectConfig path) = "project config " ++ path showConstraintSource (ConstraintSourceUserConfig path)= "user config " ++ path showConstraintSource ConstraintSourceCommandlineFlag = "command line flag" showConstraintSource ConstraintSourceUserTarget = "user target" showConstraintSource ConstraintSourceNonUpgradeablePackage = "non-upgradeable package" showConstraintSource ConstraintSourceFreeze = "cabal freeze" showConstraintSource ConstraintSourceConfigFlagOrTarget = "config file, command line flag, or user target" showConstraintSource ConstraintSourceUnknown = "unknown source" showConstraintSource ConstraintSetupCabalMinVersion = "minimum version of Cabal used by Setup.hs" showConstraintSource ConstraintSetupCabalMaxVersion = "maximum version of Cabal used by Setup.hs" cabal-install-solver-3.8.1.0/src/Distribution/Solver/Types/DependencyResolver.hs0000644000000000000000000000301707346545000026051 0ustar0000000000000000module Distribution.Solver.Types.DependencyResolver ( DependencyResolver ) where import Distribution.Solver.Compat.Prelude import Prelude () import Distribution.Solver.Types.LabeledPackageConstraint import Distribution.Solver.Types.PkgConfigDb ( PkgConfigDb ) import Distribution.Solver.Types.PackagePreferences import Distribution.Solver.Types.PackageIndex ( PackageIndex ) import Distribution.Solver.Types.Progress import Distribution.Solver.Types.ResolverPackage import Distribution.Solver.Types.SourcePackage import Distribution.Simple.PackageIndex ( InstalledPackageIndex ) import Distribution.Package ( PackageName ) import Distribution.Compiler ( CompilerInfo ) import Distribution.System ( Platform ) -- | A dependency resolver is a function that works out an installation plan -- given the set of installed and available packages and a set of deps to -- solve for. -- -- The reason for this interface is because there are dozens of approaches to -- solving the package dependency problem and we want to make it easy to swap -- in alternatives. -- type DependencyResolver loc = Platform -> CompilerInfo -> InstalledPackageIndex -> PackageIndex (SourcePackage loc) -> PkgConfigDb -> (PackageName -> PackagePreferences) -> [LabeledPackageConstraint] -> Set PackageName -> Progress String String [ResolverPackage loc] cabal-install-solver-3.8.1.0/src/Distribution/Solver/Types/Flag.hs0000644000000000000000000000023207346545000023116 0ustar0000000000000000module Distribution.Solver.Types.Flag ( FlagType(..) ) where import Prelude (Eq, Show) data FlagType = Manual | Automatic deriving (Eq, Show) cabal-install-solver-3.8.1.0/src/Distribution/Solver/Types/InstSolverPackage.hs0000644000000000000000000000260407346545000025636 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} module Distribution.Solver.Types.InstSolverPackage ( InstSolverPackage(..) ) where import Distribution.Solver.Compat.Prelude import Prelude () import Distribution.Package ( Package(..), HasMungedPackageId(..), HasUnitId(..) ) import Distribution.Solver.Types.ComponentDeps ( ComponentDeps ) import Distribution.Solver.Types.SolverId import Distribution.Types.MungedPackageId import Distribution.Types.PackageId import Distribution.Types.MungedPackageName import Distribution.InstalledPackageInfo (InstalledPackageInfo) -- | An 'InstSolverPackage' is a pre-existing installed package -- specified by the dependency solver. data InstSolverPackage = InstSolverPackage { instSolverPkgIPI :: InstalledPackageInfo, instSolverPkgLibDeps :: ComponentDeps [SolverId], instSolverPkgExeDeps :: ComponentDeps [SolverId] } deriving (Eq, Show, Generic) instance Binary InstSolverPackage instance Structured InstSolverPackage instance Package InstSolverPackage where packageId i = -- HACK! See Note [Index conversion with internal libraries] let MungedPackageId mpn v = mungedId i in PackageIdentifier (encodeCompatPackageName mpn) v instance HasMungedPackageId InstSolverPackage where mungedId = mungedId . instSolverPkgIPI instance HasUnitId InstSolverPackage where installedUnitId = installedUnitId . instSolverPkgIPI cabal-install-solver-3.8.1.0/src/Distribution/Solver/Types/InstalledPreference.hs0000644000000000000000000000043707346545000026172 0ustar0000000000000000module Distribution.Solver.Types.InstalledPreference ( InstalledPreference(..), ) where import Prelude (Show) -- | Whether we prefer an installed version of a package or simply the latest -- version. -- data InstalledPreference = PreferInstalled | PreferLatest deriving Show cabal-install-solver-3.8.1.0/src/Distribution/Solver/Types/LabeledPackageConstraint.hs0000644000000000000000000000101107346545000027112 0ustar0000000000000000module Distribution.Solver.Types.LabeledPackageConstraint ( LabeledPackageConstraint(..) , unlabelPackageConstraint ) where import Distribution.Solver.Types.ConstraintSource import Distribution.Solver.Types.PackageConstraint -- | 'PackageConstraint' labeled with its source. data LabeledPackageConstraint = LabeledPackageConstraint PackageConstraint ConstraintSource unlabelPackageConstraint :: LabeledPackageConstraint -> PackageConstraint unlabelPackageConstraint (LabeledPackageConstraint pc _) = pc cabal-install-solver-3.8.1.0/src/Distribution/Solver/Types/OptionalStanza.hs0000644000000000000000000001211107346545000025212 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} module Distribution.Solver.Types.OptionalStanza ( -- * OptionalStanza OptionalStanza(..), showStanza, showStanzas, enableStanzas, -- * Set of stanzas OptionalStanzaSet, optStanzaSetFromList, optStanzaSetToList, optStanzaSetMember, optStanzaSetInsert, optStanzaSetSingleton, optStanzaSetIntersection, optStanzaSetNull, optStanzaSetIsSubset, -- * Map indexed by stanzas OptionalStanzaMap, optStanzaTabulate, optStanzaIndex, optStanzaLookup, optStanzaKeysFilteredByValue, ) where import Distribution.Solver.Compat.Prelude import Prelude () import Data.Bits (testBit, (.|.), (.&.)) import Distribution.Types.ComponentRequestedSpec (ComponentRequestedSpec (..)) import Distribution.Utils.Structured (Structured (..), nominalStructure) ------------------------------------------------------------------------------- -- OptionalStanza ------------------------------------------------------------------------------- data OptionalStanza = TestStanzas | BenchStanzas deriving (Eq, Ord, Enum, Bounded, Show, Generic, Typeable) -- | String representation of an OptionalStanza. showStanza :: OptionalStanza -> String showStanza TestStanzas = "test" showStanza BenchStanzas = "bench" showStanzas :: OptionalStanzaSet -> String showStanzas = unwords . map (("*" ++) . showStanza) . optStanzaSetToList -- | Convert a list of 'OptionalStanza' into the corresponding -- Cabal's 'ComponentRequestedSpec' which records what components are enabled. -- enableStanzas :: OptionalStanzaSet -> ComponentRequestedSpec enableStanzas optionalStanzas = ComponentRequestedSpec { testsRequested = optStanzaSetMember TestStanzas optionalStanzas , benchmarksRequested = optStanzaSetMember BenchStanzas optionalStanzas } instance Binary OptionalStanza instance Structured OptionalStanza ------------------------------------------------------------------------------- -- OptionalStanzaSet ------------------------------------------------------------------------------- newtype OptionalStanzaSet = OptionalStanzaSet Word deriving (Eq, Ord, Show) instance Binary OptionalStanzaSet where put (OptionalStanzaSet w) = put w get = fmap (OptionalStanzaSet . (.&. 0x03)) get instance Structured OptionalStanzaSet where structure = nominalStructure optStanzaSetFromList :: [OptionalStanza] -> OptionalStanzaSet optStanzaSetFromList = foldl' (flip optStanzaSetInsert) mempty optStanzaSetToList :: OptionalStanzaSet -> [OptionalStanza] optStanzaSetToList (OptionalStanzaSet 0) = [] optStanzaSetToList (OptionalStanzaSet 1) = [TestStanzas] optStanzaSetToList (OptionalStanzaSet 2) = [BenchStanzas] optStanzaSetToList (OptionalStanzaSet 3) = [TestStanzas, BenchStanzas] optStanzaSetToList (OptionalStanzaSet _) = [] optStanzaSetInsert :: OptionalStanza -> OptionalStanzaSet -> OptionalStanzaSet optStanzaSetInsert x s = optStanzaSetSingleton x <> s optStanzaSetMember :: OptionalStanza -> OptionalStanzaSet -> Bool optStanzaSetMember TestStanzas (OptionalStanzaSet w) = testBit w 0 optStanzaSetMember BenchStanzas (OptionalStanzaSet w) = testBit w 1 optStanzaSetSingleton :: OptionalStanza -> OptionalStanzaSet optStanzaSetSingleton TestStanzas = OptionalStanzaSet 1 optStanzaSetSingleton BenchStanzas = OptionalStanzaSet 2 optStanzaSetIntersection :: OptionalStanzaSet -> OptionalStanzaSet -> OptionalStanzaSet optStanzaSetIntersection (OptionalStanzaSet a) (OptionalStanzaSet b) = OptionalStanzaSet (a .&. b) optStanzaSetNull :: OptionalStanzaSet -> Bool optStanzaSetNull (OptionalStanzaSet w) = w == 0 optStanzaSetIsSubset :: OptionalStanzaSet -> OptionalStanzaSet -> Bool optStanzaSetIsSubset (OptionalStanzaSet a) (OptionalStanzaSet b) = (a .|. b) == b instance Semigroup OptionalStanzaSet where OptionalStanzaSet a <> OptionalStanzaSet b = OptionalStanzaSet (a .|. b) instance Monoid OptionalStanzaSet where mempty = OptionalStanzaSet 0 mappend = (<>) ------------------------------------------------------------------------------- -- OptionalStanzaMap ------------------------------------------------------------------------------- -- | Note: this is total map. data OptionalStanzaMap a = OptionalStanzaMap a a deriving (Eq, Ord, Show, Generic) instance Binary a => Binary (OptionalStanzaMap a) instance Structured a => Structured (OptionalStanzaMap a) optStanzaTabulate :: (OptionalStanza -> a) -> OptionalStanzaMap a optStanzaTabulate f = OptionalStanzaMap (f TestStanzas) (f BenchStanzas) optStanzaIndex :: OptionalStanzaMap a -> OptionalStanza -> a optStanzaIndex (OptionalStanzaMap x _) TestStanzas = x optStanzaIndex (OptionalStanzaMap _ x) BenchStanzas = x optStanzaLookup :: OptionalStanza -> OptionalStanzaMap a -> a optStanzaLookup = flip optStanzaIndex optStanzaKeysFilteredByValue :: (a -> Bool) -> OptionalStanzaMap a -> OptionalStanzaSet optStanzaKeysFilteredByValue p (OptionalStanzaMap x y) | p x = if p y then OptionalStanzaSet 3 else OptionalStanzaSet 1 | otherwise = if p y then OptionalStanzaSet 2 else OptionalStanzaSet 0 cabal-install-solver-3.8.1.0/src/Distribution/Solver/Types/PackageConstraint.hs0000644000000000000000000001450407346545000025654 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} -- | Per-package constraints. Package constraints must be respected by the -- solver. Multiple constraints for each package can be given, though obviously -- it is possible to construct conflicting constraints (eg impossible version -- range or inconsistent flag assignment). -- module Distribution.Solver.Types.PackageConstraint ( ConstraintScope(..), scopeToplevel, scopeToPackageName, constraintScopeMatches, PackageProperty(..), dispPackageProperty, PackageConstraint(..), dispPackageConstraint, showPackageConstraint, packageConstraintToDependency ) where import Distribution.Solver.Compat.Prelude import Prelude () import Distribution.Package (PackageName) import Distribution.PackageDescription (FlagAssignment, dispFlagAssignment) import Distribution.Pretty (flatStyle, pretty) import Distribution.Types.PackageVersionConstraint (PackageVersionConstraint (..)) import Distribution.Version (VersionRange, simplifyVersionRange) import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.PackagePath import qualified Text.PrettyPrint as Disp -- | Determines to what packages and in what contexts a -- constraint applies. data ConstraintScope -- | A scope that applies when the given package is used as a build target. -- In other words, the scope applies iff a goal has a top-level qualifier -- and its namespace matches the given package name. A namespace is -- considered to match a package name when it is either the default -- namespace (for --no-independent-goals) or it is an independent namespace -- with the given package name (for --independent-goals). -- TODO: Try to generalize the ConstraintScopes once component-based -- solving is implemented, and remove this special case for targets. = ScopeTarget PackageName -- | The package with the specified name and qualifier. | ScopeQualified Qualifier PackageName -- | The package with the specified name when it has a -- setup qualifier. | ScopeAnySetupQualifier PackageName -- | The package with the specified name regardless of -- qualifier. | ScopeAnyQualifier PackageName deriving (Eq, Show) -- | Constructor for a common use case: the constraint applies to -- the package with the specified name when that package is a -- top-level dependency in the default namespace. scopeToplevel :: PackageName -> ConstraintScope scopeToplevel = ScopeQualified QualToplevel -- | Returns the package name associated with a constraint scope. scopeToPackageName :: ConstraintScope -> PackageName scopeToPackageName (ScopeTarget pn) = pn scopeToPackageName (ScopeQualified _ pn) = pn scopeToPackageName (ScopeAnySetupQualifier pn) = pn scopeToPackageName (ScopeAnyQualifier pn) = pn constraintScopeMatches :: ConstraintScope -> QPN -> Bool constraintScopeMatches (ScopeTarget pn) (Q (PackagePath ns q) pn') = let namespaceMatches DefaultNamespace = True namespaceMatches (Independent namespacePn) = pn == namespacePn in namespaceMatches ns && q == QualToplevel && pn == pn' constraintScopeMatches (ScopeQualified q pn) (Q (PackagePath _ q') pn') = q == q' && pn == pn' constraintScopeMatches (ScopeAnySetupQualifier pn) (Q pp pn') = let setup (PackagePath _ (QualSetup _)) = True setup _ = False in setup pp && pn == pn' constraintScopeMatches (ScopeAnyQualifier pn) (Q _ pn') = pn == pn' -- | Pretty-prints a constraint scope. dispConstraintScope :: ConstraintScope -> Disp.Doc dispConstraintScope (ScopeTarget pn) = pretty pn <<>> Disp.text "." <<>> pretty pn dispConstraintScope (ScopeQualified q pn) = dispQualifier q <<>> pretty pn dispConstraintScope (ScopeAnySetupQualifier pn) = Disp.text "setup." <<>> pretty pn dispConstraintScope (ScopeAnyQualifier pn) = Disp.text "any." <<>> pretty pn -- | A package property is a logical predicate on packages. data PackageProperty = PackagePropertyVersion VersionRange | PackagePropertyInstalled | PackagePropertySource | PackagePropertyFlags FlagAssignment | PackagePropertyStanzas [OptionalStanza] deriving (Eq, Show, Generic) instance Binary PackageProperty instance Structured PackageProperty -- | Pretty-prints a package property. dispPackageProperty :: PackageProperty -> Disp.Doc dispPackageProperty (PackagePropertyVersion verrange) = pretty verrange dispPackageProperty PackagePropertyInstalled = Disp.text "installed" dispPackageProperty PackagePropertySource = Disp.text "source" dispPackageProperty (PackagePropertyFlags flags) = dispFlagAssignment flags dispPackageProperty (PackagePropertyStanzas stanzas) = Disp.hsep $ map (Disp.text . showStanza) stanzas -- | A package constraint consists of a scope plus a property -- that must hold for all packages within that scope. data PackageConstraint = PackageConstraint ConstraintScope PackageProperty deriving (Eq, Show) -- | Pretty-prints a package constraint. dispPackageConstraint :: PackageConstraint -> Disp.Doc dispPackageConstraint (PackageConstraint scope prop) = dispConstraintScope scope <+> dispPackageProperty prop -- | Alternative textual representation of a package constraint -- for debugging purposes (slightly more verbose than that -- produced by 'dispPackageConstraint'). -- showPackageConstraint :: PackageConstraint -> String showPackageConstraint pc@(PackageConstraint scope prop) = Disp.renderStyle flatStyle . postprocess $ dispPackageConstraint pc2 where pc2 = case prop of PackagePropertyVersion vr -> PackageConstraint scope $ PackagePropertyVersion (simplifyVersionRange vr) _ -> pc postprocess = case prop of PackagePropertyFlags _ -> (Disp.text "flags" <+>) PackagePropertyStanzas _ -> (Disp.text "stanzas" <+>) _ -> id -- | Lossily convert a 'PackageConstraint' to a 'Dependency'. packageConstraintToDependency :: PackageConstraint -> Maybe PackageVersionConstraint packageConstraintToDependency (PackageConstraint scope prop) = toDep prop where toDep (PackagePropertyVersion vr) = Just $ PackageVersionConstraint (scopeToPackageName scope) vr toDep (PackagePropertyInstalled) = Nothing toDep (PackagePropertySource) = Nothing toDep (PackagePropertyFlags _) = Nothing toDep (PackagePropertyStanzas _) = Nothing cabal-install-solver-3.8.1.0/src/Distribution/Solver/Types/PackageFixedDeps.hs0000644000000000000000000000172307346545000025402 0ustar0000000000000000module Distribution.Solver.Types.PackageFixedDeps ( PackageFixedDeps(..) ) where import Distribution.InstalledPackageInfo ( InstalledPackageInfo ) import Distribution.Package ( Package(..), UnitId, installedDepends) import Distribution.Solver.Types.ComponentDeps ( ComponentDeps ) import qualified Distribution.Solver.Types.ComponentDeps as CD -- | Subclass of packages that have specific versioned dependencies. -- -- So for example a not-yet-configured package has dependencies on version -- ranges, not specific versions. A configured or an already installed package -- depends on exact versions. Some operations or data structures (like -- dependency graphs) only make sense on this subclass of package types. -- class Package pkg => PackageFixedDeps pkg where depends :: pkg -> ComponentDeps [UnitId] instance PackageFixedDeps InstalledPackageInfo where depends pkg = CD.fromInstalled (installedDepends pkg) cabal-install-solver-3.8.1.0/src/Distribution/Solver/Types/PackageIndex.hs0000644000000000000000000002522407346545000024600 0ustar0000000000000000{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Solver.Types.PackageIndex -- Copyright : (c) David Himmelstrup 2005, -- Bjorn Bringert 2007, -- Duncan Coutts 2008 -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- An index of packages. -- module Distribution.Solver.Types.PackageIndex ( -- * Package index data type PackageIndex, -- * Creating an index fromList, -- * Updates merge, override, insert, deletePackageName, deletePackageId, deleteDependency, -- * Queries -- ** Precise lookups elemByPackageId, elemByPackageName, lookupPackageName, lookupPackageId, lookupDependency, -- ** Case-insensitive searches searchByName, SearchResult(..), searchByNameSubstring, searchWithPredicate, -- ** Bulk queries allPackages, allPackagesByName, ) where import Prelude () import Distribution.Solver.Compat.Prelude hiding (lookup) import qualified Data.Map as Map import Data.List (isInfixOf) import qualified Data.List.NonEmpty as NE import Distribution.Client.Utils.Assertion ( expensiveAssert ) import Distribution.Package ( PackageName, unPackageName, PackageIdentifier(..) , Package(..), packageName, packageVersion ) import Distribution.Version ( VersionRange, withinRange ) import Distribution.Simple.Utils ( lowercase ) import qualified Prelude (foldr1) -- | The collection of information about packages from one or more 'PackageDB's. -- -- It can be searched efficiently by package name and version. -- newtype PackageIndex pkg = PackageIndex -- This index package names to all the package records matching that package -- name case-sensitively. It includes all versions. -- -- This allows us to find all versions satisfying a dependency. -- Most queries are a map lookup followed by a linear scan of the bucket. -- (Map PackageName [pkg]) deriving (Eq, Show, Read, Functor, Generic) --FIXME: the Functor instance here relies on no package id changes instance Package pkg => Semigroup (PackageIndex pkg) where (<>) = merge instance Package pkg => Monoid (PackageIndex pkg) where mempty = PackageIndex Map.empty mappend = (<>) --save one mappend with empty in the common case: mconcat [] = mempty mconcat xs = Prelude.foldr1 mappend xs instance Binary pkg => Binary (PackageIndex pkg) invariant :: Package pkg => PackageIndex pkg -> Bool invariant (PackageIndex m) = all (uncurry goodBucket) (Map.toList m) where goodBucket _ [] = False goodBucket name (pkg0:pkgs0) = check (packageId pkg0) pkgs0 where check pkgid [] = packageName pkgid == name check pkgid (pkg':pkgs) = packageName pkgid == name && pkgid < pkgid' && check pkgid' pkgs where pkgid' = packageId pkg' -- -- * Internal helpers -- mkPackageIndex :: Package pkg => Map PackageName [pkg] -> PackageIndex pkg mkPackageIndex index = expensiveAssert (invariant (PackageIndex index)) (PackageIndex index) internalError :: String -> a internalError name = error ("PackageIndex." ++ name ++ ": internal error") -- | Lookup a name in the index to get all packages that match that name -- case-sensitively. -- lookup :: PackageIndex pkg -> PackageName -> [pkg] lookup (PackageIndex m) name = fromMaybe [] $ Map.lookup name m -- -- * Construction -- -- | Build an index out of a bunch of packages. -- -- If there are duplicates, later ones mask earlier ones. -- fromList :: Package pkg => [pkg] -> PackageIndex pkg fromList pkgs = mkPackageIndex . Map.map fixBucket . Map.fromListWith (++) $ [ (packageName pkg, [pkg]) | pkg <- pkgs ] where fixBucket = -- out of groups of duplicates, later ones mask earlier ones -- but Map.fromListWith (++) constructs groups in reverse order map NE.head -- Eq instance for PackageIdentifier is wrong, so use Ord: . NE.groupBy (\a b -> EQ == comparing packageId a b) -- relies on sortBy being a stable sort so we -- can pick consistently among duplicates . sortBy (comparing packageId) -- -- * Updates -- -- | Merge two indexes. -- -- Packages from the second mask packages of the same exact name -- (case-sensitively) from the first. -- merge :: Package pkg => PackageIndex pkg -> PackageIndex pkg -> PackageIndex pkg merge i1@(PackageIndex m1) i2@(PackageIndex m2) = expensiveAssert (invariant i1 && invariant i2) $ mkPackageIndex (Map.unionWith mergeBuckets m1 m2) -- | Elements in the second list mask those in the first. mergeBuckets :: Package pkg => [pkg] -> [pkg] -> [pkg] mergeBuckets [] ys = ys mergeBuckets xs [] = xs mergeBuckets xs@(x:xs') ys@(y:ys') = case packageId x `compare` packageId y of GT -> y : mergeBuckets xs ys' EQ -> y : mergeBuckets xs' ys' LT -> x : mergeBuckets xs' ys -- | Override-merge of two indexes. -- -- Packages from the second mask packages of the same exact name -- (case-sensitively) from the first. -- override :: Package pkg => PackageIndex pkg -> PackageIndex pkg -> PackageIndex pkg override i1@(PackageIndex m1) i2@(PackageIndex m2) = expensiveAssert (invariant i1 && invariant i2) $ mkPackageIndex (Map.unionWith (\_l r -> r) m1 m2) -- | Inserts a single package into the index. -- -- This is equivalent to (but slightly quicker than) using 'mappend' or -- 'merge' with a singleton index. -- insert :: Package pkg => pkg -> PackageIndex pkg -> PackageIndex pkg insert pkg (PackageIndex index) = mkPackageIndex $ Map.insertWith (\_ -> insertNoDup) (packageName pkg) [pkg] index where pkgid = packageId pkg insertNoDup [] = [pkg] insertNoDup pkgs@(pkg':pkgs') = case compare pkgid (packageId pkg') of LT -> pkg : pkgs EQ -> pkg : pkgs' GT -> pkg' : insertNoDup pkgs' -- | Internal delete helper. -- delete :: Package pkg => PackageName -> (pkg -> Bool) -> PackageIndex pkg -> PackageIndex pkg delete name p (PackageIndex index) = mkPackageIndex $ Map.update filterBucket name index where filterBucket = deleteEmptyBucket . filter (not . p) deleteEmptyBucket [] = Nothing deleteEmptyBucket remaining = Just remaining -- | Removes a single package from the index. -- deletePackageId :: Package pkg => PackageIdentifier -> PackageIndex pkg -> PackageIndex pkg deletePackageId pkgid = delete (packageName pkgid) (\pkg -> packageId pkg == pkgid) -- | Removes all packages with this (case-sensitive) name from the index. -- deletePackageName :: Package pkg => PackageName -> PackageIndex pkg -> PackageIndex pkg deletePackageName name = delete name (\pkg -> packageName pkg == name) -- | Removes all packages satisfying this dependency from the index. deleteDependency :: Package pkg => PackageName -> VersionRange -> PackageIndex pkg -> PackageIndex pkg deleteDependency name verstionRange = delete name (\pkg -> packageVersion pkg `withinRange` verstionRange) -- -- * Bulk queries -- -- | Get all the packages from the index. -- allPackages :: PackageIndex pkg -> [pkg] allPackages (PackageIndex m) = concat (Map.elems m) -- | Get all the packages from the index. -- -- They are grouped by package name, case-sensitively. -- allPackagesByName :: PackageIndex pkg -> [[pkg]] allPackagesByName (PackageIndex m) = Map.elems m -- -- * Lookups -- elemByPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier -> Bool elemByPackageId index = isJust . lookupPackageId index elemByPackageName :: Package pkg => PackageIndex pkg -> PackageName -> Bool elemByPackageName index = not . null . lookupPackageName index -- | Does a lookup by package id (name & version). -- -- Since multiple package DBs mask each other case-sensitively by package name, -- then we get back at most one package. -- lookupPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier -> Maybe pkg lookupPackageId index pkgid = case [ pkg | pkg <- lookup index (packageName pkgid) , packageId pkg == pkgid ] of [] -> Nothing [pkg] -> Just pkg _ -> internalError "lookupPackageIdentifier" -- | Does a case-sensitive search by package name. -- lookupPackageName :: Package pkg => PackageIndex pkg -> PackageName -> [pkg] lookupPackageName index name = [ pkg | pkg <- lookup index name , packageName pkg == name ] -- | Does a case-sensitive search by package name and a range of versions. -- -- We get back any number of versions of the specified package name, all -- satisfying the version range constraint. -- lookupDependency :: Package pkg => PackageIndex pkg -> PackageName -> VersionRange -> [pkg] lookupDependency index name versionRange = [ pkg | pkg <- lookup index name , packageName pkg == name , packageVersion pkg `withinRange` versionRange ] -- -- * Case insensitive name lookups -- -- | Does a case-insensitive search by package name. -- -- If there is only one package that compares case-insensitively to this name -- then the search is unambiguous and we get back all versions of that package. -- If several match case-insensitively but one matches exactly then it is also -- unambiguous. -- -- If however several match case-insensitively and none match exactly then we -- have an ambiguous result, and we get back all the versions of all the -- packages. The list of ambiguous results is split by exact package name. So -- it is a non-empty list of non-empty lists. -- searchByName :: PackageIndex pkg -> String -> [(PackageName, [pkg])] searchByName (PackageIndex m) name = [ pkgs | pkgs@(pname,_) <- Map.toList m , lowercase (unPackageName pname) == lname ] where lname = lowercase name data SearchResult a = None | Unambiguous a | Ambiguous [a] -- | Does a case-insensitive substring search by package name. -- -- That is, all packages that contain the given string in their name. -- searchByNameSubstring :: PackageIndex pkg -> String -> [(PackageName, [pkg])] searchByNameSubstring index searchterm = searchWithPredicate index (\n -> lsearchterm `isInfixOf` lowercase n) where lsearchterm = lowercase searchterm searchWithPredicate :: PackageIndex pkg -> (String -> Bool) -> [(PackageName, [pkg])] searchWithPredicate (PackageIndex m) predicate = [ pkgs | pkgs@(pname, _) <- Map.toList m , predicate (unPackageName pname) ] cabal-install-solver-3.8.1.0/src/Distribution/Solver/Types/PackagePath.hs0000644000000000000000000000742207346545000024425 0ustar0000000000000000module Distribution.Solver.Types.PackagePath ( PackagePath(..) , Namespace(..) , Qualifier(..) , dispQualifier , Qualified(..) , QPN , dispQPN , showQPN ) where import Distribution.Solver.Compat.Prelude import Prelude () import Distribution.Package (PackageName) import Distribution.Pretty (pretty, flatStyle) import qualified Text.PrettyPrint as Disp -- | A package path consists of a namespace and a package path inside that -- namespace. data PackagePath = PackagePath Namespace Qualifier deriving (Eq, Ord, Show) -- | Top-level namespace -- -- Package choices in different namespaces are considered completely independent -- by the solver. data Namespace = -- | The default namespace DefaultNamespace -- | A namespace for a specific build target | Independent PackageName deriving (Eq, Ord, Show) -- | Pretty-prints a namespace. The result is either empty or -- ends in a period, so it can be prepended onto a qualifier. dispNamespace :: Namespace -> Disp.Doc dispNamespace DefaultNamespace = Disp.empty dispNamespace (Independent i) = pretty i <<>> Disp.text "." -- | Qualifier of a package within a namespace (see 'PackagePath') data Qualifier = -- | Top-level dependency in this namespace QualToplevel -- | Any dependency on base is considered independent -- -- This makes it possible to have base shims. | QualBase PackageName -- | Setup dependency -- -- By rights setup dependencies ought to be nestable; after all, the setup -- dependencies of a package might themselves have setup dependencies, which -- are independent from everything else. However, this very quickly leads to -- infinite search trees in the solver. Therefore we limit ourselves to -- a single qualifier (within a given namespace). | QualSetup PackageName -- | If we depend on an executable from a package (via -- @build-tools@), we should solve for the dependencies of that -- package separately (since we're not going to actually try to -- link it.) We qualify for EACH package separately; e.g., -- @'Exe' pn1 pn2@ qualifies the @build-tools@ dependency on -- @pn2@ from package @pn1@. (If we tracked only @pn1@, that -- would require a consistent dependency resolution for all -- of the depended upon executables from a package; if we -- tracked only @pn2@, that would require us to pick only one -- version of an executable over the entire install plan.) | QualExe PackageName PackageName deriving (Eq, Ord, Show) -- | Pretty-prints a qualifier. The result is either empty or -- ends in a period, so it can be prepended onto a package name. -- -- NOTE: the base qualifier is for a dependency _on_ base; the qualifier is -- there to make sure different dependencies on base are all independent. -- So we want to print something like @"A.base"@, where the @"A."@ part -- is the qualifier and @"base"@ is the actual dependency (which, for the -- 'Base' qualifier, will always be @base@). dispQualifier :: Qualifier -> Disp.Doc dispQualifier QualToplevel = Disp.empty dispQualifier (QualSetup pn) = pretty pn <<>> Disp.text ":setup." dispQualifier (QualExe pn pn2) = pretty pn <<>> Disp.text ":" <<>> pretty pn2 <<>> Disp.text ":exe." dispQualifier (QualBase pn) = pretty pn <<>> Disp.text "." -- | A qualified entity. Pairs a package path with the entity. data Qualified a = Q PackagePath a deriving (Eq, Ord, Show) -- | Qualified package name. type QPN = Qualified PackageName -- | Pretty-prints a qualified package name. dispQPN :: QPN -> Disp.Doc dispQPN (Q (PackagePath ns qual) pn) = dispNamespace ns <<>> dispQualifier qual <<>> pretty pn -- | String representation of a qualified package name. showQPN :: QPN -> String showQPN = Disp.renderStyle flatStyle . dispQPN cabal-install-solver-3.8.1.0/src/Distribution/Solver/Types/PackagePreferences.hs0000644000000000000000000000177707346545000026001 0ustar0000000000000000module Distribution.Solver.Types.PackagePreferences ( PackagePreferences(..) ) where import Distribution.Solver.Types.InstalledPreference import Distribution.Solver.Types.OptionalStanza import Distribution.Version (VersionRange) -- | Per-package preferences on the version. It is a soft constraint that the -- 'DependencyResolver' should try to respect where possible. It consists of -- an 'InstalledPreference' which says if we prefer versions of packages -- that are already installed. It also has (possibly multiple) -- 'PackageVersionPreference's which are suggested constraints on the version -- number. The resolver should try to use package versions that satisfy -- the maximum number of the suggested version constraints. -- -- It is not specified if preferences on some packages are more important than -- others. -- data PackagePreferences = PackagePreferences [VersionRange] InstalledPreference [OptionalStanza] cabal-install-solver-3.8.1.0/src/Distribution/Solver/Types/PkgConfigDb.hs0000644000000000000000000001505707346545000024375 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} ----------------------------------------------------------------------------- -- | -- Module : Distribution.Solver.Types.PkgConfigDb -- Copyright : (c) Iñaki García Etxebarria 2016 -- License : BSD-like -- -- Maintainer : cabal-devel@haskell.org -- Portability : portable -- -- Read the list of packages available to pkg-config. ----------------------------------------------------------------------------- module Distribution.Solver.Types.PkgConfigDb ( PkgConfigDb (..) , readPkgConfigDb , pkgConfigDbFromList , pkgConfigPkgIsPresent , pkgConfigDbPkgVersion , getPkgConfigDbDirs ) where import Distribution.Solver.Compat.Prelude import Prelude () import Control.Exception (handle) import qualified Data.Map as M import System.FilePath (splitSearchPath) import Distribution.Compat.Environment (lookupEnv) import Distribution.Package (PkgconfigName, mkPkgconfigName) import Distribution.Parsec import Distribution.Simple.Program (ProgramDb, getProgramOutput, pkgConfigProgram, needProgram) import Distribution.Simple.Utils (info) import Distribution.Types.PkgconfigVersion import Distribution.Types.PkgconfigVersionRange import Distribution.Verbosity (Verbosity) -- | The list of packages installed in the system visible to -- @pkg-config@. This is an opaque datatype, to be constructed with -- `readPkgConfigDb` and queried with `pkgConfigPkgPresent`. data PkgConfigDb = PkgConfigDb (M.Map PkgconfigName (Maybe PkgconfigVersion)) -- ^ If an entry is `Nothing`, this means that the -- package seems to be present, but we don't know the -- exact version (because parsing of the version -- number failed). | NoPkgConfigDb -- ^ For when we could not run pkg-config successfully. deriving (Show, Generic, Typeable) instance Binary PkgConfigDb instance Structured PkgConfigDb -- | Query pkg-config for the list of installed packages, together -- with their versions. Return a `PkgConfigDb` encapsulating this -- information. readPkgConfigDb :: Verbosity -> ProgramDb -> IO PkgConfigDb readPkgConfigDb verbosity progdb = handle ioErrorHandler $ do mpkgConfig <- needProgram verbosity pkgConfigProgram progdb case mpkgConfig of Nothing -> noPkgConfig "Cannot find pkg-config program" Just (pkgConfig, _) -> do pkgList <- lines <$> getProgramOutput verbosity pkgConfig ["--list-all"] -- The output of @pkg-config --list-all@ also includes a description -- for each package, which we do not need. let pkgNames = map (takeWhile (not . isSpace)) pkgList pkgVersions <- lines <$> getProgramOutput verbosity pkgConfig ("--modversion" : pkgNames) (return . pkgConfigDbFromList . zip pkgNames) pkgVersions where -- For when pkg-config invocation fails (possibly because of a -- too long command line). noPkgConfig extra = do info verbosity ("Failed to query pkg-config, Cabal will continue" ++ " without solving for pkg-config constraints: " ++ extra) return NoPkgConfigDb ioErrorHandler :: IOException -> IO PkgConfigDb ioErrorHandler e = noPkgConfig (show e) -- | Create a `PkgConfigDb` from a list of @(packageName, version)@ pairs. pkgConfigDbFromList :: [(String, String)] -> PkgConfigDb pkgConfigDbFromList pairs = (PkgConfigDb . M.fromList . map convert) pairs where convert :: (String, String) -> (PkgconfigName, Maybe PkgconfigVersion) convert (n,vs) = (mkPkgconfigName n, simpleParsec vs) -- | Check whether a given package range is satisfiable in the given -- @pkg-config@ database. pkgConfigPkgIsPresent :: PkgConfigDb -> PkgconfigName -> PkgconfigVersionRange -> Bool pkgConfigPkgIsPresent (PkgConfigDb db) pn vr = case M.lookup pn db of Nothing -> False -- Package not present in the DB. Just Nothing -> True -- Package present, but version unknown. Just (Just v) -> withinPkgconfigVersionRange v vr -- If we could not read the pkg-config database successfully we fail. -- The plan found by the solver can't be executed later, because pkg-config itself -- is going to be called in the build phase to get the library location for linking -- so even if there is a library, it would need to be passed manual flags anyway. pkgConfigPkgIsPresent NoPkgConfigDb _ _ = False -- | Query the version of a package in the @pkg-config@ database. -- @Nothing@ indicates the package is not in the database, while -- @Just Nothing@ indicates that the package is in the database, -- but its version is not known. pkgConfigDbPkgVersion :: PkgConfigDb -> PkgconfigName -> Maybe (Maybe PkgconfigVersion) pkgConfigDbPkgVersion (PkgConfigDb db) pn = M.lookup pn db -- NB: Since the solver allows solving to succeed if there is -- NoPkgConfigDb, we should report that we *guess* that there -- is a matching pkg-config configuration, but that we just -- don't know about it. pkgConfigDbPkgVersion NoPkgConfigDb _ = Just Nothing -- | Query pkg-config for the locations of pkg-config's package files. Use this -- to monitor for changes in the pkg-config DB. -- getPkgConfigDbDirs :: Verbosity -> ProgramDb -> IO [FilePath] getPkgConfigDbDirs verbosity progdb = (++) <$> getEnvPath <*> getDefPath where -- According to @man pkg-config@: -- -- PKG_CONFIG_PATH -- A colon-separated (on Windows, semicolon-separated) list of directories -- to search for .pc files. The default directory will always be searched -- after searching the path -- getEnvPath = maybe [] parseSearchPath <$> lookupEnv "PKG_CONFIG_PATH" -- Again according to @man pkg-config@: -- -- pkg-config can be used to query itself for the default search path, -- version number and other information, for instance using: -- -- > pkg-config --variable pc_path pkg-config -- getDefPath = handle ioErrorHandler $ do mpkgConfig <- needProgram verbosity pkgConfigProgram progdb case mpkgConfig of Nothing -> return [] Just (pkgConfig, _) -> parseSearchPath <$> getProgramOutput verbosity pkgConfig ["--variable", "pc_path", "pkg-config"] parseSearchPath str = case lines str of [p] | not (null p) -> splitSearchPath p _ -> [] ioErrorHandler :: IOException -> IO [FilePath] ioErrorHandler _e = return [] cabal-install-solver-3.8.1.0/src/Distribution/Solver/Types/Progress.hs0000644000000000000000000000330107346545000024051 0ustar0000000000000000module Distribution.Solver.Types.Progress ( Progress(..) , foldProgress ) where import Prelude () import Distribution.Solver.Compat.Prelude hiding (fail) -- | A type to represent the unfolding of an expensive long running -- calculation that may fail. We may get intermediate steps before the final -- result which may be used to indicate progress and\/or logging messages. -- data Progress step fail done = Step step (Progress step fail done) | Fail fail | Done done -- This Functor instance works around a bug in GHC 7.6.3. -- See https://gitlab.haskell.org/ghc/ghc/-/issues/7436#note_66637. -- The derived functor instance caused a space leak in the solver. instance Functor (Progress step fail) where fmap f (Step s p) = Step s (fmap f p) fmap _ (Fail x) = Fail x fmap f (Done r) = Done (f r) -- | Consume a 'Progress' calculation. Much like 'foldr' for lists but with two -- base cases, one for a final result and one for failure. -- -- Eg to convert into a simple 'Either' result use: -- -- > foldProgress (flip const) Left Right -- foldProgress :: (step -> a -> a) -> (fail -> a) -> (done -> a) -> Progress step fail done -> a foldProgress step fail done = fold where fold (Step s p) = step s (fold p) fold (Fail f) = fail f fold (Done r) = done r instance Monad (Progress step fail) where return = pure p >>= f = foldProgress Step Fail f p instance Applicative (Progress step fail) where pure a = Done a p <*> x = foldProgress Step Fail (flip fmap x) p instance Monoid fail => Alternative (Progress step fail) where empty = Fail mempty p <|> q = foldProgress Step (const q) Done p cabal-install-solver-3.8.1.0/src/Distribution/Solver/Types/ResolverPackage.hs0000644000000000000000000000403007346545000025322 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DeriveGeneric #-} module Distribution.Solver.Types.ResolverPackage ( ResolverPackage(..) , resolverPackageLibDeps , resolverPackageExeDeps ) where import Distribution.Solver.Compat.Prelude import Prelude () import Distribution.Solver.Types.InstSolverPackage import Distribution.Solver.Types.SolverId import Distribution.Solver.Types.SolverPackage import qualified Distribution.Solver.Types.ComponentDeps as CD import Distribution.Compat.Graph (IsNode(..)) import Distribution.Package (Package(..), HasUnitId(..)) import Distribution.Simple.Utils (ordNub) -- | The dependency resolver picks either pre-existing installed packages -- or it picks source packages along with package configuration. -- -- This is like the 'InstallPlan.PlanPackage' but with fewer cases. -- data ResolverPackage loc = PreExisting InstSolverPackage | Configured (SolverPackage loc) deriving (Eq, Show, Generic) instance Binary loc => Binary (ResolverPackage loc) instance Structured loc => Structured (ResolverPackage loc) instance Package (ResolverPackage loc) where packageId (PreExisting ipkg) = packageId ipkg packageId (Configured spkg) = packageId spkg resolverPackageLibDeps :: ResolverPackage loc -> CD.ComponentDeps [SolverId] resolverPackageLibDeps (PreExisting ipkg) = instSolverPkgLibDeps ipkg resolverPackageLibDeps (Configured spkg) = solverPkgLibDeps spkg resolverPackageExeDeps :: ResolverPackage loc -> CD.ComponentDeps [SolverId] resolverPackageExeDeps (PreExisting ipkg) = instSolverPkgExeDeps ipkg resolverPackageExeDeps (Configured spkg) = solverPkgExeDeps spkg instance IsNode (ResolverPackage loc) where type Key (ResolverPackage loc) = SolverId nodeKey (PreExisting ipkg) = PreExistingId (packageId ipkg) (installedUnitId ipkg) nodeKey (Configured spkg) = PlannedId (packageId spkg) -- Use dependencies for ALL components nodeNeighbors pkg = ordNub $ CD.flatDeps (resolverPackageLibDeps pkg) ++ CD.flatDeps (resolverPackageExeDeps pkg) cabal-install-solver-3.8.1.0/src/Distribution/Solver/Types/Settings.hs0000644000000000000000000000576607346545000024066 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Distribution.Solver.Types.Settings ( ReorderGoals(..) , IndependentGoals(..) , MinimizeConflictSet(..) , AvoidReinstalls(..) , ShadowPkgs(..) , StrongFlags(..) , AllowBootLibInstalls(..) , OnlyConstrained(..) , EnableBackjumping(..) , CountConflicts(..) , FineGrainedConflicts(..) , SolveExecutables(..) ) where import Distribution.Solver.Compat.Prelude import Prelude () import Distribution.Simple.Setup ( BooleanFlag(..) ) import Distribution.Pretty ( Pretty(pretty) ) import Distribution.Parsec ( Parsec(parsec) ) import qualified Distribution.Compat.CharParsing as P import qualified Text.PrettyPrint as PP newtype ReorderGoals = ReorderGoals Bool deriving (BooleanFlag, Eq, Generic, Show) newtype CountConflicts = CountConflicts Bool deriving (BooleanFlag, Eq, Generic, Show) newtype FineGrainedConflicts = FineGrainedConflicts Bool deriving (BooleanFlag, Eq, Generic, Show) newtype MinimizeConflictSet = MinimizeConflictSet Bool deriving (BooleanFlag, Eq, Generic, Show) newtype IndependentGoals = IndependentGoals Bool deriving (BooleanFlag, Eq, Generic, Show) newtype AvoidReinstalls = AvoidReinstalls Bool deriving (BooleanFlag, Eq, Generic, Show) newtype ShadowPkgs = ShadowPkgs Bool deriving (BooleanFlag, Eq, Generic, Show) newtype StrongFlags = StrongFlags Bool deriving (BooleanFlag, Eq, Generic, Show) newtype AllowBootLibInstalls = AllowBootLibInstalls Bool deriving (BooleanFlag, Eq, Generic, Show) -- | Should we consider all packages we know about, or only those that -- have constraints explicitly placed on them or which are goals? data OnlyConstrained = OnlyConstrainedNone | OnlyConstrainedAll deriving (Eq, Generic, Show) newtype EnableBackjumping = EnableBackjumping Bool deriving (BooleanFlag, Eq, Generic, Show) newtype SolveExecutables = SolveExecutables Bool deriving (BooleanFlag, Eq, Generic, Show) instance Binary ReorderGoals instance Binary CountConflicts instance Binary FineGrainedConflicts instance Binary IndependentGoals instance Binary MinimizeConflictSet instance Binary AvoidReinstalls instance Binary ShadowPkgs instance Binary StrongFlags instance Binary AllowBootLibInstalls instance Binary OnlyConstrained instance Binary SolveExecutables instance Structured ReorderGoals instance Structured CountConflicts instance Structured FineGrainedConflicts instance Structured IndependentGoals instance Structured MinimizeConflictSet instance Structured AvoidReinstalls instance Structured ShadowPkgs instance Structured StrongFlags instance Structured AllowBootLibInstalls instance Structured OnlyConstrained instance Structured SolveExecutables instance Pretty OnlyConstrained where pretty OnlyConstrainedAll = PP.text "all" pretty OnlyConstrainedNone = PP.text "none" instance Parsec OnlyConstrained where parsec = P.choice [ P.string "all" >> return OnlyConstrainedAll , P.string "none" >> return OnlyConstrainedNone ] cabal-install-solver-3.8.1.0/src/Distribution/Solver/Types/SolverId.hs0000644000000000000000000000144607346545000024004 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} module Distribution.Solver.Types.SolverId ( SolverId(..) ) where import Distribution.Solver.Compat.Prelude import Prelude () import Distribution.Package (PackageId, Package(..), UnitId) -- | The solver can produce references to existing packages or -- packages we plan to install. Unlike 'ConfiguredId' we don't -- yet know the 'UnitId' for planned packages, because it's -- not the solver's job to compute them. -- data SolverId = PreExistingId { solverSrcId :: PackageId, solverInstId :: UnitId } | PlannedId { solverSrcId :: PackageId } deriving (Eq, Ord, Generic) instance Binary SolverId instance Structured SolverId instance Show SolverId where show = show . solverSrcId instance Package SolverId where packageId = solverSrcId cabal-install-solver-3.8.1.0/src/Distribution/Solver/Types/SolverPackage.hs0000644000000000000000000000244607346545000025004 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} module Distribution.Solver.Types.SolverPackage ( SolverPackage(..) ) where import Distribution.Solver.Compat.Prelude import Prelude () import Distribution.Package ( Package(..) ) import Distribution.PackageDescription ( FlagAssignment ) import Distribution.Solver.Types.ComponentDeps ( ComponentDeps ) import Distribution.Solver.Types.OptionalStanza import Distribution.Solver.Types.SolverId import Distribution.Solver.Types.SourcePackage -- | A 'SolverPackage' is a package specified by the dependency solver. -- It will get elaborated into a 'ConfiguredPackage' or even an -- 'ElaboratedConfiguredPackage'. -- -- NB: 'SolverPackage's are essentially always with 'UnresolvedPkgLoc', -- but for symmetry we have the parameter. (Maybe it can be removed.) -- data SolverPackage loc = SolverPackage { solverPkgSource :: SourcePackage loc, solverPkgFlags :: FlagAssignment, solverPkgStanzas :: OptionalStanzaSet, solverPkgLibDeps :: ComponentDeps [SolverId], solverPkgExeDeps :: ComponentDeps [SolverId] } deriving (Eq, Show, Generic) instance Binary loc => Binary (SolverPackage loc) instance Structured loc => Structured (SolverPackage loc) instance Package (SolverPackage loc) where packageId = packageId . solverPkgSource cabal-install-solver-3.8.1.0/src/Distribution/Solver/Types/SourcePackage.hs0000644000000000000000000000232607346545000024767 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveDataTypeable #-} module Distribution.Solver.Types.SourcePackage ( PackageDescriptionOverride , SourcePackage(..) ) where import Distribution.Solver.Compat.Prelude import Prelude () import Distribution.Package ( PackageId, Package(..) ) import Distribution.PackageDescription ( GenericPackageDescription(..) ) import Data.ByteString.Lazy (ByteString) -- | A package description along with the location of the package sources. -- data SourcePackage loc = SourcePackage { srcpkgPackageId :: PackageId , srcpkgDescription :: GenericPackageDescription -- ^ Note, this field is lazy, e.g. when reading in hackage index -- we parse only what we need, not whole index. , srcpkgSource :: loc , srcpkgDescrOverride :: PackageDescriptionOverride } deriving (Eq, Show, Generic, Typeable) instance Binary loc => Binary (SourcePackage loc) instance Structured loc => Structured (SourcePackage loc) instance Package (SourcePackage a) where packageId = srcpkgPackageId -- | We sometimes need to override the .cabal file in the tarball with -- the newer one from the package index. type PackageDescriptionOverride = Maybe ByteString cabal-install-solver-3.8.1.0/src/Distribution/Solver/Types/Variable.hs0000644000000000000000000000061107346545000023773 0ustar0000000000000000module Distribution.Solver.Types.Variable where import Prelude (Eq, Show) import Distribution.Solver.Types.OptionalStanza import Distribution.PackageDescription (FlagName) -- | Variables used by the dependency solver. This type is similar to the -- internal 'Var' type. data Variable qpn = PackageVar qpn | FlagVar qpn FlagName | StanzaVar qpn OptionalStanza deriving (Eq, Show) cabal-install-solver-3.8.1.0/tests/0000755000000000000000000000000007346545000015232 5ustar0000000000000000cabal-install-solver-3.8.1.0/tests/UnitTests.hs0000644000000000000000000000047307346545000017534 0ustar0000000000000000module Main (main) where import Test.Tasty import qualified UnitTests.Distribution.Solver.Modular.MessageUtils main :: IO () main = defaultMain $ testGroup "Unit Tests" [ testGroup "UnitTests.Distribution.Solver.Modular.MessageUtils" UnitTests.Distribution.Solver.Modular.MessageUtils.tests ] cabal-install-solver-3.8.1.0/tests/UnitTests/Distribution/Solver/Modular/0000755000000000000000000000000007346545000024530 5ustar0000000000000000cabal-install-solver-3.8.1.0/tests/UnitTests/Distribution/Solver/Modular/MessageUtils.hs0000644000000000000000000000503207346545000027471 0ustar0000000000000000module UnitTests.Distribution.Solver.Modular.MessageUtils ( tests ) where import Distribution.Solver.Modular.MessageUtils (allKnownExtensions, cutoffRange, withinRange, mostSimilarElement) import Language.Haskell.Extension (knownLanguages) import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck tests :: [TestTree] tests = testProperty "the equal string is always the closest" propEqualStringClosest : assertionTests -- The equal string will always be the most similar element propEqualStringClosest :: String -> Bool propEqualStringClosest str = mostSimilarElement str [str] == str assertionTests :: [TestTree] assertionTests = map (testCase "assert equals") (extensionAssertions ++ languageAssertions) ++ map (testCase "assert truthy") rangeAssertions extensionAssertions :: [Assertion] extensionAssertions = map (`testClosest` extensionStrings) shouldSuggestExtension languageAssertions :: [Assertion] languageAssertions = map (`testClosest` languageStrings) shouldSuggestLanguage testClosest :: (String, String) -> [String] -> Assertion testClosest (misspelled, closestMatch) elems = assertEqual "Strings should match" closestMatch (mostSimilarElement misspelled elems) extensionStrings :: [String] extensionStrings = allKnownExtensions languageStrings :: [String] languageStrings = show <$> knownLanguages -- Given x misspelled extension should suggest y extension shouldSuggestExtension :: [(String, String)] shouldSuggestExtension = [ ("FlexibleConstraints", "FlexibleContexts") , ("FlexibleInstantiation", "FlexibleInstances") , ("GATs", "GADTs") , ("MultiTypeClass", "MultiParamTypeClasses") , ("NoMonoLoclBinds", "NoMonoLocalBinds") , ("NoLamdaCase", "NoLambdaCase") ] -- Given x misspelled language should suggest y language shouldSuggestLanguage :: [(String, String)] shouldSuggestLanguage = [ ("GHC2020", "GHC2021") , ("Haskell2011", "Haskell2010") , ("Hugs98", "Haskell98") ] rangeAssertions :: [Assertion] rangeAssertions = map (testRange cutoffRange extensionStrings) outOfBounds isOutOfBounds :: Int -> String -> String -> Bool isOutOfBounds range a b = not $ withinRange range a b testRange :: Int -> [String] -> String -> Assertion testRange range elems erronousElement = assertBool "String should be out of bounds to make a spelling suggestion" (isOutOfBounds range erronousElement suggestion) where suggestion = mostSimilarElement erronousElement elems outOfBounds :: [String] outOfBounds = [ "HopefullyThisExtensionWontOccur" , "ThisIsNotEvenRemotelyAnExtension" , "IsThisMaybeAnExtension" ]