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