Mercurial > urweb

comparison src/jscomp.sml @ 583:1fd4c041634e

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Reactive computation with more base types and records
author Adam Chlipala <adamc@hcoop.net>
date Thu, 01 Jan 2009 10:18:20 -0500
parents 66463006f893
children 101eb0058136
comparison
equal deleted inserted replaced
582:66463006f893 583:1fd4c041634e
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 val funcs = [(("Basis", "alert"), "alert"), 36 val funcs = [(("Basis", "alert"), "alert"),
37 (("Basis", "htmlifyFloat"), "ts"),
37 (("Basis", "htmlifyInt"), "ts"), 38 (("Basis", "htmlifyInt"), "ts"),
38 (("Basis", "htmlifyString"), "escape"), 39 (("Basis", "htmlifyString"), "escape"),
39 (("Basis", "new_client_source"), "sc"), 40 (("Basis", "new_client_source"), "sc"),
40 (("Basis", "set_client_source"), "sv")] 41 (("Basis", "set_client_source"), "sv")]
41 42
109 fun patCon pc = 110 fun patCon pc =
110 case pc of 111 case pc of
111 PConVar n => str (Int.toString n) 112 PConVar n => str (Int.toString n)
112 | PConFfi {con, ...} => str ("\"_" ^ con ^ "\"") 113 | PConFfi {con, ...} => str ("\"_" ^ con ^ "\"")
113 114
114
115
116 fun isNullable (t, _) = 115 fun isNullable (t, _) =
117 case t of 116 case t of
118 TOption _ => true 117 TOption _ => true
118 | TRecord [] => true
119 | _ => false 119 | _ => false
120 120
121 fun unsupported s = 121 fun unsupported s =
122 (EM.errorAt loc (s ^ " in code to be compiled to JavaScript"); 122 (EM.errorAt loc (s ^ " in code to be compiled to JavaScript");
123 (str "ERROR", st)) 123 (str "ERROR", st))
152 | ch => String.str ch) s 152 | ch => String.str ch) s
153 ^ "\""), st) 153 ^ "\""), st)
154 | EPrim p => (str (Prim.toString p), st) 154 | EPrim p => (str (Prim.toString p), st)
155 | ERel n => 155 | ERel n =>
156 if n < inner then 156 if n < inner then
157 (str ("uwr" ^ var n), st) 157 (str ("_" ^ var n), st)
158 else 158 else
159 let 159 let
160 val n = n - inner 160 val n = n - inner
161 in 161 in
162 (quoteExp (List.nth (outer, n)) (ERel (n - skip), loc), st) 162 (quoteExp (List.nth (outer, n)) (ERel (n - skip), loc), st)
244 end 244 end
245 | EAbs (_, _, _, e) => 245 | EAbs (_, _, _, e) =>
246 let 246 let
247 val locals = List.tabulate 247 val locals = List.tabulate
248 (varDepth e, 248 (varDepth e,
249 fn i => str ("var uwr" ^ Int.toString (len + inner + i) ^ ";")) 249 fn i => str ("var _" ^ Int.toString (len + inner + i) ^ ";"))
250 val (e, st) = jsE (inner + 1) (e, st) 250 val (e, st) = jsE (inner + 1) (e, st)
251 in 251 in
252 (strcat (str ("function(uwr" 252 (strcat (str ("function(_"
253 ^ Int.toString (len + inner) 253 ^ Int.toString (len + inner)
254 ^ "){") 254 ^ "){")
255 :: locals 255 :: locals
256 @ [str "return ", 256 @ [str "return ",
257 e, 257 e,
284 | ERecord [] => (str "null", st) 284 | ERecord [] => (str "null", st)
285 | ERecord [(x, e, _)] => 285 | ERecord [(x, e, _)] =>
286 let 286 let
287 val (e, st) = jsE inner (e, st) 287 val (e, st) = jsE inner (e, st)
288 in 288 in
289 (strcat [str "{uw_x:", e, str "}"], st) 289 (strcat [str "{_x:", e, str "}"], st)
290 end 290 end
291 | ERecord ((x, e, _) :: xes) => 291 | ERecord ((x, e, _) :: xes) =>
292 let 292 let
293 val (e, st) = jsE inner (e, st) 293 val (e, st) = jsE inner (e, st)
294 294
295 val (es, st) = 295 val (es, st) =
296 foldr (fn ((x, e, _), (es, st)) => 296 foldr (fn ((x, e, _), (es, st)) =>
297 let 297 let
298 val (e, st) = jsE inner (e, st) 298 val (e, st) = jsE inner (e, st)
299 in 299 in
300 (str (",uw_" ^ x ^ ":") 300 (str (",_" ^ x ^ ":")
301 :: e 301 :: e
302 :: es, 302 :: es,
303 st) 303 st)
304 end) 304 end)
305 ([str "}"], st) xes 305 ([str "}"], st) xes
306 in 306 in
307 (strcat (str ("{uw_" ^ x ^ ":") 307 (strcat (str ("{_" ^ x ^ ":")
308 :: e 308 :: e
309 :: es), 309 :: es),
310 st) 310 st)
311 end 311 end
312 | EField (e, x) => 312 | EField (e, x) =>
313 let 313 let
314 val (e, st) = jsE inner (e, st) 314 val (e, st) = jsE inner (e, st)
315 in 315 in
316 (strcat [e, 316 (strcat [e,
317 str ("." ^ x)], st) 317 str ("._" ^ x)], st)
318 end 318 end
319 319
320 | ECase _ => raise Fail "Jscomp: ECase" 320 | ECase _ => raise Fail "Jscomp: ECase"
321 321
322 | EStrcat (e1, e2) => 322 | EStrcat (e1, e2) =>
354 | ELet (_, _, e1, e2) => 354 | ELet (_, _, e1, e2) =>
355 let 355 let
356 val (e1, st) = jsE inner (e1, st) 356 val (e1, st) = jsE inner (e1, st)
357 val (e2, st) = jsE (inner + 1) (e2, st) 357 val (e2, st) = jsE (inner + 1) (e2, st)
358 in 358 in
359 (strcat [str ("(uwr" ^ Int.toString (len + inner) ^ "="), 359 (strcat [str ("(_" ^ Int.toString (len + inner) ^ "="),
360 e1, 360 e1,
361 str ",", 361 str ",",
362 e2, 362 e2,
363 str ")"], st) 363 str ")"], st)
364 end 364 end
413 val len = length env 413 val len = length env
414 fun str s = (EPrim (Prim.String s), #2 e) 414 fun str s = (EPrim (Prim.String s), #2 e)
415 415
416 val locals = List.tabulate 416 val locals = List.tabulate
417 (varDepth e, 417 (varDepth e,
418 fn i => str ("var uwr" ^ Int.toString (len + i) ^ ";")) 418 fn i => str ("var _" ^ Int.toString (len + i) ^ ";"))
419 val (e, st) = jsExp m skip env 0 (e, st) 419 val (e, st) = jsExp m skip env 0 (e, st)
420 in 420 in
421 (EJavaScript (m, orig, SOME (strcat (#2 e) (locals @ [e]))), st) 421 (EJavaScript (m, orig, SOME (strcat (#2 e) (locals @ [e]))), st)
422 end 422 end
423 in 423 in