Mercurial > urweb
changeset 638:3ee6bb48f6e8
RPC returning an enumeration
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sun, 08 Mar 2009 12:37:42 -0400 |
| parents | 24fd1edfcaa3 |
| children | 9da62680adc5 |
| files | src/cjr_print.sml src/jscomp.sml tests/rpcDE.ur tests/rpcDE.urp |
| diffstat | 4 files changed, 126 insertions(+), 96 deletions(-) [+] |
line wrap: on
line diff
--- a/src/cjr_print.sml Thu Feb 26 16:16:54 2009 -0500 +++ b/src/cjr_print.sml Sun Mar 08 12:37:42 2009 -0400 @@ -501,25 +501,32 @@ fun notLeaky env allowHeapAllocated = let - fun nl (t, _) = + fun nl ok (t, _) = case t of TFun _ => false | TRecord n => let val xts = E.lookupStruct env n in - List.all (fn (_, t) => nl t) xts + List.all (fn (_, t) => nl ok t) xts end - | TDatatype (dk, _, ref cons) => - (allowHeapAllocated orelse dk = Enum) - andalso List.all (fn (_, _, to) => case to of - NONE => true - | SOME t => nl t) cons + | TDatatype (dk, n, ref cons) => + IS.member (ok, n) + orelse + ((allowHeapAllocated orelse dk = Enum) + andalso + let + val ok' = IS.add (ok, n) + in + List.all (fn (_, _, to) => case to of + NONE => true + | SOME t => nl ok' t) cons + end) | TFfi ("Basis", "string") => false | TFfi _ => true - | TOption t => allowHeapAllocated andalso nl t + | TOption t => allowHeapAllocated andalso nl ok t in - nl + nl IS.empty end fun capitalize s = @@ -896,33 +903,29 @@ box (rev blocks) end - | TDatatype (Enum, i, _) => box [] - (*let + | TDatatype (Enum, i, _) => + let val (x, xncs) = E.lookupDatatype env i fun doEm xncs = case xncs of - [] => string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " - ^ x ^ "\"), (enum __uwe_" - ^ x ^ "_" ^ Int.toString i ^ ")0)") + [] => box [string ("uw_error(ctx, FATAL, \"Error urlifying datatype " + ^ x ^ "\");"), + newline] | (x', n, to) :: rest => - box [string "((!strncmp(request, \"", - string x', - string "\", ", - string (Int.toString (size x')), - string ") && (request[", - string (Int.toString (size x')), - string "] == 0 || request[", - string (Int.toString (size x')), - string ("] == '/')) ? __uwc_" ^ ident x' ^ "_" ^ Int.toString n), - space, - string ":", - space, - doEm rest, - string ")"] + box [string ("if (it" ^ Int.toString level + ^ "==__uwc_" ^ ident x' ^ "_" ^ Int.toString n ^ ") {"), + newline, + box [string ("uw_write(ctx, \"" ^ x' ^ "\");"), + newline], + string "} else {", + newline, + box [doEm rest, + newline], + string "}"] in doEm xncs - end*) + end | TDatatype (Option, i, xncs) => box [] (*if IS.member (rf, i) then @@ -1453,7 +1456,7 @@ val tables = ListUtil.mapConcat (fn (x, xts) => map (fn (x', t) => ("__uwf_" ^ ident x ^ ".__uwf_" ^ ident x', t)) xts) tables - + val outputs = exps @ tables val outputs = ListMergeSort.sort (fn ((s1, _), (s2, _)) => String.compare (s1, s2) = GREATER) outputs @@ -1837,9 +1840,9 @@ space, string "{", newline, - box[string "return(", - p_exp env' e, - string ");"], + box [string "return(", + p_exp env' e, + string ");"], newline, string "}"] end @@ -2164,8 +2167,8 @@ fun p_file env (ds, ps) = let val (pds, env) = ListUtil.foldlMap (fn (d, env) => - (p_decl env d, - E.declBinds env d)) + (p_decl env d, + E.declBinds env d)) env ds val fields = foldl (fn ((ek, _, _, ts, _), fields) =>
--- a/src/jscomp.sml Thu Feb 26 16:16:54 2009 -0500 +++ b/src/jscomp.sml Sun Mar 08 12:37:42 2009 -0400 @@ -64,6 +64,7 @@ script : string list, included : IS.set, injectors : int IM.map, + decoders : int IM.map, maxName : int } @@ -251,13 +252,12 @@ SOME n' => ((EApp ((ENamed n', loc), e), loc), st) | NONE => let - val dk = ElabUtil.classifyDatatype cs - val n' = #maxName st val st = {decls = #decls st, script = #script st, included = #included st, injectors = IM.insert (#injectors st, n, n'), + decoders = #decoders st, maxName = n' + 1} val (pes, st) = ListUtil.foldlMap @@ -275,7 +275,7 @@ case dk of Option => if isNullable t then - strcat loc [str loc "{_v:", + strcat loc [str loc "{v:", e, str loc "}"] else @@ -298,6 +298,7 @@ script = #script st, included = #included st, injectors = #injectors st, + decoders= #decoders st, maxName = #maxName st} in ((EApp ((ENamed n', loc), e), loc), st) @@ -321,13 +322,13 @@ let val (e', st) = unurlifyExp loc (t, st) val (es, st) = ListUtil.foldlMap - (fn ((x, t), st) => - let - val (e, st) = unurlifyExp loc (t, st) - in - (",_" ^ x ^ ":" ^ e, st) - end) - st xts + (fn ((x, t), st) => + let + val (e, st) = unurlifyExp loc (t, st) + in + (",_" ^ x ^ ":" ^ e, st) + end) + st xts in (String.concat ("{_" :: x @@ -343,79 +344,66 @@ | TFfi ("Basis", "bool") => ("t[i++] == \"True\"", st) - | TOption t => raise Fail "!!" (* + | TOption t => let - val (e', st) = quoteExp loc t ((ERel 0, loc), st) + val (e, st) = unurlifyExp loc (t, st) + val e = if isNullable t then + "{v:" ^ e ^ "}" + else + e in - ((ECase (e, - [((PNone t, loc), - str loc "null"), - ((PSome (t, (PVar ("x", t), loc)), loc), - if isNullable t then - strcat loc [str loc "{v:", e', str loc "}"] - else - e')], - {disc = (TOption t, loc), - result = (TFfi ("Basis", "string"), loc)}), loc), - st) - end*) + ("(uu=t[i++],uu==\"Some\"?" ^ e ^ ":null)", st) + end - | TDatatype (n, ref (dk, cs)) => raise Fail "!!" (* - (case IM.find (#injectors st, n) of - SOME n' => ((EApp ((ENamed n', loc), e), loc), st) + | TDatatype (n, ref (dk, cs)) => + (case IM.find (#decoders st, n) of + SOME n' => ("(tmp=_n" ^ Int.toString n' ^ "(t,i),i=tmp._1,tmp._2)", st) | NONE => let - val dk = ElabUtil.classifyDatatype cs - val n' = #maxName st val st = {decls = #decls st, script = #script st, included = #included st, - injectors = IM.insert (#injectors st, n, n'), + injectors = #injectors st, + decoders = IM.insert (#decoders st, n, n'), maxName = n' + 1} - val (pes, st) = ListUtil.foldlMap - (fn ((_, cn, NONE), st) => - (((PCon (dk, PConVar cn, NONE), loc), - case dk of - Option => str loc "null" - | _ => str loc (Int.toString cn)), + val (e, st) = foldl (fn ((x, cn, NONE), (e, st)) => + ("x==\"" ^ x ^ "\"?" + ^ (case dk of + Option => "null" + | _ => Int.toString cn) + ^ ":" ^ e, st) - | ((_, cn, SOME t), st) => + | ((x, cn, SOME t), (e, st)) => let - val (e, st) = quoteExp loc t ((ERel 0, loc), st) + val (e', st) = unurlifyExp loc (t, st) in - (((PCon (dk, PConVar cn, SOME (PVar ("x", t), loc)), loc), - case dk of - Option => - if isNullable t then - strcat loc [str loc "{_v:", - e, - str loc "}"] - else - e - | _ => strcat loc [str loc ("{n:" ^ Int.toString cn - ^ ",v:"), - e, - str loc "}"]), + ("x==\"" ^ x ^ "\"?" + ^ (case dk of + Option => + if isNullable t then + "{v:" ^ e' ^ "}" + else + e' + | _ => "{n:" ^ Int.toString cn ^ ",v:" ^ e' ^ "}") + ^ ":" ^ e, st) end) - st cs + ("pf()", st) cs - val s = (TFfi ("Basis", "string"), loc) - val body = (ECase ((ERel 0, loc), pes, - {disc = t, result = s}), loc) - val body = (EAbs ("x", t, s, body), loc) + val body = "function _n" ^ Int.toString n' ^ "(t,i){var x=t[i++];var r=" + ^ e ^ ";return {_1:i,_2:r}}\n\n" - val st = {decls = (DValRec [("jsify", n', (TFun (t, s), loc), - body, "jsify")], loc) :: #decls st, - script = #script st, + val st = {decls = #decls st, + script = body :: #script st, included = #included st, injectors = #injectors st, + decoders = #decoders st, maxName = #maxName st} in - ((EApp ((ENamed n', loc), e), loc), st) - end)*) + ("(tmp=_n" ^ Int.toString n' ^ "(t,i),i=tmp._1,tmp._2)", st) + end) | _ => (EM.errorAt loc "Don't know how to unurlify type in JavaScript"; Print.prefaces "Can't unurlify" [("t", MonoPrint.p_typ MonoEnv.empty t)]; @@ -602,6 +590,7 @@ script = #script st, included = IS.add (#included st, n), injectors = #injectors st, + decoders = #decoders st, maxName = #maxName st} val (e, st) = jsExp mode skip [] 0 (e, st) @@ -613,6 +602,7 @@ script = sc :: #script st, included = #included st, injectors = #injectors st, + decoders= #decoders st, maxName = #maxName st} end in @@ -986,6 +976,7 @@ script = #script st, included = #included st, injectors = #injectors st, + decoders = #decoders st, maxName = #maxName st}) end @@ -994,6 +985,7 @@ script = [], included = IS.empty, injectors = IM.empty, + decoders = IM.empty, maxName = U.File.maxName file + 1} file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/rpcDE.ur Sun Mar 08 12:37:42 2009 -0400 @@ -0,0 +1,30 @@ +datatype result = Neg | Zero | Pos + +table t : {A : int} + +fun main () : transaction page = + let + fun check () = + r <- oneRow (SELECT SUM(t.A) AS X FROM t); + return (if r.X < 0 then + Neg + else if r.X = 0 then + Zero + else + Pos) + + fun show r = + case r of + Neg => <xml>-</xml> + | Zero => <xml>0</xml> + | Pos => <xml>+</xml> + in + s <- source Zero; + return <xml><body> + <button value="Get It On!" + onclick={r <- check (); + set s r}/><br/> + <br/> + Current: <dyn signal={r <- signal s; return (show r)}/> + </body></xml> + end