git.iko.soy/elk
on da346ea help sign in
elk/compiler/Compiler.hs
186 lines 7.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
14import qualified Text.Blaze.Html.Renderer.Pretty as Pretty
15import qualified Text.Blaze.Html.Renderer.String as Normal
16import qualified Text.Jasmine as JS
17import qualified Data.ByteString.Lazy.Char8 as BS
19import qualified Metadata.Prelude as Prelude
20import SourceSyntax.Module
21import Initialize (buildFromSource, getSortedModuleNames, Interfaces)
22import Generate.JavaScript (jsModule)
23import Generate.Html (createHtml, JSStyle(..), JSSource(..))
24import Paths_Elm
26import SourceSyntax.PrettyPrint (pretty, variable)
27import Text.PrettyPrint as P
28import qualified Type.Type as Type
29import qualified Parse.Type as Parse
30import qualified Data.Traversable as Traverse
32data Flags =
33 Flags { make :: Bool
34 , files :: [FilePath]
35 , runtime :: Maybe FilePath
36 , only_js :: Bool
37 , print_types :: Bool
38 , print_program :: Bool
39 , scripts :: [FilePath]
40 , no_prelude :: Bool
41 , minify :: Bool
42 , output_directory :: FilePath
43 }
44 deriving (Data,Typeable,Show,Eq)
46flags = Flags
47 { make = False
48 &= help "automatically compile dependencies."
49 , files = def &= args &= typ "FILES"
50 , runtime = Nothing &= typFile
51 &= help "Specify a custom location for Elm's runtime system."
52 , only_js = False
53 &= help "Compile only to JavaScript."
54 , print_types = False
55 &= help "Print out infered types of top-level definitions."
56 , print_program = False
57 &= help "Print out an internal representation of a program."
58 , scripts = [] &= typFile
59 &= help "Load JavaScript files in generated HTML. Files will be included in the given order."
60 , no_prelude = False
61 &= help "Do not import Prelude by default, used only when compiling standard libraries."
62 , minify = False
63 &= help "Minify generated JavaScript and HTML"
64 , output_directory = "ElmFiles" &= typFile
65 &= help "Output files to directory specified. Defaults to ElmFiles/ directory."
66 } &= help "Compile Elm programs to HTML, CSS, and JavaScript."
67 &= summary ("The Elm Compiler " ++ showVersion version ++ ", (c) Evan Czaplicki")
69main :: IO ()
70main = compileArgs =<< cmdArgs flags
72compileArgs :: Flags -> IO ()
73compileArgs flags =
74 case files flags of
75 [] -> putStrLn "Usage: elm [OPTIONS] [FILES]\nFor more help: elm --help"
76 fs -> mapM_ (build flags) fs
79file :: Flags -> FilePath -> String -> FilePath
80file flags filePath ext = output_directory flags </> replaceExtension filePath ext
82elmo :: Flags -> FilePath -> FilePath
83elmo flags filePath = file flags filePath "elmo"
84elmi flags filePath = file flags filePath "elmi"
87buildFile :: Flags -> Int -> Int -> Interfaces -> FilePath -> IO ModuleInterface
88buildFile flags moduleNum numModules interfaces filePath =
89 do compiled <- alreadyCompiled
90 if compiled then Binary.decodeFile (elmi flags filePath) else compile
92 where
93 alreadyCompiled :: IO Bool
94 alreadyCompiled = do
95 existsi <- doesFileExist (elmi flags filePath)
96 existso <- doesFileExist (elmo flags filePath)
97 if not existsi || not existso
98 then return False
99 else do tsrc <- getModificationTime filePath
100 tint <- getModificationTime (elmo flags filePath)
101 return (tsrc < tint)
103 number :: String
104 number = "[" ++ show moduleNum ++ " of " ++ show numModules ++ "]"
106 name :: String
107 name = List.intercalate "." (splitDirectories (dropExtensions filePath))
109 compile :: IO ModuleInterface
110 compile = do
111 putStrLn (number ++ " Compiling " ++ name)
112 source <- readFile filePath
113 createDirectoryIfMissing True (output_directory flags)
114 metaModule <-
115 case buildFromSource interfaces source of
116 Left err -> mapM print err >> exitFailure
117 Right modul -> do
118 if print_program flags then print . pretty $ program modul else return ()
119 return modul
121 if print_types flags then printTypes metaModule else return ()
122 tipes <- toSrcTypes (types metaModule)
123 let interface = ModuleInterface {
124 iTypes = tipes,
125 iAdts = datatypes metaModule,
126 iAliases = aliases metaModule
127 }
128 createDirectoryIfMissing True . dropFileName $ elmi flags filePath
129 Binary.encodeFile (elmi flags filePath) interface
130 let js = jsModule metaModule
131 writeFile (elmo flags filePath) js
132 return interface
134toSrcTypes tipes = Traverse.traverse convert tipes
135 where
136 convert t = fmap (Parse.readType . P.render) (Type.extraPretty t)
138printTypes metaModule = do
139 putStrLn ""
140 forM_ (Map.toList $ types metaModule) $ \(n,t) -> do
141 pt <- Type.extraPretty t
142 print $ variable n <+> P.text ":" <+> pt
143 putStrLn ""
145getRuntime :: Flags -> IO FilePath
146getRuntime flags =
147 case runtime flags of
148 Just fp -> return fp
149 Nothing -> getDataFileName "elm-runtime.js"
151build :: Flags -> FilePath -> IO ()
152build flags rootFile = do
153 files <- if make flags then getSortedModuleNames rootFile else return [rootFile]
154 interfaces <- buildFiles flags (length files) Prelude.interfaces files
155 js <- foldM appendToOutput "" files
156 case only_js flags of
157 True -> do
158 putStr "Generating JavaScript ... "
159 writeFile (file flags rootFile "js") (genJs js)
160 putStrLn "Done"
161 False -> do
162 putStr "Generating HTML ... "
163 runtime <- getRuntime flags
164 let html = genHtml $ createHtml runtime rootFile (sources js) ""
165 writeFile (file flags rootFile "html") html
166 putStrLn "Done"
168 where
169 appendToOutput :: String -> FilePath -> IO String
170 appendToOutput js filePath =
171 do src <- readFile (elmo flags filePath)
172 return (src ++ js)
174 genHtml = if minify flags then Normal.renderHtml else Pretty.renderHtml
175 genJs = if minify flags then BS.unpack . JS.minify . BS.pack else id
176 sources js = map Link (scripts flags) ++
177 [ Source (if minify flags then Minified else Readable) js ]
180buildFiles :: Flags -> Int -> Interfaces -> [FilePath] -> IO Interfaces
181buildFiles _ _ interfaces [] = return interfaces
182buildFiles flags numModules interfaces (filePath:rest) = do
183 interface <- buildFile flags (numModules - length rest) numModules interfaces filePath
184 let moduleName = List.intercalate "." (splitDirectories (dropExtensions filePath))
185 interfaces' = Map.insert moduleName interface interfaces
186 buildFiles flags numModules interfaces' rest