diff --git a/Stackage/BuildPlan.hs b/Stackage/BuildPlan.hs index 27868f06..b8bc5376 100644 --- a/Stackage/BuildPlan.hs +++ b/Stackage/BuildPlan.hs @@ -14,6 +14,7 @@ module Stackage.BuildPlan , PackagePlan (..) , newBuildPlan , makeToolMap + , getLatestAllowedPlans ) where import Control.Monad.State.Strict (execState, get, put) @@ -90,9 +91,9 @@ instance FromJSON PackagePlan where ppDesc <- o .: "description" return PackagePlan {..} -newBuildPlan :: MonadIO m => BuildConstraints -> m BuildPlan -newBuildPlan bc@BuildConstraints {..} = liftIO $ do - packagesOrig <- getLatestDescriptions (isAllowed bc) (mkPackagePlan bc) +-- | Make a build plan given these package set and build constraints. +newBuildPlan :: MonadIO m => Map PackageName PackagePlan -> BuildConstraints -> m BuildPlan +newBuildPlan packagesOrig bc@BuildConstraints {..} = liftIO $ do let toolMap = makeToolMap packagesOrig packages = populateUsers $ removeUnincluded bc toolMap packagesOrig toolNames :: [ExeName] @@ -205,3 +206,9 @@ mkPackagePlan bc gpd = do getFlag MkFlag {..} = (flagName, fromMaybe flagDefault $ lookup flagName overrides) flags = mapFromList $ map getFlag $ genPackageFlags gpd + +getLatestAllowedPlans :: MonadIO m => BuildConstraints -> m (Map PackageName PackagePlan) +getLatestAllowedPlans bc = + getLatestDescriptions + (isAllowed bc) + (mkPackagePlan bc) diff --git a/Stackage/CompleteBuild.hs b/Stackage/CompleteBuild.hs index 19e90c43..0d62bdbd 100644 --- a/Stackage/CompleteBuild.hs +++ b/Stackage/CompleteBuild.hs @@ -54,7 +54,9 @@ getSettings :: Manager -> BuildType -> IO Settings getSettings man Nightly = do day <- tshow . utctDay <$> getCurrentTime let slug' = "nightly-" ++ day - plan' <- defaultBuildConstraints man >>= newBuildPlan + bc <- defaultBuildConstraints man + pkgs <- getLatestAllowedPlans bc + plan' <- newBuildPlan pkgs bc return Settings { planFile = fpFromText ("nightly-" ++ day) <.> "yaml" , buildDir = fpFromText $ "builds/stackage-nightly-" ++ day @@ -81,14 +83,18 @@ getSettings man (LTS bumpType) = do case mlts of Nothing -> LTSVer 0 0 Just (LTSVer x _) -> LTSVer (x + 1) 0 - plan' <- defaultBuildConstraints man >>= newBuildPlan + bc <- defaultBuildConstraints man + pkgs <- getLatestAllowedPlans bc + plan' <- newBuildPlan pkgs bc return (new, plan') Minor -> do old <- maybe (error "No LTS plans found in current directory") return mlts oldplan <- decodeFileEither (fpToString $ renderLTSVer old) >>= either throwM return let new = incrLTSVer old - plan' <- updateBuildPlan oldplan + let bc = updateBuildConstraints oldplan + pkgs <- getLatestAllowedPlans bc + plan' <- newBuildPlan pkgs bc return (new, plan') let newfile = renderLTSVer new @@ -148,7 +154,8 @@ justCheck = withManager tlsManagerSettings $ \man -> do bc <- defaultBuildConstraints man putStrLn "Creating build plan" - plan <- newBuildPlan bc + plans <- getLatestAllowedPlans bc + plan <- newBuildPlan plans bc putStrLn $ "Writing build plan to check-plan.yaml" encodeFile "check-plan.yaml" plan diff --git a/Stackage/UpdateBuildPlan.hs b/Stackage/UpdateBuildPlan.hs index a1615b11..8c67c5ef 100644 --- a/Stackage/UpdateBuildPlan.hs +++ b/Stackage/UpdateBuildPlan.hs @@ -15,8 +15,9 @@ import Stackage.BuildConstraints import Stackage.BuildPlan import Stackage.Prelude -updateBuildPlan :: BuildPlan -> IO BuildPlan -updateBuildPlan = newBuildPlan . updateBuildConstraints +updateBuildPlan :: Map PackageName PackagePlan -> BuildPlan -> IO BuildPlan +updateBuildPlan packagesOrig + = newBuildPlan packagesOrig . updateBuildConstraints updateBuildConstraints :: BuildPlan -> BuildConstraints updateBuildConstraints BuildPlan {..} = diff --git a/test/Stackage/BuildPlanSpec.hs b/test/Stackage/BuildPlanSpec.hs index aa33c8dd..7c87d6d3 100644 --- a/test/Stackage/BuildPlanSpec.hs +++ b/test/Stackage/BuildPlanSpec.hs @@ -15,7 +15,8 @@ import Network.HTTP.Client.TLS (tlsManagerSettings) spec :: Spec spec = it "works" $ withManager tlsManagerSettings $ \man -> do bc <- defaultBuildConstraints man - bp <- newBuildPlan bc + pkgs <- getLatestAllowedPlans bc + bp <- newBuildPlan pkgs bc let bs = Y.encode bp ebp' = Y.decodeEither bs @@ -28,7 +29,7 @@ spec = it "works" $ withManager tlsManagerSettings $ \man -> do bpGithubUsers bp' `shouldBe` bpGithubUsers bp when (bp' /= bp) $ error "bp' /= bp" - bp2 <- updateBuildPlan bp + bp2 <- updateBuildPlan pkgs bp when (dropVersionRanges bp2 /= dropVersionRanges bp) $ error "bp2 /= bp" where dropVersionRanges bp =