2012-06-14 08:43:04 +00:00
|
|
|
{-# LANGUAGE DeriveDataTypeable #-}
|
2012-04-19 06:32:10 +00:00
|
|
|
module Main where
|
|
|
|
|
2013-07-20 16:53:15 +00:00
|
|
|
import Control.Monad
|
2013-06-05 07:44:04 +00:00
|
|
|
import qualified Data.Map as Map
|
2013-07-20 16:53:15 +00:00
|
|
|
import qualified Data.List as List
|
2013-07-25 18:53:22 +00:00
|
|
|
import qualified Data.Binary as Binary
|
2012-10-03 07:17:09 +00:00
|
|
|
import Data.Version (showVersion)
|
2013-07-21 20:49:42 +00:00
|
|
|
import System.Console.CmdArgs hiding (program)
|
2013-06-05 07:44:04 +00:00
|
|
|
import System.Directory
|
2013-03-14 08:04:51 +00:00
|
|
|
import System.Exit
|
2012-11-25 22:08:10 +00:00
|
|
|
import System.FilePath
|
2013-08-06 07:36:07 +00:00
|
|
|
import System.IO
|
2013-08-03 05:20:55 +00:00
|
|
|
import GHC.Conc
|
2013-07-20 16:53:15 +00:00
|
|
|
|
2013-06-05 07:44:04 +00:00
|
|
|
import qualified Text.Blaze.Html.Renderer.Pretty as Pretty
|
|
|
|
import qualified Text.Blaze.Html.Renderer.String as Normal
|
2012-09-11 09:53:45 +00:00
|
|
|
import qualified Text.Jasmine as JS
|
|
|
|
import qualified Data.ByteString.Lazy.Char8 as BS
|
2013-08-06 07:36:07 +00:00
|
|
|
import qualified Data.ByteString.Lazy as L
|
2012-09-11 09:53:45 +00:00
|
|
|
|
2013-07-25 18:53:22 +00:00
|
|
|
import qualified Metadata.Prelude as Prelude
|
2013-07-29 09:59:55 +00:00
|
|
|
import qualified Transform.Canonicalize as Canonical
|
2013-06-14 05:59:14 +00:00
|
|
|
import SourceSyntax.Module
|
2013-08-07 04:20:08 +00:00
|
|
|
import Parse.Module (getModuleName)
|
2013-08-02 00:22:44 +00:00
|
|
|
import Initialize (buildFromSource, getSortedDependencies)
|
2013-06-14 05:59:14 +00:00
|
|
|
import Generate.JavaScript (jsModule)
|
|
|
|
import Generate.Html (createHtml, JSStyle(..), JSSource(..))
|
2012-06-14 08:43:04 +00:00
|
|
|
import Paths_Elm
|
|
|
|
|
2013-07-23 13:43:21 +00:00
|
|
|
import SourceSyntax.PrettyPrint (pretty, variable)
|
2013-07-20 16:53:15 +00:00
|
|
|
import Text.PrettyPrint as P
|
|
|
|
import qualified Type.Type as Type
|
2013-08-22 02:08:03 +00:00
|
|
|
import qualified Type.Alias as Alias
|
2013-07-20 16:53:15 +00:00
|
|
|
|
2013-06-05 07:44:04 +00:00
|
|
|
data Flags =
|
|
|
|
Flags { make :: Bool
|
|
|
|
, files :: [FilePath]
|
|
|
|
, runtime :: Maybe FilePath
|
|
|
|
, only_js :: Bool
|
2013-07-21 04:08:08 +00:00
|
|
|
, print_types :: Bool
|
2013-07-21 20:49:42 +00:00
|
|
|
, print_program :: Bool
|
2013-06-05 07:44:04 +00:00
|
|
|
, scripts :: [FilePath]
|
|
|
|
, no_prelude :: Bool
|
|
|
|
, minify :: Bool
|
2013-08-07 01:34:23 +00:00
|
|
|
, cache_dir :: FilePath
|
|
|
|
, build_dir :: FilePath
|
2013-06-05 07:44:04 +00:00
|
|
|
}
|
2012-06-14 08:43:04 +00:00
|
|
|
deriving (Data,Typeable,Show,Eq)
|
|
|
|
|
2013-06-05 07:44:04 +00:00
|
|
|
flags = Flags
|
|
|
|
{ make = False
|
|
|
|
&= help "automatically compile dependencies."
|
|
|
|
, files = def &= args &= typ "FILES"
|
|
|
|
, runtime = Nothing &= typFile
|
|
|
|
&= help "Specify a custom location for Elm's runtime system."
|
|
|
|
, only_js = False
|
|
|
|
&= help "Compile only to JavaScript."
|
2013-07-21 04:08:08 +00:00
|
|
|
, print_types = False
|
|
|
|
&= help "Print out infered types of top-level definitions."
|
2013-07-21 20:49:42 +00:00
|
|
|
, print_program = False
|
|
|
|
&= help "Print out an internal representation of a program."
|
2013-06-05 07:44:04 +00:00
|
|
|
, scripts = [] &= typFile
|
|
|
|
&= help "Load JavaScript files in generated HTML. Files will be included in the given order."
|
|
|
|
, no_prelude = False
|
|
|
|
&= help "Do not import Prelude by default, used only when compiling standard libraries."
|
|
|
|
, minify = False
|
2013-06-05 21:22:30 +00:00
|
|
|
&= help "Minify generated JavaScript and HTML"
|
2013-08-07 01:34:23 +00:00
|
|
|
, 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."
|
2013-06-05 07:44:04 +00:00
|
|
|
} &= help "Compile Elm programs to HTML, CSS, and JavaScript."
|
|
|
|
&= summary ("The Elm Compiler " ++ showVersion version ++ ", (c) Evan Czaplicki")
|
|
|
|
|
|
|
|
main :: IO ()
|
2013-08-03 05:20:55 +00:00
|
|
|
main = do setNumCapabilities =<< getNumProcessors
|
|
|
|
compileArgs =<< cmdArgs flags
|
2013-06-05 07:44:04 +00:00
|
|
|
|
|
|
|
compileArgs :: Flags -> IO ()
|
|
|
|
compileArgs flags =
|
2013-06-05 21:22:30 +00:00
|
|
|
case files flags of
|
|
|
|
[] -> putStrLn "Usage: elm [OPTIONS] [FILES]\nFor more help: elm --help"
|
|
|
|
fs -> mapM_ (build flags) fs
|
2013-06-05 07:44:04 +00:00
|
|
|
|
|
|
|
|
2013-08-07 01:34:23 +00:00
|
|
|
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
|
2013-06-10 06:36:59 +00:00
|
|
|
|
|
|
|
elmo :: Flags -> FilePath -> FilePath
|
2013-08-07 01:34:23 +00:00
|
|
|
elmo flags filePath = cachePath flags filePath "elmo"
|
2013-06-10 06:36:59 +00:00
|
|
|
|
2013-07-31 14:42:31 +00:00
|
|
|
elmi :: Flags -> FilePath -> FilePath
|
2013-08-07 01:34:23 +00:00
|
|
|
elmi flags filePath = cachePath flags filePath "elmi"
|
2013-06-10 06:36:59 +00:00
|
|
|
|
2013-06-05 07:44:04 +00:00
|
|
|
|
2013-08-07 04:20:08 +00:00
|
|
|
buildFile :: Flags -> Int -> Int -> Interfaces -> FilePath -> IO (String,ModuleInterface)
|
2013-07-21 05:14:13 +00:00
|
|
|
buildFile flags moduleNum numModules interfaces filePath =
|
2013-06-05 07:44:04 +00:00
|
|
|
do compiled <- alreadyCompiled
|
2013-08-06 07:36:07 +00:00
|
|
|
case compiled of
|
|
|
|
False -> compile
|
|
|
|
True -> do
|
|
|
|
handle <- openBinaryFile (elmi flags filePath) ReadMode
|
|
|
|
bits <- L.hGetContents handle
|
2013-08-07 04:20:08 +00:00
|
|
|
let info :: (String, ModuleInterface)
|
|
|
|
info = Binary.decode bits
|
2013-08-06 07:36:07 +00:00
|
|
|
L.length bits `seq` hClose handle
|
2013-08-07 04:20:08 +00:00
|
|
|
return info
|
2013-06-05 07:44:04 +00:00
|
|
|
where
|
|
|
|
alreadyCompiled :: IO Bool
|
|
|
|
alreadyCompiled = do
|
2013-07-26 22:39:40 +00:00
|
|
|
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)
|
2013-06-05 07:44:04 +00:00
|
|
|
|
|
|
|
number :: String
|
|
|
|
number = "[" ++ show moduleNum ++ " of " ++ show numModules ++ "]"
|
|
|
|
|
2013-08-07 04:20:08 +00:00
|
|
|
compile :: IO (String,ModuleInterface)
|
2013-06-05 07:44:04 +00:00
|
|
|
compile = do
|
2013-08-07 04:20:08 +00:00
|
|
|
source <- readFile filePath
|
|
|
|
let name = case getModuleName source of
|
|
|
|
Just n -> n
|
2013-08-07 04:40:54 +00:00
|
|
|
Nothing -> "Main"
|
2013-08-03 05:20:55 +00:00
|
|
|
putStrLn $ concat [ number, " Compiling ", name
|
|
|
|
, replicate (max 1 (20 - length name)) ' '
|
|
|
|
, "( " ++ filePath ++ " )" ]
|
2013-08-07 04:20:08 +00:00
|
|
|
|
2013-08-07 01:34:23 +00:00
|
|
|
createDirectoryIfMissing True (cache_dir flags)
|
|
|
|
createDirectoryIfMissing True (build_dir flags)
|
2013-07-21 04:08:08 +00:00
|
|
|
metaModule <-
|
2013-07-29 09:59:55 +00:00
|
|
|
case buildFromSource (no_prelude flags) interfaces source of
|
2013-08-03 18:39:56 +00:00
|
|
|
Left errors -> do
|
|
|
|
mapM print (List.intersperse (P.text " ") errors)
|
|
|
|
exitFailure
|
|
|
|
Right modul -> do
|
2013-07-29 11:21:34 +00:00
|
|
|
case print_program flags of
|
|
|
|
False -> return ()
|
|
|
|
True -> print . pretty $ program modul
|
2013-07-22 12:41:55 +00:00
|
|
|
return modul
|
2013-07-21 20:49:42 +00:00
|
|
|
|
2013-08-22 02:08:03 +00:00
|
|
|
if print_types flags then printTypes interfaces metaModule else return ()
|
2013-07-29 09:59:55 +00:00
|
|
|
let interface = Canonical.interface name $ ModuleInterface {
|
2013-08-21 21:23:11 +00:00
|
|
|
iTypes = types metaModule,
|
2013-07-26 13:06:35 +00:00
|
|
|
iAdts = datatypes metaModule,
|
|
|
|
iAliases = aliases metaModule
|
2013-07-21 04:08:08 +00:00
|
|
|
}
|
2013-07-26 22:39:40 +00:00
|
|
|
createDirectoryIfMissing True . dropFileName $ elmi flags filePath
|
2013-08-06 07:36:07 +00:00
|
|
|
handle <- openBinaryFile (elmi flags filePath) WriteMode
|
|
|
|
L.hPut handle (Binary.encode (name,interface))
|
|
|
|
hClose handle
|
2013-07-28 00:24:17 +00:00
|
|
|
writeFile (elmo flags filePath) (jsModule metaModule)
|
2013-08-07 04:20:08 +00:00
|
|
|
return (name,interface)
|
2013-07-20 16:53:15 +00:00
|
|
|
|
2013-08-22 02:08:03 +00:00
|
|
|
printTypes interfaces metaModule = do
|
2013-07-21 05:14:13 +00:00
|
|
|
putStrLn ""
|
2013-08-22 02:08:03 +00:00
|
|
|
let rules = Alias.rules interfaces metaModule
|
2013-07-21 05:14:13 +00:00
|
|
|
forM_ (Map.toList $ types metaModule) $ \(n,t) -> do
|
2013-08-22 02:08:03 +00:00
|
|
|
print $ variable n <+> P.text ":" <+> pretty (Alias.realias rules t)
|
2013-07-21 05:14:13 +00:00
|
|
|
putStrLn ""
|
2013-06-05 07:44:04 +00:00
|
|
|
|
|
|
|
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
|
2013-07-28 00:24:17 +00:00
|
|
|
let noPrelude = no_prelude flags
|
2013-08-02 00:22:44 +00:00
|
|
|
files <- if make flags then getSortedDependencies noPrelude rootFile else return [rootFile]
|
2013-07-28 00:24:17 +00:00
|
|
|
let ifaces = if noPrelude then Map.empty else Prelude.interfaces
|
2013-08-06 20:41:17 +00:00
|
|
|
(moduleName, interfaces) <- buildFiles flags (length files) ifaces "" files
|
2013-06-05 07:44:04 +00:00
|
|
|
js <- foldM appendToOutput "" files
|
|
|
|
case only_js flags of
|
|
|
|
True -> do
|
2013-06-05 21:22:30 +00:00
|
|
|
putStr "Generating JavaScript ... "
|
2013-08-07 01:34:23 +00:00
|
|
|
writeFile (buildPath flags rootFile "js") (genJs js)
|
2013-06-05 07:44:04 +00:00
|
|
|
putStrLn "Done"
|
|
|
|
False -> do
|
2013-06-05 21:22:30 +00:00
|
|
|
putStr "Generating HTML ... "
|
2013-06-05 07:44:04 +00:00
|
|
|
runtime <- getRuntime flags
|
2013-08-06 20:41:17 +00:00
|
|
|
let html = genHtml $ createHtml runtime (takeBaseName rootFile) (sources js) moduleName ""
|
2013-08-07 05:51:21 +00:00
|
|
|
htmlFile = buildPath flags rootFile "html"
|
|
|
|
createDirectoryIfMissing True (takeDirectory htmlFile)
|
|
|
|
writeFile htmlFile html
|
2013-06-05 07:44:04 +00:00
|
|
|
putStrLn "Done"
|
|
|
|
|
|
|
|
where
|
|
|
|
appendToOutput :: String -> FilePath -> IO String
|
|
|
|
appendToOutput js filePath =
|
2013-06-10 06:36:59 +00:00
|
|
|
do src <- readFile (elmo flags filePath)
|
2013-06-05 07:44:04 +00:00
|
|
|
return (src ++ js)
|
|
|
|
|
|
|
|
genHtml = if minify flags then Normal.renderHtml else Pretty.renderHtml
|
|
|
|
genJs = if minify flags then BS.unpack . JS.minify . BS.pack else id
|
|
|
|
sources js = map Link (scripts flags) ++
|
|
|
|
[ Source (if minify flags then Minified else Readable) js ]
|
|
|
|
|
|
|
|
|
2013-08-06 20:41:17 +00:00
|
|
|
buildFiles :: Flags -> Int -> Interfaces -> String -> [FilePath] -> IO (String, Interfaces)
|
|
|
|
buildFiles _ _ interfaces moduleName [] = return (moduleName, interfaces)
|
|
|
|
buildFiles flags numModules interfaces _ (filePath:rest) = do
|
2013-08-07 04:20:08 +00:00
|
|
|
(name,interface) <- buildFile flags (numModules - length rest) numModules interfaces filePath
|
|
|
|
let interfaces' = Map.insert name interface interfaces
|
|
|
|
buildFiles flags numModules interfaces' name rest
|