Repository : ssh://darcs.haskell.org//srv/darcs/packages/Cabal On branch :
http://hackage.haskell.org/trac/ghc/changeset/d091f116dfa0770a285e2a75696be69b540f8552 >--------------------------------------------------------------- commit d091f116dfa0770a285e2a75696be69b540f8552 Author: Duncan Coutts <[email protected]> Date: Sun Oct 5 00:14:00 2008 +0000 Add the glue code to actully report excluded packages Now displayed in the output of install --dry-run -v >--------------------------------------------------------------- .../Distribution/Client/Dependency/TopDown.hs | 75 +++++++++++-------- 1 files changed, 43 insertions(+), 32 deletions(-) diff --git a/cabal-install/Distribution/Client/Dependency/TopDown.hs b/cabal-install/Distribution/Client/Dependency/TopDown.hs index bab47e3..31b4291 100644 --- a/cabal-install/Distribution/Client/Dependency/TopDown.hs +++ b/cabal-install/Distribution/Client/Dependency/TopDown.hs @@ -50,7 +50,7 @@ import Distribution.Text ( display ) import Data.List - ( foldl', maximumBy, minimumBy, delete, nub, sort, groupBy ) + ( foldl', maximumBy, minimumBy, nub, sort, groupBy ) import Data.Maybe ( fromJust, fromMaybe ) import Data.Monoid @@ -84,22 +84,20 @@ data SearchSpace inherited pkg -- ------------------------------------------------------------ explore :: (PackageName -> PackageVersionPreference) - -> SearchSpace a SelectablePackage - -> Progress Log Failure a + -> SearchSpace (SelectedPackages, Constraints, SelectionChanges) + SelectablePackage + -> Progress Log Failure (SelectedPackages, Constraints) -explore _ (Failure failure) = Fail failure -explore _explore (ChoiceNode result []) = Done result -explore pref (ChoiceNode _ choices) = +explore _ (Failure failure) = Fail failure +explore _ (ChoiceNode (s,c,_) []) = Done (s,c) +explore pref (ChoiceNode _ choices) = case [ choice | [choice] <- choices ] of - ((pkg, node'):_) -> Step (Select [pkg] []) (explore pref node') - [] -> seq pkgs' -- avoid retaining defaultChoice - $ Step (Select [pkg] pkgs') (explore pref node') + ((_, node'):_) -> Step (logInfo node') (explore pref node') + [] -> Step (logInfo node') (explore pref node') where - choice = minimumBy (comparing topSortNumber) choices - pkgname = packageName . fst . head $ choice - (pkg, node') = maximumBy (bestByPref pkgname) choice - pkgs' = delete (packageId pkg) (map (packageId.fst) choice) - + choice = minimumBy (comparing topSortNumber) choices + pkgname = packageName . fst . head $ choice + (_, node') = maximumBy (bestByPref pkgname) choice where topSortNumber choice = case fst (head choice) of InstalledOnly (InstalledPackage _ i _) -> i @@ -112,6 +110,11 @@ explore pref (ChoiceNode _ choices) = where isInstalled (AvailableOnly _) = False isInstalled _ = True + logInfo node = Select selected discarded + where (selected, discarded) = case node of + Failure _ -> ([], []) + ChoiceNode (_,_,changes) _ -> changes + -- ------------------------------------------------------------ -- * Generate a search tree -- ------------------------------------------------------------ @@ -120,13 +123,18 @@ type ConfigurePackage = PackageIndex SelectablePackage -> SelectablePackage -> Either [Dependency] SelectedPackage +-- | (packages selected, packages discarded) +type SelectionChanges = ([SelectedPackage], [PackageIdentifier]) + searchSpace :: ConfigurePackage -> Constraints -> SelectedPackages + -> SelectionChanges -> Set PackageName - -> SearchSpace (SelectedPackages, Constraints) SelectablePackage -searchSpace configure constraints selected next = - ChoiceNode (selected, constraints) + -> SearchSpace (SelectedPackages, Constraints, SelectionChanges) + SelectablePackage +searchSpace configure constraints selected changes next = + ChoiceNode (selected, constraints, changes) [ [ (pkg, select name pkg) | pkg <- PackageIndex.lookupPackageName available name ] | name <- Set.elems next ] @@ -137,19 +145,22 @@ searchSpace configure constraints selected next = Left missing -> Failure $ ConfigureFailed pkg [ (dep, Constraints.conflicting constraints dep) | dep <- missing ] - Right pkg' -> - let selected' = PackageIndex.insert pkg' selected - newPkgs = [ name' - | dep <- packageConstraints pkg' - , let (Dependency name' _) = untagDependency dep - , null (PackageIndex.lookupPackageName selected' name') ] - newDeps = packageConstraints pkg' - next' = Set.delete name - $ foldl' (flip Set.insert) next newPkgs - in case constrainDeps pkg' newDeps constraints [] of - Left failure -> Failure failure - Right (constraints', _) -> searchSpace configure - constraints' selected' next' + Right pkg' -> case constrainDeps pkg' newDeps constraints [] of + Left failure -> Failure failure + Right (constraints', newDiscarded) -> + searchSpace configure + constraints' selected' (newSelected, newDiscarded) next' + where + selected' = foldl' (flip PackageIndex.insert) selected newSelected + newSelected = [pkg'] + + newPkgs = [ name' + | dep <- packageConstraints pkg' + , let (Dependency name' _) = untagDependency dep + , null (PackageIndex.lookupPackageName selected' name') ] + newDeps = packageConstraints pkg' + next' = Set.delete name + $ foldl' (flip Set.insert) next newPkgs packageConstraints :: SelectedPackage -> [TaggedDependency] packageConstraints = either installedConstraints availableConstraints @@ -188,7 +199,7 @@ search :: ConfigurePackage -> Set PackageName -> Progress Log Failure (SelectedPackages, Constraints) search configure pref constraints = - explore pref . searchSpace configure constraints mempty + explore pref . searchSpace configure constraints mempty ([], []) -- ------------------------------------------------------------ -- * The top level resolver @@ -524,7 +535,7 @@ showExclusionReason pkgid (ExcludedByTopLevelDependency dep) = -- * Logging progress and failures -- ------------------------------------------------------------ -data Log = Select [SelectablePackage] [PackageIdentifier] +data Log = Select [SelectedPackage] [PackageIdentifier] data Failure = ConfigureFailed SelectablePackage _______________________________________________ Cvs-libraries mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-libraries
