@@ -19,13 +19,27 @@ import Rename (deprime)
19import Types.Types ( Type(RecordT) )
19import Types.Types ( Type(RecordT) )
21showErr :: String -> String
21showErr :: String -> String
22−showErr err = mainEquals $ "Elm.Graphics.text(Elm.Text.monospace(" ++ msg ++ "))"
22+showErr err = "Elm.Graphics.text(Elm.Text.monospace(" ++ msg ++ "))"
23 where msg = show . concatMap (++"<br>") . lines $ err
23 where msg = show . concatMap (++"<br>") . lines $ err
25indent = concatMap f
25indent = concatMap f
26 where f '\n' = "\n "
26 where f '\n' = "\n "
30+ [ ("_Utils", "Elm.Native.Utils(elm)"),
31+ ("_insert", "_Utils.insert"),
32+ ("_remove", "_Utils.remove"),
33+ ("_replace", "_Utils.replace"),
34+ ("_eq", "_Utils.eq"),
35+ ("_compare", "_Utils.compare"),
36+ ("_range", "Elm.Native.List(elm).range"),
37+ ("_append", "Elm.Native.List(elm).append"),
38+ ("_caseError", "Elm.Native.Error(elm).Case"),
39+ ("_ifError", "Elm.Native.Error(elm).If"),
40+ ("_str", "Elm.Native.JavaScript(elm).toString")
29parens s = "(" ++ s ++ ")"
43parens s = "(" ++ s ++ ")"
30brackets s = "{" ++ s ++ "}"
44brackets s = "{" ++ s ++ "}"
31jsList ss = "["++ intercalate "," ss ++"]"
45jsList ss = "["++ intercalate "," ss ++"]"
@@ -41,24 +55,26 @@ quoted s = "'" ++ concatMap f s ++ "'"
41 f '\\' = "\\\\"
55 f '\\' = "\\\\"
44−mainEquals s = globalAssign "Elm.main" (jsFunc "" (ret (s ++ ".main")))
45globalAssign n e = "\n" ++ assign' n e ++ ";"
58globalAssign n e = "\n" ++ assign' n e ++ ";"
46assign' n e = n ++ " = " ++ e
59assign' n e = n ++ " = " ++ e
48jsModule (Module names exports imports stmts) =
61jsModule (Module names exports imports stmts) =
49− setup ++ parens (jsFunc "" program ++ "()") ++ mainEquals modName
62+ setup ++ globalAssign ("Elm." ++ modName) (jsFunc "elm" program)
51− modNames = if null names then ["Elm", "Main"] else "Elm" : names
64+ modNames = if null names then ["Main"] else names
52 modName = intercalate "." modNames
65 modName = intercalate "." modNames
53 includes = concatMap jsImport imports
66 includes = concatMap jsImport imports
54 body = stmtsToJS stmts
67 body = stmtsToJS stmts
55 export = getExports exports stmts
68 export = getExports exports stmts
56 exps = if null exports then ["main"] else exports
69 exps = if null exports then ["main"] else exports
57 defs = assign "$op" "{}"
70 defs = assign "$op" "{}"
58− program = defs ++ includes ++ body ++ globalAssign modName export
71+ program = usefulFuncs ++ defs ++ includes ++ body ++
72+ ret ("elm." ++ modName ++ " = " ++ export)
59 setup = concatMap (\n -> globalAssign n $ n ++ " || {}") .
73 setup = concatMap (\n -> globalAssign n $ n ++ " || {}") .
60− map (intercalate ".") . drop 2 . inits $
74+ map (intercalate ".") . tail . inits $
61 take (length modNames - 1) modNames
75 take (length modNames - 1) modNames
77+ "var " ++ intercalate ", " (map (uncurry assign) internalImports) ++ ";"
63getExports names stmts = brackets . ("\n "++) $
79getExports names stmts = brackets . ("\n "++) $
64 intercalate ",\n " (op : map fnPair fns)
80 intercalate ",\n " (op : map fnPair fns)
@@ -85,11 +101,11 @@ getExports names stmts = brackets . ("\n "++) $
86jsImport (modul, how) =
102jsImport (modul, how) =
87 case how of
103 case how of
88− As name -> assign name ("Elm." ++ modul)
104+ As name -> assign name ("Elm." ++ modul ++ parens "elm")
89 Importing vs ->
105 Importing vs ->
90− assign modul ("Elm." ++ modul) ++ concatMap def vs
106+ "\nElm." ++ modul ++ parens "elm" ++ ";" ++ concatMap def vs
92− imprt asgn v = asgn v ("Elm." ++ modul ++ "." ++ v)
108+ imprt asgn v = asgn v ("elm." ++ modul ++ "." ++ v)
93 def (o:p) =
109 def (o:p) =
94 if isOp o then imprt globalAssign ("$op['" ++ o:p ++ "']")
110 if isOp o then imprt globalAssign ("$op['" ++ o:p ++ "']")
95 else imprt assign (deprime (o:p))
111 else imprt assign (deprime (o:p))
@@ -137,13 +153,13 @@ instance ToJS Statement where
137 ImportEvent js base elm _ ->
153 ImportEvent js base elm _ ->
138 do v <- toJS' base
154 do v <- toJS' base
139 return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal.constant(" ++ v ++ ");"
155 return $ concat [ "\nvar " ++ elm ++ "=Elm.Signal.constant(" ++ v ++ ");"
140− , "\nValue.addListener(document, '" ++ js
156+ , "\ndocument.addEventListener('", js
141− , "', function(e) { Dispatcher.notify(" ++ elm
157+ , "_' + elm.id, function(e) { elm.notify(", elm
142 , ".id, e.value); });" ]
158 , ".id, e.value); });" ]
143 ExportEvent js elm _ ->
159 ExportEvent js elm _ ->
144 return $ concat [ "\nlift(function(v) { "
160 return $ concat [ "\nlift(function(v) { "
145 , "var e = document.createEvent('Event');"
161 , "var e = document.createEvent('Event');"
146− , "e.initEvent('", js, "', true, true);"
162+ , "e.initEvent('", js, "_' + elm.id, true, true);"
147 , "e.value = v;"
163 , "e.value = v;"
148 , "document.dispatchEvent(e); return v; })(", elm, ");" ]
164 , "document.dispatchEvent(e); return v; })(", elm, ");" ]
149 TypeAnnotation _ _ -> return ""
165 TypeAnnotation _ _ -> return ""
@@ -163,9 +179,9 @@ toJS' (C txt span expr) =
163 Case e cases -> caseToJS span e cases
179 Case e cases -> caseToJS span e cases
164 _ -> toJS expr
180 _ -> toJS expr
166−remove x e = "elmRecordRemove('" ++ x ++ "', " ++ e ++ ")"
182+remove x e = "_remove('" ++ x ++ "', " ++ e ++ ")"
167−addField x v e = "elmRecordInsert('" ++ x ++ "', " ++ v ++ ", " ++ e ++ ")"
183+addField x v e = "_insert('" ++ x ++ "', " ++ v ++ ", " ++ e ++ ")"
168−setField fs e = "elmRecordReplace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"
184+setField fs e = "_replace(" ++ jsList (map f fs) ++ ", " ++ e ++ ")"
169 where f (x,v) = "['" ++ x ++ "'," ++ v ++ "]"
185 where f (x,v) = "['" ++ x ++ "'," ++ v ++ "]"
170access x e = parens e ++ "." ++ x
186access x e = parens e ++ "." ++ x
171makeRecord kvs = record `liftM` collect kvs
187makeRecord kvs = record `liftM` collect kvs
@@ -185,11 +201,11 @@ makeRecord kvs = record `liftM` collect kvs
185instance ToJS Expr where
201instance ToJS Expr where
186 toJS expr =
202 toJS expr =
187 case expr of
203 case expr of
188− IntNum n -> return $ show n ++ "|0"
204+ IntNum n -> return $ show n
189 FloatNum n -> return $ show n
205 FloatNum n -> return $ show n
190 Var x -> return $ x
206 Var x -> return $ x
191 Chr c -> return $ quoted [c]
207 Chr c -> return $ quoted [c]
192− Str s -> return $ "Value.str" ++ parens (quoted s)
208+ Str s -> return $ "_str" ++ parens (quoted s)
193 Boolean b -> return $ if b then "true" else "false"
209 Boolean b -> return $ if b then "true" else "false"
194 Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
210 Range lo hi -> jsRange `liftM` toJS' lo `ap` toJS' hi
195 Access e x -> access x `liftM` toJS' e
211 Access e x -> access x `liftM` toJS' e
@@ -238,7 +254,7 @@ formatMarkdown = concatMap f
238multiIfToJS span ps =
254multiIfToJS span ps =
239 case last ps of
255 case last ps of
240 (C _ _ (Var "otherwise"), e) -> toJS' e >>= \b -> format b (init ps)
256 (C _ _ (Var "otherwise"), e) -> toJS' e >>= \b -> format b (init ps)
241− _ -> format ("Elm.Error.If" ++ parens (quoted (show span))) ps
257+ _ -> format ("_ifError" ++ parens (quoted (show span))) ps
243 format base ps =
259 format base ps =
244 foldr (\c e -> parens $ c ++ " : " ++ e) base `liftM` mapM f ps
260 foldr (\c e -> parens $ c ++ " : " ++ e) base `liftM` mapM f ps
@@ -263,7 +279,7 @@ caseToJS span e ps = do
263 return (matchSubst [(name,x)] match, Nothing)
279 return (matchSubst [(name,x)] match, Nothing)
264 (Match name _ _, _) ->
280 (Match name _ _, _) ->
265 return (match, Just (name ++ " = " ++ e'))
281 return (match, Just (name ++ " = " ++ e'))
266− _ -> return (match, Nothing) -- Just e'
282+ _ -> return (match, Nothing)
267 matches <- matchToJS span match'
283 matches <- matchToJS span match'
268 return $ case stmt of
284 return $ case stmt of
269 Nothing -> matches
285 Nothing -> matches
@@ -276,7 +292,7 @@ matchToJS span match =
276 do cases <- intercalate " : " `liftM` mapM (clauseToJS span name) clauses
292 do cases <- intercalate " : " `liftM` mapM (clauseToJS span name) clauses
277 finally <- matchToJS span def
293 finally <- matchToJS span def
278 return (sqnc cases finally)
294 return (sqnc cases finally)
279− Fail -> return ("Elm.Error.Case" ++ parens (quoted (show span)))
295+ Fail -> return ("_caseError" ++ parens (quoted (show span)))
280 Break -> return "null"
296 Break -> return "null"
281 Other e -> toJS' e
297 Other e -> toJS' e
282 Seq ms -> foldr1 sqnc `liftM` mapM (matchToJS span) (dropEnd [] ms)
298 Seq ms -> foldr1 sqnc `liftM` mapM (matchToJS span) (dropEnd [] ms)
@@ -294,7 +310,8 @@ clauseToJS span var (Clause name vars e) = do
295jsNil = "{ctor:'Nil'}"
311jsNil = "{ctor:'Nil'}"
296jsCons e1 e2 = "{ctor:'Cons',_0:" ++ e1 ++ ",_1:" ++ e2 ++ "}"
312jsCons e1 e2 = "{ctor:'Cons',_0:" ++ e1 ++ ",_1:" ++ e2 ++ "}"
297−jsRange e1 e2 = "Elm.Native.List.range" ++ parens (e1 ++ "," ++ e2)
313+jsRange e1 e2 = "_range" ++ parens (e1 ++ "," ++ e2)
314+jsCompare e1 e2 op = parens ("_compare(" ++ e1 ++ "," ++ e2 ++ ").ctor " ++ op)
299binop (o:p) e1 e2
316binop (o:p) e1 e2
300 | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
317 | isAlpha o || '_' == o = (o:p) ++ parens e1 ++ parens e2
@@ -302,23 +319,19 @@ binop (o:p) e1 e2
302 let ops = ["+","-","*","/","&&","||"] in
319 let ops = ["+","-","*","/","&&","||"] in
303 case o:p of
320 case o:p of
304 "::" -> jsCons e1 e2
321 "::" -> jsCons e1 e2
305− "++" -> append e1 e2
322+ "++" -> "_append" ++ parens (e1 ++ "," ++ e2)
306 "$" -> e1 ++ parens e2
323 "$" -> e1 ++ parens e2
307 "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
324 "." -> jsFunc "x" . ret $ e1 ++ parens (e2 ++ parens "x")
308 "^" -> "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")"
325 "^" -> "Math.pow(" ++ e1 ++ "," ++ e2 ++ ")"
309− "==" -> "eq(" ++ e1 ++ "," ++ e2 ++ ")"
326+ "==" -> "_eq(" ++ e1 ++ "," ++ e2 ++ ")"
310− "/=" -> "not(eq(" ++ e1 ++ "," ++ e2 ++ "))"
327+ "/=" -> "!_eq(" ++ e1 ++ "," ++ e2 ++ ")"
311− "<" -> "(compare(" ++ e1 ++ ")(" ++ e2 ++ ").ctor === 'LT')"
328+ "<" -> jsCompare e1 e2 "=== 'LT'"
312− ">" -> "(compare(" ++ e1 ++ ")(" ++ e2 ++ ").ctor === 'GT')"
329+ ">" -> jsCompare e1 e2 "=== 'GT'"
313− "<=" -> "function() { var ord = compare(" ++ e1 ++ ")(" ++
330+ "<=" -> jsCompare e1 e2 "!== 'GT'"
314− e2 ++ ").ctor; return ord==='LT' || ord==='EQ'; }()"
331+ ">=" -> jsCompare e1 e2 "!== 'LT'"
315− ">=" -> "function() { var ord = compare(" ++ e1 ++ ")(" ++
316− e2 ++ ").ctor; return ord==='GT' || ord==='EQ'; }()"
317 "<~" -> "lift" ++ parens e1 ++ parens e2
332 "<~" -> "lift" ++ parens e1 ++ parens e2
318 "~" -> "lift2(function(f){return function(x){return f(x);};})" ++
333 "~" -> "lift2(function(f){return function(x){return f(x);};})" ++
319 parens e1 ++ parens e2
334 parens e1 ++ parens e2
320 _ | elem (o:p) ops -> parens (e1 ++ (o:p) ++ e2)
335 _ | elem (o:p) ops -> parens (e1 ++ (o:p) ++ e2)
321 | otherwise -> concat [ "$op['", o:p, "']"
336 | otherwise -> concat [ "$op['", o:p, "']"
322− , parens e1, parens e2 ]
337+ , parens e1, parens e2 ]
324−append e1 e2 = "Value.append" ++ parens (e1 ++ "," ++ e2)