git.iko.soy/elk
on b1dd157 help sign in
elk/compiler/Compiler.hs
179 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)
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 -> (Map.Map String ModuleInterface) -> 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 interfaces <- buildFiles flags (length files) Map.empty files
144 js <- foldM appendToOutput "" files
145 case only_js flags of
146 True -> do
147 putStr "Generating JavaScript ... "
148 writeFile (file flags rootFile "js") (genJs js)
149 putStrLn "Done"
150 False -> do
151 putStr "Generating HTML ... "
152 runtime <- getRuntime flags
153 let html = genHtml $ createHtml runtime rootFile (sources js) ""
154 writeFile (file flags rootFile "html") html
155 putStrLn "Done"
157 where
158 appendToOutput :: String -> FilePath -> IO String
159 appendToOutput js filePath =
160 do src <- readFile (elmo flags filePath)
161 return (src ++ js)
163 genHtml = if minify flags then Normal.renderHtml else Pretty.renderHtml
164 genJs = if minify flags then BS.unpack . JS.minify . BS.pack else id
165 sources js = map Link (scripts flags) ++
166 [ Source (if minify flags then Minified else Readable) js ]
169buildFiles :: Flags
170 -> Int
171 -> Map.Map String ModuleInterface
172 -> [FilePath]
173 -> IO (Map.Map String ModuleInterface)
174buildFiles _ _ interfaces [] = return interfaces
175buildFiles flags numModules interfaces (filePath:rest) = do
176 interface <- buildFile flags (numModules - length rest) numModules interfaces filePath
177 let moduleName = List.intercalate "." (splitDirectories (dropExtensions filePath))
178 interfaces' = Map.insert moduleName interface interfaces
179 buildFiles flags numModules interfaces' rest