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