git.iko.soy/stackage
on 32dbaa4 help sign in
stackage/Stackage/BuildPlan.hs
214 lines 8.0 kB history raw
1{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE DeriveFoldable #-}
3{-# LANGUAGE DeriveFunctor #-}
4{-# LANGUAGE DeriveTraversable #-}
5{-# LANGUAGE NoImplicitPrelude #-}
6{-# LANGUAGE OverloadedStrings #-}
7{-# LANGUAGE RecordWildCards #-}
8{-# LANGUAGE TupleSections #-}
9{-# LANGUAGE TypeFamilies #-}
10-- | Representation of a concrete build plan, and how to generate a new one
11-- based on constraints.
12module Stackage.BuildPlan
13 ( BuildPlan (..)
14 , PackagePlan (..)
15 , newBuildPlan
16 , makeToolMap
17 , getLatestAllowedPlans
18 ) where
20import Control.Monad.State.Strict (execState, get, put)
21import Data.Aeson
22import qualified Data.Map as Map
23import qualified Data.Set as Set
24import qualified Distribution.Compiler
25import Distribution.PackageDescription
26import Stackage.BuildConstraints
27import Stackage.GithubPings
28import Stackage.PackageDescription
29import Stackage.PackageIndex
30import Stackage.Prelude
32data BuildPlan = BuildPlan
33 { bpSystemInfo :: SystemInfo
34 , bpTools :: Vector (PackageName, Version)
35 , bpPackages :: Map PackageName PackagePlan
36 , bpGithubUsers :: Map Text (Set Text)
37 }
38 deriving (Show, Eq)
40instance ToJSON BuildPlan where
41 toJSON BuildPlan {..} = object
42 [ "system-info" .= bpSystemInfo
43 , "tools" .= map goTool bpTools
44 , "packages" .= Map.mapKeysWith const unPackageName bpPackages
45 , "github-users" .= bpGithubUsers
46 ]
47 where
48 goTool (k, v) = object
49 [ "name" .= display k
50 , "version" .= display v
51 ]
52instance FromJSON BuildPlan where
53 parseJSON = withObject "BuildPlan" $ \o -> do
54 bpSystemInfo <- o .: "system-info"
55 bpTools <- (o .: "tools") >>= mapM goTool
56 bpPackages <- Map.mapKeysWith const mkPackageName <$> (o .: "packages")
57 bpGithubUsers <- o .:? "github-users" .!= mempty
58 return BuildPlan {..}
59 where
60 goTool = withObject "Tool" $ \o -> (,)
61 <$> ((o .: "name") >>=
62 either (fail . show) return . simpleParse . asText)
63 <*> ((o .: "version") >>=
64 either (fail . show) return . simpleParse . asText)
66data PackagePlan = PackagePlan
67 { ppVersion :: Version
68 , ppGithubPings :: Set Text
69 , ppUsers :: Set PackageName
70 , ppConstraints :: PackageConstraints
71 , ppDesc :: SimpleDesc
72 }
73 deriving (Show, Eq)
75instance ToJSON PackagePlan where
76 toJSON PackagePlan {..} = object
77 [ "version" .= asText (display ppVersion)
78 , "github-pings" .= ppGithubPings
79 , "users" .= map unPackageName (unpack ppUsers)
80 , "constraints" .= ppConstraints
81 , "description" .= ppDesc
82 ]
83instance FromJSON PackagePlan where
84 parseJSON = withObject "PackageBuild" $ \o -> do
85 ppVersion <- o .: "version"
86 >>= either (fail . show) return
87 . simpleParse . asText
88 ppGithubPings <- o .:? "github-pings" .!= mempty
89 ppUsers <- Set.map PackageName <$> (o .:? "users" .!= mempty)
90 ppConstraints <- o .: "constraints"
91 ppDesc <- o .: "description"
92 return PackagePlan {..}
94-- | Make a build plan given these package set and build constraints.
95newBuildPlan :: MonadIO m => Map PackageName PackagePlan -> BuildConstraints -> m BuildPlan
96newBuildPlan packagesOrig bc@BuildConstraints {..} = liftIO $ do
97 let toolMap = makeToolMap packagesOrig
98 packages = populateUsers $ removeUnincluded bc toolMap packagesOrig
99 toolNames :: [ExeName]
100 toolNames = concatMap (Map.keys . sdTools . ppDesc) packages
101 tools <- topologicalSortTools toolMap $ mapFromList $ do
102 exeName <- toolNames
103 guard $ exeName `notMember` siCoreExecutables
104 packageName <- maybe mempty setToList $ lookup exeName toolMap
105 packagePlan <- maybeToList $ lookup packageName packagesOrig
106 return (packageName, packagePlan)
107 -- FIXME topologically sort packages? maybe just leave that to the build phase
108 return BuildPlan
109 { bpSystemInfo = bcSystemInfo
110 , bpTools = tools
111 , bpPackages = packages
112 , bpGithubUsers = bcGithubUsers
113 }
114 where
115 SystemInfo {..} = bcSystemInfo
117makeToolMap :: Map PackageName PackagePlan
118 -> Map ExeName (Set PackageName)
119makeToolMap =
120 unionsWith (++) . map go . mapToList
121 where
122 go (packageName, pp) =
123 foldMap go' $ sdProvidedExes $ ppDesc pp
124 where
125 go' exeName = singletonMap exeName (singletonSet packageName)
127topologicalSortTools :: MonadThrow m
128 => Map ExeName (Set PackageName)
129 -> Map PackageName PackagePlan
130 -> m (Vector (PackageName, Version))
131topologicalSortTools toolMap = topologicalSort
132 ppVersion
133 (concatMap (fromMaybe mempty . flip lookup toolMap) . Map.keys . sdTools . ppDesc)
135-- | Include only packages which are dependencies of the required packages and
136-- their build tools.
137removeUnincluded :: BuildConstraints
138 -> Map ExeName (Set PackageName)
139 -> Map PackageName PackagePlan
140 -> Map PackageName PackagePlan
141removeUnincluded BuildConstraints {..} toolMap orig =
142 mapFromList $ filter (\(x, _) -> x `member` included) $ mapToList orig
143 where
144 SystemInfo {..} = bcSystemInfo
146 included :: Set PackageName
147 included = flip execState mempty $ mapM_ add bcPackages
149 add name = do
150 inc <- get
151 when (name `notMember` inc) $ do
152 put $ insertSet name inc
153 case lookup name orig of
154 Nothing -> return ()
155 Just pb -> do
156 mapM_ add $ Map.keys $ sdPackages $ ppDesc pb
157 forM_ (Map.keys $ sdTools $ ppDesc pb) $
158 \exeName -> when (exeName `notMember` siCoreExecutables)
159 $ mapM_ add $ fromMaybe mempty $ lookup exeName toolMap
161populateUsers :: Map PackageName PackagePlan
162 -> Map PackageName PackagePlan
163populateUsers orig =
164 mapWithKey go orig
165 where
166 go name pb = pb { ppUsers = foldMap (go2 name) (mapToList orig) }
168 go2 dep (user, pb)
169 | dep `member` sdPackages (ppDesc pb) = singletonSet user
170 | otherwise = mempty
172-- | Check whether the given package/version combo meets the constraints
173-- currently in place.
174isAllowed :: BuildConstraints
175 -> PackageName -> Version -> Bool
176isAllowed bc = \name version ->
177 case lookup name $ siCorePackages $ bcSystemInfo bc of
178 Just _ -> False -- never reinstall a core package
179 Nothing -> withinRange version $ pcVersionRange $ bcPackageConstraints bc name
181mkPackagePlan :: MonadThrow m
182 => BuildConstraints
183 -> GenericPackageDescription
184 -> m PackagePlan
185mkPackagePlan bc gpd = do
186 ppDesc <- toSimpleDesc CheckCond {..} gpd
187 return PackagePlan {..}
188 where
189 PackageIdentifier name ppVersion = package $ packageDescription gpd
190 ppGithubPings = getGithubPings bc gpd
191 ppConstraints = bcPackageConstraints bc name
192 ppUsers = mempty -- must be filled in later
194 ccPackageName = name
195 ccOS = siOS
196 ccArch = siArch
197 ccCompilerFlavor = Distribution.Compiler.GHC
198 ccCompilerVersion = siGhcVersion
199 ccFlags = flags
200 ccIncludeTests = pcTests ppConstraints /= Don'tBuild
201 ccIncludeBenchmarks = pcBuildBenchmarks ppConstraints
203 SystemInfo {..} = bcSystemInfo bc
205 overrides = pcFlagOverrides ppConstraints
206 getFlag MkFlag {..} =
207 (flagName, fromMaybe flagDefault $ lookup flagName overrides)
208 flags = mapFromList $ map getFlag $ genPackageFlags gpd
210getLatestAllowedPlans :: MonadIO m => BuildConstraints -> m (Map PackageName PackagePlan)
211getLatestAllowedPlans bc =
212 getLatestDescriptions
213 (isAllowed bc)
214 (mkPackagePlan bc)