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