module Distribution.Simple.Program.GHC (
GhcOptions(..),
GhcMode(..),
GhcOptimisation(..),
GhcDynLinkMode(..),
ghcInvocation,
renderGhcOptions,
runGHC,
) where
import Distribution.Simple.GHC.ImplInfo ( getImplInfo, GhcImplInfo(..) )
import Distribution.Package
import Distribution.PackageDescription hiding (Flag)
import Distribution.ModuleName
import Distribution.Simple.Compiler hiding (Flag)
import Distribution.Simple.Setup ( Flag(..), flagToMaybe, fromFlagOrDefault,
flagToList )
import Distribution.Simple.Program.Types
import Distribution.Simple.Program.Run
import Distribution.Text
import Distribution.Verbosity
import Distribution.Utils.NubList ( NubListR, fromNubListR )
import Language.Haskell.Extension ( Language(..), Extension(..) )
import qualified Data.Map as M
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid
#endif
import Data.List ( intercalate )
data GhcOptions = GhcOptions {
ghcOptMode :: Flag GhcMode,
ghcOptExtra :: NubListR String,
ghcOptExtraDefault :: NubListR String,
ghcOptInputFiles :: NubListR FilePath,
ghcOptInputModules :: NubListR ModuleName,
ghcOptOutputFile :: Flag FilePath,
ghcOptOutputDynFile :: Flag FilePath,
ghcOptSourcePathClear :: Flag Bool,
ghcOptSourcePath :: NubListR FilePath,
ghcOptPackageKey :: Flag PackageKey,
ghcOptPackageDBs :: PackageDBStack,
ghcOptPackages ::
NubListR (InstalledPackageId, PackageId, ModuleRenaming),
ghcOptHideAllPackages :: Flag Bool,
ghcOptNoAutoLinkPackages :: Flag Bool,
ghcOptSigOf :: [(ModuleName, (PackageKey, ModuleName))],
ghcOptLinkLibs :: NubListR FilePath,
ghcOptLinkLibPath :: NubListR FilePath,
ghcOptLinkOptions :: NubListR String,
ghcOptLinkFrameworks :: NubListR String,
ghcOptNoLink :: Flag Bool,
ghcOptLinkNoHsMain :: Flag Bool,
ghcOptCcOptions :: NubListR String,
ghcOptCppOptions :: NubListR String,
ghcOptCppIncludePath :: NubListR FilePath,
ghcOptCppIncludes :: NubListR FilePath,
ghcOptFfiIncludes :: NubListR FilePath,
ghcOptLanguage :: Flag Language,
ghcOptExtensions :: NubListR Extension,
ghcOptExtensionMap :: M.Map Extension String,
ghcOptOptimisation :: Flag GhcOptimisation,
ghcOptDebugInfo :: Flag Bool,
ghcOptProfilingMode :: Flag Bool,
ghcOptSplitObjs :: Flag Bool,
ghcOptNumJobs :: Flag (Maybe Int),
ghcOptHPCDir :: Flag FilePath,
ghcOptGHCiScripts :: NubListR FilePath,
ghcOptHiSuffix :: Flag String,
ghcOptObjSuffix :: Flag String,
ghcOptDynHiSuffix :: Flag String,
ghcOptDynObjSuffix :: Flag String,
ghcOptHiDir :: Flag FilePath,
ghcOptObjDir :: Flag FilePath,
ghcOptOutputDir :: Flag FilePath,
ghcOptStubDir :: Flag FilePath,
ghcOptDynLinkMode :: Flag GhcDynLinkMode,
ghcOptShared :: Flag Bool,
ghcOptFPic :: Flag Bool,
ghcOptDylibName :: Flag String,
ghcOptRPaths :: NubListR FilePath,
ghcOptVerbosity :: Flag Verbosity,
ghcOptCabal :: Flag Bool
} deriving Show
data GhcMode = GhcModeCompile
| GhcModeLink
| GhcModeMake
| GhcModeInteractive
| GhcModeAbiHash
deriving (Show, Eq)
data GhcOptimisation = GhcNoOptimisation
| GhcNormalOptimisation
| GhcMaximumOptimisation
| GhcSpecialOptimisation String
deriving (Show, Eq)
data GhcDynLinkMode = GhcStaticOnly
| GhcDynamicOnly
| GhcStaticAndDynamic
deriving (Show, Eq)
runGHC :: Verbosity -> ConfiguredProgram -> Compiler -> GhcOptions -> IO ()
runGHC verbosity ghcProg comp opts = do
runProgramInvocation verbosity (ghcInvocation ghcProg comp opts)
ghcInvocation :: ConfiguredProgram -> Compiler -> GhcOptions -> ProgramInvocation
ghcInvocation prog comp opts =
programInvocation prog (renderGhcOptions comp opts)
renderGhcOptions :: Compiler -> GhcOptions -> [String]
renderGhcOptions comp opts
| compilerFlavor comp `notElem` [GHC, GHCJS] =
error $ "Distribution.Simple.Program.GHC.renderGhcOptions: "
++ "compiler flavor must be 'GHC' or 'GHCJS'!"
| otherwise =
concat
[ case flagToMaybe (ghcOptMode opts) of
Nothing -> []
Just GhcModeCompile -> ["-c"]
Just GhcModeLink -> []
Just GhcModeMake -> ["--make"]
Just GhcModeInteractive -> ["--interactive"]
Just GhcModeAbiHash -> ["--abi-hash"]
, flags ghcOptExtraDefault
, [ "-no-link" | flagBool ghcOptNoLink ]
, maybe [] verbosityOpts (flagToMaybe (ghcOptVerbosity opts))
, [ "-fbuilding-cabal-package" | flagBool ghcOptCabal
, flagBuildingCabalPkg implInfo ]
, case flagToMaybe (ghcOptOptimisation opts) of
Nothing -> []
Just GhcNoOptimisation -> ["-O0"]
Just GhcNormalOptimisation -> ["-O"]
Just GhcMaximumOptimisation -> ["-O2"]
Just (GhcSpecialOptimisation s) -> ["-O" ++ s]
, [ "-g" | flagDebugInfo implInfo && flagBool ghcOptDebugInfo ]
, [ "-prof" | flagBool ghcOptProfilingMode ]
, [ "-split-objs" | flagBool ghcOptSplitObjs ]
, case flagToMaybe (ghcOptHPCDir opts) of
Nothing -> []
Just hpcdir -> ["-fhpc", "-hpcdir", hpcdir]
, if parmakeSupported comp
then case ghcOptNumJobs opts of
NoFlag -> []
Flag n -> ["-j" ++ maybe "" show n]
else []
, [ "-shared" | flagBool ghcOptShared ]
, case flagToMaybe (ghcOptDynLinkMode opts) of
Nothing -> []
Just GhcStaticOnly -> ["-static"]
Just GhcDynamicOnly -> ["-dynamic"]
Just GhcStaticAndDynamic -> ["-static", "-dynamic-too"]
, [ "-fPIC" | flagBool ghcOptFPic ]
, concat [ ["-dylib-install-name", libname] | libname <- flag ghcOptDylibName ]
, concat [ ["-osuf", suf] | suf <- flag ghcOptObjSuffix ]
, concat [ ["-hisuf", suf] | suf <- flag ghcOptHiSuffix ]
, concat [ ["-dynosuf", suf] | suf <- flag ghcOptDynObjSuffix ]
, concat [ ["-dynhisuf",suf] | suf <- flag ghcOptDynHiSuffix ]
, concat [ ["-outputdir", dir] | dir <- flag ghcOptOutputDir
, flagOutputDir implInfo ]
, concat [ ["-odir", dir] | dir <- flag ghcOptObjDir ]
, concat [ ["-hidir", dir] | dir <- flag ghcOptHiDir ]
, concat [ ["-stubdir", dir] | dir <- flag ghcOptStubDir
, flagStubdir implInfo ]
, [ "-i" | flagBool ghcOptSourcePathClear ]
, [ "-i" ++ dir | dir <- flags ghcOptSourcePath ]
, [ "-I" ++ dir | dir <- flags ghcOptCppIncludePath ]
, [ "-optP" ++ opt | opt <- flags ghcOptCppOptions ]
, concat [ [ "-optP-include", "-optP" ++ inc]
| inc <- flags ghcOptCppIncludes ]
, [ "-#include \"" ++ inc ++ "\""
| inc <- flags ghcOptFfiIncludes, flagFfiIncludes implInfo ]
, [ "-optc" ++ opt | opt <- flags ghcOptCcOptions ]
, [ "-optl" ++ opt | opt <- flags ghcOptLinkOptions ]
, ["-l" ++ lib | lib <- flags ghcOptLinkLibs ]
, ["-L" ++ dir | dir <- flags ghcOptLinkLibPath ]
, concat [ ["-framework", fmwk] | fmwk <- flags ghcOptLinkFrameworks ]
, [ "-no-hs-main" | flagBool ghcOptLinkNoHsMain ]
, [ "-dynload deploy" | not (null (flags ghcOptRPaths)) ]
, concat [ [ "-optl-Wl,-rpath," ++ dir]
| dir <- flags ghcOptRPaths ]
, concat [ [if packageKeySupported comp
then "-this-package-key"
else "-package-name", display pkgid]
| pkgid <- flag ghcOptPackageKey ]
, [ "-hide-all-packages" | flagBool ghcOptHideAllPackages ]
, [ "-no-auto-link-packages" | flagBool ghcOptNoAutoLinkPackages ]
, packageDbArgs implInfo (ghcOptPackageDBs opts)
, if null (ghcOptSigOf opts)
then []
else "-sig-of"
: intercalate "," (map (\(n,(p,m)) -> display n ++ " is "
++ display p ++ ":"
++ display m)
(ghcOptSigOf opts))
: []
, concat $ if flagPackageId implInfo
then let space "" = ""
space xs = ' ' : xs
in [ ["-package-id", display ipkgid ++ space (display rns)]
| (ipkgid,_,rns) <- flags ghcOptPackages ]
else [ ["-package", display pkgid]
| (_,pkgid,_) <- flags ghcOptPackages ]
, if supportsHaskell2010 implInfo
then [ "-X" ++ display lang | lang <- flag ghcOptLanguage ]
else []
, [ case M.lookup ext (ghcOptExtensionMap opts) of
Just arg -> arg
Nothing -> error $ "Distribution.Simple.Program.GHC.renderGhcOptions: "
++ display ext ++ " not present in ghcOptExtensionMap."
| ext <- flags ghcOptExtensions ]
, concat [ [ "-ghci-script", script ] | script <- flags ghcOptGHCiScripts
, flagGhciScript implInfo ]
, [ display modu | modu <- flags ghcOptInputModules ]
, flags ghcOptInputFiles
, concat [ [ "-o", out] | out <- flag ghcOptOutputFile ]
, concat [ [ "-dyno", out] | out <- flag ghcOptOutputDynFile ]
, flags ghcOptExtra
]
where
implInfo = getImplInfo comp
flag flg = flagToList (flg opts)
flags flg = fromNubListR . flg $ opts
flagBool flg = fromFlagOrDefault False (flg opts)
verbosityOpts :: Verbosity -> [String]
verbosityOpts verbosity
| verbosity >= deafening = ["-v"]
| verbosity >= normal = []
| otherwise = ["-w", "-v0"]
packageDbArgs :: GhcImplInfo -> PackageDBStack -> [String]
packageDbArgs implInfo dbstack = case dbstack of
(GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs
(GlobalPackageDB:dbs) -> ("-no-user-" ++ packageDbFlag)
: concatMap specific dbs
_ -> ierror
where
specific (SpecificPackageDB db) = [ '-':packageDbFlag , db ]
specific _ = ierror
ierror = error $ "internal error: unexpected package db stack: "
++ show dbstack
packageDbFlag
| flagPackageConf implInfo
= "package-conf"
| otherwise
= "package-db"
instance Monoid GhcOptions where
mempty = GhcOptions {
ghcOptMode = mempty,
ghcOptExtra = mempty,
ghcOptExtraDefault = mempty,
ghcOptInputFiles = mempty,
ghcOptInputModules = mempty,
ghcOptOutputFile = mempty,
ghcOptOutputDynFile = mempty,
ghcOptSourcePathClear = mempty,
ghcOptSourcePath = mempty,
ghcOptPackageKey = mempty,
ghcOptPackageDBs = mempty,
ghcOptPackages = mempty,
ghcOptHideAllPackages = mempty,
ghcOptNoAutoLinkPackages = mempty,
ghcOptSigOf = mempty,
ghcOptLinkLibs = mempty,
ghcOptLinkLibPath = mempty,
ghcOptLinkOptions = mempty,
ghcOptLinkFrameworks = mempty,
ghcOptNoLink = mempty,
ghcOptLinkNoHsMain = mempty,
ghcOptCcOptions = mempty,
ghcOptCppOptions = mempty,
ghcOptCppIncludePath = mempty,
ghcOptCppIncludes = mempty,
ghcOptFfiIncludes = mempty,
ghcOptLanguage = mempty,
ghcOptExtensions = mempty,
ghcOptExtensionMap = mempty,
ghcOptOptimisation = mempty,
ghcOptDebugInfo = mempty,
ghcOptProfilingMode = mempty,
ghcOptSplitObjs = mempty,
ghcOptNumJobs = mempty,
ghcOptHPCDir = mempty,
ghcOptGHCiScripts = mempty,
ghcOptHiSuffix = mempty,
ghcOptObjSuffix = mempty,
ghcOptDynHiSuffix = mempty,
ghcOptDynObjSuffix = mempty,
ghcOptHiDir = mempty,
ghcOptObjDir = mempty,
ghcOptOutputDir = mempty,
ghcOptStubDir = mempty,
ghcOptDynLinkMode = mempty,
ghcOptShared = mempty,
ghcOptFPic = mempty,
ghcOptDylibName = mempty,
ghcOptRPaths = mempty,
ghcOptVerbosity = mempty,
ghcOptCabal = mempty
}
mappend a b = GhcOptions {
ghcOptMode = combine ghcOptMode,
ghcOptExtra = combine ghcOptExtra,
ghcOptExtraDefault = combine ghcOptExtraDefault,
ghcOptInputFiles = combine ghcOptInputFiles,
ghcOptInputModules = combine ghcOptInputModules,
ghcOptOutputFile = combine ghcOptOutputFile,
ghcOptOutputDynFile = combine ghcOptOutputDynFile,
ghcOptSourcePathClear = combine ghcOptSourcePathClear,
ghcOptSourcePath = combine ghcOptSourcePath,
ghcOptPackageKey = combine ghcOptPackageKey,
ghcOptPackageDBs = combine ghcOptPackageDBs,
ghcOptPackages = combine ghcOptPackages,
ghcOptHideAllPackages = combine ghcOptHideAllPackages,
ghcOptNoAutoLinkPackages = combine ghcOptNoAutoLinkPackages,
ghcOptSigOf = combine ghcOptSigOf,
ghcOptLinkLibs = combine ghcOptLinkLibs,
ghcOptLinkLibPath = combine ghcOptLinkLibPath,
ghcOptLinkOptions = combine ghcOptLinkOptions,
ghcOptLinkFrameworks = combine ghcOptLinkFrameworks,
ghcOptNoLink = combine ghcOptNoLink,
ghcOptLinkNoHsMain = combine ghcOptLinkNoHsMain,
ghcOptCcOptions = combine ghcOptCcOptions,
ghcOptCppOptions = combine ghcOptCppOptions,
ghcOptCppIncludePath = combine ghcOptCppIncludePath,
ghcOptCppIncludes = combine ghcOptCppIncludes,
ghcOptFfiIncludes = combine ghcOptFfiIncludes,
ghcOptLanguage = combine ghcOptLanguage,
ghcOptExtensions = combine ghcOptExtensions,
ghcOptExtensionMap = combine ghcOptExtensionMap,
ghcOptOptimisation = combine ghcOptOptimisation,
ghcOptDebugInfo = combine ghcOptDebugInfo,
ghcOptProfilingMode = combine ghcOptProfilingMode,
ghcOptSplitObjs = combine ghcOptSplitObjs,
ghcOptNumJobs = combine ghcOptNumJobs,
ghcOptHPCDir = combine ghcOptHPCDir,
ghcOptGHCiScripts = combine ghcOptGHCiScripts,
ghcOptHiSuffix = combine ghcOptHiSuffix,
ghcOptObjSuffix = combine ghcOptObjSuffix,
ghcOptDynHiSuffix = combine ghcOptDynHiSuffix,
ghcOptDynObjSuffix = combine ghcOptDynObjSuffix,
ghcOptHiDir = combine ghcOptHiDir,
ghcOptObjDir = combine ghcOptObjDir,
ghcOptOutputDir = combine ghcOptOutputDir,
ghcOptStubDir = combine ghcOptStubDir,
ghcOptDynLinkMode = combine ghcOptDynLinkMode,
ghcOptShared = combine ghcOptShared,
ghcOptFPic = combine ghcOptFPic,
ghcOptDylibName = combine ghcOptDylibName,
ghcOptRPaths = combine ghcOptRPaths,
ghcOptVerbosity = combine ghcOptVerbosity,
ghcOptCabal = combine ghcOptCabal
}
where
combine field = field a `mappend` field b