From afeb48f16fcc67538f13060eff19c39e03a03381 Mon Sep 17 00:00:00 2001
From: Edsko de Vries <edsko@well-typed.com>
Date: Thu, 19 Feb 2015 11:57:50 +0100
Subject: [PATCH] Add "defer setup choices" heuristic.
By chosing setup dependencies after regular dependencies we get more
opportunities for linking setup dependencies against regular dependencies.
---
.../Client/Dependency/Modular/Preference.hs | 13 +++++++++++++
.../Client/Dependency/Modular/Solver.hs | 1 +
2 files changed, 14 insertions(+)
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs b/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
index eb45b1b043..0834f0a5a0 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs
@@ -259,6 +259,19 @@ preferBaseGoalChoice = trav go
preferBase _ (OpenGoal (Simple (Dep (Q _pp pn) _) _) _) | unPN pn == "base" = GT
preferBase _ _ = EQ
+-- | Deal with setup dependencies after regular dependencies, so that we can
+-- will link setup depencencies against package dependencies when possible
+deferSetupChoices :: Tree a -> Tree a
+deferSetupChoices = trav go
+ where
+ go (GoalChoiceF xs) = GoalChoiceF (P.sortByKeys deferSetup xs)
+ go x = x
+
+ deferSetup :: OpenGoal comp -> OpenGoal comp -> Ordering
+ deferSetup (OpenGoal (Simple (Dep (Q (Setup _ _) _) _) _) _) _ = GT
+ deferSetup _ (OpenGoal (Simple (Dep (Q (Setup _ _) _) _) _) _) = LT
+ deferSetup _ _ = EQ
+
-- | Transformation that sorts choice nodes so that
-- child nodes with a small branching degree are preferred. As a
-- special case, choices with 0 branches will be preferred (as they
diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs b/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs
index dd93f28944..7484fd0c5e 100644
--- a/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs
+++ b/cabal-install/Distribution/Client/Dependency/Modular/Solver.hs
@@ -42,6 +42,7 @@ solve sc idx userPrefs userConstraints userGoals =
where
explorePhase = exploreTreeLog . backjump
heuristicsPhase = P.firstGoal . -- after doing goal-choice heuristics, commit to the first choice (saves space)
+ P.deferSetupChoices .
P.deferWeakFlagChoices .
P.preferBaseGoalChoice .
P.preferLinked .
--
GitLab