module Distribution.Simple.GHC.Internal (
configureToolchain,
getLanguages,
getExtensions,
targetPlatform,
getGhcInfo,
componentCcGhcOptions,
componentCmmGhcOptions,
componentCxxGhcOptions,
componentAsmGhcOptions,
componentGhcOptions,
mkGHCiLibName,
mkGHCiProfLibName,
filterGhciFlags,
ghcLookupProperty,
getHaskellObjects,
mkGhcOptPackages,
substTopDir,
checkPackageDbEnvVar,
profDetailLevelFlag,
ghcArchString,
ghcOsString,
ghcPlatformAndVersionString,
GhcEnvironmentFileEntry(..),
writeGhcEnvironmentFile,
simpleGhcEnvironmentFile,
ghcEnvironmentFileName,
renderGhcEnvironmentFile,
renderGhcEnvironmentFileEntry,
) where
import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Simple.GHC.ImplInfo
import Distribution.Types.ComponentLocalBuildInfo
import Distribution.Backpack
import qualified Distribution.InstalledPackageInfo as IPI
import Distribution.PackageDescription
import Distribution.Lex
import Distribution.Simple.Compiler
import Distribution.Simple.Program.GHC
import Distribution.Simple.Setup
import qualified Distribution.ModuleName as ModuleName
import Distribution.Simple.Program
import Distribution.Simple.LocalBuildInfo
import Distribution.Types.UnitId
import Distribution.Types.LocalBuildInfo
import Distribution.Types.TargetInfo
import Distribution.Types.ModuleRenaming
import Distribution.Simple.Utils
import Distribution.Simple.BuildPaths
import Distribution.System
import Distribution.Pretty ( prettyShow )
import Distribution.Parsec ( simpleParsec )
import Distribution.Utils.NubList ( toNubListR )
import Distribution.Verbosity
import Distribution.Compat.Stack
import Distribution.Version (Version)
import Language.Haskell.Extension
import qualified Data.Map as Map
import qualified Data.ByteString.Lazy.Char8 as BS
import System.Directory ( getDirectoryContents, getTemporaryDirectory )
import System.Environment ( getEnv )
import System.FilePath ( (</>), (<.>), takeExtension
, takeDirectory, takeFileName)
import System.IO ( hClose, hPutStrLn )
targetPlatform :: [(String, String)] -> Maybe Platform
targetPlatform ghcInfo = platformFromTriple =<< lookup "Target platform" ghcInfo
configureToolchain :: GhcImplInfo
-> ConfiguredProgram
-> Map String String
-> ProgramDb
-> ProgramDb
configureToolchain _implInfo ghcProg ghcInfo =
addKnownProgram gccProgram {
programFindLocation = findProg gccProgramName extraGccPath,
programPostConf = configureGcc
}
. addKnownProgram ldProgram {
programFindLocation = findProg ldProgramName extraLdPath,
programPostConf = configureLd
}
. addKnownProgram arProgram {
programFindLocation = findProg arProgramName extraArPath
}
. addKnownProgram stripProgram {
programFindLocation = findProg stripProgramName extraStripPath
}
where
compilerDir = takeDirectory (programPath ghcProg)
base_dir = takeDirectory compilerDir
mingwBinDir = base_dir </> "mingw" </> "bin"
isWindows = case buildOS of Windows -> True; _ -> False
binPrefix = ""
maybeName :: Program -> Maybe FilePath -> String
maybeName prog = maybe (programName prog) (dropExeExtension . takeFileName)
gccProgramName = maybeName gccProgram mbGccLocation
ldProgramName = maybeName ldProgram mbLdLocation
arProgramName = maybeName arProgram mbArLocation
stripProgramName = maybeName stripProgram mbStripLocation
mkExtraPath :: Maybe FilePath -> FilePath -> [FilePath]
mkExtraPath mbPath mingwPath | isWindows = mbDir ++ [mingwPath]
| otherwise = mbDir
where
mbDir = maybeToList . fmap takeDirectory $ mbPath
extraGccPath = mkExtraPath mbGccLocation windowsExtraGccDir
extraLdPath = mkExtraPath mbLdLocation windowsExtraLdDir
extraArPath = mkExtraPath mbArLocation windowsExtraArDir
extraStripPath = mkExtraPath mbStripLocation windowsExtraStripDir
(windowsExtraGccDir, windowsExtraLdDir,
windowsExtraArDir, windowsExtraStripDir) =
let b = mingwBinDir </> binPrefix
in (b, b, b, b)
findProg :: String -> [FilePath]
-> Verbosity -> ProgramSearchPath
-> IO (Maybe (FilePath, [FilePath]))
findProg progName extraPath v searchpath =
findProgramOnSearchPath v searchpath' progName
where
searchpath' = (map ProgramSearchPathDir extraPath) ++ searchpath
mbGccLocation = Map.lookup "C compiler command" ghcInfo
mbLdLocation = Map.lookup "ld command" ghcInfo
mbArLocation = Map.lookup "ar command" ghcInfo
mbStripLocation = Map.lookup "strip command" ghcInfo
ccFlags = getFlags "C compiler flags"
gccLinkerFlags = getFlags "Gcc Linker flags" ++ getFlags "C compiler link flags"
ldLinkerFlags = getFlags "Ld Linker flags" ++ getFlags "ld flags"
getFlags :: String -> [String]
getFlags key =
case Map.lookup key ghcInfo of
Nothing -> []
Just flags
| (flags', ""):_ <- reads flags -> flags'
| otherwise -> tokenizeQuotedWords flags
configureGcc :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
configureGcc _v gccProg = do
return gccProg {
programDefaultArgs = programDefaultArgs gccProg
++ ccFlags ++ gccLinkerFlags
}
configureLd :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
configureLd v ldProg = do
ldProg' <- configureLd' v ldProg
return ldProg' {
programDefaultArgs = programDefaultArgs ldProg' ++ ldLinkerFlags
}
configureLd' :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
configureLd' verbosity ldProg = do
tempDir <- getTemporaryDirectory
ldx <- withTempFile tempDir ".c" $ \testcfile testchnd ->
withTempFile tempDir ".o" $ \testofile testohnd -> do
hPutStrLn testchnd "int foo() { return 0; }"
hClose testchnd; hClose testohnd
runProgram verbosity ghcProg
[ "-hide-all-packages"
, "-c", testcfile
, "-o", testofile
]
withTempFile tempDir ".o" $ \testofile' testohnd' ->
do
hClose testohnd'
_ <- getProgramOutput verbosity ldProg
["-x", "-r", testofile, "-o", testofile']
return True
`catchIO` (\_ -> return False)
`catchExit` (\_ -> return False)
if ldx
then return ldProg { programDefaultArgs = ["-x"] }
else return ldProg
getLanguages :: Verbosity -> GhcImplInfo -> ConfiguredProgram
-> IO [(Language, String)]
getLanguages _ implInfo _
| supportsHaskell2010 implInfo = return [(Haskell98, "-XHaskell98")
,(Haskell2010, "-XHaskell2010")]
| otherwise = return [(Haskell98, "")]
getGhcInfo :: Verbosity -> GhcImplInfo -> ConfiguredProgram
-> IO [(String, String)]
getGhcInfo verbosity _implInfo ghcProg = do
xs <- getProgramOutput verbosity (suppressOverrideArgs ghcProg)
["--info"]
case reads xs of
[(i, ss)]
| all isSpace ss ->
return i
_ ->
die' verbosity "Can't parse --info output of GHC"
getExtensions :: Verbosity -> GhcImplInfo -> ConfiguredProgram
-> IO [(Extension, Maybe String)]
getExtensions verbosity implInfo ghcProg = do
str <- getProgramOutput verbosity (suppressOverrideArgs ghcProg)
["--supported-languages"]
let extStrs = if reportsNoExt implInfo
then lines str
else
[ extStr''
| extStr <- lines str
, let extStr' = case extStr of
'N' : 'o' : xs -> xs
_ -> "No" ++ extStr
, extStr'' <- [extStr, extStr']
]
let extensions0 = [ (ext, Just $ "-X" ++ prettyShow ext)
| Just ext <- map simpleParsec extStrs ]
extensions1 = if alwaysNondecIndent implInfo
then
(EnableExtension NondecreasingIndentation, Nothing) :
extensions0
else extensions0
return extensions1
componentCcGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo
-> BuildInfo -> ComponentLocalBuildInfo
-> FilePath -> FilePath
-> GhcOptions
componentCcGhcOptions verbosity _implInfo lbi bi clbi odir filename =
mempty {
ghcOptVerbosity = toFlag (min verbosity normal),
ghcOptMode = toFlag GhcModeCompile,
ghcOptInputFiles = toNubListR [filename],
ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi
,autogenPackageModulesDir lbi
,odir]
++ includeDirs bi
++ [buildDir lbi </> dir | dir <- includeDirs bi],
ghcOptHideAllPackages= toFlag True,
ghcOptPackageDBs = withPackageDB lbi,
ghcOptPackages = toNubListR $ mkGhcOptPackages clbi,
ghcOptCcOptions = (case withOptimization lbi of
NoOptimisation -> []
_ -> ["-O2"]) ++
(case withDebugInfo lbi of
NoDebugInfo -> []
MinimalDebugInfo -> ["-g1"]
NormalDebugInfo -> ["-g"]
MaximalDebugInfo -> ["-g3"]) ++
ccOptions bi,
ghcOptObjDir = toFlag odir
}
componentCxxGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo
-> BuildInfo -> ComponentLocalBuildInfo
-> FilePath -> FilePath
-> GhcOptions
componentCxxGhcOptions verbosity _implInfo lbi bi clbi odir filename =
mempty {
ghcOptVerbosity = toFlag (min verbosity normal),
ghcOptMode = toFlag GhcModeCompile,
ghcOptInputFiles = toNubListR [filename],
ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi
,autogenPackageModulesDir lbi
,odir]
++ includeDirs bi
++ [buildDir lbi </> dir | dir <- includeDirs bi],
ghcOptHideAllPackages= toFlag True,
ghcOptPackageDBs = withPackageDB lbi,
ghcOptPackages = toNubListR $ mkGhcOptPackages clbi,
ghcOptCxxOptions = (case withOptimization lbi of
NoOptimisation -> []
_ -> ["-O2"]) ++
(case withDebugInfo lbi of
NoDebugInfo -> []
MinimalDebugInfo -> ["-g1"]
NormalDebugInfo -> ["-g"]
MaximalDebugInfo -> ["-g3"]) ++
cxxOptions bi,
ghcOptObjDir = toFlag odir
}
componentAsmGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo
-> BuildInfo -> ComponentLocalBuildInfo
-> FilePath -> FilePath
-> GhcOptions
componentAsmGhcOptions verbosity _implInfo lbi bi clbi odir filename =
mempty {
ghcOptVerbosity = toFlag (min verbosity normal),
ghcOptMode = toFlag GhcModeCompile,
ghcOptInputFiles = toNubListR [filename],
ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi
,autogenPackageModulesDir lbi
,odir]
++ includeDirs bi
++ [buildDir lbi </> dir | dir <- includeDirs bi],
ghcOptHideAllPackages= toFlag True,
ghcOptPackageDBs = withPackageDB lbi,
ghcOptPackages = toNubListR $ mkGhcOptPackages clbi,
ghcOptAsmOptions = (case withOptimization lbi of
NoOptimisation -> []
_ -> ["-O2"]) ++
(case withDebugInfo lbi of
NoDebugInfo -> []
MinimalDebugInfo -> ["-g1"]
NormalDebugInfo -> ["-g"]
MaximalDebugInfo -> ["-g3"]) ++
asmOptions bi,
ghcOptObjDir = toFlag odir
}
componentGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo
-> BuildInfo -> ComponentLocalBuildInfo -> FilePath
-> GhcOptions
componentGhcOptions verbosity implInfo lbi bi clbi odir =
mempty {
ghcOptVerbosity = toFlag (min verbosity normal),
ghcOptCabal = toFlag True,
ghcOptThisUnitId = case clbi of
LibComponentLocalBuildInfo { componentCompatPackageKey = pk }
-> toFlag pk
_ -> mempty,
ghcOptThisComponentId = case clbi of
LibComponentLocalBuildInfo { componentComponentId = cid
, componentInstantiatedWith = insts } ->
if null insts
then mempty
else toFlag cid
_ -> mempty,
ghcOptInstantiatedWith = case clbi of
LibComponentLocalBuildInfo { componentInstantiatedWith = insts }
-> insts
_ -> [],
ghcOptNoCode = toFlag $ componentIsIndefinite clbi,
ghcOptHideAllPackages = toFlag True,
ghcOptWarnMissingHomeModules = toFlag $ flagWarnMissingHomeModules implInfo,
ghcOptPackageDBs = withPackageDB lbi,
ghcOptPackages = toNubListR $ mkGhcOptPackages clbi,
ghcOptSplitSections = toFlag (splitSections lbi),
ghcOptSplitObjs = toFlag (splitObjs lbi),
ghcOptSourcePathClear = toFlag True,
ghcOptSourcePath = toNubListR $ [odir] ++ (hsSourceDirs bi)
++ [autogenComponentModulesDir lbi clbi]
++ [autogenPackageModulesDir lbi],
ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi
,autogenPackageModulesDir lbi
,odir]
++ includeDirs bi
++ [buildDir lbi </> dir | dir <- includeDirs bi],
ghcOptCppOptions = cppOptions bi,
ghcOptCppIncludes = toNubListR $
[autogenComponentModulesDir lbi clbi </> cppHeaderName],
ghcOptFfiIncludes = toNubListR $ includes bi,
ghcOptObjDir = toFlag odir,
ghcOptHiDir = toFlag odir,
ghcOptStubDir = toFlag odir,
ghcOptOutputDir = toFlag odir,
ghcOptOptimisation = toGhcOptimisation (withOptimization lbi),
ghcOptDebugInfo = toFlag (withDebugInfo lbi),
ghcOptExtra = hcOptions GHC bi,
ghcOptExtraPath = toNubListR $ exe_paths,
ghcOptLanguage = toFlag (fromMaybe Haskell98 (defaultLanguage bi)),
ghcOptExtensions = toNubListR $ usedExtensions bi,
ghcOptExtensionMap = Map.fromList . compilerExtensions $ (compiler lbi)
}
where
exe_paths = [ componentBuildDir lbi (targetCLBI exe_tgt)
| uid <- componentExeDeps clbi
, Just exe_tgt <- [unitIdTarget' (localPkgDescr lbi) lbi uid] ]
toGhcOptimisation :: OptimisationLevel -> Flag GhcOptimisation
toGhcOptimisation NoOptimisation = mempty
toGhcOptimisation NormalOptimisation = toFlag GhcNormalOptimisation
toGhcOptimisation MaximumOptimisation = toFlag GhcMaximumOptimisation
componentCmmGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo
-> BuildInfo -> ComponentLocalBuildInfo
-> FilePath -> FilePath
-> GhcOptions
componentCmmGhcOptions verbosity _implInfo lbi bi clbi odir filename =
mempty {
ghcOptVerbosity = toFlag (min verbosity normal),
ghcOptMode = toFlag GhcModeCompile,
ghcOptInputFiles = toNubListR [filename],
ghcOptCppIncludePath = toNubListR $ [autogenComponentModulesDir lbi clbi
,autogenPackageModulesDir lbi
,odir]
++ includeDirs bi
++ [buildDir lbi </> dir | dir <- includeDirs bi],
ghcOptCppOptions = cppOptions bi,
ghcOptCppIncludes = toNubListR $
[autogenComponentModulesDir lbi clbi </> cppHeaderName],
ghcOptHideAllPackages= toFlag True,
ghcOptPackageDBs = withPackageDB lbi,
ghcOptPackages = toNubListR $ mkGhcOptPackages clbi,
ghcOptOptimisation = toGhcOptimisation (withOptimization lbi),
ghcOptDebugInfo = toFlag (withDebugInfo lbi),
ghcOptExtra = cmmOptions bi,
ghcOptObjDir = toFlag odir
}
filterGhciFlags :: [String] -> [String]
filterGhciFlags = filter supported
where
supported ('-':'O':_) = False
supported "-debug" = False
supported "-threaded" = False
supported "-ticky" = False
supported "-eventlog" = False
supported "-prof" = False
supported "-unreg" = False
supported _ = True
mkGHCiLibName :: UnitId -> String
mkGHCiLibName lib = getHSLibraryName lib <.> "o"
mkGHCiProfLibName :: UnitId -> String
mkGHCiProfLibName lib = getHSLibraryName lib <.> "p_o"
ghcLookupProperty :: String -> Compiler -> Bool
ghcLookupProperty prop comp =
case Map.lookup prop (compilerProperties comp) of
Just "YES" -> True
_ -> False
getHaskellObjects :: GhcImplInfo -> Library -> LocalBuildInfo
-> ComponentLocalBuildInfo
-> FilePath -> String -> Bool -> IO [FilePath]
getHaskellObjects _implInfo lib lbi clbi pref wanted_obj_ext allow_split_objs
| splitObjs lbi && allow_split_objs = do
let splitSuffix = "_" ++ wanted_obj_ext ++ "_split"
dirs = [ pref </> (ModuleName.toFilePath x ++ splitSuffix)
| x <- allLibModules lib clbi ]
objss <- traverse getDirectoryContents dirs
let objs = [ dir </> obj
| (objs',dir) <- zip objss dirs, obj <- objs',
let obj_ext = takeExtension obj,
'.':wanted_obj_ext == obj_ext ]
return objs
| otherwise =
return [ pref </> ModuleName.toFilePath x <.> wanted_obj_ext
| x <- allLibModules lib clbi ]
mkGhcOptPackages :: ComponentLocalBuildInfo
-> [(OpenUnitId, ModuleRenaming)]
mkGhcOptPackages = componentIncludes
substTopDir :: FilePath -> IPI.InstalledPackageInfo -> IPI.InstalledPackageInfo
substTopDir topDir ipo
= ipo {
IPI.importDirs = map f (IPI.importDirs ipo),
IPI.libraryDirs = map f (IPI.libraryDirs ipo),
IPI.includeDirs = map f (IPI.includeDirs ipo),
IPI.frameworkDirs = map f (IPI.frameworkDirs ipo),
IPI.haddockInterfaces = map f (IPI.haddockInterfaces ipo),
IPI.haddockHTMLs = map f (IPI.haddockHTMLs ipo)
}
where f ('$':'t':'o':'p':'d':'i':'r':rest) = topDir ++ rest
f x = x
checkPackageDbEnvVar :: Verbosity -> String -> String -> IO ()
checkPackageDbEnvVar verbosity compilerName packagePathEnvVar = do
mPP <- lookupEnv packagePathEnvVar
when (isJust mPP) $ do
mcsPP <- lookupEnv "CABAL_SANDBOX_PACKAGE_PATH"
unless (mPP == mcsPP) abort
where
lookupEnv :: String -> IO (Maybe String)
lookupEnv name = (Just `fmap` getEnv name)
`catchIO` const (return Nothing)
abort =
die' verbosity $ "Use of " ++ compilerName ++ "'s environment variable "
++ packagePathEnvVar ++ " is incompatible with Cabal. Use the "
++ "flag --package-db to specify a package database (it can be "
++ "used multiple times)."
_ = callStack
profDetailLevelFlag :: Bool -> ProfDetailLevel -> Flag GhcProfAuto
profDetailLevelFlag forLib mpl =
case mpl of
ProfDetailNone -> mempty
ProfDetailDefault | forLib -> toFlag GhcProfAutoExported
| otherwise -> toFlag GhcProfAutoToplevel
ProfDetailExportedFunctions -> toFlag GhcProfAutoExported
ProfDetailToplevelFunctions -> toFlag GhcProfAutoToplevel
ProfDetailAllFunctions -> toFlag GhcProfAutoAll
ProfDetailOther _ -> mempty
ghcArchString :: Arch -> String
ghcArchString PPC = "powerpc"
ghcArchString PPC64 = "powerpc64"
ghcArchString other = prettyShow other
ghcOsString :: OS -> String
ghcOsString Windows = "mingw32"
ghcOsString OSX = "darwin"
ghcOsString Solaris = "solaris2"
ghcOsString other = prettyShow other
ghcPlatformAndVersionString :: Platform -> Version -> String
ghcPlatformAndVersionString (Platform arch os) version =
intercalate "-" [ ghcArchString arch, ghcOsString os, prettyShow version ]
data GhcEnvironmentFileEntry =
GhcEnvFileComment String
| GhcEnvFilePackageId UnitId
| GhcEnvFilePackageDb PackageDB
| GhcEnvFileClearPackageDbStack
deriving (Eq, Ord, Show)
simpleGhcEnvironmentFile :: PackageDBStack
-> [UnitId]
-> [GhcEnvironmentFileEntry]
simpleGhcEnvironmentFile packageDBs pkgids =
GhcEnvFileClearPackageDbStack
: map GhcEnvFilePackageDb packageDBs
++ map GhcEnvFilePackageId pkgids
writeGhcEnvironmentFile :: FilePath
-> Platform
-> Version
-> [GhcEnvironmentFileEntry]
-> IO FilePath
writeGhcEnvironmentFile directory platform ghcversion entries = do
writeFileAtomic envfile . BS.pack . renderGhcEnvironmentFile $ entries
return envfile
where
envfile = directory </> ghcEnvironmentFileName platform ghcversion
ghcEnvironmentFileName :: Platform -> Version -> FilePath
ghcEnvironmentFileName platform ghcversion =
".ghc.environment." ++ ghcPlatformAndVersionString platform ghcversion
renderGhcEnvironmentFile :: [GhcEnvironmentFileEntry] -> String
renderGhcEnvironmentFile =
unlines . map renderGhcEnvironmentFileEntry
renderGhcEnvironmentFileEntry :: GhcEnvironmentFileEntry -> String
renderGhcEnvironmentFileEntry entry = case entry of
GhcEnvFileComment comment -> format comment
where format = intercalate "\n" . map ("--" <++>) . lines
pref <++> "" = pref
pref <++> str = pref ++ " " ++ str
GhcEnvFilePackageId pkgid -> "package-id " ++ prettyShow pkgid
GhcEnvFilePackageDb pkgdb ->
case pkgdb of
GlobalPackageDB -> "global-package-db"
UserPackageDB -> "user-package-db"
SpecificPackageDB dbfile -> "package-db " ++ dbfile
GhcEnvFileClearPackageDbStack -> "clear-package-db"