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

@@ -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 :: (PackageName, BuildInfo) -> String
-showDep (name, (version, deps, Maintainer m)) =
+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

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
+            = Map.unionsWith unionVersionRanges
-            $ Set.fromList (map (\(Dependency p _) -> p) $ condTreeConstraints tree)
+            $ Map.fromList (map (\(Dependency p vr) -> (p, vr)) $ condTreeConstraints tree)
             : map (go gpd) (mapMaybe (checkCond gpd) $ condTreeComponents tree)
 
         checkCond gpd (cond, tree, melse)

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
+                            result' = Map.insert p BuildInfo
-                        loop result' $ Set.foldl' (addDep users' result' maintainer) toProcess' $ piDeps pi
+                                { 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

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