solver: swap catas with recursion, fuse travs (#7519)

* solver: swap catas with recursion, fuse travs

* whoops

* add traverseWithKey to cabal-install-solver (#7533)

Co-authored-by: mergify[bot] <37929162+mergify[bot]@users.noreply.github.com>

* replace sequence . mapWithKey with traverseWithKey

* more sequence -> traverse

* Update Preference.hs

fix bad merge

* Update Solver.hs

Co-authored-by: Gershom Bazerman <[email protected]>
Co-authored-by: Emily Pillmore <[email protected]>
Co-authored-by: mergify[bot] <37929162+mergify[bot]@users.noreply.github.com>
(cherry picked from commit 67c440a)

# Conflicts:
#	cabal-install/cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs
#	cabal-install/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs

Author: gbaz

cabal-install/cabal-install-solver/src/Distribution/Solver/Modular/Cycles.hs

@@ -18,17 +18,19 @@ import Distribution.Solver.Types.PackagePath
 
 -- | Find and reject any nodes with cyclic dependencies
 detectCyclesPhase :: Tree d c -> Tree d c
-detectCyclesPhase = cata go
+detectCyclesPhase = go
   where
     -- Only check children of choice nodes.
-    go :: TreeF d c (Tree d c) -> Tree d c
-    go (PChoiceF qpn rdm gr                         cs) =
-        PChoice qpn rdm gr     $ fmap (checkChild qpn)   cs
-    go (FChoiceF qfn@(FN qpn _) rdm gr w m d cs) =
-        FChoice qfn rdm gr w m d $ fmap (checkChild qpn) cs
-    go (SChoiceF qsn@(SN qpn _) rdm gr w     cs) =
-        SChoice qsn rdm gr w   $ fmap (checkChild qpn)   cs
-    go x                                                = inn x
+    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

cabal-install/cabal-install-solver/src/Distribution/Solver/Modular/Explore.hs

@@ -183,19 +183,18 @@ updateCM cs cm =
 
 -- | Record complete assignments on 'Done' nodes.
 assign :: Tree d c -> Tree Assignment c
-assign tree = cata go tree $ A M.empty M.empty M.empty
+assign tree = go tree (A M.empty M.empty M.empty)
   where
-    go :: TreeF d c (Assignment -> Tree Assignment c)
-                 -> (Assignment -> Tree Assignment c)
-    go (FailF c fr)            _                  = Fail c fr
-    go (DoneF rdm _)           a                  = Done rdm a
-    go (PChoiceF qpn rdm y       ts) (A pa fa sa) = PChoice qpn rdm y       $ W.mapWithKey f ts
+    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 (FChoiceF qfn rdm y t m d ts) (A pa fa sa) = FChoice qfn rdm y t m d $ W.mapWithKey f ts
+    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 (SChoiceF qsn rdm y t     ts) (A pa fa sa) = SChoice qsn rdm y t     $ W.mapWithKey f ts
+    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 (GoalChoiceF  rdm         ts) a            = GoalChoice  rdm         $ fmap ($ a) ts
+    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.

cabal-install/cabal-install-solver/src/Distribution/Solver/Modular/Linking.hs

@@ -78,21 +78,21 @@ type Validate = Reader ValidateState
 -- * Equal flag assignments
 -- * Equal stanza assignments
 validateLinking :: Index -> Tree d c -> Tree d c
-validateLinking index = (`runReader` initVS) . cata go
+validateLinking index = (`runReader` initVS) . go
   where
-    go :: TreeF d c (Validate (Tree d c)) -> Validate (Tree d c)
+    go :: Tree d c -> Validate (Tree d c)
 
-    go (PChoiceF qpn rdm gr       cs) =
-      PChoice qpn rdm gr       <$> T.sequence (W.mapWithKey (goP qpn) cs)
-    go (FChoiceF qfn rdm gr t m d cs) =
-      FChoice qfn rdm gr t m d <$> T.sequence (W.mapWithKey (goF qfn) cs)
-    go (SChoiceF qsn rdm gr t     cs) =
-      SChoice qsn rdm gr t     <$> T.sequence (W.mapWithKey (goS qsn) cs)
+    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 (GoalChoiceF rdm           cs) = GoalChoice rdm <$> T.sequence cs
-    go (DoneF revDepMap s)            = return $ Done revDepMap s
-    go (FailF conflictSet failReason) = return $ Fail conflictSet failReason
+    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)

cabal-install/cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs

@@ -51,8 +51,8 @@ import qualified Distribution.Solver.Modular.WeightedPSQ as W
 -- 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] -> Tree d c -> Tree d c
-addWeights fs = trav go
+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) =
@@ -69,21 +69,21 @@ addWeights fs = trav go
              W.mapWeightsWithKey (\k w -> weights k ++ w) cs)
     go x                            = x
 
-addWeight :: (PN -> [Ver] -> POption -> Weight) -> Tree d c -> Tree d c
+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 :: Tree d c -> Tree d c
+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) -> Tree d c -> Tree d c
+preferPackagePreferences :: (PN -> PackagePreferences) -> EndoTreeTrav d c
 preferPackagePreferences pcs =
     preferPackageStanzaPreferences pcs .
     addWeights [
@@ -127,8 +127,20 @@ preferPackagePreferences pcs =
 
 -- | Traversal that tries to establish package stanza enable\/disable
 -- preferences. Works by reordering the branches of stanza choices.
+<<<<<<< HEAD:cabal-install/cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs
 preferPackageStanzaPreferences :: (PN -> PackagePreferences) -> Tree d c -> Tree d c
 preferPackageStanzaPreferences pcs = trav go
+=======
+-- 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
+>>>>>>> 67c440a40 (solver: swap catas with recursion, fuse travs (#7519)):cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs
   where
     go (SChoiceF qsn@(SN (Q pp pn) s) rdm gr _tr ts)
       | primaryPP pp && enableStanzaPref pn s =
@@ -221,9 +233,8 @@ processPackageConstraintS qpn s c b' (LabeledPackageConstraint (PackageConstrain
 -- by selectively disabling choices that have been ruled out by global user
 -- constraints.
 enforcePackageConstraints :: M.Map PN [LabeledPackageConstraint]
-                          -> Tree d c
-                          -> Tree d c
-enforcePackageConstraints pcs = trav go
+                          -> EndoTreeTrav d c
+enforcePackageConstraints pcs = go
   where
     go (PChoiceF qpn@(Q _ pn) rdm gr                    ts) =
       let c = varToConflictSet (P qpn)
@@ -268,8 +279,8 @@ enforcePackageConstraints pcs = trav go
 --
 -- This function does not enforce any of the constraints, since that is done by
 -- 'enforcePackageConstraints'.
-enforceManualFlags :: M.Map PN [LabeledPackageConstraint] -> Tree d c -> Tree d c
-enforceManualFlags pcs = trav go
+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 $
@@ -295,8 +306,8 @@ enforceManualFlags pcs = trav go
     go x                                                            = x
 
 -- | Require installed packages.
-requireInstalled :: (PN -> Bool) -> Tree d c -> Tree d c
-requireInstalled p = trav go
+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)
@@ -319,8 +330,8 @@ requireInstalled p = trav go
 -- 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) -> Tree d c -> Tree d c
-avoidReinstalls p = trav go
+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
@@ -337,8 +348,8 @@ avoidReinstalls p = trav go
     go x          = x
 
 -- | Require all packages to be mentioned in a constraint or as a goal.
-onlyConstrained :: (PN -> Bool) -> Tree d QGoalReason -> Tree d QGoalReason
-onlyConstrained p = trav go
+onlyConstrained :: (PN -> Bool) -> EndoTreeTrav d QGoalReason
+onlyConstrained p = go
   where
     go (PChoiceF v@(Q _ pn) _ gr _) | not (p pn)
       = FailF
@@ -348,8 +359,8 @@ onlyConstrained p = trav go
       = x
 
 -- | Sort all goals using the provided function.
-sortGoals :: (Variable QPN -> Variable QPN -> Ordering) -> Tree d c -> Tree d c
-sortGoals variableOrder = trav go
+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
@@ -365,8 +376,8 @@ sortGoals variableOrder = trav go
 -- | 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 :: Tree d c -> Tree d c
-pruneAfterFirstSuccess = trav go
+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)
@@ -379,8 +390,8 @@ pruneAfterFirstSuccess = trav go
 -- 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 :: Tree d c -> Tree d c
-firstGoal = trav go
+firstGoal :: EndoTreeTrav d c
+firstGoal = go
   where
     go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.firstOnly xs)
     go x                    = x
@@ -390,8 +401,8 @@ firstGoal = trav go
 -- 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 :: Tree d c -> Tree d c
-preferBaseGoalChoice = trav go
+preferBaseGoalChoice :: EndoTreeTrav d c
+preferBaseGoalChoice = go
   where
     go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.filterIfAnyByKeys isBase xs)
     go x                    = x
@@ -400,10 +411,17 @@ preferBaseGoalChoice = trav go
     isBase (Goal (P (Q _pp pn)) _) = unPN pn == "base"
     isBase _                       = False
 
+<<<<<<< HEAD:cabal-install/cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs
 -- | Deal with setup dependencies after regular dependencies, so that we can
 -- will link setup dependencies against package dependencies when possible
 deferSetupChoices :: Tree d c -> Tree d c
 deferSetupChoices = trav go
+=======
+-- | 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
+>>>>>>> 67c440a40 (solver: swap catas with recursion, fuse travs (#7519)):cabal-install-solver/src/Distribution/Solver/Modular/Preference.hs
   where
     go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.preferByKeys noSetup xs)
     go x                    = x
@@ -415,8 +433,8 @@ deferSetupChoices = trav go
 -- | 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 :: Tree d c -> Tree d c
-deferWeakFlagChoices = trav go
+deferWeakFlagChoices :: EndoTreeTrav d c
+deferWeakFlagChoices = go
   where
     go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.prefer noWeakFlag (P.prefer noWeakStanza xs))
     go x                    = x
@@ -435,8 +453,8 @@ deferWeakFlagChoices = trav go
 -- 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 :: Tree d c -> Tree d c
-preferReallyEasyGoalChoices = trav go
+preferReallyEasyGoalChoices :: EndoTreeTrav d c
+preferReallyEasyGoalChoices = go
   where
     go (GoalChoiceF rdm xs) = GoalChoiceF rdm (P.filterIfAny zeroOrOneChoices xs)
     go x                    = x
@@ -454,15 +472,21 @@ type EnforceSIR = Reader (Map (PI PN) QPN)
 -- 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) . cata go
+enforceSingleInstanceRestriction = (`runReader` M.empty) . go
   where
-    go :: TreeF d c (EnforceSIR (Tree d c)) -> EnforceSIR (Tree d c)
+    go :: Tree d c -> EnforceSIR (Tree d c)
 
     -- We just verify package choices.
-    go (PChoiceF qpn rdm gr cs) =
-      PChoice qpn rdm gr <$> sequenceA (W.mapWithKey (goP qpn) cs)
-    go _otherwise =
-      innM _otherwise
+    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)

cabal-install/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs

@@ -98,40 +98,50 @@ solve :: SolverConfig                         -- ^ solver parameters
       -> S.Set PN                             -- ^ global goals
       -> RetryLog Message SolverFailure (Assignment, RevDepMap)
 solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals =
-  explorePhase     $
-  detectCycles     $
-  heuristicsPhase  $
-  preferencesPhase $
-  validationPhase  $
-  prunePhase       $
+  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     = traceTree "cycles.json" id . detectCyclesPhase
+    detectCycles     = detectCyclesPhase
     heuristicsPhase  =
-      let heuristicsTree = traceTree "heuristics.json" id
+      let
           sortGoals = case goalOrder sc of
                         Nothing -> goalChoiceHeuristics .
+<<<<<<< HEAD:cabal-install/cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs
                                    heuristicsTree .
                                    P.deferSetupChoices .
+=======
+                                   P.deferSetupExeChoices .
+>>>>>>> 67c440a40 (solver: swap catas with recursion, fuse travs (#7519)):cabal-install-solver/src/Distribution/Solver/Modular/Solver.hs
                                    P.deferWeakFlagChoices .
                                    P.preferBaseGoalChoice
                         Just order -> P.firstGoal .
-                                   heuristicsTree .
-                                   P.sortGoals order
+                                      P.sortGoals order
           PruneAfterFirstSuccess prune = pruneAfterFirstSuccess sc
       in sortGoals .
          (if prune then P.pruneAfterFirstSuccess else id)
     preferencesPhase = P.preferLinked .
                        P.preferPackagePreferences userPrefs
-    validationPhase  = traceTree "validated.json" id .
-                       P.enforcePackageConstraints userConstraints .
-                       P.enforceManualFlags userConstraints .
-                       P.enforceSingleInstanceRestriction .
+    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) .
@@ -143,8 +153,7 @@ solve sc cinfo idx pkgConfigDB userPrefs userConstraints userGoals =
                             P.onlyConstrained pkgIsExplicit
                           OnlyConstrainedNone ->
                             id)
-    buildPhase       = traceTree "build.json" id
-                     $ buildTree idx (independentGoals sc) (S.toList userGoals)
+    buildPhase       = buildTree idx (independentGoals sc) (S.toList userGoals)
 
     allExplicit = M.keysSet userConstraints `S.union` userGoals