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