shake: unpacking, building and registering

Stackage/ShakeBuild.hs

@@ -3,11 +3,16 @@
 module Stackage.ShakeBuild where
 
 import           Stackage.BuildPlan
+import           Stackage.PackageDescription
+import           Stackage.BuildConstraints
 import           Stackage.PerformBuild (PerformBuild(..))
 
+import           Control.Monad
+import           Data.List ((\\))
 import qualified Data.Map.Strict as M
 import           Data.Text (Text)
 import           Development.Shake
+import           Distribution.Package (PackageName)
 import           Distribution.Text (display)
 import           System.Directory
 import           System.Environment
@@ -15,8 +20,7 @@ import           System.Environment
 -- | Run the shake builder.
 performBuild :: PerformBuild -> IO ()
 performBuild pb = do
-    shakeDir <- fmap (<//> "shake") getCurrentDirectory
+    shakeDir <- fmap (<//> "shake/") getCurrentDirectory
-    createDirectoryIfMissing True shakeDir
     withArgs
         []
         (shakeArgs
@@ -26,24 +30,75 @@ performBuild pb = do
 -- | The complete build plan as far as Shake is concerned.
 shakePlan :: PerformBuild -> FilePath -> Rules ()
 shakePlan pb shakeDir = do
-    wantedFetched *> const (fetchedTarget wantedFetched pb)
+    fetched <- target (targetForFetched shakeDir) $
-    want [wantedFetched]
+               fetchedTarget shakeDir pb
-    where wantedFetched =
+    _ <- forM corePackages $
-              shakeDir <//> "fetched"
+         \name ->
+              let fp =
+                      targetForPackage shakeDir name
+              in target fp (makeFile fp)
+    packageTargets <- forM normalPackages $
+                      \(name,plan) ->
+                           target
+                               (targetForPackage shakeDir name)
+                               (do need [fetched]
+                                   packageTarget shakeDir name plan)
+    want packageTargets
+    where corePackages =
+              M.keys $ siCorePackages $ bpSystemInfo $ pbPlan pb
+          normalPackages =
+              filter (not . (`elem` corePackages) . fst) $
+              M.toList $ bpPackages $ pbPlan pb
 
 -- | Make sure all package archives have been fetched.
 fetchedTarget :: FilePath -> PerformBuild -> Action ()
-fetchedTarget wantedFile pb =
+fetchedTarget shakeDir pb = do
-    do () <- cmd
+    () <- cmd "cabal" "fetch" "--no-dependencies" $
-                 "cabal"
+          map
-                 "fetch"
-                 "--no-dependencies"
-                 (map
               (\(name,plan) ->
                     display name ++
                     "-" ++
                     display (ppVersion plan))
               (M.toList
                    (bpPackages
-                                (pbPlan pb))))
+                        (pbPlan pb)))
-       liftIO (writeFile wantedFile "")
+    makeFile (targetForFetched shakeDir)
+
+-- | Build, test and generate documentation for the package.
+packageTarget :: FilePath -> PackageName -> PackagePlan -> Action ()
+packageTarget shakeDir name plan = do
+    need (map (targetForPackage shakeDir)
+              (M.keys (sdPackages (ppDesc plan))))
+    () <- cmd (Cwd shakeDir) "cabal" "unpack" nameVer
+    () <- cmd (Cwd pkgDir) "cabal" "configure"
+    () <- cmd (Cwd pkgDir) "cabal" "build"
+    () <- cmd (Cwd pkgDir) "cabal" "copy"
+    () <- cmd (Cwd pkgDir) "cabal" "register"
+    makeFile (targetForPackage shakeDir name)
+    where pkgDir =
+              shakeDir <//> nameVer
+          nameVer =
+              display name ++
+              "-" ++
+              display (ppVersion plan)
+
+-- | Get the target file for confirming that all packages have been
+-- pre-fetched.
+targetForFetched :: FilePattern -> FilePattern
+targetForFetched shakeDir =
+    shakeDir <//> "fetched"
+
+-- | Get the target file for a package.
+targetForPackage :: FilePattern -> PackageName -> FilePattern
+targetForPackage shakeDir name =
+    shakeDir <//> "packages" <//> display name
+
+-- | Declare a target, returning the target name.
+target :: FilePattern -> Action () -> Rules FilePattern
+target name action = do
+    name *> const action
+    return name
+
+-- | Make a file of this name.
+makeFile :: FilePath -> Action ()
+makeFile fp = liftIO $ writeFile fp ""

stackage.cabal

@@ -64,6 +64,7 @@ library
                      , streaming-commons >= 0.1.7.1
                      , semigroups
                      , xml-conduit
+                     , shake
 
 executable stackage
   default-language:    Haskell2010

test/Stackage/BuildPlanSpec.hs

@@ -48,11 +48,11 @@ spec = do
                         ,("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-strtok", [0,1,0,3], [("mtl", thisV [2, 1, 3, 1])])
         ,("acme-dont", [1,1], [])
-        ,("mtl",[2,2,1],[("base",anyV)
+        ,("mtl",[2,1,3,1],[("base",anyV)
                           ,("transformers",anyV)])
-        ,("transformers",[0,4,1,0],[("base",anyV)])]
+        ,("transformers",[0,3,0,0],[("base",anyV)])]
     it "default package set checks ok" $
       check defaultBuildConstraints getLatestAllowedPlans
     -}