git.iko.soy/stackage
on 7849ced help sign in
stackage/Stackage/InstallInfo.hs
160 lines 6.2 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 mhp <- loadHaskellPlatform settings
32 core <-
33 case mhp of
34 Just hp | not (useGlobalDatabase settings) -> return $ hpcore hp
35 _ -> do
36 putStrLn "Loading core packages from global database"
37 getGlobalPackages $ selectGhcVersion settings
38 let coreMap = Map.unions
39 $ map (\(PackageIdentifier k v) -> Map.singleton k v)
40 $ Set.toList core
42 let allPackages' =
43 case mhp of
44 Just hp | requireHaskellPlatform settings ->
45 Map.union (stablePackages settings) $ identsToRanges (hplibs hp)
46 _ -> stablePackages settings
47 allPackages = dropExcluded settings allPackages'
48 let totalCore = extraCore settings `Set.union` Set.map (\(PackageIdentifier p _) -> p) core
50 putStrLn "Loading package database"
51 pdb <- loadPackageDB settings coreMap totalCore allPackages
53 putStrLn "Narrowing package database"
54 (final, errs) <- narrowPackageDB settings totalCore pdb $ Set.fromList $ Map.toList $ Map.map snd $ allPackages
56 putStrLn "Printing build plan to build-plan.log"
57 writeFile "build-plan.log" $ unlines $ map showDep $ Map.toList final
59 unless (Set.null errs) $ do
60 putStrLn "Build plan requires some disallowed packages"
61 mapM_ putStrLn $ Set.toList errs
62 exitFailure
64 putStrLn "Checking for bad versions"
65 case checkBadVersions settings coreMap pdb final of
66 badVersions
67 | Map.null badVersions -> return ()
68 | otherwise -> do
69 forM_ (Map.toList badVersions) $ \(user, badDeps) -> do
70 putStrLn $ user ++ " cannot use: "
71 forM_ (Map.toList badDeps) $ \(name, (version, range)) -> do
72 putStrLn $ concat
73 [ "- "
74 , packageVersionString (name, version)
75 , " -- "
76 , Distribution.Text.display $ simplifyVersionRange range
77 ]
78 putStrLn ""
80 error "Conflicting build plan, exiting"
82 return InstallInfo
83 { iiCore = totalCore
84 , iiPackages = Map.map biToSPI final
85 , iiOptionalCore = maybe
86 Map.empty
87 (Map.fromList . map (\(PackageIdentifier p v) -> (p, v)) . Set.toList . hplibs)
88 mhp
89 , iiPackageDB = pdb
90 }
92biToSPI :: BuildInfo -> SelectedPackageInfo
93biToSPI BuildInfo {..} = SelectedPackageInfo
94 { spiVersion = biVersion
95 , spiMaintainer = biMaintainer
96 , spiGithubUser = biGithubUser
97 , spiHasTests = biHasTests
98 }
100showDep :: (PackageName, BuildInfo) -> String
101showDep (PackageName name, BuildInfo {..}) =
102 concat
103 [ name
104 , "-"
105 , showVersion biVersion
106 , " ("
107 , unMaintainer biMaintainer
108 , case biGithubUser of
109 Nothing -> ""
110 Just x -> " @" ++ x
111 , ")"
112 , ": "
113 , unwords $ map unP biUsers
114 ]
115 where
116 unP (PackageName p) = p
118bpPackageList :: BuildPlan -> [String]
119bpPackageList = map packageVersionString . Map.toList . Map.map spiVersion . bpPackages
121-- | Check for internal mismatches in required and actual package versions.
122checkBadVersions :: SelectSettings
123 -> Map PackageName Version -- ^ core
124 -> PackageDB
125 -> Map PackageName BuildInfo
126 -> Map String (Map PackageName (Version, VersionRange))
127checkBadVersions settings core (PackageDB pdb) buildPlan =
128 Map.unions $ map getBadVersions $ Map.toList $ Map.filterWithKey unexpectedFailure buildPlan
129 where
130 unexpectedFailure name _ = name `Set.notMember` expectedFailuresSelect settings
132 getBadVersions :: (PackageName, BuildInfo) -> Map String (Map PackageName (Version, VersionRange))
133 getBadVersions (name, bi)
134 | Map.null badVersions = Map.empty
135 | otherwise = Map.singleton display badVersions
136 where
137 badVersions = Map.unions $ map (uncurry checkPackage) $ Map.toList $ biDeps bi
138 display = concat
139 [ packageVersionString (name, biVersion bi)
140 , " ("
141 , unMaintainer $ biMaintainer bi
142 , case Map.lookup name pdb of
143 Just PackageInfo { piGithubUser = Just gu } -> " @" ++ gu
144 _ -> ""
145 , ")"
146 ]
148 checkPackage :: PackageName -> VersionRange -> Map PackageName (Version, VersionRange)
149 checkPackage name vr =
150 case Map.lookup name buildPlan of
151 Nothing ->
152 case Map.lookup name core of
153 -- Might be part of extra-core
154 Nothing -> Map.empty
155 Just version
156 | version `withinRange` vr -> Map.empty
157 | otherwise -> Map.singleton name (version, vr)
158 Just bi
159 | biVersion bi `withinRange` vr -> Map.empty
160 | otherwise -> Map.singleton name (biVersion bi, vr)