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