git.iko.soy/stackage
on 55b44ab help sign in
stackage/Stackage/Select.hs
118 lines 4.2 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 Distribution.Text (simpleParse)
12import Distribution.Version (withinRange)
13import Prelude hiding (pi)
14import Stackage.Config
15import Stackage.InstallInfo
16import Stackage.Types
17import Stackage.Util
19defaultSelectSettings :: SelectSettings
20defaultSelectSettings = SelectSettings
21 { extraCore = defaultExtraCore
22 , expectedFailuresSelect = defaultExpectedFailures
23 , stablePackages = defaultStablePackages
24 , haskellPlatformCabal = "haskell-platform/haskell-platform.cabal"
25 , requireHaskellPlatform = True
26 , excludedPackages = empty
27 , flags = \coreMap ->
28 Set.fromList (words "blaze_html_0_5") `Set.union`
29 -- Support for containers-unicode-symbols
30 (case Map.lookup (PackageName "containers") coreMap of
31 Just v | Just range <- simpleParse "< 0.5", v `withinRange` range
32 -> Set.singleton "containers-old"
33 _ -> Set.empty)
34 , disabledFlags = Set.fromList $ words "bytestring-in-base"
35 , allowedPackage = const $ Right ()
36 , useGlobalDatabase = False
37 }
39select :: SelectSettings -> IO BuildPlan
40select settings' = do
41 ii <- getInstallInfo settings'
43 bt <-
44 case iiBuildTools ii of
45 Left s -> error $ "Could not topologically sort build tools: " ++ s
46 Right x -> return x
48 return BuildPlan
49 { bpTools = bt
50 , bpPackages = iiPackages ii
51 , bpOptionalCore = iiOptionalCore ii
52 , bpCore = iiCore ii
53 }
55-- | Get all of the build tools required.
56iiBuildTools :: InstallInfo -> Either String [String]
57iiBuildTools InstallInfo { iiPackageDB = PackageDB m, iiPackages = packages } =
58 fmap (map packageVersionString)
59 $ topSort
60 $ map addDependencies
61 $ filter (flip Set.notMember coreTools . fst)
62 $ Set.toList
63 $ Set.fromList
64 $ mapMaybe (flip Map.lookup buildToolMap)
65 $ Set.toList
66 $ Set.unions
67 $ map piBuildTools
68 $ Map.elems
69 $ Map.filterWithKey isSelected m
70 where
71 isSelected name _ = name `Set.member` selected
72 selected = Set.fromList $ Map.keys packages
74 -- Build tools shipped with GHC which we should not attempt to build
75 -- ourselves.
76 coreTools = Set.fromList $ map PackageName $ words "hsc2hs"
78 -- The map from build tool name to the package it comes from.
79 buildToolMap :: Map Executable (PackageName, Version)
80 buildToolMap = Map.unions $ map toBuildToolMap $ Map.toList m
82 toBuildToolMap :: (PackageName, PackageInfo) -> Map Executable (PackageName, Version)
83 toBuildToolMap (pn, pi) = Map.unions
84 $ map (flip Map.singleton (pn, piVersion pi))
85 $ Set.toList
86 $ piExecs pi
88 addDependencies :: (PackageName, Version) -> ((PackageName, Version), Set (PackageName, Version))
89 addDependencies (pn, pv) =
90 ((pn, pv), deps)
91 where
92 deps =
93 case Map.lookup pn m of
94 Nothing -> Set.empty
95 Just pi -> Set.fromList
96 $ mapMaybe (flip Map.lookup buildToolMap)
97 $ Set.toList
98 $ piBuildTools pi
100topSort :: (Show a, Ord a) => [(a, Set a)] -> Either String [a]
101topSort orig =
102 uncurry go . partitionEithers . map (splitter . limitDeps) $ orig
103 where
104 splitter (x, y)
105 | Set.null y = Left x
106 | otherwise = Right (x, y)
108 go x [] = Right x
109 go [] y = Left $ "The following form a cycle: " ++ show (map fst y)
110 go (x:xs) ys = do
111 let (xs', ys') = partitionEithers $ map (splitter . dropDep x) ys
112 rest <- go (xs ++ xs') ys'
113 return $ x : rest
115 dropDep x (y, z) = (y, Set.delete x z)
117 allVertices = Set.fromList $ map fst orig
118 limitDeps (x, y) = (x, Set.intersection allVertices y)