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