git.iko.soy/stackage
on 3ac3d06 help sign in
stackage/Stackage/Select.hs
108 lines 3.7 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 , 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 $ Set.toList
53 $ Set.fromList
54 $ mapMaybe (flip Map.lookup buildToolMap)
55 $ Set.toList
56 $ Set.unions
57 $ map piBuildTools
58 $ Map.elems
59 $ Map.filterWithKey isSelected m
60 where
61 isSelected name _ = name `Set.member` selected
62 selected = Set.fromList $ Map.keys packages
64 -- Build tools shipped with GHC which we should not attempt to build
65 -- ourselves.
66 coreTools = Set.fromList $ map PackageName $ words "hsc2hs"
68 -- The map from build tool name to the package it comes from.
69 buildToolMap :: Map Executable (PackageName, Version)
70 buildToolMap = Map.unions $ map toBuildToolMap $ Map.toList m
72 toBuildToolMap :: (PackageName, PackageInfo) -> Map Executable (PackageName, Version)
73 toBuildToolMap (pn, pi) = Map.unions
74 $ map (flip Map.singleton (pn, piVersion pi))
75 $ Set.toList
76 $ piExecs pi
78 addDependencies :: (PackageName, Version) -> ((PackageName, Version), Set (PackageName, Version))
79 addDependencies (pn, pv) =
80 ((pn, pv), deps)
81 where
82 deps =
83 case Map.lookup pn m of
84 Nothing -> Set.empty
85 Just pi -> Set.fromList
86 $ mapMaybe (flip Map.lookup buildToolMap)
87 $ Set.toList
88 $ piBuildTools pi
90topSort :: (Show a, Ord a) => [(a, Set a)] -> Either String [a]
91topSort orig =
92 uncurry go . partitionEithers . map (splitter . limitDeps) $ orig
93 where
94 splitter (x, y)
95 | Set.null y = Left x
96 | otherwise = Right (x, y)
98 go x [] = Right x
99 go [] y = Left $ "The following form a cycle: " ++ show (map fst y)
100 go (x:xs) ys = do
101 let (xs', ys') = partitionEithers $ map (splitter . dropDep x) ys
102 rest <- go (xs ++ xs') ys'
103 return $ x : rest
105 dropDep x (y, z) = (y, Set.delete x z)
107 allVertices = Set.fromList $ map fst orig
108 limitDeps (x, y) = (x, Set.intersection allVertices y)