Repository : ssh://darcs.haskell.org//srv/darcs/packages/Cabal On branch : master
http://hackage.haskell.org/trac/ghc/changeset/7c4ae3ea2f5bce410f8c71669b5e6d818d63ded6 >--------------------------------------------------------------- commit 7c4ae3ea2f5bce410f8c71669b5e6d818d63ded6 Author: Andres Loeh <[email protected]> Date: Fri Oct 21 12:08:31 2011 +0000 Added a check for destructive reinstalls. Some refactoring in Distribution.Client.Install: * the linear representation of an install plan is now typed * it can be checked for the presence of destructive reinstalls Currently, Cabal will stop if destructive reinstalls are encountered. While this should become default behaviour, there has to be a flag that overrides it. >--------------------------------------------------------------- cabal-install/Distribution/Client/Install.hs | 101 ++++++++++++++++++-------- 1 files changed, 70 insertions(+), 31 deletions(-) diff --git a/cabal-install/Distribution/Client/Install.hs b/cabal-install/Distribution/Client/Install.hs index 77f8321..b355ad1 100644 --- a/cabal-install/Distribution/Client/Install.hs +++ b/cabal-install/Distribution/Client/Install.hs @@ -345,46 +345,62 @@ printPlanMessages verbosity installed installPlan dryRun = do ++ "already installed.\n If you want to reinstall anyway then use " ++ "the --reinstall flag." - when (dryRun || verbosity >= verbose) $ - printDryRun verbosity installed installPlan + let lPlan = linearizeInstallPlan installed installPlan + let containsReinstalls = any (isReinstall . snd) lPlan + let adaptedVerbosity | containsReinstalls = verbose `max` verbosity + | otherwise = verbosity + + when (dryRun || adaptedVerbosity >= verbose) $ + printDryRun adaptedVerbosity lPlan + + when containsReinstalls $ + (if dryRun then notice adaptedVerbosity else die) $ + "The install plan contains reinstalls which can break your " + ++ "GHC installation." + -- TODO: Add pointers to flags once implemented. where nothingToInstall = null (InstallPlan.ready installPlan) - -printDryRun :: Verbosity - -> PackageIndex - -> InstallPlan - -> IO () -printDryRun verbosity installedPkgIndex plan = case unfoldr next plan of - [] -> return () - pkgs - | verbosity >= Verbosity.verbose -> notice verbosity $ unlines $ - "In order, the following would be installed:" - : map showPkgAndReason pkgs - | otherwise -> notice verbosity $ unlines $ - "In order, the following would be installed (use -v for more details):" - : map (display . packageId) pkgs +linearizeInstallPlan :: PackageIndex + -> InstallPlan + -> [(ConfiguredPackage, PackageStatus)] +linearizeInstallPlan installedPkgIndex plan = unfoldr next plan where next plan' = case InstallPlan.ready plan' of [] -> Nothing - (pkg:_) -> Just (pkg, InstallPlan.completed pkgid result plan') - where pkgid = packageId pkg + (pkg:_) -> Just ((pkg, status), InstallPlan.completed pkgid result plan') + where pkgid = packageId pkg + status = packageStatus installedPkgIndex pkg result = BuildOk DocsNotTried TestsNotTried --FIXME: This is a bit of a hack, -- pretending that each package is installed - showPkgAndReason pkg' = display (packageId pkg') ++ " " ++ - case PackageIndex.lookupPackageName installedPkgIndex - (packageName pkg') of - [] -> "(new package)" - ps -> case find ((==packageId pkg') . Installed.sourcePackageId) (concatMap snd ps) of - Nothing -> "(new version)" - Just pkg -> "(reinstall)" ++ case changes pkg pkg' of - [] -> "" - diff -> " changes: " ++ intercalate ", " diff - changes :: Installed.InstalledPackageInfo -> ConfiguredPackage -> [String] - changes pkg pkg' = map change . filter changed +data PackageStatus = NewPackage + | NewVersion [Version] + | Reinstall [PackageChange] + +type PackageChange = MergeResult PackageIdentifier PackageIdentifier + +isReinstall :: PackageStatus -> Bool +isReinstall (Reinstall _) = True +isReinstall _ = False + +packageStatus :: PackageIndex -> ConfiguredPackage -> PackageStatus +packageStatus installedPkgIndex cpkg = + case PackageIndex.lookupPackageName installedPkgIndex + (packageName cpkg) of + [] -> NewPackage + ps -> case find ((==packageId cpkg) . Installed.sourcePackageId) (concatMap snd ps) of + Nothing -> NewVersion (map fst ps) + Just pkg -> Reinstall (changes pkg cpkg) + + where + + changes :: Installed.InstalledPackageInfo + -> ConfiguredPackage + -> [MergeResult PackageIdentifier PackageIdentifier] + changes pkg pkg' = filter changed $ mergeBy (comparing packageName) -- get dependencies of installed package (convert to source pkg ids via index) (nub . sort . concatMap (maybeToList . @@ -393,12 +409,35 @@ printDryRun verbosity installedPkgIndex plan = case unfoldr next plan of Installed.depends $ pkg) -- get dependencies of configured package (nub . sort . depends $ pkg') + + changed (InBoth pkgid pkgid') = pkgid /= pkgid' + changed _ = True + +printDryRun :: Verbosity + -> [(ConfiguredPackage, PackageStatus)] + -> IO () +printDryRun verbosity plan = case plan of + [] -> return () + pkgs + | verbosity >= Verbosity.verbose -> notice verbosity $ unlines $ + "In order, the following would be installed:" + : map showPkgAndReason pkgs + | otherwise -> notice verbosity $ unlines $ + "In order, the following would be installed (use -v for more details):" + : map (display . packageId) (map fst pkgs) + where + showPkgAndReason (pkg', pr) = display (packageId pkg') ++ " " ++ + case pr of + NewPackage -> "(new package)" + NewVersion _ -> "(new version)" + Reinstall cs -> "(reinstall)" ++ case cs of + [] -> "" + diff -> " changes: " ++ intercalate ", " (map change diff) + change (OnlyInLeft pkgid) = display pkgid ++ " removed" change (InBoth pkgid pkgid') = display pkgid ++ " -> " ++ display (packageVersion pkgid') change (OnlyInRight pkgid') = display pkgid' ++ " added" - changed (InBoth pkgid pkgid') = pkgid /= pkgid' - changed _ = True -- ------------------------------------------------------------ -- * Post installation stuff _______________________________________________ Cvs-libraries mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-libraries
