@@ -5,6 +5,7 @@ module Stackage.Select
55
66import qualified Data.Map as Map
77import Data.Maybe (mapMaybe)
8+import Data.Either (partitionEithers)
89import Data.Set (empty)
910import qualified Data.Set as Set
1011import Prelude hiding (pi)
@@ -29,19 +30,24 @@ select :: SelectSettings -> IO BuildPlan
2930select settings' = do
3031 ii <- getInstallInfo settings'
3132
33+ bt <-
34+ case iiBuildTools ii of
35+ Left s -> error $ "Could not topologically sort build tools: " ++ s
36+ Right x -> return x
37+
3238 return BuildPlan
33− { bpTools = iiBuildTools ii
39+ { bpTools = bt
3440 , bpPackages = iiPackages ii
3541 , bpOptionalCore = iiOptionalCore ii
3642 , bpCore = iiCore ii
3743 }
3844
3945-- | Get all of the build tools required.
40−iiBuildTools :: InstallInfo -> [String]
46+iiBuildTools :: InstallInfo -> Either String [String]
4147iiBuildTools InstallInfo { iiPackageDB = PackageDB m, iiPackages = packages } =
42− -- FIXME possible improvement: track the dependencies between the build
43− -- tools themselves, and install them in the correct order.
44− map packageVersionString
48+ fmap (map packageVersionString)
49+ $ topSort
50+ $ map addDependencies
4551 $ filter (flip Set.notMember coreTools . fst)
4652 $ mapMaybe (flip Map.lookup buildToolMap)
4753 $ Set.toList
@@ -58,9 +64,43 @@ iiBuildTools InstallInfo { iiPackageDB = PackageDB m, iiPackages = packages } =
5864 coreTools = Set.fromList $ map PackageName $ words "hsc2hs"
5965
6066 -- The map from build tool name to the package it comes from.
67+ buildToolMap :: Map Executable (PackageName, Version)
6168 buildToolMap = Map.unions $ map toBuildToolMap $ Map.toList m
69+
6270 toBuildToolMap :: (PackageName, PackageInfo) -> Map Executable (PackageName, Version)
6371 toBuildToolMap (pn, pi) = Map.unions
6472 $ map (flip Map.singleton (pn, piVersion pi))
6573 $ Set.toList
6674 $ piExecs pi
75+
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
87+
88+topSort :: (Show a, Ord a) => [(a, Set a)] -> Either String [a]
89+topSort 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)
95+
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
102+
103+ dropDep x (y, z) = (y, Set.delete x z)
104+
105+ allVertices = Set.fromList $ map fst orig
106+ limitDeps (x, y) = (x, Set.intersection allVertices y)