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