git.iko.soy/stackage
on master help sign in
Dependency injection of newBuildPlan (#375)
commit5da6e5cfa463c0ae12ca947ab2577b6f00e36db2 authorChris Done <chrisdone@gmail.com> dateSun 4 Jan 2015, 21:39 (12 years ago) parentee9bc2b
4 files changed+27−11
compare with master
unifiedsplit
Stackage/BuildPlan.hs+10−3 Stackage/CompleteBuild.hs+11−4 Stackage/UpdateBuildPlan.hs+3−2 test/Stackage/BuildPlanSpec.hs+3−2
Stackage/BuildPlan.hs+10−3
@@ -14,6 +14,7 @@ module Stackage.BuildPlan
1414 , PackagePlan (..)
1515 , newBuildPlan
1616 , makeToolMap
17+ , getLatestAllowedPlans
1718 ) where
1819
1920import Control.Monad.State.Strict (execState, get, put)
@@ -90,9 +91,9 @@ instance FromJSON PackagePlan where
9091 ppDesc <- o .: "description"
9192 return PackagePlan {..}
9293
93−newBuildPlan :: MonadIO m => BuildConstraints -> m BuildPlan
94−newBuildPlan bc@BuildConstraints {..} = liftIO $ do
95− packagesOrig <- getLatestDescriptions (isAllowed bc) (mkPackagePlan bc)
94+-- | Make a build plan given these package set and build constraints.
95+newBuildPlan :: MonadIO m => Map PackageName PackagePlan -> BuildConstraints -> m BuildPlan
96+newBuildPlan packagesOrig bc@BuildConstraints {..} = liftIO $ do
9697 let toolMap = makeToolMap packagesOrig
9798 packages = populateUsers $ removeUnincluded bc toolMap packagesOrig
9899 toolNames :: [ExeName]
@@ -205,3 +206,9 @@ mkPackagePlan bc gpd = do
205206 getFlag MkFlag {..} =
206207 (flagName, fromMaybe flagDefault $ lookup flagName overrides)
207208 flags = mapFromList $ map getFlag $ genPackageFlags gpd
209+
210+getLatestAllowedPlans :: MonadIO m => BuildConstraints -> m (Map PackageName PackagePlan)
211+getLatestAllowedPlans bc =
212+ getLatestDescriptions
213+ (isAllowed bc)
214+ (mkPackagePlan bc)
Stackage/CompleteBuild.hs+11−4
@@ -54,7 +54,9 @@ getSettings :: Manager -> BuildType -> IO Settings
5454getSettings man Nightly = do
5555 day <- tshow . utctDay <$> getCurrentTime
5656 let slug' = "nightly-" ++ day
57− plan' <- defaultBuildConstraints man >>= newBuildPlan
57+ bc <- defaultBuildConstraints man
58+ pkgs <- getLatestAllowedPlans bc
59+ plan' <- newBuildPlan pkgs bc
5860 return Settings
5961 { planFile = fpFromText ("nightly-" ++ day) <.> "yaml"
6062 , buildDir = fpFromText $ "builds/stackage-nightly-" ++ day
@@ -81,14 +83,18 @@ getSettings man (LTS bumpType) = do
8183 case mlts of
8284 Nothing -> LTSVer 0 0
8385 Just (LTSVer x _) -> LTSVer (x + 1) 0
84− plan' <- defaultBuildConstraints man >>= newBuildPlan
86+ bc <- defaultBuildConstraints man
87+ pkgs <- getLatestAllowedPlans bc
88+ plan' <- newBuildPlan pkgs bc
8589 return (new, plan')
8690 Minor -> do
8791 old <- maybe (error "No LTS plans found in current directory") return mlts
8892 oldplan <- decodeFileEither (fpToString $ renderLTSVer old)
8993 >>= either throwM return
9094 let new = incrLTSVer old
91− plan' <- updateBuildPlan oldplan
95+ let bc = updateBuildConstraints oldplan
96+ pkgs <- getLatestAllowedPlans bc
97+ plan' <- newBuildPlan pkgs bc
9298 return (new, plan')
9399
94100 let newfile = renderLTSVer new
@@ -148,7 +154,8 @@ justCheck = withManager tlsManagerSettings $ \man -> do
148154 bc <- defaultBuildConstraints man
149155
150156 putStrLn "Creating build plan"
151− plan <- newBuildPlan bc
157+ plans <- getLatestAllowedPlans bc
158+ plan <- newBuildPlan plans bc
152159
153160 putStrLn $ "Writing build plan to check-plan.yaml"
154161 encodeFile "check-plan.yaml" plan
Stackage/UpdateBuildPlan.hs+3−2
@@ -15,8 +15,9 @@ import Stackage.BuildConstraints
1515import Stackage.BuildPlan
1616import Stackage.Prelude
1717
18−updateBuildPlan :: BuildPlan -> IO BuildPlan
19−updateBuildPlan = newBuildPlan . updateBuildConstraints
18+updateBuildPlan :: Map PackageName PackagePlan -> BuildPlan -> IO BuildPlan
19+updateBuildPlan packagesOrig
20+ = newBuildPlan packagesOrig . updateBuildConstraints
2021
2122updateBuildConstraints :: BuildPlan -> BuildConstraints
2223updateBuildConstraints BuildPlan {..} =
test/Stackage/BuildPlanSpec.hs+3−2
@@ -15,7 +15,8 @@ import Network.HTTP.Client.TLS (tlsManagerSettings)
1515spec :: Spec
1616spec = it "works" $ withManager tlsManagerSettings $ \man -> do
1717 bc <- defaultBuildConstraints man
18− bp <- newBuildPlan bc
18+ pkgs <- getLatestAllowedPlans bc
19+ bp <- newBuildPlan pkgs bc
1920 let bs = Y.encode bp
2021 ebp' = Y.decodeEither bs
2122
@@ -28,7 +29,7 @@ spec = it "works" $ withManager tlsManagerSettings $ \man -> do
2829
2930 bpGithubUsers bp' `shouldBe` bpGithubUsers bp
3031 when (bp' /= bp) $ error "bp' /= bp"
31− bp2 <- updateBuildPlan bp
32+ bp2 <- updateBuildPlan pkgs bp
3233 when (dropVersionRanges bp2 /= dropVersionRanges bp) $ error "bp2 /= bp"
3334 where
3435 dropVersionRanges bp =