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