Mercurial > urweb

changeset 731:e0dd85ea58e1

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Label exported symbols by effect-ness; factor out some common datatypes
author Adam Chlipala <adamc@hcoop.net>
date Thu, 16 Apr 2009 14:49:25 -0400
parents 1b1047992ecf
children 5819fb63c93a
files src/cjr.sml src/cjr_print.sml src/core.sml src/core_print.sml src/datatype_kind.sml src/elab.sml src/expl.sml src/export.sml src/mono.sml src/rpcify.sml src/sources src/tag.sml
diffstat 12 files changed, 109 insertions(+), 32 deletions(-) [+]
line wrap: on
line diff
--- a/src/cjr.sml	Thu Apr 16 14:35:01 2009 -0400
+++ b/src/cjr.sml	Thu Apr 16 14:49:25 2009 -0400
@@ -29,7 +29,7 @@
 
 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 @@
        | 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
--- a/src/cjr_print.sml	Thu Apr 16 14:35:01 2009 -0400
+++ b/src/cjr_print.sml	Thu Apr 16 14:49:25 2009 -0400
@@ -2208,8 +2208,8 @@
         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 @@
                 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 @@
                      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 @@
                                                                 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 @@
                           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;",
--- a/src/core.sml	Thu Apr 16 14:35:01 2009 -0400
+++ b/src/core.sml	Thu Apr 16 14:49:25 2009 -0400
@@ -70,7 +70,7 @@
 
 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 @@
 
 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
--- a/src/core_print.sml	Thu Apr 16 14:35:01 2009 -0400
+++ b/src/core_print.sml	Thu Apr 16 14:49:25 2009 -0400
@@ -470,8 +470,8 @@
 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
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/datatype_kind.sml	Thu Apr 16 14:49:25 2009 -0400
@@ -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
--- a/src/elab.sml	Thu Apr 16 14:35:01 2009 -0400
+++ b/src/elab.sml	Thu Apr 16 14:49:25 2009 -0400
@@ -81,10 +81,7 @@
 
 withtype con = con' located
 
-datatype datatype_kind =
-         Enum
-       | Option
-       | Default
+datatype datatype_kind = datatype DatatypeKind.datatype_kind
 
 datatype patCon =
          PConVar of int
--- a/src/expl.sml	Thu Apr 16 14:35:01 2009 -0400
+++ b/src/expl.sml	Thu Apr 16 14:49:25 2009 -0400
@@ -70,7 +70,7 @@
 
 withtype con = con' located
 
-datatype datatype_kind = datatype Elab.datatype_kind
+datatype datatype_kind = datatype DatatypeKind.datatype_kind
 
 datatype patCon =
          PConVar of int
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/export.sml	Thu Apr 16 14:49:25 2009 -0400
@@ -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
--- a/src/mono.sml	Thu Apr 16 14:35:01 2009 -0400
+++ b/src/mono.sml	Thu Apr 16 14:49:25 2009 -0400
@@ -29,7 +29,7 @@
 
 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 @@
 
 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 @@
        | DCookie of string
        | DStyle of string
 
-
 withtype decl = decl' located
 
 type file = decl list
--- a/src/rpcify.sml	Thu Apr 16 14:35:01 2009 -0400
+++ b/src/rpcify.sml	Thu Apr 16 14:49:25 2009 -0400
@@ -173,7 +173,7 @@
                                 (#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,
--- a/src/sources	Thu Apr 16 14:35:01 2009 -0400
+++ b/src/sources	Thu Apr 16 14:49:25 2009 -0400
@@ -19,6 +19,9 @@
 prim.sig
 prim.sml
 
+datatype_kind.sml
+export.sml
+
 source.sml
 
 urweb.grm
--- a/src/tag.sml	Thu Apr 16 14:35:01 2009 -0400
+++ b/src/tag.sml	Thu Apr 16 14:49:25 2009 -0400
@@ -118,7 +118,7 @@
                                            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