Mercurial > urweb

comparison src/jscomp.sml @ 589:102e81d975e3

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Included a recursive function in JavaScript
author Adam Chlipala <adamc@hcoop.net>
date Thu, 01 Jan 2009 11:58:00 -0500
parents 5803b4f041cb
children 57f476c934da
comparison
equal deleted inserted replaced
588:5803b4f041cb 589:102e81d975e3
31 31
32 structure EM = ErrorMsg 32 structure EM = ErrorMsg
33 structure E = MonoEnv 33 structure E = MonoEnv
34 structure U = MonoUtil 34 structure U = MonoUtil
35 35
36 structure IS = IntBinarySet
37 structure IM = IntBinaryMap
38
36 val funcs = [(("Basis", "alert"), "alert"), 39 val funcs = [(("Basis", "alert"), "alert"),
37 (("Basis", "htmlifyBool"), "bs"), 40 (("Basis", "htmlifyBool"), "bs"),
38 (("Basis", "htmlifyFloat"), "ts"), 41 (("Basis", "htmlifyFloat"), "ts"),
39 (("Basis", "htmlifyInt"), "ts"), 42 (("Basis", "htmlifyInt"), "ts"),
40 (("Basis", "htmlifyString"), "escape"), 43 (("Basis", "htmlifyString"), "escape"),
52 55
53 fun ffi k = FM.find (funcs, k) 56 fun ffi k = FM.find (funcs, k)
54 57
55 type state = { 58 type state = {
56 decls : decl list, 59 decls : decl list,
57 script : string 60 script : string list,
61 included : IS.set
58 } 62 }
59 63
60 fun varDepth (e, _) = 64 fun varDepth (e, _) =
61 case e of 65 case e of
62 EPrim _ => 0 66 EPrim _ => 0
96 case es of 100 case es of
97 [] => (EPrim (Prim.String ""), loc) 101 [] => (EPrim (Prim.String ""), loc)
98 | [x] => x 102 | [x] => x
99 | x :: es' => (EStrcat (x, strcat loc es'), loc) 103 | x :: es' => (EStrcat (x, strcat loc es'), loc)
100 104
101 fun jsExp mode skip outer =
102 let
103 val len = length outer
104
105 fun jsE inner (e as (_, loc), st) =
106 let
107 fun str s = (EPrim (Prim.String s), loc)
108
109 fun var n = Int.toString (len + inner - n - 1)
110
111 fun patCon pc =
112 case pc of
113 PConVar n => str (Int.toString n)
114 | PConFfi {mod = "Basis", con = "True", ...} => str "true"
115 | PConFfi {mod = "Basis", con = "False", ...} => str "false"
116 | PConFfi {con, ...} => str ("\"_" ^ con ^ "\"")
117
118 fun isNullable (t, _) =
119 case t of
120 TOption _ => true
121 | TRecord [] => true
122 | _ => false
123
124 fun unsupported s =
125 (EM.errorAt loc (s ^ " in code to be compiled to JavaScript");
126 (str "ERROR", st))
127
128 val strcat = strcat loc
129
130 fun quoteExp (t : typ) e =
131 case #1 t of
132 TSource => strcat [str "s",
133 (EFfiApp ("Basis", "htmlifyInt", [e]), loc)]
134 | TRecord [] => str "null"
135 | TFfi ("Basis", "string") => e
136 | _ => (EM.errorAt loc "Don't know how to embed type in JavaScript";
137 Print.prefaces "Can't embed" [("t", MonoPrint.p_typ MonoEnv.empty t)];
138 str "ERROR")
139
140 fun jsPrim p =
141 case p of
142 Prim.String s =>
143 str ("\""
144 ^ String.translate (fn #"'" =>
145 if mode = Attribute then
146 "\\047"
147 else
148 "'"
149 | #"\"" => "\\\""
150 | #"<" =>
151 if mode = Script then
152 "<"
153 else
154 "\\074"
155 | #"\\" => "\\\\"
156 | ch => String.str ch) s
157 ^ "\"")
158 | _ => str (Prim.toString p)
159
160 fun jsPat depth inner (p, _) succ fail =
161 case p of
162 PWild => succ
163 | PVar _ => strcat [str ("(_" ^ Int.toString (len + inner) ^ "=d" ^ Int.toString depth ^ ","),
164 succ,
165 str ")"]
166 | PPrim p => strcat [str ("(d" ^ Int.toString depth ^ "=="),
167 jsPrim p,
168 str "?",
169 succ,
170 str ":",
171 fail,
172 str ")"]
173 | PCon (_, PConFfi {mod = "Basis", con = "True", ...}, NONE) =>
174 strcat [str ("(d" ^ Int.toString depth ^ "?"),
175 succ,
176 str ":",
177 fail,
178 str ")"]
179 | PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE) =>
180 strcat [str ("(d" ^ Int.toString depth ^ "?"),
181 fail,
182 str ":",
183 succ,
184 str ")"]
185 | PCon (_, pc, NONE) =>
186 strcat [str ("(d" ^ Int.toString depth ^ "=="),
187 patCon pc,
188 str "?",
189 succ,
190 str ":",
191 fail,
192 str ")"]
193 | PCon (_, pc, SOME p) =>
194 strcat [str ("(d" ^ Int.toString depth ^ ".n=="),
195 patCon pc,
196 str ("?(d" ^ Int.toString depth ^ "=d" ^ Int.toString depth ^ ".v,"),
197 succ,
198 str "):",
199 fail,
200 str ")"]
201 | PRecord xps =>
202 let
203 val (_, succ) = foldl
204 (fn ((x, p, _), (inner, succ)) =>
205 (inner + E.patBindsN p,
206 strcat [str ("(d" ^ Int.toString (depth+1) ^ "=d"
207 ^ Int.toString depth ^ "._" ^ x ^ ","),
208 jsPat (depth+1) inner p succ fail,
209 str ")"]))
210 (inner, succ) xps
211 in
212 succ
213 end
214 | PNone _ => strcat [str ("(d" ^ Int.toString depth ^ "?"),
215 fail,
216 str ":",
217 succ,
218 str ")"]
219 | PSome (_, p) => strcat [str ("(d" ^ Int.toString depth ^ "?"),
220 jsPat depth inner p succ fail,
221 str ":",
222 fail,
223 str ")"]
224 in
225 case #1 e of
226 EPrim p => (jsPrim p, st)
227 | ERel n =>
228 if n < inner then
229 (str ("_" ^ var n), st)
230 else
231 let
232 val n = n - inner
233 in
234 (quoteExp (List.nth (outer, n)) (ERel (n - skip), loc), st)
235 end
236 | ENamed _ => raise Fail "Named"
237 | ECon (_, pc, NONE) => (patCon pc, st)
238 | ECon (_, pc, SOME e) =>
239 let
240 val (s, st) = jsE inner (e, st)
241 in
242 (strcat [str "{n:",
243 patCon pc,
244 str ",v:",
245 s,
246 str "}"], st)
247 end
248 | ENone _ => (str "null", st)
249 | ESome (t, e) =>
250 let
251 val (e, st) = jsE inner (e, st)
252 in
253 (if isNullable t then
254 strcat [str "{v:", e, str "}"]
255 else
256 e, st)
257 end
258
259 | EFfi k =>
260 let
261 val name = case ffi k of
262 NONE => (EM.errorAt loc ("Unsupported FFI identifier " ^ #2 k ^ " in JavaScript");
263 "ERROR")
264 | SOME s => s
265 in
266 (str name, st)
267 end
268 | EFfiApp (m, x, args) =>
269 let
270 val args =
271 case (m, x, args) of
272 ("Basis", "new_client_source", [(EJavaScript (_, e, _), _)]) => [e]
273 | ("Basis", "set_client_source", [e1, (EJavaScript (_, e2, _), _)]) => [e1, e2]
274 | _ => args
275
276 val name = case ffi (m, x) of
277 NONE => (EM.errorAt loc ("Unsupported FFI function " ^ x ^ " in JavaScript");
278 "ERROR")
279 | SOME s => s
280 in
281 case args of
282 [] => (str (name ^ "()"), st)
283 | [e] =>
284 let
285 val (e, st) = jsE inner (e, st)
286 in
287 (strcat [str (name ^ "("),
288 e,
289 str ")"], st)
290 end
291 | e :: es =>
292 let
293 val (e, st) = jsE inner (e, st)
294 val (es, st) = ListUtil.foldlMapConcat
295 (fn (e, st) =>
296 let
297 val (e, st) = jsE inner (e, st)
298 in
299 ([str ",", e], st)
300 end)
301 st es
302 in
303 (strcat (str (name ^ "(")
304 :: e
305 :: es
306 @ [str ")"]), st)
307 end
308 end
309
310 | EApp (e1, e2) =>
311 let
312 val (e1, st) = jsE inner (e1, st)
313 val (e2, st) = jsE inner (e2, st)
314 in
315 (strcat [e1, str "(", e2, str ")"], st)
316 end
317 | EAbs (_, _, _, e) =>
318 let
319 val locals = List.tabulate
320 (varDepth e,
321 fn i => str ("var _" ^ Int.toString (len + inner + i + 1) ^ ";"))
322 val (e, st) = jsE (inner + 1) (e, st)
323 in
324 (strcat (str ("function(_"
325 ^ Int.toString (len + inner)
326 ^ "){")
327 :: locals
328 @ [str "return ",
329 e,
330 str "}"]),
331 st)
332 end
333
334 | EUnop (s, e) =>
335 let
336 val (e, st) = jsE inner (e, st)
337 in
338 (strcat [str ("(" ^ s),
339 e,
340 str ")"],
341 st)
342 end
343 | EBinop (s, e1, e2) =>
344 let
345 val (e1, st) = jsE inner (e1, st)
346 val (e2, st) = jsE inner (e2, st)
347 in
348 (strcat [str "(",
349 e1,
350 str s,
351 e2,
352 str ")"],
353 st)
354 end
355
356 | ERecord [] => (str "null", st)
357 | ERecord [(x, e, _)] =>
358 let
359 val (e, st) = jsE inner (e, st)
360 in
361 (strcat [str "{_x:", e, str "}"], st)
362 end
363 | ERecord ((x, e, _) :: xes) =>
364 let
365 val (e, st) = jsE inner (e, st)
366
367 val (es, st) =
368 foldr (fn ((x, e, _), (es, st)) =>
369 let
370 val (e, st) = jsE inner (e, st)
371 in
372 (str (",_" ^ x ^ ":")
373 :: e
374 :: es,
375 st)
376 end)
377 ([str "}"], st) xes
378 in
379 (strcat (str ("{_" ^ x ^ ":")
380 :: e
381 :: es),
382 st)
383 end
384 | EField (e, x) =>
385 let
386 val (e, st) = jsE inner (e, st)
387 in
388 (strcat [e,
389 str ("._" ^ x)], st)
390 end
391
392 | ECase (e, pes, _) =>
393 let
394 val plen = length pes
395
396 val (cases, st) = ListUtil.foldliMap
397 (fn (i, (p, e), st) =>
398 let
399 val (e, st) = jsE (inner + E.patBindsN p) (e, st)
400 val fail =
401 if i = plen - 1 then
402 str "pf()"
403 else
404 str ("c" ^ Int.toString (i+1) ^ "()")
405 val c = jsPat 0 inner p e fail
406 in
407 (strcat [str ("c" ^ Int.toString i ^ "=function(){return "),
408 c,
409 str "},"],
410 st)
411 end)
412 st pes
413
414 val (e, st) = jsE inner (e, st)
415 in
416 (strcat (str "("
417 :: List.revAppend (cases,
418 [str "d0=",
419 e,
420 str ",c0())"])), st)
421 end
422
423 | EStrcat (e1, e2) =>
424 let
425 val (e1, st) = jsE inner (e1, st)
426 val (e2, st) = jsE inner (e2, st)
427 in
428 (strcat [str "(", e1, str "+", e2, str ")"], st)
429 end
430
431 | EError (e, _) =>
432 let
433 val (e, st) = jsE inner (e, st)
434 in
435 (strcat [str "alert(\"ERROR: \"+", e, str ")"],
436 st)
437 end
438
439 | EWrite e =>
440 let
441 val (e, st) = jsE inner (e, st)
442 in
443 (strcat [str "document.write(",
444 e,
445 str ".v)"], st)
446 end
447
448 | ESeq (e1, e2) =>
449 let
450 val (e1, st) = jsE inner (e1, st)
451 val (e2, st) = jsE inner (e2, st)
452 in
453 (strcat [str "(", e1, str ",", e2, str ")"], st)
454 end
455 | ELet (_, _, e1, e2) =>
456 let
457 val (e1, st) = jsE inner (e1, st)
458 val (e2, st) = jsE (inner + 1) (e2, st)
459 in
460 (strcat [str ("(_" ^ Int.toString (len + inner) ^ "="),
461 e1,
462 str ",",
463 e2,
464 str ")"], st)
465 end
466
467 | EClosure _ => unsupported "EClosure"
468 | EQuery _ => unsupported "Query"
469 | EDml _ => unsupported "DML"
470 | ENextval _ => unsupported "Nextval"
471 | EUnurlify _ => unsupported "EUnurlify"
472 | EJavaScript _ => unsupported "Nested JavaScript"
473 | ESignalReturn e =>
474 let
475 val (e, st) = jsE inner (e, st)
476 in
477 (strcat [str "sr(",
478 e,
479 str ")"],
480 st)
481 end
482 | ESignalBind (e1, e2) =>
483 let
484 val (e1, st) = jsE inner (e1, st)
485 val (e2, st) = jsE inner (e2, st)
486 in
487 (strcat [str "sb(",
488 e1,
489 str ",",
490 e2,
491 str ")"],
492 st)
493 end
494 | ESignalSource e =>
495 let
496 val (e, st) = jsE inner (e, st)
497 in
498 (strcat [str "ss(",
499 e,
500 str ")"],
501 st)
502 end
503 end
504 in
505 jsE
506 end
507
508 val decl : state -> decl -> decl * state =
509 U.Decl.foldMapB {typ = fn x => x,
510 exp = fn (env, e, st) =>
511 let
512 fun doCode m skip env orig e =
513 let
514 val len = length env
515 fun str s = (EPrim (Prim.String s), #2 e)
516
517 val locals = List.tabulate
518 (varDepth e,
519 fn i => str ("var _" ^ Int.toString (len + i) ^ ";"))
520 val (e, st) = jsExp m skip env 0 (e, st)
521 in
522 (EJavaScript (m, orig, SOME (strcat (#2 e) (locals @ [e]))), st)
523 end
524 in
525 case e of
526 EJavaScript (m, orig as (EAbs (_, t, _, e), _), _) => doCode m 1 (t :: env) orig e
527 | EJavaScript (m, e, _) => doCode m 0 env e e
528 | _ => (e, st)
529 end,
530 decl = fn (_, e, st) => (e, st),
531 bind = fn (env, U.Decl.RelE (_, t)) => t :: env
532 | (env, _) => env}
533 []
534
535 fun process file = 105 fun process file =
536 let 106 let
107 val nameds = foldl (fn ((DVal (_, n, t, e, _), _), nameds) => IM.insert (nameds, n, e)
108 | ((DValRec vis, _), nameds) =>
109 foldl (fn ((_, n, _, e, _), nameds) => IM.insert (nameds, n, e))
110 nameds vis
111 | (_, nameds) => nameds)
112 IM.empty file
113
114 fun jsExp mode skip outer =
115 let
116 val len = length outer
117
118 fun jsE inner (e as (_, loc), st) =
119 let
120 fun str s = (EPrim (Prim.String s), loc)
121
122 fun var n = Int.toString (len + inner - n - 1)
123
124 fun patCon pc =
125 case pc of
126 PConVar n => str (Int.toString n)
127 | PConFfi {mod = "Basis", con = "True", ...} => str "true"
128 | PConFfi {mod = "Basis", con = "False", ...} => str "false"
129 | PConFfi {con, ...} => str ("\"_" ^ con ^ "\"")
130
131 fun isNullable (t, _) =
132 case t of
133 TOption _ => true
134 | TRecord [] => true
135 | _ => false
136
137 fun unsupported s =
138 (EM.errorAt loc (s ^ " in code to be compiled to JavaScript");
139 (str "ERROR", st))
140
141 val strcat = strcat loc
142
143 fun quoteExp (t : typ) e =
144 case #1 t of
145 TSource => strcat [str "s",
146 (EFfiApp ("Basis", "htmlifyInt", [e]), loc)]
147 | TRecord [] => str "null"
148 | TFfi ("Basis", "string") => e
149 | _ => (EM.errorAt loc "Don't know how to embed type in JavaScript";
150 Print.prefaces "Can't embed" [("t", MonoPrint.p_typ MonoEnv.empty t)];
151 str "ERROR")
152
153 fun jsPrim p =
154 case p of
155 Prim.String s =>
156 str ("\""
157 ^ String.translate (fn #"'" =>
158 if mode = Attribute then
159 "\\047"
160 else
161 "'"
162 | #"\"" => "\\\""
163 | #"<" =>
164 if mode = Script then
165 "<"
166 else
167 "\\074"
168 | #"\\" => "\\\\"
169 | ch => String.str ch) s
170 ^ "\"")
171 | _ => str (Prim.toString p)
172
173 fun jsPat depth inner (p, _) succ fail =
174 case p of
175 PWild => succ
176 | PVar _ => strcat [str ("(_" ^ Int.toString (len + inner) ^ "=d"
177 ^ Int.toString depth ^ ","),
178 succ,
179 str ")"]
180 | PPrim p => strcat [str ("(d" ^ Int.toString depth ^ "=="),
181 jsPrim p,
182 str "?",
183 succ,
184 str ":",
185 fail,
186 str ")"]
187 | PCon (_, PConFfi {mod = "Basis", con = "True", ...}, NONE) =>
188 strcat [str ("(d" ^ Int.toString depth ^ "?"),
189 succ,
190 str ":",
191 fail,
192 str ")"]
193 | PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE) =>
194 strcat [str ("(d" ^ Int.toString depth ^ "?"),
195 fail,
196 str ":",
197 succ,
198 str ")"]
199 | PCon (_, pc, NONE) =>
200 strcat [str ("(d" ^ Int.toString depth ^ "=="),
201 patCon pc,
202 str "?",
203 succ,
204 str ":",
205 fail,
206 str ")"]
207 | PCon (_, pc, SOME p) =>
208 strcat [str ("(d" ^ Int.toString depth ^ ".n=="),
209 patCon pc,
210 str ("?(d" ^ Int.toString depth ^ "=d" ^ Int.toString depth ^ ".v,"),
211 jsPat depth inner p succ fail,
212 str "):",
213 fail,
214 str ")"]
215 | PRecord xps =>
216 let
217 val (_, succ) = foldl
218 (fn ((x, p, _), (inner, succ)) =>
219 (inner + E.patBindsN p,
220 strcat [str ("(d" ^ Int.toString (depth+1) ^ "=d"
221 ^ Int.toString depth ^ "._" ^ x ^ ","),
222 jsPat (depth+1) inner p succ fail,
223 str ")"]))
224 (inner, succ) xps
225 in
226 succ
227 end
228 | PNone _ => strcat [str ("(d" ^ Int.toString depth ^ "?"),
229 fail,
230 str ":",
231 succ,
232 str ")"]
233 | PSome (_, p) => strcat [str ("(d" ^ Int.toString depth ^ "?"),
234 jsPat depth inner p succ fail,
235 str ":",
236 fail,
237 str ")"]
238
239 fun deStrcat (e, _) =
240 case e of
241 EPrim (Prim.String s) => s
242 | EStrcat (e1, e2) => deStrcat e1 ^ deStrcat e2
243 | _ => raise Fail "Jscomp: deStrcat"
244 in
245 case #1 e of
246 EPrim p => (jsPrim p, st)
247 | ERel n =>
248 if n < inner then
249 (str ("_" ^ var n), st)
250 else
251 let
252 val n = n - inner
253 in
254 (quoteExp (List.nth (outer, n)) (ERel (n - skip), loc), st)
255 end
256
257 | ENamed n =>
258 let
259 val st =
260 if IS.member (#included st, n) then
261 st
262 else
263 case IM.find (nameds, n) of
264 NONE => raise Fail "Jscomp: Unbound ENamed"
265 | SOME e =>
266 let
267 val st = {decls = #decls st,
268 script = #script st,
269 included = IS.add (#included st, n)}
270
271 val (e, st) = jsExp mode skip [] 0 (e, st)
272 val e = deStrcat e
273
274 val sc = "_n" ^ Int.toString n ^ "=" ^ e ^ ";\n"
275 in
276 {decls = #decls st,
277 script = sc :: #script st,
278 included = #included st}
279 end
280 in
281 (str ("_n" ^ Int.toString n), st)
282 end
283
284 | ECon (_, pc, NONE) => (patCon pc, st)
285 | ECon (_, pc, SOME e) =>
286 let
287 val (s, st) = jsE inner (e, st)
288 in
289 (strcat [str "{n:",
290 patCon pc,
291 str ",v:",
292 s,
293 str "}"], st)
294 end
295 | ENone _ => (str "null", st)
296 | ESome (t, e) =>
297 let
298 val (e, st) = jsE inner (e, st)
299 in
300 (if isNullable t then
301 strcat [str "{v:", e, str "}"]
302 else
303 e, st)
304 end
305
306 | EFfi k =>
307 let
308 val name = case ffi k of
309 NONE => (EM.errorAt loc ("Unsupported FFI identifier " ^ #2 k
310 ^ " in JavaScript");
311 "ERROR")
312 | SOME s => s
313 in
314 (str name, st)
315 end
316 | EFfiApp (m, x, args) =>
317 let
318 val args =
319 case (m, x, args) of
320 ("Basis", "new_client_source", [(EJavaScript (_, e, _), _)]) => [e]
321 | ("Basis", "set_client_source", [e1, (EJavaScript (_, e2, _), _)]) => [e1, e2]
322 | _ => args
323
324 val name = case ffi (m, x) of
325 NONE => (EM.errorAt loc ("Unsupported FFI function "
326 ^ x ^ " in JavaScript");
327 "ERROR")
328 | SOME s => s
329 in
330 case args of
331 [] => (str (name ^ "()"), st)
332 | [e] =>
333 let
334 val (e, st) = jsE inner (e, st)
335 in
336 (strcat [str (name ^ "("),
337 e,
338 str ")"], st)
339 end
340 | e :: es =>
341 let
342 val (e, st) = jsE inner (e, st)
343 val (es, st) = ListUtil.foldlMapConcat
344 (fn (e, st) =>
345 let
346 val (e, st) = jsE inner (e, st)
347 in
348 ([str ",", e], st)
349 end)
350 st es
351 in
352 (strcat (str (name ^ "(")
353 :: e
354 :: es
355 @ [str ")"]), st)
356 end
357 end
358
359 | EApp (e1, e2) =>
360 let
361 val (e1, st) = jsE inner (e1, st)
362 val (e2, st) = jsE inner (e2, st)
363 in
364 (strcat [e1, str "(", e2, str ")"], st)
365 end
366 | EAbs (_, _, _, e) =>
367 let
368 val locals = List.tabulate
369 (varDepth e,
370 fn i => str ("var _" ^ Int.toString (len + inner + i + 1) ^ ";"))
371 val (e, st) = jsE (inner + 1) (e, st)
372 in
373 (strcat (str ("function(_"
374 ^ Int.toString (len + inner)
375 ^ "){")
376 :: locals
377 @ [str "return ",
378 e,
379 str "}"]),
380 st)
381 end
382
383 | EUnop (s, e) =>
384 let
385 val (e, st) = jsE inner (e, st)
386 in
387 (strcat [str ("(" ^ s),
388 e,
389 str ")"],
390 st)
391 end
392 | EBinop (s, e1, e2) =>
393 let
394 val (e1, st) = jsE inner (e1, st)
395 val (e2, st) = jsE inner (e2, st)
396 in
397 (strcat [str "(",
398 e1,
399 str s,
400 e2,
401 str ")"],
402 st)
403 end
404
405 | ERecord [] => (str "null", st)
406 | ERecord [(x, e, _)] =>
407 let
408 val (e, st) = jsE inner (e, st)
409 in
410 (strcat [str "{_x:", e, str "}"], st)
411 end
412 | ERecord ((x, e, _) :: xes) =>
413 let
414 val (e, st) = jsE inner (e, st)
415
416 val (es, st) =
417 foldr (fn ((x, e, _), (es, st)) =>
418 let
419 val (e, st) = jsE inner (e, st)
420 in
421 (str (",_" ^ x ^ ":")
422 :: e
423 :: es,
424 st)
425 end)
426 ([str "}"], st) xes
427 in
428 (strcat (str ("{_" ^ x ^ ":")
429 :: e
430 :: es),
431 st)
432 end
433 | EField (e, x) =>
434 let
435 val (e, st) = jsE inner (e, st)
436 in
437 (strcat [e,
438 str ("._" ^ x)], st)
439 end
440
441 | ECase (e, pes, _) =>
442 let
443 val plen = length pes
444
445 val (cases, st) = ListUtil.foldliMap
446 (fn (i, (p, e), st) =>
447 let
448 val (e, st) = jsE (inner + E.patBindsN p) (e, st)
449 val fail =
450 if i = plen - 1 then
451 str "pf()"
452 else
453 str ("c" ^ Int.toString (i+1) ^ "()")
454 val c = jsPat 0 inner p e fail
455 in
456 (strcat [str ("c" ^ Int.toString i ^ "=function(){return "),
457 c,
458 str "},"],
459 st)
460 end)
461 st pes
462
463 val (e, st) = jsE inner (e, st)
464 in
465 (strcat (str "("
466 :: List.revAppend (cases,
467 [str "d0=",
468 e,
469 str ",c0())"])), st)
470 end
471
472 | EStrcat (e1, e2) =>
473 let
474 val (e1, st) = jsE inner (e1, st)
475 val (e2, st) = jsE inner (e2, st)
476 in
477 (strcat [str "(", e1, str "+", e2, str ")"], st)
478 end
479
480 | EError (e, _) =>
481 let
482 val (e, st) = jsE inner (e, st)
483 in
484 (strcat [str "alert(\"ERROR: \"+", e, str ")"],
485 st)
486 end
487
488 | EWrite e =>
489 let
490 val (e, st) = jsE inner (e, st)
491 in
492 (strcat [str "document.write(",
493 e,
494 str ".v)"], st)
495 end
496
497 | ESeq (e1, e2) =>
498 let
499 val (e1, st) = jsE inner (e1, st)
500 val (e2, st) = jsE inner (e2, st)
501 in
502 (strcat [str "(", e1, str ",", e2, str ")"], st)
503 end
504 | ELet (_, _, e1, e2) =>
505 let
506 val (e1, st) = jsE inner (e1, st)
507 val (e2, st) = jsE (inner + 1) (e2, st)
508 in
509 (strcat [str ("(_" ^ Int.toString (len + inner) ^ "="),
510 e1,
511 str ",",
512 e2,
513 str ")"], st)
514 end
515
516 | EClosure _ => unsupported "EClosure"
517 | EQuery _ => unsupported "Query"
518 | EDml _ => unsupported "DML"
519 | ENextval _ => unsupported "Nextval"
520 | EUnurlify _ => unsupported "EUnurlify"
521 | EJavaScript _ => unsupported "Nested JavaScript"
522 | ESignalReturn e =>
523 let
524 val (e, st) = jsE inner (e, st)
525 in
526 (strcat [str "sr(",
527 e,
528 str ")"],
529 st)
530 end
531 | ESignalBind (e1, e2) =>
532 let
533 val (e1, st) = jsE inner (e1, st)
534 val (e2, st) = jsE inner (e2, st)
535 in
536 (strcat [str "sb(",
537 e1,
538 str ",",
539 e2,
540 str ")"],
541 st)
542 end
543 | ESignalSource e =>
544 let
545 val (e, st) = jsE inner (e, st)
546 in
547 (strcat [str "ss(",
548 e,
549 str ")"],
550 st)
551 end
552 end
553 in
554 jsE
555 end
556
557 val decl : state -> decl -> decl * state =
558 U.Decl.foldMapB {typ = fn x => x,
559 exp = fn (env, e, st) =>
560 let
561 fun doCode m skip env orig e =
562 let
563 val len = length env
564 fun str s = (EPrim (Prim.String s), #2 e)
565
566 val locals = List.tabulate
567 (varDepth e,
568 fn i => str ("var _" ^ Int.toString (len + i) ^ ";"))
569 val (e, st) = jsExp m skip env 0 (e, st)
570 in
571 (EJavaScript (m, orig, SOME (strcat (#2 e) (locals @ [e]))), st)
572 end
573 in
574 case e of
575 EJavaScript (m, orig as (EAbs (_, t, _, e), _), _) =>
576 doCode m 1 (t :: env) orig e
577 | EJavaScript (m, e, _) => doCode m 0 env e e
578 | _ => (e, st)
579 end,
580 decl = fn (_, e, st) => (e, st),
581 bind = fn (env, U.Decl.RelE (_, t)) => t :: env
582 | (env, _) => env}
583 []
584
537 fun doDecl (d, st) = 585 fun doDecl (d, st) =
538 let 586 let
539 val (d, st) = decl st d 587 val (d, st) = decl st d
540 in 588 in
541 (List.revAppend (#decls st, [d]), 589 (List.revAppend (#decls st, [d]),
542 {decls = [], 590 {decls = [],
543 script = #script st}) 591 script = #script st,
592 included = #included st})
544 end 593 end
545 594
546 val (ds, st) = ListUtil.foldlMapConcat doDecl 595 val (ds, st) = ListUtil.foldlMapConcat doDecl
547 {decls = [], 596 {decls = [],
548 script = ""} 597 script = [],
598 included = IS.empty}
549 file 599 file
550 600
551 val inf = TextIO.openIn (OS.Path.joinDirFile {dir = Config.libJs, file = "urweb.js"}) 601 val inf = TextIO.openIn (OS.Path.joinDirFile {dir = Config.libJs, file = "urweb.js"})
552 fun lines acc = 602 fun lines acc =
553 case TextIO.inputLine inf of 603 case TextIO.inputLine inf of
554 NONE => String.concat (rev acc) 604 NONE => String.concat (rev acc)
555 | SOME line => lines (line :: acc) 605 | SOME line => lines (line :: acc)
556 val lines = lines [] 606 val lines = lines []
557 in 607 in
558 TextIO.closeIn inf; 608 TextIO.closeIn inf;
559 (DJavaScript lines, ErrorMsg.dummySpan) :: ds 609 (DJavaScript (lines ^ String.concat (rev (#script st))), ErrorMsg.dummySpan) :: ds
560 end 610 end
561 611
562 end 612 end