Elm-0.10: compiler/Compiler.hs
{-# LANGUAGE DeriveDataTypeable #-}
module Main where
import Control.Monad
import qualified Data.Map as Map
import qualified Data.List as List
import qualified Data.Binary as Binary
import Data.Version (showVersion)
import System.Console.CmdArgs hiding (program)
import System.Directory
import System.Exit
import System.FilePath
import System.IO
import GHC.Conc
import Text.Blaze.Html.Renderer.Pretty (renderHtml)
import qualified Data.ByteString.Lazy.Char8 as BS
import qualified Data.ByteString.Lazy as L
import qualified Metadata.Prelude as Prelude
import qualified Transform.Canonicalize as Canonical
import SourceSyntax.Module
import Parse.Module (getModuleName)
import Initialize (buildFromSource, getSortedDependencies)
import Generate.JavaScript (jsModule)
import Generate.Html (createHtml, JSSource(..))
import Paths_Elm
import SourceSyntax.PrettyPrint (pretty, variable)
import Text.PrettyPrint as P
import qualified Type.Type as Type
import qualified Type.Alias as Alias
data Flags =
Flags { make :: Bool
, files :: [FilePath]
, runtime :: Maybe FilePath
, only_js :: Bool
, print_types :: Bool
, print_program :: Bool
, scripts :: [FilePath]
, no_prelude :: Bool
, cache_dir :: FilePath
, build_dir :: FilePath
, src_dir :: [FilePath]
}
deriving (Data,Typeable,Show,Eq)
flags = Flags
{ files = def &= args &= typ "FILES"
, make = False
&= help "automatically compile dependencies."
, only_js = False
&= help "Compile only to JavaScript."
, no_prelude = False
&= help "Do not import Prelude by default, used only when compiling standard libraries."
, scripts = [] &= typFile
&= help "Load JavaScript files in generated HTML. Files will be included in the given order."
, runtime = Nothing &= typFile
&= help "Specify a custom location for Elm's runtime system."
, cache_dir = "cache" &= typFile
&= help "Directory for files cached to make builds faster. Defaults to cache/ directory."
, build_dir = "build" &= typFile
&= help "Directory for generated HTML and JS files. Defaults to build/ directory."
, src_dir = ["."] &= typFile
&= help "Additional source directories besides project root. Searched when using --make"
, print_types = False
&= help "Print out infered types of top-level definitions."
, print_program = False
&= help "Print out an internal representation of a program."
} &= help "Compile Elm programs to HTML, CSS, and JavaScript."
&= helpArg [explicit, name "help", name "h"]
&= versionArg [explicit, name "version", name "v", summary (showVersion version)]
&= summary ("The Elm Compiler " ++ showVersion version ++ ", (c) Evan Czaplicki 2011-2013")
main :: IO ()
main = do setNumCapabilities =<< getNumProcessors
compileArgs =<< cmdArgs flags
compileArgs :: Flags -> IO ()
compileArgs flags =
case files flags of
[] -> putStrLn "Usage: elm [OPTIONS] [FILES]\nFor more help: elm --help"
fs -> mapM_ (build flags) fs
buildPath :: Flags -> FilePath -> String -> FilePath
buildPath flags filePath ext = build_dir flags </> replaceExtension filePath ext
cachePath :: Flags -> FilePath -> String -> FilePath
cachePath flags filePath ext = cache_dir flags </> replaceExtension filePath ext
elmo :: Flags -> FilePath -> FilePath
elmo flags filePath = cachePath flags filePath "elmo"
elmi :: Flags -> FilePath -> FilePath
elmi flags filePath = cachePath flags filePath "elmi"
buildFile :: Flags -> Int -> Int -> Interfaces -> FilePath -> IO (String,ModuleInterface)
buildFile flags moduleNum numModules interfaces filePath =
do compiled <- alreadyCompiled
case compiled of
False -> compile
True -> do
handle <- openBinaryFile (elmi flags filePath) ReadMode
bits <- L.hGetContents handle
let info :: (String, ModuleInterface)
info = Binary.decode bits
L.length bits `seq` hClose handle
return info
where
alreadyCompiled :: IO Bool
alreadyCompiled = do
existsi <- doesFileExist (elmi flags filePath)
existso <- doesFileExist (elmo flags filePath)
if not existsi || not existso
then return False
else do tsrc <- getModificationTime filePath
tint <- getModificationTime (elmo flags filePath)
return (tsrc <= tint)
number :: String
number = "[" ++ show moduleNum ++ " of " ++ show numModules ++ "]"
compile :: IO (String,ModuleInterface)
compile = do
source <- readFile filePath
let name = case getModuleName source of
Just n -> n
Nothing -> "Main"
putStrLn $ concat [ number, " Compiling ", name
, replicate (max 1 (20 - length name)) ' '
, "( " ++ filePath ++ " )" ]
createDirectoryIfMissing True (cache_dir flags)
createDirectoryIfMissing True (build_dir flags)
metaModule <-
case buildFromSource (no_prelude flags) interfaces source of
Left errors -> do
mapM print (List.intersperse (P.text " ") errors)
exitFailure
Right modul -> do
case print_program flags of
False -> return ()
True -> print . pretty $ program modul
return modul
when (print_types flags) (printTypes interfaces metaModule)
let interface = Canonical.interface name $ ModuleInterface {
iTypes = types metaModule,
iAdts = datatypes metaModule,
iAliases = aliases metaModule,
iFixities = fixities metaModule
}
createDirectoryIfMissing True . dropFileName $ elmi flags filePath
handle <- openBinaryFile (elmi flags filePath) WriteMode
L.hPut handle (Binary.encode (name,interface))
hClose handle
writeFile (elmo flags filePath) (jsModule metaModule)
return (name,interface)
printTypes interfaces metaModule = do
putStrLn ""
let rules = Alias.rules interfaces metaModule
forM_ (Map.toList $ types metaModule) $ \(n,t) -> do
print $ variable n <+> P.text ":" <+> pretty (Alias.realias rules t)
putStrLn ""
getRuntime :: Flags -> IO FilePath
getRuntime flags =
case runtime flags of
Just fp -> return fp
Nothing -> getDataFileName "elm-runtime.js"
build :: Flags -> FilePath -> IO ()
build flags rootFile = do
let noPrelude = no_prelude flags
files <- if make flags then getSortedDependencies (src_dir flags) noPrelude rootFile
else return [rootFile]
let ifaces = if noPrelude then Map.empty else Prelude.interfaces
(moduleName, interfaces) <- buildFiles flags (length files) ifaces "" files
js <- foldM appendToOutput BS.empty files
(extension, code) <- case only_js flags of
True -> do
putStr "Generating JavaScript ... "
return ("js", js)
False -> do
putStr "Generating HTML ... "
rtsPath <- getRuntime flags
return ("html", BS.pack . renderHtml $
createHtml rtsPath (takeBaseName rootFile) (sources js) moduleName "")
let targetFile = buildPath flags rootFile extension
createDirectoryIfMissing True (takeDirectory targetFile)
BS.writeFile targetFile code
putStrLn "Done"
where
appendToOutput :: BS.ByteString -> FilePath -> IO BS.ByteString
appendToOutput js filePath =
do src <- BS.readFile (elmo flags filePath)
return (BS.append src js)
sources js = map Link (scripts flags) ++ [ Source js ]
buildFiles :: Flags -> Int -> Interfaces -> String -> [FilePath] -> IO (String, Interfaces)
buildFiles _ _ interfaces moduleName [] = return (moduleName, interfaces)
buildFiles flags numModules interfaces _ (filePath:rest) = do
(name,interface) <- buildFile flags (numModules - length rest) numModules interfaces filePath
let interfaces' = Map.insert name interface interfaces
buildFiles flags numModules interfaces' name rest