git.iko.soy/stackage
on fffb035 help sign in
stackage/Stackage/Select.hs
129 lines 4.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 -> 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 (if version >= GhcMajorVersion 7 6 then Set.empty else Set.fromList (words "old-time"))
35 `Set.union`
36#endif
37 -- Support for containers-unicode-symbols
38 (case Map.lookup (PackageName "containers") coreMap of
39 Just v | Just range <- simpleParse "< 0.5", v `withinRange` range
40 -> Set.singleton "containers-old"
41 _ -> Set.empty)
42 , disabledFlags = Set.fromList $ words "bytestring-in-base"
43 , allowedPackage = const $ Right ()
44 , useGlobalDatabase = False
45 , skippedTests = empty
46 , selectGhcVersion = version
47 }
49select :: SelectSettings -> IO BuildPlan
50select settings' = do
51 ii <- getInstallInfo settings'
53 bt <-
54 case iiBuildTools ii of
55 Left s -> error $ "Could not topologically sort build tools: " ++ s
56 Right x -> return x
58 return BuildPlan
59 { bpTools = bt
60 , bpPackages = iiPackages ii
61 , bpOptionalCore = iiOptionalCore ii
62 , bpCore = iiCore ii
63 , bpSkippedTests = skippedTests settings'
64 }
66-- | Get all of the build tools required.
67iiBuildTools :: InstallInfo -> Either String [String]
68iiBuildTools InstallInfo { iiPackageDB = PackageDB m, iiPackages = packages } =
69 fmap (map packageVersionString)
70 $ topSort
71 $ map addDependencies
72 $ filter (flip Set.notMember coreTools . fst)
73 $ Set.toList
74 $ Set.fromList
75 $ mapMaybe (flip Map.lookup buildToolMap)
76 $ Set.toList
77 $ Set.unions
78 $ map piBuildTools
79 $ Map.elems
80 $ Map.filterWithKey isSelected m
81 where
82 isSelected name _ = name `Set.member` selected
83 selected = Set.fromList $ Map.keys packages
85 -- Build tools shipped with GHC which we should not attempt to build
86 -- ourselves.
87 coreTools = Set.fromList $ map PackageName $ words "hsc2hs"
89 -- The map from build tool name to the package it comes from.
90 buildToolMap :: Map Executable (PackageName, Version)
91 buildToolMap = Map.unions $ map toBuildToolMap $ Map.toList m
93 toBuildToolMap :: (PackageName, PackageInfo) -> Map Executable (PackageName, Version)
94 toBuildToolMap (pn, pi) = Map.unions
95 $ map (flip Map.singleton (pn, piVersion pi))
96 $ Set.toList
97 $ piExecs pi
99 addDependencies :: (PackageName, Version) -> ((PackageName, Version), Set (PackageName, Version))
100 addDependencies (pn, pv) =
101 ((pn, pv), deps)
102 where
103 deps =
104 case Map.lookup pn m of
105 Nothing -> Set.empty
106 Just pi -> Set.fromList
107 $ mapMaybe (flip Map.lookup buildToolMap)
108 $ Set.toList
109 $ piBuildTools pi
111topSort :: (Show a, Ord a) => [(a, Set a)] -> Either String [a]
112topSort orig =
113 uncurry go . partitionEithers . map (splitter . limitDeps) $ orig
114 where
115 splitter (x, y)
116 | Set.null y = Left x
117 | otherwise = Right (x, y)
119 go x [] = Right x
120 go [] y = Left $ "The following form a cycle: " ++ show (map fst y)
121 go (x:xs) ys = do
122 let (xs', ys') = partitionEithers $ map (splitter . dropDep x) ys
123 rest <- go (xs ++ xs') ys'
124 return $ x : rest
126 dropDep x (y, z) = (y, Set.delete x z)
128 allVertices = Set.fromList $ map fst orig
129 limitDeps (x, y) = (x, Set.intersection allVertices y)