git.iko.soy/stackage
on 283a4cc help sign in
stackage/Stackage/Select.hs
128 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 :: GhcMajorVersion -> SelectSettings
22defaultSelectSettings version = SelectSettings
23 { extraCore = defaultExtraCore version
24 , expectedFailuresSelect = defaultExpectedFailures version
25 , stablePackages = defaultStablePackages version
26 , haskellPlatformDir = "hp"
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 , selectGhcVersion = version
46 }
48select :: SelectSettings -> IO BuildPlan
49select settings' = do
50 ii <- getInstallInfo settings'
52 bt <-
53 case iiBuildTools ii of
54 Left s -> error $ "Could not topologically sort build tools: " ++ s
55 Right x -> return x
57 return BuildPlan
58 { bpTools = bt
59 , bpPackages = iiPackages ii
60 , bpOptionalCore = iiOptionalCore ii
61 , bpCore = iiCore ii
62 , bpSkippedTests = skippedTests settings'
63 }
65-- | Get all of the build tools required.
66iiBuildTools :: InstallInfo -> Either String [String]
67iiBuildTools InstallInfo { iiPackageDB = PackageDB m, iiPackages = packages } =
68 fmap (map packageVersionString)
69 $ topSort
70 $ map addDependencies
71 $ filter (flip Set.notMember coreTools . fst)
72 $ Set.toList
73 $ Set.fromList
74 $ mapMaybe (flip Map.lookup buildToolMap)
75 $ Set.toList
76 $ Set.unions
77 $ map piBuildTools
78 $ Map.elems
79 $ Map.filterWithKey isSelected m
80 where
81 isSelected name _ = name `Set.member` selected
82 selected = Set.fromList $ Map.keys packages
84 -- Build tools shipped with GHC which we should not attempt to build
85 -- ourselves.
86 coreTools = Set.fromList $ map PackageName $ words "hsc2hs"
88 -- The map from build tool name to the package it comes from.
89 buildToolMap :: Map Executable (PackageName, Version)
90 buildToolMap = Map.unions $ map toBuildToolMap $ Map.toList m
92 toBuildToolMap :: (PackageName, PackageInfo) -> Map Executable (PackageName, Version)
93 toBuildToolMap (pn, pi) = Map.unions
94 $ map (flip Map.singleton (pn, piVersion pi))
95 $ Set.toList
96 $ piExecs pi
98 addDependencies :: (PackageName, Version) -> ((PackageName, Version), Set (PackageName, Version))
99 addDependencies (pn, pv) =
100 ((pn, pv), deps)
101 where
102 deps =
103 case Map.lookup pn m of
104 Nothing -> Set.empty
105 Just pi -> Set.fromList
106 $ mapMaybe (flip Map.lookup buildToolMap)
107 $ Set.toList
108 $ piBuildTools pi
110topSort :: (Show a, Ord a) => [(a, Set a)] -> Either String [a]
111topSort orig =
112 uncurry go . partitionEithers . map (splitter . limitDeps) $ orig
113 where
114 splitter (x, y)
115 | Set.null y = Left x
116 | otherwise = Right (x, y)
118 go x [] = Right x
119 go [] y = Left $ "The following form a cycle: " ++ show (map fst y)
120 go (x:xs) ys = do
121 let (xs', ys') = partitionEithers $ map (splitter . dropDep x) ys
122 rest <- go (xs ++ xs') ys'
123 return $ x : rest
125 dropDep x (y, z) = (y, Set.delete x z)
127 allVertices = Set.fromList $ map fst orig
128 limitDeps (x, y) = (x, Set.intersection allVertices y)