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