From a609f1fc0cc7b312ec746ffa47a6ad6c1504f488 Mon Sep 17 00:00:00 2001 From: Michael Snoyman Date: Sun, 9 Dec 2012 18:58:05 +0200 Subject: [PATCH] Check for version conflicts ourselves. This was done by cabal-install previously. But doing it ourselves, we gain a few things: * Found out about problems faster. * Get a complete list of problems, including tests. * Much more user-friendly output. --- Stackage/InstallInfo.hs | 45 ++++++++++++++++++++++++++++++++++---- Stackage/LoadDatabase.hs | 6 ++--- Stackage/NarrowDatabase.hs | 11 +++++++--- Stackage/Types.hs | 14 +++++++++--- 4 files changed, 63 insertions(+), 13 deletions(-) diff --git a/Stackage/InstallInfo.hs b/Stackage/InstallInfo.hs index 3fc49b53..c8a518f1 100644 --- a/Stackage/InstallInfo.hs +++ b/Stackage/InstallInfo.hs @@ -3,9 +3,12 @@ module Stackage.InstallInfo , iiPackageList ) where +import Control.Arrow ((&&&)) +import Control.Monad (forM_) import qualified Data.Map as Map import qualified Data.Set as Set import Data.Version (showVersion) +import Distribution.Version (withinRange) import Stackage.Config import Stackage.HaskellPlatform import Stackage.LoadDatabase @@ -32,17 +35,29 @@ getInstallInfo settings = do putStrLn "Printing build plan to build-plan.log" writeFile "build-plan.log" $ unlines $ map showDep $ Map.toList final + + case checkBadVersions settings final of + badVersions + | Map.null badVersions -> return () + | otherwise -> do + forM_ (Map.toList badVersions) $ \(PackageName user, badDeps) -> do + putStrLn $ user ++ " cannot use: " + mapM_ (putStrLn . packageVersionString) $ Map.toList badDeps + putStrLn "" + + error "Conflicting build plan, exiting" + return InstallInfo { iiCore = totalCore - , iiPackages = Map.map (\(v, _, m) -> (v, m)) final + , iiPackages = Map.map (biVersion &&& biMaintainer) final , iiOptionalCore = Map.fromList $ map (\(PackageIdentifier p v) -> (p, v)) $ Set.toList $ hplibs hp , iiPackageDB = pdb } -showDep :: (PackageName, (Version, [PackageName], Maintainer)) -> String -showDep (name, (version, deps, Maintainer m)) = +showDep :: (PackageName, BuildInfo) -> String +showDep (PackageName name, (BuildInfo version deps (Maintainer m) _)) = concat - [ unP name + [ name , "-" , showVersion version , " (" @@ -56,3 +71,25 @@ showDep (name, (version, deps, Maintainer m)) = iiPackageList :: InstallInfo -> [String] iiPackageList = map packageVersionString . Map.toList . Map.map fst . iiPackages + +-- | Check for internal mismatches in required and actual package versions. +checkBadVersions :: BuildSettings + -> Map PackageName BuildInfo + -> Map PackageName (Map PackageName Version) +checkBadVersions settings buildPlan = + Map.filter (not . Map.null) $ Map.map getBadVersions $ Map.filterWithKey unexpectedFailure buildPlan + where + unexpectedFailure name _ = name `Set.notMember` expectedFailures settings + + getBadVersions :: BuildInfo -> Map PackageName Version + getBadVersions = Map.unions . map (uncurry checkPackage) . Map.toList . biDeps + + checkPackage :: PackageName -> VersionRange -> Map PackageName Version + checkPackage name vr = + case Map.lookup name buildPlan of + -- Can't find the dependency. Could be part of core, so just ignore + -- it. + Nothing -> Map.empty + Just bi + | biVersion bi `withinRange` vr -> Map.empty + | otherwise -> Map.singleton name $ biVersion bi diff --git a/Stackage/LoadDatabase.hs b/Stackage/LoadDatabase.hs index af01e229..7b2d60ed 100644 --- a/Stackage/LoadDatabase.hs +++ b/Stackage/LoadDatabase.hs @@ -30,7 +30,7 @@ import Distribution.PackageDescription (Condition (..), import Distribution.PackageDescription.Parse (ParseResult (ParseOk), parsePackageDescription) import Distribution.System (buildArch, buildOS) -import Distribution.Version (withinRange) +import Distribution.Version (withinRange, unionVersionRanges) import Stackage.Config import Stackage.Types import Stackage.Util @@ -101,8 +101,8 @@ loadPackageDB core deps = do goBI f x = buildTools $ f $ condTreeData x depName (Dependency p _) = p go gpd tree - = Set.unions - $ Set.fromList (map (\(Dependency p _) -> p) $ condTreeConstraints tree) + = Map.unionsWith unionVersionRanges + $ Map.fromList (map (\(Dependency p vr) -> (p, vr)) $ condTreeConstraints tree) : map (go gpd) (mapMaybe (checkCond gpd) $ condTreeComponents tree) checkCond gpd (cond, tree, melse) diff --git a/Stackage/NarrowDatabase.hs b/Stackage/NarrowDatabase.hs index 3cc7ca8d..ac434956 100644 --- a/Stackage/NarrowDatabase.hs +++ b/Stackage/NarrowDatabase.hs @@ -9,7 +9,7 @@ import Stackage.Types -- their dependencies. narrowPackageDB :: PackageDB -> Set (PackageName, Maintainer) - -> IO (Map PackageName (Version, [PackageName], Maintainer)) + -> IO (Map PackageName BuildInfo) narrowPackageDB (PackageDB pdb) = loop Map.empty . Set.map (\(name, maintainer) -> ([], name, maintainer)) where @@ -23,8 +23,13 @@ narrowPackageDB (PackageDB pdb) = | otherwise -> loop result toProcess' Just pi -> do let users' = p:users - result' = Map.insert p (piVersion pi, users, maintainer) result - loop result' $ Set.foldl' (addDep users' result' maintainer) toProcess' $ piDeps pi + result' = Map.insert p BuildInfo + { biVersion = piVersion pi + , biUsers = users + , biMaintainer = maintainer + , biDeps = piDeps pi + } result + loop result' $ Set.foldl' (addDep users' result' maintainer) toProcess' $ Map.keysSet $ piDeps pi addDep users result maintainer toProcess p = case Map.lookup p result of Nothing -> Set.insert (users, p, maintainer) toProcess diff --git a/Stackage/Types.hs b/Stackage/Types.hs index d2fefa89..a4eb7133 100644 --- a/Stackage/Types.hs +++ b/Stackage/Types.hs @@ -13,7 +13,7 @@ import Distribution.Package as X (PackageIdentifier (..), import Distribution.Version as X (VersionRange (..)) newtype PackageDB = PackageDB (Map PackageName PackageInfo) - deriving (Show, Eq, Ord) + deriving (Show, Eq) instance Monoid PackageDB where mempty = PackageDB mempty @@ -26,11 +26,19 @@ instance Monoid PackageDB where data PackageInfo = PackageInfo { piVersion :: Version - , piDeps :: Set PackageName + , piDeps :: Map PackageName VersionRange , piHasTests :: Bool , piBuildTools :: Set PackageName } - deriving (Show, Eq, Ord) + deriving (Show, Eq) + +-- | Information on a package we're going to build. +data BuildInfo = BuildInfo + { biVersion :: Version + , biUsers :: [PackageName] + , biMaintainer :: Maintainer + , biDeps :: Map PackageName VersionRange + } data HaskellPlatform = HaskellPlatform { hpcore :: Set PackageIdentifier