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