changeset 609:56aaa1941dad

First gimpy RPC
author Adam Chlipala <adamc@hcoop.net>
date Sun, 15 Feb 2009 10:32:50 -0500 (2009-02-15)
parents 330a7de47914
children c41b2abf156b
files lib/js/urweb.js src/cjr.sml src/cjr_print.sml src/cjrize.sml src/core.sml src/core_print.sml src/core_util.sml src/jscomp.sml src/mono.sml src/mono_print.sml src/mono_reduce.sml src/mono_shake.sml src/mono_util.sml src/monoize.sml src/pathcheck.sml src/reduce.sml src/reduce_local.sml src/rpcify.sml src/shake.sml tests/rpc.ur tests/rpc.urp
diffstat 21 files changed, 184 insertions(+), 76 deletions(-) [+]
line wrap: on
line diff
--- a/lib/js/urweb.js	Sun Feb 15 09:27:36 2009 -0500
+++ b/lib/js/urweb.js	Sun Feb 15 10:32:50 2009 -0500
@@ -111,3 +111,32 @@
   return closures[n]();
 }
 
+
+function getXHR()
+{
+  try {
+    return new XMLHttpRequest();
+  } catch (e) {
+    try {
+     return new ActiveXObject("Msxml2.XMLHTTP");
+    } catch (e) {
+      try {
+        return new ActiveXObject("Microsoft.XMLHTTP");
+      } catch (e) {
+        throw "Your browser doesn't seem to support AJAX.";
+      }
+    }
+  }
+}
+
+function rc(uri, k) {
+  var xhr = getXHR();
+
+  xhr.onreadystatechange = function() {
+    if (xhr.readyState == 4)
+      k(xhr.responseText);
+  };
+
+  xhr.open("GET", uri, true);
+  xhr.send(null);
+}
--- a/src/cjr.sml	Sun Feb 15 09:27:36 2009 -0500
+++ b/src/cjr.sml	Sun Feb 15 10:32:50 2009 -0500
@@ -113,6 +113,6 @@
 
 withtype decl = decl' located
 
-type file = decl list * (Core.export_kind * string * int * typ list) list
+type file = decl list * (Core.export_kind * string * int * typ list * typ) list
 
 end
--- a/src/cjr_print.sml	Sun Feb 15 09:27:36 2009 -0500
+++ b/src/cjr_print.sml	Sun Feb 15 10:32:50 2009 -0500
@@ -1846,7 +1846,7 @@
                                               E.declBinds env d))
                              env ds
 
-        val fields = foldl (fn ((ek, _, _, ts), fields) =>
+        val fields = foldl (fn ((ek, _, _, ts, _), fields) =>
                                case ek of
                                    Core.Link => fields
                                  | Core.Rpc => fields
@@ -1967,7 +1967,7 @@
                              string "}"]
                 end
 
-        fun p_page (ek, s, n, ts) =
+        fun p_page (ek, s, n, ts, ran) =
             let
                 val (ts, defInputs, inputsVar) =
                     case ek of
@@ -2054,12 +2054,14 @@
                      newline,
                      string "if (*request == '/') ++request;",
                      newline,
-                     string "uw_write_header(ctx, \"Content-type: text/html\\r\\n\");",
-                     newline,
-                     string "uw_write_header(ctx, \"Content-script-type: text/javascript\\r\\n\");",
-                     newline,
-                     string "uw_write(ctx, \"<html>\");",
-                     newline,
+                     box (case ek of
+                              Core.Rpc => []
+                            | _ => [string "uw_write_header(ctx, \"Content-type: text/html\\r\\n\");",
+                                    newline,
+                                    string "uw_write_header(ctx, \"Content-script-type: text/javascript\\r\\n\");",
+                                    newline,
+                                    string "uw_write(ctx, \"<html>\");",
+                                    newline]),
                      box [string "{",
                           newline,
                           box (ListUtil.mapi (fn (i, t) => box [p_typ env t,
@@ -2073,6 +2075,14 @@
                                                                 string ";",
                                                                 newline]) ts),
                           defInputs,
+                          box (case ek of
+                                   Core.Rpc => [p_typ env ran,
+                                                space,
+                                                string "res",
+                                                space,
+                                                string "=",
+                                                space]
+                                 | _ => []),
                           p_enamed env n,
                           string "(",
                           p_list_sep (box [string ",", space])
@@ -2082,8 +2092,10 @@
                           inputsVar,
                           string ", uw_unit_v);",
                           newline,
-                          string "uw_write(ctx, \"</html>\");",
-                          newline,
+                          box (case ek of
+                                   Core.Rpc => []
+                                 | _ => [string "uw_write(ctx, \"</html>\");",
+                                         newline]),
                           string "return;",
                           newline,
                           string "}",
--- a/src/cjrize.sml	Sun Feb 15 09:27:36 2009 -0500
+++ b/src/cjrize.sml	Sun Feb 15 10:32:50 2009 -0500
@@ -514,11 +514,12 @@
             (SOME (L'.DFunRec vis, loc), NONE, sm)
         end        
 
-      | L.DExport (ek, s, n, ts) =>
+      | L.DExport (ek, s, n, ts, t) =>
         let
             val (ts, sm) = ListUtil.foldlMap cifyTyp sm ts
+            val (t, sm) = cifyTyp (t, sm)
         in
-            (NONE, SOME (ek, "/" ^ s, n, ts), sm)
+            (NONE, SOME (ek, "/" ^ s, n, ts, t), sm)
         end
 
       | L.DTable (s, xts) =>
--- a/src/core.sml	Sun Feb 15 09:27:36 2009 -0500
+++ b/src/core.sml	Sun Feb 15 10:32:50 2009 -0500
@@ -106,7 +106,7 @@
 
        | ELet of string * con * exp * exp
 
-       | EServerCall of int * exp list * exp
+       | EServerCall of int * exp list * exp * con
 
 withtype exp = exp' located
 
--- a/src/core_print.sml	Sun Feb 15 09:27:36 2009 -0500
+++ b/src/core_print.sml	Sun Feb 15 10:32:50 2009 -0500
@@ -394,14 +394,14 @@
                                     newline,
                                     p_exp (E.pushERel env x t) e2]
 
-      | EServerCall (n, es, e) => box [string "Server(",
-                                       p_enamed env n,
-                                       string ",",
-                                       space,
-                                       p_list (p_exp env) es,
-                                       string ")[",
-                                       p_exp env e,
-                                       string "]"]
+      | EServerCall (n, es, e, _) => box [string "Server(",
+                                          p_enamed env n,
+                                          string ",",
+                                          space,
+                                          p_list (p_exp env) es,
+                                          string ")[",
+                                          p_exp env e,
+                                          string "]"]
 
 and p_exp env = p_exp' false env
 
--- a/src/core_util.sml	Sun Feb 15 09:27:36 2009 -0500
+++ b/src/core_util.sml	Sun Feb 15 10:32:50 2009 -0500
@@ -482,7 +482,7 @@
       | (ELet _, _) => LESS
       | (_, ELet _) => GREATER
 
-      | (EServerCall (n1, es1, e1), EServerCall (n2, es2, e2)) =>
+      | (EServerCall (n1, es1, e1, _), EServerCall (n2, es2, e2, _)) =>
         join (Int.compare (n1, n2),
               fn () => join (joinL compare (es1, es2),
                              fn () => compare (e1, e2)))
@@ -660,12 +660,14 @@
                                           fn e2' =>
                                              (ELet (x, t', e1', e2'), loc))))
 
-              | EServerCall (n, es, e) =>
+              | EServerCall (n, es, e, t) =>
                 S.bind2 (ListUtil.mapfold (mfe ctx) es,
                       fn es' =>
-                         S.map2 (mfe ctx e,
+                         S.bind2 (mfe ctx e,
                                  fn e' =>
-                                    (EServerCall (n, es', e'), loc)))
+                                    S.map2 (mfc ctx t,
+                                            fn t' =>
+                                               (EServerCall (n, es', e', t'), loc))))
                          
         and mfp ctx (pAll as (p, loc)) =
             case p of
--- a/src/jscomp.sml	Sun Feb 15 09:27:36 2009 -0500
+++ b/src/jscomp.sml	Sun Feb 15 10:32:50 2009 -0500
@@ -98,7 +98,7 @@
       | ESignalReturn e => varDepth e
       | ESignalBind (e1, e2) => Int.max (varDepth e1, varDepth e2)
       | ESignalSource e => varDepth e
-      | EServerCall (_, es, ek) => foldl Int.max (varDepth ek) (map varDepth es)
+      | EServerCall (_, es, ek, _) => foldl Int.max (varDepth ek) (map varDepth es)
 
 fun closedUpto d =
     let
@@ -139,7 +139,7 @@
               | ESignalReturn e => cu inner e
               | ESignalBind (e1, e2) => cu inner e1 andalso cu inner e2
               | ESignalSource e => cu inner e
-              | EServerCall (_, es, ek) => List.all (cu inner) es andalso cu inner ek
+              | EServerCall (_, es, ek, _) => List.all (cu inner) es andalso cu inner ek
     in
         cu 0
     end
@@ -812,7 +812,15 @@
                                  st)
                             end
 
-                          | EServerCall _ => raise Fail "Jscomp EServerCall"
+                          | EServerCall (x, es, ek, _) =>
+                            let
+                                val (ek, st) = jsE inner (ek, st)
+                            in
+                                (strcat [str ("rc(\"" ^ !Monoize.urlPrefix ^ x ^ "\","),
+                                         ek,
+                                         str ")"],
+                                 st)
+                            end
                     end
             in
                 jsE
--- a/src/mono.sml	Sun Feb 15 09:27:36 2009 -0500
+++ b/src/mono.sml	Sun Feb 15 10:32:50 2009 -0500
@@ -109,7 +109,7 @@
        | ESignalBind of exp * exp
        | ESignalSource of exp
 
-       | EServerCall of int * exp list * exp
+       | EServerCall of string * exp list * exp * typ
 
 withtype exp = exp' located
 
@@ -117,7 +117,7 @@
          DDatatype of string * int * (string * int * typ option) list
        | DVal of string * int * typ * exp * string
        | DValRec of (string * int * typ * exp * string) list
-       | DExport of Core.export_kind * string * int * typ list
+       | DExport of Core.export_kind * string * int * typ list * typ
 
        | DTable of string * (string * typ) list
        | DSequence of string
--- a/src/mono_print.sml	Sun Feb 15 09:27:36 2009 -0500
+++ b/src/mono_print.sml	Sun Feb 15 10:32:50 2009 -0500
@@ -308,14 +308,14 @@
                                 p_exp env e,
                                 string ")"]
 
-      | EServerCall (n, es, e) => box [string "Server(",
-                                       p_enamed env n,
-                                       string ",",
-                                       space,
-                                       p_list (p_exp env) es,
-                                       string ")[",
-                                       p_exp env e,
-                                       string "]"]
+      | EServerCall (n, es, e, _) => box [string "Server(",
+                                          string n,
+                                          string ",",
+                                          space,
+                                          p_list (p_exp env) es,
+                                          string ")[",
+                                          p_exp env e,
+                                          string "]"]
 
 and p_exp env = p_exp' false env
 
@@ -378,19 +378,23 @@
                  p_list_sep (box [newline, string "and", space]) (p_vali env) vis]
         end
 
-      | DExport (ek, s, n, ts) => box [string "export",
-                                       space,
-                                       CorePrint.p_export_kind ek,
-                                       space,
-                                       p_enamed env n,
-                                       space,
-                                       string "as",
-                                       space,
-                                       string s,
-                                       p_list_sep (string "") (fn t => box [space,
-                                                                            string "(",
-                                                                            p_typ env t,
-                                                                            string ")"]) ts]
+      | DExport (ek, s, n, ts, t) => box [string "export",
+                                          space,
+                                          CorePrint.p_export_kind ek,
+                                          space,
+                                          p_enamed env n,
+                                          space,
+                                          string "as",
+                                          space,
+                                          string s,
+                                          p_list_sep (string "") (fn t => box [space,
+                                                                               string "(",
+                                                                               p_typ env t,
+                                                                               string ")"]) ts,
+                                          space,
+                                          string "->",
+                                          space,
+                                          p_typ env t]
 
       | DTable (s, xts) => box [string "(* SQL table ",
                                 string s,
--- a/src/mono_reduce.sml	Sun Feb 15 09:27:36 2009 -0500
+++ b/src/mono_reduce.sml	Sun Feb 15 10:32:50 2009 -0500
@@ -346,7 +346,7 @@
                       | ESignalBind (e1, e2) => summarize d e1 @ summarize d e2
                       | ESignalSource e => summarize d e
 
-                      | EServerCall (_, es, ek) => List.concat (map (summarize d) es) @ summarize d ek @ [Unsure]
+                      | EServerCall (_, es, ek, _) => List.concat (map (summarize d) es) @ summarize d ek @ [Unsure]
             in
                 (*Print.prefaces "Summarize"
                                [("e", MonoPrint.p_exp MonoEnv.empty (e, ErrorMsg.dummySpan)),
--- a/src/mono_shake.sml	Sun Feb 15 09:27:36 2009 -0500
+++ b/src/mono_shake.sml	Sun Feb 15 10:32:50 2009 -0500
@@ -44,7 +44,7 @@
 fun shake file =
     let
         val page_es = List.foldl
-                          (fn ((DExport (_, _, n, _), _), page_es) => n :: page_es
+                          (fn ((DExport (_, _, n, _, _), _), page_es) => n :: page_es
                             | (_, page_es) => page_es) [] file
 
         val (cdef, edef) = foldl (fn ((DDatatype (_, n, xncs), _), (cdef, edef)) =>
--- a/src/mono_util.sml	Sun Feb 15 09:27:36 2009 -0500
+++ b/src/mono_util.sml	Sun Feb 15 10:32:50 2009 -0500
@@ -350,12 +350,14 @@
                      fn e' =>
                         (ESignalSource e', loc))
 
-              | EServerCall (n, es, ek) =>
+              | EServerCall (n, es, ek, t) =>
                 S.bind2 (ListUtil.mapfold (fn e => mfe ctx e) es,
                       fn es' =>
-                         S.map2 (mfe ctx ek,
+                         S.bind2 (mfe ctx ek,
                                  fn ek' =>
-                                    (EServerCall (n, es', ek'), loc)))
+                                    S.map2 (mft t,
+                                            fn t' =>
+                                               (EServerCall (n, es', ek', t'), loc))))
     in
         mfe
     end
@@ -443,10 +445,12 @@
                          fn vis' =>
                             (DValRec vis', loc))
                 end
-              | DExport (ek, s, n, ts) =>
-                S.map2 (ListUtil.mapfold mft ts,
+              | DExport (ek, s, n, ts, t) =>
+                S.bind2 (ListUtil.mapfold mft ts,
                         fn ts' =>
-                           (DExport (ek, s, n, ts'), loc))
+                           S.map2 (mft t,
+                                   fn t' =>
+                                      (DExport (ek, s, n, ts', t'), loc)))
               | DTable _ => S.return2 dAll
               | DSequence _ => S.return2 dAll
               | DDatabase _ => S.return2 dAll
--- a/src/monoize.sml	Sun Feb 15 09:27:36 2009 -0500
+++ b/src/monoize.sml	Sun Feb 15 10:32:50 2009 -0500
@@ -2225,12 +2225,28 @@
                 ((L'.ELet (x, t', e1, e2), loc), fm)
             end
 
-          | L.EServerCall (n, es, ek) =>
+          | L.EServerCall (n, es, ek, t) =>
             let
+                val t = monoType env t
+                val (_, _, _, name) = Env.lookupENamed env n
                 val (es, fm) = ListUtil.foldlMap (fn (e, fm) => monoExp (env, st, fm) e) fm es
                 val (ek, fm) = monoExp (env, st, fm) ek
+
+                val ekf = (L'.EAbs ("f",
+                                    (L'.TFun (t,
+                                              (L'.TFun ((L'.TRecord [], loc),
+                                                        (L'.TRecord [], loc)), loc)), loc),
+                                    (L'.TFun (t,
+                                              (L'.TRecord [], loc)), loc),
+                                    (L'.EAbs ("x",
+                                              t,
+                                              (L'.TRecord [], loc),
+                                              (L'.EApp ((L'.EApp ((L'.ERel 1, loc),
+                                                                  (L'.ERel 0, loc)), loc),
+                                                        (L'.ERecord [], loc)), loc)), loc)), loc)
+                val ek = (L'.EApp (ekf, ek), loc)
             in
-                ((L'.EServerCall (n, es, ek), loc), fm)
+                ((L'.EServerCall (name, es, ek, t), loc), fm)
             end
     end
 
@@ -2280,16 +2296,18 @@
             let
                 val (_, t, _, s) = Env.lookupENamed env n
 
-                fun unwind (t, _) =
-                    case t of
-                        L.TFun (dom, ran) => dom :: unwind ran
+                fun unwind (t, args) =
+                    case #1 t of
+                        L.TFun (dom, ran) => unwind (ran, dom :: args)
                       | L.CApp ((L.CFfi ("Basis", "transaction"), _), t) =>
-                        (L.TRecord (L.CRecord ((L.KType, loc), []), loc), loc) :: unwind t
-                      | _ => []
+                        unwind (t, (L.TRecord (L.CRecord ((L.KType, loc), []), loc), loc) :: args)
+                      | _ => (rev args, t)
 
-                val ts = map (monoType env) (unwind t)
+                val (ts, ran) = unwind (t, [])
+                val ts = map (monoType env) ts
+                val ran = monoType env ran
             in
-                SOME (env, fm, [(L'.DExport (ek, s, n, ts), loc)])
+                SOME (env, fm, [(L'.DExport (ek, s, n, ts, ran), loc)])
             end
           | L.DTable (x, n, (L.CRecord (_, xts), _), s) =>
             let
--- a/src/pathcheck.sml	Sun Feb 15 09:27:36 2009 -0500
+++ b/src/pathcheck.sml	Sun Feb 15 10:32:50 2009 -0500
@@ -46,7 +46,7 @@
              (funcs, SS.add (rels, s)))
     in
         case d of
-            DExport (_, s, _, _) =>
+            DExport (_, s, _, _, _) =>
             (if SS.member (funcs, s) then
                  E.errorAt loc ("Duplicate function path " ^ s)
              else
--- a/src/reduce.sml	Sun Feb 15 09:27:36 2009 -0500
+++ b/src/reduce.sml	Sun Feb 15 10:32:50 2009 -0500
@@ -368,7 +368,7 @@
 
               | ELet (x, t, e1, e2) => (ELet (x, con env t, exp env e1, exp (UnknownE :: env) e2), loc)
 
-              | EServerCall (n, es, e) => (EServerCall (n, map (exp env) es, exp env e), loc))
+              | EServerCall (n, es, e, t) => (EServerCall (n, map (exp env) es, exp env e, con env t), loc))
     in
         {con = con, exp = exp}
     end
--- a/src/reduce_local.sml	Sun Feb 15 09:27:36 2009 -0500
+++ b/src/reduce_local.sml	Sun Feb 15 10:32:50 2009 -0500
@@ -131,7 +131,7 @@
 
       | ELet (x, t, e1, e2) => (ELet (x, t, exp env e1, exp (Unknown :: env) e2), loc)
 
-      | EServerCall (n, es, e) => (EServerCall (n, map (exp env) es, exp env e), loc)
+      | EServerCall (n, es, e, t) => (EServerCall (n, map (exp env) es, exp env e, t), loc)
 
 fun reduce file =
     let
--- a/src/rpcify.sml	Sun Feb 15 09:27:36 2009 -0500
+++ b/src/rpcify.sml	Sun Feb 15 10:32:50 2009 -0500
@@ -98,6 +98,29 @@
         val serverSide = sideish (ssBasis, ssids)
         val clientSide = sideish (csBasis, csids)
 
+        val tfuncs = foldl
+                     (fn ((d, _), tfuncs) =>
+                         let
+                             fun doOne ((_, n, t, _, _), tfuncs) =
+                                 let
+                                     fun crawl ((t, _), args) =
+                                         case t of
+                                             CApp ((CFfi ("Basis", "transaction"), _), ran) => SOME (rev args, ran)
+                                           | TFun (arg, rest) => crawl (rest, arg :: args)
+                                           | _ => NONE
+                                 in
+                                     case crawl (t, []) of
+                                         NONE => tfuncs
+                                       | SOME sg => IM.insert (tfuncs, n, sg)
+                                 end
+                         in
+                             case d of
+                                 DVal vi => doOne (vi, tfuncs)
+                               | DValRec vis => foldl doOne tfuncs vis
+                               | _ => tfuncs
+                         end)
+                     IM.empty file
+                             
         fun exp (e, st) =
             case e of
                 EApp (
@@ -130,8 +153,13 @@
 
                                    exported = exported,
                                    export_decls = export_decls}
+
+                         val ran =
+                             case IM.find (tfuncs, n) of
+                                 NONE => raise Fail "Rpcify: Undetected transaction function"
+                               | SOME (_, ran) => ran
                      in
-                         (EServerCall (n, args, trans2), st)
+                         (EServerCall (n, args, trans2, ran), st)
                      end
                    | _ => (e, st))
               | _ => (e, st)
--- a/src/shake.sml	Sun Feb 15 09:27:36 2009 -0500
+++ b/src/shake.sml	Sun Feb 15 10:32:50 2009 -0500
@@ -116,7 +116,7 @@
             in
                 case e of
                     ENamed n => check n
-                  | EServerCall (n, _, _) => check n
+                  | EServerCall (n, _, _, _) => check n
                   | _ => s
             end
 
--- a/tests/rpc.ur	Sun Feb 15 09:27:36 2009 -0500
+++ b/tests/rpc.ur	Sun Feb 15 10:32:50 2009 -0500
@@ -8,6 +8,8 @@
         return <xml><body>
           <button value="Get It On!"
                   onclick={n <- getNext ();
-                           set s n}/>
+                           set s n}/><br/>
+          <br/>
+          Current: <dyn signal={n <- signal s; return <xml>{[n]}</xml>}/>
         </body></xml>
     end
--- a/tests/rpc.urp	Sun Feb 15 09:27:36 2009 -0500
+++ b/tests/rpc.urp	Sun Feb 15 10:32:50 2009 -0500
@@ -1,5 +1,5 @@
 debug
 sql rpc.sql
-database rpc
+database dbname=rpc
 
 rpc