git.iko.soy/stackage
on master help sign in
Dependency injection of newBuildPlan (#375)
5da6e5cChris Done
Stackage/BuildPlan.hs+10−3
compare with master
unifiedsplit
@@ -14,6 +14,7 @@ module Stackage.BuildPlan
14 , PackagePlan (..)
14 , PackagePlan (..)
15 , newBuildPlan
15 , newBuildPlan
16 , makeToolMap
16 , makeToolMap
17+ , getLatestAllowedPlans
17 ) where
18 ) where
18
19
19import Control.Monad.State.Strict (execState, get, put)
20import Control.Monad.State.Strict (execState, get, put)
@@ -90,9 +91,9 @@ instance FromJSON PackagePlan where
90 ppDesc <- o .: "description"
91 ppDesc <- o .: "description"
91 return PackagePlan {..}
92 return PackagePlan {..}
92
93
94+-- | Make a build plan given these package set and build constraints.
93−newBuildPlan :: MonadIO m => BuildConstraints -> m BuildPlan
95+newBuildPlan :: MonadIO m => Map PackageName PackagePlan -> BuildConstraints -> m BuildPlan
94−newBuildPlan bc@BuildConstraints {..} = liftIO $ do
96+newBuildPlan packagesOrig bc@BuildConstraints {..} = liftIO $ do
95− packagesOrig <- getLatestDescriptions (isAllowed bc) (mkPackagePlan bc)
96 let toolMap = makeToolMap packagesOrig
97 let toolMap = makeToolMap packagesOrig
97 packages = populateUsers $ removeUnincluded bc toolMap packagesOrig
98 packages = populateUsers $ removeUnincluded bc toolMap packagesOrig
98 toolNames :: [ExeName]
99 toolNames :: [ExeName]
@@ -205,3 +206,9 @@ mkPackagePlan bc gpd = do
205 getFlag MkFlag {..} =
206 getFlag MkFlag {..} =
206 (flagName, fromMaybe flagDefault $ lookup flagName overrides)
207 (flagName, fromMaybe flagDefault $ lookup flagName overrides)
207 flags = mapFromList $ map getFlag $ genPackageFlags gpd
208 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
54getSettings man Nightly = do
54getSettings man Nightly = do
55 day <- tshow . utctDay <$> getCurrentTime
55 day <- tshow . utctDay <$> getCurrentTime
56 let slug' = "nightly-" ++ day
56 let slug' = "nightly-" ++ day
57+ bc <- defaultBuildConstraints man
58+ pkgs <- getLatestAllowedPlans bc
57− plan' <- defaultBuildConstraints man >>= newBuildPlan
59+ plan' <- newBuildPlan pkgs bc
58 return Settings
60 return Settings
59 { planFile = fpFromText ("nightly-" ++ day) <.> "yaml"
61 { planFile = fpFromText ("nightly-" ++ day) <.> "yaml"
60 , buildDir = fpFromText $ "builds/stackage-nightly-" ++ day
62 , buildDir = fpFromText $ "builds/stackage-nightly-" ++ day
@@ -81,14 +83,18 @@ getSettings man (LTS bumpType) = do
81 case mlts of
83 case mlts of
82 Nothing -> LTSVer 0 0
84 Nothing -> LTSVer 0 0
83 Just (LTSVer x _) -> LTSVer (x + 1) 0
85 Just (LTSVer x _) -> LTSVer (x + 1) 0
86+ bc <- defaultBuildConstraints man
87+ pkgs <- getLatestAllowedPlans bc
84− plan' <- defaultBuildConstraints man >>= newBuildPlan
88+ plan' <- newBuildPlan pkgs bc
85 return (new, plan')
89 return (new, plan')
86 Minor -> do
90 Minor -> do
87 old <- maybe (error "No LTS plans found in current directory") return mlts
91 old <- maybe (error "No LTS plans found in current directory") return mlts
88 oldplan <- decodeFileEither (fpToString $ renderLTSVer old)
92 oldplan <- decodeFileEither (fpToString $ renderLTSVer old)
89 >>= either throwM return
93 >>= either throwM return
90 let new = incrLTSVer old
94 let new = incrLTSVer old
91− plan' <- updateBuildPlan oldplan
95+ let bc = updateBuildConstraints oldplan
96+ pkgs <- getLatestAllowedPlans bc
97+ plan' <- newBuildPlan pkgs bc
92 return (new, plan')
98 return (new, plan')
93
99
94 let newfile = renderLTSVer new
100 let newfile = renderLTSVer new
@@ -148,7 +154,8 @@ justCheck = withManager tlsManagerSettings $ \man -> do
148 bc <- defaultBuildConstraints man
154 bc <- defaultBuildConstraints man
149
155
150 putStrLn "Creating build plan"
156 putStrLn "Creating build plan"
157+ plans <- getLatestAllowedPlans bc
151− plan <- newBuildPlan bc
158+ plan <- newBuildPlan plans bc
152
159
153 putStrLn $ "Writing build plan to check-plan.yaml"
160 putStrLn $ "Writing build plan to check-plan.yaml"
154 encodeFile "check-plan.yaml" plan
161 encodeFile "check-plan.yaml" plan
Stackage/UpdateBuildPlan.hs+3−2
@@ -15,8 +15,9 @@ import Stackage.BuildConstraints
15import Stackage.BuildPlan
15import Stackage.BuildPlan
16import Stackage.Prelude
16import Stackage.Prelude
17
17
18−updateBuildPlan :: BuildPlan -> IO BuildPlan
18+updateBuildPlan :: Map PackageName PackagePlan -> BuildPlan -> IO BuildPlan
19+updateBuildPlan packagesOrig
19−updateBuildPlan = newBuildPlan . updateBuildConstraints
20+ = newBuildPlan packagesOrig . updateBuildConstraints
20
21
21updateBuildConstraints :: BuildPlan -> BuildConstraints
22updateBuildConstraints :: BuildPlan -> BuildConstraints
22updateBuildConstraints BuildPlan {..} =
23updateBuildConstraints BuildPlan {..} =
test/Stackage/BuildPlanSpec.hs+3−2
@@ -15,7 +15,8 @@ import Network.HTTP.Client.TLS (tlsManagerSettings)
15spec :: Spec
15spec :: Spec
16spec = it "works" $ withManager tlsManagerSettings $ \man -> do
16spec = it "works" $ withManager tlsManagerSettings $ \man -> do
17 bc <- defaultBuildConstraints man
17 bc <- defaultBuildConstraints man
18+ pkgs <- getLatestAllowedPlans bc
18− bp <- newBuildPlan bc
19+ bp <- newBuildPlan pkgs bc
19 let bs = Y.encode bp
20 let bs = Y.encode bp
20 ebp' = Y.decodeEither bs
21 ebp' = Y.decodeEither bs
21
22
@@ -28,7 +29,7 @@ spec = it "works" $ withManager tlsManagerSettings $ \man -> do
28
29
29 bpGithubUsers bp' `shouldBe` bpGithubUsers bp
30 bpGithubUsers bp' `shouldBe` bpGithubUsers bp
30 when (bp' /= bp) $ error "bp' /= bp"
31 when (bp' /= bp) $ error "bp' /= bp"
31− bp2 <- updateBuildPlan bp
32+ bp2 <- updateBuildPlan pkgs bp
32 when (dropVersionRanges bp2 /= dropVersionRanges bp) $ error "bp2 /= bp"
33 when (dropVersionRanges bp2 /= dropVersionRanges bp) $ error "bp2 /= bp"
33 where
34 where
34 dropVersionRanges bp =
35 dropVersionRanges bp =