git.iko.soy/stackage
on master help sign in
Check for version conflicts ourselves.
a609f1fMichael Snoyman
Stackage/InstallInfo.hs+41−4
compare with master
unifiedsplit
@@ -3,9 +3,12 @@ module Stackage.InstallInfo
3 , iiPackageList
3 , iiPackageList
4 ) where
4 ) where
5
5
6+import Control.Arrow ((&&&))
7+import Control.Monad (forM_)
6import qualified Data.Map as Map
8import qualified Data.Map as Map
7import qualified Data.Set as Set
9import qualified Data.Set as Set
8import Data.Version (showVersion)
10import Data.Version (showVersion)
11+import Distribution.Version (withinRange)
9import Stackage.Config
12import Stackage.Config
10import Stackage.HaskellPlatform
13import Stackage.HaskellPlatform
11import Stackage.LoadDatabase
14import Stackage.LoadDatabase
@@ -32,17 +35,29 @@ getInstallInfo settings = do
32
35
33 putStrLn "Printing build plan to build-plan.log"
36 putStrLn "Printing build plan to build-plan.log"
34 writeFile "build-plan.log" $ unlines $ map showDep $ Map.toList final
37 writeFile "build-plan.log" $ unlines $ map showDep $ Map.toList final
38+
39+ case checkBadVersions settings final of
40+ badVersions
41+ | Map.null badVersions -> return ()
42+ | otherwise -> do
43+ forM_ (Map.toList badVersions) $ \(PackageName user, badDeps) -> do
44+ putStrLn $ user ++ " cannot use: "
45+ mapM_ (putStrLn . packageVersionString) $ Map.toList badDeps
46+ putStrLn ""
47+
48+ error "Conflicting build plan, exiting"
49+
35 return InstallInfo
50 return InstallInfo
36 { iiCore = totalCore
51 { iiCore = totalCore
37− , iiPackages = Map.map (\(v, _, m) -> (v, m)) final
52+ , iiPackages = Map.map (biVersion &&& biMaintainer) final
38 , iiOptionalCore = Map.fromList $ map (\(PackageIdentifier p v) -> (p, v)) $ Set.toList $ hplibs hp
53 , iiOptionalCore = Map.fromList $ map (\(PackageIdentifier p v) -> (p, v)) $ Set.toList $ hplibs hp
39 , iiPackageDB = pdb
54 , iiPackageDB = pdb
40 }
55 }
41
56
42−showDep :: (PackageName, (Version, [PackageName], Maintainer)) -> String
57+showDep :: (PackageName, BuildInfo) -> String
43−showDep (name, (version, deps, Maintainer m)) =
58+showDep (PackageName name, (BuildInfo version deps (Maintainer m) _)) =
44 concat
59 concat
45− [ unP name
60+ [ name
46 , "-"
61 , "-"
47 , showVersion version
62 , showVersion version
48 , " ("
63 , " ("
@@ -56,3 +71,25 @@ showDep (name, (version, deps, Maintainer m)) =
56
71
57iiPackageList :: InstallInfo -> [String]
72iiPackageList :: InstallInfo -> [String]
58iiPackageList = map packageVersionString . Map.toList . Map.map fst . iiPackages
73iiPackageList = map packageVersionString . Map.toList . Map.map fst . iiPackages
74+
75+-- | Check for internal mismatches in required and actual package versions.
76+checkBadVersions :: BuildSettings
77+ -> Map PackageName BuildInfo
78+ -> Map PackageName (Map PackageName Version)
79+checkBadVersions settings buildPlan =
80+ Map.filter (not . Map.null) $ Map.map getBadVersions $ Map.filterWithKey unexpectedFailure buildPlan
81+ where
82+ unexpectedFailure name _ = name `Set.notMember` expectedFailures settings
83+
84+ getBadVersions :: BuildInfo -> Map PackageName Version
85+ getBadVersions = Map.unions . map (uncurry checkPackage) . Map.toList . biDeps
86+
87+ checkPackage :: PackageName -> VersionRange -> Map PackageName Version
88+ checkPackage name vr =
89+ case Map.lookup name buildPlan of
90+ -- Can't find the dependency. Could be part of core, so just ignore
91+ -- it.
92+ Nothing -> Map.empty
93+ Just bi
94+ | biVersion bi `withinRange` vr -> Map.empty
95+ | otherwise -> Map.singleton name $ biVersion bi
Stackage/LoadDatabase.hs+3−3
@@ -30,7 +30,7 @@ import Distribution.PackageDescription (Condition (..),
30import Distribution.PackageDescription.Parse (ParseResult (ParseOk),
30import Distribution.PackageDescription.Parse (ParseResult (ParseOk),
31 parsePackageDescription)
31 parsePackageDescription)
32import Distribution.System (buildArch, buildOS)
32import Distribution.System (buildArch, buildOS)
33−import Distribution.Version (withinRange)
33+import Distribution.Version (withinRange, unionVersionRanges)
34import Stackage.Config
34import Stackage.Config
35import Stackage.Types
35import Stackage.Types
36import Stackage.Util
36import Stackage.Util
@@ -101,8 +101,8 @@ loadPackageDB core deps = do
101 goBI f x = buildTools $ f $ condTreeData x
101 goBI f x = buildTools $ f $ condTreeData x
102 depName (Dependency p _) = p
102 depName (Dependency p _) = p
103 go gpd tree
103 go gpd tree
104− = Set.unions
104+ = Map.unionsWith unionVersionRanges
105− $ Set.fromList (map (\(Dependency p _) -> p) $ condTreeConstraints tree)
105+ $ Map.fromList (map (\(Dependency p vr) -> (p, vr)) $ condTreeConstraints tree)
106 : map (go gpd) (mapMaybe (checkCond gpd) $ condTreeComponents tree)
106 : map (go gpd) (mapMaybe (checkCond gpd) $ condTreeComponents tree)
107
107
108 checkCond gpd (cond, tree, melse)
108 checkCond gpd (cond, tree, melse)
Stackage/NarrowDatabase.hs+8−3
@@ -9,7 +9,7 @@ import Stackage.Types
9-- their dependencies.
9-- their dependencies.
10narrowPackageDB :: PackageDB
10narrowPackageDB :: PackageDB
11 -> Set (PackageName, Maintainer)
11 -> Set (PackageName, Maintainer)
12− -> IO (Map PackageName (Version, [PackageName], Maintainer))
12+ -> IO (Map PackageName BuildInfo)
13narrowPackageDB (PackageDB pdb) =
13narrowPackageDB (PackageDB pdb) =
14 loop Map.empty . Set.map (\(name, maintainer) -> ([], name, maintainer))
14 loop Map.empty . Set.map (\(name, maintainer) -> ([], name, maintainer))
15 where
15 where
@@ -23,8 +23,13 @@ narrowPackageDB (PackageDB pdb) =
23 | otherwise -> loop result toProcess'
23 | otherwise -> loop result toProcess'
24 Just pi -> do
24 Just pi -> do
25 let users' = p:users
25 let users' = p:users
26− result' = Map.insert p (piVersion pi, users, maintainer) result
26+ result' = Map.insert p BuildInfo
27+ { biVersion = piVersion pi
28+ , biUsers = users
29+ , biMaintainer = maintainer
30+ , biDeps = piDeps pi
31+ } result
27− loop result' $ Set.foldl' (addDep users' result' maintainer) toProcess' $ piDeps pi
32+ loop result' $ Set.foldl' (addDep users' result' maintainer) toProcess' $ Map.keysSet $ piDeps pi
28 addDep users result maintainer toProcess p =
33 addDep users result maintainer toProcess p =
29 case Map.lookup p result of
34 case Map.lookup p result of
30 Nothing -> Set.insert (users, p, maintainer) toProcess
35 Nothing -> Set.insert (users, p, maintainer) toProcess
Stackage/Types.hs+11−3
@@ -13,7 +13,7 @@ import Distribution.Package as X (PackageIdentifier (..),
13import Distribution.Version as X (VersionRange (..))
13import Distribution.Version as X (VersionRange (..))
14
14
15newtype PackageDB = PackageDB (Map PackageName PackageInfo)
15newtype PackageDB = PackageDB (Map PackageName PackageInfo)
16− deriving (Show, Eq, Ord)
16+ deriving (Show, Eq)
17
17
18instance Monoid PackageDB where
18instance Monoid PackageDB where
19 mempty = PackageDB mempty
19 mempty = PackageDB mempty
@@ -26,11 +26,19 @@ instance Monoid PackageDB where
26
26
27data PackageInfo = PackageInfo
27data PackageInfo = PackageInfo
28 { piVersion :: Version
28 { piVersion :: Version
29− , piDeps :: Set PackageName
29+ , piDeps :: Map PackageName VersionRange
30 , piHasTests :: Bool
30 , piHasTests :: Bool
31 , piBuildTools :: Set PackageName
31 , piBuildTools :: Set PackageName
32 }
32 }
33− deriving (Show, Eq, Ord)
33+ deriving (Show, Eq)
34+
35+-- | Information on a package we're going to build.
36+data BuildInfo = BuildInfo
37+ { biVersion :: Version
38+ , biUsers :: [PackageName]
39+ , biMaintainer :: Maintainer
40+ , biDeps :: Map PackageName VersionRange
41+ }
34
42
35data HaskellPlatform = HaskellPlatform
43data HaskellPlatform = HaskellPlatform
36 { hpcore :: Set PackageIdentifier
44 { hpcore :: Set PackageIdentifier