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