Label exported symbols by effect-ness; factor out some common datatypes

12 files changed, 109 insertions, 32 deletions

diff --git a/src/cjr.sml b/src/cjr.sml
index 3844ccad..9d43f14a 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -29,7 +29,7 @@ structure Cjr = struct
 
 type 'a located = 'a ErrorMsg.located
 
-datatype datatype_kind = datatype Mono.datatype_kind
+datatype datatype_kind = datatype DatatypeKind.datatype_kind
 
 datatype typ' =
          TFun of typ * typ
@@ -120,6 +120,9 @@ datatype sidedness =
        | ServerAndPull
        | ServerAndPullAndPush
 
-type file = decl list * (Core.export_kind * string * int * typ list * typ * sidedness) list
+datatype effect = datatype Export.effect
+datatype export_kind = datatype Export.export_kind
+
+type file = decl list * (export_kind * string * int * typ list * typ * sidedness) list
 
 end
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index d6852455..e834300d 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -2208,8 +2208,8 @@ fun p_file env (ds, ps) =
         val fields = foldl (fn ((ek, _, _, ts, _, _), fields) =>
                                case ek of
                                    Core.Link => fields
-                                 | Core.Rpc => fields
-                                 | Core.Action =>
+                                 | Core.Rpc _ => fields
+                                 | Core.Action _ =>
                                    case List.nth (ts, length ts - 2) of
                                        (TRecord i, _) =>
                                        let
@@ -2331,8 +2331,8 @@ fun p_file env (ds, ps) =
                 val (ts, defInputs, inputsVar) =
                     case ek of
                         Core.Link => (List.take (ts, length ts - 1), string "", string "")
-                      | Core.Rpc => (List.take (ts, length ts - 1), string "", string "")
-                      | Core.Action =>
+                      | Core.Rpc _ => (List.take (ts, length ts - 1), string "", string "")
+                      | Core.Action _ =>
                         case List.nth (ts, length ts - 2) of
                             (TRecord i, _) =>
                             let
@@ -2414,8 +2414,8 @@ fun p_file env (ds, ps) =
                      string "if (*request == '/') ++request;",
                      newline,
                      box (case ek of
-                              Core.Rpc => [string "uw_write_header(ctx, \"Content-type: text/plain\\r\\n\");",
-                                           newline]
+                              Core.Rpc _ => [string "uw_write_header(ctx, \"Content-type: text/plain\\r\\n\");",
+                                             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\");",
@@ -2457,12 +2457,12 @@ fun p_file env (ds, ps) =
                                                                 newline]) ts),
                           defInputs,
                           box (case ek of
-                                   Core.Rpc => [p_typ env ran,
-                                                space,
-                                                string "it0",
-                                                space,
-                                                string "=",
-                                                space]
+                                   Core.Rpc _ => [p_typ env ran,
+                                                  space,
+                                                  string "it0",
+                                                  space,
+                                                  string "=",
+                                                  space]
                                  | _ => []),
                           p_enamed env n,
                           string "(",
@@ -2474,7 +2474,7 @@ fun p_file env (ds, ps) =
                           string ", uw_unit_v);",
                           newline,
                           box (case ek of
-                                   Core.Rpc => [urlify env ran]
+                                   Core.Rpc _ => [urlify env ran]
                                  | _ => [string "uw_write(ctx, \"</html>\");",
                                          newline]),
                           string "return;",
diff --git a/src/core.sml b/src/core.sml
index d9d7f51d..01cf4ec7 100644
--- a/src/core.sml
+++ b/src/core.sml
@@ -70,7 +70,7 @@ datatype con' =
 
 withtype con = con' located
 
-datatype datatype_kind = datatype Elab.datatype_kind
+datatype datatype_kind = datatype DatatypeKind.datatype_kind
 
 datatype patCon =
          PConVar of int
@@ -119,10 +119,8 @@ datatype exp' =
 
 withtype exp = exp' located
 
-datatype export_kind =
-         Link
-       | Action
-       | Rpc
+datatype effect = datatype Export.effect
+datatype export_kind = datatype Export.export_kind
 
 datatype decl' =
          DCon of string * int * kind * con
diff --git a/src/core_print.sml b/src/core_print.sml
index 8d8f275c..683b1b90 100644
--- a/src/core_print.sml
+++ b/src/core_print.sml
@@ -470,8 +470,8 @@ fun p_vali env (x, n, t, e, s) =
 fun p_export_kind ck =
     case ck of
         Link => string "link"
-      | Action => string "action"
-      | Rpc => string "rpc"
+      | Action _ => string "action"
+      | Rpc _ => string "rpc"
 
 fun p_datatype env (x, n, xs, cons) =
     let
diff --git a/src/datatype_kind.sml b/src/datatype_kind.sml
new file mode 100644
index 00000000..140a0122
--- /dev/null
+++ b/src/datatype_kind.sml
@@ -0,0 +1,35 @@
+(* 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 DatatypeKind = struct
+
+datatype datatype_kind =
+         Enum
+       | Option
+       | Default
+
+end
diff --git a/src/elab.sml b/src/elab.sml
index 41bc85dd..f82a947d 100644
--- a/src/elab.sml
+++ b/src/elab.sml
@@ -81,10 +81,7 @@ datatype con' =
 
 withtype con = con' located
 
-datatype datatype_kind =
-         Enum
-       | Option
-       | Default
+datatype datatype_kind = datatype DatatypeKind.datatype_kind
 
 datatype patCon =
          PConVar of int
diff --git a/src/expl.sml b/src/expl.sml
index 859e21ff..e293c36b 100644
--- a/src/expl.sml
+++ b/src/expl.sml
@@ -70,7 +70,7 @@ datatype con' =
 
 withtype con = con' located
 
-datatype datatype_kind = datatype Elab.datatype_kind
+datatype datatype_kind = datatype DatatypeKind.datatype_kind
 
 datatype patCon =
          PConVar of int
diff --git a/src/export.sml b/src/export.sml
new file mode 100644
index 00000000..4aae9b08
--- /dev/null
+++ b/src/export.sml
@@ -0,0 +1,39 @@
+(* 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 Export = struct
+
+datatype effect =
+         ReadOnly
+       | ReadWrite
+
+datatype export_kind =
+         Link
+       | Action of effect
+       | Rpc of effect
+
+end
diff --git a/src/mono.sml b/src/mono.sml
index d60c552c..dedb41ea 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -29,7 +29,7 @@ structure Mono = struct
 
 type 'a located = 'a ErrorMsg.located
 
-datatype datatype_kind = datatype Core.datatype_kind
+datatype datatype_kind = datatype DatatypeKind.datatype_kind
 
 datatype typ' =
          TFun of typ * typ
@@ -115,11 +115,14 @@ datatype exp' =
 
 withtype exp = exp' located
 
+datatype effect = datatype Export.effect
+datatype export_kind = datatype Export.export_kind
+
 datatype decl' =
          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 * typ
+       | DExport of export_kind * string * int * typ list * typ
 
        | DTable of string * (string * typ) list * exp * exp
        | DSequence of string
@@ -130,7 +133,6 @@ datatype decl' =
        | DCookie of string
        | DStyle of string
 
-
 withtype decl = decl' located
 
 type file = decl list
diff --git a/src/rpcify.sml b/src/rpcify.sml
index 846cc6c5..6b7a3c90 100644
--- a/src/rpcify.sml
+++ b/src/rpcify.sml
@@ -173,7 +173,7 @@ fun frob file =
                                 (#exported st, #export_decls st)
                             else
                                 (IS.add (#exported st, n),
-                                 (DExport (Rpc, n), loc) :: #export_decls st)
+                                 (DExport (Rpc ReadWrite, n), loc) :: #export_decls st)
 
                         val st = {cpsed = #cpsed st,
                                   cpsed_range = #cpsed_range st,
diff --git a/src/sources b/src/sources
index 27b6673b..19e4e102 100644
--- a/src/sources
+++ b/src/sources
@@ -19,6 +19,9 @@ print.sml
 prim.sig
 prim.sml
 
+datatype_kind.sml
+export.sml
+
 source.sml
 
 urweb.grm
diff --git a/src/tag.sml b/src/tag.sml
index 7a8fe128..78a4609b 100644
--- a/src/tag.sml
+++ b/src/tag.sml
@@ -118,7 +118,7 @@ fun exp env (e, s) =
                                            in
                                                case x of
                                                    (CName "Link", _) => tagIt (Link, "Href")
-                                                 | (CName "Action", _) => tagIt (Action, "Action")
+                                                 | (CName "Action", _) => tagIt (Action ReadWrite, "Action")
                                                  | _ => ((x, e, t), (count, tags, byTag, newTags))
                                            end)
                      s xets