Mercurial > urweb
changeset 765:a28982de5645
Successfully influenced effectful-ness status of FFI func
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sat, 02 May 2009 11:27:26 -0400 |
| parents | 7f653298dd66 |
| children | df09c95085f8 |
| files | src/cjr_print.sml src/compiler.sig src/compiler.sml src/corify.sml src/demo.sml src/effectize.sml src/jscomp.sml src/marshalcheck.sml src/mono_reduce.sml src/rpcify.sml src/settings.sig src/settings.sml tests/cffi.ur tests/cffi.urp tests/test.c tests/test.h tests/test.urs |
| diffstat | 17 files changed, 235 insertions(+), 113 deletions(-) [+] |
line wrap: on
line diff
--- a/src/cjr_print.sml Thu Apr 30 17:15:14 2009 -0400 +++ b/src/cjr_print.sml Sat May 02 11:27:26 2009 -0400 @@ -1396,6 +1396,12 @@ | EApp ((EReturnBlob {blob, mimeType, t = (TFun (_, ran), _)}, loc), _) => p_exp env (EReturnBlob {blob = blob, mimeType = mimeType, t = ran}, loc) + | EFfiApp (m, x, []) => box [string "uw_", + p_ident m, + string "_", + p_ident x, + string "(ctx)"] + | EFfiApp (m, x, es) => box [string "uw_", p_ident m, string "_",
--- a/src/compiler.sig Thu Apr 30 17:15:14 2009 -0400 +++ b/src/compiler.sig Sat May 02 11:27:26 2009 -0400 @@ -40,7 +40,12 @@ timeout : int, ffi : string list, link : string list, - headers : string list + headers : string list, + clientToServer : Settings.ffi list, + effectful : Settings.ffi list, + clientOnly : Settings.ffi list, + serverOnly : Settings.ffi list, + jsFuncs : (Settings.ffi * string) list } val compile : string -> unit val compileC : {cname : string, oname : string, ename : string, libs : string,
--- a/src/compiler.sml Thu Apr 30 17:15:14 2009 -0400 +++ b/src/compiler.sml Sat May 02 11:27:26 2009 -0400 @@ -44,7 +44,12 @@ timeout : int, ffi : string list, link : string list, - headers : string list + headers : string list, + clientToServer : Settings.ffi list, + effectful : Settings.ffi list, + clientOnly : Settings.ffi list, + serverOnly : Settings.ffi list, + jsFuncs : (Settings.ffi * string) list } type ('src, 'dst) phase = { @@ -202,10 +207,15 @@ handle LrParser.ParseError => [], print = SourcePrint.p_file} -fun p_job {prefix, database, exe, sql, sources, debug, profile, timeout, ffi, link, headers} = +fun p_job {prefix, database, exe, sql, sources, debug, profile, + timeout, ffi, link, headers, + clientToServer, effectful, clientOnly, serverOnly, jsFuncs} = let open Print.PD open Print + + fun p_ffi name = p_list_sep (box []) (fn (m, s) => + box [string name, space, string m, string ".", string s, newline]) in box [if debug then box [string "DEBUG", newline] @@ -232,6 +242,13 @@ p_list_sep (box []) (fn s => box [string "Ffi", space, string s, newline]) ffi, p_list_sep (box []) (fn s => box [string "Header", space, string s, newline]) headers, p_list_sep (box []) (fn s => box [string "Link", space, string s, newline]) link, + p_ffi "ClientToServer" clientToServer, + p_ffi "Effectful" effectful, + p_ffi "ClientOnly" clientOnly, + p_ffi "ServerOnly" serverOnly, + p_list_sep (box []) (fn ((m, s), s') => + box [string "JsFunc", space, string m, string ".", string s, + space, string "=", space, string s', newline]) jsFuncs, string "Sources:", p_list string sources, newline] @@ -288,6 +305,11 @@ val ffi = ref [] val link = ref [] val headers = ref [] + val clientToServer = ref [] + val effectful = ref [] + val clientOnly = ref [] + val serverOnly = ref [] + val jsFuncs = ref [] fun finish sources = {prefix = Option.getOpt (!prefix, "/"), @@ -298,9 +320,14 @@ debug = !debug, profile = !profile, timeout = Option.getOpt (!timeout, 60), - ffi = !ffi, - link = !link, - headers = !headers, + ffi = rev (!ffi), + link = rev (!link), + headers = rev (!headers), + clientToServer = rev (!clientToServer), + effectful = rev (!effectful), + clientOnly = rev (!clientOnly), + serverOnly = rev (!serverOnly), + jsFuncs = rev (!jsFuncs), sources = sources} fun read () = @@ -312,6 +339,22 @@ val (cmd, arg) = Substring.splitl (fn x => not (Char.isSpace x)) (Substring.full line) val cmd = Substring.string (trim cmd) val arg = Substring.string (trim arg) + + fun ffiS () = + case String.fields (fn ch => ch = #".") arg of + [m, x] => (m, x) + | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func"); + ("", "")) + + fun ffiM () = + case String.fields (fn ch => ch = #"=") arg of + [f, s] => + (case String.fields (fn ch => ch = #".") f of + [m, x] => ((m, x), s) + | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'"); + (("", ""), ""))) + | _ => (ErrorMsg.error (cmd ^ " argument not of the form Module.func=func'"); + (("", ""), "")) in case cmd of "prefix" => @@ -344,6 +387,11 @@ | "ffi" => ffi := relify arg :: !ffi | "link" => link := relifyA arg :: !link | "include" => headers := relifyA arg :: !headers + | "clientToServer" => clientToServer := ffiS () :: !clientToServer + | "effectful" => effectful := ffiS () :: !effectful + | "clientOnly" => clientOnly := ffiS () :: !clientOnly + | "serverOnly" => serverOnly := ffiS () :: !serverOnly + | "jsFunc" => jsFuncs := ffiM () :: !jsFuncs | _ => ErrorMsg.error ("Unrecognized command '" ^ cmd ^ "'"); read () end @@ -354,6 +402,11 @@ Settings.setUrlPrefix (#prefix job); Settings.setTimeout (#timeout job); Settings.setHeaders (#headers job); + Settings.setClientToServer (#clientToServer job); + Settings.setEffectful (#effectful job); + Settings.setClientOnly (#clientOnly job); + Settings.setServerOnly (#serverOnly job); + Settings.setJsFuncs (#jsFuncs job); job end, print = p_job
--- a/src/corify.sml Thu Apr 30 17:15:14 2009 -0400 +++ b/src/corify.sml Sat May 02 11:27:26 2009 -0400 @@ -539,6 +539,9 @@ case t of (L'.TFun (dom as (L'.TRecord (L'.CRecord (_, []), _), _), ran), _) => (L'.EAbs ("arg", dom, ran, (L'.EFfiApp (m, x, []), loc)), loc) + | (L'.CApp ((L'.CFfi ("Basis", "transaction"), _), dom), _) => + (L'.EAbs ("arg", dom, (L'.TRecord (L'.CRecord ((L'.KType, loc), []), loc), loc), + (L'.EFfiApp (m, x, []), loc)), loc) | t as (L'.TFun _, _) => let fun getArgs (all as (t, _), args) =
--- a/src/demo.sml Thu Apr 30 17:15:14 2009 -0400 +++ b/src/demo.sml Sat May 02 11:27:26 2009 -0400 @@ -97,7 +97,12 @@ profile = false, ffi = [], link = [], - headers = [] + headers = [], + clientToServer = [], + effectful = [], + clientOnly = [], + serverOnly = [], + jsFuncs = [] } val parse = Compiler.run (Compiler.transform Compiler.parseUrp "Demo parseUrp")
--- a/src/effectize.sml Thu Apr 30 17:15:14 2009 -0400 +++ b/src/effectize.sml Sat May 02 11:27:26 2009 -0400 @@ -37,15 +37,14 @@ val compare = String.compare end) -val effectful = ["dml", "nextval", "send", "setCookie"] -val effectful = SS.addList (SS.empty, effectful) +fun effectful x = Settings.isEffectful x andalso not (Settings.isClientOnly x) fun effectize file = let fun exp evs e = case e of - EFfi ("Basis", s) => SS.member (effectful, s) - | EFfiApp ("Basis", s, _) => SS.member (effectful, s) + EFfi f => effectful f + | EFfiApp (m, x, _) => effectful (m, x) | ENamed n => IM.inDomain (evs, n) | EServerCall (n, _, _, _) => IM.inDomain (evs, n) | _ => false
--- a/src/jscomp.sml Thu Apr 30 17:15:14 2009 -0400 +++ b/src/jscomp.sml Sat May 02 11:27:26 2009 -0400 @@ -36,40 +36,6 @@ structure IS = IntBinarySet structure IM = IntBinaryMap -val funcs = [(("Basis", "alert"), "alert"), - (("Basis", "get_client_source"), "sg"), - (("Basis", "htmlifyBool"), "bs"), - (("Basis", "htmlifyFloat"), "ts"), - (("Basis", "htmlifyInt"), "ts"), - (("Basis", "htmlifyString"), "eh"), - (("Basis", "new_client_source"), "sc"), - (("Basis", "set_client_source"), "sv"), - (("Basis", "stringToFloat_error"), "pfl"), - (("Basis", "stringToInt_error"), "pi"), - (("Basis", "urlifyInt"), "ts"), - (("Basis", "urlifyFloat"), "ts"), - (("Basis", "urlifyString"), "uf"), - (("Basis", "recv"), "rv"), - (("Basis", "strcat"), "cat"), - (("Basis", "intToString"), "ts"), - (("Basis", "floatToString"), "ts"), - (("Basis", "onError"), "onError"), - (("Basis", "onFail"), "onFail"), - (("Basis", "onConnectFail"), "onConnectFail"), - (("Basis", "onDisconnect"), "onDisconnect"), - (("Basis", "onServerError"), "onServerError")] - -structure FM = BinaryMapFn(struct - type ord_key = string * string - fun compare ((m1, x1), (m2, x2)) = - Order.join (String.compare (m1, m2), - fn () => String.compare (x1, x2)) - end) - -val funcs = foldl (fn ((k, v), m) => FM.insert (m, k, v)) FM.empty funcs - -fun ffi k = FM.find (funcs, k) - type state = { decls : decl list, script : string list, @@ -684,7 +650,7 @@ | EFfi k => let - val name = case ffi k of + val name = case Settings.jsFunc k of NONE => (EM.errorAt loc ("Unsupported FFI identifier " ^ #2 k ^ " in JavaScript"); "ERROR") @@ -700,7 +666,7 @@ | ("Basis", "set_client_source", [e1, (EJavaScript (_, e2, _), _)]) => [e1, e2] | _ => args - val name = case ffi (m, x) of + val name = case Settings.jsFunc (m, x) of NONE => (EM.errorAt loc ("Unsupported FFI function " ^ x ^ " in JavaScript"); "ERROR")
--- a/src/marshalcheck.sml Thu Apr 30 17:15:14 2009 -0400 +++ b/src/marshalcheck.sml Sat May 02 11:27:26 2009 -0400 @@ -53,18 +53,6 @@ structure IM = IntBinaryMap -val clientToServer = [("Basis", "int"), - ("Basis", "float"), - ("Basis", "string"), - ("Basis", "time"), - ("Basis", "file"), - ("Basis", "unit"), - ("Basis", "option"), - ("Basis", "list"), - ("Basis", "bool")] - -val clientToServer = PS.addList (PS.empty, clientToServer) - fun check file = let fun kind (_, st) = st @@ -72,7 +60,7 @@ fun con cmap (c, st) = case c of CFfi mx => - if PS.member (clientToServer, mx) then + if Settings.mayClientToServer mx then st else PS.add (st, mx)
--- a/src/mono_reduce.sml Thu Apr 30 17:15:14 2009 -0400 +++ b/src/mono_reduce.sml Sat May 02 11:27:26 2009 -0400 @@ -53,20 +53,7 @@ | ENone _ => false | ESome (_, e) => impure e | EFfi _ => false - | EFfiApp ("Basis", "set_cookie", _) => true - | EFfiApp ("Basis", "new_client_source", _) => true - | EFfiApp ("Basis", "get_client_source", _) => true - | EFfiApp ("Basis", "set_client_source", _) => true - | EFfiApp ("Basis", "alert", _) => true - | EFfiApp ("Basis", "new_channel", _) => true - | EFfiApp ("Basis", "subscribe", _) => true - | EFfiApp ("Basis", "send", _) => true - | EFfiApp ("Basis", "onError", _) => true - | EFfiApp ("Basis", "onFail", _) => true - | EFfiApp ("Basis", "onConnectFail", _) => true - | EFfiApp ("Basis", "onDisconnect", _) => true - | EFfiApp ("Basis", "onServerError", _) => true - | EFfiApp _ => false + | EFfiApp (m, x, _) => Settings.isEffectful (m, x) | EApp ((EFfi _, _), _) => false | EApp _ => true @@ -271,8 +258,6 @@ fun summarize d (e, _) = let - fun ffi es = List.concat (map (summarize d) es) @ [Unsure] - val s = case e of EPrim _ => [] @@ -283,20 +268,11 @@ | ENone _ => [] | ESome (_, e) => summarize d e | EFfi _ => [] - | EFfiApp ("Basis", "set_cookie", es) => ffi es - | EFfiApp ("Basis", "new_client_source", es) => ffi es - | EFfiApp ("Basis", "get_client_source", es) => ffi es - | EFfiApp ("Basis", "set_client_source", es) => ffi es - | EFfiApp ("Basis", "alert", es) => ffi es - | EFfiApp ("Basis", "new_channel", es) => ffi es - | EFfiApp ("Basis", "subscribe", es) => ffi es - | EFfiApp ("Basis", "send", es) => ffi es - | EFfiApp ("Basis", "onError", es) => ffi es - | EFfiApp ("Basis", "onFail", es) => ffi es - | EFfiApp ("Basis", "onConnectFail", es) => ffi es - | EFfiApp ("Basis", "onDisconnect", es) => ffi es - | EFfiApp ("Basis", "onServerError", es) => ffi es - | EFfiApp (_, _, es) => List.concat (map (summarize d) es) + | EFfiApp (m, x, es) => + if Settings.isEffectful (m, x) then + List.concat (map (summarize d) es) @ [Unsure] + else + List.concat (map (summarize d) es) | EApp ((EFfi _, _), e) => summarize d e | EApp _ => let
--- a/src/rpcify.sml Thu Apr 30 17:15:14 2009 -0400 +++ b/src/rpcify.sml Sat May 02 11:27:26 2009 -0400 @@ -46,23 +46,6 @@ else multiLiftExpInExp (n - 1) (E.liftExpInExp 0 e) -val ssBasis = SS.addList (SS.empty, - ["requestHeader", - "query", - "dml", - "nextval", - "channel", - "subscribe", - "send"]) - -val csBasis = SS.addList (SS.empty, - ["get", - "set", - "alert", - "recv", - "sleep", - "spawn"]) - type state = { cpsed : int IM.map, cpsed_range : con IM.map, @@ -80,8 +63,8 @@ U.Exp.exists {kind = fn _ => false, con = fn _ => false, exp = fn ENamed n => IS.member (ssids, n) - | EFfi ("Basis", x) => SS.member (basis, x) - | EFfiApp ("Basis", x, _) => SS.member (basis, x) + | EFfi x => basis x + | EFfiApp (m, x, _) => basis (m, x) | _ => false} (U.Exp.map {kind = fn x => x, con = fn x => x, @@ -110,14 +93,14 @@ foldl decl IS.empty file end - val ssids = whichIds ssBasis - val csids = whichIds csBasis + val ssids = whichIds Settings.isServerOnly + val csids = whichIds Settings.isClientOnly fun sideish' (basis, ids) extra = sideish (basis, IM.foldli (fn (id, _, ids) => IS.add (ids, id)) ids extra) - val serverSide = sideish' (ssBasis, ssids) - val clientSide = sideish' (csBasis, csids) + val serverSide = sideish' (Settings.isServerOnly, ssids) + val clientSide = sideish' (Settings.isClientOnly, csids) val tfuncs = foldl (fn ((d, _), tfuncs) =>
--- a/src/settings.sig Thu Apr 30 17:15:14 2009 -0400 +++ b/src/settings.sig Sat May 02 11:27:26 2009 -0400 @@ -27,13 +27,38 @@ signature SETTINGS = sig + (* How do all application URLs begin? *) val setUrlPrefix : string -> unit val getUrlPrefix : unit -> string + (* How many seconds should the server wait before assuming a Comet client has left? *) val setTimeout : int -> unit val getTimeout : unit -> int + (* Which C header files are needed? *) val setHeaders : string list -> unit val getHeaders : unit -> string list + type ffi = string * string + + (* Which FFI types may be sent from clients to servers? *) + val setClientToServer : ffi list -> unit + val mayClientToServer : ffi -> bool + + (* Which FFI functions have side effects? *) + val setEffectful : ffi list -> unit + val isEffectful : ffi -> bool + + (* Which FFI functions may only be run in clients? *) + val setClientOnly : ffi list -> unit + val isClientOnly : ffi -> bool + + (* Which FFI functions may only be run on servers? *) + val setServerOnly : ffi list -> unit + val isServerOnly : ffi -> bool + + (* Which FFI functions may be run in JavaScript? (JavaScript function names included) *) + val setJsFuncs : (ffi * string) list -> unit + val jsFunc : ffi -> string option + end
--- a/src/settings.sml Thu Apr 30 17:15:14 2009 -0400 +++ b/src/settings.sml Sat May 02 11:27:26 2009 -0400 @@ -46,4 +46,101 @@ fun getHeaders () = !headers fun setHeaders ls = headers := ls +type ffi = string * string + +structure K = struct +type ord_key = ffi +fun compare ((m1, x1), (m2, x2)) = + Order.join (String.compare (m1, m2), + fn () => String.compare (x1, x2)) end + +structure S = BinarySetFn(K) +structure M = BinaryMapFn(K) + +fun basis x = S.addList (S.empty, map (fn x : string => ("Basis", x)) x) + +val clientToServerBase = basis ["int", + "float", + "string", + "time", + "file", + "unit", + "option", + "list", + "bool"] +val clientToServer = ref clientToServerBase +fun setClientToServer ls = clientToServer := S.addList (clientToServerBase, ls) +fun mayClientToServer x = S.member (!clientToServer, x) + +val effectfulBase = basis ["set_cookie", + "new_client_source", + "get_client_source", + "set_client_source", + "alert", + "new_channel", + "send", + "onError", + "onFail", + "onConnectFail", + "onDisconnect", + "onServerError"] + +val effectful = ref effectfulBase +fun setEffectful ls = effectful := S.addList (effectfulBase, ls) +fun isEffectful x = S.member (!effectful, x) + +val clientBase = basis ["get", + "set", + "alert", + "recv", + "sleep", + "spawn", + "onError", + "onFail", + "onConnectFail", + "onDisconnect", + "onServerError"] +val client = ref clientBase +fun setClientOnly ls = client := S.addList (clientBase, ls) +fun isClientOnly x = S.member (!client, x) + +val serverBase = basis ["requestHeader", + "query", + "dml", + "nextval", + "channel", + "send"] +val server = ref serverBase +fun setServerOnly ls = server := S.addList (serverBase, ls) +fun isServerOnly x = S.member (!server, x) + +val basisM = foldl (fn ((k, v : string), m) => M.insert (m, ("Basis", k), v)) M.empty + +val jsFuncsBase = basisM [("alert", "alert"), + ("get_client_source", "sg"), + ("htmlifyBool", "bs"), + ("htmlifyFloat", "ts"), + ("htmlifyInt", "ts"), + ("htmlifyString", "eh"), + ("new_client_source", "sc"), + ("set_client_source", "sv"), + ("stringToFloat_error", "pfl"), + ("stringToInt_error", "pi"), + ("urlifyInt", "ts"), + ("urlifyFloat", "ts"), + ("urlifyString", "uf"), + ("recv", "rv"), + ("strcat", "cat"), + ("intToString", "ts"), + ("floatToString", "ts"), + ("onError", "onError"), + ("onFail", "onFail"), + ("onConnectFail", "onConnectFail"), + ("onDisconnect", "onDisconnect"), + ("onServerError", "onServerError")] +val jsFuncs = ref jsFuncsBase +fun setJsFuncs ls = jsFuncs := foldl (fn ((k, v), m) => M.insert (m, k, v)) jsFuncsBase ls +fun jsFunc x = M.find (!jsFuncs, x) + +end
--- a/tests/cffi.ur Thu Apr 30 17:15:14 2009 -0400 +++ b/tests/cffi.ur Sat May 02 11:27:26 2009 -0400 @@ -1,3 +1,8 @@ +fun effect () = + Test.print; + return <xml/> + fun main () = return <xml><body> {[Test.out (Test.frob (Test.create "Hello ") "world!")]} + <form><submit action={effect}/></form> </body></xml>
--- a/tests/cffi.urp Thu Apr 30 17:15:14 2009 -0400 +++ b/tests/cffi.urp Sat May 02 11:27:26 2009 -0400 @@ -2,5 +2,6 @@ ffi test include test.h link test.o +effectful Test.print cffi
--- a/tests/test.c Thu Apr 30 17:15:14 2009 -0400 +++ b/tests/test.c Sat May 02 11:27:26 2009 -0400 @@ -1,3 +1,5 @@ +#include <stdio.h> + #include "../include/urweb.h" typedef uw_Basis_string uw_Test_t; @@ -13,3 +15,8 @@ uw_Test_t uw_Test_frob(uw_context ctx, uw_Test_t s1, uw_Basis_string s2) { return uw_Basis_strcat(ctx, s1, s2); } + +uw_Basis_unit uw_Test_print(uw_context ctx) { + printf("Hi there!\n"); + return uw_unit_v; +}
--- a/tests/test.h Thu Apr 30 17:15:14 2009 -0400 +++ b/tests/test.h Sat May 02 11:27:26 2009 -0400 @@ -5,3 +5,5 @@ uw_Test_t uw_Test_create(uw_context, uw_Basis_string); uw_Basis_string uw_Test_out(uw_context, uw_Test_t); uw_Test_t uw_Test_frob(uw_context, uw_Test_t, uw_Basis_string); + +uw_Basis_unit uw_Test_print(uw_context);