{-# 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 :: SolverConfig -> DependencyResolver loc
modularResolver SolverConfig
sc (Platform Arch
arch OS
os) CompilerInfo
cinfo InstalledPackageIndex
iidx PackageIndex (SourcePackage loc)
sidx PkgConfigDb
pkgConfigDB PackageName -> PackagePreferences
pprefs [LabeledPackageConstraint]
pcs Set PackageName
pns =
  ((Assignment, RevDepMap) -> [ResolverPackage loc])
-> Progress String String (Assignment, RevDepMap)
-> Progress String String [ResolverPackage loc]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Assignment -> RevDepMap -> [ResolverPackage loc])
-> (Assignment, RevDepMap) -> [ResolverPackage loc]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Assignment -> RevDepMap -> [ResolverPackage loc]
postprocess) (Progress String String (Assignment, RevDepMap)
 -> Progress String String [ResolverPackage loc])
-> Progress String String (Assignment, RevDepMap)
-> Progress String String [ResolverPackage loc]
forall a b. (a -> b) -> a -> b
$ -- convert install plan
  SolverConfig
-> CompilerInfo
-> Index
-> PkgConfigDb
-> (PackageName -> PackagePreferences)
-> Map PackageName [LabeledPackageConstraint]
-> Set PackageName
-> Progress String String (Assignment, RevDepMap)
solve' SolverConfig
sc CompilerInfo
cinfo Index
idx PkgConfigDb
pkgConfigDB PackageName -> PackagePreferences
pprefs Map PackageName [LabeledPackageConstraint]
gcs Set PackageName
pns
    where
      -- Indices have to be converted into solver-specific uniform index.
      idx :: Index
idx    = OS
-> Arch
-> CompilerInfo
-> Map PackageName [LabeledPackageConstraint]
-> ShadowPkgs
-> StrongFlags
-> SolveExecutables
-> InstalledPackageIndex
-> PackageIndex (SourcePackage loc)
-> Index
forall loc.
OS
-> Arch
-> CompilerInfo
-> Map PackageName [LabeledPackageConstraint]
-> ShadowPkgs
-> StrongFlags
-> SolveExecutables
-> InstalledPackageIndex
-> PackageIndex (SourcePackage loc)
-> Index
convPIs OS
os Arch
arch CompilerInfo
cinfo Map PackageName [LabeledPackageConstraint]
gcs (SolverConfig -> ShadowPkgs
shadowPkgs SolverConfig
sc) (SolverConfig -> StrongFlags
strongFlags SolverConfig
sc) (SolverConfig -> SolveExecutables
solveExecutables SolverConfig
sc) InstalledPackageIndex
iidx PackageIndex (SourcePackage loc)
sidx
      -- Constraints have to be converted into a finite map indexed by PN.
      gcs :: Map PackageName [LabeledPackageConstraint]
gcs    = ([LabeledPackageConstraint]
 -> [LabeledPackageConstraint] -> [LabeledPackageConstraint])
-> [(PackageName, [LabeledPackageConstraint])]
-> Map PackageName [LabeledPackageConstraint]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith [LabeledPackageConstraint]
-> [LabeledPackageConstraint] -> [LabeledPackageConstraint]
forall a. [a] -> [a] -> [a]
(++) ((LabeledPackageConstraint
 -> (PackageName, [LabeledPackageConstraint]))
-> [LabeledPackageConstraint]
-> [(PackageName, [LabeledPackageConstraint])]
forall a b. (a -> b) -> [a] -> [b]
map LabeledPackageConstraint
-> (PackageName, [LabeledPackageConstraint])
pair [LabeledPackageConstraint]
pcs)
        where
          pair :: LabeledPackageConstraint
-> (PackageName, [LabeledPackageConstraint])
pair LabeledPackageConstraint
lpc = (PackageConstraint -> PackageName
pcName (PackageConstraint -> PackageName)
-> PackageConstraint -> PackageName
forall a b. (a -> b) -> a -> b
$ LabeledPackageConstraint -> PackageConstraint
unlabelPackageConstraint LabeledPackageConstraint
lpc, [LabeledPackageConstraint
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 :: Assignment -> RevDepMap -> [ResolverPackage loc]
postprocess Assignment
a RevDepMap
rdm = (ResolverPackage loc -> SolverId)
-> [ResolverPackage loc] -> [ResolverPackage loc]
forall b a. Ord b => (a -> b) -> [a] -> [a]
ordNubBy ResolverPackage loc -> SolverId
forall a. IsNode a => a -> Key a
nodeKey ([ResolverPackage loc] -> [ResolverPackage loc])
-> [ResolverPackage loc] -> [ResolverPackage loc]
forall a b. (a -> b) -> a -> b
$
                          (CP QPN -> ResolverPackage loc)
-> [CP QPN] -> [ResolverPackage loc]
forall a b. (a -> b) -> [a] -> [b]
map (InstalledPackageIndex
-> PackageIndex (SourcePackage loc)
-> CP QPN
-> ResolverPackage loc
forall loc.
InstalledPackageIndex
-> PackageIndex (SourcePackage loc)
-> CP QPN
-> ResolverPackage loc
convCP InstalledPackageIndex
iidx PackageIndex (SourcePackage loc)
sidx) (Assignment -> RevDepMap -> [CP QPN]
toCPs Assignment
a RevDepMap
rdm)

      -- Helper function to extract the PN from a constraint.
      pcName :: PackageConstraint -> PN
      pcName :: PackageConstraint -> PackageName
pcName (PackageConstraint ConstraintScope
scope PackageProperty
_) = ConstraintScope -> PackageName
scopeToPackageName ConstraintScope
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' :: SolverConfig
-> CompilerInfo
-> Index
-> PkgConfigDb
-> (PackageName -> PackagePreferences)
-> Map PackageName [LabeledPackageConstraint]
-> Set PackageName
-> Progress String String (Assignment, RevDepMap)
solve' SolverConfig
sc CompilerInfo
cinfo Index
idx PkgConfigDb
pkgConfigDB PackageName -> PackagePreferences
pprefs Map PackageName [LabeledPackageConstraint]
gcs Set PackageName
pns =
    RetryLog String String (Assignment, RevDepMap)
-> Progress String String (Assignment, RevDepMap)
forall step fail done.
RetryLog step fail done -> Progress step fail done
toProgress (RetryLog String String (Assignment, RevDepMap)
 -> Progress String String (Assignment, RevDepMap))
-> RetryLog String String (Assignment, RevDepMap)
-> Progress String String (Assignment, RevDepMap)
forall a b. (a -> b) -> a -> b
$ RetryLog String SolverFailure (Assignment, RevDepMap)
-> (SolverFailure
    -> RetryLog String String (Assignment, RevDepMap))
-> RetryLog String String (Assignment, RevDepMap)
forall step fail1 done fail2.
RetryLog step fail1 done
-> (fail1 -> RetryLog step fail2 done) -> RetryLog step fail2 done
retry (Bool
-> SolverConfig
-> RetryLog String SolverFailure (Assignment, RevDepMap)
runSolver Bool
printFullLog SolverConfig
sc) SolverFailure -> RetryLog String String (Assignment, RevDepMap)
createErrorMsg
  where
    runSolver :: Bool -> SolverConfig
              -> RetryLog String SolverFailure (Assignment, RevDepMap)
    runSolver :: Bool
-> SolverConfig
-> RetryLog String SolverFailure (Assignment, RevDepMap)
runSolver Bool
keepLog SolverConfig
sc' =
        Bool
-> RetryLog Message SolverFailure (Assignment, RevDepMap)
-> RetryLog String SolverFailure (Assignment, RevDepMap)
forall a.
Bool
-> RetryLog Message SolverFailure a
-> RetryLog String SolverFailure a
displayLogMessages Bool
keepLog (RetryLog Message SolverFailure (Assignment, RevDepMap)
 -> RetryLog String SolverFailure (Assignment, RevDepMap))
-> RetryLog Message SolverFailure (Assignment, RevDepMap)
-> RetryLog String SolverFailure (Assignment, RevDepMap)
forall a b. (a -> b) -> a -> b
$
        SolverConfig
-> CompilerInfo
-> Index
-> PkgConfigDb
-> (PackageName -> PackagePreferences)
-> Map PackageName [LabeledPackageConstraint]
-> Set PackageName
-> RetryLog Message SolverFailure (Assignment, RevDepMap)
solve SolverConfig
sc' CompilerInfo
cinfo Index
idx PkgConfigDb
pkgConfigDB PackageName -> PackagePreferences
pprefs Map PackageName [LabeledPackageConstraint]
gcs Set PackageName
pns

    createErrorMsg :: SolverFailure
                   -> RetryLog String String (Assignment, RevDepMap)
    createErrorMsg :: SolverFailure -> RetryLog String String (Assignment, RevDepMap)
createErrorMsg failure :: SolverFailure
failure@(ExhaustiveSearch ConflictSet
cs ConflictMap
cm) =
      if MinimizeConflictSet -> Bool
forall a. BooleanFlag a => a -> Bool
asBool (MinimizeConflictSet -> Bool) -> MinimizeConflictSet -> Bool
forall a b. (a -> b) -> a -> b
$ SolverConfig -> MinimizeConflictSet
minimizeConflictSet SolverConfig
sc
      then String
-> RetryLog String String (Assignment, RevDepMap)
-> RetryLog String String (Assignment, RevDepMap)
forall step fail done.
step -> RetryLog step fail done -> RetryLog step fail done
continueWith (String
"Found no solution after exhaustively searching the "
                          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"dependency tree. Rerunning the dependency solver "
                          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"to minimize the conflict set ({"
                          String -> String -> String
forall a. [a] -> [a] -> [a]
++ ConflictSet -> String
showConflictSet ConflictSet
cs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"}).") (RetryLog String String (Assignment, RevDepMap)
 -> RetryLog String String (Assignment, RevDepMap))
-> RetryLog String String (Assignment, RevDepMap)
-> RetryLog String String (Assignment, RevDepMap)
forall a b. (a -> b) -> a -> b
$
           RetryLog String SolverFailure (Assignment, RevDepMap)
-> (SolverFailure
    -> RetryLog String String (Assignment, RevDepMap))
-> RetryLog String String (Assignment, RevDepMap)
forall step fail1 done fail2.
RetryLog step fail1 done
-> (fail1 -> RetryLog step fail2 done) -> RetryLog step fail2 done
retry ((SolverConfig
 -> RetryLog String SolverFailure (Assignment, RevDepMap))
-> SolverConfig
-> ConflictSet
-> ConflictMap
-> RetryLog String SolverFailure (Assignment, RevDepMap)
forall a.
(SolverConfig -> RetryLog String SolverFailure a)
-> SolverConfig
-> ConflictSet
-> ConflictMap
-> RetryLog String SolverFailure a
tryToMinimizeConflictSet (Bool
-> SolverConfig
-> RetryLog String SolverFailure (Assignment, RevDepMap)
runSolver Bool
printFullLog) SolverConfig
sc ConflictSet
cs ConflictMap
cm) ((SolverFailure -> RetryLog String String (Assignment, RevDepMap))
 -> RetryLog String String (Assignment, RevDepMap))
-> (SolverFailure
    -> RetryLog String String (Assignment, RevDepMap))
-> RetryLog String String (Assignment, RevDepMap)
forall a b. (a -> b) -> a -> b
$
               \case
                  ExhaustiveSearch ConflictSet
cs' ConflictMap
cm' ->
                      Progress String String (Assignment, RevDepMap)
-> RetryLog String String (Assignment, RevDepMap)
forall step fail done.
Progress step fail done -> RetryLog step fail done
fromProgress (Progress String String (Assignment, RevDepMap)
 -> RetryLog String String (Assignment, RevDepMap))
-> Progress String String (Assignment, RevDepMap)
-> RetryLog String String (Assignment, RevDepMap)
forall a b. (a -> b) -> a -> b
$ String -> Progress String String (Assignment, RevDepMap)
forall step fail done. fail -> Progress step fail done
Fail (String -> Progress String String (Assignment, RevDepMap))
-> String -> Progress String String (Assignment, RevDepMap)
forall a b. (a -> b) -> a -> b
$
                          ConflictSet -> String
rerunSolverForErrorMsg ConflictSet
cs'
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ SolverConfig -> SolverFailure -> String
finalErrorMsg SolverConfig
sc (ConflictSet -> ConflictMap -> SolverFailure
ExhaustiveSearch ConflictSet
cs' ConflictMap
cm')
                  SolverFailure
BackjumpLimitReached ->
                      Progress String String (Assignment, RevDepMap)
-> RetryLog String String (Assignment, RevDepMap)
forall step fail done.
Progress step fail done -> RetryLog step fail done
fromProgress (Progress String String (Assignment, RevDepMap)
 -> RetryLog String String (Assignment, RevDepMap))
-> Progress String String (Assignment, RevDepMap)
-> RetryLog String String (Assignment, RevDepMap)
forall a b. (a -> b) -> a -> b
$ String -> Progress String String (Assignment, RevDepMap)
forall step fail done. fail -> Progress step fail done
Fail (String -> Progress String String (Assignment, RevDepMap))
-> String -> Progress String String (Assignment, RevDepMap)
forall a b. (a -> b) -> a -> b
$
                          String
"Reached backjump limit while trying to minimize the "
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"conflict set to create a better error message. "
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Original error message:\n"
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ ConflictSet -> String
rerunSolverForErrorMsg ConflictSet
cs
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ SolverConfig -> SolverFailure -> String
finalErrorMsg SolverConfig
sc SolverFailure
failure
      else Progress String String (Assignment, RevDepMap)
-> RetryLog String String (Assignment, RevDepMap)
forall step fail done.
Progress step fail done -> RetryLog step fail done
fromProgress (Progress String String (Assignment, RevDepMap)
 -> RetryLog String String (Assignment, RevDepMap))
-> Progress String String (Assignment, RevDepMap)
-> RetryLog String String (Assignment, RevDepMap)
forall a b. (a -> b) -> a -> b
$ String -> Progress String String (Assignment, RevDepMap)
forall step fail done. fail -> Progress step fail done
Fail (String -> Progress String String (Assignment, RevDepMap))
-> String -> Progress String String (Assignment, RevDepMap)
forall a b. (a -> b) -> a -> b
$
           ConflictSet -> String
rerunSolverForErrorMsg ConflictSet
cs String -> String -> String
forall a. [a] -> [a] -> [a]
++ SolverConfig -> SolverFailure -> String
finalErrorMsg SolverConfig
sc SolverFailure
failure
    createErrorMsg failure :: SolverFailure
failure@SolverFailure
BackjumpLimitReached     =
        String
-> RetryLog String String (Assignment, RevDepMap)
-> RetryLog String String (Assignment, RevDepMap)
forall step fail done.
step -> RetryLog step fail done -> RetryLog step fail done
continueWith
             (String
"Backjump limit reached. Rerunning dependency solver to generate "
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"a final conflict set for the search tree containing the "
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"first backjump.") (RetryLog String String (Assignment, RevDepMap)
 -> RetryLog String String (Assignment, RevDepMap))
-> RetryLog String String (Assignment, RevDepMap)
-> RetryLog String String (Assignment, RevDepMap)
forall a b. (a -> b) -> a -> b
$
        RetryLog String SolverFailure (Assignment, RevDepMap)
-> (SolverFailure
    -> RetryLog String String (Assignment, RevDepMap))
-> RetryLog String String (Assignment, RevDepMap)
forall step fail1 done fail2.
RetryLog step fail1 done
-> (fail1 -> RetryLog step fail2 done) -> RetryLog step fail2 done
retry (Bool
-> SolverConfig
-> RetryLog String SolverFailure (Assignment, RevDepMap)
runSolver Bool
printFullLog SolverConfig
sc { pruneAfterFirstSuccess :: PruneAfterFirstSuccess
pruneAfterFirstSuccess = Bool -> PruneAfterFirstSuccess
PruneAfterFirstSuccess Bool
True }) ((SolverFailure -> RetryLog String String (Assignment, RevDepMap))
 -> RetryLog String String (Assignment, RevDepMap))
-> (SolverFailure
    -> RetryLog String String (Assignment, RevDepMap))
-> RetryLog String String (Assignment, RevDepMap)
forall a b. (a -> b) -> a -> b
$
            \case
               ExhaustiveSearch ConflictSet
cs ConflictMap
_ ->
                   Progress String String (Assignment, RevDepMap)
-> RetryLog String String (Assignment, RevDepMap)
forall step fail done.
Progress step fail done -> RetryLog step fail done
fromProgress (Progress String String (Assignment, RevDepMap)
 -> RetryLog String String (Assignment, RevDepMap))
-> Progress String String (Assignment, RevDepMap)
-> RetryLog String String (Assignment, RevDepMap)
forall a b. (a -> b) -> a -> b
$ String -> Progress String String (Assignment, RevDepMap)
forall step fail done. fail -> Progress step fail done
Fail (String -> Progress String String (Assignment, RevDepMap))
-> String -> Progress String String (Assignment, RevDepMap)
forall a b. (a -> b) -> a -> b
$
                   ConflictSet -> String
rerunSolverForErrorMsg ConflictSet
cs String -> String -> String
forall a. [a] -> [a] -> [a]
++ SolverConfig -> SolverFailure -> String
finalErrorMsg SolverConfig
sc SolverFailure
failure
               SolverFailure
BackjumpLimitReached  ->
                   -- This case is possible when the number of goals involved in
                   -- conflicts is greater than the backjump limit.
                   Progress String String (Assignment, RevDepMap)
-> RetryLog String String (Assignment, RevDepMap)
forall step fail done.
Progress step fail done -> RetryLog step fail done
fromProgress (Progress String String (Assignment, RevDepMap)
 -> RetryLog String String (Assignment, RevDepMap))
-> Progress String String (Assignment, RevDepMap)
-> RetryLog String String (Assignment, RevDepMap)
forall a b. (a -> b) -> a -> b
$ String -> Progress String String (Assignment, RevDepMap)
forall step fail done. fail -> Progress step fail done
Fail (String -> Progress String String (Assignment, RevDepMap))
-> String -> Progress String String (Assignment, RevDepMap)
forall a b. (a -> b) -> a -> b
$ SolverConfig -> SolverFailure -> String
finalErrorMsg SolverConfig
sc SolverFailure
failure
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Failed to generate a summarized dependency solver "
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"log due to low backjump limit."

    rerunSolverForErrorMsg :: ConflictSet -> String
    rerunSolverForErrorMsg :: ConflictSet -> String
rerunSolverForErrorMsg ConflictSet
cs =
      let sc' :: SolverConfig
sc' = SolverConfig
sc {
                    goalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering)
goalOrder = (Variable QPN -> Variable QPN -> Ordering)
-> Maybe (Variable QPN -> Variable QPN -> Ordering)
forall a. a -> Maybe a
Just Variable QPN -> Variable QPN -> Ordering
goalOrder'
                  , maxBackjumps :: Maybe Int
maxBackjumps = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0
                  }

          -- Preferring goals from the conflict set takes precedence over the
          -- original goal order.
          goalOrder' :: Variable QPN -> Variable QPN -> Ordering
goalOrder' = ConflictSet -> Variable QPN -> Variable QPN -> Ordering
preferGoalsFromConflictSet ConflictSet
cs (Variable QPN -> Variable QPN -> Ordering)
-> (Variable QPN -> Variable QPN -> Ordering)
-> Variable QPN
-> Variable QPN
-> Ordering
forall a. Semigroup a => a -> a -> a
<> (Variable QPN -> Variable QPN -> Ordering)
-> Maybe (Variable QPN -> Variable QPN -> Ordering)
-> Variable QPN
-> Variable QPN
-> Ordering
forall a. a -> Maybe a -> a
fromMaybe Variable QPN -> Variable QPN -> Ordering
forall a. Monoid a => a
mempty (SolverConfig -> Maybe (Variable QPN -> Variable QPN -> Ordering)
goalOrder SolverConfig
sc)

      in [String] -> String
unlines (String
"Could not resolve dependencies:" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: Progress String SolverFailure (Assignment, RevDepMap) -> [String]
forall step fail done. Progress step fail done -> [step]
messages (RetryLog String SolverFailure (Assignment, RevDepMap)
-> Progress String SolverFailure (Assignment, RevDepMap)
forall step fail done.
RetryLog step fail done -> Progress step fail done
toProgress (Bool
-> SolverConfig
-> RetryLog String SolverFailure (Assignment, RevDepMap)
runSolver Bool
True SolverConfig
sc')))

    printFullLog :: Bool
printFullLog = SolverConfig -> Verbosity
solverVerbosity SolverConfig
sc Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>= Verbosity
verbose

    messages :: Progress step fail done -> [step]
    messages :: Progress step fail done -> [step]
messages = (step -> [step] -> [step])
-> (fail -> [step])
-> (done -> [step])
-> Progress step fail done
-> [step]
forall step a fail done.
(step -> a -> a)
-> (fail -> a) -> (done -> a) -> Progress step fail done -> a
foldProgress (:) ([step] -> fail -> [step]
forall a b. a -> b -> a
const []) ([step] -> done -> [step]
forall a b. a -> b -> a
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 :: (SolverConfig -> RetryLog String SolverFailure a)
-> SolverConfig
-> ConflictSet
-> ConflictMap
-> RetryLog String SolverFailure a
tryToMinimizeConflictSet SolverConfig -> RetryLog String SolverFailure a
runSolver SolverConfig
sc ConflictSet
cs ConflictMap
cm =
    (RetryLog String SolverFailure a
 -> Var QPN -> RetryLog String SolverFailure a)
-> RetryLog String SolverFailure a
-> [Var QPN]
-> RetryLog String SolverFailure a
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\RetryLog String SolverFailure a
r Var QPN
v -> RetryLog String SolverFailure a
-> (ConflictSet -> ConflictMap -> RetryLog String SolverFailure a)
-> RetryLog String SolverFailure a
forall step done.
RetryLog step SolverFailure done
-> (ConflictSet -> ConflictMap -> RetryLog step SolverFailure done)
-> RetryLog step SolverFailure done
retryNoSolution RetryLog String SolverFailure a
r ((ConflictSet -> ConflictMap -> RetryLog String SolverFailure a)
 -> RetryLog String SolverFailure a)
-> (ConflictSet -> ConflictMap -> RetryLog String SolverFailure a)
-> RetryLog String SolverFailure a
forall a b. (a -> b) -> a -> b
$ Var QPN
-> ConflictSet -> ConflictMap -> RetryLog String SolverFailure a
tryToRemoveOneVar Var QPN
v)
          (Progress String SolverFailure a -> RetryLog String SolverFailure a
forall step fail done.
Progress step fail done -> RetryLog step fail done
fromProgress (Progress String SolverFailure a
 -> RetryLog String SolverFailure a)
-> Progress String SolverFailure a
-> RetryLog String SolverFailure a
forall a b. (a -> b) -> a -> b
$ SolverFailure -> Progress String SolverFailure a
forall step fail done. fail -> Progress step fail done
Fail (SolverFailure -> Progress String SolverFailure a)
-> SolverFailure -> Progress String SolverFailure a
forall a b. (a -> b) -> a -> b
$ ConflictSet -> ConflictMap -> SolverFailure
ExhaustiveSearch ConflictSet
cs ConflictMap
cm)
          (ConflictSet -> [Var QPN]
CS.toList ConflictSet
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 :: Var QPN
-> ConflictSet -> ConflictMap -> RetryLog String SolverFailure a
tryToRemoveOneVar Var QPN
v ConflictSet
smallestKnownCS ConflictMap
smallestKnownCM
        -- Check whether v is still present, because it may have already been
        -- removed in a previous solver rerun.
      | Bool -> Bool
not (Var QPN
v Var QPN -> ConflictSet -> Bool
`CS.member` ConflictSet
smallestKnownCS) =
          Progress String SolverFailure a -> RetryLog String SolverFailure a
forall step fail done.
Progress step fail done -> RetryLog step fail done
fromProgress (Progress String SolverFailure a
 -> RetryLog String SolverFailure a)
-> Progress String SolverFailure a
-> RetryLog String SolverFailure a
forall a b. (a -> b) -> a -> b
$ SolverFailure -> Progress String SolverFailure a
forall step fail done. fail -> Progress step fail done
Fail (SolverFailure -> Progress String SolverFailure a)
-> SolverFailure -> Progress String SolverFailure a
forall a b. (a -> b) -> a -> b
$ ConflictSet -> ConflictMap -> SolverFailure
ExhaustiveSearch ConflictSet
smallestKnownCS ConflictMap
smallestKnownCM
      | Bool
otherwise =
        String
-> RetryLog String SolverFailure a
-> RetryLog String SolverFailure a
forall step fail done.
step -> RetryLog step fail done -> RetryLog step fail done
continueWith (String
"Trying to remove variable " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
varStr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" from the "
                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"conflict set.") (RetryLog String SolverFailure a
 -> RetryLog String SolverFailure a)
-> RetryLog String SolverFailure a
-> RetryLog String SolverFailure a
forall a b. (a -> b) -> a -> b
$
        RetryLog String SolverFailure a
-> (SolverFailure -> RetryLog String SolverFailure a)
-> RetryLog String SolverFailure a
forall step fail1 done fail2.
RetryLog step fail1 done
-> (fail1 -> RetryLog step fail2 done) -> RetryLog step fail2 done
retry (SolverConfig -> RetryLog String SolverFailure a
runSolver SolverConfig
sc') ((SolverFailure -> RetryLog String SolverFailure a)
 -> RetryLog String SolverFailure a)
-> (SolverFailure -> RetryLog String SolverFailure a)
-> RetryLog String SolverFailure a
forall a b. (a -> b) -> a -> b
$ \case
            err :: SolverFailure
err@(ExhaustiveSearch ConflictSet
cs' ConflictMap
_)
              | ConflictSet -> Set (Var QPN)
CS.toSet ConflictSet
cs' Set (Var QPN) -> Set (Var QPN) -> Bool
forall a. Ord a => Set a -> Set a -> Bool
`isSubsetOf` ConflictSet -> Set (Var QPN)
CS.toSet ConflictSet
smallestKnownCS ->
                  let msg :: String
msg = if Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Var QPN -> ConflictSet -> Bool
CS.member Var QPN
v ConflictSet
cs'
                            then String
"Successfully removed " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
varStr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" from "
                                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"the conflict set."
                            else String
"Failed to remove " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
varStr String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" from the "
                                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"conflict set."
                  in -- Use the new conflict set, even if v wasn't removed,
                     -- because other variables may have been removed.
                     String -> SolverFailure -> RetryLog String SolverFailure a
forall step fail done. step -> fail -> RetryLog step fail done
failWith (String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" Continuing with " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ConflictSet -> String
showCS ConflictSet
cs' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".") SolverFailure
err
              | Bool
otherwise ->
                  String -> SolverFailure -> RetryLog String SolverFailure a
forall step fail done. step -> fail -> RetryLog step fail done
failWith (String
"Failed to find a smaller conflict set. The new "
                             String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"conflict set is not a subset of the previous "
                             String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"conflict set: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ConflictSet -> String
showCS ConflictSet
cs') (SolverFailure -> RetryLog String SolverFailure a)
-> SolverFailure -> RetryLog String SolverFailure a
forall a b. (a -> b) -> a -> b
$
                  ConflictSet -> ConflictMap -> SolverFailure
ExhaustiveSearch ConflictSet
smallestKnownCS ConflictMap
smallestKnownCM
            SolverFailure
BackjumpLimitReached ->
                String -> SolverFailure -> RetryLog String SolverFailure a
forall step fail done. step -> fail -> RetryLog step fail done
failWith (String
"Reached backjump limit while minimizing conflict set.")
                         SolverFailure
BackjumpLimitReached
      where
        varStr :: String
varStr = String
"\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Var QPN -> String
showVar Var QPN
v String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\""
        showCS :: ConflictSet -> String
showCS ConflictSet
cs' = String
"{" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ConflictSet -> String
showConflictSet ConflictSet
cs' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"}"

        sc' :: SolverConfig
sc' = SolverConfig
sc { goalOrder :: Maybe (Variable QPN -> Variable QPN -> Ordering)
goalOrder = (Variable QPN -> Variable QPN -> Ordering)
-> Maybe (Variable QPN -> Variable QPN -> Ordering)
forall a. a -> Maybe a
Just Variable QPN -> Variable QPN -> Ordering
goalOrder' }

        goalOrder' :: Variable QPN -> Variable QPN -> Ordering
goalOrder' =
            ConflictSet -> Variable QPN -> Variable QPN -> Ordering
preferGoalsFromConflictSet (Var QPN
v Var QPN -> ConflictSet -> ConflictSet
`CS.delete` ConflictSet
smallestKnownCS)
         (Variable QPN -> Variable QPN -> Ordering)
-> (Variable QPN -> Variable QPN -> Ordering)
-> Variable QPN
-> Variable QPN
-> Ordering
forall a. Semigroup a => a -> a -> a
<> Var QPN -> Variable QPN -> Variable QPN -> Ordering
preferGoal Var QPN
v
         (Variable QPN -> Variable QPN -> Ordering)
-> (Variable QPN -> Variable QPN -> Ordering)
-> Variable QPN
-> Variable QPN
-> Ordering
forall a. Semigroup a => a -> a -> a
<> (Variable QPN -> Variable QPN -> Ordering)
-> Maybe (Variable QPN -> Variable QPN -> Ordering)
-> Variable QPN
-> Variable QPN
-> Ordering
forall a. a -> Maybe a -> a
fromMaybe Variable QPN -> Variable QPN -> Ordering
forall a. Monoid a => a
mempty (SolverConfig -> Maybe (Variable QPN -> Variable QPN -> Ordering)
goalOrder SolverConfig
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 :: RetryLog step SolverFailure done
-> (ConflictSet -> ConflictMap -> RetryLog step SolverFailure done)
-> RetryLog step SolverFailure done
retryNoSolution RetryLog step SolverFailure done
lg ConflictSet -> ConflictMap -> RetryLog step SolverFailure done
f = RetryLog step SolverFailure done
-> (SolverFailure -> RetryLog step SolverFailure done)
-> RetryLog step SolverFailure done
forall step fail1 done fail2.
RetryLog step fail1 done
-> (fail1 -> RetryLog step fail2 done) -> RetryLog step fail2 done
retry RetryLog step SolverFailure done
lg ((SolverFailure -> RetryLog step SolverFailure done)
 -> RetryLog step SolverFailure done)
-> (SolverFailure -> RetryLog step SolverFailure done)
-> RetryLog step SolverFailure done
forall a b. (a -> b) -> a -> b
$ \case
        ExhaustiveSearch ConflictSet
cs' ConflictMap
cm' -> ConflictSet -> ConflictMap -> RetryLog step SolverFailure done
f ConflictSet
cs' ConflictMap
cm'
        SolverFailure
BackjumpLimitReached     -> Progress step SolverFailure done
-> RetryLog step SolverFailure done
forall step fail done.
Progress step fail done -> RetryLog step fail done
fromProgress (SolverFailure -> Progress step SolverFailure done
forall step fail done. fail -> Progress step fail done
Fail SolverFailure
BackjumpLimitReached)

-- | Goal ordering that chooses goals contained in the conflict set before
-- other goals.
preferGoalsFromConflictSet :: ConflictSet
                           -> Variable QPN -> Variable QPN -> Ordering
preferGoalsFromConflictSet :: ConflictSet -> Variable QPN -> Variable QPN -> Ordering
preferGoalsFromConflictSet ConflictSet
cs = (Variable QPN -> Bool) -> Variable QPN -> Variable QPN -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing ((Variable QPN -> Bool)
 -> Variable QPN -> Variable QPN -> Ordering)
-> (Variable QPN -> Bool)
-> Variable QPN
-> Variable QPN
-> Ordering
forall a b. (a -> b) -> a -> b
$ \Variable QPN
v -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Var QPN -> ConflictSet -> Bool
CS.member (Variable QPN -> Var QPN
toVar Variable QPN
v) ConflictSet
cs

-- | Goal ordering that chooses the given goal first.
preferGoal :: Var QPN -> Variable QPN -> Variable QPN -> Ordering
preferGoal :: Var QPN -> Variable QPN -> Variable QPN -> Ordering
preferGoal Var QPN
preferred = (Variable QPN -> Bool) -> Variable QPN -> Variable QPN -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing ((Variable QPN -> Bool)
 -> Variable QPN -> Variable QPN -> Ordering)
-> (Variable QPN -> Bool)
-> Variable QPN
-> Variable QPN
-> Ordering
forall a b. (a -> b) -> a -> b
$ \Variable QPN
v -> Variable QPN -> Var QPN
toVar Variable QPN
v Var QPN -> Var QPN -> Bool
forall a. Eq a => a -> a -> Bool
/= Var QPN
preferred

toVar :: Variable QPN -> Var QPN
toVar :: Variable QPN -> Var QPN
toVar (PackageVar QPN
qpn)    = QPN -> Var QPN
forall qpn. qpn -> Var qpn
P QPN
qpn
toVar (FlagVar    QPN
qpn FlagName
fn) = FN QPN -> Var QPN
forall qpn. FN qpn -> Var qpn
F (QPN -> FlagName -> FN QPN
forall qpn. qpn -> FlagName -> FN qpn
FN QPN
qpn FlagName
fn)
toVar (StanzaVar  QPN
qpn OptionalStanza
sn) = SN QPN -> Var QPN
forall qpn. SN qpn -> Var qpn
S (QPN -> OptionalStanza -> SN QPN
forall qpn. qpn -> OptionalStanza -> SN qpn
SN QPN
qpn OptionalStanza
sn)

finalErrorMsg :: SolverConfig -> SolverFailure -> String
finalErrorMsg :: SolverConfig -> SolverFailure -> String
finalErrorMsg SolverConfig
sc SolverFailure
failure =
    case SolverFailure
failure of
      ExhaustiveSearch ConflictSet
cs ConflictMap
cm ->
          String
"After searching the rest of the dependency tree exhaustively, "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"these were the goals I've had most trouble fulfilling: "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ ConflictMap -> ConflictSet -> String
showCS ConflictMap
cm ConflictSet
cs
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
flagSuggestion
        where
          showCS :: ConflictMap -> ConflictSet -> String
showCS = if SolverConfig -> Verbosity
solverVerbosity SolverConfig
sc Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
> Verbosity
normal
                   then ConflictMap -> ConflictSet -> String
CS.showCSWithFrequency
                   else ConflictMap -> ConflictSet -> String
CS.showCSSortedByFrequency
          flagSuggestion :: String
flagSuggestion =
              -- Don't suggest --minimize-conflict-set if the conflict set is
              -- already small, because it is unlikely to be reduced further.
              if ConflictSet -> Int
CS.size ConflictSet
cs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
3 Bool -> Bool -> Bool
&& Bool -> Bool
not (MinimizeConflictSet -> Bool
forall a. BooleanFlag a => a -> Bool
asBool (SolverConfig -> MinimizeConflictSet
minimizeConflictSet SolverConfig
sc))
              then String
"\nTry running with --minimize-conflict-set to improve the "
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"error message."
              else String
""
      SolverFailure
BackjumpLimitReached ->
          String
"Backjump limit reached (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe Int -> String
forall a. Show a => Maybe a -> String
currlimit (SolverConfig -> Maybe Int
maxBackjumps SolverConfig
sc) String -> String -> String
forall a. [a] -> [a] -> [a]
++
          String
"change with --max-backjumps or try to run with --reorder-goals).\n"
        where currlimit :: Maybe a -> String
currlimit (Just a
n) = String
"currently " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", "
              currlimit Maybe a
Nothing  = String
""