{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}

module Distribution.Simple.GHCJS
  ( getGhcInfo
  , configure
  , getInstalledPackages
  , getInstalledPackagesMonitorFiles
  , getPackageDBContents
  , buildLib
  , buildFLib
  , buildExe
  , replLib
  , replFLib
  , replExe
  , startInterpreter
  , installLib
  , installFLib
  , installExe
  , libAbiHash
  , hcPkgInfo
  , registerPackage
  , componentGhcOptions
  , componentCcGhcOptions
  , getLibDir
  , isDynamic
  , getGlobalPackageDB
  , pkgRoot
  , runCmd

    -- * Constructing and deconstructing GHC environment files
  , Internal.GhcEnvironmentFileEntry (..)
  , Internal.simpleGhcEnvironmentFile
  , Internal.renderGhcEnvironmentFile
  , Internal.writeGhcEnvironmentFile
  , Internal.ghcPlatformAndVersionString
  , readGhcEnvironmentFile
  , parseGhcEnvironmentFile
  , ParseErrorExc (..)

    -- * Version-specific implementation quirks
  , getImplInfo
  , GhcImplInfo (..)
  ) where

import Distribution.Compat.Prelude
import Prelude ()

import Distribution.CabalSpecVersion
import Distribution.InstalledPackageInfo (InstalledPackageInfo)
import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo
import Distribution.ModuleName (ModuleName)
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.BuildPaths
import Distribution.Simple.Compiler
import Distribution.Simple.Flag
import Distribution.Simple.GHC.EnvironmentParser
import Distribution.Simple.GHC.ImplInfo
import qualified Distribution.Simple.GHC.Internal as Internal
import qualified Distribution.Simple.Hpc as Hpc
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.PackageIndex (InstalledPackageIndex)
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Simple.Program
import Distribution.Simple.Program.GHC
import qualified Distribution.Simple.Program.HcPkg as HcPkg
import qualified Distribution.Simple.Program.Strip as Strip
import Distribution.Simple.Setup.Config
import Distribution.Simple.Utils
import Distribution.System
import Distribution.Types.ComponentLocalBuildInfo
import Distribution.Types.PackageName.Magic
import Distribution.Utils.NubList
import Distribution.Utils.Path
import Distribution.Verbosity
import Distribution.Version

import Control.Monad (msum)
import Data.Char (isLower)
import qualified Data.Map as Map
import System.Directory
  ( canonicalizePath
  , createDirectoryIfMissing
  , doesFileExist
  , getAppUserDataDirectory
  , removeFile
  , renameFile
  )
import System.FilePath
  ( isRelative
  , replaceExtension
  , takeDirectory
  , takeExtension
  , (<.>)
  , (</>)
  )
import qualified System.Info

-- -----------------------------------------------------------------------------
-- Configuring

configure
  :: Verbosity
  -> Maybe FilePath
  -> Maybe FilePath
  -> ProgramDb
  -> IO (Compiler, Maybe Platform, ProgramDb)
configure :: Verbosity
-> Maybe String
-> Maybe String
-> ProgramDb
-> IO (Compiler, Maybe Platform, ProgramDb)
configure Verbosity
verbosity Maybe String
hcPath Maybe String
hcPkgPath ProgramDb
conf0 = do
  (ConfiguredProgram
ghcjsProg, Version
ghcjsVersion, ProgramDb
progdb1) <-
    Verbosity
-> Program
-> VersionRange
-> ProgramDb
-> IO (ConfiguredProgram, Version, ProgramDb)
requireProgramVersion
      Verbosity
verbosity
      Program
ghcjsProgram
      (Version -> VersionRange
orLaterVersion ([Int] -> Version
mkVersion [Int
0, Int
1]))
      (String -> Maybe String -> ProgramDb -> ProgramDb
userMaybeSpecifyPath String
"ghcjs" Maybe String
hcPath ProgramDb
conf0)

  Just Version
ghcjsGhcVersion <- Verbosity -> String -> IO (Maybe Version)
findGhcjsGhcVersion Verbosity
verbosity (ConfiguredProgram -> String
programPath ConfiguredProgram
ghcjsProg)
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Version
ghcjsGhcVersion Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
< [Int] -> Version
mkVersion [Int
8, Int
8]) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Verbosity -> String -> IO ()
warn Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
      String
"Unknown/unsupported 'ghc' version detected "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(Cabal "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ Version -> String
forall a. Pretty a => a -> String
prettyShow Version
cabalVersion
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" supports 'ghc' version < 8.8): "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ ConfiguredProgram -> String
programPath ConfiguredProgram
ghcjsProg
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is based on GHC version "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ Version -> String
forall a. Pretty a => a -> String
prettyShow Version
ghcjsGhcVersion

  let implInfo :: GhcImplInfo
implInfo = Version -> Version -> GhcImplInfo
ghcjsVersionImplInfo Version
ghcjsVersion Version
ghcjsGhcVersion

  -- This is slightly tricky, we have to configure ghc first, then we use the
  -- location of ghc to help find ghc-pkg in the case that the user did not
  -- specify the location of ghc-pkg directly:
  (ConfiguredProgram
ghcjsPkgProg, Version
ghcjsPkgVersion, ProgramDb
progdb2) <-
    Verbosity
-> Program
-> VersionRange
-> ProgramDb
-> IO (ConfiguredProgram, Version, ProgramDb)
requireProgramVersion
      Verbosity
verbosity
      Program
ghcjsPkgProgram
        { programFindLocation = guessGhcjsPkgFromGhcjsPath ghcjsProg
        }
      VersionRange
anyVersion
      (String -> Maybe String -> ProgramDb -> ProgramDb
userMaybeSpecifyPath String
"ghcjs-pkg" Maybe String
hcPkgPath ProgramDb
progdb1)

  Just Version
ghcjsPkgGhcjsVersion <-
    Verbosity -> String -> IO (Maybe Version)
findGhcjsPkgGhcjsVersion
      Verbosity
verbosity
      (ConfiguredProgram -> String
programPath ConfiguredProgram
ghcjsPkgProg)

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Version
ghcjsVersion Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
/= Version
ghcjsPkgGhcjsVersion) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Verbosity -> String -> IO ()
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
      String
"Version mismatch between ghcjs and ghcjs-pkg: "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ ConfiguredProgram -> String
programPath ConfiguredProgram
ghcjsProg
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is version "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ Version -> String
forall a. Pretty a => a -> String
prettyShow Version
ghcjsVersion
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ ConfiguredProgram -> String
programPath ConfiguredProgram
ghcjsPkgProg
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is version "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ Version -> String
forall a. Pretty a => a -> String
prettyShow Version
ghcjsPkgGhcjsVersion

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Version
ghcjsGhcVersion Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
/= Version
ghcjsPkgVersion) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Verbosity -> String -> IO ()
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
      String
"Version mismatch between ghcjs and ghcjs-pkg: "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ ConfiguredProgram -> String
programPath ConfiguredProgram
ghcjsProg
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" was built with GHC version "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ Version -> String
forall a. Pretty a => a -> String
prettyShow Version
ghcjsGhcVersion
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ ConfiguredProgram -> String
programPath ConfiguredProgram
ghcjsPkgProg
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" was built with GHC version "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ Version -> String
forall a. Pretty a => a -> String
prettyShow Version
ghcjsPkgVersion

  -- Likewise we try to find the matching hsc2hs and haddock programs.
  let hsc2hsProgram' :: Program
hsc2hsProgram' =
        Program
hsc2hsProgram
          { programFindLocation =
              guessHsc2hsFromGhcjsPath ghcjsProg
          }
      haddockProgram' :: Program
haddockProgram' =
        Program
haddockProgram
          { programFindLocation =
              guessHaddockFromGhcjsPath ghcjsProg
          }
      hpcProgram' :: Program
hpcProgram' =
        Program
hpcProgram
          { programFindLocation = guessHpcFromGhcjsPath ghcjsProg
          }
      {-
      runghcProgram' = runghcProgram {
                        programFindLocation = guessRunghcFromGhcjsPath ghcjsProg
                    } -}
      progdb3 :: ProgramDb
progdb3 =
        Program -> ProgramDb -> ProgramDb
addKnownProgram Program
haddockProgram' (ProgramDb -> ProgramDb) -> ProgramDb -> ProgramDb
forall a b. (a -> b) -> a -> b
$
          Program -> ProgramDb -> ProgramDb
addKnownProgram Program
hsc2hsProgram' (ProgramDb -> ProgramDb) -> ProgramDb -> ProgramDb
forall a b. (a -> b) -> a -> b
$
            Program -> ProgramDb -> ProgramDb
addKnownProgram Program
hpcProgram' (ProgramDb -> ProgramDb) -> ProgramDb -> ProgramDb
forall a b. (a -> b) -> a -> b
$
              {- addKnownProgram runghcProgram' -} ProgramDb
progdb2

  [(Language, String)]
languages <- Verbosity
-> GhcImplInfo -> ConfiguredProgram -> IO [(Language, String)]
Internal.getLanguages Verbosity
verbosity GhcImplInfo
implInfo ConfiguredProgram
ghcjsProg
  [(Extension, Maybe String)]
extensions <- Verbosity
-> GhcImplInfo
-> ConfiguredProgram
-> IO [(Extension, Maybe String)]
Internal.getExtensions Verbosity
verbosity GhcImplInfo
implInfo ConfiguredProgram
ghcjsProg

  [(String, String)]
ghcjsInfo <- Verbosity
-> GhcImplInfo -> ConfiguredProgram -> IO [(String, String)]
Internal.getGhcInfo Verbosity
verbosity GhcImplInfo
implInfo ConfiguredProgram
ghcjsProg
  let ghcInfoMap :: Map String String
ghcInfoMap = [(String, String)] -> Map String String
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(String, String)]
ghcjsInfo

  let comp :: Compiler
comp =
        Compiler
          { compilerId :: CompilerId
compilerId = CompilerFlavor -> Version -> CompilerId
CompilerId CompilerFlavor
GHCJS Version
ghcjsVersion
          , compilerAbiTag :: AbiTag
compilerAbiTag =
              String -> AbiTag
AbiTag (String -> AbiTag) -> String -> AbiTag
forall a b. (a -> b) -> a -> b
$
                String
"ghc" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"_" ((Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Int -> String
forall a. Show a => a -> String
show ([Int] -> [String]) -> (Version -> [Int]) -> Version -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> [Int]
versionNumbers (Version -> [String]) -> Version -> [String]
forall a b. (a -> b) -> a -> b
$ Version
ghcjsGhcVersion)
          , compilerCompat :: [CompilerId]
compilerCompat = [CompilerFlavor -> Version -> CompilerId
CompilerId CompilerFlavor
GHC Version
ghcjsGhcVersion]
          , compilerLanguages :: [(Language, String)]
compilerLanguages = [(Language, String)]
languages
          , compilerExtensions :: [(Extension, Maybe String)]
compilerExtensions = [(Extension, Maybe String)]
extensions
          , compilerProperties :: Map String String
compilerProperties = Map String String
ghcInfoMap
          }
      compPlatform :: Maybe Platform
compPlatform = [(String, String)] -> Maybe Platform
Internal.targetPlatform [(String, String)]
ghcjsInfo
  (Compiler, Maybe Platform, ProgramDb)
-> IO (Compiler, Maybe Platform, ProgramDb)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Compiler
comp, Maybe Platform
compPlatform, ProgramDb
progdb3)

guessGhcjsPkgFromGhcjsPath
  :: ConfiguredProgram
  -> Verbosity
  -> ProgramSearchPath
  -> IO (Maybe (FilePath, [FilePath]))
guessGhcjsPkgFromGhcjsPath :: ConfiguredProgram
-> Verbosity -> ProgramSearchPath -> IO (Maybe (String, [String]))
guessGhcjsPkgFromGhcjsPath = Program
-> ConfiguredProgram
-> Verbosity
-> ProgramSearchPath
-> IO (Maybe (String, [String]))
guessToolFromGhcjsPath Program
ghcjsPkgProgram

guessHsc2hsFromGhcjsPath
  :: ConfiguredProgram
  -> Verbosity
  -> ProgramSearchPath
  -> IO (Maybe (FilePath, [FilePath]))
guessHsc2hsFromGhcjsPath :: ConfiguredProgram
-> Verbosity -> ProgramSearchPath -> IO (Maybe (String, [String]))
guessHsc2hsFromGhcjsPath = Program
-> ConfiguredProgram
-> Verbosity
-> ProgramSearchPath
-> IO (Maybe (String, [String]))
guessToolFromGhcjsPath Program
hsc2hsProgram

guessHaddockFromGhcjsPath
  :: ConfiguredProgram
  -> Verbosity
  -> ProgramSearchPath
  -> IO (Maybe (FilePath, [FilePath]))
guessHaddockFromGhcjsPath :: ConfiguredProgram
-> Verbosity -> ProgramSearchPath -> IO (Maybe (String, [String]))
guessHaddockFromGhcjsPath = Program
-> ConfiguredProgram
-> Verbosity
-> ProgramSearchPath
-> IO (Maybe (String, [String]))
guessToolFromGhcjsPath Program
haddockProgram

guessHpcFromGhcjsPath
  :: ConfiguredProgram
  -> Verbosity
  -> ProgramSearchPath
  -> IO (Maybe (FilePath, [FilePath]))
guessHpcFromGhcjsPath :: ConfiguredProgram
-> Verbosity -> ProgramSearchPath -> IO (Maybe (String, [String]))
guessHpcFromGhcjsPath = Program
-> ConfiguredProgram
-> Verbosity
-> ProgramSearchPath
-> IO (Maybe (String, [String]))
guessToolFromGhcjsPath Program
hpcProgram

guessToolFromGhcjsPath
  :: Program
  -> ConfiguredProgram
  -> Verbosity
  -> ProgramSearchPath
  -> IO (Maybe (FilePath, [FilePath]))
guessToolFromGhcjsPath :: Program
-> ConfiguredProgram
-> Verbosity
-> ProgramSearchPath
-> IO (Maybe (String, [String]))
guessToolFromGhcjsPath Program
tool ConfiguredProgram
ghcjsProg Verbosity
verbosity ProgramSearchPath
searchpath =
  do
    let toolname :: String
toolname = Program -> String
programName Program
tool
        given_path :: String
given_path = ConfiguredProgram -> String
programPath ConfiguredProgram
ghcjsProg
        given_dir :: String
given_dir = String -> String
takeDirectory String
given_path
    String
real_path <- String -> IO String
canonicalizePath String
given_path
    let real_dir :: String
real_dir = String -> String
takeDirectory String
real_path
        versionSuffix :: String -> String
versionSuffix String
path = String -> String
takeVersionSuffix (String -> String
dropExeExtension String
path)
        given_suf :: String
given_suf = String -> String
versionSuffix String
given_path
        real_suf :: String
real_suf = String -> String
versionSuffix String
real_path
        guessNormal :: String -> String
guessNormal String
dir = String
dir String -> String -> String
</> String
toolname String -> String -> String
<.> Platform -> String
exeExtension Platform
buildPlatform
        guessGhcjs :: String -> String
guessGhcjs String
dir =
          String
dir
            String -> String -> String
</> (String
toolname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-ghcjs")
              String -> String -> String
<.> Platform -> String
exeExtension Platform
buildPlatform
        guessGhcjsVersioned :: String -> String -> String
guessGhcjsVersioned String
dir String
suf =
          String
dir
            String -> String -> String
</> (String
toolname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-ghcjs" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
suf)
              String -> String -> String
<.> Platform -> String
exeExtension Platform
buildPlatform
        guessVersioned :: String -> String -> String
guessVersioned String
dir String
suf =
          String
dir
            String -> String -> String
</> (String
toolname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
suf)
              String -> String -> String
<.> Platform -> String
exeExtension Platform
buildPlatform
        mkGuesses :: String -> String -> [String]
mkGuesses String
dir String
suf
          | String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
suf = [String -> String
guessGhcjs String
dir, String -> String
guessNormal String
dir]
          | Bool
otherwise =
              [ String -> String -> String
guessGhcjsVersioned String
dir String
suf
              , String -> String -> String
guessVersioned String
dir String
suf
              , String -> String
guessGhcjs String
dir
              , String -> String
guessNormal String
dir
              ]
        guesses :: [String]
guesses =
          String -> String -> [String]
mkGuesses String
given_dir String
given_suf
            [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ if String
real_path String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
given_path
              then []
              else String -> String -> [String]
mkGuesses String
real_dir String
real_suf
    Verbosity -> String -> IO ()
info Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
      String
"looking for tool "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
toolname
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" near compiler in "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
given_dir
    Verbosity -> String -> IO ()
debug Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"candidate locations: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
guesses
    [Bool]
exists <- (String -> IO Bool) -> [String] -> IO [Bool]
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 Bool
doesFileExist [String]
guesses
    case [String
file | (String
file, Bool
True) <- [String] -> [Bool] -> [(String, Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
guesses [Bool]
exists] of
      -- If we can't find it near ghc, fall back to the usual
      -- method.
      [] -> Program
-> Verbosity -> ProgramSearchPath -> IO (Maybe (String, [String]))
programFindLocation Program
tool Verbosity
verbosity ProgramSearchPath
searchpath
      (String
fp : [String]
_) -> do
        Verbosity -> String -> IO ()
info Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"found " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
toolname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fp
        let lookedAt :: [String]
lookedAt =
              ((String, Bool) -> String) -> [(String, Bool)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, Bool) -> String
forall a b. (a, b) -> a
fst
                ([(String, Bool)] -> [String])
-> ([(String, Bool)] -> [(String, Bool)])
-> [(String, Bool)]
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, Bool) -> Bool) -> [(String, Bool)] -> [(String, Bool)]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\(String
_file, Bool
exist) -> Bool -> Bool
not Bool
exist)
                ([(String, Bool)] -> [String]) -> [(String, Bool)] -> [String]
forall a b. (a -> b) -> a -> b
$ [String] -> [Bool] -> [(String, Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
guesses [Bool]
exists
        Maybe (String, [String]) -> IO (Maybe (String, [String]))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((String, [String]) -> Maybe (String, [String])
forall a. a -> Maybe a
Just (String
fp, [String]
lookedAt))
  where
    takeVersionSuffix :: FilePath -> String
    takeVersionSuffix :: String -> String
takeVersionSuffix = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhileEndLE Char -> Bool
isSuffixChar

    isSuffixChar :: Char -> Bool
    isSuffixChar :: Char -> Bool
isSuffixChar Char
c = Char -> Bool
isDigit Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-'

getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)]
getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)]
getGhcInfo Verbosity
verbosity ConfiguredProgram
ghcjsProg = Verbosity
-> GhcImplInfo -> ConfiguredProgram -> IO [(String, String)]
Internal.getGhcInfo Verbosity
verbosity GhcImplInfo
implInfo ConfiguredProgram
ghcjsProg
  where
    version :: Version
version = Version -> Maybe Version -> Version
forall a. a -> Maybe a -> a
fromMaybe (String -> Version
forall a. HasCallStack => String -> a
error String
"GHCJS.getGhcInfo: no version") (Maybe Version -> Version) -> Maybe Version -> Version
forall a b. (a -> b) -> a -> b
$ ConfiguredProgram -> Maybe Version
programVersion ConfiguredProgram
ghcjsProg
    implInfo :: GhcImplInfo
implInfo = Version -> GhcImplInfo
ghcVersionImplInfo Version
version

-- | Given a single package DB, return all installed packages.
getPackageDBContents
  :: Verbosity
  -> PackageDB
  -> ProgramDb
  -> IO InstalledPackageIndex
getPackageDBContents :: Verbosity -> PackageDB -> ProgramDb -> IO InstalledPackageIndex
getPackageDBContents Verbosity
verbosity PackageDB
packagedb ProgramDb
progdb = do
  [(PackageDB, [InstalledPackageInfo])]
pkgss <- Verbosity
-> [PackageDB]
-> ProgramDb
-> IO [(PackageDB, [InstalledPackageInfo])]
getInstalledPackages' Verbosity
verbosity [PackageDB
packagedb] ProgramDb
progdb
  Verbosity
-> [(PackageDB, [InstalledPackageInfo])]
-> ProgramDb
-> IO InstalledPackageIndex
toPackageIndex Verbosity
verbosity [(PackageDB, [InstalledPackageInfo])]
pkgss ProgramDb
progdb

-- | Given a package DB stack, return all installed packages.
getInstalledPackages
  :: Verbosity
  -> PackageDBStack
  -> ProgramDb
  -> IO InstalledPackageIndex
getInstalledPackages :: Verbosity -> [PackageDB] -> ProgramDb -> IO InstalledPackageIndex
getInstalledPackages Verbosity
verbosity [PackageDB]
packagedbs ProgramDb
progdb = do
  Verbosity -> IO ()
checkPackageDbEnvVar Verbosity
verbosity
  Verbosity -> [PackageDB] -> IO ()
checkPackageDbStack Verbosity
verbosity [PackageDB]
packagedbs
  [(PackageDB, [InstalledPackageInfo])]
pkgss <- Verbosity
-> [PackageDB]
-> ProgramDb
-> IO [(PackageDB, [InstalledPackageInfo])]
getInstalledPackages' Verbosity
verbosity [PackageDB]
packagedbs ProgramDb
progdb
  InstalledPackageIndex
index <- Verbosity
-> [(PackageDB, [InstalledPackageInfo])]
-> ProgramDb
-> IO InstalledPackageIndex
toPackageIndex Verbosity
verbosity [(PackageDB, [InstalledPackageInfo])]
pkgss ProgramDb
progdb
  InstalledPackageIndex -> IO InstalledPackageIndex
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (InstalledPackageIndex -> IO InstalledPackageIndex)
-> InstalledPackageIndex -> IO InstalledPackageIndex
forall a b. (a -> b) -> a -> b
$! InstalledPackageIndex
index

toPackageIndex
  :: Verbosity
  -> [(PackageDB, [InstalledPackageInfo])]
  -> ProgramDb
  -> IO InstalledPackageIndex
toPackageIndex :: Verbosity
-> [(PackageDB, [InstalledPackageInfo])]
-> ProgramDb
-> IO InstalledPackageIndex
toPackageIndex Verbosity
verbosity [(PackageDB, [InstalledPackageInfo])]
pkgss ProgramDb
progdb = do
  -- On Windows, various fields have $topdir/foo rather than full
  -- paths. We need to substitute the right value in so that when
  -- we, for example, call gcc, we have proper paths to give it.
  String
topDir <- Verbosity -> ConfiguredProgram -> IO String
getLibDir' Verbosity
verbosity ConfiguredProgram
ghcjsProg
  let indices :: [InstalledPackageIndex]
indices =
        [ [InstalledPackageInfo] -> InstalledPackageIndex
PackageIndex.fromList ((InstalledPackageInfo -> InstalledPackageInfo)
-> [InstalledPackageInfo] -> [InstalledPackageInfo]
forall a b. (a -> b) -> [a] -> [b]
map (String -> InstalledPackageInfo -> InstalledPackageInfo
Internal.substTopDir String
topDir) [InstalledPackageInfo]
pkgs)
        | (PackageDB
_, [InstalledPackageInfo]
pkgs) <- [(PackageDB, [InstalledPackageInfo])]
pkgss
        ]
  InstalledPackageIndex -> IO InstalledPackageIndex
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (InstalledPackageIndex -> IO InstalledPackageIndex)
-> InstalledPackageIndex -> IO InstalledPackageIndex
forall a b. (a -> b) -> a -> b
$! ([InstalledPackageIndex] -> InstalledPackageIndex
forall a. Monoid a => [a] -> a
mconcat [InstalledPackageIndex]
indices)
  where
    ghcjsProg :: ConfiguredProgram
ghcjsProg = ConfiguredProgram -> Maybe ConfiguredProgram -> ConfiguredProgram
forall a. a -> Maybe a -> a
fromMaybe (String -> ConfiguredProgram
forall a. HasCallStack => String -> a
error String
"GHCJS.toPackageIndex no ghcjs program") (Maybe ConfiguredProgram -> ConfiguredProgram)
-> Maybe ConfiguredProgram -> ConfiguredProgram
forall a b. (a -> b) -> a -> b
$ Program -> ProgramDb -> Maybe ConfiguredProgram
lookupProgram Program
ghcjsProgram ProgramDb
progdb

getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath
getLibDir :: Verbosity -> LocalBuildInfo -> IO String
getLibDir Verbosity
verbosity LocalBuildInfo
lbi =
  (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEndLE Char -> Bool
isSpace
    (String -> String) -> IO String -> IO String
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Verbosity -> Program -> ProgramDb -> [String] -> IO String
getDbProgramOutput
      Verbosity
verbosity
      Program
ghcjsProgram
      (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)
      [String
"--print-libdir"]

getLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath
getLibDir' :: Verbosity -> ConfiguredProgram -> IO String
getLibDir' Verbosity
verbosity ConfiguredProgram
ghcjsProg =
  (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEndLE Char -> Bool
isSpace
    (String -> String) -> IO String -> IO String
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Verbosity -> ConfiguredProgram -> [String] -> IO String
getProgramOutput Verbosity
verbosity ConfiguredProgram
ghcjsProg [String
"--print-libdir"]

-- | Return the 'FilePath' to the global GHC package database.
getGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO FilePath
getGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO String
getGlobalPackageDB Verbosity
verbosity ConfiguredProgram
ghcProg =
  (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEndLE Char -> Bool
isSpace
    (String -> String) -> IO String -> IO String
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Verbosity -> ConfiguredProgram -> [String] -> IO String
getProgramOutput Verbosity
verbosity ConfiguredProgram
ghcProg [String
"--print-global-package-db"]

-- | Return the 'FilePath' to the per-user GHC package database.
getUserPackageDB :: Verbosity -> ConfiguredProgram -> Platform -> IO FilePath
getUserPackageDB :: Verbosity -> ConfiguredProgram -> Platform -> IO String
getUserPackageDB Verbosity
_verbosity ConfiguredProgram
ghcjsProg Platform
platform = do
  -- It's rather annoying that we have to reconstruct this, because ghc
  -- hides this information from us otherwise. But for certain use cases
  -- like change monitoring it really can't remain hidden.
  String
appdir <- String -> IO String
getAppUserDataDirectory String
"ghcjs"
  String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
appdir String -> String -> String
</> String
platformAndVersion String -> String -> String
</> String
packageConfFileName)
  where
    platformAndVersion :: String
platformAndVersion =
      Platform -> Version -> String
Internal.ghcPlatformAndVersionString
        Platform
platform
        Version
ghcjsVersion
    packageConfFileName :: String
packageConfFileName = String
"package.conf.d"
    ghcjsVersion :: Version
ghcjsVersion = Version -> Maybe Version -> Version
forall a. a -> Maybe a -> a
fromMaybe (String -> Version
forall a. HasCallStack => String -> a
error String
"GHCJS.getUserPackageDB: no version") (Maybe Version -> Version) -> Maybe Version -> Version
forall a b. (a -> b) -> a -> b
$ ConfiguredProgram -> Maybe Version
programVersion ConfiguredProgram
ghcjsProg

checkPackageDbEnvVar :: Verbosity -> IO ()
checkPackageDbEnvVar :: Verbosity -> IO ()
checkPackageDbEnvVar Verbosity
verbosity =
  Verbosity -> String -> String -> IO ()
Internal.checkPackageDbEnvVar Verbosity
verbosity String
"GHCJS" String
"GHCJS_PACKAGE_PATH"

checkPackageDbStack :: Verbosity -> PackageDBStack -> IO ()
checkPackageDbStack :: Verbosity -> [PackageDB] -> IO ()
checkPackageDbStack Verbosity
_ (PackageDB
GlobalPackageDB : [PackageDB]
rest)
  | PackageDB
GlobalPackageDB PackageDB -> [PackageDB] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [PackageDB]
rest = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkPackageDbStack Verbosity
verbosity [PackageDB]
rest
  | PackageDB
GlobalPackageDB PackageDB -> [PackageDB] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [PackageDB]
rest =
      Verbosity -> String -> IO ()
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
        String
"With current ghc versions the global package db is always used "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"and must be listed first. This ghc limitation may be lifted in "
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"future, see https://gitlab.haskell.org/ghc/ghc/-/issues/5977"
checkPackageDbStack Verbosity
verbosity [PackageDB]
_ =
  Verbosity -> String -> IO ()
forall a. Verbosity -> String -> IO a
die' Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
    String
"If the global package db is specified, it must be "
      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"specified first and cannot be specified multiple times"

getInstalledPackages'
  :: Verbosity
  -> [PackageDB]
  -> ProgramDb
  -> IO [(PackageDB, [InstalledPackageInfo])]
getInstalledPackages' :: Verbosity
-> [PackageDB]
-> ProgramDb
-> IO [(PackageDB, [InstalledPackageInfo])]
getInstalledPackages' Verbosity
verbosity [PackageDB]
packagedbs ProgramDb
progdb =
  [IO (PackageDB, [InstalledPackageInfo])]
-> IO [(PackageDB, [InstalledPackageInfo])]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => [f a] -> f [a]
sequenceA
    [ do
      [InstalledPackageInfo]
pkgs <- HcPkgInfo -> Verbosity -> PackageDB -> IO [InstalledPackageInfo]
HcPkg.dump (ProgramDb -> HcPkgInfo
hcPkgInfo ProgramDb
progdb) Verbosity
verbosity PackageDB
packagedb
      (PackageDB, [InstalledPackageInfo])
-> IO (PackageDB, [InstalledPackageInfo])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PackageDB
packagedb, [InstalledPackageInfo]
pkgs)
    | PackageDB
packagedb <- [PackageDB]
packagedbs
    ]

-- | Get the packages from specific PackageDBs, not cumulative.
getInstalledPackagesMonitorFiles
  :: Verbosity
  -> Platform
  -> ProgramDb
  -> [PackageDB]
  -> IO [FilePath]
getInstalledPackagesMonitorFiles :: Verbosity -> Platform -> ProgramDb -> [PackageDB] -> IO [String]
getInstalledPackagesMonitorFiles Verbosity
verbosity Platform
platform ProgramDb
progdb =
  (PackageDB -> IO String) -> [PackageDB] -> 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 PackageDB -> IO String
getPackageDBPath
  where
    getPackageDBPath :: PackageDB -> IO FilePath
    getPackageDBPath :: PackageDB -> IO String
getPackageDBPath PackageDB
GlobalPackageDB =
      String -> IO String
selectMonitorFile (String -> IO String) -> IO String -> IO String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Verbosity -> ConfiguredProgram -> IO String
getGlobalPackageDB Verbosity
verbosity ConfiguredProgram
ghcjsProg
    getPackageDBPath PackageDB
UserPackageDB =
      String -> IO String
selectMonitorFile (String -> IO String) -> IO String -> IO String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Verbosity -> ConfiguredProgram -> Platform -> IO String
getUserPackageDB Verbosity
verbosity ConfiguredProgram
ghcjsProg Platform
platform
    getPackageDBPath (SpecificPackageDB String
path) = String -> IO String
selectMonitorFile String
path

    -- GHC has old style file dbs, and new style directory dbs.
    -- Note that for dir style dbs, we only need to monitor the cache file, not
    -- the whole directory. The ghc program itself only reads the cache file
    -- so it's safe to only monitor this one file.
    selectMonitorFile :: String -> IO String
selectMonitorFile String
path = do
      Bool
isFileStyle <- String -> IO Bool
doesFileExist String
path
      if Bool
isFileStyle
        then String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
path
        else String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
path String -> String -> String
</> String
"package.cache")

    ghcjsProg :: ConfiguredProgram
ghcjsProg = ConfiguredProgram -> Maybe ConfiguredProgram -> ConfiguredProgram
forall a. a -> Maybe a -> a
fromMaybe (String -> ConfiguredProgram
forall a. HasCallStack => String -> a
error String
"GHCJS.toPackageIndex no ghcjs program") (Maybe ConfiguredProgram -> ConfiguredProgram)
-> Maybe ConfiguredProgram -> ConfiguredProgram
forall a b. (a -> b) -> a -> b
$ Program -> ProgramDb -> Maybe ConfiguredProgram
lookupProgram Program
ghcjsProgram ProgramDb
progdb

toJSLibName :: String -> String
toJSLibName :: String -> String
toJSLibName String
lib
  | String -> String
takeExtension String
lib String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
".dll", String
".dylib", String
".so"] =
      String -> String -> String
replaceExtension String
lib String
"js_so"
  | String -> String
takeExtension String
lib String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".a" = String -> String -> String
replaceExtension String
lib String
"js_a"
  | Bool
otherwise = String
lib String -> String -> String
<.> String
"js_a"

-- -----------------------------------------------------------------------------
-- Building a library

buildLib
  :: Verbosity
  -> Flag (Maybe Int)
  -> PackageDescription
  -> LocalBuildInfo
  -> Library
  -> ComponentLocalBuildInfo
  -> IO ()
buildLib :: Verbosity
-> Flag (Maybe Int)
-> PackageDescription
-> LocalBuildInfo
-> Library
-> ComponentLocalBuildInfo
-> IO ()
buildLib = Maybe [String]
-> Verbosity
-> Flag (Maybe Int)
-> PackageDescription
-> LocalBuildInfo
-> Library
-> ComponentLocalBuildInfo
-> IO ()
buildOrReplLib Maybe [String]
forall a. Maybe a
Nothing

replLib
  :: [String]
  -> Verbosity
  -> Flag (Maybe Int)
  -> PackageDescription
  -> LocalBuildInfo
  -> Library
  -> ComponentLocalBuildInfo
  -> IO ()
replLib :: [String]
-> Verbosity
-> Flag (Maybe Int)
-> PackageDescription
-> LocalBuildInfo
-> Library
-> ComponentLocalBuildInfo
-> IO ()
replLib = Maybe [String]
-> Verbosity
-> Flag (Maybe Int)
-> PackageDescription
-> LocalBuildInfo
-> Library
-> ComponentLocalBuildInfo
-> IO ()
buildOrReplLib (Maybe [String]
 -> Verbosity
 -> Flag (Maybe Int)
 -> PackageDescription
 -> LocalBuildInfo
 -> Library
 -> ComponentLocalBuildInfo
 -> IO ())
-> ([String] -> Maybe [String])
-> [String]
-> Verbosity
-> Flag (Maybe Int)
-> PackageDescription
-> LocalBuildInfo
-> Library
-> ComponentLocalBuildInfo
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Maybe [String]
forall a. a -> Maybe a
Just

buildOrReplLib
  :: Maybe [String]
  -> Verbosity
  -> Flag (Maybe Int)
  -> PackageDescription
  -> LocalBuildInfo
  -> Library
  -> ComponentLocalBuildInfo
  -> IO ()
buildOrReplLib :: Maybe [String]
-> Verbosity
-> Flag (Maybe Int)
-> PackageDescription
-> LocalBuildInfo
-> Library
-> ComponentLocalBuildInfo
-> IO ()
buildOrReplLib Maybe [String]
mReplFlags Verbosity
verbosity Flag (Maybe Int)
numJobs PackageDescription
pkg_descr LocalBuildInfo
lbi Library
lib ComponentLocalBuildInfo
clbi = do
  let uid :: UnitId
uid = ComponentLocalBuildInfo -> UnitId
componentUnitId ComponentLocalBuildInfo
clbi
      libTargetDir :: String
libTargetDir = LocalBuildInfo -> ComponentLocalBuildInfo -> String
componentBuildDir LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi
      whenVanillaLib :: Bool -> f () -> f ()
whenVanillaLib Bool
forceVanilla =
        Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
forceVanilla Bool -> Bool -> Bool
|| LocalBuildInfo -> Bool
withVanillaLib LocalBuildInfo
lbi)
      whenProfLib :: IO () -> IO ()
whenProfLib = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LocalBuildInfo -> Bool
withProfLib LocalBuildInfo
lbi)
      whenSharedLib :: Bool -> f () -> f ()
whenSharedLib Bool
forceShared =
        Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
forceShared Bool -> Bool -> Bool
|| LocalBuildInfo -> Bool
withSharedLib LocalBuildInfo
lbi)
      whenStaticLib :: Bool -> f () -> f ()
whenStaticLib Bool
forceStatic =
        Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
forceStatic Bool -> Bool -> Bool
|| LocalBuildInfo -> Bool
withStaticLib LocalBuildInfo
lbi)
      -- whenGHCiLib = when (withGHCiLib lbi)
      forRepl :: Bool
forRepl = Bool -> ([String] -> Bool) -> Maybe [String] -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Bool -> [String] -> Bool
forall a b. a -> b -> a
const Bool
True) Maybe [String]
mReplFlags
      -- ifReplLib = when forRepl
      comp :: Compiler
comp = LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi
      implInfo :: GhcImplInfo
implInfo = Compiler -> GhcImplInfo
getImplInfo Compiler
comp
      platform :: Platform
platform@(Platform Arch
_hostArch OS
_hostOS) = LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi
      has_code :: Bool
has_code = Bool -> Bool
not (ComponentLocalBuildInfo -> Bool
componentIsIndefinite ComponentLocalBuildInfo
clbi)

  (ConfiguredProgram
ghcjsProg, ProgramDb
_) <- Verbosity
-> Program -> ProgramDb -> IO (ConfiguredProgram, ProgramDb)
requireProgram Verbosity
verbosity Program
ghcjsProgram (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)
  let runGhcjsProg :: GhcOptions -> IO ()
runGhcjsProg = Verbosity
-> ConfiguredProgram -> Compiler -> Platform -> GhcOptions -> IO ()
runGHC Verbosity
verbosity ConfiguredProgram
ghcjsProg Compiler
comp Platform
platform

  let libBi :: BuildInfo
libBi = Library -> BuildInfo
libBuildInfo Library
lib

  -- fixme flags shouldn't depend on ghcjs being dynamic or not
  let isGhcjsDynamic :: Bool
isGhcjsDynamic = Compiler -> Bool
isDynamic Compiler
comp
      dynamicTooSupported :: Bool
dynamicTooSupported = Compiler -> Bool
supportsDynamicToo Compiler
comp
      doingTH :: Bool
doingTH = BuildInfo -> Bool
usesTemplateHaskellOrQQ BuildInfo
libBi
      forceVanillaLib :: Bool
forceVanillaLib = Bool
doingTH Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isGhcjsDynamic
      forceSharedLib :: Bool
forceSharedLib = Bool
doingTH Bool -> Bool -> Bool
&& Bool
isGhcjsDynamic
  -- TH always needs default libs, even when building for profiling

  -- Determine if program coverage should be enabled and if so, what
  -- '-hpcdir' should be.
  let isCoverageEnabled :: Bool
isCoverageEnabled = LocalBuildInfo -> Bool
libCoverage LocalBuildInfo
lbi
      -- TODO: Historically HPC files have been put into a directory which
      -- has the package name.  I'm going to avoid changing this for
      -- now, but it would probably be better for this to be the
      -- component ID instead...
      pkg_name :: String
pkg_name = PackageId -> String
forall a. Pretty a => a -> String
prettyShow (PackageDescription -> PackageId
PD.package PackageDescription
pkg_descr)
      distPref :: String
distPref = Flag String -> String
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag String -> String) -> Flag String -> String
forall a b. (a -> b) -> a -> b
$ ConfigFlags -> Flag String
configDistPref (ConfigFlags -> Flag String) -> ConfigFlags -> Flag String
forall a b. (a -> b) -> a -> b
$ LocalBuildInfo -> ConfigFlags
configFlags LocalBuildInfo
lbi
      hpcdir :: Way -> Flag String
hpcdir Way
way
        | Bool
forRepl = Flag String
forall a. Monoid a => a
mempty -- HPC is not supported in ghci
        | Bool
isCoverageEnabled = String -> Flag String
forall a. a -> Flag a
toFlag (String -> Flag String) -> String -> Flag String
forall a b. (a -> b) -> a -> b
$ String -> Way -> String -> String
Hpc.mixDir String
distPref Way
way String
pkg_name
        | Bool
otherwise = Flag String
forall a. Monoid a => a
mempty

  Verbosity -> Bool -> String -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True String
libTargetDir
  -- TODO: do we need to put hs-boot files into place for mutually recursive
  -- modules?
  let cLikeFiles :: [String]
cLikeFiles = NubListR String -> [String]
forall a. NubListR a -> [a]
fromNubListR (NubListR String -> [String]) -> NubListR String -> [String]
forall a b. (a -> b) -> a -> b
$ [String] -> NubListR String
forall a. Ord a => [a] -> NubListR a
toNubListR (BuildInfo -> [String]
cSources BuildInfo
libBi) 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]
cxxSources BuildInfo
libBi)
      jsSrcs :: [String]
jsSrcs = BuildInfo -> [String]
jsSources BuildInfo
libBi
      cObjs :: [String]
cObjs = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> String
`replaceExtension` String
objExtension) [String]
cLikeFiles
      baseOpts :: GhcOptions
baseOpts = Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> String
-> GhcOptions
componentGhcOptions Verbosity
verbosity LocalBuildInfo
lbi BuildInfo
libBi ComponentLocalBuildInfo
clbi String
libTargetDir
      linkJsLibOpts :: GhcOptions
linkJsLibOpts =
        GhcOptions
forall a. Monoid a => a
mempty
          { ghcOptExtra =
              [ "-link-js-lib"
              , getHSLibraryName uid
              , "-js-lib-outputdir"
              , libTargetDir
              ]
                ++ jsSrcs
          }
      vanillaOptsNoJsLib :: GhcOptions
vanillaOptsNoJsLib =
        GhcOptions
baseOpts
          GhcOptions -> GhcOptions -> GhcOptions
forall a. Monoid a => a -> a -> a
`mappend` GhcOptions
forall a. Monoid a => a
mempty
            { ghcOptMode = toFlag GhcModeMake
            , ghcOptNumJobs = numJobs
            , ghcOptInputModules = toNubListR $ allLibModules lib clbi
            , ghcOptHPCDir = hpcdir Hpc.Vanilla
            }
      vanillaOpts :: GhcOptions
vanillaOpts = GhcOptions
vanillaOptsNoJsLib GhcOptions -> GhcOptions -> GhcOptions
forall a. Monoid a => a -> a -> a
`mappend` GhcOptions
linkJsLibOpts

      profOpts :: GhcOptions
profOpts =
        String -> String -> GhcOptions -> GhcOptions
adjustExts String
"p_hi" String
"p_o" GhcOptions
vanillaOpts
          GhcOptions -> GhcOptions -> GhcOptions
forall a. Monoid a => a -> a -> a
`mappend` GhcOptions
forall a. Monoid a => a
mempty
            { ghcOptProfilingMode = toFlag True
            , ghcOptProfilingAuto =
                Internal.profDetailLevelFlag
                  True
                  (withProfLibDetail lbi)
            , --  ghcOptHiSuffix      = toFlag "p_hi",
              --  ghcOptObjSuffix     = toFlag "p_o",
              ghcOptExtra = hcProfOptions GHC libBi
            , ghcOptHPCDir = hpcdir Hpc.Prof
            }

      sharedOpts :: GhcOptions
sharedOpts =
        String -> String -> GhcOptions -> GhcOptions
adjustExts String
"dyn_hi" String
"dyn_o" GhcOptions
vanillaOpts
          GhcOptions -> GhcOptions -> GhcOptions
forall a. Monoid a => a -> a -> a
`mappend` GhcOptions
forall a. Monoid a => a
mempty
            { ghcOptDynLinkMode = toFlag GhcDynamicOnly
            , ghcOptFPic = toFlag True
            , --  ghcOptHiSuffix    = toFlag "dyn_hi",
              --  ghcOptObjSuffix   = toFlag "dyn_o",
              ghcOptExtra = hcSharedOptions GHC libBi
            , ghcOptHPCDir = hpcdir Hpc.Dyn
            }

      vanillaSharedOpts :: GhcOptions
vanillaSharedOpts =
        GhcOptions
vanillaOpts
          GhcOptions -> GhcOptions -> GhcOptions
forall a. Monoid a => a -> a -> a
`mappend` GhcOptions
forall a. Monoid a => a
mempty
            { ghcOptDynLinkMode = toFlag GhcStaticAndDynamic
            , ghcOptDynHiSuffix = toFlag "js_dyn_hi"
            , ghcOptDynObjSuffix = toFlag "js_dyn_o"
            , ghcOptHPCDir = hpcdir Hpc.Dyn
            }

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
forRepl Bool -> Bool -> Bool
|| [ModuleName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Library -> ComponentLocalBuildInfo -> [ModuleName]
allLibModules Library
lib ComponentLocalBuildInfo
clbi) Bool -> Bool -> Bool
&& [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
jsSrcs Bool -> Bool -> Bool
&& [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
cObjs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    do
      let vanilla :: IO ()
vanilla = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
whenVanillaLib Bool
forceVanillaLib (GhcOptions -> IO ()
runGhcjsProg GhcOptions
vanillaOpts)
          shared :: IO ()
shared = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
whenSharedLib Bool
forceSharedLib (GhcOptions -> IO ()
runGhcjsProg GhcOptions
sharedOpts)
          useDynToo :: Bool
useDynToo =
            Bool
dynamicTooSupported
              Bool -> Bool -> Bool
&& (Bool
forceVanillaLib Bool -> Bool -> Bool
|| LocalBuildInfo -> Bool
withVanillaLib LocalBuildInfo
lbi)
              Bool -> Bool -> Bool
&& (Bool
forceSharedLib Bool -> Bool -> Bool
|| LocalBuildInfo -> Bool
withSharedLib LocalBuildInfo
lbi)
              Bool -> Bool -> Bool
&& [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (CompilerFlavor -> BuildInfo -> [String]
hcSharedOptions CompilerFlavor
GHC BuildInfo
libBi)
      if Bool -> Bool
not Bool
has_code
        then IO ()
vanilla
        else
          if Bool
useDynToo
            then do
              GhcOptions -> IO ()
runGhcjsProg GhcOptions
vanillaSharedOpts
              case (Way -> Flag String
hpcdir Way
Hpc.Dyn, Way -> Flag String
hpcdir Way
Hpc.Vanilla) of
                (Flag String
dynDir, Flag String
vanillaDir) ->
                  -- When the vanilla and shared library builds are done
                  -- in one pass, only one set of HPC module interfaces
                  -- are generated. This set should suffice for both
                  -- static and dynamically linked executables. We copy
                  -- the modules interfaces so they are available under
                  -- both ways.
                  Verbosity -> String -> String -> IO ()
copyDirectoryRecursive Verbosity
verbosity String
dynDir String
vanillaDir
                (Flag String, Flag String)
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            else
              if Bool
isGhcjsDynamic
                then do IO ()
shared; IO ()
vanilla
                else do IO ()
vanilla; IO ()
shared
      IO () -> IO ()
whenProfLib (GhcOptions -> IO ()
runGhcjsProg GhcOptions
profOpts)

  -- Build any C++ sources separately.
  {-
    unless (not has_code || null (cxxSources libBi) || not nativeToo) $ do
      info verbosity "Building C++ Sources..."
      sequence_
        [ do let baseCxxOpts    = Internal.componentCxxGhcOptions verbosity implInfo
                                  lbi libBi clbi libTargetDir filename
                 vanillaCxxOpts = if isGhcjsDynamic
                                  then baseCxxOpts { ghcOptFPic = toFlag True }
                                  else baseCxxOpts
                 profCxxOpts    = vanillaCxxOpts `mappend` mempty {
                                    ghcOptProfilingMode = toFlag True,
                                    ghcOptObjSuffix     = toFlag "p_o"
                                  }
                 sharedCxxOpts  = vanillaCxxOpts `mappend` mempty {
                                   ghcOptFPic        = toFlag True,
                                   ghcOptDynLinkMode = toFlag GhcDynamicOnly,
                                   ghcOptObjSuffix   = toFlag "dyn_o"
                                 }
                 odir           = fromFlag (ghcOptObjDir vanillaCxxOpts)
             createDirectoryIfMissingVerbose verbosity True odir
             let runGhcProgIfNeeded cxxOpts = do
                   needsRecomp <- checkNeedsRecompilation filename cxxOpts
                   when needsRecomp $ runGhcjsProg cxxOpts
             runGhcProgIfNeeded vanillaCxxOpts
             unless forRepl $
               whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCxxOpts)
             unless forRepl $ whenProfLib   (runGhcProgIfNeeded   profCxxOpts)
        | filename <- cxxSources libBi]

    ifReplLib $ do
      when (null (allLibModules lib clbi)) $ warn verbosity "No exposed modules"
      ifReplLib (runGhcjsProg replOpts)
  -}
  -- build any C sources
  -- TODO: Add support for S and CMM files.
  {-
    unless (not has_code || null (cSources libBi) || not nativeToo) $ do
      info verbosity "Building C Sources..."
      sequence_
        [ do let baseCcOpts    = Internal.componentCcGhcOptions verbosity implInfo
                                 lbi libBi clbi libTargetDir filename
                 vanillaCcOpts = if isGhcjsDynamic
                                 -- Dynamic GHC requires C sources to be built
                                 -- with -fPIC for REPL to work. See #2207.
                                 then baseCcOpts { ghcOptFPic = toFlag True }
                                 else baseCcOpts
                 profCcOpts    = vanillaCcOpts `mappend` mempty {
                                   ghcOptProfilingMode = toFlag True,
                                   ghcOptObjSuffix     = toFlag "p_o"
                                 }
                 sharedCcOpts  = vanillaCcOpts `mappend` mempty {
                                   ghcOptFPic        = toFlag True,
                                   ghcOptDynLinkMode = toFlag GhcDynamicOnly,
                                   ghcOptObjSuffix   = toFlag "dyn_o"
                                 }
                 odir          = fromFlag (ghcOptObjDir vanillaCcOpts)
             createDirectoryIfMissingVerbose verbosity True odir
             let runGhcProgIfNeeded ccOpts = do
                   needsRecomp <- checkNeedsRecompilation filename ccOpts
                   when needsRecomp $ runGhcjsProg ccOpts
             runGhcProgIfNeeded vanillaCcOpts
             unless forRepl $
               whenSharedLib forceSharedLib (runGhcProgIfNeeded sharedCcOpts)
             unless forRepl $ whenProfLib (runGhcProgIfNeeded profCcOpts)
        | filename <- cSources libBi]
  -}
  -- 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.

  -- link:

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
has_code (IO () -> IO ()) -> (IO () -> IO ()) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
False {- fixme nativeToo -} (IO () -> IO ()) -> (IO () -> IO ()) -> IO () -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
forRepl (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Verbosity -> String -> IO ()
info Verbosity
verbosity String
"Linking..."
    let cSharedObjs :: [String]
cSharedObjs =
          (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map
            (String -> String -> String
`replaceExtension` (String
"dyn_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
objExtension))
            (BuildInfo -> [String]
cSources BuildInfo
libBi [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ BuildInfo -> [String]
cxxSources BuildInfo
libBi)
        compiler_id :: CompilerId
compiler_id = Compiler -> CompilerId
compilerId (LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi)
        sharedLibFilePath :: String
sharedLibFilePath = String
libTargetDir String -> String -> String
</> Platform -> CompilerId -> UnitId -> String
mkSharedLibName (LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi) CompilerId
compiler_id UnitId
uid
        staticLibFilePath :: String
staticLibFilePath = String
libTargetDir String -> String -> String
</> Platform -> CompilerId -> UnitId -> String
mkStaticLibName (LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi) CompilerId
compiler_id UnitId
uid

    let stubObjs :: [a]
stubObjs = []
        stubSharedObjs :: [a]
stubSharedObjs = []

    {-
        stubObjs <- catMaybes <$> sequenceA
          [ findFileWithExtension [objExtension] [libTargetDir]
              (ModuleName.toFilePath x ++"_stub")
          | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files
          , x <- allLibModules lib clbi ]
        stubProfObjs <- catMaybes <$> sequenceA
          [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir]
              (ModuleName.toFilePath x ++"_stub")
          | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files
          , x <- allLibModules lib clbi ]
        stubSharedObjs <- catMaybes <$> sequenceA
          [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir]
              (ModuleName.toFilePath x ++"_stub")
          | ghcVersion < mkVersion [7,2] -- ghc-7.2+ does not make _stub.o files
          , x <- allLibModules lib clbi ]
    -}
    [String]
hObjs <-
      GhcImplInfo
-> Library
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> String
-> String
-> Bool
-> IO [String]
Internal.getHaskellObjects
        GhcImplInfo
implInfo
        Library
lib
        LocalBuildInfo
lbi
        ComponentLocalBuildInfo
clbi
        String
libTargetDir
        String
objExtension
        Bool
True
    [String]
hSharedObjs <-
      if LocalBuildInfo -> Bool
withSharedLib LocalBuildInfo
lbi
        then
          GhcImplInfo
-> Library
-> LocalBuildInfo
-> ComponentLocalBuildInfo
-> String
-> String
-> Bool
-> IO [String]
Internal.getHaskellObjects
            GhcImplInfo
implInfo
            Library
lib
            LocalBuildInfo
lbi
            ComponentLocalBuildInfo
clbi
            String
libTargetDir
            (String
"dyn_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
objExtension)
            Bool
False
        else [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []

    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]
hObjs Bool -> Bool -> Bool
&& [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
cObjs Bool -> Bool -> Bool
&& [Any] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Any]
forall a. [a]
stubObjs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      NubListR String
rpaths <- LocalBuildInfo -> ComponentLocalBuildInfo -> IO (NubListR String)
getRPaths LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi

      let staticObjectFiles :: [String]
staticObjectFiles =
            [String]
hObjs
              [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
libTargetDir String -> String -> String
</>) [String]
cObjs
              [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
forall a. [a]
stubObjs
          dynamicObjectFiles :: [String]
dynamicObjectFiles =
            [String]
hSharedObjs
              [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
libTargetDir String -> String -> String
</>) [String]
cSharedObjs
              [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
forall a. [a]
stubSharedObjs
          -- 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 :: GhcOptions
ghcSharedLinkArgs =
            GhcOptions
forall a. Monoid a => a
mempty
              { ghcOptShared = toFlag True
              , ghcOptDynLinkMode = toFlag GhcDynamicOnly
              , ghcOptInputFiles = toNubListR dynamicObjectFiles
              , ghcOptOutputFile = toFlag sharedLibFilePath
              , ghcOptExtra = hcSharedOptions GHC libBi
              , -- 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, -}
                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
              , ghcOptLinkLibs = extraLibs libBi
              , ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi
              , ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi
              , ghcOptLinkFrameworkDirs =
                  toNubListR $ PD.extraFrameworkDirs libBi
              , ghcOptRPaths = rpaths
              }
          ghcStaticLinkArgs :: GhcOptions
ghcStaticLinkArgs =
            GhcOptions
forall a. Monoid a => a
mempty
              { ghcOptStaticLib = toFlag True
              , ghcOptInputFiles = toNubListR staticObjectFiles
              , ghcOptOutputFile = toFlag staticLibFilePath
              , 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
              , ghcOptLinkLibs = extraLibs libBi
              , ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi
              }

      Verbosity -> String -> IO ()
info Verbosity
verbosity (NubListR (OpenUnitId, ModuleRenaming) -> String
forall a. Show a => a -> String
show (GhcOptions -> NubListR (OpenUnitId, ModuleRenaming)
ghcOptPackages GhcOptions
ghcSharedLinkArgs))
      {-
            whenVanillaLib False $ do
              Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles
              whenGHCiLib $ do
                (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi)
                Ld.combineObjectFiles verbosity lbi ldProg
                  ghciLibFilePath staticObjectFiles
                  -}
      {-
            whenProfLib $ do
              Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles
              whenGHCiLib $ do
                (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi)
                Ld.combineObjectFiles verbosity lbi ldProg
                  ghciProfLibFilePath profObjectFiles
      -}
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
whenSharedLib Bool
False (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        GhcOptions -> IO ()
runGhcjsProg GhcOptions
ghcSharedLinkArgs

      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
whenStaticLib Bool
False (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        GhcOptions -> IO ()
runGhcjsProg GhcOptions
ghcStaticLinkArgs

-- | Start a REPL without loading any source files.
startInterpreter
  :: Verbosity
  -> ProgramDb
  -> Compiler
  -> Platform
  -> PackageDBStack
  -> IO ()
startInterpreter :: Verbosity
-> ProgramDb -> Compiler -> Platform -> [PackageDB] -> IO ()
startInterpreter Verbosity
verbosity ProgramDb
progdb Compiler
comp Platform
platform [PackageDB]
packageDBs = do
  let replOpts :: GhcOptions
replOpts =
        GhcOptions
forall a. Monoid a => a
mempty
          { ghcOptMode = toFlag GhcModeInteractive
          , ghcOptPackageDBs = packageDBs
          }
  Verbosity -> [PackageDB] -> IO ()
checkPackageDbStack Verbosity
verbosity [PackageDB]
packageDBs
  (ConfiguredProgram
ghcjsProg, ProgramDb
_) <- Verbosity
-> Program -> ProgramDb -> IO (ConfiguredProgram, ProgramDb)
requireProgram Verbosity
verbosity Program
ghcjsProgram ProgramDb
progdb
  Verbosity
-> ConfiguredProgram -> Compiler -> Platform -> GhcOptions -> IO ()
runGHC Verbosity
verbosity ConfiguredProgram
ghcjsProg Compiler
comp Platform
platform GhcOptions
replOpts

-- -----------------------------------------------------------------------------
-- Building an executable or foreign library

-- | Build a foreign library
buildFLib
  :: Verbosity
  -> Flag (Maybe Int)
  -> PackageDescription
  -> LocalBuildInfo
  -> ForeignLib
  -> ComponentLocalBuildInfo
  -> IO ()
buildFLib :: Verbosity
-> Flag (Maybe Int)
-> PackageDescription
-> LocalBuildInfo
-> ForeignLib
-> ComponentLocalBuildInfo
-> IO ()
buildFLib Verbosity
v Flag (Maybe Int)
njobs PackageDescription
pkg LocalBuildInfo
lbi = Verbosity
-> Flag (Maybe Int)
-> PackageDescription
-> LocalBuildInfo
-> GBuildMode
-> ComponentLocalBuildInfo
-> IO ()
gbuild Verbosity
v Flag (Maybe Int)
njobs PackageDescription
pkg LocalBuildInfo
lbi (GBuildMode -> ComponentLocalBuildInfo -> IO ())
-> (ForeignLib -> GBuildMode)
-> ForeignLib
-> ComponentLocalBuildInfo
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ForeignLib -> GBuildMode
GBuildFLib

replFLib
  :: [String]
  -> Verbosity
  -> Flag (Maybe Int)
  -> PackageDescription
  -> LocalBuildInfo
  -> ForeignLib
  -> ComponentLocalBuildInfo
  -> IO ()
replFLib :: [String]
-> Verbosity
-> Flag (Maybe Int)
-> PackageDescription
-> LocalBuildInfo
-> ForeignLib
-> ComponentLocalBuildInfo
-> IO ()
replFLib [String]
replFlags Verbosity
v Flag (Maybe Int)
njobs PackageDescription
pkg LocalBuildInfo
lbi =
  Verbosity
-> Flag (Maybe Int)
-> PackageDescription
-> LocalBuildInfo
-> GBuildMode
-> ComponentLocalBuildInfo
-> IO ()
gbuild Verbosity
v Flag (Maybe Int)
njobs PackageDescription
pkg LocalBuildInfo
lbi (GBuildMode -> ComponentLocalBuildInfo -> IO ())
-> (ForeignLib -> GBuildMode)
-> ForeignLib
-> ComponentLocalBuildInfo
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> ForeignLib -> GBuildMode
GReplFLib [String]
replFlags

-- | Build an executable with GHC.
buildExe
  :: Verbosity
  -> Flag (Maybe Int)
  -> PackageDescription
  -> LocalBuildInfo
  -> Executable
  -> ComponentLocalBuildInfo
  -> IO ()
buildExe :: Verbosity
-> Flag (Maybe Int)
-> PackageDescription
-> LocalBuildInfo
-> Executable
-> ComponentLocalBuildInfo
-> IO ()
buildExe Verbosity
v Flag (Maybe Int)
njobs PackageDescription
pkg LocalBuildInfo
lbi = Verbosity
-> Flag (Maybe Int)
-> PackageDescription
-> LocalBuildInfo
-> GBuildMode
-> ComponentLocalBuildInfo
-> IO ()
gbuild Verbosity
v Flag (Maybe Int)
njobs PackageDescription
pkg LocalBuildInfo
lbi (GBuildMode -> ComponentLocalBuildInfo -> IO ())
-> (Executable -> GBuildMode)
-> Executable
-> ComponentLocalBuildInfo
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Executable -> GBuildMode
GBuildExe

replExe
  :: [String]
  -> Verbosity
  -> Flag (Maybe Int)
  -> PackageDescription
  -> LocalBuildInfo
  -> Executable
  -> ComponentLocalBuildInfo
  -> IO ()
replExe :: [String]
-> Verbosity
-> Flag (Maybe Int)
-> PackageDescription
-> LocalBuildInfo
-> Executable
-> ComponentLocalBuildInfo
-> IO ()
replExe [String]
replFlags Verbosity
v Flag (Maybe Int)
njobs PackageDescription
pkg LocalBuildInfo
lbi =
  Verbosity
-> Flag (Maybe Int)
-> PackageDescription
-> LocalBuildInfo
-> GBuildMode
-> ComponentLocalBuildInfo
-> IO ()
gbuild Verbosity
v Flag (Maybe Int)
njobs PackageDescription
pkg LocalBuildInfo
lbi (GBuildMode -> ComponentLocalBuildInfo -> IO ())
-> (Executable -> GBuildMode)
-> Executable
-> ComponentLocalBuildInfo
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Executable -> GBuildMode
GReplExe [String]
replFlags

-- | Building an executable, starting the REPL, and building foreign
-- libraries are all very similar and implemented in 'gbuild'. The
-- 'GBuildMode' distinguishes between the various kinds of operation.
data GBuildMode
  = GBuildExe Executable
  | GReplExe [String] Executable
  | GBuildFLib ForeignLib
  | GReplFLib [String] ForeignLib

gbuildInfo :: GBuildMode -> BuildInfo
gbuildInfo :: GBuildMode -> BuildInfo
gbuildInfo (GBuildExe Executable
exe) = Executable -> BuildInfo
buildInfo Executable
exe
gbuildInfo (GReplExe [String]
_ Executable
exe) = Executable -> BuildInfo
buildInfo Executable
exe
gbuildInfo (GBuildFLib ForeignLib
flib) = ForeignLib -> BuildInfo
foreignLibBuildInfo ForeignLib
flib
gbuildInfo (GReplFLib [String]
_ ForeignLib
flib) = ForeignLib -> BuildInfo
foreignLibBuildInfo ForeignLib
flib

gbuildName :: GBuildMode -> String
gbuildName :: GBuildMode -> String
gbuildName (GBuildExe Executable
exe) = UnqualComponentName -> String
unUnqualComponentName (UnqualComponentName -> String) -> UnqualComponentName -> String
forall a b. (a -> b) -> a -> b
$ Executable -> UnqualComponentName
exeName Executable
exe
gbuildName (GReplExe [String]
_ Executable
exe) = UnqualComponentName -> String
unUnqualComponentName (UnqualComponentName -> String) -> UnqualComponentName -> String
forall a b. (a -> b) -> a -> b
$ Executable -> UnqualComponentName
exeName Executable
exe
gbuildName (GBuildFLib ForeignLib
flib) = UnqualComponentName -> String
unUnqualComponentName (UnqualComponentName -> String) -> UnqualComponentName -> String
forall a b. (a -> b) -> a -> b
$ ForeignLib -> UnqualComponentName
foreignLibName ForeignLib
flib
gbuildName (GReplFLib [String]
_ ForeignLib
flib) = UnqualComponentName -> String
unUnqualComponentName (UnqualComponentName -> String) -> UnqualComponentName -> String
forall a b. (a -> b) -> a -> b
$ ForeignLib -> UnqualComponentName
foreignLibName ForeignLib
flib

gbuildTargetName :: LocalBuildInfo -> GBuildMode -> String
gbuildTargetName :: LocalBuildInfo -> GBuildMode -> String
gbuildTargetName LocalBuildInfo
lbi (GBuildExe Executable
exe) = Platform -> Executable -> String
exeTargetName (LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi) Executable
exe
gbuildTargetName LocalBuildInfo
lbi (GReplExe [String]
_ Executable
exe) = Platform -> Executable -> String
exeTargetName (LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi) Executable
exe
gbuildTargetName LocalBuildInfo
lbi (GBuildFLib ForeignLib
flib) = LocalBuildInfo -> ForeignLib -> String
flibTargetName LocalBuildInfo
lbi ForeignLib
flib
gbuildTargetName LocalBuildInfo
lbi (GReplFLib [String]
_ ForeignLib
flib) = LocalBuildInfo -> ForeignLib -> String
flibTargetName LocalBuildInfo
lbi ForeignLib
flib

exeTargetName :: Platform -> Executable -> String
exeTargetName :: Platform -> Executable -> String
exeTargetName Platform
platform Executable
exe = UnqualComponentName -> String
unUnqualComponentName (Executable -> UnqualComponentName
exeName Executable
exe) String -> String -> String
`withExt` Platform -> String
exeExtension Platform
platform

-- | Target name for a foreign library (the actual file name)
--
-- We do not use mkLibName and co here because the naming for foreign libraries
-- is slightly different (we don't use "_p" or compiler version suffices, and we
-- don't want the "lib" prefix on Windows).
--
-- TODO: We do use `dllExtension` and co here, but really that's wrong: they
-- use the OS used to build cabal to determine which extension to use, rather
-- than the target OS (but this is wrong elsewhere in Cabal as well).
flibTargetName :: LocalBuildInfo -> ForeignLib -> String
flibTargetName :: LocalBuildInfo -> ForeignLib -> String
flibTargetName LocalBuildInfo
lbi ForeignLib
flib =
  case (OS
os, ForeignLib -> ForeignLibType
foreignLibType ForeignLib
flib) of
    (OS
Windows, ForeignLibType
ForeignLibNativeShared) -> String
nm String -> String -> String
<.> String
"dll"
    (OS
Windows, ForeignLibType
ForeignLibNativeStatic) -> String
nm String -> String -> String
<.> String
"lib"
    (OS
Linux, ForeignLibType
ForeignLibNativeShared) -> String
"lib" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nm String -> String -> String
<.> String
versionedExt
    (OS
_other, ForeignLibType
ForeignLibNativeShared) -> String
"lib" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nm String -> String -> String
<.> Platform -> String
dllExtension (LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi)
    (OS
_other, ForeignLibType
ForeignLibNativeStatic) -> String
"lib" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nm String -> String -> String
<.> Platform -> String
staticLibExtension (LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi)
    (OS
_any, ForeignLibType
ForeignLibTypeUnknown) -> String -> String
forall a. String -> a
cabalBug String
"unknown foreign lib type"
  where
    nm :: String
    nm :: String
nm = UnqualComponentName -> String
unUnqualComponentName (UnqualComponentName -> String) -> UnqualComponentName -> String
forall a b. (a -> b) -> a -> b
$ ForeignLib -> UnqualComponentName
foreignLibName ForeignLib
flib

    os :: OS
    os :: OS
os =
      let (Platform Arch
_ OS
os') = LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi
       in OS
os'

    -- If a foreign lib foo has lib-version-info 5:1:2 or
    -- lib-version-linux 3.2.1, it should be built as libfoo.so.3.2.1
    -- Libtool's version-info data is translated into library versions in a
    -- nontrivial way: so refer to libtool documentation.
    versionedExt :: String
    versionedExt :: String
versionedExt =
      let nums :: [Int]
nums = ForeignLib -> OS -> [Int]
foreignLibVersion ForeignLib
flib OS
os
       in (String -> String -> String) -> String -> [String] -> String
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl String -> String -> String
(<.>) String
"so" ((Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Int -> String
forall a. Show a => a -> String
show [Int]
nums)

-- | Name for the library when building.
--
-- If the `lib-version-info` field or the `lib-version-linux` field of
-- a foreign library target is set, we need to incorporate that
-- version into the SONAME field.
--
-- If a foreign library foo has lib-version-info 5:1:2, it should be
-- built as libfoo.so.3.2.1.  We want it to get soname libfoo.so.3.
-- However, GHC does not allow overriding soname by setting linker
-- options, as it sets a soname of its own (namely the output
-- filename), after the user-supplied linker options.  Hence, we have
-- to compile the library with the soname as its filename.  We rename
-- the compiled binary afterwards.
--
-- This method allows to adjust the name of the library at build time
-- such that the correct soname can be set.
flibBuildName :: LocalBuildInfo -> ForeignLib -> String
flibBuildName :: LocalBuildInfo -> ForeignLib -> String
flibBuildName LocalBuildInfo
lbi ForeignLib
flib
  -- On linux, if a foreign-library has version data, the first digit is used
  -- to produce the SONAME.
  | (OS
os, ForeignLib -> ForeignLibType
foreignLibType ForeignLib
flib)
      (OS, ForeignLibType) -> (OS, ForeignLibType) -> Bool
forall a. Eq a => a -> a -> Bool
== (OS
Linux, ForeignLibType
ForeignLibNativeShared) =
      let nums :: [Int]
nums = ForeignLib -> OS -> [Int]
foreignLibVersion ForeignLib
flib OS
os
       in String
"lib" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nm String -> String -> String
<.> (String -> String -> String) -> String -> [String] -> String
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl String -> String -> String
(<.>) String
"so" ((Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Int -> String
forall a. Show a => a -> String
show (Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
1 [Int]
nums))
  | Bool
otherwise = LocalBuildInfo -> ForeignLib -> String
flibTargetName LocalBuildInfo
lbi ForeignLib
flib
  where
    os :: OS
    os :: OS
os =
      let (Platform Arch
_ OS
os') = LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi
       in OS
os'

    nm :: String
    nm :: String
nm = UnqualComponentName -> String
unUnqualComponentName (UnqualComponentName -> String) -> UnqualComponentName -> String
forall a b. (a -> b) -> a -> b
$ ForeignLib -> UnqualComponentName
foreignLibName ForeignLib
flib

gbuildIsRepl :: GBuildMode -> Bool
gbuildIsRepl :: GBuildMode -> Bool
gbuildIsRepl (GBuildExe Executable
_) = Bool
False
gbuildIsRepl (GReplExe [String]
_ Executable
_) = Bool
True
gbuildIsRepl (GBuildFLib ForeignLib
_) = Bool
False
gbuildIsRepl (GReplFLib [String]
_ ForeignLib
_) = Bool
True

gbuildNeedDynamic :: LocalBuildInfo -> GBuildMode -> Bool
gbuildNeedDynamic :: LocalBuildInfo -> GBuildMode -> Bool
gbuildNeedDynamic LocalBuildInfo
lbi GBuildMode
bm =
  case GBuildMode
bm of
    GBuildExe Executable
_ -> LocalBuildInfo -> Bool
withDynExe LocalBuildInfo
lbi
    GReplExe [String]
_ Executable
_ -> LocalBuildInfo -> Bool
withDynExe LocalBuildInfo
lbi
    GBuildFLib ForeignLib
flib -> ForeignLib -> Bool
withDynFLib ForeignLib
flib
    GReplFLib [String]
_ ForeignLib
flib -> ForeignLib -> Bool
withDynFLib ForeignLib
flib
  where
    withDynFLib :: ForeignLib -> Bool
withDynFLib ForeignLib
flib =
      case ForeignLib -> ForeignLibType
foreignLibType ForeignLib
flib of
        ForeignLibType
ForeignLibNativeShared ->
          ForeignLibOption
ForeignLibStandalone ForeignLibOption -> [ForeignLibOption] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` ForeignLib -> [ForeignLibOption]
foreignLibOptions ForeignLib
flib
        ForeignLibType
ForeignLibNativeStatic ->
          Bool
False
        ForeignLibType
ForeignLibTypeUnknown ->
          String -> Bool
forall a. String -> a
cabalBug String
"unknown foreign lib type"

gbuildModDefFiles :: GBuildMode -> [FilePath]
gbuildModDefFiles :: GBuildMode -> [String]
gbuildModDefFiles (GBuildExe Executable
_) = []
gbuildModDefFiles (GReplExe [String]
_ Executable
_) = []
gbuildModDefFiles (GBuildFLib ForeignLib
flib) = ForeignLib -> [String]
foreignLibModDefFile ForeignLib
flib
gbuildModDefFiles (GReplFLib [String]
_ ForeignLib
flib) = ForeignLib -> [String]
foreignLibModDefFile ForeignLib
flib

-- | "Main" module name when overridden by @ghc-options: -main-is ...@
-- or 'Nothing' if no @-main-is@ flag could be found.
--
-- In case of 'Nothing', 'Distribution.ModuleName.main' can be assumed.
exeMainModuleName :: Executable -> Maybe ModuleName
exeMainModuleName :: Executable -> Maybe ModuleName
exeMainModuleName Executable{buildInfo :: Executable -> BuildInfo
buildInfo = BuildInfo
bnfo} =
  -- GHC honors the last occurrence of a module name updated via -main-is
  --
  -- Moreover, -main-is when parsed left-to-right can update either
  -- the "Main" module name, or the "main" function name, or both,
  -- see also 'decodeMainIsArg'.
  [Maybe ModuleName] -> Maybe ModuleName
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([Maybe ModuleName] -> Maybe ModuleName)
-> [Maybe ModuleName] -> Maybe ModuleName
forall a b. (a -> b) -> a -> b
$ [Maybe ModuleName] -> [Maybe ModuleName]
forall a. [a] -> [a]
reverse ([Maybe ModuleName] -> [Maybe ModuleName])
-> [Maybe ModuleName] -> [Maybe ModuleName]
forall a b. (a -> b) -> a -> b
$ (String -> Maybe ModuleName) -> [String] -> [Maybe ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map String -> Maybe ModuleName
decodeMainIsArg ([String] -> [Maybe ModuleName]) -> [String] -> [Maybe ModuleName]
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
findIsMainArgs [String]
ghcopts
  where
    ghcopts :: [String]
ghcopts = CompilerFlavor -> BuildInfo -> [String]
hcOptions CompilerFlavor
GHC BuildInfo
bnfo

    findIsMainArgs :: [String] -> [String]
findIsMainArgs [] = []
    findIsMainArgs (String
"-main-is" : String
arg : [String]
rest) = String
arg String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String] -> [String]
findIsMainArgs [String]
rest
    findIsMainArgs (String
_ : [String]
rest) = [String] -> [String]
findIsMainArgs [String]
rest

-- | Decode argument to '-main-is'
--
-- Returns 'Nothing' if argument set only the function name.
--
-- This code has been stolen/refactored from GHC's DynFlags.setMainIs
-- function. The logic here is deliberately imperfect as it is
-- intended to be bug-compatible with GHC's parser. See discussion in
-- https://github.com/haskell/cabal/pull/4539#discussion_r118981753.
decodeMainIsArg :: String -> Maybe ModuleName
decodeMainIsArg :: String -> Maybe ModuleName
decodeMainIsArg String
arg
  | String -> (Char -> Bool) -> Bool
headOf String
main_fn Char -> Bool
isLower =
      -- The arg looked like "Foo.Bar.baz"
      ModuleName -> Maybe ModuleName
forall a. a -> Maybe a
Just (String -> ModuleName
forall a. IsString a => String -> a
ModuleName.fromString String
main_mod)
  | String -> (Char -> Bool) -> Bool
headOf String
arg Char -> Bool
isUpper -- The arg looked like "Foo" or "Foo.Bar"
    =
      ModuleName -> Maybe ModuleName
forall a. a -> Maybe a
Just (String -> ModuleName
forall a. IsString a => String -> a
ModuleName.fromString String
arg)
  | Bool
otherwise -- The arg looked like "baz"
    =
      Maybe ModuleName
forall a. Maybe a
Nothing
  where
    headOf :: String -> (Char -> Bool) -> Bool
    headOf :: String -> (Char -> Bool) -> Bool
headOf String
str Char -> Bool
pred' = (Char -> Bool) -> Maybe Char -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Char -> Bool
pred' (String -> Maybe Char
forall a. [a] -> Maybe a
safeHead String
str)

    (String
main_mod, String
main_fn) = String -> (Char -> Bool) -> (String, String)
splitLongestPrefix String
arg (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.')

    splitLongestPrefix :: String -> (Char -> Bool) -> (String, String)
    splitLongestPrefix :: String -> (Char -> Bool) -> (String, String)
splitLongestPrefix String
str Char -> Bool
pred'
      | String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
r_pre = (String
str, [])
      | Bool
otherwise = (String -> String
forall a. [a] -> [a]
reverse (String -> String
forall a. [a] -> [a]
safeTail String
r_pre), String -> String
forall a. [a] -> [a]
reverse String
r_suf)
      where
        -- 'safeTail' drops the char satisfying 'pred'
        (String
r_suf, String
r_pre) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
pred' (String -> String
forall a. [a] -> [a]
reverse String
str)

-- | A collection of:
--    * C input files
--    * C++ input files
--    * GHC input files
--    * GHC input modules
--
-- Used to correctly build and link sources.
data BuildSources = BuildSources
  { BuildSources -> [String]
cSourcesFiles :: [FilePath]
  , BuildSources -> [String]
cxxSourceFiles :: [FilePath]
  , BuildSources -> [String]
inputSourceFiles :: [FilePath]
  , BuildSources -> [ModuleName]
inputSourceModules :: [ModuleName]
  }

-- | Locate and return the 'BuildSources' required to build and link.
gbuildSources
  :: Verbosity
  -> PackageId
  -> CabalSpecVersion
  -> FilePath
  -> GBuildMode
  -> IO BuildSources
gbuildSources :: Verbosity
-> PackageId
-> CabalSpecVersion
-> String
-> GBuildMode
-> IO BuildSources
gbuildSources Verbosity
verbosity PackageId
pkgId CabalSpecVersion
specVer String
tmpDir GBuildMode
bm =
  case GBuildMode
bm of
    GBuildExe Executable
exe -> Executable -> IO BuildSources
exeSources Executable
exe
    GReplExe [String]
_ Executable
exe -> Executable -> IO BuildSources
exeSources Executable
exe
    GBuildFLib ForeignLib
flib -> BuildSources -> IO BuildSources
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (BuildSources -> IO BuildSources)
-> BuildSources -> IO BuildSources
forall a b. (a -> b) -> a -> b
$ ForeignLib -> BuildSources
flibSources ForeignLib
flib
    GReplFLib [String]
_ ForeignLib
flib -> BuildSources -> IO BuildSources
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (BuildSources -> IO BuildSources)
-> BuildSources -> IO BuildSources
forall a b. (a -> b) -> a -> b
$ ForeignLib -> BuildSources
flibSources ForeignLib
flib
  where
    exeSources :: Executable -> IO BuildSources
    exeSources :: Executable -> IO BuildSources
exeSources exe :: Executable
exe@Executable{buildInfo :: Executable -> BuildInfo
buildInfo = BuildInfo
bnfo, modulePath :: Executable -> String
modulePath = String
modPath} = do
      String
main <- Verbosity -> [String] -> String -> IO String
findFileEx Verbosity
verbosity (String
tmpDir String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (SymbolicPath PackageDir SourceDir -> String)
-> [SymbolicPath PackageDir SourceDir] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map SymbolicPath PackageDir SourceDir -> String
forall from to. SymbolicPath from to -> String
getSymbolicPath (BuildInfo -> [SymbolicPath PackageDir SourceDir]
hsSourceDirs BuildInfo
bnfo)) String
modPath
      let mainModName :: ModuleName
mainModName = ModuleName -> Maybe ModuleName -> ModuleName
forall a. a -> Maybe a -> a
fromMaybe ModuleName
ModuleName.main (Maybe ModuleName -> ModuleName) -> Maybe ModuleName -> ModuleName
forall a b. (a -> b) -> a -> b
$ Executable -> Maybe ModuleName
exeMainModuleName Executable
exe
          otherModNames :: [ModuleName]
otherModNames = Executable -> [ModuleName]
exeModules Executable
exe

      -- Scripts have fakePackageId and are always Haskell but can have any extension.
      if String -> Bool
isHaskell String
main Bool -> Bool -> Bool
|| PackageId
pkgId PackageId -> PackageId -> Bool
forall a. Eq a => a -> a -> Bool
== PackageId
fakePackageId
        then
          if CabalSpecVersion
specVer CabalSpecVersion -> CabalSpecVersion -> Bool
forall a. Ord a => a -> a -> Bool
< CabalSpecVersion
CabalSpecV2_0 Bool -> Bool -> Bool
&& (ModuleName
mainModName ModuleName -> [ModuleName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ModuleName]
otherModNames)
            then do
              -- The cabal manual clearly states that `other-modules` is
              -- intended for non-main modules.  However, there's at least one
              -- important package on Hackage (happy-1.19.5) which
              -- violates this. We workaround this here so that we don't
              -- invoke GHC with e.g.  'ghc --make Main src/Main.hs' which
              -- would result in GHC complaining about duplicate Main
              -- modules.
              --
              -- Finally, we only enable this workaround for
              -- specVersion < 2, as 'cabal-version:>=2.0' cabal files
              -- have no excuse anymore to keep doing it wrong... ;-)
              Verbosity -> String -> IO ()
warn Verbosity
verbosity (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
                String
"Enabling workaround for Main module '"
                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ ModuleName -> String
forall a. Pretty a => a -> String
prettyShow ModuleName
mainModName
                  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' listed in 'other-modules' illegally!"

              BuildSources -> IO BuildSources
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
                BuildSources
                  { cSourcesFiles :: [String]
cSourcesFiles = BuildInfo -> [String]
cSources BuildInfo
bnfo
                  , cxxSourceFiles :: [String]
cxxSourceFiles = BuildInfo -> [String]
cxxSources BuildInfo
bnfo
                  , inputSourceFiles :: [String]
inputSourceFiles = [String
main]
                  , inputSourceModules :: [ModuleName]
inputSourceModules = (ModuleName -> Bool) -> [ModuleName] -> [ModuleName]
forall a. (a -> Bool) -> [a] -> [a]
filter (ModuleName -> ModuleName -> Bool
forall a. Eq a => a -> a -> Bool
/= ModuleName
mainModName) ([ModuleName] -> [ModuleName]) -> [ModuleName] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$ Executable -> [ModuleName]
exeModules Executable
exe
                  }
            else
              BuildSources -> IO BuildSources
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
                BuildSources
                  { cSourcesFiles :: [String]
cSourcesFiles = BuildInfo -> [String]
cSources BuildInfo
bnfo
                  , cxxSourceFiles :: [String]
cxxSourceFiles = BuildInfo -> [String]
cxxSources BuildInfo
bnfo
                  , inputSourceFiles :: [String]
inputSourceFiles = [String
main]
                  , inputSourceModules :: [ModuleName]
inputSourceModules = Executable -> [ModuleName]
exeModules Executable
exe
                  }
        else
          let ([String]
csf, [String]
cxxsf)
                | String -> Bool
isCxx String
main = (BuildInfo -> [String]
cSources BuildInfo
bnfo, String
main String -> [String] -> [String]
forall a. a -> [a] -> [a]
: BuildInfo -> [String]
cxxSources BuildInfo
bnfo)
                -- if main is not a Haskell source
                -- and main is not a C++ source
                -- then we assume that it is a C source
                | Bool
otherwise = (String
main String -> [String] -> [String]
forall a. a -> [a] -> [a]
: BuildInfo -> [String]
cSources BuildInfo
bnfo, BuildInfo -> [String]
cxxSources BuildInfo
bnfo)
           in BuildSources -> IO BuildSources
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
                BuildSources
                  { cSourcesFiles :: [String]
cSourcesFiles = [String]
csf
                  , cxxSourceFiles :: [String]
cxxSourceFiles = [String]
cxxsf
                  , inputSourceFiles :: [String]
inputSourceFiles = []
                  , inputSourceModules :: [ModuleName]
inputSourceModules = Executable -> [ModuleName]
exeModules Executable
exe
                  }

    flibSources :: ForeignLib -> BuildSources
    flibSources :: ForeignLib -> BuildSources
flibSources flib :: ForeignLib
flib@ForeignLib{foreignLibBuildInfo :: ForeignLib -> BuildInfo
foreignLibBuildInfo = BuildInfo
bnfo} =
      BuildSources
        { cSourcesFiles :: [String]
cSourcesFiles = BuildInfo -> [String]
cSources BuildInfo
bnfo
        , cxxSourceFiles :: [String]
cxxSourceFiles = BuildInfo -> [String]
cxxSources BuildInfo
bnfo
        , inputSourceFiles :: [String]
inputSourceFiles = []
        , inputSourceModules :: [ModuleName]
inputSourceModules = ForeignLib -> [ModuleName]
foreignLibModules ForeignLib
flib
        }

    isCxx :: FilePath -> Bool
    isCxx :: String -> Bool
isCxx String
fp = String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (String -> String
takeExtension String
fp) [String
".cpp", String
".cxx", String
".c++"]

-- | FilePath has a Haskell extension: .hs or .lhs
isHaskell :: FilePath -> Bool
isHaskell :: String -> Bool
isHaskell String
fp = String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (String -> String
takeExtension String
fp) [String
".hs", String
".lhs"]

-- | Generic build function. See comment for 'GBuildMode'.
gbuild
  :: Verbosity
  -> Flag (Maybe Int)
  -> PackageDescription
  -> LocalBuildInfo
  -> GBuildMode
  -> ComponentLocalBuildInfo
  -> IO ()
gbuild :: Verbosity
-> Flag (Maybe Int)
-> PackageDescription
-> LocalBuildInfo
-> GBuildMode
-> ComponentLocalBuildInfo
-> IO ()
gbuild Verbosity
verbosity Flag (Maybe Int)
numJobs PackageDescription
pkg_descr LocalBuildInfo
lbi GBuildMode
bm ComponentLocalBuildInfo
clbi = do
  (ConfiguredProgram
ghcjsProg, ProgramDb
_) <- Verbosity
-> Program -> ProgramDb -> IO (ConfiguredProgram, ProgramDb)
requireProgram Verbosity
verbosity Program
ghcjsProgram (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)
  let replFlags :: [String]
replFlags = case GBuildMode
bm of
        GReplExe [String]
flags Executable
_ -> [String]
flags
        GReplFLib [String]
flags ForeignLib
_ -> [String]
flags
        GBuildExe{} -> [String]
forall a. Monoid a => a
mempty
        GBuildFLib{} -> [String]
forall a. Monoid a => a
mempty
      comp :: Compiler
comp = LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi
      platform :: Platform
platform = LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi
      implInfo :: GhcImplInfo
implInfo = Compiler -> GhcImplInfo
getImplInfo Compiler
comp
      runGhcProg :: GhcOptions -> IO ()
runGhcProg = Verbosity
-> ConfiguredProgram -> Compiler -> Platform -> GhcOptions -> IO ()
runGHC Verbosity
verbosity ConfiguredProgram
ghcjsProg Compiler
comp Platform
platform

  let (BuildInfo
bnfo, Bool
threaded) = case GBuildMode
bm of
        GBuildFLib ForeignLib
_ -> BuildInfo -> (BuildInfo, Bool)
popThreadedFlag (GBuildMode -> BuildInfo
gbuildInfo GBuildMode
bm)
        GBuildMode
_ -> (GBuildMode -> BuildInfo
gbuildInfo GBuildMode
bm, Bool
False)

  -- the name that GHC really uses (e.g., with .exe on Windows for executables)
  let targetName :: String
targetName = LocalBuildInfo -> GBuildMode -> String
gbuildTargetName LocalBuildInfo
lbi GBuildMode
bm
  let targetDir :: String
targetDir = LocalBuildInfo -> String
buildDir LocalBuildInfo
lbi String -> String -> String
</> (GBuildMode -> String
gbuildName GBuildMode
bm)
  let tmpDir :: String
tmpDir = String
targetDir String -> String -> String
</> (GBuildMode -> String
gbuildName GBuildMode
bm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"-tmp")
  Verbosity -> Bool -> String -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True String
targetDir
  Verbosity -> Bool -> String -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True String
tmpDir

  -- TODO: do we need to put hs-boot files into place for mutually recursive
  -- modules?  FIX: what about exeName.hi-boot?

  -- Determine if program coverage should be enabled and if so, what
  -- '-hpcdir' should be.
  let isCoverageEnabled :: Bool
isCoverageEnabled = LocalBuildInfo -> Bool
exeCoverage LocalBuildInfo
lbi
      distPref :: String
distPref = Flag String -> String
forall a. WithCallStack (Flag a -> a)
fromFlag (Flag String -> String) -> Flag String -> String
forall a b. (a -> b) -> a -> b
$ ConfigFlags -> Flag String
configDistPref (ConfigFlags -> Flag String) -> ConfigFlags -> Flag String
forall a b. (a -> b) -> a -> b
$ LocalBuildInfo -> ConfigFlags
configFlags LocalBuildInfo
lbi
      hpcdir :: Way -> Flag String
hpcdir Way
way
        | GBuildMode -> Bool
gbuildIsRepl GBuildMode
bm = Flag String
forall a. Monoid a => a
mempty -- HPC is not supported in ghci
        | Bool
isCoverageEnabled = String -> Flag String
forall a. a -> Flag a
toFlag (String -> Flag String) -> String -> Flag String
forall a b. (a -> b) -> a -> b
$ String -> Way -> String -> String
Hpc.mixDir String
distPref Way
way (GBuildMode -> String
gbuildName GBuildMode
bm)
        | Bool
otherwise = Flag String
forall a. Monoid a => a
mempty

  NubListR String
rpaths <- LocalBuildInfo -> ComponentLocalBuildInfo -> IO (NubListR String)
getRPaths LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi
  BuildSources
buildSources <- Verbosity
-> PackageId
-> CabalSpecVersion
-> String
-> GBuildMode
-> IO BuildSources
gbuildSources Verbosity
verbosity (PackageDescription -> PackageId
package PackageDescription
pkg_descr) (PackageDescription -> CabalSpecVersion
specVersion PackageDescription
pkg_descr) String
tmpDir GBuildMode
bm

  let cSrcs :: [String]
cSrcs = BuildSources -> [String]
cSourcesFiles BuildSources
buildSources
      cxxSrcs :: [String]
cxxSrcs = BuildSources -> [String]
cxxSourceFiles BuildSources
buildSources
      inputFiles :: [String]
inputFiles = BuildSources -> [String]
inputSourceFiles BuildSources
buildSources
      inputModules :: [ModuleName]
inputModules = BuildSources -> [ModuleName]
inputSourceModules BuildSources
buildSources
      isGhcDynamic :: Bool
isGhcDynamic = Compiler -> Bool
isDynamic Compiler
comp
      dynamicTooSupported :: Bool
dynamicTooSupported = Compiler -> Bool
supportsDynamicToo Compiler
comp
      cObjs :: [String]
cObjs = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> String
`replaceExtension` String
objExtension) [String]
cSrcs
      cxxObjs :: [String]
cxxObjs = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> String
`replaceExtension` String
objExtension) [String]
cxxSrcs
      needDynamic :: Bool
needDynamic = LocalBuildInfo -> GBuildMode -> Bool
gbuildNeedDynamic LocalBuildInfo
lbi GBuildMode
bm
      needProfiling :: Bool
needProfiling = LocalBuildInfo -> Bool
withProfExe LocalBuildInfo
lbi

      -- build executables
      buildRunner :: Bool
buildRunner = case ComponentLocalBuildInfo
clbi of
        LibComponentLocalBuildInfo{} -> Bool
False
        FLibComponentLocalBuildInfo{} -> Bool
False
        ExeComponentLocalBuildInfo{} -> Bool
True
        TestComponentLocalBuildInfo{} -> Bool
True
        BenchComponentLocalBuildInfo{} -> Bool
True
      baseOpts :: GhcOptions
baseOpts =
        (Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> String
-> GhcOptions
componentGhcOptions Verbosity
verbosity LocalBuildInfo
lbi BuildInfo
bnfo ComponentLocalBuildInfo
clbi String
tmpDir)
          GhcOptions -> GhcOptions -> GhcOptions
forall a. Monoid a => a -> a -> a
`mappend` GhcOptions
forall a. Monoid a => a
mempty
            { ghcOptMode = toFlag GhcModeMake
            , ghcOptInputFiles =
                toNubListR $
                  if package pkg_descr == fakePackageId
                    then filter isHaskell inputFiles
                    else inputFiles
            , ghcOptInputScripts =
                toNubListR $
                  if package pkg_descr == fakePackageId
                    then filter (not . isHaskell) inputFiles
                    else []
            , ghcOptInputModules = toNubListR inputModules
            , -- for all executable components (exe/test/bench),
              -- GHCJS must be passed the "-build-runner" option
              ghcOptExtra =
                if buildRunner
                  then ["-build-runner"]
                  else mempty
            }
      staticOpts :: GhcOptions
staticOpts =
        GhcOptions
baseOpts
          GhcOptions -> GhcOptions -> GhcOptions
forall a. Monoid a => a -> a -> a
`mappend` GhcOptions
forall a. Monoid a => a
mempty
            { ghcOptDynLinkMode = toFlag GhcStaticOnly
            , ghcOptHPCDir = hpcdir Hpc.Vanilla
            }
      profOpts :: GhcOptions
profOpts =
        GhcOptions
baseOpts
          GhcOptions -> GhcOptions -> GhcOptions
forall a. Monoid a => a -> a -> a
`mappend` GhcOptions
forall a. Monoid a => a
mempty
            { ghcOptProfilingMode = toFlag True
            , ghcOptProfilingAuto =
                Internal.profDetailLevelFlag
                  False
                  (withProfExeDetail lbi)
            , ghcOptHiSuffix = toFlag "p_hi"
            , ghcOptObjSuffix = toFlag "p_o"
            , ghcOptExtra = hcProfOptions GHC bnfo
            , ghcOptHPCDir = hpcdir Hpc.Prof
            }
      dynOpts :: GhcOptions
dynOpts =
        GhcOptions
baseOpts
          GhcOptions -> GhcOptions -> GhcOptions
forall a. Monoid a => a -> a -> a
`mappend` GhcOptions
forall a. Monoid a => a
mempty
            { ghcOptDynLinkMode = toFlag GhcDynamicOnly
            , -- TODO: Does it hurt to set -fPIC for executables?
              ghcOptFPic = toFlag True
            , ghcOptHiSuffix = toFlag "dyn_hi"
            , ghcOptObjSuffix = toFlag "dyn_o"
            , ghcOptExtra = hcSharedOptions GHC bnfo
            , ghcOptHPCDir = hpcdir Hpc.Dyn
            }
      dynTooOpts :: GhcOptions
dynTooOpts =
        GhcOptions
staticOpts
          GhcOptions -> GhcOptions -> GhcOptions
forall a. Monoid a => a -> a -> a
`mappend` GhcOptions
forall a. Monoid a => a
mempty
            { ghcOptDynLinkMode = toFlag GhcStaticAndDynamic
            , ghcOptDynHiSuffix = toFlag "dyn_hi"
            , ghcOptDynObjSuffix = toFlag "dyn_o"
            , ghcOptHPCDir = hpcdir Hpc.Dyn
            }
      linkerOpts :: GhcOptions
linkerOpts =
        GhcOptions
forall a. Monoid a => a
mempty
          { ghcOptLinkOptions = PD.ldOptions bnfo
          , ghcOptLinkLibs = extraLibs bnfo
          , ghcOptLinkLibPath = toNubListR $ extraLibDirs bnfo
          , ghcOptLinkFrameworks =
              toNubListR $
                PD.frameworks bnfo
          , ghcOptLinkFrameworkDirs =
              toNubListR $
                PD.extraFrameworkDirs bnfo
          , ghcOptInputFiles =
              toNubListR
                [tmpDir </> x | x <- cObjs ++ cxxObjs]
          }
      dynLinkerOpts :: GhcOptions
dynLinkerOpts =
        GhcOptions
forall a. Monoid a => a
mempty
          { ghcOptRPaths = rpaths
          }
      replOpts :: GhcOptions
replOpts =
        GhcOptions
baseOpts
          { ghcOptExtra =
              Internal.filterGhciFlags
                (ghcOptExtra baseOpts)
                <> replFlags
          }
          -- 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.
          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
            { ghcOptMode = toFlag GhcModeInteractive
            , ghcOptOptimisation = toFlag GhcNoOptimisation
            }
      commonOpts :: GhcOptions
commonOpts
        | Bool
needProfiling = GhcOptions
profOpts
        | Bool
needDynamic = GhcOptions
dynOpts
        | Bool
otherwise = GhcOptions
staticOpts
      compileOpts :: GhcOptions
compileOpts
        | Bool
useDynToo = GhcOptions
dynTooOpts
        | Bool
otherwise = GhcOptions
commonOpts
      withStaticExe :: Bool
withStaticExe = Bool -> Bool
not Bool
needProfiling Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
needDynamic

      -- For building exe's that use TH with -prof or -dynamic we actually have
      -- to build twice, once without -prof/-dynamic and then again with
      -- -prof/-dynamic. This is because the code that TH needs to run at
      -- compile time needs to be the vanilla ABI so it can be loaded up and run
      -- by the compiler.
      -- With dynamic-by-default GHC the TH object files loaded at compile-time
      -- need to be .dyn_o instead of .o.
      doingTH :: Bool
doingTH = BuildInfo -> Bool
usesTemplateHaskellOrQQ BuildInfo
bnfo
      -- Should we use -dynamic-too instead of compiling twice?
      useDynToo :: Bool
useDynToo =
        Bool
dynamicTooSupported
          Bool -> Bool -> Bool
&& Bool
isGhcDynamic
          Bool -> Bool -> Bool
&& Bool
doingTH
          Bool -> Bool -> Bool
&& Bool
withStaticExe
          Bool -> Bool -> Bool
&& [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (CompilerFlavor -> BuildInfo -> [String]
hcSharedOptions CompilerFlavor
GHC BuildInfo
bnfo)
      compileTHOpts :: GhcOptions
compileTHOpts
        | Bool
isGhcDynamic = GhcOptions
dynOpts
        | Bool
otherwise = GhcOptions
staticOpts
      compileForTH :: Bool
compileForTH
        | GBuildMode -> Bool
gbuildIsRepl GBuildMode
bm = Bool
False
        | Bool
useDynToo = Bool
False
        | Bool
isGhcDynamic = Bool
doingTH Bool -> Bool -> Bool
&& (Bool
needProfiling Bool -> Bool -> Bool
|| Bool
withStaticExe)
        | Bool
otherwise = Bool
doingTH Bool -> Bool -> Bool
&& (Bool
needProfiling Bool -> Bool -> Bool
|| Bool
needDynamic)

  -- Build static/dynamic object files for TH, if needed.
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
compileForTH (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    GhcOptions -> IO ()
runGhcProg
      GhcOptions
compileTHOpts
        { ghcOptNoLink = toFlag True
        , ghcOptNumJobs = numJobs
        }

  -- Do not try to build anything if there are no input files.
  -- This can happen if the cabal file ends up with only cSrcs
  -- but no Haskell modules.
  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]
inputFiles Bool -> Bool -> Bool
&& [ModuleName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ModuleName]
inputModules)
        Bool -> Bool -> Bool
|| GBuildMode -> Bool
gbuildIsRepl GBuildMode
bm
    )
    (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ GhcOptions -> IO ()
runGhcProg
      GhcOptions
compileOpts
        { ghcOptNoLink = toFlag True
        , ghcOptNumJobs = numJobs
        }

  -- build any C++ sources
  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]
cxxSrcs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Verbosity -> String -> IO ()
info Verbosity
verbosity String
"Building C++ Sources..."
    [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
      [ do
        let baseCxxOpts :: GhcOptions
baseCxxOpts =
              Verbosity
-> GhcImplInfo
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> String
-> String
-> GhcOptions
Internal.componentCxxGhcOptions
                Verbosity
verbosity
                GhcImplInfo
implInfo
                LocalBuildInfo
lbi
                BuildInfo
bnfo
                ComponentLocalBuildInfo
clbi
                String
tmpDir
                String
filename
            vanillaCxxOpts :: GhcOptions
vanillaCxxOpts =
              if Bool
isGhcDynamic
                then -- Dynamic GHC requires C++ sources to be built
                -- with -fPIC for REPL to work. See #2207.
                  GhcOptions
baseCxxOpts{ghcOptFPic = toFlag True}
                else GhcOptions
baseCxxOpts
            profCxxOpts :: GhcOptions
profCxxOpts =
              GhcOptions
vanillaCxxOpts
                GhcOptions -> GhcOptions -> GhcOptions
forall a. Monoid a => a -> a -> a
`mappend` GhcOptions
forall a. Monoid a => a
mempty
                  { ghcOptProfilingMode = toFlag True
                  }
            sharedCxxOpts :: GhcOptions
sharedCxxOpts =
              GhcOptions
vanillaCxxOpts
                GhcOptions -> GhcOptions -> GhcOptions
forall a. Monoid a => a -> a -> a
`mappend` GhcOptions
forall a. Monoid a => a
mempty
                  { ghcOptFPic = toFlag True
                  , ghcOptDynLinkMode = toFlag GhcDynamicOnly
                  }
            opts :: GhcOptions
opts
              | Bool
needProfiling = GhcOptions
profCxxOpts
              | Bool
needDynamic = GhcOptions
sharedCxxOpts
              | Bool
otherwise = GhcOptions
vanillaCxxOpts
            -- TODO: Placing all Haskell, C, & C++ objects in a single directory
            --       Has the potential for file collisions. In general we would
            --       consider this a user error. However, we should strive to
            --       add a warning if this occurs.
            odir :: String
odir = Flag String -> String
forall a. WithCallStack (Flag a -> a)
fromFlag (GhcOptions -> Flag String
ghcOptObjDir GhcOptions
opts)
        Verbosity -> Bool -> String -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True String
odir
        Bool
needsRecomp <- String -> GhcOptions -> IO Bool
checkNeedsRecompilation String
filename GhcOptions
opts
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needsRecomp (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          GhcOptions -> IO ()
runGhcProg GhcOptions
opts
      | String
filename <- [String]
cxxSrcs
      ]

  -- build any C sources
  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]
cSrcs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Verbosity -> String -> IO ()
info Verbosity
verbosity String
"Building C Sources..."
    [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
      [ do
        let baseCcOpts :: GhcOptions
baseCcOpts =
              Verbosity
-> GhcImplInfo
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> String
-> String
-> GhcOptions
Internal.componentCcGhcOptions
                Verbosity
verbosity
                GhcImplInfo
implInfo
                LocalBuildInfo
lbi
                BuildInfo
bnfo
                ComponentLocalBuildInfo
clbi
                String
tmpDir
                String
filename
            vanillaCcOpts :: GhcOptions
vanillaCcOpts =
              if Bool
isGhcDynamic
                then -- Dynamic GHC requires C sources to be built
                -- with -fPIC for REPL to work. See #2207.
                  GhcOptions
baseCcOpts{ghcOptFPic = toFlag True}
                else GhcOptions
baseCcOpts
            profCcOpts :: GhcOptions
profCcOpts =
              GhcOptions
vanillaCcOpts
                GhcOptions -> GhcOptions -> GhcOptions
forall a. Monoid a => a -> a -> a
`mappend` GhcOptions
forall a. Monoid a => a
mempty
                  { ghcOptProfilingMode = toFlag True
                  }
            sharedCcOpts :: GhcOptions
sharedCcOpts =
              GhcOptions
vanillaCcOpts
                GhcOptions -> GhcOptions -> GhcOptions
forall a. Monoid a => a -> a -> a
`mappend` GhcOptions
forall a. Monoid a => a
mempty
                  { ghcOptFPic = toFlag True
                  , ghcOptDynLinkMode = toFlag GhcDynamicOnly
                  }
            opts :: GhcOptions
opts
              | Bool
needProfiling = GhcOptions
profCcOpts
              | Bool
needDynamic = GhcOptions
sharedCcOpts
              | Bool
otherwise = GhcOptions
vanillaCcOpts
            odir :: String
odir = Flag String -> String
forall a. WithCallStack (Flag a -> a)
fromFlag (GhcOptions -> Flag String
ghcOptObjDir GhcOptions
opts)
        Verbosity -> Bool -> String -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True String
odir
        Bool
needsRecomp <- String -> GhcOptions -> IO Bool
checkNeedsRecompilation String
filename GhcOptions
opts
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
needsRecomp (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          GhcOptions -> IO ()
runGhcProg GhcOptions
opts
      | String
filename <- [String]
cSrcs
      ]

  -- 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.
  case GBuildMode
bm of
    GReplExe [String]
_ Executable
_ -> GhcOptions -> IO ()
runGhcProg GhcOptions
replOpts
    GReplFLib [String]
_ ForeignLib
_ -> GhcOptions -> IO ()
runGhcProg GhcOptions
replOpts
    GBuildExe Executable
_ -> do
      let linkOpts :: GhcOptions
linkOpts =
            GhcOptions
commonOpts
              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
                { ghcOptLinkNoHsMain = toFlag (null inputFiles)
                }
              GhcOptions -> GhcOptions -> GhcOptions
forall a. Monoid a => a -> a -> a
`mappend` (if LocalBuildInfo -> Bool
withDynExe LocalBuildInfo
lbi then GhcOptions
dynLinkerOpts else GhcOptions
forall a. Monoid a => a
mempty)

      Verbosity -> String -> IO ()
info Verbosity
verbosity String
"Linking..."
      -- Work around old GHCs not relinking in this
      -- situation, see #3294
      let target :: String
target = String
targetDir String -> String -> String
</> String
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}
    GBuildFLib ForeignLib
flib -> do
      let rtsInfo :: RtsInfo
rtsInfo = LocalBuildInfo -> RtsInfo
extractRtsInfo LocalBuildInfo
lbi
          rtsOptLinkLibs :: [String]
rtsOptLinkLibs =
            [ if Bool
needDynamic
                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 :: GhcOptions
linkOpts = case ForeignLib -> ForeignLibType
foreignLibType ForeignLib
flib of
            ForeignLibType
ForeignLibNativeShared ->
              GhcOptions
commonOpts
                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
dynLinkerOpts
                GhcOptions -> GhcOptions -> GhcOptions
forall a. Monoid a => a -> a -> a
`mappend` GhcOptions
forall a. Monoid a => a
mempty
                  { ghcOptLinkNoHsMain = toFlag True
                  , ghcOptShared = toFlag True
                  , ghcOptLinkLibs = rtsOptLinkLibs
                  , ghcOptLinkLibPath = toNubListR $ rtsLibPaths rtsInfo
                  , ghcOptFPic = toFlag True
                  , ghcOptLinkModDefFiles = toNubListR $ gbuildModDefFiles bm
                  }
                -- See Note [RPATH]
                GhcOptions -> GhcOptions -> GhcOptions
forall a. Monoid a => a -> a -> a
`mappend` LocalBuildInfo -> GhcOptions -> GhcOptions
forall a. Monoid a => LocalBuildInfo -> a -> a
ifNeedsRPathWorkaround
                  LocalBuildInfo
lbi
                  GhcOptions
forall a. Monoid a => a
mempty
                    { ghcOptLinkOptions = ["-Wl,--no-as-needed"]
                    , ghcOptLinkLibs = ["ffi"]
                    }
            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@.
      Verbosity -> String -> IO ()
info Verbosity
verbosity String
"Linking..."
      let buildName :: String
buildName = LocalBuildInfo -> ForeignLib -> String
flibBuildName LocalBuildInfo
lbi ForeignLib
flib
      GhcOptions -> IO ()
runGhcProg GhcOptions
linkOpts{ghcOptOutputFile = toFlag (targetDir </> buildName)}
      String -> String -> IO ()
renameFile (String
targetDir String -> String -> String
</> String
buildName) (String
targetDir String -> String -> String
</> String
targetName)

{-
Note [RPATH]
~~~~~~~~~~~~

Suppose that the dynamic library depends on `base`, but not (directly) on
`integer-gmp` (which, however, is a dependency of `base`). We will link the
library as

    gcc ... -lHSbase-4.7.0.2-ghc7.8.4 -lHSinteger-gmp-0.5.1.0-ghc7.8.4 ...

However, on systems (like Ubuntu) where the linker gets called with `-as-needed`
by default, the linker will notice that `integer-gmp` isn't actually a direct
dependency and hence omit the link.

Then when we attempt to link a C program against this dynamic library, the
_static_ linker will attempt to verify that all symbols can be resolved.  The
dynamic library itself does not require any symbols from `integer-gmp`, but
`base` does. In order to verify that the symbols used by `base` can be
resolved, the static linker needs to be able to _find_ integer-gmp.

Finding the `base` dependency is simple, because the dynamic elf header
(`readelf -d`) for the library that we have created looks something like

    (NEEDED) Shared library: [libHSbase-4.7.0.2-ghc7.8.4.so]
    (RPATH)  Library rpath: [/path/to/base-4.7.0.2:...]

However, when it comes to resolving the dependency on `integer-gmp`, it needs
to look at the dynamic header for `base`. On modern ghc (7.8 and higher) this
looks something like

    (NEEDED) Shared library: [libHSinteger-gmp-0.5.1.0-ghc7.8.4.so]
    (RPATH)  Library rpath: [$ORIGIN/../integer-gmp-0.5.1.0:...]

This specifies the location of `integer-gmp` _in terms of_ the location of base
(using the `$ORIGIN`) variable. But here's the crux: when the static linker
attempts to verify that all symbols can be resolved, [**IT DOES NOT RESOLVE
`$ORIGIN`**](http://stackoverflow.com/questions/6323603/ld-using-rpath-origin-inside-a-shared-library-recursive).
As a consequence, it will not be able to resolve the symbols and report the
missing symbols as errors, _even though the dynamic linker **would** be able to
resolve these symbols_. We can tell the static linker not to report these
errors by using `--unresolved-symbols=ignore-all` and all will be fine when we
run the program ([(indeed, this is what the gold linker
does)](https://sourceware.org/ml/binutils/2013-05/msg00038.html), but it makes
the resulting library more difficult to use.

Instead what we can do is make sure that the generated dynamic library has
explicit top-level dependencies on these libraries. This means that the static
linker knows where to find them, and when we have transitive dependencies on
the same libraries the linker will only load them once, so we avoid needing to
look at the `RPATH` of our dependencies. We can do this by passing
`--no-as-needed` to the linker, so that it doesn't omit any libraries.

Note that on older ghc (7.6 and before) the Haskell libraries don't have an
RPATH set at all, which makes it even more important that we make these
top-level dependencies.

Finally, we have to explicitly link against `libffi` for the same reason. For
newer ghc this _happens_ to be unnecessary on many systems because `libffi` is
a library which is not specific to GHC, and when the static linker verifies
that all symbols can be resolved it will find the `libffi` that is globally
installed (completely independent from ghc). Of course, this may well be the
_wrong_ version of `libffi`, but it's quite possible that symbol resolution
happens to work. This is of course the wrong approach, which is why we link
explicitly against `libffi` so that we will find the _right_ version of
`libffi`.
-}

-- | Do we need the RPATH workaround?
--
-- See Note [RPATH].
ifNeedsRPathWorkaround :: Monoid a => LocalBuildInfo -> a -> a
ifNeedsRPathWorkaround :: forall a. Monoid a => LocalBuildInfo -> a -> a
ifNeedsRPathWorkaround LocalBuildInfo
lbi a
a =
  case LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi of
    Platform Arch
_ OS
Linux -> a
a
    Platform
_otherwise -> a
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 InstalledPackageIndex
-> PackageName -> [(Version, [InstalledPackageInfo])]
forall a. PackageIndex a -> PackageName -> [(Version, [a])]
PackageIndex.lookupPackageName (LocalBuildInfo -> InstalledPackageIndex
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))))

-- | Returns True if the modification date of the given source file is newer than
-- the object file we last compiled for it, or if no object file exists yet.
checkNeedsRecompilation :: FilePath -> GhcOptions -> IO Bool
checkNeedsRecompilation :: String -> GhcOptions -> IO Bool
checkNeedsRecompilation String
filename GhcOptions
opts = String
filename String -> String -> IO Bool
`moreRecentFile` String
oname
  where
    oname :: String
oname = String -> GhcOptions -> String
getObjectFileName String
filename GhcOptions
opts

-- | Finds the object file name of the given source file
getObjectFileName :: FilePath -> GhcOptions -> FilePath
getObjectFileName :: String -> GhcOptions -> String
getObjectFileName String
filename GhcOptions
opts = String
oname
  where
    odir :: String
odir = Flag String -> String
forall a. WithCallStack (Flag a -> a)
fromFlag (GhcOptions -> Flag String
ghcOptObjDir GhcOptions
opts)
    oext :: String
oext = String -> Flag String -> String
forall a. a -> Flag a -> a
fromFlagOrDefault String
"o" (GhcOptions -> Flag String
ghcOptObjSuffix GhcOptions
opts)
    oname :: String
oname = String
odir String -> String -> String
</> String -> String -> String
replaceExtension String
filename String
oext

-- | Calculate the RPATHs for the component we are building.
--
-- Calculates relative RPATHs when 'relocatable' is set.
getRPaths
  :: LocalBuildInfo
  -> ComponentLocalBuildInfo
  -- ^ Component we are building
  -> IO (NubListR FilePath)
getRPaths :: LocalBuildInfo -> ComponentLocalBuildInfo -> IO (NubListR String)
getRPaths LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi | OS -> Bool
supportRPaths OS
hostOS = do
  [String]
libraryPaths <- 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 -> IO (NubListR String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return NubListR String
rpaths
  where
    (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
False
    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.

getRPaths LocalBuildInfo
_ ComponentLocalBuildInfo
_ = 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

-- | Remove the "-threaded" flag when building a foreign library, as it has no
--   effect when used with "-shared". Returns the updated 'BuildInfo', along
--   with whether or not the flag was present, so we can use it to link against
--   the appropriate RTS on our own.
popThreadedFlag :: BuildInfo -> (BuildInfo, Bool)
popThreadedFlag :: BuildInfo -> (BuildInfo, Bool)
popThreadedFlag BuildInfo
bi =
  ( BuildInfo
bi{options = filterHcOptions (/= "-threaded") (options bi)}
  , PerCompilerFlavor [String] -> Bool
hasThreaded (BuildInfo -> PerCompilerFlavor [String]
options BuildInfo
bi)
  )
  where
    filterHcOptions
      :: (String -> Bool)
      -> PerCompilerFlavor [String]
      -> PerCompilerFlavor [String]
    filterHcOptions :: (String -> Bool)
-> PerCompilerFlavor [String] -> PerCompilerFlavor [String]
filterHcOptions String -> Bool
p (PerCompilerFlavor [String]
ghc [String]
ghcjs) =
      [String] -> [String] -> PerCompilerFlavor [String]
forall v. v -> v -> PerCompilerFlavor v
PerCompilerFlavor ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
p [String]
ghc) [String]
ghcjs

    hasThreaded :: PerCompilerFlavor [String] -> Bool
    hasThreaded :: PerCompilerFlavor [String] -> Bool
hasThreaded (PerCompilerFlavor [String]
ghc [String]
_) = 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

-- | Extracts a String representing a hash of the ABI of a built
-- library.  It can fail if the library has not yet been built.
libAbiHash
  :: Verbosity
  -> PackageDescription
  -> LocalBuildInfo
  -> Library
  -> ComponentLocalBuildInfo
  -> IO String
libAbiHash :: Verbosity
-> PackageDescription
-> LocalBuildInfo
-> Library
-> ComponentLocalBuildInfo
-> IO String
libAbiHash Verbosity
verbosity PackageDescription
_pkg_descr LocalBuildInfo
lbi Library
lib ComponentLocalBuildInfo
clbi = do
  let
    libBi :: BuildInfo
libBi = Library -> BuildInfo
libBuildInfo Library
lib
    comp :: Compiler
comp = LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi
    platform :: Platform
platform = LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi
    vanillaArgs0 :: GhcOptions
vanillaArgs0 =
      (Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> String
-> GhcOptions
componentGhcOptions Verbosity
verbosity LocalBuildInfo
lbi BuildInfo
libBi ComponentLocalBuildInfo
clbi (LocalBuildInfo -> ComponentLocalBuildInfo -> String
componentBuildDir LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi))
        GhcOptions -> GhcOptions -> GhcOptions
forall a. Monoid a => a -> a -> a
`mappend` GhcOptions
forall a. Monoid a => a
mempty
          { ghcOptMode = toFlag GhcModeAbiHash
          , ghcOptInputModules = toNubListR $ exposedModules lib
          }
    vanillaArgs :: GhcOptions
vanillaArgs =
      -- Package DBs unnecessary, and break ghc-cabal. See #3633
      -- BUT, put at least the global database so that 7.4 doesn't
      -- break.
      GhcOptions
vanillaArgs0
        { ghcOptPackageDBs = [GlobalPackageDB]
        , ghcOptPackages = mempty
        }
    sharedArgs :: GhcOptions
sharedArgs =
      GhcOptions
vanillaArgs
        GhcOptions -> GhcOptions -> GhcOptions
forall a. Monoid a => a -> a -> a
`mappend` GhcOptions
forall a. Monoid a => a
mempty
          { ghcOptDynLinkMode = toFlag GhcDynamicOnly
          , ghcOptFPic = toFlag True
          , ghcOptHiSuffix = toFlag "js_dyn_hi"
          , ghcOptObjSuffix = toFlag "js_dyn_o"
          , ghcOptExtra = hcSharedOptions GHC libBi
          }
    profArgs :: GhcOptions
profArgs =
      GhcOptions
vanillaArgs
        GhcOptions -> GhcOptions -> GhcOptions
forall a. Monoid a => a -> a -> a
`mappend` GhcOptions
forall a. Monoid a => a
mempty
          { ghcOptProfilingMode = toFlag True
          , ghcOptProfilingAuto =
              Internal.profDetailLevelFlag
                True
                (withProfLibDetail lbi)
          , ghcOptHiSuffix = toFlag "js_p_hi"
          , ghcOptObjSuffix = toFlag "js_p_o"
          , ghcOptExtra = hcProfOptions GHC libBi
          }
    ghcArgs :: GhcOptions
ghcArgs
      | LocalBuildInfo -> Bool
withVanillaLib LocalBuildInfo
lbi = GhcOptions
vanillaArgs
      | LocalBuildInfo -> Bool
withSharedLib LocalBuildInfo
lbi = GhcOptions
sharedArgs
      | LocalBuildInfo -> Bool
withProfLib LocalBuildInfo
lbi = GhcOptions
profArgs
      | Bool
otherwise = String -> GhcOptions
forall a. HasCallStack => String -> a
error String
"libAbiHash: Can't find an enabled library way"

  (ConfiguredProgram
ghcjsProg, ProgramDb
_) <- Verbosity
-> Program -> ProgramDb -> IO (ConfiguredProgram, ProgramDb)
requireProgram Verbosity
verbosity Program
ghcjsProgram (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)
  String
hash <-
    Verbosity -> ProgramInvocation -> IO String
getProgramInvocationOutput
      Verbosity
verbosity
      (ConfiguredProgram
-> Compiler -> Platform -> GhcOptions -> ProgramInvocation
ghcInvocation ConfiguredProgram
ghcjsProg Compiler
comp Platform
platform GhcOptions
ghcArgs)
  String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace) String
hash)

componentGhcOptions
  :: Verbosity
  -> LocalBuildInfo
  -> BuildInfo
  -> ComponentLocalBuildInfo
  -> FilePath
  -> GhcOptions
componentGhcOptions :: Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> String
-> GhcOptions
componentGhcOptions Verbosity
verbosity LocalBuildInfo
lbi BuildInfo
bi ComponentLocalBuildInfo
clbi String
odir =
  let opts :: GhcOptions
opts = Verbosity
-> GhcImplInfo
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> String
-> GhcOptions
Internal.componentGhcOptions Verbosity
verbosity GhcImplInfo
implInfo LocalBuildInfo
lbi BuildInfo
bi ComponentLocalBuildInfo
clbi String
odir
      comp :: Compiler
comp = LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi
      implInfo :: GhcImplInfo
implInfo = Compiler -> GhcImplInfo
getImplInfo Compiler
comp
   in GhcOptions
opts
        { ghcOptExtra = ghcOptExtra opts `mappend` hcOptions GHCJS bi
        }

componentCcGhcOptions
  :: Verbosity
  -> LocalBuildInfo
  -> BuildInfo
  -> ComponentLocalBuildInfo
  -> FilePath
  -> FilePath
  -> GhcOptions
componentCcGhcOptions :: Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> String
-> String
-> GhcOptions
componentCcGhcOptions Verbosity
verbosity LocalBuildInfo
lbi =
  Verbosity
-> GhcImplInfo
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> String
-> String
-> GhcOptions
Internal.componentCcGhcOptions Verbosity
verbosity GhcImplInfo
implInfo LocalBuildInfo
lbi
  where
    comp :: Compiler
comp = LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi
    implInfo :: GhcImplInfo
implInfo = Compiler -> GhcImplInfo
getImplInfo Compiler
comp

-- -----------------------------------------------------------------------------
-- Installing

-- | Install executables for GHCJS.
installExe
  :: Verbosity
  -> LocalBuildInfo
  -> FilePath
  -- ^ Where to copy the files to
  -> FilePath
  -- ^ Build location
  -> (FilePath, FilePath)
  -- ^ Executable (prefix,suffix)
  -> PackageDescription
  -> Executable
  -> IO ()
installExe :: Verbosity
-> LocalBuildInfo
-> String
-> String
-> (String, String)
-> PackageDescription
-> Executable
-> IO ()
installExe
  Verbosity
verbosity
  LocalBuildInfo
lbi
  String
binDir
  String
buildPref
  (String
progprefix, String
progsuffix)
  PackageDescription
_pkg
  Executable
exe = do
    Verbosity -> Bool -> String -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True String
binDir
    let exeName' :: String
exeName' = UnqualComponentName -> String
unUnqualComponentName (UnqualComponentName -> String) -> UnqualComponentName -> String
forall a b. (a -> b) -> a -> b
$ Executable -> UnqualComponentName
exeName Executable
exe
        exeFileName :: String
exeFileName = String
exeName'
        fixedExeBaseName :: String
fixedExeBaseName = String
progprefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
exeName' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
progsuffix
        installBinary :: String -> IO ()
installBinary String
dest = do
          Verbosity -> Program -> ProgramDb -> [String] -> IO ()
runDbProgram Verbosity
verbosity Program
ghcjsProgram (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi) ([String] -> IO ()) -> [String] -> IO ()
forall a b. (a -> b) -> a -> b
$
            [ String
"--install-executable"
            , String
buildPref String -> String -> String
</> String
exeName' String -> String -> String
</> String
exeFileName
            , String
"-o"
            , String
dest
            ]
              [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ case (LocalBuildInfo -> Bool
stripExes LocalBuildInfo
lbi, Program -> ProgramDb -> Maybe ConfiguredProgram
lookupProgram Program
stripProgram (ProgramDb -> Maybe ConfiguredProgram)
-> ProgramDb -> Maybe ConfiguredProgram
forall a b. (a -> b) -> a -> b
$ LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi) of
                (Bool
True, Just ConfiguredProgram
strip) -> [String
"-strip-program", ConfiguredProgram -> String
programPath ConfiguredProgram
strip]
                (Bool, Maybe ConfiguredProgram)
_ -> []
    String -> IO ()
installBinary (String
binDir String -> String -> String
</> String
fixedExeBaseName)

-- | Install foreign library for GHC.
installFLib
  :: Verbosity
  -> LocalBuildInfo
  -> FilePath
  -- ^ install location
  -> FilePath
  -- ^ Build location
  -> PackageDescription
  -> ForeignLib
  -> IO ()
installFLib :: Verbosity
-> LocalBuildInfo
-> String
-> String
-> PackageDescription
-> ForeignLib
-> IO ()
installFLib Verbosity
verbosity LocalBuildInfo
lbi String
targetDir String
builtDir PackageDescription
_pkg ForeignLib
flib =
  Bool -> String -> String -> String -> IO ()
forall {p}. p -> String -> String -> String -> IO ()
install
    (ForeignLib -> Bool
foreignLibIsShared ForeignLib
flib)
    String
builtDir
    String
targetDir
    (LocalBuildInfo -> ForeignLib -> String
flibTargetName LocalBuildInfo
lbi ForeignLib
flib)
  where
    install :: p -> String -> String -> String -> IO ()
install p
_isShared String
srcDir String
dstDir String
name = do
      let src :: String
src = String
srcDir String -> String -> String
</> String
name
          dst :: String
dst = String
dstDir String -> String -> String
</> String
name
      Verbosity -> Bool -> String -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True String
targetDir
      Verbosity -> String -> String -> IO ()
installOrdinaryFile Verbosity
verbosity String
src String
dst

-- | Install for ghc, .hi, .a and, if --with-ghci given, .o
installLib
  :: Verbosity
  -> LocalBuildInfo
  -> FilePath
  -- ^ install location
  -> FilePath
  -- ^ install location for dynamic libraries
  -> FilePath
  -- ^ Build location
  -> PackageDescription
  -> Library
  -> ComponentLocalBuildInfo
  -> IO ()
installLib :: Verbosity
-> LocalBuildInfo
-> String
-> String
-> String
-> PackageDescription
-> Library
-> ComponentLocalBuildInfo
-> IO ()
installLib Verbosity
verbosity LocalBuildInfo
lbi String
targetDir String
dynlibTargetDir String
_builtDir PackageDescription
_pkg Library
lib ComponentLocalBuildInfo
clbi = do
  IO () -> IO ()
whenVanilla (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
copyModuleFiles String
"js_hi"
  IO () -> IO ()
whenProf (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
copyModuleFiles String
"js_p_hi"
  IO () -> IO ()
whenShared (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
copyModuleFiles String
"js_dyn_hi"

  -- whenVanilla $ installOrdinary builtDir targetDir $ toJSLibName vanillaLibName
  -- whenProf    $ installOrdinary builtDir targetDir $ toJSLibName profileLibName
  -- whenShared  $ installShared   builtDir dynlibTargetDir $ toJSLibName sharedLibName
  -- fixme do these make the correct lib names?
  IO () -> IO ()
whenHasCode (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    IO () -> IO ()
whenVanilla (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
        [ String -> String -> String -> IO ()
installOrdinary String
builtDir' String
targetDir (String -> String
toJSLibName (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
mkGenericStaticLibName (String
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f))
        | String
l <- UnitId -> String
getHSLibraryName (ComponentLocalBuildInfo -> UnitId
componentUnitId ComponentLocalBuildInfo
clbi) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (BuildInfo -> [String]
extraBundledLibs (Library -> BuildInfo
libBuildInfo Library
lib))
        , String
f <- String
"" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: BuildInfo -> [String]
extraLibFlavours (Library -> BuildInfo
libBuildInfo Library
lib)
        ]
    -- whenGHCi $ installOrdinary builtDir targetDir (toJSLibName ghciLibName)
    IO () -> IO ()
whenProf (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      String -> String -> String -> IO ()
installOrdinary String
builtDir' String
targetDir (String -> String
toJSLibName String
profileLibName)
    -- whenGHCi $ installOrdinary builtDir targetDir (toJSLibName ghciProfLibName)
    IO () -> IO ()
whenShared (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      [IO ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
        [ String -> String -> String -> IO ()
installShared
          String
builtDir'
          String
dynlibTargetDir
          (String -> String
toJSLibName (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Platform -> CompilerId -> String -> String
mkGenericSharedLibName Platform
platform CompilerId
compiler_id (String
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
f))
        | String
l <- UnitId -> String
getHSLibraryName UnitId
uid String -> [String] -> [String]
forall a. a -> [a] -> [a]
: BuildInfo -> [String]
extraBundledLibs (Library -> BuildInfo
libBuildInfo Library
lib)
        , String
f <- String
"" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: BuildInfo -> [String]
extraDynLibFlavours (Library -> BuildInfo
libBuildInfo Library
lib)
        ]
  where
    builtDir' :: String
builtDir' = LocalBuildInfo -> ComponentLocalBuildInfo -> String
componentBuildDir LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi

    install :: Bool -> Bool -> String -> String -> String -> IO ()
install Bool
isShared Bool
isJS String
srcDir String
dstDir String
name = do
      let src :: String
src = String
srcDir String -> String -> String
</> String
name
          dst :: String
dst = String
dstDir String -> String -> String
</> String
name
      Verbosity -> Bool -> String -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True String
dstDir

      if Bool
isShared
        then Verbosity -> String -> String -> IO ()
installExecutableFile Verbosity
verbosity String
src String
dst
        else Verbosity -> String -> String -> IO ()
installOrdinaryFile Verbosity
verbosity String
src String
dst

      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (LocalBuildInfo -> Bool
stripLibs LocalBuildInfo
lbi Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isJS) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Verbosity -> Platform -> ProgramDb -> String -> IO ()
Strip.stripLib
          Verbosity
verbosity
          (LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi)
          (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)
          String
dst

    installOrdinary :: String -> String -> String -> IO ()
installOrdinary = Bool -> Bool -> String -> String -> String -> IO ()
install Bool
False Bool
True
    installShared :: String -> String -> String -> IO ()
installShared = Bool -> Bool -> String -> String -> String -> IO ()
install Bool
True Bool
True

    copyModuleFiles :: String -> IO ()
copyModuleFiles String
ext =
      Verbosity
-> [String] -> [String] -> [ModuleName] -> IO [(String, String)]
findModuleFilesEx Verbosity
verbosity [String
builtDir'] [String
ext] (Library -> ComponentLocalBuildInfo -> [ModuleName]
allLibModules Library
lib ComponentLocalBuildInfo
clbi)
        IO [(String, String)] -> ([(String, String)] -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Verbosity -> String -> [(String, String)] -> IO ()
installOrdinaryFiles Verbosity
verbosity String
targetDir

    compiler_id :: CompilerId
compiler_id = Compiler -> CompilerId
compilerId (LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi)
    platform :: Platform
platform = LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi
    uid :: UnitId
uid = ComponentLocalBuildInfo -> UnitId
componentUnitId ComponentLocalBuildInfo
clbi
    -- vanillaLibName = mkLibName              uid
    profileLibName :: String
profileLibName = UnitId -> String
mkProfLibName UnitId
uid
    -- sharedLibName  = (mkSharedLibName (hostPlatform lbi) compiler_id)  uid

    hasLib :: Bool
hasLib =
      Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$
        [ModuleName] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Library -> ComponentLocalBuildInfo -> [ModuleName]
allLibModules Library
lib ComponentLocalBuildInfo
clbi)
          Bool -> Bool -> Bool
&& [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (BuildInfo -> [String]
cSources (Library -> BuildInfo
libBuildInfo Library
lib))
          Bool -> Bool -> Bool
&& [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (BuildInfo -> [String]
cxxSources (Library -> BuildInfo
libBuildInfo Library
lib))
          Bool -> Bool -> Bool
&& [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (BuildInfo -> [String]
jsSources (Library -> BuildInfo
libBuildInfo Library
lib))
    has_code :: Bool
has_code = Bool -> Bool
not (ComponentLocalBuildInfo -> Bool
componentIsIndefinite ComponentLocalBuildInfo
clbi)
    whenHasCode :: IO () -> IO ()
whenHasCode = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
has_code
    whenVanilla :: IO () -> IO ()
whenVanilla = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
hasLib Bool -> Bool -> Bool
&& LocalBuildInfo -> Bool
withVanillaLib LocalBuildInfo
lbi)
    whenProf :: IO () -> IO ()
whenProf = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
hasLib Bool -> Bool -> Bool
&& LocalBuildInfo -> Bool
withProfLib LocalBuildInfo
lbi Bool -> Bool -> Bool
&& Bool
has_code)
    -- whenGHCi    = when (hasLib && withGHCiLib    lbi && has_code)
    whenShared :: IO () -> IO ()
whenShared = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
hasLib Bool -> Bool -> Bool
&& LocalBuildInfo -> Bool
withSharedLib LocalBuildInfo
lbi Bool -> Bool -> Bool
&& Bool
has_code)

adjustExts :: String -> String -> GhcOptions -> GhcOptions
adjustExts :: String -> String -> GhcOptions -> GhcOptions
adjustExts String
hiSuf String
objSuf GhcOptions
opts =
  GhcOptions
opts
    GhcOptions -> GhcOptions -> GhcOptions
forall a. Monoid a => a -> a -> a
`mappend` GhcOptions
forall a. Monoid a => a
mempty
      { ghcOptHiSuffix = toFlag hiSuf
      , ghcOptObjSuffix = toFlag objSuf
      }

isDynamic :: Compiler -> Bool
isDynamic :: Compiler -> Bool
isDynamic = String -> Compiler -> Bool
Internal.ghcLookupProperty String
"GHC Dynamic"

supportsDynamicToo :: Compiler -> Bool
supportsDynamicToo :: Compiler -> Bool
supportsDynamicToo = String -> Compiler -> Bool
Internal.ghcLookupProperty String
"Support dynamic-too"

withExt :: FilePath -> String -> FilePath
withExt :: String -> String -> String
withExt String
fp String
ext = String
fp String -> String -> String
<.> if String -> String
takeExtension String
fp String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= (Char
'.' Char -> String -> String
forall a. a -> [a] -> [a]
: String
ext) then String
ext else String
""

findGhcjsGhcVersion :: Verbosity -> FilePath -> IO (Maybe Version)
findGhcjsGhcVersion :: Verbosity -> String -> IO (Maybe Version)
findGhcjsGhcVersion Verbosity
verbosity String
pgm =
  String
-> (String -> String) -> Verbosity -> String -> IO (Maybe Version)
findProgramVersion String
"--numeric-ghc-version" String -> String
forall a. a -> a
id Verbosity
verbosity String
pgm

findGhcjsPkgGhcjsVersion :: Verbosity -> FilePath -> IO (Maybe Version)
findGhcjsPkgGhcjsVersion :: Verbosity -> String -> IO (Maybe Version)
findGhcjsPkgGhcjsVersion Verbosity
verbosity String
pgm =
  String
-> (String -> String) -> Verbosity -> String -> IO (Maybe Version)
findProgramVersion String
"--numeric-ghcjs-version" String -> String
forall a. a -> a
id Verbosity
verbosity String
pgm

-- -----------------------------------------------------------------------------
-- Registering

hcPkgInfo :: ProgramDb -> HcPkg.HcPkgInfo
hcPkgInfo :: ProgramDb -> HcPkgInfo
hcPkgInfo ProgramDb
progdb =
  HcPkg.HcPkgInfo
    { hcPkgProgram :: ConfiguredProgram
HcPkg.hcPkgProgram = ConfiguredProgram
ghcjsPkgProg
    , noPkgDbStack :: Bool
HcPkg.noPkgDbStack = Bool
False
    , noVerboseFlag :: Bool
HcPkg.noVerboseFlag = Bool
False
    , flagPackageConf :: Bool
HcPkg.flagPackageConf = Bool
False
    , supportsDirDbs :: Bool
HcPkg.supportsDirDbs = Bool
True
    , requiresDirDbs :: Bool
HcPkg.requiresDirDbs = Version
ver Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= Version
v7_10
    , nativeMultiInstance :: Bool
HcPkg.nativeMultiInstance = Version
ver Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= Version
v7_10
    , recacheMultiInstance :: Bool
HcPkg.recacheMultiInstance = Bool
True
    , suppressFilesCheck :: Bool
HcPkg.suppressFilesCheck = Bool
True
    }
  where
    v7_10 :: Version
v7_10 = [Int] -> Version
mkVersion [Int
7, Int
10]
    ghcjsPkgProg :: ConfiguredProgram
ghcjsPkgProg = ConfiguredProgram -> Maybe ConfiguredProgram -> ConfiguredProgram
forall a. a -> Maybe a -> a
fromMaybe (String -> ConfiguredProgram
forall a. HasCallStack => String -> a
error String
"GHCJS.hcPkgInfo no ghcjs program") (Maybe ConfiguredProgram -> ConfiguredProgram)
-> Maybe ConfiguredProgram -> ConfiguredProgram
forall a b. (a -> b) -> a -> b
$ Program -> ProgramDb -> Maybe ConfiguredProgram
lookupProgram Program
ghcjsPkgProgram ProgramDb
progdb
    ver :: Version
ver = Version -> Maybe Version -> Version
forall a. a -> Maybe a -> a
fromMaybe (String -> Version
forall a. HasCallStack => String -> a
error String
"GHCJS.hcPkgInfo no ghcjs version") (Maybe Version -> Version) -> Maybe Version -> Version
forall a b. (a -> b) -> a -> b
$ ConfiguredProgram -> Maybe Version
programVersion ConfiguredProgram
ghcjsPkgProg

registerPackage
  :: Verbosity
  -> ProgramDb
  -> PackageDBStack
  -> InstalledPackageInfo
  -> HcPkg.RegisterOptions
  -> IO ()
registerPackage :: Verbosity
-> ProgramDb
-> [PackageDB]
-> InstalledPackageInfo
-> RegisterOptions
-> IO ()
registerPackage Verbosity
verbosity ProgramDb
progdb [PackageDB]
packageDbs InstalledPackageInfo
installedPkgInfo RegisterOptions
registerOptions =
  HcPkgInfo
-> Verbosity
-> [PackageDB]
-> InstalledPackageInfo
-> RegisterOptions
-> IO ()
HcPkg.register
    (ProgramDb -> HcPkgInfo
hcPkgInfo ProgramDb
progdb)
    Verbosity
verbosity
    [PackageDB]
packageDbs
    InstalledPackageInfo
installedPkgInfo
    RegisterOptions
registerOptions

pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO FilePath
pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO String
pkgRoot Verbosity
verbosity LocalBuildInfo
lbi = PackageDB -> IO String
pkgRoot'
  where
    pkgRoot' :: PackageDB -> IO String
pkgRoot' PackageDB
GlobalPackageDB =
      let ghcjsProg :: ConfiguredProgram
ghcjsProg = ConfiguredProgram -> Maybe ConfiguredProgram -> ConfiguredProgram
forall a. a -> Maybe a -> a
fromMaybe (String -> ConfiguredProgram
forall a. HasCallStack => String -> a
error String
"GHCJS.pkgRoot: no ghcjs program") (Maybe ConfiguredProgram -> ConfiguredProgram)
-> Maybe ConfiguredProgram -> ConfiguredProgram
forall a b. (a -> b) -> a -> b
$ Program -> ProgramDb -> Maybe ConfiguredProgram
lookupProgram Program
ghcjsProgram (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)
       in (String -> String) -> IO String -> IO String
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> String
takeDirectory (Verbosity -> ConfiguredProgram -> IO String
getGlobalPackageDB Verbosity
verbosity ConfiguredProgram
ghcjsProg)
    pkgRoot' PackageDB
UserPackageDB = do
      String
appDir <- String -> IO String
getAppUserDataDirectory String
"ghcjs"
      -- fixme correct this version
      let ver :: Version
ver = Compiler -> Version
compilerVersion (LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi)
          subdir :: String
subdir =
            String
System.Info.arch
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
'-'
              Char -> String -> String
forall a. a -> [a] -> [a]
: String
System.Info.os
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ Char
'-'
              Char -> String -> String
forall a. a -> [a] -> [a]
: Version -> String
forall a. Pretty a => a -> String
prettyShow Version
ver
          rootDir :: String
rootDir = String
appDir String -> String -> String
</> String
subdir
      -- We must create the root directory for the user package database if it
      -- does not yet exists. Otherwise '${pkgroot}' will resolve to a
      -- directory at the time of 'ghc-pkg register', and registration will
      -- fail.
      Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
rootDir
      String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return String
rootDir
    pkgRoot' (SpecificPackageDB String
fp) = String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> String
takeDirectory String
fp)

-- | Get the JavaScript file name and command and arguments to run a
--   program compiled by GHCJS
--   the exe should be the base program name without exe extension
runCmd
  :: ProgramDb
  -> FilePath
  -> (FilePath, FilePath, [String])
runCmd :: ProgramDb -> String -> (String, String, [String])
runCmd ProgramDb
progdb String
exe =
  ( String
script
  , ConfiguredProgram -> String
programPath ConfiguredProgram
ghcjsProg
  , ConfiguredProgram -> [String]
programDefaultArgs ConfiguredProgram
ghcjsProg [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ConfiguredProgram -> [String]
programOverrideArgs ConfiguredProgram
ghcjsProg [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"--run"]
  )
  where
    script :: String
script = String
exe String -> String -> String
<.> String
"jsexe" String -> String -> String
</> String
"all" String -> String -> String
<.> String
"js"
    ghcjsProg :: ConfiguredProgram
ghcjsProg = ConfiguredProgram -> Maybe ConfiguredProgram -> ConfiguredProgram
forall a. a -> Maybe a -> a
fromMaybe (String -> ConfiguredProgram
forall a. HasCallStack => String -> a
error String
"GHCJS.runCmd: no ghcjs program") (Maybe ConfiguredProgram -> ConfiguredProgram)
-> Maybe ConfiguredProgram -> ConfiguredProgram
forall a b. (a -> b) -> a -> b
$ Program -> ProgramDb -> Maybe ConfiguredProgram
lookupProgram Program
ghcjsProgram ProgramDb
progdb