git.iko.soy/stackage
on c95bf43 help sign in
stackage/Stackage/Select.hs
167 lines 6.1 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
22 -> Bool -- ^ haskell platform?
23 -> SelectSettings
24defaultSelectSettings version requireHP = SelectSettings
25 { extraCore = defaultExtraCore version
26 , expectedFailures = defaultExpectedFailures version requireHP
27 , stablePackages = defaultStablePackages version
28 , haskellPlatformDir = "hp"
29 , requireHaskellPlatform = requireHP
30 , ignoreUpgradeableCore = False
31 , excludedPackages = empty
32 , flags = \coreMap ->
33 Set.fromList (words "blaze_html_0_5 small_base https splitbase old-locale") `Set.union`
35#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
36 -- Needed on Windows to get unix-compat to compile
37 (if version >= GhcMajorVersion 7 6 then Set.empty else Set.fromList (words "old-time"))
38 `Set.union`
39#endif
40 -- Support for containers-unicode-symbols
41 (case Map.lookup (PackageName "containers") coreMap of
42 Just v | Just range <- simpleParse "< 0.5", v `withinRange` range
43 -> Set.singleton "containers-old"
44 _ -> Set.empty) `Set.union`
46 -- Support for network 2.6
47 (if version >= GhcMajorVersion 7 8 && not requireHP
48 then Set.singleton "network-uri"
49 else Set.empty)
50 , disabledFlags = Set.fromList (words "bytestring-in-base test-hlint")
51 `Set.union`
52 (if version <= GhcMajorVersion 7 4
53 then Set.singleton "bytestring-builder"
54 else Set.empty)
56 -- SHA and binary
58 `Set.union`
59 (if version <= GhcMajorVersion 7 6
60 then Set.singleton "decoderinterface"
61 else Set.empty) `Set.union`
63 -- Support for network 2.6
64 (if version >= GhcMajorVersion 7 8 && not requireHP
65 then Set.empty
66 else Set.singleton "network-uri")
67 , allowedPackage = const $ Right ()
68 , useGlobalDatabase = False
69 , skippedTests =
70 Set.insert (PackageName "ReadArgs") $ -- old version of hspec
71 if version >= GhcMajorVersion 7 8
72 then Set.fromList
73 [ PackageName "punycode" -- pulls in encoding
74 , PackageName "ersatz" -- old QuickCheck
75 ]
76 else Set.empty
77 , selectGhcVersion = version
78 , selectTarballDir = "patching/tarballs"
79 , selectUnderlayPackageDirs = []
80 }
82select :: SelectSettings -> IO BuildPlan
83select settings' = do
84 ii <- getInstallInfo settings'
86 bt <-
87 case iiBuildTools ii of
88 Left s -> error $ "Could not topologically sort build tools: " ++ s
89 Right x -> return x
91 return BuildPlan
92 { bpTools = bt
93 , bpPackages = iiPackages ii
94 , bpOptionalCore = iiOptionalCore ii
95 , bpCore = iiCore ii
96 , bpSkippedTests = skippedTests settings'
97 , bpExpectedFailures = expectedFailures settings'
98 }
100-- | Get all of the build tools required.
101iiBuildTools :: InstallInfo -> Either String [String]
102iiBuildTools InstallInfo { iiPackageDB = PackageDB m, iiPackages = packages } =
103 fmap (map packageVersionString)
104 $ topSort
105 $ map addDependencies
106 $ filter (flip Set.notMember coreTools . fst)
107 $ Set.toList
108 $ Set.fromList
109 $ mapMaybe (flip Map.lookup buildToolMap)
110 $ Set.toList
111 $ Set.unions
112 $ map piBuildToolsAll
113 $ Map.elems
114 $ Map.filterWithKey isSelected m
115 where
116 isSelected name _ = name `Set.member` selected
117 selected = Set.fromList $ Map.keys packages
119 -- Build tools shipped with GHC which we should not attempt to build
120 -- ourselves.
121 coreTools = Set.fromList $ map PackageName $ words "hsc2hs"
123 -- The map from build tool name to the package it comes from.
124 buildToolMap :: Map Executable (PackageName, Version)
125 buildToolMap = Map.unions $ map toBuildToolMap $ Map.toList m
127 toBuildToolMap :: (PackageName, PackageInfo) -> Map Executable (PackageName, Version)
128 toBuildToolMap (pn, pi) = Map.unions
129 $ map (flip Map.singleton (pn, piVersion pi))
130 $ Set.toList
131 $ piExecs pi
133 addDependencies :: (PackageName, Version) -> ((PackageName, Version), Set (PackageName, Version))
134 addDependencies (pn, pv) =
135 ((pn, pv), deps)
136 where
137 deps =
138 case Map.lookup pn m of
139 Nothing -> Set.empty
140 Just pi -> Set.fromList
141 $ mapMaybe (flip Map.lookup buildToolMap)
142 $ Set.toList
143 $ piBuildToolsExe pi `Set.union` manualDeps
145 manualDeps
146 | pn == PackageName "c2hs" = Set.singleton $ Executable "happy"
147 | otherwise = Set.empty
149topSort :: (Show a, Ord a) => [(a, Set a)] -> Either String [a]
150topSort orig =
151 uncurry go . partitionEithers . map (splitter . limitDeps) $ orig
152 where
153 splitter (x, y)
154 | Set.null y = Left x
155 | otherwise = Right (x, y)
157 go x [] = Right x
158 go [] y = Left $ "The following form a cycle: " ++ show (map fst y)
159 go (x:xs) ys = do
160 let (xs', ys') = partitionEithers $ map (splitter . dropDep x) ys
161 rest <- go (xs ++ xs') ys'
162 return $ x : rest
164 dropDep x (y, z) = (y, Set.delete x z)
166 allVertices = Set.fromList $ map fst orig
167 limitDeps (x, y) = (x, Set.intersection allVertices y)