git.iko.soy/stackage
on 5b60f58 help sign in
stackage/Stackage/Select.hs
134 lines 4.8 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 , ignoreUpgradeableCore = False
29 , excludedPackages = empty
30 , flags = \coreMap ->
31 Set.fromList (words "blaze_html_0_5 small_base") `Set.union`
33#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
34 -- Needed on Windows to get unix-compat to compile
35 (if version >= GhcMajorVersion 7 6 then Set.empty else Set.fromList (words "old-time"))
36 `Set.union`
37#endif
38 -- Support for containers-unicode-symbols
39 (case Map.lookup (PackageName "containers") coreMap of
40 Just v | Just range <- simpleParse "< 0.5", v `withinRange` range
41 -> Set.singleton "containers-old"
42 _ -> Set.empty)
43 , disabledFlags = Set.fromList $ words "bytestring-in-base test-hlint"
44 , allowedPackage = const $ Right ()
45 , useGlobalDatabase = False
46 , skippedTests =
47 if version >= GhcMajorVersion 7 8
48 then Set.singleton (PackageName "punycode") -- pulls in encoding
49 else Set.empty
50 , selectGhcVersion = version
51 , selectTarballDir = "patching/tarballs"
52 }
54select :: SelectSettings -> IO BuildPlan
55select settings' = do
56 ii <- getInstallInfo settings'
58 bt <-
59 case iiBuildTools ii of
60 Left s -> error $ "Could not topologically sort build tools: " ++ s
61 Right x -> return x
63 return BuildPlan
64 { bpTools = bt
65 , bpPackages = iiPackages ii
66 , bpOptionalCore = iiOptionalCore ii
67 , bpCore = iiCore ii
68 , bpSkippedTests = skippedTests settings'
69 }
71-- | Get all of the build tools required.
72iiBuildTools :: InstallInfo -> Either String [String]
73iiBuildTools InstallInfo { iiPackageDB = PackageDB m, iiPackages = packages } =
74 fmap (map packageVersionString)
75 $ topSort
76 $ map addDependencies
77 $ filter (flip Set.notMember coreTools . fst)
78 $ Set.toList
79 $ Set.fromList
80 $ mapMaybe (flip Map.lookup buildToolMap)
81 $ Set.toList
82 $ Set.unions
83 $ map piBuildToolsAll
84 $ Map.elems
85 $ Map.filterWithKey isSelected m
86 where
87 isSelected name _ = name `Set.member` selected
88 selected = Set.fromList $ Map.keys packages
90 -- Build tools shipped with GHC which we should not attempt to build
91 -- ourselves.
92 coreTools = Set.fromList $ map PackageName $ words "hsc2hs"
94 -- The map from build tool name to the package it comes from.
95 buildToolMap :: Map Executable (PackageName, Version)
96 buildToolMap = Map.unions $ map toBuildToolMap $ Map.toList m
98 toBuildToolMap :: (PackageName, PackageInfo) -> Map Executable (PackageName, Version)
99 toBuildToolMap (pn, pi) = Map.unions
100 $ map (flip Map.singleton (pn, piVersion pi))
101 $ Set.toList
102 $ piExecs pi
104 addDependencies :: (PackageName, Version) -> ((PackageName, Version), Set (PackageName, Version))
105 addDependencies (pn, pv) =
106 ((pn, pv), deps)
107 where
108 deps =
109 case Map.lookup pn m of
110 Nothing -> Set.empty
111 Just pi -> Set.fromList
112 $ mapMaybe (flip Map.lookup buildToolMap)
113 $ Set.toList
114 $ piBuildToolsExe pi
116topSort :: (Show a, Ord a) => [(a, Set a)] -> Either String [a]
117topSort orig =
118 uncurry go . partitionEithers . map (splitter . limitDeps) $ orig
119 where
120 splitter (x, y)
121 | Set.null y = Left x
122 | otherwise = Right (x, y)
124 go x [] = Right x
125 go [] y = Left $ "The following form a cycle: " ++ show (map fst y)
126 go (x:xs) ys = do
127 let (xs', ys') = partitionEithers $ map (splitter . dropDep x) ys
128 rest <- go (xs ++ xs') ys'
129 return $ x : rest
131 dropDep x (y, z) = (y, Set.delete x z)
133 allVertices = Set.fromList $ map fst orig
134 limitDeps (x, y) = (x, Set.intersection allVertices y)