{-# LANGUAGE CPP #-}
module Distribution.Simple.GHC.Internal (
configureToolchain,
getLanguages,
getExtensions,
targetPlatform,
getGhcInfo,
componentCcGhcOptions,
componentGhcOptions,
mkGHCiLibName,
filterGhciFlags,
ghcLookupProperty,
getHaskellObjects,
mkGhcOptPackages,
substTopDir,
checkPackageDbEnvVar
) where
import Distribution.Simple.GHC.ImplInfo ( GhcImplInfo (..) )
import Distribution.Package
( InstalledPackageId, PackageId )
import Distribution.InstalledPackageInfo
( InstalledPackageInfo )
import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo
( InstalledPackageInfo_(..) )
import Distribution.PackageDescription as PD
( BuildInfo(..), Library(..), libModules
, hcOptions, usedExtensions, ModuleRenaming, lookupRenaming )
import Distribution.Compat.Exception ( catchExit, catchIO )
import Distribution.Simple.Compiler
( CompilerFlavor(..), Compiler(..), DebugInfoLevel(..), OptimisationLevel(..) )
import Distribution.Simple.Program.GHC
import Distribution.Simple.Setup
( toFlag )
import qualified Distribution.ModuleName as ModuleName
import Distribution.Simple.Program
( Program(..), ConfiguredProgram(..), ProgramConfiguration
, ProgramLocation(..), ProgramSearchPath, ProgramSearchPathEntry(..)
, rawSystemProgram, rawSystemProgramStdout, programPath
, addKnownProgram, arProgram, ldProgram, gccProgram, stripProgram
, getProgramOutput )
import Distribution.Simple.Program.Types ( suppressOverrideArgs )
import Distribution.Simple.LocalBuildInfo
( LocalBuildInfo(..), ComponentLocalBuildInfo(..)
, LibraryName(..) )
import Distribution.Simple.Utils
import Distribution.Simple.BuildPaths
import Distribution.System ( buildOS, OS(..), Platform, platformFromTriple )
import Distribution.Text ( display, simpleParse )
import Distribution.Utils.NubList ( toNubListR )
import Distribution.Verbosity
import Language.Haskell.Extension
( Language(..), Extension(..), KnownExtension(..) )
import qualified Data.Map as M
import Data.Char ( isSpace )
import Data.Maybe ( fromMaybe, maybeToList, isJust )
import Control.Monad ( unless, when )
#if __GLASGOW_HASKELL__ < 710
import Data.Monoid ( Monoid(..) )
#endif
import System.Directory ( getDirectoryContents, getTemporaryDirectory )
import System.Environment ( getEnv )
import System.FilePath ( (</>), (<.>), takeExtension, takeDirectory )
import System.IO ( hClose, hPutStrLn )
targetPlatform :: [(String, String)] -> Maybe Platform
targetPlatform ghcInfo = platformFromTriple =<< lookup "Target platform" ghcInfo
configureToolchain :: GhcImplInfo
-> ConfiguredProgram
-> M.Map String String
-> ProgramConfiguration
-> ProgramConfiguration
configureToolchain implInfo ghcProg ghcInfo =
addKnownProgram gccProgram {
programFindLocation = findProg gccProgram extraGccPath,
programPostConf = configureGcc
}
. addKnownProgram ldProgram {
programFindLocation = findProg ldProgram extraLdPath,
programPostConf = configureLd
}
. addKnownProgram arProgram {
programFindLocation = findProg arProgram extraArPath
}
. addKnownProgram stripProgram {
programFindLocation = findProg stripProgram extraStripPath
}
where
compilerDir = takeDirectory (programPath ghcProg)
baseDir = takeDirectory compilerDir
mingwBinDir = baseDir </> "mingw" </> "bin"
libDir = baseDir </> "gcc-lib"
includeDir = baseDir </> "include" </> "mingw"
isWindows = case buildOS of Windows -> True; _ -> False
binPrefix = ""
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)
| separateGccMingw implInfo = (baseDir, libDir, libDir, libDir)
| otherwise =
let b = mingwBinDir </> binPrefix
in (b, b, b, b)
findProg :: Program -> [FilePath]
-> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath)
findProg prog extraPath v searchpath =
programFindLocation prog v searchpath'
where
searchpath' = (map ProgramSearchPathDir extraPath) ++ searchpath
mbGccLocation = M.lookup "C compiler command" ghcInfo
mbLdLocation = M.lookup "ld command" ghcInfo
mbArLocation = M.lookup "ar command" ghcInfo
mbStripLocation = M.lookup "strip command" ghcInfo
ccFlags = getFlags "C compiler flags"
gccLinkerFlags = getFlags "Gcc Linker flags"
ldLinkerFlags = getFlags "Ld Linker flags"
getFlags key = case M.lookup key ghcInfo of
Nothing -> []
Just flags ->
case reads flags of
[(args, "")] -> args
_ -> []
configureGcc :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
configureGcc v gccProg = do
gccProg' <- configureGcc' v gccProg
return gccProg' {
programDefaultArgs = programDefaultArgs gccProg'
++ ccFlags ++ gccLinkerFlags
}
configureGcc' :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
configureGcc'
| isWindows = \_ gccProg -> case programLocation gccProg of
FoundOnSystem {}
| separateGccMingw implInfo ->
return gccProg { programDefaultArgs = ["-B" ++ libDir,
"-I" ++ includeDir] }
_ -> return gccProg
| otherwise = \_ gccProg -> return gccProg
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
rawSystemProgram verbosity ghcProg ["-c", testcfile,
"-o", testofile]
withTempFile tempDir ".o" $ \testofile' testohnd' ->
do
hClose testohnd'
_ <- rawSystemProgramStdout 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
| flagInfoLanguages implInfo = do
xs <- getProgramOutput verbosity (suppressOverrideArgs ghcProg)
["--info"]
case reads xs of
[(i, ss)]
| all isSpace ss ->
return i
_ ->
die "Can't parse --info output of GHC"
| otherwise =
return []
getExtensions :: Verbosity -> GhcImplInfo -> ConfiguredProgram
-> IO [(Extension, String)]
getExtensions verbosity implInfo ghcProg
| flagInfoLanguages implInfo = 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, "-X" ++ display ext)
| Just ext <- map simpleParse extStrs ]
extensions1 = if fakeRecordPuns implInfo
then
(EnableExtension NamedFieldPuns, "-XRecordPuns") :
(DisableExtension NamedFieldPuns, "-XNoRecordPuns") :
extensions0
else extensions0
extensions2 = if alwaysNondecIndent implInfo
then
(EnableExtension NondecreasingIndentation, "") :
(DisableExtension NondecreasingIndentation, "") :
extensions1
else extensions1
return extensions2
| otherwise = return oldLanguageExtensions
oldLanguageExtensions :: [(Extension, String)]
oldLanguageExtensions =
let doFlag (f, (enable, disable)) = [(EnableExtension f, enable),
(DisableExtension f, disable)]
fglasgowExts = ("-fglasgow-exts",
"")
fFlag flag = ("-f" ++ flag, "-fno-" ++ flag)
in concatMap doFlag
[(OverlappingInstances , fFlag "allow-overlapping-instances")
,(TypeSynonymInstances , fglasgowExts)
,(TemplateHaskell , fFlag "th")
,(ForeignFunctionInterface , fFlag "ffi")
,(MonomorphismRestriction , fFlag "monomorphism-restriction")
,(MonoPatBinds , fFlag "mono-pat-binds")
,(UndecidableInstances , fFlag "allow-undecidable-instances")
,(IncoherentInstances , fFlag "allow-incoherent-instances")
,(Arrows , fFlag "arrows")
,(Generics , fFlag "generics")
,(ImplicitPrelude , fFlag "implicit-prelude")
,(ImplicitParams , fFlag "implicit-params")
,(CPP , ("-cpp", ""))
,(BangPatterns , fFlag "bang-patterns")
,(KindSignatures , fglasgowExts)
,(RecursiveDo , fglasgowExts)
,(ParallelListComp , fglasgowExts)
,(MultiParamTypeClasses , fglasgowExts)
,(FunctionalDependencies , fglasgowExts)
,(Rank2Types , fglasgowExts)
,(RankNTypes , fglasgowExts)
,(PolymorphicComponents , fglasgowExts)
,(ExistentialQuantification , fglasgowExts)
,(ScopedTypeVariables , fFlag "scoped-type-variables")
,(FlexibleContexts , fglasgowExts)
,(FlexibleInstances , fglasgowExts)
,(EmptyDataDecls , fglasgowExts)
,(PatternGuards , fglasgowExts)
,(GeneralizedNewtypeDeriving , fglasgowExts)
,(MagicHash , fglasgowExts)
,(UnicodeSyntax , fglasgowExts)
,(PatternSignatures , fglasgowExts)
,(UnliftedFFITypes , fglasgowExts)
,(LiberalTypeSynonyms , fglasgowExts)
,(TypeOperators , fglasgowExts)
,(GADTs , fglasgowExts)
,(RelaxedPolyRec , fglasgowExts)
,(ExtendedDefaultRules , fFlag "extended-default-rules")
,(UnboxedTuples , fglasgowExts)
,(DeriveDataTypeable , fglasgowExts)
,(ConstrainedClassMethods , fglasgowExts)
]
componentCcGhcOptions :: Verbosity -> GhcImplInfo -> LocalBuildInfo
-> BuildInfo -> ComponentLocalBuildInfo
-> FilePath -> FilePath
-> GhcOptions
componentCcGhcOptions verbosity implInfo lbi bi clbi pref filename =
mempty {
ghcOptVerbosity = toFlag verbosity,
ghcOptMode = toFlag GhcModeCompile,
ghcOptInputFiles = toNubListR [filename],
ghcOptCppIncludePath = toNubListR $ [autogenModulesDir lbi, odir]
++ PD.includeDirs bi,
ghcOptPackageDBs = withPackageDB lbi,
ghcOptPackages = toNubListR $ mkGhcOptPackages clbi,
ghcOptCcOptions = toNubListR $
(case withOptimization lbi of
NoOptimisation -> []
_ -> ["-O2"]) ++
(case withDebugInfo lbi of
NoDebugInfo -> []
MinimalDebugInfo -> ["-g1"]
NormalDebugInfo -> ["-g"]
MaximalDebugInfo -> ["-g3"]) ++
PD.ccOptions bi,
ghcOptObjDir = toFlag odir
}
where
odir | hasCcOdirBug implInfo = pref </> takeDirectory filename
| otherwise = pref
componentGhcOptions :: Verbosity -> LocalBuildInfo
-> BuildInfo -> ComponentLocalBuildInfo -> FilePath
-> GhcOptions
componentGhcOptions verbosity lbi bi clbi odir =
mempty {
ghcOptVerbosity = toFlag verbosity,
ghcOptHideAllPackages = toFlag True,
ghcOptCabal = toFlag True,
ghcOptPackageDBs = withPackageDB lbi,
ghcOptPackages = toNubListR $ mkGhcOptPackages clbi,
ghcOptSplitObjs = toFlag (splitObjs lbi),
ghcOptSourcePathClear = toFlag True,
ghcOptSourcePath = toNubListR $ [odir] ++ (hsSourceDirs bi)
++ [autogenModulesDir lbi],
ghcOptCppIncludePath = toNubListR $ [autogenModulesDir lbi, odir]
++ PD.includeDirs bi,
ghcOptCppOptions = toNubListR $ cppOptions bi,
ghcOptCppIncludes = toNubListR $
[autogenModulesDir lbi </> cppHeaderName],
ghcOptFfiIncludes = toNubListR $ PD.includes bi,
ghcOptObjDir = toFlag odir,
ghcOptHiDir = toFlag odir,
ghcOptStubDir = toFlag odir,
ghcOptOutputDir = toFlag odir,
ghcOptOptimisation = toGhcOptimisation (withOptimization lbi),
ghcOptDebugInfo = toGhcDebugInfo (withDebugInfo lbi),
ghcOptExtra = toNubListR $ hcOptions GHC bi,
ghcOptLanguage = toFlag (fromMaybe Haskell98 (defaultLanguage bi)),
ghcOptExtensions = toNubListR $ usedExtensions bi,
ghcOptExtensionMap = M.fromList . compilerExtensions $ (compiler lbi)
}
where
toGhcOptimisation NoOptimisation = mempty
toGhcOptimisation NormalOptimisation = toFlag GhcNormalOptimisation
toGhcOptimisation MaximumOptimisation = toFlag GhcMaximumOptimisation
toGhcDebugInfo NoDebugInfo = mempty
toGhcDebugInfo MinimalDebugInfo = toFlag True
toGhcDebugInfo NormalDebugInfo = toFlag True
toGhcDebugInfo MaximalDebugInfo = toFlag True
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 :: LibraryName -> String
mkGHCiLibName (LibraryName lib) = lib <.> "o"
ghcLookupProperty :: String -> Compiler -> Bool
ghcLookupProperty prop comp =
case M.lookup prop (compilerProperties comp) of
Just "YES" -> True
_ -> False
getHaskellObjects :: GhcImplInfo -> Library -> LocalBuildInfo
-> FilePath -> String -> Bool -> IO [FilePath]
getHaskellObjects implInfo lib lbi pref wanted_obj_ext allow_split_objs
| splitObjs lbi && allow_split_objs = do
let splitSuffix = if noExtInSplitSuffix implInfo
then "_split"
else "_" ++ wanted_obj_ext ++ "_split"
dirs = [ pref </> (ModuleName.toFilePath x ++ splitSuffix)
| x <- libModules lib ]
objss <- mapM 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 <- libModules lib ]
mkGhcOptPackages :: ComponentLocalBuildInfo
-> [(InstalledPackageId, PackageId, ModuleRenaming)]
mkGhcOptPackages clbi =
map (\(i,p) -> (i,p,lookupRenaming p (componentPackageRenaming clbi)))
(componentPackageDeps clbi)
substTopDir :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo
substTopDir topDir ipo
= ipo {
InstalledPackageInfo.importDirs
= map f (InstalledPackageInfo.importDirs ipo),
InstalledPackageInfo.libraryDirs
= map f (InstalledPackageInfo.libraryDirs ipo),
InstalledPackageInfo.includeDirs
= map f (InstalledPackageInfo.includeDirs ipo),
InstalledPackageInfo.frameworkDirs
= map f (InstalledPackageInfo.frameworkDirs ipo),
InstalledPackageInfo.haddockInterfaces
= map f (InstalledPackageInfo.haddockInterfaces ipo),
InstalledPackageInfo.haddockHTMLs
= map f (InstalledPackageInfo.haddockHTMLs ipo)
}
where f ('$':'t':'o':'p':'d':'i':'r':rest) = topDir ++ rest
f x = x
checkPackageDbEnvVar :: String -> String -> IO ()
checkPackageDbEnvVar 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 $ "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)."