Mercurial > urweb
changeset 970:8371d12ae63f
Hopefully complete refactoring of Jscomp to output ASTs; partial implementation of interpreter in runtime system (demo/alert works)
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Tue, 22 Sep 2009 12:23:21 -0400 |
| parents | 001edfbe2561 |
| children | c22e524a6dd3 |
| files | lib/js/urweb.js src/c/urweb.c src/jscomp.sml src/monoize.sml src/scriptcheck.sml |
| diffstat | 5 files changed, 406 insertions(+), 453 deletions(-) [+] |
line wrap: on
line diff
--- a/lib/js/urweb.js Tue Sep 22 09:53:05 2009 -0400 +++ b/lib/js/urweb.js Tue Sep 22 12:23:21 2009 -0400 @@ -1,3 +1,17 @@ +// Function versions of operators + +function not(x) { return !x; } +function neg(x) { return -x; } + +function eq(x, y) { return x == y; } +function plus(x, y) { return x + y; } +function minus(x, y) { return x - y; } +function times(x, y) { return x * y; } +function div(x, y) { return x / y; } +function mod(x, y) { return x % y; } +function lt(x, y) { return x < y; } +function le(x, y) { return x <= y; } + // Lists function cons(v, ls) { @@ -765,8 +779,176 @@ // Key events -function kc(e) { - return window.event ? e.keyCode : e.which; +var uw_event = null; + +function kc() { + return window.event ? uw_event.keyCode : uw_event.which; +} + + +// The Ur interpreter + +var urfuncs = []; + +function lookup(env, n) { + while (env != null) { + if (n == 0) + return env.data; + else { + --n; + env = env.next; + } + } + + throw "Out-of-bounds Ur variable reference"; +} + +function exec0(env, e) { + var stack = null; + + while (true) { + switch (e.c) { + case "c": + var v = e.v; + if (stack == null) + return v; + var fr = stack.data; + + switch (fr.c) { + case "s": + e = {c: "c", v: {v: v}}; + stack = stack.next; + break; + case "1": + e = {c: "c", v: {n: fr.n, v: v}}; + stack = stack.next; + break; + case "f": + fr.args[fr.pos++] = v; + if (fr.a == null) { + e = {c: "c", v: fr.f.apply(null, fr.args)}; + stack = stack.next; + } else { + e = fr.a.data; + fr.a = fr.a.next; + } + break; + case "a1": + if (v == null || !v.body) + throw "Ur: applying non-function"; + stack = cons({c: "a2", env: v.env, body: v.body}, stack.next); + e = fr.x; + break; + case "a2": + stack = cons({c: "a3", env: env}, stack.next); + env = cons(v, fr.env); + e = fr.body; + break; + case "a3": + env = fr.env; + stack = stack.next; + break; + case "r": + fr.fs["_" + fr.n] = v; + if (fr.l == null) { + e = {c: "c", v: fr.fs}; + stack = stack.next; + } else { + fr.n = fr.l.data.n; + e = fr.l.data.v; + fr.l = fr.l.next; + } + break; + case ".": + e = {c: "c", v: v["_" + fr.f]}; + stack = stack.next; + break; + case ";": + e = fr.e2; + stack = stack.next; + break; + case "=1": + env = cons(v, env); + e = fr.e2; + stack = stack.next; + break; + case "=": + env = cons(v, env); + e = fr.e2; + stack = cons({c: "a3", env: env}, stack.next); + break; + default: + throw "Unknown Ur continuation kind"; + } + + break; + case "v": + e = {c: "c", v: lookup(env, e.n)}; + break; + case "n": + e = {c: "c", v: urfuncs[e.n]}; + break; + case "s": + stack = cons({c: "s"}, stack); + e = e.v; + break; + case "1": + stack = cons({c: "1", n: e.n}, stack); + e = e.v; + break; + case "f": + if (e.a == null) + e = {c: "c", v: e.f()}; + else { + var args = []; + stack = cons({c: "f", f: e.f, args: args, pos: 0, a: e.a.next}, stack); + e = e.a.data; + } + break; + case "l": + e = {c: "c", v: {env: env, body: e.b}}; + break; + case "a": + stack = cons({c: "a1", x: e.x}, stack); + e = e.f; + break; + case "r": + if (e.l == null) + throw "Empty Ur record in interpretation"; + var fs = {}; + stack = cons({c: "r", n: e.l.data.n, fs: fs, l: e.l.next}, stack); + e = e.l.data; + break; + case ".": + stack = cons({c: ".", f: e.f}, stack); + e = e.r; + break; + case ";": + stack = cons({c: ";", e2: e.e2}, stack); + e = e.e1; + break; + case "=": + stack = cons({c: "=", e2: e.e2}, stack); + e = e.e1; + break; + case "e": + var env0 = env; + var e0 = e.e; + e = {c: "c", v: cs(function() { return exec0(env0, e0); })}; + break; + default: + throw "Unknown Ur expression kind"; + } + } +} + +function exec(e) { + var r = exec0(null, e); + + if (r != null && r.body) + return function(v) { return exec0(cons(v, r.env), r.body); }; + else + return r; }
--- a/src/c/urweb.c Tue Sep 22 09:53:05 2009 -0400 +++ b/src/c/urweb.c Tue Sep 22 12:23:21 2009 -0400 @@ -1286,12 +1286,12 @@ int len; size_t s_len = strlen(s); - uw_check_script(ctx, 12 + INTS_MAX + s_len); - sprintf(ctx->script.front, "var s%d=sc(%n", ctx->source_count, &len); + uw_check_script(ctx, 18 + INTS_MAX + s_len); + sprintf(ctx->script.front, "var s%d=sc(exec(%n", ctx->source_count, &len); ctx->script.front += len; strcpy(ctx->script.front, s); ctx->script.front += s_len; - strcpy(ctx->script.front, ");"); + strcpy(ctx->script.front, "));"); ctx->script.front += 2; return ctx->source_count++; @@ -1301,12 +1301,12 @@ int len; size_t s_len = strlen(s); - uw_check_script(ctx, 6 + INTS_MAX + s_len); - sprintf(ctx->script.front, "sv(s%d,%n", (int)n, &len); + uw_check_script(ctx, 12 + INTS_MAX + s_len); + sprintf(ctx->script.front, "sv(s%d,exec(%n", (int)n, &len); ctx->script.front += len; strcpy(ctx->script.front, s); ctx->script.front += s_len; - strcpy(ctx->script.front, ");"); + strcpy(ctx->script.front, "));"); ctx->script.front += 2; return uw_unit_v;
--- a/src/jscomp.sml Tue Sep 22 09:53:05 2009 -0400 +++ b/src/jscomp.sml Tue Sep 22 12:23:21 2009 -0400 @@ -51,132 +51,15 @@ maxName : int } -fun varDepth (e, _) = - case e of - EPrim _ => 0 - | ERel _ => 0 - | ENamed _ => 0 - | ECon (_, _, NONE) => 0 - | ECon (_, _, SOME e) => varDepth e - | ENone _ => 0 - | ESome (_, e) => varDepth e - | EFfi _ => 0 - | EFfiApp (_, _, es) => foldl Int.max 0 (map varDepth es) - | EApp (e1, e2) => Int.max (varDepth e1, varDepth e2) - | EAbs _ => 0 - | EUnop (_, e) => varDepth e - | EBinop (_, e1, e2) => Int.max (varDepth e1, varDepth e2) - | ERecord xes => foldl Int.max 0 (map (fn (_, e, _) => varDepth e) xes) - | EField (e, _) => varDepth e - | ECase (e, pes, _) => - foldl Int.max (varDepth e) - (map (fn (p, e) => E.patBindsN p + varDepth e) pes) - | EStrcat (e1, e2) => Int.max (varDepth e1, varDepth e2) - | EError (e, _) => varDepth e - | EReturnBlob {blob = e1, mimeType = e2, ...} => Int.max (varDepth e1, varDepth e2) - | EWrite e => varDepth e - | ESeq (e1, e2) => Int.max (varDepth e1, varDepth e2) - | ELet (_, _, e1, e2) => Int.max (varDepth e1, 1 + varDepth e2) - | EClosure _ => 0 - | EQuery _ => 0 - | EDml _ => 0 - | ENextval _ => 0 - | EUnurlify _ => 0 - | EJavaScript _ => 0 - | ESignalReturn e => varDepth e - | ESignalBind (e1, e2) => Int.max (varDepth e1, varDepth e2) - | ESignalSource e => varDepth e - | EServerCall (e, ek, _, _) => Int.max (varDepth e, varDepth ek) - | ERecv (e, ek, _) => Int.max (varDepth e, varDepth ek) - | ESleep (e, ek) => Int.max (varDepth e, varDepth ek) - -fun closedUpto d = - let - fun cu inner (e, _) = - case e of - EPrim _ => true - | ERel n => n < inner orelse n - inner >= d - | ENamed _ => true - | ECon (_, _, NONE) => true - | ECon (_, _, SOME e) => cu inner e - | ENone _ => true - | ESome (_, e) => cu inner e - | EFfi _ => true - | EFfiApp (_, _, es) => List.all (cu inner) es - | EApp (e1, e2) => cu inner e1 andalso cu inner e2 - | EAbs (_, _, _, e) => cu (inner + 1) e - | EUnop (_, e) => cu inner e - | EBinop (_, e1, e2) => cu inner e1 andalso cu inner e2 - | ERecord xes => List.all (fn (_, e, _) => cu inner e) xes - | EField (e, _) => cu inner e - | ECase (e, pes, _) => - cu inner e - andalso List.all (fn (p, e) => cu (inner + E.patBindsN p) e) pes - | EStrcat (e1, e2) => cu inner e1 andalso cu inner e2 - | EError (e, _) => cu inner e - | EReturnBlob {blob = e1, mimeType = e2, ...} => cu inner e1 andalso cu inner e2 - | EWrite e => cu inner e - | ESeq (e1, e2) => cu inner e1 andalso cu inner e2 - | ELet (_, _, e1, e2) => cu inner e1 andalso cu (inner + 1) e2 - | EClosure (_, es) => List.all (cu inner) es - | EQuery {query, body, initial, ...} => - cu inner query - andalso cu (inner + 2) body - andalso cu inner initial - | EDml e => cu inner e - | ENextval e => cu inner e - | EUnurlify (e, _) => cu inner e - | EJavaScript (_, e) => cu inner e - | ESignalReturn e => cu inner e - | ESignalBind (e1, e2) => cu inner e1 andalso cu inner e2 - | ESignalSource e => cu inner e - | EServerCall (e, ek, _, _) => cu inner e andalso cu inner ek - | ERecv (e, ek, _) => cu inner e andalso cu inner ek - | ESleep (e, ek) => cu inner e andalso cu inner ek - in - cu 0 - end - fun strcat loc es = case es of [] => (EPrim (Prim.String ""), loc) | [x] => x | x :: es' => (EStrcat (x, strcat loc es'), loc) -fun patDepth (p, _) = - case p of - PWild => 0 - | PVar _ => 0 - | PPrim _ => 0 - | PCon (_, _, NONE) => 0 - | PCon (_, _, SOME p) => 1 + patDepth p - | PRecord xpts => foldl Int.max 0 (map (fn (_, p, _) => 1 + patDepth p) xpts) - | PNone _ => 0 - | PSome (_, p) => 1 + patDepth p - -val compact = - U.Exp.mapB {typ = fn t => t, - exp = fn inner => fn e => - case e of - ERel n => - if n >= inner then - ERel (n - inner) - else - e - | _ => e, - bind = fn (inner, b) => - case b of - U.Exp.RelE _ => inner+1 - | _ => inner} - exception CantEmbed of typ -fun inString {needle, haystack} = - let - val (_, suffix) = Substring.position needle (Substring.full haystack) - in - not (Substring.isEmpty suffix) - end +fun inString {needle, haystack} = String.isSubstring needle haystack fun process file = let @@ -520,14 +403,12 @@ let val str = str loc - fun var n = Int.toString (len + inner - n - 1) - fun patCon pc = case pc of PConVar n => str (Int.toString n) | PConFfi {mod = "Basis", con = "True", ...} => str "true" | PConFfi {mod = "Basis", con = "False", ...} => str "false" - | PConFfi {con, ...} => str ("\"_" ^ con ^ "\"") + | PConFfi {con, ...} => str ("\"" ^ con ^ "\"") fun unsupported s = (EM.errorAt loc (s ^ " in code to be compiled to JavaScript[2]"); @@ -566,98 +447,56 @@ | _ => str (Prim.toString p) end - fun jsPat depth inner (p, _) succ fail = + fun jsPat (p, _) = case p of - PWild => succ - | PVar _ => strcat [str ("(_" ^ Int.toString (len + inner) ^ "=d" - ^ Int.toString depth ^ ","), - succ, - str ")"] - | PPrim p => strcat [str ("(d" ^ Int.toString depth ^ "=="), + PWild => str "{c:\"w\"}" + | PVar _ => str "{c:\"v\"}" + | PPrim p => strcat [str "{c:\"c\",v:", jsPrim p, - str "?", - succ, - str ":", - fail, - str ")"] + str "}"] | PCon (_, PConFfi {mod = "Basis", con = "True", ...}, NONE) => - strcat [str ("(d" ^ Int.toString depth ^ "?"), - succ, - str ":", - fail, - str ")"] + str "{c:\"c\",v:true}" | PCon (_, PConFfi {mod = "Basis", con = "False", ...}, NONE) => - strcat [str ("(d" ^ Int.toString depth ^ "?"), - fail, - str ":", - succ, - str ")"] + str "{c:\"c\",v:false}" | PCon (Option, _, NONE) => - strcat [str ("(d" ^ Int.toString depth ^ "!=null?"), - fail, - str ":", - succ, - str ")"] + str "{c:\"c\",v:null}" | PCon (Option, PConVar n, SOME p) => (case IM.find (someTs, n) of NONE => raise Fail "Jscomp: Not in someTs" - | SOME t => - strcat [str ("(d" ^ Int.toString depth ^ "!=null?(d" - ^ Int.toString (depth+1) ^ "=d" ^ Int.toString depth - ^ (if isNullable t then - ".v," - else - "") - ^ ","), - jsPat (depth+1) inner p succ fail, - str "):", - fail, - str ")"]) - | PCon (_, pc, NONE) => - strcat [str ("(d" ^ Int.toString depth ^ "=="), - patCon pc, - str "?", - succ, - str ":", - fail, - str ")"] - | PCon (_, pc, SOME p) => - strcat [str ("(d" ^ Int.toString depth ^ ".n=="), - patCon pc, - str ("?(d" ^ Int.toString (depth+1) ^ "=d" ^ Int.toString depth ^ ".v,"), - jsPat (depth+1) inner p succ fail, - str "):", - fail, - str ")"] - | PRecord xps => - let - val (_, succ) = foldl - (fn ((x, p, _), (inner, succ)) => - (inner + E.patBindsN p, - strcat [str ("(d" ^ Int.toString (depth+1) ^ "=d" - ^ Int.toString depth ^ "._" ^ x ^ ","), - jsPat (depth+1) inner p succ fail, - str ")"])) - (inner, succ) xps - in - succ - end - | PNone _ => strcat [str ("(d" ^ Int.toString depth ^ "!=null?"), - fail, - str ":", - succ, - str ")"] - | PSome (t, p) => strcat [str ("(d" ^ Int.toString depth ^ "!=null?(d" ^ Int.toString (depth+1) - ^ "=d" ^ Int.toString depth + | SOME t => strcat [str ("{c:\"s\",n:" + ^ (if isNullable t then + "true" + else + "false") + ^ ",p:"), + jsPat p, + str "}"]) + | PCon (_, pc, NONE) => strcat [str "{c:\"0\",n:", + patCon pc, + str "}"] + | PCon (_, pc, SOME p) => strcat [str "{c:\"1\",n:", + patCon pc, + str ",p:", + jsPat p, + str "}"] + | PRecord xps => strcat [str "{c:\"r\",l:", + foldr (fn ((x, p, _), e) => + strcat [str ("cons({n:\"" ^ x ^ "\",p:"), + jsPat p, + str "},", + e, + str ")"]) + (str "null") xps, + str "}"] + | PNone _ => str "{c:\"c\",v:null}" + | PSome (t, p) => strcat [str ("{c:\"s\",n:" ^ (if isNullable t then - ".v" + "true" else - "") - ^ ","), - jsPat (depth+1) inner p succ fail, - str "):", - fail, - str ")"] + "false") + ^ ",p:"), + jsPat p, + str "}"] val jsifyString = String.translate (fn #"\"" => "\\\"" | #"\\" => "\\\\" @@ -677,39 +516,28 @@ raise Fail "Jscomp: deStrcat") val quoteExp = quoteExp loc - - val hasQuery = U.Exp.exists {typ = fn _ => false, - exp = fn EQuery _ => true - | _ => false} - - val indirectQuery = U.Exp.exists {typ = fn _ => false, - exp = fn ENamed n => - (case IM.find (nameds, n) of - NONE => false - | SOME e => hasQuery e) - | _ => false} - in - (*if indirectQuery e then - Print.preface ("Indirect", MonoPrint.p_exp MonoEnv.empty e) - else - ();*) - (*Print.prefaces "jsE" [("e", MonoPrint.p_exp MonoEnv.empty e), ("inner", Print.PD.string (Int.toString inner))];*) case #1 e of - EPrim p => (jsPrim p, st) + EPrim p => (strcat [str "{c:\"c\",v:", + jsPrim p, + str "}"], + st) | ERel n => if n < inner then - (str ("_" ^ var n), st) + (str ("{c:\"v\",n:" ^ Int.toString n ^ "}"), st) else let val n = n - inner (*val () = Print.prefaces "quote" [("t", MonoPrint.p_typ MonoEnv.empty (List.nth (outer, n)))]*) + val (e, st) = quoteExp (List.nth (outer, n)) ((ERel n, loc), st) in - quoteExp (List.nth (outer, n)) ((ERel n, loc), st) + (strcat [str "{c:\"c\",v:", + e, + str "}"], st) end | ENamed n => @@ -731,11 +559,11 @@ maxName = #maxName st} val old = e - val (e, st) = jsExp mode [] 0 (e, st) + val (e, st) = jsExp mode [] (e, st) val new = e val e = deStrcat 0 e - val sc = "_n" ^ Int.toString n ^ "=" ^ e ^ ";\n" + val sc = "urfuncs[" ^ Int.toString n ^ "] = " ^ e ^ ";\n" in (*Print.prefaces "jsify'" [("old", MonoPrint.p_exp MonoEnv.empty old), ("new", MonoPrint.p_exp MonoEnv.empty new)];*) @@ -748,10 +576,10 @@ maxName = #maxName st} end in - (str ("_n" ^ Int.toString n), st) + (str ("{c:\"n\",n:" ^ Int.toString n ^ "}"), st) end - | ECon (Option, _, NONE) => (str "null", st) + | ECon (Option, _, NONE) => (str "{c:\"c\",v:null}", st) | ECon (Option, PConVar n, SOME e) => let val (e, st) = jsE inner (e, st) @@ -760,32 +588,35 @@ NONE => raise Fail "Jscomp: Not in someTs [2]" | SOME t => (if isNullable t then - strcat [str "{v:", + strcat [str "{c:\"s\",v:", e, str "}"] else e, st) end - | ECon (_, pc, NONE) => (patCon pc, st) + | ECon (_, pc, NONE) => (strcat [str "{c:\"c\",v:", + patCon pc, + str "}"], + st) | ECon (_, pc, SOME e) => let val (s, st) = jsE inner (e, st) in - (strcat [str "{n:", + (strcat [str "{c:\"1\",n:", patCon pc, str ",v:", s, str "}"], st) end - | ENone _ => (str "null", st) + | ENone _ => (str "{c:\"c\",v:null}", st) | ESome (t, e) => let val (e, st) = jsE inner (e, st) in (if isNullable t then - strcat [str "{v:", e, str "}"] + strcat [str "{c:\"s\",v:", e, str "}"] else e, st) end @@ -798,12 +629,11 @@ "ERROR") | SOME s => s in - (str name, st) + (str ("{c:\"c\",v:" ^ name ^ "}"), st) end - | EFfiApp ("Basis", "sigString", [_]) => (strcat [str "\"", - e, - str "\""], st) - | EFfiApp ("Basis", "kc", []) => (str "kc(event)", st) + | EFfiApp ("Basis", "sigString", [_]) => (strcat [str "{c:\"c\",v:\"", + e, + str "\"}"], st) | EFfiApp (m, x, args) => let val name = case Settings.jsFunc (m, x) of @@ -811,34 +641,24 @@ ^ x ^ " in JavaScript"); "ERROR") | SOME s => s + + val (e, st) = foldr (fn (e, (acc, st)) => + let + val (e, st) = jsE inner (e, st) + in + (strcat [str "cons(", + e, + str ",", + acc, + str ")"], + st) + end) + (str "null", st) args in - case args of - [] => (str (name ^ "()"), st) - | [e] => - let - val (e, st) = jsE inner (e, st) - in - (strcat [str (name ^ "("), - e, - str ")"], st) - end - | e :: es => - let - val (e, st) = jsE inner (e, st) - val (es, st) = ListUtil.foldlMapConcat - (fn (e, st) => - let - val (e, st) = jsE inner (e, st) - in - ([str ",", e], st) - end) - st es - in - (strcat (str (name ^ "(") - :: e - :: es - @ [str ")"]), st) - end + (strcat [str ("{c:\"f\",f:" ^ name ^ ",a:"), + e, + str "}"], + st) end | EApp (e1, e2) => @@ -846,90 +666,80 @@ val (e1, st) = jsE inner (e1, st) val (e2, st) = jsE inner (e2, st) in - (strcat [e1, str "(", e2, str ")"], st) + (strcat [str "{c:\"a\",f:", + e1, + str ",x:", + e2, + str "}"], st) end | EAbs (_, _, _, e) => let - val locals = List.tabulate - (varDepth e, - fn i => str ("var _" ^ Int.toString (len + inner + i + 1) ^ ";")) val (e, st) = jsE (inner + 1) (e, st) in - (strcat (str ("function(_" - ^ Int.toString (len + inner) - ^ "){") - :: locals - @ [str "return ", - e, - str "}"]), - st) + (strcat [str "{c:\"l\",b:", + e, + str "}"], st) end | EUnop (s, e) => let + val name = case s of + "!" => "not" + | "-" => "neg" + | _ => raise Fail "Jscomp: Unknown unary operator" + val (e, st) = jsE inner (e, st) in - (strcat [str ("(" ^ s), + (strcat [str ("{c:\"f\",f:" ^ name ^ ",:a:cons("), e, - str ")"], + str ",null)}"], st) end - | EBinop ("strcmp", e1, e2) => - let - val (e1, st) = jsE inner (e1, st) - val (e2, st) = jsE inner (e2, st) - in - (strcat [str "strcmp(", - e1, - str ",", - e2, - str ")"], - st) - end | EBinop (s, e1, e2) => let - val s = - case s of - "!strcmp" => "==" - | _ => s + val name = case s of + "==" => "eq" + | "!strcmp" => "eq" + | "+" => "plus" + | "-" => "minus" + | "*" => "times" + | "/" => "div" + | "%" => "mod" + | "<" => "lt" + | "<=" => "le" + | _ => raise Fail "Jscomp: Unknown binary operator" val (e1, st) = jsE inner (e1, st) val (e2, st) = jsE inner (e2, st) in - (strcat [str "(", + (strcat [str ("{c:\"f\",f:" ^ name ^ ",a:cons("), e1, - str s, + str ",cons(", e2, - str ")"], + str ",null))}"], st) end - | ERecord [] => (str "null", st) - | ERecord [(x, e, _)] => + | ERecord [] => (str "{c:\"c\",v:null}", st) + | ERecord xes => let - val (e, st) = jsE inner (e, st) - in - (strcat [str ("{_" ^ x ^ ":"), e, str "}"], st) - end - | ERecord ((x, e, _) :: xes) => - let - val (e, st) = jsE inner (e, st) - val (es, st) = foldr (fn ((x, e, _), (es, st)) => let val (e, st) = jsE inner (e, st) in - (str (",_" ^ x ^ ":") - :: e - :: es, + (strcat [str ("cons({n:\"" ^ x ^ ",v:"), + e, + str "},", + es, + str ")"], st) end) - ([str "}"], st) xes + (str "null", st) xes in - (strcat (str ("{_" ^ x ^ ":") - :: e - :: es), + (strcat [str "{c:\"r\",l:", + es, + str "}"], st) end | EField (e', x) => @@ -938,8 +748,9 @@ let val (e', st) = jsE inner (e', st) in - (strcat [e', - str ("._" ^ x)], st) + (strcat [str "{c:\".\",r:", + e', + str (",f:\"" ^ x ^ "\"}")], st) end fun seek (e, xs) = @@ -960,8 +771,12 @@ val e = (ERel n, loc) val e = foldl (fn (x, e) => (EField (e, x), loc)) e xs + val (e, st) = quoteExp t (e, st) in - quoteExp t (e, st) + (strcat [str "{c:\"c\",v:", + e, + str "}"], + st) end | EField (e', x) => seek (e', x :: xs) | _ => default () @@ -969,43 +784,31 @@ seek (e', [x]) end - | ECase (e', pes, {result, ...}) => + | ECase (e', pes, _) => let - val plen = length pes + val (e', st) = jsE inner (e', st) - val (cases, st) = ListUtil.foldliMap - (fn (i, (p, e), st) => - let - val (e, st) = jsE (inner + E.patBindsN p) (e, st) - val fail = - if i = plen - 1 then - str ("pf(\"" ^ ErrorMsg.spanToString loc ^ "\")") - else - str ("c" ^ Int.toString (i+1) ^ "()") - val c = jsPat 0 inner p e fail - in - (strcat [str ("c" ^ Int.toString i ^ "=function(){return "), - c, - str "},"], - st) - end) - st pes - - val depth = foldl Int.max 0 (map (fn (p, _) => 1 + patDepth p) pes) - val normalDepth = foldl Int.max 0 (map (fn (_, e) => 1 + varDepth e) pes) - val (e, st) = jsE inner (e', st) - - val len = inner + len - val normalVars = List.tabulate (normalDepth, fn n => "_" ^ Int.toString (n + len)) - val patVars = List.tabulate (depth, fn n => "d" ^ Int.toString n) - val caseVars = ListUtil.mapi (fn (i, _) => "c" ^ Int.toString i) pes + val (ps, st) = + foldr (fn ((p, e), (ps, st)) => + let + val (e, st) = jsE inner (e, st) + in + (strcat [str "cons({p:", + jsPat p, + str ",b:", + e, + str "},", + ps, + str ")"], + st) + end) + (str "null", st) pes in - (strcat (str "(function (){ var " - :: str (String.concatWith "," (normalVars @ patVars @ caseVars) ^ ";d0=") - :: e - :: str ";\nreturn (" - :: List.revAppend (cases, - [str "c0()) } ())"])), st) + (strcat [str "{c:\"m\",e:", + e, + str ",p:", + ps, + str "}"], st) end | EStrcat (e1, e2) => @@ -1013,43 +816,34 @@ val (e1, st) = jsE inner (e1, st) val (e2, st) = jsE inner (e2, st) in - (strcat [str "cat(", e1, str ",", e2, str ")"], st) + (strcat [str "{c:\"f\",f:cat,a:cons(", e1, str ",cons(", e2, str ",null))}"], st) end | EError (e, _) => let val (e, st) = jsE inner (e, st) in - (strcat [str "er(", e, str ")"], + (strcat [str "{c:\"f\",f:er,a:cons(", e, str ",null)}"], st) end - | EWrite e => - let - val (e, st) = jsE inner (e, st) - in - (strcat [str "document.write(", - e, - str ".v)"], st) - end - | ESeq (e1, e2) => let val (e1, st) = jsE inner (e1, st) val (e2, st) = jsE inner (e2, st) in - (strcat [str "(", e1, str ",", e2, str ")"], st) + (strcat [str "{c:\";\",e1:", e1, str ",e2:", e2, str "}"], st) end | ELet (_, _, e1, e2) => let val (e1, st) = jsE inner (e1, st) val (e2, st) = jsE (inner + 1) (e2, st) in - (strcat [str ("(_" ^ Int.toString (len + inner) ^ "="), + (strcat [str "{c:\"=\",e1:", e1, - str ",", + str ",e2:", e2, - str ")"], st) + str "}"], st) end | EJavaScript (Source _, e) => @@ -1057,21 +851,16 @@ jsE inner (e, st)) | EJavaScript (_, e) => let - val locals = List.tabulate - (varDepth e, - fn i => str ("var _" ^ Int.toString (len + inner + i) ^ ";")) - val (e, st) = jsE inner (e, st) in foundJavaScript := true; - (strcat (str "cs(function(){" - :: locals - @ [str "return ", - (*compact inner*) e, - str "})"]), + (strcat [str "{c:\"e\",e:", + e, + str "}"], st) end + | EWrite _ => unsupported "EWrite" | EClosure _ => unsupported "EClosure" | EQuery _ => unsupported "Query" | EDml _ => unsupported "DML" @@ -1083,9 +872,9 @@ let val (e, st) = jsE inner (e, st) in - (strcat [str "sr(", + (strcat [str "{c:\"f\",f:sr,a:cons(", e, - str ")"], + str ",null)}"], st) end | ESignalBind (e1, e2) => @@ -1093,20 +882,20 @@ val (e1, st) = jsE inner (e1, st) val (e2, st) = jsE inner (e2, st) in - (strcat [str "sb(", + (strcat [str "{c:\"b\",e1:", e1, - str ",", + str ",e2:", e2, - str ")"], + str "}"], st) end | ESignalSource e => let val (e, st) = jsE inner (e, st) in - (strcat [str "ss(", + (strcat [str "{c:\"f\",f:ss,a:cons(", e, - str ")"], + str ",null)}"], st) end @@ -1116,16 +905,18 @@ val (ek, st) = jsE inner (ek, st) val (unurl, st) = unurlifyExp loc (t, st) in - (strcat [str ("rc(cat(\"" ^ Settings.getUrlPrefix () ^ "\","), + (strcat [str ("{c:\"f\",f:rc,a:cons({c:\"c\",v:\"" + ^ Settings.getUrlPrefix () + ^ "\"},cons("), e, - str ("), function(s){var t=s.split(\"/\");var i=0;return " - ^ unurl ^ "},"), + str (",cons({c:\"c\",v:function(s){var t=s.split(\"/\");var i=0;return " + ^ unurl ^ "}},cons({c:\"!\",e:"), ek, - str ("," + str ("},cons(" ^ (case eff of ReadCookieWrite => "true" | _ => "false") - ^ ")")], + ^ ",null)))))}")], st) end @@ -1135,12 +926,12 @@ val (ek, st) = jsE inner (ek, st) val (unurl, st) = unurlifyExp loc (t, st) in - (strcat [str "rv(", + (strcat [str ("{c:\"f\",f:rv,a:cons("), e, - str (", function(s){var t=s.split(\"/\");var i=0;return " - ^ unurl ^ "},"), + str (",cons({c:\"c\",v:function(s){var t=s.split(\"/\");var i=0;return " + ^ unurl ^ "}},cons({c:\"!\",e:"), ek, - str ")"], + str ("},null)))}")], st) end @@ -1149,19 +940,18 @@ val (e, st) = jsE inner (e, st) val (ek, st) = jsE inner (ek, st) in - (strcat [str "window.setTimeout(", + (strcat [str "{c:\"f\",f:window.setTimeout,a:cons(", ek, - str ", ", + str ",cons(", e, - str ")"], + str ",null))}"], st) end end in - jsE + jsE 0 end - fun patBinds ((p, _), env) = case p of PWild => env @@ -1350,28 +1140,9 @@ end | EJavaScript (m, e') => - (let - val len = length outer - fun str s = (EPrim (Prim.String s), #2 e') - - val locals = List.tabulate - (varDepth e', - fn i => str ("var _" ^ Int.toString (len + i) ^ ";")) - - val (e', st) = jsExp m outer 0 (e', st) - - val e' = - case locals of - [] => e' - | _ => - strcat (#2 e') (str "(function(){" - :: locals - @ [str "return ", - e', - str "}())"]) - in - (e', st) - end handle CantEmbed _ => (e, st)) + (foundJavaScript := true; + jsExp m outer (e', st) + handle CantEmbed _ => (e, st)) | ESignalReturn e => let
--- a/src/monoize.sml Tue Sep 22 09:53:05 2009 -0400 +++ b/src/monoize.sml Tue Sep 22 12:23:21 2009 -0400 @@ -2522,17 +2522,20 @@ | (L'.TFun (dom, _), _) => let val s' = " " ^ lowercaseFirst x ^ "='" - val e = case #1 dom of - L'.TRecord [] => (L'.EApp (e, (L'.ERecord [], loc)), loc) - | _ => (L'.EApp ((L'.EApp (e, (L'.EFfiApp ("Basis", "kc", []), loc)), - loc), (L'.ERecord [], loc)), loc) + val (e, s') = + case #1 dom of + L'.TRecord [] => ((L'.EApp (e, (L'.ERecord [], loc)), loc), s') + | _ => ((L'.EApp ((L'.EApp (e, (L'.EFfiApp ("Basis", "kc", []), loc)), + loc), (L'.ERecord [], loc)), loc), + s' ^ "uwe=event;") + val s' = s' ^ "exec(" in ((L'.EStrcat (s, (L'.EStrcat ( (L'.EPrim (Prim.String s'), loc), (L'.EStrcat ( (L'.EJavaScript (L'.Attribute, e), loc), - (L'.EPrim (Prim.String ";return false'"), loc)), loc)), + (L'.EPrim (Prim.String ");return false'"), loc)), loc)), loc)), loc), fm) end @@ -2621,13 +2624,13 @@ val assgns = List.mapPartial (fn ("Source", _, _) => NONE | ("Onchange", e, _) => - SOME (strcat [str "addOnChange(d,", + SOME (strcat [str "addOnChange(d,exec(", (L'.EJavaScript (L'.Script, e), loc), - str ")"]) + str "))"]) | (x, e, _) => - SOME (strcat [str ("d." ^ lowercaseFirst x ^ "="), + SOME (strcat [str ("d." ^ lowercaseFirst x ^ "=exec("), (L'.EJavaScript (L'.Script, e), loc), - str ";"])) + str ");"])) attrs in case assgns of @@ -2646,7 +2649,9 @@ let val e = (L'.EApp (e, (L'.ERecord [], loc)), loc) in - (L'.EJavaScript (L'.Attribute, e), loc) + (L'.EStrcat ((L'.EPrim (Prim.String "exec("), loc), + (L'.EStrcat ((L'.EJavaScript (L'.Attribute, e), loc), + (L'.EPrim (Prim.String ")"), loc)), loc)), loc) end in normal ("body", @@ -2677,9 +2682,9 @@ [("Signal", e, _)] => ((L'.EStrcat ((L'.EPrim (Prim.String ("<script type=\"text/javascript\">dyn(\"" - ^ tag ^ "\", ")), loc), + ^ tag ^ "\", exec(")), loc), (L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc), - (L'.EPrim (Prim.String (")</script>")), loc)), loc)), loc), + (L'.EPrim (Prim.String ("))</script>")), loc)), loc)), loc), fm) | _ => raise Fail "Monoize: Bad dyn attributes" end @@ -2701,9 +2706,9 @@ loc)), loc), fm) end | SOME (_, src, _) => - (strcat [str "<script type=\"text/javascript\">inp(", + (strcat [str "<script type=\"text/javascript\">inp(exec(", (L'.EJavaScript (L'.Script, src), loc), - str ")</script>"], + str "))</script>"], fm)) | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); raise Fail "No name passed to textbox tag")) @@ -2773,9 +2778,9 @@ end | SOME (_, src, _) => let - val sc = strcat [str "inp(", + val sc = strcat [str "inp(exec(", (L'.EJavaScript (L'.Script, src), loc), - str ")"] + str "))"] val sc = setAttrs sc in (strcat [str "<script type=\"text/javascript\">", @@ -2796,9 +2801,9 @@ end | SOME (_, src, _) => let - val sc = strcat [str "chk(", + val sc = strcat [str "chk(exec(", (L'.EJavaScript (L'.Script, src), loc), - str ")"] + str "))"] val sc = setAttrs sc in (strcat [str "<script type=\"text/javascript\">", @@ -2824,11 +2829,11 @@ let val (xml, fm) = monoExp (env, st, fm) xml - val sc = strcat [str "sel(", + val sc = strcat [str "sel(exec(", (L'.EJavaScript (L'.Script, src), loc), str ",", (L'.EJavaScript (L'.Script, xml), loc), - str ")"] + str "))"] val sc = setAttrs sc in (strcat [str "<script type=\"text/javascript\">",
--- a/src/scriptcheck.sml Tue Sep 22 09:53:05 2009 -0400 +++ b/src/scriptcheck.sml Tue Sep 22 12:23:21 2009 -0400 @@ -67,7 +67,7 @@ "unload"] val scriptWords = "<script" - :: map (fn s => "on" ^ s ^ " ='") events + :: map (fn s => " on" ^ s ^ "='") events val pushWords = ["rv("] @@ -75,12 +75,7 @@ let val proto = Settings.currentProtocol () - fun inString {needle, haystack} = - let - val (_, suffix) = Substring.position needle (Substring.full haystack) - in - not (Substring.isEmpty suffix) - end + fun inString {needle, haystack} = String.isSubstring needle haystack fun hasClient {basis, words, onload} csids = let