git.iko.soy/stackage
on f9999a5 help sign in
stackage/Stackage/Select.hs
106 lines 3.6 kB history raw
1module Stackage.Select
2 ( select
3 , defaultSelectSettings
4 ) where
6import qualified Data.Map as Map
7import Data.Maybe (mapMaybe)
8import Data.Either (partitionEithers)
9import Data.Set (empty)
10import qualified Data.Set as Set
11import Prelude hiding (pi)
12import Stackage.Config
13import Stackage.InstallInfo
14import Stackage.Types
15import Stackage.Util
17defaultSelectSettings :: SelectSettings
18defaultSelectSettings = SelectSettings
19 { extraCore = defaultExtraCore
20 , expectedFailuresSelect = defaultExpectedFailures
21 , stablePackages = defaultStablePackages
22 , haskellPlatformCabal = "haskell-platform/haskell-platform.cabal"
23 , requireHaskellPlatform = True
24 , excludedPackages = empty
25 , flags = Set.fromList $ words "blaze_html_0_5"
26 , allowedPackage = const $ Right ()
27 }
29select :: SelectSettings -> IO BuildPlan
30select settings' = do
31 ii <- getInstallInfo settings'
33 bt <-
34 case iiBuildTools ii of
35 Left s -> error $ "Could not topologically sort build tools: " ++ s
36 Right x -> return x
38 return BuildPlan
39 { bpTools = bt
40 , bpPackages = iiPackages ii
41 , bpOptionalCore = iiOptionalCore ii
42 , bpCore = iiCore ii
43 }
45-- | Get all of the build tools required.
46iiBuildTools :: InstallInfo -> Either String [String]
47iiBuildTools InstallInfo { iiPackageDB = PackageDB m, iiPackages = packages } =
48 fmap (map packageVersionString)
49 $ topSort
50 $ map addDependencies
51 $ filter (flip Set.notMember coreTools . fst)
52 $ mapMaybe (flip Map.lookup buildToolMap)
53 $ Set.toList
54 $ Set.unions
55 $ map piBuildTools
56 $ Map.elems
57 $ Map.filterWithKey isSelected m
58 where
59 isSelected name _ = name `Set.member` selected
60 selected = Set.fromList $ Map.keys packages
62 -- Build tools shipped with GHC which we should not attempt to build
63 -- ourselves.
64 coreTools = Set.fromList $ map PackageName $ words "hsc2hs"
66 -- The map from build tool name to the package it comes from.
67 buildToolMap :: Map Executable (PackageName, Version)
68 buildToolMap = Map.unions $ map toBuildToolMap $ Map.toList m
70 toBuildToolMap :: (PackageName, PackageInfo) -> Map Executable (PackageName, Version)
71 toBuildToolMap (pn, pi) = Map.unions
72 $ map (flip Map.singleton (pn, piVersion pi))
73 $ Set.toList
74 $ piExecs pi
76 addDependencies :: (PackageName, Version) -> ((PackageName, Version), Set (PackageName, Version))
77 addDependencies (pn, pv) =
78 ((pn, pv), deps)
79 where
80 deps =
81 case Map.lookup pn m of
82 Nothing -> Set.empty
83 Just pi -> Set.fromList
84 $ mapMaybe (flip Map.lookup buildToolMap)
85 $ Set.toList
86 $ piBuildTools pi
88topSort :: (Show a, Ord a) => [(a, Set a)] -> Either String [a]
89topSort orig =
90 uncurry go . partitionEithers . map (splitter . limitDeps) $ orig
91 where
92 splitter (x, y)
93 | Set.null y = Left x
94 | otherwise = Right (x, y)
96 go x [] = Right x
97 go [] y = Left $ "The following form a cycle: " ++ show (map fst y)
98 go (x:xs) ys = do
99 let (xs', ys') = partitionEithers $ map (splitter . dropDep x) ys
100 rest <- go (xs ++ xs') ys'
101 return $ x : rest
103 dropDep x (y, z) = (y, Set.delete x z)
105 allVertices = Set.fromList $ map fst orig
106 limitDeps (x, y) = (x, Set.intersection allVertices y)