{-# LANGUAGE CPP #-} 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 ) -- | A structured set of GHC options/flags -- data GhcOptions = GhcOptions { -- | The major mode for the ghc invocation. ghcOptMode :: Flag GhcMode, -- | Any extra options to pass directly to ghc. These go at the end and hence -- override other stuff. ghcOptExtra :: NubListR String, -- | Extra default flags to pass directly to ghc. These go at the beginning -- and so can be overridden by other stuff. ghcOptExtraDefault :: NubListR String, ----------------------- -- Inputs and outputs -- | The main input files; could be .hs, .hi, .c, .o, depending on mode. ghcOptInputFiles :: NubListR FilePath, -- | The names of input Haskell modules, mainly for @--make@ mode. ghcOptInputModules :: NubListR ModuleName, -- | Location for output file; the @ghc -o@ flag. ghcOptOutputFile :: Flag FilePath, -- | Location for dynamic output file in 'GhcStaticAndDynamic' mode; -- the @ghc -dyno@ flag. ghcOptOutputDynFile :: Flag FilePath, -- | Start with an empty search path for Haskell source files; -- the @ghc -i@ flag (@-i@ on it's own with no path argument). ghcOptSourcePathClear :: Flag Bool, -- | Search path for Haskell source files; the @ghc -i@ flag. ghcOptSourcePath :: NubListR FilePath, ------------- -- Packages -- | The package key the modules will belong to; the @ghc -this-package-key@ -- flag. ghcOptPackageKey :: Flag PackageKey, -- | GHC package databases to use, the @ghc -package-conf@ flag. ghcOptPackageDBs :: PackageDBStack, -- | The GHC packages to use. For compatability with old and new ghc, this -- requires both the short and long form of the package id; -- the @ghc -package@ or @ghc -package-id@ flags. ghcOptPackages :: NubListR (InstalledPackageId, PackageId, ModuleRenaming), -- | Start with a clean package set; the @ghc -hide-all-packages@ flag ghcOptHideAllPackages :: Flag Bool, -- | Don't automatically link in Haskell98 etc; the @ghc -- -no-auto-link-packages@ flag. ghcOptNoAutoLinkPackages :: Flag Bool, -- | What packages are implementing the signatures ghcOptSigOf :: [(ModuleName, (PackageKey, ModuleName))], ----------------- -- Linker stuff -- | Names of libraries to link in; the @ghc -l@ flag. ghcOptLinkLibs :: NubListR FilePath, -- | Search path for libraries to link in; the @ghc -L@ flag. ghcOptLinkLibPath :: NubListR FilePath, -- | Options to pass through to the linker; the @ghc -optl@ flag. ghcOptLinkOptions :: NubListR String, -- | OSX only: frameworks to link in; the @ghc -framework@ flag. ghcOptLinkFrameworks :: NubListR String, -- | Don't do the link step, useful in make mode; the @ghc -no-link@ flag. ghcOptNoLink :: Flag Bool, -- | Don't link in the normal RTS @main@ entry point; the @ghc -no-hs-main@ -- flag. ghcOptLinkNoHsMain :: Flag Bool, -------------------- -- C and CPP stuff -- | Options to pass through to the C compiler; the @ghc -optc@ flag. ghcOptCcOptions :: NubListR String, -- | Options to pass through to CPP; the @ghc -optP@ flag. ghcOptCppOptions :: NubListR String, -- | Search path for CPP includes like header files; the @ghc -I@ flag. ghcOptCppIncludePath :: NubListR FilePath, -- | Extra header files to include at CPP stage; the @ghc -optP-include@ flag. ghcOptCppIncludes :: NubListR FilePath, -- | Extra header files to include for old-style FFI; the @ghc -#include@ flag. ghcOptFfiIncludes :: NubListR FilePath, ---------------------------- -- Language and extensions -- | The base language; the @ghc -XHaskell98@ or @-XHaskell2010@ flag. ghcOptLanguage :: Flag Language, -- | The language extensions; the @ghc -X@ flag. ghcOptExtensions :: NubListR Extension, -- | A GHC version-dependent mapping of extensions to flags. This must be -- set to be able to make use of the 'ghcOptExtensions'. ghcOptExtensionMap :: M.Map Extension String, ---------------- -- Compilation -- | What optimisation level to use; the @ghc -O@ flag. ghcOptOptimisation :: Flag GhcOptimisation, -- | Emit debug info; the @ghc -g@ flag. ghcOptDebugInfo :: Flag Bool, -- | Compile in profiling mode; the @ghc -prof@ flag. ghcOptProfilingMode :: Flag Bool, -- | Use the \"split object files\" feature; the @ghc -split-objs@ flag. ghcOptSplitObjs :: Flag Bool, -- | Run N jobs simultaneously (if possible). ghcOptNumJobs :: Flag (Maybe Int), -- | Enable coverage analysis; the @ghc -fhpc -hpcdir@ flags. ghcOptHPCDir :: Flag FilePath, ---------------- -- GHCi -- | Extra GHCi startup scripts; the @-ghci-script@ flag ghcOptGHCiScripts :: NubListR FilePath, ------------------------ -- Redirecting outputs ghcOptHiSuffix :: Flag String, ghcOptObjSuffix :: Flag String, ghcOptDynHiSuffix :: Flag String, -- ^ only in 'GhcStaticAndDynamic' mode ghcOptDynObjSuffix :: Flag String, -- ^ only in 'GhcStaticAndDynamic' mode ghcOptHiDir :: Flag FilePath, ghcOptObjDir :: Flag FilePath, ghcOptOutputDir :: Flag FilePath, ghcOptStubDir :: Flag FilePath, -------------------- -- Dynamic linking ghcOptDynLinkMode :: Flag GhcDynLinkMode, ghcOptShared :: Flag Bool, ghcOptFPic :: Flag Bool, ghcOptDylibName :: Flag String, ghcOptRPaths :: NubListR FilePath, --------------- -- Misc flags -- | Get GHC to be quiet or verbose with what it's doing; the @ghc -v@ flag. ghcOptVerbosity :: Flag Verbosity, -- | Let GHC know that it is Cabal that's calling it. -- Modifies some of the GHC error messages. ghcOptCabal :: Flag Bool } deriving Show data GhcMode = GhcModeCompile -- ^ @ghc -c@ | GhcModeLink -- ^ @ghc@ | GhcModeMake -- ^ @ghc --make@ | GhcModeInteractive -- ^ @ghci@ \/ @ghc --interactive@ | GhcModeAbiHash -- ^ @ghc --abi-hash@ -- | GhcModeDepAnalysis -- ^ @ghc -M@ -- | GhcModeEvaluate -- ^ @ghc -e@ deriving (Show, Eq) data GhcOptimisation = GhcNoOptimisation -- ^ @-O0@ | GhcNormalOptimisation -- ^ @-O@ | GhcMaximumOptimisation -- ^ @-O2@ | GhcSpecialOptimisation String -- ^ e.g. @-Odph@ deriving (Show, Eq) data GhcDynLinkMode = GhcStaticOnly -- ^ @-static@ | GhcDynamicOnly -- ^ @-dynamic@ | GhcStaticAndDynamic -- ^ @-static -dynamic-too@ 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"] -- Just GhcModeDepAnalysis -> ["-M"] -- Just GhcModeEvaluate -> ["-e", expr] , flags ghcOptExtraDefault , [ "-no-link" | flagBool ghcOptNoLink ] --------------- -- Misc flags , maybe [] verbosityOpts (flagToMaybe (ghcOptVerbosity opts)) , [ "-fbuilding-cabal-package" | flagBool ghcOptCabal , flagBuildingCabalPkg implInfo ] ---------------- -- Compilation , case flagToMaybe (ghcOptOptimisation opts) of Nothing -> [] Just GhcNoOptimisation -> ["-O0"] Just GhcNormalOptimisation -> ["-O"] Just GhcMaximumOptimisation -> ["-O2"] Just (GhcSpecialOptimisation s) -> ["-O" ++ s] -- eg -Odph , [ "-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 [] -------------------- -- Dynamic linking , [ "-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 ] ------------------------ -- Redirecting outputs , 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 ] ----------------------- -- Source search path , [ "-i" | flagBool ghcOptSourcePathClear ] , [ "-i" ++ dir | dir <- flags ghcOptSourcePath ] -------------------- -- C and CPP stuff , [ "-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 ] ----------------- -- Linker stuff , [ "-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 ] ------------- -- Packages , 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 ] ---------------------------- -- Language and extensions , 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 ] ---------------- -- GHCi , concat [ [ "-ghci-script", script ] | script <- flags ghcOptGHCiScripts , flagGhciScript implInfo ] --------------- -- Inputs , [ display modu | modu <- flags ghcOptInputModules ] , flags ghcOptInputFiles , concat [ [ "-o", out] | out <- flag ghcOptOutputFile ] , concat [ [ "-dyno", out] | out <- flag ghcOptOutputDynFile ] --------------- -- Extra , 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" -- ----------------------------------------------------------------------------- -- Boilerplate Monoid instance for GhcOptions 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