Repository : ssh://darcs.haskell.org//srv/darcs/packages/Cabal On branch : master
http://hackage.haskell.org/trac/ghc/changeset/d5a29e14903d7327f7e0914da74facce47917ee5 >--------------------------------------------------------------- commit d5a29e14903d7327f7e0914da74facce47917ee5 Author: Andres Loeh <[email protected]> Date: Mon Jul 4 18:29:30 2011 +0000 Rewrite traversals using a new combinator. The hope is that sooner or later we can apply fusion. >--------------------------------------------------------------- .../Client/Dependency/Modular/Preference.hs | 18 +++++++++--------- .../Distribution/Client/Dependency/Modular/Tree.hs | 7 ++++--- 2 files changed, 13 insertions(+), 12 deletions(-) diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs b/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs index 9781684..fd85275 100644 --- a/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs +++ b/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs @@ -22,7 +22,7 @@ import Distribution.Client.Dependency.Modular.Version -- | Generic abstraction for strategies that just rearrange the package order. -- Only packages that match the given predicate are reordered. packageOrderFor :: (PN -> Bool) -> (PN -> I -> I -> Ordering) -> Tree a -> Tree a -packageOrderFor p cmp = cata (inn . go) +packageOrderFor p cmp = trav go where go (PChoiceF v@(Q _ pn) r cs) | p pn = PChoiceF v r (P.sortByKeys (flip (cmp pn)) cs) @@ -76,7 +76,7 @@ preferLatestOrdering (I v1 _) (I v2 _) = compare v1 v2 -- by selectively disabling choices that have been rules out by global user -- constraints. enforcePackageConstraints :: M.Map PN PackageConstraint -> Tree QGoalReasons -> Tree QGoalReasons -enforcePackageConstraints pcs = cata (inn . go) +enforcePackageConstraints pcs = trav go where go x@(PChoiceF qpn@(Q _ pn) gr ts) = let c = toConflictSet (Goal (P qpn) gr) in @@ -133,7 +133,7 @@ preferLatest = preferLatestFor (const True) -- | Require installed packages. requireInstalled :: (PN -> Bool) -> Tree (QGoalReasons, a) -> Tree (QGoalReasons, a) -requireInstalled p = cata (inn . go) +requireInstalled p = trav go where go (PChoiceF v@(Q _ pn) i@(gr, _) cs) | p pn = PChoiceF v i (P.mapWithKey installed cs) @@ -157,7 +157,7 @@ requireInstalled p = cata (inn . go) -- 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 (QGoalReasons, a) -> Tree (QGoalReasons, a) -avoidReinstalls p = cata (inn . go) +avoidReinstalls p = trav go where go (PChoiceF qpn@(Q _ pn) i@(gr, _) cs) | p pn = PChoiceF qpn i disableReinstalls @@ -180,7 +180,7 @@ type LocalFlags = M.Map (FN PN) Bool -- flexibility we allow both global and local choices, where local -- choices override the global ones. enforceFlagChoices :: GlobalFlags -> LocalFlags -> Tree a -> Tree a -enforceFlagChoices gfs lfs = cata (inn . go) +enforceFlagChoices gfs lfs = trav go where go (FChoiceF qfn@(FN _ f) r tr cs) = case M.lookup (fmap unQualify qfn) lfs <|> M.lookup f gfs of -- find flag in either map @@ -198,7 +198,7 @@ enforceFlagChoices gfs lfs = cata (inn . go) -- it descends only into the first goal choice anyway, -- but may still make sense to just reduce the tree size a bit. firstGoal :: Tree a -> Tree a -firstGoal = cata (inn . go) +firstGoal = trav go where go (GoalChoiceF xs) = casePSQ xs (GoalChoiceF xs) (\ _ t _ -> out t) go x = x @@ -210,7 +210,7 @@ firstGoal = cata (inn . go) -- are immediately considered inconsistent), and choices with 1 -- branch will also be preferred (as they don't involve choice). preferEasyGoalChoices :: Tree a -> Tree a -preferEasyGoalChoices = cata (inn . go) +preferEasyGoalChoices = trav go where go (GoalChoiceF xs) = GoalChoiceF (P.sortBy (comparing choices) xs) go x = x @@ -218,7 +218,7 @@ preferEasyGoalChoices = cata (inn . go) -- | Transformation that tries to avoid making inconsequential -- flag choices early. deferDefaultFlagChoices :: Tree a -> Tree a -deferDefaultFlagChoices = cata (inn . go) +deferDefaultFlagChoices = trav go where go (GoalChoiceF xs) = GoalChoiceF (P.sortBy defer xs) go x = x @@ -233,7 +233,7 @@ deferDefaultFlagChoices = cata (inn . go) -- Only approximates the number of choices in the branches. Less accurate, -- more efficient. lpreferEasyGoalChoices :: Tree a -> Tree a -lpreferEasyGoalChoices = cata (inn . go) +lpreferEasyGoalChoices = trav go where go (GoalChoiceF xs) = GoalChoiceF (P.sortBy (comparing lchoices) xs) go x = x diff --git a/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs b/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs index a94b91d..954bef4 100644 --- a/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs +++ b/cabal-install/Distribution/Client/Dependency/Modular/Tree.hs @@ -3,8 +3,6 @@ module Distribution.Client.Dependency.Modular.Tree where import Control.Applicative import Control.Monad hiding (mapM) import Data.Foldable -import qualified Data.List as L -import qualified Data.Set as S import Data.Traversable import Prelude hiding (foldr, mapM) @@ -105,7 +103,10 @@ lchoices (Fail _ _ ) = 0 -- | Catamorphism on trees. cata :: (TreeF a b -> b) -> Tree a -> b -cata phi = phi . fmap (cata phi) . out +cata phi x = (phi . fmap (cata phi) . out) x + +trav :: (TreeF a (Tree a) -> TreeF a (Tree a)) -> Tree a -> Tree a +trav psi x = cata (inn . psi) x -- | Paramorphism on trees. para :: (TreeF a (b, Tree a) -> b) -> Tree a -> b _______________________________________________ Cvs-libraries mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-libraries
