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