{-# LANGUAGE CPP #-} -- | Haste's main compiler driver. module Main where import Language.Haskell.GHC.Simple as GHC import Language.Haskell.GHC.Simple.PrimIface import Packages import GHC import Outputable (showPpr) import Platform import System.Environment (getArgs, lookupEnv, setEnv) import System.Exit import Data.List import System.IO.Unsafe import System.IO import System.FilePath import System.Directory (copyFile) import Control.Monad import qualified Control.Shell as Sh import qualified Data.ByteString.UTF8 as BS import Haste.Opts import Haste.Args import Haste.Config import Haste.Environment import Haste.Version import Haste.Module import Haste.CodeGen import Haste.AST as AST (Module) import Haste.Linker import Haste.JSLib logStr :: Config -> String -> IO () logStr cfg = when (verbose cfg) . hPutStrLn stderr main :: IO () main = do initUserPkgDB as <- getArgs lookupEnv "HASTE_PACKAGE_PATH" >>= setEnv "GHC_PACKAGE_PATH" . maybe "" id booting <- maybe False (const True) `fmap` lookupEnv "HASTE_BOOTING" let args = "-O2":concat [pkgs booting, as, ["-D__HASTE__="++show intVersion]] prof = "-prof" `elem` args case parseHasteFlags booting args as of Left act -> act Right (fs, mkConfig) -> do let hastecfg = mkConfig Haste.Config.defaultConfig ghccfg = mkGhcCfg hastecfg fs args (dfs, _) <- getDynFlagsForConfig ghccfg extralibdirs <- getExtraLibDirs dfs let cfg = mkLinkerCfg dfs extralibdirs . setShowOutputable dfs $ hastecfg res <- compileFold ghccfg (compJSMod cfg) finalize ([], []) [] case res of Failure _ _ -> do exitFailure Success (targets, mods) _ _ -> do when (performLink cfg) $ do if linkJSLib cfg then buildJSLib prof cfg (fst $ head targets) mods else mapM_ (uncurry $ linkAndMinify cfg) targets where getExtraLibDirs = fmap (concatMap libraryDirs) . readPackageConfigs pkgs booting = ["-no-global-package-db", "-no-user-package-db", "-package-db=" ++ pkgSysDir] ++ if booting && portableHaste then [] else ["-package-db=" ++ pkgUserDir] buildJSLib profiling cfg pkgkey mods = do let targetpath = targetLibPath cfg mods' = [moduleFilePath targetpath mn False | mn <- mods] libfile = maybe (pkgkey <.> "jsmod") id (linkJSLibFile cfg) profLibfile = reverse (drop 6 (reverse libfile)) ++ "_p.jslib" createJSLib libfile (BS.fromString pkgkey) mods' when profiling . void $ do copyFile libfile (profLibfile) finalize (targets, mods) m = do let meta = modMetadata m infile = maybe (mmInterfaceFile meta) id (mmSourceFile meta) modpair = (mmPackageKey meta, infile) if modIsTarget m then return (modpair : targets, mmName meta : mods) else return (targets, mmName meta : mods) mkGhcCfg cfg fs args = disableCodeGen $ GHC.defaultConfig { cfgGhcFlags = fs, cfgGhcLibDir = Just hasteGhcLibDir, cfgUseTargetsFromFlags = True, cfgUseGhcErrorLogger = True, cfgCacheDirectory = Just $ targetLibPath cfg, cfgCacheFileExt = "jsmod", cfgUpdateDynFlags = \dfs -> dfs { ghcMode = if "-c" `elem` args then OneShot else CompManager, settings = (settings dfs) { sTargetPlatform = (sTargetPlatform $ settings dfs) { platformArch = ArchX86, platformWordSize = 4 }, sPlatformConstants = (sPlatformConstants $ settings dfs) { pc_WORD_SIZE = 4, pc_CINT_SIZE = 4, pc_CLONG_SIZE = 4, pc_CLONG_LONG_SIZE = 8, pc_DOUBLE_SIZE = 8, pc_WORDS_BIGENDIAN = False } } } , cfgCustomPrimIface = Just (primOpInfo, primOpStrictness) } mkLinkerCfg dfs extralibdirs cfg = cfg { mainMod = Just (pkgKeyString $ modulePkgKey (mainModIs dfs), moduleNameString $ moduleName (mainModIs dfs)), libPaths = extralibdirs ++ libPaths cfg } setShowOutputable dfs cfg = cfg {showOutputable = showPpr dfs} -- | Primop info for custom GHC.Prim interface. primOpInfo :: PrimOp -> PrimOpInfo #include "primop-info-710.hs" primOpInfo _ = error "Nonexistent primop!" -- | Strictness info for custom GHC.Prim interface. primOpStrictness :: PrimOp -> Arity -> StrictSig #include "primop-stricts-710.hs" -- | Compile an STG module into a JS module and write it to its appropriate -- location according to the given config. compJSMod :: Config -> ModMetadata -> [StgBinding] -> IO AST.Module compJSMod cfg meta stg = do logStr cfg $ "Compiling " ++ myName ++ " into " ++ targetpath return $ generate cfg meta stg where boot = mmSourceIsHsBoot meta myName = mmName meta ++ if boot then " [boot]" else "" targetpath = targetLibPath cfg -- | Link a program starting from the 'mainMod' symbol of the given 'Config'. -- Minify the result if indicated by the config. linkAndMinify :: Config -> String -> FilePath -> IO () linkAndMinify cfg pkgkey infile = do logStr cfg $ "Linking target " ++ outfile link cfg (BS.fromString pkgkey) infile case useGoogleClosure cfg of Just clopath -> closurize cfg clopath outfile _ -> return () when (outputHTML cfg) $ do res <- Sh.shell $ Sh.withCustomTempFile Sh.TextMode "." $ \tmp h -> do prog <- Sh.input outfile Sh.hPutStrLn h (htmlSkeleton outfile prog) Sh.liftIO $ hClose h Sh.mv tmp outfile case res of Right () -> return () Left err -> error $ "Couldn't output HTML file: " ++ Sh.exitString err where outfile = outFile cfg cfg infile -- | Produce an HTML skeleton with an embedded JS program. htmlSkeleton :: FilePath -> String -> String htmlSkeleton filename prog = concat [ "", "
", "