{-# LANGUAGE DataKinds #-}
{-# 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.ComponentLocalBuildInfo
import Distribution.Types.GivenComponent
import Distribution.Types.LocalBuildInfo
import Distribution.Types.TargetInfo
import Distribution.Types.UnitId
import Distribution.Utils.NubList (NubListR, 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, base_dir, mingwBinDir :: FilePath
    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
forall p q r. PathLike p q r => p -> q -> r
</> String
"mingw" String -> String -> String
forall p q r. PathLike p q r => p -> q -> r
</> 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
forall p q r. PathLike p q r => p -> q -> r
</> 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
supportsGHC2024 GhcImplInfo
implInfo =
      [(Language, String)] -> IO [(Language, String)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
        [ (Language
GHC2024, String
"-XGHC2024")
        , (Language
GHC2021, String
"-XGHC2021")
        , (Language
Haskell2010, String
"-XHaskell2010")
        , (Language
Haskell98, String
"-XHaskell98")
        ]
  | 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

includePaths
  :: LocalBuildInfo
  -> BuildInfo
  -> ComponentLocalBuildInfo
  -> SymbolicPath Pkg p
  -> NubListR (SymbolicPath Pkg (Dir Include))
includePaths :: forall (p :: FileOrDir).
LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> SymbolicPath Pkg p
-> NubListR (SymbolicPath Pkg ('Dir Include))
includePaths LocalBuildInfo
lbi BuildInfo
bi ComponentLocalBuildInfo
clbi SymbolicPath Pkg p
odir =
  [SymbolicPath Pkg ('Dir Include)]
-> NubListR (SymbolicPath Pkg ('Dir Include))
forall a. Ord a => [a] -> NubListR a
toNubListR ([SymbolicPath Pkg ('Dir Include)]
 -> NubListR (SymbolicPath Pkg ('Dir Include)))
-> [SymbolicPath Pkg ('Dir Include)]
-> NubListR (SymbolicPath Pkg ('Dir Include))
forall a b. (a -> b) -> a -> b
$
    [ SymbolicPath Pkg ('Dir Source) -> SymbolicPath Pkg ('Dir Include)
forall (allowAbsolute :: AllowAbsolute) from (to1 :: FileOrDir)
       (to2 :: FileOrDir).
SymbolicPathX allowAbsolute from to1
-> SymbolicPathX allowAbsolute from to2
coerceSymbolicPath (SymbolicPath Pkg ('Dir Source) -> SymbolicPath Pkg ('Dir Include))
-> SymbolicPath Pkg ('Dir Source)
-> SymbolicPath Pkg ('Dir Include)
forall a b. (a -> b) -> a -> b
$ LocalBuildInfo
-> ComponentLocalBuildInfo -> SymbolicPath Pkg ('Dir Source)
autogenComponentModulesDir LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi
    , SymbolicPath Pkg ('Dir Source) -> SymbolicPath Pkg ('Dir Include)
forall (allowAbsolute :: AllowAbsolute) from (to1 :: FileOrDir)
       (to2 :: FileOrDir).
SymbolicPathX allowAbsolute from to1
-> SymbolicPathX allowAbsolute from to2
coerceSymbolicPath (SymbolicPath Pkg ('Dir Source) -> SymbolicPath Pkg ('Dir Include))
-> SymbolicPath Pkg ('Dir Source)
-> SymbolicPath Pkg ('Dir Include)
forall a b. (a -> b) -> a -> b
$ LocalBuildInfo -> SymbolicPath Pkg ('Dir Source)
autogenPackageModulesDir LocalBuildInfo
lbi
    , SymbolicPath Pkg p -> SymbolicPath Pkg ('Dir Include)
forall (allowAbsolute :: AllowAbsolute) from (to1 :: FileOrDir)
       (to2 :: FileOrDir).
SymbolicPathX allowAbsolute from to1
-> SymbolicPathX allowAbsolute from to2
coerceSymbolicPath SymbolicPath Pkg p
odir
    ]
      -- includes relative to the package
      [SymbolicPath Pkg ('Dir Include)]
-> [SymbolicPath Pkg ('Dir Include)]
-> [SymbolicPath Pkg ('Dir Include)]
forall a. [a] -> [a] -> [a]
++ BuildInfo -> [SymbolicPath Pkg ('Dir Include)]
includeDirs BuildInfo
bi
      -- potential includes generated by `configure'
      -- in the build directory
      [SymbolicPath Pkg ('Dir Include)]
-> [SymbolicPath Pkg ('Dir Include)]
-> [SymbolicPath Pkg ('Dir Include)]
forall a. [a] -> [a] -> [a]
++ [ LocalBuildInfo -> SymbolicPath Pkg ('Dir Build)
buildDir LocalBuildInfo
lbi SymbolicPath Pkg ('Dir Build)
-> RelativePath Build ('Dir Include)
-> SymbolicPath Pkg ('Dir Include)
forall p q r. PathLike p q r => p -> q -> r
</> RelativePath Build ('Dir Include)
dir
         | RelativePath Build ('Dir Include)
dir <- (SymbolicPath Pkg ('Dir Include)
 -> Maybe (RelativePath Build ('Dir Include)))
-> [SymbolicPath Pkg ('Dir Include)]
-> [RelativePath Build ('Dir Include)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (SymbolicPath Build ('Dir Include)
-> Maybe (RelativePath Build ('Dir Include))
forall from (to :: FileOrDir).
SymbolicPath from to -> Maybe (RelativePath from to)
symbolicPathRelative_maybe (SymbolicPath Build ('Dir Include)
 -> Maybe (RelativePath Build ('Dir Include)))
-> (SymbolicPath Pkg ('Dir Include)
    -> SymbolicPath Build ('Dir Include))
-> SymbolicPath Pkg ('Dir Include)
-> Maybe (RelativePath Build ('Dir Include))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymbolicPath Pkg ('Dir Include)
-> SymbolicPath Build ('Dir Include)
forall (allowAbsolute :: AllowAbsolute) from1 (to1 :: FileOrDir)
       from2 (to2 :: FileOrDir).
SymbolicPathX allowAbsolute from1 to1
-> SymbolicPathX allowAbsolute from2 to2
unsafeCoerceSymbolicPath) ([SymbolicPath Pkg ('Dir Include)]
 -> [RelativePath Build ('Dir Include)])
-> [SymbolicPath Pkg ('Dir Include)]
-> [RelativePath Build ('Dir Include)]
forall a b. (a -> b) -> a -> b
$ BuildInfo -> [SymbolicPath Pkg ('Dir Include)]
includeDirs BuildInfo
bi
         ]

componentCcGhcOptions
  :: Verbosity
  -> LocalBuildInfo
  -> BuildInfo
  -> ComponentLocalBuildInfo
  -> SymbolicPath Pkg (Dir Artifacts)
  -> SymbolicPath Pkg File
  -> GhcOptions
componentCcGhcOptions :: Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> SymbolicPath Pkg ('Dir Artifacts)
-> SymbolicPath Pkg 'File
-> GhcOptions
componentCcGhcOptions Verbosity
verbosity LocalBuildInfo
lbi BuildInfo
bi ComponentLocalBuildInfo
clbi SymbolicPath Pkg ('Dir Artifacts)
odir SymbolicPath Pkg 'File
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 = includePaths lbi bi clbi odir
    , 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
  -> SymbolicPath Pkg (Dir Artifacts)
  -> SymbolicPath Pkg File
  -> GhcOptions
componentCxxGhcOptions :: Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> SymbolicPath Pkg ('Dir Artifacts)
-> SymbolicPath Pkg 'File
-> GhcOptions
componentCxxGhcOptions Verbosity
verbosity LocalBuildInfo
lbi BuildInfo
bi ComponentLocalBuildInfo
clbi SymbolicPath Pkg ('Dir Artifacts)
odir SymbolicPath Pkg 'File
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 = includePaths lbi bi clbi odir
    , 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
  -> SymbolicPath Pkg (Dir Artifacts)
  -> SymbolicPath Pkg File
  -> GhcOptions
componentAsmGhcOptions :: Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> SymbolicPath Pkg ('Dir Artifacts)
-> SymbolicPath Pkg 'File
-> GhcOptions
componentAsmGhcOptions Verbosity
verbosity LocalBuildInfo
lbi BuildInfo
bi ComponentLocalBuildInfo
clbi SymbolicPath Pkg ('Dir Artifacts)
odir SymbolicPath Pkg 'File
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 = includePaths lbi bi clbi odir
    , 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
  -> SymbolicPath Pkg (Dir Artifacts)
  -> SymbolicPath Pkg File
  -> GhcOptions
componentJsGhcOptions :: Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> SymbolicPath Pkg ('Dir Artifacts)
-> SymbolicPath Pkg 'File
-> GhcOptions
componentJsGhcOptions Verbosity
verbosity LocalBuildInfo
lbi BuildInfo
bi ComponentLocalBuildInfo
clbi SymbolicPath Pkg ('Dir Artifacts)
odir SymbolicPath Pkg 'File
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 = includePaths lbi bi clbi odir
    , ghcOptHideAllPackages = toFlag True
    , ghcOptPackageDBs = withPackageDB lbi
    , ghcOptPackages = toNubListR $ mkGhcOptPackages (promisedPkgs lbi) clbi
    , ghcOptObjDir = toFlag odir
    }

componentGhcOptions
  :: Verbosity
  -> LocalBuildInfo
  -> BuildInfo
  -> ComponentLocalBuildInfo
  -> SymbolicPath Pkg (Dir build)
  -> GhcOptions
componentGhcOptions :: forall build.
Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> SymbolicPath Pkg ('Dir build)
-> GhcOptions
componentGhcOptions Verbosity
verbosity LocalBuildInfo
lbi BuildInfo
bi ComponentLocalBuildInfo
clbi SymbolicPath Pkg ('Dir build)
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 $
              (hsSourceDirs bi)
                ++ [coerceSymbolicPath odir]
                ++ [autogenComponentModulesDir lbi clbi]
                ++ [autogenPackageModulesDir lbi]
        , ghcOptCppIncludePath = includePaths lbi bi clbi odir
        , ghcOptCppOptions = cppOptions bi
        , ghcOptCppIncludes =
            toNubListR $
              [coerceSymbolicPath (autogenComponentModulesDir lbi clbi </> makeRelativePathEx cppHeaderName)]
        , ghcOptFfiIncludes = toNubListR $ map getSymbolicPath $ includes bi
        , ghcOptObjDir = toFlag $ coerceSymbolicPath odir
        , ghcOptHiDir = toFlag $ coerceSymbolicPath odir
        , ghcOptHieDir = bool NoFlag (toFlag $ coerceSymbolicPath odir </> (extraCompilationArtifacts </> makeRelativePathEx "hie")) $ flagHie implInfo
        , ghcOptStubDir = toFlag $ coerceSymbolicPath odir
        , ghcOptOutputDir = toFlag $ coerceSymbolicPath 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 :: [SymbolicPath Pkg ('Dir Build)]
exe_paths =
      [ LocalBuildInfo
-> ComponentLocalBuildInfo -> SymbolicPath Pkg ('Dir Build)
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
  -> SymbolicPath Pkg (Dir Artifacts)
  -> SymbolicPath Pkg File
  -> GhcOptions
componentCmmGhcOptions :: Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> SymbolicPath Pkg ('Dir Artifacts)
-> SymbolicPath Pkg 'File
-> GhcOptions
componentCmmGhcOptions Verbosity
verbosity LocalBuildInfo
lbi BuildInfo
bi ComponentLocalBuildInfo
clbi SymbolicPath Pkg ('Dir Artifacts)
odir SymbolicPath Pkg 'File
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 = includePaths lbi bi clbi odir
    , ghcOptCppOptions = cppOptions bi
    , ghcOptCppIncludes =
        toNubListR $
          [autogenComponentModulesDir lbi clbi </> makeRelativePathEx 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
forall p. FileLike p => p -> String -> p
<.> String
"o"

mkGHCiProfLibName :: UnitId -> String
mkGHCiProfLibName :: UnitId -> String
mkGHCiProfLibName UnitId
lib = UnitId -> String
getHSLibraryName UnitId
lib String -> String -> String
forall p. FileLike p => p -> String -> p
<.> 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
  -> SymbolicPath Pkg (Dir Artifacts)
  -> String
  -> Bool
  -> IO [SymbolicPath Pkg File]
getHaskellObjects :: GhcImplInfo
-> Library
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> SymbolicPath Pkg ('Dir Artifacts)
-> String
-> Bool
-> IO [SymbolicPath Pkg 'File]
getHaskellObjects GhcImplInfo
_implInfo Library
lib LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi SymbolicPath Pkg ('Dir Artifacts)
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 :: [SymbolicPathX 'AllowAbsolute Pkg c3]
dirs =
            [ SymbolicPath Pkg ('Dir Artifacts)
pref SymbolicPath Pkg ('Dir Artifacts)
-> RelativePath Artifacts c3 -> SymbolicPathX 'AllowAbsolute Pkg c3
forall p q r. PathLike p q r => p -> q -> r
</> String -> RelativePath Artifacts c3
forall from (to :: FileOrDir).
HasCallStack =>
String -> RelativePath from to
makeRelativePathEx (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 <- (SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 0) -> IO [String])
-> [SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 0)] -> 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 -> IO [String])
-> (SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 0) -> String)
-> SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 0)
-> IO [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 0) -> String
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> String
i) [SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 0)]
forall {c3 :: FileOrDir}. [SymbolicPathX 'AllowAbsolute Pkg c3]
dirs
      let objs =
            [ SymbolicPathX 'AllowAbsolute Pkg ('Dir (ZonkAny 1))
dir SymbolicPathX 'AllowAbsolute Pkg ('Dir (ZonkAny 1))
-> RelativePath (ZonkAny 1) c3
-> SymbolicPathX 'AllowAbsolute Pkg c3
forall p q r. PathLike p q r => p -> q -> r
</> String -> RelativePath (ZonkAny 1) c3
forall from (to :: FileOrDir).
HasCallStack =>
String -> RelativePath from to
makeRelativePathEx String
obj
            | ([String]
objs', SymbolicPathX 'AllowAbsolute Pkg ('Dir (ZonkAny 1))
dir) <- [[String]]
-> [SymbolicPathX 'AllowAbsolute Pkg ('Dir (ZonkAny 1))]
-> [([String],
     SymbolicPathX 'AllowAbsolute Pkg ('Dir (ZonkAny 1)))]
forall a b. [a] -> [b] -> [(a, b)]
zip [[String]]
objss [SymbolicPathX 'AllowAbsolute Pkg ('Dir (ZonkAny 1))]
forall {c3 :: FileOrDir}. [SymbolicPathX 'AllowAbsolute Pkg c3]
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 =
      [SymbolicPath Pkg 'File] -> IO [SymbolicPath Pkg 'File]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
        [ SymbolicPath Pkg ('Dir Artifacts)
pref SymbolicPath Pkg ('Dir Artifacts)
-> RelativePath Artifacts 'File -> SymbolicPath Pkg 'File
forall p q r. PathLike p q r => p -> q -> r
</> String -> RelativePath Artifacts 'File
forall from (to :: FileOrDir).
HasCallStack =>
String -> RelativePath from to
makeRelativePathEx (ModuleName -> String
ModuleName.toFilePath ModuleName
x String -> String -> String
forall p. FileLike p => p -> String -> p
<.> String
wanted_obj_ext)
        | ModuleName
x <- Library -> ComponentLocalBuildInfo -> [ModuleName]
allLibModules Library
lib ComponentLocalBuildInfo
clbi
        ]
  where
    i :: SymbolicPathX allowAbsolute Pkg to -> String
i = LocalBuildInfo -> SymbolicPathX allowAbsolute Pkg to -> String
forall (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
LocalBuildInfo -> SymbolicPathX allowAbsolute Pkg to -> String
interpretSymbolicPathLBI LocalBuildInfo
lbi

-- | 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) PromisedComponent
  -> ComponentLocalBuildInfo
  -> [(OpenUnitId, ModuleRenaming)]
mkGhcOptPackages :: Map (PackageName, ComponentName) PromisedComponent
-> ComponentLocalBuildInfo -> [(OpenUnitId, ModuleRenaming)]
mkGhcOptPackages Map (PackageName, ComponentName) PromisedComponent
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 ((PromisedComponent -> UnitId) -> [PromisedComponent] -> [UnitId]
forall a b. (a -> b) -> [a] -> [b]
map (ComponentId -> UnitId
newSimpleUnitId (ComponentId -> UnitId)
-> (PromisedComponent -> ComponentId)
-> PromisedComponent
-> UnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PromisedComponent -> ComponentId
promisedComponentId) (Map (PackageName, ComponentName) PromisedComponent
-> [PromisedComponent]
forall k a. Map k a -> [a]
Map.elems Map (PackageName, ComponentName) PromisedComponent
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 fp
  = -- | @-- 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 (PackageDBX fp)
  | -- | @clear-package-db@
    GhcEnvFileClearPackageDbStack
  deriving (GhcEnvironmentFileEntry fp -> GhcEnvironmentFileEntry fp -> Bool
(GhcEnvironmentFileEntry fp -> GhcEnvironmentFileEntry fp -> Bool)
-> (GhcEnvironmentFileEntry fp
    -> GhcEnvironmentFileEntry fp -> Bool)
-> Eq (GhcEnvironmentFileEntry fp)
forall fp.
Eq fp =>
GhcEnvironmentFileEntry fp -> GhcEnvironmentFileEntry fp -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall fp.
Eq fp =>
GhcEnvironmentFileEntry fp -> GhcEnvironmentFileEntry fp -> Bool
== :: GhcEnvironmentFileEntry fp -> GhcEnvironmentFileEntry fp -> Bool
$c/= :: forall fp.
Eq fp =>
GhcEnvironmentFileEntry fp -> GhcEnvironmentFileEntry fp -> Bool
/= :: GhcEnvironmentFileEntry fp -> GhcEnvironmentFileEntry fp -> Bool
Eq, Eq (GhcEnvironmentFileEntry fp)
Eq (GhcEnvironmentFileEntry fp) =>
(GhcEnvironmentFileEntry fp
 -> GhcEnvironmentFileEntry fp -> Ordering)
-> (GhcEnvironmentFileEntry fp
    -> GhcEnvironmentFileEntry fp -> Bool)
-> (GhcEnvironmentFileEntry fp
    -> GhcEnvironmentFileEntry fp -> Bool)
-> (GhcEnvironmentFileEntry fp
    -> GhcEnvironmentFileEntry fp -> Bool)
-> (GhcEnvironmentFileEntry fp
    -> GhcEnvironmentFileEntry fp -> Bool)
-> (GhcEnvironmentFileEntry fp
    -> GhcEnvironmentFileEntry fp -> GhcEnvironmentFileEntry fp)
-> (GhcEnvironmentFileEntry fp
    -> GhcEnvironmentFileEntry fp -> GhcEnvironmentFileEntry fp)
-> Ord (GhcEnvironmentFileEntry fp)
GhcEnvironmentFileEntry fp -> GhcEnvironmentFileEntry fp -> Bool
GhcEnvironmentFileEntry fp
-> GhcEnvironmentFileEntry fp -> Ordering
GhcEnvironmentFileEntry fp
-> GhcEnvironmentFileEntry fp -> GhcEnvironmentFileEntry fp
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
forall fp. Ord fp => Eq (GhcEnvironmentFileEntry fp)
forall fp.
Ord fp =>
GhcEnvironmentFileEntry fp -> GhcEnvironmentFileEntry fp -> Bool
forall fp.
Ord fp =>
GhcEnvironmentFileEntry fp
-> GhcEnvironmentFileEntry fp -> Ordering
forall fp.
Ord fp =>
GhcEnvironmentFileEntry fp
-> GhcEnvironmentFileEntry fp -> GhcEnvironmentFileEntry fp
$ccompare :: forall fp.
Ord fp =>
GhcEnvironmentFileEntry fp
-> GhcEnvironmentFileEntry fp -> Ordering
compare :: GhcEnvironmentFileEntry fp
-> GhcEnvironmentFileEntry fp -> Ordering
$c< :: forall fp.
Ord fp =>
GhcEnvironmentFileEntry fp -> GhcEnvironmentFileEntry fp -> Bool
< :: GhcEnvironmentFileEntry fp -> GhcEnvironmentFileEntry fp -> Bool
$c<= :: forall fp.
Ord fp =>
GhcEnvironmentFileEntry fp -> GhcEnvironmentFileEntry fp -> Bool
<= :: GhcEnvironmentFileEntry fp -> GhcEnvironmentFileEntry fp -> Bool
$c> :: forall fp.
Ord fp =>
GhcEnvironmentFileEntry fp -> GhcEnvironmentFileEntry fp -> Bool
> :: GhcEnvironmentFileEntry fp -> GhcEnvironmentFileEntry fp -> Bool
$c>= :: forall fp.
Ord fp =>
GhcEnvironmentFileEntry fp -> GhcEnvironmentFileEntry fp -> Bool
>= :: GhcEnvironmentFileEntry fp -> GhcEnvironmentFileEntry fp -> Bool
$cmax :: forall fp.
Ord fp =>
GhcEnvironmentFileEntry fp
-> GhcEnvironmentFileEntry fp -> GhcEnvironmentFileEntry fp
max :: GhcEnvironmentFileEntry fp
-> GhcEnvironmentFileEntry fp -> GhcEnvironmentFileEntry fp
$cmin :: forall fp.
Ord fp =>
GhcEnvironmentFileEntry fp
-> GhcEnvironmentFileEntry fp -> GhcEnvironmentFileEntry fp
min :: GhcEnvironmentFileEntry fp
-> GhcEnvironmentFileEntry fp -> GhcEnvironmentFileEntry fp
Ord, Int -> GhcEnvironmentFileEntry fp -> String -> String
[GhcEnvironmentFileEntry fp] -> String -> String
GhcEnvironmentFileEntry fp -> String
(Int -> GhcEnvironmentFileEntry fp -> String -> String)
-> (GhcEnvironmentFileEntry fp -> String)
-> ([GhcEnvironmentFileEntry fp] -> String -> String)
-> Show (GhcEnvironmentFileEntry fp)
forall fp.
Show fp =>
Int -> GhcEnvironmentFileEntry fp -> String -> String
forall fp.
Show fp =>
[GhcEnvironmentFileEntry fp] -> String -> String
forall fp. Show fp => GhcEnvironmentFileEntry fp -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: forall fp.
Show fp =>
Int -> GhcEnvironmentFileEntry fp -> String -> String
showsPrec :: Int -> GhcEnvironmentFileEntry fp -> String -> String
$cshow :: forall fp. Show fp => GhcEnvironmentFileEntry fp -> String
show :: GhcEnvironmentFileEntry fp -> String
$cshowList :: forall fp.
Show fp =>
[GhcEnvironmentFileEntry fp] -> String -> String
showList :: [GhcEnvironmentFileEntry fp] -> 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
  :: PackageDBStackX fp
  -> [UnitId]
  -> [GhcEnvironmentFileEntry fp]
simpleGhcEnvironmentFile :: forall fp.
PackageDBStackX fp -> [UnitId] -> [GhcEnvironmentFileEntry fp]
simpleGhcEnvironmentFile PackageDBStackX fp
packageDBs [UnitId]
pkgids =
  GhcEnvironmentFileEntry fp
forall fp. GhcEnvironmentFileEntry fp
GhcEnvFileClearPackageDbStack
    GhcEnvironmentFileEntry fp
-> [GhcEnvironmentFileEntry fp] -> [GhcEnvironmentFileEntry fp]
forall a. a -> [a] -> [a]
: (PackageDBX fp -> GhcEnvironmentFileEntry fp)
-> PackageDBStackX fp -> [GhcEnvironmentFileEntry fp]
forall a b. (a -> b) -> [a] -> [b]
map PackageDBX fp -> GhcEnvironmentFileEntry fp
forall fp. PackageDBX fp -> GhcEnvironmentFileEntry fp
GhcEnvFilePackageDb PackageDBStackX fp
packageDBs
    [GhcEnvironmentFileEntry fp]
-> [GhcEnvironmentFileEntry fp] -> [GhcEnvironmentFileEntry fp]
forall a. [a] -> [a] -> [a]
++ (UnitId -> GhcEnvironmentFileEntry fp)
-> [UnitId] -> [GhcEnvironmentFileEntry fp]
forall a b. (a -> b) -> [a] -> [b]
map UnitId -> GhcEnvironmentFileEntry fp
forall fp. UnitId -> GhcEnvironmentFileEntry fp
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 FilePath]
  -- ^ the content
  -> IO FilePath
writeGhcEnvironmentFile :: String
-> Platform
-> Version
-> [GhcEnvironmentFileEntry String]
-> IO String
writeGhcEnvironmentFile String
directory Platform
platform Version
ghcversion [GhcEnvironmentFileEntry String]
entries = do
  String -> ByteString -> IO ()
writeFileAtomic String
envfile (ByteString -> IO ())
-> ([GhcEnvironmentFileEntry String] -> ByteString)
-> [GhcEnvironmentFileEntry String]
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
BS.pack (String -> ByteString)
-> ([GhcEnvironmentFileEntry String] -> String)
-> [GhcEnvironmentFileEntry String]
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GhcEnvironmentFileEntry String] -> String
renderGhcEnvironmentFile ([GhcEnvironmentFileEntry String] -> IO ())
-> [GhcEnvironmentFileEntry String] -> IO ()
forall a b. (a -> b) -> a -> b
$ [GhcEnvironmentFileEntry String]
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
forall p q r. PathLike p q r => p -> q -> r
</> 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 FilePath] -> String
renderGhcEnvironmentFile :: [GhcEnvironmentFileEntry String] -> String
renderGhcEnvironmentFile =
  [String] -> String
unlines ([String] -> String)
-> ([GhcEnvironmentFileEntry String] -> [String])
-> [GhcEnvironmentFileEntry String]
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GhcEnvironmentFileEntry String -> String)
-> [GhcEnvironmentFileEntry String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map GhcEnvironmentFileEntry String -> String
renderGhcEnvironmentFileEntry

-- | Render an individual GHC environment file entry
renderGhcEnvironmentFileEntry :: GhcEnvironmentFileEntry FilePath -> String
renderGhcEnvironmentFileEntry :: GhcEnvironmentFileEntry String -> String
renderGhcEnvironmentFileEntry GhcEnvironmentFileEntry String
entry = case GhcEnvironmentFileEntry String
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 PackageDBX String
pkgdb ->
    case PackageDBX String
pkgdb of
      PackageDBX String
GlobalPackageDB -> String
"global-package-db"
      PackageDBX String
UserPackageDB -> String
"user-package-db"
      SpecificPackageDB String
dbfile -> String
"package-db " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dbfile
  GhcEnvironmentFileEntry String
GhcEnvFileClearPackageDbStack -> String
"clear-package-db"