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