git.iko.soy/stackage
on 39cc820 help sign in
stackage/Stackage/InstallInfo.hs
132 lines 5.1 kB history raw
1{-# LANGUAGE RecordWildCards #-}
2module Stackage.InstallInfo
3 ( getInstallInfo
4 , bpPackageList
5 ) where
7import Control.Arrow ((&&&))
8import Control.Monad (forM_)
9import qualified Data.Map as Map
10import qualified Data.Set as Set
11import Data.Version (showVersion)
12import qualified Distribution.Text
13import Distribution.Version (withinRange, simplifyVersionRange)
14import Stackage.HaskellPlatform
15import Stackage.LoadDatabase
16import Stackage.NarrowDatabase
17import Stackage.Types
18import Stackage.Util
20dropExcluded :: SelectSettings
21 -> Map PackageName (VersionRange, Maintainer)
22 -> Map PackageName (VersionRange, Maintainer)
23dropExcluded bs m0 =
24 Set.foldl' (flip Map.delete) m0 (excludedPackages bs)
26getInstallInfo :: SelectSettings -> IO InstallInfo
27getInstallInfo settings = do
28 putStrLn "Loading Haskell Platform"
29 hp <- loadHaskellPlatform settings
30 let allPackages'
31 | requireHaskellPlatform settings = Map.union (stablePackages settings) $ identsToRanges (hplibs hp)
32 | otherwise = stablePackages settings
33 allPackages = dropExcluded settings allPackages'
34 let totalCore = extraCore settings `Set.union` Set.map (\(PackageIdentifier p _) -> p) (hpcore hp)
36 putStrLn "Loading package database"
37 pdb <- loadPackageDB settings totalCore allPackages
39 putStrLn "Narrowing package database"
40 final <- narrowPackageDB settings pdb $ Set.fromList $ Map.toList $ Map.map snd $ allPackages
42 putStrLn "Printing build plan to build-plan.log"
43 writeFile "build-plan.log" $ unlines $ map showDep $ Map.toList final
45 case checkBadVersions settings pdb final of
46 badVersions
47 | Map.null badVersions -> return ()
48 | otherwise -> do
49 forM_ (Map.toList badVersions) $ \(user, badDeps) -> do
50 putStrLn $ user ++ " cannot use: "
51 forM_ (Map.toList badDeps) $ \(name, (version, range)) -> do
52 putStrLn $ concat
53 [ "- "
54 , packageVersionString (name, version)
55 , " -- "
56 , Distribution.Text.display $ simplifyVersionRange range
57 ]
58 putStrLn ""
60 error "Conflicting build plan, exiting"
62 return InstallInfo
63 { iiCore = totalCore
64 , iiPackages = Map.map biToSPI final
65 , iiOptionalCore = Map.fromList $ map (\(PackageIdentifier p v) -> (p, v)) $ Set.toList $ hplibs hp
66 , iiPackageDB = pdb
67 }
69biToSPI :: BuildInfo -> SelectedPackageInfo
70biToSPI BuildInfo {..} = SelectedPackageInfo
71 { spiVersion = biVersion
72 , spiMaintainer = biMaintainer
73 , spiGithubUser = biGithubUser
74 , spiHasTests = biHasTests
75 }
77showDep :: (PackageName, BuildInfo) -> String
78showDep (PackageName name, BuildInfo {..}) =
79 concat
80 [ name
81 , "-"
82 , showVersion biVersion
83 , " ("
84 , unMaintainer biMaintainer
85 , case biGithubUser of
86 Nothing -> ""
87 Just x -> " @" ++ x
88 , ")"
89 , ": "
90 , unwords $ map unP biUsers
91 ]
92 where
93 unP (PackageName p) = p
95bpPackageList :: BuildPlan -> [String]
96bpPackageList = map packageVersionString . Map.toList . Map.map spiVersion . bpPackages
98-- | Check for internal mismatches in required and actual package versions.
99checkBadVersions :: SelectSettings
100 -> PackageDB
101 -> Map PackageName BuildInfo
102 -> Map String (Map PackageName (Version, VersionRange))
103checkBadVersions settings (PackageDB pdb) buildPlan =
104 Map.unions $ map getBadVersions $ Map.toList $ Map.filterWithKey unexpectedFailure buildPlan
105 where
106 unexpectedFailure name _ = name `Set.notMember` expectedFailuresSelect settings
108 getBadVersions :: (PackageName, BuildInfo) -> Map String (Map PackageName (Version, VersionRange))
109 getBadVersions (name, bi)
110 | Map.null badVersions = Map.empty
111 | otherwise = Map.singleton display badVersions
112 where
113 badVersions = Map.unions $ map (uncurry checkPackage) $ Map.toList $ biDeps bi
114 display = concat
115 [ packageVersionString (name, biVersion bi)
116 , " ("
117 , unMaintainer $ biMaintainer bi
118 , case Map.lookup name pdb of
119 Just PackageInfo { piGithubUser = Just gu } -> " @" ++ gu
120 _ -> ""
121 , ")"
122 ]
124 checkPackage :: PackageName -> VersionRange -> Map PackageName (Version, VersionRange)
125 checkPackage name vr =
126 case Map.lookup name buildPlan of
127 -- Can't find the dependency. Could be part of core, so just ignore
128 -- it.
129 Nothing -> Map.empty
130 Just bi
131 | biVersion bi `withinRange` vr -> Map.empty
132 | otherwise -> Map.singleton name (biVersion bi, vr)