Successfully influenced effectful-ness status of FFI func

12 files changed, 219 insertions, 113 deletions

diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index e1d6d88b..b40d4248 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -1396,6 +1396,12 @@ fun p_exp' par env (e, loc) =
       | 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 "_",
diff --git a/src/compiler.sig b/src/compiler.sig
index cae86472..d49d34b0 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -40,7 +40,12 @@ signature COMPILER = sig
          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,
diff --git a/src/compiler.sml b/src/compiler.sml
index a5360f89..cdde57ad 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -44,7 +44,12 @@ type job = {
      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 @@ val parseUr = {
               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 @@ fun p_job {prefix, database, exe, sql, sources, debug, profile, timeout, ffi, li
              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 parseUrp = {
                   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 @@ val parseUrp = {
                        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 parseUrp = {
                               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 @@ val parseUrp = {
                                 | "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 @@ val parseUrp = {
                   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
diff --git a/src/corify.sml b/src/corify.sml
index 19568b8b..6cd2b753 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -539,6 +539,9 @@ fun corifyExp st (e, loc) =
                     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) =
diff --git a/src/demo.sml b/src/demo.sml
index 4e73faea..9fa08021 100644
--- a/src/demo.sml
+++ b/src/demo.sml
@@ -97,7 +97,12 @@ fun make {prefix, dirname, guided} =
             profile = false,
             ffi = [],
             link = [],
-            headers = []
+            headers = [],
+            clientToServer = [],
+            effectful = [],
+            clientOnly = [],
+            serverOnly = [],
+            jsFuncs = []
         }
 
         val parse = Compiler.run (Compiler.transform Compiler.parseUrp "Demo parseUrp")
diff --git a/src/effectize.sml b/src/effectize.sml
index 52fdec6d..e3d62ff8 100644
--- a/src/effectize.sml
+++ b/src/effectize.sml
@@ -37,15 +37,14 @@ structure SS = BinarySetFn(struct
                            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
diff --git a/src/jscomp.sml b/src/jscomp.sml
index 1c5132c2..26558745 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -36,40 +36,6 @@ structure U = MonoUtil
 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 @@ fun process file =
 
                           | 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 @@ fun process file =
                                       | ("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")
diff --git a/src/marshalcheck.sml b/src/marshalcheck.sml
index 7dea28f3..3dbf93fc 100644
--- a/src/marshalcheck.sml
+++ b/src/marshalcheck.sml
@@ -53,18 +53,6 @@ end
 
 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 check file =
         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)
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 4eee1f79..5d8afee3 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -53,20 +53,7 @@ fun impure (e, _) =
       | 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 reduce file =
 
         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 @@ fun reduce file =
                       | 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
diff --git a/src/rpcify.sml b/src/rpcify.sml
index 6b7a3c90..1ed4cd54 100644
--- a/src/rpcify.sml
+++ b/src/rpcify.sml
@@ -46,23 +46,6 @@ fun multiLiftExpInExp n e =
     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 @@ fun frob file =
             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 @@ fun frob file =
                 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) =>
diff --git a/src/settings.sig b/src/settings.sig
index ba4e1b9a..4e764a78 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -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
diff --git a/src/settings.sml b/src/settings.sml
index 1bc14776..b022219d 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -46,4 +46,101 @@ fun setTimeout n = timeout := n
 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