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