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