git.iko.soy/stackage
on 5b60f58 help sign in
stackage/Stackage/InstallInfo.hs
174 lines 6.9 kB history raw
1{-# LANGUAGE RecordWildCards #-}
2module Stackage.InstallInfo
3 ( getInstallInfo
4 , bpPackageList
5 ) where
7import Control.Monad (forM_, unless)
8import Data.List (foldl')
9import qualified Data.Map as Map
10import qualified Data.Set as Set
11import Data.Version (showVersion)
12import qualified Distribution.Text
13import Distribution.Version (simplifyVersionRange, withinRange)
14import Stackage.GhcPkg
15import Stackage.HaskellPlatform
16import Stackage.LoadDatabase
17import Stackage.NarrowDatabase
18import Stackage.Types
19import Stackage.Util
20import qualified System.IO.UTF8
21import System.Exit (exitFailure)
23dropExcluded :: SelectSettings
24 -> Map PackageName (VersionRange, Maintainer)
25 -> Map PackageName (VersionRange, Maintainer)
26dropExcluded bs m0 =
27 foldl' (flip Map.delete) m0 (Set.toList $ excludedPackages bs)
29getInstallInfo :: SelectSettings -> IO InstallInfo
30getInstallInfo settings = do
31 putStrLn "Loading Haskell Platform"
32 mhp <- loadHaskellPlatform settings
34 core <-
35 case mhp of
36 Just hp | not (useGlobalDatabase settings) -> return $ hpcore hp
37 _ -> do
38 putStrLn "Loading core packages from global database"
39 getGlobalPackages $ selectGhcVersion settings
40 let coreMap = Map.unions
41 $ map (\(PackageIdentifier k v) -> Map.singleton k v)
42 $ Set.toList core
44 let allPackages' =
45 case mhp of
46 Just hp | requireHaskellPlatform settings ->
47 Map.union (stablePackages settings $ requireHaskellPlatform settings)
48 $ identsToRanges (hplibs hp)
49 _ -> stablePackages settings $ requireHaskellPlatform settings
50 allPackages = dropExcluded settings allPackages'
51 let totalCore
52 | ignoreUpgradeableCore settings =
53 Set.fromList $ map PackageName $ words "base containers template-haskell"
54 | otherwise =
55 extraCore settings `Set.union` Set.map (\(PackageIdentifier p _) -> p) core
57 putStrLn "Loading package database"
58 pdb <- loadPackageDB settings coreMap totalCore allPackages
60 putStrLn "Narrowing package database"
61 (final, errs) <- narrowPackageDB settings totalCore pdb $ Set.fromList $ Map.toList $ Map.map snd $ allPackages
63 putStrLn "Printing build plan to build-plan.log"
64 System.IO.UTF8.writeFile "build-plan.log" $ unlines $ map showDep $ Map.toList final
65 System.IO.UTF8.writeFile "hackage-map.txt" $ unlines $ map showHackageMap $ Map.toList final
67 unless (Set.null errs) $ do
68 putStrLn "Build plan requires some disallowed packages"
69 mapM_ putStrLn $ Set.toList errs
70 exitFailure
72 putStrLn "Checking for bad versions"
73 case checkBadVersions settings coreMap pdb final of
74 badVersions
75 | Map.null badVersions -> return ()
76 | otherwise -> do
77 forM_ (Map.toList badVersions) $ \(user, badDeps) -> do
78 putStrLn $ user ++ " cannot use: "
79 forM_ (Map.toList badDeps) $ \(name, (version, range)) -> do
80 putStrLn $ concat
81 [ "- "
82 , packageVersionString (name, version)
83 , " -- "
84 , Distribution.Text.display $ simplifyVersionRange range
85 ]
86 putStrLn ""
88 error "Conflicting build plan, exiting"
90 return InstallInfo
91 { iiCore = totalCore
92 , iiPackages = Map.map biToSPI final
93 , iiOptionalCore = maybe
94 Map.empty
95 (Map.fromList . map (\(PackageIdentifier p v) -> (p, v)) . Set.toList . hplibs)
96 mhp
97 , iiPackageDB = pdb
98 }
100biToSPI :: BuildInfo -> SelectedPackageInfo
101biToSPI BuildInfo {..} = SelectedPackageInfo
102 { spiVersion = biVersion
103 , spiMaintainer = biMaintainer
104 , spiGithubUser = biGithubUser
105 , spiHasTests = biHasTests
106 }
108showDep :: (PackageName, BuildInfo) -> String
109showDep (PackageName name, BuildInfo {..}) =
110 concat
111 [ name
112 , "-"
113 , showVersion biVersion
114 , " ("
115 , unMaintainer biMaintainer
116 , case biGithubUser of
117 Nothing -> ""
118 Just x -> " @" ++ x
119 , ")"
120 , ": "
121 , unwords $ map unP biUsers
122 ]
123 where
124 unP (PackageName p) = p
126-- | Convert to format used by Hackage for displaying distribution versions.
127-- For more info, see https://github.com/fpco/stackage/issues/38.
128showHackageMap :: (PackageName, BuildInfo) -> String
129showHackageMap (PackageName name, BuildInfo {..}) =
130 show (name, showVersion biVersion, Nothing :: Maybe String)
132bpPackageList :: BuildPlan -> [String]
133bpPackageList = map packageVersionString . Map.toList . Map.map spiVersion . bpPackages
135-- | Check for internal mismatches in required and actual package versions.
136checkBadVersions :: SelectSettings
137 -> Map PackageName Version -- ^ core
138 -> PackageDB
139 -> Map PackageName BuildInfo
140 -> Map String (Map PackageName (Version, VersionRange))
141checkBadVersions settings core (PackageDB pdb) buildPlan =
142 Map.unions $ map getBadVersions $ Map.toList $ Map.filterWithKey unexpectedFailure buildPlan
143 where
144 unexpectedFailure name _ = name `Set.notMember` expectedFailuresSelect settings
146 getBadVersions :: (PackageName, BuildInfo) -> Map String (Map PackageName (Version, VersionRange))
147 getBadVersions (name, bi)
148 | Map.null badVersions = Map.empty
149 | otherwise = Map.singleton display badVersions
150 where
151 badVersions = Map.unions $ map (uncurry checkPackage) $ Map.toList $ biDeps bi
152 display = concat
153 [ packageVersionString (name, biVersion bi)
154 , " ("
155 , unMaintainer $ biMaintainer bi
156 , case Map.lookup name pdb of
157 Just PackageInfo { piGithubUser = Just gu } -> " @" ++ gu
158 _ -> ""
159 , ")"
160 ]
162 checkPackage :: PackageName -> VersionRange -> Map PackageName (Version, VersionRange)
163 checkPackage name vr =
164 case Map.lookup name buildPlan of
165 Nothing ->
166 case Map.lookup name core of
167 -- Might be part of extra-core
168 Nothing -> Map.empty
169 Just version
170 | version `withinRange` vr -> Map.empty
171 | otherwise -> Map.singleton name (version, vr)
172 Just bi
173 | biVersion bi `withinRange` vr -> Map.empty
174 | otherwise -> Map.singleton name (biVersion bi, vr)