git.iko.soy/stackage
on 6ba9699 help sign in
stackage/Stackage/InstallInfo.hs
155 lines 6.0 kB history raw
1{-# LANGUAGE RecordWildCards #-}
2module Stackage.InstallInfo
3 ( getInstallInfo
4 , bpPackageList
5 ) where
7import Control.Monad (forM_, unless)
8import qualified Data.Map as Map
9import qualified Data.Set as Set
10import Data.Version (showVersion)
11import qualified Distribution.Text
12import Distribution.Version (simplifyVersionRange, withinRange)
13import Stackage.GhcPkg
14import Stackage.HaskellPlatform
15import Stackage.LoadDatabase
16import Stackage.NarrowDatabase
17import Stackage.Types
18import Stackage.Util
19import System.Exit (exitFailure)
21dropExcluded :: SelectSettings
22 -> Map PackageName (VersionRange, Maintainer)
23 -> Map PackageName (VersionRange, Maintainer)
24dropExcluded bs m0 =
25 Set.foldl' (flip Map.delete) m0 (excludedPackages bs)
27getInstallInfo :: SelectSettings -> IO InstallInfo
28getInstallInfo settings = do
29 putStrLn "Loading Haskell Platform"
30 hp <- loadHaskellPlatform settings
32 core <-
33 if useGlobalDatabase settings
34 then do
35 putStrLn "Loading core packages from global database"
36 getGlobalPackages
37 else return $ hpcore hp
38 let coreMap = Map.unions
39 $ map (\(PackageIdentifier k v) -> Map.singleton k v)
40 $ Set.toList core
42 let allPackages'
43 | requireHaskellPlatform settings = Map.union (stablePackages settings) $ identsToRanges (hplibs hp)
44 | otherwise = stablePackages settings
45 allPackages = dropExcluded settings allPackages'
46 let totalCore = extraCore settings `Set.union` Set.map (\(PackageIdentifier p _) -> p) core
48 putStrLn "Loading package database"
49 pdb <- loadPackageDB settings coreMap totalCore allPackages
51 putStrLn "Narrowing package database"
52 (final, errs) <- narrowPackageDB settings totalCore pdb $ Set.fromList $ Map.toList $ Map.map snd $ allPackages
54 putStrLn "Printing build plan to build-plan.log"
55 writeFile "build-plan.log" $ unlines $ map showDep $ Map.toList final
57 unless (Set.null errs) $ do
58 putStrLn "Build plan requires some disallowed packages"
59 mapM_ putStrLn $ Set.toList errs
60 exitFailure
62 putStrLn "Checking for bad versions"
63 case checkBadVersions settings coreMap pdb final of
64 badVersions
65 | Map.null badVersions -> return ()
66 | otherwise -> do
67 forM_ (Map.toList badVersions) $ \(user, badDeps) -> do
68 putStrLn $ user ++ " cannot use: "
69 forM_ (Map.toList badDeps) $ \(name, (version, range)) -> do
70 putStrLn $ concat
71 [ "- "
72 , packageVersionString (name, version)
73 , " -- "
74 , Distribution.Text.display $ simplifyVersionRange range
75 ]
76 putStrLn ""
78 error "Conflicting build plan, exiting"
80 return InstallInfo
81 { iiCore = totalCore
82 , iiPackages = Map.map biToSPI final
83 , iiOptionalCore = Map.fromList $ map (\(PackageIdentifier p v) -> (p, v)) $ Set.toList $ hplibs hp
84 , iiPackageDB = pdb
85 }
87biToSPI :: BuildInfo -> SelectedPackageInfo
88biToSPI BuildInfo {..} = SelectedPackageInfo
89 { spiVersion = biVersion
90 , spiMaintainer = biMaintainer
91 , spiGithubUser = biGithubUser
92 , spiHasTests = biHasTests
93 }
95showDep :: (PackageName, BuildInfo) -> String
96showDep (PackageName name, BuildInfo {..}) =
97 concat
98 [ name
99 , "-"
100 , showVersion biVersion
101 , " ("
102 , unMaintainer biMaintainer
103 , case biGithubUser of
104 Nothing -> ""
105 Just x -> " @" ++ x
106 , ")"
107 , ": "
108 , unwords $ map unP biUsers
109 ]
110 where
111 unP (PackageName p) = p
113bpPackageList :: BuildPlan -> [String]
114bpPackageList = map packageVersionString . Map.toList . Map.map spiVersion . bpPackages
116-- | Check for internal mismatches in required and actual package versions.
117checkBadVersions :: SelectSettings
118 -> Map PackageName Version -- ^ core
119 -> PackageDB
120 -> Map PackageName BuildInfo
121 -> Map String (Map PackageName (Version, VersionRange))
122checkBadVersions settings core (PackageDB pdb) buildPlan =
123 Map.unions $ map getBadVersions $ Map.toList $ Map.filterWithKey unexpectedFailure buildPlan
124 where
125 unexpectedFailure name _ = name `Set.notMember` expectedFailuresSelect settings
127 getBadVersions :: (PackageName, BuildInfo) -> Map String (Map PackageName (Version, VersionRange))
128 getBadVersions (name, bi)
129 | Map.null badVersions = Map.empty
130 | otherwise = Map.singleton display badVersions
131 where
132 badVersions = Map.unions $ map (uncurry checkPackage) $ Map.toList $ biDeps bi
133 display = concat
134 [ packageVersionString (name, biVersion bi)
135 , " ("
136 , unMaintainer $ biMaintainer bi
137 , case Map.lookup name pdb of
138 Just PackageInfo { piGithubUser = Just gu } -> " @" ++ gu
139 _ -> ""
140 , ")"
141 ]
143 checkPackage :: PackageName -> VersionRange -> Map PackageName (Version, VersionRange)
144 checkPackage name vr =
145 case Map.lookup name buildPlan of
146 Nothing ->
147 case Map.lookup name core of
148 -- Might be part of extra-core
149 Nothing -> Map.empty
150 Just version
151 | version `withinRange` vr -> Map.empty
152 | otherwise -> Map.singleton name (version, vr)
153 Just bi
154 | biVersion bi `withinRange` vr -> Map.empty
155 | otherwise -> Map.singleton name (biVersion bi, vr)