git.iko.soy/stackage
on 10364db help sign in
stackage/Stackage/NarrowDatabase.hs
61 lines 3.0 kB history raw
1module Stackage.NarrowDatabase where
3import Control.Monad.Trans.Writer
4import qualified Data.Map as Map
5import qualified Data.Set as Set
6import Prelude hiding (pi)
7import Stackage.Types
8import Stackage.Util
9import System.Exit (exitFailure)
10import Distribution.Text (display)
12-- | Narrow down the database to only the specified packages and all of
13-- their dependencies.
14narrowPackageDB :: SelectSettings
15 -> Set PackageName -- ^ core packages to be excluded from installation
16 -> PackageDB
17 -> Set (PackageName, Maintainer)
18 -> IO (Map PackageName BuildInfo)
19narrowPackageDB settings core (PackageDB pdb) packageSet = do
20 (res, errs) <- runWriterT $ loop Map.empty $ Set.map (\(name, maintainer) -> ([], name, maintainer)) packageSet
21 if Set.null errs
22 then return res
23 else do
24 putStrLn "Build plan requires some disallowed packages"
25 mapM_ putStrLn $ Set.toList errs
26 exitFailure
27 where
28 loop result toProcess =
29 case Set.minView toProcess of
30 Nothing -> return result
31 Just ((users, p, maintainer), toProcess') ->
32 case Map.lookup p pdb of
33 Nothing
34 | p `Set.member` core -> loop result toProcess'
35 | null users -> error $ "Unknown package: " ++ show p
36 | otherwise -> loop result toProcess'
37 Just pi -> do
38 let users' = p:users
39 result' = Map.insert p BuildInfo
40 { biVersion = piVersion pi
41 , biUsers = users
42 , biMaintainer = maintainer
43 , biDeps = piDeps pi
44 , biGithubUser = piGithubUser pi
45 , biHasTests = piHasTests pi
46 } result
47 case piGPD pi of
48 Nothing -> return ()
49 Just gpd ->
50 case allowedPackage settings gpd of
51 Left msg -> tell $ Set.singleton $ concat
52 [ packageVersionString (p, piVersion pi)
53 , ": "
54 , msg
55 ]
56 Right () -> return ()
57 loop result' $ Set.foldl' (addDep users' result' maintainer) toProcess' $ Map.keysSet $ piDeps pi
58 addDep users result maintainer toProcess p =
59 case Map.lookup p result of
60 Nothing -> Set.insert (users, p, maintainer) toProcess
61 Just{} -> toProcess