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