{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}

-----------------------------------------------------------------------------

-- |
-- Module      :  Distribution.Simple.GHC.Internal
-- Copyright   :  Isaac Jones 2003-2007
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- This module contains functions shared by GHC (Distribution.Simple.GHC)
-- and GHC-derived compilers.
module Distribution.Simple.GHC.Internal
  ( configureToolchain
  , getLanguages
  , getExtensions
  , targetPlatform
  , getGhcInfo
  , componentCcGhcOptions
  , componentCmmGhcOptions
  , componentCxxGhcOptions
  , componentAsmGhcOptions
  , componentJsGhcOptions
  , componentGhcOptions
  , mkGHCiLibName
  , mkGHCiProfLibName
  , filterGhciFlags
  , ghcLookupProperty
  , getHaskellObjects
  , mkGhcOptPackages
  , substTopDir
  , checkPackageDbEnvVar
  , profDetailLevelFlag

    -- * GHC platform and version strings
  , ghcArchString
  , ghcOsString
  , ghcPlatformAndVersionString

    -- * Constructing GHC environment files
  , GhcEnvironmentFileEntry (..)
  , writeGhcEnvironmentFile
  , simpleGhcEnvironmentFile
  , ghcEnvironmentFileName
  , renderGhcEnvironmentFile
  , renderGhcEnvironmentFileEntry
  ) where

import Distribution.Compat.Prelude
import Prelude ()

import Data.Bool (bool)
import qualified Data.ByteString.Lazy.Char8 as BS
import qualified Data.Map as Map
import qualified Data.Set as Set
import Distribution.Backpack
import Distribution.Compat.Stack
import qualified Distribution.InstalledPackageInfo as IPI
import Distribution.Lex
import qualified Distribution.ModuleName as ModuleName
import Distribution.PackageDescription
import Distribution.Parsec (simpleParsec)
import Distribution.Pretty (prettyShow)
import Distribution.Simple.BuildPaths
import Distribution.Simple.Compiler
import Distribution.Simple.Errors
import Distribution.Simple.Flag (Flag (NoFlag), maybeToFlag, toFlag)
import Distribution.Simple.GHC.ImplInfo
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Program
import Distribution.Simple.Program.GHC
import Distribution.Simple.Setup.Common (extraCompilationArtifacts)
import Distribution.Simple.Utils
import Distribution.System
import Distribution.Types.ComponentId (ComponentId)
import Distribution.Types.ComponentLocalBuildInfo
import Distribution.Types.LocalBuildInfo
import Distribution.Types.TargetInfo
import Distribution.Types.UnitId
import Distribution.Utils.NubList (toNubListR)
import Distribution.Utils.Path
import Distribution.Verbosity
import Distribution.Version (Version)
import Language.Haskell.Extension
import System.Directory (getDirectoryContents, getTemporaryDirectory)
import System.Environment (getEnv)
import System.FilePath
  ( takeDirectory
  , takeExtension
  , takeFileName
  , (<.>)
  , (</>)
  )
import System.IO (hClose, hPutStrLn)

targetPlatform :: [(String, String)] -> Maybe Platform
targetPlatform :: [(String, String)] -> Maybe Platform
targetPlatform [(String, String)]
ghcInfo = String -> Maybe Platform
platformFromTriple (String -> Maybe Platform) -> Maybe String -> Maybe Platform
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"Target platform" [(String, String)]
ghcInfo

-- | Adjust the way we find and configure gcc and ld
configureToolchain
  :: GhcImplInfo
  -> ConfiguredProgram
  -> Map String String
  -> ProgramDb
  -> ProgramDb
configureToolchain :: GhcImplInfo
-> ConfiguredProgram -> Map String String -> ProgramDb -> ProgramDb
configureToolchain GhcImplInfo
_implInfo ConfiguredProgram
ghcProg Map String String
ghcInfo =
  Program -> ProgramDb -> ProgramDb
addKnownProgram
    Program
gccProgram
      { programFindLocation = findProg gccProgramName extraGccPath
      , programPostConf = configureGcc
      }
    (ProgramDb -> ProgramDb)
-> (ProgramDb -> ProgramDb) -> ProgramDb -> ProgramDb
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Program -> ProgramDb -> ProgramDb
addKnownProgram
      Program
ldProgram
        { programFindLocation = findProg ldProgramName extraLdPath
        , programPostConf = \Verbosity
v ConfiguredProgram
cp ->
            -- Call any existing configuration first and then add any new configuration
            Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
configureLd Verbosity
v (ConfiguredProgram -> IO ConfiguredProgram)
-> IO ConfiguredProgram -> IO ConfiguredProgram
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Program -> Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
programPostConf Program
ldProgram Verbosity
v ConfiguredProgram
cp
        }
    (ProgramDb -> ProgramDb)
-> (ProgramDb -> ProgramDb) -> ProgramDb -> ProgramDb
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Program -> ProgramDb -> ProgramDb
addKnownProgram
      Program
arProgram
        { programFindLocation = findProg arProgramName extraArPath
        }
    (ProgramDb -> ProgramDb)
-> (ProgramDb -> ProgramDb) -> ProgramDb -> ProgramDb
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Program -> ProgramDb -> ProgramDb
addKnownProgram
      Program
stripProgram
        { programFindLocation = findProg stripProgramName extraStripPath
        }
  where
    compilerDir :: String
compilerDir = String -> String
takeDirectory (ConfiguredProgram -> String
programPath ConfiguredProgram
ghcProg)
    base_dir :: String
base_dir = String -> String
takeDirectory String
compilerDir
    mingwBinDir :: String
mingwBinDir = String
base_dir String -> String -> String
</> String
"mingw" String -> String -> String
</> String
"bin"
    isWindows :: Bool
isWindows = case OS
buildOS of OS
Windows -> Bool
True; OS
_ -> Bool
False
    binPrefix :: String
binPrefix = String
""

    maybeName :: Program -> Maybe FilePath -> String
    maybeName :: Program -> Maybe String -> String
maybeName Program
prog = String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Program -> String
programName Program
prog) (String -> String
dropExeExtension (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
takeFileName)

    gccProgramName :: String
gccProgramName = Program -> Maybe String -> String
maybeName Program
gccProgram Maybe String
mbGccLocation
    ldProgramName :: String
ldProgramName = Program -> Maybe String -> String
maybeName Program
ldProgram Maybe String
mbLdLocation
    arProgramName :: String
arProgramName = Program -> Maybe String -> String
maybeName Program
arProgram Maybe String
mbArLocation
    stripProgramName :: String
stripProgramName = Program -> Maybe String -> String
maybeName Program
stripProgram Maybe String
mbStripLocation

    mkExtraPath :: Maybe FilePath -> FilePath -> [FilePath]
    mkExtraPath :: Maybe String -> String -> [String]
mkExtraPath Maybe String
mbPath String
mingwPath
      | Bool
isWindows = [String]
mbDir [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
mingwPath]
      | Bool
otherwise = [String]
mbDir
      where
        mbDir :: [String]
mbDir = Maybe String -> [String]
forall a. Maybe a -> [a]
maybeToList (Maybe String -> [String])
-> (Maybe String -> Maybe String) -> Maybe String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> Maybe String -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> String
takeDirectory (Maybe String -> [String]) -> Maybe String -> [String]
forall a b. (a -> b) -> a -> b
$ Maybe String
mbPath

    extraGccPath :: [String]
extraGccPath = Maybe String -> String -> [String]
mkExtraPath Maybe String
mbGccLocation String
windowsExtraGccDir
    extraLdPath :: [String]
extraLdPath = Maybe String -> String -> [String]
mkExtraPath Maybe String
mbLdLocation String
windowsExtraLdDir
    extraArPath :: [String]
extraArPath = Maybe String -> String -> [String]
mkExtraPath Maybe String
mbArLocation String
windowsExtraArDir
    extraStripPath :: [String]
extraStripPath = Maybe String -> String -> [String]
mkExtraPath Maybe String
mbStripLocation String
windowsExtraStripDir

    -- on Windows finding and configuring ghc's gcc & binutils is a bit special
    ( String
windowsExtraGccDir
      , String
windowsExtraLdDir
      , String
windowsExtraArDir
      , String
windowsExtraStripDir
      ) =
        let b :: String
b = String
mingwBinDir String -> String -> String
</> String
binPrefix
         in (String
b, String
b, String
b, String
b)

    findProg
      :: String
      -> [FilePath]
      -> Verbosity
      -> ProgramSearchPath
      -> IO (Maybe (FilePath, [FilePath]))
    findProg :: String
-> [String]
-> Verbosity
-> ProgramSearchPath
-> IO (Maybe (String, [String]))
findProg String
progName [String]
extraPath Verbosity
v ProgramSearchPath
searchpath =
      Verbosity
-> ProgramSearchPath -> String -> IO (Maybe (String, [String]))
findProgramOnSearchPath Verbosity
v ProgramSearchPath
searchpath' String
progName
      where
        searchpath' :: ProgramSearchPath
searchpath' = ((String -> ProgramSearchPathEntry) -> [String] -> ProgramSearchPath
forall a b. (a -> b) -> [a] -> [b]
map String -> ProgramSearchPathEntry
ProgramSearchPathDir [String]
extraPath) ProgramSearchPath -> ProgramSearchPath -> ProgramSearchPath
forall a. [a] -> [a] -> [a]
++ ProgramSearchPath
searchpath

    -- Read tool locations from the 'ghc --info' output. Useful when
    -- cross-compiling.
    mbGccLocation :: Maybe String
mbGccLocation = String -> Map String String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
"C compiler command" Map String String
ghcInfo
    mbLdLocation :: Maybe String
mbLdLocation = String -> Map String String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
"ld command" Map String String
ghcInfo
    mbArLocation :: Maybe String
mbArLocation = String -> Map String String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
"ar command" Map String String
ghcInfo
    mbStripLocation :: Maybe String
mbStripLocation = String -> Map String String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
"strip command" Map String String
ghcInfo

    ccFlags :: [String]
ccFlags = String -> [String]
getFlags String
"C compiler flags"
    -- GHC 7.8 renamed "Gcc Linker flags" to "C compiler link flags"
    -- and "Ld Linker flags" to "ld flags" (GHC #4862).
    gccLinkerFlags :: [String]
gccLinkerFlags = String -> [String]
getFlags String
"Gcc Linker flags" [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ String -> [String]
getFlags String
"C compiler link flags"
    ldLinkerFlags :: [String]
ldLinkerFlags = String -> [String]
getFlags String
"Ld Linker flags" [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ String -> [String]
getFlags String
"ld flags"

    -- It appears that GHC 7.6 and earlier encode the tokenized flags as a
    -- [String] in these settings whereas later versions just encode the flags as
    -- String.
    --
    -- We first try to parse as a [String] and if this fails then tokenize the
    -- flags ourself.
    getFlags :: String -> [String]
    getFlags :: String -> [String]
getFlags String
key =
      case String -> Map String String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
key Map String String
ghcInfo of
        Maybe String
Nothing -> []
        Just String
flags
          | ([String]
flags', String
"") : [([String], String)]
_ <- ReadS [String]
forall a. Read a => ReadS a
reads String
flags -> [String]
flags'
          | Bool
otherwise -> String -> [String]
tokenizeQuotedWords String
flags

    configureGcc :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
    configureGcc :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
configureGcc Verbosity
_v ConfiguredProgram
gccProg = do
      ConfiguredProgram -> IO ConfiguredProgram
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
        ConfiguredProgram
gccProg
          { programDefaultArgs =
              programDefaultArgs gccProg
                ++ ccFlags
                ++ gccLinkerFlags
          }

    configureLd :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
    configureLd :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
configureLd Verbosity
v ConfiguredProgram
ldProg = do
      ldProg' <- Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
configureLd' Verbosity
v ConfiguredProgram
ldProg
      return
        ldProg'
          { programDefaultArgs = programDefaultArgs ldProg' ++ ldLinkerFlags
          }

    -- we need to find out if ld supports the -x flag
    configureLd' :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
    configureLd' :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
configureLd' Verbosity
verbosity ConfiguredProgram
ldProg = do
      tempDir <- IO String
getTemporaryDirectory
      ldx <- withTempFile tempDir ".c" $ \String
testcfile Handle
testchnd ->
        String -> String -> (String -> Handle -> IO Bool) -> IO Bool
forall a. String -> String -> (String -> Handle -> IO a) -> IO a
withTempFile String
tempDir String
".o" ((String -> Handle -> IO Bool) -> IO Bool)
-> (String -> Handle -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \String
testofile Handle
testohnd -> do
          Handle -> String -> IO ()
hPutStrLn Handle
testchnd String
"int foo() { return 0; }"
          Handle -> IO ()
hClose Handle
testchnd
          Handle -> IO ()
hClose Handle
testohnd
          Verbosity -> ConfiguredProgram -> [String] -> IO ()
runProgram
            Verbosity
verbosity
            ConfiguredProgram
ghcProg
            [ String
"-hide-all-packages"
            , String
"-c"
            , String
testcfile
            , String
"-o"
            , String
testofile
            ]
          String -> String -> (String -> Handle -> IO Bool) -> IO Bool
forall a. String -> String -> (String -> Handle -> IO a) -> IO a
withTempFile String
tempDir String
".o" ((String -> Handle -> IO Bool) -> IO Bool)
-> (String -> Handle -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \String
testofile' Handle
testohnd' ->
            do
              Handle -> IO ()
hClose Handle
testohnd'
              _ <-
                Verbosity -> ConfiguredProgram -> [String] -> IO String
getProgramOutput
                  Verbosity
verbosity
                  ConfiguredProgram
ldProg
                  [String
"-x", String
"-r", String
testofile, String
"-o", String
testofile']
              return True
              IO Bool -> (IOException -> IO Bool) -> IO Bool
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` (\IOException
_ -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)
              IO Bool -> (ExitCode -> IO Bool) -> IO Bool
forall a. IO a -> (ExitCode -> IO a) -> IO a
`catchExit` (\ExitCode
_ -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False)
      if ldx
        then return ldProg{programDefaultArgs = ["-x"]}
        else return ldProg

getLanguages
  :: Verbosity
  -> GhcImplInfo
  -> ConfiguredProgram
  -> IO [(Language, String)]
getLanguages :: Verbosity
-> GhcImplInfo -> ConfiguredProgram -> IO [(Language, String)]
getLanguages Verbosity
_ GhcImplInfo
implInfo ConfiguredProgram
_
  -- TODO: should be using --supported-languages rather than hard coding
  | GhcImplInfo -> Bool
supportsGHC2021 GhcImplInfo
implInfo =
      [(Language, String)] -> IO [(Language, String)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
        [ (Language
GHC2021, String
"-XGHC2021")
        , (Language
Haskell2010, String
"-XHaskell2010")
        , (Language
Haskell98, String
"-XHaskell98")
        ]
  | GhcImplInfo -> Bool
supportsHaskell2010 GhcImplInfo
implInfo =
      [(Language, String)] -> IO [(Language, String)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
        [ (Language
Haskell98, String
"-XHaskell98")
        , (Language
Haskell2010, String
"-XHaskell2010")
        ]
  | Bool
otherwise = [(Language, String)] -> IO [(Language, String)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Language
Haskell98, String
"")]

getGhcInfo
  :: Verbosity
  -> GhcImplInfo
  -> ConfiguredProgram
  -> IO [(String, String)]
getGhcInfo :: Verbosity
-> GhcImplInfo -> ConfiguredProgram -> IO [(String, String)]
getGhcInfo Verbosity
verbosity GhcImplInfo
_implInfo ConfiguredProgram
ghcProg = do
  xs <-
    Verbosity -> ConfiguredProgram -> [String] -> IO String
getProgramOutput
      Verbosity
verbosity
      (ConfiguredProgram -> ConfiguredProgram
suppressOverrideArgs ConfiguredProgram
ghcProg)
      [String
"--info"]
  case reads xs of
    [([(String, String)]
i, String
ss)]
      | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
ss ->
          [(String, String)] -> IO [(String, String)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [(String, String)]
i
    [([(String, String)], String)]
_ ->
      Verbosity -> CabalException -> IO [(String, String)]
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity CabalException
CantParseGHCOutput

getExtensions
  :: Verbosity
  -> GhcImplInfo
  -> ConfiguredProgram
  -> IO [(Extension, Maybe String)]
getExtensions :: Verbosity
-> GhcImplInfo
-> ConfiguredProgram
-> IO [(Extension, Maybe String)]
getExtensions Verbosity
verbosity GhcImplInfo
implInfo ConfiguredProgram
ghcProg = do
  str <-
    Verbosity -> ConfiguredProgram -> [String] -> IO String
getProgramOutput
      Verbosity
verbosity
      (ConfiguredProgram -> ConfiguredProgram
suppressOverrideArgs ConfiguredProgram
ghcProg)
      [String
"--supported-languages"]
  let extStrs =
        if GhcImplInfo -> Bool
reportsNoExt GhcImplInfo
implInfo
          then String -> [String]
lines String
str
          else -- Older GHCs only gave us either Foo or NoFoo,
          -- so we have to work out the other one ourselves

            [ String
extStr''
            | String
extStr <- String -> [String]
lines String
str
            , let extStr' :: String
extStr' = case String
extStr of
                    Char
'N' : Char
'o' : String
xs -> String
xs
                    String
_ -> String
"No" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
extStr
            , String
extStr'' <- [String
extStr, String
extStr']
            ]
  let extensions0 =
        [ (Extension
ext, String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String
"-X" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Extension -> String
forall a. Pretty a => a -> String
prettyShow Extension
ext)
        | Just Extension
ext <- (String -> Maybe Extension) -> [String] -> [Maybe Extension]
forall a b. (a -> b) -> [a] -> [b]
map String -> Maybe Extension
forall a. Parsec a => String -> Maybe a
simpleParsec [String]
extStrs
        ]
      extensions1 =
        if GhcImplInfo -> Bool
alwaysNondecIndent GhcImplInfo
implInfo
          then -- ghc-7.2 split NondecreasingIndentation off
          -- into a proper extension. Before that it
          -- was always on.
          -- Since it was not a proper extension, it could
          -- not be turned off, hence we omit a
          -- DisableExtension entry here.

            (KnownExtension -> Extension
EnableExtension KnownExtension
NondecreasingIndentation, Maybe String
forall a. Maybe a
Nothing)
              (Extension, Maybe String)
-> [(Extension, Maybe String)] -> [(Extension, Maybe String)]
forall a. a -> [a] -> [a]
: [(Extension, Maybe String)]
extensions0
          else [(Extension, Maybe String)]
extensions0
  return extensions1

componentCcGhcOptions
  :: Verbosity
  -> LocalBuildInfo
  -> BuildInfo
  -> ComponentLocalBuildInfo
  -> FilePath
  -> FilePath
  -> GhcOptions
componentCcGhcOptions :: Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> String
-> String
-> GhcOptions
componentCcGhcOptions Verbosity
verbosity LocalBuildInfo
lbi BuildInfo
bi ComponentLocalBuildInfo
clbi String
odir String
filename =
  GhcOptions
forall a. Monoid a => a
mempty
    { -- Respect -v0, but don't crank up verbosity on GHC if
      -- Cabal verbosity is requested. For that, use --ghc-option=-v instead!
      ghcOptVerbosity = toFlag (min verbosity normal)
    , ghcOptMode = toFlag GhcModeCompile
    , ghcOptInputFiles = toNubListR [filename]
    , ghcOptCppIncludePath =
        toNubListR $
          [ autogenComponentModulesDir lbi clbi
          , autogenPackageModulesDir lbi
          , odir
          ]
            -- includes relative to the package
            ++ includeDirs bi
            -- potential includes generated by `configure'
            -- in the build directory
            ++ [buildDir lbi </> dir | dir <- includeDirs bi]
    , ghcOptHideAllPackages = toFlag True
    , ghcOptPackageDBs = withPackageDB lbi
    , ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi
    , ghcOptCcOptions =
        ( case withOptimization lbi of
            OptimisationLevel
NoOptimisation -> []
            OptimisationLevel
_ -> [String
"-O2"]
        )
          ++ ( case withDebugInfo lbi of
                DebugInfoLevel
NoDebugInfo -> []
                DebugInfoLevel
MinimalDebugInfo -> [String
"-g1"]
                DebugInfoLevel
NormalDebugInfo -> [String
"-g"]
                DebugInfoLevel
MaximalDebugInfo -> [String
"-g3"]
             )
          ++ ccOptions bi
    , ghcOptCcProgram =
        maybeToFlag $
          programPath
            <$> lookupProgram gccProgram (withPrograms lbi)
    , ghcOptObjDir = toFlag odir
    , ghcOptExtra = hcOptions GHC bi
    }

componentCxxGhcOptions
  :: Verbosity
  -> LocalBuildInfo
  -> BuildInfo
  -> ComponentLocalBuildInfo
  -> FilePath
  -> FilePath
  -> GhcOptions
componentCxxGhcOptions :: Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> String
-> String
-> GhcOptions
componentCxxGhcOptions Verbosity
verbosity LocalBuildInfo
lbi BuildInfo
bi ComponentLocalBuildInfo
clbi String
odir String
filename =
  GhcOptions
forall a. Monoid a => a
mempty
    { -- Respect -v0, but don't crank up verbosity on GHC if
      -- Cabal verbosity is requested. For that, use --ghc-option=-v instead!
      ghcOptVerbosity = toFlag (min verbosity normal)
    , ghcOptMode = toFlag GhcModeCompile
    , ghcOptInputFiles = toNubListR [filename]
    , ghcOptCppIncludePath =
        toNubListR $
          [ autogenComponentModulesDir lbi clbi
          , autogenPackageModulesDir lbi
          , odir
          ]
            -- includes relative to the package
            ++ includeDirs bi
            -- potential includes generated by `configure'
            -- in the build directory
            ++ [buildDir lbi </> dir | dir <- includeDirs bi]
    , ghcOptHideAllPackages = toFlag True
    , ghcOptPackageDBs = withPackageDB lbi
    , ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi
    , ghcOptCxxOptions =
        ( case withOptimization lbi of
            OptimisationLevel
NoOptimisation -> []
            OptimisationLevel
_ -> [String
"-O2"]
        )
          ++ ( case withDebugInfo lbi of
                DebugInfoLevel
NoDebugInfo -> []
                DebugInfoLevel
MinimalDebugInfo -> [String
"-g1"]
                DebugInfoLevel
NormalDebugInfo -> [String
"-g"]
                DebugInfoLevel
MaximalDebugInfo -> [String
"-g3"]
             )
          ++ cxxOptions bi
    , ghcOptCcProgram =
        maybeToFlag $
          programPath
            <$> lookupProgram gccProgram (withPrograms lbi)
    , ghcOptObjDir = toFlag odir
    , ghcOptExtra = hcOptions GHC bi
    }

componentAsmGhcOptions
  :: Verbosity
  -> LocalBuildInfo
  -> BuildInfo
  -> ComponentLocalBuildInfo
  -> FilePath
  -> FilePath
  -> GhcOptions
componentAsmGhcOptions :: Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> String
-> String
-> GhcOptions
componentAsmGhcOptions Verbosity
verbosity LocalBuildInfo
lbi BuildInfo
bi ComponentLocalBuildInfo
clbi String
odir String
filename =
  GhcOptions
forall a. Monoid a => a
mempty
    { -- Respect -v0, but don't crank up verbosity on GHC if
      -- Cabal verbosity is requested. For that, use --ghc-option=-v instead!
      ghcOptVerbosity = toFlag (min verbosity normal)
    , ghcOptMode = toFlag GhcModeCompile
    , ghcOptInputFiles = toNubListR [filename]
    , ghcOptCppIncludePath =
        toNubListR $
          [ autogenComponentModulesDir lbi clbi
          , autogenPackageModulesDir lbi
          , odir
          ]
            -- includes relative to the package
            ++ includeDirs bi
            -- potential includes generated by `configure'
            -- in the build directory
            ++ [buildDir lbi </> dir | dir <- includeDirs bi]
    , ghcOptHideAllPackages = toFlag True
    , ghcOptPackageDBs = withPackageDB lbi
    , ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi
    , ghcOptAsmOptions =
        ( case withOptimization lbi of
            OptimisationLevel
NoOptimisation -> []
            OptimisationLevel
_ -> [String
"-O2"]
        )
          ++ ( case withDebugInfo lbi of
                DebugInfoLevel
NoDebugInfo -> []
                DebugInfoLevel
MinimalDebugInfo -> [String
"-g1"]
                DebugInfoLevel
NormalDebugInfo -> [String
"-g"]
                DebugInfoLevel
MaximalDebugInfo -> [String
"-g3"]
             )
          ++ asmOptions bi
    , ghcOptObjDir = toFlag odir
    }

componentJsGhcOptions
  :: Verbosity
  -> LocalBuildInfo
  -> BuildInfo
  -> ComponentLocalBuildInfo
  -> FilePath
  -> FilePath
  -> GhcOptions
componentJsGhcOptions :: Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> String
-> String
-> GhcOptions
componentJsGhcOptions Verbosity
verbosity LocalBuildInfo
lbi BuildInfo
bi ComponentLocalBuildInfo
clbi String
odir String
filename =
  GhcOptions
forall a. Monoid a => a
mempty
    { -- Respect -v0, but don't crank up verbosity on GHC if
      -- Cabal verbosity is requested. For that, use --ghc-option=-v instead!
      ghcOptVerbosity = toFlag (min verbosity normal)
    , ghcOptMode = toFlag GhcModeCompile
    , ghcOptInputFiles = toNubListR [filename]
    , ghcOptCppIncludePath =
        toNubListR $
          [ autogenComponentModulesDir lbi clbi
          , autogenPackageModulesDir lbi
          , odir
          ]
            -- includes relative to the package
            ++ includeDirs bi
            -- potential includes generated by `configure'
            -- in the build directory
            ++ [buildDir lbi </> dir | dir <- includeDirs bi]
    , ghcOptHideAllPackages = toFlag True
    , ghcOptPackageDBs = withPackageDB lbi
    , ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi
    , ghcOptObjDir = toFlag odir
    }

componentGhcOptions
  :: Verbosity
  -> LocalBuildInfo
  -> BuildInfo
  -> ComponentLocalBuildInfo
  -> FilePath
  -> GhcOptions
componentGhcOptions :: Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> String
-> GhcOptions
componentGhcOptions Verbosity
verbosity LocalBuildInfo
lbi BuildInfo
bi ComponentLocalBuildInfo
clbi String
odir =
  let implInfo :: GhcImplInfo
implInfo = Compiler -> GhcImplInfo
getImplInfo (Compiler -> GhcImplInfo) -> Compiler -> GhcImplInfo
forall a b. (a -> b) -> a -> b
$ LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi
   in GhcOptions
forall a. Monoid a => a
mempty
        { -- Respect -v0, but don't crank up verbosity on GHC if
          -- Cabal verbosity is requested. For that, use --ghc-option=-v instead!
          ghcOptVerbosity = toFlag (min verbosity normal)
        , ghcOptCabal = toFlag True
        , ghcOptThisUnitId = case clbi of
            LibComponentLocalBuildInfo{componentCompatPackageKey :: ComponentLocalBuildInfo -> String
componentCompatPackageKey = String
pk} ->
              String -> Flag String
forall a. a -> Flag a
toFlag String
pk
            ComponentLocalBuildInfo
_ | Bool -> Bool
not (GhcImplInfo -> Bool
unitIdForExes GhcImplInfo
implInfo) -> Flag String
forall a. Monoid a => a
mempty
            ExeComponentLocalBuildInfo{componentUnitId :: ComponentLocalBuildInfo -> UnitId
componentUnitId = UnitId
uid} ->
              String -> Flag String
forall a. a -> Flag a
toFlag (UnitId -> String
unUnitId UnitId
uid)
            TestComponentLocalBuildInfo{componentUnitId :: ComponentLocalBuildInfo -> UnitId
componentUnitId = UnitId
uid} ->
              String -> Flag String
forall a. a -> Flag a
toFlag (UnitId -> String
unUnitId UnitId
uid)
            BenchComponentLocalBuildInfo{componentUnitId :: ComponentLocalBuildInfo -> UnitId
componentUnitId = UnitId
uid} ->
              String -> Flag String
forall a. a -> Flag a
toFlag (UnitId -> String
unUnitId UnitId
uid)
            FLibComponentLocalBuildInfo{componentUnitId :: ComponentLocalBuildInfo -> UnitId
componentUnitId = UnitId
uid} ->
              String -> Flag String
forall a. a -> Flag a
toFlag (UnitId -> String
unUnitId UnitId
uid)
        , ghcOptThisComponentId = case clbi of
            LibComponentLocalBuildInfo
              { componentComponentId :: ComponentLocalBuildInfo -> ComponentId
componentComponentId = ComponentId
cid
              , componentInstantiatedWith :: ComponentLocalBuildInfo -> [(ModuleName, OpenModule)]
componentInstantiatedWith = [(ModuleName, OpenModule)]
insts
              } ->
                if [(ModuleName, OpenModule)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(ModuleName, OpenModule)]
insts
                  then Flag ComponentId
forall a. Monoid a => a
mempty
                  else ComponentId -> Flag ComponentId
forall a. a -> Flag a
toFlag ComponentId
cid
            ComponentLocalBuildInfo
_ -> Flag ComponentId
forall a. Monoid a => a
mempty
        , ghcOptInstantiatedWith = case clbi of
            LibComponentLocalBuildInfo{componentInstantiatedWith :: ComponentLocalBuildInfo -> [(ModuleName, OpenModule)]
componentInstantiatedWith = [(ModuleName, OpenModule)]
insts} ->
              [(ModuleName, OpenModule)]
insts
            ComponentLocalBuildInfo
_ -> []
        , ghcOptNoCode = toFlag $ componentIsIndefinite clbi
        , ghcOptHideAllPackages = toFlag True
        , ghcOptWarnMissingHomeModules = toFlag $ flagWarnMissingHomeModules implInfo
        , ghcOptPackageDBs = withPackageDB lbi
        , ghcOptPackages = toNubListR $ mkGhcOptPackages mempty clbi
        , ghcOptSplitSections = toFlag (splitSections lbi)
        , ghcOptSplitObjs = toFlag (splitObjs lbi)
        , ghcOptSourcePathClear = toFlag True
        , ghcOptSourcePath =
            toNubListR $
              map getSymbolicPath (hsSourceDirs bi)
                ++ [odir]
                ++ [autogenComponentModulesDir lbi clbi]
                ++ [autogenPackageModulesDir lbi]
        , ghcOptCppIncludePath =
            toNubListR $
              [ autogenComponentModulesDir lbi clbi
              , autogenPackageModulesDir lbi
              , odir
              ]
                -- includes relative to the package
                ++ includeDirs bi
                -- potential includes generated by `configure'
                -- in the build directory
                ++ [buildDir lbi </> dir | dir <- includeDirs bi]
        , ghcOptCppOptions = cppOptions bi
        , ghcOptCppIncludes =
            toNubListR $
              [autogenComponentModulesDir lbi clbi </> cppHeaderName]
        , ghcOptFfiIncludes = toNubListR $ includes bi
        , ghcOptObjDir = toFlag odir
        , ghcOptHiDir = toFlag odir
        , ghcOptHieDir = bool NoFlag (toFlag $ odir </> extraCompilationArtifacts </> "hie") $ flagHie implInfo
        , ghcOptStubDir = toFlag odir
        , ghcOptOutputDir = toFlag odir
        , ghcOptOptimisation = toGhcOptimisation (withOptimization lbi)
        , ghcOptDebugInfo = toFlag (withDebugInfo lbi)
        , ghcOptExtra = hcOptions GHC bi
        , ghcOptExtraPath = toNubListR $ exe_paths
        , ghcOptLanguage = toFlag (fromMaybe Haskell98 (defaultLanguage bi))
        , -- Unsupported extensions have already been checked by configure
          ghcOptExtensions = toNubListR $ usedExtensions bi
        , ghcOptExtensionMap = Map.fromList . compilerExtensions $ (compiler lbi)
        }
  where
    exe_paths :: [String]
exe_paths =
      [ LocalBuildInfo -> ComponentLocalBuildInfo -> String
componentBuildDir LocalBuildInfo
lbi (TargetInfo -> ComponentLocalBuildInfo
targetCLBI TargetInfo
exe_tgt)
      | UnitId
uid <- ComponentLocalBuildInfo -> [UnitId]
componentExeDeps ComponentLocalBuildInfo
clbi
      , -- TODO: Ugh, localPkgDescr
      Just TargetInfo
exe_tgt <- [PackageDescription -> LocalBuildInfo -> UnitId -> Maybe TargetInfo
unitIdTarget' (LocalBuildInfo -> PackageDescription
localPkgDescr LocalBuildInfo
lbi) LocalBuildInfo
lbi UnitId
uid]
      ]

toGhcOptimisation :: OptimisationLevel -> Flag GhcOptimisation
toGhcOptimisation :: OptimisationLevel -> Flag GhcOptimisation
toGhcOptimisation OptimisationLevel
NoOptimisation = Flag GhcOptimisation
forall a. Monoid a => a
mempty -- TODO perhaps override?
toGhcOptimisation OptimisationLevel
NormalOptimisation = GhcOptimisation -> Flag GhcOptimisation
forall a. a -> Flag a
toFlag GhcOptimisation
GhcNormalOptimisation
toGhcOptimisation OptimisationLevel
MaximumOptimisation = GhcOptimisation -> Flag GhcOptimisation
forall a. a -> Flag a
toFlag GhcOptimisation
GhcMaximumOptimisation

componentCmmGhcOptions
  :: Verbosity
  -> LocalBuildInfo
  -> BuildInfo
  -> ComponentLocalBuildInfo
  -> FilePath
  -> FilePath
  -> GhcOptions
componentCmmGhcOptions :: Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> String
-> String
-> GhcOptions
componentCmmGhcOptions Verbosity
verbosity LocalBuildInfo
lbi BuildInfo
bi ComponentLocalBuildInfo
clbi String
odir String
filename =
  GhcOptions
forall a. Monoid a => a
mempty
    { -- Respect -v0, but don't crank up verbosity on GHC if
      -- Cabal verbosity is requested. For that, use --ghc-option=-v instead!
      ghcOptVerbosity = toFlag (min verbosity normal)
    , ghcOptMode = toFlag GhcModeCompile
    , ghcOptInputFiles = toNubListR [filename]
    , ghcOptCppIncludePath =
        toNubListR $
          [ autogenComponentModulesDir lbi clbi
          , autogenPackageModulesDir lbi
          , odir
          ]
            -- includes relative to the package
            ++ includeDirs bi
            -- potential includes generated by `configure'
            -- in the build directory
            ++ [buildDir lbi </> dir | dir <- includeDirs bi]
    , ghcOptCppOptions = cppOptions bi
    , ghcOptCppIncludes =
        toNubListR $
          [autogenComponentModulesDir lbi clbi </> cppHeaderName]
    , ghcOptHideAllPackages = toFlag True
    , ghcOptPackageDBs = withPackageDB lbi
    , ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi
    , ghcOptOptimisation = toGhcOptimisation (withOptimization lbi)
    , ghcOptDebugInfo = toFlag (withDebugInfo lbi)
    , ghcOptExtra = cmmOptions bi
    , ghcOptObjDir = toFlag odir
    }

-- | Strip out flags that are not supported in ghci
filterGhciFlags :: [String] -> [String]
filterGhciFlags :: [String] -> [String]
filterGhciFlags = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
supported
  where
    supported :: String -> Bool
supported (Char
'-' : Char
'O' : String
_) = Bool
False
    supported String
"-debug" = Bool
False
    supported String
"-threaded" = Bool
False
    supported String
"-ticky" = Bool
False
    supported String
"-eventlog" = Bool
False
    supported String
"-prof" = Bool
False
    supported String
"-unreg" = Bool
False
    supported String
_ = Bool
True

mkGHCiLibName :: UnitId -> String
mkGHCiLibName :: UnitId -> String
mkGHCiLibName UnitId
lib = UnitId -> String
getHSLibraryName UnitId
lib String -> String -> String
<.> String
"o"

mkGHCiProfLibName :: UnitId -> String
mkGHCiProfLibName :: UnitId -> String
mkGHCiProfLibName UnitId
lib = UnitId -> String
getHSLibraryName UnitId
lib String -> String -> String
<.> String
"p_o"

ghcLookupProperty :: String -> Compiler -> Bool
ghcLookupProperty :: String -> Compiler -> Bool
ghcLookupProperty String
prop Compiler
comp =
  case String -> Map String String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
prop (Compiler -> Map String String
compilerProperties Compiler
comp) of
    Just String
"YES" -> Bool
True
    Maybe String
_ -> Bool
False

-- when using -split-objs, we need to search for object files in the
-- Module_split directory for each module.
getHaskellObjects
  :: GhcImplInfo
  -> Library
  -> LocalBuildInfo
  -> ComponentLocalBuildInfo
  -> FilePath
  -> String
  -> Bool
  -> IO [FilePath]
getHaskellObjects :: GhcImplInfo
-> Library
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> String
-> String
-> Bool
-> IO [String]
getHaskellObjects GhcImplInfo
_implInfo Library
lib LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi String
pref String
wanted_obj_ext Bool
allow_split_objs
  | LocalBuildInfo -> Bool
splitObjs LocalBuildInfo
lbi Bool -> Bool -> Bool
&& Bool
allow_split_objs = do
      let splitSuffix :: String
splitSuffix = String
"_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
wanted_obj_ext String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_split"
          dirs :: [String]
dirs =
            [ String
pref String -> String -> String
</> (ModuleName -> String
ModuleName.toFilePath ModuleName
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
splitSuffix)
            | ModuleName
x <- Library -> ComponentLocalBuildInfo -> [ModuleName]
allLibModules Library
lib ComponentLocalBuildInfo
clbi
            ]
      objss <- (String -> IO [String]) -> [String] -> IO [[String]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse String -> IO [String]
getDirectoryContents [String]
dirs
      let objs =
            [ String
dir String -> String -> String
</> String
obj
            | ([String]
objs', String
dir) <- [[String]] -> [String] -> [([String], String)]
forall a b. [a] -> [b] -> [(a, b)]
zip [[String]]
objss [String]
dirs
            , String
obj <- [String]
objs'
            , let obj_ext :: String
obj_ext = String -> String
takeExtension String
obj
            , Char
'.' Char -> String -> String
forall a. a -> [a] -> [a]
: String
wanted_obj_ext String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
obj_ext
            ]
      return objs
  | Bool
otherwise =
      [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
        [ String
pref String -> String -> String
</> ModuleName -> String
ModuleName.toFilePath ModuleName
x String -> String -> String
<.> String
wanted_obj_ext
        | ModuleName
x <- Library -> ComponentLocalBuildInfo -> [ModuleName]
allLibModules Library
lib ComponentLocalBuildInfo
clbi
        ]

-- | Create the required packaged arguments, but filtering out package arguments which
-- aren't yet built, but promised. This filtering is used when compiling C/Cxx/Asm files,
-- and is a hack to avoid passing bogus `-package` arguments to GHC. The assumption being that
-- in 99% of cases we will include the right `-package` so that the C file finds the right headers.
mkGhcOptPackages
  :: Map (PackageName, ComponentName) ComponentId
  -> ComponentLocalBuildInfo
  -> [(OpenUnitId, ModuleRenaming)]
mkGhcOptPackages :: Map (PackageName, ComponentName) ComponentId
-> ComponentLocalBuildInfo -> [(OpenUnitId, ModuleRenaming)]
mkGhcOptPackages Map (PackageName, ComponentName) ComponentId
promisedPkgsMap ComponentLocalBuildInfo
clbi =
  [ (OpenUnitId, ModuleRenaming)
i | i :: (OpenUnitId, ModuleRenaming)
i@(OpenUnitId
uid, ModuleRenaming
_) <- ComponentLocalBuildInfo -> [(OpenUnitId, ModuleRenaming)]
componentIncludes ComponentLocalBuildInfo
clbi, OpenUnitId -> UnitId
abstractUnitId OpenUnitId
uid UnitId -> Set UnitId -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set UnitId
promised_cids
  ]
  where
    -- Promised deps are going to be simple UnitIds
    promised_cids :: Set UnitId
promised_cids = [UnitId] -> Set UnitId
forall a. Ord a => [a] -> Set a
Set.fromList ((ComponentId -> UnitId) -> [ComponentId] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map ComponentId -> UnitId
newSimpleUnitId (Map (PackageName, ComponentName) ComponentId -> [ComponentId]
forall k a. Map k a -> [a]
Map.elems Map (PackageName, ComponentName) ComponentId
promisedPkgsMap))

substTopDir :: FilePath -> IPI.InstalledPackageInfo -> IPI.InstalledPackageInfo
substTopDir :: String -> InstalledPackageInfo -> InstalledPackageInfo
substTopDir String
topDir InstalledPackageInfo
ipo =
  InstalledPackageInfo
ipo
    { IPI.importDirs = map f (IPI.importDirs ipo)
    , IPI.libraryDirs = map f (IPI.libraryDirs ipo)
    , IPI.libraryDirsStatic = map f (IPI.libraryDirsStatic ipo)
    , IPI.includeDirs = map f (IPI.includeDirs ipo)
    , IPI.frameworkDirs = map f (IPI.frameworkDirs ipo)
    , IPI.haddockInterfaces = map f (IPI.haddockInterfaces ipo)
    , IPI.haddockHTMLs = map f (IPI.haddockHTMLs ipo)
    }
  where
    f :: String -> String
f (Char
'$' : Char
't' : Char
'o' : Char
'p' : Char
'd' : Char
'i' : Char
'r' : String
rest) = String
topDir String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
rest
    f String
x = String
x

-- Cabal does not use the environment variable GHC{,JS}_PACKAGE_PATH; let
-- users know that this is the case. See ticket #335. Simply ignoring it is
-- not a good idea, since then ghc and cabal are looking at different sets
-- of package DBs and chaos is likely to ensue.
--
-- An exception to this is when running cabal from within a `cabal exec`
-- environment. In this case, `cabal exec` will set the
-- CABAL_SANDBOX_PACKAGE_PATH to the same value that it set
-- GHC{,JS}_PACKAGE_PATH to. If that is the case it is OK to allow
-- GHC{,JS}_PACKAGE_PATH.
checkPackageDbEnvVar :: Verbosity -> String -> String -> IO ()
checkPackageDbEnvVar :: Verbosity -> String -> String -> IO ()
checkPackageDbEnvVar Verbosity
verbosity String
compilerName String
packagePathEnvVar = do
  mPP <- String -> IO (Maybe String)
lookupEnv String
packagePathEnvVar
  when (isJust mPP) $ do
    mcsPP <- lookupEnv "CABAL_SANDBOX_PACKAGE_PATH"
    unless (mPP == mcsPP) abort
  where
    lookupEnv :: String -> IO (Maybe String)
    lookupEnv :: String -> IO (Maybe String)
lookupEnv String
name =
      (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> IO String -> IO (Maybe String)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> IO String
getEnv String
name)
        IO (Maybe String)
-> (IOException -> IO (Maybe String)) -> IO (Maybe String)
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` IO (Maybe String) -> IOException -> IO (Maybe String)
forall a b. a -> b -> a
const (Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing)
    abort :: IO a
abort =
      Verbosity -> CabalException -> IO a
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity (CabalException -> IO a) -> CabalException -> IO a
forall a b. (a -> b) -> a -> b
$ String -> String -> CabalException
IncompatibleWithCabal String
compilerName String
packagePathEnvVar
    CallStack
_ = CallStack
HasCallStack => CallStack
callStack -- TODO: output stack when erroring

profDetailLevelFlag :: Bool -> ProfDetailLevel -> Flag GhcProfAuto
profDetailLevelFlag :: Bool -> ProfDetailLevel -> Flag GhcProfAuto
profDetailLevelFlag Bool
forLib ProfDetailLevel
mpl =
  case ProfDetailLevel
mpl of
    ProfDetailLevel
ProfDetailNone -> Flag GhcProfAuto
forall a. Monoid a => a
mempty
    ProfDetailLevel
ProfDetailDefault
      | Bool
forLib -> GhcProfAuto -> Flag GhcProfAuto
forall a. a -> Flag a
toFlag GhcProfAuto
GhcProfAutoExported
      | Bool
otherwise -> GhcProfAuto -> Flag GhcProfAuto
forall a. a -> Flag a
toFlag GhcProfAuto
GhcProfAutoToplevel
    ProfDetailLevel
ProfDetailExportedFunctions -> GhcProfAuto -> Flag GhcProfAuto
forall a. a -> Flag a
toFlag GhcProfAuto
GhcProfAutoExported
    ProfDetailLevel
ProfDetailToplevelFunctions -> GhcProfAuto -> Flag GhcProfAuto
forall a. a -> Flag a
toFlag GhcProfAuto
GhcProfAutoToplevel
    ProfDetailLevel
ProfDetailAllFunctions -> GhcProfAuto -> Flag GhcProfAuto
forall a. a -> Flag a
toFlag GhcProfAuto
GhcProfAutoAll
    ProfDetailLevel
ProfDetailTopLate -> GhcProfAuto -> Flag GhcProfAuto
forall a. a -> Flag a
toFlag GhcProfAuto
GhcProfLate
    ProfDetailOther String
_ -> Flag GhcProfAuto
forall a. Monoid a => a
mempty

-- -----------------------------------------------------------------------------
-- GHC platform and version strings

-- | GHC's rendering of its host or target 'Arch' as used in its platform
-- strings and certain file locations (such as user package db location).
ghcArchString :: Arch -> String
ghcArchString :: Arch -> String
ghcArchString Arch
PPC = String
"powerpc"
ghcArchString Arch
PPC64 = String
"powerpc64"
ghcArchString Arch
PPC64LE = String
"powerpc64le"
ghcArchString Arch
other = Arch -> String
forall a. Pretty a => a -> String
prettyShow Arch
other

-- | GHC's rendering of its host or target 'OS' as used in its platform
-- strings and certain file locations (such as user package db location).
ghcOsString :: OS -> String
ghcOsString :: OS -> String
ghcOsString OS
Windows = String
"mingw32"
ghcOsString OS
OSX = String
"darwin"
ghcOsString OS
Solaris = String
"solaris2"
ghcOsString OS
Hurd = String
"gnu"
ghcOsString OS
other = OS -> String
forall a. Pretty a => a -> String
prettyShow OS
other

-- | GHC's rendering of its platform and compiler version string as used in
-- certain file locations (such as user package db location).
-- For example @x86_64-linux-7.10.4@
ghcPlatformAndVersionString :: Platform -> Version -> String
ghcPlatformAndVersionString :: Platform -> Version -> String
ghcPlatformAndVersionString (Platform Arch
arch OS
os) Version
version =
  String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"-" [Arch -> String
ghcArchString Arch
arch, OS -> String
ghcOsString OS
os, Version -> String
forall a. Pretty a => a -> String
prettyShow Version
version]

-- -----------------------------------------------------------------------------
-- Constructing GHC environment files

-- | The kinds of entries we can stick in a @.ghc.environment@ file.
data GhcEnvironmentFileEntry
  = -- | @-- a comment@
    GhcEnvFileComment String
  | -- | @package-id foo-1.0-4fe301a...@
    GhcEnvFilePackageId UnitId
  | -- | @global-package-db@,
    --   @user-package-db@ or
    --   @package-db blah/package.conf.d/@
    GhcEnvFilePackageDb PackageDB
  | -- | @clear-package-db@
    GhcEnvFileClearPackageDbStack
  deriving (GhcEnvironmentFileEntry -> GhcEnvironmentFileEntry -> Bool
(GhcEnvironmentFileEntry -> GhcEnvironmentFileEntry -> Bool)
-> (GhcEnvironmentFileEntry -> GhcEnvironmentFileEntry -> Bool)
-> Eq GhcEnvironmentFileEntry
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GhcEnvironmentFileEntry -> GhcEnvironmentFileEntry -> Bool
== :: GhcEnvironmentFileEntry -> GhcEnvironmentFileEntry -> Bool
$c/= :: GhcEnvironmentFileEntry -> GhcEnvironmentFileEntry -> Bool
/= :: GhcEnvironmentFileEntry -> GhcEnvironmentFileEntry -> Bool
Eq, Eq GhcEnvironmentFileEntry
Eq GhcEnvironmentFileEntry =>
(GhcEnvironmentFileEntry -> GhcEnvironmentFileEntry -> Ordering)
-> (GhcEnvironmentFileEntry -> GhcEnvironmentFileEntry -> Bool)
-> (GhcEnvironmentFileEntry -> GhcEnvironmentFileEntry -> Bool)
-> (GhcEnvironmentFileEntry -> GhcEnvironmentFileEntry -> Bool)
-> (GhcEnvironmentFileEntry -> GhcEnvironmentFileEntry -> Bool)
-> (GhcEnvironmentFileEntry
    -> GhcEnvironmentFileEntry -> GhcEnvironmentFileEntry)
-> (GhcEnvironmentFileEntry
    -> GhcEnvironmentFileEntry -> GhcEnvironmentFileEntry)
-> Ord GhcEnvironmentFileEntry
GhcEnvironmentFileEntry -> GhcEnvironmentFileEntry -> Bool
GhcEnvironmentFileEntry -> GhcEnvironmentFileEntry -> Ordering
GhcEnvironmentFileEntry
-> GhcEnvironmentFileEntry -> GhcEnvironmentFileEntry
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: GhcEnvironmentFileEntry -> GhcEnvironmentFileEntry -> Ordering
compare :: GhcEnvironmentFileEntry -> GhcEnvironmentFileEntry -> Ordering
$c< :: GhcEnvironmentFileEntry -> GhcEnvironmentFileEntry -> Bool
< :: GhcEnvironmentFileEntry -> GhcEnvironmentFileEntry -> Bool
$c<= :: GhcEnvironmentFileEntry -> GhcEnvironmentFileEntry -> Bool
<= :: GhcEnvironmentFileEntry -> GhcEnvironmentFileEntry -> Bool
$c> :: GhcEnvironmentFileEntry -> GhcEnvironmentFileEntry -> Bool
> :: GhcEnvironmentFileEntry -> GhcEnvironmentFileEntry -> Bool
$c>= :: GhcEnvironmentFileEntry -> GhcEnvironmentFileEntry -> Bool
>= :: GhcEnvironmentFileEntry -> GhcEnvironmentFileEntry -> Bool
$cmax :: GhcEnvironmentFileEntry
-> GhcEnvironmentFileEntry -> GhcEnvironmentFileEntry
max :: GhcEnvironmentFileEntry
-> GhcEnvironmentFileEntry -> GhcEnvironmentFileEntry
$cmin :: GhcEnvironmentFileEntry
-> GhcEnvironmentFileEntry -> GhcEnvironmentFileEntry
min :: GhcEnvironmentFileEntry
-> GhcEnvironmentFileEntry -> GhcEnvironmentFileEntry
Ord, Int -> GhcEnvironmentFileEntry -> String -> String
[GhcEnvironmentFileEntry] -> String -> String
GhcEnvironmentFileEntry -> String
(Int -> GhcEnvironmentFileEntry -> String -> String)
-> (GhcEnvironmentFileEntry -> String)
-> ([GhcEnvironmentFileEntry] -> String -> String)
-> Show GhcEnvironmentFileEntry
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> GhcEnvironmentFileEntry -> String -> String
showsPrec :: Int -> GhcEnvironmentFileEntry -> String -> String
$cshow :: GhcEnvironmentFileEntry -> String
show :: GhcEnvironmentFileEntry -> String
$cshowList :: [GhcEnvironmentFileEntry] -> String -> String
showList :: [GhcEnvironmentFileEntry] -> String -> String
Show)

-- | Make entries for a GHC environment file based on a 'PackageDBStack' and
-- a bunch of package (unit) ids.
--
-- If you need to do anything more complicated then either use this as a basis
-- and add more entries, or just make all the entries directly.
simpleGhcEnvironmentFile
  :: PackageDBStack
  -> [UnitId]
  -> [GhcEnvironmentFileEntry]
simpleGhcEnvironmentFile :: PackageDBStack -> [UnitId] -> [GhcEnvironmentFileEntry]
simpleGhcEnvironmentFile PackageDBStack
packageDBs [UnitId]
pkgids =
  GhcEnvironmentFileEntry
GhcEnvFileClearPackageDbStack
    GhcEnvironmentFileEntry
-> [GhcEnvironmentFileEntry] -> [GhcEnvironmentFileEntry]
forall a. a -> [a] -> [a]
: (PackageDB -> GhcEnvironmentFileEntry)
-> PackageDBStack -> [GhcEnvironmentFileEntry]
forall a b. (a -> b) -> [a] -> [b]
map PackageDB -> GhcEnvironmentFileEntry
GhcEnvFilePackageDb PackageDBStack
packageDBs
    [GhcEnvironmentFileEntry]
-> [GhcEnvironmentFileEntry] -> [GhcEnvironmentFileEntry]
forall a. [a] -> [a] -> [a]
++ (UnitId -> GhcEnvironmentFileEntry)
-> [UnitId] -> [GhcEnvironmentFileEntry]
forall a b. (a -> b) -> [a] -> [b]
map UnitId -> GhcEnvironmentFileEntry
GhcEnvFilePackageId [UnitId]
pkgids

-- | Write a @.ghc.environment-$arch-$os-$ver@ file in the given directory.
--
-- The 'Platform' and GHC 'Version' are needed as part of the file name.
--
-- Returns the name of the file written.
writeGhcEnvironmentFile
  :: FilePath
  -- ^ directory in which to put it
  -> Platform
  -- ^ the GHC target platform
  -> Version
  -- ^ the GHC version
  -> [GhcEnvironmentFileEntry]
  -- ^ the content
  -> IO FilePath
writeGhcEnvironmentFile :: String
-> Platform -> Version -> [GhcEnvironmentFileEntry] -> IO String
writeGhcEnvironmentFile String
directory Platform
platform Version
ghcversion [GhcEnvironmentFileEntry]
entries = do
  String -> ByteString -> IO ()
writeFileAtomic String
envfile (ByteString -> IO ())
-> ([GhcEnvironmentFileEntry] -> ByteString)
-> [GhcEnvironmentFileEntry]
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
BS.pack (String -> ByteString)
-> ([GhcEnvironmentFileEntry] -> String)
-> [GhcEnvironmentFileEntry]
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GhcEnvironmentFileEntry] -> String
renderGhcEnvironmentFile ([GhcEnvironmentFileEntry] -> IO ())
-> [GhcEnvironmentFileEntry] -> IO ()
forall a b. (a -> b) -> a -> b
$ [GhcEnvironmentFileEntry]
entries
  String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
envfile
  where
    envfile :: String
envfile = String
directory String -> String -> String
</> Platform -> Version -> String
ghcEnvironmentFileName Platform
platform Version
ghcversion

-- | The @.ghc.environment-$arch-$os-$ver@ file name
ghcEnvironmentFileName :: Platform -> Version -> FilePath
ghcEnvironmentFileName :: Platform -> Version -> String
ghcEnvironmentFileName Platform
platform Version
ghcversion =
  String
".ghc.environment." String -> String -> String
forall a. [a] -> [a] -> [a]
++ Platform -> Version -> String
ghcPlatformAndVersionString Platform
platform Version
ghcversion

-- | Render a bunch of GHC environment file entries
renderGhcEnvironmentFile :: [GhcEnvironmentFileEntry] -> String
renderGhcEnvironmentFile :: [GhcEnvironmentFileEntry] -> String
renderGhcEnvironmentFile =
  [String] -> String
unlines ([String] -> String)
-> ([GhcEnvironmentFileEntry] -> [String])
-> [GhcEnvironmentFileEntry]
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GhcEnvironmentFileEntry -> String)
-> [GhcEnvironmentFileEntry] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map GhcEnvironmentFileEntry -> String
renderGhcEnvironmentFileEntry

-- | Render an individual GHC environment file entry
renderGhcEnvironmentFileEntry :: GhcEnvironmentFileEntry -> String
renderGhcEnvironmentFileEntry :: GhcEnvironmentFileEntry -> String
renderGhcEnvironmentFileEntry GhcEnvironmentFileEntry
entry = case GhcEnvironmentFileEntry
entry of
  GhcEnvFileComment String
comment -> String -> String
format String
comment
    where
      format :: String -> String
format = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"--" String -> String -> String
<++>) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
      String
pref <++> :: String -> String -> String
<++> String
"" = String
pref
      String
pref <++> String
str = String
pref String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str
  GhcEnvFilePackageId UnitId
pkgid -> String
"package-id " String -> String -> String
forall a. [a] -> [a] -> [a]
++ UnitId -> String
forall a. Pretty a => a -> String
prettyShow UnitId
pkgid
  GhcEnvFilePackageDb PackageDB
pkgdb ->
    case PackageDB
pkgdb of
      PackageDB
GlobalPackageDB -> String
"global-package-db"
      PackageDB
UserPackageDB -> String
"user-package-db"
      SpecificPackageDB String
dbfile -> String
"package-db " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dbfile
  GhcEnvironmentFileEntry
GhcEnvFileClearPackageDbStack -> String
"clear-package-db"