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