module Distribution.Simple.GHCJS (
configure, getInstalledPackages, getPackageDBContents,
buildLib, buildExe,
replLib, replExe,
startInterpreter,
installLib, installExe,
libAbiHash,
hcPkgInfo,
registerPackage,
componentGhcOptions,
getLibDir,
isDynamic,
getGlobalPackageDB,
runCmd
) where
import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Types.UnqualComponentName
import Distribution.Simple.GHC.ImplInfo
import qualified Distribution.Simple.GHC.Internal as Internal
import Distribution.PackageDescription as PD
import Distribution.InstalledPackageInfo
import Distribution.Simple.PackageIndex ( InstalledPackageIndex )
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.Simple.LocalBuildInfo
import qualified Distribution.Simple.Hpc as Hpc
import Distribution.Simple.BuildPaths
import Distribution.Simple.Utils
import Distribution.Simple.Program
import qualified Distribution.Simple.Program.HcPkg as HcPkg
import qualified Distribution.Simple.Program.Ar as Ar
import qualified Distribution.Simple.Program.Ld as Ld
import qualified Distribution.Simple.Program.Strip as Strip
import Distribution.Simple.Program.GHC
import Distribution.Simple.Setup hiding ( Flag )
import qualified Distribution.Simple.Setup as Cabal
import Distribution.Simple.Compiler hiding ( Flag )
import Distribution.Version
import Distribution.System
import Distribution.Verbosity
import Distribution.Utils.NubList
import Distribution.Text
import Distribution.Types.UnitId
import qualified Data.Map as Map
import System.Directory ( doesFileExist )
import System.FilePath ( (</>), (<.>), takeExtension
, takeDirectory, replaceExtension )
configure :: Verbosity -> Maybe FilePath -> Maybe FilePath
-> ProgramDb
-> IO (Compiler, Maybe Platform, ProgramDb)
configure verbosity hcPath hcPkgPath progdb0 = do
(ghcjsProg, ghcjsVersion, progdb1) <-
requireProgramVersion verbosity ghcjsProgram
(orLaterVersion (mkVersion [0,1]))
(userMaybeSpecifyPath "ghcjs" hcPath progdb0)
Just ghcjsGhcVersion <- findGhcjsGhcVersion verbosity (programPath ghcjsProg)
let implInfo = ghcjsVersionImplInfo ghcjsVersion ghcjsGhcVersion
(ghcjsPkgProg, ghcjsPkgVersion, progdb2) <-
requireProgramVersion verbosity ghcjsPkgProgram {
programFindLocation = guessGhcjsPkgFromGhcjsPath ghcjsProg
}
anyVersion (userMaybeSpecifyPath "ghcjs-pkg" hcPkgPath progdb1)
Just ghcjsPkgGhcjsVersion <- findGhcjsPkgGhcjsVersion
verbosity (programPath ghcjsPkgProg)
when (ghcjsVersion /= ghcjsPkgGhcjsVersion) $ die' verbosity $
"Version mismatch between ghcjs and ghcjs-pkg: "
++ programPath ghcjsProg ++ " is version " ++ display ghcjsVersion ++ " "
++ programPath ghcjsPkgProg ++ " is version " ++ display ghcjsPkgGhcjsVersion
when (ghcjsGhcVersion /= ghcjsPkgVersion) $ die' verbosity $
"Version mismatch between ghcjs and ghcjs-pkg: "
++ programPath ghcjsProg
++ " was built with GHC version " ++ display ghcjsGhcVersion ++ " "
++ programPath ghcjsPkgProg
++ " was built with GHC version " ++ display ghcjsPkgVersion
let hsc2hsProgram' =
hsc2hsProgram { programFindLocation =
guessHsc2hsFromGhcjsPath ghcjsProg }
c2hsProgram' =
c2hsProgram { programFindLocation =
guessC2hsFromGhcjsPath ghcjsProg }
haddockProgram' =
haddockProgram { programFindLocation =
guessHaddockFromGhcjsPath ghcjsProg }
progdb3 = addKnownPrograms [ hsc2hsProgram', c2hsProgram', haddockProgram' ] progdb2
languages <- Internal.getLanguages verbosity implInfo ghcjsProg
extensions <- Internal.getExtensions verbosity implInfo ghcjsProg
ghcInfo <- Internal.getGhcInfo verbosity implInfo ghcjsProg
let ghcInfoMap = Map.fromList ghcInfo
let comp = Compiler {
compilerId = CompilerId GHCJS ghcjsVersion,
compilerAbiTag = AbiTag $
"ghc" ++ intercalate "_" (map show . versionNumbers $ ghcjsGhcVersion),
compilerCompat = [CompilerId GHC ghcjsGhcVersion],
compilerLanguages = languages,
compilerExtensions = extensions,
compilerProperties = ghcInfoMap
}
compPlatform = Internal.targetPlatform ghcInfo
let progdb4 = if ghcjsNativeToo comp
then Internal.configureToolchain implInfo
ghcjsProg ghcInfoMap progdb3
else progdb3
return (comp, compPlatform, progdb4)
ghcjsNativeToo :: Compiler -> Bool
ghcjsNativeToo = Internal.ghcLookupProperty "Native Too"
guessGhcjsPkgFromGhcjsPath :: ConfiguredProgram -> Verbosity
-> ProgramSearchPath -> IO (Maybe (FilePath, [FilePath]))
guessGhcjsPkgFromGhcjsPath = guessToolFromGhcjsPath ghcjsPkgProgram
guessHsc2hsFromGhcjsPath :: ConfiguredProgram -> Verbosity
-> ProgramSearchPath -> IO (Maybe (FilePath, [FilePath]))
guessHsc2hsFromGhcjsPath = guessToolFromGhcjsPath hsc2hsProgram
guessC2hsFromGhcjsPath :: ConfiguredProgram -> Verbosity
-> ProgramSearchPath -> IO (Maybe (FilePath, [FilePath]))
guessC2hsFromGhcjsPath = guessToolFromGhcjsPath c2hsProgram
guessHaddockFromGhcjsPath :: ConfiguredProgram -> Verbosity
-> ProgramSearchPath -> IO (Maybe (FilePath, [FilePath]))
guessHaddockFromGhcjsPath = guessToolFromGhcjsPath haddockProgram
guessToolFromGhcjsPath :: Program -> ConfiguredProgram
-> Verbosity -> ProgramSearchPath
-> IO (Maybe (FilePath, [FilePath]))
guessToolFromGhcjsPath tool ghcjsProg verbosity searchpath
= do let toolname = programName tool
path = programPath ghcjsProg
dir = takeDirectory path
versionSuffix = takeVersionSuffix (dropExeExtension path)
guessNormal = dir </> toolname <.> exeExtension buildPlatform
guessGhcjsVersioned = dir </> (toolname ++ "-ghcjs" ++ versionSuffix)
<.> exeExtension buildPlatform
guessGhcjs = dir </> (toolname ++ "-ghcjs")
<.> exeExtension buildPlatform
guessVersioned = dir </> (toolname ++ versionSuffix) <.> exeExtension buildPlatform
guesses | null versionSuffix = [guessGhcjs, guessNormal]
| otherwise = [guessGhcjsVersioned,
guessGhcjs,
guessVersioned,
guessNormal]
info verbosity $ "looking for tool " ++ toolname
++ " near compiler in " ++ dir
exists <- traverse doesFileExist guesses
case [ file | (file, True) <- zip guesses exists ] of
[] -> programFindLocation tool verbosity searchpath
(fp:_) -> do info verbosity $ "found " ++ toolname ++ " in " ++ fp
let lookedAt = map fst
. takeWhile (\(_file, exist) -> not exist)
$ zip guesses exists
return (Just (fp, lookedAt))
where takeVersionSuffix :: FilePath -> String
takeVersionSuffix = reverse . takeWhile (`elem ` "0123456789.-") .
reverse
getPackageDBContents :: Verbosity -> PackageDB -> ProgramDb
-> IO InstalledPackageIndex
getPackageDBContents verbosity packagedb progdb = do
pkgss <- getInstalledPackages' verbosity [packagedb] progdb
toPackageIndex verbosity pkgss progdb
getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramDb
-> IO InstalledPackageIndex
getInstalledPackages verbosity packagedbs progdb = do
checkPackageDbEnvVar verbosity
checkPackageDbStack verbosity packagedbs
pkgss <- getInstalledPackages' verbosity packagedbs progdb
index <- toPackageIndex verbosity pkgss progdb
return $! index
toPackageIndex :: Verbosity
-> [(PackageDB, [InstalledPackageInfo])]
-> ProgramDb
-> IO InstalledPackageIndex
toPackageIndex verbosity pkgss progdb = do
topDir <- getLibDir' verbosity ghcjsProg
let indices = [ PackageIndex.fromList (map (Internal.substTopDir topDir) pkgs)
| (_, pkgs) <- pkgss ]
return $! (mconcat indices)
where
Just ghcjsProg = lookupProgram ghcjsProgram progdb
checkPackageDbEnvVar :: Verbosity -> IO ()
checkPackageDbEnvVar verbosity =
Internal.checkPackageDbEnvVar verbosity "GHCJS" "GHCJS_PACKAGE_PATH"
checkPackageDbStack :: Verbosity -> PackageDBStack -> IO ()
checkPackageDbStack _ (GlobalPackageDB:rest)
| GlobalPackageDB `notElem` rest = return ()
checkPackageDbStack verbosity rest
| GlobalPackageDB `notElem` rest =
die' verbosity $ "With current ghc versions the global package db is always used "
++ "and must be listed first. This ghc limitation may be lifted in "
++ "future, see http://hackage.haskell.org/trac/ghc/ticket/5977"
checkPackageDbStack verbosity _ =
die' verbosity $ "If the global package db is specified, it must be "
++ "specified first and cannot be specified multiple times"
getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramDb
-> IO [(PackageDB, [InstalledPackageInfo])]
getInstalledPackages' verbosity packagedbs progdb =
sequenceA
[ do pkgs <- HcPkg.dump (hcPkgInfo progdb) verbosity packagedb
return (packagedb, pkgs)
| packagedb <- packagedbs ]
getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath
getLibDir verbosity lbi =
(reverse . dropWhile isSpace . reverse) `fmap`
getDbProgramOutput verbosity ghcjsProgram
(withPrograms lbi) ["--print-libdir"]
getLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath
getLibDir' verbosity ghcjsProg =
(reverse . dropWhile isSpace . reverse) `fmap`
getProgramOutput verbosity ghcjsProg ["--print-libdir"]
getGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO FilePath
getGlobalPackageDB verbosity ghcjsProg =
(reverse . dropWhile isSpace . reverse) `fmap`
getProgramOutput verbosity ghcjsProg ["--print-global-package-db"]
toJSLibName :: String -> String
toJSLibName lib
| takeExtension lib `elem` [".dll",".dylib",".so"]
= replaceExtension lib "js_so"
| takeExtension lib == ".a" = replaceExtension lib "js_a"
| otherwise = lib <.> "js_a"
buildLib :: Verbosity -> Cabal.Flag (Maybe Int) -> PackageDescription
-> LocalBuildInfo -> Library -> ComponentLocalBuildInfo
-> IO ()
buildLib = buildOrReplLib Nothing
replLib :: [String] -> Verbosity
-> Cabal.Flag (Maybe Int) -> PackageDescription
-> LocalBuildInfo -> Library
-> ComponentLocalBuildInfo -> IO ()
replLib = buildOrReplLib . Just
buildOrReplLib :: Maybe [String] -> Verbosity
-> Cabal.Flag (Maybe Int) -> PackageDescription
-> LocalBuildInfo -> Library
-> ComponentLocalBuildInfo -> IO ()
buildOrReplLib mReplFlags verbosity numJobs pkg_descr lbi lib clbi = do
let uid = componentUnitId clbi
libTargetDir = buildDir lbi
whenVanillaLib forceVanilla =
when (not forRepl && (forceVanilla || withVanillaLib lbi))
whenProfLib = when (not forRepl && withProfLib lbi)
whenSharedLib forceShared =
when (not forRepl && (forceShared || withSharedLib lbi))
whenGHCiLib = when (not forRepl && withGHCiLib lbi && withVanillaLib lbi)
forRepl = maybe False (const True) mReplFlags
ifReplLib = when forRepl
replFlags = fromMaybe mempty mReplFlags
comp = compiler lbi
platform = hostPlatform lbi
implInfo = getImplInfo comp
nativeToo = ghcjsNativeToo comp
(ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi)
let runGhcjsProg = runGHC verbosity ghcjsProg comp platform
libBi = libBuildInfo lib
isGhcjsDynamic = isDynamic comp
dynamicTooSupported = supportsDynamicToo comp
doingTH = usesTemplateHaskellOrQQ libBi
forceVanillaLib = doingTH && not isGhcjsDynamic
forceSharedLib = doingTH && isGhcjsDynamic
let isCoverageEnabled = libCoverage lbi
pkg_name = display $ PD.package pkg_descr
distPref = fromFlag $ configDistPref $ configFlags lbi
hpcdir way
| isCoverageEnabled = toFlag $ Hpc.mixDir distPref way pkg_name
| otherwise = mempty
createDirectoryIfMissingVerbose verbosity True libTargetDir
let cObjs = map (`replaceExtension` objExtension) (cSources libBi)
jsSrcs = jsSources libBi
baseOpts = componentGhcOptions verbosity lbi libBi clbi libTargetDir
linkJsLibOpts = mempty {
ghcOptExtra =
[ "-link-js-lib" , getHSLibraryName uid
, "-js-lib-outputdir", libTargetDir ] ++
jsSrcs
}
vanillaOptsNoJsLib = baseOpts `mappend` mempty {
ghcOptMode = toFlag GhcModeMake,
ghcOptNumJobs = numJobs,
ghcOptInputModules = toNubListR $ allLibModules lib clbi,
ghcOptHPCDir = hpcdir Hpc.Vanilla
}
vanillaOpts = vanillaOptsNoJsLib `mappend` linkJsLibOpts
profOpts = adjustExts "p_hi" "p_o" vanillaOpts `mappend` mempty {
ghcOptProfilingMode = toFlag True,
ghcOptExtra = ghcjsProfOptions libBi,
ghcOptHPCDir = hpcdir Hpc.Prof
}
sharedOpts = adjustExts "dyn_hi" "dyn_o" vanillaOpts `mappend` mempty {
ghcOptDynLinkMode = toFlag GhcDynamicOnly,
ghcOptFPic = toFlag True,
ghcOptExtra = ghcjsSharedOptions libBi,
ghcOptHPCDir = hpcdir Hpc.Dyn
}
linkerOpts = mempty {
ghcOptLinkOptions = PD.ldOptions libBi,
ghcOptLinkLibs = extraLibs libBi,
ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi,
ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi,
ghcOptInputFiles =
toNubListR $ [libTargetDir </> x | x <- cObjs] ++ jsSrcs
}
replOpts = vanillaOptsNoJsLib {
ghcOptExtra = Internal.filterGhciFlags
(ghcOptExtra vanillaOpts)
<> replFlags,
ghcOptNumJobs = mempty
}
`mappend` linkerOpts
`mappend` mempty {
ghcOptMode = toFlag GhcModeInteractive,
ghcOptOptimisation = toFlag GhcNoOptimisation
}
vanillaSharedOpts = vanillaOpts `mappend`
mempty {
ghcOptDynLinkMode = toFlag GhcStaticAndDynamic,
ghcOptDynHiSuffix = toFlag "dyn_hi",
ghcOptDynObjSuffix = toFlag "dyn_o",
ghcOptHPCDir = hpcdir Hpc.Dyn
}
unless (forRepl || (null (allLibModules lib clbi) && null jsSrcs && null cObjs)) $
do let vanilla = whenVanillaLib forceVanillaLib (runGhcjsProg vanillaOpts)
shared = whenSharedLib forceSharedLib (runGhcjsProg sharedOpts)
useDynToo = dynamicTooSupported &&
(forceVanillaLib || withVanillaLib lbi) &&
(forceSharedLib || withSharedLib lbi) &&
null (ghcjsSharedOptions libBi)
if useDynToo
then do
runGhcjsProg vanillaSharedOpts
case (hpcdir Hpc.Dyn, hpcdir Hpc.Vanilla) of
(Cabal.Flag dynDir, Cabal.Flag vanillaDir) -> do
copyDirectoryRecursive verbosity dynDir vanillaDir
_ -> return ()
else if isGhcjsDynamic
then do shared; vanilla
else do vanilla; shared
whenProfLib (runGhcjsProg profOpts)
unless (null (cSources libBi) || not nativeToo) $ do
info verbosity "Building C Sources..."
sequence_
[ do let vanillaCcOpts =
(Internal.componentCcGhcOptions verbosity implInfo
lbi libBi clbi libTargetDir filename)
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
runGhcjsProg vanillaCcOpts
whenSharedLib forceSharedLib (runGhcjsProg sharedCcOpts)
whenProfLib (runGhcjsProg profCcOpts)
| filename <- cSources libBi]
unless (null (allLibModules lib clbi)) $
ifReplLib (runGhcjsProg replOpts)
when (nativeToo && not forRepl) $ do
info verbosity "Linking..."
let cProfObjs = map (`replaceExtension` ("p_" ++ objExtension))
(cSources libBi)
cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension))
(cSources libBi)
compiler_id = compilerId (compiler lbi)
vanillaLibFilePath = libTargetDir </> mkLibName uid
profileLibFilePath = libTargetDir </> mkProfLibName uid
sharedLibFilePath = libTargetDir </> mkSharedLibName (hostPlatform lbi) compiler_id uid
ghciLibFilePath = libTargetDir </> Internal.mkGHCiLibName uid
hObjs <- Internal.getHaskellObjects implInfo lib lbi clbi
libTargetDir objExtension True
hProfObjs <-
if (withProfLib lbi)
then Internal.getHaskellObjects implInfo lib lbi clbi
libTargetDir ("p_" ++ objExtension) True
else return []
hSharedObjs <-
if (withSharedLib lbi)
then Internal.getHaskellObjects implInfo lib lbi clbi
libTargetDir ("dyn_" ++ objExtension) False
else return []
unless (null hObjs && null cObjs) $ do
let staticObjectFiles =
hObjs
++ map (libTargetDir </>) cObjs
profObjectFiles =
hProfObjs
++ map (libTargetDir </>) cProfObjs
ghciObjFiles =
hObjs
++ map (libTargetDir </>) cObjs
dynamicObjectFiles =
hSharedObjs
++ map (libTargetDir </>) cSharedObjs
ghcSharedLinkArgs =
mempty {
ghcOptShared = toFlag True,
ghcOptDynLinkMode = toFlag GhcDynamicOnly,
ghcOptInputFiles = toNubListR dynamicObjectFiles,
ghcOptOutputFile = toFlag sharedLibFilePath,
ghcOptExtra = ghcjsSharedOptions libBi,
ghcOptNoAutoLinkPackages = toFlag True,
ghcOptPackageDBs = withPackageDB lbi,
ghcOptPackages = toNubListR $
Internal.mkGhcOptPackages clbi,
ghcOptLinkLibs = extraLibs libBi,
ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi
}
whenVanillaLib False $ do
Ar.createArLibArchive verbosity lbi vanillaLibFilePath staticObjectFiles
whenProfLib $ do
Ar.createArLibArchive verbosity lbi profileLibFilePath profObjectFiles
whenGHCiLib $ do
(ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi)
Ld.combineObjectFiles verbosity lbi ldProg
ghciLibFilePath ghciObjFiles
whenSharedLib False $
runGhcjsProg ghcSharedLinkArgs
startInterpreter :: Verbosity -> ProgramDb -> Compiler -> Platform
-> PackageDBStack -> IO ()
startInterpreter verbosity progdb comp platform packageDBs = do
let replOpts = mempty {
ghcOptMode = toFlag GhcModeInteractive,
ghcOptPackageDBs = packageDBs
}
checkPackageDbStack verbosity packageDBs
(ghcjsProg, _) <- requireProgram verbosity ghcjsProgram progdb
runGHC verbosity ghcjsProg comp platform replOpts
buildExe :: Verbosity -> Cabal.Flag (Maybe Int)
-> PackageDescription -> LocalBuildInfo
-> Executable -> ComponentLocalBuildInfo -> IO ()
buildExe = buildOrReplExe Nothing
replExe :: [String] -> Verbosity
-> Cabal.Flag (Maybe Int) -> PackageDescription
-> LocalBuildInfo -> Executable
-> ComponentLocalBuildInfo -> IO ()
replExe = buildOrReplExe . Just
buildOrReplExe :: Maybe [String] -> Verbosity
-> Cabal.Flag (Maybe Int) -> PackageDescription
-> LocalBuildInfo -> Executable
-> ComponentLocalBuildInfo -> IO ()
buildOrReplExe mReplFlags verbosity numJobs _pkg_descr lbi
exe@Executable { exeName = exeName', modulePath = modPath } clbi = do
(ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi)
let forRepl = maybe False (const True) mReplFlags
replFlags = fromMaybe mempty mReplFlags
comp = compiler lbi
platform = hostPlatform lbi
implInfo = getImplInfo comp
runGhcjsProg = runGHC verbosity ghcjsProg comp platform
exeBi = buildInfo exe
let exeName'' = unUnqualComponentName exeName'
let exeNameReal = exeName'' <.>
(if takeExtension exeName'' /= ('.':exeExtension buildPlatform)
then exeExtension buildPlatform
else "")
let targetDir = (buildDir lbi) </> exeName''
let exeDir = targetDir </> (exeName'' ++ "-tmp")
createDirectoryIfMissingVerbose verbosity True targetDir
createDirectoryIfMissingVerbose verbosity True exeDir
let isCoverageEnabled = exeCoverage lbi
distPref = fromFlag $ configDistPref $ configFlags lbi
hpcdir way
| isCoverageEnabled = toFlag $ Hpc.mixDir distPref way exeName''
| otherwise = mempty
srcMainFile <- findFile (exeDir : hsSourceDirs exeBi) modPath
let isGhcjsDynamic = isDynamic comp
dynamicTooSupported = supportsDynamicToo comp
buildRunner = case clbi of
ExeComponentLocalBuildInfo {} -> False
_ -> True
isHaskellMain = elem (takeExtension srcMainFile) [".hs", ".lhs"]
jsSrcs = jsSources exeBi
cSrcs = cSources exeBi ++ [srcMainFile | not isHaskellMain]
cObjs = map (`replaceExtension` objExtension) cSrcs
nativeToo = ghcjsNativeToo comp
baseOpts = (componentGhcOptions verbosity lbi exeBi clbi exeDir)
`mappend` mempty {
ghcOptMode = toFlag GhcModeMake,
ghcOptInputFiles = toNubListR $
[ srcMainFile | isHaskellMain],
ghcOptInputModules = toNubListR $
[ m | not isHaskellMain, m <- exeModules exe],
ghcOptExtra =
if buildRunner then ["-build-runner"]
else mempty
}
staticOpts = baseOpts `mappend` mempty {
ghcOptDynLinkMode = toFlag GhcStaticOnly,
ghcOptHPCDir = hpcdir Hpc.Vanilla
}
profOpts = adjustExts "p_hi" "p_o" baseOpts `mappend` mempty {
ghcOptProfilingMode = toFlag True,
ghcOptExtra = ghcjsProfOptions exeBi,
ghcOptHPCDir = hpcdir Hpc.Prof
}
dynOpts = adjustExts "dyn_hi" "dyn_o" baseOpts `mappend` mempty {
ghcOptDynLinkMode = toFlag GhcDynamicOnly,
ghcOptExtra = ghcjsSharedOptions exeBi,
ghcOptHPCDir = hpcdir Hpc.Dyn
}
dynTooOpts = adjustExts "dyn_hi" "dyn_o" staticOpts `mappend` mempty {
ghcOptDynLinkMode = toFlag GhcStaticAndDynamic,
ghcOptHPCDir = hpcdir Hpc.Dyn
}
linkerOpts = mempty {
ghcOptLinkOptions = PD.ldOptions exeBi,
ghcOptLinkLibs = extraLibs exeBi,
ghcOptLinkLibPath = toNubListR $ extraLibDirs exeBi,
ghcOptLinkFrameworks = toNubListR $ PD.frameworks exeBi,
ghcOptInputFiles = toNubListR $
[exeDir </> x | x <- cObjs] ++ jsSrcs
}
replOpts = baseOpts {
ghcOptExtra = Internal.filterGhciFlags
(ghcOptExtra baseOpts)
<> replFlags
}
`mappend` linkerOpts
`mappend` mempty {
ghcOptMode = toFlag GhcModeInteractive,
ghcOptOptimisation = toFlag GhcNoOptimisation
}
commonOpts | withProfExe lbi = profOpts
| withDynExe lbi = dynOpts
| otherwise = staticOpts
compileOpts | useDynToo = dynTooOpts
| otherwise = commonOpts
withStaticExe = (not $ withProfExe lbi) && (not $ withDynExe lbi)
doingTH = usesTemplateHaskellOrQQ exeBi
useDynToo = dynamicTooSupported && isGhcjsDynamic
&& doingTH && withStaticExe && null (ghcjsSharedOptions exeBi)
compileTHOpts | isGhcjsDynamic = dynOpts
| otherwise = staticOpts
compileForTH
| forRepl = False
| useDynToo = False
| isGhcjsDynamic = doingTH && (withProfExe lbi || withStaticExe)
| otherwise = doingTH && (withProfExe lbi || withDynExe lbi)
linkOpts = commonOpts `mappend`
linkerOpts `mappend` mempty {
ghcOptLinkNoHsMain = toFlag (not isHaskellMain)
}
when compileForTH $
runGhcjsProg compileTHOpts { ghcOptNoLink = toFlag True
, ghcOptNumJobs = numJobs }
unless forRepl $
runGhcjsProg compileOpts { ghcOptNoLink = toFlag True
, ghcOptNumJobs = numJobs }
unless (null cSrcs || not nativeToo) $ do
info verbosity "Building C Sources..."
sequence_
[ do let opts = (Internal.componentCcGhcOptions verbosity implInfo lbi exeBi
clbi exeDir filename) `mappend` mempty {
ghcOptDynLinkMode = toFlag (if withDynExe lbi
then GhcDynamicOnly
else GhcStaticOnly),
ghcOptProfilingMode = toFlag (withProfExe lbi)
}
odir = fromFlag (ghcOptObjDir opts)
createDirectoryIfMissingVerbose verbosity True odir
runGhcjsProg opts
| filename <- cSrcs ]
when forRepl $ runGhcjsProg replOpts
unless forRepl $ do
info verbosity "Linking..."
runGhcjsProg linkOpts { ghcOptOutputFile = toFlag (targetDir </> exeNameReal) }
installLib :: Verbosity
-> LocalBuildInfo
-> FilePath
-> FilePath
-> FilePath
-> PackageDescription
-> Library
-> ComponentLocalBuildInfo
-> IO ()
installLib verbosity lbi targetDir dynlibTargetDir builtDir _pkg lib clbi = do
whenVanilla $ copyModuleFiles "js_hi"
whenProf $ copyModuleFiles "js_p_hi"
whenShared $ copyModuleFiles "js_dyn_hi"
whenVanilla $ installOrdinary builtDir targetDir $ toJSLibName vanillaLibName
whenProf $ installOrdinary builtDir targetDir $ toJSLibName profileLibName
whenShared $ installShared builtDir dynlibTargetDir $ toJSLibName sharedLibName
when (ghcjsNativeToo $ compiler lbi) $ do
whenVanilla $ copyModuleFiles "hi"
whenProf $ copyModuleFiles "p_hi"
whenShared $ copyModuleFiles "dyn_hi"
whenVanilla $ installOrdinaryNative builtDir targetDir vanillaLibName
whenProf $ installOrdinaryNative builtDir targetDir profileLibName
whenGHCi $ installOrdinaryNative builtDir targetDir ghciLibName
whenShared $ installSharedNative builtDir dynlibTargetDir sharedLibName
where
install isShared isJS srcDir dstDir name = do
let src = srcDir </> name
dst = dstDir </> name
createDirectoryIfMissingVerbose verbosity True dstDir
if isShared
then installExecutableFile verbosity src dst
else installOrdinaryFile verbosity src dst
when (stripLibs lbi && not isJS) $
Strip.stripLib verbosity
(hostPlatform lbi) (withPrograms lbi) dst
installOrdinary = install False True
installShared = install True True
installOrdinaryNative = install False False
installSharedNative = install True False
copyModuleFiles ext =
findModuleFiles [builtDir] [ext] (allLibModules lib clbi)
>>= installOrdinaryFiles verbosity targetDir
compiler_id = compilerId (compiler lbi)
uid = componentUnitId clbi
vanillaLibName = mkLibName uid
profileLibName = mkProfLibName uid
ghciLibName = Internal.mkGHCiLibName uid
sharedLibName = (mkSharedLibName (hostPlatform lbi) compiler_id) uid
hasLib = not $ null (allLibModules lib clbi)
&& null (cSources (libBuildInfo lib))
whenVanilla = when (hasLib && withVanillaLib lbi)
whenProf = when (hasLib && withProfLib lbi)
whenGHCi = when (hasLib && withGHCiLib lbi)
whenShared = when (hasLib && withSharedLib lbi)
installExe :: Verbosity
-> LocalBuildInfo
-> FilePath
-> FilePath
-> (FilePath, FilePath)
-> PackageDescription
-> Executable
-> IO ()
installExe verbosity lbi binDir buildPref
(progprefix, progsuffix) _pkg exe = do
createDirectoryIfMissingVerbose verbosity True binDir
let exeName' = unUnqualComponentName $ exeName exe
exeFileName = exeName'
fixedExeBaseName = progprefix ++ exeName' ++ progsuffix
installBinary dest = do
runDbProgram verbosity ghcjsProgram (withPrograms lbi) $
[ "--install-executable"
, buildPref </> exeName' </> exeFileName
, "-o", dest
] ++
case (stripExes lbi, lookupProgram stripProgram $ withPrograms lbi) of
(True, Just strip) -> ["-strip-program", programPath strip]
_ -> []
installBinary (binDir </> fixedExeBaseName)
libAbiHash :: Verbosity -> PackageDescription -> LocalBuildInfo
-> Library -> ComponentLocalBuildInfo -> IO String
libAbiHash verbosity _pkg_descr lbi lib clbi = do
let
libBi = libBuildInfo lib
comp = compiler lbi
platform = hostPlatform lbi
vanillaArgs =
(componentGhcOptions verbosity lbi libBi clbi (buildDir lbi))
`mappend` mempty {
ghcOptMode = toFlag GhcModeAbiHash,
ghcOptInputModules = toNubListR $ PD.exposedModules lib
}
profArgs = adjustExts "js_p_hi" "js_p_o" vanillaArgs `mappend` mempty {
ghcOptProfilingMode = toFlag True,
ghcOptExtra = ghcjsProfOptions libBi
}
ghcArgs | withVanillaLib lbi = vanillaArgs
| withProfLib lbi = profArgs
| otherwise = error "libAbiHash: Can't find an enabled library way"
(ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi)
hash <- getProgramInvocationOutput verbosity
(ghcInvocation ghcjsProg comp platform ghcArgs)
return (takeWhile (not . isSpace) hash)
adjustExts :: String -> String -> GhcOptions -> GhcOptions
adjustExts hiSuf objSuf opts =
opts `mappend` mempty {
ghcOptHiSuffix = toFlag hiSuf,
ghcOptObjSuffix = toFlag objSuf
}
registerPackage :: Verbosity
-> ProgramDb
-> PackageDBStack
-> InstalledPackageInfo
-> HcPkg.RegisterOptions
-> IO ()
registerPackage verbosity progdb packageDbs installedPkgInfo registerOptions =
HcPkg.register (hcPkgInfo progdb) verbosity packageDbs
installedPkgInfo registerOptions
componentGhcOptions :: Verbosity -> LocalBuildInfo
-> BuildInfo -> ComponentLocalBuildInfo -> FilePath
-> GhcOptions
componentGhcOptions verbosity lbi bi clbi odir =
let opts = Internal.componentGhcOptions verbosity implInfo lbi bi clbi odir
comp = compiler lbi
implInfo = getImplInfo comp
in opts { ghcOptExtra = ghcOptExtra opts `mappend` hcOptions GHCJS bi
}
ghcjsProfOptions :: BuildInfo -> [String]
ghcjsProfOptions bi =
hcProfOptions GHC bi `mappend` hcProfOptions GHCJS bi
ghcjsSharedOptions :: BuildInfo -> [String]
ghcjsSharedOptions bi =
hcSharedOptions GHC bi `mappend` hcSharedOptions GHCJS bi
isDynamic :: Compiler -> Bool
isDynamic = Internal.ghcLookupProperty "GHC Dynamic"
supportsDynamicToo :: Compiler -> Bool
supportsDynamicToo = Internal.ghcLookupProperty "Support dynamic-too"
findGhcjsGhcVersion :: Verbosity -> FilePath -> IO (Maybe Version)
findGhcjsGhcVersion verbosity pgm =
findProgramVersion "--numeric-ghc-version" id verbosity pgm
findGhcjsPkgGhcjsVersion :: Verbosity -> FilePath -> IO (Maybe Version)
findGhcjsPkgGhcjsVersion verbosity pgm =
findProgramVersion "--numeric-ghcjs-version" id verbosity pgm
hcPkgInfo :: ProgramDb -> HcPkg.HcPkgInfo
hcPkgInfo progdb = HcPkg.HcPkgInfo { HcPkg.hcPkgProgram = ghcjsPkgProg
, HcPkg.noPkgDbStack = False
, HcPkg.noVerboseFlag = False
, HcPkg.flagPackageConf = False
, HcPkg.supportsDirDbs = True
, HcPkg.requiresDirDbs = ver >= v7_10
, HcPkg.nativeMultiInstance = ver >= v7_10
, HcPkg.recacheMultiInstance = True
, HcPkg.suppressFilesCheck = True
}
where
v7_10 = mkVersion [7,10]
Just ghcjsPkgProg = lookupProgram ghcjsPkgProgram progdb
Just ver = programVersion ghcjsPkgProg
runCmd :: ProgramDb -> FilePath
-> (FilePath, FilePath, [String])
runCmd progdb exe =
( script
, programPath ghcjsProg
, programDefaultArgs ghcjsProg ++ programOverrideArgs ghcjsProg ++ ["--run"]
)
where
script = exe <.> "jsexe" </> "all" <.> "js"
Just ghcjsProg = lookupProgram ghcjsProgram progdb