Dependency injection of newBuildPlan (#375)

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)

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

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 {..} =

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 =