@@ -25,6 +25,7 @@ import Control.Monad.State.Strict (execState, get, put)
2525import qualified Data.Map as Map
2626import qualified Data.Set as Set
2727import Data.Aeson
28+import Stackage2.PackageDescription
2829
2930data BuildPlan desc = BuildPlan
3031 { bpCore :: Map PackageName Version
@@ -145,8 +146,8 @@ instance FromJSON TestState where
145146newBuildPlan :: MonadIO m => m (BuildPlan FlatComponent)
146147newBuildPlan = liftIO $ do
147148 core <- getCorePackages
148− extraOrig <- getLatestDescriptions (isAllowed core) simplifyDesc
149− let toolNames = concatMap (seTools . fcExtra . pbDesc) extraOrig
149+ extraOrig <- getLatestDescriptions (isAllowed core) mkPackageBuild
150+ let toolNames = concatMap (seTools . fcExtra . pbDesc) extraOrig -- FIXME extraOrig ==> extra
150151 extra = populateUsers $ removeUnincluded (Map.keysSet toolNames) extraOrig
151152 return BuildPlan
152153 { bpCore = core
@@ -170,7 +171,7 @@ removeUnincluded toolNames orig =
170171 included :: Set PackageName
171172 included = flip execState mempty $ do
172173 mapM_ (add . fst) $ mapToList $ pcPackages defaultPackageConstraints
173− mapM_ add toolNames
174+ mapM_ add toolNames -- FIXME remove this
174175
175176 add name = do
176177 inc <- get
@@ -179,6 +180,7 @@ removeUnincluded toolNames orig =
179180 case lookup name orig of
180181 Nothing -> return ()
181182 Just pb -> mapM_ (add . fst) $ mapToList $ fcDeps $ pbDesc pb
183+ -- FIXME add tools here
182184
183185populateUsers :: Map PackageName (PackageBuild FlatComponent)
184186 -> Map PackageName (PackageBuild FlatComponent)
@@ -191,83 +193,20 @@ populateUsers orig =
191193 | dep `member` fcDeps (pbDesc pb) = singletonSet user
192194 | otherwise = mempty
193195
194−data SimpleTree = SimpleTree
195− { stDeps :: Map PackageName VersionRange
196− , stConds :: [(Condition ConfVar, SimpleTree, Maybe SimpleTree)]
197− , stExtra :: SimpleExtra
198− }
199− deriving Show
200−instance Monoid SimpleTree where
201− mempty = SimpleTree mempty mempty mempty
202− mappend (SimpleTree a b c) (SimpleTree x y z) = SimpleTree
203− (unionWith intersectVersionRanges a x)
204− (b ++ y)
205− (c ++ z)
206−
207−data SimpleExtra = SimpleExtra
208− { seTools :: Map PackageName VersionRange
209− }
210− deriving Show
211−instance Monoid SimpleExtra where
212− mempty = SimpleExtra mempty
213− mappend (SimpleExtra a) (SimpleExtra x) = SimpleExtra
214− (unionWith intersectVersionRanges a x)
215−
216−getSimpleTrees :: Bool -- ^ include test suites?
217− -> Bool -- ^ include benchmarks?
218− -> GenericPackageDescription
219− -> [SimpleTree]
220−getSimpleTrees includeTests includeBench gpd = concat
221− [ maybe [] (return . go libBuildInfo) $ condLibrary gpd
222− , map (go buildInfo . snd) $ condExecutables gpd
223− , if includeTests
224− then map (go testBuildInfo . snd) $ condTestSuites gpd
225− else []
226− , if includeBench
227− then map (go benchmarkBuildInfo . snd) $ condBenchmarks gpd
228− else []
229− ]
230− where
231− go getExtra (CondNode dat deps comps) = SimpleTree
232− { stDeps = unionsWith intersectVersionRanges
233− $ map (\(Dependency x y) -> singletonMap x y) deps
234− , stConds = map (goComp getExtra) comps
235− , stExtra = toSimpleExtra $ getExtra dat
236− }
237−
238− goComp getExtra (cond, tree1, mtree2) =
239− (cond, go getExtra tree1, go getExtra <$> mtree2)
240−
241− toSimpleExtra bi = SimpleExtra
242− { seTools = unionsWith intersectVersionRanges $ flip map (buildTools bi)
243− $ \(Dependency name range) -> singletonMap name range
244− }
245−
246−data FlatComponent = FlatComponent
247− { fcDeps :: Map PackageName VersionRange
248− , fcExtra :: SimpleExtra
249− }
250− deriving Show
251−instance Monoid FlatComponent where
252− mempty = FlatComponent mempty mempty
253− mappend (FlatComponent a b) (FlatComponent x y) = FlatComponent
254− (unionWith intersectVersionRanges a x)
255− (b ++ y)
256−
257−flattenComponent :: SimpleTree -> FlatComponent
258−flattenComponent (SimpleTree deps conds extra) =
259− mconcat $ here : map goCond conds
260− where
261− here = FlatComponent { fcDeps = deps, fcExtra = extra }
262− goCond (cond, tree1, mtree2)
263− | checkCond cond = flattenComponent tree1
264− | otherwise = maybe mempty flattenComponent mtree2
265−
266−checkCond :: Condition ConfVar -> Bool
267−checkCond _ = False -- FIXME
196+isAllowed :: Map PackageName Version -- ^ core
197+ -> PackageName -> Version -> Bool
198+isAllowed core = \name version ->
199+ case lookup name core of
200+ Just _ -> False -- never reinstall a core package
201+ Nothing ->
202+ case lookup name $ pcPackages defaultPackageConstraints of
203+ Nothing -> True -- no constraints
204+ Just (range, _) -> withinRange version range
268205
269−simplifyDesc :: GenericPackageDescription -> IO (PackageBuild FlatComponent)
270−simplifyDesc gpd = do
206+mkPackageBuild :: Monad m
207+ => GenericPackageDescription
208+ -> m (PackageBuild FlatComponent)
209+mkPackageBuild gpd =
271210 return PackageBuild
272211 { pbVersion = version
273212 , pbMaintainer = fmap snd $ lookup name $ pcPackages defaultPackageConstraints
@@ -288,20 +227,10 @@ simplifyDesc gpd = do
288227 -> ExpectFailure
289228 | otherwise -> ExpectSuccess
290229 , pbTryBuildBenchmark = tryBuildBenchmark name
291− , pbDesc = foldMap flattenComponent $ getSimpleTrees
230+ , pbDesc = getFlattenedComponent
292231 (tryBuildTest name)
293232 (tryBuildBenchmark name)
294233 gpd
295234 }
296235 where
297236 PackageIdentifier name version = package $ packageDescription gpd
298−
299−isAllowed :: Map PackageName Version -- ^ core
300− -> PackageName -> Version -> Bool
301−isAllowed core = \name version ->
302− case lookup name core of
303− Just _ -> False -- never reinstall a core package
304− Nothing ->
305− case lookup name $ pcPackages defaultPackageConstraints of
306− Nothing -> True -- no constraints
307− Just (range, _) -> withinRange version range