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