{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Distribution.Solver.Modular
( modularResolver, SolverConfig(..), PruneAfterFirstSuccess(..) ) where
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
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
$
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
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
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])
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)
pcName :: PackageConstraint -> PN
pcName :: PackageConstraint -> PackageName
pcName (PackageConstraint ConstraintScope
scope PackageProperty
_) = ConstraintScope -> PackageName
scopeToPackageName ConstraintScope
scope
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 ->
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
}
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 [])
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
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
| 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
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)
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)
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
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 =
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
""