{-# LANGUAGE CPP #-} module Distribution.Simple.GHCJS ( configure, getInstalledPackages, getPackageDBContents, buildLib, buildExe, replLib, replExe, startInterpreter, installLib, installExe, libAbiHash, hcPkgInfo, registerPackage, componentGhcOptions, getLibDir, isDynamic, getGlobalPackageDB, runCmd ) where import Distribution.Simple.GHC.ImplInfo ( getImplInfo, ghcjsVersionImplInfo ) import qualified Distribution.Simple.GHC.Internal as Internal import Distribution.PackageDescription as PD ( PackageDescription(..), BuildInfo(..), Executable(..) , Library(..), libModules, exeModules , hcOptions, hcProfOptions, hcSharedOptions , allExtensions ) import Distribution.InstalledPackageInfo ( InstalledPackageInfo ) import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo ( InstalledPackageInfo_(..) ) import Distribution.Simple.PackageIndex ( InstalledPackageIndex ) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) , LibraryName(..) ) import qualified Distribution.Simple.Hpc as Hpc import Distribution.Simple.InstallDirs hiding ( absoluteInstallDirs ) import Distribution.Simple.BuildPaths import Distribution.Simple.Utils import Distribution.Simple.Program ( Program(..), ConfiguredProgram(..), ProgramConfiguration , ProgramSearchPath , rawSystemProgramConf , rawSystemProgramStdout, rawSystemProgramStdoutConf , getProgramInvocationOutput , requireProgramVersion, requireProgram , userMaybeSpecifyPath, programPath , lookupProgram, addKnownPrograms , ghcjsProgram, ghcjsPkgProgram, c2hsProgram, hsc2hsProgram , ldProgram, haddockProgram, stripProgram ) 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 ( toFlag, fromFlag, configCoverage, configDistPref ) import qualified Distribution.Simple.Setup as Cabal ( Flag(..) ) import Distribution.Simple.Compiler ( CompilerFlavor(..), CompilerId(..), Compiler(..) , PackageDB(..), PackageDBStack, AbiTag(..) ) import Distribution.Version ( Version(..), anyVersion, orLaterVersion ) import Distribution.System ( Platform(..) ) import Distribution.Verbosity import Distribution.Utils.NubList ( overNubListR, toNubListR ) import Distribution.Text ( display ) import Language.Haskell.Extension ( Extension(..) , KnownExtension(..)) import Control.Monad ( unless, when ) import Data.Char ( isSpace ) import qualified Data.Map as M ( fromList ) #if __GLASGOW_HASKELL__ < 710 import Data.Monoid ( Monoid(..) ) #endif import System.Directory ( doesFileExist ) import System.FilePath ( (), (<.>), takeExtension, takeDirectory, replaceExtension, splitExtension ) configure :: Verbosity -> Maybe FilePath -> Maybe FilePath -> ProgramConfiguration -> IO (Compiler, Maybe Platform, ProgramConfiguration) configure verbosity hcPath hcPkgPath conf0 = do (ghcjsProg, ghcjsVersion, conf1) <- requireProgramVersion verbosity ghcjsProgram (orLaterVersion (Version [0,1] [])) (userMaybeSpecifyPath "ghcjs" hcPath conf0) Just ghcjsGhcVersion <- findGhcjsGhcVersion verbosity (programPath ghcjsProg) let implInfo = ghcjsVersionImplInfo ghcjsVersion ghcjsGhcVersion -- This is slightly tricky, we have to configure ghcjs first, then we use the -- location of ghcjs to help find ghcjs-pkg in the case that the user did not -- specify the location of ghc-pkg directly: (ghcjsPkgProg, ghcjsPkgVersion, conf2) <- requireProgramVersion verbosity ghcjsPkgProgram { programFindLocation = guessGhcjsPkgFromGhcjsPath ghcjsProg } anyVersion (userMaybeSpecifyPath "ghcjs-pkg" hcPkgPath conf1) Just ghcjsPkgGhcVersion <- findGhcjsPkgGhcVersion verbosity (programPath ghcjsPkgProg) when (ghcjsVersion /= ghcjsPkgVersion) $ die $ "Version mismatch between ghcjs and ghcjs-pkg: " ++ programPath ghcjsProg ++ " is version " ++ display ghcjsVersion ++ " " ++ programPath ghcjsPkgProg ++ " is version " ++ display ghcjsPkgVersion when (ghcjsGhcVersion /= ghcjsPkgGhcVersion) $ die $ "Version mismatch between ghcjs and ghcjs-pkg: " ++ programPath ghcjsProg ++ " was built with GHC version " ++ display ghcjsGhcVersion ++ " " ++ programPath ghcjsPkgProg ++ " was built with GHC version " ++ display ghcjsPkgGhcVersion -- be sure to use our versions of hsc2hs, c2hs, haddock and ghc let hsc2hsProgram' = hsc2hsProgram { programFindLocation = guessHsc2hsFromGhcjsPath ghcjsProg } c2hsProgram' = c2hsProgram { programFindLocation = guessC2hsFromGhcjsPath ghcjsProg } haddockProgram' = haddockProgram { programFindLocation = guessHaddockFromGhcjsPath ghcjsProg } conf3 = addKnownPrograms [ hsc2hsProgram', c2hsProgram', haddockProgram' ] conf2 languages <- Internal.getLanguages verbosity implInfo ghcjsProg extensions <- Internal.getExtensions verbosity implInfo ghcjsProg ghcInfo <- Internal.getGhcInfo verbosity implInfo ghcjsProg let ghcInfoMap = M.fromList ghcInfo let comp = Compiler { compilerId = CompilerId GHCJS ghcjsVersion, compilerAbiTag = AbiTag $ "ghc" ++ intercalate "_" (map show . versionBranch $ ghcjsGhcVersion), compilerCompat = [CompilerId GHC ghcjsGhcVersion], compilerLanguages = languages, compilerExtensions = extensions, compilerProperties = ghcInfoMap } compPlatform = Internal.targetPlatform ghcInfo -- configure gcc and ld let conf4 = if ghcjsNativeToo comp then Internal.configureToolchain implInfo ghcjsProg ghcInfoMap conf3 else conf3 return (comp, compPlatform, conf4) ghcjsNativeToo :: Compiler -> Bool ghcjsNativeToo = Internal.ghcLookupProperty "Native Too" guessGhcjsPkgFromGhcjsPath :: ConfiguredProgram -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath) guessGhcjsPkgFromGhcjsPath = guessToolFromGhcjsPath ghcjsPkgProgram guessHsc2hsFromGhcjsPath :: ConfiguredProgram -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath) guessHsc2hsFromGhcjsPath = guessToolFromGhcjsPath hsc2hsProgram guessC2hsFromGhcjsPath :: ConfiguredProgram -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath) guessC2hsFromGhcjsPath = guessToolFromGhcjsPath c2hsProgram guessHaddockFromGhcjsPath :: ConfiguredProgram -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath) guessHaddockFromGhcjsPath = guessToolFromGhcjsPath haddockProgram guessToolFromGhcjsPath :: Program -> ConfiguredProgram -> Verbosity -> ProgramSearchPath -> IO (Maybe 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 guessGhcjsVersioned = dir (toolname ++ "-ghcjs" ++ versionSuffix) <.> exeExtension guessGhcjs = dir (toolname ++ "-ghcjs") <.> exeExtension guessVersioned = dir (toolname ++ versionSuffix) <.> exeExtension guesses | null versionSuffix = [guessGhcjs, guessNormal] | otherwise = [guessGhcjsVersioned, guessGhcjs, guessVersioned, guessNormal] info verbosity $ "looking for tool " ++ toolname ++ " near compiler in " ++ dir exists <- mapM doesFileExist guesses case [ file | (file, True) <- zip guesses exists ] of -- If we can't find it near ghc, fall back to the usual -- method. [] -> programFindLocation tool verbosity searchpath (fp:_) -> do info verbosity $ "found " ++ toolname ++ " in " ++ fp return (Just fp) where takeVersionSuffix :: FilePath -> String takeVersionSuffix = reverse . takeWhile (`elem ` "0123456789.-") . reverse dropExeExtension :: FilePath -> FilePath dropExeExtension filepath = case splitExtension filepath of (filepath', extension) | extension == exeExtension -> filepath' | otherwise -> filepath -- | Given a single package DB, return all installed packages. getPackageDBContents :: Verbosity -> PackageDB -> ProgramConfiguration -> IO InstalledPackageIndex getPackageDBContents verbosity packagedb conf = do pkgss <- getInstalledPackages' verbosity [packagedb] conf toPackageIndex verbosity pkgss conf -- | Given a package DB stack, return all installed packages. getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration -> IO InstalledPackageIndex getInstalledPackages verbosity packagedbs conf = do checkPackageDbEnvVar checkPackageDbStack packagedbs pkgss <- getInstalledPackages' verbosity packagedbs conf index <- toPackageIndex verbosity pkgss conf return $! index toPackageIndex :: Verbosity -> [(PackageDB, [InstalledPackageInfo])] -> ProgramConfiguration -> IO InstalledPackageIndex toPackageIndex verbosity pkgss conf = 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 <- getLibDir' verbosity ghcjsProg let indices = [ PackageIndex.fromList (map (Internal.substTopDir topDir) pkgs) | (_, pkgs) <- pkgss ] return $! (mconcat indices) where Just ghcjsProg = lookupProgram ghcjsProgram conf checkPackageDbEnvVar :: IO () checkPackageDbEnvVar = Internal.checkPackageDbEnvVar "GHCJS" "GHCJS_PACKAGE_PATH" checkPackageDbStack :: PackageDBStack -> IO () checkPackageDbStack (GlobalPackageDB:rest) | GlobalPackageDB `notElem` rest = return () checkPackageDbStack rest | GlobalPackageDB `notElem` rest = die $ "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 _ = die $ "If the global package db is specified, it must be " ++ "specified first and cannot be specified multiple times" getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramConfiguration -> IO [(PackageDB, [InstalledPackageInfo])] getInstalledPackages' verbosity packagedbs conf = sequence [ do pkgs <- HcPkg.dump (hcPkgInfo conf) verbosity packagedb return (packagedb, pkgs) | packagedb <- packagedbs ] getLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath getLibDir verbosity lbi = (reverse . dropWhile isSpace . reverse) `fmap` rawSystemProgramStdoutConf verbosity ghcjsProgram (withPrograms lbi) ["--print-libdir"] getLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath getLibDir' verbosity ghcjsProg = (reverse . dropWhile isSpace . reverse) `fmap` rawSystemProgramStdout verbosity ghcjsProg ["--print-libdir"] -- | Return the 'FilePath' to the global GHC package database. getGlobalPackageDB :: Verbosity -> ConfiguredProgram -> IO FilePath getGlobalPackageDB verbosity ghcjsProg = (reverse . dropWhile isSpace . reverse) `fmap` rawSystemProgramStdout 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, replLib :: Verbosity -> Cabal.Flag (Maybe Int) -> PackageDescription -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> IO () buildLib = buildOrReplLib False replLib = buildOrReplLib True buildOrReplLib :: Bool -> Verbosity -> Cabal.Flag (Maybe Int) -> PackageDescription -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo -> IO () buildOrReplLib forRepl verbosity numJobs _pkg_descr lbi lib clbi = do libName <- case componentLibraries clbi of [libName] -> return libName [] -> die "No library name found when building library" _ -> die "Multiple library names found when building library" let 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) ifReplLib = when forRepl comp = compiler lbi implInfo = getImplInfo comp hole_insts = map (\(k,(p,n)) -> (k,(InstalledPackageInfo.packageKey p,n))) (instantiatedWith lbi) nativeToo = ghcjsNativeToo comp (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi) let runGhcjsProg = runGHC verbosity ghcjsProg comp libBi = libBuildInfo lib isGhcjsDynamic = isDynamic comp dynamicTooSupported = supportsDynamicToo comp doingTH = EnableExtension TemplateHaskell `elem` allExtensions libBi forceVanillaLib = doingTH && not isGhcjsDynamic forceSharedLib = doingTH && 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 = fromFlag $ configCoverage $ configFlags lbi -- Component name. Not 'libName' because that has the "HS" prefix -- that GHC gives Haskell libraries. cname = display $ PD.package $ localPkgDescr lbi distPref = fromFlag $ configDistPref $ configFlags lbi hpcdir way | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way cname | otherwise = mempty createDirectoryIfMissingVerbose verbosity True libTargetDir -- TODO: do we need to put hs-boot files into place for mutually recursive -- modules? let cObjs = map (`replaceExtension` objExtension) (cSources libBi) jsSrcs = jsSources libBi baseOpts = componentGhcOptions verbosity lbi libBi clbi libTargetDir linkJsLibOpts = mempty { ghcOptExtra = toNubListR $ [ "-link-js-lib" , (\(LibraryName l) -> l) libName , "-js-lib-outputdir", libTargetDir ] ++ concatMap (\x -> ["-js-lib-src",x]) jsSrcs } vanillaOptsNoJsLib = baseOpts `mappend` mempty { ghcOptMode = toFlag GhcModeMake, ghcOptNumJobs = numJobs, ghcOptPackageKey = toFlag (pkgKey lbi), ghcOptSigOf = hole_insts, ghcOptInputModules = toNubListR $ libModules lib, ghcOptHPCDir = hpcdir Hpc.Vanilla } vanillaOpts = vanillaOptsNoJsLib `mappend` linkJsLibOpts profOpts = adjustExts "p_hi" "p_o" vanillaOpts `mappend` mempty { ghcOptProfilingMode = toFlag True, ghcOptExtra = toNubListR $ ghcjsProfOptions libBi, ghcOptHPCDir = hpcdir Hpc.Prof } sharedOpts = adjustExts "dyn_hi" "dyn_o" vanillaOpts `mappend` mempty { ghcOptDynLinkMode = toFlag GhcDynamicOnly, ghcOptFPic = toFlag True, ghcOptExtra = toNubListR $ ghcjsSharedOptions libBi, ghcOptHPCDir = hpcdir Hpc.Dyn } linkerOpts = mempty { ghcOptLinkOptions = toNubListR $ PD.ldOptions libBi, ghcOptLinkLibs = toNubListR $ extraLibs libBi, ghcOptLinkLibPath = toNubListR $ extraLibDirs libBi, ghcOptLinkFrameworks = toNubListR $ PD.frameworks libBi, ghcOptInputFiles = toNubListR $ [libTargetDir x | x <- cObjs] ++ jsSrcs } replOpts = vanillaOptsNoJsLib { ghcOptExtra = overNubListR Internal.filterGhciFlags (ghcOptExtra vanillaOpts), 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 (libModules lib) && 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 -- 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. copyDirectoryRecursive verbosity dynDir vanillaDir _ -> return () else if isGhcjsDynamic then do shared; vanilla else do vanilla; shared whenProfLib (runGhcjsProg profOpts) -- build any C sources 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] -- 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. unless (null (libModules lib)) $ ifReplLib (runGhcjsProg replOpts) -- link: when (nativeToo && not forRepl) $ do info verbosity "Linking..." let cProfObjs = map (`replaceExtension` ("p_" ++ objExtension)) (cSources libBi) cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension)) (cSources libBi) cid = compilerId (compiler lbi) vanillaLibFilePath = libTargetDir mkLibName libName profileLibFilePath = libTargetDir mkProfLibName libName sharedLibFilePath = libTargetDir mkSharedLibName cid libName ghciLibFilePath = libTargetDir Internal.mkGHCiLibName libName hObjs <- Internal.getHaskellObjects implInfo lib lbi libTargetDir objExtension True hProfObjs <- if (withProfLib lbi) then Internal.getHaskellObjects implInfo lib lbi libTargetDir ("p_" ++ objExtension) True else return [] hSharedObjs <- if (withSharedLib lbi) then Internal.getHaskellObjects implInfo lib lbi 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 -- 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 = mempty { ghcOptShared = toFlag True, ghcOptDynLinkMode = toFlag GhcDynamicOnly, ghcOptInputFiles = toNubListR dynamicObjectFiles, ghcOptOutputFile = toFlag sharedLibFilePath, ghcOptPackageKey = toFlag (pkgKey lbi), ghcOptNoAutoLinkPackages = toFlag True, ghcOptPackageDBs = withPackageDB lbi, ghcOptPackages = toNubListR $ Internal.mkGhcOptPackages clbi, ghcOptLinkLibs = toNubListR $ 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 ldProg ghciLibFilePath ghciObjFiles whenSharedLib False $ runGhcjsProg ghcSharedLinkArgs -- | Start a REPL without loading any source files. startInterpreter :: Verbosity -> ProgramConfiguration -> Compiler -> PackageDBStack -> IO () startInterpreter verbosity conf comp packageDBs = do let replOpts = mempty { ghcOptMode = toFlag GhcModeInteractive, ghcOptPackageDBs = packageDBs } checkPackageDbStack packageDBs (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram conf runGHC verbosity ghcjsProg comp replOpts buildExe, replExe :: Verbosity -> Cabal.Flag (Maybe Int) -> PackageDescription -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo -> IO () buildExe = buildOrReplExe False replExe = buildOrReplExe True buildOrReplExe :: Bool -> Verbosity -> Cabal.Flag (Maybe Int) -> PackageDescription -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo -> IO () buildOrReplExe forRepl verbosity numJobs _pkg_descr lbi exe@Executable { exeName = exeName', modulePath = modPath } clbi = do (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi) let comp = compiler lbi implInfo = getImplInfo comp runGhcjsProg = runGHC verbosity ghcjsProg comp exeBi = buildInfo exe -- exeNameReal, the name that GHC really uses (with .exe on Windows) let exeNameReal = exeName' <.> (if takeExtension exeName' /= ('.':exeExtension) then exeExtension else "") let targetDir = (buildDir lbi) exeName' let exeDir = targetDir (exeName' ++ "-tmp") createDirectoryIfMissingVerbose verbosity True targetDir createDirectoryIfMissingVerbose verbosity True exeDir -- 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 = fromFlag $ configCoverage $ configFlags lbi distPref = fromFlag $ configDistPref $ configFlags lbi hpcdir way | isCoverageEnabled = toFlag $ Hpc.mixDir distPref way exeName' | otherwise = mempty -- build executables 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 toNubListR ["-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 = toNubListR $ ghcjsProfOptions exeBi, ghcOptHPCDir = hpcdir Hpc.Prof } dynOpts = adjustExts "dyn_hi" "dyn_o" baseOpts `mappend` mempty { ghcOptDynLinkMode = toFlag GhcDynamicOnly, ghcOptExtra = toNubListR $ 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 = toNubListR $ PD.ldOptions exeBi, ghcOptLinkLibs = toNubListR $ extraLibs exeBi, ghcOptLinkLibPath = toNubListR $ extraLibDirs exeBi, ghcOptLinkFrameworks = toNubListR $ PD.frameworks exeBi, ghcOptInputFiles = toNubListR $ [exeDir x | x <- cObjs] ++ jsSrcs } replOpts = baseOpts { ghcOptExtra = overNubListR Internal.filterGhciFlags (ghcOptExtra baseOpts) } -- 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. `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) -- 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 = EnableExtension TemplateHaskell `elem` allExtensions exeBi -- Should we use -dynamic-too instead of compiling twice? 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) } -- Build static/dynamic object files for TH, if needed. when compileForTH $ runGhcjsProg compileTHOpts { ghcOptNoLink = toFlag True , ghcOptNumJobs = numJobs } unless forRepl $ runGhcjsProg compileOpts { ghcOptNoLink = toFlag True , ghcOptNumJobs = numJobs } -- build any C sources 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 ] -- 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. when forRepl $ runGhcjsProg replOpts -- link: unless forRepl $ do info verbosity "Linking..." runGhcjsProg linkOpts { ghcOptOutputFile = toFlag (targetDir exeNameReal) } -- |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 lbi targetDir dynlibTargetDir builtDir _pkg lib clbi = do whenVanilla $ copyModuleFiles "js_hi" whenProf $ copyModuleFiles "js_p_hi" whenShared $ copyModuleFiles "js_dyn_hi" whenVanilla $ mapM_ (installOrdinary builtDir targetDir . toJSLibName) vanillaLibNames whenProf $ mapM_ (installOrdinary builtDir targetDir . toJSLibName) profileLibNames whenShared $ mapM_ (installShared builtDir dynlibTargetDir . toJSLibName) sharedLibNames when (ghcjsNativeToo $ compiler lbi) $ do -- copy .hi files over: whenVanilla $ copyModuleFiles "hi" whenProf $ copyModuleFiles "p_hi" whenShared $ copyModuleFiles "dyn_hi" -- copy the built library files over: whenVanilla $ mapM_ (installOrdinary builtDir targetDir) vanillaLibNames whenProf $ mapM_ (installOrdinary builtDir targetDir) profileLibNames whenGHCi $ mapM_ (installOrdinary builtDir targetDir) ghciLibNames whenShared $ mapM_ (installShared builtDir dynlibTargetDir) sharedLibNames where install isShared srcDir dstDir name = do let src = srcDir name dst = dstDir name createDirectoryIfMissingVerbose verbosity True dstDir if isShared then do when (stripLibs lbi) $ Strip.stripLib verbosity (hostPlatform lbi) (withPrograms lbi) src installExecutableFile verbosity src dst else installOrdinaryFile verbosity src dst installOrdinary = install False installShared = install True copyModuleFiles ext = findModuleFiles [builtDir] [ext] (libModules lib) >>= installOrdinaryFiles verbosity targetDir cid = compilerId (compiler lbi) libNames = componentLibraries clbi vanillaLibNames = map mkLibName libNames profileLibNames = map mkProfLibName libNames ghciLibNames = map Internal.mkGHCiLibName libNames sharedLibNames = map (mkSharedLibName cid) libNames hasLib = not $ null (libModules lib) && 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 -> InstallDirs FilePath -- ^Where to copy the files to -> FilePath -- ^Build location -> (FilePath, FilePath) -- ^Executable (prefix,suffix) -> PackageDescription -> Executable -> IO () installExe verbosity lbi installDirs buildPref (progprefix, progsuffix) _pkg exe = do let binDir = bindir installDirs createDirectoryIfMissingVerbose verbosity True binDir let exeFileName = exeName exe fixedExeBaseName = progprefix ++ exeName exe ++ progsuffix installBinary dest = do rawSystemProgramConf verbosity ghcjsProgram (withPrograms lbi) $ [ "--install-executable" , buildPref exeName exe 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 vanillaArgs = (componentGhcOptions verbosity lbi libBi clbi (buildDir lbi)) `mappend` mempty { ghcOptMode = toFlag GhcModeAbiHash, ghcOptPackageKey = toFlag (pkgKey lbi), ghcOptInputModules = toNubListR $ exposedModules lib } profArgs = adjustExts "js_p_hi" "js_p_o" vanillaArgs `mappend` mempty { ghcOptProfilingMode = toFlag True, ghcOptExtra = toNubListR (ghcjsProfOptions libBi) } ghcArgs = if withVanillaLib lbi then vanillaArgs else if withProfLib lbi then profArgs else error "libAbiHash: Can't find an enabled library way" -- (ghcjsProg, _) <- requireProgram verbosity ghcjsProgram (withPrograms lbi) getProgramInvocationOutput verbosity (ghcInvocation ghcjsProg comp ghcArgs) adjustExts :: String -> String -> GhcOptions -> GhcOptions adjustExts hiSuf objSuf opts = opts `mappend` mempty { ghcOptHiSuffix = toFlag hiSuf, ghcOptObjSuffix = toFlag objSuf } registerPackage :: Verbosity -> InstalledPackageInfo -> PackageDescription -> LocalBuildInfo -> Bool -> PackageDBStack -> IO () registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs = HcPkg.reregister (hcPkgInfo $ withPrograms lbi) verbosity packageDbs (Right installedPkgInfo) componentGhcOptions :: Verbosity -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo -> FilePath -> GhcOptions componentGhcOptions verbosity lbi bi clbi odir = let opts = Internal.componentGhcOptions verbosity lbi bi clbi odir in opts { ghcOptExtra = ghcOptExtra opts `mappend` toNubListR (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 findGhcjsPkgGhcVersion :: Verbosity -> FilePath -> IO (Maybe Version) findGhcjsPkgGhcVersion verbosity pgm = findProgramVersion "--numeric-ghc-version" id verbosity pgm -- ----------------------------------------------------------------------------- -- Registering hcPkgInfo :: ProgramConfiguration -> HcPkg.HcPkgInfo hcPkgInfo conf = HcPkg.HcPkgInfo { HcPkg.hcPkgProgram = ghcjsPkgProg , HcPkg.noPkgDbStack = False , HcPkg.noVerboseFlag = False , HcPkg.flagPackageConf = False , HcPkg.useSingleFileDb = v < [7,9] } where v = versionBranch ver Just ghcjsPkgProg = lookupProgram ghcjsPkgProgram conf Just ver = programVersion ghcjsPkgProg -- | 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 :: ProgramConfiguration -> FilePath -> (FilePath, FilePath, [String]) runCmd conf exe = ( script , programPath ghcjsProg , programDefaultArgs ghcjsProg ++ programOverrideArgs ghcjsProg ++ ["--run"] ) where script = exe <.> "jsexe" "all" <.> "js" Just ghcjsProg = lookupProgram ghcjsProgram conf