Cabal/src/Distribution/Simple/GHC/Internal.hs

   1 {-# LANGUAGE DataKinds #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE RankNTypes #-}
   4
   5 -----------------------------------------------------------------------------
   6
   7 -- |
   8 -- Module      :  Distribution.Simple.GHC.Internal
   9 -- Copyright   :  Isaac Jones 2003-2007
  10 --
  11 -- Maintainer  :  cabal-devel@haskell.org
  12 -- Portability :  portable
  13 --
  14 -- This module contains functions shared by GHC (Distribution.Simple.GHC)
  15 -- and GHC-derived compilers.
  16 module Distribution.Simple.GHC.Internal
  17   ( configureToolchain
  18   , getLanguages
  19   , getExtensions
  20   , targetPlatform
  21   , getGhcInfo
  22   , componentCcGhcOptions
  23   , componentCmmGhcOptions
  24   , componentCxxGhcOptions
  25   , componentAsmGhcOptions
  26   , componentJsGhcOptions
  27   , componentGhcOptions
  28   , mkGHCiLibName
  29   , mkGHCiProfLibName
  30   , filterGhciFlags
  31   , ghcLookupProperty
  32   , getHaskellObjects
  33   , mkGhcOptPackages
  34   , substTopDir
  35   , checkPackageDbEnvVar
  36   , profDetailLevelFlag
  37
  38     -- * GHC platform and version strings
  39   , ghcArchString
  40   , ghcOsString
  41   , ghcPlatformAndVersionString
  42
  43     -- * Constructing GHC environment files
  44   , GhcEnvironmentFileEntry (..)
  45   , writeGhcEnvironmentFile
  46   , simpleGhcEnvironmentFile
  47   , ghcEnvironmentFileName
  48   , renderGhcEnvironmentFile
  49   , renderGhcEnvironmentFileEntry
  50   ) where
  51
  52 import Distribution.Compat.Prelude
  53 import Prelude ()
  54
  55 import Data.Bool (bool)
  56 import qualified Data.ByteString.Lazy.Char8 as BS
  57 import qualified Data.Map as Map
  58 import qualified Data.Set as Set
  59 import Distribution.Backpack
  60 import Distribution.Compat.Stack
  61 import qualified Distribution.InstalledPackageInfo as IPI
  62 import Distribution.Lex
  63 import qualified Distribution.ModuleName as ModuleName
  64 import Distribution.PackageDescription
  65 import Distribution.Parsec (simpleParsec)
  66 import Distribution.Pretty (prettyShow)
  67 import Distribution.Simple.BuildPaths
  68 import Distribution.Simple.Compiler
  69 import Distribution.Simple.Errors
  70 import Distribution.Simple.Flag (Flag (NoFlag), maybeToFlag, toFlag)
  71 import Distribution.Simple.GHC.ImplInfo
  72 import Distribution.Simple.LocalBuildInfo
  73 import Distribution.Simple.Program
  74 import Distribution.Simple.Program.GHC
  75 import Distribution.Simple.Setup.Common (extraCompilationArtifacts)
  76 import Distribution.Simple.Utils
  77 import Distribution.System
  78 import Distribution.Types.ComponentLocalBuildInfo
  79 import Distribution.Types.GivenComponent
  80 import Distribution.Types.LocalBuildInfo
  81 import Distribution.Types.TargetInfo
  82 import Distribution.Types.UnitId
  83 import Distribution.Utils.NubList (NubListR, toNubListR)
  84 import Distribution.Utils.Path
  85 import Distribution.Verbosity
  86 import Distribution.Version (Version)
  87 import Language.Haskell.Extension
  88 import System.Directory (getDirectoryContents)
  89 import System.Environment (getEnv)
  90 import System.FilePath
  91   ( takeDirectory
  92   , takeExtension
  93   , takeFileName
  94   )
  95 import System.IO (hClose, hPutStrLn)
  96
  97 targetPlatform :: [(String, String)] -> Maybe Platform
  98 targetPlatform ghcInfo = platformFromTriple =<< lookup "Target platform" ghcInfo
  99
 100 -- | Adjust the way we find and configure gcc and ld
 101 configureToolchain
 102   :: GhcImplInfo
 103   -> ConfiguredProgram
 104   -> Map String String
 105   -> ProgramDb
 106   -> ProgramDb
 107 configureToolchain _implInfo ghcProg ghcInfo =
 108   addKnownProgram
 109     gccProgram
 110       { programFindLocation = findProg gccProgramName extraGccPath
 111       , programPostConf = configureGcc
 112       }
 113     . addKnownProgram
 114       ldProgram
 115         { programFindLocation = findProg ldProgramName extraLdPath
 116         , programPostConf = \v cp ->
 117             -- Call any existing configuration first and then add any new configuration
 118             configureLd v =<< programPostConf ldProgram v cp
 119         }
 120     . addKnownProgram
 121       arProgram
 122         { programFindLocation = findProg arProgramName extraArPath
 123         }
 124     . addKnownProgram
 125       stripProgram
 126         { programFindLocation = findProg stripProgramName extraStripPath
 127         }
 128   where
 129     compilerDir, base_dir, mingwBinDir :: FilePath
 130     compilerDir = takeDirectory (programPath ghcProg)
 131     base_dir = takeDirectory compilerDir
 132     mingwBinDir = base_dir </> "mingw" </> "bin"
 133     isWindows = case buildOS of Windows -> True; _ -> False
 134     binPrefix = ""
 135
 136     maybeName :: Program -> Maybe FilePath -> String
 137     maybeName prog = maybe (programName prog) (dropExeExtension . takeFileName)
 138
 139     gccProgramName = maybeName gccProgram mbGccLocation
 140     ldProgramName = maybeName ldProgram mbLdLocation
 141     arProgramName = maybeName arProgram mbArLocation
 142     stripProgramName = maybeName stripProgram mbStripLocation
 143
 144     mkExtraPath :: Maybe FilePath -> FilePath -> [FilePath]
 145     mkExtraPath mbPath mingwPath
 146       | isWindows = mbDir ++ [mingwPath]
 147       | otherwise = mbDir
 148       where
 149         mbDir = maybeToList . fmap takeDirectory $ mbPath
 150
 151     extraGccPath = mkExtraPath mbGccLocation windowsExtraGccDir
 152     extraLdPath = mkExtraPath mbLdLocation windowsExtraLdDir
 153     extraArPath = mkExtraPath mbArLocation windowsExtraArDir
 154     extraStripPath = mkExtraPath mbStripLocation windowsExtraStripDir
 155
 156     -- on Windows finding and configuring ghc's gcc & binutils is a bit special
 157     ( windowsExtraGccDir
 158       , windowsExtraLdDir
 159       , windowsExtraArDir
 160       , windowsExtraStripDir
 161       ) =
 162         let b = mingwBinDir </> binPrefix
 163          in (b, b, b, b)
 164
 165     findProg
 166       :: String
 167       -> [FilePath]
 168       -> Verbosity
 169       -> ProgramSearchPath
 170       -> IO (Maybe (FilePath, [FilePath]))
 171     findProg progName extraPath v searchpath =
 172       findProgramOnSearchPath v searchpath' progName
 173       where
 174         searchpath' = (map ProgramSearchPathDir extraPath) ++ searchpath
 175
 176     -- Read tool locations from the 'ghc --info' output. Useful when
 177     -- cross-compiling.
 178     mbGccLocation = Map.lookup "C compiler command" ghcInfo
 179     mbLdLocation = Map.lookup "ld command" ghcInfo
 180     mbArLocation = Map.lookup "ar command" ghcInfo
 181     mbStripLocation = Map.lookup "strip command" ghcInfo
 182
 183     ccFlags = getFlags "C compiler flags"
 184     -- GHC 7.8 renamed "Gcc Linker flags" to "C compiler link flags"
 185     -- and "Ld Linker flags" to "ld flags" (GHC #4862).
 186     gccLinkerFlags = getFlags "Gcc Linker flags" ++ getFlags "C compiler link flags"
 187     ldLinkerFlags = getFlags "Ld Linker flags" ++ getFlags "ld flags"
 188
 189     -- It appears that GHC 7.6 and earlier encode the tokenized flags as a
 190     -- [String] in these settings whereas later versions just encode the flags as
 191     -- String.
 192     --
 193     -- We first try to parse as a [String] and if this fails then tokenize the
 194     -- flags ourself.
 195     getFlags :: String -> [String]
 196     getFlags key =
 197       case Map.lookup key ghcInfo of
 198         Nothing -> []
 199         Just flags
 200           | (flags', "") : _ <- reads flags -> flags'
 201           | otherwise -> tokenizeQuotedWords flags
 202
 203     configureGcc :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
 204     configureGcc _v gccProg = do
 205       return
 206         gccProg
 207           { programDefaultArgs =
 208               programDefaultArgs gccProg
 209                 ++ ccFlags
 210                 ++ gccLinkerFlags
 211           }
 212
 213     configureLd :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
 214     configureLd v ldProg = do
 215       ldProg' <- configureLd' v ldProg
 216       return
 217         ldProg'
 218           { programDefaultArgs = programDefaultArgs ldProg' ++ ldLinkerFlags
 219           }
 220
 221     -- we need to find out if ld supports the -x flag
 222     configureLd' :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
 223     configureLd' verbosity ldProg = do
 224       ldx <- withTempFile ".c" $ \testcfile testchnd ->
 225         withTempFile ".o" $ \testofile testohnd -> do
 226           hPutStrLn testchnd "int foo() { return 0; }"
 227           hClose testchnd
 228           hClose testohnd
 229           runProgram
 230             verbosity
 231             ghcProg
 232             [ "-hide-all-packages"
 233             , "-c"
 234             , testcfile
 235             , "-o"
 236             , testofile
 237             ]
 238           withTempFile ".o" $ \testofile' testohnd' ->
 239             do
 240               hClose testohnd'
 241               _ <-
 242                 getProgramOutput
 243                   verbosity
 244                   ldProg
 245                   ["-x", "-r", testofile, "-o", testofile']
 246               return True
 247               `catchIO` (\_ -> return False)
 248               `catchExit` (\_ -> return False)
 249       if ldx
 250         then return ldProg{programDefaultArgs = ["-x"]}
 251         else return ldProg
 252
 253 getLanguages
 254   :: Verbosity
 255   -> GhcImplInfo
 256   -> ConfiguredProgram
 257   -> IO [(Language, String)]
 258 getLanguages _ implInfo _
 259   -- TODO: should be using --supported-languages rather than hard coding
 260   | supportsGHC2024 implInfo =
 261       return
 262         [ (GHC2024, "-XGHC2024")
 263         , (GHC2021, "-XGHC2021")
 264         , (Haskell2010, "-XHaskell2010")
 265         , (Haskell98, "-XHaskell98")
 266         ]
 267   | supportsGHC2021 implInfo =
 268       return
 269         [ (GHC2021, "-XGHC2021")
 270         , (Haskell2010, "-XHaskell2010")
 271         , (Haskell98, "-XHaskell98")
 272         ]
 273   | supportsHaskell2010 implInfo =
 274       return
 275         [ (Haskell98, "-XHaskell98")
 276         , (Haskell2010, "-XHaskell2010")
 277         ]
 278   | otherwise = return [(Haskell98, "")]
 279
 280 getGhcInfo
 281   :: Verbosity
 282   -> GhcImplInfo
 283   -> ConfiguredProgram
 284   -> IO [(String, String)]
 285 getGhcInfo verbosity _implInfo ghcProg = do
 286   xs <-
 287     getProgramOutput
 288       verbosity
 289       (suppressOverrideArgs ghcProg)
 290       ["--info"]
 291   case reads xs of
 292     [(i, ss)]
 293       | all isSpace ss ->
 294           return i
 295     _ ->
 296       dieWithException verbosity CantParseGHCOutput
 297
 298 getExtensions
 299   :: Verbosity
 300   -> GhcImplInfo
 301   -> ConfiguredProgram
 302   -> IO [(Extension, Maybe String)]
 303 getExtensions verbosity implInfo ghcProg = do
 304   str <-
 305     getProgramOutput
 306       verbosity
 307       (suppressOverrideArgs ghcProg)
 308       ["--supported-languages"]
 309   let extStrs =
 310         if reportsNoExt implInfo
 311           then lines str
 312           else -- Older GHCs only gave us either Foo or NoFoo,
 313           -- so we have to work out the other one ourselves
 314
 315             [ extStr''
 316             | extStr <- lines str
 317             , let extStr' = case extStr of
 318                     'N' : 'o' : xs -> xs
 319                     _ -> "No" ++ extStr
 320             , extStr'' <- [extStr, extStr']
 321             ]
 322   let extensions0 =
 323         [ (ext, Just $ "-X" ++ prettyShow ext)
 324         | Just ext <- map simpleParsec extStrs
 325         ]
 326       extensions1 =
 327         if alwaysNondecIndent implInfo
 328           then -- ghc-7.2 split NondecreasingIndentation off
 329           -- into a proper extension. Before that it
 330           -- was always on.
 331           -- Since it was not a proper extension, it could
 332           -- not be turned off, hence we omit a
 333           -- DisableExtension entry here.
 334
 335             (EnableExtension NondecreasingIndentation, Nothing)
 336               : extensions0
 337           else extensions0
 338   return extensions1
 339
 340 includePaths
 341   :: LocalBuildInfo
 342   -> BuildInfo
 343   -> ComponentLocalBuildInfo
 344   -> SymbolicPath Pkg p
 345   -> NubListR (SymbolicPath Pkg (Dir Include))
 346 includePaths lbi bi clbi odir =
 347   toNubListR $
 348     [ coerceSymbolicPath $ autogenComponentModulesDir lbi clbi
 349     , coerceSymbolicPath $ autogenPackageModulesDir lbi
 350     , coerceSymbolicPath odir
 351     ]
 352       -- includes relative to the package
 353       ++ includeDirs bi
 354       -- potential includes generated by `configure'
 355       -- in the build directory
 356       ++ [ buildDir lbi </> dir
 357          | dir <- mapMaybe (symbolicPathRelative_maybe . unsafeCoerceSymbolicPath) $ includeDirs bi
 358          ]
 359
 360 componentCcGhcOptions
 361   :: Verbosity
 362   -> LocalBuildInfo
 363   -> BuildInfo
 364   -> ComponentLocalBuildInfo
 365   -> SymbolicPath Pkg (Dir Artifacts)
 366   -> SymbolicPath Pkg File
 367   -> GhcOptions
 368 componentCcGhcOptions verbosity lbi bi clbi odir filename =
 369   mempty
 370     { -- Respect -v0, but don't crank up verbosity on GHC if
 371       -- Cabal verbosity is requested. For that, use --ghc-option=-v instead!
 372       ghcOptVerbosity = toFlag (min verbosity normal)
 373     , ghcOptMode = toFlag GhcModeCompile
 374     , ghcOptInputFiles = toNubListR [filename]
 375     , ghcOptCppIncludePath = includePaths lbi bi clbi odir
 376     , ghcOptHideAllPackages = toFlag True
 377     , ghcOptPackageDBs = withPackageDB lbi
 378     , ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi
 379     , ghcOptCcOptions =
 380         ( case withOptimization lbi of
 381             NoOptimisation -> []
 382             _ -> ["-O2"]
 383         )
 384           ++ ( case withDebugInfo lbi of
 385                 NoDebugInfo -> []
 386                 MinimalDebugInfo -> ["-g1"]
 387                 NormalDebugInfo -> ["-g"]
 388                 MaximalDebugInfo -> ["-g3"]
 389              )
 390           ++ ccOptions bi
 391     , ghcOptCcProgram =
 392         maybeToFlag $
 393           programPath
 394             <$> lookupProgram gccProgram (withPrograms lbi)
 395     , ghcOptObjDir = toFlag odir
 396     , ghcOptExtra = hcOptions GHC bi
 397     }
 398
 399 componentCxxGhcOptions
 400   :: Verbosity
 401   -> LocalBuildInfo
 402   -> BuildInfo
 403   -> ComponentLocalBuildInfo
 404   -> SymbolicPath Pkg (Dir Artifacts)
 405   -> SymbolicPath Pkg File
 406   -> GhcOptions
 407 componentCxxGhcOptions verbosity lbi bi clbi odir filename =
 408   mempty
 409     { -- Respect -v0, but don't crank up verbosity on GHC if
 410       -- Cabal verbosity is requested. For that, use --ghc-option=-v instead!
 411       ghcOptVerbosity = toFlag (min verbosity normal)
 412     , ghcOptMode = toFlag GhcModeCompile
 413     , ghcOptInputFiles = toNubListR [filename]
 414     , ghcOptCppIncludePath = includePaths lbi bi clbi odir
 415     , ghcOptHideAllPackages = toFlag True
 416     , ghcOptPackageDBs = withPackageDB lbi
 417     , ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi
 418     , ghcOptCxxOptions =
 419         ( case withOptimization lbi of
 420             NoOptimisation -> []
 421             _ -> ["-O2"]
 422         )
 423           ++ ( case withDebugInfo lbi of
 424                 NoDebugInfo -> []
 425                 MinimalDebugInfo -> ["-g1"]
 426                 NormalDebugInfo -> ["-g"]
 427                 MaximalDebugInfo -> ["-g3"]
 428              )
 429           ++ cxxOptions bi
 430     , ghcOptCcProgram =
 431         maybeToFlag $
 432           programPath
 433             <$> lookupProgram gccProgram (withPrograms lbi)
 434     , ghcOptObjDir = toFlag odir
 435     , ghcOptExtra = hcOptions GHC bi
 436     }
 437
 438 componentAsmGhcOptions
 439   :: Verbosity
 440   -> LocalBuildInfo
 441   -> BuildInfo
 442   -> ComponentLocalBuildInfo
 443   -> SymbolicPath Pkg (Dir Artifacts)
 444   -> SymbolicPath Pkg File
 445   -> GhcOptions
 446 componentAsmGhcOptions verbosity lbi bi clbi odir filename =
 447   mempty
 448     { -- Respect -v0, but don't crank up verbosity on GHC if
 449       -- Cabal verbosity is requested. For that, use --ghc-option=-v instead!
 450       ghcOptVerbosity = toFlag (min verbosity normal)
 451     , ghcOptMode = toFlag GhcModeCompile
 452     , ghcOptInputFiles = toNubListR [filename]
 453     , ghcOptCppIncludePath = includePaths lbi bi clbi odir
 454     , ghcOptHideAllPackages = toFlag True
 455     , ghcOptPackageDBs = withPackageDB lbi
 456     , ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi
 457     , ghcOptAsmOptions =
 458         ( case withOptimization lbi of
 459             NoOptimisation -> []
 460             _ -> ["-O2"]
 461         )
 462           ++ ( case withDebugInfo lbi of
 463                 NoDebugInfo -> []
 464                 MinimalDebugInfo -> ["-g1"]
 465                 NormalDebugInfo -> ["-g"]
 466                 MaximalDebugInfo -> ["-g3"]
 467              )
 468           ++ asmOptions bi
 469     , ghcOptObjDir = toFlag odir
 470     }
 471
 472 componentJsGhcOptions
 473   :: Verbosity
 474   -> LocalBuildInfo
 475   -> BuildInfo
 476   -> ComponentLocalBuildInfo
 477   -> SymbolicPath Pkg (Dir Artifacts)
 478   -> SymbolicPath Pkg File
 479   -> GhcOptions
 480 componentJsGhcOptions verbosity lbi bi clbi odir filename =
 481   mempty
 482     { -- Respect -v0, but don't crank up verbosity on GHC if
 483       -- Cabal verbosity is requested. For that, use --ghc-option=-v instead!
 484       ghcOptVerbosity = toFlag (min verbosity normal)
 485     , ghcOptMode = toFlag GhcModeCompile
 486     , ghcOptInputFiles = toNubListR [filename]
 487     , ghcOptCppIncludePath = includePaths lbi bi clbi odir
 488     , ghcOptHideAllPackages = toFlag True
 489     , ghcOptPackageDBs = withPackageDB lbi
 490     , ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi
 491     , ghcOptObjDir = toFlag odir
 492     }
 493
 494 componentGhcOptions
 495   :: Verbosity
 496   -> LocalBuildInfo
 497   -> BuildInfo
 498   -> ComponentLocalBuildInfo
 499   -> SymbolicPath Pkg (Dir build)
 500   -> GhcOptions
 501 componentGhcOptions verbosity lbi bi clbi odir =
 502   let implInfo = getImplInfo $ compiler lbi
 503    in mempty
 504         { -- Respect -v0, but don't crank up verbosity on GHC if
 505           -- Cabal verbosity is requested. For that, use --ghc-option=-v instead!
 506           ghcOptVerbosity = toFlag (min verbosity normal)
 507         , ghcOptCabal = toFlag True
 508         , ghcOptThisUnitId = case clbi of
 509             LibComponentLocalBuildInfo{componentCompatPackageKey = pk} ->
 510               toFlag pk
 511             _ | not (unitIdForExes implInfo) -> mempty
 512             ExeComponentLocalBuildInfo{componentUnitId = uid} ->
 513               toFlag (unUnitId uid)
 514             TestComponentLocalBuildInfo{componentUnitId = uid} ->
 515               toFlag (unUnitId uid)
 516             BenchComponentLocalBuildInfo{componentUnitId = uid} ->
 517               toFlag (unUnitId uid)
 518             FLibComponentLocalBuildInfo{componentUnitId = uid} ->
 519               toFlag (unUnitId uid)
 520         , ghcOptThisComponentId = case clbi of
 521             LibComponentLocalBuildInfo
 522               { componentComponentId = cid
 523               , componentInstantiatedWith = insts
 524               } ->
 525                 if null insts
 526                   then mempty
 527                   else toFlag cid
 528             _ -> mempty
 529         , ghcOptInstantiatedWith = case clbi of
 530             LibComponentLocalBuildInfo{componentInstantiatedWith = insts} ->
 531               insts
 532             _ -> []
 533         , ghcOptNoCode = toFlag $ componentIsIndefinite clbi
 534         , ghcOptHideAllPackages = toFlag True
 535         , ghcOptWarnMissingHomeModules = toFlag $ flagWarnMissingHomeModules implInfo
 536         , ghcOptPackageDBs = withPackageDB lbi
 537         , ghcOptPackages = toNubListR $ mkGhcOptPackages mempty clbi
 538         , ghcOptSplitSections = toFlag (splitSections lbi)
 539         , ghcOptSplitObjs = toFlag (splitObjs lbi)
 540         , ghcOptSourcePathClear = toFlag True
 541         , ghcOptSourcePath =
 542             toNubListR $
 543               (hsSourceDirs bi)
 544                 ++ [coerceSymbolicPath odir]
 545                 ++ [autogenComponentModulesDir lbi clbi]
 546                 ++ [autogenPackageModulesDir lbi]
 547         , ghcOptCppIncludePath = includePaths lbi bi clbi odir
 548         , ghcOptCppOptions = cppOptions bi
 549         , ghcOptCppIncludes =
 550             toNubListR $
 551               [coerceSymbolicPath (autogenComponentModulesDir lbi clbi </> makeRelativePathEx cppHeaderName)]
 552         , ghcOptFfiIncludes = toNubListR $ map getSymbolicPath $ includes bi
 553         , ghcOptObjDir = toFlag $ coerceSymbolicPath odir
 554         , ghcOptHiDir = toFlag $ coerceSymbolicPath odir
 555         , ghcOptHieDir = bool NoFlag (toFlag $ coerceSymbolicPath odir </> (extraCompilationArtifacts </> makeRelativePathEx "hie")) $ flagHie implInfo
 556         , ghcOptStubDir = toFlag $ coerceSymbolicPath odir
 557         , ghcOptOutputDir = toFlag $ coerceSymbolicPath odir
 558         , ghcOptOptimisation = toGhcOptimisation (withOptimization lbi)
 559         , ghcOptDebugInfo = toFlag (withDebugInfo lbi)
 560         , ghcOptExtra = hcOptions GHC bi
 561         , ghcOptExtraPath = toNubListR exe_paths
 562         , ghcOptLanguage = toFlag (fromMaybe Haskell98 (defaultLanguage bi))
 563         , -- Unsupported extensions have already been checked by configure
 564           ghcOptExtensions = toNubListR $ usedExtensions bi
 565         , ghcOptExtensionMap = Map.fromList . compilerExtensions $ (compiler lbi)
 566         }
 567   where
 568     exe_paths =
 569       [ componentBuildDir lbi (targetCLBI exe_tgt)
 570       | uid <- componentExeDeps clbi
 571       , -- TODO: Ugh, localPkgDescr
 572       Just exe_tgt <- [unitIdTarget' (localPkgDescr lbi) lbi uid]
 573       ]
 574
 575 toGhcOptimisation :: OptimisationLevel -> Flag GhcOptimisation
 576 toGhcOptimisation NoOptimisation = mempty -- TODO perhaps override?
 577 toGhcOptimisation NormalOptimisation = toFlag GhcNormalOptimisation
 578 toGhcOptimisation MaximumOptimisation = toFlag GhcMaximumOptimisation
 579
 580 componentCmmGhcOptions
 581   :: Verbosity
 582   -> LocalBuildInfo
 583   -> BuildInfo
 584   -> ComponentLocalBuildInfo
 585   -> SymbolicPath Pkg (Dir Artifacts)
 586   -> SymbolicPath Pkg File
 587   -> GhcOptions
 588 componentCmmGhcOptions verbosity lbi bi clbi odir filename =
 589   mempty
 590     { -- Respect -v0, but don't crank up verbosity on GHC if
 591       -- Cabal verbosity is requested. For that, use --ghc-option=-v instead!
 592       ghcOptVerbosity = toFlag (min verbosity normal)
 593     , ghcOptMode = toFlag GhcModeCompile
 594     , ghcOptInputFiles = toNubListR [filename]
 595     , ghcOptCppIncludePath = includePaths lbi bi clbi odir
 596     , ghcOptCppOptions = cppOptions bi
 597     , ghcOptCppIncludes =
 598         toNubListR $
 599           [autogenComponentModulesDir lbi clbi </> makeRelativePathEx cppHeaderName]
 600     , ghcOptHideAllPackages = toFlag True
 601     , ghcOptPackageDBs = withPackageDB lbi
 602     , ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi
 603     , ghcOptOptimisation = toGhcOptimisation (withOptimization lbi)
 604     , ghcOptDebugInfo = toFlag (withDebugInfo lbi)
 605     , ghcOptExtra = cmmOptions bi
 606     , ghcOptObjDir = toFlag odir
 607     }
 608
 609 -- | Strip out flags that are not supported in ghci
 610 filterGhciFlags :: [String] -> [String]
 611 filterGhciFlags = filter supported
 612   where
 613     supported ('-' : 'O' : _) = False
 614     supported "-debug" = False
 615     supported "-threaded" = False
 616     supported "-ticky" = False
 617     supported "-eventlog" = False
 618     supported "-prof" = False
 619     supported "-unreg" = False
 620     supported _ = True
 621
 622 mkGHCiLibName :: UnitId -> String
 623 mkGHCiLibName lib = getHSLibraryName lib <.> "o"
 624
 625 mkGHCiProfLibName :: UnitId -> String
 626 mkGHCiProfLibName lib = getHSLibraryName lib <.> "p_o"
 627
 628 ghcLookupProperty :: String -> Compiler -> Bool
 629 ghcLookupProperty prop comp =
 630   case Map.lookup prop (compilerProperties comp) of
 631     Just "YES" -> True
 632     _ -> False
 633
 634 -- when using -split-objs, we need to search for object files in the
 635 -- Module_split directory for each module.
 636 getHaskellObjects
 637   :: GhcImplInfo
 638   -> Library
 639   -> LocalBuildInfo
 640   -> ComponentLocalBuildInfo
 641   -> SymbolicPath Pkg (Dir Artifacts)
 642   -> String
 643   -> Bool
 644   -> IO [SymbolicPath Pkg File]
 645 getHaskellObjects _implInfo lib lbi clbi pref wanted_obj_ext allow_split_objs
 646   | splitObjs lbi && allow_split_objs = do
 647       let splitSuffix = "_" ++ wanted_obj_ext ++ "_split"
 648           dirs =
 649             [ pref </> makeRelativePathEx (ModuleName.toFilePath x ++ splitSuffix)
 650             | x <- allLibModules lib clbi
 651             ]
 652       objss <- traverse (getDirectoryContents . i) dirs
 653       let objs =
 654             [ dir </> makeRelativePathEx obj
 655             | (objs', dir) <- zip objss dirs
 656             , obj <- objs'
 657             , let obj_ext = takeExtension obj
 658             , '.' : wanted_obj_ext == obj_ext
 659             ]
 660       return objs
 661   | otherwise =
 662       return
 663         [ pref </> makeRelativePathEx (ModuleName.toFilePath x <.> wanted_obj_ext)
 664         | x <- allLibModules lib clbi
 665         ]
 666   where
 667     i = interpretSymbolicPathLBI lbi
 668
 669 -- | Create the required packaged arguments, but filtering out package arguments which
 670 -- aren't yet built, but promised. This filtering is used when compiling C/Cxx/Asm files,
 671 -- and is a hack to avoid passing bogus `-package` arguments to GHC. The assumption being that
 672 -- in 99% of cases we will include the right `-package` so that the C file finds the right headers.
 673 mkGhcOptPackages
 674   :: Map (PackageName, ComponentName) PromisedComponent
 675   -> ComponentLocalBuildInfo
 676   -> [(OpenUnitId, ModuleRenaming)]
 677 mkGhcOptPackages promisedPkgsMap clbi =
 678   [ i | i@(uid, _) <- componentIncludes clbi, abstractUnitId uid `Set.notMember` promised_cids
 679   ]
 680   where
 681     -- Promised deps are going to be simple UnitIds
 682     promised_cids = Set.fromList (map (newSimpleUnitId . promisedComponentId) (Map.elems promisedPkgsMap))
 683
 684 substTopDir :: FilePath -> IPI.InstalledPackageInfo -> IPI.InstalledPackageInfo
 685 substTopDir topDir ipo =
 686   ipo
 687     { IPI.importDirs = map f (IPI.importDirs ipo)
 688     , IPI.libraryDirs = map f (IPI.libraryDirs ipo)
 689     , IPI.libraryDirsStatic = map f (IPI.libraryDirsStatic ipo)
 690     , IPI.includeDirs = map f (IPI.includeDirs ipo)
 691     , IPI.frameworkDirs = map f (IPI.frameworkDirs ipo)
 692     , IPI.haddockInterfaces = map f (IPI.haddockInterfaces ipo)
 693     , IPI.haddockHTMLs = map f (IPI.haddockHTMLs ipo)
 694     }
 695   where
 696     f ('$' : 't' : 'o' : 'p' : 'd' : 'i' : 'r' : rest) = topDir ++ rest
 697     f x = x
 698
 699 -- Cabal does not use the environment variable GHC{,JS}_PACKAGE_PATH; let
 700 -- users know that this is the case. See ticket #335. Simply ignoring it is
 701 -- not a good idea, since then ghc and cabal are looking at different sets
 702 -- of package DBs and chaos is likely to ensue.
 703 --
 704 -- An exception to this is when running cabal from within a `cabal exec`
 705 -- environment. In this case, `cabal exec` will set the
 706 -- CABAL_SANDBOX_PACKAGE_PATH to the same value that it set
 707 -- GHC{,JS}_PACKAGE_PATH to. If that is the case it is OK to allow
 708 -- GHC{,JS}_PACKAGE_PATH.
 709 checkPackageDbEnvVar :: Verbosity -> String -> String -> IO ()
 710 checkPackageDbEnvVar verbosity compilerName packagePathEnvVar = do
 711   mPP <- lookupEnv packagePathEnvVar
 712   when (isJust mPP) $ do
 713     mcsPP <- lookupEnv "CABAL_SANDBOX_PACKAGE_PATH"
 714     unless (mPP == mcsPP) abort
 715   where
 716     lookupEnv :: String -> IO (Maybe String)
 717     lookupEnv name =
 718       (Just `fmap` getEnv name)
 719         `catchIO` const (return Nothing)
 720     abort =
 721       dieWithException verbosity $ IncompatibleWithCabal compilerName packagePathEnvVar
 722     _ = callStack -- TODO: output stack when erroring
 723
 724 profDetailLevelFlag :: Bool -> ProfDetailLevel -> Flag GhcProfAuto
 725 profDetailLevelFlag forLib mpl =
 726   case mpl of
 727     ProfDetailNone -> mempty
 728     ProfDetailDefault
 729       | forLib -> toFlag GhcProfAutoExported
 730       | otherwise -> toFlag GhcProfAutoToplevel
 731     ProfDetailExportedFunctions -> toFlag GhcProfAutoExported
 732     ProfDetailToplevelFunctions -> toFlag GhcProfAutoToplevel
 733     ProfDetailAllFunctions -> toFlag GhcProfAutoAll
 734     ProfDetailTopLate -> toFlag GhcProfLate
 735     ProfDetailOther _ -> mempty
 736
 737 -- -----------------------------------------------------------------------------
 738 -- GHC platform and version strings
 739
 740 -- | GHC's rendering of its host or target 'Arch' as used in its platform
 741 -- strings and certain file locations (such as user package db location).
 742 ghcArchString :: Arch -> String
 743 ghcArchString PPC = "powerpc"
 744 ghcArchString PPC64 = "powerpc64"
 745 ghcArchString PPC64LE = "powerpc64le"
 746 ghcArchString other = prettyShow other
 747
 748 -- | GHC's rendering of its host or target 'OS' as used in its platform
 749 -- strings and certain file locations (such as user package db location).
 750 ghcOsString :: OS -> String
 751 ghcOsString Windows = "mingw32"
 752 ghcOsString OSX = "darwin"
 753 ghcOsString Solaris = "solaris2"
 754 ghcOsString Hurd = "gnu"
 755 ghcOsString other = prettyShow other
 756
 757 -- | GHC's rendering of its platform and compiler version string as used in
 758 -- certain file locations (such as user package db location).
 759 -- For example @x86_64-linux-7.10.4@
 760 ghcPlatformAndVersionString :: Platform -> Version -> String
 761 ghcPlatformAndVersionString (Platform arch os) version =
 762   intercalate "-" [ghcArchString arch, ghcOsString os, prettyShow version]
 763
 764 -- -----------------------------------------------------------------------------
 765 -- Constructing GHC environment files
 766
 767 -- | The kinds of entries we can stick in a @.ghc.environment@ file.
 768 data GhcEnvironmentFileEntry fp
 769   = -- | @-- a comment@
 770     GhcEnvFileComment String
 771   | -- | @package-id foo-1.0-4fe301a...@
 772     GhcEnvFilePackageId UnitId
 773   | -- | @global-package-db@,
 774     --   @user-package-db@ or
 775     --   @package-db blah/package.conf.d/@
 776     GhcEnvFilePackageDb (PackageDBX fp)
 777   | -- | @clear-package-db@
 778     GhcEnvFileClearPackageDbStack
 779   deriving (Eq, Ord, Show)
 780
 781 -- | Make entries for a GHC environment file based on a 'PackageDBStack' and
 782 -- a bunch of package (unit) ids.
 783 --
 784 -- If you need to do anything more complicated then either use this as a basis
 785 -- and add more entries, or just make all the entries directly.
 786 simpleGhcEnvironmentFile
 787   :: PackageDBStackX fp
 788   -> [UnitId]
 789   -> [GhcEnvironmentFileEntry fp]
 790 simpleGhcEnvironmentFile packageDBs pkgids =
 791   GhcEnvFileClearPackageDbStack
 792     : map GhcEnvFilePackageDb packageDBs
 793     ++ map GhcEnvFilePackageId pkgids
 794
 795 -- | Write a @.ghc.environment-$arch-$os-$ver@ file in the given directory.
 796 --
 797 -- The 'Platform' and GHC 'Version' are needed as part of the file name.
 798 --
 799 -- Returns the name of the file written.
 800 writeGhcEnvironmentFile
 801   :: FilePath
 802   -- ^ directory in which to put it
 803   -> Platform
 804   -- ^ the GHC target platform
 805   -> Version
 806   -- ^ the GHC version
 807   -> [GhcEnvironmentFileEntry FilePath]
 808   -- ^ the content
 809   -> IO FilePath
 810 writeGhcEnvironmentFile directory platform ghcversion entries = do
 811   writeFileAtomic envfile . BS.pack . renderGhcEnvironmentFile $ entries
 812   return envfile
 813   where
 814     envfile = directory </> ghcEnvironmentFileName platform ghcversion
 815
 816 -- | The @.ghc.environment-$arch-$os-$ver@ file name
 817 ghcEnvironmentFileName :: Platform -> Version -> FilePath
 818 ghcEnvironmentFileName platform ghcversion =
 819   ".ghc.environment." ++ ghcPlatformAndVersionString platform ghcversion
 820
 821 -- | Render a bunch of GHC environment file entries
 822 renderGhcEnvironmentFile :: [GhcEnvironmentFileEntry FilePath] -> String
 823 renderGhcEnvironmentFile =
 824   unlines . map renderGhcEnvironmentFileEntry
 825
 826 -- | Render an individual GHC environment file entry
 827 renderGhcEnvironmentFileEntry :: GhcEnvironmentFileEntry FilePath -> String
 828 renderGhcEnvironmentFileEntry entry = case entry of
 829   GhcEnvFileComment comment -> format comment
 830     where
 831       format = intercalate "\n" . map ("--" <++>) . lines
 832       pref <++> "" = pref
 833       pref <++> str = pref ++ " " ++ str
 834   GhcEnvFilePackageId pkgid -> "package-id " ++ prettyShow pkgid
 835   GhcEnvFilePackageDb pkgdb ->
 836     case pkgdb of
 837       GlobalPackageDB -> "global-package-db"
 838       UserPackageDB -> "user-package-db"
 839       SpecificPackageDB dbfile -> "package-db " ++ dbfile
 840   GhcEnvFileClearPackageDbStack -> "clear-package-db"