diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,1 @@ +Please see https://hackage.haskell.org/package/cabal-install/changelog diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,34 @@ +Copyright (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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple +main :: IO () +main = defaultMain diff --git a/cabal-install-solver.cabal b/cabal-install-solver.cabal new file mode 100644 --- /dev/null +++ b/cabal-install-solver.cabal @@ -0,0 +1,147 @@ +cabal-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 diff --git a/src-assertion/Distribution/Client/Utils/Assertion.hs b/src-assertion/Distribution/Client/Utils/Assertion.hs new file mode 100644 --- /dev/null +++ b/src-assertion/Distribution/Client/Utils/Assertion.hs @@ -0,0 +1,22 @@ +{-# 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 diff --git a/src/Distribution/Solver/Compat/Prelude.hs b/src/Distribution/Solver/Compat/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Compat/Prelude.hs @@ -0,0 +1,19 @@ +-- 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) diff --git a/src/Distribution/Solver/Modular.hs b/src/Distribution/Solver/Modular.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Modular.hs @@ -0,0 +1,338 @@ +{-# 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 = "" diff --git a/src/Distribution/Solver/Modular/Assignment.hs b/src/Distribution/Solver/Modular/Assignment.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Modular/Assignment.hs @@ -0,0 +1,94 @@ +module 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 diff --git a/src/Distribution/Solver/Modular/Builder.hs b/src/Distribution/Solver/Modular/Builder.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Modular/Builder.hs @@ -0,0 +1,296 @@ +{-# 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 diff --git a/src/Distribution/Solver/Modular/Configured.hs b/src/Distribution/Solver/Modular/Configured.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Modular/Configured.hs @@ -0,0 +1,13 @@ +module 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]) diff --git a/src/Distribution/Solver/Modular/ConfiguredConversion.hs b/src/Distribution/Solver/Modular/ConfiguredConversion.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Modular/ConfiguredConversion.hs @@ -0,0 +1,72 @@ +module 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 diff --git a/src/Distribution/Solver/Modular/ConflictSet.hs b/src/Distribution/Solver/Modular/ConflictSet.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Modular/ConflictSet.hs @@ -0,0 +1,244 @@ +{-# 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 + diff --git a/src/Distribution/Solver/Modular/Cycles.hs b/src/Distribution/Solver/Modular/Cycles.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Modular/Cycles.hs @@ -0,0 +1,120 @@ +{-# 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] diff --git a/src/Distribution/Solver/Modular/Dependency.hs b/src/Distribution/Solver/Modular/Dependency.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Modular/Dependency.hs @@ -0,0 +1,358 @@ +{-# 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 diff --git a/src/Distribution/Solver/Modular/Explore.hs b/src/Distribution/Solver/Modular/Explore.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Modular/Explore.hs @@ -0,0 +1,366 @@ +{-# 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 diff --git a/src/Distribution/Solver/Modular/Flag.hs b/src/Distribution/Solver/Modular/Flag.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Modular/Flag.hs @@ -0,0 +1,108 @@ +{-# 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 diff --git a/src/Distribution/Solver/Modular/Index.hs b/src/Distribution/Solver/Modular/Index.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Modular/Index.hs @@ -0,0 +1,74 @@ +module 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" diff --git a/src/Distribution/Solver/Modular/IndexConversion.hs b/src/Distribution/Solver/Modular/IndexConversion.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Modular/IndexConversion.hs @@ -0,0 +1,562 @@ +module 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 ] diff --git a/src/Distribution/Solver/Modular/LabeledGraph.hs b/src/Distribution/Solver/Modular/LabeledGraph.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Modular/LabeledGraph.hs @@ -0,0 +1,117 @@ +-- | 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 diff --git a/src/Distribution/Solver/Modular/Linking.hs b/src/Distribution/Solver/Modular/Linking.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Modular/Linking.hs @@ -0,0 +1,519 @@ +{-# 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) diff --git a/src/Distribution/Solver/Modular/Log.hs b/src/Distribution/Solver/Modular/Log.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Modular/Log.hs @@ -0,0 +1,31 @@ +module 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 diff --git a/src/Distribution/Solver/Modular/Message.hs b/src/Distribution/Solver/Modular/Message.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Modular/Message.hs @@ -0,0 +1,273 @@ +{-# 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 diff --git a/src/Distribution/Solver/Modular/MessageUtils.hs b/src/Distribution/Solver/Modular/MessageUtils.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Modular/MessageUtils.hs @@ -0,0 +1,56 @@ +-- | 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 diff --git a/src/Distribution/Solver/Modular/PSQ.hs b/src/Distribution/Solver/Modular/PSQ.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Modular/PSQ.hs @@ -0,0 +1,149 @@ +{-# 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) diff --git a/src/Distribution/Solver/Modular/Package.hs b/src/Distribution/Solver/Modular/Package.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Modular/Package.hs @@ -0,0 +1,106 @@ +{-# 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 diff --git a/src/Distribution/Solver/Modular/Preference.hs b/src/Distribution/Solver/Modular/Preference.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Modular/Preference.hs @@ -0,0 +1,494 @@ +{-# 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 diff --git a/src/Distribution/Solver/Modular/RetryLog.hs b/src/Distribution/Solver/Modular/RetryLog.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Modular/RetryLog.hs @@ -0,0 +1,72 @@ +{-# 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)) diff --git a/src/Distribution/Solver/Modular/Solver.hs b/src/Distribution/Solver/Modular/Solver.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Modular/Solver.hs @@ -0,0 +1,269 @@ +{-# 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 diff --git a/src/Distribution/Solver/Modular/Tree.hs b/src/Distribution/Solver/Modular/Tree.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Modular/Tree.hs @@ -0,0 +1,204 @@ +{-# 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 diff --git a/src/Distribution/Solver/Modular/Validate.hs b/src/Distribution/Solver/Modular/Validate.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Modular/Validate.hs @@ -0,0 +1,590 @@ +{-# 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 + } diff --git a/src/Distribution/Solver/Modular/Var.hs b/src/Distribution/Solver/Modular/Var.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Modular/Var.hs @@ -0,0 +1,34 @@ +{-# 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 diff --git a/src/Distribution/Solver/Modular/Version.hs b/src/Distribution/Solver/Modular/Version.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Modular/Version.hs @@ -0,0 +1,56 @@ +module 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 diff --git a/src/Distribution/Solver/Modular/WeightedPSQ.hs b/src/Distribution/Solver/Modular/WeightedPSQ.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Modular/WeightedPSQ.hs @@ -0,0 +1,108 @@ +{-# 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 diff --git a/src/Distribution/Solver/Types/ComponentDeps.hs b/src/Distribution/Solver/Types/ComponentDeps.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Types/ComponentDeps.hs @@ -0,0 +1,205 @@ +{-# 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 diff --git a/src/Distribution/Solver/Types/ConstraintSource.hs b/src/Distribution/Solver/Types/ConstraintSource.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Types/ConstraintSource.hs @@ -0,0 +1,72 @@ +{-# 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" diff --git a/src/Distribution/Solver/Types/DependencyResolver.hs b/src/Distribution/Solver/Types/DependencyResolver.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Types/DependencyResolver.hs @@ -0,0 +1,37 @@ +module 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] diff --git a/src/Distribution/Solver/Types/Flag.hs b/src/Distribution/Solver/Types/Flag.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Types/Flag.hs @@ -0,0 +1,8 @@ +module Distribution.Solver.Types.Flag + ( FlagType(..) + ) where + +import Prelude (Eq, Show) + +data FlagType = Manual | Automatic + deriving (Eq, Show) diff --git a/src/Distribution/Solver/Types/InstSolverPackage.hs b/src/Distribution/Solver/Types/InstSolverPackage.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Types/InstSolverPackage.hs @@ -0,0 +1,39 @@ +{-# 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 diff --git a/src/Distribution/Solver/Types/InstalledPreference.hs b/src/Distribution/Solver/Types/InstalledPreference.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Types/InstalledPreference.hs @@ -0,0 +1,11 @@ +module 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 diff --git a/src/Distribution/Solver/Types/LabeledPackageConstraint.hs b/src/Distribution/Solver/Types/LabeledPackageConstraint.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Types/LabeledPackageConstraint.hs @@ -0,0 +1,14 @@ +module 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 diff --git a/src/Distribution/Solver/Types/OptionalStanza.hs b/src/Distribution/Solver/Types/OptionalStanza.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Types/OptionalStanza.hs @@ -0,0 +1,138 @@ +{-# 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 diff --git a/src/Distribution/Solver/Types/PackageConstraint.hs b/src/Distribution/Solver/Types/PackageConstraint.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Types/PackageConstraint.hs @@ -0,0 +1,148 @@ +{-# 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 diff --git a/src/Distribution/Solver/Types/PackageFixedDeps.hs b/src/Distribution/Solver/Types/PackageFixedDeps.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Types/PackageFixedDeps.hs @@ -0,0 +1,23 @@ +module 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) + diff --git a/src/Distribution/Solver/Types/PackageIndex.hs b/src/Distribution/Solver/Types/PackageIndex.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Types/PackageIndex.hs @@ -0,0 +1,338 @@ +{-# 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) + ] diff --git a/src/Distribution/Solver/Types/PackagePath.hs b/src/Distribution/Solver/Types/PackagePath.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Types/PackagePath.hs @@ -0,0 +1,102 @@ +module 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 diff --git a/src/Distribution/Solver/Types/PackagePreferences.hs b/src/Distribution/Solver/Types/PackagePreferences.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Types/PackagePreferences.hs @@ -0,0 +1,22 @@ +module 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] diff --git a/src/Distribution/Solver/Types/PkgConfigDb.hs b/src/Distribution/Solver/Types/PkgConfigDb.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Types/PkgConfigDb.hs @@ -0,0 +1,156 @@ +{-# 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 [] diff --git a/src/Distribution/Solver/Types/Progress.hs b/src/Distribution/Solver/Types/Progress.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Types/Progress.hs @@ -0,0 +1,49 @@ +module 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 diff --git a/src/Distribution/Solver/Types/ResolverPackage.hs b/src/Distribution/Solver/Types/ResolverPackage.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Types/ResolverPackage.hs @@ -0,0 +1,52 @@ +{-# 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) diff --git a/src/Distribution/Solver/Types/Settings.hs b/src/Distribution/Solver/Types/Settings.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Types/Settings.hs @@ -0,0 +1,101 @@ +{-# 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 + ] + diff --git a/src/Distribution/Solver/Types/SolverId.hs b/src/Distribution/Solver/Types/SolverId.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Types/SolverId.hs @@ -0,0 +1,29 @@ +{-# 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 diff --git a/src/Distribution/Solver/Types/SolverPackage.hs b/src/Distribution/Solver/Types/SolverPackage.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Types/SolverPackage.hs @@ -0,0 +1,36 @@ +{-# 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 diff --git a/src/Distribution/Solver/Types/SourcePackage.hs b/src/Distribution/Solver/Types/SourcePackage.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Types/SourcePackage.hs @@ -0,0 +1,37 @@ +{-# 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 diff --git a/src/Distribution/Solver/Types/Variable.hs b/src/Distribution/Solver/Types/Variable.hs new file mode 100644 --- /dev/null +++ b/src/Distribution/Solver/Types/Variable.hs @@ -0,0 +1,15 @@ +module 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) diff --git a/tests/UnitTests.hs b/tests/UnitTests.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests.hs @@ -0,0 +1,12 @@ +module 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 + ] diff --git a/tests/UnitTests/Distribution/Solver/Modular/MessageUtils.hs b/tests/UnitTests/Distribution/Solver/Modular/MessageUtils.hs new file mode 100644 --- /dev/null +++ b/tests/UnitTests/Distribution/Solver/Modular/MessageUtils.hs @@ -0,0 +1,70 @@ +module 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" + ]