git.iko.soy/stackage
on 243ee6b help sign in
stackage/Stackage/Select.hs
146 lines 5.2 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 network-uri")
44 `Set.union`
45 (if version <= GhcMajorVersion 7 4
46 then Set.singleton "bytestring-builder"
47 else Set.empty)
49 -- SHA and binary
51 `Set.union`
52 (if version <= GhcMajorVersion 7 6
53 then Set.singleton "decoderinterface"
54 else Set.empty)
55 , allowedPackage = const $ Right ()
56 , useGlobalDatabase = False
57 , skippedTests =
58 if version >= GhcMajorVersion 7 8
59 then Set.singleton (PackageName "punycode") -- pulls in encoding
60 else Set.empty
61 , selectGhcVersion = version
62 , selectTarballDir = "patching/tarballs"
63 , selectUnderlayPackageDirs = []
64 }
66select :: SelectSettings -> IO BuildPlan
67select settings' = do
68 ii <- getInstallInfo settings'
70 bt <-
71 case iiBuildTools ii of
72 Left s -> error $ "Could not topologically sort build tools: " ++ s
73 Right x -> return x
75 return BuildPlan
76 { bpTools = bt
77 , bpPackages = iiPackages ii
78 , bpOptionalCore = iiOptionalCore ii
79 , bpCore = iiCore ii
80 , bpSkippedTests = skippedTests settings'
81 }
83-- | Get all of the build tools required.
84iiBuildTools :: InstallInfo -> Either String [String]
85iiBuildTools InstallInfo { iiPackageDB = PackageDB m, iiPackages = packages } =
86 fmap (map packageVersionString)
87 $ topSort
88 $ map addDependencies
89 $ filter (flip Set.notMember coreTools . fst)
90 $ Set.toList
91 $ Set.fromList
92 $ mapMaybe (flip Map.lookup buildToolMap)
93 $ Set.toList
94 $ Set.unions
95 $ map piBuildToolsAll
96 $ Map.elems
97 $ Map.filterWithKey isSelected m
98 where
99 isSelected name _ = name `Set.member` selected
100 selected = Set.fromList $ Map.keys packages
102 -- Build tools shipped with GHC which we should not attempt to build
103 -- ourselves.
104 coreTools = Set.fromList $ map PackageName $ words "hsc2hs"
106 -- The map from build tool name to the package it comes from.
107 buildToolMap :: Map Executable (PackageName, Version)
108 buildToolMap = Map.unions $ map toBuildToolMap $ Map.toList m
110 toBuildToolMap :: (PackageName, PackageInfo) -> Map Executable (PackageName, Version)
111 toBuildToolMap (pn, pi) = Map.unions
112 $ map (flip Map.singleton (pn, piVersion pi))
113 $ Set.toList
114 $ piExecs pi
116 addDependencies :: (PackageName, Version) -> ((PackageName, Version), Set (PackageName, Version))
117 addDependencies (pn, pv) =
118 ((pn, pv), deps)
119 where
120 deps =
121 case Map.lookup pn m of
122 Nothing -> Set.empty
123 Just pi -> Set.fromList
124 $ mapMaybe (flip Map.lookup buildToolMap)
125 $ Set.toList
126 $ piBuildToolsExe pi
128topSort :: (Show a, Ord a) => [(a, Set a)] -> Either String [a]
129topSort orig =
130 uncurry go . partitionEithers . map (splitter . limitDeps) $ orig
131 where
132 splitter (x, y)
133 | Set.null y = Left x
134 | otherwise = Right (x, y)
136 go x [] = Right x
137 go [] y = Left $ "The following form a cycle: " ++ show (map fst y)
138 go (x:xs) ys = do
139 let (xs', ys') = partitionEithers $ map (splitter . dropDep x) ys
140 rest <- go (xs ++ xs') ys'
141 return $ x : rest
143 dropDep x (y, z) = (y, Set.delete x z)
145 allVertices = Set.fromList $ map fst orig
146 limitDeps (x, y) = (x, Set.intersection allVertices y)