git.iko.soy/stackage
on 2adf607 help sign in
stackage/Stackage/Select.hs
131 lines 4.7 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"
44 , allowedPackage = const $ Right ()
45 , useGlobalDatabase = False
46 , skippedTests = empty
47 , selectGhcVersion = version
48 , selectTarballDir = "patching/tarballs"
49 }
51select :: SelectSettings -> IO BuildPlan
52select settings' = do
53 ii <- getInstallInfo settings'
55 bt <-
56 case iiBuildTools ii of
57 Left s -> error $ "Could not topologically sort build tools: " ++ s
58 Right x -> return x
60 return BuildPlan
61 { bpTools = bt
62 , bpPackages = iiPackages ii
63 , bpOptionalCore = iiOptionalCore ii
64 , bpCore = iiCore ii
65 , bpSkippedTests = skippedTests settings'
66 }
68-- | Get all of the build tools required.
69iiBuildTools :: InstallInfo -> Either String [String]
70iiBuildTools InstallInfo { iiPackageDB = PackageDB m, iiPackages = packages } =
71 fmap (map packageVersionString)
72 $ topSort
73 $ map addDependencies
74 $ filter (flip Set.notMember coreTools . fst)
75 $ Set.toList
76 $ Set.fromList
77 $ mapMaybe (flip Map.lookup buildToolMap)
78 $ Set.toList
79 $ Set.unions
80 $ map piBuildToolsAll
81 $ Map.elems
82 $ Map.filterWithKey isSelected m
83 where
84 isSelected name _ = name `Set.member` selected
85 selected = Set.fromList $ Map.keys packages
87 -- Build tools shipped with GHC which we should not attempt to build
88 -- ourselves.
89 coreTools = Set.fromList $ map PackageName $ words "hsc2hs"
91 -- The map from build tool name to the package it comes from.
92 buildToolMap :: Map Executable (PackageName, Version)
93 buildToolMap = Map.unions $ map toBuildToolMap $ Map.toList m
95 toBuildToolMap :: (PackageName, PackageInfo) -> Map Executable (PackageName, Version)
96 toBuildToolMap (pn, pi) = Map.unions
97 $ map (flip Map.singleton (pn, piVersion pi))
98 $ Set.toList
99 $ piExecs pi
101 addDependencies :: (PackageName, Version) -> ((PackageName, Version), Set (PackageName, Version))
102 addDependencies (pn, pv) =
103 ((pn, pv), deps)
104 where
105 deps =
106 case Map.lookup pn m of
107 Nothing -> Set.empty
108 Just pi -> Set.fromList
109 $ mapMaybe (flip Map.lookup buildToolMap)
110 $ Set.toList
111 $ piBuildToolsExe pi
113topSort :: (Show a, Ord a) => [(a, Set a)] -> Either String [a]
114topSort orig =
115 uncurry go . partitionEithers . map (splitter . limitDeps) $ orig
116 where
117 splitter (x, y)
118 | Set.null y = Left x
119 | otherwise = Right (x, y)
121 go x [] = Right x
122 go [] y = Left $ "The following form a cycle: " ++ show (map fst y)
123 go (x:xs) ys = do
124 let (xs', ys') = partitionEithers $ map (splitter . dropDep x) ys
125 rest <- go (xs ++ xs') ys'
126 return $ x : rest
128 dropDep x (y, z) = (y, Set.delete x z)
130 allVertices = Set.fromList $ map fst orig
131 limitDeps (x, y) = (x, Set.intersection allVertices y)