From 8d523d98cf1972d75bc0fa497a7b722f033ef628 Mon Sep 17 00:00:00 2001 From: Chris Done Date: Thu, 8 Jan 2015 12:59:01 +0100 Subject: [PATCH 01/47] Fix typo in doc string --- Stackage/BuildPlan.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Stackage/BuildPlan.hs b/Stackage/BuildPlan.hs index b8bc5376..b854b0c7 100644 --- a/Stackage/BuildPlan.hs +++ b/Stackage/BuildPlan.hs @@ -91,7 +91,7 @@ instance FromJSON PackagePlan where ppDesc <- o .: "description" return PackagePlan {..} --- | Make a build plan given these package set and build constraints. +-- | Make a build plan given this package set and build constraints. newBuildPlan :: MonadIO m => Map PackageName PackagePlan -> BuildConstraints -> m BuildPlan newBuildPlan packagesOrig bc@BuildConstraints {..} = liftIO $ do let toolMap = makeToolMap packagesOrig From 64a2393ca59e08c58e16fa49af56d0e0c39c8164 Mon Sep 17 00:00:00 2001 From: Chris Done Date: Thu, 8 Jan 2015 21:11:46 +0100 Subject: [PATCH 02/47] Basic build test in preparation for Shake --- Stackage/CompleteBuild.hs | 3 ++ Stackage/ShakeBuild.hs | 10 ++++++ stackage.cabal | 1 + test/Stackage/BuildPlanSpec.hs | 55 ++++++++++++++++++++++++++++++++ test/full-build-constraints.yaml | 20 ++++++++++++ 5 files changed, 89 insertions(+) create mode 100644 Stackage/ShakeBuild.hs create mode 100644 test/full-build-constraints.yaml diff --git a/Stackage/CompleteBuild.hs b/Stackage/CompleteBuild.hs index cf74eef2..89b443b7 100644 --- a/Stackage/CompleteBuild.hs +++ b/Stackage/CompleteBuild.hs @@ -5,9 +5,12 @@ module Stackage.CompleteBuild ( BuildType (..) , BumpType (..) , BuildFlags (..) + , Settings (..) , completeBuild , justCheck , justUploadNightly + , getPerformBuild + , nightlySettings ) where import Control.Concurrent (threadDelay) diff --git a/Stackage/ShakeBuild.hs b/Stackage/ShakeBuild.hs new file mode 100644 index 00000000..42600e11 --- /dev/null +++ b/Stackage/ShakeBuild.hs @@ -0,0 +1,10 @@ +-- | + +module Stackage.ShakeBuild where + +import Data.Text (Text) +import Stackage.PerformBuild (PerformBuild(..)) + +-- | Run the shake builder. +performBuild :: PerformBuild -> IO [Text] +performBuild = undefined diff --git a/stackage.cabal b/stackage.cabal index 94b42da9..877e9349 100644 --- a/stackage.cabal +++ b/stackage.cabal @@ -29,6 +29,7 @@ library Stackage.ServerBundle Stackage.Upload Stackage.PerformBuild + Stackage.ShakeBuild Stackage.CompleteBuild build-depends: base >= 4 && < 5 , containers diff --git a/test/Stackage/BuildPlanSpec.hs b/test/Stackage/BuildPlanSpec.hs index b87c74d2..e0180e1e 100644 --- a/test/Stackage/BuildPlanSpec.hs +++ b/test/Stackage/BuildPlanSpec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings, NoImplicitPrelude #-} module Stackage.BuildPlanSpec (spec) where @@ -13,8 +14,11 @@ import Network.HTTP.Client.TLS (tlsManagerSettings) import Stackage.BuildConstraints import Stackage.BuildPlan import Stackage.CheckBuildPlan +import Stackage.CompleteBuild import Stackage.PackageDescription +import Stackage.PerformBuild import Stackage.Prelude +import qualified Stackage.ShakeBuild as Shake import Stackage.UpdateBuildPlan import Test.Hspec @@ -37,6 +41,12 @@ spec = do ,("bar", [0, 0, 0], [("mu", thisV [0, 0, 0])]) ,("mu", [0, 0, 0], [("foo", thisV [0, 0, 0])])] {- Shouldn't be testing this actually + it "basic build" $ basicBuild $ 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 -} @@ -53,6 +63,34 @@ badBuildPlan m _ = do Right () -> error "Expected bad build plan." +-- | Perform a basic build. +basicBuild :: (BuildConstraints -> IO (Map PackageName PackagePlan)) + -> void + -> IO () +basicBuild getPlans _ = do + withManager + tlsManagerSettings + (\man -> + do settings@Settings{..} <- getTestSettings man + Nightly + fullBuildConstraints + getPlans + let pb = (getPerformBuild buildFlags settings) + print (pbPlan pb) + + logs <- performBuild + pb + mapM_ putStrLn logs) + 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)) @@ -134,6 +172,23 @@ thisV ver = thisVersion (Version ver []) anyV :: VersionRange anyV = anyVersion +-- | Get settings for doing test builds. +getTestSettings :: Manager -> BuildType -> (Manager -> IO BuildConstraints) -> (BuildConstraints -> IO (Map PackageName PackagePlan)) -> IO Settings +getTestSettings man Nightly readPlanFile getPlans = do + day <- tshow . utctDay <$> getCurrentTime + bc <- readPlanFile man + plans <- getPlans bc + bp <- newBuildPlan plans bc + return $ nightlySettings day bp + +-- | Test plan. +fullBuildConstraints :: void -> IO BuildConstraints +fullBuildConstraints _ = + decodeFileEither + (fpToString fp) >>= + either throwIO toBC + where fp = "test/full-build-constraints.yaml" + -- | Test plan. testBuildConstraints :: void -> IO BuildConstraints testBuildConstraints _ = diff --git a/test/full-build-constraints.yaml b/test/full-build-constraints.yaml new file mode 100644 index 00000000..ea4f1b20 --- /dev/null +++ b/test/full-build-constraints.yaml @@ -0,0 +1,20 @@ +packages: + "Test": + - acme-dont + - acme-strtok + +global-flags: [] + +skipped-tests: [] +expected-test-failures: [] +expected-haddock-failures: [] +skipped-benchmarks: [] +skipped-profiling: [] + +github-users: + bar: + - demo + +package-flags: + foo: + demo: true From bb6078f4f1387a7ca73157839dff15a49a96e43d Mon Sep 17 00:00:00 2001 From: Chris Done Date: Sun, 11 Jan 2015 20:28:07 +0100 Subject: [PATCH 03/47] shake: fetching packages --- Stackage/ShakeBuild.hs | 49 ++++++++++++++++++++++++++++++---- test/Stackage/BuildPlanSpec.hs | 31 +++++++++++++++++++++ 2 files changed, 75 insertions(+), 5 deletions(-) diff --git a/Stackage/ShakeBuild.hs b/Stackage/ShakeBuild.hs index 42600e11..c9022699 100644 --- a/Stackage/ShakeBuild.hs +++ b/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 "") diff --git a/test/Stackage/BuildPlanSpec.hs b/test/Stackage/BuildPlanSpec.hs index e0180e1e..4981c049 100644 --- a/test/Stackage/BuildPlanSpec.hs +++ b/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)) From f677e8bb73a806d2db893f499e8e4ea057a89745 Mon Sep 17 00:00:00 2001 From: Chris Done Date: Sun, 11 Jan 2015 21:33:42 +0100 Subject: [PATCH 04/47] shake: unpacking, building and registering --- Stackage/ShakeBuild.hs | 95 +++++++++++++++++++++++++++------- stackage.cabal | 1 + test/Stackage/BuildPlanSpec.hs | 8 +-- 3 files changed, 80 insertions(+), 24 deletions(-) diff --git a/Stackage/ShakeBuild.hs b/Stackage/ShakeBuild.hs index c9022699..d1081cf2 100644 --- a/Stackage/ShakeBuild.hs +++ b/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 - createDirectoryIfMissing True shakeDir + shakeDir <- fmap ( "shake/") getCurrentDirectory 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) - want [wantedFetched] - where wantedFetched = - shakeDir "fetched" + fetched <- target (targetForFetched shakeDir) $ + fetchedTarget shakeDir pb + _ <- forM corePackages $ + \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 = - do () <- cmd - "cabal" - "fetch" - "--no-dependencies" - (map - (\(name,plan) -> - display name ++ - "-" ++ - display (ppVersion plan)) - (M.toList - (bpPackages - (pbPlan pb)))) - liftIO (writeFile wantedFile "") +fetchedTarget shakeDir pb = do + () <- cmd "cabal" "fetch" "--no-dependencies" $ + map + (\(name,plan) -> + display name ++ + "-" ++ + display (ppVersion plan)) + (M.toList + (bpPackages + (pbPlan pb))) + 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 "" diff --git a/stackage.cabal b/stackage.cabal index 877e9349..114e83cb 100644 --- a/stackage.cabal +++ b/stackage.cabal @@ -64,6 +64,7 @@ library , streaming-commons >= 0.1.7.1 , semigroups , xml-conduit + , shake executable stackage default-language: Haskell2010 diff --git a/test/Stackage/BuildPlanSpec.hs b/test/Stackage/BuildPlanSpec.hs index 4981c049..d13dee52 100644 --- a/test/Stackage/BuildPlanSpec.hs +++ b/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) - ,("transformers",anyV)]) - ,("transformers",[0,4,1,0],[("base",anyV)])] + ,("mtl",[2,1,3,1],[("base",anyV) + ,("transformers",anyV)]) + ,("transformers",[0,3,0,0],[("base",anyV)])] it "default package set checks ok" $ check defaultBuildConstraints getLatestAllowedPlans -} From d944971a101ad1be52a416767864a9c233c537c0 Mon Sep 17 00:00:00 2001 From: Chris Done Date: Mon, 12 Jan 2015 01:08:52 +0100 Subject: [PATCH 05/47] 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 From c109bbaa2e7787946722b93ac7a3726cbc553422 Mon Sep 17 00:00:00 2001 From: Chris Done Date: Tue, 13 Jan 2015 19:26:30 +0100 Subject: [PATCH 06/47] Fix path relativity in package db --- Stackage/ShakeBuild.hs | 47 +++++++++++++++++++++++++++--------------- 1 file changed, 30 insertions(+), 17 deletions(-) diff --git a/Stackage/ShakeBuild.hs b/Stackage/ShakeBuild.hs index 67a3a9eb..d821b08f 100644 --- a/Stackage/ShakeBuild.hs +++ b/Stackage/ShakeBuild.hs @@ -94,29 +94,42 @@ packageTarget pb shakeDir name plan = do () <- cmd cwd env "cabal" "copy" () <- cmd cwd env "cabal" "register" makeFile (targetForPackage shakeDir name) - 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)] + 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') - ] + 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. From a94ff15c5993ceaee3d28a8d2c117d53ada0a299 Mon Sep 17 00:00:00 2001 From: Chris Done Date: Tue, 13 Jan 2015 19:26:34 +0100 Subject: [PATCH 07/47] Only unpack when necessary --- Stackage/ShakeBuild.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/Stackage/ShakeBuild.hs b/Stackage/ShakeBuild.hs index d821b08f..e4f4aaf1 100644 --- a/Stackage/ShakeBuild.hs +++ b/Stackage/ShakeBuild.hs @@ -88,7 +88,9 @@ packageTarget pb shakeDir name plan = do (M.keys (sdPackages (ppDesc plan)))) pwd <- liftIO getCurrentDirectory env <- liftIO (fmap (Env . (++ defaultEnv pwd)) getEnvironment) - () <- cmd (Cwd shakeDir) "cabal" "unpack" nameVer + unpacked <- liftIO (doesDirectoryExist (shakeDir nameVer)) + unless unpacked + (cmd (Cwd shakeDir) "cabal" "unpack" nameVer) () <- cmd cwd env "cabal" "configure" (opts pwd) () <- cmd cwd env "cabal" "build" () <- cmd cwd env "cabal" "copy" From 127fe575e70cc42986efcbb145f57deffbe82fb0 Mon Sep 17 00:00:00 2001 From: Chris Done Date: Tue, 13 Jan 2015 19:31:13 +0100 Subject: [PATCH 08/47] Small refactoring --- Stackage/ShakeBuild.hs | 60 +++++++++++++++++++++--------------------- 1 file changed, 30 insertions(+), 30 deletions(-) diff --git a/Stackage/ShakeBuild.hs b/Stackage/ShakeBuild.hs index e4f4aaf1..86f83112 100644 --- a/Stackage/ShakeBuild.hs +++ b/Stackage/ShakeBuild.hs @@ -88,10 +88,10 @@ packageTarget pb shakeDir name plan = do (M.keys (sdPackages (ppDesc plan)))) pwd <- liftIO getCurrentDirectory env <- liftIO (fmap (Env . (++ defaultEnv pwd)) getEnvironment) - unpacked <- liftIO (doesDirectoryExist (shakeDir nameVer)) - unless unpacked - (cmd (Cwd shakeDir) "cabal" "unpack" nameVer) - () <- cmd cwd env "cabal" "configure" (opts pwd) + unpacked <- liftIO (doesDirectoryExist pkgDir) + unless unpacked $ + cmd (Cwd shakeDir) "cabal" "unpack" nameVer + () <- cmd cwd env "cabal" "configure" (opts shakeDir pb plan pwd) () <- cmd cwd env "cabal" "build" () <- cmd cwd env "cabal" "copy" () <- cmd cwd env "cabal" "register" @@ -102,36 +102,36 @@ packageTarget pb shakeDir name plan = do [ ( "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 + 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')] + +-- | Make @cabal configure@ options for a package. +opts :: FilePath -> PerformBuild -> PackagePlan -> FilePattern -> [String] +opts shakeDir pb plan pwd = + [ "--package-db=clear" + , "--package-db=global" + , "--libdir=" ++ pwd pbLibDir pb + , "--bindir=" ++ pwd pbBinDir pb + , "--datadir=" ++ pwd pbDataDir pb + , "--docdir=" ++ pwd pbDocDir pb + , "--flags=" ++ planFlags plan] ++ + ["--package-db=" ++ + pwd + targetForDb shakeDir pb | not (pbGlobalInstall pb)] + +-- | Generate a flags string for the package plan. +planFlags :: PackagePlan -> String +planFlags plan = 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. From 9d3bab31d0ad404db4e6a1338db698a4637f5084 Mon Sep 17 00:00:00 2001 From: Chris Done Date: Tue, 13 Jan 2015 20:27:56 +0100 Subject: [PATCH 09/47] Proper caching of database --- Stackage/ShakeBuild.hs | 34 +++++++++++++++++++--------------- 1 file changed, 19 insertions(+), 15 deletions(-) diff --git a/Stackage/ShakeBuild.hs b/Stackage/ShakeBuild.hs index 86f83112..125cb737 100644 --- a/Stackage/ShakeBuild.hs +++ b/Stackage/ShakeBuild.hs @@ -35,7 +35,7 @@ shakePlan pb shakeDir = do fetched <- target (targetForFetched shakeDir) $ fetchedTarget shakeDir pb db <- target - (targetForDb shakeDir pb) + (targetForDb' shakeDir) (databaseTarget shakeDir pb) _ <- forM corePackages $ \name -> @@ -59,13 +59,18 @@ shakePlan pb shakeDir = do -- 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 + do if pbGlobalInstall pb + then return () + else do liftIO (createDirectoryIfMissing True dir) + liftIO (removeDirectoryRecursive dir) + () <- cmd "ghc-pkg" "init" dir + liftIO (copyBuiltInHaddocks (FP.decodeString (pbDocDir pb))) + makeFile (targetForDb' shakeDir) + where dir = buildDatabase pb + +-- | Database location. +buildDatabase :: PerformBuild -> FilePattern +buildDatabase pb = FP.encodeString (pbInstallDest pb) "pkgdb" -- | Make sure all package archives have been fetched. fetchedTarget :: FilePath -> PerformBuild -> Action () @@ -101,7 +106,8 @@ packageTarget pb shakeDir name plan = do defaultEnv pwd = [ ( "HASKELL_PACKAGE_SANDBOX" , pwd - targetForDb shakeDir pb)] + buildDatabase pb) + | pbGlobalInstall pb] pkgDir = shakeDir nameVer nameVer = display name ++ @@ -120,7 +126,7 @@ opts shakeDir pb plan pwd = , "--flags=" ++ planFlags plan] ++ ["--package-db=" ++ pwd - targetForDb shakeDir pb | not (pbGlobalInstall pb)] + buildDatabase pb | not (pbGlobalInstall pb)] -- | Generate a flags string for the package plan. planFlags :: PackagePlan -> String @@ -145,11 +151,9 @@ 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" +targetForDb' :: FilePath -> FilePath +targetForDb' shakeDir = + shakeDir "pkgdb" -- | Declare a target, returning the target name. target :: FilePattern -> Action () -> Rules FilePattern From ff996e9410e1adf0b331409d26a72b68a0764d72 Mon Sep 17 00:00:00 2001 From: Chris Done Date: Tue, 13 Jan 2015 20:35:41 +0100 Subject: [PATCH 10/47] Don't reconfigure if unnecessary --- Stackage/ShakeBuild.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/Stackage/ShakeBuild.hs b/Stackage/ShakeBuild.hs index 125cb737..e55d8250 100644 --- a/Stackage/ShakeBuild.hs +++ b/Stackage/ShakeBuild.hs @@ -10,7 +10,7 @@ import Stackage.PerformBuild (PerformBuild(..),copyBuiltInHaddocks) import Control.Monad hiding (forM_) import qualified Data.Map.Strict as M import qualified Data.Text as T -import Development.Shake hiding (doesDirectoryExist) +import Development.Shake hiding (doesFileExist,doesDirectoryExist) import Distribution.Package (PackageName) import Distribution.Text (display) import qualified Filesystem.Path.CurrentOS as FP @@ -96,7 +96,9 @@ packageTarget pb shakeDir name plan = do unpacked <- liftIO (doesDirectoryExist pkgDir) unless unpacked $ cmd (Cwd shakeDir) "cabal" "unpack" nameVer - () <- cmd cwd env "cabal" "configure" (opts shakeDir pb plan pwd) + configured <- liftIO (doesFileExist (pkgDir "dist" "setup-config")) + unless configured $ + cmd cwd env "cabal" "configure" (opts shakeDir pb plan pwd) () <- cmd cwd env "cabal" "build" () <- cmd cwd env "cabal" "copy" () <- cmd cwd env "cabal" "register" From 585e8bd1c7bc5db1b4bed13ebd814372d00cc2e6 Mon Sep 17 00:00:00 2001 From: Chris Done Date: Tue, 13 Jan 2015 23:42:06 +0100 Subject: [PATCH 11/47] shake: Do Haddock generation --- Stackage/PerformBuild.hs | 1 + Stackage/ShakeBuild.hs | 186 ++++++++++++++++++++++++--------- test/Stackage/BuildPlanSpec.hs | 2 +- 3 files changed, 137 insertions(+), 52 deletions(-) diff --git a/Stackage/PerformBuild.hs b/Stackage/PerformBuild.hs index 1f6baa4a..a3b46c5a 100644 --- a/Stackage/PerformBuild.hs +++ b/Stackage/PerformBuild.hs @@ -11,6 +11,7 @@ module Stackage.PerformBuild , BuildException (..) , pbDocDir , copyBuiltInHaddocks + , renameOrCopy ) where import Control.Concurrent.Async (async) diff --git a/Stackage/ShakeBuild.hs b/Stackage/ShakeBuild.hs index e55d8250..0828a41f 100644 --- a/Stackage/ShakeBuild.hs +++ b/Stackage/ShakeBuild.hs @@ -1,20 +1,28 @@ +{-# LANGUAGE ScopedTypeVariables #-} + -- | Build everything with Shake. module Stackage.ShakeBuild where +import Data.Monoid import Stackage.BuildConstraints import Stackage.BuildPlan import Stackage.PackageDescription -import Stackage.PerformBuild (PerformBuild(..),copyBuiltInHaddocks) +import Stackage.PerformBuild (PerformBuild(..),copyBuiltInHaddocks,renameOrCopy) +import Stackage.Prelude (unFlagName) +import Control.Concurrent.STM +import Control.Concurrent.STM.TVar +import Control.Exception import Control.Monad hiding (forM_) +import Data.Map.Strict (Map) import qualified Data.Map.Strict as M +import qualified Data.Set as S import qualified Data.Text as T import Development.Shake hiding (doesFileExist,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 @@ -23,15 +31,17 @@ performBuild :: PerformBuild -> IO () performBuild pb = do shakeDir <- fmap ( "shake/") (getCurrentDirectory >>= canonicalizePath) createDirectoryIfMissing True shakeDir + haddockFiles <- liftIO (newTVarIO mempty) withArgs [] (shakeArgs - shakeOptions {shakeFiles = shakeDir} - (shakePlan pb shakeDir)) + shakeOptions {shakeFiles = shakeDir + ,shakeVerbosity = Diagnostic} + (shakePlan haddockFiles pb shakeDir)) -- | The complete build plan as far as Shake is concerned. -shakePlan :: PerformBuild -> FilePath -> Rules () -shakePlan pb shakeDir = do +shakePlan :: TVar (Map String FilePath) -> PerformBuild -> FilePath -> Rules () +shakePlan haddockFiles pb shakeDir = do fetched <- target (targetForFetched shakeDir) $ fetchedTarget shakeDir pb db <- target @@ -47,7 +57,7 @@ shakePlan pb shakeDir = do target (targetForPackage shakeDir name) (do need [db, fetched] - packageTarget pb shakeDir name plan) + packageTarget haddockFiles pb shakeDir name plan) want packageTargets where corePackages = M.keys $ siCorePackages $ bpSystemInfo $ pbPlan pb @@ -68,9 +78,34 @@ databaseTarget shakeDir pb = makeFile (targetForDb' shakeDir) where dir = buildDatabase pb --- | Database location. -buildDatabase :: PerformBuild -> FilePattern -buildDatabase pb = FP.encodeString (pbInstallDest pb) "pkgdb" +-- | Build, test and generate documentation for the package. +packageTarget :: TVar (Map String FilePath) + -> PerformBuild -> FilePath -> PackageName -> PackagePlan + -> Action () +packageTarget haddockFiles pb shakeDir name plan = do + need (map (targetForPackage shakeDir) + (M.keys (sdPackages (ppDesc plan)))) + pwd <- liftIO getCurrentDirectory + env <- liftIO (fmap (Env . (++ defaultEnv pwd)) getEnvironment) + unpack shakeDir nameVer + configure pkgDir env pb plan + () <- cmd cwd env "cabal" "build" + register pkgDir env + when (pcHaddocks (ppConstraints plan) /= Don'tBuild) $ + (generateHaddocks haddockFiles pb pkgDir env name nameVer) + makeFile (targetForPackage shakeDir name) + where cwd = + Cwd pkgDir + defaultEnv pwd = + [ ( "HASKELL_PACKAGE_SANDBOX" + , pwd + buildDatabase pb) + | pbGlobalInstall pb] + pkgDir = shakeDir nameVer + nameVer = + display name ++ + "-" ++ + display (ppVersion plan) -- | Make sure all package archives have been fetched. fetchedTarget :: FilePath -> PerformBuild -> Action () @@ -86,49 +121,94 @@ fetchedTarget shakeDir pb = do (pbPlan pb))) makeFile (targetForFetched shakeDir) --- | Build, test and generate documentation for the package. -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) +-- | Unpack the package. +unpack :: FilePath -> String -> Action () +unpack shakeDir nameVer = do unpacked <- liftIO (doesDirectoryExist pkgDir) - unless unpacked $ - cmd (Cwd shakeDir) "cabal" "unpack" nameVer - configured <- liftIO (doesFileExist (pkgDir "dist" "setup-config")) - unless configured $ - cmd cwd env "cabal" "configure" (opts shakeDir pb plan pwd) - () <- cmd cwd env "cabal" "build" - () <- cmd cwd env "cabal" "copy" - () <- cmd cwd env "cabal" "register" - makeFile (targetForPackage shakeDir name) - where cwd = - Cwd pkgDir - defaultEnv pwd = - [ ( "HASKELL_PACKAGE_SANDBOX" - , pwd - buildDatabase pb) - | pbGlobalInstall pb] - pkgDir = shakeDir nameVer - nameVer = - display name ++ - "-" ++ - display (ppVersion plan) + unless unpacked (cmd (Cwd shakeDir) "cabal" "unpack" nameVer) + where pkgDir = + shakeDir nameVer --- | Make @cabal configure@ options for a package. -opts :: FilePath -> PerformBuild -> PackagePlan -> FilePattern -> [String] -opts shakeDir pb plan pwd = - [ "--package-db=clear" - , "--package-db=global" - , "--libdir=" ++ pwd pbLibDir pb - , "--bindir=" ++ pwd pbBinDir pb - , "--datadir=" ++ pwd pbDataDir pb - , "--docdir=" ++ pwd pbDocDir pb - , "--flags=" ++ planFlags plan] ++ - ["--package-db=" ++ - pwd - buildDatabase pb | not (pbGlobalInstall pb)] +-- | Configure the given package. +configure :: FilePath -> CmdOption -> PerformBuild -> PackagePlan -> Action () +configure pkgDir env pb plan = do + configured <- liftIO + (doesFileExist + (pkgDir "dist" "setup-config")) + unless + configured + (do pwd <- liftIO getCurrentDirectory + cmd (Cwd pkgDir) env "cabal" "configure" (opts pwd)) + where 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=" ++ planFlags plan] ++ + ["--package-db=" ++ + pwd + buildDatabase pb | not (pbGlobalInstall pb)] + +-- | Register the package. +-- +-- TODO: Do a mutex lock in here. Does Shake already support doing +-- this out of the box? +register :: FilePath -> CmdOption -> Action () +register pkgDir env = + do () <- cmd cwd env "cabal" "copy" + cmd cwd env "cabal" "register" + where cwd = Cwd pkgDir + +-- | Generate haddocks for the package. +generateHaddocks + :: TVar (Map String FilePath) + -> PerformBuild + -> FilePath + -> CmdOption + -> PackageName + -> FilePattern + -> Action () +generateHaddocks haddockFiles pb pkgDir env name nameVer = do + hfs <- liftIO (readTVarIO haddockFiles) + () <- cmd + (Cwd pkgDir) + env + "cabal" + "haddock" + "--hyperlink-source" + "--html" + "--hoogle" + "--html-location=../$pkg-$version/" + (map + (\(pkgVer,hf) -> + concat + [ "--haddock-options=--read-interface=" + , "../" + , pkgVer + , "/," + , hf]) + (M.toList hfs)) + liftIO + (renameOrCopy + (FP.decodeString + (pkgDir "dist" "doc" "html" display name)) + (FP.decodeString + (pbDocDir pb nameVer))) + enewPath <- liftIO + (try $ + canonicalizePath + (pbDocDir pb nameVer display name ++ + ".haddock")) + case enewPath of + Left (e :: IOException) -> + return () -- FIXME: log it with Shake. + Right newPath -> + liftIO + (atomically $ + modifyTVar haddockFiles $ + M.insert nameVer newPath) -- | Generate a flags string for the package plan. planFlags :: PackagePlan -> String @@ -141,6 +221,10 @@ planFlags plan = unwords $ map go $ M.toList (pcFlagOverrides (ppConstraints pla else "-" , T.unpack (unFlagName name')] +-- | Database location. +buildDatabase :: PerformBuild -> FilePattern +buildDatabase pb = FP.encodeString (pbInstallDest pb) "pkgdb" + -- | Get the target file for confirming that all packages have been -- pre-fetched. targetForFetched :: FilePath -> FilePath diff --git a/test/Stackage/BuildPlanSpec.hs b/test/Stackage/BuildPlanSpec.hs index 433cfd87..c57eaab1 100644 --- a/test/Stackage/BuildPlanSpec.hs +++ b/test/Stackage/BuildPlanSpec.hs @@ -181,7 +181,7 @@ makePackageSet ps _ = {pcVersionRange = anyV ,pcMaintainer = Nothing ,pcTests = Don'tBuild - ,pcHaddocks = Don'tBuild + ,pcHaddocks = ExpectSuccess ,pcBuildBenchmarks = False ,pcFlagOverrides = mempty ,pcEnableLibProfile = False} From 794881627ec75dbd853ad7e646dbc8422136d327 Mon Sep 17 00:00:00 2001 From: Chris Done Date: Wed, 14 Jan 2015 01:24:25 +0100 Subject: [PATCH 12/47] Drop cycles --- Stackage/CheckBuildPlan.hs | 12 +- Stackage/ShakeBuild.hs | 241 ++++++++++++++++++++----------------- 2 files changed, 136 insertions(+), 117 deletions(-) diff --git a/Stackage/CheckBuildPlan.hs b/Stackage/CheckBuildPlan.hs index 74bf3b83..a2a0c4af 100644 --- a/Stackage/CheckBuildPlan.hs +++ b/Stackage/CheckBuildPlan.hs @@ -8,6 +8,7 @@ -- | Confirm that a build plan has a consistent set of dependencies. module Stackage.CheckBuildPlan ( checkBuildPlan + , libAndExe , BadBuildPlan ) where @@ -29,10 +30,13 @@ checkBuildPlan BuildPlan {..} map (ppVersion &&& M.keys . M.filter libAndExe . sdPackages . ppDesc) bpPackages errs@(BadBuildPlan errs') = execWriter $ mapM_ (checkDeps allPackages) $ mapToList bpPackages - -- Only looking at libraries and executables, benchmarks and tests - -- are allowed to create cycles (e.g. test-framework depends on - -- text, which uses test-framework in its test-suite). - libAndExe (DepInfo cs _) = any (flip elem [CompLibrary,CompExecutable]) cs + + +-- Only looking at libraries and executables, benchmarks and tests +-- are allowed to create cycles (e.g. test-framework depends on +-- text, which uses test-framework in its test-suite). +libAndExe :: DepInfo -> Bool +libAndExe (DepInfo cs _) = any (flip elem [CompLibrary,CompExecutable]) cs -- | For a given package name and plan, check that its dependencies are: -- diff --git a/Stackage/ShakeBuild.hs b/Stackage/ShakeBuild.hs index 0828a41f..a3402d34 100644 --- a/Stackage/ShakeBuild.hs +++ b/Stackage/ShakeBuild.hs @@ -4,9 +4,10 @@ module Stackage.ShakeBuild where -import Data.Monoid +import Control.Concurrent.MVar import Stackage.BuildConstraints import Stackage.BuildPlan +import Stackage.CheckBuildPlan import Stackage.PackageDescription import Stackage.PerformBuild (PerformBuild(..),copyBuiltInHaddocks,renameOrCopy) import Stackage.Prelude (unFlagName) @@ -17,6 +18,7 @@ import Control.Exception import Control.Monad hiding (forM_) import Data.Map.Strict (Map) import qualified Data.Map.Strict as M +import Data.Monoid import qualified Data.Set as S import qualified Data.Text as T import Development.Shake hiding (doesFileExist,doesDirectoryExist) @@ -32,81 +34,94 @@ performBuild pb = do shakeDir <- fmap ( "shake/") (getCurrentDirectory >>= canonicalizePath) createDirectoryIfMissing True shakeDir haddockFiles <- liftIO (newTVarIO mempty) - withArgs - [] - (shakeArgs - shakeOptions {shakeFiles = shakeDir - ,shakeVerbosity = Diagnostic} - (shakePlan haddockFiles pb shakeDir)) + registerLock <- liftIO (newMVar ()) + withArgs [] $ + shakeArgs + shakeOptions + { shakeFiles = shakeDir + , shakeThreads = 2 + } $ + shakePlan haddockFiles registerLock pb shakeDir -- | The complete build plan as far as Shake is concerned. -shakePlan :: TVar (Map String FilePath) -> PerformBuild -> FilePath -> Rules () -shakePlan haddockFiles pb shakeDir = do +shakePlan :: TVar (Map String FilePath) + -> MVar () + -> PerformBuild + -> FilePath + -> Rules () +shakePlan haddockFiles registerLock pb shakeDir = do fetched <- target (targetForFetched shakeDir) $ fetchedTarget shakeDir pb - db <- target - (targetForDb' shakeDir) - (databaseTarget shakeDir pb) + db <- target (targetForDb' shakeDir) $ + databaseTarget shakeDir pb _ <- forM corePackages $ \name -> - let fp = - targetForPackage shakeDir name + let fp = targetForPackage shakeDir name in target fp (makeFile fp) packageTargets <- forM normalPackages $ \(name,plan) -> - target - (targetForPackage shakeDir name) - (do need [db, fetched] - packageTarget haddockFiles pb shakeDir name plan) + target (targetForPackage shakeDir name) $ + do need [db, fetched] + packageTarget + haddockFiles + registerLock + pb + shakeDir + name + plan want packageTargets - where corePackages = - M.keys $ siCorePackages $ bpSystemInfo $ pbPlan pb - normalPackages = - filter (not . (`elem` corePackages) . fst) $ + where corePackages = M.keys $ siCorePackages $ bpSystemInfo $ pbPlan pb + normalPackages = 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 = - do if pbGlobalInstall pb - then return () - else do liftIO (createDirectoryIfMissing True dir) - liftIO (removeDirectoryRecursive dir) - () <- cmd "ghc-pkg" "init" dir - liftIO (copyBuiltInHaddocks (FP.decodeString (pbDocDir pb))) - makeFile (targetForDb' shakeDir) - where dir = buildDatabase pb +databaseTarget shakeDir pb = do + if pbGlobalInstall pb + then return () + else do + liftIO (createDirectoryIfMissing True dir) + liftIO (removeDirectoryRecursive dir) + () <- cmd "ghc-pkg" "init" dir + liftIO + (copyBuiltInHaddocks + (FP.decodeString + (pbDocDir pb))) + makeFile (targetForDb' shakeDir) + where dir = buildDatabase pb -- | Build, test and generate documentation for the package. packageTarget :: TVar (Map String FilePath) - -> PerformBuild -> FilePath -> PackageName -> PackagePlan + -> MVar () + -> PerformBuild + -> FilePath + -> PackageName + -> PackagePlan -> Action () -packageTarget haddockFiles pb shakeDir name plan = do - need (map (targetForPackage shakeDir) - (M.keys (sdPackages (ppDesc plan)))) +packageTarget haddockFiles registerLock pb shakeDir name plan = do + need $ + map (targetForPackage shakeDir) $ + filter (/= name) $ + M.keys $ M.filter libAndExe $ sdPackages $ ppDesc plan pwd <- liftIO getCurrentDirectory env <- liftIO (fmap (Env . (++ defaultEnv pwd)) getEnvironment) unpack shakeDir nameVer configure pkgDir env pb plan - () <- cmd cwd env "cabal" "build" - register pkgDir env - when (pcHaddocks (ppConstraints plan) /= Don'tBuild) $ - (generateHaddocks haddockFiles pb pkgDir env name nameVer) + () <- cmd cwd env "cabal" "build" "--ghc-options=-O0" + register pkgDir env registerLock makeFile (targetForPackage shakeDir name) - where cwd = - Cwd pkgDir - defaultEnv pwd = - [ ( "HASKELL_PACKAGE_SANDBOX" - , pwd - buildDatabase pb) - | pbGlobalInstall pb] + where cwd = Cwd pkgDir + defaultEnv pwd = [( "HASKELL_PACKAGE_SANDBOX" + , pwd buildDatabase pb) | pbGlobalInstall pb] pkgDir = shakeDir nameVer - nameVer = - display name ++ + nameVer = display name ++ "-" ++ display (ppVersion plan) +{-when (pcHaddocks (ppConstraints plan) /= Don'tBuild) $ +(generateHaddocks haddockFiles pb pkgDir env name nameVer)-} + -- | Make sure all package archives have been fetched. fetchedTarget :: FilePath -> PerformBuild -> Action () fetchedTarget shakeDir pb = do @@ -115,63 +130,64 @@ fetchedTarget shakeDir pb = do (\(name,plan) -> display name ++ "-" ++ - display (ppVersion plan)) - (M.toList - (bpPackages - (pbPlan pb))) + display (ppVersion plan)) $ + M.toList $ bpPackages $ pbPlan pb makeFile (targetForFetched shakeDir) -- | Unpack the package. unpack :: FilePath -> String -> Action () unpack shakeDir nameVer = do unpacked <- liftIO (doesDirectoryExist pkgDir) - unless unpacked (cmd (Cwd shakeDir) "cabal" "unpack" nameVer) - where pkgDir = - shakeDir nameVer + unless unpacked $ + cmd (Cwd shakeDir) "cabal" "unpack" nameVer + where pkgDir = shakeDir nameVer -- | Configure the given package. configure :: FilePath -> CmdOption -> PerformBuild -> PackagePlan -> Action () configure pkgDir env pb plan = do - configured <- liftIO - (doesFileExist - (pkgDir "dist" "setup-config")) - unless - configured - (do pwd <- liftIO getCurrentDirectory - cmd (Cwd pkgDir) env "cabal" "configure" (opts pwd)) - where 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=" ++ planFlags plan] ++ - ["--package-db=" ++ - pwd - buildDatabase pb | not (pbGlobalInstall pb)] + configured <- liftIO $ doesFileExist $ pkgDir "dist" + "setup-config" + unless configured $ + do pwd <- liftIO getCurrentDirectory + cmd + (Cwd pkgDir) + env + "cabal" + "configure" + (opts pwd) + where 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=" ++ planFlags plan] ++ + ["--package-db=" ++ pwd buildDatabase pb | not (pbGlobalInstall pb)] -- | Register the package. -- -- TODO: Do a mutex lock in here. Does Shake already support doing -- this out of the box? -register :: FilePath -> CmdOption -> Action () -register pkgDir env = - do () <- cmd cwd env "cabal" "copy" - cmd cwd env "cabal" "register" - where cwd = Cwd pkgDir +register :: FilePath -> CmdOption -> MVar () -> Action () +register pkgDir env registerLock = do + () <- cmd cwd env "cabal" "copy" + -- FIXME: + liftIO + (takeMVar registerLock) + () <- cmd cwd env "cabal" "register" + liftIO (putMVar registerLock ()) + where cwd = Cwd pkgDir -- | Generate haddocks for the package. -generateHaddocks - :: TVar (Map String FilePath) - -> PerformBuild - -> FilePath - -> CmdOption - -> PackageName - -> FilePattern - -> Action () +generateHaddocks :: TVar (Map String FilePath) + -> PerformBuild + -> FilePath + -> CmdOption + -> PackageName + -> FilePattern + -> Action () generateHaddocks haddockFiles pb pkgDir env name nameVer = do - hfs <- liftIO (readTVarIO haddockFiles) + hfs <- liftIO $ readTVarIO haddockFiles () <- cmd (Cwd pkgDir) env @@ -190,36 +206,35 @@ generateHaddocks haddockFiles pb pkgDir env name nameVer = do , "/," , hf]) (M.toList hfs)) - liftIO - (renameOrCopy - (FP.decodeString - (pkgDir "dist" "doc" "html" display name)) - (FP.decodeString - (pbDocDir pb nameVer))) - enewPath <- liftIO - (try $ - canonicalizePath - (pbDocDir pb nameVer display name ++ - ".haddock")) + liftIO $ + renameOrCopy + (FP.decodeString + (pkgDir "dist" "doc" "html" display name)) + (FP.decodeString + (pbDocDir pb nameVer)) + enewPath <- liftIO $ + try $ + canonicalizePath + (pbDocDir pb nameVer display name ++ ".haddock") case enewPath of - Left (e :: IOException) -> - return () -- FIXME: log it with Shake. - Right newPath -> - liftIO - (atomically $ - modifyTVar haddockFiles $ - M.insert nameVer newPath) + Left (e :: IOException) -> return () -- FIXME: log it with Shake. + Right newPath -> liftIO $ + atomically $ + modifyTVar haddockFiles $ + M.insert nameVer newPath -- | Generate a flags string for the package plan. planFlags :: PackagePlan -> String -planFlags plan = unwords $ map go $ M.toList (pcFlagOverrides (ppConstraints plan)) - where - go (name',isOn) = - concat - [ if isOn - then "" - else "-" - , T.unpack (unFlagName name')] +planFlags plan = unwords $ + map go $ + M.toList + (pcFlagOverrides + (ppConstraints plan)) + where go (name',isOn) = concat + [ if isOn + then "" + else "-" + , T.unpack (unFlagName name')] -- | Database location. buildDatabase :: PerformBuild -> FilePattern From 7f7250702b1aab789ef24a88d4b5ef486bb94d32 Mon Sep 17 00:00:00 2001 From: Chris Done Date: Wed, 14 Jan 2015 01:30:22 +0100 Subject: [PATCH 13/47] Style tweak --- Stackage/ShakeBuild.hs | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/Stackage/ShakeBuild.hs b/Stackage/ShakeBuild.hs index a3402d34..fa413bf5 100644 --- a/Stackage/ShakeBuild.hs +++ b/Stackage/ShakeBuild.hs @@ -84,10 +84,7 @@ databaseTarget shakeDir pb = do liftIO (createDirectoryIfMissing True dir) liftIO (removeDirectoryRecursive dir) () <- cmd "ghc-pkg" "init" dir - liftIO - (copyBuiltInHaddocks - (FP.decodeString - (pbDocDir pb))) + liftIO $ copyBuiltInHaddocks $ FP.decodeString $ pbDocDir pb makeFile (targetForDb' shakeDir) where dir = buildDatabase pb From e774fc15fd42f58604d27ce8900425b517112fa3 Mon Sep 17 00:00:00 2001 From: Chris Done Date: Wed, 14 Jan 2015 17:14:39 +0100 Subject: [PATCH 14/47] shake: Build haddocks --- Stackage/ShakeBuild.hs | 130 +++++++++++++++++++++++++++-------------- 1 file changed, 87 insertions(+), 43 deletions(-) diff --git a/Stackage/ShakeBuild.hs b/Stackage/ShakeBuild.hs index fa413bf5..b1cb86b9 100644 --- a/Stackage/ShakeBuild.hs +++ b/Stackage/ShakeBuild.hs @@ -11,6 +11,7 @@ import Stackage.CheckBuildPlan import Stackage.PackageDescription import Stackage.PerformBuild (PerformBuild(..),copyBuiltInHaddocks,renameOrCopy) import Stackage.Prelude (unFlagName) +import System.Exit import Control.Concurrent.STM import Control.Concurrent.STM.TVar @@ -52,7 +53,7 @@ shakePlan :: TVar (Map String FilePath) shakePlan haddockFiles registerLock pb shakeDir = do fetched <- target (targetForFetched shakeDir) $ fetchedTarget shakeDir pb - db <- target (targetForDb' shakeDir) $ + db <- target (targetForDb shakeDir) $ databaseTarget shakeDir pb _ <- forM corePackages $ \name -> @@ -69,11 +70,41 @@ shakePlan haddockFiles registerLock pb shakeDir = do shakeDir name plan - want packageTargets + haddockTargets <- forM normalPackages $ + \(name,plan) -> + target (targetForDocs shakeDir name) $ + do need [targetForPackage shakeDir name] + packageDocs haddockFiles shakeDir pb plan name + if True + then want haddockTargets + else want packageTargets where corePackages = M.keys $ siCorePackages $ bpSystemInfo $ pbPlan pb normalPackages = filter (not . (`elem` corePackages) . fst) $ M.toList $ bpPackages $ pbPlan pb +-- | Generate haddock docs for the package. +packageDocs :: TVar (Map String FilePath) + -> FilePattern + -> PerformBuild + -> PackagePlan + -> PackageName + -> Action () +packageDocs haddockFiles shakeDir pb plan name = do + pwd <- liftIO getCurrentDirectory + env <- liftIO (fmap (Env . (++ defaultEnv pwd)) getEnvironment) + when + (haddocksFlag /= Don'tBuild && + not (S.null $ sdModules $ ppDesc plan)) $ + generateHaddocks haddockFiles pb pkgDir env name nameVer haddocksFlag + makeFile (targetForDocs shakeDir name) + where haddocksFlag = pcHaddocks $ ppConstraints plan + defaultEnv pwd = [( "HASKELL_PACKAGE_SANDBOX" + , pwd buildDatabase pb) | pbGlobalInstall pb] + pkgDir = shakeDir nameVer + nameVer = display name ++ + "-" ++ + display (ppVersion plan) + -- | Initialize the database if there one needs to be, and in any case -- create the target file. databaseTarget :: FilePath -> PerformBuild -> Action () @@ -85,7 +116,7 @@ databaseTarget shakeDir pb = do liftIO (removeDirectoryRecursive dir) () <- cmd "ghc-pkg" "init" dir liftIO $ copyBuiltInHaddocks $ FP.decodeString $ pbDocDir pb - makeFile (targetForDb' shakeDir) + makeFile (targetForDb shakeDir) where dir = buildDatabase pb -- | Build, test and generate documentation for the package. @@ -116,9 +147,6 @@ packageTarget haddockFiles registerLock pb shakeDir name plan = do "-" ++ display (ppVersion plan) -{-when (pcHaddocks (ppConstraints plan) /= Don'tBuild) $ -(generateHaddocks haddockFiles pb pkgDir env name nameVer)-} - -- | Make sure all package archives have been fetched. fetchedTarget :: FilePath -> PerformBuild -> Action () fetchedTarget shakeDir pb = do @@ -182,43 +210,54 @@ generateHaddocks :: TVar (Map String FilePath) -> CmdOption -> PackageName -> FilePattern + -> TestState -> Action () -generateHaddocks haddockFiles pb pkgDir env name nameVer = do +generateHaddocks haddockFiles pb pkgDir env name nameVer expected = do hfs <- liftIO $ readTVarIO haddockFiles - () <- cmd - (Cwd pkgDir) - env - "cabal" - "haddock" - "--hyperlink-source" - "--html" - "--hoogle" - "--html-location=../$pkg-$version/" - (map - (\(pkgVer,hf) -> - concat - [ "--haddock-options=--read-interface=" - , "../" - , pkgVer - , "/," - , hf]) - (M.toList hfs)) - liftIO $ - renameOrCopy - (FP.decodeString - (pkgDir "dist" "doc" "html" display name)) - (FP.decodeString - (pbDocDir pb nameVer)) - enewPath <- liftIO $ - try $ - canonicalizePath - (pbDocDir pb nameVer display name ++ ".haddock") - case enewPath of - Left (e :: IOException) -> return () -- FIXME: log it with Shake. - Right newPath -> liftIO $ - atomically $ - modifyTVar haddockFiles $ - M.insert nameVer newPath + exitCode <- cmd + (Cwd pkgDir) + env + "cabal" + "haddock" + "--hyperlink-source" + "--html" + "--hoogle" + "--html-location=../$pkg-$version/" + (map + (\(pkgVer,hf) -> + concat + [ "--haddock-options=--read-interface=" + , "../" + , pkgVer + , "/," + , hf]) + (M.toList hfs)) + case (exitCode,expected) of + (ExitSuccess,ExpectFailure) -> return () -- FIXME: warn. + (ExitFailure{},ExpectSuccess) -> throw exitCode -- FIXME: report it + _ -> return () + copy + where copy = do + liftIO $ + do let orig = pkgDir "dist" "doc" "html" + (display name) + exists <- doesDirectoryExist orig + when exists $ + renameOrCopy + (FP.decodeString orig) + (FP.decodeString + (pbDocDir pb nameVer)) + enewPath <- liftIO $ + try $ + canonicalizePath + (pbDocDir pb nameVer display name ++ + ".haddock") + case enewPath of + Left (e :: IOException) -> return () -- FIXME: log it with Shake. + Right newPath -> liftIO $ + atomically $ + modifyTVar haddockFiles $ + M.insert nameVer newPath -- | Generate a flags string for the package plan. planFlags :: PackagePlan -> String @@ -248,9 +287,14 @@ targetForPackage :: FilePath -> PackageName -> FilePath targetForPackage shakeDir name = shakeDir "packages" display name +-- | Get the target file for a package. +targetForDocs :: FilePath -> PackageName -> FilePath +targetForDocs shakeDir name = + shakeDir "docs" display name + -- | Get a package database path. -targetForDb' :: FilePath -> FilePath -targetForDb' shakeDir = +targetForDb :: FilePath -> FilePath +targetForDb shakeDir = shakeDir "pkgdb" -- | Declare a target, returning the target name. From 1abef8ff44b6c22e5ea8d5ccdce834635703c6be Mon Sep 17 00:00:00 2001 From: Chris Done Date: Thu, 15 Jan 2015 08:52:47 +0100 Subject: [PATCH 15/47] shake: Make package builds version-specific --- Stackage/ShakeBuild.hs | 99 ++++++++++++++++++++++++------------------ 1 file changed, 56 insertions(+), 43 deletions(-) diff --git a/Stackage/ShakeBuild.hs b/Stackage/ShakeBuild.hs index b1cb86b9..4a8296b3 100644 --- a/Stackage/ShakeBuild.hs +++ b/Stackage/ShakeBuild.hs @@ -5,6 +5,9 @@ module Stackage.ShakeBuild where import Control.Concurrent.MVar +import Data.List +import Data.Maybe +import Data.Version import Stackage.BuildConstraints import Stackage.BuildPlan import Stackage.CheckBuildPlan @@ -55,13 +58,13 @@ shakePlan haddockFiles registerLock pb shakeDir = do fetchedTarget shakeDir pb db <- target (targetForDb shakeDir) $ databaseTarget shakeDir pb - _ <- forM corePackages $ - \name -> - let fp = targetForPackage shakeDir name + _ <- forM (mapMaybe (\p -> find ((==p) . fst) versionMappings) corePackages) $ + \(name,version) -> + let fp = targetForPackage shakeDir name version in target fp (makeFile fp) packageTargets <- forM normalPackages $ \(name,plan) -> - target (targetForPackage shakeDir name) $ + target (targetForPackage shakeDir name (ppVersion plan)) $ do need [db, fetched] packageTarget haddockFiles @@ -72,13 +75,14 @@ shakePlan haddockFiles registerLock pb shakeDir = do plan haddockTargets <- forM normalPackages $ \(name,plan) -> - target (targetForDocs shakeDir name) $ - do need [targetForPackage shakeDir name] + target (targetForDocs shakeDir name (ppVersion plan)) $ + do need [targetForPackage shakeDir name (ppVersion plan)] packageDocs haddockFiles shakeDir pb plan name if True - then want haddockTargets - else want packageTargets - where corePackages = M.keys $ siCorePackages $ bpSystemInfo $ pbPlan pb + then want haddockTargets + else want packageTargets + where versionMappings = M.toList (M.map ppVersion (bpPackages (pbPlan pb))) + corePackages = M.keys $ siCorePackages $ bpSystemInfo $ pbPlan pb normalPackages = filter (not . (`elem` corePackages) . fst) $ M.toList $ bpPackages $ pbPlan pb @@ -95,11 +99,11 @@ packageDocs haddockFiles shakeDir pb plan name = do when (haddocksFlag /= Don'tBuild && not (S.null $ sdModules $ ppDesc plan)) $ - generateHaddocks haddockFiles pb pkgDir env name nameVer haddocksFlag - makeFile (targetForDocs shakeDir name) + generateHaddocks haddockFiles pb shakeDir pkgDir env name nameVer haddocksFlag + makeFile (targetForDocs shakeDir name (ppVersion plan)) where haddocksFlag = pcHaddocks $ ppConstraints plan defaultEnv pwd = [( "HASKELL_PACKAGE_SANDBOX" - , pwd buildDatabase pb) | pbGlobalInstall pb] + , pwd buildDatabase shakeDir) | pbGlobalInstall pb] pkgDir = shakeDir nameVer nameVer = display name ++ "-" ++ @@ -115,9 +119,9 @@ databaseTarget shakeDir pb = do liftIO (createDirectoryIfMissing True dir) liftIO (removeDirectoryRecursive dir) () <- cmd "ghc-pkg" "init" dir - liftIO $ copyBuiltInHaddocks $ FP.decodeString $ pbDocDir pb + liftIO $ copyBuiltInHaddocks $ FP.decodeString $ pbDocDir shakeDir makeFile (targetForDb shakeDir) - where dir = buildDatabase pb + where dir = buildDatabase shakeDir -- | Build, test and generate documentation for the package. packageTarget :: TVar (Map String FilePath) @@ -129,19 +133,21 @@ packageTarget :: TVar (Map String FilePath) -> Action () packageTarget haddockFiles registerLock pb shakeDir name plan = do need $ - map (targetForPackage shakeDir) $ + map (\(name,version) -> targetForPackage shakeDir name version) $ + mapMaybe (\p -> find ((==p) . fst) versionMappings) $ filter (/= name) $ M.keys $ M.filter libAndExe $ sdPackages $ ppDesc plan pwd <- liftIO getCurrentDirectory env <- liftIO (fmap (Env . (++ defaultEnv pwd)) getEnvironment) unpack shakeDir nameVer - configure pkgDir env pb plan + configure shakeDir pkgDir env pb plan () <- cmd cwd env "cabal" "build" "--ghc-options=-O0" register pkgDir env registerLock - makeFile (targetForPackage shakeDir name) - where cwd = Cwd pkgDir + makeFile (targetForPackage shakeDir name (ppVersion plan)) + where versionMappings = M.toList (M.map ppVersion (bpPackages (pbPlan pb))) + cwd = Cwd pkgDir defaultEnv pwd = [( "HASKELL_PACKAGE_SANDBOX" - , pwd buildDatabase pb) | pbGlobalInstall pb] + , pwd buildDatabase shakeDir) | pbGlobalInstall pb] pkgDir = shakeDir nameVer nameVer = display name ++ "-" ++ @@ -168,8 +174,8 @@ unpack shakeDir nameVer = do where pkgDir = shakeDir nameVer -- | Configure the given package. -configure :: FilePath -> CmdOption -> PerformBuild -> PackagePlan -> Action () -configure pkgDir env pb plan = do +configure :: FilePath -> FilePath -> CmdOption -> PerformBuild -> PackagePlan -> Action () +configure shakeDir pkgDir env pb plan = do configured <- liftIO $ doesFileExist $ pkgDir "dist" "setup-config" unless configured $ @@ -182,12 +188,12 @@ configure pkgDir env pb plan = do (opts pwd) where opts pwd = [ "--package-db=clear" , "--package-db=global" - , "--libdir=" ++ pwd pbLibDir pb - , "--bindir=" ++ pwd pbBinDir pb - , "--datadir=" ++ pwd pbDataDir pb - , "--docdir=" ++ pwd pbDocDir pb + , "--libdir=" ++ pbLibDir shakeDir + , "--bindir=" ++ pbBinDir shakeDir + , "--datadir=" ++ pbDataDir shakeDir + , "--docdir=" ++ pbDocDir shakeDir , "--flags=" ++ planFlags plan] ++ - ["--package-db=" ++ pwd buildDatabase pb | not (pbGlobalInstall pb)] + ["--package-db=" ++ buildDatabase shakeDir | not (pbGlobalInstall pb)] -- | Register the package. -- @@ -207,12 +213,13 @@ register pkgDir env registerLock = do generateHaddocks :: TVar (Map String FilePath) -> PerformBuild -> FilePath + -> FilePath -> CmdOption -> PackageName -> FilePattern -> TestState -> Action () -generateHaddocks haddockFiles pb pkgDir env name nameVer expected = do +generateHaddocks haddockFiles pb shakeDir pkgDir env name nameVer expected = do hfs <- liftIO $ readTVarIO haddockFiles exitCode <- cmd (Cwd pkgDir) @@ -246,11 +253,11 @@ generateHaddocks haddockFiles pb pkgDir env name nameVer expected = do renameOrCopy (FP.decodeString orig) (FP.decodeString - (pbDocDir pb nameVer)) + (pbDocDir shakeDir nameVer)) enewPath <- liftIO $ try $ canonicalizePath - (pbDocDir pb nameVer display name ++ + (pbDocDir shakeDir nameVer display name ++ ".haddock") case enewPath of Left (e :: IOException) -> return () -- FIXME: log it with Shake. @@ -273,8 +280,8 @@ planFlags plan = unwords $ , T.unpack (unFlagName name')] -- | Database location. -buildDatabase :: PerformBuild -> FilePattern -buildDatabase pb = FP.encodeString (pbInstallDest pb) "pkgdb" +buildDatabase :: FilePath -> FilePattern +buildDatabase shakeDir = shakeDir "pkgdb" -- | Get the target file for confirming that all packages have been -- pre-fetched. @@ -283,19 +290,25 @@ targetForFetched shakeDir = shakeDir "fetched" -- | Get the target file for a package. -targetForPackage :: FilePath -> PackageName -> FilePath -targetForPackage shakeDir name = - shakeDir "packages" display name +targetForPackage :: FilePath -> PackageName -> Version -> FilePath +targetForPackage shakeDir name version = + shakeDir "packages" nameVer + where nameVer = display name ++ + "-" ++ + display version -- | Get the target file for a package. -targetForDocs :: FilePath -> PackageName -> FilePath -targetForDocs shakeDir name = - shakeDir "docs" display name +targetForDocs :: FilePath -> PackageName -> Version -> FilePath +targetForDocs shakeDir name version = + shakeDir "docs" nameVer + where nameVer = display name ++ + "-" ++ + display version -- | Get a package database path. targetForDb :: FilePath -> FilePath targetForDb shakeDir = - shakeDir "pkgdb" + shakeDir "pkgdb-built" -- | Declare a target, returning the target name. target :: FilePattern -> Action () -> Rules FilePattern @@ -307,8 +320,8 @@ target name act = do 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" +pbBinDir, pbLibDir, pbDataDir, pbDocDir :: FilePath -> FilePath +pbBinDir shakeDir = shakeDir "bin" +pbLibDir shakeDir = shakeDir "lib" +pbDataDir shakeDir = shakeDir "share" +pbDocDir shakeDir = shakeDir "doc" From 1d4b4268b358a86f959b431ce339b5ba5cc824d3 Mon Sep 17 00:00:00 2001 From: Chris Done Date: Thu, 15 Jan 2015 12:22:14 +0100 Subject: [PATCH 16/47] shake: Re-jig dir positions --- Stackage/ShakeBuild.hs | 47 ++++++++++++++++++++---------------------- 1 file changed, 22 insertions(+), 25 deletions(-) diff --git a/Stackage/ShakeBuild.hs b/Stackage/ShakeBuild.hs index 4a8296b3..c09ee33a 100644 --- a/Stackage/ShakeBuild.hs +++ b/Stackage/ShakeBuild.hs @@ -78,9 +78,7 @@ shakePlan haddockFiles registerLock pb shakeDir = do target (targetForDocs shakeDir name (ppVersion plan)) $ do need [targetForPackage shakeDir name (ppVersion plan)] packageDocs haddockFiles shakeDir pb plan name - if True - then want haddockTargets - else want packageTargets + want haddockTargets where versionMappings = M.toList (M.map ppVersion (bpPackages (pbPlan pb))) corePackages = M.keys $ siCorePackages $ bpSystemInfo $ pbPlan pb normalPackages = filter (not . (`elem` corePackages) . fst) $ @@ -104,7 +102,7 @@ packageDocs haddockFiles shakeDir pb plan name = do where haddocksFlag = pcHaddocks $ ppConstraints plan defaultEnv pwd = [( "HASKELL_PACKAGE_SANDBOX" , pwd buildDatabase shakeDir) | pbGlobalInstall pb] - pkgDir = shakeDir nameVer + pkgDir = shakeDir "packages" nameVer nameVer = display name ++ "-" ++ display (ppVersion plan) @@ -139,7 +137,7 @@ packageTarget haddockFiles registerLock pb shakeDir name plan = do M.keys $ M.filter libAndExe $ sdPackages $ ppDesc plan pwd <- liftIO getCurrentDirectory env <- liftIO (fmap (Env . (++ defaultEnv pwd)) getEnvironment) - unpack shakeDir nameVer + unpack shakeDir name nameVer configure shakeDir pkgDir env pb plan () <- cmd cwd env "cabal" "build" "--ghc-options=-O0" register pkgDir env registerLock @@ -148,7 +146,7 @@ packageTarget haddockFiles registerLock pb shakeDir name plan = do cwd = Cwd pkgDir defaultEnv pwd = [( "HASKELL_PACKAGE_SANDBOX" , pwd buildDatabase shakeDir) | pbGlobalInstall pb] - pkgDir = shakeDir nameVer + pkgDir = shakeDir "packages" nameVer nameVer = display name ++ "-" ++ display (ppVersion plan) @@ -166,26 +164,25 @@ fetchedTarget shakeDir pb = do makeFile (targetForFetched shakeDir) -- | Unpack the package. -unpack :: FilePath -> String -> Action () -unpack shakeDir nameVer = do - unpacked <- liftIO (doesDirectoryExist pkgDir) +unpack :: FilePath -> PackageName -> String -> Action () +unpack shakeDir name nameVer = do + unpacked <- liftIO (doesFileExist (pkgDir display name ++ ".cabal")) unless unpacked $ - cmd (Cwd shakeDir) "cabal" "unpack" nameVer - where pkgDir = shakeDir nameVer + do liftIO (catch (removeDirectoryRecursive pkgDir) + (\(_ :: IOException) -> return ())) + cmd (Cwd (shakeDir "packages")) "cabal" "unpack" nameVer + where pkgDir = shakeDir "packages" nameVer -- | Configure the given package. configure :: FilePath -> FilePath -> CmdOption -> PerformBuild -> PackagePlan -> Action () configure shakeDir pkgDir env pb plan = do - configured <- liftIO $ doesFileExist $ pkgDir "dist" - "setup-config" - unless configured $ - do pwd <- liftIO getCurrentDirectory - cmd - (Cwd pkgDir) - env - "cabal" - "configure" - (opts pwd) + pwd <- liftIO getCurrentDirectory + cmd + (Cwd pkgDir) + env + "cabal" + "configure" + (opts pwd) where opts pwd = [ "--package-db=clear" , "--package-db=global" , "--libdir=" ++ pbLibDir shakeDir @@ -287,12 +284,12 @@ buildDatabase shakeDir = shakeDir "pkgdb" -- pre-fetched. targetForFetched :: FilePath -> FilePath targetForFetched shakeDir = - shakeDir "fetched" + shakeDir "packages-fetched" -- | Get the target file for a package. targetForPackage :: FilePath -> PackageName -> Version -> FilePath targetForPackage shakeDir name version = - shakeDir "packages" nameVer + shakeDir "packages" nameVer "dist" "shake-build" where nameVer = display name ++ "-" ++ display version @@ -300,7 +297,7 @@ targetForPackage shakeDir name version = -- | Get the target file for a package. targetForDocs :: FilePath -> PackageName -> Version -> FilePath targetForDocs shakeDir name version = - shakeDir "docs" nameVer + shakeDir "packages" nameVer "dist" "shake-docs" where nameVer = display name ++ "-" ++ display version @@ -308,7 +305,7 @@ targetForDocs shakeDir name version = -- | Get a package database path. targetForDb :: FilePath -> FilePath targetForDb shakeDir = - shakeDir "pkgdb-built" + shakeDir "pkgdb-initialized" -- | Declare a target, returning the target name. target :: FilePattern -> Action () -> Rules FilePattern From 20666ae7f2b092c09c4ef608e8b31ebb1826c911 Mon Sep 17 00:00:00 2001 From: Chris Done Date: Thu, 15 Jan 2015 15:44:39 +0100 Subject: [PATCH 17/47] shake: Small refactor --- Stackage/ShakeBuild.hs | 131 ++++++++++++++++++++++++++--------------- 1 file changed, 83 insertions(+), 48 deletions(-) diff --git a/Stackage/ShakeBuild.hs b/Stackage/ShakeBuild.hs index c09ee33a..6462bf10 100644 --- a/Stackage/ShakeBuild.hs +++ b/Stackage/ShakeBuild.hs @@ -4,33 +4,39 @@ module Stackage.ShakeBuild where -import Control.Concurrent.MVar -import Data.List -import Data.Maybe -import Data.Version import Stackage.BuildConstraints import Stackage.BuildPlan import Stackage.CheckBuildPlan import Stackage.PackageDescription import Stackage.PerformBuild (PerformBuild(..),copyBuiltInHaddocks,renameOrCopy) import Stackage.Prelude (unFlagName) -import System.Exit +import Control.Concurrent.MVar import Control.Concurrent.STM import Control.Concurrent.STM.TVar import Control.Exception import Control.Monad hiding (forM_) +import Data.Conduit +import qualified Data.Conduit.List as CL +import Data.Conduit.Process +import qualified Data.Conduit.Text as CT +import Data.List import Data.Map.Strict (Map) import qualified Data.Map.Strict as M +import Data.Maybe import Data.Monoid import qualified Data.Set as S +import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Version import Development.Shake hiding (doesFileExist,doesDirectoryExist) import Distribution.Package (PackageName) import Distribution.Text (display) import qualified Filesystem.Path.CurrentOS as FP import System.Directory import System.Environment +import System.Exit -- | Run the shake builder. performBuild :: PerformBuild -> IO () @@ -39,6 +45,7 @@ performBuild pb = do createDirectoryIfMissing True shakeDir haddockFiles <- liftIO (newTVarIO mempty) registerLock <- liftIO (newMVar ()) + cleanOldPackages pb withArgs [] $ shakeArgs shakeOptions @@ -97,15 +104,12 @@ packageDocs haddockFiles shakeDir pb plan name = do when (haddocksFlag /= Don'tBuild && not (S.null $ sdModules $ ppDesc plan)) $ - generateHaddocks haddockFiles pb shakeDir pkgDir env name nameVer haddocksFlag + generateHaddocks haddockFiles pb shakeDir (pkgDir shakeDir name version) env name version haddocksFlag makeFile (targetForDocs shakeDir name (ppVersion plan)) - where haddocksFlag = pcHaddocks $ ppConstraints plan + where version = ppVersion plan + haddocksFlag = pcHaddocks $ ppConstraints plan defaultEnv pwd = [( "HASKELL_PACKAGE_SANDBOX" , pwd buildDatabase shakeDir) | pbGlobalInstall pb] - pkgDir = shakeDir "packages" nameVer - nameVer = display name ++ - "-" ++ - display (ppVersion plan) -- | Initialize the database if there one needs to be, and in any case -- create the target file. @@ -137,19 +141,17 @@ packageTarget haddockFiles registerLock pb shakeDir name plan = do M.keys $ M.filter libAndExe $ sdPackages $ ppDesc plan pwd <- liftIO getCurrentDirectory env <- liftIO (fmap (Env . (++ defaultEnv pwd)) getEnvironment) - unpack shakeDir name nameVer - configure shakeDir pkgDir env pb plan + unpack shakeDir name version + configure shakeDir dir env pb plan () <- cmd cwd env "cabal" "build" "--ghc-options=-O0" - register pkgDir env registerLock - makeFile (targetForPackage shakeDir name (ppVersion plan)) - where versionMappings = M.toList (M.map ppVersion (bpPackages (pbPlan pb))) - cwd = Cwd pkgDir + register dir env registerLock + makeFile (targetForPackage shakeDir name version) + where dir = pkgDir shakeDir name version + version = ppVersion plan + versionMappings = M.toList (M.map ppVersion (bpPackages (pbPlan pb))) + cwd = Cwd dir defaultEnv pwd = [( "HASKELL_PACKAGE_SANDBOX" , pwd buildDatabase shakeDir) | pbGlobalInstall pb] - pkgDir = shakeDir "packages" nameVer - nameVer = display name ++ - "-" ++ - display (ppVersion plan) -- | Make sure all package archives have been fetched. fetchedTarget :: FilePath -> PerformBuild -> Action () @@ -164,14 +166,23 @@ fetchedTarget shakeDir pb = do makeFile (targetForFetched shakeDir) -- | Unpack the package. -unpack :: FilePath -> PackageName -> String -> Action () -unpack shakeDir name nameVer = do - unpacked <- liftIO (doesFileExist (pkgDir display name ++ ".cabal")) +unpack :: FilePath -> PackageName -> Version -> Action () +unpack shakeDir name version = do + unpacked <- liftIO $ + doesFileExist $ + pkgDir shakeDir name version + display name ++ + ".cabal" unless unpacked $ - do liftIO (catch (removeDirectoryRecursive pkgDir) - (\(_ :: IOException) -> return ())) - cmd (Cwd (shakeDir "packages")) "cabal" "unpack" nameVer - where pkgDir = shakeDir "packages" nameVer + do liftIO $ + catch (removeDirectoryRecursive (pkgDir shakeDir name version)) $ + \(_ :: IOException) -> + return () + cmd + (Cwd (shakeDir "packages")) + "cabal" + "unpack" + (nameVer name version) -- | Configure the given package. configure :: FilePath -> FilePath -> CmdOption -> PerformBuild -> PackagePlan -> Action () @@ -213,10 +224,10 @@ generateHaddocks :: TVar (Map String FilePath) -> FilePath -> CmdOption -> PackageName - -> FilePattern + -> Version -> TestState -> Action () -generateHaddocks haddockFiles pb shakeDir pkgDir env name nameVer expected = do +generateHaddocks haddockFiles pb shakeDir pkgDir env name version expected = do hfs <- liftIO $ readTVarIO haddockFiles exitCode <- cmd (Cwd pkgDir) @@ -236,32 +247,32 @@ generateHaddocks haddockFiles pb shakeDir pkgDir env name nameVer expected = do , "/," , hf]) (M.toList hfs)) - case (exitCode,expected) of - (ExitSuccess,ExpectFailure) -> return () -- FIXME: warn. - (ExitFailure{},ExpectSuccess) -> throw exitCode -- FIXME: report it - _ -> return () + case (exitCode, expected) of + (ExitSuccess,ExpectFailure) -> return () -- FIXME: warn. + (ExitFailure{},ExpectSuccess) -> throw exitCode -- FIXME: report it + _ -> return () copy - where copy = do + where ident = nameVer name version + copy = do liftIO $ - do let orig = pkgDir "dist" "doc" "html" - (display name) + do let orig = pkgDocDir shakeDir name version exists <- doesDirectoryExist orig when exists $ renameOrCopy (FP.decodeString orig) (FP.decodeString - (pbDocDir shakeDir nameVer)) + (pbDocDir shakeDir ident)) enewPath <- liftIO $ try $ canonicalizePath - (pbDocDir shakeDir nameVer display name ++ + (pbDocDir shakeDir ident display name ++ ".haddock") case enewPath of Left (e :: IOException) -> return () -- FIXME: log it with Shake. Right newPath -> liftIO $ atomically $ modifyTVar haddockFiles $ - M.insert nameVer newPath + M.insert (ident) newPath -- | Generate a flags string for the package plan. planFlags :: PackagePlan -> String @@ -280,6 +291,23 @@ planFlags plan = unwords $ buildDatabase :: FilePath -> FilePattern buildDatabase shakeDir = shakeDir "pkgdb" +-- | Print the name and version. +nameVer :: PackageName -> Version -> String +nameVer name version = display name ++ "-" ++ display version + +-- | The directory for the package's docs. +pkgDocDir :: FilePath -> PackageName -> Version -> FilePath +pkgDocDir shakeDir name version = pkgDir shakeDir name version + "dist" + "doc" + "html" + (display name) + +-- | The package directory. +pkgDir :: FilePath -> PackageName -> Version -> FilePath +pkgDir shakeDir name version = shakeDir "packages" + (nameVer name version) + -- | Get the target file for confirming that all packages have been -- pre-fetched. targetForFetched :: FilePath -> FilePath @@ -289,18 +317,12 @@ targetForFetched shakeDir = -- | Get the target file for a package. targetForPackage :: FilePath -> PackageName -> Version -> FilePath targetForPackage shakeDir name version = - shakeDir "packages" nameVer "dist" "shake-build" - where nameVer = display name ++ - "-" ++ - display version + shakeDir "packages" nameVer name version "dist" "shake-build" -- | Get the target file for a package. targetForDocs :: FilePath -> PackageName -> Version -> FilePath targetForDocs shakeDir name version = - shakeDir "packages" nameVer "dist" "shake-docs" - where nameVer = display name ++ - "-" ++ - display version + shakeDir "packages" nameVer name version "dist" "shake-docs" -- | Get a package database path. targetForDb :: FilePath -> FilePath @@ -322,3 +344,16 @@ pbBinDir shakeDir = shakeDir "bin" pbLibDir shakeDir = shakeDir "lib" pbDataDir shakeDir = shakeDir "share" pbDocDir shakeDir = shakeDir "doc" + +-- | Clean up old versions of packages that are no longer in use. +cleanOldPackages :: PerformBuild -> IO () +cleanOldPackages pb = do undefined + undefined + +-- | Get globally available packages. +getGlobalPackages :: FilePath -> IO [Text] +getGlobalPackages shakeDir = + do (_,ps) <- sourceProcessWithConsumer + (proc "ghc-pkg" ["list","--simple-output","-f",buildDatabase shakeDir]) + (CT.decodeUtf8 $= CT.lines $= CL.consume) + return (T.words (T.unlines ps)) From 16d58d5887334623ecb7f125229cc570e1efcab0 Mon Sep 17 00:00:00 2001 From: Chris Done Date: Thu, 15 Jan 2015 20:14:45 +0100 Subject: [PATCH 18/47] shake: Clean up unused packages --- Stackage/ShakeBuild.hs | 66 +++++++++++++++++++++++++++++++++++------- 1 file changed, 56 insertions(+), 10 deletions(-) diff --git a/Stackage/ShakeBuild.hs b/Stackage/ShakeBuild.hs index 6462bf10..30186993 100644 --- a/Stackage/ShakeBuild.hs +++ b/Stackage/ShakeBuild.hs @@ -4,6 +4,7 @@ module Stackage.ShakeBuild where +import Control.Monad import Stackage.BuildConstraints import Stackage.BuildPlan import Stackage.CheckBuildPlan @@ -31,8 +32,11 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Version import Development.Shake hiding (doesFileExist,doesDirectoryExist) +import Distribution.Compat.ReadP +import Distribution.Package import Distribution.Package (PackageName) import Distribution.Text (display) +import Distribution.Text (parse) import qualified Filesystem.Path.CurrentOS as FP import System.Directory import System.Environment @@ -45,7 +49,7 @@ performBuild pb = do createDirectoryIfMissing True shakeDir haddockFiles <- liftIO (newTVarIO mempty) registerLock <- liftIO (newMVar ()) - cleanOldPackages pb + cleanOldPackages pb shakeDir withArgs [] $ shakeArgs shakeOptions @@ -346,14 +350,56 @@ pbDataDir shakeDir = shakeDir "share" pbDocDir shakeDir = shakeDir "doc" -- | Clean up old versions of packages that are no longer in use. -cleanOldPackages :: PerformBuild -> IO () -cleanOldPackages pb = do undefined - undefined +cleanOldPackages :: PerformBuild -> FilePath -> IO () +cleanOldPackages pb shakeDir = do + putStrLn "Collecting garbage" + pkgs <- getRegisteredPackages shakeDir + forM_ pkgs $ + \(PackageIdentifier name version) -> + case M.lookup name versions of + Just version' + | version' == version -> + return () + Just newVersion -> purgePackage shakeDir name version (Just newVersion) + Nothing -> purgePackage shakeDir name version Nothing + where versions = (M.map ppVersion . bpPackages . pbPlan) pb + +-- | Purge the given package and version. +purgePackage :: FilePath -> PackageName -> Version -> Maybe Version -> IO () +purgePackage shakeDir name version newVersion = do + putStrLn $ "Cleaning up unused package: " ++ ident ++ " (" ++ reason ++ ")" + unregister + delete + where reason = + case newVersion of + Just version' -> "replaced by " ++ ordinal ++ " " ++ display version' + where ordinal | version' > version = "newer" + | otherwise = "older" + Nothing -> "no longer included" + ident = nameVer name version + unregister = void $ + readProcessWithExitCode + "ghc-pkg" + ["unregister", "-f", buildDatabase shakeDir, "--force", ident] + "" + delete = removeDirectoryRecursive $ + pkgDir shakeDir name version -- | Get globally available packages. -getGlobalPackages :: FilePath -> IO [Text] -getGlobalPackages shakeDir = - do (_,ps) <- sourceProcessWithConsumer - (proc "ghc-pkg" ["list","--simple-output","-f",buildDatabase shakeDir]) - (CT.decodeUtf8 $= CT.lines $= CL.consume) - return (T.words (T.unlines ps)) +getRegisteredPackages :: FilePath -> IO [PackageIdentifier] +getRegisteredPackages shakeDir = do + (_,ps) <- sourceProcessWithConsumer + (proc' + "ghc-pkg" + ["list", "--simple-output", "-f", buildDatabase shakeDir]) + (CT.decodeUtf8 $= CT.lines $= CL.consume) + return (mapMaybe parsePackageIdent (T.words (T.unlines ps))) + +-- | Parse a package identifier: foo-1.2.3 +parsePackageIdent :: Text -> Maybe PackageIdentifier +parsePackageIdent = fmap fst . + listToMaybe . + filter (null . snd) . + readP_to_S parse . T.unpack + +proc' = proc From 2cc33a8545ebc8016b86544b76842da32b99a25d Mon Sep 17 00:00:00 2001 From: Chris Done Date: Thu, 15 Jan 2015 21:03:29 +0100 Subject: [PATCH 19/47] shake: Clean up broken packages --- Stackage/ShakeBuild.hs | 71 ++++++++++++++++++++++++++++++------------ 1 file changed, 51 insertions(+), 20 deletions(-) diff --git a/Stackage/ShakeBuild.hs b/Stackage/ShakeBuild.hs index 30186993..b96b3aee 100644 --- a/Stackage/ShakeBuild.hs +++ b/Stackage/ShakeBuild.hs @@ -349,43 +349,74 @@ pbLibDir shakeDir = shakeDir "lib" pbDataDir shakeDir = shakeDir "share" pbDocDir shakeDir = shakeDir "doc" +-- | Reason for purging a package. +data PurgeReason + = NoLongerIncluded + | Replaced Version + | Broken + -- | Clean up old versions of packages that are no longer in use. cleanOldPackages :: PerformBuild -> FilePath -> IO () cleanOldPackages pb shakeDir = do putStrLn "Collecting garbage" pkgs <- getRegisteredPackages shakeDir forM_ pkgs $ - \(PackageIdentifier name version) -> - case M.lookup name versions of - Just version' - | version' == version -> - return () - Just newVersion -> purgePackage shakeDir name version (Just newVersion) - Nothing -> purgePackage shakeDir name version Nothing + \(PackageIdentifier name version) -> + case M.lookup name versions of + Just version' + | version' == version -> + return () + Just newVersion -> purgePackage + shakeDir + name + version + (Replaced newVersion) + Nothing -> purgePackage shakeDir name version NoLongerIncluded + broken <- getBrokenPackages shakeDir + forM_ + broken + (\(PackageIdentifier name version) -> + purgePackage shakeDir name version Broken) where versions = (M.map ppVersion . bpPackages . pbPlan) pb -- | Purge the given package and version. -purgePackage :: FilePath -> PackageName -> Version -> Maybe Version -> IO () -purgePackage shakeDir name version newVersion = do - putStrLn $ "Cleaning up unused package: " ++ ident ++ " (" ++ reason ++ ")" +purgePackage :: FilePath -> PackageName -> Version -> PurgeReason -> IO () +purgePackage shakeDir name version reason = do + putStr $ "Purging package: " ++ ident ++ " (" ++ showReason ++ ") ... " unregister delete - where reason = - case newVersion of - Just version' -> "replaced by " ++ ordinal ++ " " ++ display version' + putStrLn "done." + where showReason = + case reason of + Replaced version' -> "replaced by " ++ ordinal ++ " " ++ display version' where ordinal | version' > version = "newer" | otherwise = "older" - Nothing -> "no longer included" + NoLongerIncluded -> "no longer included" + Broken -> "broken" ident = nameVer name version - unregister = void $ - readProcessWithExitCode - "ghc-pkg" - ["unregister", "-f", buildDatabase shakeDir, "--force", ident] - "" + unregister = do + void (readProcessWithExitCode + "ghc-pkg" + ["unregister", "-f", buildDatabase shakeDir, "--force", ident] + "") + void (readProcessWithExitCode + "ghc-pkg" + ["recache", "-f", buildDatabase shakeDir] + "") delete = removeDirectoryRecursive $ pkgDir shakeDir name version --- | Get globally available packages. +-- | Get broken packages. +getBrokenPackages :: FilePath -> IO [PackageIdentifier] +getBrokenPackages shakeDir = do + (_,ps) <- sourceProcessWithConsumer + (proc' + "ghc-pkg" + ["check", "--simple-output", "-f", buildDatabase shakeDir]) + (CT.decodeUtf8 $= CT.lines $= CL.consume) + return (mapMaybe parsePackageIdent (T.words (T.unlines ps))) + +-- | Get available packages. getRegisteredPackages :: FilePath -> IO [PackageIdentifier] getRegisteredPackages shakeDir = do (_,ps) <- sourceProcessWithConsumer From 6da56e4f155cf34155b636322e663202ce291485 Mon Sep 17 00:00:00 2001 From: Chris Done Date: Thu, 15 Jan 2015 21:15:38 +0100 Subject: [PATCH 20/47] Remove recache --- Stackage/ShakeBuild.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/Stackage/ShakeBuild.hs b/Stackage/ShakeBuild.hs index b96b3aee..55b49ddc 100644 --- a/Stackage/ShakeBuild.hs +++ b/Stackage/ShakeBuild.hs @@ -399,10 +399,6 @@ purgePackage shakeDir name version reason = do "ghc-pkg" ["unregister", "-f", buildDatabase shakeDir, "--force", ident] "") - void (readProcessWithExitCode - "ghc-pkg" - ["recache", "-f", buildDatabase shakeDir] - "") delete = removeDirectoryRecursive $ pkgDir shakeDir name version From eb734cb5d76ef812a2c4de23b802f918bd652d8f Mon Sep 17 00:00:00 2001 From: Chris Done Date: Thu, 15 Jan 2015 21:17:39 +0100 Subject: [PATCH 21/47] Update .cabal --- stackage.cabal | 69 +++++++++++++++++++++++++------------------------- 1 file changed, 35 insertions(+), 34 deletions(-) diff --git a/stackage.cabal b/stackage.cabal index 114e83cb..cbcf9eca 100644 --- a/stackage.cabal +++ b/stackage.cabal @@ -31,40 +31,41 @@ library Stackage.PerformBuild Stackage.ShakeBuild Stackage.CompleteBuild - build-depends: base >= 4 && < 5 - , containers - , Cabal >= 1.14 - , tar >= 0.3 - , zlib - , bytestring - , directory - , filepath - , transformers - , process - , old-locale - , time - , utf8-string - - , conduit-extra - , classy-prelude-conduit - , text - , system-fileio - , system-filepath - , mtl - , aeson - , yaml - , unix-compat - , http-client - , http-client-tls - , temporary - , data-default-class - , stm - , mono-traversable - , async - , streaming-commons >= 0.1.7.1 - , semigroups - , xml-conduit - , shake + build-depends: + Cabal >= 1.14 + , aeson + , async + , base >= 4 && < 5 + , bytestring + , classy-prelude-conduit + , conduit + , conduit-extra + , containers + , data-default-class + , directory + , filepath + , http-client + , http-client-tls + , mono-traversable + , mtl + , old-locale + , process + , semigroups + , shake + , stm + , streaming-commons >= 0.1.7.1 + , system-fileio + , system-filepath + , tar >= 0.3 + , temporary + , text + , time + , transformers + , unix-compat + , utf8-string + , xml-conduit + , yaml + , zlib executable stackage default-language: Haskell2010 From bb5952dbf9722d2cff5dd03d4cf5c067433f0f44 Mon Sep 17 00:00:00 2001 From: Chris Done Date: Sun, 18 Jan 2015 20:13:14 +0100 Subject: [PATCH 22/47] Copy final built distro to builds/ --- Stackage/CompleteBuild.hs | 3 ++- Stackage/PerformBuild.hs | 1 + Stackage/ShakeBuild.hs | 44 ++++++++++++++++++++++++++++++++++++--- 3 files changed, 44 insertions(+), 4 deletions(-) diff --git a/Stackage/CompleteBuild.hs b/Stackage/CompleteBuild.hs index 89b443b7..0ac4c84d 100644 --- a/Stackage/CompleteBuild.hs +++ b/Stackage/CompleteBuild.hs @@ -26,6 +26,7 @@ import Stackage.BuildConstraints import Stackage.BuildPlan import Stackage.CheckBuildPlan import Stackage.PerformBuild +import qualified Stackage.ShakeBuild as Shake import Stackage.Prelude import Stackage.ServerBundle import Stackage.UpdateBuildPlan @@ -230,7 +231,7 @@ completeBuild buildType buildFlags = withManager tlsManagerSettings $ \man -> do checkBuildPlan plan putStrLn "Performing build" - performBuild (getPerformBuild buildFlags settings) >>= mapM_ putStrLn + Shake.performBuild (getPerformBuild buildFlags settings) -- >>= mapM_ putStrLn when (bfDoUpload buildFlags) $ finallyUpload settings man diff --git a/Stackage/PerformBuild.hs b/Stackage/PerformBuild.hs index a3b46c5a..52e37cd5 100644 --- a/Stackage/PerformBuild.hs +++ b/Stackage/PerformBuild.hs @@ -12,6 +12,7 @@ module Stackage.PerformBuild , pbDocDir , copyBuiltInHaddocks , renameOrCopy + , copyDir ) where import Control.Concurrent.Async (async) diff --git a/Stackage/ShakeBuild.hs b/Stackage/ShakeBuild.hs index 55b49ddc..aed743ab 100644 --- a/Stackage/ShakeBuild.hs +++ b/Stackage/ShakeBuild.hs @@ -4,12 +4,13 @@ module Stackage.ShakeBuild where +import Control.Concurrent import Control.Monad import Stackage.BuildConstraints import Stackage.BuildPlan import Stackage.CheckBuildPlan import Stackage.PackageDescription -import Stackage.PerformBuild (PerformBuild(..),copyBuiltInHaddocks,renameOrCopy) +import Stackage.PerformBuild (PerformBuild(..),copyBuiltInHaddocks,renameOrCopy,copyDir) import Stackage.Prelude (unFlagName) import Control.Concurrent.MVar @@ -89,12 +90,28 @@ shakePlan haddockFiles registerLock pb shakeDir = do target (targetForDocs shakeDir name (ppVersion plan)) $ do need [targetForPackage shakeDir name (ppVersion plan)] packageDocs haddockFiles shakeDir pb plan name - want haddockTargets + build <- target (targetForBuild pb) + (do need haddockTargets + copyToBuild pb shakeDir) + want [build] where versionMappings = M.toList (M.map ppVersion (bpPackages (pbPlan pb))) corePackages = M.keys $ siCorePackages $ bpSystemInfo $ pbPlan pb normalPackages = filter (not . (`elem` corePackages) . fst) $ M.toList $ bpPackages $ pbPlan pb +-- | Copy the build as a whole to builds/. +copyToBuild :: PerformBuild -> String -> Action () +copyToBuild pb shakeDir = do + copy pbBinDir + copy pbLibDir + copy pbDataDir + copy pbDocDir + makeFile (targetForBuild pb) + where copy mkPath = liftIO $ + copyDir + (FP.decodeString $ mkPath shakeDir) + (FP.decodeString $ mkPath $ FP.encodeString $ pbInstallDest pb) + -- | Generate haddock docs for the package. packageDocs :: TVar (Map String FilePath) -> FilePattern @@ -328,6 +345,10 @@ targetForDocs :: FilePath -> PackageName -> Version -> FilePath targetForDocs shakeDir name version = shakeDir "packages" nameVer name version "dist" "shake-docs" +-- | Target for the complete, copied build under builds/date/. +targetForBuild :: PerformBuild -> FilePattern +targetForBuild pb = FP.encodeString (pbInstallDest pb) "shake-built" + -- | Get a package database path. targetForDb :: FilePath -> FilePath targetForDb shakeDir = @@ -360,6 +381,24 @@ cleanOldPackages :: PerformBuild -> FilePath -> IO () cleanOldPackages pb shakeDir = do putStrLn "Collecting garbage" pkgs <- getRegisteredPackages shakeDir + let toRemove = mapMaybe + (\(PackageIdentifier name version) -> + case M.lookup name versions of + Just version' + | version' == version -> + Nothing + Just newVersion -> Just + (name, version, (Replaced newVersion)) + Nothing -> Just (name, version, NoLongerIncluded)) + pkgs + broken <- getBrokenPackages shakeDir + unless (null toRemove) + (putStrLn ("There are " ++ show (length toRemove) ++ " packages to be purged.")) + unless (null broken) + (putStrLn ("There are " ++ show (length broken) ++ " broken packages to be purged.")) + when (length broken + length toRemove > 0) + (do putStrLn "Waiting 3 seconds before proceeding to remove ..." + threadDelay (1000 * 1000 * 3)) forM_ pkgs $ \(PackageIdentifier name version) -> case M.lookup name versions of @@ -372,7 +411,6 @@ cleanOldPackages pb shakeDir = do version (Replaced newVersion) Nothing -> purgePackage shakeDir name version NoLongerIncluded - broken <- getBrokenPackages shakeDir forM_ broken (\(PackageIdentifier name version) -> From 5e089315d997e288d9534ce26bc91feec6d7954c Mon Sep 17 00:00:00 2001 From: Chris Done Date: Sun, 18 Jan 2015 20:48:21 +0100 Subject: [PATCH 23/47] Tweak wanting --- Stackage/ShakeBuild.hs | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/Stackage/ShakeBuild.hs b/Stackage/ShakeBuild.hs index aed743ab..7e5e05f6 100644 --- a/Stackage/ShakeBuild.hs +++ b/Stackage/ShakeBuild.hs @@ -93,6 +93,7 @@ shakePlan haddockFiles registerLock pb shakeDir = do build <- target (targetForBuild pb) (do need haddockTargets copyToBuild pb shakeDir) + want haddockTargets want [build] where versionMappings = M.toList (M.map ppVersion (bpPackages (pbPlan pb))) corePackages = M.keys $ siCorePackages $ bpSystemInfo $ pbPlan pb @@ -102,15 +103,19 @@ shakePlan haddockFiles registerLock pb shakeDir = do -- | Copy the build as a whole to builds/. copyToBuild :: PerformBuild -> String -> Action () copyToBuild pb shakeDir = do + liftIO (putStrLn ("Copying snapshot to " ++ FP.encodeString (pbInstallDest pb))) copy pbBinDir copy pbLibDir copy pbDataDir copy pbDocDir makeFile (targetForBuild pb) where copy mkPath = liftIO $ - copyDir - (FP.decodeString $ mkPath shakeDir) - (FP.decodeString $ mkPath $ FP.encodeString $ pbInstallDest pb) + do putStrLn ("Copying " ++ mkPath shakeDir) + copyDir + here + there + where here = (FP.decodeString $ mkPath shakeDir) + there = (FP.decodeString $ mkPath $ FP.encodeString $ pbInstallDest pb) -- | Generate haddock docs for the package. packageDocs :: TVar (Map String FilePath) From adafabb225e3c2b0db9bc13796c1b12c7349c2bb Mon Sep 17 00:00:00 2001 From: Chris Done Date: Sun, 18 Jan 2015 21:41:55 +0100 Subject: [PATCH 24/47] Print out new packages that'll be installed --- Stackage/ShakeBuild.hs | 45 +++++++++++++++++++++++++++++++++++------- 1 file changed, 38 insertions(+), 7 deletions(-) diff --git a/Stackage/ShakeBuild.hs b/Stackage/ShakeBuild.hs index 7e5e05f6..169a5293 100644 --- a/Stackage/ShakeBuild.hs +++ b/Stackage/ShakeBuild.hs @@ -50,7 +50,9 @@ performBuild pb = do createDirectoryIfMissing True shakeDir haddockFiles <- liftIO (newTVarIO mempty) registerLock <- liftIO (newMVar ()) - cleanOldPackages pb shakeDir + pkgs <- getRegisteredPackages shakeDir + cleanOldPackages pb shakeDir pkgs + printNewPackages pb pkgs withArgs [] $ shakeArgs shakeOptions @@ -381,9 +383,34 @@ data PurgeReason | Replaced Version | Broken +-- | Print the new packages. +printNewPackages :: PerformBuild -> [PackageIdentifier] -> IO (Map PackageName Version) +printNewPackages pb pkgs = do + unless + (M.null new) + (do putStrLn + ("There are " ++ + show (M.size new) ++ + " packages to build and install: ") + forM_ + (take maxDisplay (M.toList new)) + (\(name,ver) -> + putStrLn (display name)) + when (M.size new > maxDisplay) + (putStrLn ("And " ++ show (M.size new - maxDisplay) ++ " more."))) + return new + where maxDisplay = 10 + new = M.filterWithKey + (\name ver -> + isNothing (find ((== name) . pkgName) pkgs)) + versions + versions = (M.map ppVersion . + M.filter (not . S.null . sdModules . ppDesc) . + bpPackages . pbPlan) pb + -- | Clean up old versions of packages that are no longer in use. -cleanOldPackages :: PerformBuild -> FilePath -> IO () -cleanOldPackages pb shakeDir = do +cleanOldPackages :: PerformBuild -> FilePath -> [PackageIdentifier] -> IO () +cleanOldPackages pb shakeDir pkgs = do putStrLn "Collecting garbage" pkgs <- getRegisteredPackages shakeDir let toRemove = mapMaybe @@ -396,12 +423,10 @@ cleanOldPackages pb shakeDir = do (name, version, (Replaced newVersion)) Nothing -> Just (name, version, NoLongerIncluded)) pkgs - broken <- getBrokenPackages shakeDir + unless (null toRemove) (putStrLn ("There are " ++ show (length toRemove) ++ " packages to be purged.")) - unless (null broken) - (putStrLn ("There are " ++ show (length broken) ++ " broken packages to be purged.")) - when (length broken + length toRemove > 0) + when (length toRemove > 0) (do putStrLn "Waiting 3 seconds before proceeding to remove ..." threadDelay (1000 * 1000 * 3)) forM_ pkgs $ @@ -416,6 +441,12 @@ cleanOldPackages pb shakeDir = do version (Replaced newVersion) Nothing -> purgePackage shakeDir name version NoLongerIncluded + broken <- getBrokenPackages shakeDir + unless (null broken) + (putStrLn ("There are " ++ show (length broken) ++ " broken packages to be purged.")) + when (length broken > 0) + (do putStrLn "Waiting 3 seconds before proceeding to remove ..." + threadDelay (1000 * 1000 * 3)) forM_ broken (\(PackageIdentifier name version) -> From b6cc4f8ee05ad95f35a3e8b9d6aa5264a7082349 Mon Sep 17 00:00:00 2001 From: Chris Done Date: Tue, 17 Feb 2015 14:54:54 +0100 Subject: [PATCH 25/47] Port to system-filepath --- Stackage/ShakeBuild.hs | 402 ++++++++++++++++++----------------------- stackage.cabal | 2 + 2 files changed, 174 insertions(+), 230 deletions(-) diff --git a/Stackage/ShakeBuild.hs b/Stackage/ShakeBuild.hs index 169a5293..49769792 100644 --- a/Stackage/ShakeBuild.hs +++ b/Stackage/ShakeBuild.hs @@ -1,11 +1,12 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ExtendedDefaultRules #-} -- | Build everything with Shake. module Stackage.ShakeBuild where -import Control.Concurrent -import Control.Monad import Stackage.BuildConstraints import Stackage.BuildPlan import Stackage.CheckBuildPlan @@ -13,11 +14,11 @@ import Stackage.PackageDescription import Stackage.PerformBuild (PerformBuild(..),copyBuiltInHaddocks,renameOrCopy,copyDir) import Stackage.Prelude (unFlagName) -import Control.Concurrent.MVar +import Control.Concurrent import Control.Concurrent.STM -import Control.Concurrent.STM.TVar import Control.Exception -import Control.Monad hiding (forM_) +import Control.Monad +import Control.Monad.IO.Class import Data.Conduit import qualified Data.Conduit.List as CL import Data.Conduit.Process @@ -30,114 +31,89 @@ import Data.Monoid import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T -import qualified Data.Text.Encoding as T import Data.Version -import Development.Shake hiding (doesFileExist,doesDirectoryExist) +import Development.Shake.FilePath import Distribution.Compat.ReadP import Distribution.Package -import Distribution.Package (PackageName) import Distribution.Text (display) import Distribution.Text (parse) +import qualified Filesystem as FP +import Filesystem.Path.CurrentOS (FilePath) import qualified Filesystem.Path.CurrentOS as FP -import System.Directory +import Prelude hiding (FilePath) import System.Environment import System.Exit -- | Run the shake builder. performBuild :: PerformBuild -> IO () -performBuild pb = do - shakeDir <- fmap ( "shake/") (getCurrentDirectory >>= canonicalizePath) - createDirectoryIfMissing True shakeDir +performBuild pb' = do + cur <- FP.getWorkingDirectory + let shakeDir = cur <> "shake/" + FP.createTree shakeDir haddockFiles <- liftIO (newTVarIO mempty) registerLock <- liftIO (newMVar ()) pkgs <- getRegisteredPackages shakeDir + let !pb = pb' + { pbInstallDest = cur <> pbInstallDest pb' + } cleanOldPackages pb shakeDir pkgs printNewPackages pb pkgs - withArgs [] $ - shakeArgs - shakeOptions - { shakeFiles = shakeDir - , shakeThreads = 2 - } $ - shakePlan haddockFiles registerLock pb shakeDir + startShake 2 shakeDir (shakePlan haddockFiles registerLock pb shakeDir) -- | The complete build plan as far as Shake is concerned. -shakePlan :: TVar (Map String FilePath) - -> MVar () - -> PerformBuild - -> FilePath - -> Rules () +shakePlan :: TVar (Map String FilePath) -> MVar () -> PerformBuild -> FilePath -> Rules () shakePlan haddockFiles registerLock pb shakeDir = do - fetched <- target (targetForFetched shakeDir) $ - fetchedTarget shakeDir pb + fetched <- target (targetForFetched shakeDir) $ fetchedTarget shakeDir pb db <- target (targetForDb shakeDir) $ databaseTarget shakeDir pb _ <- forM (mapMaybe (\p -> find ((==p) . fst) versionMappings) corePackages) $ \(name,version) -> let fp = targetForPackage shakeDir name version - in target fp (makeFile fp) - packageTargets <- forM normalPackages $ - \(name,plan) -> - target (targetForPackage shakeDir name (ppVersion plan)) $ - do need [db, fetched] - packageTarget - haddockFiles - registerLock - pb - shakeDir - name - plan - haddockTargets <- forM normalPackages $ - \(name,plan) -> - target (targetForDocs shakeDir name (ppVersion plan)) $ - do need [targetForPackage shakeDir name (ppVersion plan)] - packageDocs haddockFiles shakeDir pb plan name - build <- target (targetForBuild pb) - (do need haddockTargets - copyToBuild pb shakeDir) + in target fp (makeTargetFile fp) + packageTargets <- + forM normalPackages $ + \(name,plan) -> + target (targetForPackage shakeDir name (ppVersion plan)) $ + do need [db, fetched] + packageTarget haddockFiles registerLock pb shakeDir name plan + haddockTargets <- + forM normalPackages $ + \(name,plan) -> + target (targetForDocs shakeDir name (ppVersion plan)) $ + do need [targetForPackage shakeDir name (ppVersion plan)] + packageDocs haddockFiles shakeDir pb plan name want haddockTargets - want [build] where versionMappings = M.toList (M.map ppVersion (bpPackages (pbPlan pb))) corePackages = M.keys $ siCorePackages $ bpSystemInfo $ pbPlan pb normalPackages = filter (not . (`elem` corePackages) . fst) $ M.toList $ bpPackages $ pbPlan pb --- | Copy the build as a whole to builds/. -copyToBuild :: PerformBuild -> String -> Action () -copyToBuild pb shakeDir = do - liftIO (putStrLn ("Copying snapshot to " ++ FP.encodeString (pbInstallDest pb))) - copy pbBinDir - copy pbLibDir - copy pbDataDir - copy pbDocDir - makeFile (targetForBuild pb) - where copy mkPath = liftIO $ - do putStrLn ("Copying " ++ mkPath shakeDir) - copyDir - here - there - where here = (FP.decodeString $ mkPath shakeDir) - there = (FP.decodeString $ mkPath $ FP.encodeString $ pbInstallDest pb) - -- | Generate haddock docs for the package. -packageDocs :: TVar (Map String FilePath) - -> FilePattern - -> PerformBuild - -> PackagePlan - -> PackageName - -> Action () +packageDocs :: TVar (Map String FilePath) -> FilePath -> PerformBuild -> PackagePlan -> PackageName -> Action () packageDocs haddockFiles shakeDir pb plan name = do - pwd <- liftIO getCurrentDirectory - env <- liftIO (fmap (Env . (++ defaultEnv pwd)) getEnvironment) - when - (haddocksFlag /= Don'tBuild && - not (S.null $ sdModules $ ppDesc plan)) $ - generateHaddocks haddockFiles pb shakeDir (pkgDir shakeDir name version) env name version haddocksFlag - makeFile (targetForDocs shakeDir name (ppVersion plan)) + pwd <- liftIO FP.getWorkingDirectory + env <- liftIO (fmap (Env . (++ defaultEnv pb shakeDir pwd)) getEnvironment) + when (haddocksFlag /= Don'tBuild && + not (S.null $ sdModules $ ppDesc plan)) $ + generateHaddocks + haddockFiles + pb + shakeDir + (pkgDir shakeDir name version) + env + name + version + haddocksFlag + makeTargetFile (targetForDocs shakeDir name (ppVersion plan)) where version = ppVersion plan haddocksFlag = pcHaddocks $ ppConstraints plan - defaultEnv pwd = [( "HASKELL_PACKAGE_SANDBOX" - , pwd buildDatabase shakeDir) | pbGlobalInstall pb] + +-- | Default environment for running commands. +defaultEnv :: PerformBuild -> FilePath -> FilePath -> [(String, String)] +defaultEnv pb shakeDir pwd = + [( "HASKELL_PACKAGE_SANDBOX" + , FP.encodeString (pwd <> buildDatabase shakeDir)) + | pbGlobalInstall pb] -- | Initialize the database if there one needs to be, and in any case -- create the target file. @@ -146,68 +122,54 @@ databaseTarget shakeDir pb = do if pbGlobalInstall pb then return () else do - liftIO (createDirectoryIfMissing True dir) - liftIO (removeDirectoryRecursive dir) - () <- cmd "ghc-pkg" "init" dir - liftIO $ copyBuiltInHaddocks $ FP.decodeString $ pbDocDir shakeDir - makeFile (targetForDb shakeDir) + liftIO (FP.removeTree dir) + liftIO (FP.createTree dir) + () <- cmd "ghc-pkg" "init" (FP.encodeString dir) + liftIO $ copyBuiltInHaddocks $ pbDocDir pb + makeTargetFile (targetForDb shakeDir) where dir = buildDatabase shakeDir -- | Build, test and generate documentation for the package. -packageTarget :: TVar (Map String FilePath) - -> MVar () - -> PerformBuild - -> FilePath - -> PackageName - -> PackagePlan - -> Action () +packageTarget :: TVar (Map String FilePath) -> MVar () -> PerformBuild -> FilePath -> PackageName -> PackagePlan -> Action () packageTarget haddockFiles registerLock pb shakeDir name plan = do need $ map (\(name,version) -> targetForPackage shakeDir name version) $ mapMaybe (\p -> find ((==p) . fst) versionMappings) $ filter (/= name) $ M.keys $ M.filter libAndExe $ sdPackages $ ppDesc plan - pwd <- liftIO getCurrentDirectory - env <- liftIO (fmap (Env . (++ defaultEnv pwd)) getEnvironment) + pwd <- liftIO FP.getWorkingDirectory + env <- liftIO (fmap (Env . (++ defaultEnv pb shakeDir pwd)) getEnvironment) unpack shakeDir name version configure shakeDir dir env pb plan () <- cmd cwd env "cabal" "build" "--ghc-options=-O0" register dir env registerLock - makeFile (targetForPackage shakeDir name version) + makeTargetFile (targetForPackage shakeDir name version) where dir = pkgDir shakeDir name version version = ppVersion plan versionMappings = M.toList (M.map ppVersion (bpPackages (pbPlan pb))) - cwd = Cwd dir - defaultEnv pwd = [( "HASKELL_PACKAGE_SANDBOX" - , pwd buildDatabase shakeDir) | pbGlobalInstall pb] + cwd = Cwd (FP.encodeString dir) -- | Make sure all package archives have been fetched. fetchedTarget :: FilePath -> PerformBuild -> Action () fetchedTarget shakeDir pb = do () <- cmd "cabal" "fetch" "--no-dependencies" $ map - (\(name,plan) -> - display name ++ - "-" ++ - display (ppVersion plan)) $ + (\(name,plan) -> display name ++ "-" ++ display (ppVersion plan)) $ M.toList $ bpPackages $ pbPlan pb - makeFile (targetForFetched shakeDir) + makeTargetFile (targetForFetched shakeDir) -- | Unpack the package. unpack :: FilePath -> PackageName -> Version -> Action () unpack shakeDir name version = do - unpacked <- liftIO $ - doesFileExist $ - pkgDir shakeDir name version - display name ++ - ".cabal" + unpacked <- liftIO $ FP.isFile $ + pkgDir shakeDir name version <> + FP.decodeString + (display name ++ ".cabal") unless unpacked $ - do liftIO $ - catch (removeDirectoryRecursive (pkgDir shakeDir name version)) $ - \(_ :: IOException) -> - return () + do liftIO $ catch (FP.removeTree (pkgDir shakeDir name version)) $ + \(_ :: IOException) -> return () cmd - (Cwd (shakeDir "packages")) + (Cwd (FP.encodeString (shakeDir <> "packages"))) "cabal" "unpack" (nameVer name version) @@ -215,21 +177,18 @@ unpack shakeDir name version = do -- | Configure the given package. configure :: FilePath -> FilePath -> CmdOption -> PerformBuild -> PackagePlan -> Action () configure shakeDir pkgDir env pb plan = do - pwd <- liftIO getCurrentDirectory - cmd - (Cwd pkgDir) - env - "cabal" - "configure" - (opts pwd) - where opts pwd = [ "--package-db=clear" - , "--package-db=global" - , "--libdir=" ++ pbLibDir shakeDir - , "--bindir=" ++ pbBinDir shakeDir - , "--datadir=" ++ pbDataDir shakeDir - , "--docdir=" ++ pbDocDir shakeDir - , "--flags=" ++ planFlags plan] ++ - ["--package-db=" ++ buildDatabase shakeDir | not (pbGlobalInstall pb)] + pwd <- liftIO FP.getWorkingDirectory + cmd (Cwd (FP.encodeString pkgDir)) env "cabal" "configure" (opts pwd) + where + opts pwd = + [ "--package-db=clear" + , "--package-db=global" + , "--libdir=" ++ FP.encodeString (pbLibDir pb) + , "--bindir=" ++ FP.encodeString (pbBinDir pb) + , "--datadir=" ++ FP.encodeString (pbDataDir pb) + , "--docdir=" ++ FP.encodeString (pbDocDir pb) + , "--flags=" ++ planFlags plan] ++ + ["--package-db=" ++ FP.encodeString (buildDatabase shakeDir) | not (pbGlobalInstall pb)] -- | Register the package. -- @@ -238,86 +197,70 @@ configure shakeDir pkgDir env pb plan = do register :: FilePath -> CmdOption -> MVar () -> Action () register pkgDir env registerLock = do () <- cmd cwd env "cabal" "copy" - -- FIXME: - liftIO - (takeMVar registerLock) + liftIO (takeMVar registerLock) () <- cmd cwd env "cabal" "register" liftIO (putMVar registerLock ()) - where cwd = Cwd pkgDir + where cwd = Cwd (FP.encodeString pkgDir) -- | Generate haddocks for the package. -generateHaddocks :: TVar (Map String FilePath) - -> PerformBuild - -> FilePath - -> FilePath - -> CmdOption - -> PackageName - -> Version - -> TestState - -> Action () +generateHaddocks :: TVar (Map String FilePath) -> PerformBuild -> FilePath -> FilePath -> CmdOption -> PackageName -> Version -> TestState -> Action () generateHaddocks haddockFiles pb shakeDir pkgDir env name version expected = do hfs <- liftIO $ readTVarIO haddockFiles - exitCode <- cmd - (Cwd pkgDir) - env - "cabal" - "haddock" - "--hyperlink-source" - "--html" - "--hoogle" - "--html-location=../$pkg-$version/" - (map - (\(pkgVer,hf) -> - concat - [ "--haddock-options=--read-interface=" - , "../" - , pkgVer - , "/," - , hf]) - (M.toList hfs)) + exitCode <- + cmd + (Cwd (FP.encodeString pkgDir)) + env + "cabal" + "haddock" + "--hyperlink-source" + "--html" + "--hoogle" + "--html-location=../$pkg-$version/" + (map + (\(pkgVer,hf) -> + concat + [ "--haddock-options=--read-interface=" + , "../" + , pkgVer + , "/," + , FP.encodeString hf]) + (M.toList hfs)) case (exitCode, expected) of (ExitSuccess,ExpectFailure) -> return () -- FIXME: warn. (ExitFailure{},ExpectSuccess) -> throw exitCode -- FIXME: report it _ -> return () copy - where ident = nameVer name version - copy = do - liftIO $ - do let orig = pkgDocDir shakeDir name version - exists <- doesDirectoryExist orig - when exists $ - renameOrCopy - (FP.decodeString orig) - (FP.decodeString - (pbDocDir shakeDir ident)) - enewPath <- liftIO $ - try $ - canonicalizePath - (pbDocDir shakeDir ident display name ++ - ".haddock") - case enewPath of - Left (e :: IOException) -> return () -- FIXME: log it with Shake. - Right newPath -> liftIO $ - atomically $ - modifyTVar haddockFiles $ - M.insert (ident) newPath + where + ident = nameVer name version + copy = do + liftIO $ + do let orig = pkgDocDir shakeDir name version + exists <- FP.isDirectory orig + when exists $ + renameOrCopy + orig + (pbDocDir pb <> FP.decodeString ident) + enewPath <- + liftIO $ + try $ + FP.canonicalizePath + (pbDocDir pb <> FP.decodeString ident <> + FP.decodeString (display name ++ ".haddock")) + case enewPath of + Left (e :: IOException) -> return () -- FIXME: log it with Shake. + Right newPath -> liftIO $ atomically $ modifyTVar haddockFiles $ + M.insert (ident) newPath -- | Generate a flags string for the package plan. planFlags :: PackagePlan -> String planFlags plan = unwords $ - map go $ - M.toList - (pcFlagOverrides - (ppConstraints plan)) + map go $ M.toList (pcFlagOverrides (ppConstraints plan)) where go (name',isOn) = concat - [ if isOn - then "" - else "-" - , T.unpack (unFlagName name')] + [ if isOn then "" else "-" , T.unpack (unFlagName name')] -- | Database location. -buildDatabase :: FilePath -> FilePattern -buildDatabase shakeDir = shakeDir "pkgdb" +buildDatabase :: FilePath -> FilePath +buildDatabase shakeDir = shakeDir <> "pkgdb" -- | Print the name and version. nameVer :: PackageName -> Version -> String @@ -325,57 +268,59 @@ nameVer name version = display name ++ "-" ++ display version -- | The directory for the package's docs. pkgDocDir :: FilePath -> PackageName -> Version -> FilePath -pkgDocDir shakeDir name version = pkgDir shakeDir name version - "dist" - "doc" - "html" - (display name) +pkgDocDir shakeDir name version = pkgDir shakeDir name version <> + "dist" <> + "doc" <> + "html" <> + (FP.decodeString (display name)) -- | The package directory. pkgDir :: FilePath -> PackageName -> Version -> FilePath -pkgDir shakeDir name version = shakeDir "packages" - (nameVer name version) +pkgDir shakeDir name version = shakeDir <> "packages" <> + (FP.decodeString (nameVer name version)) -- | Get the target file for confirming that all packages have been -- pre-fetched. -targetForFetched :: FilePath -> FilePath +targetForFetched :: FilePath -> Target targetForFetched shakeDir = - shakeDir "packages-fetched" + Target (shakeDir <> "packages-fetched") -- | Get the target file for a package. -targetForPackage :: FilePath -> PackageName -> Version -> FilePath -targetForPackage shakeDir name version = - shakeDir "packages" nameVer name version "dist" "shake-build" +targetForPackage :: FilePath -> PackageName -> Version -> Target +targetForPackage shakeDir name version = Target $ + shakeDir <> "packages" <> + FP.decodeString + (nameVer name version) <> + "dist" <> + "shake-build" -- | Get the target file for a package. -targetForDocs :: FilePath -> PackageName -> Version -> FilePath -targetForDocs shakeDir name version = - shakeDir "packages" nameVer name version "dist" "shake-docs" +targetForDocs :: FilePath -> PackageName -> Version -> Target +targetForDocs shakeDir name version = Target $ + shakeDir <> "packages" <> + FP.decodeString + (nameVer name version) <> + "dist" <> + "shake-docs" -- | Target for the complete, copied build under builds/date/. -targetForBuild :: PerformBuild -> FilePattern -targetForBuild pb = FP.encodeString (pbInstallDest pb) "shake-built" +targetForBuild :: PerformBuild -> Target +targetForBuild pb = Target $ (pbInstallDest pb) <> "shake-built" -- | Get a package database path. -targetForDb :: FilePath -> FilePath +targetForDb :: FilePath -> Target targetForDb shakeDir = - shakeDir "pkgdb-initialized" - --- | Declare a target, returning the target name. -target :: FilePattern -> Action () -> Rules FilePattern -target name act = do - name *> const act - return name + Target $ shakeDir <> "pkgdb-initialized" -- | Make a file of this name. -makeFile :: FilePath -> Action () -makeFile fp = liftIO $ writeFile fp "" +makeTargetFile :: Target -> Action () +makeTargetFile fp = liftIO $ FP.writeFile (unTarget fp) "" -pbBinDir, pbLibDir, pbDataDir, pbDocDir :: FilePath -> FilePath -pbBinDir shakeDir = shakeDir "bin" -pbLibDir shakeDir = shakeDir "lib" -pbDataDir shakeDir = shakeDir "share" -pbDocDir shakeDir = shakeDir "doc" +pbBinDir, pbLibDir, pbDataDir, pbDocDir :: PerformBuild -> FilePath +pbBinDir root = (pbInstallDest root) <> "bin" +pbLibDir root = (pbInstallDest root) <> "lib" +pbDataDir root = (pbInstallDest root) <> "share" +pbDocDir root = (pbInstallDest root) <> "doc" -- | Reason for purging a package. data PurgeReason @@ -423,7 +368,6 @@ cleanOldPackages pb shakeDir pkgs = do (name, version, (Replaced newVersion)) Nothing -> Just (name, version, NoLongerIncluded)) pkgs - unless (null toRemove) (putStrLn ("There are " ++ show (length toRemove) ++ " packages to be purged.")) when (length toRemove > 0) @@ -471,18 +415,18 @@ purgePackage shakeDir name version reason = do unregister = do void (readProcessWithExitCode "ghc-pkg" - ["unregister", "-f", buildDatabase shakeDir, "--force", ident] + ["unregister", "-f", FP.encodeString (buildDatabase shakeDir), "--force", ident] "") - delete = removeDirectoryRecursive $ + delete = FP.removeTree $ pkgDir shakeDir name version -- | Get broken packages. getBrokenPackages :: FilePath -> IO [PackageIdentifier] getBrokenPackages shakeDir = do (_,ps) <- sourceProcessWithConsumer - (proc' + (proc "ghc-pkg" - ["check", "--simple-output", "-f", buildDatabase shakeDir]) + ["check", "--simple-output", "-f", FP.encodeString (buildDatabase shakeDir)]) (CT.decodeUtf8 $= CT.lines $= CL.consume) return (mapMaybe parsePackageIdent (T.words (T.unlines ps))) @@ -490,9 +434,9 @@ getBrokenPackages shakeDir = do getRegisteredPackages :: FilePath -> IO [PackageIdentifier] getRegisteredPackages shakeDir = do (_,ps) <- sourceProcessWithConsumer - (proc' + (proc "ghc-pkg" - ["list", "--simple-output", "-f", buildDatabase shakeDir]) + ["list", "--simple-output", "-f", FP.encodeString (buildDatabase shakeDir)]) (CT.decodeUtf8 $= CT.lines $= CL.consume) return (mapMaybe parsePackageIdent (T.words (T.unlines ps))) @@ -502,5 +446,3 @@ parsePackageIdent = fmap fst . listToMaybe . filter (null . snd) . readP_to_S parse . T.unpack - -proc' = proc diff --git a/stackage.cabal b/stackage.cabal index cbcf9eca..00fba4d3 100644 --- a/stackage.cabal +++ b/stackage.cabal @@ -31,6 +31,8 @@ library Stackage.PerformBuild Stackage.ShakeBuild Stackage.CompleteBuild + other-modules: + Development.Shake.FilePath build-depends: Cabal >= 1.14 , aeson From bdbde2c2fb1b04d17e3c4c15dd90d3b413629aab Mon Sep 17 00:00:00 2001 From: Chris Done Date: Tue, 17 Feb 2015 15:23:24 +0100 Subject: [PATCH 26/47] Make a reader environment --- Stackage/ShakeBuild.hs | 240 ++++++++++++++++++++++------------------- 1 file changed, 127 insertions(+), 113 deletions(-) diff --git a/Stackage/ShakeBuild.hs b/Stackage/ShakeBuild.hs index 49769792..5ab46a96 100644 --- a/Stackage/ShakeBuild.hs +++ b/Stackage/ShakeBuild.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ExtendedDefaultRules #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} -- | Build everything with Shake. @@ -11,7 +13,7 @@ import Stackage.BuildConstraints import Stackage.BuildPlan import Stackage.CheckBuildPlan import Stackage.PackageDescription -import Stackage.PerformBuild (PerformBuild(..),copyBuiltInHaddocks,renameOrCopy,copyDir) +import Stackage.PerformBuild (PerformBuild(..),copyBuiltInHaddocks,renameOrCopy) import Stackage.Prelude (unFlagName) import Control.Concurrent @@ -32,7 +34,8 @@ import qualified Data.Set as S import Data.Text (Text) import qualified Data.Text as T import Data.Version -import Development.Shake.FilePath +import Development.Shake.FilePath hiding (Env) +import qualified Development.Shake.FilePath as Shake import Distribution.Compat.ReadP import Distribution.Package import Distribution.Text (display) @@ -44,6 +47,15 @@ import Prelude hiding (FilePath) import System.Environment import System.Exit +data Env = Env + {envCur :: FilePath + ,envShake :: FilePath + ,envHadLock :: TVar (Map String FilePath) + ,envRegLock :: MVar () + ,envPB :: PerformBuild + ,envRegistered :: [PackageIdentifier] + } + -- | Run the shake builder. performBuild :: PerformBuild -> IO () performBuild pb' = do @@ -56,55 +68,59 @@ performBuild pb' = do let !pb = pb' { pbInstallDest = cur <> pbInstallDest pb' } - cleanOldPackages pb shakeDir pkgs - printNewPackages pb pkgs - startShake 2 shakeDir (shakePlan haddockFiles registerLock pb shakeDir) + !env = Env + { envCur = cur + , envShake = shakeDir + , envHadLock = haddockFiles + , envRegLock = registerLock + , envPB = pb + , envRegistered = pkgs + } + cleanOldPackages env + printNewPackages env + startShake 2 shakeDir (shakePlan env) -- | The complete build plan as far as Shake is concerned. -shakePlan :: TVar (Map String FilePath) -> MVar () -> PerformBuild -> FilePath -> Rules () -shakePlan haddockFiles registerLock pb shakeDir = do - fetched <- target (targetForFetched shakeDir) $ fetchedTarget shakeDir pb - db <- target (targetForDb shakeDir) $ - databaseTarget shakeDir pb - _ <- forM (mapMaybe (\p -> find ((==p) . fst) versionMappings) corePackages) $ - \(name,version) -> - let fp = targetForPackage shakeDir name version - in target fp (makeTargetFile fp) - packageTargets <- - forM normalPackages $ +shakePlan :: Env -> Rules () +shakePlan env@Env{..} = do + fetched <- target (targetForFetched env) $ fetchedTarget env + db <- target (targetForDb env) $ databaseTarget env + void $ forM (mapMaybe (\p -> find ((==p) . fst) versionMappings) corePackages) $ + \(name,version) -> + let fp = targetForPackage envShake name version + in target fp (makeTargetFile fp) + void $ forM normalPackages $ \(name,plan) -> - target (targetForPackage shakeDir name (ppVersion plan)) $ + target (targetForPackage envShake name (ppVersion plan)) $ do need [db, fetched] - packageTarget haddockFiles registerLock pb shakeDir name plan + packageTarget env name plan haddockTargets <- forM normalPackages $ \(name,plan) -> - target (targetForDocs shakeDir name (ppVersion plan)) $ - do need [targetForPackage shakeDir name (ppVersion plan)] - packageDocs haddockFiles shakeDir pb plan name + target (targetForDocs envShake name (ppVersion plan)) $ + do need [targetForPackage envShake name (ppVersion plan)] + packageDocs env plan name want haddockTargets - where versionMappings = M.toList (M.map ppVersion (bpPackages (pbPlan pb))) - corePackages = M.keys $ siCorePackages $ bpSystemInfo $ pbPlan pb + where versionMappings = M.toList (M.map ppVersion (bpPackages (pbPlan envPB))) + corePackages = M.keys $ siCorePackages $ bpSystemInfo $ pbPlan envPB normalPackages = filter (not . (`elem` corePackages) . fst) $ - M.toList $ bpPackages $ pbPlan pb + M.toList $ bpPackages $ pbPlan envPB -- | Generate haddock docs for the package. -packageDocs :: TVar (Map String FilePath) -> FilePath -> PerformBuild -> PackagePlan -> PackageName -> Action () -packageDocs haddockFiles shakeDir pb plan name = do +packageDocs :: Env -> PackagePlan -> PackageName -> Action () +packageDocs env@Env{..} plan name = do pwd <- liftIO FP.getWorkingDirectory - env <- liftIO (fmap (Env . (++ defaultEnv pb shakeDir pwd)) getEnvironment) + envmap <- liftIO (fmap (Shake.Env . (++ defaultEnv envPB envShake pwd)) getEnvironment) when (haddocksFlag /= Don'tBuild && not (S.null $ sdModules $ ppDesc plan)) $ generateHaddocks - haddockFiles - pb - shakeDir - (pkgDir shakeDir name version) env + (pkgDir env name version) + envmap name version haddocksFlag - makeTargetFile (targetForDocs shakeDir name (ppVersion plan)) + makeTargetFile (targetForDocs envShake name (ppVersion plan)) where version = ppVersion plan haddocksFlag = pcHaddocks $ ppConstraints plan @@ -117,99 +133,99 @@ defaultEnv pb shakeDir pwd = -- | Initialize the database if there one needs to be, and in any case -- create the target file. -databaseTarget :: FilePath -> PerformBuild -> Action () -databaseTarget shakeDir pb = do - if pbGlobalInstall pb +databaseTarget :: Env -> Action () +databaseTarget env = do + if pbGlobalInstall (envPB env) then return () else do liftIO (FP.removeTree dir) liftIO (FP.createTree dir) () <- cmd "ghc-pkg" "init" (FP.encodeString dir) - liftIO $ copyBuiltInHaddocks $ pbDocDir pb - makeTargetFile (targetForDb shakeDir) - where dir = buildDatabase shakeDir + liftIO $ copyBuiltInHaddocks $ pbDocDir (envPB env) + makeTargetFile (targetForDb env) + where dir = buildDatabase (envShake env) -- | Build, test and generate documentation for the package. -packageTarget :: TVar (Map String FilePath) -> MVar () -> PerformBuild -> FilePath -> PackageName -> PackagePlan -> Action () -packageTarget haddockFiles registerLock pb shakeDir name plan = do +packageTarget :: Env -> PackageName -> PackagePlan -> Action () +packageTarget env@Env{..} name plan = do need $ - map (\(name,version) -> targetForPackage shakeDir name version) $ + map (\(pname,pver) -> targetForPackage envShake pname pver) $ mapMaybe (\p -> find ((==p) . fst) versionMappings) $ filter (/= name) $ M.keys $ M.filter libAndExe $ sdPackages $ ppDesc plan pwd <- liftIO FP.getWorkingDirectory - env <- liftIO (fmap (Env . (++ defaultEnv pb shakeDir pwd)) getEnvironment) - unpack shakeDir name version - configure shakeDir dir env pb plan - () <- cmd cwd env "cabal" "build" "--ghc-options=-O0" - register dir env registerLock - makeTargetFile (targetForPackage shakeDir name version) - where dir = pkgDir shakeDir name version + envmap <- liftIO (fmap (Shake.Env . (++ defaultEnv envPB envShake pwd)) getEnvironment) + unpack env name version + configure env dir envmap plan + () <- cmd cwd envmap "cabal" "build" "--ghc-options=-O0" + register dir envmap envRegLock + makeTargetFile (targetForPackage envShake name version) + where dir = pkgDir env name version version = ppVersion plan - versionMappings = M.toList (M.map ppVersion (bpPackages (pbPlan pb))) + versionMappings = M.toList (M.map ppVersion (bpPackages (pbPlan envPB))) cwd = Cwd (FP.encodeString dir) -- | Make sure all package archives have been fetched. -fetchedTarget :: FilePath -> PerformBuild -> Action () -fetchedTarget shakeDir pb = do +fetchedTarget :: Env -> Action () +fetchedTarget env@Env{..} = do () <- cmd "cabal" "fetch" "--no-dependencies" $ map (\(name,plan) -> display name ++ "-" ++ display (ppVersion plan)) $ - M.toList $ bpPackages $ pbPlan pb - makeTargetFile (targetForFetched shakeDir) + M.toList $ bpPackages $ pbPlan envPB + makeTargetFile (targetForFetched env) -- | Unpack the package. -unpack :: FilePath -> PackageName -> Version -> Action () -unpack shakeDir name version = do +unpack :: Env -> PackageName -> Version -> Action () +unpack env@Env{..} name version = do unpacked <- liftIO $ FP.isFile $ - pkgDir shakeDir name version <> + pkgDir env name version <> FP.decodeString (display name ++ ".cabal") unless unpacked $ - do liftIO $ catch (FP.removeTree (pkgDir shakeDir name version)) $ + do liftIO $ catch (FP.removeTree (pkgDir env name version)) $ \(_ :: IOException) -> return () cmd - (Cwd (FP.encodeString (shakeDir <> "packages"))) + (Cwd (FP.encodeString (envShake <> "packages"))) "cabal" "unpack" (nameVer name version) -- | Configure the given package. -configure :: FilePath -> FilePath -> CmdOption -> PerformBuild -> PackagePlan -> Action () -configure shakeDir pkgDir env pb plan = do - pwd <- liftIO FP.getWorkingDirectory - cmd (Cwd (FP.encodeString pkgDir)) env "cabal" "configure" (opts pwd) +configure :: Env -> FilePath -> CmdOption -> PackagePlan -> Action () +configure Env{..} pdir env plan = + cmd (Cwd (FP.encodeString pdir)) env "cabal" "configure" opts where - opts pwd = + opts = [ "--package-db=clear" , "--package-db=global" - , "--libdir=" ++ FP.encodeString (pbLibDir pb) - , "--bindir=" ++ FP.encodeString (pbBinDir pb) - , "--datadir=" ++ FP.encodeString (pbDataDir pb) - , "--docdir=" ++ FP.encodeString (pbDocDir pb) + , "--libdir=" ++ FP.encodeString (pbLibDir envPB) + , "--bindir=" ++ FP.encodeString (pbBinDir envPB) + , "--datadir=" ++ FP.encodeString (pbDataDir envPB) + , "--docdir=" ++ FP.encodeString (pbDocDir envPB) , "--flags=" ++ planFlags plan] ++ - ["--package-db=" ++ FP.encodeString (buildDatabase shakeDir) | not (pbGlobalInstall pb)] + ["--package-db=" ++ FP.encodeString (buildDatabase envShake) + | not (pbGlobalInstall envPB)] -- | Register the package. -- -- TODO: Do a mutex lock in here. Does Shake already support doing -- this out of the box? register :: FilePath -> CmdOption -> MVar () -> Action () -register pkgDir env registerLock = do +register pdir env registerLock = do () <- cmd cwd env "cabal" "copy" liftIO (takeMVar registerLock) () <- cmd cwd env "cabal" "register" liftIO (putMVar registerLock ()) - where cwd = Cwd (FP.encodeString pkgDir) + where cwd = Cwd (FP.encodeString pdir) -- | Generate haddocks for the package. -generateHaddocks :: TVar (Map String FilePath) -> PerformBuild -> FilePath -> FilePath -> CmdOption -> PackageName -> Version -> TestState -> Action () -generateHaddocks haddockFiles pb shakeDir pkgDir env name version expected = do - hfs <- liftIO $ readTVarIO haddockFiles +generateHaddocks :: Env -> FilePath -> CmdOption -> PackageName -> Version -> TestState -> Action () +generateHaddocks env@Env{..} pdir envmap name version expected = do + hfs <- liftIO $ readTVarIO envHadLock exitCode <- cmd - (Cwd (FP.encodeString pkgDir)) - env + (Cwd (FP.encodeString pdir)) + envmap "cabal" "haddock" "--hyperlink-source" @@ -234,21 +250,21 @@ generateHaddocks haddockFiles pb shakeDir pkgDir env name version expected = do ident = nameVer name version copy = do liftIO $ - do let orig = pkgDocDir shakeDir name version + do let orig = pkgDocDir env name version exists <- FP.isDirectory orig when exists $ renameOrCopy orig - (pbDocDir pb <> FP.decodeString ident) + (pbDocDir envPB <> FP.decodeString ident) enewPath <- liftIO $ try $ FP.canonicalizePath - (pbDocDir pb <> FP.decodeString ident <> + (pbDocDir envPB <> FP.decodeString ident <> FP.decodeString (display name ++ ".haddock")) case enewPath of - Left (e :: IOException) -> return () -- FIXME: log it with Shake. - Right newPath -> liftIO $ atomically $ modifyTVar haddockFiles $ + Left (_ :: IOException) -> return () -- FIXME: log it with Shake. + Right newPath -> liftIO $ atomically $ modifyTVar envHadLock $ M.insert (ident) newPath -- | Generate a flags string for the package plan. @@ -267,23 +283,23 @@ nameVer :: PackageName -> Version -> String nameVer name version = display name ++ "-" ++ display version -- | The directory for the package's docs. -pkgDocDir :: FilePath -> PackageName -> Version -> FilePath -pkgDocDir shakeDir name version = pkgDir shakeDir name version <> +pkgDocDir :: Env -> PackageName -> Version -> FilePath +pkgDocDir env@Env{..} name version = pkgDir env name version <> "dist" <> "doc" <> "html" <> (FP.decodeString (display name)) -- | The package directory. -pkgDir :: FilePath -> PackageName -> Version -> FilePath -pkgDir shakeDir name version = shakeDir <> "packages" <> +pkgDir :: Env -> PackageName -> Version -> FilePath +pkgDir Env{..} name version = envShake <> "packages" <> (FP.decodeString (nameVer name version)) -- | Get the target file for confirming that all packages have been -- pre-fetched. -targetForFetched :: FilePath -> Target -targetForFetched shakeDir = - Target (shakeDir <> "packages-fetched") +targetForFetched :: Env -> Target +targetForFetched Env{..} = + Target (envShake <> "packages-fetched") -- | Get the target file for a package. targetForPackage :: FilePath -> PackageName -> Version -> Target @@ -308,9 +324,9 @@ targetForBuild :: PerformBuild -> Target targetForBuild pb = Target $ (pbInstallDest pb) <> "shake-built" -- | Get a package database path. -targetForDb :: FilePath -> Target -targetForDb shakeDir = - Target $ shakeDir <> "pkgdb-initialized" +targetForDb :: Env -> Target +targetForDb Env{..} = + Target $ envShake <> "pkgdb-initialized" -- | Make a file of this name. makeTargetFile :: Target -> Action () @@ -329,8 +345,8 @@ data PurgeReason | Broken -- | Print the new packages. -printNewPackages :: PerformBuild -> [PackageIdentifier] -> IO (Map PackageName Version) -printNewPackages pb pkgs = do +printNewPackages :: Env -> IO () +printNewPackages Env{..} = do unless (M.null new) (do putStrLn @@ -338,26 +354,24 @@ printNewPackages pb pkgs = do show (M.size new) ++ " packages to build and install: ") forM_ - (take maxDisplay (M.toList new)) - (\(name,ver) -> - putStrLn (display name)) + (map fst (take maxDisplay (M.toList new))) + (putStrLn . display) when (M.size new > maxDisplay) (putStrLn ("And " ++ show (M.size new - maxDisplay) ++ " more."))) - return new where maxDisplay = 10 new = M.filterWithKey - (\name ver -> - isNothing (find ((== name) . pkgName) pkgs)) + (\name _ -> + isNothing (find ((== name) . pkgName) envRegistered)) versions versions = (M.map ppVersion . M.filter (not . S.null . sdModules . ppDesc) . - bpPackages . pbPlan) pb + bpPackages . pbPlan) envPB -- | Clean up old versions of packages that are no longer in use. -cleanOldPackages :: PerformBuild -> FilePath -> [PackageIdentifier] -> IO () -cleanOldPackages pb shakeDir pkgs = do +cleanOldPackages :: Env -> IO () +cleanOldPackages env@Env{..} = do putStrLn "Collecting garbage" - pkgs <- getRegisteredPackages shakeDir + pkgs <- getRegisteredPackages envShake let toRemove = mapMaybe (\(PackageIdentifier name version) -> case M.lookup name versions of @@ -380,12 +394,12 @@ cleanOldPackages pb shakeDir pkgs = do | version' == version -> return () Just newVersion -> purgePackage - shakeDir + env name version (Replaced newVersion) - Nothing -> purgePackage shakeDir name version NoLongerIncluded - broken <- getBrokenPackages shakeDir + Nothing -> purgePackage env name version NoLongerIncluded + broken <- getBrokenPackages envShake unless (null broken) (putStrLn ("There are " ++ show (length broken) ++ " broken packages to be purged.")) when (length broken > 0) @@ -394,15 +408,15 @@ cleanOldPackages pb shakeDir pkgs = do forM_ broken (\(PackageIdentifier name version) -> - purgePackage shakeDir name version Broken) - where versions = (M.map ppVersion . bpPackages . pbPlan) pb + purgePackage env name version Broken) + where versions = (M.map ppVersion . bpPackages . pbPlan) envPB -- | Purge the given package and version. -purgePackage :: FilePath -> PackageName -> Version -> PurgeReason -> IO () -purgePackage shakeDir name version reason = do +purgePackage :: Env -> PackageName -> Version -> PurgeReason -> IO () +purgePackage env name version reason = do putStr $ "Purging package: " ++ ident ++ " (" ++ showReason ++ ") ... " unregister - delete + remove putStrLn "done." where showReason = case reason of @@ -415,10 +429,10 @@ purgePackage shakeDir name version reason = do unregister = do void (readProcessWithExitCode "ghc-pkg" - ["unregister", "-f", FP.encodeString (buildDatabase shakeDir), "--force", ident] + ["unregister", "-f", FP.encodeString (buildDatabase (envShake env)), "--force", ident] "") - delete = FP.removeTree $ - pkgDir shakeDir name version + remove = FP.removeTree $ + pkgDir env name version -- | Get broken packages. getBrokenPackages :: FilePath -> IO [PackageIdentifier] From fd2b6c9ea226e6a170f459b2e3f0153f78ce180d Mon Sep 17 00:00:00 2001 From: Chris Done Date: Tue, 17 Feb 2015 15:34:22 +0100 Subject: [PATCH 27/47] Add Shake.FilePath --- Development/Shake/FilePath.hs | 56 +++++++++++++++++++++++++++++++++++ 1 file changed, 56 insertions(+) create mode 100644 Development/Shake/FilePath.hs diff --git a/Development/Shake/FilePath.hs b/Development/Shake/FilePath.hs new file mode 100644 index 00000000..5750e0e4 --- /dev/null +++ b/Development/Shake/FilePath.hs @@ -0,0 +1,56 @@ +-- | Useful 'System.FilePath' wrapper around Shake. + +module Development.Shake.FilePath + (startShake + ,target + ,need + ,want + ,Target(Target) + ,unTarget + ,Rules + ,Action + ,CmdOption(..) + ,Shake.cmd) + where + +import Control.Monad.IO.Class +import Development.Shake (Rules,Action,CmdOption(..)) +import qualified Development.Shake as Shake +import Filesystem.Path.CurrentOS (FilePath) +import qualified Filesystem.Path.CurrentOS as FP +import Prelude hiding (FilePath) +import System.Environment + +-- | A simple opaque wrapper for the "target" abstraction. +newtype Target = Target + { unTarget :: FilePath + } + +-- | Start Shake with the given data directory. +startShake :: MonadIO m => Int -> FilePath -> Rules () -> m () +startShake threads dir rules = + liftIO (withArgs [] $ + Shake.shakeArgs + Shake.shakeOptions + { Shake.shakeFiles = FP.encodeString dir + , Shake.shakeThreads = threads + } $ + rules) + +-- | Declare a target, returning the target name. +target :: Target -> Action () -> Rules Target +target name act = do + (FP.encodeString + (unTarget name)) Shake.*> + const act + return name + +-- | Need the given dependencies. +need :: [Target] -> Action () +need xs = Shake.need $ + map (FP.encodeString . unTarget) xs + +-- | Need the given dependencies. +want :: [Target] -> Rules () +want xs = Shake.want + (map (FP.encodeString . unTarget) xs) From 77f1ea3789633d24b4117d4eb2ca67c5ba597e14 Mon Sep 17 00:00:00 2001 From: Chris Done Date: Tue, 17 Feb 2015 15:49:30 +0100 Subject: [PATCH 28/47] Some shake cleanup --- Development/Shake/FilePath.hs | 10 +- Stackage/GhcPkg.hs | 55 ++++ Stackage/ShakeBuild.hs | 457 ++++++++++++++++------------------ stackage.cabal | 1 + 4 files changed, 279 insertions(+), 244 deletions(-) create mode 100644 Stackage/GhcPkg.hs diff --git a/Development/Shake/FilePath.hs b/Development/Shake/FilePath.hs index 5750e0e4..c351bb1f 100644 --- a/Development/Shake/FilePath.hs +++ b/Development/Shake/FilePath.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + -- | Useful 'System.FilePath' wrapper around Shake. module Development.Shake.FilePath @@ -10,12 +12,14 @@ module Development.Shake.FilePath ,Rules ,Action ,CmdOption(..) - ,Shake.cmd) + ,Shake.cmd + ,makeTargetFile) where import Control.Monad.IO.Class import Development.Shake (Rules,Action,CmdOption(..)) import qualified Development.Shake as Shake +import qualified Filesystem as FP import Filesystem.Path.CurrentOS (FilePath) import qualified Filesystem.Path.CurrentOS as FP import Prelude hiding (FilePath) @@ -54,3 +58,7 @@ need xs = Shake.need $ want :: [Target] -> Rules () want xs = Shake.want (map (FP.encodeString . unTarget) xs) + +-- | Make an empty file of this name. +makeTargetFile :: Target -> Action () +makeTargetFile fp = liftIO $ FP.writeFile (unTarget fp) "" diff --git a/Stackage/GhcPkg.hs b/Stackage/GhcPkg.hs new file mode 100644 index 00000000..f49a7477 --- /dev/null +++ b/Stackage/GhcPkg.hs @@ -0,0 +1,55 @@ +-- | General commands related to ghc-pkg. + +module Stackage.GhcPkg where + +import Control.Monad +import Data.Conduit +import qualified Data.Conduit.List as CL +import Data.Conduit.Process +import qualified Data.Conduit.Text as CT +import Data.List +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Distribution.Compat.ReadP +import Distribution.Package +import Distribution.Text (display) +import Distribution.Text (parse) +import Filesystem.Path.CurrentOS (FilePath) +import qualified Filesystem.Path.CurrentOS as FP +import Prelude hiding (FilePath) + +-- | Get broken packages. +getBrokenPackages :: FilePath -> IO [PackageIdentifier] +getBrokenPackages dir = do + (_,ps) <- sourceProcessWithConsumer + (proc + "ghc-pkg" + ["check", "--simple-output", "-f", FP.encodeString dir]) + (CT.decodeUtf8 $= CT.lines $= CL.consume) + return (mapMaybe parsePackageIdent (T.words (T.unlines ps))) + +-- | Get available packages. +getRegisteredPackages :: FilePath -> IO [PackageIdentifier] +getRegisteredPackages dir = do + (_,ps) <- sourceProcessWithConsumer + (proc + "ghc-pkg" + ["list", "--simple-output", "-f", FP.encodeString dir]) + (CT.decodeUtf8 $= CT.lines $= CL.consume) + return (mapMaybe parsePackageIdent (T.words (T.unlines ps))) + +-- | Parse a package identifier: foo-1.2.3 +parsePackageIdent :: Text -> Maybe PackageIdentifier +parsePackageIdent = fmap fst . + listToMaybe . + filter (null . snd) . + readP_to_S parse . T.unpack + +-- | Unregister a package. +unregisterPackage :: FilePath -> PackageName -> IO () +unregisterPackage dir ident = do + void (readProcessWithExitCode + "ghc-pkg" + ["unregister", "-f", FP.encodeString dir, "--force", display ident] + "") diff --git a/Stackage/ShakeBuild.hs b/Stackage/ShakeBuild.hs index 5ab46a96..7e1f5c3b 100644 --- a/Stackage/ShakeBuild.hs +++ b/Stackage/ShakeBuild.hs @@ -12,6 +12,7 @@ module Stackage.ShakeBuild where import Stackage.BuildConstraints import Stackage.BuildPlan import Stackage.CheckBuildPlan +import Stackage.GhcPkg import Stackage.PackageDescription import Stackage.PerformBuild (PerformBuild(..),copyBuiltInHaddocks,renameOrCopy) import Stackage.Prelude (unFlagName) @@ -21,25 +22,18 @@ import Control.Concurrent.STM import Control.Exception import Control.Monad import Control.Monad.IO.Class -import Data.Conduit -import qualified Data.Conduit.List as CL -import Data.Conduit.Process -import qualified Data.Conduit.Text as CT import Data.List import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Maybe import Data.Monoid import qualified Data.Set as S -import Data.Text (Text) import qualified Data.Text as T import Data.Version -import Development.Shake.FilePath hiding (Env) import qualified Development.Shake.FilePath as Shake -import Distribution.Compat.ReadP +import Development.Shake.FilePath hiding (Env) import Distribution.Package import Distribution.Text (display) -import Distribution.Text (parse) import qualified Filesystem as FP import Filesystem.Path.CurrentOS (FilePath) import qualified Filesystem.Path.CurrentOS as FP @@ -47,15 +41,19 @@ import Prelude hiding (FilePath) import System.Environment import System.Exit +-- | Reader environment used generally throughout the build process. data Env = Env - {envCur :: FilePath - ,envShake :: FilePath - ,envHadLock :: TVar (Map String FilePath) - ,envRegLock :: MVar () - ,envPB :: PerformBuild - ,envRegistered :: [PackageIdentifier] + {envCur :: FilePath -- ^ Current directory. + ,envShake :: FilePath -- ^ Shake directory. + ,envHaddocks :: TVar (Map String FilePath) -- ^ Haddock files. + ,envRegLock :: MVar () -- ^ Package registering lock. + ,envPB :: PerformBuild -- ^ Build perform settings. + ,envRegistered :: [PackageIdentifier] -- ^ Registered packages. } +-------------------------------------------------------------------------------- +-- Main entry point + -- | Run the shake builder. performBuild :: PerformBuild -> IO () performBuild pb' = do @@ -64,14 +62,14 @@ performBuild pb' = do FP.createTree shakeDir haddockFiles <- liftIO (newTVarIO mempty) registerLock <- liftIO (newMVar ()) - pkgs <- getRegisteredPackages shakeDir + pkgs <- getRegisteredPackages (buildDatabase shakeDir) let !pb = pb' { pbInstallDest = cur <> pbInstallDest pb' } !env = Env { envCur = cur , envShake = shakeDir - , envHadLock = haddockFiles + , envHaddocks = haddockFiles , envRegLock = registerLock , envPB = pb , envRegistered = pkgs @@ -80,6 +78,9 @@ performBuild pb' = do printNewPackages env startShake 2 shakeDir (shakePlan env) +-------------------------------------------------------------------------------- +-- The whole Shake plan + -- | The complete build plan as far as Shake is concerned. shakePlan :: Env -> Rules () shakePlan env@Env{..} = do @@ -106,6 +107,190 @@ shakePlan env@Env{..} = do normalPackages = filter (not . (`elem` corePackages) . fst) $ M.toList $ bpPackages $ pbPlan envPB +-------------------------------------------------------------------------------- +-- Target file paths + +-- | Get the target file for confirming that all packages have been +-- pre-fetched. +targetForFetched :: Env -> Target +targetForFetched Env{..} = Target (envShake <> "packages-fetched") + +-- | Get the target file for a package. +targetForPackage :: FilePath -> PackageName -> Version -> Target +targetForPackage shakeDir name version = Target $ + shakeDir <> "packages" <> + FP.decodeString (nameVer name version) + <> "dist" <> "shake-build" + +-- | Get the target file for a package. +targetForDocs :: FilePath -> PackageName -> Version -> Target +targetForDocs shakeDir name version = Target $ + shakeDir <> "packages" <> + FP.decodeString + (nameVer name version) <> + "dist" <> "shake-docs" + +-- | Target for the complete, copied build under builds/date/. +targetForBuild :: PerformBuild -> Target +targetForBuild pb = Target $ (pbInstallDest pb) <> "shake-built" + +-- | Get a package database path. +targetForDb :: Env -> Target +targetForDb Env{..} = Target $ envShake <> "pkgdb-initialized" + +-------------------------------------------------------------------------------- +-- Locations, names and environments used. Just to avoid "magic +-- strings". + +-- | Print the name and version. +nameVer :: PackageName -> Version -> String +nameVer name version = display name ++ "-" ++ display version + +-- | Default environment for running commands. +defaultEnv :: PerformBuild -> FilePath -> FilePath -> [(String, String)] +defaultEnv pb shakeDir pwd = + [( "HASKELL_PACKAGE_SANDBOX" + , FP.encodeString (pwd <> buildDatabase shakeDir)) + | pbGlobalInstall pb] + +-- | Database location. +buildDatabase :: FilePath -> FilePath +buildDatabase shakeDir = shakeDir <> "pkgdb" + +-- | The directory for the package's docs. +pkgDocDir :: Env -> PackageName -> Version -> FilePath +pkgDocDir env@Env{..} name version = pkgDir env name version <> + "dist" <> + "doc" <> + "html" <> + (FP.decodeString (display name)) + +-- | The package directory. +pkgDir :: Env -> PackageName -> Version -> FilePath +pkgDir Env{..} name version = envShake <> "packages" <> + (FP.decodeString (nameVer name version)) + +-- | Installation paths. +pbBinDir, pbLibDir, pbDataDir, pbDocDir :: PerformBuild -> FilePath +pbBinDir root = (pbInstallDest root) <> "bin" +pbLibDir root = (pbInstallDest root) <> "lib" +pbDataDir root = (pbInstallDest root) <> "share" +pbDocDir root = (pbInstallDest root) <> "doc" + +-------------------------------------------------------------------------------- +-- Pre-build messages + +-- | Print the new packages. +printNewPackages :: Env -> IO () +printNewPackages Env{..} = do + unless + (M.null new) + (do putStrLn + ("There are " ++ + show (M.size new) ++ + " packages to build and install: ") + forM_ + (map fst (take maxDisplay (M.toList new))) + (putStrLn . display) + when (M.size new > maxDisplay) + (putStrLn ("And " ++ show (M.size new - maxDisplay) ++ " more."))) + where maxDisplay = 10 + new = M.filterWithKey + (\name _ -> + isNothing (find ((== name) . pkgName) envRegistered)) + versions + versions = (M.map ppVersion . + M.filter (not . S.null . sdModules . ppDesc) . + bpPackages . pbPlan) envPB + +-------------------------------------------------------------------------------- +-- Clean/purging of old packages + +-- | Reason for purging a package. +data PurgeReason + = NoLongerIncluded + | Replaced Version + | Broken + +-- | Clean up old versions of packages that are no longer in use. +cleanOldPackages :: Env -> IO () +cleanOldPackages env@Env{..} = do + putStrLn "Collecting garbage" + pkgs <- getRegisteredPackages (buildDatabase envShake) + let toRemove = mapMaybe + (\(PackageIdentifier name version) -> + case M.lookup name versions of + Just version' + | version' == version -> + Nothing + Just newVersion -> Just + (name, version, (Replaced newVersion)) + Nothing -> Just (name, version, NoLongerIncluded)) + pkgs + unless (null toRemove) + (putStrLn ("There are " ++ show (length toRemove) ++ " packages to be purged.")) + when (length toRemove > 0) + (do putStrLn "Waiting 3 seconds before proceeding to remove ..." + threadDelay (1000 * 1000 * 3)) + forM_ pkgs $ + \(PackageIdentifier name version) -> + case M.lookup name versions of + Just version' + | version' == version -> + return () + Just newVersion -> purgePackage + env + name + version + (Replaced newVersion) + Nothing -> purgePackage env name version NoLongerIncluded + broken <- getBrokenPackages (buildDatabase envShake) + unless (null broken) + (putStrLn ("There are " ++ show (length broken) ++ " broken packages to be purged.")) + when (length broken > 0) + (do putStrLn "Waiting 3 seconds before proceeding to remove ..." + threadDelay (1000 * 1000 * 3)) + forM_ + broken + (\(PackageIdentifier name version) -> + purgePackage env name version Broken) + where versions = (M.map ppVersion . bpPackages . pbPlan) envPB + +-- | Purge the given package and version. +purgePackage :: Env -> PackageName -> Version -> PurgeReason -> IO () +purgePackage env name version reason = do + putStr $ "Purging package: " ++ ident ++ " (" ++ showReason ++ ") ... " + unregisterPackage (buildDatabase (envShake env)) name + remove + putStrLn "done." + where showReason = + case reason of + Replaced version' -> "replaced by " ++ ordinal ++ " " ++ display version' + where ordinal | version' > version = "newer" + | otherwise = "older" + NoLongerIncluded -> "no longer included" + Broken -> "broken" + ident = nameVer name version + remove = FP.removeTree $ + pkgDir env name version + +-------------------------------------------------------------------------------- +-- Target actions + +-- | Initialize the database if there one needs to be, and in any case +-- create the target file. +databaseTarget :: Env -> Action () +databaseTarget env = do + if pbGlobalInstall (envPB env) + then return () + else do + liftIO (FP.removeTree dir) + liftIO (FP.createTree dir) + () <- cmd "ghc-pkg" "init" (FP.encodeString dir) + liftIO $ copyBuiltInHaddocks $ pbDocDir (envPB env) + makeTargetFile (targetForDb env) + where dir = buildDatabase (envShake env) + -- | Generate haddock docs for the package. packageDocs :: Env -> PackagePlan -> PackageName -> Action () packageDocs env@Env{..} plan name = do @@ -124,27 +309,6 @@ packageDocs env@Env{..} plan name = do where version = ppVersion plan haddocksFlag = pcHaddocks $ ppConstraints plan --- | Default environment for running commands. -defaultEnv :: PerformBuild -> FilePath -> FilePath -> [(String, String)] -defaultEnv pb shakeDir pwd = - [( "HASKELL_PACKAGE_SANDBOX" - , FP.encodeString (pwd <> buildDatabase shakeDir)) - | pbGlobalInstall pb] - --- | Initialize the database if there one needs to be, and in any case --- create the target file. -databaseTarget :: Env -> Action () -databaseTarget env = do - if pbGlobalInstall (envPB env) - then return () - else do - liftIO (FP.removeTree dir) - liftIO (FP.createTree dir) - () <- cmd "ghc-pkg" "init" (FP.encodeString dir) - liftIO $ copyBuiltInHaddocks $ pbDocDir (envPB env) - makeTargetFile (targetForDb env) - where dir = buildDatabase (envShake env) - -- | Build, test and generate documentation for the package. packageTarget :: Env -> PackageName -> PackagePlan -> Action () packageTarget env@Env{..} name plan = do @@ -174,6 +338,9 @@ fetchedTarget env@Env{..} = do M.toList $ bpPackages $ pbPlan envPB makeTargetFile (targetForFetched env) +-------------------------------------------------------------------------------- +-- Package actions + -- | Unpack the package. unpack :: Env -> PackageName -> Version -> Action () unpack env@Env{..} name version = do @@ -202,14 +369,16 @@ configure Env{..} pdir env plan = , "--bindir=" ++ FP.encodeString (pbBinDir envPB) , "--datadir=" ++ FP.encodeString (pbDataDir envPB) , "--docdir=" ++ FP.encodeString (pbDocDir envPB) - , "--flags=" ++ planFlags plan] ++ + , "--flags=" ++ planFlags] ++ ["--package-db=" ++ FP.encodeString (buildDatabase envShake) | not (pbGlobalInstall envPB)] + planFlags = unwords $ + map go $ M.toList (pcFlagOverrides (ppConstraints plan)) + where go (name',isOn) = concat + [ if isOn then "" else "-" , T.unpack (unFlagName name')] + -- | Register the package. --- --- TODO: Do a mutex lock in here. Does Shake already support doing --- this out of the box? register :: FilePath -> CmdOption -> MVar () -> Action () register pdir env registerLock = do () <- cmd cwd env "cabal" "copy" @@ -221,7 +390,7 @@ register pdir env registerLock = do -- | Generate haddocks for the package. generateHaddocks :: Env -> FilePath -> CmdOption -> PackageName -> Version -> TestState -> Action () generateHaddocks env@Env{..} pdir envmap name version expected = do - hfs <- liftIO $ readTVarIO envHadLock + hfs <- liftIO $ readTVarIO envHaddocks exitCode <- cmd (Cwd (FP.encodeString pdir)) @@ -253,210 +422,12 @@ generateHaddocks env@Env{..} pdir envmap name version expected = do do let orig = pkgDocDir env name version exists <- FP.isDirectory orig when exists $ - renameOrCopy - orig - (pbDocDir envPB <> FP.decodeString ident) - enewPath <- - liftIO $ - try $ + renameOrCopy orig (pbDocDir envPB <> FP.decodeString ident) + enewPath <- liftIO $ try $ FP.canonicalizePath (pbDocDir envPB <> FP.decodeString ident <> FP.decodeString (display name ++ ".haddock")) case enewPath of Left (_ :: IOException) -> return () -- FIXME: log it with Shake. - Right newPath -> liftIO $ atomically $ modifyTVar envHadLock $ + Right newPath -> liftIO $ atomically $ modifyTVar envHaddocks $ M.insert (ident) newPath - --- | Generate a flags string for the package plan. -planFlags :: PackagePlan -> String -planFlags plan = unwords $ - map go $ M.toList (pcFlagOverrides (ppConstraints plan)) - where go (name',isOn) = concat - [ if isOn then "" else "-" , T.unpack (unFlagName name')] - --- | Database location. -buildDatabase :: FilePath -> FilePath -buildDatabase shakeDir = shakeDir <> "pkgdb" - --- | Print the name and version. -nameVer :: PackageName -> Version -> String -nameVer name version = display name ++ "-" ++ display version - --- | The directory for the package's docs. -pkgDocDir :: Env -> PackageName -> Version -> FilePath -pkgDocDir env@Env{..} name version = pkgDir env name version <> - "dist" <> - "doc" <> - "html" <> - (FP.decodeString (display name)) - --- | The package directory. -pkgDir :: Env -> PackageName -> Version -> FilePath -pkgDir Env{..} name version = envShake <> "packages" <> - (FP.decodeString (nameVer name version)) - --- | Get the target file for confirming that all packages have been --- pre-fetched. -targetForFetched :: Env -> Target -targetForFetched Env{..} = - Target (envShake <> "packages-fetched") - --- | Get the target file for a package. -targetForPackage :: FilePath -> PackageName -> Version -> Target -targetForPackage shakeDir name version = Target $ - shakeDir <> "packages" <> - FP.decodeString - (nameVer name version) <> - "dist" <> - "shake-build" - --- | Get the target file for a package. -targetForDocs :: FilePath -> PackageName -> Version -> Target -targetForDocs shakeDir name version = Target $ - shakeDir <> "packages" <> - FP.decodeString - (nameVer name version) <> - "dist" <> - "shake-docs" - --- | Target for the complete, copied build under builds/date/. -targetForBuild :: PerformBuild -> Target -targetForBuild pb = Target $ (pbInstallDest pb) <> "shake-built" - --- | Get a package database path. -targetForDb :: Env -> Target -targetForDb Env{..} = - Target $ envShake <> "pkgdb-initialized" - --- | Make a file of this name. -makeTargetFile :: Target -> Action () -makeTargetFile fp = liftIO $ FP.writeFile (unTarget fp) "" - -pbBinDir, pbLibDir, pbDataDir, pbDocDir :: PerformBuild -> FilePath -pbBinDir root = (pbInstallDest root) <> "bin" -pbLibDir root = (pbInstallDest root) <> "lib" -pbDataDir root = (pbInstallDest root) <> "share" -pbDocDir root = (pbInstallDest root) <> "doc" - --- | Reason for purging a package. -data PurgeReason - = NoLongerIncluded - | Replaced Version - | Broken - --- | Print the new packages. -printNewPackages :: Env -> IO () -printNewPackages Env{..} = do - unless - (M.null new) - (do putStrLn - ("There are " ++ - show (M.size new) ++ - " packages to build and install: ") - forM_ - (map fst (take maxDisplay (M.toList new))) - (putStrLn . display) - when (M.size new > maxDisplay) - (putStrLn ("And " ++ show (M.size new - maxDisplay) ++ " more."))) - where maxDisplay = 10 - new = M.filterWithKey - (\name _ -> - isNothing (find ((== name) . pkgName) envRegistered)) - versions - versions = (M.map ppVersion . - M.filter (not . S.null . sdModules . ppDesc) . - bpPackages . pbPlan) envPB - --- | Clean up old versions of packages that are no longer in use. -cleanOldPackages :: Env -> IO () -cleanOldPackages env@Env{..} = do - putStrLn "Collecting garbage" - pkgs <- getRegisteredPackages envShake - let toRemove = mapMaybe - (\(PackageIdentifier name version) -> - case M.lookup name versions of - Just version' - | version' == version -> - Nothing - Just newVersion -> Just - (name, version, (Replaced newVersion)) - Nothing -> Just (name, version, NoLongerIncluded)) - pkgs - unless (null toRemove) - (putStrLn ("There are " ++ show (length toRemove) ++ " packages to be purged.")) - when (length toRemove > 0) - (do putStrLn "Waiting 3 seconds before proceeding to remove ..." - threadDelay (1000 * 1000 * 3)) - forM_ pkgs $ - \(PackageIdentifier name version) -> - case M.lookup name versions of - Just version' - | version' == version -> - return () - Just newVersion -> purgePackage - env - name - version - (Replaced newVersion) - Nothing -> purgePackage env name version NoLongerIncluded - broken <- getBrokenPackages envShake - unless (null broken) - (putStrLn ("There are " ++ show (length broken) ++ " broken packages to be purged.")) - when (length broken > 0) - (do putStrLn "Waiting 3 seconds before proceeding to remove ..." - threadDelay (1000 * 1000 * 3)) - forM_ - broken - (\(PackageIdentifier name version) -> - purgePackage env name version Broken) - where versions = (M.map ppVersion . bpPackages . pbPlan) envPB - --- | Purge the given package and version. -purgePackage :: Env -> PackageName -> Version -> PurgeReason -> IO () -purgePackage env name version reason = do - putStr $ "Purging package: " ++ ident ++ " (" ++ showReason ++ ") ... " - unregister - remove - putStrLn "done." - where showReason = - case reason of - Replaced version' -> "replaced by " ++ ordinal ++ " " ++ display version' - where ordinal | version' > version = "newer" - | otherwise = "older" - NoLongerIncluded -> "no longer included" - Broken -> "broken" - ident = nameVer name version - unregister = do - void (readProcessWithExitCode - "ghc-pkg" - ["unregister", "-f", FP.encodeString (buildDatabase (envShake env)), "--force", ident] - "") - remove = FP.removeTree $ - pkgDir env name version - --- | Get broken packages. -getBrokenPackages :: FilePath -> IO [PackageIdentifier] -getBrokenPackages shakeDir = do - (_,ps) <- sourceProcessWithConsumer - (proc - "ghc-pkg" - ["check", "--simple-output", "-f", FP.encodeString (buildDatabase shakeDir)]) - (CT.decodeUtf8 $= CT.lines $= CL.consume) - return (mapMaybe parsePackageIdent (T.words (T.unlines ps))) - --- | Get available packages. -getRegisteredPackages :: FilePath -> IO [PackageIdentifier] -getRegisteredPackages shakeDir = do - (_,ps) <- sourceProcessWithConsumer - (proc - "ghc-pkg" - ["list", "--simple-output", "-f", FP.encodeString (buildDatabase shakeDir)]) - (CT.decodeUtf8 $= CT.lines $= CL.consume) - return (mapMaybe parsePackageIdent (T.words (T.unlines ps))) - --- | Parse a package identifier: foo-1.2.3 -parsePackageIdent :: Text -> Maybe PackageIdentifier -parsePackageIdent = fmap fst . - listToMaybe . - filter (null . snd) . - readP_to_S parse . T.unpack diff --git a/stackage.cabal b/stackage.cabal index 00fba4d3..dc35af4c 100644 --- a/stackage.cabal +++ b/stackage.cabal @@ -31,6 +31,7 @@ library Stackage.PerformBuild Stackage.ShakeBuild Stackage.CompleteBuild + Stackage.GhcPkg other-modules: Development.Shake.FilePath build-depends: From 579f0dfd7ef46736de64262868a1cf2da4d1da3c Mon Sep 17 00:00:00 2001 From: Chris Done Date: Tue, 17 Feb 2015 17:26:44 +0100 Subject: [PATCH 29/47] Move db target directories --- Stackage/CompleteBuild.hs | 2 +- Stackage/ShakeBuild.hs | 37 +++++++++++++++++++------------------ 2 files changed, 20 insertions(+), 19 deletions(-) diff --git a/Stackage/CompleteBuild.hs b/Stackage/CompleteBuild.hs index 0ac4c84d..cd7fb51b 100644 --- a/Stackage/CompleteBuild.hs +++ b/Stackage/CompleteBuild.hs @@ -70,7 +70,7 @@ nightlySettings :: Text -- ^ day -> Settings nightlySettings day plan' = Settings { planFile = nightlyPlanFile day - , buildDir = fpFromText $ "builds/stackage-nightly-" ++ day + , buildDir = fpFromText $ "nightly" , logDir = fpFromText $ "logs/stackage-nightly-" ++ day , title = \ghcVer -> concat [ "Stackage Nightly " diff --git a/Stackage/ShakeBuild.hs b/Stackage/ShakeBuild.hs index 7e1f5c3b..5dc8fa65 100644 --- a/Stackage/ShakeBuild.hs +++ b/Stackage/ShakeBuild.hs @@ -60,13 +60,14 @@ performBuild pb' = do cur <- FP.getWorkingDirectory let shakeDir = cur <> "shake/" FP.createTree shakeDir + FP.createTree (buildDatabase pb') haddockFiles <- liftIO (newTVarIO mempty) registerLock <- liftIO (newMVar ()) - pkgs <- getRegisteredPackages (buildDatabase shakeDir) let !pb = pb' - { pbInstallDest = cur <> pbInstallDest pb' - } - !env = Env + { pbInstallDest = cur <> pbInstallDest pb' + } + pkgs <- getRegisteredPackages (buildDatabase pb) + let !env = Env { envCur = cur , envShake = shakeDir , envHaddocks = haddockFiles @@ -136,7 +137,7 @@ targetForBuild pb = Target $ (pbInstallDest pb) <> "shake-built" -- | Get a package database path. targetForDb :: Env -> Target -targetForDb Env{..} = Target $ envShake <> "pkgdb-initialized" +targetForDb Env{..} = Target $ (pbInstallDest envPB) <> "pkgdb-initialized" -------------------------------------------------------------------------------- -- Locations, names and environments used. Just to avoid "magic @@ -147,15 +148,15 @@ nameVer :: PackageName -> Version -> String nameVer name version = display name ++ "-" ++ display version -- | Default environment for running commands. -defaultEnv :: PerformBuild -> FilePath -> FilePath -> [(String, String)] -defaultEnv pb shakeDir pwd = +defaultEnv :: PerformBuild -> FilePath -> [(String, String)] +defaultEnv pb pwd = [( "HASKELL_PACKAGE_SANDBOX" - , FP.encodeString (pwd <> buildDatabase shakeDir)) + , FP.encodeString (pwd <> buildDatabase pb)) | pbGlobalInstall pb] -- | Database location. -buildDatabase :: FilePath -> FilePath -buildDatabase shakeDir = shakeDir <> "pkgdb" +buildDatabase :: PerformBuild -> FilePath +buildDatabase pb = (pbInstallDest pb) <> "pkgdb" -- | The directory for the package's docs. pkgDocDir :: Env -> PackageName -> Version -> FilePath @@ -216,7 +217,7 @@ data PurgeReason cleanOldPackages :: Env -> IO () cleanOldPackages env@Env{..} = do putStrLn "Collecting garbage" - pkgs <- getRegisteredPackages (buildDatabase envShake) + pkgs <- getRegisteredPackages (buildDatabase envPB) let toRemove = mapMaybe (\(PackageIdentifier name version) -> case M.lookup name versions of @@ -244,7 +245,7 @@ cleanOldPackages env@Env{..} = do version (Replaced newVersion) Nothing -> purgePackage env name version NoLongerIncluded - broken <- getBrokenPackages (buildDatabase envShake) + broken <- getBrokenPackages (buildDatabase envPB) unless (null broken) (putStrLn ("There are " ++ show (length broken) ++ " broken packages to be purged.")) when (length broken > 0) @@ -260,7 +261,7 @@ cleanOldPackages env@Env{..} = do purgePackage :: Env -> PackageName -> Version -> PurgeReason -> IO () purgePackage env name version reason = do putStr $ "Purging package: " ++ ident ++ " (" ++ showReason ++ ") ... " - unregisterPackage (buildDatabase (envShake env)) name + unregisterPackage (buildDatabase (envPB env)) name remove putStrLn "done." where showReason = @@ -284,18 +285,18 @@ databaseTarget env = do if pbGlobalInstall (envPB env) then return () else do - liftIO (FP.removeTree dir) liftIO (FP.createTree dir) + liftIO (FP.removeTree dir) () <- cmd "ghc-pkg" "init" (FP.encodeString dir) liftIO $ copyBuiltInHaddocks $ pbDocDir (envPB env) makeTargetFile (targetForDb env) - where dir = buildDatabase (envShake env) + where dir = buildDatabase (envPB env) -- | Generate haddock docs for the package. packageDocs :: Env -> PackagePlan -> PackageName -> Action () packageDocs env@Env{..} plan name = do pwd <- liftIO FP.getWorkingDirectory - envmap <- liftIO (fmap (Shake.Env . (++ defaultEnv envPB envShake pwd)) getEnvironment) + envmap <- liftIO (fmap (Shake.Env . (++ defaultEnv envPB pwd)) getEnvironment) when (haddocksFlag /= Don'tBuild && not (S.null $ sdModules $ ppDesc plan)) $ generateHaddocks @@ -318,7 +319,7 @@ packageTarget env@Env{..} name plan = do filter (/= name) $ M.keys $ M.filter libAndExe $ sdPackages $ ppDesc plan pwd <- liftIO FP.getWorkingDirectory - envmap <- liftIO (fmap (Shake.Env . (++ defaultEnv envPB envShake pwd)) getEnvironment) + envmap <- liftIO (fmap (Shake.Env . (++ defaultEnv envPB pwd)) getEnvironment) unpack env name version configure env dir envmap plan () <- cmd cwd envmap "cabal" "build" "--ghc-options=-O0" @@ -370,7 +371,7 @@ configure Env{..} pdir env plan = , "--datadir=" ++ FP.encodeString (pbDataDir envPB) , "--docdir=" ++ FP.encodeString (pbDocDir envPB) , "--flags=" ++ planFlags] ++ - ["--package-db=" ++ FP.encodeString (buildDatabase envShake) + ["--package-db=" ++ FP.encodeString (buildDatabase envPB) | not (pbGlobalInstall envPB)] planFlags = unwords $ map go $ M.toList (pcFlagOverrides (ppConstraints plan)) From 0b85b87dc231ee3fb0533a54d6df351ed70c529b Mon Sep 17 00:00:00 2001 From: Chris Done Date: Tue, 17 Feb 2015 17:26:57 +0100 Subject: [PATCH 30/47] Use getNumCapabilities --- Stackage/ShakeBuild.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/Stackage/ShakeBuild.hs b/Stackage/ShakeBuild.hs index 5dc8fa65..156248c4 100644 --- a/Stackage/ShakeBuild.hs +++ b/Stackage/ShakeBuild.hs @@ -57,6 +57,7 @@ data Env = Env -- | Run the shake builder. performBuild :: PerformBuild -> IO () performBuild pb' = do + num <- getNumCapabilities cur <- FP.getWorkingDirectory let shakeDir = cur <> "shake/" FP.createTree shakeDir @@ -77,7 +78,7 @@ performBuild pb' = do } cleanOldPackages env printNewPackages env - startShake 2 shakeDir (shakePlan env) + startShake num shakeDir (shakePlan env) -------------------------------------------------------------------------------- -- The whole Shake plan From 796ddbca89facb2337ebf071e411fd5da0e235f9 Mon Sep 17 00:00:00 2001 From: Chris Done Date: Tue, 17 Feb 2015 18:05:10 +0100 Subject: [PATCH 31/47] Add --ghc-options arg --- Stackage/CompleteBuild.hs | 3 +++ Stackage/InstallBuild.hs | 1 + Stackage/PerformBuild.hs | 1 + Stackage/ShakeBuild.hs | 2 +- app/stackage.hs | 8 +++++++- 5 files changed, 13 insertions(+), 2 deletions(-) diff --git a/Stackage/CompleteBuild.hs b/Stackage/CompleteBuild.hs index cd7fb51b..897020c6 100644 --- a/Stackage/CompleteBuild.hs +++ b/Stackage/CompleteBuild.hs @@ -1,6 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} module Stackage.CompleteBuild ( BuildType (..) , BumpType (..) @@ -41,6 +42,7 @@ data BuildFlags = BuildFlags , bfEnableLibProfile :: !Bool , bfVerbose :: !Bool , bfSkipCheck :: !Bool + , bfGhcOptions :: !String } deriving (Show) data BuildType = Nightly | LTS BumpType @@ -210,6 +212,7 @@ getPerformBuild buildFlags Settings {..} = PerformBuild , pbEnableLibProfiling = bfEnableLibProfile buildFlags , pbVerbose = bfVerbose buildFlags , pbAllowNewer = bfSkipCheck buildFlags + , pbGhcOptions = bfGhcOptions buildFlags } -- | Make a complete plan, build, test and upload bundle, docs and diff --git a/Stackage/InstallBuild.hs b/Stackage/InstallBuild.hs index abe8a14e..6f4a8aec 100644 --- a/Stackage/InstallBuild.hs +++ b/Stackage/InstallBuild.hs @@ -51,6 +51,7 @@ getPerformBuild plan InstallFlags{..} = , pbEnableLibProfiling = ifEnableLibProfiling , pbVerbose = ifVerbose , pbAllowNewer = ifSkipCheck + , pbGhcOptions = [] } -- | Install stackage from an existing build plan. diff --git a/Stackage/PerformBuild.hs b/Stackage/PerformBuild.hs index 52e37cd5..a7eb441c 100644 --- a/Stackage/PerformBuild.hs +++ b/Stackage/PerformBuild.hs @@ -69,6 +69,7 @@ data PerformBuild = PerformBuild , pbVerbose :: Bool , pbAllowNewer :: Bool -- ^ Pass --allow-newer to cabal configure + , pbGhcOptions :: String } data PackageInfo = PackageInfo diff --git a/Stackage/ShakeBuild.hs b/Stackage/ShakeBuild.hs index 156248c4..a02a415d 100644 --- a/Stackage/ShakeBuild.hs +++ b/Stackage/ShakeBuild.hs @@ -323,7 +323,7 @@ packageTarget env@Env{..} name plan = do envmap <- liftIO (fmap (Shake.Env . (++ defaultEnv envPB pwd)) getEnvironment) unpack env name version configure env dir envmap plan - () <- cmd cwd envmap "cabal" "build" "--ghc-options=-O0" + () <- cmd cwd envmap "cabal" "build" ("--ghc-options=" <> pbGhcOptions envPB) register dir envmap envRegLock makeTargetFile (targetForPackage envShake name version) where dir = pkgDir env name version diff --git a/app/stackage.hs b/app/stackage.hs index 8fdd2833..ab33c463 100644 --- a/app/stackage.hs +++ b/app/stackage.hs @@ -90,7 +90,13 @@ main = help "Output verbose detail about the build steps") <*> switch (long "skip-check" <> - help "Skip the check phase, and pass --allow-newer to cabal configure") + help "Skip the check phase, and pass --allow-newer to cabal configure") <*> + option + auto + (long "ghc-options" <> + metavar "OPTIONS" <> + showDefault <> + help "GHC options") nightlyUploadFlags = fromString <$> strArgument (metavar "DATE" <> From 048106c593ffa7bc043668a1d01c8a3df4859b39 Mon Sep 17 00:00:00 2001 From: Chris Done Date: Tue, 17 Feb 2015 18:07:16 +0100 Subject: [PATCH 32/47] Run tests --- Stackage/ShakeBuild.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/Stackage/ShakeBuild.hs b/Stackage/ShakeBuild.hs index a02a415d..5ed9af96 100644 --- a/Stackage/ShakeBuild.hs +++ b/Stackage/ShakeBuild.hs @@ -324,6 +324,8 @@ packageTarget env@Env{..} name plan = do unpack env name version configure env dir envmap plan () <- cmd cwd envmap "cabal" "build" ("--ghc-options=" <> pbGhcOptions envPB) + when (pbEnableTests envPB) + (cmd cwd envmap "cabal" "test") register dir envmap envRegLock makeTargetFile (targetForPackage envShake name version) where dir = pkgDir env name version From 69b30063ff55943f5d9e757719ad6b7bbd783d14 Mon Sep 17 00:00:00 2001 From: Chris Done Date: Tue, 17 Feb 2015 20:09:26 +0100 Subject: [PATCH 33/47] Fix --ghc-options arg --- app/stackage.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/app/stackage.hs b/app/stackage.hs index ab33c463..15ea5902 100644 --- a/app/stackage.hs +++ b/app/stackage.hs @@ -3,11 +3,12 @@ module Main where import Control.Monad +import Data.Maybe import Data.Monoid import Data.String (fromString) import Data.Version -import Options.Applicative import Filesystem.Path.CurrentOS (decodeString) +import Options.Applicative import Paths_stackage (version) import Stackage.CompleteBuild import Stackage.InstallBuild @@ -91,12 +92,11 @@ main = switch (long "skip-check" <> help "Skip the check phase, and pass --allow-newer to cabal configure") <*> - option - auto - (long "ghc-options" <> - metavar "OPTIONS" <> - showDefault <> - help "GHC options") + fmap (fromMaybe "") + (optional (strOption + (long "ghc-options" <> + showDefault <> + help "GHC options"))) nightlyUploadFlags = fromString <$> strArgument (metavar "DATE" <> From 6613ea7e163855eba3d30cff280aa2e3d2319169 Mon Sep 17 00:00:00 2001 From: Chris Done Date: Tue, 17 Feb 2015 20:09:32 +0100 Subject: [PATCH 34/47] Check build tools --- Stackage/ShakeBuild.hs | 28 +++++++++++++++++++++++++++- 1 file changed, 27 insertions(+), 1 deletion(-) diff --git a/Stackage/ShakeBuild.hs b/Stackage/ShakeBuild.hs index 5ed9af96..2b945591 100644 --- a/Stackage/ShakeBuild.hs +++ b/Stackage/ShakeBuild.hs @@ -15,7 +15,7 @@ import Stackage.CheckBuildPlan import Stackage.GhcPkg import Stackage.PackageDescription import Stackage.PerformBuild (PerformBuild(..),copyBuiltInHaddocks,renameOrCopy) -import Stackage.Prelude (unFlagName) +import Stackage.Prelude (unFlagName,unExeName) import Control.Concurrent import Control.Concurrent.STM @@ -76,6 +76,7 @@ performBuild pb' = do , envPB = pb , envRegistered = pkgs } + checkBuildTools env cleanOldPackages env printNewPackages env startShake num shakeDir (shakePlan env) @@ -205,6 +206,31 @@ printNewPackages Env{..} = do M.filter (not . S.null . sdModules . ppDesc) . bpPackages . pbPlan) envPB +-------------------------------------------------------------------------------- +-- Checking for build tools + +-- | Check that all build tools are available. +-- https://github.com/jgm/zip-archive/issues/23 +checkBuildTools :: Env -> IO () +checkBuildTools Env{..} = + forM_ normalPackages + (\(pname,plan) -> mapM_ (checkTool pname) (M.keys (sdTools (ppDesc plan)))) + where normalPackages = filter (not . (`elem` corePackages) . fst) $ + M.toList $ bpPackages $ pbPlan envPB + where corePackages = M.keys $ siCorePackages $ bpSystemInfo $ pbPlan envPB + checkTool pname name = + case M.lookup name (makeToolMap (bpPackages (pbPlan envPB))) of + Nothing + | not (isCoreExe name) -> + putStrLn ("Warning: No executable " <> + T.unpack (unExeName name) <> + " for " <> display pname) + + Just pkgs + -> return () + _ -> return () + isCoreExe = (`S.member` siCoreExecutables (bpSystemInfo (pbPlan envPB))) + -------------------------------------------------------------------------------- -- Clean/purging of old packages From 0ec0af23f5cb807632c4b0aeb259bbc4fe4027d8 Mon Sep 17 00:00:00 2001 From: Chris Done Date: Wed, 18 Feb 2015 13:52:22 +0100 Subject: [PATCH 35/47] Start using provided log function --- Stackage/ShakeBuild.hs | 79 ++++++++++++++++++++++++++++++++---------- 1 file changed, 61 insertions(+), 18 deletions(-) diff --git a/Stackage/ShakeBuild.hs b/Stackage/ShakeBuild.hs index 2b945591..08eefa29 100644 --- a/Stackage/ShakeBuild.hs +++ b/Stackage/ShakeBuild.hs @@ -1,4 +1,6 @@ {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -22,13 +24,16 @@ import Control.Concurrent.STM import Control.Exception import Control.Monad import Control.Monad.IO.Class +import Data.ByteString (ByteString) import Data.List import Data.Map.Strict (Map) import qualified Data.Map.Strict as M import Data.Maybe import Data.Monoid import qualified Data.Set as S +import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.Encoding as T import Data.Version import qualified Development.Shake.FilePath as Shake import Development.Shake.FilePath hiding (Env) @@ -37,7 +42,7 @@ import Distribution.Text (display) import qualified Filesystem as FP import Filesystem.Path.CurrentOS (FilePath) import qualified Filesystem.Path.CurrentOS as FP -import Prelude hiding (FilePath) +import Prelude hiding (log,FilePath) import System.Environment import System.Exit @@ -185,18 +190,26 @@ pbDocDir root = (pbInstallDest root) <> "doc" -- | Print the new packages. printNewPackages :: Env -> IO () -printNewPackages Env{..} = do +printNewPackages env@Env{..} = do unless (M.null new) - (do putStrLn + (do log + env + Normal ("There are " ++ show (M.size new) ++ " packages to build and install: ") forM_ (map fst (take maxDisplay (M.toList new))) - (putStrLn . display) - when (M.size new > maxDisplay) - (putStrLn ("And " ++ show (M.size new - maxDisplay) ++ " more."))) + (logLn env Verbose . display) + when + (M.size new > maxDisplay) + (log + env + Verbose + ("And " ++ + show (M.size new - maxDisplay) ++ + " more."))) where maxDisplay = 10 new = M.filterWithKey (\name _ -> @@ -212,7 +225,7 @@ printNewPackages Env{..} = do -- | Check that all build tools are available. -- https://github.com/jgm/zip-archive/issues/23 checkBuildTools :: Env -> IO () -checkBuildTools Env{..} = +checkBuildTools env@Env{..} = forM_ normalPackages (\(pname,plan) -> mapM_ (checkTool pname) (M.keys (sdTools (ppDesc plan)))) where normalPackages = filter (not . (`elem` corePackages) . fst) $ @@ -222,11 +235,11 @@ checkBuildTools Env{..} = case M.lookup name (makeToolMap (bpPackages (pbPlan envPB))) of Nothing | not (isCoreExe name) -> - putStrLn ("Warning: No executable " <> - T.unpack (unExeName name) <> - " for " <> display pname) + logLn env Normal ("Warning: No executable " <> + T.unpack (unExeName name) <> + " for " <> display pname) - Just pkgs + Just _ -> return () _ -> return () isCoreExe = (`S.member` siCoreExecutables (bpSystemInfo (pbPlan envPB))) @@ -243,7 +256,7 @@ data PurgeReason -- | Clean up old versions of packages that are no longer in use. cleanOldPackages :: Env -> IO () cleanOldPackages env@Env{..} = do - putStrLn "Collecting garbage" + logLn env Verbose "Collecting garbage" pkgs <- getRegisteredPackages (buildDatabase envPB) let toRemove = mapMaybe (\(PackageIdentifier name version) -> @@ -256,9 +269,9 @@ cleanOldPackages env@Env{..} = do Nothing -> Just (name, version, NoLongerIncluded)) pkgs unless (null toRemove) - (putStrLn ("There are " ++ show (length toRemove) ++ " packages to be purged.")) + (logLn env Verbose ("There are " ++ show (length toRemove) ++ " packages to be purged.")) when (length toRemove > 0) - (do putStrLn "Waiting 3 seconds before proceeding to remove ..." + (do logLn env Verbose "Waiting 3 seconds before proceeding to remove ..." threadDelay (1000 * 1000 * 3)) forM_ pkgs $ \(PackageIdentifier name version) -> @@ -274,9 +287,9 @@ cleanOldPackages env@Env{..} = do Nothing -> purgePackage env name version NoLongerIncluded broken <- getBrokenPackages (buildDatabase envPB) unless (null broken) - (putStrLn ("There are " ++ show (length broken) ++ " broken packages to be purged.")) + (logLn env Verbose ("There are " ++ show (length broken) ++ " broken packages to be purged.")) when (length broken > 0) - (do putStrLn "Waiting 3 seconds before proceeding to remove ..." + (do logLn env Verbose "Waiting 3 seconds before proceeding to remove ..." threadDelay (1000 * 1000 * 3)) forM_ broken @@ -287,10 +300,10 @@ cleanOldPackages env@Env{..} = do -- | Purge the given package and version. purgePackage :: Env -> PackageName -> Version -> PurgeReason -> IO () purgePackage env name version reason = do - putStr $ "Purging package: " ++ ident ++ " (" ++ showReason ++ ") ... " + log env Verbose $ "Purging package: " ++ ident ++ " (" ++ showReason ++ ") ... " unregisterPackage (buildDatabase (envPB env)) name remove - putStrLn "done." + logLn env Verbose "done." where showReason = case reason of Replaced version' -> "replaced by " ++ ordinal ++ " " ++ display version' @@ -461,3 +474,33 @@ generateHaddocks env@Env{..} pdir envmap name version expected = do Left (_ :: IOException) -> return () -- FIXME: log it with Shake. Right newPath -> liftIO $ atomically $ modifyTVar envHaddocks $ M.insert (ident) newPath + +-------------------------------------------------------------------------------- +-- Logging utilities + +data Verbosity + = Verbose + | Normal + +-- | Convenience. +class ToBS a where toBS :: a -> ByteString +instance ToBS String where toBS = toBS . T.pack +instance ToBS Text where toBS = T.encodeUtf8 +instance ToBS ByteString where toBS = id + +-- | Log to wherever is configured by the calling code. +logLn :: (MonadIO m,ToBS str) => Env -> Verbosity -> str -> m () +logLn env v s = log env v (toBS s <> "\n") + +-- | Log to wherever is configured by the calling code. +log :: (MonadIO m,ToBS str) => Env -> Verbosity -> str -> m () +log env v s = when + (pbVerbose (envPB env) == + bool) + (liftIO + (pbLog + (envPB env) + (toBS s))) + where bool = case v of + Verbose -> True + Normal -> False From b2b5758ff07cda9d6cad2d43f62ae641c7dc2c09 Mon Sep 17 00:00:00 2001 From: Chris Done Date: Wed, 18 Feb 2015 22:22:38 +0100 Subject: [PATCH 36/47] Progress reporting of sorts --- Development/Shake/FilePath.hs | 7 +- Stackage/ShakeBuild.hs | 217 +++++++++++++++++++++------------- stackage.cabal | 1 + 3 files changed, 144 insertions(+), 81 deletions(-) diff --git a/Development/Shake/FilePath.hs b/Development/Shake/FilePath.hs index c351bb1f..d385b4c6 100644 --- a/Development/Shake/FilePath.hs +++ b/Development/Shake/FilePath.hs @@ -12,12 +12,13 @@ module Development.Shake.FilePath ,Rules ,Action ,CmdOption(..) + ,Progress(..) ,Shake.cmd ,makeTargetFile) where import Control.Monad.IO.Class -import Development.Shake (Rules,Action,CmdOption(..)) +import Development.Shake (Rules,Action,CmdOption(..),Progress(..)) import qualified Development.Shake as Shake import qualified Filesystem as FP import Filesystem.Path.CurrentOS (FilePath) @@ -31,13 +32,15 @@ newtype Target = Target } -- | Start Shake with the given data directory. -startShake :: MonadIO m => Int -> FilePath -> Rules () -> m () +startShake :: MonadIO m + => Int -> FilePath -> Rules () -> m () startShake threads dir rules = liftIO (withArgs [] $ Shake.shakeArgs Shake.shakeOptions { Shake.shakeFiles = FP.encodeString dir , Shake.shakeThreads = threads + , Shake.shakeVerbosity = Shake.Quiet } $ rules) diff --git a/Stackage/ShakeBuild.hs b/Stackage/ShakeBuild.hs index 08eefa29..397ae192 100644 --- a/Stackage/ShakeBuild.hs +++ b/Stackage/ShakeBuild.hs @@ -9,7 +9,7 @@ -- | Build everything with Shake. -module Stackage.ShakeBuild where +module Stackage.ShakeBuild (performBuild) where import Stackage.BuildConstraints import Stackage.BuildPlan @@ -31,11 +31,11 @@ import qualified Data.Map.Strict as M import Data.Maybe import Data.Monoid import qualified Data.Set as S +import Data.Streaming.Process import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Version -import qualified Development.Shake.FilePath as Shake import Development.Shake.FilePath hiding (Env) import Distribution.Package import Distribution.Text (display) @@ -45,6 +45,7 @@ import qualified Filesystem.Path.CurrentOS as FP import Prelude hiding (log,FilePath) import System.Environment import System.Exit +import System.IO (withBinaryFile,IOMode(AppendMode)) -- | Reader environment used generally throughout the build process. data Env = Env @@ -54,6 +55,7 @@ data Env = Env ,envRegLock :: MVar () -- ^ Package registering lock. ,envPB :: PerformBuild -- ^ Build perform settings. ,envRegistered :: [PackageIdentifier] -- ^ Registered packages. + ,envMsgLock :: MVar () -- ^ A lock for printing to the log. } -------------------------------------------------------------------------------- @@ -67,12 +69,13 @@ performBuild pb' = do let shakeDir = cur <> "shake/" FP.createTree shakeDir FP.createTree (buildDatabase pb') - haddockFiles <- liftIO (newTVarIO mempty) - registerLock <- liftIO (newMVar ()) + haddockFiles <- newTVarIO mempty + registerLock <- newMVar () let !pb = pb' { pbInstallDest = cur <> pbInstallDest pb' } pkgs <- getRegisteredPackages (buildDatabase pb) + msgLock <- newMVar () let !env = Env { envCur = cur , envShake = shakeDir @@ -80,6 +83,7 @@ performBuild pb' = do , envRegLock = registerLock , envPB = pb , envRegistered = pkgs + , envMsgLock = msgLock } checkBuildTools env cleanOldPackages env @@ -138,10 +142,6 @@ targetForDocs shakeDir name version = Target $ (nameVer name version) <> "dist" <> "shake-docs" --- | Target for the complete, copied build under builds/date/. -targetForBuild :: PerformBuild -> Target -targetForBuild pb = Target $ (pbInstallDest pb) <> "shake-built" - -- | Get a package database path. targetForDb :: Env -> Target targetForDb Env{..} = Target $ (pbInstallDest envPB) <> "pkgdb-initialized" @@ -178,6 +178,11 @@ pkgDir :: Env -> PackageName -> Version -> FilePath pkgDir Env{..} name version = envShake <> "packages" <> (FP.decodeString (nameVer name version)) +-- | The package directory. +pkgLogFile :: Env -> PackageName -> Version -> FilePath +pkgLogFile env@Env{..} name version = pkgDir env name version <> + "log.txt" + -- | Installation paths. pbBinDir, pbLibDir, pbDataDir, pbDocDir :: PerformBuild -> FilePath pbBinDir root = (pbInstallDest root) <> "bin" @@ -193,31 +198,36 @@ printNewPackages :: Env -> IO () printNewPackages env@Env{..} = do unless (M.null new) - (do log + (do logLn env Normal ("There are " ++ show (M.size new) ++ - " packages to build and install: ") + " packages to build and install.") forM_ (map fst (take maxDisplay (M.toList new))) (logLn env Verbose . display) when (M.size new > maxDisplay) - (log - env - Verbose - ("And " ++ - show (M.size new - maxDisplay) ++ - " more."))) + (logLn + env + Verbose + ("And " ++ + show (M.size new - maxDisplay) ++ + " more."))) where maxDisplay = 10 - new = M.filterWithKey - (\name _ -> - isNothing (find ((== name) . pkgName) envRegistered)) - versions - versions = (M.map ppVersion . - M.filter (not . S.null . sdModules . ppDesc) . - bpPackages . pbPlan) envPB + new = newPackages env + +-- | Get new packages from the env. +newPackages :: Env -> Map PackageName Version +newPackages Env{..} = new + where new = M.filterWithKey + (\name _ -> + isNothing (find ((== name) . pkgName) envRegistered)) + versions + versions = (M.map ppVersion . + M.filter (not . S.null . sdModules . ppDesc) . + bpPackages . pbPlan) envPB -------------------------------------------------------------------------------- -- Checking for build tools @@ -269,7 +279,8 @@ cleanOldPackages env@Env{..} = do Nothing -> Just (name, version, NoLongerIncluded)) pkgs unless (null toRemove) - (logLn env Verbose ("There are " ++ show (length toRemove) ++ " packages to be purged.")) + (logLn env Verbose ("There are " ++ show (length toRemove) + ++ " packages to be purged.")) when (length toRemove > 0) (do logLn env Verbose "Waiting 3 seconds before proceeding to remove ..." threadDelay (1000 * 1000 * 3)) @@ -287,7 +298,8 @@ cleanOldPackages env@Env{..} = do Nothing -> purgePackage env name version NoLongerIncluded broken <- getBrokenPackages (buildDatabase envPB) unless (null broken) - (logLn env Verbose ("There are " ++ show (length broken) ++ " broken packages to be purged.")) + (logLn env Verbose ("There are " ++ show (length broken) + ++ " broken packages to be purged.")) when (length broken > 0) (do logLn env Verbose "Waiting 3 seconds before proceeding to remove ..." threadDelay (1000 * 1000 * 3)) @@ -300,10 +312,10 @@ cleanOldPackages env@Env{..} = do -- | Purge the given package and version. purgePackage :: Env -> PackageName -> Version -> PurgeReason -> IO () purgePackage env name version reason = do - log env Verbose $ "Purging package: " ++ ident ++ " (" ++ showReason ++ ") ... " + log env Normal $ "Purging package: " ++ ident ++ " (" ++ showReason ++ ") ... " unregisterPackage (buildDatabase (envPB env)) name remove - logLn env Verbose "done." + logLn env Normal "done." where showReason = case reason of Replaced version' -> "replaced by " ++ ordinal ++ " " ++ display version' @@ -335,14 +347,12 @@ databaseTarget env = do -- | Generate haddock docs for the package. packageDocs :: Env -> PackagePlan -> PackageName -> Action () packageDocs env@Env{..} plan name = do - pwd <- liftIO FP.getWorkingDirectory - envmap <- liftIO (fmap (Shake.Env . (++ defaultEnv envPB pwd)) getEnvironment) when (haddocksFlag /= Don'tBuild && not (S.null $ sdModules $ ppDesc plan)) $ generateHaddocks env + (pkgLogFile env name version) (pkgDir env name version) - envmap name version haddocksFlag @@ -358,19 +368,24 @@ packageTarget env@Env{..} name plan = do mapMaybe (\p -> find ((==p) . fst) versionMappings) $ filter (/= name) $ M.keys $ M.filter libAndExe $ sdPackages $ ppDesc plan - pwd <- liftIO FP.getWorkingDirectory - envmap <- liftIO (fmap (Shake.Env . (++ defaultEnv envPB pwd)) getEnvironment) unpack env name version - configure env dir envmap plan - () <- cmd cwd envmap "cabal" "build" ("--ghc-options=" <> pbGhcOptions envPB) + liftIO (do exists <- FP.isFile logFile + when exists (FP.removeFile logFile)) + configure env name logFile dir plan + prefix <- packageCmdPrefix name + let pkgCabal :: (MonadIO m) => [String] -> m () + pkgCabal = succeed . cabal env prefix logFile dir + pkgCabal ["build","--ghc-options=" <> pbGhcOptions envPB] when (pbEnableTests envPB) - (cmd cwd envmap "cabal" "test") - register dir envmap envRegLock + (succeed (cabal env prefix logFile dir ["test"])) + pkgCabal ["copy"] + liftIO (withMVar envRegLock + (const (pkgCabal ["register"]))) makeTargetFile (targetForPackage envShake name version) - where dir = pkgDir env name version + where logFile = (pkgLogFile env name version) + dir = pkgDir env name version version = ppVersion plan versionMappings = M.toList (M.map ppVersion (bpPackages (pbPlan envPB))) - cwd = Cwd (FP.encodeString dir) -- | Make sure all package archives have been fetched. fetchedTarget :: Env -> Action () @@ -399,11 +414,13 @@ unpack env@Env{..} name version = do "cabal" "unpack" (nameVer name version) + "-v0" -- | Configure the given package. -configure :: Env -> FilePath -> CmdOption -> PackagePlan -> Action () -configure Env{..} pdir env plan = - cmd (Cwd (FP.encodeString pdir)) env "cabal" "configure" opts +configure :: Env -> PackageName -> FilePath -> FilePath -> PackagePlan -> Action () +configure env@Env{..} name logfile pdir plan = + do prefix <- packageCmdPrefix name + succeed (cabal env prefix logfile pdir ("configure" : opts)) where opts = [ "--package-db=clear" @@ -420,39 +437,31 @@ configure Env{..} pdir env plan = where go (name',isOn) = concat [ if isOn then "" else "-" , T.unpack (unFlagName name')] - --- | Register the package. -register :: FilePath -> CmdOption -> MVar () -> Action () -register pdir env registerLock = do - () <- cmd cwd env "cabal" "copy" - liftIO (takeMVar registerLock) - () <- cmd cwd env "cabal" "register" - liftIO (putMVar registerLock ()) - where cwd = Cwd (FP.encodeString pdir) - -- | Generate haddocks for the package. -generateHaddocks :: Env -> FilePath -> CmdOption -> PackageName -> Version -> TestState -> Action () -generateHaddocks env@Env{..} pdir envmap name version expected = do +generateHaddocks :: Env -> FilePath -> FilePath -> PackageName -> Version -> TestState -> Action () +generateHaddocks env@Env{..} logfile pdir name version expected = do hfs <- liftIO $ readTVarIO envHaddocks + prefix <- packageCmdPrefix name exitCode <- - cmd - (Cwd (FP.encodeString pdir)) - envmap - "cabal" - "haddock" - "--hyperlink-source" - "--html" - "--hoogle" - "--html-location=../$pkg-$version/" - (map - (\(pkgVer,hf) -> - concat - [ "--haddock-options=--read-interface=" - , "../" - , pkgVer - , "/," - , FP.encodeString hf]) - (M.toList hfs)) + cabal + env + prefix + logfile + pdir + (["haddock" + ,"--hyperlink-source" + ,"--html" + ,"--hoogle" + ,"--html-location=../$pkg-$version/"] ++ + map + (\(pkgVer,hf) -> + concat + [ "--haddock-options=--read-interface=" + , "../" + , pkgVer + , "/," + , FP.encodeString hf]) + (M.toList hfs)) case (exitCode, expected) of (ExitSuccess,ExpectFailure) -> return () -- FIXME: warn. (ExitFailure{},ExpectSuccess) -> throw exitCode -- FIXME: report it @@ -475,6 +484,55 @@ generateHaddocks env@Env{..} pdir envmap name version expected = do Right newPath -> liftIO $ atomically $ modifyTVar envHaddocks $ M.insert (ident) newPath +-------------------------------------------------------------------------------- +-- Running commands + +-- | Get a command prefix including progress. +packageCmdPrefix :: MonadIO m => PackageName -> m Text +packageCmdPrefix name = + return (T.pack (display name) <> ": ") + +-- | Run a command with the right envornment, logs the command being +-- run and its output as verbose mode. +cabal :: MonadIO m => Env -> Text -> FilePath -> FilePath -> [String] -> m ExitCode +cabal env prefix logfile cwd args = do + pwd <- liftIO FP.getWorkingDirectory + envmap <- liftIO $ fmap (++ defaultEnv (envPB env) pwd) $ getEnvironment + logLn env Normal (prefix <> T.pack (fromMaybe "" (listToMaybe args)) <> " ...") + logLn env Verbose (prefix <> T.pack (unwords (cmd' : map show args))) + code <- liftIO $ flip catch exitFailing + $ withBinaryFile (FP.encodeString logfile) AppendMode $ \outH -> + do withCheckedProcess + (proc cmd' args) + { cwd = Just (FP.encodeString cwd) + , std_err = UseHandle outH + , std_out = UseHandle outH + , env = Just envmap + } + (\ClosedStream UseProvidedHandle UseProvidedHandle -> + (return ())) + return ExitSuccess + logLn env Normal + (prefix <> T.pack (fromMaybe "" (listToMaybe args)) <> ": " <> + case code of + ExitFailure{} -> "FAIL" + ExitSuccess{} -> "OK") + return code + where cmd' = "cabal" :: String + exitFailing :: ProcessExitedUnsuccessfully -> IO ExitCode + exitFailing (ProcessExitedUnsuccessfully _ code) = do + FP.readFile logfile >>= logLn env Normal + return code + +-- | The action must return a success code or an exception is thrown. +succeed :: MonadIO m + => m ExitCode -> m () +succeed m = do + v <- m + case v of + ExitFailure{} -> throw v + ExitSuccess -> return () + -------------------------------------------------------------------------------- -- Logging utilities @@ -494,13 +552,14 @@ logLn env v s = log env v (toBS s <> "\n") -- | Log to wherever is configured by the calling code. log :: (MonadIO m,ToBS str) => Env -> Verbosity -> str -> m () -log env v s = when - (pbVerbose (envPB env) == - bool) - (liftIO - (pbLog - (envPB env) - (toBS s))) - where bool = case v of +log env v s = + when ((bool && verbose) || not bool) + (liftIO + (withMVar (envMsgLock env) + (const (pbLog + (envPB env) + (toBS s))))) + where verbose = pbVerbose (envPB env) + bool = case v of Verbose -> True Normal -> False diff --git a/stackage.cabal b/stackage.cabal index dc35af4c..da853053 100644 --- a/stackage.cabal +++ b/stackage.cabal @@ -53,6 +53,7 @@ library , mtl , old-locale , process + , resourcet , semigroups , shake , stm From 72a7ecc252e2993bee42303628614aa93cb3221f Mon Sep 17 00:00:00 2001 From: Chris Done Date: Wed, 18 Feb 2015 22:38:45 +0100 Subject: [PATCH 37/47] Slightly less wordy progress report --- Stackage/ShakeBuild.hs | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/Stackage/ShakeBuild.hs b/Stackage/ShakeBuild.hs index 397ae192..9934e9d8 100644 --- a/Stackage/ShakeBuild.hs +++ b/Stackage/ShakeBuild.hs @@ -512,11 +512,12 @@ cabal env prefix logfile cwd args = do (\ClosedStream UseProvidedHandle UseProvidedHandle -> (return ())) return ExitSuccess - logLn env Normal - (prefix <> T.pack (fromMaybe "" (listToMaybe args)) <> ": " <> - case code of - ExitFailure{} -> "FAIL" - ExitSuccess{} -> "OK") + case code of + ExitFailure{} -> + logLn env Normal + (prefix <> T.pack (fromMaybe "" (listToMaybe args)) <> ": " <> + "FAIL") + ExitSuccess{} -> return () return code where cmd' = "cabal" :: String exitFailing :: ProcessExitedUnsuccessfully -> IO ExitCode From 2ee501db9c4fba360f5acf42364cbc7d5d9dace4 Mon Sep 17 00:00:00 2001 From: Chris Done Date: Wed, 18 Feb 2015 22:41:56 +0100 Subject: [PATCH 38/47] Don't add date to lts dir --- Stackage/CompleteBuild.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Stackage/CompleteBuild.hs b/Stackage/CompleteBuild.hs index 897020c6..720d56cf 100644 --- a/Stackage/CompleteBuild.hs +++ b/Stackage/CompleteBuild.hs @@ -125,7 +125,7 @@ getSettings man (LTS bumpType) = do return Settings { planFile = newfile - , buildDir = fpFromText $ "builds/stackage-lts-" ++ tshow new + , buildDir = fpFromText $ "builds/stackage-lts" , logDir = fpFromText $ "logs/stackage-lts-" ++ tshow new , title = \ghcVer -> concat [ "LTS Haskell " From c551ad0cdcf2dc12f73ae24acc8315a4518a3dd1 Mon Sep 17 00:00:00 2001 From: Chris Done Date: Wed, 18 Feb 2015 22:51:31 +0100 Subject: [PATCH 39/47] Reduce more verbosity --- Stackage/ShakeBuild.hs | 28 ++++++++++++++++------------ 1 file changed, 16 insertions(+), 12 deletions(-) diff --git a/Stackage/ShakeBuild.hs b/Stackage/ShakeBuild.hs index 9934e9d8..cab8ce98 100644 --- a/Stackage/ShakeBuild.hs +++ b/Stackage/ShakeBuild.hs @@ -373,14 +373,14 @@ packageTarget env@Env{..} name plan = do when exists (FP.removeFile logFile)) configure env name logFile dir plan prefix <- packageCmdPrefix name - let pkgCabal :: (MonadIO m) => [String] -> m () - pkgCabal = succeed . cabal env prefix logFile dir - pkgCabal ["build","--ghc-options=" <> pbGhcOptions envPB] + let pkgCabal :: (MonadIO m) => Verbosity -> [String] -> m () + pkgCabal verbosity = succeed . cabal env verbosity prefix logFile dir + pkgCabal Normal ["build","--ghc-options=" <> pbGhcOptions envPB] when (pbEnableTests envPB) - (succeed (cabal env prefix logFile dir ["test"])) - pkgCabal ["copy"] + (succeed (cabal env Normal prefix logFile dir ["test"])) + pkgCabal Verbose ["copy"] liftIO (withMVar envRegLock - (const (pkgCabal ["register"]))) + (const (pkgCabal Verbose ["register"]))) makeTargetFile (targetForPackage envShake name version) where logFile = (pkgLogFile env name version) dir = pkgDir env name version @@ -420,7 +420,7 @@ unpack env@Env{..} name version = do configure :: Env -> PackageName -> FilePath -> FilePath -> PackagePlan -> Action () configure env@Env{..} name logfile pdir plan = do prefix <- packageCmdPrefix name - succeed (cabal env prefix logfile pdir ("configure" : opts)) + succeed (cabal env Verbose prefix logfile pdir ("configure" : opts)) where opts = [ "--package-db=clear" @@ -445,6 +445,7 @@ generateHaddocks env@Env{..} logfile pdir name version expected = do exitCode <- cabal env + Normal prefix logfile pdir @@ -463,8 +464,11 @@ generateHaddocks env@Env{..} logfile pdir name version expected = do , FP.encodeString hf]) (M.toList hfs)) case (exitCode, expected) of - (ExitSuccess,ExpectFailure) -> return () -- FIXME: warn. - (ExitFailure{},ExpectSuccess) -> throw exitCode -- FIXME: report it + (ExitSuccess,ExpectFailure) -> + logLn env Normal (prefix <> "expected failure for haddock generation, but it succeeded!") + (ExitFailure{},ExpectSuccess) -> + do logLn env Normal (prefix <> "expected success for haddock, but it failed!") + throw exitCode -- FIXME: report it _ -> return () copy where @@ -494,11 +498,11 @@ packageCmdPrefix name = -- | Run a command with the right envornment, logs the command being -- run and its output as verbose mode. -cabal :: MonadIO m => Env -> Text -> FilePath -> FilePath -> [String] -> m ExitCode -cabal env prefix logfile cwd args = do +cabal :: MonadIO m => Env -> Verbosity -> Text -> FilePath -> FilePath -> [String] -> m ExitCode +cabal env verbosity prefix logfile cwd args = do pwd <- liftIO FP.getWorkingDirectory envmap <- liftIO $ fmap (++ defaultEnv (envPB env) pwd) $ getEnvironment - logLn env Normal (prefix <> T.pack (fromMaybe "" (listToMaybe args)) <> " ...") + logLn env verbosity (prefix <> T.pack (fromMaybe "" (listToMaybe args))) logLn env Verbose (prefix <> T.pack (unwords (cmd' : map show args))) code <- liftIO $ flip catch exitFailing $ withBinaryFile (FP.encodeString logfile) AppendMode $ \outH -> From 81e0dc2d9808004c495fb09f4262ddd5de5e175b Mon Sep 17 00:00:00 2001 From: Chris Done Date: Wed, 18 Feb 2015 23:04:19 +0100 Subject: [PATCH 40/47] Put log under dist/ --- Stackage/ShakeBuild.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Stackage/ShakeBuild.hs b/Stackage/ShakeBuild.hs index cab8ce98..d51ccfa0 100644 --- a/Stackage/ShakeBuild.hs +++ b/Stackage/ShakeBuild.hs @@ -181,7 +181,7 @@ pkgDir Env{..} name version = envShake <> "packages" <> -- | The package directory. pkgLogFile :: Env -> PackageName -> Version -> FilePath pkgLogFile env@Env{..} name version = pkgDir env name version <> - "log.txt" + "dist" <> "log.txt" -- | Installation paths. pbBinDir, pbLibDir, pbDataDir, pbDocDir :: PerformBuild -> FilePath From c27df5e8316db22194260a3fb9cd9f9e27b86f45 Mon Sep 17 00:00:00 2001 From: Chris Done Date: Wed, 18 Feb 2015 23:18:53 +0100 Subject: [PATCH 41/47] Status code returned on haddock/test failures --- Stackage/ShakeBuild.hs | 22 ++++++++++++++++++++-- 1 file changed, 20 insertions(+), 2 deletions(-) diff --git a/Stackage/ShakeBuild.hs b/Stackage/ShakeBuild.hs index d51ccfa0..13aae4cf 100644 --- a/Stackage/ShakeBuild.hs +++ b/Stackage/ShakeBuild.hs @@ -56,6 +56,7 @@ data Env = Env ,envPB :: PerformBuild -- ^ Build perform settings. ,envRegistered :: [PackageIdentifier] -- ^ Registered packages. ,envMsgLock :: MVar () -- ^ A lock for printing to the log. + ,envStatus :: TVar ExitCode } -------------------------------------------------------------------------------- @@ -76,6 +77,7 @@ performBuild pb' = do } pkgs <- getRegisteredPackages (buildDatabase pb) msgLock <- newMVar () + status <- newTVarIO ExitSuccess let !env = Env { envCur = cur , envShake = shakeDir @@ -84,11 +86,16 @@ performBuild pb' = do , envPB = pb , envRegistered = pkgs , envMsgLock = msgLock + , envStatus = status } checkBuildTools env cleanOldPackages env printNewPackages env startShake num shakeDir (shakePlan env) + st <- readTVarIO status + case st of + ExitSuccess -> return () + _ -> throw st -------------------------------------------------------------------------------- -- The whole Shake plan @@ -377,7 +384,12 @@ packageTarget env@Env{..} name plan = do pkgCabal verbosity = succeed . cabal env verbosity prefix logFile dir pkgCabal Normal ["build","--ghc-options=" <> pbGhcOptions envPB] when (pbEnableTests envPB) - (succeed (cabal env Normal prefix logFile dir ["test"])) + (do result <- cabal env Normal prefix logFile dir ["test"] + case result of + ExitFailure{} -> + do logLn env Normal (prefix <> "TEST SUITE FAILED") + failed env result + _ -> return ()) pkgCabal Verbose ["copy"] liftIO (withMVar envRegLock (const (pkgCabal Verbose ["register"]))) @@ -468,7 +480,7 @@ generateHaddocks env@Env{..} logfile pdir name version expected = do logLn env Normal (prefix <> "expected failure for haddock generation, but it succeeded!") (ExitFailure{},ExpectSuccess) -> do logLn env Normal (prefix <> "expected success for haddock, but it failed!") - throw exitCode -- FIXME: report it + failed env exitCode _ -> return () copy where @@ -529,6 +541,12 @@ cabal env verbosity prefix logfile cwd args = do FP.readFile logfile >>= logLn env Normal return code +-- | A result failed. +failed :: MonadIO m => Env -> ExitCode -> m () +failed env code = liftIO + (atomically + (writeTVar (envStatus env) code)) + -- | The action must return a success code or an exception is thrown. succeed :: MonadIO m => m ExitCode -> m () From 8e97d5d8e78b04197ecca33d87f51655b31e50a6 Mon Sep 17 00:00:00 2001 From: Chris Done Date: Wed, 18 Feb 2015 23:33:30 +0100 Subject: [PATCH 42/47] Fix log dir creation --- Stackage/ShakeBuild.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/Stackage/ShakeBuild.hs b/Stackage/ShakeBuild.hs index 13aae4cf..02d694cd 100644 --- a/Stackage/ShakeBuild.hs +++ b/Stackage/ShakeBuild.hs @@ -188,7 +188,7 @@ pkgDir Env{..} name version = envShake <> "packages" <> -- | The package directory. pkgLogFile :: Env -> PackageName -> Version -> FilePath pkgLogFile env@Env{..} name version = pkgDir env name version <> - "dist" <> "log.txt" + "dist" <> "stackage-log.txt" -- | Installation paths. pbBinDir, pbLibDir, pbDataDir, pbDocDir :: PerformBuild -> FilePath @@ -394,7 +394,7 @@ packageTarget env@Env{..} name plan = do liftIO (withMVar envRegLock (const (pkgCabal Verbose ["register"]))) makeTargetFile (targetForPackage envShake name version) - where logFile = (pkgLogFile env name version) + where logFile = pkgLogFile env name version dir = pkgDir env name version version = ppVersion plan versionMappings = M.toList (M.map ppVersion (bpPackages (pbPlan envPB))) @@ -516,6 +516,7 @@ cabal env verbosity prefix logfile cwd args = do envmap <- liftIO $ fmap (++ defaultEnv (envPB env) pwd) $ getEnvironment logLn env verbosity (prefix <> T.pack (fromMaybe "" (listToMaybe args))) logLn env Verbose (prefix <> T.pack (unwords (cmd' : map show args))) + liftIO (FP.createTree (FP.directory logfile)) code <- liftIO $ flip catch exitFailing $ withBinaryFile (FP.encodeString logfile) AppendMode $ \outH -> do withCheckedProcess From 8e0fafff11370f245a53d859a437a8758a459867 Mon Sep 17 00:00:00 2001 From: Chris Done Date: Mon, 23 Feb 2015 20:29:36 +0100 Subject: [PATCH 43/47] Clean before configuring --- Stackage/ShakeBuild.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/Stackage/ShakeBuild.hs b/Stackage/ShakeBuild.hs index 02d694cd..4c717878 100644 --- a/Stackage/ShakeBuild.hs +++ b/Stackage/ShakeBuild.hs @@ -378,8 +378,9 @@ packageTarget env@Env{..} name plan = do unpack env name version liftIO (do exists <- FP.isFile logFile when exists (FP.removeFile logFile)) - configure env name logFile dir plan prefix <- packageCmdPrefix name + cabal env Verbose prefix logFile dir ["clean"] + configure env name logFile dir plan False let pkgCabal :: (MonadIO m) => Verbosity -> [String] -> m () pkgCabal verbosity = succeed . cabal env verbosity prefix logFile dir pkgCabal Normal ["build","--ghc-options=" <> pbGhcOptions envPB] From 3c249501f4ce1bb0e66b1790ff3b72bcc63533a3 Mon Sep 17 00:00:00 2001 From: Chris Done Date: Mon, 23 Feb 2015 20:30:20 +0100 Subject: [PATCH 44/47] Support expected failing tests --- Stackage/ShakeBuild.hs | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/Stackage/ShakeBuild.hs b/Stackage/ShakeBuild.hs index 4c717878..04c40e82 100644 --- a/Stackage/ShakeBuild.hs +++ b/Stackage/ShakeBuild.hs @@ -384,12 +384,15 @@ packageTarget env@Env{..} name plan = do let pkgCabal :: (MonadIO m) => Verbosity -> [String] -> m () pkgCabal verbosity = succeed . cabal env verbosity prefix logFile dir pkgCabal Normal ["build","--ghc-options=" <> pbGhcOptions envPB] - when (pbEnableTests envPB) - (do result <- cabal env Normal prefix logFile dir ["test"] - case result of - ExitFailure{} -> + when (pbEnableTests envPB && pcTests (ppConstraints plan) /= Don'tBuild) + (do configure env name logFile dir plan True + result <- cabal env Normal prefix logFile dir ["test"] + case (result,pcTests (ppConstraints plan)) of + (ExitFailure{},ExpectSuccess) -> do logLn env Normal (prefix <> "TEST SUITE FAILED") failed env result + (ExitSuccess,ExpectFailure) -> + logLn env Normal (prefix <> "Unexpected test suite success!") _ -> return ()) pkgCabal Verbose ["copy"] liftIO (withMVar envRegLock From fc613b248d0a3b73408428f70fb00dccb58b0bd3 Mon Sep 17 00:00:00 2001 From: Chris Done Date: Mon, 23 Feb 2015 20:30:31 +0100 Subject: [PATCH 45/47] --enable-tests when tests are enabled --- Stackage/ShakeBuild.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/Stackage/ShakeBuild.hs b/Stackage/ShakeBuild.hs index 04c40e82..b6d6f7ad 100644 --- a/Stackage/ShakeBuild.hs +++ b/Stackage/ShakeBuild.hs @@ -433,8 +433,8 @@ unpack env@Env{..} name version = do "-v0" -- | Configure the given package. -configure :: Env -> PackageName -> FilePath -> FilePath -> PackagePlan -> Action () -configure env@Env{..} name logfile pdir plan = +configure :: Env -> PackageName -> FilePath -> FilePath -> PackagePlan -> Bool -> Action () +configure env@Env{..} name logfile pdir plan enableTests = do prefix <- packageCmdPrefix name succeed (cabal env Verbose prefix logfile pdir ("configure" : opts)) where @@ -447,7 +447,8 @@ configure env@Env{..} name logfile pdir plan = , "--docdir=" ++ FP.encodeString (pbDocDir envPB) , "--flags=" ++ planFlags] ++ ["--package-db=" ++ FP.encodeString (buildDatabase envPB) - | not (pbGlobalInstall envPB)] + | not (pbGlobalInstall envPB)] ++ + ["--enable-tests" | enableTests] planFlags = unwords $ map go $ M.toList (pcFlagOverrides (ppConstraints plan)) where go (name',isOn) = concat From 246f992569b2f85855990ed0624d4a839a129e9b Mon Sep 17 00:00:00 2001 From: Chris Done Date: Tue, 24 Feb 2015 12:08:37 +0100 Subject: [PATCH 46/47] Fix tests --- Stackage/ShakeBuild.hs | 82 +++++++++++++++++++++++++++++++++++------- 1 file changed, 69 insertions(+), 13 deletions(-) diff --git a/Stackage/ShakeBuild.hs b/Stackage/ShakeBuild.hs index b6d6f7ad..ccadba05 100644 --- a/Stackage/ShakeBuild.hs +++ b/Stackage/ShakeBuild.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} @@ -19,6 +20,7 @@ import Stackage.PackageDescription import Stackage.PerformBuild (PerformBuild(..),copyBuiltInHaddocks,renameOrCopy) import Stackage.Prelude (unFlagName,unExeName) +import Data.Char import Control.Concurrent import Control.Concurrent.STM import Control.Exception @@ -109,7 +111,7 @@ shakePlan env@Env{..} = do \(name,version) -> let fp = targetForPackage envShake name version in target fp (makeTargetFile fp) - void $ forM normalPackages $ + builds <- forM normalPackages $ \(name,plan) -> target (targetForPackage envShake name (ppVersion plan)) $ do need [db, fetched] @@ -120,7 +122,14 @@ shakePlan env@Env{..} = do target (targetForDocs envShake name (ppVersion plan)) $ do need [targetForPackage envShake name (ppVersion plan)] packageDocs env plan name - want haddockTargets + tests <- forM normalPackages $ + \(name,plan) -> + target (targetForTest envShake name (ppVersion plan)) $ + do need (haddockTargets <> [db, fetched]) + testTarget env name plan + if pbEnableTests envPB + then want tests + else want haddockTargets where versionMappings = M.toList (M.map ppVersion (bpPackages (pbPlan envPB))) corePackages = M.keys $ siCorePackages $ bpSystemInfo $ pbPlan envPB normalPackages = filter (not . (`elem` corePackages) . fst) $ @@ -141,6 +150,13 @@ targetForPackage shakeDir name version = Target $ FP.decodeString (nameVer name version) <> "dist" <> "shake-build" +-- | Get the target file for a package. +targetForTest :: FilePath -> PackageName -> Version -> Target +targetForTest shakeDir name version = Target $ + shakeDir <> "packages" <> + FP.decodeString (nameVer name version) + <> "dist" <> "shake-test" + -- | Get the target file for a package. targetForDocs :: FilePath -> PackageName -> Version -> Target targetForDocs shakeDir name version = Target $ @@ -162,11 +178,29 @@ nameVer :: PackageName -> Version -> String nameVer name version = display name ++ "-" ++ display version -- | Default environment for running commands. -defaultEnv :: PerformBuild -> FilePath -> [(String, String)] -defaultEnv pb pwd = - [( "HASKELL_PACKAGE_SANDBOX" - , FP.encodeString (pwd <> buildDatabase pb)) - | pbGlobalInstall pb] +defaultEnv :: PerformBuild -> FilePath -> [(String, String)] -> [(String, String)] +defaultEnv pb pwd env = sandbox ++ rest + where sandbox = [( "HASKELL_PACKAGE_SANDBOX" + , FP.encodeString + (pwd <> buildDatabase pb)) | not (pbGlobalInstall pb)] + rest = map addPath env + where + addPath (key,val) + | map toUpper key == "PATH" = + ( key + , FP.encodeString + (pbBinDir pb) <> + pathSep <> + val) + | otherwise = (key,val) + +-- | Platform-independent PATH environment separator. +pathSep :: String +#ifdef mingw32_HOST_OS +pathSep = ";" +#else +pathSep = ":" +#endif -- | Database location. buildDatabase :: PerformBuild -> FilePath @@ -190,6 +224,11 @@ pkgLogFile :: Env -> PackageName -> Version -> FilePath pkgLogFile env@Env{..} name version = pkgDir env name version <> "dist" <> "stackage-log.txt" +-- | The package directory. +testLogFile :: Env -> PackageName -> Version -> FilePath +testLogFile env@Env{..} name version = pkgDir env name version <> + "dist" <> "stackage-test-log.txt" + -- | Installation paths. pbBinDir, pbLibDir, pbDataDir, pbDocDir :: PerformBuild -> FilePath pbBinDir root = (pbInstallDest root) <> "bin" @@ -384,6 +423,26 @@ packageTarget env@Env{..} name plan = do let pkgCabal :: (MonadIO m) => Verbosity -> [String] -> m () pkgCabal verbosity = succeed . cabal env verbosity prefix logFile dir pkgCabal Normal ["build","--ghc-options=" <> pbGhcOptions envPB] + pkgCabal Verbose ["copy"] + liftIO (withMVar envRegLock + (const (pkgCabal Verbose ["register"]))) + makeTargetFile (targetForPackage envShake name version) + where logFile = pkgLogFile env name version + dir = pkgDir env name version + version = ppVersion plan + versionMappings = M.toList (M.map ppVersion (bpPackages (pbPlan envPB))) + +-- | Build, test and generate documentation for the package. +testTarget :: Env -> PackageName -> PackagePlan -> Action () +testTarget env@Env{..} name plan = do + need $ + map (\(pname,pver) -> targetForPackage envShake pname pver) $ + mapMaybe (\p -> find ((==p) . fst) versionMappings) $ + M.keys $ sdPackages $ ppDesc plan + unpack env name version + liftIO (do exists <- FP.isFile logFile + when exists (FP.removeFile logFile)) + prefix <- packageCmdPrefix name when (pbEnableTests envPB && pcTests (ppConstraints plan) /= Don'tBuild) (do configure env name logFile dir plan True result <- cabal env Normal prefix logFile dir ["test"] @@ -394,11 +453,8 @@ packageTarget env@Env{..} name plan = do (ExitSuccess,ExpectFailure) -> logLn env Normal (prefix <> "Unexpected test suite success!") _ -> return ()) - pkgCabal Verbose ["copy"] - liftIO (withMVar envRegLock - (const (pkgCabal Verbose ["register"]))) - makeTargetFile (targetForPackage envShake name version) - where logFile = pkgLogFile env name version + makeTargetFile (targetForTest envShake name version) + where logFile = testLogFile env name version dir = pkgDir env name version version = ppVersion plan versionMappings = M.toList (M.map ppVersion (bpPackages (pbPlan envPB))) @@ -518,7 +574,7 @@ packageCmdPrefix name = cabal :: MonadIO m => Env -> Verbosity -> Text -> FilePath -> FilePath -> [String] -> m ExitCode cabal env verbosity prefix logfile cwd args = do pwd <- liftIO FP.getWorkingDirectory - envmap <- liftIO $ fmap (++ defaultEnv (envPB env) pwd) $ getEnvironment + envmap <- liftIO $ fmap (defaultEnv (envPB env) pwd) $ getEnvironment logLn env verbosity (prefix <> T.pack (fromMaybe "" (listToMaybe args))) logLn env Verbose (prefix <> T.pack (unwords (cmd' : map show args))) liftIO (FP.createTree (FP.directory logfile)) From 466ecd3eea0eb703847be88f5d6aecd7da94c240 Mon Sep 17 00:00:00 2001 From: Chris Done Date: Wed, 11 Mar 2015 18:37:54 +0100 Subject: [PATCH 47/47] Support build-tools in the dependency graph --- Stackage/ShakeBuild.hs | 49 +++++++++++++++++++++++++++++++----------- 1 file changed, 36 insertions(+), 13 deletions(-) diff --git a/Stackage/ShakeBuild.hs b/Stackage/ShakeBuild.hs index ccadba05..867293d8 100644 --- a/Stackage/ShakeBuild.hs +++ b/Stackage/ShakeBuild.hs @@ -125,7 +125,7 @@ shakePlan env@Env{..} = do tests <- forM normalPackages $ \(name,plan) -> target (targetForTest envShake name (ppVersion plan)) $ - do need (haddockTargets <> [db, fetched]) + do need haddockTargets testTarget env name plan if pbEnableTests envPB then want tests @@ -409,11 +409,8 @@ packageDocs env@Env{..} plan name = do -- | Build, test and generate documentation for the package. packageTarget :: Env -> PackageName -> PackagePlan -> Action () packageTarget env@Env{..} name plan = do - need $ - map (\(pname,pver) -> targetForPackage envShake pname pver) $ - mapMaybe (\p -> find ((==p) . fst) versionMappings) $ - filter (/= name) $ - M.keys $ M.filter libAndExe $ sdPackages $ ppDesc plan + need libraryDependencies + need toolDependencies unpack env name version liftIO (do exists <- FP.isFile logFile when exists (FP.removeFile logFile)) @@ -431,14 +428,27 @@ packageTarget env@Env{..} name plan = do dir = pkgDir env name version version = ppVersion plan versionMappings = M.toList (M.map ppVersion (bpPackages (pbPlan envPB))) + toolMappings = makeToolMap (bpPackages (pbPlan envPB)) + libraryDependencies = + packagesToTargets $ + filter (/= name) $ + M.keys $ M.filter libAndExe $ + sdPackages $ ppDesc plan + toolDependencies = + packagesToTargets $ + filter (/= name) $ + S.toList $ mconcat $ + mapMaybe (\exename -> M.lookup exename toolMappings) $ + M.keys $ M.filter libAndExe $ sdTools $ ppDesc plan + packagesToTargets = + map (\(pname,pver) -> targetForPackage envShake pname pver) . + mapMaybe (\p -> find ((==p) . fst) versionMappings) -- | Build, test and generate documentation for the package. testTarget :: Env -> PackageName -> PackagePlan -> Action () testTarget env@Env{..} name plan = do - need $ - map (\(pname,pver) -> targetForPackage envShake pname pver) $ - mapMaybe (\p -> find ((==p) . fst) versionMappings) $ - M.keys $ sdPackages $ ppDesc plan + need libraryDependencies + need toolDependencies unpack env name version liftIO (do exists <- FP.isFile logFile when exists (FP.removeFile logFile)) @@ -458,6 +468,18 @@ testTarget env@Env{..} name plan = do dir = pkgDir env name version version = ppVersion plan versionMappings = M.toList (M.map ppVersion (bpPackages (pbPlan envPB))) + toolMappings = makeToolMap (bpPackages (pbPlan envPB)) + libraryDependencies = + packagesToTargets $ M.keys $ sdPackages $ ppDesc plan + toolDependencies = + packagesToTargets $ + S.toList $ mconcat $ + mapMaybe (\exename -> + M.lookup exename toolMappings) $ + M.keys $ sdTools $ ppDesc plan + packagesToTargets = + map (\(pname,pver) -> targetForPackage envShake pname pver) . + mapMaybe (\p -> find ((==p) . fst) versionMappings) -- | Make sure all package archives have been fetched. fetchedTarget :: Env -> Action () @@ -475,18 +497,19 @@ fetchedTarget env@Env{..} = do unpack :: Env -> PackageName -> Version -> Action () unpack env@Env{..} name version = do unpacked <- liftIO $ FP.isFile $ - pkgDir env name version <> + dir <> FP.decodeString (display name ++ ".cabal") unless unpacked $ - do liftIO $ catch (FP.removeTree (pkgDir env name version)) $ - \(_ :: IOException) -> return () + do liftIO $ catch (FP.removeTree dir) $ + \(e :: IOException) -> log env Normal ("Remove ex: " <> show e <> "\n") cmd (Cwd (FP.encodeString (envShake <> "packages"))) "cabal" "unpack" (nameVer name version) "-v0" + where dir = pkgDir env name version -- | Configure the given package. configure :: Env -> PackageName -> FilePath -> FilePath -> PackagePlan -> Bool -> Action ()