git.iko.soy/elk
on 96835bf help sign in
elk/compiler/Compiler.hs
206 lines 7.9 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 , output_directory :: FilePath
46 }
47 deriving (Data,Typeable,Show,Eq)
49flags = Flags
50 { make = False
51 &= help "automatically compile dependencies."
52 , files = def &= args &= typ "FILES"
53 , runtime = Nothing &= typFile
54 &= help "Specify a custom location for Elm's runtime system."
55 , only_js = False
56 &= help "Compile only to JavaScript."
57 , print_types = False
58 &= help "Print out infered types of top-level definitions."
59 , print_program = False
60 &= help "Print out an internal representation of a program."
61 , scripts = [] &= typFile
62 &= help "Load JavaScript files in generated HTML. Files will be included in the given order."
63 , no_prelude = False
64 &= help "Do not import Prelude by default, used only when compiling standard libraries."
65 , minify = False
66 &= help "Minify generated JavaScript and HTML"
67 , output_directory = "ElmFiles" &= typFile
68 &= help "Output files to directory specified. Defaults to ElmFiles/ directory."
69 } &= help "Compile Elm programs to HTML, CSS, and JavaScript."
70 &= summary ("The Elm Compiler " ++ showVersion version ++ ", (c) Evan Czaplicki")
72main :: IO ()
73main = do setNumCapabilities =<< getNumProcessors
74 compileArgs =<< cmdArgs flags
76compileArgs :: Flags -> IO ()
77compileArgs flags =
78 case files flags of
79 [] -> putStrLn "Usage: elm [OPTIONS] [FILES]\nFor more help: elm --help"
80 fs -> mapM_ (build flags) fs
83file :: Flags -> FilePath -> String -> FilePath
84file flags filePath ext = output_directory flags </> replaceExtension filePath ext
86elmo :: Flags -> FilePath -> FilePath
87elmo flags filePath = file flags filePath "elmo"
89elmi :: Flags -> FilePath -> FilePath
90elmi flags filePath = file flags filePath "elmi"
93buildFile :: Flags -> Int -> Int -> Interfaces -> FilePath -> IO ModuleInterface
94buildFile flags moduleNum numModules interfaces filePath =
95 do compiled <- alreadyCompiled
96 case compiled of
97 False -> compile
98 True -> do
99 handle <- openBinaryFile (elmi flags filePath) ReadMode
100 bits <- L.hGetContents handle
101 let iface = getInterface (Binary.decode bits)
102 L.length bits `seq` hClose handle
103 return iface
104 where
105 getInterface :: (String, ModuleInterface) -> ModuleInterface
106 getInterface = snd
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 name :: String
122 name = List.intercalate "." (splitDirectories (dropExtensions filePath))
124 compile :: IO ModuleInterface
125 compile = do
126 putStrLn $ concat [ number, " Compiling ", name
127 , replicate (max 1 (20 - length name)) ' '
128 , "( " ++ filePath ++ " )" ]
129 source <- readFile filePath
130 createDirectoryIfMissing True (output_directory flags)
131 metaModule <-
132 case buildFromSource (no_prelude flags) interfaces source of
133 Left errors -> do
134 mapM print (List.intersperse (P.text " ") errors)
135 exitFailure
136 Right modul -> do
137 case print_program flags of
138 False -> return ()
139 True -> print . pretty $ program modul
140 return modul
142 if print_types flags then printTypes metaModule else return ()
143 tipes <- Traverse.traverse Type.toSrcType (types metaModule)
144 let interface = Canonical.interface name $ ModuleInterface {
145 iTypes = tipes,
146 iAdts = datatypes metaModule,
147 iAliases = aliases metaModule
148 }
149 createDirectoryIfMissing True . dropFileName $ elmi flags filePath
150 handle <- openBinaryFile (elmi flags filePath) WriteMode
151 L.hPut handle (Binary.encode (name,interface))
152 hClose handle
153 writeFile (elmo flags filePath) (jsModule metaModule)
154 return interface
156printTypes metaModule = do
157 putStrLn ""
158 forM_ (Map.toList $ types metaModule) $ \(n,t) -> do
159 pt <- Type.extraPretty t
160 print $ variable n <+> P.text ":" <+> pt
161 putStrLn ""
163getRuntime :: Flags -> IO FilePath
164getRuntime flags =
165 case runtime flags of
166 Just fp -> return fp
167 Nothing -> getDataFileName "elm-runtime.js"
169build :: Flags -> FilePath -> IO ()
170build flags rootFile = do
171 let noPrelude = no_prelude flags
172 files <- if make flags then getSortedDependencies noPrelude rootFile else return [rootFile]
173 let ifaces = if noPrelude then Map.empty else Prelude.interfaces
174 interfaces <- buildFiles flags (length files) ifaces files
175 js <- foldM appendToOutput "" files
176 case only_js flags of
177 True -> do
178 putStr "Generating JavaScript ... "
179 writeFile (file flags rootFile "js") (genJs js)
180 putStrLn "Done"
181 False -> do
182 putStr "Generating HTML ... "
183 runtime <- getRuntime flags
184 let html = genHtml $ createHtml runtime (takeBaseName rootFile) (sources js) ""
185 writeFile (file flags rootFile "html") html
186 putStrLn "Done"
188 where
189 appendToOutput :: String -> FilePath -> IO String
190 appendToOutput js filePath =
191 do src <- readFile (elmo flags filePath)
192 return (src ++ js)
194 genHtml = if minify flags then Normal.renderHtml else Pretty.renderHtml
195 genJs = if minify flags then BS.unpack . JS.minify . BS.pack else id
196 sources js = map Link (scripts flags) ++
197 [ Source (if minify flags then Minified else Readable) js ]
200buildFiles :: Flags -> Int -> Interfaces -> [FilePath] -> IO Interfaces
201buildFiles _ _ interfaces [] = return interfaces
202buildFiles flags numModules interfaces (filePath:rest) = do
203 interface <- buildFile flags (numModules - length rest) numModules interfaces filePath
204 let moduleName = List.intercalate "." . splitDirectories $ dropExtensions filePath
205 interfaces' = Map.insert moduleName interface interfaces
206 buildFiles flags numModules interfaces' rest