git.iko.soy/stackage
on 77fa7fa help sign in
stackage/Stackage/NarrowDatabase.hs
54 lines 2.7 kB history raw
1module Stackage.NarrowDatabase where
3import Control.Monad.Trans.Writer
4import Data.List (foldl')
5import qualified Data.Map as Map
6import qualified Data.Set as Set
7import Prelude hiding (pi)
8import Stackage.Types
9import Stackage.Util
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, Set String)
18narrowPackageDB settings core (PackageDB pdb) packageSet =
19 runWriterT $ loop Map.empty $ Set.map (\(name, maintainer) -> ([], name, maintainer)) packageSet
20 where
21 loop result toProcess =
22 case Set.minView toProcess of
23 Nothing -> return result
24 Just ((users, p, maintainer), toProcess') ->
25 case Map.lookup p pdb of
26 Nothing
27 | p `Set.member` core -> loop result toProcess'
28 | null users -> error $ "Unknown package: " ++ show p
29 | otherwise -> loop result toProcess'
30 Just pi -> do
31 let users' = p:users
32 result' = Map.insert p BuildInfo
33 { biVersion = piVersion pi
34 , biUsers = users
35 , biMaintainer = maintainer
36 , biDeps = piDeps pi
37 , biGithubUser = piGithubUser pi
38 , biHasTests = piHasTests pi
39 } result
40 case piGPD pi of
41 Nothing -> return ()
42 Just gpd ->
43 case allowedPackage settings gpd of
44 Left msg -> tell $ Set.singleton $ concat
45 [ packageVersionString (p, piVersion pi)
46 , ": "
47 , msg
48 ]
49 Right () -> return ()
50 loop result' $ foldl' (addDep users' result' maintainer) toProcess' $ Map.keys $ piDeps pi
51 addDep users result maintainer toProcess p =
52 case Map.lookup p result of
53 Nothing -> Set.insert (users, p, maintainer) toProcess
54 Just{} -> toProcess