packages feed

cabal-install-solver (empty) → 3.8.1.0

raw patch · 56 files changed

+7663/−0 lines, 56 filesdep +Cabaldep +Cabal-syntaxdep +arraysetup-changed

Dependencies added: Cabal, Cabal-syntax, array, base, bytestring, cabal-install-solver, containers, edit-distance, filepath, mtl, pretty, tasty, tasty-hunit, tasty-quickcheck, tracetree, transformers

Files

+ ChangeLog.md view
@@ -0,0 +1,1 @@+Please see https://hackage.haskell.org/package/cabal-install/changelog
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main :: IO ()+main = defaultMain
+ cabal-install-solver.cabal view
@@ -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 <cabal-devel@haskell.org>+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
+ src-assertion/Distribution/Client/Utils/Assertion.hs view
@@ -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
+ src/Distribution/Solver/Compat/Prelude.hs view
@@ -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)
+ src/Distribution/Solver/Modular.hs view
@@ -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  = ""
+ src/Distribution/Solver/Modular/Assignment.hs view
@@ -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
+ src/Distribution/Solver/Modular/Builder.hs view
@@ -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
+ src/Distribution/Solver/Modular/Configured.hs view
@@ -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])
+ src/Distribution/Solver/Modular/ConfiguredConversion.hs view
@@ -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
+ src/Distribution/Solver/Modular/ConflictSet.hs view
@@ -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+
+ src/Distribution/Solver/Modular/Cycles.hs view
@@ -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]
+ src/Distribution/Solver/Modular/Dependency.hs view
@@ -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
+ src/Distribution/Solver/Modular/Explore.hs view
@@ -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
+ src/Distribution/Solver/Modular/Flag.hs view
@@ -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
+ src/Distribution/Solver/Modular/Index.hs view
@@ -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"
+ src/Distribution/Solver/Modular/IndexConversion.hs view
@@ -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 ]
+ src/Distribution/Solver/Modular/LabeledGraph.hs view
@@ -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
+ src/Distribution/Solver/Modular/Linking.hs view
@@ -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)
+ src/Distribution/Solver/Modular/Log.hs view
@@ -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
+ src/Distribution/Solver/Modular/Message.hs view
@@ -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
+ src/Distribution/Solver/Modular/MessageUtils.hs view
@@ -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
+ src/Distribution/Solver/Modular/PSQ.hs view
@@ -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)
+ src/Distribution/Solver/Modular/Package.hs view
@@ -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
+ src/Distribution/Solver/Modular/Preference.hs view
@@ -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
+ src/Distribution/Solver/Modular/RetryLog.hs view
@@ -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))
+ src/Distribution/Solver/Modular/Solver.hs view
@@ -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
+ src/Distribution/Solver/Modular/Tree.hs view
@@ -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 <http://www.well-typed.com/blog/2015/03/qualified-goals/> 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
+ src/Distribution/Solver/Modular/Validate.hs view
@@ -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+  }
+ src/Distribution/Solver/Modular/Var.hs view
@@ -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
+ src/Distribution/Solver/Modular/Version.hs view
@@ -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
+ src/Distribution/Solver/Modular/WeightedPSQ.hs view
@@ -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
+ src/Distribution/Solver/Types/ComponentDeps.hs view
@@ -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
+ src/Distribution/Solver/Types/ConstraintSource.hs view
@@ -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"
+ src/Distribution/Solver/Types/DependencyResolver.hs view
@@ -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]
+ src/Distribution/Solver/Types/Flag.hs view
@@ -0,0 +1,8 @@+module Distribution.Solver.Types.Flag+    ( FlagType(..)+    ) where++import Prelude (Eq, Show)++data FlagType = Manual | Automatic+  deriving (Eq, Show)
+ src/Distribution/Solver/Types/InstSolverPackage.hs view
@@ -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
+ src/Distribution/Solver/Types/InstalledPreference.hs view
@@ -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
+ src/Distribution/Solver/Types/LabeledPackageConstraint.hs view
@@ -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
+ src/Distribution/Solver/Types/OptionalStanza.hs view
@@ -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
+ src/Distribution/Solver/Types/PackageConstraint.hs view
@@ -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
+ src/Distribution/Solver/Types/PackageFixedDeps.hs view
@@ -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)+
+ src/Distribution/Solver/Types/PackageIndex.hs view
@@ -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)+    ]
+ src/Distribution/Solver/Types/PackagePath.hs view
@@ -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
+ src/Distribution/Solver/Types/PackagePreferences.hs view
@@ -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]
+ src/Distribution/Solver/Types/PkgConfigDb.hs view
@@ -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 []
+ src/Distribution/Solver/Types/Progress.hs view
@@ -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
+ src/Distribution/Solver/Types/ResolverPackage.hs view
@@ -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)
+ src/Distribution/Solver/Types/Settings.hs view
@@ -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+    ]+
+ src/Distribution/Solver/Types/SolverId.hs view
@@ -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
+ src/Distribution/Solver/Types/SolverPackage.hs view
@@ -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
+ src/Distribution/Solver/Types/SourcePackage.hs view
@@ -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
+ src/Distribution/Solver/Types/Variable.hs view
@@ -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)
+ tests/UnitTests.hs view
@@ -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+    ]
+ tests/UnitTests/Distribution/Solver/Modular/MessageUtils.hs view
@@ -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"+  ]