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