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