git.iko.soy/elk
on 4f4e6ac help sign in
elk/compiler/Compiler.hs
221 lines 8.6 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 not compiled then compile else do
101 bytes <- IS.loadInterface (elmi flags filePath)
102 let binary = IS.interfaceDecode (elmi flags filePath) =<< bytes
103 case IS.validVersion filePath =<< binary of
104 Left err -> do
105 hPutStrLn stderr err
106 exitFailure
108 Right (name, interface) -> do
109 when (print_types flags) $
110 printTypes interfaces
111 (iTypes interface)
112 (iAliases interface)
113 (iImports interface)
115 return (name, interface)
117 where
118 alreadyCompiled :: IO Bool
119 alreadyCompiled = do
120 existsi <- doesFileExist (elmi flags filePath)
121 existso <- doesFileExist (elmo flags filePath)
122 if not existsi || not existso
123 then return False
124 else do tsrc <- getModificationTime filePath
125 tint <- getModificationTime (elmo flags filePath)
126 return (tsrc <= tint)
128 number :: String
129 number = "[" ++ show moduleNum ++ " of " ++ show numModules ++ "]"
131 compile :: IO (String,ModuleInterface)
132 compile = do
133 source <- readFile filePath
134 let name = case getModuleName source of
135 Just n -> n
136 Nothing -> "Main"
137 putStrLn $ concat [ number, " Compiling ", name
138 , replicate (max 1 (20 - length name)) ' '
139 , "( " ++ filePath ++ " )" ]
141 createDirectoryIfMissing True (cache_dir flags)
142 createDirectoryIfMissing True (build_dir flags)
144 metaModule <-
145 case buildFromSource (no_prelude flags) interfaces source of
146 Left errors -> do
147 mapM print (List.intersperse (P.text " ") errors)
148 exitFailure
149 Right modul -> return modul
151 when (print_types flags)
152 (printTypes interfaces
153 (types metaModule) (aliases metaModule) (imports metaModule))
155 let interface = Canonical.interface name $ ModuleInterface {
156 iVersion = showVersion version,
157 iTypes = types metaModule,
158 iImports = imports metaModule,
159 iAdts = datatypes metaModule,
160 iAliases = aliases metaModule,
161 iFixities = fixities metaModule
162 }
164 createDirectoryIfMissing True . dropFileName $ elmi flags filePath
165 handle <- openBinaryFile (elmi flags filePath) WriteMode
166 L.hPut handle (Binary.encode (name,interface))
167 hClose handle
168 writeFile (elmo flags filePath) (jsModule metaModule)
169 return (name,interface)
171printTypes interfaces moduleTypes moduleAliases moduleImports = do
172 putStrLn ""
173 let rules = Alias.rules interfaces moduleAliases moduleImports
174 forM_ (Map.toList moduleTypes) $ \(n,t) -> do
175 print $ variable n <+> P.text ":" <+> pretty (Alias.realias rules t)
176 putStrLn ""
178getRuntime :: Flags -> IO FilePath
179getRuntime flags =
180 case runtime flags of
181 Just fp -> return fp
182 Nothing -> getDataFileName "elm-runtime.js"
184build :: Flags -> FilePath -> IO ()
185build flags rootFile = do
186 let noPrelude = no_prelude flags
187 files <- if make flags then getSortedDependencies (src_dir flags) noPrelude rootFile
188 else return [rootFile]
189 let ifaces = if noPrelude then Map.empty else Prelude.interfaces
190 (moduleName, interfaces) <- buildFiles flags (length files) ifaces "" files
191 js <- foldM appendToOutput BS.empty files
193 (extension, code) <- case only_js flags of
194 True -> do
195 putStr "Generating JavaScript ... "
196 return ("js", js)
197 False -> do
198 putStr "Generating HTML ... "
199 rtsPath <- getRuntime flags
200 return ("html", BS.pack . renderHtml $
201 createHtml rtsPath (takeBaseName rootFile) (sources js) moduleName "")
203 let targetFile = buildPath flags rootFile extension
204 createDirectoryIfMissing True (takeDirectory targetFile)
205 BS.writeFile targetFile code
206 putStrLn "Done"
208 where
209 appendToOutput :: BS.ByteString -> FilePath -> IO BS.ByteString
210 appendToOutput js filePath =
211 do src <- BS.readFile (elmo flags filePath)
212 return (BS.append src js)
214 sources js = map Link (scripts flags) ++ [ Source js ]
216buildFiles :: Flags -> Int -> Interfaces -> String -> [FilePath] -> IO (String, Interfaces)
217buildFiles _ _ interfaces moduleName [] = return (moduleName, interfaces)
218buildFiles flags numModules interfaces _ (filePath:rest) = do
219 (name,interface) <- buildFile flags (numModules - length rest) numModules interfaces filePath
220 let interfaces' = Map.insert name interface interfaces
221 buildFiles flags numModules interfaces' name rest