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