git.iko.soy/stackage
on 02809df help sign in
stackage/Stackage/Select.hs
127 lines 4.5 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 :: SelectSettings
22defaultSelectSettings = SelectSettings
23 { extraCore = defaultExtraCore
24 , expectedFailuresSelect = defaultExpectedFailures
25 , stablePackages = defaultStablePackages
26 , haskellPlatformCabal = "haskell-platform/haskell-platform.cabal"
27 , requireHaskellPlatform = True
28 , excludedPackages = empty
29 , flags = \coreMap ->
30 Set.fromList (words "blaze_html_0_5 small_base") `Set.union`
32#if defined(mingw32_HOST_OS) || defined(__MINGW32__)
33 -- Needed on Windows to get unix-compat to compile
34 Set.fromList (words "old-time") `Set.union`
35#endif
36 -- Support for containers-unicode-symbols
37 (case Map.lookup (PackageName "containers") coreMap of
38 Just v | Just range <- simpleParse "< 0.5", v `withinRange` range
39 -> Set.singleton "containers-old"
40 _ -> Set.empty)
41 , disabledFlags = Set.fromList $ words "bytestring-in-base"
42 , allowedPackage = const $ Right ()
43 , useGlobalDatabase = False
44 , skippedTests = empty
45 }
47select :: SelectSettings -> IO BuildPlan
48select settings' = do
49 ii <- getInstallInfo settings'
51 bt <-
52 case iiBuildTools ii of
53 Left s -> error $ "Could not topologically sort build tools: " ++ s
54 Right x -> return x
56 return BuildPlan
57 { bpTools = bt
58 , bpPackages = iiPackages ii
59 , bpOptionalCore = iiOptionalCore ii
60 , bpCore = iiCore ii
61 , bpSkippedTests = skippedTests settings'
62 }
64-- | Get all of the build tools required.
65iiBuildTools :: InstallInfo -> Either String [String]
66iiBuildTools InstallInfo { iiPackageDB = PackageDB m, iiPackages = packages } =
67 fmap (map packageVersionString)
68 $ topSort
69 $ map addDependencies
70 $ filter (flip Set.notMember coreTools . fst)
71 $ Set.toList
72 $ Set.fromList
73 $ mapMaybe (flip Map.lookup buildToolMap)
74 $ Set.toList
75 $ Set.unions
76 $ map piBuildTools
77 $ Map.elems
78 $ Map.filterWithKey isSelected m
79 where
80 isSelected name _ = name `Set.member` selected
81 selected = Set.fromList $ Map.keys packages
83 -- Build tools shipped with GHC which we should not attempt to build
84 -- ourselves.
85 coreTools = Set.fromList $ map PackageName $ words "hsc2hs"
87 -- The map from build tool name to the package it comes from.
88 buildToolMap :: Map Executable (PackageName, Version)
89 buildToolMap = Map.unions $ map toBuildToolMap $ Map.toList m
91 toBuildToolMap :: (PackageName, PackageInfo) -> Map Executable (PackageName, Version)
92 toBuildToolMap (pn, pi) = Map.unions
93 $ map (flip Map.singleton (pn, piVersion pi))
94 $ Set.toList
95 $ piExecs pi
97 addDependencies :: (PackageName, Version) -> ((PackageName, Version), Set (PackageName, Version))
98 addDependencies (pn, pv) =
99 ((pn, pv), deps)
100 where
101 deps =
102 case Map.lookup pn m of
103 Nothing -> Set.empty
104 Just pi -> Set.fromList
105 $ mapMaybe (flip Map.lookup buildToolMap)
106 $ Set.toList
107 $ piBuildTools pi
109topSort :: (Show a, Ord a) => [(a, Set a)] -> Either String [a]
110topSort orig =
111 uncurry go . partitionEithers . map (splitter . limitDeps) $ orig
112 where
113 splitter (x, y)
114 | Set.null y = Left x
115 | otherwise = Right (x, y)
117 go x [] = Right x
118 go [] y = Left $ "The following form a cycle: " ++ show (map fst y)
119 go (x:xs) ys = do
120 let (xs', ys') = partitionEithers $ map (splitter . dropDep x) ys
121 rest <- go (xs ++ xs') ys'
122 return $ x : rest
124 dropDep x (y, z) = (y, Set.delete x z)
126 allVertices = Set.fromList $ map fst orig
127 limitDeps (x, y) = (x, Set.intersection allVertices y)