module Main (main) where
import GHC
import GHC.Paths (libdir)
import HscMain
import Outputable (showPpr)
import DynFlags hiding (flags)
import TidyPgm
import CorePrep
import CoreToStg
import StgSyn (StgBinding)
import HscTypes
import Module (moduleNameSlashes)
import GhcMonad
import System.Environment (getArgs)
import Control.Monad (when)
import Haste
import Haste.Util (showOutputable)
import Haste.Environment
import Haste.Version
import Args
import ArgSpecs
import System.FilePath (addExtension)
import System.IO
import System.Process (runProcess, waitForProcess, rawSystem)
import System.Exit (ExitCode (..), exitFailure)
import System.Directory (renameFile)
import Filesystem (getModified, isFile)
import Data.Version
import Data.List
import Data.String
import qualified Data.ByteString.Char8 as B
logStr :: String -> IO ()
logStr = hPutStrLn stderr
rebootMsg :: String
rebootMsg = "Haste needs to be rebooted; please run haste-boot"
printInfo :: IO ()
printInfo = do
ghc <- runGhc (Just libdir) getSessionDynFlags
putStrLn $ formatInfo $ compilerInfo ghc
where
formatInfo = ('[' :) . tail . unlines . (++ ["]"]) . map ((',' :) . show)
-- | Check for arguments concerning version info and the like, and act on them.
-- Return True if the compiler should run afterwards.
preArgs :: [String] -> IO Bool
preArgs args
| "--numeric-version" `elem` args =
putStrLn ghcVersion >> return False
| "--info" `elem` args =
printInfo >> return False
| "--version" `elem` args =
putStrLn (showVersion hasteVersion) >> return False
| "--supported-extensions" `elem` args =
(putStrLn $ unlines $ supportedLanguagesAndExtensions) >> return False
| "--supported-languages" `elem` args =
(putStrLn $ unlines $ supportedLanguagesAndExtensions) >> return False
| otherwise =
return True
main :: IO ()
main = do
args <- fmap (++ packageDBArgs) getArgs
runCompiler <- preArgs args
when (runCompiler) $ do
if allSupported args
then hasteMain args
else callVanillaGHC args
where
packageDBArgs = ["-no-global-package-db",
"-no-user-package-db",
"-package-db " ++ pkgDir]
-- | Call vanilla GHC; used for boot files and the like.
callVanillaGHC :: [String] -> IO ()
callVanillaGHC args = do
_ <- rawSystem "ghc" (filter noHasteArgs args)
return ()
where
noHasteArgs x =
x /= "--libinstall" &&
x /= "--unbooted"
-- | Run the compiler if everything's satisfactorily booted, otherwise whine
-- and exit.
hasteMain :: [String] -> IO ()
hasteMain args
| not needsReboot =
compiler ("-O2" : args)
| otherwise = do
if "--unbooted" `elem` args
then compiler (filter (/= "--unbooted") ("-O2" : args))
else fail rebootMsg
-- | Determine whether all given args are handled by Haste, or if we need to
-- ship them off to vanilla GHC instead.
allSupported :: [String] -> Bool
allSupported args =
and args'
where
args' = [not $ any (`isSuffixOf` a) someoneElsesProblems | a <- args]
someoneElsesProblems = [".c", ".cmm", ".hs-boot", ".lhs-boot"]
-- | The main compiler driver.
compiler :: [String] -> IO ()
compiler cmdargs = do
let cmdargs' | "-debug" `elem` cmdargs = "--trace-primops":cmdargs
| otherwise = cmdargs
argRes = handleArgs defConfig argSpecs cmdargs'
usedGhcMode = if "-c" `elem` cmdargs then OneShot else CompManager
case argRes of
-- We got --help as an argument - display help and exit.
Left help -> putStrLn help
-- We got a config and a set of arguments for GHC; let's compile!
Right (cfg, ghcargs) -> do
-- Parse static flags, but ignore profiling.
(ghcargs', _) <- parseStaticFlags [noLoc a | a <- ghcargs, a /= "-prof"]
runGhc (Just libdir) $ handleSourceError (const $ liftIO exitFailure) $ do
-- Handle dynamic GHC flags. Make sure __HASTE__ is #defined.
let args = "-D__HASTE__" : map unLoc ghcargs'
dynflags <- getSessionDynFlags
(dynflags', files, _) <- parseDynamicFlags dynflags (map noLoc args)
_ <- setSessionDynFlags dynflags' {ghcLink = NoLink,
ghcMode = usedGhcMode}
-- Prepare and compile all needed targets.
let files' = map unLoc files
printErrorAndDie e = printException e >> liftIO exitFailure
deps <- handleSourceError printErrorAndDie $ do
ts <- mapM (flip guessTarget Nothing) files'
setTargets ts
_ <- load LoadAllTargets
depanal [] False
mapM_ (compile cfg dynflags') deps
-- Link everything together into a .js file.
when (performLink cfg) $ liftIO $ do
flip mapM_ files' $ \file -> do
logStr $ "Linking " ++ outFile cfg file
let pkgid = showPpr dynflags $ thisPackage dynflags'
link cfg pkgid file
case useGoogleClosure cfg of
Just clopath -> closurize clopath $ outFile cfg file
_ -> return ()
-- | Do everything required to get a list of STG bindings out of a module.
prepare :: (GhcMonad m) => DynFlags -> ModSummary -> m ([StgBinding], ModuleName)
prepare dynflags theMod = do
env <- getSession
let name = moduleName $ ms_mod theMod
pgm <- parseModule theMod
>>= typecheckModule
>>= desugarModule
>>= liftIO . hscSimplify env . coreModule
>>= liftIO . tidyProgram env
>>= prepPgm env . fst
>>= liftIO . coreToStg dynflags
return (pgm, name)
where
prepPgm env tidy = liftIO $ do
prepd <- corePrepPgm dynflags env (cg_binds tidy) (cg_tycons tidy)
return prepd
-- | Run Google Closure on a file.
closurize :: FilePath -> FilePath -> IO ()
closurize cloPath file = do
logStr $ "Running the Google Closure compiler on " ++ file ++ "..."
let cloFile = file `addExtension` ".clo"
cloOut <- openFile cloFile WriteMode
build <- runProcess "java"
["-jar", cloPath, "--compilation_level", "ADVANCED_OPTIMIZATIONS",
"--jscomp_off", "uselessCode", "--jscomp_off", "globalThis",
file]
Nothing
Nothing
Nothing
(Just cloOut)
Nothing
res <- waitForProcess build
hClose cloOut
case res of
ExitFailure n ->
fail $ "Couldn't execute Google Closure compiler: " ++ show n
ExitSuccess ->
renameFile cloFile file
-- | Generate a unique fingerprint for the compiler, command line arguments,
-- etc.
genFingerprint :: String -> FilePath -> [String] -> Fingerprint
genFingerprint modname targetpath args =
{- md5sum $ B.pack $ -} show [
modname,
targetpath,
show bootVersion,
show args
]
-- | Compile a module into a .jsmod intermediate file.
compile :: (GhcMonad m) => Config -> DynFlags -> ModSummary -> m ()
compile cfg dynflags modSummary = do
fp <- liftIO $ fmap (genFingerprint myName targetpath) getArgs
should_recompile <- liftIO $ shouldRecompile fp modSummary targetpath
when should_recompile $ do
case ms_hsc_src modSummary of
HsBootFile -> liftIO $ logStr $ "Skipping boot " ++ myName
_ -> do
(pgm, name) <- prepare dynflags modSummary
let pkgid = showPpr dynflags $ modulePackageId $ ms_mod modSummary
theCode = generate cfg fp pkgid name pgm
liftIO $ logStr $ "Compiling " ++ myName ++ " into " ++ targetpath
liftIO $ writeModule targetpath theCode
where
myName = moduleNameString $ moduleName $ ms_mod modSummary
targetpath = targetLibPath cfg
shouldRecompile :: Fingerprint -> ModSummary -> FilePath -> IO Bool
shouldRecompile _ _ _ = return True
{-
shouldRecompile fp ms path = do
exists <- isFile fpPath
if exists
then do
fp' <- readModuleFingerprint path pkgid modname
jsmtime <- getModified fpPath
return $ ms_hs_date ms > jsmtime || fp /= fp'
else do
return True
where
modname = moduleNameString $ ms_mod_name ms
file = moduleNameSlashes (ms_mod_name ms) ++ ".jsmod"
path' = path ++ "/" ++ pkgid ++ "/" ++ file
pkgid = showOutputable $ modulePackageId $ ms_mod ms
fpPath = fromString path'
-}