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

module Distribution.Simple.GHCJS
  ( getGhcInfo
  , configure
  , configureCompiler
  , compilerProgramDb
  , getInstalledPackages
  , getInstalledPackagesMonitorFiles
  , getPackageDBContents
  , buildLib
  , buildFLib
  , buildExe
  , replLib
  , replFLib
  , replExe
  , startInterpreter
  , installLib
  , installFLib
  , installExe
  , libAbiHash
  , hcPkgInfo
  , registerPackage
  , componentGhcOptions
  , Internal.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.Errors
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.PreProcess.Types
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.Common
import Distribution.Simple.Utils
import Distribution.System
import Distribution.Types.ComponentLocalBuildInfo
import Distribution.Types.PackageName.Magic
import Distribution.Types.ParStrat
import Distribution.Utils.NubList
import Distribution.Utils.Path
import Distribution.Verbosity (Verbosity)
import Distribution.Version

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

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

-- | Configure GHCJS, and then auxiliary programs such as @ghc-pkg@, @haddock@
-- as well as toolchain programs such as @ar@, @ld.
configure
  :: Verbosity
  -> Maybe FilePath
  -- ^ user-specified @ghcjs@ path (optional)
  -> Maybe FilePath
  -- ^ user-specified @ghcjs-pkg@ path (optional)
  -> ProgramDb
  -> IO (Compiler, Maybe Platform, ProgramDb)
configure :: Verbosity
-> Maybe [Char]
-> Maybe [Char]
-> ProgramDb
-> IO (Compiler, Maybe Platform, ProgramDb)
configure Verbosity
verbosity Maybe [Char]
hcPath Maybe [Char]
hcPkgPath ProgramDb
conf0 = do
  (comp, compPlatform, progdb1) <- Verbosity
-> Maybe [Char]
-> ProgramDb
-> IO (Compiler, Maybe Platform, ProgramDb)
configureCompiler Verbosity
verbosity Maybe [Char]
hcPath ProgramDb
conf0
  compProgDb <- compilerProgramDb verbosity comp progdb1 hcPkgPath
  return (comp, compPlatform, compProgDb)

-- | Configure GHCJS.
configureCompiler
  :: Verbosity
  -> Maybe FilePath
  -- ^ user-specified @ghc@ path (optional)
  -> ProgramDb
  -> IO (Compiler, Maybe Platform, ProgramDb)
configureCompiler :: Verbosity
-> Maybe [Char]
-> ProgramDb
-> IO (Compiler, Maybe Platform, ProgramDb)
configureCompiler Verbosity
verbosity Maybe [Char]
hcPath ProgramDb
conf0 = do
  (ghcjsProg, ghcjsVersion, progdb1) <-
    Verbosity
-> Program
-> VersionRange
-> ProgramDb
-> IO (ConfiguredProgram, Version, ProgramDb)
requireProgramVersion
      Verbosity
verbosity
      Program
ghcjsProgram
      (Version -> VersionRange
orLaterVersion ([Int] -> Version
mkVersion [Int
0, Int
1]))
      ([Char] -> Maybe [Char] -> ProgramDb -> ProgramDb
userMaybeSpecifyPath [Char]
"ghcjs" Maybe [Char]
hcPath ProgramDb
conf0)

  Just ghcjsGhcVersion <- findGhcjsGhcVersion verbosity (programPath ghcjsProg)
  unless (ghcjsGhcVersion < mkVersion [8, 8]) $
    warn verbosity $
      "Unknown/unsupported 'ghc' version detected "
        ++ "(Cabal "
        ++ prettyShow cabalVersion
        ++ " supports 'ghc' version < 8.8): "
        ++ programPath ghcjsProg
        ++ " is based on GHC version "
        ++ prettyShow ghcjsGhcVersion

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

  languages <- Internal.getLanguages verbosity implInfo ghcjsProg
  extensions <- Internal.getExtensions verbosity implInfo ghcjsProg

  ghcjsInfo <- Internal.getGhcInfo verbosity implInfo ghcjsProg
  let ghcInfoMap = [([Char], [Char])] -> Map [Char] [Char]
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [([Char], [Char])]
ghcjsInfo

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

-- | Given a configured @ghcjs@ program, configure auxiliary programs such
-- as @ghcjs-pkg@ or @haddock@, based on the location of the @ghcjs@ executable.
compilerProgramDb
  :: Verbosity
  -> Compiler
  -> ProgramDb
  -> Maybe FilePath
  -- ^ user-specified @ghc-pkg@ path (optional)
  -> IO ProgramDb
compilerProgramDb :: Verbosity -> Compiler -> ProgramDb -> Maybe [Char] -> IO ProgramDb
compilerProgramDb Verbosity
verbosity Compiler
comp ProgramDb
progdb1 Maybe [Char]
hcPkgPath = do
  let
    ghcjsProg :: ConfiguredProgram
ghcjsProg = Maybe ConfiguredProgram -> ConfiguredProgram
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe ConfiguredProgram -> ConfiguredProgram)
-> Maybe ConfiguredProgram -> ConfiguredProgram
forall a b. (a -> b) -> a -> b
$ Program -> ProgramDb -> Maybe ConfiguredProgram
lookupProgram Program
ghcjsProgram ProgramDb
progdb1
    ghcjsVersion :: Version
ghcjsVersion = Compiler -> Version
compilerVersion Compiler
comp
    ghcjsGhcVersion :: Version
ghcjsGhcVersion = case Compiler -> [CompilerId]
compilerCompat Compiler
comp of
      [CompilerId CompilerFlavor
GHC Version
ghcjsGhcVer] -> Version
ghcjsGhcVer
      [CompilerId]
compat -> [Char] -> Version
forall a. HasCallStack => [Char] -> a
error ([Char] -> Version) -> [Char] -> Version
forall a b. (a -> b) -> a -> b
$ [Char]
"could not parse ghcjsGhcVersion:" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [CompilerId] -> [Char]
forall a. Show a => a -> [Char]
show [CompilerId]
compat

  -- 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:
  (ghcjsPkgProg, ghcjsPkgVersion, progdb2) <-
    Verbosity
-> Program
-> VersionRange
-> ProgramDb
-> IO (ConfiguredProgram, Version, ProgramDb)
requireProgramVersion
      Verbosity
verbosity
      Program
ghcjsPkgProgram
        { programFindLocation = guessGhcjsPkgFromGhcjsPath ghcjsProg
        }
      VersionRange
anyVersion
      ([Char] -> Maybe [Char] -> ProgramDb -> ProgramDb
userMaybeSpecifyPath [Char]
"ghcjs-pkg" Maybe [Char]
hcPkgPath ProgramDb
progdb1)

  Just ghcjsPkgGhcjsVersion <-
    findGhcjsPkgGhcjsVersion
      verbosity
      (programPath ghcjsPkgProg)

  when (ghcjsVersion /= ghcjsPkgGhcjsVersion) $
    dieWithException verbosity $
      VersionMismatchJS
        (programPath ghcjsProg)
        ghcjsVersion
        (programPath ghcjsPkgProg)
        ghcjsPkgGhcjsVersion

  when (ghcjsGhcVersion /= ghcjsPkgVersion) $
    dieWithException verbosity $
      VersionMismatchGHCJS (programPath ghcjsProg) ghcjsGhcVersion (programPath ghcjsPkgProg) ghcjsPkgVersion

  -- Likewise we try to find the matching hsc2hs and haddock programs.
  let hsc2hsProgram' =
        Program
hsc2hsProgram
          { programFindLocation =
              guessHsc2hsFromGhcjsPath ghcjsProg
          }
      haddockProgram' =
        Program
haddockProgram
          { programFindLocation =
              guessHaddockFromGhcjsPath ghcjsProg
          }
      hpcProgram' =
        Program
hpcProgram
          { programFindLocation = guessHpcFromGhcjsPath ghcjsProg
          }
      {-
      runghcProgram' = runghcProgram {
                        programFindLocation = guessRunghcFromGhcjsPath ghcjsProg
                    } -}
      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

  return progdb3

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

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

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

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

guessToolFromGhcjsPath
  :: Program
  -> ConfiguredProgram
  -> Verbosity
  -> ProgramSearchPath
  -> IO (Maybe (FilePath, [FilePath]))
guessToolFromGhcjsPath :: Program
-> ConfiguredProgram
-> Verbosity
-> ProgramSearchPath
-> IO (Maybe ([Char], [[Char]]))
guessToolFromGhcjsPath Program
tool ConfiguredProgram
ghcjsProg Verbosity
verbosity ProgramSearchPath
searchpath =
  do
    let toolname :: [Char]
toolname = Program -> [Char]
programName Program
tool
        given_path :: [Char]
given_path = ConfiguredProgram -> [Char]
programPath ConfiguredProgram
ghcjsProg
        given_dir :: [Char]
given_dir = [Char] -> [Char]
takeDirectory [Char]
given_path
    real_path <- [Char] -> IO [Char]
canonicalizePath [Char]
given_path
    let real_dir = [Char] -> [Char]
takeDirectory [Char]
real_path
        versionSuffix [Char]
path = [Char] -> [Char]
takeVersionSuffix ([Char] -> [Char]
dropExeExtension [Char]
path)
        given_suf = [Char] -> [Char]
versionSuffix [Char]
given_path
        real_suf = [Char] -> [Char]
versionSuffix [Char]
real_path
        guessNormal p
dir = p
dir p -> [Char] -> r
forall p q r. PathLike p q r => p -> q -> r
</> [Char]
toolname [Char] -> [Char] -> [Char]
forall p. FileLike p => p -> [Char] -> p
<.> Platform -> [Char]
exeExtension Platform
buildPlatform
        guessGhcjs p
dir =
          p
dir
            p -> [Char] -> r
forall p q r. PathLike p q r => p -> q -> r
</> ([Char]
toolname [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"-ghcjs")
              [Char] -> [Char] -> [Char]
forall p. FileLike p => p -> [Char] -> p
<.> Platform -> [Char]
exeExtension Platform
buildPlatform
        guessGhcjsVersioned p
dir [Char]
suf =
          p
dir
            p -> [Char] -> r
forall p q r. PathLike p q r => p -> q -> r
</> ([Char]
toolname [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"-ghcjs" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
suf)
              [Char] -> [Char] -> [Char]
forall p. FileLike p => p -> [Char] -> p
<.> Platform -> [Char]
exeExtension Platform
buildPlatform
        guessVersioned p
dir [Char]
suf =
          p
dir
            p -> [Char] -> r
forall p q r. PathLike p q r => p -> q -> r
</> ([Char]
toolname [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
suf)
              [Char] -> [Char] -> [Char]
forall p. FileLike p => p -> [Char] -> p
<.> Platform -> [Char]
exeExtension Platform
buildPlatform
        mkGuesses p
dir [Char]
suf
          | [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
suf = [p -> a
forall {p} {r}. PathLike p [Char] r => p -> r
guessGhcjs p
dir, p -> a
forall {p} {r}. PathLike p [Char] r => p -> r
guessNormal p
dir]
          | Bool
otherwise =
              [ p -> [Char] -> a
forall {p} {r}. PathLike p [Char] r => p -> [Char] -> r
guessGhcjsVersioned p
dir [Char]
suf
              , p -> [Char] -> a
forall {p} {r}. PathLike p [Char] r => p -> [Char] -> r
guessVersioned p
dir [Char]
suf
              , p -> a
forall {p} {r}. PathLike p [Char] r => p -> r
guessGhcjs p
dir
              , p -> a
forall {p} {r}. PathLike p [Char] r => p -> r
guessNormal p
dir
              ]
        guesses =
          [Char] -> [Char] -> [[Char]]
forall {p} {a}. PathLike p [Char] a => p -> [Char] -> [a]
mkGuesses [Char]
given_dir [Char]
given_suf
            [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ if [Char]
real_path [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
given_path
              then []
              else [Char] -> [Char] -> [[Char]]
forall {p} {a}. PathLike p [Char] a => p -> [Char] -> [a]
mkGuesses [Char]
real_dir [Char]
real_suf
    info verbosity $
      "looking for tool "
        ++ toolname
        ++ " near compiler in "
        ++ given_dir
    debug verbosity $ "candidate locations: " ++ show guesses
    exists <- traverse doesFileExist guesses
    case [file | (file, True) <- zip guesses exists] of
      -- If we can't find it near ghc, fall back to the usual
      -- method.
      [] -> Program
-> Verbosity -> ProgramSearchPath -> IO (Maybe ([Char], [[Char]]))
programFindLocation Program
tool Verbosity
verbosity ProgramSearchPath
searchpath
      ([Char]
fp : [[Char]]
_) -> do
        Verbosity -> [Char] -> IO ()
info Verbosity
verbosity ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"found " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
toolname [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" in " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
fp
        let lookedAt :: [[Char]]
lookedAt =
              (([Char], Bool) -> [Char]) -> [([Char], Bool)] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], Bool) -> [Char]
forall a b. (a, b) -> a
fst
                ([([Char], Bool)] -> [[Char]])
-> ([([Char], Bool)] -> [([Char], Bool)])
-> [([Char], Bool)]
-> [[Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([Char], Bool) -> Bool) -> [([Char], Bool)] -> [([Char], Bool)]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\([Char]
_file, Bool
exist) -> Bool -> Bool
not Bool
exist)
                ([([Char], Bool)] -> [[Char]]) -> [([Char], Bool)] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Bool] -> [([Char], Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip [[Char]]
guesses [Bool]
exists
        Maybe ([Char], [[Char]]) -> IO (Maybe ([Char], [[Char]]))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (([Char], [[Char]]) -> Maybe ([Char], [[Char]])
forall a. a -> Maybe a
Just ([Char]
fp, [[Char]]
lookedAt))
  where
    takeVersionSuffix :: FilePath -> String
    takeVersionSuffix :: [Char] -> [Char]
takeVersionSuffix = (Char -> Bool) -> [Char] -> [Char]
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 [([Char], [Char])]
getGhcInfo Verbosity
verbosity ConfiguredProgram
ghcjsProg = Verbosity
-> GhcImplInfo -> ConfiguredProgram -> IO [([Char], [Char])]
Internal.getGhcInfo Verbosity
verbosity GhcImplInfo
implInfo ConfiguredProgram
ghcjsProg
  where
    version :: Version
version = Version -> Maybe Version -> Version
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Version
forall a. HasCallStack => [Char] -> a
error [Char]
"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
  -> Maybe (SymbolicPath CWD (Dir from))
  -> PackageDBX (SymbolicPath from (Dir PkgDB))
  -> ProgramDb
  -> IO InstalledPackageIndex
getPackageDBContents :: forall from.
Verbosity
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBX (SymbolicPath from ('Dir PkgDB))
-> ProgramDb
-> IO InstalledPackageIndex
getPackageDBContents Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir PackageDBX (SymbolicPath from ('Dir PkgDB))
packagedb ProgramDb
progdb = do
  pkgss <- Verbosity
-> Maybe (SymbolicPath CWD ('Dir from))
-> [PackageDBX (SymbolicPath from ('Dir PkgDB))]
-> ProgramDb
-> IO
     [(PackageDBX (SymbolicPath from ('Dir PkgDB)),
       [InstalledPackageInfo])]
forall from.
Verbosity
-> Maybe (SymbolicPath CWD ('Dir from))
-> [PackageDBX (SymbolicPath from ('Dir PkgDB))]
-> ProgramDb
-> IO
     [(PackageDBX (SymbolicPath from ('Dir PkgDB)),
       [InstalledPackageInfo])]
getInstalledPackages' Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir [PackageDBX (SymbolicPath from ('Dir PkgDB))
packagedb] ProgramDb
progdb
  toPackageIndex verbosity pkgss progdb

-- | Given a package DB stack, return all installed packages.
getInstalledPackages
  :: Verbosity
  -> Maybe (SymbolicPath CWD (Dir from))
  -> PackageDBStackX (SymbolicPath from (Dir PkgDB))
  -> ProgramDb
  -> IO InstalledPackageIndex
getInstalledPackages :: forall from.
Verbosity
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBStackX (SymbolicPath from ('Dir PkgDB))
-> ProgramDb
-> IO InstalledPackageIndex
getInstalledPackages Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir PackageDBStackX (SymbolicPath from ('Dir PkgDB))
packagedbs ProgramDb
progdb = do
  Verbosity -> IO ()
checkPackageDbEnvVar Verbosity
verbosity
  Verbosity
-> PackageDBStackX (SymbolicPath from ('Dir PkgDB)) -> IO ()
forall fp. Eq fp => Verbosity -> PackageDBStackX fp -> IO ()
checkPackageDbStack Verbosity
verbosity PackageDBStackX (SymbolicPath from ('Dir PkgDB))
packagedbs
  pkgss <- Verbosity
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBStackX (SymbolicPath from ('Dir PkgDB))
-> ProgramDb
-> IO
     [(PackageDBX (SymbolicPath from ('Dir PkgDB)),
       [InstalledPackageInfo])]
forall from.
Verbosity
-> Maybe (SymbolicPath CWD ('Dir from))
-> [PackageDBX (SymbolicPath from ('Dir PkgDB))]
-> ProgramDb
-> IO
     [(PackageDBX (SymbolicPath from ('Dir PkgDB)),
       [InstalledPackageInfo])]
getInstalledPackages' Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir PackageDBStackX (SymbolicPath from ('Dir PkgDB))
packagedbs ProgramDb
progdb
  index <- toPackageIndex verbosity pkgss progdb
  return $! index

toPackageIndex
  :: Verbosity
  -> [(PackageDBX a, [InstalledPackageInfo])]
  -> ProgramDb
  -> IO InstalledPackageIndex
toPackageIndex :: forall a.
Verbosity
-> [(PackageDBX a, [InstalledPackageInfo])]
-> ProgramDb
-> IO InstalledPackageIndex
toPackageIndex Verbosity
verbosity [(PackageDBX a, [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.
  topDir <- Verbosity -> ConfiguredProgram -> IO [Char]
getLibDir' Verbosity
verbosity ConfiguredProgram
ghcjsProg
  let indices =
        [ [InstalledPackageInfo] -> InstalledPackageIndex
PackageIndex.fromList ((InstalledPackageInfo -> InstalledPackageInfo)
-> [InstalledPackageInfo] -> [InstalledPackageInfo]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> InstalledPackageInfo -> InstalledPackageInfo
Internal.substTopDir [Char]
topDir) [InstalledPackageInfo]
pkgs)
        | (PackageDBX a
_, [InstalledPackageInfo]
pkgs) <- [(PackageDBX a, [InstalledPackageInfo])]
pkgss
        ]
  return $! (mconcat indices)
  where
    ghcjsProg :: ConfiguredProgram
ghcjsProg = ConfiguredProgram -> Maybe ConfiguredProgram -> ConfiguredProgram
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> ConfiguredProgram
forall a. HasCallStack => [Char] -> a
error [Char]
"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 [Char]
getLibDir Verbosity
verbosity LocalBuildInfo
lbi =
  (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEndLE Char -> Bool
isSpace
    ([Char] -> [Char]) -> IO [Char] -> IO [Char]
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 -> [[Char]] -> IO [Char]
getDbProgramOutput
      Verbosity
verbosity
      Program
ghcjsProgram
      (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)
      [[Char]
"--print-libdir"]

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

-- | Return the 'FilePath' to the global GHC package database.
getGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO FilePath
getGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO [Char]
getGlobalPackageDB Verbosity
verbosity ConfiguredProgram
ghcProg =
  (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhileEndLE Char -> Bool
isSpace
    ([Char] -> [Char]) -> IO [Char] -> IO [Char]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Verbosity -> ConfiguredProgram -> [[Char]] -> IO [Char]
getProgramOutput Verbosity
verbosity ConfiguredProgram
ghcProg [[Char]
"--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 [Char]
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.
  appdir <- [Char] -> IO [Char]
getAppUserDataDirectory [Char]
"ghcjs"
  return (appdir </> platformAndVersion </> packageConfFileName)
  where
    platformAndVersion :: [Char]
platformAndVersion =
      Platform -> Version -> [Char]
Internal.ghcPlatformAndVersionString
        Platform
platform
        Version
ghcjsVersion
    packageConfFileName :: [Char]
packageConfFileName = [Char]
"package.conf.d"
    ghcjsVersion :: Version
ghcjsVersion = Version -> Maybe Version -> Version
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> Version
forall a. HasCallStack => [Char] -> a
error [Char]
"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 -> [Char] -> [Char] -> IO ()
Internal.checkPackageDbEnvVar Verbosity
verbosity [Char]
"GHCJS" [Char]
"GHCJS_PACKAGE_PATH"

checkPackageDbStack :: Eq fp => Verbosity -> PackageDBStackX fp -> IO ()
checkPackageDbStack :: forall fp. Eq fp => Verbosity -> PackageDBStackX fp -> IO ()
checkPackageDbStack Verbosity
_ (PackageDBX fp
GlobalPackageDB : [PackageDBX fp]
rest)
  | PackageDBX fp
forall fp. PackageDBX fp
GlobalPackageDB PackageDBX fp -> [PackageDBX fp] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [PackageDBX fp]
rest = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkPackageDbStack Verbosity
verbosity [PackageDBX fp]
rest
  | PackageDBX fp
forall fp. PackageDBX fp
GlobalPackageDB PackageDBX fp -> [PackageDBX fp] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [PackageDBX fp]
rest =
      Verbosity -> CabalException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity CabalException
GlobalPackageDBLimitation
checkPackageDbStack Verbosity
verbosity [PackageDBX fp]
_ =
  Verbosity -> CabalException -> IO ()
forall a1 a.
(HasCallStack, Show a1, Typeable a1,
 Exception (VerboseException a1)) =>
Verbosity -> a1 -> IO a
dieWithException Verbosity
verbosity CabalException
GlobalPackageDBSpecifiedFirst

getInstalledPackages'
  :: Verbosity
  -> Maybe (SymbolicPath CWD (Dir from))
  -> [PackageDBX (SymbolicPath from (Dir PkgDB))]
  -> ProgramDb
  -> IO [(PackageDBX (SymbolicPath from (Dir PkgDB)), [InstalledPackageInfo])]
getInstalledPackages' :: forall from.
Verbosity
-> Maybe (SymbolicPath CWD ('Dir from))
-> [PackageDBX (SymbolicPath from ('Dir PkgDB))]
-> ProgramDb
-> IO
     [(PackageDBX (SymbolicPath from ('Dir PkgDB)),
       [InstalledPackageInfo])]
getInstalledPackages' Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir [PackageDBX (SymbolicPath from ('Dir PkgDB))]
packagedbs ProgramDb
progdb =
  [IO
   (PackageDBX (SymbolicPath from ('Dir PkgDB)),
    [InstalledPackageInfo])]
-> IO
     [(PackageDBX (SymbolicPath from ('Dir PkgDB)),
       [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
      pkgs <- HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBX (SymbolicPath from ('Dir PkgDB))
-> IO [InstalledPackageInfo]
forall from.
HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBX (SymbolicPath from ('Dir PkgDB))
-> IO [InstalledPackageInfo]
HcPkg.dump (ProgramDb -> HcPkgInfo
hcPkgInfo ProgramDb
progdb) Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir PackageDBX (SymbolicPath from ('Dir PkgDB))
packagedb
      return (packagedb, pkgs)
    | PackageDBX (SymbolicPath from ('Dir PkgDB))
packagedb <- [PackageDBX (SymbolicPath from ('Dir PkgDB))]
packagedbs
    ]

-- | Get the packages from specific PackageDBs, not cumulative.
getInstalledPackagesMonitorFiles
  :: Verbosity
  -> Platform
  -> Maybe (SymbolicPath CWD (Dir Pkg))
  -> ProgramDb
  -> [PackageDB]
  -> IO [FilePath]
getInstalledPackagesMonitorFiles :: Verbosity
-> Platform
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> ProgramDb
-> [PackageDB]
-> IO [[Char]]
getInstalledPackagesMonitorFiles Verbosity
verbosity Platform
platform Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir ProgramDb
progdb =
  (PackageDB -> IO [Char]) -> [PackageDB] -> IO [[Char]]
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 [Char]
getPackageDBPath
  where
    getPackageDBPath :: PackageDB -> IO FilePath
    getPackageDBPath :: PackageDB -> IO [Char]
getPackageDBPath PackageDB
GlobalPackageDB =
      [Char] -> IO [Char]
selectMonitorFile ([Char] -> IO [Char]) -> IO [Char] -> IO [Char]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Verbosity -> ConfiguredProgram -> IO [Char]
getGlobalPackageDB Verbosity
verbosity ConfiguredProgram
ghcjsProg
    getPackageDBPath PackageDB
UserPackageDB =
      [Char] -> IO [Char]
selectMonitorFile ([Char] -> IO [Char]) -> IO [Char] -> IO [Char]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Verbosity -> ConfiguredProgram -> Platform -> IO [Char]
getUserPackageDB Verbosity
verbosity ConfiguredProgram
ghcjsProg Platform
platform
    getPackageDBPath (SpecificPackageDB SymbolicPath Pkg ('Dir PkgDB)
path) = [Char] -> IO [Char]
selectMonitorFile (Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg ('Dir PkgDB) -> [Char]
forall from (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPathX allowAbsolute from to -> [Char]
interpretSymbolicPath Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir SymbolicPath Pkg ('Dir PkgDB)
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 :: [Char] -> IO [Char]
selectMonitorFile [Char]
path0 = do
      let path :: [Char]
path =
            if [Char] -> Bool
isRelative [Char]
path0
              then Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPathX 'OnlyRelative Pkg (ZonkAny 12) -> [Char]
forall from (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPathX allowAbsolute from to -> [Char]
interpretSymbolicPath Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir ([Char] -> SymbolicPathX 'OnlyRelative Pkg (ZonkAny 12)
forall from (to :: FileOrDir).
HasCallStack =>
[Char] -> RelativePath from to
makeRelativePathEx [Char]
path0)
              else [Char]
path0
      isFileStyle <- [Char] -> IO Bool
doesFileExist [Char]
path
      if isFileStyle
        then return path
        else return (path </> "package.cache")

    ghcjsProg :: ConfiguredProgram
ghcjsProg = ConfiguredProgram -> Maybe ConfiguredProgram -> ConfiguredProgram
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> ConfiguredProgram
forall a. HasCallStack => [Char] -> a
error [Char]
"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 :: [Char] -> [Char]
toJSLibName [Char]
lib
  | [Char] -> [Char]
takeExtension [Char]
lib [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]
".dll", [Char]
".dylib", [Char]
".so"] =
      [Char] -> [Char] -> [Char]
replaceExtension [Char]
lib [Char]
"js_so"
  | [Char] -> [Char]
takeExtension [Char]
lib [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
".a" = [Char] -> [Char] -> [Char]
replaceExtension [Char]
lib [Char]
"js_a"
  | Bool
otherwise = [Char]
lib [Char] -> [Char] -> [Char]
forall p. FileLike p => p -> [Char] -> p
<.> [Char]
"js_a"

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

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

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

buildOrReplLib
  :: Maybe [String]
  -> Verbosity
  -> Flag ParStrat
  -> PackageDescription
  -> LocalBuildInfo
  -> Library
  -> ComponentLocalBuildInfo
  -> IO ()
buildOrReplLib :: Maybe [[Char]]
-> Verbosity
-> Flag ParStrat
-> PackageDescription
-> LocalBuildInfo
-> Library
-> ComponentLocalBuildInfo
-> IO ()
buildOrReplLib Maybe [[Char]]
mReplFlags Verbosity
verbosity Flag ParStrat
numJobs PackageDescription
_pkg_descr LocalBuildInfo
lbi Library
lib ComponentLocalBuildInfo
clbi = do
  let uid :: UnitId
uid = ComponentLocalBuildInfo -> UnitId
componentUnitId ComponentLocalBuildInfo
clbi
      libTargetDir :: SymbolicPath Pkg ('Dir Build)
libTargetDir = LocalBuildInfo
-> ComponentLocalBuildInfo -> SymbolicPath Pkg ('Dir Build)
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 -> ([[Char]] -> Bool) -> Maybe [[Char]] -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Bool -> [[Char]] -> Bool
forall a b. a -> b -> a
const Bool
True) Maybe [[Char]]
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)
      mbWorkDir :: Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir = LocalBuildInfo -> Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDirLBI LocalBuildInfo
lbi

      -- See Note [Symbolic paths] in Distribution.Utils.Path
      i :: SymbolicPathX allowAbsolute Pkg to -> [Char]
i = LocalBuildInfo -> SymbolicPathX allowAbsolute Pkg to -> [Char]
forall (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
LocalBuildInfo -> SymbolicPathX allowAbsolute Pkg to -> [Char]
interpretSymbolicPathLBI LocalBuildInfo
lbi
      u :: SymbolicPathX allowAbs Pkg to -> FilePath
      u :: forall (allowAbs :: AllowAbsolute) (to :: FileOrDir).
SymbolicPathX allowAbs Pkg to -> [Char]
u = SymbolicPathX allowAbs Pkg to -> [Char]
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> [Char]
getSymbolicPath

  (ghcjsProg, _) <- Verbosity
-> Program -> ProgramDb -> IO (ConfiguredProgram, ProgramDb)
requireProgram Verbosity
verbosity Program
ghcjsProgram (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)
  let runGhcjsProg = Verbosity
-> ConfiguredProgram
-> Compiler
-> Platform
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> GhcOptions
-> IO ()
runGHC Verbosity
verbosity ConfiguredProgram
ghcjsProg Compiler
comp Platform
platform Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir

  let libBi = Library -> BuildInfo
libBuildInfo Library
lib

  -- fixme flags shouldn't depend on ghcjs being dynamic or not
  let isGhcjsDynamic = Compiler -> Bool
isDynamic Compiler
comp
      dynamicTooSupported = Compiler -> Bool
supportsDynamicToo Compiler
comp
      doingTH = BuildInfo -> Bool
usesTemplateHaskellOrQQ BuildInfo
libBi
      forceVanillaLib = Bool
doingTH Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isGhcjsDynamic
      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 = LocalBuildInfo -> Bool
libCoverage LocalBuildInfo
lbi
      hpcdir Way
way
        | Bool
forRepl = Flag (SymbolicPath Pkg ('Dir Mix))
forall a. Monoid a => a
mempty -- HPC is not supported in ghci
        | Bool
isCoverageEnabled = SymbolicPath Pkg ('Dir Mix) -> Flag (SymbolicPath Pkg ('Dir Mix))
forall a. a -> Flag a
toFlag (SymbolicPath Pkg ('Dir Mix) -> Flag (SymbolicPath Pkg ('Dir Mix)))
-> SymbolicPath Pkg ('Dir Mix)
-> Flag (SymbolicPath Pkg ('Dir Mix))
forall a b. (a -> b) -> a -> b
$ SymbolicPathX 'AllowAbsolute Pkg ('Dir Dist)
-> Way -> SymbolicPath Pkg ('Dir Mix)
Hpc.mixDir (SymbolicPath Pkg ('Dir Build) -> SymbolicPath Pkg ('Dir Build)
forall (allowAbsolute :: AllowAbsolute) from (to1 :: FileOrDir)
       (to2 :: FileOrDir).
SymbolicPathX allowAbsolute from to1
-> SymbolicPathX allowAbsolute from to2
coerceSymbolicPath SymbolicPath Pkg ('Dir Build)
libTargetDir SymbolicPath Pkg ('Dir Build)
-> SymbolicPathX 'OnlyRelative Build ('Dir Dist)
-> SymbolicPathX 'AllowAbsolute Pkg ('Dir Dist)
forall p q r. PathLike p q r => p -> q -> r
</> SymbolicPathX 'OnlyRelative Build ('Dir Artifacts)
-> SymbolicPathX 'OnlyRelative Build ('Dir Dist)
forall (allowAbsolute :: AllowAbsolute) from (to1 :: FileOrDir)
       (to2 :: FileOrDir).
SymbolicPathX allowAbsolute from to1
-> SymbolicPathX allowAbsolute from to2
coerceSymbolicPath SymbolicPathX 'OnlyRelative Build ('Dir Artifacts)
extraCompilationArtifacts) Way
way
        | Bool
otherwise = Flag (SymbolicPath Pkg ('Dir Mix))
forall a. Monoid a => a
mempty

  createDirectoryIfMissingVerbose verbosity True $ i libTargetDir
  -- TODO: do we need to put hs-boot files into place for mutually recursive
  -- modules?
  let cLikeFiles = NubListR (SymbolicPath Pkg 'File) -> [SymbolicPath Pkg 'File]
forall a. NubListR a -> [a]
fromNubListR (NubListR (SymbolicPath Pkg 'File) -> [SymbolicPath Pkg 'File])
-> NubListR (SymbolicPath Pkg 'File) -> [SymbolicPath Pkg 'File]
forall a b. (a -> b) -> a -> b
$ [SymbolicPath Pkg 'File] -> NubListR (SymbolicPath Pkg 'File)
forall a. Ord a => [a] -> NubListR a
toNubListR (BuildInfo -> [SymbolicPath Pkg 'File]
cSources BuildInfo
libBi) NubListR (SymbolicPath Pkg 'File)
-> NubListR (SymbolicPath Pkg 'File)
-> NubListR (SymbolicPath Pkg 'File)
forall a. Semigroup a => a -> a -> a
<> [SymbolicPath Pkg 'File] -> NubListR (SymbolicPath Pkg 'File)
forall a. Ord a => [a] -> NubListR a
toNubListR (BuildInfo -> [SymbolicPath Pkg 'File]
cxxSources BuildInfo
libBi)
      jsSrcs = BuildInfo -> [SymbolicPath Pkg 'File]
jsSources BuildInfo
libBi
      cObjs = (SymbolicPath Pkg 'File -> SymbolicPath Pkg 'File)
-> [SymbolicPath Pkg 'File] -> [SymbolicPath Pkg 'File]
forall a b. (a -> b) -> [a] -> [b]
map ((SymbolicPath Pkg 'File -> [Char] -> SymbolicPath Pkg 'File
forall (allowAbsolute :: AllowAbsolute) from.
SymbolicPathX allowAbsolute from 'File
-> [Char] -> SymbolicPathX allowAbsolute from 'File
`replaceExtensionSymbolicPath` [Char]
objExtension)) [SymbolicPath Pkg 'File]
cLikeFiles
      baseOpts = Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> SymbolicPath Pkg ('Dir Build)
-> GhcOptions
forall build.
Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> SymbolicPath Pkg ('Dir build)
-> GhcOptions
componentGhcOptions Verbosity
verbosity LocalBuildInfo
lbi BuildInfo
libBi ComponentLocalBuildInfo
clbi SymbolicPath Pkg ('Dir Build)
libTargetDir
      linkJsLibOpts =
        GhcOptions
forall a. Monoid a => a
mempty
          { ghcOptExtra =
              [ "-link-js-lib"
              , getHSLibraryName uid
              , "-js-lib-outputdir"
              , u libTargetDir
              ]
                ++ map u jsSrcs
          }
      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
vanillaOptsNoJsLib GhcOptions -> GhcOptions -> GhcOptions
forall a. Monoid a => a -> a -> a
`mappend` GhcOptions
linkJsLibOpts

      profOpts =
        [Char] -> [Char] -> GhcOptions -> GhcOptions
adjustExts [Char]
"p_hi" [Char]
"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 =
        [Char] -> [Char] -> GhcOptions -> GhcOptions
adjustExts [Char]
"dyn_hi" [Char]
"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 = hcOptions GHC libBi ++ hcSharedOptions GHC libBi
            , ghcOptHPCDir = hpcdir Hpc.Dyn
            }

      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
            }

  unless (forRepl || null (allLibModules lib clbi) && null jsSrcs && null cObjs) $
    do
      let vanilla = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
whenVanillaLib Bool
forceVanillaLib (GhcOptions -> IO ()
runGhcjsProg GhcOptions
vanillaOpts)
          shared = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
whenSharedLib Bool
forceSharedLib (GhcOptions -> IO ()
runGhcjsProg GhcOptions
sharedOpts)
          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
&& [[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (CompilerFlavor -> BuildInfo -> [[Char]]
hcSharedOptions CompilerFlavor
GHC BuildInfo
libBi)
      if not has_code
        then vanilla
        else
          if useDynToo
            then do
              runGhcjsProg vanillaSharedOpts
              case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of
                (Flag SymbolicPath Pkg ('Dir Mix)
dynDir, Flag SymbolicPath Pkg ('Dir Mix)
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 -> [Char] -> [Char] -> IO ()
copyDirectoryRecursive Verbosity
verbosity (SymbolicPath Pkg ('Dir Mix) -> [Char]
forall (allowAbs :: AllowAbsolute) (to :: FileOrDir).
SymbolicPathX allowAbs Pkg to -> [Char]
i SymbolicPath Pkg ('Dir Mix)
dynDir) (SymbolicPath Pkg ('Dir Mix) -> [Char]
forall (allowAbs :: AllowAbsolute) (to :: FileOrDir).
SymbolicPathX allowAbs Pkg to -> [Char]
i SymbolicPath Pkg ('Dir Mix)
vanillaDir)
                (Flag (SymbolicPath Pkg ('Dir Mix)),
 Flag (SymbolicPath Pkg ('Dir Mix)))
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            else
              if isGhcjsDynamic
                then do shared; vanilla
                else do vanilla; shared
      whenProfLib (runGhcjsProg 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:

  when has_code . when False {- fixme nativeToo -} . unless forRepl $ do
    info verbosity "Linking..."
    let cSharedObjs =
          (SymbolicPath Pkg 'File -> SymbolicPath Pkg 'File)
-> [SymbolicPath Pkg 'File] -> [SymbolicPath Pkg 'File]
forall a b. (a -> b) -> [a] -> [b]
map
            ((SymbolicPath Pkg 'File -> [Char] -> SymbolicPath Pkg 'File
forall (allowAbsolute :: AllowAbsolute) from.
SymbolicPathX allowAbsolute from 'File
-> [Char] -> SymbolicPathX allowAbsolute from 'File
`replaceExtensionSymbolicPath` ([Char]
"dyn_" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
objExtension)))
            (BuildInfo -> [SymbolicPath Pkg 'File]
cSources BuildInfo
libBi [SymbolicPath Pkg 'File]
-> [SymbolicPath Pkg 'File] -> [SymbolicPath Pkg 'File]
forall a. [a] -> [a] -> [a]
++ BuildInfo -> [SymbolicPath Pkg 'File]
cxxSources BuildInfo
libBi)
        compiler_id = Compiler -> CompilerId
compilerId (LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi)
        sharedLibFilePath = SymbolicPath Pkg ('Dir Build)
libTargetDir SymbolicPath Pkg ('Dir Build)
-> SymbolicPathX 'OnlyRelative Build c3
-> SymbolicPathX 'AllowAbsolute Pkg c3
forall p q r. PathLike p q r => p -> q -> r
</> [Char] -> SymbolicPathX 'OnlyRelative Build c3
forall from (to :: FileOrDir).
HasCallStack =>
[Char] -> RelativePath from to
makeRelativePathEx (Platform -> CompilerId -> UnitId -> [Char]
mkSharedLibName (LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi) CompilerId
compiler_id UnitId
uid)
        staticLibFilePath = SymbolicPath Pkg ('Dir Build)
libTargetDir SymbolicPath Pkg ('Dir Build)
-> SymbolicPathX 'OnlyRelative Build c3
-> SymbolicPathX 'AllowAbsolute Pkg c3
forall p q r. PathLike p q r => p -> q -> r
</> [Char] -> SymbolicPathX 'OnlyRelative Build c3
forall from (to :: FileOrDir).
HasCallStack =>
[Char] -> RelativePath from to
makeRelativePathEx (Platform -> CompilerId -> UnitId -> [Char]
mkStaticLibName (LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi) CompilerId
compiler_id UnitId
uid)

    let stubObjs = []
        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 ]
    -}
    hObjs <-
      Internal.getHaskellObjects
        implInfo
        lib
        lbi
        clbi
        (coerceSymbolicPath libTargetDir)
        objExtension
        True
    hSharedObjs <-
      if withSharedLib lbi
        then
          Internal.getHaskellObjects
            implInfo
            lib
            lbi
            clbi
            (coerceSymbolicPath libTargetDir)
            ("dyn_" ++ objExtension)
            False
        else return []

    unless (null hObjs && null cObjs && null stubObjs) $ do
      rpaths <- getRPaths lbi clbi

      let staticObjectFiles =
            [SymbolicPath Pkg 'File]
hObjs
              [SymbolicPath Pkg 'File]
-> [SymbolicPath Pkg 'File] -> [SymbolicPath Pkg 'File]
forall a. [a] -> [a] -> [a]
++ (SymbolicPath Pkg 'File -> SymbolicPath Pkg 'File)
-> [SymbolicPath Pkg 'File] -> [SymbolicPath Pkg 'File]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> SymbolicPath Pkg 'File
forall from (to :: FileOrDir). [Char] -> SymbolicPath from to
makeSymbolicPath ([Char] -> SymbolicPath Pkg 'File)
-> (SymbolicPath Pkg 'File -> [Char])
-> SymbolicPath Pkg 'File
-> SymbolicPath Pkg 'File
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SymbolicPath Pkg ('Dir Build) -> [Char]
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> [Char]
getSymbolicPath SymbolicPath Pkg ('Dir Build)
libTargetDir [Char] -> [Char] -> [Char]
forall p q r. PathLike p q r => p -> q -> r
</>) ([Char] -> [Char])
-> (SymbolicPath Pkg 'File -> [Char])
-> SymbolicPath Pkg 'File
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymbolicPath Pkg 'File -> [Char]
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> [Char]
getSymbolicPath) [SymbolicPath Pkg 'File]
cObjs
              [SymbolicPath Pkg 'File]
-> [SymbolicPath Pkg 'File] -> [SymbolicPath Pkg 'File]
forall a. [a] -> [a] -> [a]
++ [SymbolicPath Pkg 'File]
forall a. [a]
stubObjs
          dynamicObjectFiles =
            [SymbolicPath Pkg 'File]
hSharedObjs
              [SymbolicPath Pkg 'File]
-> [SymbolicPath Pkg 'File] -> [SymbolicPath Pkg 'File]
forall a. [a] -> [a] -> [a]
++ (SymbolicPath Pkg 'File -> SymbolicPath Pkg 'File)
-> [SymbolicPath Pkg 'File] -> [SymbolicPath Pkg 'File]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> SymbolicPath Pkg 'File
forall from (to :: FileOrDir). [Char] -> SymbolicPath from to
makeSymbolicPath ([Char] -> SymbolicPath Pkg 'File)
-> (SymbolicPath Pkg 'File -> [Char])
-> SymbolicPath Pkg 'File
-> SymbolicPath Pkg 'File
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SymbolicPath Pkg ('Dir Build) -> [Char]
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> [Char]
getSymbolicPath SymbolicPath Pkg ('Dir Build)
libTargetDir [Char] -> [Char] -> [Char]
forall p q r. PathLike p q r => p -> q -> r
</>) ([Char] -> [Char])
-> (SymbolicPath Pkg 'File -> [Char])
-> SymbolicPath Pkg 'File
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymbolicPath Pkg 'File -> [Char]
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> [Char]
getSymbolicPath) [SymbolicPath Pkg 'File]
cSharedObjs
              [SymbolicPath Pkg 'File]
-> [SymbolicPath Pkg 'File] -> [SymbolicPath Pkg 'File]
forall a. [a] -> [a] -> [a]
++ [SymbolicPath Pkg 'File]
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
forall a. Monoid a => a
mempty
              { ghcOptShared = toFlag True
              , ghcOptDynLinkMode = toFlag GhcDynamicOnly
              , ghcOptInputFiles = toNubListR dynamicObjectFiles
              , ghcOptOutputFile = toFlag sharedLibFilePath
              , ghcOptExtra = hcOptions GHC libBi ++ 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 -> [Char]
componentCompatPackageKey = [Char]
pk} ->
                    [Char] -> Flag [Char]
forall a. a -> Flag a
toFlag [Char]
pk
                  ComponentLocalBuildInfo
_ -> Flag [Char]
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 Last ComponentId
forall a. Monoid a => a
mempty
                      else ComponentId -> Last ComponentId
forall a. a -> Flag a
toFlag (ComponentLocalBuildInfo -> ComponentId
componentComponentId ComponentLocalBuildInfo
clbi)
                  ComponentLocalBuildInfo
_ -> Last 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 $ map getSymbolicPath $ PD.frameworks libBi
              , ghcOptLinkFrameworkDirs =
                  toNubListR $ PD.extraFrameworkDirs libBi
              , ghcOptRPaths = rpaths
              }
          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 -> [Char]
componentCompatPackageKey = [Char]
pk} ->
                    [Char] -> Flag [Char]
forall a. a -> Flag a
toFlag [Char]
pk
                  ComponentLocalBuildInfo
_ -> Flag [Char]
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 Last ComponentId
forall a. Monoid a => a
mempty
                      else ComponentId -> Last ComponentId
forall a. a -> Flag a
toFlag (ComponentLocalBuildInfo -> ComponentId
componentComponentId ComponentLocalBuildInfo
clbi)
                  ComponentLocalBuildInfo
_ -> Last 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
              }

      info verbosity (show (ghcOptPackages 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
      -}
      whenSharedLib False $
        runGhcjsProg ghcSharedLinkArgs

      whenStaticLib False $
        runGhcjsProg 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 ()
forall fp. Eq fp => Verbosity -> PackageDBStackX fp -> IO ()
checkPackageDbStack Verbosity
verbosity [PackageDB]
packageDBs
  (ghcjsProg, _) <- Verbosity
-> Program -> ProgramDb -> IO (ConfiguredProgram, ProgramDb)
requireProgram Verbosity
verbosity Program
ghcjsProgram ProgramDb
progdb
  runGHC verbosity ghcjsProg comp platform Nothing replOpts

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

-- | Build a foreign library
buildFLib
  :: Verbosity
  -> Flag ParStrat
  -> PackageDescription
  -> LocalBuildInfo
  -> ForeignLib
  -> ComponentLocalBuildInfo
  -> IO ()
buildFLib :: Verbosity
-> Flag ParStrat
-> PackageDescription
-> LocalBuildInfo
-> ForeignLib
-> ComponentLocalBuildInfo
-> IO ()
buildFLib Verbosity
v Flag ParStrat
njobs PackageDescription
pkg LocalBuildInfo
lbi = Verbosity
-> Flag ParStrat
-> PackageDescription
-> LocalBuildInfo
-> GBuildMode
-> ComponentLocalBuildInfo
-> IO ()
gbuild Verbosity
v Flag ParStrat
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 ParStrat
  -> PackageDescription
  -> LocalBuildInfo
  -> ForeignLib
  -> ComponentLocalBuildInfo
  -> IO ()
replFLib :: [[Char]]
-> Verbosity
-> Flag ParStrat
-> PackageDescription
-> LocalBuildInfo
-> ForeignLib
-> ComponentLocalBuildInfo
-> IO ()
replFLib [[Char]]
replFlags Verbosity
v Flag ParStrat
njobs PackageDescription
pkg LocalBuildInfo
lbi =
  Verbosity
-> Flag ParStrat
-> PackageDescription
-> LocalBuildInfo
-> GBuildMode
-> ComponentLocalBuildInfo
-> IO ()
gbuild Verbosity
v Flag ParStrat
njobs PackageDescription
pkg LocalBuildInfo
lbi (GBuildMode -> ComponentLocalBuildInfo -> IO ())
-> (ForeignLib -> GBuildMode)
-> ForeignLib
-> ComponentLocalBuildInfo
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> ForeignLib -> GBuildMode
GReplFLib [[Char]]
replFlags

-- | Build an executable with GHC.
buildExe
  :: Verbosity
  -> Flag ParStrat
  -> PackageDescription
  -> LocalBuildInfo
  -> Executable
  -> ComponentLocalBuildInfo
  -> IO ()
buildExe :: Verbosity
-> Flag ParStrat
-> PackageDescription
-> LocalBuildInfo
-> Executable
-> ComponentLocalBuildInfo
-> IO ()
buildExe Verbosity
v Flag ParStrat
njobs PackageDescription
pkg LocalBuildInfo
lbi = Verbosity
-> Flag ParStrat
-> PackageDescription
-> LocalBuildInfo
-> GBuildMode
-> ComponentLocalBuildInfo
-> IO ()
gbuild Verbosity
v Flag ParStrat
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 ParStrat
  -> PackageDescription
  -> LocalBuildInfo
  -> Executable
  -> ComponentLocalBuildInfo
  -> IO ()
replExe :: [[Char]]
-> Verbosity
-> Flag ParStrat
-> PackageDescription
-> LocalBuildInfo
-> Executable
-> ComponentLocalBuildInfo
-> IO ()
replExe [[Char]]
replFlags Verbosity
v Flag ParStrat
njobs PackageDescription
pkg LocalBuildInfo
lbi =
  Verbosity
-> Flag ParStrat
-> PackageDescription
-> LocalBuildInfo
-> GBuildMode
-> ComponentLocalBuildInfo
-> IO ()
gbuild Verbosity
v Flag ParStrat
njobs PackageDescription
pkg LocalBuildInfo
lbi (GBuildMode -> ComponentLocalBuildInfo -> IO ())
-> (Executable -> GBuildMode)
-> Executable
-> ComponentLocalBuildInfo
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Char]] -> Executable -> GBuildMode
GReplExe [[Char]]
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 [[Char]]
_ Executable
exe) = Executable -> BuildInfo
buildInfo Executable
exe
gbuildInfo (GBuildFLib ForeignLib
flib) = ForeignLib -> BuildInfo
foreignLibBuildInfo ForeignLib
flib
gbuildInfo (GReplFLib [[Char]]
_ ForeignLib
flib) = ForeignLib -> BuildInfo
foreignLibBuildInfo ForeignLib
flib

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

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

exeTargetName :: Platform -> Executable -> String
exeTargetName :: Platform -> Executable -> [Char]
exeTargetName Platform
platform Executable
exe = UnqualComponentName -> [Char]
unUnqualComponentName (Executable -> UnqualComponentName
exeName Executable
exe) [Char] -> [Char] -> [Char]
`withExt` Platform -> [Char]
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 -> [Char]
flibTargetName LocalBuildInfo
lbi ForeignLib
flib =
  case (OS
os, ForeignLib -> ForeignLibType
foreignLibType ForeignLib
flib) of
    (OS
Windows, ForeignLibType
ForeignLibNativeShared) -> [Char]
nm [Char] -> [Char] -> [Char]
forall p. FileLike p => p -> [Char] -> p
<.> [Char]
"dll"
    (OS
Windows, ForeignLibType
ForeignLibNativeStatic) -> [Char]
nm [Char] -> [Char] -> [Char]
forall p. FileLike p => p -> [Char] -> p
<.> [Char]
"lib"
    (OS
Linux, ForeignLibType
ForeignLibNativeShared) -> [Char]
"lib" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
nm [Char] -> [Char] -> [Char]
forall p. FileLike p => p -> [Char] -> p
<.> [Char]
versionedExt
    (OS
_other, ForeignLibType
ForeignLibNativeShared) -> [Char]
"lib" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
nm [Char] -> [Char] -> [Char]
forall p. FileLike p => p -> [Char] -> p
<.> Platform -> [Char]
dllExtension (LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi)
    (OS
_other, ForeignLibType
ForeignLibNativeStatic) -> [Char]
"lib" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
nm [Char] -> [Char] -> [Char]
forall p. FileLike p => p -> [Char] -> p
<.> Platform -> [Char]
staticLibExtension (LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi)
    (OS
_any, ForeignLibType
ForeignLibTypeUnknown) -> [Char] -> [Char]
forall a. [Char] -> a
cabalBug [Char]
"unknown foreign lib type"
  where
    nm :: String
    nm :: [Char]
nm = UnqualComponentName -> [Char]
unUnqualComponentName (UnqualComponentName -> [Char]) -> UnqualComponentName -> [Char]
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 :: [Char]
versionedExt =
      let nums :: [Int]
nums = ForeignLib -> OS -> [Int]
foreignLibVersion ForeignLib
flib OS
os
       in ([Char] -> [Char] -> [Char]) -> [Char] -> [[Char]] -> [Char]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [Char] -> [Char] -> [Char]
forall p. FileLike p => p -> [Char] -> p
(<.>) [Char]
"so" ((Int -> [Char]) -> [Int] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Int -> [Char]
forall a. Show a => a -> [Char]
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 -> [Char]
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 [Char]
"lib" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
nm [Char] -> [Char] -> [Char]
forall p. FileLike p => p -> [Char] -> p
<.> ([Char] -> [Char] -> [Char]) -> [Char] -> [[Char]] -> [Char]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [Char] -> [Char] -> [Char]
forall p. FileLike p => p -> [Char] -> p
(<.>) [Char]
"so" ((Int -> [Char]) -> [Int] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Int -> [Char]
forall a. Show a => a -> [Char]
show (Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take Int
1 [Int]
nums))
  | Bool
otherwise = LocalBuildInfo -> ForeignLib -> [Char]
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 :: [Char]
nm = UnqualComponentName -> [Char]
unUnqualComponentName (UnqualComponentName -> [Char]) -> UnqualComponentName -> [Char]
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 [[Char]]
_ Executable
_) = Bool
True
gbuildIsRepl (GBuildFLib ForeignLib
_) = Bool
False
gbuildIsRepl (GReplFLib [[Char]]
_ 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 [[Char]]
_ Executable
_ -> LocalBuildInfo -> Bool
withDynExe LocalBuildInfo
lbi
    GBuildFLib ForeignLib
flib -> ForeignLib -> Bool
withDynFLib ForeignLib
flib
    GReplFLib [[Char]]
_ 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 ->
          [Char] -> Bool
forall a. [Char] -> a
cabalBug [Char]
"unknown foreign lib type"

gbuildModDefFiles :: GBuildMode -> [RelativePath Source File]
gbuildModDefFiles :: GBuildMode -> [RelativePath Source 'File]
gbuildModDefFiles (GBuildExe Executable
_) = []
gbuildModDefFiles (GReplExe [[Char]]
_ Executable
_) = []
gbuildModDefFiles (GBuildFLib ForeignLib
flib) = ForeignLib -> [RelativePath Source 'File]
foreignLibModDefFile ForeignLib
flib
gbuildModDefFiles (GReplFLib [[Char]]
_ ForeignLib
flib) = ForeignLib -> [RelativePath Source 'File]
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
$ ([Char] -> Maybe ModuleName) -> [[Char]] -> [Maybe ModuleName]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> Maybe ModuleName
decodeMainIsArg ([[Char]] -> [Maybe ModuleName]) -> [[Char]] -> [Maybe ModuleName]
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [[Char]]
findIsMainArgs [[Char]]
ghcopts
  where
    ghcopts :: [[Char]]
ghcopts = CompilerFlavor -> BuildInfo -> [[Char]]
hcOptions CompilerFlavor
GHC BuildInfo
bnfo

    findIsMainArgs :: [[Char]] -> [[Char]]
findIsMainArgs [] = []
    findIsMainArgs ([Char]
"-main-is" : [Char]
arg : [[Char]]
rest) = [Char]
arg [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]] -> [[Char]]
findIsMainArgs [[Char]]
rest
    findIsMainArgs ([Char]
_ : [[Char]]
rest) = [[Char]] -> [[Char]]
findIsMainArgs [[Char]]
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 :: [Char] -> Maybe ModuleName
decodeMainIsArg [Char]
arg
  | [Char] -> (Char -> Bool) -> Bool
headOf [Char]
main_fn Char -> Bool
isLower =
      -- The arg looked like "Foo.Bar.baz"
      ModuleName -> Maybe ModuleName
forall a. a -> Maybe a
Just ([Char] -> ModuleName
forall a. IsString a => [Char] -> a
ModuleName.fromString [Char]
main_mod)
  | [Char] -> (Char -> Bool) -> Bool
headOf [Char]
arg Char -> Bool
isUpper -- The arg looked like "Foo" or "Foo.Bar"
    =
      ModuleName -> Maybe ModuleName
forall a. a -> Maybe a
Just ([Char] -> ModuleName
forall a. IsString a => [Char] -> a
ModuleName.fromString [Char]
arg)
  | Bool
otherwise -- The arg looked like "baz"
    =
      Maybe ModuleName
forall a. Maybe a
Nothing
  where
    headOf :: String -> (Char -> Bool) -> Bool
    headOf :: [Char] -> (Char -> Bool) -> Bool
headOf [Char]
str Char -> Bool
pred' = (Char -> Bool) -> Maybe Char -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Char -> Bool
pred' ([Char] -> Maybe Char
forall a. [a] -> Maybe a
safeHead [Char]
str)

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

    splitLongestPrefix :: String -> (Char -> Bool) -> (String, String)
    splitLongestPrefix :: [Char] -> (Char -> Bool) -> ([Char], [Char])
splitLongestPrefix [Char]
str Char -> Bool
pred'
      | [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
r_pre = ([Char]
str, [])
      | Bool
otherwise = ([Char] -> [Char]
forall a. [a] -> [a]
reverse ([Char] -> [Char]
forall a. [a] -> [a]
safeTail [Char]
r_pre), [Char] -> [Char]
forall a. [a] -> [a]
reverse [Char]
r_suf)
      where
        -- 'safeTail' drops the char satisfying 'pred'
        ([Char]
r_suf, [Char]
r_pre) = (Char -> Bool) -> [Char] -> ([Char], [Char])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
pred' ([Char] -> [Char]
forall a. [a] -> [a]
reverse [Char]
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 -> [SymbolicPath Pkg 'File]
cSourcesFiles :: [SymbolicPath Pkg File]
  , BuildSources -> [SymbolicPath Pkg 'File]
cxxSourceFiles :: [SymbolicPath Pkg File]
  , BuildSources -> [SymbolicPath Pkg 'File]
inputSourceFiles :: [SymbolicPath Pkg File]
  , BuildSources -> [ModuleName]
inputSourceModules :: [ModuleName]
  }

-- | Locate and return the 'BuildSources' required to build and link.
gbuildSources
  :: Verbosity
  -> Maybe (SymbolicPath CWD ('Dir Pkg))
  -> PackageId
  -> CabalSpecVersion
  -> SymbolicPath Pkg (Dir Source)
  -> GBuildMode
  -> IO BuildSources
gbuildSources :: Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> PackageIdentifier
-> CabalSpecVersion
-> SymbolicPath Pkg ('Dir Source)
-> GBuildMode
-> IO BuildSources
gbuildSources Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir PackageIdentifier
pkgId CabalSpecVersion
specVer SymbolicPath Pkg ('Dir Source)
tmpDir GBuildMode
bm =
  case GBuildMode
bm of
    GBuildExe Executable
exe -> Executable -> IO BuildSources
exeSources Executable
exe
    GReplExe [[Char]]
_ 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 [[Char]]
_ 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 -> RelativePath Source 'File
modulePath = RelativePath Source 'File
modPath} = do
      main <- Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> [SymbolicPath Pkg ('Dir Source)]
-> RelativePath Source 'File
-> IO (SymbolicPath Pkg 'File)
forall searchDir (allowAbsolute :: AllowAbsolute).
Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
-> RelativePath searchDir 'File
-> IO (SymbolicPathX allowAbsolute Pkg 'File)
findFileCwd Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir (SymbolicPath Pkg ('Dir Source)
tmpDir SymbolicPath Pkg ('Dir Source)
-> [SymbolicPath Pkg ('Dir Source)]
-> [SymbolicPath Pkg ('Dir Source)]
forall a. a -> [a] -> [a]
: BuildInfo -> [SymbolicPath Pkg ('Dir Source)]
hsSourceDirs BuildInfo
bnfo) RelativePath Source 'File
modPath
      let 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 = Executable -> [ModuleName]
exeModules Executable
exe
          haskellMain = [Char] -> Bool
isHaskell (SymbolicPath Pkg 'File -> [Char]
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> [Char]
getSymbolicPath SymbolicPath Pkg 'File
main)

      -- Scripts have fakePackageId and are always Haskell but can have any extension.
      if haskellMain || pkgId == fakePackageId
        then
          if specVer < CabalSpecV2_0 && (mainModName `elem` 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... ;-)
              warn verbosity $
                "Enabling workaround for Main module '"
                  ++ prettyShow mainModName
                  ++ "' listed in 'other-modules' illegally!"

              return
                BuildSources
                  { cSourcesFiles = cSources bnfo
                  , cxxSourceFiles = cxxSources bnfo
                  , inputSourceFiles = [main]
                  , inputSourceModules = filter (/= mainModName) $ exeModules exe
                  }
            else
              return
                BuildSources
                  { cSourcesFiles = cSources bnfo
                  , cxxSourceFiles = cxxSources bnfo
                  , inputSourceFiles = [main]
                  , inputSourceModules = exeModules exe
                  }
        else
          let (csf, cxxsf)
                | isCxx (getSymbolicPath main) = (cSources bnfo, main : cxxSources bnfo)
                -- if main is not a Haskell source
                -- and main is not a C++ source
                -- then we assume that it is a C source
                | otherwise = (main : cSources bnfo, cxxSources bnfo)
           in return
                BuildSources
                  { cSourcesFiles = csf
                  , cxxSourceFiles = cxxsf
                  , inputSourceFiles = []
                  , inputSourceModules = exeModules exe
                  }

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

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

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

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

  let (bnfo, threaded) = case 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 = LocalBuildInfo -> GBuildMode -> [Char]
gbuildTargetName LocalBuildInfo
lbi GBuildMode
bm
      targetDir = LocalBuildInfo -> SymbolicPath Pkg ('Dir Build)
buildDir LocalBuildInfo
lbi SymbolicPath Pkg ('Dir Build)
-> SymbolicPathX 'OnlyRelative Build c3
-> SymbolicPathX 'AllowAbsolute Pkg c3
forall p q r. PathLike p q r => p -> q -> r
</> [Char] -> SymbolicPathX 'OnlyRelative Build c3
forall from (to :: FileOrDir).
HasCallStack =>
[Char] -> RelativePath from to
makeRelativePathEx (GBuildMode -> [Char]
gbuildName GBuildMode
bm)
      tmpDir = SymbolicPathX 'AllowAbsolute Pkg ('Dir (ZonkAny 0))
forall {c3 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg c3
targetDir SymbolicPathX 'AllowAbsolute Pkg ('Dir (ZonkAny 0))
-> SymbolicPathX 'OnlyRelative (ZonkAny 0) c3
-> SymbolicPathX 'AllowAbsolute Pkg c3
forall p q r. PathLike p q r => p -> q -> r
</> [Char] -> SymbolicPathX 'OnlyRelative (ZonkAny 0) c3
forall from (to :: FileOrDir).
HasCallStack =>
[Char] -> RelativePath from to
makeRelativePathEx (GBuildMode -> [Char]
gbuildName GBuildMode
bm [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"-tmp")

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

  createDirectoryIfMissingVerbose verbosity True $ i targetDir
  createDirectoryIfMissingVerbose verbosity True $ i 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 = LocalBuildInfo -> Bool
exeCoverage LocalBuildInfo
lbi
      hpcdir Way
way
        | GBuildMode -> Bool
gbuildIsRepl GBuildMode
bm = Flag (SymbolicPath Pkg ('Dir Mix))
forall a. Monoid a => a
mempty -- HPC is not supported in ghci
        | Bool
isCoverageEnabled = SymbolicPath Pkg ('Dir Mix) -> Flag (SymbolicPath Pkg ('Dir Mix))
forall a. a -> Flag a
toFlag (SymbolicPath Pkg ('Dir Mix) -> Flag (SymbolicPath Pkg ('Dir Mix)))
-> SymbolicPath Pkg ('Dir Mix)
-> Flag (SymbolicPath Pkg ('Dir Mix))
forall a b. (a -> b) -> a -> b
$ SymbolicPathX 'AllowAbsolute Pkg ('Dir Dist)
-> Way -> SymbolicPath Pkg ('Dir Mix)
Hpc.mixDir (SymbolicPath Pkg ('Dir Build)
forall {c3 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg c3
tmpDir SymbolicPath Pkg ('Dir Build)
-> SymbolicPathX 'OnlyRelative Build ('Dir Dist)
-> SymbolicPathX 'AllowAbsolute Pkg ('Dir Dist)
forall p q r. PathLike p q r => p -> q -> r
</> SymbolicPathX 'OnlyRelative Build ('Dir Artifacts)
-> SymbolicPathX 'OnlyRelative Build ('Dir Dist)
forall (allowAbsolute :: AllowAbsolute) from (to1 :: FileOrDir)
       (to2 :: FileOrDir).
SymbolicPathX allowAbsolute from to1
-> SymbolicPathX allowAbsolute from to2
coerceSymbolicPath SymbolicPathX 'OnlyRelative Build ('Dir Artifacts)
extraCompilationArtifacts) Way
way
        | Bool
otherwise = Flag (SymbolicPath Pkg ('Dir Mix))
forall a. Monoid a => a
mempty

  rpaths <- getRPaths lbi clbi
  buildSources <- gbuildSources verbosity mbWorkDir (package pkg_descr) (specVersion pkg_descr) tmpDir bm

  let cSrcs = BuildSources -> [SymbolicPath Pkg 'File]
cSourcesFiles BuildSources
buildSources
      cxxSrcs = BuildSources -> [SymbolicPath Pkg 'File]
cxxSourceFiles BuildSources
buildSources
      inputFiles = BuildSources -> [SymbolicPath Pkg 'File]
inputSourceFiles BuildSources
buildSources
      inputModules = BuildSources -> [ModuleName]
inputSourceModules BuildSources
buildSources
      isGhcDynamic = Compiler -> Bool
isDynamic Compiler
comp
      dynamicTooSupported = Compiler -> Bool
supportsDynamicToo Compiler
comp
      cObjs = (SymbolicPath Pkg 'File -> SymbolicPath Pkg 'File)
-> [SymbolicPath Pkg 'File] -> [SymbolicPath Pkg 'File]
forall a b. (a -> b) -> [a] -> [b]
map ((SymbolicPath Pkg 'File -> [Char] -> SymbolicPath Pkg 'File
forall (allowAbsolute :: AllowAbsolute) from.
SymbolicPathX allowAbsolute from 'File
-> [Char] -> SymbolicPathX allowAbsolute from 'File
`replaceExtensionSymbolicPath` [Char]
objExtension)) [SymbolicPath Pkg 'File]
cSrcs
      cxxObjs = (SymbolicPath Pkg 'File -> SymbolicPath Pkg 'File)
-> [SymbolicPath Pkg 'File] -> [SymbolicPath Pkg 'File]
forall a b. (a -> b) -> [a] -> [b]
map ((SymbolicPath Pkg 'File -> [Char] -> SymbolicPath Pkg 'File
forall (allowAbsolute :: AllowAbsolute) from.
SymbolicPathX allowAbsolute from 'File
-> [Char] -> SymbolicPathX allowAbsolute from 'File
`replaceExtensionSymbolicPath` [Char]
objExtension)) [SymbolicPath Pkg 'File]
cxxSrcs
      needDynamic = LocalBuildInfo -> GBuildMode -> Bool
gbuildNeedDynamic LocalBuildInfo
lbi GBuildMode
bm
      needProfiling = LocalBuildInfo -> Bool
withProfExe LocalBuildInfo
lbi

      -- build executables
      buildRunner = case ComponentLocalBuildInfo
clbi of
        LibComponentLocalBuildInfo{} -> Bool
False
        FLibComponentLocalBuildInfo{} -> Bool
False
        ExeComponentLocalBuildInfo{} -> Bool
True
        TestComponentLocalBuildInfo{} -> Bool
True
        BenchComponentLocalBuildInfo{} -> Bool
True
      baseOpts =
        (Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> SymbolicPath Pkg ('Dir (ZonkAny 3))
-> GhcOptions
forall build.
Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> SymbolicPath Pkg ('Dir build)
-> GhcOptions
componentGhcOptions Verbosity
verbosity LocalBuildInfo
lbi BuildInfo
bnfo ComponentLocalBuildInfo
clbi SymbolicPath Pkg ('Dir (ZonkAny 3))
forall {c3 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg c3
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 . getSymbolicPath) inputFiles
                    else inputFiles
            , ghcOptInputScripts =
                toNubListR $
                  if package pkg_descr == fakePackageId
                    then filter (not . isHaskell . getSymbolicPath) 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
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
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
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 = hcOptions GHC bnfo ++ hcSharedOptions GHC bnfo
            , ghcOptHPCDir = hpcdir Hpc.Dyn
            }
      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
forall a. Monoid a => a
mempty
          { ghcOptLinkOptions = PD.ldOptions bnfo
          , ghcOptLinkLibs = extraLibs bnfo
          , ghcOptLinkLibPath = toNubListR $ extraLibDirs bnfo
          , ghcOptLinkFrameworks =
              toNubListR $
                map getSymbolicPath $
                  PD.frameworks bnfo
          , ghcOptLinkFrameworkDirs =
              toNubListR $
                PD.extraFrameworkDirs bnfo
          , ghcOptInputFiles =
              toNubListR
                [makeSymbolicPath $ getSymbolicPath tmpDir </> getSymbolicPath x | x <- cObjs ++ cxxObjs]
          }
      dynLinkerOpts =
        GhcOptions
forall a. Monoid a => a
mempty
          { ghcOptRPaths = rpaths
          }
      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
        | Bool
needProfiling = GhcOptions
profOpts
        | Bool
needDynamic = GhcOptions
dynOpts
        | Bool
otherwise = GhcOptions
staticOpts
      compileOpts
        | Bool
useDynToo = GhcOptions
dynTooOpts
        | Bool
otherwise = GhcOptions
commonOpts
      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 = BuildInfo -> Bool
usesTemplateHaskellOrQQ BuildInfo
bnfo
      -- Should we use -dynamic-too instead of compiling twice?
      useDynToo =
        Bool
dynamicTooSupported
          Bool -> Bool -> Bool
&& Bool
isGhcDynamic
          Bool -> Bool -> Bool
&& Bool
doingTH
          Bool -> Bool -> Bool
&& Bool
withStaticExe
          Bool -> Bool -> Bool
&& [[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (CompilerFlavor -> BuildInfo -> [[Char]]
hcSharedOptions CompilerFlavor
GHC BuildInfo
bnfo)
      compileTHOpts
        | Bool
isGhcDynamic = GhcOptions
dynOpts
        | Bool
otherwise = GhcOptions
staticOpts
      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.
  when compileForTH $
    runGhcProg
      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.
  unless
    ( (null inputFiles && null inputModules)
        || gbuildIsRepl bm
    )
    $ runGhcProg
      compileOpts
        { ghcOptNoLink = toFlag True
        , ghcOptNumJobs = numJobs
        }

  -- build any C++ sources
  unless (null cxxSrcs) $ do
    info verbosity "Building C++ Sources..."
    sequence_
      [ do
        let baseCxxOpts =
              Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> SymbolicPath Pkg ('Dir Artifacts)
-> SymbolicPath Pkg 'File
-> GhcOptions
Internal.componentCxxGhcOptions
                Verbosity
verbosity
                LocalBuildInfo
lbi
                BuildInfo
bnfo
                ComponentLocalBuildInfo
clbi
                SymbolicPath Pkg ('Dir Artifacts)
forall {c3 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg c3
tmpDir
                SymbolicPath Pkg 'File
filename
            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
vanillaCxxOpts
                GhcOptions -> GhcOptions -> GhcOptions
forall a. Monoid a => a -> a -> a
`mappend` GhcOptions
forall a. Monoid a => a
mempty
                  { ghcOptProfilingMode = toFlag True
                  }
            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
              | 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 = Flag (SymbolicPath Pkg ('Dir Artifacts))
-> SymbolicPath Pkg ('Dir Artifacts)
forall a. WithCallStack (Flag a -> a)
fromFlag (GhcOptions -> Flag (SymbolicPath Pkg ('Dir Artifacts))
ghcOptObjDir GhcOptions
opts)
        createDirectoryIfMissingVerbose verbosity True (i odir)
        needsRecomp <- checkNeedsRecompilation mbWorkDir filename opts
        when needsRecomp $
          runGhcProg opts
      | filename <- cxxSrcs
      ]

  -- build any C sources
  unless (null cSrcs) $ do
    info verbosity "Building C Sources..."
    sequence_
      [ do
        let baseCcOpts =
              Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> SymbolicPath Pkg ('Dir Artifacts)
-> SymbolicPath Pkg 'File
-> GhcOptions
Internal.componentCcGhcOptions
                Verbosity
verbosity
                LocalBuildInfo
lbi
                BuildInfo
bnfo
                ComponentLocalBuildInfo
clbi
                SymbolicPath Pkg ('Dir Artifacts)
forall {c3 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg c3
tmpDir
                SymbolicPath Pkg 'File
filename
            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
vanillaCcOpts
                GhcOptions -> GhcOptions -> GhcOptions
forall a. Monoid a => a -> a -> a
`mappend` GhcOptions
forall a. Monoid a => a
mempty
                  { ghcOptProfilingMode = toFlag True
                  }
            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
              | Bool
needProfiling = GhcOptions
profCcOpts
              | Bool
needDynamic = GhcOptions
sharedCcOpts
              | Bool
otherwise = GhcOptions
vanillaCcOpts
            odir = Flag (SymbolicPath Pkg ('Dir Artifacts))
-> SymbolicPath Pkg ('Dir Artifacts)
forall a. WithCallStack (Flag a -> a)
fromFlag (GhcOptions -> Flag (SymbolicPath Pkg ('Dir Artifacts))
ghcOptObjDir GhcOptions
opts)
        createDirectoryIfMissingVerbose verbosity True (i odir)
        needsRecomp <- checkNeedsRecompilation mbWorkDir filename opts
        when needsRecomp $
          runGhcProg opts
      | filename <- 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 bm of
    GReplExe [[Char]]
_ Executable
_ -> GhcOptions -> IO ()
runGhcProg GhcOptions
replOpts
    GReplFLib [[Char]]
_ 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 -> [Char] -> IO ()
info Verbosity
verbosity [Char]
"Linking..."
      -- Work around old GHCs not relinking in this
      -- situation, see #3294
      let target :: SymbolicPathX 'AllowAbsolute Pkg c3
target = SymbolicPathX 'AllowAbsolute Pkg ('Dir (ZonkAny 5))
forall {c3 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg c3
targetDir SymbolicPathX 'AllowAbsolute Pkg ('Dir (ZonkAny 5))
-> SymbolicPathX 'OnlyRelative (ZonkAny 5) c3
-> SymbolicPathX 'AllowAbsolute Pkg c3
forall p q r. PathLike p q r => p -> q -> r
</> [Char] -> SymbolicPathX 'OnlyRelative (ZonkAny 5) c3
forall from (to :: FileOrDir).
HasCallStack =>
[Char] -> RelativePath from to
makeRelativePathEx [Char]
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
        let targetPath :: [Char]
targetPath = SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 6) -> [Char]
forall (allowAbs :: AllowAbsolute) (to :: FileOrDir).
SymbolicPathX allowAbs Pkg to -> [Char]
i SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 6)
forall {c3 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg c3
target
        e <- [Char] -> IO Bool
doesFileExist [Char]
targetPath
        when e (removeFile targetPath)
      GhcOptions -> IO ()
runGhcProg GhcOptions
linkOpts{ghcOptOutputFile = toFlag target}
    GBuildFLib ForeignLib
flib -> do
      let rtsInfo :: RtsInfo
rtsInfo = LocalBuildInfo -> RtsInfo
extractRtsInfo LocalBuildInfo
lbi
          rtsOptLinkLibs :: [[Char]]
rtsOptLinkLibs =
            [ if Bool
needDynamic
                then
                  if Bool
threaded
                    then DynamicRtsInfo -> [Char]
dynRtsThreadedLib (RtsInfo -> DynamicRtsInfo
rtsDynamicInfo RtsInfo
rtsInfo)
                    else DynamicRtsInfo -> [Char]
dynRtsVanillaLib (RtsInfo -> DynamicRtsInfo
rtsDynamicInfo RtsInfo
rtsInfo)
                else
                  if Bool
threaded
                    then StaticRtsInfo -> [Char]
statRtsThreadedLib (RtsInfo -> StaticRtsInfo
rtsStaticInfo RtsInfo
rtsInfo)
                    else StaticRtsInfo -> [Char]
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 $ map makeSymbolicPath $ rtsLibPaths rtsInfo
                  , ghcOptFPic = toFlag True
                  , ghcOptLinkModDefFiles = toNubListR $ fmap getSymbolicPath $ gbuildModDefFiles bm
                  }
            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)
              [Char] -> GhcOptions
forall a. [Char] -> a
cabalBug [Char]
"static libraries not yet implemented"
            ForeignLibType
ForeignLibTypeUnknown ->
              [Char] -> GhcOptions
forall a. [Char] -> a
cabalBug [Char]
"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 -> [Char] -> IO ()
info Verbosity
verbosity [Char]
"Linking..."
      let buildName :: [Char]
buildName = LocalBuildInfo -> ForeignLib -> [Char]
flibBuildName LocalBuildInfo
lbi ForeignLib
flib
          buildFile :: SymbolicPathX 'AllowAbsolute Pkg c3
buildFile = SymbolicPathX 'AllowAbsolute Pkg ('Dir (ZonkAny 7))
forall {c3 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg c3
targetDir SymbolicPathX 'AllowAbsolute Pkg ('Dir (ZonkAny 7))
-> SymbolicPathX 'OnlyRelative (ZonkAny 7) c3
-> SymbolicPathX 'AllowAbsolute Pkg c3
forall p q r. PathLike p q r => p -> q -> r
</> [Char] -> SymbolicPathX 'OnlyRelative (ZonkAny 7) c3
forall from (to :: FileOrDir).
HasCallStack =>
[Char] -> RelativePath from to
makeRelativePathEx [Char]
buildName
      GhcOptions -> IO ()
runGhcProg GhcOptions
linkOpts{ghcOptOutputFile = toFlag buildFile}
      [Char] -> [Char] -> IO ()
renameFile (SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 8) -> [Char]
forall (allowAbs :: AllowAbsolute) (to :: FileOrDir).
SymbolicPathX allowAbs Pkg to -> [Char]
i SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 8)
forall {c3 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg c3
buildFile) (SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 9) -> [Char]
forall (allowAbs :: AllowAbsolute) (to :: FileOrDir).
SymbolicPathX allowAbs Pkg to -> [Char]
i SymbolicPathX 'AllowAbsolute Pkg (ZonkAny 9)
forall {c3 :: FileOrDir}. SymbolicPathX 'AllowAbsolute Pkg c3
targetDir [Char] -> [Char] -> [Char]
forall p q r. PathLike p q r => p -> q -> r
</> [Char]
targetName)

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

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

data RtsInfo = RtsInfo
  { RtsInfo -> DynamicRtsInfo
rtsDynamicInfo :: DynamicRtsInfo
  , RtsInfo -> StaticRtsInfo
rtsStaticInfo :: StaticRtsInfo
  , RtsInfo -> [[Char]]
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) ([Char] -> PackageName
mkPackageName [Char]
"rts") of
    [(Version
_, [InstalledPackageInfo
rts])] -> InstalledPackageInfo -> RtsInfo
aux InstalledPackageInfo
rts
    [(Version, [InstalledPackageInfo])]
_otherwise -> [Char] -> RtsInfo
forall a. HasCallStack => [Char] -> a
error [Char]
"No (or multiple) ghc rts package is registered"
  where
    aux :: InstalledPackageInfo -> RtsInfo
    aux :: InstalledPackageInfo -> RtsInfo
aux InstalledPackageInfo
rts =
      RtsInfo
        { rtsDynamicInfo :: DynamicRtsInfo
rtsDynamicInfo =
            DynamicRtsInfo
              { dynRtsVanillaLib :: [Char]
dynRtsVanillaLib = [Char] -> [Char]
withGhcVersion [Char]
"HSrts"
              , dynRtsThreadedLib :: [Char]
dynRtsThreadedLib = [Char] -> [Char]
withGhcVersion [Char]
"HSrts_thr"
              , dynRtsDebugLib :: [Char]
dynRtsDebugLib = [Char] -> [Char]
withGhcVersion [Char]
"HSrts_debug"
              , dynRtsEventlogLib :: [Char]
dynRtsEventlogLib = [Char] -> [Char]
withGhcVersion [Char]
"HSrts_l"
              , dynRtsThreadedDebugLib :: [Char]
dynRtsThreadedDebugLib = [Char] -> [Char]
withGhcVersion [Char]
"HSrts_thr_debug"
              , dynRtsThreadedEventlogLib :: [Char]
dynRtsThreadedEventlogLib = [Char] -> [Char]
withGhcVersion [Char]
"HSrts_thr_l"
              }
        , rtsStaticInfo :: StaticRtsInfo
rtsStaticInfo =
            StaticRtsInfo
              { statRtsVanillaLib :: [Char]
statRtsVanillaLib = [Char]
"HSrts"
              , statRtsThreadedLib :: [Char]
statRtsThreadedLib = [Char]
"HSrts_thr"
              , statRtsDebugLib :: [Char]
statRtsDebugLib = [Char]
"HSrts_debug"
              , statRtsEventlogLib :: [Char]
statRtsEventlogLib = [Char]
"HSrts_l"
              , statRtsThreadedDebugLib :: [Char]
statRtsThreadedDebugLib = [Char]
"HSrts_thr_debug"
              , statRtsThreadedEventlogLib :: [Char]
statRtsThreadedEventlogLib = [Char]
"HSrts_thr_l"
              , statRtsProfilingLib :: [Char]
statRtsProfilingLib = [Char]
"HSrts_p"
              , statRtsThreadedProfilingLib :: [Char]
statRtsThreadedProfilingLib = [Char]
"HSrts_thr_p"
              }
        , rtsLibPaths :: [[Char]]
rtsLibPaths = InstalledPackageInfo -> [[Char]]
InstalledPackageInfo.libraryDirs InstalledPackageInfo
rts
        }
    withGhcVersion :: [Char] -> [Char]
withGhcVersion = ([Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ([Char]
"-ghc" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Version -> [Char]
forall a. Pretty a => a -> [Char]
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
  :: Maybe (SymbolicPath CWD (Dir Pkg))
  -> SymbolicPath Pkg File
  -> GhcOptions
  -> IO Bool
checkNeedsRecompilation :: Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg 'File -> GhcOptions -> IO Bool
checkNeedsRecompilation Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir SymbolicPath Pkg 'File
filename GhcOptions
opts =
  SymbolicPath Pkg 'File -> [Char]
forall (allowAbs :: AllowAbsolute) (to :: FileOrDir).
SymbolicPathX allowAbs Pkg to -> [Char]
i SymbolicPath Pkg 'File
filename [Char] -> [Char] -> IO Bool
`moreRecentFile` [Char]
oname
  where
    oname :: [Char]
oname = Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg 'File -> GhcOptions -> [Char]
getObjectFileName Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir SymbolicPath Pkg 'File
filename GhcOptions
opts
    i :: SymbolicPathX allowAbsolute Pkg to -> [Char]
i = Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPathX allowAbsolute Pkg to -> [Char]
forall from (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPathX allowAbsolute from to -> [Char]
interpretSymbolicPath Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path

-- | Finds the object file name of the given source file
getObjectFileName
  :: Maybe (SymbolicPath CWD (Dir Pkg))
  -> SymbolicPath Pkg File
  -> GhcOptions
  -> FilePath
getObjectFileName :: Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPath Pkg 'File -> GhcOptions -> [Char]
getObjectFileName Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir SymbolicPath Pkg 'File
filename GhcOptions
opts = [Char]
oname
  where
    i :: SymbolicPathX allowAbsolute Pkg to -> [Char]
i = Maybe (SymbolicPath CWD ('Dir Pkg))
-> SymbolicPathX allowAbsolute Pkg to -> [Char]
forall from (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
Maybe (SymbolicPath CWD ('Dir from))
-> SymbolicPathX allowAbsolute from to -> [Char]
interpretSymbolicPath Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir -- See Note [Symbolic paths] in Distribution.Utils.Path
    odir :: [Char]
odir = SymbolicPath Pkg ('Dir Artifacts) -> [Char]
forall (allowAbs :: AllowAbsolute) (to :: FileOrDir).
SymbolicPathX allowAbs Pkg to -> [Char]
i (SymbolicPath Pkg ('Dir Artifacts) -> [Char])
-> SymbolicPath Pkg ('Dir Artifacts) -> [Char]
forall a b. (a -> b) -> a -> b
$ Flag (SymbolicPath Pkg ('Dir Artifacts))
-> SymbolicPath Pkg ('Dir Artifacts)
forall a. WithCallStack (Flag a -> a)
fromFlag (GhcOptions -> Flag (SymbolicPath Pkg ('Dir Artifacts))
ghcOptObjDir GhcOptions
opts)
    oext :: [Char]
oext = [Char] -> Flag [Char] -> [Char]
forall a. a -> Flag a -> a
fromFlagOrDefault [Char]
"o" (GhcOptions -> Flag [Char]
ghcOptObjSuffix GhcOptions
opts)
    -- NB: the filepath might be absolute, e.g. if it is the path to
    -- an autogenerated .hs file.
    oname :: [Char]
oname = [Char]
odir [Char] -> [Char] -> [Char]
forall p q r. PathLike p q r => p -> q -> r
</> [Char] -> [Char] -> [Char]
replaceExtension (SymbolicPath Pkg 'File -> [Char]
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> [Char]
getSymbolicPath SymbolicPath Pkg 'File
filename) [Char]
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 [Char])
getRPaths LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi | OS -> Bool
supportRPaths OS
hostOS = do
  libraryPaths <- Bool
-> Bool -> LocalBuildInfo -> ComponentLocalBuildInfo -> IO [[Char]]
depLibraryPaths Bool
False (LocalBuildInfo -> Bool
relocatable LocalBuildInfo
lbi) LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi
  let hostPref = case OS
hostOS of
        OS
OSX -> [Char]
"@loader_path"
        OS
_ -> [Char]
"$ORIGIN"
      relPath [Char]
p = if [Char] -> Bool
isRelative [Char]
p then [Char]
hostPref [Char] -> [Char] -> [Char]
forall p q r. PathLike p q r => p -> q -> r
</> [Char]
p else [Char]
p
      rpaths = [[Char]] -> NubListR [Char]
forall a. Ord a => [a] -> NubListR a
toNubListR (([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> [Char]
relPath [[Char]]
libraryPaths)
  return 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
True
    supportRPaths OS
Haiku = Bool
False
    supportRPaths (OtherOS [Char]
_) = 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 [Char] -> IO (NubListR [Char])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return NubListR [Char]
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 [[Char]] -> Bool
hasThreaded (BuildInfo -> PerCompilerFlavor [[Char]]
options BuildInfo
bi)
  )
  where
    filterHcOptions
      :: (String -> Bool)
      -> PerCompilerFlavor [String]
      -> PerCompilerFlavor [String]
    filterHcOptions :: ([Char] -> Bool)
-> PerCompilerFlavor [[Char]] -> PerCompilerFlavor [[Char]]
filterHcOptions [Char] -> Bool
p (PerCompilerFlavor [[Char]]
ghc [[Char]]
ghcjs) =
      [[Char]] -> [[Char]] -> PerCompilerFlavor [[Char]]
forall v. v -> v -> PerCompilerFlavor v
PerCompilerFlavor (([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter [Char] -> Bool
p [[Char]]
ghc) [[Char]]
ghcjs

    hasThreaded :: PerCompilerFlavor [String] -> Bool
    hasThreaded :: PerCompilerFlavor [[Char]] -> Bool
hasThreaded (PerCompilerFlavor [[Char]]
ghc [[Char]]
_) = [Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [Char]
"-threaded" [[Char]]
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 [Char]
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
    mbWorkDir :: Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir = LocalBuildInfo -> Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDirLBI LocalBuildInfo
lbi
    vanillaArgs :: GhcOptions
vanillaArgs =
      (Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> SymbolicPath Pkg ('Dir Build)
-> GhcOptions
forall build.
Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> SymbolicPath Pkg ('Dir build)
-> GhcOptions
componentGhcOptions Verbosity
verbosity LocalBuildInfo
lbi BuildInfo
libBi ComponentLocalBuildInfo
clbi (LocalBuildInfo
-> ComponentLocalBuildInfo -> SymbolicPath Pkg ('Dir Build)
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
          }
    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 = hcOptions GHC libBi ++ 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 = [Char] -> GhcOptions
forall a. HasCallStack => [Char] -> a
error [Char]
"libAbiHash: Can't find an enabled library way"

  (ghcjsProg, _) <- Verbosity
-> Program -> ProgramDb -> IO (ConfiguredProgram, ProgramDb)
requireProgram Verbosity
verbosity Program
ghcjsProgram (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)
  hash <-
    getProgramInvocationOutput
      verbosity
      =<< ghcInvocation verbosity ghcjsProg comp platform mbWorkDir ghcArgs
  return (takeWhile (not . isSpace) hash)

componentGhcOptions
  :: Verbosity
  -> LocalBuildInfo
  -> BuildInfo
  -> ComponentLocalBuildInfo
  -> SymbolicPath Pkg (Dir build)
  -> GhcOptions
componentGhcOptions :: forall build.
Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> SymbolicPath Pkg ('Dir build)
-> GhcOptions
componentGhcOptions Verbosity
verbosity LocalBuildInfo
lbi BuildInfo
bi ComponentLocalBuildInfo
clbi SymbolicPath Pkg ('Dir build)
odir =
  let opts :: GhcOptions
opts = Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> SymbolicPath Pkg ('Dir build)
-> GhcOptions
forall build.
Verbosity
-> LocalBuildInfo
-> BuildInfo
-> ComponentLocalBuildInfo
-> SymbolicPath Pkg ('Dir build)
-> GhcOptions
Internal.componentGhcOptions Verbosity
verbosity LocalBuildInfo
lbi BuildInfo
bi ComponentLocalBuildInfo
clbi SymbolicPath Pkg ('Dir build)
odir
   in GhcOptions
opts
        { ghcOptExtra = ghcOptExtra opts `mappend` hcOptions GHCJS bi
        }

-- -----------------------------------------------------------------------------
-- 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
-> [Char]
-> [Char]
-> ([Char], [Char])
-> PackageDescription
-> Executable
-> IO ()
installExe
  Verbosity
verbosity
  LocalBuildInfo
lbi
  [Char]
binDir
  [Char]
buildPref
  ([Char]
progprefix, [Char]
progsuffix)
  PackageDescription
_pkg
  Executable
exe = do
    Verbosity -> Bool -> [Char] -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True [Char]
binDir
    let exeName' :: [Char]
exeName' = UnqualComponentName -> [Char]
unUnqualComponentName (UnqualComponentName -> [Char]) -> UnqualComponentName -> [Char]
forall a b. (a -> b) -> a -> b
$ Executable -> UnqualComponentName
exeName Executable
exe
        exeFileName :: [Char]
exeFileName = [Char]
exeName'
        fixedExeBaseName :: [Char]
fixedExeBaseName = [Char]
progprefix [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
exeName' [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
progsuffix
        installBinary :: [Char] -> IO ()
installBinary [Char]
dest = do
          Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> Program
-> ProgramDb
-> [[Char]]
-> IO ()
forall to.
Verbosity
-> Maybe (SymbolicPath CWD ('Dir to))
-> Program
-> ProgramDb
-> [[Char]]
-> IO ()
runDbProgramCwd Verbosity
verbosity (LocalBuildInfo -> Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDirLBI LocalBuildInfo
lbi) Program
ghcjsProgram (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi) ([[Char]] -> IO ()) -> [[Char]] -> IO ()
forall a b. (a -> b) -> a -> b
$
            [ [Char]
"--install-executable"
            , [Char]
buildPref [Char] -> [Char] -> [Char]
forall p q r. PathLike p q r => p -> q -> r
</> [Char]
exeName' [Char] -> [Char] -> [Char]
forall p q r. PathLike p q r => p -> q -> r
</> [Char]
exeFileName
            , [Char]
"-o"
            , [Char]
dest
            ]
              [[Char]] -> [[Char]] -> [[Char]]
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) -> [[Char]
"-strip-program", ConfiguredProgram -> [Char]
programPath ConfiguredProgram
strip]
                (Bool, Maybe ConfiguredProgram)
_ -> []
    [Char] -> IO ()
installBinary ([Char]
binDir [Char] -> [Char] -> [Char]
forall p q r. PathLike p q r => p -> q -> r
</> [Char]
fixedExeBaseName)

-- | Install foreign library for GHC.
installFLib
  :: Verbosity
  -> LocalBuildInfo
  -> FilePath
  -- ^ install location
  -> FilePath
  -- ^ Build location
  -> PackageDescription
  -> ForeignLib
  -> IO ()
installFLib :: Verbosity
-> LocalBuildInfo
-> [Char]
-> [Char]
-> PackageDescription
-> ForeignLib
-> IO ()
installFLib Verbosity
verbosity LocalBuildInfo
lbi [Char]
targetDir [Char]
builtDir PackageDescription
_pkg ForeignLib
flib =
  Bool -> [Char] -> [Char] -> [Char] -> IO ()
forall {p} {p} {p}.
PathLike p p [Char] =>
p -> p -> p -> p -> IO ()
install
    (ForeignLib -> Bool
foreignLibIsShared ForeignLib
flib)
    [Char]
builtDir
    [Char]
targetDir
    (LocalBuildInfo -> ForeignLib -> [Char]
flibTargetName LocalBuildInfo
lbi ForeignLib
flib)
  where
    install :: p -> p -> p -> p -> IO ()
install p
_isShared p
srcDir p
dstDir p
name = do
      let src :: [Char]
src = p
srcDir p -> p -> [Char]
forall p q r. PathLike p q r => p -> q -> r
</> p
name
          dst :: [Char]
dst = p
dstDir p -> p -> [Char]
forall p q r. PathLike p q r => p -> q -> r
</> p
name
      Verbosity -> Bool -> [Char] -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True [Char]
targetDir
      Verbosity -> [Char] -> [Char] -> IO ()
installOrdinaryFile Verbosity
verbosity [Char]
src [Char]
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
-> [Char]
-> [Char]
-> [Char]
-> PackageDescription
-> Library
-> ComponentLocalBuildInfo
-> IO ()
installLib Verbosity
verbosity LocalBuildInfo
lbi [Char]
targetDir [Char]
dynlibTargetDir [Char]
_builtDir PackageDescription
_pkg Library
lib ComponentLocalBuildInfo
clbi = do
  IO () -> IO ()
whenVanilla (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Suffix -> IO ()
copyModuleFiles (Suffix -> IO ()) -> Suffix -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Suffix
Suffix [Char]
"js_hi"
  IO () -> IO ()
whenProf (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Suffix -> IO ()
copyModuleFiles (Suffix -> IO ()) -> Suffix -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Suffix
Suffix [Char]
"js_p_hi"
  IO () -> IO ()
whenShared (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Suffix -> IO ()
copyModuleFiles (Suffix -> IO ()) -> Suffix -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Suffix
Suffix [Char]
"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_
        [ SymbolicPath Pkg ('Dir Build) -> [Char] -> [Char] -> IO ()
forall {allowAbsolute :: AllowAbsolute} {from}.
SymbolicPathX allowAbsolute Pkg ('Dir from)
-> [Char] -> [Char] -> IO ()
installOrdinary SymbolicPath Pkg ('Dir Build)
builtDir' [Char]
targetDir ([Char] -> [Char]
toJSLibName ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
mkGenericStaticLibName ([Char]
l [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
f))
        | [Char]
l <- UnitId -> [Char]
getHSLibraryName (ComponentLocalBuildInfo -> UnitId
componentUnitId ComponentLocalBuildInfo
clbi) [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: (BuildInfo -> [[Char]]
extraBundledLibs (Library -> BuildInfo
libBuildInfo Library
lib))
        , [Char]
f <- [Char]
"" [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: BuildInfo -> [[Char]]
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
      SymbolicPath Pkg ('Dir Build) -> [Char] -> [Char] -> IO ()
forall {allowAbsolute :: AllowAbsolute} {from}.
SymbolicPathX allowAbsolute Pkg ('Dir from)
-> [Char] -> [Char] -> IO ()
installOrdinary SymbolicPath Pkg ('Dir Build)
builtDir' [Char]
targetDir ([Char] -> [Char]
toJSLibName [Char]
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_
        [ SymbolicPath Pkg ('Dir Build) -> [Char] -> [Char] -> IO ()
forall {allowAbsolute :: AllowAbsolute} {from}.
SymbolicPathX allowAbsolute Pkg ('Dir from)
-> [Char] -> [Char] -> IO ()
installShared
          SymbolicPath Pkg ('Dir Build)
builtDir'
          [Char]
dynlibTargetDir
          ([Char] -> [Char]
toJSLibName ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ Platform -> CompilerId -> [Char] -> [Char]
mkGenericSharedLibName Platform
platform CompilerId
compiler_id ([Char]
l [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
f))
        | [Char]
l <- UnitId -> [Char]
getHSLibraryName UnitId
uid [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: BuildInfo -> [[Char]]
extraBundledLibs (Library -> BuildInfo
libBuildInfo Library
lib)
        , [Char]
f <- [Char]
"" [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: BuildInfo -> [[Char]]
extraDynLibFlavours (Library -> BuildInfo
libBuildInfo Library
lib)
        ]
  where
    i :: SymbolicPathX allowAbsolute Pkg to -> [Char]
i = LocalBuildInfo -> SymbolicPathX allowAbsolute Pkg to -> [Char]
forall (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
LocalBuildInfo -> SymbolicPathX allowAbsolute Pkg to -> [Char]
interpretSymbolicPathLBI LocalBuildInfo
lbi -- See Note [Symbolic paths] in Distribution.Utils.Path
    builtDir' :: SymbolicPath Pkg ('Dir Build)
builtDir' = LocalBuildInfo
-> ComponentLocalBuildInfo -> SymbolicPath Pkg ('Dir Build)
componentBuildDir LocalBuildInfo
lbi ComponentLocalBuildInfo
clbi
    mbWorkDir :: Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir = LocalBuildInfo -> Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDirLBI LocalBuildInfo
lbi

    install :: Bool
-> Bool
-> SymbolicPathX allowAbsolute Pkg ('Dir from)
-> [Char]
-> [Char]
-> IO ()
install Bool
isShared Bool
isJS SymbolicPathX allowAbsolute Pkg ('Dir from)
srcDir [Char]
dstDir [Char]
name = do
      let src :: [Char]
src = SymbolicPathX allowAbsolute Pkg (ZonkAny 11) -> [Char]
forall (allowAbs :: AllowAbsolute) (to :: FileOrDir).
SymbolicPathX allowAbs Pkg to -> [Char]
i (SymbolicPathX allowAbsolute Pkg (ZonkAny 11) -> [Char])
-> SymbolicPathX allowAbsolute Pkg (ZonkAny 11) -> [Char]
forall a b. (a -> b) -> a -> b
$ SymbolicPathX allowAbsolute Pkg ('Dir from)
srcDir SymbolicPathX allowAbsolute Pkg ('Dir from)
-> SymbolicPathX 'OnlyRelative from (ZonkAny 11)
-> SymbolicPathX allowAbsolute Pkg (ZonkAny 11)
forall p q r. PathLike p q r => p -> q -> r
</> [Char] -> SymbolicPathX 'OnlyRelative from (ZonkAny 11)
forall from (to :: FileOrDir).
HasCallStack =>
[Char] -> RelativePath from to
makeRelativePathEx [Char]
name
          dst :: [Char]
dst = [Char]
dstDir [Char] -> [Char] -> [Char]
forall p q r. PathLike p q r => p -> q -> r
</> [Char]
name
      Verbosity -> Bool -> [Char] -> IO ()
createDirectoryIfMissingVerbose Verbosity
verbosity Bool
True [Char]
dstDir

      if Bool
isShared
        then Verbosity -> [Char] -> [Char] -> IO ()
installExecutableFile Verbosity
verbosity [Char]
src [Char]
dst
        else Verbosity -> [Char] -> [Char] -> IO ()
installOrdinaryFile Verbosity
verbosity [Char]
src [Char]
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 -> [Char] -> IO ()
Strip.stripLib
          Verbosity
verbosity
          (LocalBuildInfo -> Platform
hostPlatform LocalBuildInfo
lbi)
          (LocalBuildInfo -> ProgramDb
withPrograms LocalBuildInfo
lbi)
          [Char]
dst

    installOrdinary :: SymbolicPathX allowAbsolute Pkg ('Dir from)
-> [Char] -> [Char] -> IO ()
installOrdinary = Bool
-> Bool
-> SymbolicPathX allowAbsolute Pkg ('Dir from)
-> [Char]
-> [Char]
-> IO ()
forall {allowAbsolute :: AllowAbsolute} {from}.
Bool
-> Bool
-> SymbolicPathX allowAbsolute Pkg ('Dir from)
-> [Char]
-> [Char]
-> IO ()
install Bool
False Bool
True
    installShared :: SymbolicPathX allowAbsolute Pkg ('Dir from)
-> [Char] -> [Char] -> IO ()
installShared = Bool
-> Bool
-> SymbolicPathX allowAbsolute Pkg ('Dir from)
-> [Char]
-> [Char]
-> IO ()
forall {allowAbsolute :: AllowAbsolute} {from}.
Bool
-> Bool
-> SymbolicPathX allowAbsolute Pkg ('Dir from)
-> [Char]
-> [Char]
-> IO ()
install Bool
True Bool
True

    copyModuleFiles :: Suffix -> IO ()
copyModuleFiles Suffix
ext = do
      files <- Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> [SymbolicPath Pkg ('Dir Build)]
-> [Suffix]
-> [ModuleName]
-> IO [(SymbolicPath Pkg ('Dir Build), RelativePath Build 'File)]
forall searchDir (allowAbsolute :: AllowAbsolute).
Verbosity
-> Maybe (SymbolicPath CWD ('Dir Pkg))
-> [SymbolicPathX allowAbsolute Pkg ('Dir searchDir)]
-> [Suffix]
-> [ModuleName]
-> IO
     [(SymbolicPathX allowAbsolute Pkg ('Dir searchDir),
       RelativePath searchDir 'File)]
findModuleFilesCwd Verbosity
verbosity Maybe (SymbolicPath CWD ('Dir Pkg))
mbWorkDir [SymbolicPath Pkg ('Dir Build)
builtDir'] [Suffix
ext] (Library -> ComponentLocalBuildInfo -> [ModuleName]
allLibModules Library
lib ComponentLocalBuildInfo
clbi)
      let files' = ((SymbolicPath Pkg ('Dir Build), RelativePath Build 'File)
 -> ([Char], [Char]))
-> [(SymbolicPath Pkg ('Dir Build), RelativePath Build 'File)]
-> [([Char], [Char])]
forall a b. (a -> b) -> [a] -> [b]
map (SymbolicPath Pkg ('Dir Build) -> [Char]
forall (allowAbs :: AllowAbsolute) (to :: FileOrDir).
SymbolicPathX allowAbs Pkg to -> [Char]
i (SymbolicPath Pkg ('Dir Build) -> [Char])
-> (RelativePath Build 'File -> [Char])
-> (SymbolicPath Pkg ('Dir Build), RelativePath Build 'File)
-> ([Char], [Char])
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** RelativePath Build 'File -> [Char]
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> [Char]
getSymbolicPath) [(SymbolicPath Pkg ('Dir Build), RelativePath Build 'File)]
files
      installOrdinaryFiles verbosity targetDir files'

    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 :: [Char]
profileLibName = UnitId -> [Char]
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
&& [SymbolicPath Pkg 'File] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (BuildInfo -> [SymbolicPath Pkg 'File]
cSources (Library -> BuildInfo
libBuildInfo Library
lib))
          Bool -> Bool -> Bool
&& [SymbolicPath Pkg 'File] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (BuildInfo -> [SymbolicPath Pkg 'File]
cxxSources (Library -> BuildInfo
libBuildInfo Library
lib))
          Bool -> Bool -> Bool
&& [SymbolicPath Pkg 'File] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (BuildInfo -> [SymbolicPath Pkg 'File]
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 :: [Char] -> [Char] -> GhcOptions -> GhcOptions
adjustExts [Char]
hiSuf [Char]
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 = [Char] -> Compiler -> Bool
Internal.ghcLookupProperty [Char]
"GHC Dynamic"

supportsDynamicToo :: Compiler -> Bool
supportsDynamicToo :: Compiler -> Bool
supportsDynamicToo = [Char] -> Compiler -> Bool
Internal.ghcLookupProperty [Char]
"Support dynamic-too"

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

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

findGhcjsPkgGhcjsVersion :: Verbosity -> FilePath -> IO (Maybe Version)
findGhcjsPkgGhcjsVersion :: Verbosity -> [Char] -> IO (Maybe Version)
findGhcjsPkgGhcjsVersion Verbosity
verbosity [Char]
pgm =
  [Char]
-> ([Char] -> [Char]) -> Verbosity -> [Char] -> IO (Maybe Version)
findProgramVersion [Char]
"--numeric-ghcjs-version" [Char] -> [Char]
forall a. a -> a
id Verbosity
verbosity [Char]
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 ([Char] -> ConfiguredProgram
forall a. HasCallStack => [Char] -> a
error [Char]
"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 ([Char] -> Version
forall a. HasCallStack => [Char] -> a
error [Char]
"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
  -> Maybe (SymbolicPath CWD (Dir from))
  -> PackageDBStackS from
  -> InstalledPackageInfo
  -> HcPkg.RegisterOptions
  -> IO ()
registerPackage :: forall from.
Verbosity
-> ProgramDb
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBStackS from
-> InstalledPackageInfo
-> RegisterOptions
-> IO ()
registerPackage Verbosity
verbosity ProgramDb
progdb Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir PackageDBStackS from
packageDbs InstalledPackageInfo
installedPkgInfo RegisterOptions
registerOptions =
  HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBStackS from
-> InstalledPackageInfo
-> RegisterOptions
-> IO ()
forall from.
HcPkgInfo
-> Verbosity
-> Maybe (SymbolicPath CWD ('Dir from))
-> PackageDBStackS from
-> InstalledPackageInfo
-> RegisterOptions
-> IO ()
HcPkg.register
    (ProgramDb -> HcPkgInfo
hcPkgInfo ProgramDb
progdb)
    Verbosity
verbosity
    Maybe (SymbolicPath CWD ('Dir from))
mbWorkDir
    PackageDBStackS from
packageDbs
    InstalledPackageInfo
installedPkgInfo
    RegisterOptions
registerOptions

pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO FilePath
pkgRoot :: Verbosity -> LocalBuildInfo -> PackageDB -> IO [Char]
pkgRoot Verbosity
verbosity LocalBuildInfo
lbi = PackageDB -> IO [Char]
forall {allowAbsolute :: AllowAbsolute} {to :: FileOrDir}.
PackageDBX (SymbolicPathX allowAbsolute Pkg to) -> IO [Char]
pkgRoot'
  where
    pkgRoot' :: PackageDBX (SymbolicPathX allowAbsolute Pkg to) -> IO [Char]
pkgRoot' PackageDBX (SymbolicPathX allowAbsolute Pkg to)
GlobalPackageDB =
      let ghcjsProg :: ConfiguredProgram
ghcjsProg = ConfiguredProgram -> Maybe ConfiguredProgram -> ConfiguredProgram
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> ConfiguredProgram
forall a. HasCallStack => [Char] -> a
error [Char]
"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 ([Char] -> [Char]) -> IO [Char] -> IO [Char]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> [Char]
takeDirectory (Verbosity -> ConfiguredProgram -> IO [Char]
getGlobalPackageDB Verbosity
verbosity ConfiguredProgram
ghcjsProg)
    pkgRoot' PackageDBX (SymbolicPathX allowAbsolute Pkg to)
UserPackageDB = do
      appDir <- [Char] -> IO [Char]
getAppUserDataDirectory [Char]
"ghcjs"
      -- fixme correct this version
      let ver = Compiler -> Version
compilerVersion (LocalBuildInfo -> Compiler
compiler LocalBuildInfo
lbi)
          subdir =
            [Char]
System.Info.arch
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Char
'-'
              Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
System.Info.os
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Char
'-'
              Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: Version -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Version
ver
          rootDir = [Char]
appDir [Char] -> [Char] -> [Char]
forall p q r. PathLike p q r => p -> q -> r
</> [Char]
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.
      createDirectoryIfMissing True rootDir
      return rootDir
    pkgRoot' (SpecificPackageDB SymbolicPathX allowAbsolute Pkg to
fp) =
      [Char] -> IO [Char]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> IO [Char]) -> [Char] -> IO [Char]
forall a b. (a -> b) -> a -> b
$
        [Char] -> [Char]
takeDirectory ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$
          LocalBuildInfo -> SymbolicPathX allowAbsolute Pkg to -> [Char]
forall (allowAbsolute :: AllowAbsolute) (to :: FileOrDir).
LocalBuildInfo -> SymbolicPathX allowAbsolute Pkg to -> [Char]
interpretSymbolicPathLBI LocalBuildInfo
lbi SymbolicPathX allowAbsolute Pkg to
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 -> [Char] -> ([Char], [Char], [[Char]])
runCmd ProgramDb
progdb [Char]
exe =
  ( [Char]
script
  , ConfiguredProgram -> [Char]
programPath ConfiguredProgram
ghcjsProg
  , ConfiguredProgram -> [[Char]]
programDefaultArgs ConfiguredProgram
ghcjsProg [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ ConfiguredProgram -> [[Char]]
programOverrideArgs ConfiguredProgram
ghcjsProg [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]
"--run"]
  )
  where
    script :: [Char]
script = [Char]
exe [Char] -> [Char] -> [Char]
forall p. FileLike p => p -> [Char] -> p
<.> [Char]
"jsexe" [Char] -> [Char] -> [Char]
forall p q r. PathLike p q r => p -> q -> r
</> [Char]
"all" [Char] -> [Char] -> [Char]
forall p. FileLike p => p -> [Char] -> p
<.> [Char]
"js"
    ghcjsProg :: ConfiguredProgram
ghcjsProg = ConfiguredProgram -> Maybe ConfiguredProgram -> ConfiguredProgram
forall a. a -> Maybe a -> a
fromMaybe ([Char] -> ConfiguredProgram
forall a. HasCallStack => [Char] -> a
error [Char]
"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