summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-04-16 14:49:25 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-04-16 14:49:25 -0400
commit6d021ead0f73c5a28080b50a1bd08b1ab72590c9 (patch)
tree1560f6013ce6de0388180550168c20e9756eaa2c /src
parent6d06bc0105d704373295c749aa65cc92488ac56c (diff)
Label exported symbols by effect-ness; factor out some common datatypes
Diffstat (limited to 'src')
-rw-r--r--src/cjr.sml7
-rw-r--r--src/cjr_print.sml26
-rw-r--r--src/core.sml8
-rw-r--r--src/core_print.sml4
-rw-r--r--src/datatype_kind.sml35
-rw-r--r--src/elab.sml5
-rw-r--r--src/expl.sml2
-rw-r--r--src/export.sml39
-rw-r--r--src/mono.sml8
-rw-r--r--src/rpcify.sml2
-rw-r--r--src/sources3
-rw-r--r--src/tag.sml2
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