{-# LANGUAGE LambdaCase #-}

module Distribution.Simple.GHC.Build.Link where

import Distribution.Compat.Prelude
import Prelude ()

import Control.Exception (assert)
import Control.Monad (forM_)
import Control.Monad.IO.Class
import qualified Data.ByteString.Lazy.Char8 as BS
import qualified Data.Set as Set
import Distribution.Compat.Binary (encode)
import Distribution.Compat.ResponseFile
import Distribution.InstalledPackageInfo (InstalledPackageInfo)
import qualified Distribution.InstalledPackageInfo as IPI
import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo
import qualified Distribution.ModuleName as ModuleName
import Distribution.Package
import Distribution.PackageDescription as PD
import Distribution.PackageDescription.Utils (cabalBug)
import Distribution.Pretty
import Distribution.Simple.Build.Inputs
import Distribution.Simple.BuildPaths
import Distribution.Simple.Compiler
import Distribution.Simple.GHC.Build.Modules
import Distribution.Simple.GHC.Build.Utils (exeTargetName, flibBuildName, flibTargetName, withDynFLib)
import Distribution.Simple.GHC.ImplInfo
import qualified Distribution.Simple.GHC.Internal as Internal
import Distribution.Simple.LocalBuildInfo
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Simple.PreProcess.Types
import Distribution.Simple.Program
import qualified Distribution.Simple.Program.Ar as Ar
import Distribution.Simple.Program.GHC
import qualified Distribution.Simple.Program.Ld as Ld
import Distribution.Simple.Setup.Common
import Distribution.Simple.Setup.Repl
import Distribution.Simple.Utils
import Distribution.System
import Distribution.Types.ComponentLocalBuildInfo
import Distribution.Utils.NubList
import Distribution.Verbosity
import Distribution.Version
import System.Directory
import System.FilePath

-- | Links together the object files of the Haskell modules and extra sources
-- using the context in which the component is being built.
--
-- If the build kind is 'BuildRepl', we load the component into GHCi instead of linking.
linkOrLoadComponent
  :: ConfiguredProgram
  -- ^ The configured GHC program that will be used for linking
  -> PackageDescription
  -- ^ The package description containing the component being built
  -> [FilePath]
  -- ^ The full list of extra build sources (all C, C++, Js,
  -- Asm, and Cmm sources), which were compiled to object
  -- files.
  -> (FilePath, FilePath)
  -- ^ The build target dir, and the target dir.
  -- See Note [Build Target Dir vs Target Dir] in Distribution.Simple.GHC.Build
  -> (Set.Set BuildWay, BuildWay -> GhcOptions)
  -- ^ The set of build ways wanted based on the user opts, and a function to
  -- convert a build way into the set of ghc options that were used to build
  -- that way.
  -> PreBuildComponentInputs
  -- ^ The context and component being built in it.
  -> IO ()
linkOrLoadComponent :: ConfiguredProgram
-> PackageDescription
-> [String]
-> (String, String)
-> (Set BuildWay, BuildWay -> GhcOptions)
-> PreBuildComponentInputs
-> IO ()
linkOrLoadComponent ConfiguredProgram
ghcProg PackageDescription
pkg_descr [String]
extraSources (String
buildTargetDir, String
targetDir) (Set BuildWay
wantedWays, BuildWay -> GhcOptions
buildOpts) PreBuildComponentInputs
pbci = do
  let
    verbosity :: Verbosity
verbosity = PreBuildComponentInputs -> Verbosity
buildVerbosity PreBuildComponentInputs
pbci
    target :: TargetInfo
target = PreBuildComponentInputs -> TargetInfo
targetInfo PreBuildComponentInputs
pbci
    component :: Component
component = PreBuildComponentInputs -> Component
buildComponent PreBuildComponentInputs
pbci
    what :: BuildingWhat
what = PreBuildComponentInputs -> BuildingWhat
buildingWhat PreBuildComponentInputs
pbci
    lbi :: LocalBuildInfo
lbi = PreBuildComponentInputs -> LocalBuildInfo
localBuildInfo PreBuildComponentInputs
pbci
    bi :: BuildInfo
bi = PreBuildComponentInputs -> BuildInfo
buildBI PreBuildComponentInputs
pbci
    clbi :: ComponentLocalBuildInfo
clbi = PreBuildComponentInputs -> ComponentLocalBuildInfo
buildCLBI PreBuildComponentInputs
pbci

  -- ensure extra lib dirs exist before passing to ghc
  [String]
cleanedExtraLibDirs <- IO [String] -> IO [String]
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> IO [String]) -> IO [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesDirectoryExist (BuildInfo -> [String]
extraLibDirs BuildInfo
bi)
  [String]
cleanedExtraLibDirsStatic <- IO [String] -> IO [String]
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> IO [String]) -> IO [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesDirectoryExist (BuildInfo -> [String]
extraLibDirsStatic BuildInfo
bi)

  let
    extraSourcesObjs :: [String]
extraSourcesObjs = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> String
`replaceExtension` String
objExtension) [String]
extraSources

    -- TODO: Shouldn't we use withStaticLib for libraries and something else
    -- for foreign libs in the three cases where we use `withFullyStaticExe` below?
    linkerOpts :: NubListR String -> GhcOptions
linkerOpts NubListR String
rpaths =
      GhcOptions
forall a. Monoid a => a
mempty
        { ghcOptLinkOptions =
            PD.ldOptions bi
              ++ [ "-static"
                 | withFullyStaticExe lbi
                 ]
              -- Pass extra `ld-options` given
              -- through to GHC's linker.
              ++ maybe
                []
                programOverrideArgs
                (lookupProgram ldProgram (withPrograms lbi))
        , ghcOptLinkLibs =
            if withFullyStaticExe lbi
              then extraLibsStatic bi
              else extraLibs bi
        , ghcOptLinkLibPath =
            toNubListR $
              if withFullyStaticExe lbi
                then cleanedExtraLibDirsStatic
                else cleanedExtraLibDirs
        , ghcOptLinkFrameworks = toNubListR $ PD.frameworks bi
        , ghcOptLinkFrameworkDirs = toNubListR $ PD.extraFrameworkDirs bi
        , ghcOptInputFiles = toNubListR [buildTargetDir </> x | x <- extraSourcesObjs]
        , ghcOptNoLink = Flag False
        , ghcOptRPaths = rpaths
        }
  case BuildingWhat
what of
    BuildRepl ReplFlags
replFlags -> IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      let
        -- For repl we use the vanilla (static) ghc options
        staticOpts :: GhcOptions
staticOpts = BuildWay -> GhcOptions
buildOpts BuildWay
StaticWay
        replOpts :: GhcOptions
replOpts =
          GhcOptions
staticOpts
            { -- Repl options use Static as the base, but doesn't need to pass -static.
              -- However, it maybe should, for uniformity.
              ghcOptDynLinkMode = NoFlag
            , ghcOptExtra =
                Internal.filterGhciFlags
                  (ghcOptExtra staticOpts)
                  <> replOptionsFlags (replReplOptions replFlags)
            , ghcOptInputModules = replNoLoad (replReplOptions replFlags) (ghcOptInputModules staticOpts)
            , ghcOptInputFiles = replNoLoad (replReplOptions replFlags) (ghcOptInputFiles staticOpts)
            }
            -- For a normal compile we do separate invocations of ghc for
            -- compiling as for linking. But for repl we have to do just
            -- the one invocation, so that one has to include all the
            -- linker stuff too, like -l flags and any .o files from C
            -- files etc.
            --
            -- TODO: The repl doesn't use the runtime paths from linkerOpts
            -- (ghcOptRPaths), which looks like a bug. After the refactor we
            -- can fix this.
            GhcOptions -> GhcOptions -> GhcOptions
forall a. Monoid a => a -> a -> a
`mappend` NubListR String -> GhcOptions
linkerOpts NubListR String
forall a. Monoid a => a
mempty
            GhcOptions -> GhcOptions -> GhcOptions
forall a. Monoid a => a -> a -> a
`mappend` GhcOptions
forall a. Monoid a => a
mempty
              { ghcOptMode = toFlag GhcModeInteractive
              , ghcOptOptimisation = toFlag GhcNoOptimisation
              }

      -- TODO: problem here is we need the .c files built first, so we can load them
      -- with ghci, but .c files can depend on .h files generated by ghc by ffi
      -- exports.
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (case Component
component of CLib Library
lib -> [ModuleName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Library -> ComponentLocalBuildInfo -> [ModuleName]
allLibModules Library
lib ComponentLocalBuildInfo
clbi); Component
_ -> Bool
False) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Verbosity -> String -> IO ()
warn Verbosity
verbosity String
"No exposed modules"
      ConfiguredProgram
-> LocalBuildInfo
-> ReplFlags
-> GhcOptions
-> PackageName
-> TargetInfo
-> IO ()
runReplOrWriteFlags ConfiguredProgram
ghcProg LocalBuildInfo
lbi ReplFlags
replFlags GhcOptions
replOpts (PackageIdentifier -> PackageName
pkgName (PackageDescription -> PackageIdentifier
PD.package PackageDescription
pkg_descr)) TargetInfo
target
    BuildingWhat
_otherwise ->
      let
        runGhcProg :: GhcOptions -> IO ()
runGhcProg = Verbosity
-> ConfiguredProgram -> Compiler -> Platform -> GhcOptions -> IO ()
runGHC Verbosity
verbosity ConfiguredProgram
ghcProg Compiler
comp Platform
platform
        platform :: Platform
platform = LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi
        comp :: Compiler
comp = LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi
       in
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ComponentLocalBuildInfo -> Bool
componentIsIndefinite ComponentLocalBuildInfo
clbi) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          -- If not building dynamically, we don't pass any runtime paths.
          NubListR String
rpaths <- if BuildWay
DynWay BuildWay -> Set BuildWay -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set BuildWay
wantedWays then PreBuildComponentInputs -> IO (NubListR String)
getRPaths PreBuildComponentInputs
pbci else NubListR String -> IO (NubListR String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> NubListR String
forall a. Ord a => [a] -> NubListR a
toNubListR [])
          IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Verbosity -> String -> IO ()
info Verbosity
verbosity String
"Linking..."
            let linkExeLike :: UnqualComponentName -> IO ()
linkExeLike UnqualComponentName
name = GhcOptions
-> (Set BuildWay, BuildWay -> GhcOptions)
-> String
-> UnqualComponentName
-> (GhcOptions -> IO ())
-> LocalBuildInfo
-> IO ()
linkExecutable (NubListR String -> GhcOptions
linkerOpts NubListR String
rpaths) (Set BuildWay
wantedWays, BuildWay -> GhcOptions
buildOpts) String
targetDir UnqualComponentName
name GhcOptions -> IO ()
runGhcProg LocalBuildInfo
lbi
            case Component
component of
              CLib Library
lib -> String
-> [String]
-> PackageDescription
-> Verbosity
-> (GhcOptions -> IO ())
-> Library
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> [String]
-> NubListR String
-> Set BuildWay
-> IO ()
linkLibrary String
buildTargetDir [String]
cleanedExtraLibDirs PackageDescription
pkg_descr Verbosity
verbosity GhcOptions -> IO ()
runGhcProg Library
lib LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi [String]
extraSources NubListR String
rpaths Set BuildWay
wantedWays
              CFLib ForeignLib
flib -> ForeignLib
-> BuildInfo
-> LocalBuildInfo
-> GhcOptions
-> (Set BuildWay, BuildWay -> GhcOptions)
-> String
-> (GhcOptions -> IO ())
-> IO ()
linkFLib ForeignLib
flib BuildInfo
bi LocalBuildInfo
lbi (NubListR String -> GhcOptions
linkerOpts NubListR String
rpaths) (Set BuildWay
wantedWays, BuildWay -> GhcOptions
buildOpts) String
targetDir GhcOptions -> IO ()
runGhcProg
              CExe Executable
exe -> UnqualComponentName -> IO ()
linkExeLike (Executable -> UnqualComponentName
exeName Executable
exe)
              CTest TestSuite
test -> UnqualComponentName -> IO ()
linkExeLike (TestSuite -> UnqualComponentName
testName TestSuite
test)
              CBench Benchmark
bench -> UnqualComponentName -> IO ()
linkExeLike (Benchmark -> UnqualComponentName
benchmarkName Benchmark
bench)

-- | Link a library component
linkLibrary
  :: FilePath
  -- ^ The library target build directory
  -> [FilePath]
  -- ^ The list of extra lib dirs that exist (aka "cleaned")
  -> PackageDescription
  -- ^ The package description containing this library
  -> Verbosity
  -> (GhcOptions -> IO ())
  -- ^ Run the configured Ghc program
  -> Library
  -> LocalBuildInfo
  -> ComponentLocalBuildInfo
  -> [FilePath]
  -- ^ Extra build sources (that were compiled to objects)
  -> NubListR FilePath
  -- ^ A list with the runtime-paths (rpaths), or empty if not linking dynamically
  -> Set.Set BuildWay
  -- ^ Wanted build ways and corresponding build options
  -> IO ()
linkLibrary :: String
-> [String]
-> PackageDescription
-> Verbosity
-> (GhcOptions -> IO ())
-> Library
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> [String]
-> NubListR String
-> Set BuildWay
-> IO ()
linkLibrary String
buildTargetDir [String]
cleanedExtraLibDirs PackageDescription
pkg_descr Verbosity
verbosity GhcOptions -> IO ()
runGhcProg Library
lib LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi [String]
extraSources NubListR String
rpaths Set BuildWay
wantedWays = do
  let
    compiler_id :: CompilerId
compiler_id = Compiler -> CompilerId
compilerId Compiler
comp
    comp :: Compiler
comp = LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi
    ghcVersion :: Version
ghcVersion = Compiler -> Version
compilerVersion Compiler
comp
    implInfo :: GhcImplInfo
implInfo = Compiler -> GhcImplInfo
getImplInfo Compiler
comp
    uid :: UnitId
uid = ComponentLocalBuildInfo -> UnitId
componentUnitId ComponentLocalBuildInfo
clbi
    libBi :: BuildInfo
libBi = Library -> BuildInfo
libBuildInfo Library
lib
    Platform Arch
_hostArch OS
hostOS = LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi
    vanillaLibFilePath :: String
vanillaLibFilePath = String
buildTargetDir String -> String -> String
</> UnitId -> String
mkLibName UnitId
uid
    profileLibFilePath :: String
profileLibFilePath = String
buildTargetDir String -> String -> String
</> UnitId -> String
mkProfLibName UnitId
uid
    sharedLibFilePath :: String
sharedLibFilePath =
      String
buildTargetDir
        String -> String -> String
</> Platform -> CompilerId -> UnitId -> String
mkSharedLibName (LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi) CompilerId
compiler_id UnitId
uid
    staticLibFilePath :: String
staticLibFilePath =
      String
buildTargetDir
        String -> String -> String
</> Platform -> CompilerId -> UnitId -> String
mkStaticLibName (LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi) CompilerId
compiler_id UnitId
uid
    ghciLibFilePath :: String
ghciLibFilePath = String
buildTargetDir String -> String -> String
</> UnitId -> String
Internal.mkGHCiLibName UnitId
uid
    ghciProfLibFilePath :: String
ghciProfLibFilePath = String
buildTargetDir String -> String -> String
</> UnitId -> String
Internal.mkGHCiProfLibName UnitId
uid
    libInstallPath :: String
libInstallPath =
      InstallDirs String -> String
forall dir. InstallDirs dir -> dir
libdir (InstallDirs String -> String) -> InstallDirs String -> String
forall a b. (a -> b) -> a -> b
$
        PackageDescription
-> LocalBuildInfo -> UnitId -> CopyDest -> InstallDirs String
absoluteComponentInstallDirs
          PackageDescription
pkg_descr
          LocalBuildInfo
lbi
          UnitId
uid
          CopyDest
NoCopyDest
    sharedLibInstallPath :: String
sharedLibInstallPath =
      String
libInstallPath
        String -> String -> String
</> Platform -> CompilerId -> UnitId -> String
mkSharedLibName (LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi) CompilerId
compiler_id UnitId
uid

    getObjFiles :: BuildWay -> IO [String]
getObjFiles BuildWay
way =
      [IO [String]] -> IO [String]
forall a. Monoid a => [a] -> a
mconcat
        [ GhcImplInfo
-> Library
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> String
-> String
-> Bool
-> IO [String]
Internal.getHaskellObjects
            GhcImplInfo
implInfo
            Library
lib
            LocalBuildInfo
lbi
            ComponentLocalBuildInfo
clbi
            String
buildTargetDir
            (BuildWay -> String
buildWayPrefix BuildWay
way String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
objExtension)
            Bool
True
        , [String] -> IO [String]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$
            (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
buildTargetDir String -> String -> String
</>) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$
              (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> String -> String
`replaceExtension` (BuildWay -> String
buildWayPrefix BuildWay
way String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
objExtension))) [String]
extraSources
        , [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes
            ([Maybe String] -> [String]) -> IO [Maybe String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [IO (Maybe String)] -> IO [Maybe String]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => [f a] -> f [a]
sequenceA
              [ [Suffix] -> [String] -> String -> IO (Maybe String)
findFileWithExtension
                [String -> Suffix
Suffix (String -> Suffix) -> String -> Suffix
forall a b. (a -> b) -> a -> b
$ BuildWay -> String
buildWayPrefix BuildWay
way String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
objExtension]
                [String
buildTargetDir]
                (ModuleName -> String
ModuleName.toFilePath ModuleName
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"_stub")
              | Version
ghcVersion Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< [Int] -> Version
mkVersion [Int
7, Int
2] -- ghc-7.2+ does not make _stub.o files
              , ModuleName
x <- Library -> ComponentLocalBuildInfo -> [ModuleName]
allLibModules Library
lib ComponentLocalBuildInfo
clbi
              ]
        ]

    -- I'm fairly certain that, just like the executable, we can keep just the
    -- module input list, and point to the right sources dir (as is already
    -- done), and GHC will pick up the right suffix (p_ for profile, dyn_ when
    -- -shared...). The downside to doing this is that GHC would have to
    -- reconstruct the module graph again.
    -- That would mean linking the lib would be just like the executable, and
    -- we could more easily merge the two.
    --
    -- Right now, instead, we pass the path to each object file.
    ghcBaseLinkArgs :: GhcOptions
ghcBaseLinkArgs =
      GhcOptions
forall a. Monoid a => a
mempty
        { -- TODO: This basically duplicates componentGhcOptions.
          -- I think we want to do the same as we do for executables: re-use the
          -- base options, and link by module names, not object paths.
          ghcOptExtra = hcStaticOptions GHC libBi
        , ghcOptHideAllPackages = toFlag True
        , ghcOptNoAutoLinkPackages = toFlag True
        , ghcOptPackageDBs = withPackageDB lbi
        , ghcOptThisUnitId = case clbi of
            LibComponentLocalBuildInfo{componentCompatPackageKey :: ComponentLocalBuildInfo -> String
componentCompatPackageKey = String
pk} ->
              String -> Flag String
forall a. a -> Flag a
toFlag String
pk
            ComponentLocalBuildInfo
_ -> Flag String
forall a. Monoid a => a
mempty
        , ghcOptThisComponentId = case clbi of
            LibComponentLocalBuildInfo
              { 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 (ComponentLocalBuildInfo -> ComponentId
componentComponentId ComponentLocalBuildInfo
clbi)
            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
_ -> []
        , ghcOptPackages =
            toNubListR $
              Internal.mkGhcOptPackages mempty clbi
        }

    -- After the relocation lib is created we invoke ghc -shared
    -- with the dependencies spelled out as -package arguments
    -- and ghc invokes the linker with the proper library paths
    ghcSharedLinkArgs :: [String] -> GhcOptions
ghcSharedLinkArgs [String]
dynObjectFiles =
      GhcOptions
ghcBaseLinkArgs
        { ghcOptShared = toFlag True
        , ghcOptDynLinkMode = toFlag GhcDynamicOnly
        , ghcOptInputFiles = toNubListR dynObjectFiles
        , ghcOptOutputFile = toFlag sharedLibFilePath
        , -- For dynamic libs, Mac OS/X needs to know the install location
          -- at build time. This only applies to GHC < 7.8 - see the
          -- discussion in #1660.
          ghcOptDylibName =
            if hostOS == OSX
              && ghcVersion < mkVersion [7, 8]
              then toFlag sharedLibInstallPath
              else mempty
        , ghcOptLinkLibs = extraLibs libBi
        , ghcOptLinkLibPath = toNubListR $ cleanedExtraLibDirs
        , ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi
        , ghcOptLinkFrameworkDirs =
            toNubListR $ PD.extraFrameworkDirs libBi
        , ghcOptRPaths = rpaths
        }
    ghcStaticLinkArgs :: [String] -> GhcOptions
ghcStaticLinkArgs [String]
staticObjectFiles =
      GhcOptions
ghcBaseLinkArgs
        { ghcOptStaticLib = toFlag True
        , ghcOptInputFiles = toNubListR staticObjectFiles
        , ghcOptOutputFile = toFlag staticLibFilePath
        , ghcOptLinkLibs = extraLibs libBi
        , -- TODO: Shouldn't this use cleanedExtraLibDirsStatic instead?
          ghcOptLinkLibPath = toNubListR $ cleanedExtraLibDirs
        }

  [String]
staticObjectFiles <- BuildWay -> IO [String]
getObjFiles BuildWay
StaticWay
  [String]
profObjectFiles <- BuildWay -> IO [String]
getObjFiles BuildWay
ProfWay
  [String]
dynamicObjectFiles <- BuildWay -> IO [String]
getObjFiles BuildWay
DynWay

  let
    linkWay :: BuildWay -> IO ()
linkWay = \case
      BuildWay
ProfWay -> do
        Verbosity -> LocalBuildInfo -> String -> [String] -> IO ()
Ar.createArLibArchive Verbosity
verbosity LocalBuildInfo
lbi String
profileLibFilePath [String]
profObjectFiles
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LocalBuildInfo -> Bool
withGHCiLib LocalBuildInfo
lbi) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          (ConfiguredProgram
ldProg, ProgramDb
_) <- Verbosity
-> Program -> ProgramDb -> IO (ConfiguredProgram, ProgramDb)
requireProgram Verbosity
verbosity Program
ldProgram (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)
          Verbosity
-> LocalBuildInfo
-> ConfiguredProgram
-> String
-> [String]
-> IO ()
Ld.combineObjectFiles
            Verbosity
verbosity
            LocalBuildInfo
lbi
            ConfiguredProgram
ldProg
            String
ghciProfLibFilePath
            [String]
profObjectFiles
      BuildWay
DynWay -> do
        GhcOptions -> IO ()
runGhcProg (GhcOptions -> IO ()) -> GhcOptions -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> GhcOptions
ghcSharedLinkArgs [String]
dynamicObjectFiles
      BuildWay
StaticWay -> do
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LocalBuildInfo -> Bool
withVanillaLib LocalBuildInfo
lbi) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          Verbosity -> LocalBuildInfo -> String -> [String] -> IO ()
Ar.createArLibArchive Verbosity
verbosity LocalBuildInfo
lbi String
vanillaLibFilePath [String]
staticObjectFiles
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LocalBuildInfo -> Bool
withGHCiLib LocalBuildInfo
lbi) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            (ConfiguredProgram
ldProg, ProgramDb
_) <- Verbosity
-> Program -> ProgramDb -> IO (ConfiguredProgram, ProgramDb)
requireProgram Verbosity
verbosity Program
ldProgram (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)
            Verbosity
-> LocalBuildInfo
-> ConfiguredProgram
-> String
-> [String]
-> IO ()
Ld.combineObjectFiles
              Verbosity
verbosity
              LocalBuildInfo
lbi
              ConfiguredProgram
ldProg
              String
ghciLibFilePath
              [String]
staticObjectFiles
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LocalBuildInfo -> Bool
withStaticLib LocalBuildInfo
lbi) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          GhcOptions -> IO ()
runGhcProg (GhcOptions -> IO ()) -> GhcOptions -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> GhcOptions
ghcStaticLinkArgs [String]
staticObjectFiles

  -- ROMES: Why exactly branch on staticObjectFiles, rather than any other build
  -- kind that we might have wanted instead?
  -- This would be simpler by not adding every object to the invocation, and
  -- rather using module names.
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
staticObjectFiles) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Verbosity -> String -> IO ()
info Verbosity
verbosity (NubListR (OpenUnitId, ModuleRenaming) -> String
forall a. Show a => a -> String
show (GhcOptions -> NubListR (OpenUnitId, ModuleRenaming)
ghcOptPackages (Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> String
-> GhcOptions
Internal.componentGhcOptions Verbosity
verbosity LocalBuildInfo
lbi BuildInfo
libBi ComponentLocalBuildInfo
clbi String
buildTargetDir)))
    (BuildWay -> IO ()) -> Set BuildWay -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ BuildWay -> IO ()
linkWay Set BuildWay
wantedWays

-- | Link the executable resulting from building this component, be it an
-- executable, test, or benchmark component.
linkExecutable
  :: (GhcOptions)
  -- ^ The linker-specific GHC options
  -> (Set.Set BuildWay, BuildWay -> GhcOptions)
  -- ^ The wanted build ways and corresponding GhcOptions that were
  -- used to compile the modules in that way.
  -> FilePath
  -- ^ The target dir (2024-01:note: not the same as build target
  -- dir, see Note [Build Target Dir vs Target Dir] in Distribution.Simple.GHC.Build)
  -> UnqualComponentName
  -- ^ Name of executable-like target
  -> (GhcOptions -> IO ())
  -- ^ Run the configured GHC program
  -> LocalBuildInfo
  -> IO ()
linkExecutable :: GhcOptions
-> (Set BuildWay, BuildWay -> GhcOptions)
-> String
-> UnqualComponentName
-> (GhcOptions -> IO ())
-> LocalBuildInfo
-> IO ()
linkExecutable GhcOptions
linkerOpts (Set BuildWay
wantedWays, BuildWay -> GhcOptions
buildOpts) String
targetDir UnqualComponentName
targetName GhcOptions -> IO ()
runGhcProg LocalBuildInfo
lbi = do
  -- When building an executable, we should only "want" one build way.
  Bool -> IO () -> IO ()
forall a. HasCallStack => Bool -> a -> a
assert (Set BuildWay -> Int
forall a. Set a -> Int
Set.size Set BuildWay
wantedWays Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Set BuildWay -> (BuildWay -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Set BuildWay
wantedWays ((BuildWay -> IO ()) -> IO ()) -> (BuildWay -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \BuildWay
way -> do
      let baseOpts :: GhcOptions
baseOpts = BuildWay -> GhcOptions
buildOpts BuildWay
way
          linkOpts :: GhcOptions
linkOpts =
            GhcOptions
baseOpts
              GhcOptions -> GhcOptions -> GhcOptions
forall a. Monoid a => a -> a -> a
`mappend` GhcOptions
linkerOpts
              GhcOptions -> GhcOptions -> GhcOptions
forall a. Monoid a => a -> a -> a
`mappend` GhcOptions
forall a. Monoid a => a
mempty
                { -- If there are no input Haskell files we pass -no-hs-main, and
                  -- assume there is a main function in another non-haskell object
                  ghcOptLinkNoHsMain = toFlag (ghcOptInputFiles baseOpts == mempty && ghcOptInputScripts baseOpts == mempty)
                }
          comp :: Compiler
comp = LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi

      -- Work around old GHCs not relinking in this
      -- situation, see #3294
      let target :: String
target = String
targetDir String -> String -> String
</> Platform -> UnqualComponentName -> String
exeTargetName (LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi) UnqualComponentName
targetName
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Compiler -> Version
compilerVersion Compiler
comp Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< [Int] -> Version
mkVersion [Int
7, Int
7]) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Bool
e <- String -> IO Bool
doesFileExist String
target
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
e (String -> IO ()
removeFile String
target)
      GhcOptions -> IO ()
runGhcProg GhcOptions
linkOpts{ghcOptOutputFile = toFlag target}

-- | Link a foreign library component
linkFLib
  :: ForeignLib
  -> BuildInfo
  -> LocalBuildInfo
  -> (GhcOptions)
  -- ^ The linker-specific GHC options
  -> (Set.Set BuildWay, BuildWay -> GhcOptions)
  -- ^ The wanted build ways and corresponding GhcOptions that were
  -- used to compile the modules in that way.
  -> FilePath
  -- ^ The target dir (2024-01:note: not the same as build target
  -- dir, see Note [Build Target Dir vs Target Dir] in Distribution.Simple.GHC.Build)
  -> (GhcOptions -> IO ())
  -- ^ Run the configured GHC program
  -> IO ()
linkFLib :: ForeignLib
-> BuildInfo
-> LocalBuildInfo
-> GhcOptions
-> (Set BuildWay, BuildWay -> GhcOptions)
-> String
-> (GhcOptions -> IO ())
-> IO ()
linkFLib ForeignLib
flib BuildInfo
bi LocalBuildInfo
lbi GhcOptions
linkerOpts (Set BuildWay
wantedWays, BuildWay -> GhcOptions
buildOpts) String
targetDir GhcOptions -> IO ()
runGhcProg = do
  let
    comp :: Compiler
comp = LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi

    -- Instruct GHC to link against libHSrts.
    rtsLinkOpts :: GhcOptions
    rtsLinkOpts :: GhcOptions
rtsLinkOpts
      | Bool
supportsFLinkRts =
          GhcOptions
forall a. Monoid a => a
mempty
            { ghcOptLinkRts = toFlag True
            }
      | Bool
otherwise =
          GhcOptions
forall a. Monoid a => a
mempty
            { ghcOptLinkLibs = rtsOptLinkLibs
            , ghcOptLinkLibPath = toNubListR $ rtsLibPaths rtsInfo
            }
      where
        threaded :: Bool
threaded = BuildInfo -> Bool
hasThreaded BuildInfo
bi
        supportsFLinkRts :: Bool
supportsFLinkRts = Compiler -> Version
compilerVersion Compiler
comp Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
9, Int
0]
        rtsInfo :: RtsInfo
rtsInfo = LocalBuildInfo -> RtsInfo
extractRtsInfo LocalBuildInfo
lbi
        rtsOptLinkLibs :: [String]
rtsOptLinkLibs =
          [ if ForeignLib -> Bool
withDynFLib ForeignLib
flib
              then
                if Bool
threaded
                  then DynamicRtsInfo -> String
dynRtsThreadedLib (RtsInfo -> DynamicRtsInfo
rtsDynamicInfo RtsInfo
rtsInfo)
                  else DynamicRtsInfo -> String
dynRtsVanillaLib (RtsInfo -> DynamicRtsInfo
rtsDynamicInfo RtsInfo
rtsInfo)
              else
                if Bool
threaded
                  then StaticRtsInfo -> String
statRtsThreadedLib (RtsInfo -> StaticRtsInfo
rtsStaticInfo RtsInfo
rtsInfo)
                  else StaticRtsInfo -> String
statRtsVanillaLib (RtsInfo -> StaticRtsInfo
rtsStaticInfo RtsInfo
rtsInfo)
          ]

    linkOpts :: BuildWay -> GhcOptions
    linkOpts :: BuildWay -> GhcOptions
linkOpts BuildWay
way = case ForeignLib -> ForeignLibType
foreignLibType ForeignLib
flib of
      ForeignLibType
ForeignLibNativeShared ->
        (BuildWay -> GhcOptions
buildOpts BuildWay
way)
          GhcOptions -> GhcOptions -> GhcOptions
forall a. Monoid a => a -> a -> a
`mappend` GhcOptions
linkerOpts
          GhcOptions -> GhcOptions -> GhcOptions
forall a. Monoid a => a -> a -> a
`mappend` GhcOptions
rtsLinkOpts
          GhcOptions -> GhcOptions -> GhcOptions
forall a. Monoid a => a -> a -> a
`mappend` GhcOptions
forall a. Monoid a => a
mempty
            { ghcOptLinkNoHsMain = toFlag True
            , ghcOptShared = toFlag True
            , ghcOptFPic = toFlag True
            , ghcOptLinkModDefFiles = toNubListR $ foreignLibModDefFile flib
            }
      ForeignLibType
ForeignLibNativeStatic ->
        -- this should be caught by buildFLib
        -- (and if we do implement this, we probably don't even want to call
        -- ghc here, but rather Ar.createArLibArchive or something)
        String -> GhcOptions
forall a. String -> a
cabalBug String
"static libraries not yet implemented"
      ForeignLibType
ForeignLibTypeUnknown ->
        String -> GhcOptions
forall a. String -> a
cabalBug String
"unknown foreign lib type"
  -- We build under a (potentially) different filename to set a
  -- soname on supported platforms.  See also the note for
  -- @flibBuildName@.
  let buildName :: String
buildName = LocalBuildInfo -> ForeignLib -> String
flibBuildName LocalBuildInfo
lbi ForeignLib
flib
  -- There should not be more than one wanted way when building an flib
  Bool -> IO () -> IO ()
forall a. HasCallStack => Bool -> a -> a
assert (Set BuildWay -> Int
forall a. Set a -> Int
Set.size Set BuildWay
wantedWays Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Set BuildWay -> (BuildWay -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Set BuildWay
wantedWays ((BuildWay -> IO ()) -> IO ()) -> (BuildWay -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \BuildWay
way -> do
      GhcOptions -> IO ()
runGhcProg (BuildWay -> GhcOptions
linkOpts BuildWay
way){ghcOptOutputFile = toFlag (targetDir </> buildName)}
      String -> String -> IO ()
renameFile (String
targetDir String -> String -> String
</> String
buildName) (String
targetDir String -> String -> String
</> LocalBuildInfo -> ForeignLib -> String
flibTargetName LocalBuildInfo
lbi ForeignLib
flib)

-- | Calculate the RPATHs for the component we are building.
--
-- Calculates relative RPATHs when 'relocatable' is set.
getRPaths
  :: PreBuildComponentInputs
  -- ^ The context and component being built in it.
  -> IO (NubListR FilePath)
getRPaths :: PreBuildComponentInputs -> IO (NubListR String)
getRPaths PreBuildComponentInputs
pbci = do
  let
    lbi :: LocalBuildInfo
lbi = PreBuildComponentInputs -> LocalBuildInfo
localBuildInfo PreBuildComponentInputs
pbci
    bi :: BuildInfo
bi = PreBuildComponentInputs -> BuildInfo
buildBI PreBuildComponentInputs
pbci
    clbi :: ComponentLocalBuildInfo
clbi = PreBuildComponentInputs -> ComponentLocalBuildInfo
buildCLBI PreBuildComponentInputs
pbci

    (Platform Arch
_ OS
hostOS) = LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi
    compid :: CompilerId
compid = Compiler -> CompilerId
compilerId (Compiler -> CompilerId)
-> (LocalBuildInfo -> Compiler) -> LocalBuildInfo -> CompilerId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalBuildInfo -> Compiler
compiler (LocalBuildInfo -> CompilerId) -> LocalBuildInfo -> CompilerId
forall a b. (a -> b) -> a -> b
$ LocalBuildInfo
lbi

    -- The list of RPath-supported operating systems below reflects the
    -- platforms on which Cabal's RPATH handling is tested. It does _NOT_
    -- reflect whether the OS supports RPATH.

    -- E.g. when this comment was written, the *BSD operating systems were
    -- untested with regards to Cabal RPATH handling, and were hence set to
    -- 'False', while those operating systems themselves do support RPATH.
    supportRPaths :: OS -> Bool
supportRPaths OS
Linux = Bool
True
    supportRPaths OS
Windows = Bool
False
    supportRPaths OS
OSX = Bool
True
    supportRPaths OS
FreeBSD =
      case CompilerId
compid of
        CompilerId CompilerFlavor
GHC Version
ver | Version
ver Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int] -> Version
mkVersion [Int
7, Int
10, Int
2] -> Bool
True
        CompilerId
_ -> Bool
False
    supportRPaths OS
OpenBSD = Bool
False
    supportRPaths OS
NetBSD = Bool
False
    supportRPaths OS
DragonFly = Bool
False
    supportRPaths OS
Solaris = Bool
False
    supportRPaths OS
AIX = Bool
False
    supportRPaths OS
HPUX = Bool
False
    supportRPaths OS
IRIX = Bool
False
    supportRPaths OS
HaLVM = Bool
False
    supportRPaths OS
IOS = Bool
False
    supportRPaths OS
Android = Bool
False
    supportRPaths OS
Ghcjs = Bool
False
    supportRPaths OS
Wasi = Bool
False
    supportRPaths OS
Hurd = Bool
True
    supportRPaths OS
Haiku = Bool
False
    supportRPaths (OtherOS String
_) = Bool
False
  -- Do _not_ add a default case so that we get a warning here when a new OS
  -- is added.

  if OS -> Bool
supportRPaths OS
hostOS
    then do
      [String]
libraryPaths <- IO [String] -> IO [String]
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [String] -> IO [String]) -> IO [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ Bool
-> Bool -> LocalBuildInfo -> ComponentLocalBuildInfo -> IO [String]
depLibraryPaths Bool
False (LocalBuildInfo -> Bool
relocatable LocalBuildInfo
lbi) LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi
      let hostPref :: String
hostPref = case OS
hostOS of
            OS
OSX -> String
"@loader_path"
            OS
_ -> String
"$ORIGIN"
          relPath :: String -> String
relPath String
p = if String -> Bool
isRelative String
p then String
hostPref String -> String -> String
</> String
p else String
p
          rpaths :: NubListR String
rpaths = [String] -> NubListR String
forall a. Ord a => [a] -> NubListR a
toNubListR ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
relPath [String]
libraryPaths) NubListR String -> NubListR String -> NubListR String
forall a. Semigroup a => a -> a -> a
<> [String] -> NubListR String
forall a. Ord a => [a] -> NubListR a
toNubListR (BuildInfo -> [String]
extraLibDirs BuildInfo
bi)
      NubListR String -> IO (NubListR String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return NubListR String
rpaths
    else NubListR String -> IO (NubListR String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return NubListR String
forall a. Monoid a => a
mempty

data DynamicRtsInfo = DynamicRtsInfo
  { DynamicRtsInfo -> String
dynRtsVanillaLib :: FilePath
  , DynamicRtsInfo -> String
dynRtsThreadedLib :: FilePath
  , DynamicRtsInfo -> String
dynRtsDebugLib :: FilePath
  , DynamicRtsInfo -> String
dynRtsEventlogLib :: FilePath
  , DynamicRtsInfo -> String
dynRtsThreadedDebugLib :: FilePath
  , DynamicRtsInfo -> String
dynRtsThreadedEventlogLib :: FilePath
  }

data StaticRtsInfo = StaticRtsInfo
  { StaticRtsInfo -> String
statRtsVanillaLib :: FilePath
  , StaticRtsInfo -> String
statRtsThreadedLib :: FilePath
  , StaticRtsInfo -> String
statRtsDebugLib :: FilePath
  , StaticRtsInfo -> String
statRtsEventlogLib :: FilePath
  , StaticRtsInfo -> String
statRtsThreadedDebugLib :: FilePath
  , StaticRtsInfo -> String
statRtsThreadedEventlogLib :: FilePath
  , StaticRtsInfo -> String
statRtsProfilingLib :: FilePath
  , StaticRtsInfo -> String
statRtsThreadedProfilingLib :: FilePath
  }

data RtsInfo = RtsInfo
  { RtsInfo -> DynamicRtsInfo
rtsDynamicInfo :: DynamicRtsInfo
  , RtsInfo -> StaticRtsInfo
rtsStaticInfo :: StaticRtsInfo
  , RtsInfo -> [String]
rtsLibPaths :: [FilePath]
  }

-- | Extract (and compute) information about the RTS library
--
-- TODO: This hardcodes the name as @HSrts-ghc<version>@. I don't know if we can
-- find this information somewhere. We can lookup the 'hsLibraries' field of
-- 'InstalledPackageInfo' but it will tell us @["HSrts", "Cffi"]@, which
-- doesn't really help.
extractRtsInfo :: LocalBuildInfo -> RtsInfo
extractRtsInfo :: LocalBuildInfo -> RtsInfo
extractRtsInfo LocalBuildInfo
lbi =
  case PackageIndex InstalledPackageInfo
-> PackageName -> [(Version, [InstalledPackageInfo])]
forall a. PackageIndex a -> PackageName -> [(Version, [a])]
PackageIndex.lookupPackageName
    (LocalBuildInfo -> PackageIndex InstalledPackageInfo
installedPkgs LocalBuildInfo
lbi)
    (String -> PackageName
mkPackageName String
"rts") of
    [(Version
_, [InstalledPackageInfo
rts])] -> InstalledPackageInfo -> RtsInfo
aux InstalledPackageInfo
rts
    [(Version, [InstalledPackageInfo])]
_otherwise -> String -> RtsInfo
forall a. HasCallStack => String -> a
error String
"No (or multiple) ghc rts package is registered"
  where
    aux :: InstalledPackageInfo -> RtsInfo
    aux :: InstalledPackageInfo -> RtsInfo
aux InstalledPackageInfo
rts =
      RtsInfo
        { rtsDynamicInfo :: DynamicRtsInfo
rtsDynamicInfo =
            DynamicRtsInfo
              { dynRtsVanillaLib :: String
dynRtsVanillaLib = String -> String
withGhcVersion String
"HSrts"
              , dynRtsThreadedLib :: String
dynRtsThreadedLib = String -> String
withGhcVersion String
"HSrts_thr"
              , dynRtsDebugLib :: String
dynRtsDebugLib = String -> String
withGhcVersion String
"HSrts_debug"
              , dynRtsEventlogLib :: String
dynRtsEventlogLib = String -> String
withGhcVersion String
"HSrts_l"
              , dynRtsThreadedDebugLib :: String
dynRtsThreadedDebugLib = String -> String
withGhcVersion String
"HSrts_thr_debug"
              , dynRtsThreadedEventlogLib :: String
dynRtsThreadedEventlogLib = String -> String
withGhcVersion String
"HSrts_thr_l"
              }
        , rtsStaticInfo :: StaticRtsInfo
rtsStaticInfo =
            StaticRtsInfo
              { statRtsVanillaLib :: String
statRtsVanillaLib = String
"HSrts"
              , statRtsThreadedLib :: String
statRtsThreadedLib = String
"HSrts_thr"
              , statRtsDebugLib :: String
statRtsDebugLib = String
"HSrts_debug"
              , statRtsEventlogLib :: String
statRtsEventlogLib = String
"HSrts_l"
              , statRtsThreadedDebugLib :: String
statRtsThreadedDebugLib = String
"HSrts_thr_debug"
              , statRtsThreadedEventlogLib :: String
statRtsThreadedEventlogLib = String
"HSrts_thr_l"
              , statRtsProfilingLib :: String
statRtsProfilingLib = String
"HSrts_p"
              , statRtsThreadedProfilingLib :: String
statRtsThreadedProfilingLib = String
"HSrts_thr_p"
              }
        , rtsLibPaths :: [String]
rtsLibPaths = InstalledPackageInfo -> [String]
InstalledPackageInfo.libraryDirs InstalledPackageInfo
rts
        }
    withGhcVersion :: String -> String
withGhcVersion = (String -> String -> String
forall a. [a] -> [a] -> [a]
++ (String
"-ghc" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Version -> String
forall a. Pretty a => a -> String
prettyShow (Compiler -> Version
compilerVersion (LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi))))

-- | Determine whether the given 'BuildInfo' is intended to link against the
-- threaded RTS. This is used to determine which RTS to link against when
-- building a foreign library with a GHC without support for @-flink-rts@.
hasThreaded :: BuildInfo -> Bool
hasThreaded :: BuildInfo -> Bool
hasThreaded BuildInfo
bi = String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
"-threaded" [String]
ghc
  where
    PerCompilerFlavor [String]
ghc [String]
_ = BuildInfo -> PerCompilerFlavor [String]
options BuildInfo
bi

-- | Load a target component into a repl, or write to disk a script which runs
-- GHCi with the GHC options Cabal elaborated to load the component interactively.
runReplOrWriteFlags
  :: ConfiguredProgram
  -> LocalBuildInfo
  -> ReplFlags
  -> GhcOptions
  -> PackageName
  -> TargetInfo
  -> IO ()
runReplOrWriteFlags :: ConfiguredProgram
-> LocalBuildInfo
-> ReplFlags
-> GhcOptions
-> PackageName
-> TargetInfo
-> IO ()
runReplOrWriteFlags ConfiguredProgram
ghcProg LocalBuildInfo
lbi ReplFlags
rflags GhcOptions
ghcOpts PackageName
pkg_name TargetInfo
target =
  let bi :: BuildInfo
bi = Component -> BuildInfo
componentBuildInfo (Component -> BuildInfo) -> Component -> BuildInfo
forall a b. (a -> b) -> a -> b
$ TargetInfo -> Component
targetComponent TargetInfo
target
      clbi :: ComponentLocalBuildInfo
clbi = TargetInfo -> ComponentLocalBuildInfo
targetCLBI TargetInfo
target
      comp :: Compiler
comp = LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi
      platform :: Platform
platform = LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi
   in case ReplOptions -> Flag String
replOptionsFlagOutput (ReplFlags -> ReplOptions
replReplOptions ReplFlags
rflags) of
        Flag String
NoFlag -> Verbosity
-> ConfiguredProgram -> Compiler -> Platform -> GhcOptions -> IO ()
runGHC (Flag Verbosity -> Verbosity
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag Verbosity -> Verbosity) -> Flag Verbosity -> Verbosity
forall a b. (a -> b) -> a -> b
$ ReplFlags -> Flag Verbosity
replVerbosity ReplFlags
rflags) ConfiguredProgram
ghcProg Compiler
comp Platform
platform GhcOptions
ghcOpts
        Flag String
out_dir -> do
          String
src_dir <- IO String
getCurrentDirectory
          let uid :: UnitId
uid = ComponentLocalBuildInfo -> UnitId
componentUnitId ComponentLocalBuildInfo
clbi
              this_unit :: String
this_unit = UnitId -> String
forall a. Pretty a => a -> String
prettyShow UnitId
uid
              reexported_modules :: [ModuleName]
reexported_modules = [ModuleName
mn | LibComponentLocalBuildInfo{} <- [ComponentLocalBuildInfo
clbi], IPI.ExposedModule ModuleName
mn (Just{}) <- ComponentLocalBuildInfo -> [ExposedModule]
componentExposedModules ComponentLocalBuildInfo
clbi]
              hidden_modules :: [ModuleName]
hidden_modules = BuildInfo -> [ModuleName]
otherModules BuildInfo
bi
              extra_opts :: [String]
extra_opts =
                [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[String]] -> [String]) -> [[String]] -> [String]
forall a b. (a -> b) -> a -> b
$
                  [ [String
"-this-package-name", PackageName -> String
forall a. Pretty a => a -> String
prettyShow PackageName
pkg_name]
                  , [String
"-working-dir", String
src_dir]
                  ]
                    [[String]] -> [[String]] -> [[String]]
forall a. [a] -> [a] -> [a]
++ [ [String
"-reexported-module", ModuleName -> String
forall a. Pretty a => a -> String
prettyShow ModuleName
m] | ModuleName
m <- [ModuleName]
reexported_modules
                       ]
                    [[String]] -> [[String]] -> [[String]]
forall a. [a] -> [a] -> [a]
++ [ [String
"-hidden-module", ModuleName -> String
forall a. Pretty a => a -> String
prettyShow ModuleName
m] | ModuleName
m <- [ModuleName]
hidden_modules
                       ]
          -- Create "paths" subdirectory if it doesn't exist. This is where we write
          -- information about how the PATH was augmented.
          Bool -> String -> IO ()
createDirectoryIfMissing Bool
False (String
out_dir String -> String -> String
</> String
"paths")
          -- Write out the PATH information into `paths` subdirectory.
          String -> ByteString -> IO ()
writeFileAtomic (String
out_dir String -> String -> String
</> String
"paths" String -> String -> String
</> String
this_unit) (ConfiguredProgram -> ByteString
forall a. Binary a => a -> ByteString
encode ConfiguredProgram
ghcProg)
          -- Write out options for this component into a file ready for loading into
          -- the multi-repl
          String -> ByteString -> IO ()
writeFileAtomic (String
out_dir String -> String -> String
</> String
this_unit) (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$
            String -> ByteString
BS.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$
              [String] -> String
escapeArgs ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
                [String]
extra_opts [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ Compiler -> Platform -> GhcOptions -> [String]
renderGhcOptions Compiler
comp Platform
platform (GhcOptions
ghcOpts{ghcOptMode = NoFlag})

replNoLoad :: Ord a => ReplOptions -> NubListR a -> NubListR a
replNoLoad :: forall a. Ord a => ReplOptions -> NubListR a -> NubListR a
replNoLoad ReplOptions
replFlags NubListR a
l
  | ReplOptions -> Flag Bool
replOptionsNoLoad ReplOptions
replFlags Flag Bool -> Flag Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Flag Bool
forall a. a -> Flag a
Flag Bool
True = NubListR a
forall a. Monoid a => a
mempty
  | Bool
otherwise = NubListR a
l