git.iko.soy/elk
on master help sign in
Merge https://github.com/evancz/Elm
commit1c918a7053222d459378fe4a5e707c08495c961a authorVladimir Bychkovsky <vladimir.bychkovsky@gmail.com> dateFri 8 Feb 2013, 13:22 (14 years ago) parentd813e0543fd6c4
7 files changed+136−63
compare with master
unifiedsplit
core-elm/Dict.elm+1−1 core-elm/Either.elm+10 core-elm/Set.elm+27−3 elm/src/Compiler.hs+17−46 elm/src/Gen/GenerateHtml.hs+1−1 elm/src/Initialize.hs+79−11 elm/src/Language/Elm.hs+1−1
core-elm/Dict.elm+1−1
@@ -272,7 +272,7 @@ moveRedRight t =
272272 let t' = color_flip t in
273273 if isRedLeftLeft t' then color_flip (rotateRight t') else t'
274274
275−moveRedLeft : RBTree k v -> RBTree k v
275+moveRedLeftIfNeeded : RBTree k v -> RBTree k v
276276moveRedLeftIfNeeded t =
277277 if not (isRedLeft t) && not (isRedLeftLeft t) then moveRedLeft t else t
278278
core-elm/Either.elm+10
@@ -1,12 +1,22 @@
11
22data Either a b = Left a | Right b
33
4+either : (a -> c) -> (b -> c) -> Either a b -> c
45either f g e = case e of { Left x -> f x ; Right y -> g y }
56
7+
8+isLeft : Either a b -> Bool
69isLeft e = case e of { Left _ -> True ; _ -> False }
10+
11+isRight : Either a b -> Bool
712isRight e = case e of { Right _ -> True ; _ -> False }
813
14+
15+lefts : [Either a b] -> [a]
916lefts = Elm.List.filter isLeft
17+
18+rights : [Either a b] -> [b]
1019rights = Elm.List.filter isRight
1120
21+partition : [Either a b] -> ([a],[b])
1222partition = Elm.List.partition isLeft
core-elm/Set.elm+27−3
@@ -6,19 +6,43 @@ module Set (empty,singleton,insert,remove
66 ,toList,fromList
77 ) where
88
9+type Set t = Dict t ()
10+
11+empty : Set t
912empty = Dict.empty
13+
14+singleton : t -> Set t
1015singleton k = Dict.singleton k ()
16+
17+insert : t -> Set t -> Set t
1118insert k = Dict.insert k ()
19+
20+remove : t -> Set t -> Set t
1221remove = Dict.remove
22+
23+member : t -> Set t -> Bool
1324member = Dict.member
1425
26+union : Set t -> Set t -> Set t
1527union = Dict.union
28+
29+intersect : Set t -> Set t -> Set t
1630intersect = Dict.intersect
31+
32+diff : Set t -> Set t -> Set t
1733diff = Dict.diff
1834
35+toList : Set t -> [t]
1936toList = Dict.keys
37+
38+fromList : [t] -> Set t
2039fromList = List.foldl (\k t -> Dict.insert k () t) empty
2140
22−foldl f = Dict.foldl (\k v b -> f k b)
23−foldr f = Dict.foldr (\k v b -> f k b)
24−map f t = fromList . List.map f $ toList t
41+foldl : (a -> b -> b) -> b -> Set a -> b
42+foldl f = Dict.foldl (\k _ b -> f k b)
43+
44+foldr : (a -> b -> b) -> b -> Set a -> b
45+foldr f = Dict.foldr (\k _ b -> f k b)
46+
47+map : (a -> b) -> Set a -> Set b
48+map f = fromList . List.map f . toList
elm/src/Compiler.hs+17−46
@@ -53,17 +53,18 @@ main = do
5353compileArgs mini (ELM _ [] _ _ _ _ _ _ _) =
5454 putStrLn "Usage: elm [OPTIONS] [FILES]\nFor more help: elm --help"
5555compileArgs mini (ELM make files rtLoc split only js nscrpt isMini outputDir) =
56− mapM_ (fileTo isMini get what js nscrpt outputDir $ fromMaybe mini rtLoc) files
57− where get = if make then getModules [] else getModule
58− what = if only then JS else
59− if split then Split else HTML
56+ mapM_ (fileTo isMini make what js nscrpt outputDir loc) files
57+ where loc = fromMaybe mini rtLoc
58+ what | only = JS
59+ | split = Split
60+ | otherwise = HTML
6061
6162data What = JS | HTML | Split
6263
63−fileTo isMini get what jsFiles noscript outputDir rtLoc file = do
64− let jsStyle = if isMini then Minified else Readable
65− let formatJS = if isMini then BS.unpack . JS.minify . BS.pack else id
66− ems <- get file
64+fileTo isMini make what jsFiles noscript outputDir rtLoc file = do
65+ let jsStyle = if isMini then Minified else Readable
66+ formatJS = if isMini then BS.unpack . JS.minify . BS.pack else id
67+ ems <- build make file
6768 jss <- concat `fmap` mapM readFile jsFiles
6869 case ems of
6970 Left err -> putStrLn $ "Error while compiling " ++ file ++ ":\n" ++ err
@@ -71,42 +72,12 @@ fileTo isMini get what jsFiles noscript outputDir rtLoc file = do
7172 let path = fromMaybe "" outputDir </> file
7273 js = replaceExtension path ".js"
7374 html = replaceExtension path ".html"
75+ pairs = map ((,) (fst ms)) (snd ms)
76+ txt = jss ++ concatMap jsModule pairs
7477 in case what of
75− JS -> writeFile js . formatJS $ jss ++ concatMap jsModule ms
76− HTML -> writeFile html . renderHtml $ modulesToHtml jsStyle "" rtLoc jss noscript ms
77− Split -> do
78− writeFile html . renderHtml $ linkedHtml rtLoc js ms
79− writeFile js . formatJS $ jss ++ concatMap jsModule ms
80−
81−getModules :: [String] -> FilePath -> IO (Either String [([String],Module)])
82−getModules uses file = do
83− code <- readFile file
84− case initialize code of
85− Left err -> return . Left $ "Error in " ++ file ++ ":\n" ++ err
86− Right (escs, modul@(Module _ _ imports _)) ->
87− let imps = filter (`notElem` builtInModules) $ map fst imports in
88− case intersect uses imps of
89− x:_ -> return . Left $ "Error: Cyclic dependency. Module " ++
90− x ++ " depends on itself."
91− [] -> do
92− ems <- mapM (getModules (uses ++ imps) . toFilePath) imps
93− return $ case lefts ems of
94− [] -> Right $ concat (rights ems) ++ [(escs,modul)]
95− errs -> Left $ intercalate "\n" errs
96−
97−getModule :: FilePath -> IO (Either String [([String],Module)])
98−getModule file = do
99− code <- readFile file
100− return . fmap (:[]) $ initialize code
101−
102−toFilePath :: String -> FilePath
103−toFilePath modul = map (\c -> if c == '.' then '/' else c) modul ++ ".elm"
104−
105−builtInModules =
106− concat [ [ "List", "Char", "Maybe", "Dict", "Set", "Automaton", "Date" ]
107− , [ "Signal", "Mouse", "Keyboard.Raw"
108− , "Window", "Time", "HTTP", "Input", "Random" ]
109− , [ "Graphics", "Text", "Color" ]
110− , map ("JavaScript"++) [ "", ".Experimental" ]
111− , [ "Prelude", "JSON" ]
112− ]
78+ JS -> writeFile js (formatJS txt)
79+ HTML -> writeFile html . renderHtml $
80+ modulesToHtml jsStyle "" rtLoc jss noscript pairs
81+ Split ->
82+ do writeFile html . renderHtml $ linkedHtml rtLoc js pairs
83+ writeFile js (formatJS txt)
elm/src/Gen/GenerateHtml.hs+1−1
@@ -45,7 +45,7 @@ generateHtml :: String -- ^ Location of elm-min.js as expected by the browser
4545 -> String -- ^ The elm source code.
4646 -> Html
4747generateHtml libLoc title source =
48− case initialize source of
48+ case buildFromSource source of
4949 Left err -> createHtml Readable libLoc title (Right $ showErr err) (H.noscript "")
5050 Right (escs, modul) -> modulesToHtml Readable title libLoc [] True [(escs,modul)]
5151
elm/src/Initialize.hs+79−11
@@ -1,10 +1,12 @@
1−module Initialize (initialize) where
1+module Initialize (build,buildFromSource) where
22
33import Control.Applicative ((<$>))
44import Control.Monad.Error
55import Data.List (lookup)
66
77import Ast
8+import Data.Either (lefts,rights)
9+import Data.List (intercalate,partition)
810import Parse.Parser (parseProgram)
911import Rename
1012import Types.Types ((-:))
@@ -13,15 +15,81 @@ import Types.Unify
1315import Types.Alias
1416import Optimize
1517
16−initialize :: String -> Either String ([String], Module)
17−initialize str = do
18− Module name ex im stmts <- parseProgram str
18+checkMistakes :: Module -> Either String Module
19+checkMistakes modul@(Module name ex im stmts) =
1920 case mistakes stmts of
2021 m:ms -> Left (unlines (m:ms))
21− [] -> let stmts' = dealias stmts
22− modul = Module name ex im stmts'
23− in do (escapees, subs) <- unify hints modul
24− let im' | any ((=="Prelude") . fst) im = im
25− | otherwise = ("Prelude", Hiding []) : im
26− modul' = optimize . renameModule $ Module name ex im' stmts'
27− subs `seq` return (escapees, modul')
22+ [] -> return modul
23+
24+checkTypes :: Module -> Either String ([String], Module)
25+checkTypes (Module name ex im stmts) =
26+ let stmts' = dealias stmts
27+ modul = Module name ex im stmts'
28+ in do (escapees, subs) <- unify hints modul
29+ let im' | any ((=="Prelude") . fst) im = im
30+ | otherwise = ("Prelude", Hiding []) : im
31+ modul' = optimize . renameModule $ Module name ex im' stmts'
32+ subs `seq` return (escapees, modul')
33+
34+check :: Module -> Either String ([String], Module)
35+check = checkMistakes >=> checkTypes
36+
37+buildFromSource :: String -> Either String ([String],Module)
38+buildFromSource = parseProgram >=> check
39+
40+build :: Bool -> FilePath -> IO (Either String ([String],[Module]))
41+build make root = do
42+ proj <- parse make root
43+ return $ do
44+ ms <- proj
45+ (escapeess, modules) <- unzip `liftM` mapM check ms
46+ sortedModules <- (if make then sort else return) modules
47+ return (concat escapeess, sortedModules)
48+
49+parse :: Bool -> FilePath -> IO (Either String [Module])
50+parse make root = parseProject [] make root
51+
52+parseProject :: [FilePath] -> Bool -> FilePath -> IO (Either String [Module])
53+parseProject seen make root = do
54+ txt <- readFile root
55+ case parseProgram txt of
56+ Left err -> return (Left err)
57+ Right modul@(Module names exs ims stmts) ->
58+ let allDeps = map toFilePath (getDeps modul)
59+ newDeps = if make then filter (`notElem` seen) allDeps else []
60+ name = intercalate "." names
61+ in do ps <- mapM (parseProject (name : seen ++ newDeps) make) newDeps
62+ return $ case unlines (lefts ps) of
63+ c:cs -> Left (c:cs)
64+ _ -> Right (modul : concat (rights ps))
65+
66+toFilePath :: String -> FilePath
67+toFilePath modul = map (\c -> if c == '.' then '/' else c) modul ++ ".elm"
68+
69+getDeps :: Module -> [String]
70+getDeps (Module _ _ is _) = filter (`notElem` builtInModules) (map fst is)
71+ where
72+ builtInModules =
73+ ["List","Char","Either","Maybe","Dict","Set","Automaton","Date",
74+ "Signal","Mouse","Keyboard.Raw","Keyboard","Touch",
75+ "WebSocket","Window","Time","HTTP","Input","Random",
76+ "Graphics","Text","Color","JavaScript",
77+ "JavaScript.Experimental","Prelude","JSON"]
78+
79+
80+sort :: [Module] -> Either String [Module]
81+sort = go []
82+ where
83+ msg = "A cyclical or missing module dependency or was detected in: "
84+ getName (Module names _ _ _) = intercalate "." names
85+
86+ has name modul = name == getName modul
87+ within ms name = any (has name) ms
88+
89+ go :: [Module] -> [Module] -> Either String [Module]
90+ go sorted [] = Right sorted
91+ go sorted unsorted =
92+ case partition (all (within sorted) . getDeps) unsorted of
93+ ([],m:ms) -> Left (msg ++ intercalate ", " (map getName (m:ms)))
94+ (srtd,unsrtd) -> go (sorted ++ srtd) unsrtd
95+
elm/src/Language/Elm.hs+1−1
@@ -77,6 +77,6 @@ instance ElmSource (t -> Elm) where
7777-- build helper to avoid boilerplate repetition
7878toPartsHelper :: String -> (Html, Html, String)
7979toPartsHelper source = (html, css, js)
80− where modul = initialize source
80+ where modul = buildFromSource source
8181 js = either showErr jsModule modul
8282 html = widgetBody $ either id (extractNoscript . snd) modul