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

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