git.iko.soy/elk
on master help sign in
Start generating elmi and elmo files to permit sharing of types, values, and infix info between modules.
2d1e06bevancz
compiler/Compiler.hs+137−72
compare with master
unifiedsplit
@@ -1,91 +1,156 @@
1{-# LANGUAGE DeriveDataTypeable #-}
1{-# LANGUAGE DeriveDataTypeable #-}
2module Main where
2module Main where
3
3
4+import Control.Monad (foldM, when)
5+import qualified Data.Map as Map
4import Data.Either (lefts, rights)
6import Data.Either (lefts, rights)
5−import Data.List (intersect, intercalate,lookup)
7+import Data.List (intersect, intercalate, lookup)
6import Data.Maybe (fromMaybe)
8import Data.Maybe (fromMaybe)
7import Data.Version (showVersion)
9import Data.Version (showVersion)
8import System.Console.CmdArgs
10import System.Console.CmdArgs
11+import System.Directory
9import System.Exit
12import System.Exit
10import System.FilePath
13import System.FilePath
14+import qualified Text.Blaze.Html.Renderer.Pretty as Pretty
11−import Text.Blaze.Html.Renderer.String (renderHtml)
15+import qualified Text.Blaze.Html.Renderer.String as Normal
12
16
13import qualified Text.Jasmine as JS
17import qualified Text.Jasmine as JS
14import qualified Data.ByteString.Lazy.Char8 as BS
18import qualified Data.ByteString.Lazy.Char8 as BS
15
19
16import Ast
20import Ast
17−import Initialize (build,buildFromSource)
21+import Initialize (buildFromSource, getSortedModuleNames)
18−import CompileToJS
22+import CompileToJS (jsModule)
19−import GenerateHtml
23+import GenerateHtml (createHtml, JSStyle(..), JSSource(..))
20import qualified Libraries as Libraries
24import qualified Libraries as Libraries
21import Paths_Elm
25import Paths_Elm
22
26
23−data ELM =
27+data Flags =
24− ELM { make :: Bool
28+ Flags { make :: Bool
25− , files :: [FilePath]
29+ , files :: [FilePath]
26− , runtime :: Maybe FilePath
30+ , runtime :: Maybe FilePath
27− , separate_js :: Bool
28− , only_js :: Bool
31+ , only_js :: Bool
29− , import_js :: [FilePath]
32+ , scripts :: [FilePath]
30− , no_prelude :: Bool
33+ , no_prelude :: Bool
31− , noscript :: Bool
32− , minify :: Bool
34+ , minify :: Bool
33− , output_directory :: Maybe FilePath
35+ , output_directory :: FilePath
34− }
36+ }
35 deriving (Data,Typeable,Show,Eq)
37 deriving (Data,Typeable,Show,Eq)
36
38
39+flags = Flags
40+ { make = False
37−elm = ELM { make = False &= help "automatically compile dependencies."
41+ &= help "automatically compile dependencies."
38− , files = def &= args &= typ "FILES"
42+ , files = def &= args &= typ "FILES"
39− , runtime = Nothing &= typFile &=
43+ , runtime = Nothing &= typFile
40− help "Specify a custom location for Elm's runtime system."
44+ &= help "Specify a custom location for Elm's runtime system."
41− , separate_js = False &= help "Compile to separate HTML and JS files."
45+ , only_js = False
42− , only_js = False &= help "Compile only to JavaScript."
46+ &= help "Compile only to JavaScript."
47+ , scripts = [] &= typFile
43− , import_js = [] &= typFile &= help "Include a JavaScript file before the body of the Elm program. Can be used many times. Files will be included in the given order."
48+ &= help "Load JavaScript files in generated HTML. Files will be included in the given order."
49+ , no_prelude = False
44− , no_prelude = False &= help "Do not import Prelude by default, used only when compiling standard libraries."
50+ &= help "Do not import Prelude by default, used only when compiling standard libraries."
45− , noscript = True &= help "Add generated <noscript> tag to HTML output."
51+ , minify = False
46− , minify = False &= help "Minify generated JavaScript"
52+ &= help "Minify generated JavaScript"
53+ , output_directory = "ElmFiles" &= typFile
47− , output_directory = Nothing &= typFile &= help "Output files to directory specified. Defaults to the location of original file."
54+ &= help "Output files to directory specified. Defaults to ElmFiles/ directory."
48− } &=
49− help "Compile Elm programs to HTML, CSS, and JavaScript." &=
55+ } &= help "Compile Elm programs to HTML, CSS, and JavaScript."
50− summary ("The Elm Compiler " ++ showVersion version ++ ", (c) Evan Czaplicki")
56+ &= summary ("The Elm Compiler " ++ showVersion version ++ ", (c) Evan Czaplicki")
51−
57+
52−main = do
58+main :: IO ()
53− args <- cmdArgs elm
59+main = compileArgs =<< cmdArgs flags
54− mini <- getDataFileName "elm-runtime.js"
60+
61+compileArgs :: Flags -> IO ()
55− compileArgs mini args
62+compileArgs flags =
56−
63+ let builder file = if make flags then build flags file
57−compileArgs mini flags =
64+ else buildFile flags 1 1 file >> return ()
58− case files flags of
65+ in case files flags of
59− [] -> putStrLn "Usage: elm [OPTIONS] [FILES]\nFor more help: elm --help"
66+ [] -> putStrLn "Usage: elm [OPTIONS] [FILES]\nFor more help: elm --help"
60− fs -> mapM_ (fileTo flags what loc) fs
67+ fs -> mapM_ builder fs
61− where loc = fromMaybe mini (runtime flags)
68+
62− what | only_js flags = JS
69+
63− | separate_js flags = Split
70+type Interface = String
64− | otherwise = HTML
71+
65−
72+buildFile :: Flags -> Int -> Int -> FilePath -> IO Interface
66−data What = JS | HTML | Split
73+buildFile flags moduleNum numModules filePath =
67−
74+ do compiled <- alreadyCompiled
68−fileTo flags what rtLoc file = do
75+ if compiled then getInterface else compile
69− let jsStyle = if minify flags then Minified else Readable
76+
70− formatJS = if minify flags then BS.unpack . JS.minify . BS.pack else id
77+ where
71− prelude = not (no_prelude flags)
78+ file :: String -> FilePath
72− ems <- if make flags then build prelude file
79+ file ext = replaceExtension filePath ext
73− else do src <- readFile file
80+
74− return (fmap (:[]) (buildFromSource prelude src))
81+ interface :: FilePath
75− jss <- concat `fmap` mapM readFile (import_js flags)
82+ interface = file "elmi"
76− case ems of
83+
77− Left err -> do putStrLn $ "Error while compiling " ++ file ++ ":\n" ++ err
84+ alreadyCompiled :: IO Bool
85+ alreadyCompiled = do
86+ exists <- doesFileExist interface
87+ if not exists then return False
88+ else do tsrc <- getModificationTime filePath
89+ tint <- getModificationTime interface
90+ return (tsrc < tint)
91+
92+ number :: String
93+ number = "[" ++ show moduleNum ++ " of " ++ show numModules ++ "]"
94+
95+ name :: String
96+ name = intercalate "." (splitDirectories (dropExtensions filePath))
97+
98+ compile :: IO Interface
99+ compile = do
100+ putStrLn (number ++ " Compiling " ++ name)
101+ source <- readFile filePath
102+ js <- if takeExtension filePath == ".js" then return source else
103+ case buildFromSource (no_prelude flags) source of
78− exitFailure
104+ Left err -> putStrLn err >> exitFailure
79− Right ms' ->
105+ Right modul -> return (jsModule modul)
80− let path = fromMaybe "" (output_directory flags) </> file
106+ writeFile interface js
81− js = replaceExtension path ".js"
107+ writeFile (file "elmo") js
108+ when (only_js flags) (writeFile (file "js") js)
109+ return js
110+
111+ getInterface :: IO Interface
112+ getInterface = do
113+ readFile interface
114+
115+getRuntime :: Flags -> IO FilePath
116+getRuntime flags =
117+ case runtime flags of
118+ Just fp -> return fp
119+ Nothing -> getDataFileName "elm-runtime.js"
120+
121+build :: Flags -> FilePath -> IO ()
122+build flags rootFile = do
123+ files <- getSortedModuleNames rootFile
124+ buildFiles flags (length files) Map.empty files
125+ js <- foldM appendToOutput "" files
126+ case only_js flags of
127+ True -> do
128+ putStr "\nGenerating JavaScript... "
82− html = replaceExtension path ".html"
129+ writeFile (replaceExtension rootFile "js") (genJs js)
83− ms = if no_prelude flags then ms' else map Libraries.addPrelude ms'
130+ putStrLn "Done"
84− txt = jss ++ concatMap jsModule ms
131+ False -> do
85− in case what of
132+ putStr "\nGenerating HTML... "
86− JS -> writeFile js (formatJS txt)
133+ runtime <- getRuntime flags
87− HTML -> writeFile html . renderHtml $
134+ let html = genHtml $ createHtml runtime rootFile (sources js) ""
88− modulesToHtml jsStyle "" rtLoc jss (noscript flags) ms
135+ writeFile (replaceExtension rootFile "html") html
89− Split ->
136+ putStrLn "Done"
90− do writeFile html . renderHtml $ linkedHtml rtLoc js ms
137+
91− writeFile js (formatJS txt)
138+ where
139+ appendToOutput :: String -> FilePath -> IO String
140+ appendToOutput js filePath =
141+ do src <- readFile (replaceExtension filePath "elmo")
142+ return (src ++ js)
143+
144+ genHtml = if minify flags then Normal.renderHtml else Pretty.renderHtml
145+ genJs = if minify flags then BS.unpack . JS.minify . BS.pack else id
146+ sources js = map Link (scripts flags) ++
147+ [ Source (if minify flags then Minified else Readable) js ]
148+
149+
150+buildFiles :: Flags -> Int -> Map.Map String Interface -> [FilePath] -> IO ()
151+buildFiles _ _ _ [] = return ()
152+buildFiles flags numModules interfaces (filePath:rest) = do
153+ interface <- buildFile flags (numModules - length rest) numModules filePath
154+ let moduleName = intercalate "." (splitDirectories (dropExtensions filePath))
155+ interfaces' = Map.insert moduleName interface interfaces
156+ buildFiles flags numModules interfaces' rest
compiler/Gen/GenerateHtml.hs+26−26
@@ -1,7 +1,8 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2module GenerateHtml (generateHtml,
2module GenerateHtml (generateHtml,
3− modulesToHtml, linkedHtml,
3+ createHtml,
4− JSStyle (..)
4+ JSStyle (..),
5+ JSSource (..)
5 ) where
6 ) where
6
7
7import Data.List (intercalate)
8import Data.List (intercalate)
@@ -21,15 +22,17 @@ import ExtractNoscript
21import Libraries as Libraries
22import Libraries as Libraries
22
23
23data JSStyle = Minified | Readable
24data JSStyle = Minified | Readable
25+data JSSource = Link String | Source JSStyle String
24
26
25−makeScript :: JSStyle -> Either String String -> H.Html
27+makeScript :: JSSource -> H.Html
26−makeScript _ (Left s) =
28+makeScript source =
29+ case source of
27− H.script ! A.type_ "text/javascript" ! A.src (H.toValue s) $ ""
30+ Link src -> H.script ! A.type_ "text/javascript" ! A.src (H.toValue src) $ ""
28−makeScript jsStyle (Right s) =
31+ Source style src ->
29− H.script ! A.type_ "text/javascript" $ preEscapedToMarkup content
32+ H.script ! A.type_ "text/javascript" $
30− where content = case jsStyle of
33+ preEscapedToMarkup $ case style of
31− Minified -> BS.unpack . minify . BS.pack $ s
34+ Minified -> BS.unpack . minify . BS.pack $ src
32− Readable -> s
35+ Readable -> src
33
36
34-- |This function compiles Elm code into simple HTML.
37-- |This function compiles Elm code into simple HTML.
35--
38--
@@ -40,14 +43,16 @@ generateHtml :: String -- ^ Location of elm-runtime.js as expected by the browse
40 -> String -- ^ The page title
43 -> String -- ^ The page title
41 -> String -- ^ The elm source code.
44 -> String -- ^ The elm source code.
42 -> Html
45 -> Html
43−generateHtml libLoc title source =
46+generateHtml libLoc title source = H.span "broken for now"
47+{--
44 case buildFromSource True source of
48 case buildFromSource True source of
45− Right modul -> modulesToHtml Readable title libLoc [] True [modul]
49+ Right modul -> createHtml libLoc title [] "" title [modul]
46 Left err -> createHtml Readable libLoc title (Right $ showErr err)
50 Left err -> createHtml Readable libLoc title (Right $ showErr err)
47 (H.noscript "") "Main"
51 (H.noscript "") "Main"
48−
52+--}
49−
53+{--
54+modulesToHtml :: FilePath -> String -> []
50−modulesToHtml jsStyle title libLoc jss nscrpt modules =
55+modulesToHtml libLoc title scripts nscrpt modules =
51 createHtml jsStyle libLoc title' js noscript altTitle
56 createHtml jsStyle libLoc title' js noscript altTitle
52 where
57 where
53 js = Right $ jss ++ concatMap jsModule modules
58 js = Right $ jss ++ concatMap jsModule modules
@@ -55,21 +60,16 @@ modulesToHtml jsStyle title libLoc jss nscrpt modules =
55 title' = if null title then altTitle else title
60 title' = if null title then altTitle else title
56 altTitle = intercalate "." names
61 altTitle = intercalate "." names
57 where Module names _ _ _ = last modules
62 where Module names _ _ _ = last modules
58−
63+--}
59−
60−linkedHtml rtLoc jsLoc modules =
61− createHtml Readable rtLoc title (Left jsLoc) (H.noscript "") title
62− where
63− title = (\(Module names _ _ _) -> intercalate "." names) (last modules)
64−
65
64
65+createHtml :: FilePath -> String -> [JSSource] -> String -> Html
66−createHtml jsStyle libLoc title js noscript moduleToLoad =
66+createHtml libLoc title scripts noscript =
67 H.docTypeHtml $ do
67 H.docTypeHtml $ do
68 H.head $ do
68 H.head $ do
69 H.meta ! A.charset "UTF-8"
69 H.meta ! A.charset "UTF-8"
70 H.title . H.toHtml $ title
70 H.title . H.toHtml $ title
71− makeScript Readable (Left libLoc)
71+ makeScript (Link libLoc)
72− makeScript jsStyle js
72+ mapM_ makeScript scripts
73 H.body $ do
73 H.body $ do
74− H.script ! A.type_ "text/javascript" $ preEscapedToMarkup ("Elm.fullscreen(Elm." ++ moduleToLoad ++ ")" :: String)
74+ H.script ! A.type_ "text/javascript" $ preEscapedToMarkup ("Elm.fullscreen(Elm.Main)" :: String)
75 H.noscript $ preEscapedToMarkup noscript
75 H.noscript $ preEscapedToMarkup noscript
compiler/Initialize.hs+29−43
@@ -1,4 +1,4 @@
1−module Initialize (build, buildFromSource) where
1+module Initialize (buildFromSource, getSortedModuleNames) where
2
2
3import Control.Applicative ((<$>))
3import Control.Applicative ((<$>))
4import Control.Monad.Error
4import Control.Monad.Error
@@ -16,7 +16,8 @@ import Types.Hints (hints)
16import Types.Unify (unify)
16import Types.Unify (unify)
17import Types.Alias (dealias, mistakes)
17import Types.Alias (dealias, mistakes)
18import Optimize
18import Optimize
19−import CompileToJS (jsModule)
19+import System.Exit
20+import System.FilePath
20
21
21checkMistakes :: Module -> Either String Module
22checkMistakes :: Module -> Either String Module
22checkMistakes modul@(Module name ex im stmts) =
23checkMistakes modul@(Module name ex im stmts) =
@@ -33,64 +34,49 @@ check :: Module -> Either String Module
33check = checkMistakes >=> checkTypes
34check = checkMistakes >=> checkTypes
34
35
35buildFromSource :: Bool -> String -> Either String Module
36buildFromSource :: Bool -> String -> Either String Module
36−buildFromSource withPrelude src = (check . add) =<< (parseProgram src)
37+buildFromSource noPrelude src =
37− where add = if withPrelude then Libs.addPrelude else id
38+ let add = if noPrelude then id else Libs.addPrelude in
39+ (check . add) =<< (parseProgram src)
38
40
39−build :: Bool -> FilePath -> IO (Either String [Module])
40−build withPrelude root = do
41− names <- getSortedModuleNames root
41+getSortedModuleNames :: FilePath -> IO [String]
42− case names of
43− Left err -> return (Left err)
44− Right ns -> do srcs <- zipWithM buildFile' [1..] ns
45− return (sequence srcs)
46− where
47− buildFile' n name = putStrLn (msg n name) >> buildFile withPrelude name
48− msg n name = "["++show n++" of "++show (length ns)++"] Compiling "++name
49−
50−buildFile :: Bool -> String -> IO (Either String Module)
51−buildFile withPrelude moduleName =
52− let filePath = toFilePath moduleName in
53− case isNative moduleName of
54− True -> return (Right $ Module [moduleName] [] [] [])
55− --return (Left "Can't do that yet")
56− --Right `liftM` readFile filePath
57− False -> do txt <- readFile filePath
58− return $ buildFromSource withPrelude txt
59−
60−
61−getSortedModuleNames :: FilePath -> IO (Either String [String])
62−getSortedModuleNames root = do
42+getSortedModuleNames root =
63− deps <- readDeps [] root
64− return (sortDeps =<< deps)
43+ sortDeps =<< readDeps [] root
65
44
66type Deps = (String, [String])
45type Deps = (String, [String])
67
46
68−sortDeps :: [Deps] -> Either String [String]
47+sortDeps :: [Deps] -> IO [String]
69sortDeps deps = go [] (nub deps)
48sortDeps deps = go [] (nub deps)
70 where
49 where
71 msg = "A cyclical or missing module dependency or was detected in: "
50 msg = "A cyclical or missing module dependency or was detected in: "
72
51
73− go :: [String] -> [Deps] -> Either String [String]
52+ go :: [String] -> [Deps] -> IO [String]
74− go sorted [] = Right sorted
53+ go sorted [] = return (map toFilePath sorted)
75 go sorted unsorted =
54 go sorted unsorted =
76 case partition (all (`elem` sorted) . snd) unsorted of
55 case partition (all (`elem` sorted) . snd) unsorted of
77− ([],m:ms) -> Left (msg ++ intercalate ", " (map fst (m:ms)) ++ show sorted ++ show unsorted)
56+ ([],m:ms) -> do putStrLn (msg ++ intercalate ", " (map fst (m:ms)) ++ show sorted ++ show unsorted)
57+ exitFailure
78 (srtd,unsrtd) -> go (sorted ++ map fst srtd) unsrtd
58 (srtd,unsrtd) -> go (sorted ++ map fst srtd) unsrtd
79
59
80−readDeps :: [FilePath] -> FilePath -> IO (Either String [Deps])
60+readDeps :: [FilePath] -> FilePath -> IO [Deps]
81readDeps seen root = do
61readDeps seen root = do
82 txt <- readFile root
62 txt <- readFile root
83 case preParse txt of
63 case preParse txt of
84− Left err -> return (Left err)
64+ Left err ->
65+ let msg = "Error resolving dependencies in " ++ root ++ ":\n" in
66+ putStrLn (msg ++ err) >> exitFailure
67+ Right (name,deps) ->
85− Right (name,deps) -> do rest <- mapM (readDeps seen' . toFilePath) newDeps
68+ do rest <- mapM (readDeps seen' . toFilePath) newDeps
86− return $ do rs <- sequence rest
87− return ((name, realDeps) : concat rs)
69+ return ((name, realDeps) : concat rest)
70+ where
88− where realDeps = filter (`notElem` builtIns) deps
71+ realDeps = filter (`notElem` builtIns) deps
89− newDeps = filter (`notElem` seen) realDeps
72+ newDeps = filter (\d -> d `notElem` seen && not (isNative d)) realDeps
90− seen' = root : seen ++ newDeps
73+ seen' = root : seen ++ newDeps
91− builtIns = Map.keys Libs.libraries
74+ builtIns = Map.keys Libs.libraries
75+
92
76
93isNative name = takeWhile (/='.') name == "Native"
77isNative name = takeWhile (/='.') name == "Native"
78+
79+toFilePath :: String -> FilePath
94toFilePath name = map swapDots name ++ ext
80toFilePath name = map swapDots name ++ ext
95 where swapDots '.' = '/'
81 where swapDots '.' = '/'
96 swapDots c = c
82 swapDots c = c