git.iko.soy/elk
on 281e8a2 help sign in
elk/compiler/Compiler.hs
213 lines 8.4 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 qualified Text.Blaze.Html.Renderer.Pretty as Pretty
17import qualified Text.Blaze.Html.Renderer.String as Normal
18import qualified Text.Jasmine as JS
19import qualified Data.ByteString.Lazy.Char8 as BS
20import qualified Data.ByteString.Lazy as L
22import qualified Metadata.Prelude as Prelude
23import qualified Transform.Canonicalize as Canonical
24import SourceSyntax.Module
25import Parse.Module (getModuleName)
26import Initialize (buildFromSource, getSortedDependencies)
27import Generate.JavaScript (jsModule)
28import Generate.Html (createHtml, JSStyle(..), JSSource(..))
29import Paths_Elm
31import SourceSyntax.PrettyPrint (pretty, variable)
32import Text.PrettyPrint as P
33import qualified Type.Type as Type
34import qualified Type.Alias as Alias
36data Flags =
37 Flags { make :: Bool
38 , files :: [FilePath]
39 , runtime :: Maybe FilePath
40 , only_js :: Bool
41 , print_types :: Bool
42 , print_program :: Bool
43 , scripts :: [FilePath]
44 , no_prelude :: Bool
45 , minify :: Bool
46 , cache_dir :: FilePath
47 , build_dir :: FilePath
48 }
49 deriving (Data,Typeable,Show,Eq)
51flags = Flags
52 { make = False
53 &= help "automatically compile dependencies."
54 , files = def &= args &= typ "FILES"
55 , runtime = Nothing &= typFile
56 &= help "Specify a custom location for Elm's runtime system."
57 , only_js = False
58 &= help "Compile only to JavaScript."
59 , print_types = False
60 &= help "Print out infered types of top-level definitions."
61 , print_program = False
62 &= help "Print out an internal representation of a program."
63 , scripts = [] &= typFile
64 &= help "Load JavaScript files in generated HTML. Files will be included in the given order."
65 , no_prelude = False
66 &= help "Do not import Prelude by default, used only when compiling standard libraries."
67 , minify = False
68 &= help "Minify generated JavaScript and HTML"
69 , cache_dir = "cache" &= typFile
70 &= help "Directory for files cached to make builds faster. Defaults to cache/ directory."
71 , build_dir = "build" &= typFile
72 &= help "Directory for generated HTML and JS files. Defaults to build/ directory."
73 } &= help "Compile Elm programs to HTML, CSS, and JavaScript."
74 &= summary ("The Elm Compiler " ++ showVersion version ++ ", (c) Evan Czaplicki")
76main :: IO ()
77main = do setNumCapabilities =<< getNumProcessors
78 compileArgs =<< cmdArgs flags
80compileArgs :: Flags -> IO ()
81compileArgs flags =
82 case files flags of
83 [] -> putStrLn "Usage: elm [OPTIONS] [FILES]\nFor more help: elm --help"
84 fs -> mapM_ (build flags) fs
87buildPath :: Flags -> FilePath -> String -> FilePath
88buildPath flags filePath ext = build_dir flags </> replaceExtension filePath ext
90cachePath :: Flags -> FilePath -> String -> FilePath
91cachePath flags filePath ext = cache_dir flags </> replaceExtension filePath ext
93elmo :: Flags -> FilePath -> FilePath
94elmo flags filePath = cachePath flags filePath "elmo"
96elmi :: Flags -> FilePath -> FilePath
97elmi flags filePath = cachePath flags filePath "elmi"
100buildFile :: Flags -> Int -> Int -> Interfaces -> FilePath -> IO (String,ModuleInterface)
101buildFile flags moduleNum numModules interfaces filePath =
102 do compiled <- alreadyCompiled
103 case compiled of
104 False -> compile
105 True -> do
106 handle <- openBinaryFile (elmi flags filePath) ReadMode
107 bits <- L.hGetContents handle
108 let info :: (String, ModuleInterface)
109 info = Binary.decode bits
110 L.length bits `seq` hClose handle
111 return info
112 where
113 alreadyCompiled :: IO Bool
114 alreadyCompiled = do
115 existsi <- doesFileExist (elmi flags filePath)
116 existso <- doesFileExist (elmo flags filePath)
117 if not existsi || not existso
118 then return False
119 else do tsrc <- getModificationTime filePath
120 tint <- getModificationTime (elmo flags filePath)
121 return (tsrc < tint)
123 number :: String
124 number = "[" ++ show moduleNum ++ " of " ++ show numModules ++ "]"
126 compile :: IO (String,ModuleInterface)
127 compile = do
128 source <- readFile filePath
129 let name = case getModuleName source of
130 Just n -> n
131 Nothing -> "Main"
132 putStrLn $ concat [ number, " Compiling ", name
133 , replicate (max 1 (20 - length name)) ' '
134 , "( " ++ filePath ++ " )" ]
136 createDirectoryIfMissing True (cache_dir flags)
137 createDirectoryIfMissing True (build_dir flags)
138 metaModule <-
139 case buildFromSource (no_prelude flags) interfaces source of
140 Left errors -> do
141 mapM print (List.intersperse (P.text " ") errors)
142 exitFailure
143 Right modul -> do
144 case print_program flags of
145 False -> return ()
146 True -> print . pretty $ program modul
147 return modul
149 if print_types flags then printTypes interfaces metaModule else return ()
150 let interface = Canonical.interface name $ ModuleInterface {
151 iTypes = types metaModule,
152 iAdts = datatypes metaModule,
153 iAliases = aliases metaModule
154 }
155 createDirectoryIfMissing True . dropFileName $ elmi flags filePath
156 handle <- openBinaryFile (elmi flags filePath) WriteMode
157 L.hPut handle (Binary.encode (name,interface))
158 hClose handle
159 writeFile (elmo flags filePath) (jsModule metaModule)
160 return (name,interface)
162printTypes interfaces metaModule = do
163 putStrLn ""
164 let rules = Alias.rules interfaces metaModule
165 forM_ (Map.toList $ types metaModule) $ \(n,t) -> do
166 print $ variable n <+> P.text ":" <+> pretty (Alias.realias rules t)
167 putStrLn ""
169getRuntime :: Flags -> IO FilePath
170getRuntime flags =
171 case runtime flags of
172 Just fp -> return fp
173 Nothing -> getDataFileName "elm-runtime.js"
175build :: Flags -> FilePath -> IO ()
176build flags rootFile = do
177 let noPrelude = no_prelude flags
178 files <- if make flags then getSortedDependencies noPrelude rootFile else return [rootFile]
179 let ifaces = if noPrelude then Map.empty else Prelude.interfaces
180 (moduleName, interfaces) <- buildFiles flags (length files) ifaces "" files
181 js <- foldM appendToOutput "" files
182 case only_js flags of
183 True -> do
184 putStr "Generating JavaScript ... "
185 writeFile (buildPath flags rootFile "js") (genJs js)
186 putStrLn "Done"
187 False -> do
188 putStr "Generating HTML ... "
189 runtime <- getRuntime flags
190 let html = genHtml $ createHtml runtime (takeBaseName rootFile) (sources js) moduleName ""
191 htmlFile = buildPath flags rootFile "html"
192 createDirectoryIfMissing True (takeDirectory htmlFile)
193 writeFile htmlFile html
194 putStrLn "Done"
196 where
197 appendToOutput :: String -> FilePath -> IO String
198 appendToOutput js filePath =
199 do src <- readFile (elmo flags filePath)
200 return (src ++ js)
202 genHtml = if minify flags then Normal.renderHtml else Pretty.renderHtml
203 genJs = if minify flags then BS.unpack . JS.minify . BS.pack else id
204 sources js = map Link (scripts flags) ++
205 [ Source (if minify flags then Minified else Readable) js ]
208buildFiles :: Flags -> Int -> Interfaces -> String -> [FilePath] -> IO (String, Interfaces)
209buildFiles _ _ interfaces moduleName [] = return (moduleName, interfaces)
210buildFiles flags numModules interfaces _ (filePath:rest) = do
211 (name,interface) <- buildFile flags (numModules - length rest) numModules interfaces filePath
212 let interfaces' = Map.insert name interface interfaces
213 buildFiles flags numModules interfaces' name rest