From f083e82c95ac4a9d3a22e032f81b6dc88a88f499 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 15 Feb 2009 12:33:41 -0500 Subject: Initial parsing of RPC results --- src/cjr_print.sml | 53 +++++++++++++----------- src/jscomp.sml | 120 +++++++++++++++++++++++++++++++++++++++++++++++++++++- src/rpcify.sml | 9 ++-- 3 files changed, 153 insertions(+), 29 deletions(-) (limited to 'src') diff --git a/src/cjr_print.sml b/src/cjr_print.sml index fcd18fb7..c1911c8d 100644 --- a/src/cjr_print.sml +++ b/src/cjr_print.sml @@ -863,30 +863,37 @@ fun urlify env t = val xts = E.lookupStruct env i - val (blocks, _) = ListUtil.foldlMap - (fn ((x, t), wasEmpty) => - (box [string "{", - newline, - p_typ env t, - space, - string ("it" ^ Int.toString (level + 1)), - space, - string "=", - space, - string ("it" ^ Int.toString level ^ ".__uwf_" ^ x ^ ";"), - newline, - box (if wasEmpty then - [] - else - [string "uw_write(ctx, \"/\");", - newline]), - urlify' rf (level + 1) t, - string "}", - newline], - empty t)) - false xts + val (blocks, _) = foldl + (fn ((x, t), (blocks, printingSinceLastSlash)) => + let + val thisEmpty = empty t + in + if thisEmpty then + (blocks, printingSinceLastSlash) + else + (box [string "{", + newline, + p_typ env t, + space, + string ("it" ^ Int.toString (level + 1)), + space, + string "=", + space, + string ("it" ^ Int.toString level ^ ".__uwf_" ^ x ^ ";"), + newline, + box (if printingSinceLastSlash then + [string "uw_write(ctx, \"/\");", + newline] + else + []), + urlify' rf (level + 1) t, + string "}", + newline] :: blocks, + true) + end) + ([], false) xts in - box blocks + box (rev blocks) end | TDatatype (Enum, i, _) => box [] diff --git a/src/jscomp.sml b/src/jscomp.sml index de671fef..9651f930 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -304,6 +304,120 @@ fun process file = Print.prefaces "Can't embed" [("t", MonoPrint.p_typ MonoEnv.empty t)]; (str loc "ERROR", st)) + fun unurlifyExp loc (t : typ, st) = + case #1 t of + TRecord [] => ("null", st) + | TRecord [(x, t)] => + let + val (e, st) = unurlifyExp loc (t, st) + in + ("{_" ^ x ^ ":" ^ e ^ "}", + st) + end + | TRecord ((x, t) :: xts) => + 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 + in + (String.concat ("{_" + :: x + :: ":" + :: e' + :: es + @ ["}"]), st) + end + + | TFfi ("Basis", "string") => ("decode(t[i++])", st) + | TFfi ("Basis", "int") => ("parseInt(t[i++])", st) + | TFfi ("Basis", "float") => ("parseFloat(t[i++])", st) + + | TFfi ("Basis", "bool") => ("t[i++] == \"True\"", st) + + | TOption t => raise Fail "!!" (* + let + val (e', st) = quoteExp loc t ((ERel 0, loc), st) + 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*) + + | TDatatype (n, ref (dk, cs)) => raise Fail "!!" (* + (case IM.find (#injectors st, n) of + 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'), + 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)), + st) + | ((_, cn, SOME t), st) => + let + val (e, st) = quoteExp loc t ((ERel 0, loc), 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 "}"]), + st) + end) + 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 st = {decls = (DValRec [("jsify", n', (TFun (t, s), loc), + body, "jsify")], loc) :: #decls st, + script = #script st, + included = #included st, + injectors = #injectors st, + maxName = #maxName st} + in + ((EApp ((ENamed n', loc), e), loc), 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)]; + ("ERROR", st)) + fun jsExp mode skip outer = let val len = length outer @@ -812,11 +926,13 @@ fun process file = st) end - | EServerCall (x, es, ek, _) => + | EServerCall (x, es, ek, t) => let val (ek, st) = jsE inner (ek, st) + val (unurl, st) = unurlifyExp loc (t, st) in - (strcat [str ("rc(\"" ^ !Monoize.urlPrefix ^ x ^ "\","), + (strcat [str ("rc(\"" ^ !Monoize.urlPrefix ^ x ^ "\", function(s){var t=s.split(\"/\");var i=0;return " + ^ unurl ^ "},"), ek, str ")"], st) diff --git a/src/rpcify.sml b/src/rpcify.sml index 45d178ee..6601a14b 100644 --- a/src/rpcify.sml +++ b/src/rpcify.sml @@ -103,8 +103,8 @@ fun frob file = let fun doOne ((_, n, t, _, _), tfuncs) = let - fun crawl ((t, _), args) = - case t of + fun crawl (t, args) = + case #1 t of CApp ((CFfi ("Basis", "transaction"), _), ran) => SOME (rev args, ran) | TFun (arg, rest) => crawl (rest, arg :: args) | _ => NONE @@ -130,7 +130,7 @@ fun frob file = trans1), _), trans2) => (case (serverSide trans1, clientSide trans1, serverSide trans2, clientSide trans2) of - (true, false, false, _) => + (true, false, false, true) => let fun getApp (e, args) = case #1 e of @@ -156,7 +156,8 @@ fun frob file = val ran = case IM.find (tfuncs, n) of - NONE => raise Fail "Rpcify: Undetected transaction function" + NONE => (Print.prefaces "BAD" [("e", CorePrint.p_exp CoreEnv.empty (e, loc))]; + raise Fail "Rpcify: Undetected transaction function") | SOME (_, ran) => ran in (EServerCall (n, args, trans2, ran), st) -- cgit v1.2.3