From d944971a101ad1be52a416767864a9c233c537c0 Mon Sep 17 00:00:00 2001 From: Chris Done Date: Mon, 12 Jan 2015 01:08:52 +0100 Subject: [PATCH] shake: Creating and using local package db --- Stackage/PerformBuild.hs | 1 + Stackage/ShakeBuild.hs | 89 ++++++++++++++++++++++++++-------- test/Stackage/BuildPlanSpec.hs | 3 -- 3 files changed, 70 insertions(+), 23 deletions(-) diff --git a/Stackage/PerformBuild.hs b/Stackage/PerformBuild.hs index c74b449a..1f6baa4a 100644 --- a/Stackage/PerformBuild.hs +++ b/Stackage/PerformBuild.hs @@ -10,6 +10,7 @@ module Stackage.PerformBuild , PerformBuild (..) , BuildException (..) , pbDocDir + , copyBuiltInHaddocks ) where import Control.Concurrent.Async (async) diff --git a/Stackage/ShakeBuild.hs b/Stackage/ShakeBuild.hs index d1081cf2..67a3a9eb 100644 --- a/Stackage/ShakeBuild.hs +++ b/Stackage/ShakeBuild.hs @@ -2,25 +2,27 @@ module Stackage.ShakeBuild where +import Stackage.BuildConstraints import Stackage.BuildPlan import Stackage.PackageDescription -import Stackage.BuildConstraints -import Stackage.PerformBuild (PerformBuild(..)) +import Stackage.PerformBuild (PerformBuild(..),copyBuiltInHaddocks) -import Control.Monad -import Data.List ((\\)) +import Control.Monad hiding (forM_) import qualified Data.Map.Strict as M -import Data.Text (Text) -import Development.Shake +import qualified Data.Text as T +import Development.Shake hiding (doesDirectoryExist) import Distribution.Package (PackageName) import Distribution.Text (display) +import qualified Filesystem.Path.CurrentOS as FP +import Stackage.Prelude (unFlagName) import System.Directory import System.Environment -- | Run the shake builder. performBuild :: PerformBuild -> IO () performBuild pb = do - shakeDir <- fmap ( "shake/") getCurrentDirectory + shakeDir <- fmap ( "shake/") (getCurrentDirectory >>= canonicalizePath) + createDirectoryIfMissing True shakeDir withArgs [] (shakeArgs @@ -32,6 +34,9 @@ shakePlan :: PerformBuild -> FilePath -> Rules () shakePlan pb shakeDir = do fetched <- target (targetForFetched shakeDir) $ fetchedTarget shakeDir pb + db <- target + (targetForDb shakeDir pb) + (databaseTarget shakeDir pb) _ <- forM corePackages $ \name -> let fp = @@ -41,8 +46,8 @@ shakePlan pb shakeDir = do \(name,plan) -> target (targetForPackage shakeDir name) - (do need [fetched] - packageTarget shakeDir name plan) + (do need [db, fetched] + packageTarget pb shakeDir name plan) want packageTargets where corePackages = M.keys $ siCorePackages $ bpSystemInfo $ pbPlan pb @@ -50,6 +55,18 @@ shakePlan pb shakeDir = do filter (not . (`elem` corePackages) . fst) $ M.toList $ bpPackages $ pbPlan pb +-- | Initialize the database if there one needs to be, and in any case +-- create the target file. +databaseTarget :: FilePath -> PerformBuild -> Action () +databaseTarget shakeDir pb = + if pbGlobalInstall pb + then liftIO (createDirectoryIfMissing True dir) + else do liftIO (createDirectoryIfMissing True (dir)) + liftIO (removeDirectoryRecursive dir) + () <- cmd "ghc-pkg" "init" dir + liftIO (copyBuiltInHaddocks (FP.decodeString (pbDocDir pb))) + where dir = targetForDb shakeDir pb + -- | Make sure all package archives have been fetched. fetchedTarget :: FilePath -> PerformBuild -> Action () fetchedTarget shakeDir pb = do @@ -65,40 +82,72 @@ fetchedTarget shakeDir pb = do makeFile (targetForFetched shakeDir) -- | Build, test and generate documentation for the package. -packageTarget :: FilePath -> PackageName -> PackagePlan -> Action () -packageTarget shakeDir name plan = do +packageTarget :: PerformBuild -> FilePath -> PackageName -> PackagePlan -> Action () +packageTarget pb shakeDir name plan = do need (map (targetForPackage shakeDir) (M.keys (sdPackages (ppDesc plan)))) + pwd <- liftIO getCurrentDirectory + env <- liftIO (fmap (Env . (++ defaultEnv pwd)) getEnvironment) () <- 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" + () <- cmd cwd env "cabal" "configure" (opts pwd) + () <- cmd cwd env "cabal" "build" + () <- cmd cwd env "cabal" "copy" + () <- cmd cwd env "cabal" "register" makeFile (targetForPackage shakeDir name) - where pkgDir = + where cwd = Cwd pkgDir + defaultEnv pwd = [("HASKELL_PACKAGE_SANDBOX",pwd targetForDb shakeDir pb)] + opts pwd = ["--package-db=clear" + ,"--package-db=global" + ,"--libdir=" ++ pwd pbLibDir pb + ,"--bindir=" ++ pwd pbBinDir pb + ,"--datadir=" ++ pwd pbDataDir pb + ,"--docdir=" ++ pwd pbDocDir pb + ,"--flags=" ++ flags] ++ + ["--package-db=" ++ pwd targetForDb shakeDir pb + |not (pbGlobalInstall pb)] + pkgDir = shakeDir nameVer nameVer = display name ++ "-" ++ display (ppVersion plan) + flags = unwords $ map go $ M.toList (pcFlagOverrides (ppConstraints plan)) + where + go (name', isOn) = concat + [ if isOn then "" else "-" + , T.unpack (unFlagName name') + ] -- | Get the target file for confirming that all packages have been -- pre-fetched. -targetForFetched :: FilePattern -> FilePattern +targetForFetched :: FilePath -> FilePath targetForFetched shakeDir = shakeDir "fetched" -- | Get the target file for a package. -targetForPackage :: FilePattern -> PackageName -> FilePattern +targetForPackage :: FilePath -> PackageName -> FilePath targetForPackage shakeDir name = shakeDir "packages" display name +-- | Get a package database path. +targetForDb :: FilePath -> PerformBuild -> FilePath +targetForDb shakeDir pb = + if pbGlobalInstall pb + then shakeDir "pkgdb-global" + else FP.encodeString (pbInstallDest pb) "pkgdb" + -- | Declare a target, returning the target name. target :: FilePattern -> Action () -> Rules FilePattern -target name action = do - name *> const action +target name act = do + name *> const act return name -- | Make a file of this name. makeFile :: FilePath -> Action () makeFile fp = liftIO $ writeFile fp "" + +pbBinDir, pbLibDir, pbDataDir, pbDocDir :: PerformBuild -> FilePath +pbBinDir pb = FP.encodeString (pbInstallDest pb) "bin" +pbLibDir pb = FP.encodeString (pbInstallDest pb) "lib" +pbDataDir pb = FP.encodeString (pbInstallDest pb) "share" +pbDocDir pb = FP.encodeString (pbInstallDest pb) "doc" diff --git a/test/Stackage/BuildPlanSpec.hs b/test/Stackage/BuildPlanSpec.hs index d13dee52..433cfd87 100644 --- a/test/Stackage/BuildPlanSpec.hs +++ b/test/Stackage/BuildPlanSpec.hs @@ -82,8 +82,6 @@ basicBuild getPlans _ = do fullBuildConstraints getPlans let pb = (getPerformBuild buildFlags settings) - print (pbPlan pb) - logs <- performBuild pb mapM_ putStrLn logs) @@ -112,7 +110,6 @@ shakeBuild getPlans _ = do getPlans let pb = (getPerformBuild buildFlags settings) - print (pbPlan pb) Shake.performBuild pb) where buildType = Nightly