git.iko.soy/stackage
on ff2dd38 help sign in
stackage/Stackage2/BuildPlan.hs
266 lines 11 kB history raw
1{-# LANGUAGE NoImplicitPrelude #-}
2{-# LANGUAGE DeriveDataTypeable #-}
3{-# LANGUAGE TupleSections #-}
4{-# LANGUAGE RecordWildCards #-}
5{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE DeriveFunctor #-}
7{-# LANGUAGE DeriveFoldable #-}
8{-# LANGUAGE DeriveTraversable #-}
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 , PackageBuild (..)
15 , newBuildPlan
16 ) where
18import Distribution.Package (Dependency (..))
19import Distribution.PackageDescription
20import Distribution.Version (withinRange, intersectVersionRanges)
21import Stackage2.PackageConstraints
22import Stackage2.PackageIndex
23import Stackage2.Prelude
24import Stackage2.GithubPings
25import Control.Monad.State.Strict (execState, get, put)
26import qualified Data.Map as Map
27import qualified Data.Set as Set
28import Data.Aeson
29import Stackage2.PackageDescription
30import qualified Distribution.System
31import qualified Distribution.Compiler
33data BuildPlan desc = BuildPlan
34 { bpCore :: Map PackageName Version
35 , bpTools :: Vector (PackageName, Version)
36 , bpExtra :: Map PackageName (PackageBuild desc)
37 }
38 deriving (Functor, Foldable, Traversable, Show, Eq)
39type instance Element (BuildPlan desc) = desc
40instance MonoFunctor (BuildPlan desc)
41instance MonoFoldable (BuildPlan desc)
42instance MonoTraversable (BuildPlan desc)
44instance ToJSON (BuildPlan desc) where
45 toJSON BuildPlan {..} = object
46 [ "core" .= asMap (mapFromList $ map toCore $ mapToList bpCore)
47 , "tools" .= map goTool bpTools
48 , "extra" .= Map.mapKeysWith const (unPackageName) bpExtra
49 ]
50 where
51 toCore (x, y) = (asText $ display x, asText $ display y)
52 goTool (name, version) = object
53 [ "name" .= asText (display name)
54 , "version" .= asText (display version)
55 ]
56instance desc ~ () => FromJSON (BuildPlan desc) where
57 parseJSON = withObject "BuildPlan" $ \o -> BuildPlan
58 <$> ((o .: "core") >>= goCore)
59 <*> ((o .: "tools") >>= mapM goTool)
60 <*> (goExtra <$> (o .: "extra"))
61 where
62 goCore =
63 fmap mapFromList . mapM goCore' . mapToList . asHashMap
64 where
65 goCore' (k, v) = do
66 k' <- either (fail . show) return $ simpleParse $ asText k
67 v' <- either (fail . show) return $ simpleParse $ asText v
68 return (k', v')
70 goTool = withObject "Tool" $ \o -> (,)
71 <$> ((o .: "name") >>=
72 either (fail . show) return . simpleParse . asText)
73 <*> ((o .: "version") >>=
74 either (fail . show) return . simpleParse . asText)
76 goExtra = Map.mapKeysWith const PackageName
78data PackageBuild desc = PackageBuild
79 { pbVersion :: Version
80 , pbMaintainer :: Maybe Maintainer
81 , pbGithubPings :: Set Text
82 , pbUsers :: Set PackageName
83 , pbFlags :: Map FlagName Bool
84 , pbTestState :: TestState
85 , pbHaddockState :: TestState
86 , pbTryBuildBenchmark :: Bool
87 , pbDesc :: desc
88 }
89 deriving (Functor, Foldable, Traversable, Show, Eq)
90type instance Element (PackageBuild desc) = desc
91instance MonoFunctor (PackageBuild desc)
92instance MonoFoldable (PackageBuild desc)
93instance MonoTraversable (PackageBuild desc)
95instance ToJSON (PackageBuild desc) where
96 toJSON PackageBuild {..} = object $ concat
97 [ maybe [] (\m -> ["maintainer" .= m]) pbMaintainer
98 ,
99 [ "version" .= asText (display pbVersion)
100 , "github-pings" .= pbGithubPings
101 , "users" .= map unPackageName (unpack pbUsers)
102 , "flags" .= Map.mapKeysWith const (\(FlagName f) -> asText $ pack f) pbFlags
103 , "test-state" .= pbTestState
104 , "haddock-state" .= pbHaddockState
105 , "build-benchmark" .= pbTryBuildBenchmark
106 ]
107 ]
108instance desc ~ () => FromJSON (PackageBuild desc) where
109 parseJSON = withObject "PackageBuild" $ \o -> PackageBuild
110 <$> (o .: "version" >>= efail . simpleParse . asText)
111 <*> o .:? "maintainer"
112 <*> o .:? "github-pings" .!= mempty
113 <*> (Set.map PackageName <$> (o .:? "users" .!= mempty))
114 <*> (toFlags <$> (o .:? "flags" .!= mempty))
115 <*> o .: "test-state"
116 <*> o .: "haddock-state"
117 <*> o .: "build-benchmark"
118 <*> pure ()
119 where
120 toFlags = Map.mapKeysWith const (FlagName . unpack . asText)
122 efail = either (fail . show) return
124newBuildPlan :: MonadIO m => PackageConstraints -> m (BuildPlan FlatComponent)
125newBuildPlan pc = liftIO $ do
126 extraOrig <- getLatestDescriptions (isAllowed pc) (mkPackageBuild pc)
127 let toolMap = makeToolMap extraOrig
128 extra = populateUsers $ removeUnincluded pc toolMap extraOrig
129 toolNames :: [ExeName]
130 toolNames = concatMap (Map.keys . seTools . fcExtra . pbDesc) extra
131 tools <- topologicalSortTools toolMap $ mapFromList $ do
132 exeName <- toolNames
133 guard $ exeName `notMember` pcCoreExecutables pc
134 packageName <- maybe mempty setToList $ lookup exeName toolMap
135 packageBuild <- maybeToList $ lookup packageName extraOrig
136 return (packageName, packageBuild)
137 -- FIXME topologically sort packages? maybe just leave that to the build phase
138 return BuildPlan
139 { bpCore = pcCorePackages pc
140 -- bpCoreExes = pcCoreExecutables pc
141 , bpTools = tools
142 , bpExtra = extra
143 }
145makeToolMap :: Map PackageName (PackageBuild FlatComponent)
146 -> Map ExeName (Set PackageName)
147makeToolMap =
148 unionsWith (++) . map go . mapToList
149 where
150 go (packageName, pb) =
151 foldMap go' $ seProvidedExes $ fcExtra $ pbDesc pb
152 where
153 go' exeName = singletonMap exeName (singletonSet packageName)
155topologicalSortTools :: MonadThrow m
156 => Map ExeName (Set PackageName)
157 -> Map PackageName (PackageBuild FlatComponent)
158 -> m (Vector (PackageName, Version))
159topologicalSortTools toolMap = topologicalSort
160 pbVersion
161 (concatMap (fromMaybe mempty . flip lookup toolMap) . Map.keys . seTools . fcExtra . pbDesc)
163topologicalSort :: (Ord key, Show key, MonadThrow m, Typeable key)
164 => (value -> finalValue)
165 -> (value -> Set key) -- ^ deps
166 -> Map key value
167 -> m (Vector (key, finalValue))
168topologicalSort toFinal toDeps =
169 loop id . mapWithKey removeSelfDeps . fmap (toDeps &&& toFinal)
170 where
171 removeSelfDeps k (deps, final) = (deleteSet k deps, final)
172 loop front toProcess | null toProcess = return $ pack $ front []
173 loop front toProcess
174 | null noDeps = throwM $ NoEmptyDeps (map fst toProcess')
175 | otherwise = loop (front . noDeps') (mapFromList hasDeps)
176 where
177 toProcess' = fmap (first removeUnavailable) toProcess
178 allKeys = Map.keysSet toProcess
179 removeUnavailable = asSet . setFromList . filter (`member` allKeys) . setToList
180 (noDeps, hasDeps) = partition (null . fst . snd) $ mapToList toProcess'
181 noDeps' = (map (second snd) noDeps ++)
183data TopologicalSortException key = NoEmptyDeps (Map key (Set key))
184 deriving (Show, Typeable)
185instance (Show key, Typeable key) => Exception (TopologicalSortException key)
187removeUnincluded :: PackageConstraints
188 -> Map ExeName (Set PackageName)
189 -> Map PackageName (PackageBuild FlatComponent)
190 -> Map PackageName (PackageBuild FlatComponent)
191removeUnincluded pc toolMap orig =
192 mapFromList $ filter (\(x, _) -> x `member` included) $ mapToList orig
193 where
194 coreExes = pcCoreExecutables pc
196 included :: Set PackageName
197 included = flip execState mempty $
198 mapM_ (add . fst) $ mapToList $ pcPackages pc
200 add name = do
201 inc <- get
202 when (name `notMember` inc) $ do
203 put $ insertSet name inc
204 case lookup name orig of
205 Nothing -> return ()
206 Just pb -> do
207 mapM_ (add . fst) $ mapToList $ fcDeps $ pbDesc pb
208 forM_ (map fst $ mapToList $ seTools $ fcExtra $ pbDesc pb) $
209 \exeName -> when (exeName `notMember` coreExes)
210 $ mapM_ add $ fromMaybe mempty $ lookup exeName toolMap
212populateUsers :: Map PackageName (PackageBuild FlatComponent)
213 -> Map PackageName (PackageBuild FlatComponent)
214populateUsers orig =
215 mapWithKey go orig
216 where
217 go name pb = pb { pbUsers = foldMap (go2 name) (mapToList orig) }
219 go2 dep (user, pb)
220 | dep `member` fcDeps (pbDesc pb) = singletonSet user
221 | otherwise = mempty
223isAllowed :: PackageConstraints
224 -> PackageName -> Version -> Bool
225isAllowed pc = \name version ->
226 case lookup name $ pcCorePackages pc of
227 Just _ -> False -- never reinstall a core package
228 Nothing ->
229 case lookup name $ pcPackages pc of
230 Nothing -> True -- no constraints
231 Just (range, _) -> withinRange version range
233mkPackageBuild :: MonadThrow m
234 => PackageConstraints
235 -> GenericPackageDescription
236 -> m (PackageBuild FlatComponent)
237mkPackageBuild pc gpd = do
238 let overrides = pcFlagOverrides pc name
239 getFlag MkFlag {..} =
240 (flagName, fromMaybe flagDefault $ lookup flagName overrides)
241 flags = mapFromList $ map getFlag $ genPackageFlags gpd
242 desc <- getFlattenedComponent
243 CheckCond
244 { ccPackageName = name
245 , ccOS = pcOS pc
246 , ccArch = pcArch pc
247 , ccCompilerFlavor = Distribution.Compiler.GHC
248 , ccCompilerVersion = pcGhcVersion pc
249 , ccFlags = flags
250 }
251 (pcTests pc name /= Don'tBuild)
252 (pcBuildBenchmark pc name)
253 gpd
254 return PackageBuild
255 { pbVersion = version
256 , pbMaintainer = fmap snd $ lookup name $ pcPackages pc
257 , pbGithubPings = getGithubPings gpd
258 , pbUsers = mempty -- must be filled in later
259 , pbFlags = flags
260 , pbTestState = pcTests pc name
261 , pbHaddockState = pcHaddocks pc name
262 , pbTryBuildBenchmark = pcBuildBenchmark pc name
263 , pbDesc = desc
264 }
265 where
266 PackageIdentifier name version = package $ packageDescription gpd