git.iko.soy/elk
on 43b604e 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 Initialize (buildFromSource, getSortedDependencies)
26import Generate.JavaScript (jsModule)
27import Generate.Html (createHtml, JSStyle(..), JSSource(..))
28import Paths_Elm
30import SourceSyntax.PrettyPrint (pretty, variable)
31import Text.PrettyPrint as P
32import qualified Type.Type as Type
33import qualified Data.Traversable as Traverse
35data Flags =
36 Flags { make :: Bool
37 , files :: [FilePath]
38 , runtime :: Maybe FilePath
39 , only_js :: Bool
40 , print_types :: Bool
41 , print_program :: Bool
42 , scripts :: [FilePath]
43 , no_prelude :: Bool
44 , minify :: Bool
45 , cache_dir :: FilePath
46 , build_dir :: FilePath
47 }
48 deriving (Data,Typeable,Show,Eq)
50flags = Flags
51 { make = False
52 &= help "automatically compile dependencies."
53 , files = def &= args &= typ "FILES"
54 , runtime = Nothing &= typFile
55 &= help "Specify a custom location for Elm's runtime system."
56 , only_js = False
57 &= help "Compile only to JavaScript."
58 , print_types = False
59 &= help "Print out infered types of top-level definitions."
60 , print_program = False
61 &= help "Print out an internal representation of a program."
62 , scripts = [] &= typFile
63 &= help "Load JavaScript files in generated HTML. Files will be included in the given order."
64 , no_prelude = False
65 &= help "Do not import Prelude by default, used only when compiling standard libraries."
66 , minify = False
67 &= help "Minify generated JavaScript and HTML"
68 , cache_dir = "cache" &= typFile
69 &= help "Directory for files cached to make builds faster. Defaults to cache/ directory."
70 , build_dir = "build" &= typFile
71 &= help "Directory for generated HTML and JS files. Defaults to build/ directory."
72 } &= help "Compile Elm programs to HTML, CSS, and JavaScript."
73 &= summary ("The Elm Compiler " ++ showVersion version ++ ", (c) Evan Czaplicki")
75main :: IO ()
76main = do setNumCapabilities =<< getNumProcessors
77 compileArgs =<< cmdArgs flags
79compileArgs :: Flags -> IO ()
80compileArgs flags =
81 case files flags of
82 [] -> putStrLn "Usage: elm [OPTIONS] [FILES]\nFor more help: elm --help"
83 fs -> mapM_ (build flags) fs
86buildPath :: Flags -> FilePath -> String -> FilePath
87buildPath flags filePath ext = build_dir flags </> replaceExtension filePath ext
89cachePath :: Flags -> FilePath -> String -> FilePath
90cachePath flags filePath ext = cache_dir flags </> replaceExtension filePath ext
92elmo :: Flags -> FilePath -> FilePath
93elmo flags filePath = cachePath flags filePath "elmo"
95elmi :: Flags -> FilePath -> FilePath
96elmi flags filePath = cachePath flags filePath "elmi"
99buildFile :: Flags -> Int -> Int -> Interfaces -> FilePath -> IO ModuleInterface
100buildFile flags moduleNum numModules interfaces filePath =
101 do compiled <- alreadyCompiled
102 case compiled of
103 False -> compile
104 True -> do
105 handle <- openBinaryFile (elmi flags filePath) ReadMode
106 bits <- L.hGetContents handle
107 let iface = getInterface (Binary.decode bits)
108 L.length bits `seq` hClose handle
109 return iface
110 where
111 getInterface :: (String, ModuleInterface) -> ModuleInterface
112 getInterface = snd
114 alreadyCompiled :: IO Bool
115 alreadyCompiled = do
116 existsi <- doesFileExist (elmi flags filePath)
117 existso <- doesFileExist (elmo flags filePath)
118 if not existsi || not existso
119 then return False
120 else do tsrc <- getModificationTime filePath
121 tint <- getModificationTime (elmo flags filePath)
122 return (tsrc < tint)
124 number :: String
125 number = "[" ++ show moduleNum ++ " of " ++ show numModules ++ "]"
127 name :: String
128 name = List.intercalate "." (splitDirectories (dropExtensions filePath))
130 compile :: IO ModuleInterface
131 compile = do
132 putStrLn $ concat [ number, " Compiling ", name
133 , replicate (max 1 (20 - length name)) ' '
134 , "( " ++ filePath ++ " )" ]
135 source <- readFile 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 metaModule else return ()
150 tipes <- Traverse.traverse Type.toSrcType (types metaModule)
151 let interface = Canonical.interface name $ ModuleInterface {
152 iTypes = tipes,
153 iAdts = datatypes metaModule,
154 iAliases = aliases metaModule
155 }
156 createDirectoryIfMissing True . dropFileName $ elmi flags filePath
157 handle <- openBinaryFile (elmi flags filePath) WriteMode
158 L.hPut handle (Binary.encode (name,interface))
159 hClose handle
160 writeFile (elmo flags filePath) (jsModule metaModule)
161 return interface
163printTypes metaModule = do
164 putStrLn ""
165 forM_ (Map.toList $ types metaModule) $ \(n,t) -> do
166 pt <- Type.extraPretty t
167 print $ variable n <+> P.text ":" <+> pt
168 putStrLn ""
170getRuntime :: Flags -> IO FilePath
171getRuntime flags =
172 case runtime flags of
173 Just fp -> return fp
174 Nothing -> getDataFileName "elm-runtime.js"
176build :: Flags -> FilePath -> IO ()
177build flags rootFile = do
178 let noPrelude = no_prelude flags
179 files <- if make flags then getSortedDependencies noPrelude rootFile else return [rootFile]
180 let ifaces = if noPrelude then Map.empty else Prelude.interfaces
181 (moduleName, interfaces) <- buildFiles flags (length files) ifaces "" files
182 js <- foldM appendToOutput "" files
183 case only_js flags of
184 True -> do
185 putStr "Generating JavaScript ... "
186 writeFile (buildPath flags rootFile "js") (genJs js)
187 putStrLn "Done"
188 False -> do
189 putStr "Generating HTML ... "
190 runtime <- getRuntime flags
191 let html = genHtml $ createHtml runtime (takeBaseName rootFile) (sources js) moduleName ""
192 writeFile (buildPath flags rootFile "html") html
193 putStrLn "Done"
195 where
196 appendToOutput :: String -> FilePath -> IO String
197 appendToOutput js filePath =
198 do src <- readFile (elmo flags filePath)
199 return (src ++ js)
201 genHtml = if minify flags then Normal.renderHtml else Pretty.renderHtml
202 genJs = if minify flags then BS.unpack . JS.minify . BS.pack else id
203 sources js = map Link (scripts flags) ++
204 [ Source (if minify flags then Minified else Readable) js ]
207buildFiles :: Flags -> Int -> Interfaces -> String -> [FilePath] -> IO (String, Interfaces)
208buildFiles _ _ interfaces moduleName [] = return (moduleName, interfaces)
209buildFiles flags numModules interfaces _ (filePath:rest) = do
210 interface <- buildFile flags (numModules - length rest) numModules interfaces filePath
211 let moduleName = List.intercalate "." . splitDirectories $ dropExtensions filePath
212 interfaces' = Map.insert moduleName interface interfaces
213 buildFiles flags numModules interfaces' moduleName rest