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