yesod-bin-1.4.7: GhcBuild.hs
{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
{-# OPTIONS_GHC -fno-warn-unused-binds #-}
{-# OPTIONS_GHC -fno-warn-unused-imports #-}
{-# OPTIONS_GHC -fno-warn-unused-matches #-}
{-
There is a lot of code copied from GHC here, and some conditional
compilation. Instead of fixing all warnings and making it much more
difficult to compare the code to the original, just ignore unused
binds and imports.
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-
build package with the GHC API
-}
module GhcBuild (getBuildFlags, buildPackage, getPackageArgs) where
import qualified Control.Exception as Ex
import Control.Monad (when)
import Data.IORef
import System.Process (rawSystem)
import System.Environment (getEnvironment)
import CmdLineParser
import Data.Char (toLower)
import Data.List (isPrefixOf, isSuffixOf, 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 DynFlags as DF
import qualified GHC
import GHC.Paths (libdir)
import HscTypes (HscEnv (..), emptyHomePackageTable)
import qualified Module
import MonadUtils (liftIO)
import Panic (throwGhcException, panic)
import SrcLoc (Located, mkGeneralLocated)
import qualified StaticFlags
#if __GLASGOW_HASKELL__ >= 707
import DynFlags (ldInputs)
#else
import StaticFlags (v_Ld_inputs)
#endif
import System.FilePath (normalise, (</>))
import Util (consIORef, looksLikeModuleName)
{-
This contains a huge hack:
GHC only accepts setting static flags once per process, however it has no way to
get the remaining options from the command line, without setting the static flags.
This code overwrites the IORef to disable the check. This will likely cause
problems if the flags are modified, but fortunately that's relatively uncommon.
-}
getBuildFlags :: IO [Located String]
getBuildFlags = do
argv0 <- fmap read $ readFile "yesod-devel/ghcargs.txt" -- generated by yesod-ghc-wrapper
argv0' <- prependHsenvArgv argv0
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
writeIORef StaticFlags.v_opt_C_ready False -- the huge hack
(argv2, staticFlagWarnings) <- GHC.parseStaticFlags argv1'
return argv2
prependHsenvArgv :: [String] -> IO [String]
prependHsenvArgv argv = do
env <- getEnvironment
return $ case (lookup "HSENV" env) of
Nothing -> argv
_ -> hsenvArgv ++ argv
where hsenvArgv = words $ fromMaybe "" (lookup "PACKAGE_DB_FOR_GHC" env)
-- construct a command line for loading the right packages
getPackageArgs :: Maybe String -> [Located String] -> IO [String]
getPackageArgs buildDir argv2 = do
(mode, argv3, modeFlagWarnings) <- parseModeFlags argv2
GHC.runGhc (Just libdir) $ do
dflags0 <- GHC.getSessionDynFlags
(dflags1, _, _) <- GHC.parseDynamicFlags dflags0 argv3
let pkgFlags = map convertPkgFlag (GHC.packageFlags dflags1)
hideAll | gopt DF.Opt_HideAllPackages dflags1 = [ "-hide-all-packages"]
| otherwise = []
ownPkg = packageString (DF.thisPackage dflags1)
return (extra dflags1 ++ hideAll ++ pkgFlags ++ [ownPkg])
where
#if __GLASGOW_HASKELL__ >= 710
convertPkgFlag (DF.ExposePackage (DF.PackageArg p) _) = "-package" ++ p
convertPkgFlag (DF.ExposePackage (DF.PackageIdArg p) _) = "-package-id" ++ p
convertPkgFlag (DF.ExposePackage (DF.PackageKeyArg p) _) = "-package-key" ++ p
#else
convertPkgFlag (DF.ExposePackage p) = "-package" ++ p
convertPkgFlag (DF.ExposePackageId p) = "-package-id" ++ p
#endif
convertPkgFlag (DF.HidePackage p) = "-hide-package" ++ p
convertPkgFlag (DF.IgnorePackage p) = "-ignore-package" ++ p
convertPkgFlag (DF.TrustPackage p) = "-trust" ++ p
convertPkgFlag (DF.DistrustPackage p) ="-distrust" ++ p
#if __GLASGOW_HASKELL__ >= 710
packageString flags = "-package-key" ++ Module.packageKeyString flags
#else
packageString flags = "-package-id" ++ Module.packageIdString flags ++ "-inplace"
#endif
#if __GLASGOW_HASKELL__ >= 705
extra df = inplaceConf ++ extra'
where
extra' = concatMap convertExtra (extraConfs df)
-- old cabal-install sometimes misses the .inplace db, fix it here
inplaceConf
| any (".inplace" `isSuffixOf`) extra' = []
| otherwise = ["-package-db" ++ fromMaybe "dist" buildDir
++ "/package.conf.inplace"]
extraConfs df = GHC.extraPkgConfs df []
convertExtra DF.GlobalPkgConf = [ ]
convertExtra DF.UserPkgConf = [ ]
convertExtra (DF.PkgConfFile file) = [ "-package-db" ++ file ]
#else
extra df = inplaceConf ++ extra'
where
extra' = map ("-package-conf"++) (GHC.extraPkgConfs df)
-- old cabal-install sometimes misses the .inplace db, fix it here
inplaceConf
| any (".inplace" `isSuffixOf`) extra' = []
| otherwise = ["-package-conf" ++ fromMaybe "dist" buildDir
++ "/package.conf.inplace"]
#endif
#if __GLASGOW_HASKELL__ >= 707
gopt = DF.gopt
#else
gopt = DF.dopt
#endif
buildPackage :: [Located String] -> FilePath -> FilePath -> IO Bool
buildPackage a ld ar = buildPackage' a ld ar `Ex.catch` \e -> do
putStrLn ("exception building package: " ++ show (e :: Ex.SomeException))
return False
buildPackage' :: [Located String] -> FilePath -> FilePath -> IO Bool
buildPackage' argv2 ld ar = 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) =
#if MIN_VERSION_ghc(7,8,3)
phase `notElem` [As True, As False, Cc, Cobjc, Cobjcpp, CmmCpp, Cmm, StopLn]
#elif MIN_VERSION_ghc(7,4,0)
phase `notElem` [As, Cc, Cobjc, Cobjcpp, CmmCpp, Cmm, StopLn]
#else
phase `notElem` [As, Cc, CmmCpp, Cmm, StopLn]
#endif
hsc_env <- GHC.getSession
-- if (null hs_srcs)
-- then liftIO (oneShot hsc_env StopLn srcs)
-- else do
#if MIN_VERSION_ghc(7,2,0)
o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x)
#else
o_files <- mapM (\x -> compileFile hsc_env StopLn x)
#endif
non_hs_srcs
#if __GLASGOW_HASKELL__ >= 707
let dflags4 = dflags3
{ ldInputs = map (DF.FileOption "") (reverse o_files)
++ ldInputs dflags3
}
GHC.setSessionDynFlags dflags4
#else
liftIO $ mapM_ (consIORef v_Ld_inputs) (reverse o_files)
#endif
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 ld ar) >> return True
linkPkg :: FilePath -> FilePath -> IO ()
linkPkg ld ar = do
arargs <- fmap read $ readFile "yesod-devel/arargs.txt"
rawSystem ar arargs
ldargs <- fmap read $ readFile "yesod-devel/ldargs.txt"
rawSystem ld ldargs
return ()
--------------------------------------------------------------------------------------------
-- 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
#if __GLASGOW_HASKELL__ >= 710
errorsToGhcException' = errorsToGhcException . map (\(GHC.L _ e) -> ("on the commandline", e))
#else
errorsToGhcException' = errorsToGhcException
#endif
when (not (null errs)) $ throwGhcException $ 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 ----------------------------------------------
mkFlag "?" (PassFlag (setMode showGhcUsageMode))
, mkFlag "-help" (PassFlag (setMode showGhcUsageMode))
, mkFlag "V" (PassFlag (setMode showVersionMode))
, mkFlag "-version" (PassFlag (setMode showVersionMode))
, mkFlag "-numeric-version" (PassFlag (setMode showNumVersionMode))
, mkFlag "-info" (PassFlag (setMode showInfoMode))
, mkFlag "-supported-languages" (PassFlag (setMode showSupportedExtensionsMode))
, mkFlag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode))
] ++
[ mkFlag 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 ----------------------------------------------------
[ mkFlag "-show-iface" (HasArg (\f -> setMode (showInterfaceMode f)
"--show-iface"))
------- primary modes ------------------------------------------------
, mkFlag "c" (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f
addFlag "-no-link" f))
, mkFlag "M" (PassFlag (setMode doMkDependHSMode))
, mkFlag "E" (PassFlag (setMode (stopBeforeMode anyHsc)))
, mkFlag "C" (PassFlag (\f -> do setMode (stopBeforeMode HCc) f
addFlag "-fvia-C" f))
#if MIN_VERSION_ghc(7,8,3)
, mkFlag "S" (PassFlag (setMode (stopBeforeMode (As True))))
#else
, mkFlag "S" (PassFlag (setMode (stopBeforeMode As)))
#endif
, mkFlag "-make" (PassFlag (setMode doMakeMode))
, mkFlag "-interactive" (PassFlag (setMode doInteractiveMode))
, mkFlag "-abi-hash" (PassFlag (setMode doAbiHashMode))
, mkFlag "e" (SepArg (\s -> setMode (doEvalMode s) "-e"))
]
#if MIN_VERSION_ghc(7,10,1)
where mkFlag fName fOptKind = Flag fName fOptKind AllModes
#else
where mkFlag fName fOptKind = Flag fName fOptKind
#endif
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))
#if MIN_VERSION_ghc(7,2,0)
$ lookup k (compilerInfo dflags)
#else
$ fmap convertPrintable (lookup k compilerInfo)
where
convertPrintable (DynFlags.String s) = s
convertPrintable (DynFlags.FromDynFlags f) = f dflags
#endif
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