git.iko.soy/stackage
on 6de20bd help sign in
stackage/Stackage/NarrowDatabase.hs
56 lines 2.6 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 :: BuildSettings
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 } result
42 case piGPD pi of
43 Nothing -> return ()
44 Just gpd ->
45 case allowedPackage settings gpd of
46 Left msg -> tell $ Set.singleton $ concat
47 [ packageVersionString (p, piVersion pi)
48 , ": "
49 , msg
50 ]
51 Right () -> return ()
52 loop result' $ Set.foldl' (addDep users' result' maintainer) toProcess' $ Map.keysSet $ piDeps pi
53 addDep users result maintainer toProcess p =
54 case Map.lookup p result of
55 Nothing -> Set.insert (users, p, maintainer) toProcess
56 Just{} -> toProcess