rebuild application with GHC API (incomplete, only tested on linux, GHC 7.4.1 required)
This commit is contained in:
Luite Stegeman
parent
43d938bbe7
commit
1cb7a494a9
@ -5,6 +5,7 @@ module Build
|
||||
, touchDeps
|
||||
, touch
|
||||
, recompDeps
|
||||
, isNewerThan
|
||||
) where
|
||||
|
||||
-- FIXME there's a bug when getFileStatus applies to a file
|
||||
|
||||
@ -30,7 +30,10 @@ import System.Process (createProcess, proc, terminateProcess, readProc
|
||||
waitForProcess, rawSystem, runInteractiveProcess)
|
||||
import System.IO (hClose, hIsEOF, hGetLine, stdout, stderr, hPutStrLn)
|
||||
|
||||
import Build (recompDeps, getDeps)
|
||||
import Build (recompDeps, getDeps, isNewerThan)
|
||||
import GhcBuild (getBuildFlags, buildPackage)
|
||||
|
||||
import qualified Config as GHC
|
||||
|
||||
lockFile :: FilePath
|
||||
lockFile = "dist/devel-terminate"
|
||||
@ -57,7 +60,7 @@ devel isCabalDev passThroughArgs = do
|
||||
|
||||
_<- rawSystem cmd args
|
||||
|
||||
mainLoop hsSourceDirs
|
||||
mainLoop hsSourceDirs cabal
|
||||
|
||||
_ <- getLine
|
||||
writeLock
|
||||
@ -67,32 +70,36 @@ devel isCabalDev passThroughArgs = do
|
||||
| otherwise = "cabal"
|
||||
|
||||
diffArgs | isCabalDev = [
|
||||
"--cabal-install-arg=-fdevel" -- legacy
|
||||
"--cabal-install-arg=--with-compiler=yesod-ghc-wrapper"
|
||||
, "--cabal-install-arg=--with-ld=yesod-ld-wrapper"
|
||||
, "--cabal-install-arg=--with-ar=yesod-ar-wrapper"
|
||||
, "--cabal-install-arg=-fdevel" -- legacy
|
||||
, "--cabal-install-arg=-flibrary-only"
|
||||
]
|
||||
| otherwise = [
|
||||
"-fdevel" -- legacy
|
||||
"--with-compiler=yesod-ghc-wrapper"
|
||||
, "--with-ld=yesod-ld-wrapper"
|
||||
, "--with-ar=yesod-ar-wrapper"
|
||||
, "-fdevel" -- legacy
|
||||
, "-flibrary-only"
|
||||
]
|
||||
args = "configure":diffArgs ++ ["--disable-library-profiling" ]
|
||||
|
||||
mainLoop :: [FilePath] -> IO ()
|
||||
mainLoop hsSourceDirs = do
|
||||
mainLoop :: [FilePath] -> FilePath -> IO ()
|
||||
mainLoop hsSourceDirs cabal = do
|
||||
ghcVer <- ghcVersion
|
||||
when isCabalDev (rawSystemFilter cmd ["build"] >> return ()) -- cabal-dev fails with strange errors sometimes if we cabal-dev buildinfo before cabal-dev build
|
||||
rebuildCabal cmd
|
||||
pkgArgs <- ghcPackageArgs isCabalDev ghcVer
|
||||
rebuild <- mkRebuild ghcVer cabal cmd
|
||||
let devArgs = pkgArgs ++ ["devel.hs"] ++ passThroughArgs
|
||||
forever $ do
|
||||
putStrLn "Rebuilding application..."
|
||||
|
||||
recompDeps hsSourceDirs
|
||||
|
||||
list <- getFileList hsSourceDirs
|
||||
exit <- rawSystemFilter cmd ["build"]
|
||||
|
||||
case exit of
|
||||
ExitFailure _ -> putStrLn "Build failure, pausing..."
|
||||
_ -> do
|
||||
success <- rebuild
|
||||
if not success
|
||||
then putStrLn "Build failure, pausing..."
|
||||
else do
|
||||
removeLock
|
||||
putStrLn $ "Starting development server: runghc " ++ L.unwords devArgs
|
||||
(_,_,_,ph) <- createProcess $ proc "runghc" devArgs
|
||||
@ -108,6 +115,30 @@ devel isCabalDev passThroughArgs = do
|
||||
Ex.throwTo watchTid (userError "process finished")
|
||||
watchForChanges hsSourceDirs list
|
||||
|
||||
mkRebuild :: String -> FilePath -> String -> IO (IO Bool)
|
||||
mkRebuild ghcVer cabalFile cabalCmd
|
||||
| GHC.cProjectVersion == ghcVer = do
|
||||
bf <- getBuildFlags
|
||||
return $ do
|
||||
n <- cabalFile `isNewerThan` "dist/ghcargs.txt"
|
||||
if n
|
||||
then rebuildCabal cabalCmd
|
||||
else rebuildGhc bf
|
||||
| otherwise = return $ do
|
||||
putStrLn "WARNING: yesod is compiled with a different ghc version, falling back to cabal"
|
||||
rebuildCabal cabalCmd
|
||||
|
||||
rebuildGhc bf = do
|
||||
putStrLn "Rebuilding application... (GHC API)"
|
||||
buildPackage bf
|
||||
|
||||
rebuildCabal cmd = do
|
||||
putStrLn "Rebuilding application... (cabal)"
|
||||
exit <- rawSystemFilter cmd ["build"]
|
||||
return $ case exit of
|
||||
ExitSuccess -> True
|
||||
_ -> False
|
||||
|
||||
try_ :: forall a. IO a -> IO ()
|
||||
try_ x = (Ex.try x :: IO (Either Ex.SomeException a)) >> return ()
|
||||
|
||||
@ -221,3 +252,5 @@ rawSystemFilter command args = do
|
||||
_ <- forkIO $ go outh stdout
|
||||
_ <- forkIO $ go errh stderr
|
||||
waitForProcess ph
|
||||
|
||||
|
||||
|
||||
379
yesod/GhcBuild.hs
Normal file
379
yesod/GhcBuild.hs
Normal file
@ -0,0 +1,379 @@
|
||||
{-# LANGUAGE CPP, ScopedTypeVariables #-}
|
||||
|
||||
{-
|
||||
build package with the GHC API
|
||||
-}
|
||||
|
||||
module GhcBuild (getBuildFlags, buildPackage) where
|
||||
|
||||
import qualified Control.Exception as Ex
|
||||
import System.Process (rawSystem)
|
||||
import Control.Monad (when)
|
||||
|
||||
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)
|
||||
|
||||
getBuildFlags :: IO [Located String]
|
||||
getBuildFlags = do
|
||||
argv0 <- fmap read $ readFile "dist/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))
|
||||
let argv1' = map (mkGeneralLocated "on the commandline") argv1
|
||||
(argv2, staticFlagWarnings) <- GHC.parseStaticFlags argv1'
|
||||
return argv2
|
||||
|
||||
buildPackage :: [Located String] -> IO Bool
|
||||
buildPackage a = buildPackage' a `Ex.catch` \(e::Ex.SomeException) -> do
|
||||
putStrLn ("exception building package: " ++ show e)
|
||||
return False
|
||||
|
||||
buildPackage' argv2 = do
|
||||
(mode, argv3, modeFlagWarnings) <- parseModeFlags argv2
|
||||
GHC.runGhc (Just libdir) $ do
|
||||
dflags0 <- GHC.getSessionDynFlags
|
||||
(dflags1, _, _) <- GHC.parseDynamicFlags dflags0 argv3
|
||||
let dflags2 = dflags1 { GHC.ghcMode = GHC.CompManager
|
||||
, GHC.hscTarget = GHC.hscTarget dflags1
|
||||
, GHC.ghcLink = GHC.LinkBinary
|
||||
, GHC.verbosity = 1
|
||||
}
|
||||
(dflags3, fileish_args, _) <- GHC.parseDynamicFlags dflags2 argv3
|
||||
GHC.setSessionDynFlags dflags3
|
||||
let normal_fileish_paths = map (normalise . GHC.unLoc) fileish_args
|
||||
(srcs, objs) = partition_args normal_fileish_paths [] []
|
||||
(hs_srcs, non_hs_srcs) = partition haskellish srcs
|
||||
haskellish (f,Nothing) =
|
||||
looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f
|
||||
haskellish (_,Just phase) =
|
||||
phase `notElem` [As, Cc, Cobjc, Cobjcpp, CmmCpp, Cmm, StopLn]
|
||||
hsc_env <- GHC.getSession
|
||||
-- if (null hs_srcs)
|
||||
-- then liftIO (oneShot hsc_env StopLn srcs)
|
||||
-- else do
|
||||
o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x)
|
||||
non_hs_srcs
|
||||
liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse o_files)
|
||||
targets <- mapM (uncurry GHC.guessTarget) hs_srcs
|
||||
GHC.setTargets targets
|
||||
ok_flag <- GHC.load GHC.LoadAllTargets
|
||||
if GHC.failed ok_flag
|
||||
then return False
|
||||
else liftIO linkPkg >> return True
|
||||
|
||||
-- fixme, find default ar and ld versions
|
||||
linkPkg = do
|
||||
arargs <- fmap read $ readFile "dist/arargs.txt"
|
||||
rawSystem "ar" arargs
|
||||
ldargs <- fmap read $ readFile "dist/ldargs.txt"
|
||||
rawSystem "ld" ldargs
|
||||
|
||||
|
||||
--------------------------------------------------------------------------------------------
|
||||
-- stuff below copied from ghc main.hs
|
||||
--------------------------------------------------------------------------------------------
|
||||
|
||||
partition_args :: [String] -> [(String, Maybe Phase)] -> [String]
|
||||
-> ([(String, Maybe Phase)], [String])
|
||||
partition_args [] srcs objs = (reverse srcs, reverse objs)
|
||||
partition_args ("-x":suff:args) srcs objs
|
||||
| "none" <- suff = partition_args args srcs objs
|
||||
| StopLn <- phase = partition_args args srcs (slurp ++ objs)
|
||||
| otherwise = partition_args rest (these_srcs ++ srcs) objs
|
||||
where phase = startPhase suff
|
||||
(slurp,rest) = break (== "-x") args
|
||||
these_srcs = zip slurp (repeat (Just phase))
|
||||
partition_args (arg:args) srcs objs
|
||||
| looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs
|
||||
| otherwise = partition_args args srcs (arg:objs)
|
||||
|
||||
{-
|
||||
We split out the object files (.o, .dll) and add them
|
||||
to v_Ld_inputs for use by the linker.
|
||||
|
||||
The following things should be considered compilation manager inputs:
|
||||
|
||||
- haskell source files (strings ending in .hs, .lhs or other
|
||||
haskellish extension),
|
||||
|
||||
- module names (not forgetting hierarchical module names),
|
||||
|
||||
- and finally we consider everything not containing a '.' to be
|
||||
a comp manager input, as shorthand for a .hs or .lhs filename.
|
||||
|
||||
Everything else is considered to be a linker object, and passed
|
||||
straight through to the linker.
|
||||
-}
|
||||
looks_like_an_input :: String -> Bool
|
||||
looks_like_an_input m = isSourceFilename m
|
||||
|| looksLikeModuleName m
|
||||
|| '.' `notElem` m
|
||||
|
||||
|
||||
|
||||
-- Parsing the mode flag
|
||||
|
||||
parseModeFlags :: [Located String]
|
||||
-> IO (Mode,
|
||||
[Located String],
|
||||
[Located String])
|
||||
parseModeFlags args = do
|
||||
let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) =
|
||||
runCmdLine (processArgs mode_flags args)
|
||||
(Nothing, [], [])
|
||||
mode = case mModeFlag of
|
||||
Nothing -> doMakeMode
|
||||
Just (m, _) -> m
|
||||
errs = errs1 ++ map (mkGeneralLocated "on the commandline") errs2
|
||||
when (not (null errs)) $ ghcError $ errorsToGhcException errs
|
||||
return (mode, flags' ++ leftover, warns)
|
||||
|
||||
type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String])
|
||||
-- mode flags sometimes give rise to new DynFlags (eg. -C, see below)
|
||||
-- so we collect the new ones and return them.
|
||||
|
||||
mode_flags :: [Flag ModeM]
|
||||
mode_flags =
|
||||
[ ------- help / version ----------------------------------------------
|
||||
Flag "?" (PassFlag (setMode showGhcUsageMode))
|
||||
, Flag "-help" (PassFlag (setMode showGhcUsageMode))
|
||||
, Flag "V" (PassFlag (setMode showVersionMode))
|
||||
, Flag "-version" (PassFlag (setMode showVersionMode))
|
||||
, Flag "-numeric-version" (PassFlag (setMode showNumVersionMode))
|
||||
, Flag "-info" (PassFlag (setMode showInfoMode))
|
||||
, Flag "-supported-languages" (PassFlag (setMode showSupportedExtensionsMode))
|
||||
, Flag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode))
|
||||
] ++
|
||||
[ Flag k' (PassFlag (setMode (printSetting k)))
|
||||
| k <- ["Project version",
|
||||
"Booter version",
|
||||
"Stage",
|
||||
"Build platform",
|
||||
"Host platform",
|
||||
"Target platform",
|
||||
"Have interpreter",
|
||||
"Object splitting supported",
|
||||
"Have native code generator",
|
||||
"Support SMP",
|
||||
"Unregisterised",
|
||||
"Tables next to code",
|
||||
"RTS ways",
|
||||
"Leading underscore",
|
||||
"Debug on",
|
||||
"LibDir",
|
||||
"Global Package DB",
|
||||
"C compiler flags",
|
||||
"Gcc Linker flags",
|
||||
"Ld Linker flags"],
|
||||
let k' = "-print-" ++ map (replaceSpace . toLower) k
|
||||
replaceSpace ' ' = '-'
|
||||
replaceSpace c = c
|
||||
] ++
|
||||
------- interfaces ----------------------------------------------------
|
||||
[ Flag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f)
|
||||
"--show-iface"))
|
||||
|
||||
------- primary modes ------------------------------------------------
|
||||
, Flag "c" (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f
|
||||
addFlag "-no-link" f))
|
||||
, Flag "M" (PassFlag (setMode doMkDependHSMode))
|
||||
, Flag "E" (PassFlag (setMode (stopBeforeMode anyHsc)))
|
||||
, Flag "C" (PassFlag (\f -> do setMode (stopBeforeMode HCc) f
|
||||
addFlag "-fvia-C" f))
|
||||
, Flag "S" (PassFlag (setMode (stopBeforeMode As)))
|
||||
, Flag "-make" (PassFlag (setMode doMakeMode))
|
||||
, Flag "-interactive" (PassFlag (setMode doInteractiveMode))
|
||||
, Flag "-abi-hash" (PassFlag (setMode doAbiHashMode))
|
||||
, Flag "e" (SepArg (\s -> setMode (doEvalMode s) "-e"))
|
||||
]
|
||||
|
||||
setMode :: Mode -> String -> EwM ModeM ()
|
||||
setMode newMode newFlag = liftEwM $ do
|
||||
(mModeFlag, errs, flags') <- getCmdLineState
|
||||
let (modeFlag', errs') =
|
||||
case mModeFlag of
|
||||
Nothing -> ((newMode, newFlag), errs)
|
||||
Just (oldMode, oldFlag) ->
|
||||
case (oldMode, newMode) of
|
||||
-- -c/--make are allowed together, and mean --make -no-link
|
||||
_ | isStopLnMode oldMode && isDoMakeMode newMode
|
||||
|| isStopLnMode newMode && isDoMakeMode oldMode ->
|
||||
((doMakeMode, "--make"), [])
|
||||
|
||||
-- If we have both --help and --interactive then we
|
||||
-- want showGhciUsage
|
||||
_ | isShowGhcUsageMode oldMode &&
|
||||
isDoInteractiveMode newMode ->
|
||||
((showGhciUsageMode, oldFlag), [])
|
||||
| isShowGhcUsageMode newMode &&
|
||||
isDoInteractiveMode oldMode ->
|
||||
((showGhciUsageMode, newFlag), [])
|
||||
-- Otherwise, --help/--version/--numeric-version always win
|
||||
| isDominantFlag oldMode -> ((oldMode, oldFlag), [])
|
||||
| isDominantFlag newMode -> ((newMode, newFlag), [])
|
||||
-- We need to accumulate eval flags like "-e foo -e bar"
|
||||
(Right (Right (DoEval esOld)),
|
||||
Right (Right (DoEval [eNew]))) ->
|
||||
((Right (Right (DoEval (eNew : esOld))), oldFlag),
|
||||
errs)
|
||||
-- Saying e.g. --interactive --interactive is OK
|
||||
_ | oldFlag == newFlag -> ((oldMode, oldFlag), errs)
|
||||
-- Otherwise, complain
|
||||
_ -> let err = flagMismatchErr oldFlag newFlag
|
||||
in ((oldMode, oldFlag), err : errs)
|
||||
putCmdLineState (Just modeFlag', errs', flags')
|
||||
where isDominantFlag f = isShowGhcUsageMode f ||
|
||||
isShowGhciUsageMode f ||
|
||||
isShowVersionMode f ||
|
||||
isShowNumVersionMode f
|
||||
|
||||
flagMismatchErr :: String -> String -> String
|
||||
flagMismatchErr oldFlag newFlag
|
||||
= "cannot use `" ++ oldFlag ++ "' with `" ++ newFlag ++ "'"
|
||||
|
||||
addFlag :: String -> String -> EwM ModeM ()
|
||||
addFlag s flag = liftEwM $ do
|
||||
(m, e, flags') <- getCmdLineState
|
||||
putCmdLineState (m, e, mkGeneralLocated loc s : flags')
|
||||
where loc = "addFlag by " ++ flag ++ " on the commandline"
|
||||
|
||||
type Mode = Either PreStartupMode PostStartupMode
|
||||
type PostStartupMode = Either PreLoadMode PostLoadMode
|
||||
|
||||
data PreStartupMode
|
||||
= ShowVersion -- ghc -V/--version
|
||||
| ShowNumVersion -- ghc --numeric-version
|
||||
| ShowSupportedExtensions -- ghc --supported-extensions
|
||||
| Print String -- ghc --print-foo
|
||||
|
||||
showVersionMode, showNumVersionMode, showSupportedExtensionsMode :: Mode
|
||||
showVersionMode = mkPreStartupMode ShowVersion
|
||||
showNumVersionMode = mkPreStartupMode ShowNumVersion
|
||||
showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions
|
||||
|
||||
mkPreStartupMode :: PreStartupMode -> Mode
|
||||
mkPreStartupMode = Left
|
||||
|
||||
isShowVersionMode :: Mode -> Bool
|
||||
isShowVersionMode (Left ShowVersion) = True
|
||||
isShowVersionMode _ = False
|
||||
|
||||
isShowNumVersionMode :: Mode -> Bool
|
||||
isShowNumVersionMode (Left ShowNumVersion) = True
|
||||
isShowNumVersionMode _ = False
|
||||
|
||||
data PreLoadMode
|
||||
= ShowGhcUsage -- ghc -?
|
||||
| ShowGhciUsage -- ghci -?
|
||||
| ShowInfo -- ghc --info
|
||||
| PrintWithDynFlags (DynFlags -> String) -- ghc --print-foo
|
||||
|
||||
showGhcUsageMode, showGhciUsageMode, showInfoMode :: Mode
|
||||
showGhcUsageMode = mkPreLoadMode ShowGhcUsage
|
||||
showGhciUsageMode = mkPreLoadMode ShowGhciUsage
|
||||
showInfoMode = mkPreLoadMode ShowInfo
|
||||
|
||||
printSetting :: String -> Mode
|
||||
printSetting k = mkPreLoadMode (PrintWithDynFlags f)
|
||||
where f dflags = fromMaybe (panic ("Setting not found: " ++ show k))
|
||||
$ lookup k (compilerInfo dflags)
|
||||
|
||||
mkPreLoadMode :: PreLoadMode -> Mode
|
||||
mkPreLoadMode = Right . Left
|
||||
|
||||
isShowGhcUsageMode :: Mode -> Bool
|
||||
isShowGhcUsageMode (Right (Left ShowGhcUsage)) = True
|
||||
isShowGhcUsageMode _ = False
|
||||
|
||||
isShowGhciUsageMode :: Mode -> Bool
|
||||
isShowGhciUsageMode (Right (Left ShowGhciUsage)) = True
|
||||
isShowGhciUsageMode _ = False
|
||||
|
||||
data PostLoadMode
|
||||
= ShowInterface FilePath -- ghc --show-iface
|
||||
| DoMkDependHS -- ghc -M
|
||||
| StopBefore Phase -- ghc -E | -C | -S
|
||||
-- StopBefore StopLn is the default
|
||||
| DoMake -- ghc --make
|
||||
| DoInteractive -- ghc --interactive
|
||||
| DoEval [String] -- ghc -e foo -e bar => DoEval ["bar", "foo"]
|
||||
| DoAbiHash -- ghc --abi-hash
|
||||
|
||||
doMkDependHSMode, doMakeMode, doInteractiveMode, doAbiHashMode :: Mode
|
||||
doMkDependHSMode = mkPostLoadMode DoMkDependHS
|
||||
doMakeMode = mkPostLoadMode DoMake
|
||||
doInteractiveMode = mkPostLoadMode DoInteractive
|
||||
doAbiHashMode = mkPostLoadMode DoAbiHash
|
||||
|
||||
|
||||
showInterfaceMode :: FilePath -> Mode
|
||||
showInterfaceMode fp = mkPostLoadMode (ShowInterface fp)
|
||||
|
||||
stopBeforeMode :: Phase -> Mode
|
||||
stopBeforeMode phase = mkPostLoadMode (StopBefore phase)
|
||||
|
||||
doEvalMode :: String -> Mode
|
||||
doEvalMode str = mkPostLoadMode (DoEval [str])
|
||||
|
||||
mkPostLoadMode :: PostLoadMode -> Mode
|
||||
mkPostLoadMode = Right . Right
|
||||
|
||||
isDoInteractiveMode :: Mode -> Bool
|
||||
isDoInteractiveMode (Right (Right DoInteractive)) = True
|
||||
isDoInteractiveMode _ = False
|
||||
|
||||
isStopLnMode :: Mode -> Bool
|
||||
isStopLnMode (Right (Right (StopBefore StopLn))) = True
|
||||
isStopLnMode _ = False
|
||||
|
||||
isDoMakeMode :: Mode -> Bool
|
||||
isDoMakeMode (Right (Right DoMake)) = True
|
||||
isDoMakeMode _ = False
|
||||
|
||||
#ifdef GHCI
|
||||
isInteractiveMode :: PostLoadMode -> Bool
|
||||
isInteractiveMode DoInteractive = True
|
||||
isInteractiveMode _ = False
|
||||
#endif
|
||||
|
||||
-- isInterpretiveMode: byte-code compiler involved
|
||||
isInterpretiveMode :: PostLoadMode -> Bool
|
||||
isInterpretiveMode DoInteractive = True
|
||||
isInterpretiveMode (DoEval _) = True
|
||||
isInterpretiveMode _ = False
|
||||
|
||||
needsInputsMode :: PostLoadMode -> Bool
|
||||
needsInputsMode DoMkDependHS = True
|
||||
needsInputsMode (StopBefore _) = True
|
||||
needsInputsMode DoMake = True
|
||||
needsInputsMode _ = False
|
||||
|
||||
-- True if we are going to attempt to link in this mode.
|
||||
-- (we might not actually link, depending on the GhcLink flag)
|
||||
isLinkMode :: PostLoadMode -> Bool
|
||||
isLinkMode (StopBefore StopLn) = True
|
||||
isLinkMode DoMake = True
|
||||
isLinkMode DoInteractive = True
|
||||
isLinkMode (DoEval _) = True
|
||||
isLinkMode _ = False
|
||||
|
||||
isCompManagerMode :: PostLoadMode -> Bool
|
||||
isCompManagerMode DoMake = True
|
||||
isCompManagerMode DoInteractive = True
|
||||
isCompManagerMode (DoEval _) = True
|
||||
isCompManagerMode _ = False
|
||||
|
||||
41
yesod/ghcwrapper.hs
Normal file
41
yesod/ghcwrapper.hs
Normal file
@ -0,0 +1,41 @@
|
||||
{-
|
||||
wrapper executable that captures arguments to ghc, ar or ld
|
||||
-}
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
module Main where
|
||||
|
||||
import System.Process (rawSystem, readProcess)
|
||||
import System.Environment (getArgs)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Control.Monad (when)
|
||||
import System.Exit (exitWith)
|
||||
import System.Directory (doesDirectoryExist)
|
||||
|
||||
#ifdef LDCMD
|
||||
cmd = lookupGhcInfo "ld command" "ld"
|
||||
outFile = "dist/ldargs.txt"
|
||||
#else
|
||||
#ifdef ARCMD
|
||||
cmd = lookupGhcInfo "ar command" "ar"
|
||||
outFile ="dist/arargs.txt"
|
||||
#else
|
||||
cmd = return "ghc"
|
||||
outFile = "dist/ghcargs.txt"
|
||||
#endif
|
||||
#endif
|
||||
|
||||
lookupGhcInfo :: String -> String -> IO String
|
||||
lookupGhcInfo xs d = fmap (fromMaybe d . lookup xs . read) (readProcess "ghc" ["--info"] "")
|
||||
|
||||
passthrough args = do
|
||||
c <- cmd
|
||||
rawSystem c args
|
||||
|
||||
main = do
|
||||
args <- getArgs
|
||||
e <- doesDirectoryExist "dist"
|
||||
when e $ writeFile outFile (show args ++ "\n")
|
||||
ex <- passthrough args
|
||||
exitWith ex
|
||||
|
||||
@ -90,6 +90,22 @@ library
|
||||
exposed-modules: Yesod
|
||||
ghc-options: -Wall
|
||||
|
||||
executable yesod-ghc-wrapper
|
||||
main-is: ghcwrapper.hs
|
||||
build-depends:
|
||||
base >= 4 && < 5
|
||||
|
||||
executable yesod-ld-wrapper
|
||||
main-is: ghcwrapper.hs
|
||||
cpp-options: -DLDCMD
|
||||
build-depends:
|
||||
base >= 4 && < 5
|
||||
executable yesod-ar-wrapper
|
||||
main-is: ghcwrapper.hs
|
||||
cpp-options: -DARCMD
|
||||
build-depends:
|
||||
base >= 4 && < 5
|
||||
|
||||
executable yesod
|
||||
if flag(ghc7)
|
||||
build-depends: base >= 4.3 && < 5
|
||||
@ -114,6 +130,8 @@ executable yesod
|
||||
, filepath >= 1.1
|
||||
, fast-logger >= 0.0.2 && < 0.1
|
||||
, process
|
||||
, ghc >= 7.4.1
|
||||
, ghc-paths >= 0.1.0.8
|
||||
ghc-options: -Wall
|
||||
if flag(threaded)
|
||||
ghc-options: -threaded
|
||||
@ -122,6 +140,7 @@ executable yesod
|
||||
Scaffolding.Scaffolder
|
||||
Devel
|
||||
Build
|
||||
GhcBuild
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
|
||||
Loading…
Reference in New Issue
Block a user