shake: fetching packages

Stackage/ShakeBuild.hs

@@ -1,10 +1,49 @@
--- |
+-- | Build everything with Shake.
 
 module Stackage.ShakeBuild where
 
-import Data.Text (Text)
-import Stackage.PerformBuild (PerformBuild(..))
+import           Stackage.BuildPlan
+import           Stackage.PerformBuild (PerformBuild(..))
+
+import qualified Data.Map.Strict as M
+import           Data.Text (Text)
+import           Development.Shake
+import           Distribution.Text (display)
+import           System.Directory
+import           System.Environment
 
 -- | Run the shake builder.
-performBuild :: PerformBuild -> IO [Text]
-performBuild = undefined
+performBuild :: PerformBuild -> IO ()
+performBuild pb = do
+    shakeDir <- fmap (<//> "shake") getCurrentDirectory
+    createDirectoryIfMissing True shakeDir
+    withArgs
+        []
+        (shakeArgs
+             shakeOptions {shakeFiles = shakeDir}
+             (shakePlan pb shakeDir))
+
+-- | The complete build plan as far as Shake is concerned.
+shakePlan :: PerformBuild -> FilePath -> Rules ()
+shakePlan pb shakeDir = do
+    wantedFetched *> const (fetchedTarget wantedFetched pb)
+    want [wantedFetched]
+    where wantedFetched =
+              shakeDir <//> "fetched"
+
+-- | Make sure all package archives have been fetched.
+fetchedTarget :: FilePath -> PerformBuild -> Action ()
+fetchedTarget wantedFile pb =
+    do () <- cmd
+                 "cabal"
+                 "fetch"
+                 "--no-dependencies"
+                 (map
+                      (\(name,plan) ->
+                            display name ++
+                            "-" ++
+                            display (ppVersion plan))
+                      (M.toList
+                           (bpPackages
+                                (pbPlan pb))))
+       liftIO (writeFile wantedFile "")

test/Stackage/BuildPlanSpec.hs

@@ -47,6 +47,12 @@ spec = do
         ,("mtl",[2,2,1],[("base",anyV)
                         ,("transformers",anyV)])
         ,("transformers",[0,4,1,0],[("base",anyV)])]
+    it "shake build" $ shakeBuild $ makePackageSet
+        [("acme-strtok", [0,1,0,3], [("mtl", thisV [2, 2, 1])])
+        ,("acme-dont", [1,1], [])
+        ,("mtl",[2,2,1],[("base",anyV)
+                        ,("transformers",anyV)])
+        ,("transformers",[0,4,1,0],[("base",anyV)])]
     it "default package set checks ok" $
       check defaultBuildConstraints getLatestAllowedPlans
     -}
@@ -91,6 +97,31 @@ basicBuild getPlans _ = do
                 , bfVerbose          = False
                 }
 
+-- | Perform a shake build.
+shakeBuild :: (BuildConstraints -> IO (Map PackageName PackagePlan))
+             -> void
+             -> IO ()
+shakeBuild getPlans _ = do
+    withManager
+        tlsManagerSettings
+        (\man ->
+              do settings@Settings{..} <- getTestSettings
+                                              man
+                                              Nightly
+                                              fullBuildConstraints
+                                              getPlans
+                 let pb =
+                         (getPerformBuild buildFlags settings)
+                 print (pbPlan pb)
+                 Shake.performBuild pb)
+    where buildType =
+              Nightly
+          buildFlags =
+              BuildFlags {bfEnableTests = False
+                         ,bfDoUpload = False
+                         ,bfEnableLibProfile = False
+                         ,bfVerbose = False}
+
 -- | Check build plan with the given package set getter.
 check :: (Manager -> IO BuildConstraints)
       -> (BuildConstraints -> IO (Map PackageName PackagePlan))