From 80a8c51434c473563a16e68782bd5986d22bf5b7 Mon Sep 17 00:00:00 2001 From: Luite Stegeman Date: Wed, 17 Oct 2012 14:31:45 +0200 Subject: [PATCH] allow custom build directory with command line flag or env var --- yesod/Devel.hs | 76 +++++++++++++++++++++----------------- yesod/GhcBuild.hs | 49 ++++++++++++------------ yesod/ghcwrapper.hs | 39 ++++++++++--------- yesod/main.hs | 48 +++++++++++++++--------- yesod/scaffold/devel.hs.cg | 2 +- 5 files changed, 122 insertions(+), 92 deletions(-) diff --git a/yesod/Devel.hs b/yesod/Devel.hs index a4e1692c..8f6f4ac7 100644 --- a/yesod/Devel.hs +++ b/yesod/Devel.hs @@ -34,6 +34,7 @@ import Control.Monad (forever, unless, void, import Data.Char (isNumber, isUpper) import qualified Data.List as L import qualified Data.Map as Map +import Data.Maybe (fromMaybe) import qualified Data.Set as Set import System.Directory @@ -42,7 +43,7 @@ import System.Exit (ExitCode (..), exitSuccess) import System.FilePath (dropExtension, splitDirectories, - takeExtension) + takeExtension, ()) import System.FSNotify import System.IO (hClose, hGetLine, hIsEOF, hPutStrLn, @@ -69,16 +70,20 @@ import GhcBuild (buildPackage, import qualified Config as GHC import SrcLoc (Located) -lockFile :: FilePath -lockFile = "dist/devel-terminate" +lockFile :: DevelOpts -> FilePath +lockFile _opts = "yesod-devel/devel-terminate" -writeLock :: IO () -writeLock = do - createDirectoryIfMissing True "dist" - writeFile lockFile "" +writeLock :: DevelOpts -> IO () +writeLock opts = do + createDirectoryIfMissing True "yesod-devel" + writeFile (lockFile opts) "" + createDirectoryIfMissing True "dist" -- for compatibility with old devel.hs + writeFile "dist/devel-terminate" "" -removeLock :: IO () -removeLock = removeFileIfExists lockFile +removeLock :: DevelOpts -> IO () +removeLock opts = do + removeFileIfExists (lockFile opts) + removeFileIfExists "dist/devel-terminate" -- for compatibility with old devel.hs data DevelOpts = DevelOpts { isCabalDev :: Bool @@ -87,19 +92,23 @@ data DevelOpts = DevelOpts , eventTimeout :: Int -- negative value for no timeout , successHook :: Maybe String , failHook :: Maybe String + , buildDir :: Maybe String } deriving (Show, Eq) +getBuildDir :: DevelOpts -> String +getBuildDir opts = fromMaybe "dist" (buildDir opts) + cabalCommand :: DevelOpts -> FilePath cabalCommand opts | isCabalDev opts = "cabal-dev" | otherwise = "cabal" defaultDevelOpts :: DevelOpts -defaultDevelOpts = DevelOpts False False False (-1) Nothing Nothing +defaultDevelOpts = DevelOpts False False False (-1) Nothing Nothing Nothing devel :: DevelOpts -> [String] -> IO () devel opts passThroughArgs = withManager $ \manager -> do checkDevelFile - writeLock + writeLock opts putStrLn "Yesod devel server. Press ENTER to quit" _ <- forkIO $ do @@ -109,19 +118,20 @@ devel opts passThroughArgs = withManager $ \manager -> do ldar <- lookupLdAr (hsSourceDirs, lib) <- checkCabalFile gpd - removeFileIfExists "dist/setup-config" + removeFileIfExists (bd "setup-config") configure cabal gpd opts - removeFileIfExists "dist/ghcargs.txt" -- these files contain the wrong data after - removeFileIfExists "dist/arargs.txt" -- the configure step, remove them to force - removeFileIfExists "dist/ldargs.txt" -- a cabal build first + removeFileIfExists "yesod-devel/ghcargs.txt" -- these files contain the wrong data after + removeFileIfExists "yesod-devel/arargs.txt" -- the configure step, remove them to force + removeFileIfExists "yesod-devel/ldargs.txt" -- a cabal build first filesModified <- newEmptyMVar watchTree manager "." (const True) (\_ -> void (tryPutMVar filesModified ())) mainLoop hsSourceDirs filesModified cabal gpd lib ldar _ <- getLine - writeLock + writeLock opts exitSuccess where + bd = getBuildDir opts mainLoop :: [FilePath] -> MVar () -> FilePath @@ -144,14 +154,14 @@ devel opts passThroughArgs = withManager $ \manager -> do runBuildHook $ failHook opts else do runBuildHook $ successHook opts - removeLock + removeLock opts putStrLn $ if verbose opts then "Starting development server: runghc " ++ L.unwords devArgs else "Starting development server..." (_,_,_,ph) <- createProcess $ proc "runghc" devArgs watchTid <- forkIO . try_ $ do watchForChanges filesModified hsSourceDirs [cabal] list (eventTimeout opts) putStrLn "Stopping development server..." - writeLock + writeLock opts threadDelay 1000000 putStrLn "Terminating development server..." terminateProcess ph @@ -180,7 +190,7 @@ configure _cabalFile gpd opts | isCabalDev opts = rawSystem (cabalCommand opts) args >> return () | otherwise = do lbi <- D.configure (gpd, hookedBuildInfo) configFlags - D.writePersistBuildConfig "dist" lbi -- fixme we could keep this in memory instead of file + D.writePersistBuildConfig (getBuildDir opts) lbi -- fixme we could keep this in memory instead of file where hookedBuildInfo = (Nothing, []) configFlags | forceCabal opts = config @@ -234,9 +244,9 @@ mkRebuild gpd ghcVer cabalFile opts (ldPath, arPath) | forceCabal opts = return (rebuildCabal gpd opts) | otherwise = do return $ do - n1 <- cabalFile `isNewerThan` "dist/ghcargs.txt" - n2 <- cabalFile `isNewerThan` "dist/arargs.txt" - n3 <- cabalFile `isNewerThan` "dist/ldargs.txt" + n1 <- cabalFile `isNewerThan` "yesod-devel/ghcargs.txt" + n2 <- cabalFile `isNewerThan` "yesod-devel/arargs.txt" + n3 <- cabalFile `isNewerThan` "yesod-devel/ldargs.txt" if n1 || n2 || n3 then rebuildCabal gpd opts else do @@ -260,7 +270,7 @@ rebuildCabal _gpd opts _ -> False | otherwise = do putStrLn $ "Rebuilding application... (using Cabal library)" - lbi <- getPersistBuildConfig "dist" -- fixme we could cache this from the configure step + lbi <- getPersistBuildConfig opts -- fixme we could cache this from the configure step let buildFlags | verbose opts = DSS.defaultBuildFlags | otherwise = DSS.defaultBuildFlags { DSS.buildVerbosity = DSS.Flag D.silent } tryBool $ D.build (D.localPkgDescr lbi) lbi buildFlags [] @@ -344,7 +354,7 @@ ghcVersion = fmap getNumber $ readProcess "runghc" ["--numeric-version", "0"] [] ghcPackageArgs :: DevelOpts -> String -> D.PackageDescription -> D.Library -> IO [String] ghcPackageArgs opts ghcVer cabal lib = do - lbi <- getPersistBuildConfig "dist" + lbi <- getPersistBuildConfig opts cbi <- fromMaybeErr errCbi (D.libraryConfig lbi) if isCabalDev opts then return ("-hide-all-packages" : "-no-user-package-conf" : inplaceConf : selfPkgArg lbi : cabalDevConf : depArgs lbi cbi) @@ -353,26 +363,26 @@ ghcPackageArgs opts ghcVer cabal lib = do selfPkgArg lbi = pkgArg . D.inplacePackageId . D.package . D.localPkgDescr $ lbi pkgArg (D.InstalledPackageId pkgId) = "-package-id" ++ pkgId depArgs lbi cbi = map pkgArg (deps lbi cbi) - deps lbi cbi = let pkgInfo = D.inplaceInstalledPackageInfo "." "dist" cabal lib lbi cbi + deps lbi cbi = let pkgInfo = D.inplaceInstalledPackageInfo "." (getBuildDir opts) cabal lib lbi cbi in IPI.depends $ pkgInfo errCbi = "No library ComponentBuildInfo" cabalDevConf = "-package-confcabal-dev/packages-" ++ ghcVer ++ ".conf" - inplaceConf = "-package-confdist/package.conf.inplace" + inplaceConf = "-package-conf" ++ (getBuildDir opts"package.conf.inplace") -getPersistBuildConfig :: FilePath -> IO D.LocalBuildInfo -getPersistBuildConfig path = fromRightErr errLbi =<< getPersistConfigLenient path -- D.maybeGetPersistBuildConfig path +getPersistBuildConfig :: DevelOpts -> IO D.LocalBuildInfo +getPersistBuildConfig opts = fromRightErr errLbi =<< getPersistConfigLenient opts -- D.maybeGetPersistBuildConfig path where - errLbi = "Could not read BuildInfo file: " ++ D.localBuildInfoFile "dist" ++ + errLbi = "Could not read BuildInfo file: " ++ D.localBuildInfoFile (getBuildDir opts) ++ "\nMake sure that cabal-install has been compiled with the same GHC version as yesod." ++ "\nand that the Cabal library used by GHC is the same version" -- there can be slight differences in the cabal version, ignore those when loading the file as long as we can parse it -getPersistConfigLenient :: FilePath -> IO (Either String D.LocalBuildInfo) -getPersistConfigLenient fp = do - let file = fp ++ "/setup-config" +getPersistConfigLenient :: DevelOpts -> IO (Either String D.LocalBuildInfo) +getPersistConfigLenient opts = do + let file = D.localBuildInfoFile (getBuildDir opts) exists <- doesFileExist file if not exists - then return (Left $ "file does not exist: " ++ fp) + then return (Left $ "file does not exist: " ++ file) else do xs <- readFile file return $ case lines xs of diff --git a/yesod/GhcBuild.hs b/yesod/GhcBuild.hs index a775f134..02a6ef87 100644 --- a/yesod/GhcBuild.hs +++ b/yesod/GhcBuild.hs @@ -8,7 +8,9 @@ difficult to compare the code to the original, just ignore unused binds and imports. -} -{-# LANGUAGE CPP, ScopedTypeVariables, PatternGuards #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ScopedTypeVariables #-} {- build package with the GHC API @@ -17,28 +19,29 @@ module GhcBuild (getBuildFlags, buildPackage) where import qualified Control.Exception as Ex -import System.Process (rawSystem) -import Control.Monad (when) -import Data.IORef +import Control.Monad (when) +import Data.IORef +import System.Process (rawSystem) -import qualified GHC -import DriverPhases ( Phase(..), isSourceFilename, anyHsc, startPhase, isHaskellSrcFilename ) -import Util (looksLikeModuleName, consIORef) -import DriverPipeline (oneShot, compileFile, link, linkBinary ) -import StaticFlags (v_Ld_inputs) -import HscTypes ( emptyHomePackageTable, HscEnv(..) ) -import System.FilePath (normalise) -import GHC.Paths (libdir) -import MonadUtils ( liftIO ) -import CmdLineParser -import SrcLoc (Located, mkGeneralLocated) -import DynFlags (DynFlags, compilerInfo) -import Data.Char (toLower) -import Data.Maybe (fromMaybe) -import Panic (panic, ghcError) -import Data.List (partition, isPrefixOf) +import CmdLineParser +import Data.Char (toLower) +import Data.List (isPrefixOf, partition) +import Data.Maybe (fromMaybe) +import DriverPhases (Phase (..), anyHsc, isHaskellSrcFilename, + isSourceFilename, startPhase) +import DriverPipeline (compileFile, link, linkBinary, oneShot) +import DynFlags (DynFlags, compilerInfo) import qualified DynFlags +import qualified GHC +import GHC.Paths (libdir) +import HscTypes (HscEnv (..), emptyHomePackageTable) +import MonadUtils (liftIO) +import Panic (ghcError, panic) +import SrcLoc (Located, mkGeneralLocated) +import StaticFlags (v_Ld_inputs) import qualified StaticFlags +import System.FilePath (normalise, ()) +import Util (consIORef, looksLikeModuleName) {- This contains a huge hack: @@ -49,7 +52,7 @@ import qualified StaticFlags -} getBuildFlags :: IO [Located String] getBuildFlags = do - argv0 <- fmap read $ readFile "dist/ghcargs.txt" -- generated by yesod-ghc-wrapper + argv0 <- fmap read $ readFile "yesod-devel/ghcargs.txt" -- generated by yesod-ghc-wrapper let (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0 mbMinusB | null minusB_args = Nothing | otherwise = Just (drop 2 (last minusB_args)) @@ -107,9 +110,9 @@ buildPackage' argv2 ld ar = do linkPkg :: FilePath -> FilePath -> IO () linkPkg ld ar = do - arargs <- fmap read $ readFile "dist/arargs.txt" + arargs <- fmap read $ readFile "yesod-devel/arargs.txt" rawSystem ar arargs - ldargs <- fmap read $ readFile "dist/ldargs.txt" + ldargs <- fmap read $ readFile "yesod-devel/ldargs.txt" rawSystem ld ldargs return () diff --git a/yesod/ghcwrapper.hs b/yesod/ghcwrapper.hs index da9921e1..bd0488cc 100644 --- a/yesod/ghcwrapper.hs +++ b/yesod/ghcwrapper.hs @@ -5,37 +5,40 @@ {-# LANGUAGE CPP #-} module Main where -import Control.Monad (when) -import Data.Maybe (fromMaybe) +import Control.Monad (when) +import Data.Maybe (fromMaybe) -import Distribution.Compiler (CompilerFlavor(..)) -import Distribution.Simple.Configure (configCompiler) -import Distribution.Simple.Program (defaultProgramConfiguration, programPath, ghcProgram, - ldProgram, arProgram) -import Distribution.Simple.Program.Db (lookupProgram, configureAllKnownPrograms) -import Distribution.Simple.Program.Types (Program(..)) -import Distribution.Verbosity (silent) +import Distribution.Compiler (CompilerFlavor (..)) +import Distribution.Simple.Configure (configCompiler) +import Distribution.Simple.Program (arProgram, + defaultProgramConfiguration, + ghcProgram, ldProgram, + programPath) +import Distribution.Simple.Program.Db (configureAllKnownPrograms, + lookupProgram) +import Distribution.Simple.Program.Types (Program (..)) +import Distribution.Verbosity (silent) -import System.Directory (doesDirectoryExist) -import System.Environment (getArgs) -import System.Exit (exitWith, ExitCode(..)) -import System.IO (hPutStrLn, stderr) -import System.Process (rawSystem, readProcess) +import System.Directory (doesDirectoryExist) +import System.Environment (getArgs) +import System.Exit (ExitCode (..), exitWith) +import System.IO (hPutStrLn, stderr) +import System.Process (rawSystem, readProcess) #ifdef LDCMD cmd :: Program cmd = ldProgram -outFile = "dist/ldargs.txt" +outFile = "yesod-devel/ldargs.txt" #else #ifdef ARCMD cmd :: Program cmd = arProgram -outFile ="dist/arargs.txt" +outFile ="yesod-devel/arargs.txt" #else cmd :: Program cmd = ghcProgram -outFile = "dist/ghcargs.txt" +outFile = "yesod-devel/ghcargs.txt" #endif #endif @@ -51,7 +54,7 @@ runProgram pgm args = do main = do args <- getArgs - e <- doesDirectoryExist "dist" + e <- doesDirectoryExist "yesod-devel" when e $ writeFile outFile (show args ++ "\n") ex <- runProgram cmd args exitWith ex diff --git a/yesod/main.hs b/yesod/main.hs index 4cb464af..24b78bcc 100755 --- a/yesod/main.hs +++ b/yesod/main.hs @@ -4,6 +4,7 @@ import Control.Monad (unless) import Data.Monoid import Data.Version (showVersion) import Options.Applicative +import System.Environment (getEnvironment) import System.Exit (ExitCode (ExitSuccess), exitWith) import System.Process (rawSystem) @@ -53,6 +54,7 @@ data Command = Init , _develSuccessHook :: Maybe String , _develFailHook :: Maybe String , _develRescan :: Int + , _develBuildDir :: Maybe String , _develExtraArgs :: [String] } | Test @@ -61,16 +63,19 @@ data Command = Init | Version deriving (Show, Eq) +type Environment = [(String, String)] + main :: IO () main = do - o <- execParser optParser' + env <- getEnvironment + o <- execParser (optParser' env) let cabal xs = rawSystem' (cabalCommand o) xs case optCommand o of Init -> scaffold Configure -> cabal ["configure"] Build es -> touch' >> cabal ("build":es) Touch -> touch' - Devel da s f r es -> devel (DevelOpts (optCabalPgm o == CabalDev) da (optVerbose o) r s f) es + Devel da s f r b es -> devel (DevelOpts (optCabalPgm o == CabalDev) da (optVerbose o) r s f b) es Keter noRebuild -> keter (cabalCommand o) noRebuild Version -> do putStrLn ("yesod-core version:" ++ yesodVersion) putStrLn ("yesod version:" ++ showVersion Paths_yesod.version) @@ -80,11 +85,11 @@ main = do cabal ["build"] cabal ["test"] -optParser' :: ParserInfo Options -optParser' = info (helper <*> optParser) ( fullDesc <> header "Yesod Web Framework command line utility" ) +optParser' :: Environment -> ParserInfo Options +optParser' env = info (helper <*> optParser env) ( fullDesc <> header "Yesod Web Framework command line utility" ) -optParser :: Parser Options -optParser = Options +optParser :: Environment -> Parser Options +optParser env = Options <$> flag Cabal CabalDev ( long "dev" <> short 'd' <> help "use cabal-dev" ) <*> switch ( long "verbose" <> short 'v' <> help "More verbose output" ) <*> subparser ( command "init" (info (pure Init) @@ -95,7 +100,7 @@ optParser = Options (progDesc $ "Build project (performs TH dependency analysis)" ++ windowsWarning)) <> command "touch" (info (pure Touch) (progDesc $ "Touch any files with altered TH dependencies but do not build" ++ windowsWarning)) - <> command "devel" (info develOptions + <> command "devel" (info (develOptions env) (progDesc "Run project with the devel server")) <> command "test" (info (pure Test) (progDesc "Build and run the integration tests")) @@ -110,16 +115,19 @@ optParser = Options keterOptions :: Parser Command keterOptions = Keter <$> switch ( long "nobuild" <> short 'n' <> help "Skip rebuilding" ) -develOptions :: Parser Command -develOptions = Devel <$> switch ( long "disable-api" <> short 'd' - <> help "Disable fast GHC API rebuilding") - <*> optStr ( long "success-hook" <> short 's' <> metavar "COMMAND" - <> help "Run COMMAND after rebuild succeeds") - <*> optStr ( long "failure-hook" <> short 'f' <> metavar "COMMAND" - <> help "Run COMMAND when rebuild fails") - <*> option ( long "event-timeout" <> short 't' <> value (-1) <> metavar "N" - <> help "Force rescan of files every N seconds" ) - <*> extraCabalArgs +develOptions :: Environment -> Parser Command +develOptions env = Devel <$> switch ( long "disable-api" <> short 'd' + <> help "Disable fast GHC API rebuilding") + <*> optStr ( long "success-hook" <> short 's' <> metavar "COMMAND" + <> help "Run COMMAND after rebuild succeeds") + <*> optStr ( long "failure-hook" <> short 'f' <> metavar "COMMAND" + <> help "Run COMMAND when rebuild fails") + <*> option ( long "event-timeout" <> short 't' <> value (-1) <> metavar "N" + <> help "Force rescan of files every N seconds" ) + + <*> optStrEnv env "CABAL_BUILDDIR" ( long "builddir" <> short 'b' + <> help "Set custom cabal build directory, default `dist' or the CABAL_BUILDDIR environment variable") + <*> extraCabalArgs extraCabalArgs :: Parser [String] extraCabalArgs = many (strOption ( long "extra-cabal-arg" <> short 'e' <> metavar "ARG" @@ -130,6 +138,12 @@ extraCabalArgs = many (strOption ( long "extra-cabal-arg" <> short 'e' <> metava optStr :: Mod OptionFields (Maybe String) -> Parser (Maybe String) optStr m = nullOption $ value Nothing <> reader (Just . str) <> m +optStrEnv :: Environment + -> String + -> Mod OptionFields (Maybe String) + -> Parser (Maybe String) +optStrEnv env v m = nullOption $ value (lookup v env) <> reader (Just . str) <> m + -- | Like @rawSystem@, but exits if it receives a non-success result. rawSystem' :: String -> [String] -> IO () rawSystem' x y = do diff --git a/yesod/scaffold/devel.hs.cg b/yesod/scaffold/devel.hs.cg index 4dcd7876..c651b654 100644 --- a/yesod/scaffold/devel.hs.cg +++ b/yesod/scaffold/devel.hs.cg @@ -19,7 +19,7 @@ main = do loop :: IO () loop = do threadDelay 100000 - e <- doesFileExist "dist/devel-terminate" + e <- doesFileExist "yesod-devel/devel-terminate" if e then terminateDevel else loop terminateDevel :: IO ()