git.iko.soy/elk
on master help sign in
Change semantics of import:
c5519e3evancz
elm/Elm.cabal+2
compare with master
unifiedsplit
@@ -41,6 +41,7 @@ Library
41 ExtractNoscript,
41 ExtractNoscript,
42 GenerateHtml,
42 GenerateHtml,
43 Guid,
43 Guid,
44+ LetBoundVars,
44 Optimize,
45 Optimize,
45 Initialize,
46 Initialize,
46 Rename,
47 Rename,
@@ -89,6 +90,7 @@ Executable elm
89 ExtractNoscript,
90 ExtractNoscript,
90 GenerateHtml,
91 GenerateHtml,
91 Guid,
92 Guid,
93+ LetBoundVars,
92 Optimize,
94 Optimize,
93 Initialize,
95 Initialize,
94 Rename,
96 Rename,
elm/src/Ast.hs+1−1
@@ -12,7 +12,7 @@ data Module = Module [String] Exports Imports [Statement]
12type Exports = [String]
12type Exports = [String]
13
13
14type Imports = [(String, ImportMethod)]
14type Imports = [(String, ImportMethod)]
15−data ImportMethod = As String | Hiding [String] | Importing [String]
15+data ImportMethod = As String | Importing [String]
16 deriving (Eq,Ord)
16 deriving (Eq,Ord)
17
17
18
18
elm/src/Compiler.hs+5−5
@@ -64,7 +64,8 @@ data What = JS | HTML | Split
64fileTo isMini make what jsFiles noscript outputDir rtLoc file = do
64fileTo isMini make what jsFiles noscript outputDir rtLoc file = do
65 let jsStyle = if isMini then Minified else Readable
65 let jsStyle = if isMini then Minified else Readable
66 formatJS = if isMini then BS.unpack . JS.minify . BS.pack else id
66 formatJS = if isMini then BS.unpack . JS.minify . BS.pack else id
67− ems <- build make file
67+ ems <- if make then build file else do src <- readFile file
68+ return (fmap (:[]) (buildFromSource src))
68 jss <- concat `fmap` mapM readFile jsFiles
69 jss <- concat `fmap` mapM readFile jsFiles
69 case ems of
70 case ems of
70 Left err -> putStrLn $ "Error while compiling " ++ file ++ ":\n" ++ err
71 Left err -> putStrLn $ "Error while compiling " ++ file ++ ":\n" ++ err
@@ -72,12 +73,11 @@ fileTo isMini make what jsFiles noscript outputDir rtLoc file = do
72 let path = fromMaybe "" outputDir </> file
73 let path = fromMaybe "" outputDir </> file
73 js = replaceExtension path ".js"
74 js = replaceExtension path ".js"
74 html = replaceExtension path ".html"
75 html = replaceExtension path ".html"
75− pairs = map ((,) (fst ms)) (snd ms)
76− txt = jss ++ concatMap jsModule pairs
76+ txt = jss ++ concatMap jsModule ms
77 in case what of
77 in case what of
78 JS -> writeFile js (formatJS txt)
78 JS -> writeFile js (formatJS txt)
79 HTML -> writeFile html . renderHtml $
79 HTML -> writeFile html . renderHtml $
80− modulesToHtml jsStyle "" rtLoc jss noscript pairs
80+ modulesToHtml jsStyle "" rtLoc jss noscript ms
81 Split ->
81 Split ->
82− do writeFile html . renderHtml $ linkedHtml rtLoc js pairs
82+ do writeFile html . renderHtml $ linkedHtml rtLoc js ms
83 writeFile js (formatJS txt)
83 writeFile js (formatJS txt)
elm/src/Gen/CompileToJS.hs+97−114
@@ -1,7 +1,5 @@
1module CompileToJS (showErr, jsModule) where
1module CompileToJS (showErr, jsModule) where
2
2
3−import Ast
4−import Context
5import Control.Arrow (first,second)
3import Control.Arrow (first,second)
6import Control.Monad (liftM,(<=<),join,ap)
4import Control.Monad (liftM,(<=<),join,ap)
7import Data.Char (isAlpha,isDigit)
5import Data.Char (isAlpha,isDigit)
@@ -10,12 +8,15 @@ import qualified Data.Map as Map
10import Data.Either (partitionEithers)
8import Data.Either (partitionEithers)
11import qualified Text.Pandoc as Pan
9import qualified Text.Pandoc as Pan
12
10
13−import Initialize
11+import Ast
12+import Context
14import Rename (derename)
13import Rename (derename)
15import Cases
14import Cases
16import Guid
15import Guid
16+import LetBoundVars
17import Parse.Library (isOp)
17import Parse.Library (isOp)
18import Rename (deprime)
18import Rename (deprime)
19+import Types.Types ( Type(RecordT) )
19
20
20showErr :: String -> String
21showErr :: String -> String
21showErr err = mainEquals $ "Elm.Graphics.text(Elm.Text.monospace(" ++ msg ++ "))"
22showErr err = mainEquals $ "Elm.Graphics.text(Elm.Text.monospace(" ++ msg ++ "))"
@@ -41,47 +42,26 @@ quoted s = "'" ++ concatMap f s ++ "'"
41 f c = [c]
42 f c = [c]
42
43
43mainEquals s = globalAssign "Elm.main" (jsFunc "" (ret s))
44mainEquals s = globalAssign "Elm.main" (jsFunc "" (ret s))
44−globalAssign m s = "\n" ++ m ++ "=" ++ s ++ ";"
45+globalAssign n e = "\n" ++ assign' n e ++ ";"
45−
46+assign' n e = n ++ " = " ++ e
46−tryBlock escapees names e =
47+
47− concat [ "\ntry{\n" ++ e ++ "\n} catch (e) {"
48− , "\nElm.main=function() {"
49− , "\nvar msg = ('<br/><h2>Your browser may not be supported. " ++
50− "Are you using a modern browser?</h2>' +" ++
51− " '<br/><span style=\"color:grey\">Runtime Error in " ++
52− intercalate "." names ++ " module:<br/>' + e + '" ++ msg ++ "</span>');"
53− , "\ndocument.body.innerHTML = Elm.Text.monospace(msg);"
54− , "throw e;"
55− , "};}"
56− ]
57− where msg | escapees /= [] = concat [ "<br/><br/>The problem may stem from an improper usage of:<br/>"
58− , intercalate ", " $ map (concatMap escape) escapees ]
59− | otherwise = ""
60− escape '\'' = "\\'"
61− escape '"' = "\\\""
62− escape c = [c]
63−
64−
65−jsModule (escapees, Module names exports imports stmts) =
48+jsModule (Module names exports imports stmts) =
66− tryBlock escapees (tail modNames) $ concat
67− [ concatMap (\n -> globalAssign n $ n ++ " || {}") .
49+ concat [ concatMap (\n -> globalAssign n $ n ++ " || {}") .
68− map (intercalate ".") . drop 2 . inits $
50+ map (intercalate ".") . drop 2 . inits $
69− take (length modNames - 1) modNames
51+ take (length modNames - 1) modNames
70− , "\nif (" ++ modName ++ ") throw new Error(\"Module name collision, '" ++
71− intercalate "." (tail modNames) ++ "' is already defined.\"); "
72− , globalAssign modName $ jsFunc "" (defs ++ includes ++ body ++ export) ++ "()"
52+ , parens (jsFunc "" (defs ++ includes ++ body ++ globalAssign modName export) ++ "()")
73− , mainEquals $ modName ++ ".main" ]
53+ , mainEquals $ modName ++ ".main" ]
74− where modNames = if null names then ["Elm", "Main"]
54+ where modNames = if null names then ["Elm", "Main"]
75− else "Elm" : names
55+ else "Elm" : names
76− modName = intercalate "." modNames
56+ modName = intercalate "." modNames
77− includes = concatMap jsImport $ map (first ("Elm."++)) imports
57+ includes = concatMap jsImport imports
78− body = stmtsToJS stmts
58+ body = stmtsToJS stmts
79− export = getExports exports stmts
59+ export = getExports exports stmts
80− exps = if null exports then ["main"] else exports
60+ exps = if null exports then ["main"] else exports
81− defs = concat [ assign "$op" "{}"
61+ defs = assign "$op" "{}"
82− , "\nfor(Elm['i'] in Elm){eval('var '+Elm['i']+'=Elm[Elm.i];');}" ]
62+
83−
84−getExports names stmts = ret . brackets $ intercalate ",\n" (op : map fnPair fns)
63+getExports names stmts = brackets . ("\n "++) $
64+ intercalate ",\n " (op : map fnPair fns)
85 where exNames n = either derename id n `elem` names
65 where exNames n = either derename id n `elem` names
86 exports | null names = concatMap get stmts
66 exports | null names = concatMap get stmts
87 | otherwise = filter exNames (concatMap get stmts)
67 | otherwise = filter exNames (concatMap get stmts)
@@ -104,75 +84,75 @@ getExports names stmts = ret . brackets $ intercalate ",\n" (op : map fnPair fns
104
84
105
85
106jsImport (modul, how) =
86jsImport (modul, how) =
107− concat [ "\ntry{\n if (!(" ++ modul ++ " instanceof Object)) throw new Error('module not found');\n} catch(e) {\n throw new Error(\"Module '"
87+ case how of
108− , drop 1 (dropWhile (/='.') modul)
109− , "' is missing. Compile with --make flag or load missing "
110− , "module in a separate JavaScript file.\");\n}" ] ++
111− jsImport' (modul, how)
112−
113−jsImport' (modul, As name) = assign name modul
88+ As name -> assign name ("Elm." ++ modul)
114−jsImport' (modul, Importing vs) = concatMap def vs
89+ Importing vs ->
90+ assign modul ("Elm." ++ modul) ++ concatMap def vs
115− where def [] = []
91+ where
92+ imprt asgn v = asgn v ("Elm." ++ modul ++ "." ++ v)
116− def (o:p) | isOp o = let v = "$op['" ++ o:p ++ "']" in
93+ def (o:p) =
117− "\n" ++ v ++ " = " ++ modul ++ "." ++ v ++ ";"
94+ if isOp o then imprt globalAssign ("$op['" ++ o:p ++ "']")
118− | otherwise = let v = deprime (o:p) in
95+ else imprt assign (deprime (o:p))
119− assign v $ modul ++ "." ++ v
96+
120−
121−jsImport' (modul, Hiding vs) =
122− concat [ assign "hiddenVars" . ("{"++) . (++"}") . intercalate "," $
123− map (\v -> v ++ ":true") (map deprime vs)
124− , "\nfor (Elm['i'] in " ++ modul ++ ") "
125− , brackets . indent . concat $
126− [ "\nif (hiddenVars[Elm['i']]) continue;"
127− , "\neval('var ' + Elm['i'] + ' = "
128− , modul, "[Elm.i];');" ]
129− ]
130
97
131stmtsToJS :: [Statement] -> String
98stmtsToJS :: [Statement] -> String
132−stmtsToJS stmts = run (concat `liftM` mapM toJS (sortBy cmpStmt stmts))
99+stmtsToJS stmts = run $ do program <- mapM toJS (sortBy cmpStmt stmts)
100+ return (vars ++ concat program)
101+ where
102+ vars = "\nvar " ++ intercalate "," (letBoundVars stmts) ++ ";"
133− where cmpStmt s1 s2 = compare (valueOf s1) (valueOf s2)
103+ cmpStmt s1 s2 = compare (valueOf s1) (valueOf s2)
134− valueOf s = case s of
104+ valueOf s = case s of
135− Datatype _ _ _ -> 1
105+ Datatype _ _ _ -> 1
136− ImportEvent _ _ _ _ -> 2
106+ ImportEvent _ _ _ _ -> 2
137− Definition (FnDef f [] _) ->
107+ Definition (FnDef f [] _) ->
138− if derename f == "main" then 5 else 4
108+ if derename f == "main" then 5 else 4
139− Definition _ -> 3
109+ Definition _ -> 3
140− ExportEvent _ _ _ -> 6
110+ ExportEvent _ _ _ -> 6
141− TypeAlias _ _ _ -> 0
111+ TypeAlias _ _ _ -> 0
142− TypeAnnotation _ _ -> 0
112+ TypeAnnotation _ _ -> 0
143
113
144class ToJS a where
114class ToJS a where
145 toJS :: a -> GuidCounter String
115 toJS :: a -> GuidCounter String
146
116
147instance ToJS Def where
117instance ToJS Def where
148− toJS (FnDef x [] e) = assign x `liftM` toJS' e
118+ toJS (FnDef x [] e) = assign' x `liftM` toJS' e
149 toJS (FnDef f (a:as) e) =
119 toJS (FnDef f (a:as) e) =
150 do body <- toJS' (foldr (\x e -> noContext (Lambda x e)) e as)
120 do body <- toJS' (foldr (\x e -> noContext (Lambda x e)) e as)
151− return $ concat ["\nfunction ",f,parens a, brackets . indent $ ret body]
121+ return $ assign' f (jsFunc a (ret body))
152 toJS (OpDef op a1 a2 e) =
122 toJS (OpDef op a1 a2 e) =
153 do body <- toJS' (foldr (\x e -> noContext (Lambda x e)) e [a1,a2])
123 do body <- toJS' (foldr (\x e -> noContext (Lambda x e)) e [a1,a2])
154 return $ concat [ "\n$op['", op, "'] = ", body, ";" ]
124 return $ concat [ "\n$op['", op, "'] = ", body, ";" ]
155
125
156instance ToJS Statement where
126instance ToJS Statement where
127+ toJS stmt =
128+ case stmt of
157− toJS (Definition d) = toJS d
129+ Definition d -> (\asgn -> "\n" ++ asgn ++ ";") `liftM` toJS d
158− toJS (Datatype _ _ tcs) = concat `liftM` mapM (toJS . toDef) tcs
130+ Datatype _ _ tcs -> concat `liftM` mapM (toJS . toDef) tcs
159− where toDef (name,args) = Definition . FnDef name vars . noContext $
131+ where toDef (name,args) =
160− Data (derename name) (map (noContext . Var) vars)
161− where vars = map (('a':) . show) [1..length args]
132+ let vars = map (('a':) . show) [1..length args] in
133+ Definition . FnDef name vars . noContext $
134+ Data (derename name) (map (noContext . Var) vars)
162− toJS (ImportEvent js base elm _) =
135+ ImportEvent js base elm _ ->
163 do v <- toJS' base
136 do v <- toJS' base
164 return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal.constant(" ++ v ++ ");"
137 return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal.constant(" ++ v ++ ");"
165 , "\nValue.addListener(document, '" ++ js
138 , "\nValue.addListener(document, '" ++ js
166 , "', function(e) { Dispatcher.notify(" ++ elm
139 , "', function(e) { Dispatcher.notify(" ++ elm
167 , ".id, e.value); });" ]
140 , ".id, e.value); });" ]
168− toJS (ExportEvent js elm _) =
141+ ExportEvent js elm _ ->
169 return $ concat [ "\nlift(function(v) { "
142 return $ concat [ "\nlift(function(v) { "
170 , "var e = document.createEvent('Event');"
143 , "var e = document.createEvent('Event');"
171 , "e.initEvent('", js, "', true, true);"
144 , "e.initEvent('", js, "', true, true);"
172 , "e.value = v;"
145 , "e.value = v;"
173 , "document.dispatchEvent(e); return v; })(", elm, ");" ]
146 , "document.dispatchEvent(e); return v; })(", elm, ");" ]
174− toJS (TypeAnnotation _ _) = return ""
147+ TypeAnnotation _ _ -> return ""
175− toJS (TypeAlias _ _ _) = return ""
148+ TypeAlias n _ t ->
149+ case t of
150+ RecordT kvs _ -> return $ "\nfunction" ++ args ++ brackets body
151+ where fs = Map.keys kvs
152+ args = parens (intercalate "," fs)
153+ body = ret . brackets . intercalate "," $
154+ map (\k -> k ++ ":" ++ k) fs
155+ _ -> return ""
176
156
177toJS' :: CExpr -> GuidCounter String
157toJS' :: CExpr -> GuidCounter String
178toJS' (C txt span expr) =
158toJS' (C txt span expr) =
@@ -203,7 +183,7 @@ makeRecord kvs = record `liftM` collect kvs
203instance ToJS Expr where
183instance ToJS Expr where
204 toJS expr =
184 toJS expr =
205 case expr of
185 case expr of
206− IntNum n -> return $ show n
186+ IntNum n -> return $ show n ++ "|0"
207 FloatNum n -> return $ show n
187 FloatNum n -> return $ show n
208 Var x -> return $ x
188 Var x -> return $ x
209 Chr c -> return $ quoted [c]
189 Chr c -> return $ quoted [c]
@@ -249,22 +229,27 @@ formatMarkdown = concatMap f
249 f '"' = "\""
229 f '"' = "\""
250 f c = [c]
230 f c = [c]
251
231
252−multiIfToJS span ps = format `liftM` mapM f ps
232+multiIfToJS span ps =
233+ case last ps of
234+ (C _ _ (Var "otherwise"), e) -> toJS' e >>= \b -> format b (init ps)
235+ _ -> format err ps
236+ where
237+ format base ps =
253− where format cs = foldr (\c e -> parens $ c ++ " : " ++ e) err cs
238+ foldr (\c e -> parens $ c ++ " : " ++ e) base `liftM` mapM f ps
254− err = concat [ "(function(){throw new Error(\"Non-exhaustive "
239+ err = "throw new Error('Non-exhaustive multi-way-if expression (" ++
255− , "multi-way-if expression (", show span, ")\");}())" ]
240+ show span ++ ")')"
256− f (b,e) = do b' <- toJS' b
241+ f (b,e) = do b' <- toJS' b
257− e' <- toJS' e
242+ e' <- toJS' e
258− return (b' ++ " ? " ++ e')
243+ return (b' ++ " ? " ++ e')
259−
244+
260−jsLet defs e' = do
245+jsLet defs e' = do ds <- jsDefs defs
261− body <- (++) `liftM` jsDefs defs `ap` (ret `liftM` toJS' e')
246+ e <- toJS' e'
262− return $ jsFunc "" body ++ "()"
247+ return $ parens (intercalate ", " ds ++ ", " ++ e)
263−
248+ where
264−jsDefs defs = concat `liftM` mapM toJS (sortBy f defs)
249+ jsDefs defs = mapM toJS (sortBy f defs)
265− where f a b = compare (valueOf a) (valueOf b)
250+ f a b = compare (valueOf a) (valueOf b)
266− valueOf (FnDef _ args _) = min 1 (length args)
251+ valueOf (FnDef _ args _) = min 1 (length args)
267− valueOf (OpDef _ _ _ _) = 1
252+ valueOf (OpDef _ _ _ _) = 1
268
253
269caseToJS span e ps = do
254caseToJS span e ps = do
270 match <- caseToMatch ps
255 match <- caseToMatch ps
@@ -280,8 +265,9 @@ matchToJS span (Match name clauses def) = do
280 cases <- concat `liftM` mapM (clauseToJS span name) clauses
265 cases <- concat `liftM` mapM (clauseToJS span name) clauses
281 finally <- matchToJS span def
266 finally <- matchToJS span def
282 return $ concat [ "\nswitch(", name, ".ctor){", indent cases, "\n}", finally ]
267 return $ concat [ "\nswitch(", name, ".ctor){", indent cases, "\n}", finally ]
268+matchToJS span Fail =
283−matchToJS span Fail = return ("\nthrow new Error(\"Non-exhaustive pattern match " ++
269+ return ("\nthrow new Error(\"Non-exhaustive pattern match " ++
284− "in case expression (" ++ show span ++ ")\");")
270+ "in case expression (" ++ show span ++ ")\");")
285matchToJS span Break = return "break;"
271matchToJS span Break = return "break;"
286matchToJS span (Other e) = ret `liftM` toJS' e
272matchToJS span (Other e) = ret `liftM` toJS' e
287matchToJS span (Seq ms) = concat `liftM` mapM (matchToJS span) ms
273matchToJS span (Seq ms) = concat `liftM` mapM (matchToJS span) ms
@@ -291,12 +277,9 @@ clauseToJS span var (Clause name vars e) = do
291 s <- matchToJS span $ matchSubst (zip vars vars') e
277 s <- matchToJS span $ matchSubst (zip vars vars') e
292 return $ concat [ "\ncase ", quoted name, ":", s ]
278 return $ concat [ "\ncase ", quoted name, ":", s ]
293
279
294−jsNil = "[\"Nil\"]"
280+jsNil = "{ctor:'Nil'}"
295−jsCons e1 e2 = jsList [ quoted "Cons", e1, e2 ]
281+jsCons e1 e2 = "{ctor:'Cons',_0:" ++ e1 ++ ",_1:" ++ e2 ++ "}"
296−jsRange e1 e2 = (++"()") . jsFunc "" $
282+jsRange e1 e2 = "Elm.Native.List.range" ++ parens (e1 ++ "," ++ e2)
297− assign "lo" e1 ++ assign "hi" e2 ++ assign "lst" jsNil ++
298− "if(lo<=hi){do{lst=" ++ (jsCons "hi" "lst") ++ "}while(hi-->lo)}" ++
299− ret "lst"
300
283
301binop (o:p) e1 e2
284binop (o:p) e1 e2
302 | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
285 | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
elm/src/Gen/GenerateHtml.hs+9−10
@@ -47,23 +47,22 @@ generateHtml :: String -- ^ Location of elm-min.js as expected by the browser
47generateHtml libLoc title source =
47generateHtml libLoc title source =
48 case buildFromSource source of
48 case buildFromSource source of
49 Left err -> createHtml Readable libLoc title (Right $ showErr err) (H.noscript "")
49 Left err -> createHtml Readable libLoc title (Right $ showErr err) (H.noscript "")
50− Right (escs, modul) -> modulesToHtml Readable title libLoc [] True [(escs,modul)]
50+ Right modul -> modulesToHtml Readable title libLoc [] True [modul]
51
51
52
52
53−modulesToHtml jsStyle title libLoc jss nscrpt pairs =
53+modulesToHtml jsStyle title libLoc jss nscrpt modules =
54 createHtml jsStyle libLoc title' js noscript
54 createHtml jsStyle libLoc title' js noscript
55− where modules = map snd pairs
55+ where
56− js = Right $ jss ++ concatMap jsModule pairs
56+ js = Right $ jss ++ concatMap jsModule modules
57− noscript = if nscrpt then extractNoscript $ last modules else ""
57+ noscript = if nscrpt then extractNoscript $ last modules else ""
58− title' = if null title then altTitle else title
58+ title' = if null title then altTitle else title
59− altTitle = (\(Module names _ _ _) -> intercalate "." names) $
59+ altTitle = (\(Module names _ _ _) -> intercalate "." names) $ last modules
60− last modules
61
60
62
61
63linkedHtml rtLoc jsLoc modules =
62linkedHtml rtLoc jsLoc modules =
64 createHtml Readable rtLoc title (Left jsLoc) (H.noscript "")
63 createHtml Readable rtLoc title (Left jsLoc) (H.noscript "")
64+ where
65− where title = (\(Module names _ _ _) -> intercalate "." names) $
65+ title = (\(Module names _ _ _) -> intercalate "." names) (last modules)
66− snd (last modules)
67
66
68
67
69createHtml jsStyle libLoc title js noscript =
68createHtml jsStyle libLoc title js noscript =
elm/src/Initialize.hs+66−56
@@ -1,19 +1,20 @@
1−module Initialize (build,buildFromSource) where
1+module Initialize (build, buildFromSource) where
2
2
3import Control.Applicative ((<$>))
3import Control.Applicative ((<$>))
4import Control.Monad.Error
4import Control.Monad.Error
5−import Data.List (lookup)
5+import Data.List (lookup,nub)
6
6
7import Ast
7import Ast
8import Data.Either (lefts,rights)
8import Data.Either (lefts,rights)
9import Data.List (intercalate,partition)
9import Data.List (intercalate,partition)
10−import Parse.Parser (parseProgram)
10+import Parse.Parser (parseProgram, preParse)
11import Rename
11import Rename
12import Types.Types ((-:))
12import Types.Types ((-:))
13import Types.Hints (hints)
13import Types.Hints (hints)
14import Types.Unify
14import Types.Unify
15import Types.Alias
15import Types.Alias
16import Optimize
16import Optimize
17+import CompileToJS (jsModule)
17
18
18checkMistakes :: Module -> Either String Module
19checkMistakes :: Module -> Either String Module
19checkMistakes modul@(Module name ex im stmts) =
20checkMistakes modul@(Module name ex im stmts) =
@@ -21,75 +22,84 @@ checkMistakes modul@(Module name ex im stmts) =
21 m:ms -> Left (unlines (m:ms))
22 m:ms -> Left (unlines (m:ms))
22 [] -> return modul
23 [] -> return modul
23
24
24−checkTypes :: Module -> Either String ([String], Module)
25+checkTypes :: Module -> Either String Module
25checkTypes (Module name ex im stmts) =
26checkTypes (Module name ex im stmts) =
26 let stmts' = dealias stmts
27 let stmts' = dealias stmts
27 modul = Module name ex im stmts'
28 modul = Module name ex im stmts'
28− in do (escapees, subs) <- unify hints modul
29+ in do subs <- unify hints modul
29 let im' | any ((=="Prelude") . fst) im = im
30 let im' | any ((=="Prelude") . fst) im = im
30− | otherwise = ("Prelude", Hiding []) : im
31+ | otherwise = ("Prelude", Importing []) : im
31 modul' = optimize . renameModule $ Module name ex im' stmts'
32 modul' = optimize . renameModule $ Module name ex im' stmts'
32− subs `seq` return (escapees, modul')
33+ subs `seq` return modul'
33
34
34−check :: Module -> Either String ([String], Module)
35+check :: Module -> Either String Module
35check = checkMistakes >=> checkTypes
36check = checkMistakes >=> checkTypes
36
37
37−buildFromSource :: String -> Either String ([String],Module)
38+buildFromSource :: String -> Either String Module
38−buildFromSource = parseProgram >=> check
39+buildFromSource src = check =<< parseProgram src
39
40
40−build :: Bool -> FilePath -> IO (Either String ([String],[Module]))
41+build :: FilePath -> IO (Either String [Module])
41−build make root = do
42+build root = do
42− proj <- parse make root
43+ names <- getSortedModuleNames root
43− return $ do
44+ case names of
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)
45 Left err -> return (Left err)
57− Right modul@(Module names exs ims stmts) ->
46+ Right ns -> do srcs <- zipWithM buildFile' [1..] ns
58− let allDeps = map toFilePath (getDeps modul)
47+ return (sequence srcs)
59− newDeps = if make then filter (`notElem` seen) allDeps else []
48+ where
60− name = intercalate "." names
49+ buildFile' n name = putStrLn (msg n name) >> buildFile name
61− in do ps <- mapM (parseProject (name : seen ++ newDeps) make) newDeps
50+ msg n name = "["++show n++" of "++show (length ns)++"] Compiling "++name
62− return $ case unlines (lefts ps) of
63− c:cs -> Left (c:cs)
64− _ -> Right (modul : concat (rights ps))
65
51
66−toFilePath :: String -> FilePath
52+buildFile :: String -> IO (Either String Module)
67−toFilePath modul = map (\c -> if c == '.' then '/' else c) modul ++ ".elm"
53+buildFile moduleName =
54+ let filePath = toFilePath moduleName in
55+ case isNative moduleName of
56+ True -> return (Right $ Module [moduleName] [] [] [])
57+ --return (Left "Can't do that yet")
58+ --Right `liftM` readFile filePath
59+ False -> do txt <- readFile filePath
60+ return $ buildFromSource txt
68
61
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
62
63+getSortedModuleNames :: FilePath -> IO (Either String [String])
64+getSortedModuleNames root = do
65+ deps <- readDeps [] root
66+ return (sortDeps =<< deps)
79
67
68+type Deps = (String, [String])
69+
80−sort :: [Module] -> Either String [Module]
70+sortDeps :: [Deps] -> Either String [String]
81−sort = go []
71+sortDeps deps = go [] (nub deps)
82 where
72 where
83 msg = "A cyclical or missing module dependency or was detected in: "
73 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
74
89− go :: [Module] -> [Module] -> Either String [Module]
75+ go :: [String] -> [Deps] -> Either String [String]
90 go sorted [] = Right sorted
76 go sorted [] = Right sorted
91 go sorted unsorted =
77 go sorted unsorted =
92− case partition (all (within sorted) . getDeps) unsorted of
78+ case partition (all (`elem` sorted) . snd) unsorted of
93− ([],m:ms) -> Left (msg ++ intercalate ", " (map getName (m:ms)))
79+ ([],m:ms) -> Left (msg ++ intercalate ", " (map fst (m:ms)) ++ show sorted ++ show unsorted)
94− (srtd,unsrtd) -> go (sorted ++ srtd) unsrtd
80+ (srtd,unsrtd) -> go (sorted ++ map fst srtd) unsrtd
95−
81+
82+readDeps :: [FilePath] -> FilePath -> IO (Either String [Deps])
83+readDeps seen root = do
84+ txt <- readFile root
85+ case preParse txt of
86+ Left err -> return (Left err)
87+ Right (name,deps) -> do rest <- mapM (readDeps seen' . toFilePath) newDeps
88+ return $ do rs <- sequence rest
89+ return ((name, realDeps) : concat rs)
90+ where realDeps = filter (`notElem` builtIns) deps
91+ newDeps = filter (`notElem` seen) realDeps
92+ seen' = root : seen ++ newDeps
93+ builtIns = [] {--
94+ ["List","Char","Either","Maybe","Dict","Set","Date",
95+ "Signal","Mouse","Keyboard.Raw","Keyboard","Touch",
96+ "WebSocket","Window","Time","HTTP","Input","Random",
97+ "Graphics","Text","Color","JavaScript","Automaton",
98+ "JavaScript.Experimental","Prelude","JSON"]
99+ --}
100+
101+isNative name = takeWhile (/='.') name == "Native"
102+toFilePath name = map swapDots name ++ ext
103+ where swapDots '.' = '/'
104+ swapDots c = c
105+ ext = if isNative name then ".js" else ".elm"
elm/src/Language/Elm.hs+1−1
@@ -79,4 +79,4 @@ toPartsHelper :: String -> (Html, Html, String)
79toPartsHelper source = (html, css, js)
79toPartsHelper source = (html, css, js)
80 where modul = buildFromSource source
80 where modul = buildFromSource source
81 js = either showErr jsModule modul
81 js = either showErr jsModule modul
82− html = widgetBody $ either id (extractNoscript . snd) modul
82+ html = widgetBody $ either id extractNoscript modul
elm/src/Parse/Library.hs+1−1
@@ -162,7 +162,7 @@ whitespace :: IParser ()
162whitespace = optional forcedWS <?> ""
162whitespace = optional forcedWS <?> ""
163
163
164freshLine :: IParser [[String]]
164freshLine :: IParser [[String]]
165−freshLine = try (do { many1 newline; many space_nl }) <|> try (many1 space_nl) <?> ""
165+freshLine = try (many1 newline >> many space_nl) <|> try (many1 space_nl) <?> ""
166 where space_nl = try $ spaces >> many1 newline
166 where space_nl = try $ spaces >> many1 newline
167
167
168newline :: IParser String
168newline :: IParser String
elm/src/Parse/Modules.hs+1−6
@@ -31,17 +31,12 @@ import' = do
31 reserved "import"
31 reserved "import"
32 whitespace
32 whitespace
33 name <- intercalate "." <$> dotSep1 capVar
33 name <- intercalate "." <$> dotSep1 capVar
34− method <- option (Hiding []) $ try (whitespace >>
34+ method <- option (Importing []) $ try (whitespace >> (as' <|> importing'))
35− (as' <|> hiding' <|> importing'))
36 return (name, method)
35 return (name, method)
37
36
38
37
39as' :: IParser ImportMethod
38as' :: IParser ImportMethod
40as' = reserved "as" >> whitespace >> As <$> capVar <?> "alias for module"
39as' = reserved "as" >> whitespace >> As <$> capVar <?> "alias for module"
41
40
42−hiding' :: IParser ImportMethod
43−hiding' = reserved "hiding" >> whitespace >>
44− Hiding <$> varList <?> "listing of hidden values"
45−
46importing' :: IParser ImportMethod
41importing' :: IParser ImportMethod
47importing' = Importing <$> varList <?> "listing of imported values (x,y,z)"
42importing' = Importing <$> varList <?> "listing of imported values (x,y,z)"
elm/src/Parse/Parser.hs+17−4
@@ -1,10 +1,10 @@
1−module Parse.Parser (parseProgram) where
1+module Parse.Parser (parseProgram, preParse) where
2
2
3import Ast
3import Ast
4import Control.Applicative ((<$>), (<*>))
4import Control.Applicative ((<$>), (<*>))
5import Control.Monad
5import Control.Monad
6import Data.Char (isSymbol, isDigit)
6import Data.Char (isSymbol, isDigit)
7−import Data.List (foldl')
7+import Data.List (foldl',intercalate)
8import Text.Parsec hiding (newline,spaces)
8import Text.Parsec hiding (newline,spaces)
9
9
10import Parse.Library
10import Parse.Library
@@ -33,7 +33,20 @@ program = do
33 optional freshLine ; optional spaces ; eof
33 optional freshLine ; optional spaces ; eof
34 return $ Module names exports is statements
34 return $ Module names exports is statements
35
35
36−parseProgram source =
36+parseProgram = setupParser program
37+
38+preParse :: String -> Either String (String, [String])
39+preParse = setupParser $ do
40+ optional skip
41+ (,) <$> option "Main" moduleName <*> option [] imprts
42+ where
43+ skip = try (manyTill anyChar (try (string "/**")))
44+ imprts = fmap (map fst) imports `followedBy` freshLine
45+ getName = intercalate "." . fst
46+ moduleName = do optional freshLine
47+ getName <$> moduleDef `followedBy` freshLine
48+
49+setupParser p source =
37− case iParse program "" source of
50+ case iParse p "" source of
38 Right result -> Right result
51 Right result -> Right result
39 Left err -> Left $ "Parse error at " ++ show err
52 Left err -> Left $ "Parse error at " ++ show err
elm/src/Types/Constrain.hs+4−3
@@ -24,7 +24,6 @@ getAliases imports hints = hints ++ concatMap aliasesFrom imports'
24 aliasesFrom (name,method) =
24 aliasesFrom (name,method) =
25 case method of
25 case method of
26 As alias -> concatMap (findAlias name alias) hints
26 As alias -> concatMap (findAlias name alias) hints
27− Hiding [] -> concatMap (findAlias name "") hints
28 _ -> []
27 _ -> []
29 findAlias mName' mAlias (name,tipe) =
28 findAlias mName' mAlias (name,tipe) =
30 let mName = mName' ++ "." in
29 let mName = mName' ++ "." in
@@ -63,7 +62,7 @@ constrain typeHints (Module _ _ imports stmts) = do
63 (as', cs', schemes) <- mergeSchemes schemess
62 (as', cs', schemes) <- mergeSchemes schemess
64 let constraints = Set.unions (cs':css)
63 let constraints = Set.unions (cs':css)
65 as = unionsA (as':ass)
64 as = unionsA (as':ass)
66− extraImports = ("Time", Hiding ["read"]) : map (\n -> (n, Hiding []))
65+ extraImports = ("Time", Importing []) : map (\n -> (n, Importing []))
67 ["List","Signal","Text","Graphics","Color"]
66 ["List","Signal","Text","Graphics","Color"]
68 aliasHints = getAliases (imports ++ extraImports) hints
67 aliasHints = getAliases (imports ++ extraImports) hints
69 allHints = Map.union schemes (Map.fromList aliasHints)
68 allHints = Map.union schemes (Map.fromList aliasHints)
@@ -73,7 +72,9 @@ constrain typeHints (Module _ _ imports stmts) = do
73 let f k s vs = map (\v -> C (Just k) NoSpan $ v :<<: s) vs
72 let f k s vs = map (\v -> C (Just k) NoSpan $ v :<<: s) vs
74 cs = concat . Map.elems $ Map.intersectionWithKey f allHints assumptions
73 cs = concat . Map.elems $ Map.intersectionWithKey f allHints assumptions
75 escapees = Map.keys $ Map.difference assumptions allHints
74 escapees = Map.keys $ Map.difference assumptions allHints
75+ return $ case escapees of
76− return . Right . (,) escapees $ Set.toList constraints ++ cs
76+ _ -> Right (Set.toList constraints ++ cs)
77+ --_ -> Left ("Undefined variable(s): " ++ intercalate ", " escapees)
77
78
78type TVarMap = Map.Map String [X]
79type TVarMap = Map.Map String [X]
79type ConstraintSet = Set.Set (Context Constraint)
80type ConstraintSet = Set.Set (Context Constraint)
elm/src/Types/Unify.hs+1−6
@@ -10,10 +10,5 @@ import Types.Solver
10
10
11unify hints modul = run $ do
11unify hints modul = run $ do
12 constraints <- constrain hints modul
12 constraints <- constrain hints modul
13− case constraints of
14− Left msg -> return (Left msg)
15− Right (escapees, cs) ->
16− do subs <- solver cs Map.empty
13+ either (return . Left) (\cs -> solver cs Map.empty) constraints
17− return $ do ss <- subs
18− return (escapees, ss)
19
14