git.iko.soy/stackage
on 8ebf1ae help sign in
stackage/Stackage/Select.hs
110 lines 3.8 kB history raw
1module Stackage.Select
2 ( select
3 , defaultSelectSettings
4 ) where
6import Data.Either (partitionEithers)
7import qualified Data.Map as Map
8import Data.Maybe (mapMaybe)
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 , disabledFlags = Set.fromList $ words "bytestring-in-base"
27 , allowedPackage = const $ Right ()
28 , useGlobalDatabase = False
29 }
31select :: SelectSettings -> IO BuildPlan
32select settings' = do
33 ii <- getInstallInfo settings'
35 bt <-
36 case iiBuildTools ii of
37 Left s -> error $ "Could not topologically sort build tools: " ++ s
38 Right x -> return x
40 return BuildPlan
41 { bpTools = bt
42 , bpPackages = iiPackages ii
43 , bpOptionalCore = iiOptionalCore ii
44 , bpCore = iiCore ii
45 }
47-- | Get all of the build tools required.
48iiBuildTools :: InstallInfo -> Either String [String]
49iiBuildTools InstallInfo { iiPackageDB = PackageDB m, iiPackages = packages } =
50 fmap (map packageVersionString)
51 $ topSort
52 $ map addDependencies
53 $ filter (flip Set.notMember coreTools . fst)
54 $ Set.toList
55 $ Set.fromList
56 $ mapMaybe (flip Map.lookup buildToolMap)
57 $ Set.toList
58 $ Set.unions
59 $ map piBuildTools
60 $ Map.elems
61 $ Map.filterWithKey isSelected m
62 where
63 isSelected name _ = name `Set.member` selected
64 selected = Set.fromList $ Map.keys packages
66 -- Build tools shipped with GHC which we should not attempt to build
67 -- ourselves.
68 coreTools = Set.fromList $ map PackageName $ words "hsc2hs"
70 -- The map from build tool name to the package it comes from.
71 buildToolMap :: Map Executable (PackageName, Version)
72 buildToolMap = Map.unions $ map toBuildToolMap $ Map.toList m
74 toBuildToolMap :: (PackageName, PackageInfo) -> Map Executable (PackageName, Version)
75 toBuildToolMap (pn, pi) = Map.unions
76 $ map (flip Map.singleton (pn, piVersion pi))
77 $ Set.toList
78 $ piExecs pi
80 addDependencies :: (PackageName, Version) -> ((PackageName, Version), Set (PackageName, Version))
81 addDependencies (pn, pv) =
82 ((pn, pv), deps)
83 where
84 deps =
85 case Map.lookup pn m of
86 Nothing -> Set.empty
87 Just pi -> Set.fromList
88 $ mapMaybe (flip Map.lookup buildToolMap)
89 $ Set.toList
90 $ piBuildTools pi
92topSort :: (Show a, Ord a) => [(a, Set a)] -> Either String [a]
93topSort orig =
94 uncurry go . partitionEithers . map (splitter . limitDeps) $ orig
95 where
96 splitter (x, y)
97 | Set.null y = Left x
98 | otherwise = Right (x, y)
100 go x [] = Right x
101 go [] y = Left $ "The following form a cycle: " ++ show (map fst y)
102 go (x:xs) ys = do
103 let (xs', ys') = partitionEithers $ map (splitter . dropDep x) ys
104 rest <- go (xs ++ xs') ys'
105 return $ x : rest
107 dropDep x (y, z) = (y, Set.delete x z)
109 allVertices = Set.fromList $ map fst orig
110 limitDeps (x, y) = (x, Set.intersection allVertices y)