git.iko.soy/stackage
on 7eac8e2 help sign in
stackage/Stackage/Select.hs
173 lines 6.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
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 new-base") `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 {-
47 -- Support for network 2.6
48 (if version >= GhcMajorVersion 7 8 && not requireHP
49 then Set.singleton "network-uri"
50 else Set.empty)
51 -}
52 Set.empty
53 , disabledFlags = Set.fromList (words "bytestring-in-base test-hlint")
54 `Set.union`
55 (if version <= GhcMajorVersion 7 4
56 then Set.singleton "bytestring-builder"
57 else Set.empty)
59 -- SHA and binary
61 `Set.union`
62 (if version <= GhcMajorVersion 7 6
63 then Set.singleton "decoderinterface"
64 else Set.empty) `Set.union`
66 {-
67 -- Support for network 2.6
68 (if version >= GhcMajorVersion 7 8 && not requireHP
69 then Set.empty
70 else Set.singleton "network-uri")
71 -}
72 Set.singleton "network-uri"
73 , allowedPackage = const $ Right ()
74 , useGlobalDatabase = False
75 , skippedTests =
76 Set.insert (PackageName "ReadArgs") $ -- old version of hspec
77 Set.insert (PackageName "ersatz") $ -- old QuickCheck
78 if version >= GhcMajorVersion 7 8
79 then Set.fromList
80 [ PackageName "punycode" -- pulls in encoding
81 ]
82 else Set.empty
83 , selectGhcVersion = version
84 , selectTarballDir = "patching/tarballs"
85 , selectUnderlayPackageDirs = []
86 }
88select :: SelectSettings -> IO BuildPlan
89select settings' = do
90 ii <- getInstallInfo settings'
92 bt <-
93 case iiBuildTools ii of
94 Left s -> error $ "Could not topologically sort build tools: " ++ s
95 Right x -> return x
97 return BuildPlan
98 { bpTools = bt
99 , bpPackages = iiPackages ii
100 , bpOptionalCore = iiOptionalCore ii
101 , bpCore = iiCore ii
102 , bpSkippedTests = skippedTests settings'
103 , bpExpectedFailures = expectedFailures settings'
104 }
106-- | Get all of the build tools required.
107iiBuildTools :: InstallInfo -> Either String [String]
108iiBuildTools InstallInfo { iiPackageDB = PackageDB m, iiPackages = packages } =
109 fmap (map packageVersionString)
110 $ topSort
111 $ map addDependencies
112 $ filter (flip Set.notMember coreTools . fst)
113 $ Set.toList
114 $ Set.fromList
115 $ mapMaybe (flip Map.lookup buildToolMap)
116 $ Set.toList
117 $ Set.unions
118 $ map piBuildToolsAll
119 $ Map.elems
120 $ Map.filterWithKey isSelected m
121 where
122 isSelected name _ = name `Set.member` selected
123 selected = Set.fromList $ Map.keys packages
125 -- Build tools shipped with GHC which we should not attempt to build
126 -- ourselves.
127 coreTools = Set.fromList $ map PackageName $ words "hsc2hs"
129 -- The map from build tool name to the package it comes from.
130 buildToolMap :: Map Executable (PackageName, Version)
131 buildToolMap = Map.unions $ map toBuildToolMap $ Map.toList m
133 toBuildToolMap :: (PackageName, PackageInfo) -> Map Executable (PackageName, Version)
134 toBuildToolMap (pn, pi) = Map.unions
135 $ map (flip Map.singleton (pn, piVersion pi))
136 $ Set.toList
137 $ piExecs pi
139 addDependencies :: (PackageName, Version) -> ((PackageName, Version), Set (PackageName, Version))
140 addDependencies (pn, pv) =
141 ((pn, pv), deps)
142 where
143 deps =
144 case Map.lookup pn m of
145 Nothing -> Set.empty
146 Just pi -> Set.fromList
147 $ mapMaybe (flip Map.lookup buildToolMap)
148 $ Set.toList
149 $ piBuildToolsExe pi `Set.union` manualDeps
151 manualDeps
152 | pn == PackageName "c2hs" = Set.singleton $ Executable "happy"
153 | otherwise = Set.empty
155topSort :: (Show a, Ord a) => [(a, Set a)] -> Either String [a]
156topSort orig =
157 uncurry go . partitionEithers . map (splitter . limitDeps) $ orig
158 where
159 splitter (x, y)
160 | Set.null y = Left x
161 | otherwise = Right (x, y)
163 go x [] = Right x
164 go [] y = Left $ "The following form a cycle: " ++ show (map fst y)
165 go (x:xs) ys = do
166 let (xs', ys') = partitionEithers $ map (splitter . dropDep x) ys
167 rest <- go (xs ++ xs') ys'
168 return $ x : rest
170 dropDep x (y, z) = (y, Set.delete x z)
172 allVertices = Set.fromList $ map fst orig
173 limitDeps (x, y) = (x, Set.intersection allVertices y)