git.iko.soy/elk
on 0ffd3e2 help sign in
elk/compiler/Compiler.hs
226 lines 8.7 kB history raw
1{-# LANGUAGE DeriveDataTypeable #-}
2module Main where
4import Control.Monad
5import qualified Data.Map as Map
6import qualified Data.List as List
7import qualified Data.Binary as Binary
8import Data.Version (showVersion)
9import System.Console.CmdArgs hiding (program)
10import System.Directory
11import System.Exit
12import System.FilePath
13import System.IO
14import GHC.Conc
16import Text.Blaze.Html.Renderer.Pretty (renderHtml)
17import qualified Data.ByteString.Lazy.Char8 as BS
18import qualified Data.ByteString.Lazy as L
20import qualified Metadata.Prelude as Prelude
21import qualified Transform.Canonicalize as Canonical
22import SourceSyntax.Module
23import Parse.Module (getModuleName)
24import Initialize (buildFromSource, getSortedDependencies)
25import Generate.JavaScript (jsModule)
26import Generate.Html (createHtml, JSSource(..))
27import qualified InterfaceSerialization as IS
28import Paths_Elm
30import SourceSyntax.PrettyPrint (pretty, variable)
31import Text.PrettyPrint as P
32import qualified Type.Type as Type
33import qualified Type.Alias as Alias
35data Flags =
36 Flags { make :: Bool
37 , files :: [FilePath]
38 , runtime :: Maybe FilePath
39 , only_js :: Bool
40 , print_types :: Bool
41 , scripts :: [FilePath]
42 , no_prelude :: Bool
43 , cache_dir :: FilePath
44 , build_dir :: FilePath
45 , src_dir :: [FilePath]
46 }
47 deriving (Data,Typeable,Show,Eq)
49flags = Flags
50 { files = def &= args &= typ "FILES"
51 , make = False
52 &= help "automatically compile dependencies."
53 , only_js = False
54 &= help "Compile only to JavaScript."
55 , no_prelude = False
56 &= help "Do not import Prelude by default, used only when compiling standard libraries."
57 , scripts = [] &= typFile
58 &= help "Load JavaScript files in generated HTML. Files will be included in the given order."
59 , runtime = Nothing &= typFile
60 &= help "Specify a custom location for Elm's runtime system."
61 , cache_dir = "cache" &= typFile
62 &= help "Directory for files cached to make builds faster. Defaults to cache/ directory."
63 , build_dir = "build" &= typFile
64 &= help "Directory for generated HTML and JS files. Defaults to build/ directory."
65 , src_dir = ["."] &= typFile
66 &= help "Additional source directories besides project root. Searched when using --make"
67 , print_types = False
68 &= help "Print out infered types of top-level definitions."
69 } &= help "Compile Elm programs to HTML, CSS, and JavaScript."
70 &= helpArg [explicit, name "help", name "h"]
71 &= versionArg [explicit, name "version", name "v", summary (showVersion version)]
72 &= summary ("The Elm Compiler " ++ showVersion version ++ ", (c) Evan Czaplicki 2011-2013")
74main :: IO ()
75main = do setNumCapabilities =<< getNumProcessors
76 compileArgs =<< cmdArgs flags
78compileArgs :: Flags -> IO ()
79compileArgs flags =
80 case files flags of
81 [] -> putStrLn "Usage: elm [OPTIONS] [FILES]\nFor more help: elm --help"
82 fs -> mapM_ (build flags) fs
85buildPath :: Flags -> FilePath -> String -> FilePath
86buildPath flags filePath ext = build_dir flags </> replaceExtension filePath ext
88cachePath :: Flags -> FilePath -> String -> FilePath
89cachePath flags filePath ext = cache_dir flags </> replaceExtension filePath ext
91elmo :: Flags -> FilePath -> FilePath
92elmo flags filePath = cachePath flags filePath "elmo"
94elmi :: Flags -> FilePath -> FilePath
95elmi flags filePath = cachePath flags filePath "elmi"
97buildFile :: Flags -> Int -> Int -> Interfaces -> FilePath -> IO (String, ModuleInterface)
98buildFile flags moduleNum numModules interfaces filePath = do
99 compiled <- alreadyCompiled
100 if compiled then do
101 bytes <- IS.loadInterface (elmi flags filePath)
102 case bytes >>= IS.interfaceDecode (elmi flags filePath) >>=
103 IS.validVersion filePath of
105 Left err -> do
106 hPutStrLn stderr err
107 exitFailure
109 Right (name, interface) -> do
110 when (print_types flags)
111 (printTypes interfaces
112 (iTypes interface)
113 (iAliases interface)
114 (iImports interface))
116 return (name, interface)
118 else
119 compile
121 where
122 alreadyCompiled :: IO Bool
123 alreadyCompiled = do
124 existsi <- doesFileExist (elmi flags filePath)
125 existso <- doesFileExist (elmo flags filePath)
126 if not existsi || not existso
127 then return False
128 else do tsrc <- getModificationTime filePath
129 tint <- getModificationTime (elmo flags filePath)
130 return (tsrc <= tint)
132 number :: String
133 number = "[" ++ show moduleNum ++ " of " ++ show numModules ++ "]"
135 compile :: IO (String,ModuleInterface)
136 compile = do
137 source <- readFile filePath
138 let name = case getModuleName source of
139 Just n -> n
140 Nothing -> "Main"
141 putStrLn $ concat [ number, " Compiling ", name
142 , replicate (max 1 (20 - length name)) ' '
143 , "( " ++ filePath ++ " )" ]
145 createDirectoryIfMissing True (cache_dir flags)
146 createDirectoryIfMissing True (build_dir flags)
148 metaModule <-
149 case buildFromSource (no_prelude flags) interfaces source of
150 Left errors -> do
151 mapM print (List.intersperse (P.text " ") errors)
152 exitFailure
153 Right modul -> return modul
155 when (print_types flags)
156 (printTypes interfaces
157 (types metaModule) (aliases metaModule) (imports metaModule))
159 let interface = Canonical.interface name $ ModuleInterface {
160 iVersion = showVersion version,
161 iTypes = types metaModule,
162 iImports = imports metaModule,
163 iAdts = datatypes metaModule,
164 iAliases = aliases metaModule,
165 iFixities = fixities metaModule
166 }
168 createDirectoryIfMissing True . dropFileName $ elmi flags filePath
169 handle <- openBinaryFile (elmi flags filePath) WriteMode
170 L.hPut handle (Binary.encode (name,interface))
171 hClose handle
172 writeFile (elmo flags filePath) (jsModule metaModule)
173 return (name,interface)
175printTypes interfaces moduleTypes moduleAliases moduleImports = do
176 putStrLn ""
177 let rules = Alias.rules interfaces moduleAliases moduleImports
178 forM_ (Map.toList moduleTypes) $ \(n,t) -> do
179 print $ variable n <+> P.text ":" <+> pretty (Alias.realias rules t)
180 putStrLn ""
182getRuntime :: Flags -> IO FilePath
183getRuntime flags =
184 case runtime flags of
185 Just fp -> return fp
186 Nothing -> getDataFileName "elm-runtime.js"
188build :: Flags -> FilePath -> IO ()
189build flags rootFile = do
190 let noPrelude = no_prelude flags
191 files <- if make flags then getSortedDependencies (src_dir flags) noPrelude rootFile
192 else return [rootFile]
193 let ifaces = if noPrelude then Map.empty else Prelude.interfaces
194 (moduleName, interfaces) <- buildFiles flags (length files) ifaces "" files
195 js <- foldM appendToOutput BS.empty files
197 (extension, code) <- case only_js flags of
198 True -> do
199 putStr "Generating JavaScript ... "
200 return ("js", js)
201 False -> do
202 putStr "Generating HTML ... "
203 rtsPath <- getRuntime flags
204 return ("html", BS.pack . renderHtml $
205 createHtml rtsPath (takeBaseName rootFile) (sources js) moduleName "")
207 let targetFile = buildPath flags rootFile extension
208 createDirectoryIfMissing True (takeDirectory targetFile)
209 BS.writeFile targetFile code
210 putStrLn "Done"
212 where
213 appendToOutput :: BS.ByteString -> FilePath -> IO BS.ByteString
214 appendToOutput js filePath =
215 do
216 src <- BS.readFile (elmo flags filePath)
217 return (BS.append src js)
219 sources js = map Link (scripts flags) ++ [ Source js ]
221buildFiles :: Flags -> Int -> Interfaces -> String -> [FilePath] -> IO (String, Interfaces)
222buildFiles _ _ interfaces moduleName [] = return (moduleName, interfaces)
223buildFiles flags numModules interfaces _ (filePath:rest) = do
224 (name,interface) <- buildFile flags (numModules - length rest) numModules interfaces filePath
225 let interfaces' = Map.insert name interface interfaces
226 buildFiles flags numModules interfaces' name rest