git.iko.soy/stackage
on b2ed20c help sign in
stackage/Stackage/InstallInfo.hs
169 lines 6.7 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) $ identsToRanges (hplibs hp)
48 _ -> stablePackages settings
49 allPackages = dropExcluded settings allPackages'
50 let totalCore = extraCore settings `Set.union` Set.map (\(PackageIdentifier p _) -> p) core
52 putStrLn "Loading package database"
53 pdb <- loadPackageDB settings coreMap totalCore allPackages
55 putStrLn "Narrowing package database"
56 (final, errs) <- narrowPackageDB settings totalCore pdb $ Set.fromList $ Map.toList $ Map.map snd $ allPackages
58 putStrLn "Printing build plan to build-plan.log"
59 System.IO.UTF8.writeFile "build-plan.log" $ unlines $ map showDep $ Map.toList final
60 System.IO.UTF8.writeFile "hackage-map.txt" $ unlines $ map showHackageMap $ Map.toList final
62 unless (Set.null errs) $ do
63 putStrLn "Build plan requires some disallowed packages"
64 mapM_ putStrLn $ Set.toList errs
65 exitFailure
67 putStrLn "Checking for bad versions"
68 case checkBadVersions settings coreMap pdb final of
69 badVersions
70 | Map.null badVersions -> return ()
71 | otherwise -> do
72 forM_ (Map.toList badVersions) $ \(user, badDeps) -> do
73 putStrLn $ user ++ " cannot use: "
74 forM_ (Map.toList badDeps) $ \(name, (version, range)) -> do
75 putStrLn $ concat
76 [ "- "
77 , packageVersionString (name, version)
78 , " -- "
79 , Distribution.Text.display $ simplifyVersionRange range
80 ]
81 putStrLn ""
83 error "Conflicting build plan, exiting"
85 return InstallInfo
86 { iiCore = totalCore
87 , iiPackages = Map.map biToSPI final
88 , iiOptionalCore = maybe
89 Map.empty
90 (Map.fromList . map (\(PackageIdentifier p v) -> (p, v)) . Set.toList . hplibs)
91 mhp
92 , iiPackageDB = pdb
93 }
95biToSPI :: BuildInfo -> SelectedPackageInfo
96biToSPI BuildInfo {..} = SelectedPackageInfo
97 { spiVersion = biVersion
98 , spiMaintainer = biMaintainer
99 , spiGithubUser = biGithubUser
100 , spiHasTests = biHasTests
101 }
103showDep :: (PackageName, BuildInfo) -> String
104showDep (PackageName name, BuildInfo {..}) =
105 concat
106 [ name
107 , "-"
108 , showVersion biVersion
109 , " ("
110 , unMaintainer biMaintainer
111 , case biGithubUser of
112 Nothing -> ""
113 Just x -> " @" ++ x
114 , ")"
115 , ": "
116 , unwords $ map unP biUsers
117 ]
118 where
119 unP (PackageName p) = p
121-- | Convert to format used by Hackage for displaying distribution versions.
122-- For more info, see https://github.com/fpco/stackage/issues/38.
123showHackageMap :: (PackageName, BuildInfo) -> String
124showHackageMap (PackageName name, BuildInfo {..}) =
125 show (name, showVersion biVersion, Nothing :: Maybe String)
127bpPackageList :: BuildPlan -> [String]
128bpPackageList = map packageVersionString . Map.toList . Map.map spiVersion . bpPackages
130-- | Check for internal mismatches in required and actual package versions.
131checkBadVersions :: SelectSettings
132 -> Map PackageName Version -- ^ core
133 -> PackageDB
134 -> Map PackageName BuildInfo
135 -> Map String (Map PackageName (Version, VersionRange))
136checkBadVersions settings core (PackageDB pdb) buildPlan =
137 Map.unions $ map getBadVersions $ Map.toList $ Map.filterWithKey unexpectedFailure buildPlan
138 where
139 unexpectedFailure name _ = name `Set.notMember` expectedFailuresSelect settings
141 getBadVersions :: (PackageName, BuildInfo) -> Map String (Map PackageName (Version, VersionRange))
142 getBadVersions (name, bi)
143 | Map.null badVersions = Map.empty
144 | otherwise = Map.singleton display badVersions
145 where
146 badVersions = Map.unions $ map (uncurry checkPackage) $ Map.toList $ biDeps bi
147 display = concat
148 [ packageVersionString (name, biVersion bi)
149 , " ("
150 , unMaintainer $ biMaintainer bi
151 , case Map.lookup name pdb of
152 Just PackageInfo { piGithubUser = Just gu } -> " @" ++ gu
153 _ -> ""
154 , ")"
155 ]
157 checkPackage :: PackageName -> VersionRange -> Map PackageName (Version, VersionRange)
158 checkPackage name vr =
159 case Map.lookup name buildPlan of
160 Nothing ->
161 case Map.lookup name core of
162 -- Might be part of extra-core
163 Nothing -> Map.empty
164 Just version
165 | version `withinRange` vr -> Map.empty
166 | otherwise -> Map.singleton name (version, vr)
167 Just bi
168 | biVersion bi `withinRange` vr -> Map.empty
169 | otherwise -> Map.singleton name (biVersion bi, vr)