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