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