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

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

-- |
-- Module      :  Distribution.Simple.Program.Ld
-- Copyright   :  Duncan Coutts 2009
--
-- Maintainer  :  cabal-devel@haskell.org
-- Portability :  portable
--
-- This module provides an library interface to the @ld@ linker program.
module Distribution.Simple.Program.Ld
  ( combineObjectFiles
  ) where

import Distribution.Compat.Prelude
import Prelude ()

import Distribution.Simple.Compiler (arResponseFilesSupported)
import Distribution.Simple.Flag
  ( fromFlagOrDefault
  )
import Distribution.Simple.LocalBuildInfo (LocalBuildInfo (..), mbWorkDirLBI)
import Distribution.Simple.Program.ResponseFile
  ( withResponseFile
  )
import Distribution.Simple.Program.Run
  ( ProgramInvocation
  , multiStageProgramInvocation
  , programInvocationCwd
  , runProgramInvocation
  )
import Distribution.Simple.Program.Types
  ( ConfiguredProgram (..)
  )
import Distribution.Simple.Setup.Config
  ( configUseResponseFiles
  )
import Distribution.Simple.Utils
  ( defaultTempFileOptions
  )
import Distribution.Utils.Path
import Distribution.Verbosity
  ( Verbosity
  )

import System.Directory
  ( renameFile
  )

-- | Call @ld -r@ to link a bunch of object files together.
combineObjectFiles
  :: Verbosity
  -> LocalBuildInfo
  -> ConfiguredProgram
  -> SymbolicPath Pkg File
  -> [SymbolicPath Pkg File]
  -> IO ()
combineObjectFiles :: Verbosity
-> LocalBuildInfo
-> ConfiguredProgram
-> SymbolicPath Pkg 'File
-> [SymbolicPath Pkg 'File]
-> IO ()
combineObjectFiles Verbosity
verbosity LocalBuildInfo
lbi ConfiguredProgram
ldProg SymbolicPath Pkg 'File
target [SymbolicPath Pkg 'File]
files = do
  -- Unlike "ar", the "ld" tool is not designed to be used with xargs. That is,
  -- if we have more object files than fit on a single command line then we
  -- have a slight problem. What we have to do is link files in batches into
  -- a temp object file and then include that one in the next batch.

  let
    -- See Note [Symbolic paths] in Distribution.Utils.Path
    u :: SymbolicPath Pkg to -> FilePath
    u :: forall (to :: FileOrDir). SymbolicPath Pkg to -> FilePath
u = SymbolicPathX 'AllowAbsolute Pkg to -> FilePath
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> FilePath
interpretSymbolicPathCWD
    i :: SymbolicPathX allowAbsolute Pkg to -> FilePath
i = Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPathX allowAbsolute Pkg to -> FilePath
forall from (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPathX allowAbsolute from to -> FilePath
interpretSymbolicPath Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir
    mbWorkDir :: Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir = LocalBuildInfo -> Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDirLBI LocalBuildInfo
lbi

    simpleArgs :: [FilePath]
simpleArgs = [FilePath
"-r", FilePath
"-o", SymbolicPath Pkg 'File -> FilePath
forall (to :: FileOrDir). SymbolicPath Pkg to -> FilePath
u SymbolicPath Pkg 'File
target]
    initialArgs :: [FilePath]
initialArgs = [FilePath
"-r", FilePath
"-o", SymbolicPath Pkg 'File -> FilePath
forall (to :: FileOrDir). SymbolicPath Pkg to -> FilePath
u SymbolicPath Pkg 'File
target]
    middleArgs :: [FilePath]
middleArgs = [FilePath
"-r", FilePath
"-o", SymbolicPath Pkg 'File -> FilePath
forall (to :: FileOrDir). SymbolicPath Pkg to -> FilePath
u SymbolicPath Pkg 'File
target, SymbolicPath Pkg 'File -> FilePath
forall (to :: FileOrDir). SymbolicPath Pkg to -> FilePath
u SymbolicPath Pkg 'File
tmpfile]
    finalArgs :: [FilePath]
finalArgs = [FilePath]
middleArgs

    ld :: [FilePath] -> ProgramInvocation
ld = Maybe (SymbolicPath CWD ('Dir Pkg))
-> ConfiguredProgram -> [FilePath] -> ProgramInvocation
forall to.
Maybe (SymbolicPath CWD ('Dir to))
-> ConfiguredProgram -> [FilePath] -> ProgramInvocation
programInvocationCwd (LocalBuildInfo -> Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDirLBI LocalBuildInfo
lbi) ConfiguredProgram
ldProg
    simple :: ProgramInvocation
simple = [FilePath] -> ProgramInvocation
ld [FilePath]
simpleArgs
    initial :: ProgramInvocation
initial = [FilePath] -> ProgramInvocation
ld [FilePath]
initialArgs
    middle :: ProgramInvocation
middle = [FilePath] -> ProgramInvocation
ld [FilePath]
middleArgs
    final :: ProgramInvocation
final = [FilePath] -> ProgramInvocation
ld [FilePath]
finalArgs

    targetDir :: SymbolicPathX 'AllowAbsolute Pkg ('Dir to')
targetDir = SymbolicPath Pkg 'File
-> SymbolicPathX 'AllowAbsolute Pkg ('Dir to')
forall (allowAbsolute :: AllowAbsolute) from to'.
SymbolicPathX allowAbsolute from 'File
-> SymbolicPathX allowAbsolute from ('Dir to')
takeDirectorySymbolicPath SymbolicPath Pkg 'File
target

    invokeWithResponseFile :: FilePath -> ProgramInvocation
    invokeWithResponseFile :: FilePath -> ProgramInvocation
invokeWithResponseFile FilePath
atFile =
      [FilePath] -> ProgramInvocation
ld ([FilePath] -> ProgramInvocation)
-> [FilePath] -> ProgramInvocation
forall a b. (a -> b) -> a -> b
$ [FilePath]
simpleArgs [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [Char
'@' Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath
atFile]

    oldVersionManualOverride :: Bool
oldVersionManualOverride =
      Bool -> Flag Bool -> Bool
forall a. a -> Flag a -> a
fromFlagOrDefault Bool
False (Flag Bool -> Bool) -> Flag Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ConfigFlags -> Flag Bool
configUseResponseFiles (ConfigFlags -> Flag Bool) -> ConfigFlags -> Flag Bool
forall a b. (a -> b) -> a -> b
$ LocalBuildInfo -> ConfigFlags
configFlags LocalBuildInfo
lbi
    -- Whether ghc's ar supports response files is a good proxy for
    -- whether ghc's ld supports them as well.
    responseArgumentsNotSupported :: Bool
responseArgumentsNotSupported =
      Bool -> Bool
not (Compiler -> Bool
arResponseFilesSupported (LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi))

    run :: [ProgramInvocation] -> IO ()
    run :: [ProgramInvocation] -> IO ()
run [] = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    run [ProgramInvocation
inv] = Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation Verbosity
verbosity ProgramInvocation
inv
    run (ProgramInvocation
inv : [ProgramInvocation]
invs) = do
      Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation Verbosity
verbosity ProgramInvocation
inv
      FilePath -> FilePath -> IO ()
renameFile (SymbolicPath Pkg 'File -> FilePath
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> FilePath
i SymbolicPath Pkg 'File
target) (SymbolicPath Pkg 'File -> FilePath
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
SymbolicPathX allowAbsolute Pkg to -> FilePath
i SymbolicPath Pkg 'File
tmpfile)
      [ProgramInvocation] -> IO ()
run [ProgramInvocation]
invs

  if Bool
oldVersionManualOverride Bool -> Bool -> Bool
|| Bool
responseArgumentsNotSupported
    then [ProgramInvocation] -> IO ()
run ([ProgramInvocation] -> IO ()) -> [ProgramInvocation] -> IO ()
forall a b. (a -> b) -> a -> b
$ ProgramInvocation
-> (ProgramInvocation, ProgramInvocation, ProgramInvocation)
-> [FilePath]
-> [ProgramInvocation]
multiStageProgramInvocation ProgramInvocation
simple (ProgramInvocation
initial, ProgramInvocation
middle, ProgramInvocation
final) ((SymbolicPath Pkg 'File -> FilePath)
-> [SymbolicPath Pkg 'File] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map SymbolicPath Pkg 'File -> FilePath
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> FilePath
getSymbolicPath [SymbolicPath Pkg 'File]
files)
    else Verbosity
-> TempFileOptions
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir Response)
-> FilePath
-> Maybe TextEncoding
-> [FilePath]
-> (FilePath -> IO ())
-> IO ()
forall a.
Verbosity
-> TempFileOptions
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir Response)
-> FilePath
-> Maybe TextEncoding
-> [FilePath]
-> (FilePath -> IO a)
-> IO a
withResponseFile Verbosity
verbosity TempFileOptions
defaultTempFileOptions Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir SymbolicPath Pkg ('Dir Response)
forall {to'}. SymbolicPathX 'AllowAbsolute Pkg ('Dir to')
targetDir FilePath
"ld.rsp" Maybe TextEncoding
forall a. Maybe a
Nothing ((SymbolicPath Pkg 'File -> FilePath)
-> [SymbolicPath Pkg 'File] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map SymbolicPath Pkg 'File -> FilePath
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> FilePath
getSymbolicPath [SymbolicPath Pkg 'File]
files) ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
      \FilePath
path -> Verbosity -> ProgramInvocation -> IO ()
runProgramInvocation Verbosity
verbosity (ProgramInvocation -> IO ()) -> ProgramInvocation -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> ProgramInvocation
invokeWithResponseFile FilePath
path
  where
    tmpfile :: SymbolicPath Pkg 'File
tmpfile = SymbolicPath Pkg 'File
target SymbolicPath Pkg 'File -> FilePath -> SymbolicPath Pkg 'File
forall p. FileLike p => p -> FilePath -> p
<.> FilePath
"tmp" -- perhaps should use a proper temp file