Marshalcheck

7 files changed, 195 insertions, 6 deletions

diff --git a/src/compiler.sig b/src/compiler.sig
index 025a6bcd..d932c906 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -69,6 +69,7 @@ signature COMPILER = sig
     val shake : (Core.file, Core.file) phase
     val rpcify : (Core.file, Core.file) phase
     val tag : (Core.file, Core.file) phase
+    val marshalcheck : (Core.file, Core.file) phase
     val reduce : (Core.file, Core.file) phase
     val unpoly : (Core.file, Core.file) phase
     val specialize : (Core.file, Core.file) phase
@@ -99,6 +100,7 @@ signature COMPILER = sig
     val toCore_untangle2 : (string, Core.file) transform
     val toShake2 : (string, Core.file) transform
     val toTag : (string, Core.file) transform
+    val toMarshalcheck : (string, Core.file) transform
     val toReduce : (string, Core.file) transform
     val toUnpoly : (string, Core.file) transform 
     val toSpecialize : (string, Core.file) transform 
diff --git a/src/compiler.sml b/src/compiler.sml
index f9200731..0eb8cb0f 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -475,12 +475,19 @@ val tag = {
 
 val toTag = transform tag "tag" o toCore_untangle2
 
+val marshalcheck = {
+    func = (fn file => (MarshalCheck.check file; file)),
+    print = CorePrint.p_file CoreEnv.empty
+}
+
+val toMarshalcheck = transform marshalcheck "marshalcheck" o toTag
+
 val reduce = {
     func = Reduce.reduce,
     print = CorePrint.p_file CoreEnv.empty
 }
 
-val toReduce = transform reduce "reduce" o toTag
+val toReduce = transform reduce "reduce" o toMarshalcheck
 
 val unpoly = {
     func = Unpoly.unpoly,
diff --git a/src/core_util.sig b/src/core_util.sig
index fabb9878..807b477b 100644
--- a/src/core_util.sig
+++ b/src/core_util.sig
@@ -68,12 +68,12 @@ structure Con : sig
                -> 'context -> (Core.con -> Core.con)
 
     val fold : {kind : Core.kind' * 'state -> 'state,
-               con : Core.con' * 'state -> 'state}
-              -> 'state -> Core.con -> 'state
-
+                con : Core.con' * 'state -> 'state}
+               -> 'state -> Core.con -> 'state
+                                        
     val exists : {kind : Core.kind' -> bool,
                   con : Core.con' -> bool} -> Core.con -> bool
-
+                                                          
     val foldMap : {kind : Core.kind' * 'state -> Core.kind' * 'state,
                    con : Core.con' * 'state -> Core.con' * 'state}
                   -> 'state -> Core.con -> Core.con * 'state
diff --git a/src/marshalcheck.sig b/src/marshalcheck.sig
new file mode 100644
index 00000000..fe163454
--- /dev/null
+++ b/src/marshalcheck.sig
@@ -0,0 +1,32 @@
+(* Copyright (c) 2009, Adam Chlipala
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * - Redistributions of source code must retain the above copyright notice,
+ *   this list of conditions and the following disclaimer.
+ * - Redistributions in binary form must reproduce the above copyright notice,
+ *   this list of conditions and the following disclaimer in the documentation
+ *   and/or other materials provided with the distribution.
+ * - The names of contributors may not be used to endorse or promote products
+ *   derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ *)
+
+signature MARSHAL_CHECK = sig
+
+    val check : Core.file -> unit
+
+end
diff --git a/src/marshalcheck.sml b/src/marshalcheck.sml
new file mode 100644
index 00000000..2cce607b
--- /dev/null
+++ b/src/marshalcheck.sml
@@ -0,0 +1,136 @@
+(* Copyright (c) 2009, Adam Chlipala
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * - Redistributions of source code must retain the above copyright notice,
+ *   this list of conditions and the following disclaimer.
+ * - Redistributions in binary form must reproduce the above copyright notice,
+ *   this list of conditions and the following disclaimer in the documentation
+ *   and/or other materials provided with the distribution.
+ * - The names of contributors may not be used to endorse or promote products
+ *   derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ *)
+
+structure MarshalCheck :> MARSHAL_CHECK = struct
+
+open Core
+
+structure U = CoreUtil
+structure E = ErrorMsg
+
+structure PK = struct
+open Order
+type ord_key = string * string
+fun compare ((m1, x1), (m2, x2)) =
+    join (String.compare (m1, m2),
+          fn () => String.compare (x1, x2))
+end
+
+structure PS = BinarySetFn(PK)
+structure PS = struct
+open PS
+fun toString' (m, x) = m ^ "." ^ x
+fun toString set =
+    case PS.listItems set of
+        [] => "{}"
+      | [x] => toString' x
+      | x :: xs => List.foldl (fn (x, s) => s ^ ", " ^ toString' x) (toString' x) xs
+end
+
+structure IM = IntBinaryMap
+
+val clientToServer = [("Basis", "int"),
+                      ("Basis", "float"),
+                      ("Basis", "string"),
+                      ("Basis", "time"),
+                      ("Basis", "unit"),
+                      ("Basis", "option")]
+
+val clientToServer = PS.addList (PS.empty, clientToServer)
+
+fun check file =
+    let
+        fun kind (_, st) = st
+
+        fun con cmap (c, st) =
+            case c of
+                CFfi mx =>
+                if PS.member (clientToServer, mx) then
+                    st
+                else
+                    PS.add (st, mx)
+              | CNamed n =>
+                (case IM.find (cmap, n) of
+                     NONE => st
+                   | SOME st' => PS.union (st, st'))
+              | _ => st
+
+        fun sins cmap = U.Con.fold {kind = kind, con = con cmap} PS.empty
+    in
+        ignore (foldl (fn ((d, _), (cmap, emap)) =>
+                          case d of
+                              DCon (_, n, _, c) => (IM.insert (cmap, n, sins cmap c), emap)
+                            | DDatatype (_, n, _, xncs) =>
+                              (IM.insert (cmap, n, foldl (fn ((_, _, co), s) =>
+                                                             case co of
+                                                                 NONE => s
+                                                               | SOME c => PS.union (s, sins cmap c))
+                                                         PS.empty xncs),
+                               emap)
+
+                            | DVal (_, n, t, _, tag) => (cmap, IM.insert (emap, n, (t, tag)))
+                            | DValRec vis => (cmap,
+                                              foldl (fn ((_, n, t, _, tag), emap) => IM.insert (emap, n, (t, tag)))
+                                                    emap vis)
+
+                            | DExport (_, n) =>
+                              (case IM.find (emap, n) of
+                                   NONE => raise Fail "MarshalCheck: Unknown export"
+                                 | SOME (t, tag) =>
+                                   let
+                                       fun makeS (t, _) =
+                                           case t of
+                                               TFun (dom, ran) => PS.union (sins cmap dom, makeS ran)
+                                             | _ => PS.empty
+                                       val s = makeS t
+                                   in
+                                       if PS.isEmpty s then
+                                           ()
+                                       else
+                                           E.error ("Input to exported function '"
+                                                    ^ tag ^ "' involves one or more disallowed types: "
+                                                    ^ PS.toString s);
+                                       (cmap, emap)
+                                   end)
+
+                            | DCookie (_, _, t, tag) =>
+                              let
+                                  val s = sins cmap t
+                              in
+                                  if PS.isEmpty s then
+                                      ()
+                                  else
+                                      E.error ("Cookie '" ^ tag ^ "' includes one or more disallowed types: "
+                                               ^ PS.toString s);
+                                  (cmap, emap)
+                              end
+
+                            | _ => (cmap, emap))
+                      (IM.empty, IM.empty) file)
+    end
+
+end
diff --git a/src/sources b/src/sources
index ba453f62..b2d7b855 100644
--- a/src/sources
+++ b/src/sources
@@ -114,6 +114,9 @@ rpcify.sml
 tag.sig
 tag.sml
 
+marshalcheck.sig
+marshalcheck.sml
+
 mono.sml
 
 mono_util.sig
diff --git a/tests/chat.ur b/tests/chat.ur
index 2d79cd00..b982836d 100644
--- a/tests/chat.ur
+++ b/tests/chat.ur
@@ -25,7 +25,15 @@ fun chat id =
     logTail <- source logHead;
 
     let
-        fun join () = subscribe ch
+        fun getCh () =
+            r <- oneRow (SELECT t.Chan FROM t WHERE t.Id = {[id]});
+            case r.T.Chan of
+                None => error <xml>Channel disappeared</xml>
+              | Some ch => return ch
+
+        fun join () =
+            ch <- getCh ();
+            subscribe ch
 
         fun onload () =
             let
@@ -42,6 +50,7 @@ fun chat id =
             end
 
         fun speak line =
+            ch <- getCh ();
             send ch line
 
         fun doSpeak () =