haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

allow custom build directory with command line flag or env var

Browse Source
This commit is contained in:
Luite Stegeman 2012-10-17 14:31:45 +02:00
parent 174ac36719
commit 80a8c51434
5 changed files with 122 additions and 92 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

76
yesod/Devel.hs
View File

@ -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

49
yesod/GhcBuild.hs
View File

@ -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 ()

39
yesod/ghcwrapper.hs
View File

@ -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

48
yesod/main.hs
View File

@ -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

2
yesod/scaffold/devel.hs.cg
View File

@ -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 ()