diff options
author | 2009-03-08 12:37:42 -0400 | |
---|---|---|
committer | 2009-03-08 12:37:42 -0400 | |
commit | 8f1f8871d3760f6254a3fc171edaf6ef503d31c3 (patch) | |
tree | 16f872ddda6b89d621cb45a6dd0a1b492ece00dc | |
parent | 5dc500861e6f121d392ffa842e4836077eba3f50 (diff) |
RPC returning an enumeration
-rw-r--r-- | src/cjr_print.sml | 73 | ||||
-rw-r--r-- | src/jscomp.sml | 114 | ||||
-rw-r--r-- | tests/rpcDE.ur | 30 | ||||
-rw-r--r-- | tests/rpcDE.urp | 5 |
4 files changed, 126 insertions, 96 deletions
diff --git a/src/cjr_print.sml b/src/cjr_print.sml index c1911c8d..8b15af4d 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -501,25 +501,32 @@ fun p_ensql t e = 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 @@ fun urlify env t = 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 @@ fun p_exp' par env (e, loc) = 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 @@ fun p_fun env (fx, n, args, ran, e) = 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 is_not_null t = 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) => diff --git a/src/jscomp.sml b/src/jscomp.sml index 383a9f6f..1a85bba2 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -64,6 +64,7 @@ type state = { script : string list, included : IS.set, injectors : int IM.map, + decoders : int IM.map, maxName : int } @@ -251,13 +252,12 @@ fun process file = 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 @@ fun process file = 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 @@ fun process file = 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 @@ fun process file = 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 @@ fun process file = | 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 @@ fun process file = 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 @@ fun process file = script = sc :: #script st, included = #included st, injectors = #injectors st, + decoders= #decoders st, maxName = #maxName st} end in @@ -986,6 +976,7 @@ fun process file = script = #script st, included = #included st, injectors = #injectors st, + decoders = #decoders st, maxName = #maxName st}) end @@ -994,6 +985,7 @@ fun process file = script = [], included = IS.empty, injectors = IM.empty, + decoders = IM.empty, maxName = U.File.maxName file + 1} file diff --git a/tests/rpcDE.ur b/tests/rpcDE.ur new file mode 100644 index 00000000..64e190f5 --- /dev/null +++ b/tests/rpcDE.ur @@ -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 diff --git a/tests/rpcDE.urp b/tests/rpcDE.urp new file mode 100644 index 00000000..2027ff85 --- /dev/null +++ b/tests/rpcDE.urp @@ -0,0 +1,5 @@ +debug +sql rpcDE.sql +database dbname=rpcde + +rpcDE |