git.iko.soy/stackage
on a665487 help sign in
stackage/Stackage/Select.hs
152 lines 5.4 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 https splitbase old-locale") `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.fromList
60 [ PackageName "punycode" -- pulls in encoding
61 ]
62 else Set.empty
63 , selectGhcVersion = version
64 , selectTarballDir = "patching/tarballs"
65 , selectUnderlayPackageDirs = []
66 }
68select :: SelectSettings -> IO BuildPlan
69select settings' = do
70 ii <- getInstallInfo settings'
72 bt <-
73 case iiBuildTools ii of
74 Left s -> error $ "Could not topologically sort build tools: " ++ s
75 Right x -> return x
77 return BuildPlan
78 { bpTools = bt
79 , bpPackages = iiPackages ii
80 , bpOptionalCore = iiOptionalCore ii
81 , bpCore = iiCore ii
82 , bpSkippedTests = skippedTests settings'
83 }
85-- | Get all of the build tools required.
86iiBuildTools :: InstallInfo -> Either String [String]
87iiBuildTools InstallInfo { iiPackageDB = PackageDB m, iiPackages = packages } =
88 fmap (map packageVersionString)
89 $ topSort
90 $ map addDependencies
91 $ filter (flip Set.notMember coreTools . fst)
92 $ Set.toList
93 $ Set.fromList
94 $ mapMaybe (flip Map.lookup buildToolMap)
95 $ Set.toList
96 $ Set.unions
97 $ map piBuildToolsAll
98 $ Map.elems
99 $ Map.filterWithKey isSelected m
100 where
101 isSelected name _ = name `Set.member` selected
102 selected = Set.fromList $ Map.keys packages
104 -- Build tools shipped with GHC which we should not attempt to build
105 -- ourselves.
106 coreTools = Set.fromList $ map PackageName $ words "hsc2hs"
108 -- The map from build tool name to the package it comes from.
109 buildToolMap :: Map Executable (PackageName, Version)
110 buildToolMap = Map.unions $ map toBuildToolMap $ Map.toList m
112 toBuildToolMap :: (PackageName, PackageInfo) -> Map Executable (PackageName, Version)
113 toBuildToolMap (pn, pi) = Map.unions
114 $ map (flip Map.singleton (pn, piVersion pi))
115 $ Set.toList
116 $ piExecs pi
118 addDependencies :: (PackageName, Version) -> ((PackageName, Version), Set (PackageName, Version))
119 addDependencies (pn, pv) =
120 ((pn, pv), deps)
121 where
122 deps =
123 case Map.lookup pn m of
124 Nothing -> Set.empty
125 Just pi -> Set.fromList
126 $ mapMaybe (flip Map.lookup buildToolMap)
127 $ Set.toList
128 $ piBuildToolsExe pi `Set.union` manualDeps
130 manualDeps
131 | pn == PackageName "c2hs" = Set.singleton $ Executable "happy"
132 | otherwise = Set.empty
134topSort :: (Show a, Ord a) => [(a, Set a)] -> Either String [a]
135topSort orig =
136 uncurry go . partitionEithers . map (splitter . limitDeps) $ orig
137 where
138 splitter (x, y)
139 | Set.null y = Left x
140 | otherwise = Right (x, y)
142 go x [] = Right x
143 go [] y = Left $ "The following form a cycle: " ++ show (map fst y)
144 go (x:xs) ys = do
145 let (xs', ys') = partitionEithers $ map (splitter . dropDep x) ys
146 rest <- go (xs ++ xs') ys'
147 return $ x : rest
149 dropDep x (y, z) = (y, Set.delete x z)
151 allVertices = Set.fromList $ map fst orig
152 limitDeps (x, y) = (x, Set.intersection allVertices y)