From 047a2f193646e08db526768dca8376b7270eecb5 Mon Sep 17 00:00:00 2001
From: Adam Chlipala
Date: Sat, 1 Nov 2008 21:19:43 -0400
Subject: Almost have that nested save function compiling
---
src/cjrize.sml | 19 ++++++++++++-------
1 file changed, 12 insertions(+), 7 deletions(-)
(limited to 'src/cjrize.sml')
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 05ceb0f9..db2bd48f 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -39,6 +39,7 @@ structure Sm :> sig
val find : t * (string * L.typ) list * (string * L'.typ) list -> t * int
val declares : t -> (int * (string * L'.typ) list) list
+ val clearDeclares : t -> t
end = struct
structure FM = BinaryMapFn(struct
@@ -61,6 +62,8 @@ fun find ((n, m, ds), xts, xts') =
fun declares (_, _, ds) = ds
+fun clearDeclares (n, m, _) = (n, m, [])
+
end
fun cifyTyp x =
@@ -520,23 +523,25 @@ fun cjrize ds =
val (dsF, ds, ps, sm) = foldl (fn (d, (dsF, ds, ps, sm)) =>
let
val (dop, pop, sm) = cifyDecl (d, sm)
+
val (dsF, ds) = case dop of
NONE => (dsF, ds)
- | SOME (d as (L'.DDatatype (dk, x, n, _), loc)) =>
- ((L'.DDatatypeForward (dk, x, n), loc) :: dsF,
- d :: ds)
+ | SOME (d as (L'.DDatatype _, loc)) =>
+ (d :: dsF, ds)
| SOME d => (dsF, d :: ds)
+
+ val dsF = map (fn v => (L'.DStruct v, ErrorMsg.dummySpan)) (Sm.declares sm)
+ @ dsF
+
val ps = case pop of
NONE => ps
| SOME p => p :: ps
in
- (dsF, ds, ps, sm)
+ (dsF, ds, ps, Sm.clearDeclares sm)
end)
([], [], [], Sm.empty) ds
in
- (List.revAppend (dsF,
- List.revAppend (map (fn v => (L'.DStruct v, ErrorMsg.dummySpan)) (Sm.declares sm),
- rev ds)),
+ (List.revAppend (dsF, rev ds),
ps)
end
--
cgit v1.2.3
From 9f6397d0f801f6e020aa6123f14ddc44e11deee7 Mon Sep 17 00:00:00 2001
From: Adam Chlipala
Date: Thu, 6 Nov 2008 12:08:41 -0500
Subject: Reading cookies works
---
include/urweb.h | 2 +
src/c/urweb.c | 16 ++
src/cjr.sml | 1 +
src/cjr_print.sml | 741 +++++++++++++++++++++++++++-------------------------
src/cjrize.sml | 7 +
src/mono.sml | 2 +
src/mono_print.sml | 3 +
src/mono_reduce.sml | 2 +
src/mono_util.sml | 6 +
src/monoize.sml | 4 +-
src/prepare.sml | 7 +
tests/cookie.ur | 2 +-
12 files changed, 440 insertions(+), 353 deletions(-)
(limited to 'src/cjrize.sml')
diff --git a/include/urweb.h b/include/urweb.h
index 4fb2d612..2330a0b4 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -100,4 +100,6 @@ uw_Basis_time uw_Basis_stringToTime_error(uw_context, uw_Basis_string);
uw_Basis_string uw_Basis_requestHeader(uw_context, uw_Basis_string);
void uw_write_header(uw_context, uw_Basis_string);
+
+uw_Basis_string uw_Basis_get_cookie(uw_context, uw_Basis_string);
uw_unit uw_Basis_set_cookie(uw_context, uw_Basis_string, uw_Basis_string);
diff --git a/src/c/urweb.c b/src/c/urweb.c
index dc58576a..be12c5ea 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -1143,7 +1143,23 @@ uw_Basis_string uw_Basis_requestHeader(uw_context ctx, uw_Basis_string h) {
return NULL;
}
}
+}
+
+uw_Basis_string uw_Basis_get_cookie(uw_context ctx, uw_Basis_string c) {
+ int len = strlen(c);
+ char *s = ctx->headers, *p;
+ while (p = strchr(s, ':')) {
+ if (!strncasecmp(s, "Cookie: ", 8) && !strncmp(p + 2, c, len)
+ && p + 2 + len < ctx->headers_end && p[2 + len] == '=') {
+ return p + 3 + len;
+ } else {
+ if ((s = strchr(p, 0)) && s < ctx->headers_end)
+ s += 2;
+ else
+ return NULL;
+ }
+ }
}
uw_unit uw_Basis_set_cookie(uw_context ctx, uw_Basis_string c, uw_Basis_string v) {
diff --git a/src/cjr.sml b/src/cjr.sml
index dc700a56..84aea54e 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -92,6 +92,7 @@ datatype exp' =
prepared : int option }
| ENextval of { seq : exp,
prepared : int option }
+ | EUnurlify of exp * typ
withtype exp = exp' located
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index f1f4ef70..06154b91 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -62,6 +62,12 @@ val ident = String.translate (fn #"'" => "PRIME"
val p_ident = string o ident
+fun isUnboxable (t : typ) =
+ case #1 t of
+ TDatatype (Default, _, _) => true
+ | TFfi ("Basis", "string") => true
+ | _ => false
+
fun p_typ' par env (t, loc) =
case t of
TFun (t1, t2) => parenIf par (box [p_typ' true env t2,
@@ -96,11 +102,11 @@ fun p_typ' par env (t, loc) =
handle CjrEnv.UnboundNamed _ => string ("__uwd_UNBOUND__" ^ Int.toString n))
| TFfi (m, x) => box [string "uw_", p_ident m, string "_", p_ident x]
| TOption t =>
- (case #1 t of
- TDatatype _ => p_typ' par env t
- | TFfi ("Basis", "string") => p_typ' par env t
- | _ => box [p_typ' par env t,
- string "*"])
+ if isUnboxable t then
+ p_typ' par env t
+ else
+ box [p_typ' par env t,
+ string "*"]
and p_typ env = p_typ' false env
@@ -228,13 +234,12 @@ fun p_pat (env, exit, depth) (p, _) =
string "->data.",
string x]
| Option =>
- case #1 t of
- TDatatype _ => box [string "disc",
- string (Int.toString depth)]
- | TFfi ("Basis", "string") => box [string "disc",
- string (Int.toString depth)]
- | _ => box [string "*disc",
- string (Int.toString depth)],
+ if isUnboxable t then
+ box [string "disc",
+ string (Int.toString depth)]
+ else
+ box [string "*disc",
+ string (Int.toString depth)],
string ";",
newline,
p,
@@ -335,13 +340,12 @@ fun p_pat (env, exit, depth) (p, _) =
space,
string "=",
space,
- case #1 t of
- TDatatype _ => box [string "disc",
- string (Int.toString depth)]
- | TFfi ("Basis", "string") => box [string "disc",
- string (Int.toString depth)]
- | _ => box [string "*disc",
- string (Int.toString depth)],
+ if isUnboxable t then
+ box [string "disc",
+ string (Int.toString depth)]
+ else
+ box [string "*disc",
+ string (Int.toString depth)],
string ";",
newline,
p,
@@ -468,6 +472,288 @@ fun notLeaky env allowHeapAllocated =
nl
end
+fun capitalize s =
+ if s = "" then
+ ""
+ else
+ str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
+
+fun unurlify env (t, loc) =
+ let
+ fun unurlify' rf t =
+ case t of
+ TFfi ("Basis", "unit") => string ("uw_unit_v")
+ | TFfi (m, t) => string ("uw_" ^ ident m ^ "_unurlify" ^ capitalize t ^ "(ctx, &request)")
+
+ | TRecord 0 => string "uw_unit_v"
+ | TRecord i =>
+ let
+ val xts = E.lookupStruct env i
+ in
+ box [string "({",
+ newline,
+ box (map (fn (x, t) =>
+ box [p_typ env t,
+ space,
+ string "uwr_",
+ string x,
+ space,
+ string "=",
+ space,
+ unurlify' rf (#1 t),
+ string ";",
+ newline]) xts),
+ string "struct",
+ space,
+ string "__uws_",
+ string (Int.toString i),
+ space,
+ string "tmp",
+ space,
+ string "=",
+ space,
+ string "{",
+ space,
+ p_list_sep (box [string ",", space]) (fn (x, _) => box [string "uwr_",
+ string x]) xts,
+ space,
+ string "};",
+ newline,
+ string "tmp;",
+ newline,
+ string "})"]
+ end
+
+ | TDatatype (Enum, i, _) =>
+ let
+ val (x, xncs) = E.lookupDatatype env i
+
+ fun doEm xncs =
+ case xncs of
+ [] => string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype "
+ ^ x ^ "\"), (enum __uwe_"
+ ^ x ^ "_" ^ Int.toString i ^ ")0)")
+ | (x', n, to) :: rest =>
+ box [string "((!strncmp(request, \"",
+ string x',
+ string "\", ",
+ string (Int.toString (size x')),
+ string ") && (request[",
+ string (Int.toString (size x')),
+ string "] == 0 || request[",
+ string (Int.toString (size x')),
+ string ("] == '/')) ? __uwc_" ^ ident x' ^ "_" ^ Int.toString n),
+ space,
+ string ":",
+ space,
+ doEm rest,
+ string ")"]
+ in
+ doEm xncs
+ end
+
+ | TDatatype (Option, i, xncs) =>
+ if IS.member (rf, i) then
+ box [string "unurlify_",
+ string (Int.toString i),
+ string "()"]
+ else
+ let
+ val (x, _) = E.lookupDatatype env i
+
+ val (no_arg, has_arg, t) =
+ case !xncs of
+ [(no_arg, _, NONE), (has_arg, _, SOME t)] =>
+ (no_arg, has_arg, t)
+ | [(has_arg, _, SOME t), (no_arg, _, NONE)] =>
+ (no_arg, has_arg, t)
+ | _ => raise Fail "CjrPrint: unfooify misclassified Option datatype"
+
+ val rf = IS.add (rf, i)
+ in
+ box [string "({",
+ space,
+ p_typ env t,
+ space,
+ string "*unurlify_",
+ string (Int.toString i),
+ string "(void) {",
+ newline,
+ box [string "return (request[0] == '/' ? ++request : request,",
+ newline,
+ string "((!strncmp(request, \"",
+ string no_arg,
+ string "\", ",
+ string (Int.toString (size no_arg)),
+ string ") && (request[",
+ string (Int.toString (size no_arg)),
+ string "] == 0 || request[",
+ string (Int.toString (size no_arg)),
+ string "] == '/')) ? (request",
+ space,
+ string "+=",
+ space,
+ string (Int.toString (size no_arg)),
+ string ", NULL) : ((!strncmp(request, \"",
+ string has_arg,
+ string "\", ",
+ string (Int.toString (size has_arg)),
+ string ") && (request[",
+ string (Int.toString (size has_arg)),
+ string "] == 0 || request[",
+ string (Int.toString (size has_arg)),
+ string "] == '/')) ? (request",
+ space,
+ string "+=",
+ space,
+ string (Int.toString (size has_arg)),
+ string ", (request[0] == '/' ? ++request : NULL), ",
+ newline,
+
+ if isUnboxable t then
+ unurlify' rf (#1 t)
+ else
+ box [string "({",
+ newline,
+ p_typ env t,
+ space,
+ string "*tmp",
+ space,
+ string "=",
+ space,
+ string "uw_malloc(ctx, sizeof(",
+ p_typ env t,
+ string "));",
+ newline,
+ string "*tmp",
+ space,
+ string "=",
+ space,
+ unurlify' rf (#1 t),
+ string ";",
+ newline,
+ string "tmp;",
+ newline,
+ string "})"],
+ string ")",
+ newline,
+ string ":",
+ space,
+ string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x
+ ^ "\"), NULL))));"),
+ newline],
+ string "}",
+ newline,
+ newline,
+
+ string "unurlify_",
+ string (Int.toString i),
+ string "();",
+ newline,
+ string "})"]
+ end
+
+ | TDatatype (Default, i, _) =>
+ if IS.member (rf, i) then
+ box [string "unurlify_",
+ string (Int.toString i),
+ string "()"]
+ else
+ let
+ val (x, xncs) = E.lookupDatatype env i
+
+ val rf = IS.add (rf, i)
+
+ fun doEm xncs =
+ case xncs of
+ [] => string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype "
+ ^ x ^ "\"), NULL)")
+ | (x', n, to) :: rest =>
+ box [string "((!strncmp(request, \"",
+ string x',
+ string "\", ",
+ string (Int.toString (size x')),
+ string ") && (request[",
+ string (Int.toString (size x')),
+ string "] == 0 || request[",
+ string (Int.toString (size x')),
+ string "] == '/')) ? ({",
+ newline,
+ string "struct",
+ space,
+ string ("__uwd_" ^ ident x ^ "_" ^ Int.toString i),
+ space,
+ string "*tmp = uw_malloc(ctx, sizeof(struct __uwd_",
+ string x,
+ string "_",
+ string (Int.toString i),
+ string "));",
+ newline,
+ string "tmp->tag",
+ space,
+ string "=",
+ space,
+ string ("__uwc_" ^ ident x' ^ "_" ^ Int.toString n),
+ string ";",
+ newline,
+ string "request",
+ space,
+ string "+=",
+ space,
+ string (Int.toString (size x')),
+ string ";",
+ newline,
+ string "if (request[0] == '/') ++request;",
+ newline,
+ case to of
+ NONE => box []
+ | SOME (t, _) => box [string "tmp->data.uw_",
+ p_ident x',
+ space,
+ string "=",
+ space,
+ unurlify' rf t,
+ string ";",
+ newline],
+ string "tmp;",
+ newline,
+ string "})",
+ space,
+ string ":",
+ space,
+ doEm rest,
+ string ")"]
+ in
+ box [string "({",
+ space,
+ p_typ env (t, ErrorMsg.dummySpan),
+ space,
+ string "unurlify_",
+ string (Int.toString i),
+ string "(void) {",
+ newline,
+ box [string "return",
+ space,
+ doEm xncs,
+ string ";",
+ newline],
+ string "}",
+ newline,
+ newline,
+
+ string "unurlify_",
+ string (Int.toString i),
+ string "();",
+ newline,
+ string "})"]
+ end
+
+ | _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function";
+ space)
+ in
+ unurlify' IS.empty t
+ end
+
fun p_exp' par env (e, loc) =
case e of
EPrim p => Prim.p_t_GCC p
@@ -485,30 +771,30 @@ fun p_exp' par env (e, loc) =
NONE => raise Fail "CjrPrint: ECon argument status mismatch"
| SOME t => t
in
- case #1 t of
- TDatatype _ => p_exp' par env e
- | TFfi ("Basis", "string") => p_exp' par env e
- | _ => box [string "({",
- newline,
- p_typ env t,
- space,
- string "*tmp",
- space,
- string "=",
- space,
- string "uw_malloc(ctx, sizeof(",
- p_typ env t,
- string "));",
- newline,
- string "*tmp",
- space,
- string "=",
- p_exp' par env e,
- string ";",
- newline,
- string "tmp;",
- newline,
- string "})"]
+ if isUnboxable t then
+ p_exp' par env e
+ else
+ box [string "({",
+ newline,
+ p_typ env t,
+ space,
+ string "*tmp",
+ space,
+ string "=",
+ space,
+ string "uw_malloc(ctx, sizeof(",
+ p_typ env t,
+ string "));",
+ newline,
+ string "*tmp",
+ space,
+ string "=",
+ p_exp' par env e,
+ string ";",
+ newline,
+ string "tmp;",
+ newline,
+ string "})"]
end
| ECon (Default, pc, eo) =>
let
@@ -551,30 +837,30 @@ fun p_exp' par env (e, loc) =
end
| ENone _ => string "NULL"
| ESome (t, e) =>
- (case #1 t of
- TDatatype _ => p_exp' par env e
- | TFfi ("Basis", "string") => p_exp' par env e
- | _ => box [string "({",
- newline,
- p_typ env t,
- space,
- string "*tmp",
- space,
- string "=",
- space,
- string "uw_malloc(ctx, sizeof(",
- p_typ env t,
- string "));",
- newline,
- string "*tmp",
- space,
- string "=",
- p_exp' par env e,
- string ";",
- newline,
- string "tmp;",
- newline,
- string "})"])
+ if isUnboxable t then
+ p_exp' par env e
+ else
+ box [string "({",
+ newline,
+ p_typ env t,
+ space,
+ string "*tmp",
+ space,
+ string "=",
+ space,
+ string "uw_malloc(ctx, sizeof(",
+ p_typ env t,
+ string "));",
+ newline,
+ string "*tmp",
+ space,
+ string "=",
+ p_exp' par env e,
+ string ";",
+ newline,
+ string "tmp;",
+ newline,
+ string "})"]
| EFfi (m, x) => box [string "uw_", p_ident m, string "_", p_ident x]
| EError (e, t) =>
@@ -1078,6 +1364,41 @@ fun p_exp' par env (e, loc) =
string "}))"]
end
+ | EUnurlify (e, t) =>
+ let
+ fun getIt () =
+ if isUnboxable t then
+ unurlify env t
+ else
+ box [string "({",
+ newline,
+ p_typ env t,
+ string " *tmp = uw_malloc(ctx, sizeof(",
+ p_typ env t,
+ string "));",
+ newline,
+ string "*tmp = ",
+ unurlify env t,
+ string ";",
+ newline,
+ string "tmp;",
+ newline,
+ string "})"]
+ in
+ box [string "({",
+ newline,
+ string "uw_Basis_string request = ",
+ p_exp env e,
+ string ";",
+ newline,
+ newline,
+ string "(request ? ",
+ getIt (),
+ string " : NULL);",
+ newline,
+ string "})"]
+ end
+
and p_exp env = p_exp' false env
fun p_fun env (fx, n, args, ran, e) =
@@ -1527,288 +1848,6 @@ fun p_file env (ds, ps) =
string "}"]
end
- fun capitalize s =
- if s = "" then
- ""
- else
- str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
-
- fun unurlify (t, loc) =
- let
- fun unurlify' rf t =
- case t of
- TFfi ("Basis", "unit") => string ("uw_unit_v")
- | TFfi (m, t) => string ("uw_" ^ ident m ^ "_unurlify" ^ capitalize t ^ "(ctx, &request)")
-
- | TRecord 0 => string "uw_unit_v"
- | TRecord i =>
- let
- val xts = E.lookupStruct env i
- in
- box [string "({",
- newline,
- box (map (fn (x, t) =>
- box [p_typ env t,
- space,
- string "uwr_",
- string x,
- space,
- string "=",
- space,
- unurlify' rf (#1 t),
- string ";",
- newline]) xts),
- string "struct",
- space,
- string "__uws_",
- string (Int.toString i),
- space,
- string "tmp",
- space,
- string "=",
- space,
- string "{",
- space,
- p_list_sep (box [string ",", space]) (fn (x, _) => box [string "uwr_",
- string x]) xts,
- space,
- string "};",
- newline,
- string "tmp;",
- newline,
- string "})"]
- end
-
- | TDatatype (Enum, i, _) =>
- let
- val (x, xncs) = E.lookupDatatype env i
-
- fun doEm xncs =
- case xncs of
- [] => string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype "
- ^ x ^ "\"), (enum __uwe_"
- ^ x ^ "_" ^ Int.toString i ^ ")0)")
- | (x', n, to) :: rest =>
- box [string "((!strncmp(request, \"",
- string x',
- string "\", ",
- string (Int.toString (size x')),
- string ") && (request[",
- string (Int.toString (size x')),
- string "] == 0 || request[",
- string (Int.toString (size x')),
- string ("] == '/')) ? __uwc_" ^ ident x' ^ "_" ^ Int.toString n),
- space,
- string ":",
- space,
- doEm rest,
- string ")"]
- in
- doEm xncs
- end
-
- | TDatatype (Option, i, xncs) =>
- if IS.member (rf, i) then
- box [string "unurlify_",
- string (Int.toString i),
- string "()"]
- else
- let
- val (x, _) = E.lookupDatatype env i
-
- val (no_arg, has_arg, t) =
- case !xncs of
- [(no_arg, _, NONE), (has_arg, _, SOME t)] =>
- (no_arg, has_arg, t)
- | [(has_arg, _, SOME t), (no_arg, _, NONE)] =>
- (no_arg, has_arg, t)
- | _ => raise Fail "CjrPrint: unfooify misclassified Option datatype"
-
- val rf = IS.add (rf, i)
- in
- box [string "({",
- space,
- p_typ env t,
- space,
- string "*unurlify_",
- string (Int.toString i),
- string "(void) {",
- newline,
- box [string "return (request[0] == '/' ? ++request : request,",
- newline,
- string "((!strncmp(request, \"",
- string no_arg,
- string "\", ",
- string (Int.toString (size no_arg)),
- string ") && (request[",
- string (Int.toString (size no_arg)),
- string "] == 0 || request[",
- string (Int.toString (size no_arg)),
- string "] == '/')) ? (request",
- space,
- string "+=",
- space,
- string (Int.toString (size no_arg)),
- string ", NULL) : ((!strncmp(request, \"",
- string has_arg,
- string "\", ",
- string (Int.toString (size has_arg)),
- string ") && (request[",
- string (Int.toString (size has_arg)),
- string "] == 0 || request[",
- string (Int.toString (size has_arg)),
- string "] == '/')) ? (request",
- space,
- string "+=",
- space,
- string (Int.toString (size has_arg)),
- string ", (request[0] == '/' ? ++request : NULL), ",
- newline,
-
- case #1 t of
- TDatatype _ => unurlify' rf (#1 t)
- | TFfi ("Basis", "string") => unurlify' rf (#1 t)
- | _ => box [string "({",
- newline,
- p_typ env t,
- space,
- string "*tmp",
- space,
- string "=",
- space,
- string "uw_malloc(ctx, sizeof(",
- p_typ env t,
- string "));",
- newline,
- string "*tmp",
- space,
- string "=",
- space,
- unurlify' rf (#1 t),
- string ";",
- newline,
- string "tmp;",
- newline,
- string "})"],
- string ")",
- newline,
- string ":",
- space,
- string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype " ^ x
- ^ "\"), NULL))));"),
- newline],
- string "}",
- newline,
- newline,
-
- string "unurlify_",
- string (Int.toString i),
- string "();",
- newline,
- string "})"]
- end
-
- | TDatatype (Default, i, _) =>
- if IS.member (rf, i) then
- box [string "unurlify_",
- string (Int.toString i),
- string "()"]
- else
- let
- val (x, xncs) = E.lookupDatatype env i
-
- val rf = IS.add (rf, i)
-
- fun doEm xncs =
- case xncs of
- [] => string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype "
- ^ x ^ "\"), NULL)")
- | (x', n, to) :: rest =>
- box [string "((!strncmp(request, \"",
- string x',
- string "\", ",
- string (Int.toString (size x')),
- string ") && (request[",
- string (Int.toString (size x')),
- string "] == 0 || request[",
- string (Int.toString (size x')),
- string "] == '/')) ? ({",
- newline,
- string "struct",
- space,
- string ("__uwd_" ^ ident x ^ "_" ^ Int.toString i),
- space,
- string "*tmp = uw_malloc(ctx, sizeof(struct __uwd_",
- string x,
- string "_",
- string (Int.toString i),
- string "));",
- newline,
- string "tmp->tag",
- space,
- string "=",
- space,
- string ("__uwc_" ^ ident x' ^ "_" ^ Int.toString n),
- string ";",
- newline,
- string "request",
- space,
- string "+=",
- space,
- string (Int.toString (size x')),
- string ";",
- newline,
- string "if (request[0] == '/') ++request;",
- newline,
- case to of
- NONE => box []
- | SOME (t, _) => box [string "tmp->data.uw_",
- p_ident x',
- space,
- string "=",
- space,
- unurlify' rf t,
- string ";",
- newline],
- string "tmp;",
- newline,
- string "})",
- space,
- string ":",
- space,
- doEm rest,
- string ")"]
- in
- box [string "({",
- space,
- p_typ env (t, ErrorMsg.dummySpan),
- space,
- string "unurlify_",
- string (Int.toString i),
- string "(void) {",
- newline,
- box [string "return",
- space,
- doEm xncs,
- string ";",
- newline],
- string "}",
- newline,
- newline,
-
- string "unurlify_",
- string (Int.toString i),
- string "();",
- newline,
- string "})"]
- end
-
- | _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function";
- space)
- in
- unurlify' IS.empty t
- end
-
fun p_page (ek, s, n, ts) =
let
val (ts, defInputs, inputsVar) =
@@ -1855,7 +1894,7 @@ fun p_file env (ds, ps) =
space,
string "=",
space,
- unurlify t,
+ unurlify env t,
string ";",
newline]
end) xts),
@@ -1904,7 +1943,7 @@ fun p_file env (ds, ps) =
space,
string "=",
space,
- unurlify t,
+ unurlify env t,
string ";",
newline]) ts),
defInputs,
diff --git a/src/cjrize.sml b/src/cjrize.sml
index db2bd48f..6c34923b 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -412,6 +412,13 @@ fun cifyExp (eAll as (e, loc), sm) =
((L'.ENextval {seq = e, prepared = NONE}, loc), sm)
end
+ | L.EUnurlify (e, t) =>
+ let
+ val (e, sm) = cifyExp (e, sm)
+ val (t, sm) = cifyTyp (t, sm)
+ in
+ ((L'.EUnurlify (e, t), loc), sm)
+ end
fun cifyDecl ((d, loc), sm) =
case d of
diff --git a/src/mono.sml b/src/mono.sml
index b7ac6346..f465d2bd 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -94,6 +94,8 @@ datatype exp' =
| EDml of exp
| ENextval of exp
+ | EUnurlify of exp * typ
+
withtype exp = exp' located
diff --git a/src/mono_print.sml b/src/mono_print.sml
index 5d9f8007..8d91d048 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -272,6 +272,9 @@ fun p_exp' par env (e, _) =
| ENextval e => box [string "nextval(",
p_exp env e,
string ")"]
+ | EUnurlify (e, _) => box [string "unurlify(",
+ p_exp env e,
+ string ")"]
and p_exp env = p_exp' false env
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 7420f14f..3c4ac0df 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -41,6 +41,7 @@ fun impure (e, _) =
| EQuery _ => true
| EDml _ => true
| ENextval _ => true
+ | EUnurlify _ => true
| EAbs _ => false
| EPrim _ => false
@@ -275,6 +276,7 @@ fun summarize d (e, _) =
| EDml e => summarize d e @ [WriteDb]
| ENextval e => summarize d e @ [WriteDb]
+ | EUnurlify (e, _) => summarize d e
fun exp env e =
let
diff --git a/src/mono_util.sml b/src/mono_util.sml
index 080c3dc9..14ab1674 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -305,6 +305,12 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
S.map2 (mfe ctx e,
fn e' =>
(ENextval e', loc))
+ | EUnurlify (e, t) =>
+ S.bind2 (mfe ctx e,
+ fn e' =>
+ S.map2 (mft t,
+ fn t' =>
+ (EUnurlify (e', t'), loc)))
in
mfe
end
diff --git a/src/monoize.sml b/src/monoize.sml
index 64522a18..b8c3a6a9 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -955,7 +955,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
in
((L'.EAbs ("c", s, (L'.TFun (un, s), loc),
(L'.EAbs ("_", un, s,
- (L'.EPrim (Prim.String "Cookie!"), loc)), loc)), loc),
+ (L'.EUnurlify ((L'.EFfiApp ("Basis", "get_cookie", [(L'.ERel 1, loc)]), loc),
+ t),
+ loc)), loc)), loc),
fm)
end
diff --git a/src/prepare.sml b/src/prepare.sml
index 166f658b..6d63ad7d 100644
--- a/src/prepare.sml
+++ b/src/prepare.sml
@@ -191,6 +191,13 @@ fun prepExp (e as (_, loc), sns) =
((String.concat (rev ss), n) :: #1 sns, #2 sns + 1))
end
+ | EUnurlify (e, t) =>
+ let
+ val (e, sns) = prepExp (e, sns)
+ in
+ ((EUnurlify (e, t), loc), sns)
+ end
+
fun prepDecl (d as (_, loc), sns) =
case #1 d of
DStruct _ => (d, sns)
diff --git a/tests/cookie.ur b/tests/cookie.ur
index 36734260..cb4f8854 100644
--- a/tests/cookie.ur
+++ b/tests/cookie.ur
@@ -2,7 +2,7 @@ cookie c : string
fun main () : transaction page =
setCookie c "Hi";
- so <- requestHeader "Cookie";
+ so <- getCookie c;
case so of
None => return No cookie
| Some s => return Cookie: {[s]}
--
cgit v1.2.3
From e478b4d432d65b33613a601f71204fc0c656c3db Mon Sep 17 00:00:00 2001
From: Adam Chlipala
Date: Fri, 19 Dec 2008 12:38:11 -0500
Subject: Displayed an alert dialog
---
include/urweb.h | 2 ++
lib/basis.urs | 7 ++++++-
src/c/urweb.c | 35 +++++++++++++++++++++++++++++++++++
src/cjrize.sml | 2 ++
src/mono.sml | 2 ++
src/mono_opt.sml | 5 +++++
src/mono_print.sml | 3 +++
src/mono_reduce.sml | 2 ++
src/mono_util.sml | 4 ++++
src/monoize.sml | 13 +++++++++++++
tests/alert.ur | 3 +++
tests/alert.urp | 3 +++
12 files changed, 80 insertions(+), 1 deletion(-)
create mode 100644 tests/alert.ur
create mode 100644 tests/alert.urp
(limited to 'src/cjrize.sml')
diff --git a/include/urweb.h b/include/urweb.h
index 3d7b967c..647f153a 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -94,6 +94,8 @@ uw_Basis_string uw_Basis_sqlifyTimeN(uw_context, uw_Basis_time*);
char *uw_Basis_ensqlBool(uw_Basis_bool);
+char *uw_Basis_jsifyString(uw_context, uw_Basis_string);
+
uw_Basis_string uw_Basis_intToString(uw_context, uw_Basis_int);
uw_Basis_string uw_Basis_floatToString(uw_context, uw_Basis_float);
uw_Basis_string uw_Basis_boolToString(uw_context, uw_Basis_bool);
diff --git a/lib/basis.urs b/lib/basis.urs
index ffba2b37..ac4c4832 100644
--- a/lib/basis.urs
+++ b/lib/basis.urs
@@ -100,6 +100,11 @@ val getCookie : t ::: Type -> http_cookie t -> transaction (option t)
val setCookie : t ::: Type -> http_cookie t -> t -> transaction unit
+(** JavaScript-y gadgets *)
+
+val alert : string -> transaction unit
+
+
(** SQL *)
con sql_table :: {Type} -> Type
@@ -403,7 +408,7 @@ val ul : bodyTag []
val hr : bodyTag []
-val a : bodyTag [Link = transaction page]
+val a : bodyTag [Link = transaction page, Onclick = transaction unit]
val form : ctx ::: {Unit} -> bind ::: {Type}
-> fn [[Body] ~ ctx] =>
diff --git a/src/c/urweb.c b/src/c/urweb.c
index 7a9b3e79..64cdb81e 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -1056,6 +1056,41 @@ char *uw_Basis_ensqlBool(uw_Basis_bool b) {
return (char *)&true;
}
+uw_Basis_string uw_Basis_jsifyString(uw_context ctx, uw_Basis_string s) {
+ char *r, *s2;
+
+ uw_check_heap(ctx, strlen(s) * 4 + 2);
+
+ r = s2 = ctx->heap_front;
+ *s2++ = '"';
+
+ for (; *s; s++) {
+ char c = *s;
+
+ switch (c) {
+ case '"':
+ strcpy(s2, "\\\"");
+ s2 += 2;
+ break;
+ case '\\':
+ strcpy(s2, "\\\\");
+ s2 += 2;
+ break;
+ default:
+ if (isprint(c))
+ *s2++ = c;
+ else {
+ sprintf(s2, "\\%3o", c);
+ s2 += 4;
+ }
+ }
+ }
+
+ strcpy(s2, "\"");
+ ctx->heap_front = s2 + 1;
+ return r;
+}
+
uw_Basis_string uw_Basis_intToString(uw_context ctx, uw_Basis_int n) {
int len;
char *r;
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 6c34923b..1152b0ef 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -420,6 +420,8 @@ fun cifyExp (eAll as (e, loc), sm) =
((L'.EUnurlify (e, t), loc), sm)
end
+ | L.EJavaScript _ => raise Fail "EJavaScript remains"
+
fun cifyDecl ((d, loc), sm) =
case d of
L.DDatatype (x, n, xncs) =>
diff --git a/src/mono.sml b/src/mono.sml
index f465d2bd..187b1853 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -96,6 +96,8 @@ datatype exp' =
| EUnurlify of exp * typ
+ | EJavaScript of exp
+
withtype exp = exp' located
diff --git a/src/mono_opt.sml b/src/mono_opt.sml
index 6c0e6e21..7f83c003 100644
--- a/src/mono_opt.sml
+++ b/src/mono_opt.sml
@@ -360,6 +360,11 @@ fun exp e =
| EWrite (EPrim (Prim.String ""), loc) =>
ERecord []
+ | EJavaScript (EAbs (_, (TRecord [], _), _, (EFfiApp ("Basis", "alert", [s]), _)), loc) =>
+ EStrcat ((EPrim (Prim.String "alert("), loc),
+ (EStrcat ((EFfiApp ("Basis", "jsifyString", [s]), loc),
+ (EPrim (Prim.String ")"), loc)), loc))
+
| _ => e
and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e)
diff --git a/src/mono_print.sml b/src/mono_print.sml
index 8d91d048..7b675438 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -275,6 +275,9 @@ fun p_exp' par env (e, _) =
| EUnurlify (e, _) => box [string "unurlify(",
p_exp env e,
string ")"]
+ | EJavaScript e => box [string "JavaScript(",
+ p_exp env e,
+ string ")"]
and p_exp env = p_exp' false env
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 9cf6d8e8..040414f3 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -75,6 +75,7 @@ fun impure (e, _) =
| ELet (_, _, e1, e2) => impure e1 orelse impure e2
| EClosure (_, es) => List.exists impure es
+ | EJavaScript e => impure e
val liftExpInExp = Monoize.liftExpInExp
@@ -329,6 +330,7 @@ fun reduce file =
| EDml e => summarize d e @ [WriteDb]
| ENextval e => summarize d e @ [WriteDb]
| EUnurlify (e, _) => summarize d e
+ | EJavaScript e => summarize d e
fun exp env e =
diff --git a/src/mono_util.sml b/src/mono_util.sml
index 2b2476e7..18b5c948 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -311,6 +311,10 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
S.map2 (mft t,
fn t' =>
(EUnurlify (e', t'), loc)))
+ | EJavaScript e =>
+ S.map2 (mfe ctx e,
+ fn e' =>
+ (EJavaScript e', loc))
in
mfe
end
diff --git a/src/monoize.sml b/src/monoize.sml
index e23d4f80..e92a1c8a 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -1744,6 +1744,19 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
result = (L'.TFfi ("Basis", "string"), loc)}), loc),
fm)
end
+ | (L'.TFun _, _) =>
+ let
+ val s' = " " ^ lowercaseFirst x ^ "='"
+ in
+ ((L'.EStrcat (s,
+ (L'.EStrcat (
+ (L'.EPrim (Prim.String s'), loc),
+ (L'.EStrcat (
+ (L'.EJavaScript e, loc),
+ (L'.EPrim (Prim.String "'"), loc)), loc)),
+ loc)), loc),
+ fm)
+ end
| _ =>
let
val fooify =
diff --git a/tests/alert.ur b/tests/alert.ur
new file mode 100644
index 00000000..7b2eaacf
--- /dev/null
+++ b/tests/alert.ur
@@ -0,0 +1,3 @@
+fun main () : transaction page = return
+ Click Me!
+
diff --git a/tests/alert.urp b/tests/alert.urp
new file mode 100644
index 00000000..3976e9b0
--- /dev/null
+++ b/tests/alert.urp
@@ -0,0 +1,3 @@
+debug
+
+alert
--
cgit v1.2.3
From 80be553bea33f3d9cb19f399f64eed36017048a3 Mon Sep 17 00:00:00 2001
From: Adam Chlipala
Date: Sat, 20 Dec 2008 15:46:48 -0500
Subject: Initial support
---
lib/basis.urs | 5 +++-
src/cjrize.sml | 4 +++-
src/jscomp.sml | 66 +++++++++++++++++++++++++++++++++++++++--------------
src/mono.sml | 9 +++++++-
src/mono_print.sml | 13 ++++++++---
src/mono_reduce.sml | 7 ++++--
src/mono_util.sml | 16 +++++++++++--
src/monoize.sml | 33 ++++++++++++++++++++++++++-
tests/sreturn.ur | 5 ++++
tests/sreturn.urp | 3 +++
10 files changed, 133 insertions(+), 28 deletions(-)
create mode 100644 tests/sreturn.ur
create mode 100644 tests/sreturn.urp
(limited to 'src/cjrize.sml')
diff --git a/lib/basis.urs b/lib/basis.urs
index ac4c4832..a61bf3ce 100644
--- a/lib/basis.urs
+++ b/lib/basis.urs
@@ -376,6 +376,9 @@ con form = [Body, Form]
con tabl = [Body, Table]
con tr = [Body, Tr]
+val dyn : ctx ::: {Unit} -> use ::: {Type} -> bind ::: {Type} -> unit
+ -> tag [Signal = signal (xml ctx use bind)] ctx [] use bind
+
val head : unit -> tag [] html head [] []
val title : unit -> tag [] head [] [] []
@@ -433,7 +436,7 @@ con select = [Select]
val select : formTag string select []
val option : unit -> tag [Value = string, Selected = bool] select [] [] []
-val submit : ctx ::: {Unit} -> use ::: {Type}
+val submit : ctx ::: {Unit} -> use ::: {Type}
-> fn [[Form] ~ ctx] =>
unit
-> tag [Value = string, Action = $use -> transaction page]
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 1152b0ef..f3c5e5a7 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -120,6 +120,7 @@ fun cifyTyp x =
in
((L'.TOption t, loc), sm)
end
+ | L.TSignal _ => raise Fail "Cjrize: TSignal remains"
in
cify IM.empty x
end
@@ -420,7 +421,8 @@ fun cifyExp (eAll as (e, loc), sm) =
((L'.EUnurlify (e, t), loc), sm)
end
- | L.EJavaScript _ => raise Fail "EJavaScript remains"
+ | L.EJavaScript _ => raise Fail "Cjrize: EJavaScript remains"
+ | L.ESignalReturn _ => raise Fail "Cjrize: ESignalReturn remains"
fun cifyDecl ((d, loc), sm) =
case d of
diff --git a/src/jscomp.sml b/src/jscomp.sml
index 0dd7882a..b0842c6b 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -69,8 +69,15 @@ fun varDepth (e, _) =
| ENextval _ => 0
| EUnurlify _ => 0
| EJavaScript _ => 0
+ | ESignalReturn e => varDepth e
-fun jsExp inAttr outer =
+fun strcat loc es =
+ case es of
+ [] => (EPrim (Prim.String ""), loc)
+ | [x] => x
+ | x :: es' => (EStrcat (x, strcat loc es'), loc)
+
+fun jsExp mode outer =
let
val len = length outer
@@ -85,11 +92,7 @@ fun jsExp inAttr outer =
PConVar n => str (Int.toString n)
| PConFfi {con, ...} => str ("\"_" ^ con ^ "\"")
- fun strcat es =
- case es of
- [] => (EPrim (Prim.String ""), loc)
- | [x] => x
- | x :: es' => (EStrcat (x, strcat es'), loc)
+
fun isNullable (t, _) =
case t of
@@ -99,17 +102,19 @@ fun jsExp inAttr outer =
fun unsupported s =
(EM.errorAt loc (s ^ " in code to be compiled to JavaScript");
(str "ERROR", st))
+
+ val strcat = strcat loc
in
case #1 e of
EPrim (Prim.String s) =>
(str ("\""
^ String.translate (fn #"'" =>
- if inAttr then
+ if mode = Attribute then
"\\047"
else
"'"
| #"<" =>
- if inAttr then
+ if mode = Script then
"<"
else
"\\074"
@@ -274,7 +279,14 @@ fun jsExp inAttr outer =
st)
end
- | EWrite _ => unsupported "EWrite"
+ | EWrite e =>
+ let
+ val (e, st) = jsE inner (e, st)
+ in
+ (strcat [str "document.write(",
+ e,
+ str ")"], st)
+ end
| ESeq (e1, e2) =>
let
@@ -301,6 +313,15 @@ fun jsExp inAttr outer =
| ENextval _ => unsupported "Nextval"
| EUnurlify _ => unsupported "EUnurlify"
| EJavaScript _ => unsupported "Nested JavaScript"
+ | ESignalReturn e =>
+ let
+ val (e, st) = jsE inner (e, st)
+ in
+ (strcat [(*str "sreturn(",*)
+ e(*,
+ str ")"*)],
+ st)
+ end
end
in
jsE
@@ -309,14 +330,25 @@ fun jsExp inAttr outer =
val decl : state -> decl -> decl * state =
U.Decl.foldMapB {typ = fn x => x,
exp = fn (env, e, st) =>
- case e of
- EJavaScript (EAbs (_, t, _, e), _) =>
- let
- val (e, st) = jsExp true (t :: env) 0 (e, st)
- in
- (#1 e, st)
- end
- | _ => (e, st),
+ let
+ fun doCode m env e =
+ let
+ val len = length env
+ fun str s = (EPrim (Prim.String s), #2 e)
+
+ val locals = List.tabulate
+ (varDepth e,
+ fn i => str ("var uwr" ^ Int.toString (len + i) ^ ";"))
+ val (e, st) = jsExp m env 0 (e, st)
+ in
+ (#1 (strcat (#2 e) (locals @ [e])), st)
+ end
+ in
+ case e of
+ EJavaScript (m, (EAbs (_, t, _, e), _)) => doCode m (t :: env) e
+ | EJavaScript (m, e) => doCode m env e
+ | _ => (e, st)
+ end,
decl = fn (_, e, st) => (e, st),
bind = fn (env, U.Decl.RelE (_, t)) => t :: env
| (env, _) => env}
diff --git a/src/mono.sml b/src/mono.sml
index 187b1853..c6e0ae8a 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -37,6 +37,7 @@ datatype typ' =
| TDatatype of int * (datatype_kind * (string * int * typ option) list) ref
| TFfi of string * string
| TOption of typ
+ | TSignal of typ
withtype typ = typ' located
@@ -55,6 +56,11 @@ datatype pat' =
withtype pat = pat' located
+datatype javascript_mode =
+ Attribute
+ | Script
+ | File
+
datatype exp' =
EPrim of Prim.t
| ERel of int
@@ -96,8 +102,9 @@ datatype exp' =
| EUnurlify of exp * typ
- | EJavaScript of exp
+ | EJavaScript of javascript_mode * exp
+ | ESignalReturn of exp
withtype exp = exp' located
diff --git a/src/mono_print.sml b/src/mono_print.sml
index 7b675438..89b6c35b 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -65,6 +65,9 @@ fun p_typ' par env (t, _) =
| TOption t => box [string "option(",
p_typ env t,
string ")"]
+ | TSignal t => box [string "signal(",
+ p_typ env t,
+ string ")"]
and p_typ env = p_typ' false env
@@ -275,9 +278,13 @@ fun p_exp' par env (e, _) =
| EUnurlify (e, _) => box [string "unurlify(",
p_exp env e,
string ")"]
- | EJavaScript e => box [string "JavaScript(",
- p_exp env e,
- string ")"]
+ | EJavaScript (_, e) => box [string "JavaScript(",
+ p_exp env e,
+ string ")"]
+
+ | ESignalReturn e => box [string "Return(",
+ p_exp env e,
+ string ")"]
and p_exp env = p_exp' false env
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 040414f3..e1da02c9 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -75,7 +75,8 @@ fun impure (e, _) =
| ELet (_, _, e1, e2) => impure e1 orelse impure e2
| EClosure (_, es) => List.exists impure es
- | EJavaScript e => impure e
+ | EJavaScript (_, e) => impure e
+ | ESignalReturn e => impure e
val liftExpInExp = Monoize.liftExpInExp
@@ -330,7 +331,8 @@ fun reduce file =
| EDml e => summarize d e @ [WriteDb]
| ENextval e => summarize d e @ [WriteDb]
| EUnurlify (e, _) => summarize d e
- | EJavaScript e => summarize d e
+ | EJavaScript (_, e) => summarize d e
+ | ESignalReturn e => summarize d e
fun exp env e =
@@ -421,6 +423,7 @@ fun reduce file =
fun trySub () =
case t of
(TFfi ("Basis", "string"), _) => doSub ()
+ | (TSignal _, _) => e
| _ =>
case e' of
(ECase _, _) => e
diff --git a/src/mono_util.sml b/src/mono_util.sml
index ebc30984..553f802e 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -51,6 +51,7 @@ fun compare ((t1, _), (t2, _)) =
| (TDatatype (n1, _), TDatatype (n2, _)) => Int.compare (n1, n2)
| (TFfi (m1, x1), TFfi (m2, x2)) => join (String.compare (m1, m2), fn () => String.compare (x1, x2))
| (TOption t1, TOption t2) => compare (t1, t2)
+ | (TSignal t1, TSignal t2) => compare (t1, t2)
| (TFun _, _) => LESS
| (_, TFun _) => GREATER
@@ -64,6 +65,9 @@ fun compare ((t1, _), (t2, _)) =
| (TFfi _, _) => LESS
| (_, TFfi _) => GREATER
+ | (TOption _, _) => LESS
+ | (_, TOption _) => GREATER
+
and compareFields ((x1, t1), (x2, t2)) =
join (String.compare (x1, x2),
fn () => compare (t1, t2))
@@ -96,6 +100,10 @@ fun mapfold fc =
S.map2 (mft t,
fn t' =>
(TOption t, loc))
+ | TSignal t =>
+ S.map2 (mft t,
+ fn t' =>
+ (TSignal t, loc))
in
mft
end
@@ -311,10 +319,14 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
S.map2 (mft t,
fn t' =>
(EUnurlify (e', t'), loc)))
- | EJavaScript e =>
+ | EJavaScript (m, e) =>
+ S.map2 (mfe ctx e,
+ fn e' =>
+ (EJavaScript (m, e'), loc))
+ | ESignalReturn e =>
S.map2 (mfe ctx e,
fn e' =>
- (EJavaScript e', loc))
+ (ESignalReturn e', loc))
in
mfe
end
diff --git a/src/monoize.sml b/src/monoize.sml
index e92a1c8a..1b7b467d 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -135,6 +135,8 @@ fun monoType env =
(L'.TFun ((L'.TRecord [], loc), mt env dtmap t), loc)
| L.CApp ((L.CFfi ("Basis", "source"), _), t) =>
(L'.TFfi ("Basis", "int"), loc)
+ | L.CApp ((L.CFfi ("Basis", "signal"), _), t) =>
+ (L'.TSignal (mt env dtmap t), loc)
| L.CApp ((L.CFfi ("Basis", "http_cookie"), _), _) =>
(L'.TFfi ("Basis", "string"), loc)
| L.CApp ((L.CFfi ("Basis", "sql_table"), _), _) =>
@@ -978,6 +980,16 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
fm)
end
+ | L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "return"), _), _), _), t), _),
+ (L.EFfi ("Basis", "signal_monad"), _)) =>
+ let
+ val t = monoType env t
+ in
+ ((L'.EAbs ("x", t, (L'.TSignal t, loc),
+ (L'.ESignalReturn (L'.ERel 0, loc), loc)), loc),
+ fm)
+ end
+
| L.ECApp ((L.EFfi ("Basis", "getCookie"), _), t) =>
let
val s = (L'.TFfi ("Basis", "string"), loc)
@@ -1752,7 +1764,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L'.EStrcat (
(L'.EPrim (Prim.String s'), loc),
(L'.EStrcat (
- (L'.EJavaScript e, loc),
+ (L'.EJavaScript (L'.Attribute, e), loc),
(L'.EPrim (Prim.String "'"), loc)), loc)),
loc)), loc),
fm)
@@ -1833,6 +1845,25 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
case tag of
"body" => normal ("body", NONE,
SOME (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]), loc))
+
+ | "dyn" =>
+ (case #1 attrs of
+ (*L'.ERecord [("Signal", (L'.ESignalReturn e, _), _)] => (e, fm)
+ | L'.ERecord [("Signal", (L'.EApp ((L'.EAbs (_, _, _, (L'.ESignalReturn (L'.ERel 0, _), _)), _),
+ e), _), _)] => (e, fm) *)
+
+ L'.ERecord [("Signal", e, _)] =>
+ ((L'.EStrcat
+ ((L'.EPrim (Prim.String ""), loc)), loc)), loc),
+ fm)
+ | _ => raise Fail "Monoize: Bad dyn attributes")
| "submit" => normal ("input type=\"submit\"", NONE, NONE)
diff --git a/tests/sreturn.ur b/tests/sreturn.ur
new file mode 100644
index 00000000..62db377d
--- /dev/null
+++ b/tests/sreturn.ur
@@ -0,0 +1,5 @@
+fun main () : transaction page = return
+ Before
+ Hi!
}/>
+ After
+
diff --git a/tests/sreturn.urp b/tests/sreturn.urp
new file mode 100644
index 00000000..5591aa5e
--- /dev/null
+++ b/tests/sreturn.urp
@@ -0,0 +1,3 @@
+debug
+
+sreturn
--
cgit v1.2.3
From ec745f90fc97e10948dc32ec4f44aabf5c6908db Mon Sep 17 00:00:00 2001
From: Adam Chlipala
Date: Sat, 20 Dec 2008 16:19:26 -0500
Subject: Successfully generated a page element from a signal
---
Makefile.in | 3 +++
jslib/urweb.js | 1 +
src/c/driver.c | 5 -----
src/cjr.sml | 2 ++
src/cjr_env.sml | 1 +
src/cjr_print.sml | 20 ++++++++++++++++++++
src/cjrize.sml | 1 +
src/config.sig | 1 +
src/config.sml.in | 2 ++
src/jscomp.sml | 18 +++++++++++++-----
src/mono.sml | 3 +++
src/mono_env.sml | 1 +
src/mono_print.sml | 4 ++++
src/mono_shake.sml | 6 ++++--
src/mono_util.sml | 6 +++++-
src/monoize.sml | 4 +++-
src/prepare.sml | 1 +
17 files changed, 65 insertions(+), 14 deletions(-)
create mode 100644 jslib/urweb.js
(limited to 'src/cjrize.sml')
diff --git a/Makefile.in b/Makefile.in
index 57a083bd..ed65ceea 100644
--- a/Makefile.in
+++ b/Makefile.in
@@ -5,6 +5,7 @@ SITELISP := @SITELISP@
LIB_UR := $(LIB)/ur
LIB_C := $(LIB)/c
+LIB_JS := $(LIB)/js
all: smlnj mlton c
@@ -70,6 +71,8 @@ install:
cp lib/*.ur $(LIB_UR)/
mkdir -p $(LIB_C)
cp clib/*.o $(LIB_C)/
+ mkdir -p $(LIB_JS)
+ cp jslib/*.js $(LIB_JS)/
mkdir -p $(INCLUDE)
cp include/*.h $(INCLUDE)/
mkdir -p $(SITELISP)
diff --git a/jslib/urweb.js b/jslib/urweb.js
new file mode 100644
index 00000000..32912e4c
--- /dev/null
+++ b/jslib/urweb.js
@@ -0,0 +1 @@
+function sreturn(v) { return {v : v} }
diff --git a/src/c/driver.c b/src/c/driver.c
index a25cd743..34e57a6d 100644
--- a/src/c/driver.c
+++ b/src/c/driver.c
@@ -193,8 +193,6 @@ static void *worker(void *data) {
uw_set_headers(ctx, headers);
while (1) {
- uw_write(ctx, "");
-
if (uw_db_begin(ctx)) {
printf("Error running SQL BEGIN\n");
if (retries_left)
@@ -211,13 +209,10 @@ static void *worker(void *data) {
}
uw_write_header(ctx, "HTTP/1.1 200 OK\r\n");
- uw_write_header(ctx, "Content-type: text/html\r\n");
strcpy(path_copy, path);
fk = uw_begin(ctx, path_copy);
if (fk == SUCCESS) {
- uw_write(ctx, "");
-
if (uw_db_commit(ctx)) {
fk = FATAL;
diff --git a/src/cjr.sml b/src/cjr.sml
index 84aea54e..43a29a6c 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -109,6 +109,8 @@ datatype decl' =
| DDatabase of string
| DPreparedStatements of (string * int) list
+ | DJavaScript of string
+
withtype decl = decl' located
type file = decl list * (Core.export_kind * string * int * typ list) list
diff --git a/src/cjr_env.sml b/src/cjr_env.sml
index 49e86140..9921ee48 100644
--- a/src/cjr_env.sml
+++ b/src/cjr_env.sml
@@ -166,6 +166,7 @@ fun declBinds env (d, loc) =
| DSequence _ => env
| DDatabase _ => env
| DPreparedStatements _ => env
+ | DJavaScript _ => env
end
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 8c3c3d86..06f9f5ca 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -1800,6 +1800,10 @@ fun p_decl env (dAll as (d, _) : decl) =
string "}"]
+ | DJavaScript s => box [string "static char jslib[] = \"",
+ string (String.toString s),
+ string "\";"]
+
datatype 'a search =
Found of 'a
| NotFound
@@ -2048,6 +2052,10 @@ fun p_file env (ds, ps) =
newline,
string "if (*request == '/') ++request;",
newline,
+ string "uw_write_header(ctx, \"Content-type: text/html\\r\\n\");",
+ newline,
+ string "uw_write(ctx, \"\");",
+ newline,
box [string "{",
newline,
box (ListUtil.mapi (fn (i, t) => box [p_typ env t,
@@ -2070,6 +2078,8 @@ fun p_file env (ds, ps) =
inputsVar,
string ", uw_unit_v);",
newline,
+ string "uw_write(ctx, \"\");",
+ newline,
string "return;",
newline,
string "}",
@@ -2374,6 +2384,16 @@ fun p_file env (ds, ps) =
newline,
string "void uw_handle(uw_context ctx, char *request) {",
newline,
+ string "if (!strcmp(request, \"/app.js\")) {",
+ newline,
+ box [string "uw_write_header(ctx, \"Content-type: text/javascript\\r\\n\");",
+ newline,
+ string "uw_write(ctx, jslib);",
+ newline,
+ string "return;",
+ newline],
+ string "}",
+ newline,
p_list_sep newline (fn x => x) pds',
newline,
string "uw_error(ctx, FATAL, \"Unknown page\");",
diff --git a/src/cjrize.sml b/src/cjrize.sml
index f3c5e5a7..78513ef7 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -528,6 +528,7 @@ fun cifyDecl ((d, loc), sm) =
| L.DSequence s =>
(SOME (L'.DSequence s, loc), NONE, sm)
| L.DDatabase s => (SOME (L'.DDatabase s, loc), NONE, sm)
+ | L.DJavaScript s => (SOME (L'.DJavaScript s, loc), NONE, sm)
fun cjrize ds =
let
diff --git a/src/config.sig b/src/config.sig
index 6075482e..90fb72e7 100644
--- a/src/config.sig
+++ b/src/config.sig
@@ -6,6 +6,7 @@ signature CONFIG = sig
val libUr : string
val libC : string
+ val libJs : string
val gccArgs : string
end
diff --git a/src/config.sml.in b/src/config.sml.in
index 9e53986b..c7d231d5 100644
--- a/src/config.sml.in
+++ b/src/config.sml.in
@@ -9,6 +9,8 @@ val libUr = OS.Path.joinDirFile {dir = lib,
file = "ur"}
val libC = OS.Path.joinDirFile {dir = lib,
file = "c"}
+val libJs = OS.Path.joinDirFile {dir = lib,
+ file = "js"}
val gccArgs = "@GCCARGS@"
diff --git a/src/jscomp.sml b/src/jscomp.sml
index b0842c6b..95c18016 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -285,7 +285,7 @@ fun jsExp mode outer =
in
(strcat [str "document.write(",
e,
- str ")"], st)
+ str ".v)"], st)
end
| ESeq (e1, e2) =>
@@ -317,9 +317,9 @@ fun jsExp mode outer =
let
val (e, st) = jsE inner (e, st)
in
- (strcat [(*str "sreturn(",*)
- e(*,
- str ")"*)],
+ (strcat [str "sreturn(",
+ e,
+ str ")"],
st)
end
end
@@ -369,8 +369,16 @@ fun process file =
{decls = [],
script = ""}
file
+
+ val inf = TextIO.openIn (OS.Path.joinDirFile {dir = Config.libJs, file = "urweb.js"})
+ fun lines acc =
+ case TextIO.inputLine inf of
+ NONE => String.concat (rev acc)
+ | SOME line => lines (line :: acc)
+ val lines = lines []
in
- ds
+ TextIO.closeIn inf;
+ (DJavaScript lines, ErrorMsg.dummySpan) :: ds
end
end
diff --git a/src/mono.sml b/src/mono.sml
index c6e0ae8a..1a7fde00 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -118,6 +118,9 @@ datatype decl' =
| DSequence of string
| DDatabase of string
+ | DJavaScript of string
+
+
withtype decl = decl' located
type file = decl list
diff --git a/src/mono_env.sml b/src/mono_env.sml
index cce4a4c4..248567de 100644
--- a/src/mono_env.sml
+++ b/src/mono_env.sml
@@ -110,6 +110,7 @@ fun declBinds env (d, loc) =
| DTable _ => env
| DSequence _ => env
| DDatabase _ => env
+ | DJavaScript _ => env
fun patBinds env (p, loc) =
case p of
diff --git a/src/mono_print.sml b/src/mono_print.sml
index 89b6c35b..e44bb74c 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -379,6 +379,10 @@ fun p_decl env (dAll as (d, _) : decl) =
| DDatabase s => box [string "database",
space,
string s]
+ | DJavaScript s => box [string "JavaScript(",
+ string s,
+ string ")"]
+
fun p_file env file =
let
diff --git a/src/mono_shake.sml b/src/mono_shake.sml
index 6714718a..34bd98be 100644
--- a/src/mono_shake.sml
+++ b/src/mono_shake.sml
@@ -56,7 +56,8 @@ fun shake file =
| ((DExport _, _), acc) => acc
| ((DTable _, _), acc) => acc
| ((DSequence _, _), acc) => acc
- | ((DDatabase _, _), acc) => acc)
+ | ((DDatabase _, _), acc) => acc
+ | ((DJavaScript _, _), acc) => acc)
(IM.empty, IM.empty) file
fun typ (c, s) =
@@ -112,7 +113,8 @@ fun shake file =
| (DExport _, _) => true
| (DTable _, _) => true
| (DSequence _, _) => true
- | (DDatabase _, _) => true) file
+ | (DDatabase _, _) => true
+ | (DJavaScript _, _) => true) file
end
end
diff --git a/src/mono_util.sml b/src/mono_util.sml
index 553f802e..9788a551 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -323,6 +323,7 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
S.map2 (mfe ctx e,
fn e' =>
(EJavaScript (m, e'), loc))
+
| ESignalReturn e =>
S.map2 (mfe ctx e,
fn e' =>
@@ -421,6 +422,7 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} =
| DTable _ => S.return2 dAll
| DSequence _ => S.return2 dAll
| DDatabase _ => S.return2 dAll
+ | DJavaScript _ => S.return2 dAll
and mfvi ctx (x, n, t, e, s) =
S.bind2 (mft t,
@@ -501,6 +503,7 @@ fun mapfoldB (all as {bind, ...}) =
| DTable _ => ctx
| DSequence _ => ctx
| DDatabase _ => ctx
+ | DJavaScript _ => ctx
in
S.map2 (mff ctx' ds',
fn ds' =>
@@ -548,7 +551,8 @@ val maxName = foldl (fn ((d, _) : decl, count) =>
| DExport _ => count
| DTable _ => count
| DSequence _ => count
- | DDatabase _ => count) 0
+ | DDatabase _ => count
+ | DJavaScript _ => count) 0
end
diff --git a/src/monoize.sml b/src/monoize.sml
index 1b7b467d..a0a0df30 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -1844,7 +1844,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
in
case tag of
"body" => normal ("body", NONE,
- SOME (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]), loc))
+ SOME (L'.EStrcat ((L'.EPrim (Prim.String ""), loc),
+ (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]),
+ loc)), loc))
| "dyn" =>
(case #1 attrs of
diff --git a/src/prepare.sml b/src/prepare.sml
index 708bcade..110f6f9a 100644
--- a/src/prepare.sml
+++ b/src/prepare.sml
@@ -258,6 +258,7 @@ fun prepDecl (d as (_, loc), sns) =
| DSequence _ => (d, sns)
| DDatabase _ => (d, sns)
| DPreparedStatements _ => (d, sns)
+ | DJavaScript _ => (d, sns)
fun prepare (ds, ps) =
let
--
cgit v1.2.3
From d5c3faacb1c3114fe6802973a62528cda8be8ac7 Mon Sep 17 00:00:00 2001
From: Adam Chlipala
Date: Sun, 21 Dec 2008 12:30:57 -0500
Subject: Handling singnal bind
---
jslib/urweb.js | 3 +-
src/cjrize.sml | 1 +
src/compiler.sig | 3 +-
src/compiler.sml | 8 +++--
src/jscomp.sml | 90 +++++++++++++++++++++++++++++++++++++++--------------
src/mono.sml | 1 +
src/mono_opt.sml | 3 ++
src/mono_print.sml | 6 ++++
src/mono_reduce.sml | 5 +++
src/mono_util.sml | 6 ++++
src/monoize.sml | 18 +++++++++--
tests/sbind.ur | 5 +++
tests/sbind.urp | 3 ++
13 files changed, 122 insertions(+), 30 deletions(-)
create mode 100644 tests/sbind.ur
create mode 100644 tests/sbind.urp
(limited to 'src/cjrize.sml')
diff --git a/jslib/urweb.js b/jslib/urweb.js
index b7a1af91..f552b26b 100644
--- a/jslib/urweb.js
+++ b/jslib/urweb.js
@@ -1,4 +1,5 @@
-function sreturn(v) { return {v : v} }
+function sr(v) { return {v : v} }
+function sb(x,y) { return {v : y(x.v).v} }
function dyn(s) {
var x = document.createElement("span");
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 78513ef7..a46c725e 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -423,6 +423,7 @@ fun cifyExp (eAll as (e, loc), sm) =
| L.EJavaScript _ => raise Fail "Cjrize: EJavaScript remains"
| L.ESignalReturn _ => raise Fail "Cjrize: ESignalReturn remains"
+ | L.ESignalBind _ => raise Fail "Cjrize: ESignalBind remains"
fun cifyDecl ((d, loc), sm) =
case d of
diff --git a/src/compiler.sig b/src/compiler.sig
index 1f1f4973..c156b268 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -102,8 +102,9 @@ signature COMPILER = sig
val toUntangle : (string, Mono.file) transform
val toMono_reduce : (string, Mono.file) transform
val toMono_shake : (string, Mono.file) transform
- val toJscomp : (string, Mono.file) transform
val toMono_opt2 : (string, Mono.file) transform
+ val toJscomp : (string, Mono.file) transform
+ val toMono_opt3 : (string, Mono.file) transform
val toFuse : (string, Mono.file) transform
val toUntangle2 : (string, Mono.file) transform
val toMono_shake2 : (string, Mono.file) transform
diff --git a/src/compiler.sml b/src/compiler.sml
index ecee1065..6d499283 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -511,21 +511,23 @@ val mono_shake = {
val toMono_shake = transform mono_shake "mono_shake1" o toMono_reduce
+val toMono_opt2 = transform mono_opt "mono_opt2" o toMono_shake
+
val jscomp = {
func = JsComp.process,
print = MonoPrint.p_file MonoEnv.empty
}
-val toJscomp = transform jscomp "jscomp" o toMono_reduce
+val toJscomp = transform jscomp "jscomp" o toMono_opt2
-val toMono_opt2 = transform mono_opt "mono_opt2" o toJscomp
+val toMono_opt3 = transform mono_opt "mono_opt3" o toJscomp
val fuse = {
func = Fuse.fuse,
print = MonoPrint.p_file MonoEnv.empty
}
-val toFuse = transform fuse "fuse" o toMono_opt2
+val toFuse = transform fuse "fuse" o toMono_opt3
val toUntangle2 = transform untangle "untangle2" o toFuse
diff --git a/src/jscomp.sml b/src/jscomp.sml
index 95c18016..c38056e8 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -33,6 +33,20 @@ structure EM = ErrorMsg
structure E = MonoEnv
structure U = MonoUtil
+val funcs = [(("Basis", "alert"), "alert"),
+ (("Basis", "htmlifyString"), "escape")]
+
+structure FM = BinaryMapFn(struct
+ type ord_key = string * string
+ fun compare ((m1, x1), (m2, x2)) =
+ Order.join (String.compare (m1, m2),
+ fn () => String.compare (x1, x2))
+ end)
+
+val funcs = foldl (fn ((k, v), m) => FM.insert (m, k, v)) FM.empty funcs
+
+fun ffi k = FM.find (funcs, k)
+
type state = {
decls : decl list,
script : string
@@ -70,6 +84,7 @@ fun varDepth (e, _) =
| EUnurlify _ => 0
| EJavaScript _ => 0
| ESignalReturn e => varDepth e
+ | ESignalBind (e1, e2) => Int.max (varDepth e1, varDepth e2)
fun strcat loc es =
case es of
@@ -150,33 +165,50 @@ fun jsExp mode outer =
e, st)
end
- | EFfi (_, s) => (str s, st)
- | EFfiApp (_, s, []) => (str (s ^ "()"), st)
- | EFfiApp (_, s, [e]) =>
+ | EFfi k =>
let
- val (e, st) = jsE inner (e, st)
-
+ val name = case ffi k of
+ NONE => (EM.errorAt loc "Unsupported FFI identifier in JavaScript";
+ "ERROR")
+ | SOME s => s
in
- (strcat [str (s ^ "("),
- e,
- str ")"], st)
+ (str name, st)
end
- | EFfiApp (_, s, e :: es) =>
+ | EFfiApp (m, x, args) =>
let
- val (e, st) = jsE inner (e, st)
- val (es, st) = ListUtil.foldlMapConcat
- (fn (e, st) =>
- let
- val (e, st) = jsE inner (e, st)
- in
- ([str ",", e], st)
- end)
- st es
+ val name = case ffi (m, x) of
+ NONE => (EM.errorAt loc "Unsupported FFI function in JavaScript";
+ "ERROR")
+ | SOME s => s
in
- (strcat (str (s ^ "(")
- :: e
- :: es
- @ [str ")"]), st)
+ case args of
+ [] => (str (name ^ "()"), st)
+ | [e] =>
+ let
+ val (e, st) = jsE inner (e, st)
+
+ in
+ (strcat [str (name ^ "("),
+ e,
+ str ")"], st)
+ end
+ | e :: es =>
+ let
+ val (e, st) = jsE inner (e, st)
+ val (es, st) = ListUtil.foldlMapConcat
+ (fn (e, st) =>
+ let
+ val (e, st) = jsE inner (e, st)
+ in
+ ([str ",", e], st)
+ end)
+ st es
+ in
+ (strcat (str (name ^ "(")
+ :: e
+ :: es
+ @ [str ")"]), st)
+ end
end
| EApp (e1, e2) =>
@@ -317,11 +349,23 @@ fun jsExp mode outer =
let
val (e, st) = jsE inner (e, st)
in
- (strcat [str "sreturn(",
+ (strcat [str "sr(",
e,
str ")"],
st)
end
+ | ESignalBind (e1, e2) =>
+ let
+ val (e1, st) = jsE inner (e1, st)
+ val (e2, st) = jsE inner (e2, st)
+ in
+ (strcat [str "sb(",
+ e1,
+ str ",",
+ e2,
+ str ")"],
+ st)
+ end
end
in
jsE
diff --git a/src/mono.sml b/src/mono.sml
index 1a7fde00..54b77550 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -105,6 +105,7 @@ datatype exp' =
| EJavaScript of javascript_mode * exp
| ESignalReturn of exp
+ | ESignalBind of exp * exp
withtype exp = exp' located
diff --git a/src/mono_opt.sml b/src/mono_opt.sml
index 6c0e6e21..550a055c 100644
--- a/src/mono_opt.sml
+++ b/src/mono_opt.sml
@@ -360,6 +360,9 @@ fun exp e =
| EWrite (EPrim (Prim.String ""), loc) =>
ERecord []
+ | ESignalBind ((ESignalReturn e1, loc), e2) =>
+ optExp (EApp (e2, e1), loc)
+
| _ => e
and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e)
diff --git a/src/mono_print.sml b/src/mono_print.sml
index e44bb74c..608fe269 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -285,6 +285,12 @@ fun p_exp' par env (e, _) =
| ESignalReturn e => box [string "Return(",
p_exp env e,
string ")"]
+ | ESignalBind (e1, e2) => box [string "Return(",
+ p_exp env e1,
+ string ",",
+ space,
+ p_exp env e2,
+ string ")"]
and p_exp env = p_exp' false env
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index e1da02c9..841e034e 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -77,6 +77,7 @@ fun impure (e, _) =
| EClosure (_, es) => List.exists impure es
| EJavaScript (_, e) => impure e
| ESignalReturn e => impure e
+ | ESignalBind (e1, e2) => impure e1 orelse impure e2
val liftExpInExp = Monoize.liftExpInExp
@@ -333,6 +334,7 @@ fun reduce file =
| EUnurlify (e, _) => summarize d e
| EJavaScript (_, e) => summarize d e
| ESignalReturn e => summarize d e
+ | ESignalBind (e1, e2) => summarize d e1 @ summarize d e2
fun exp env e =
@@ -478,6 +480,9 @@ fun reduce file =
| EStrcat ((EPrim (Prim.String s1), _), (EPrim (Prim.String s2), _)) =>
EPrim (Prim.String (s1 ^ s2))
+ | ESignalBind ((ESignalReturn e1, loc), e2) =>
+ #1 (reduceExp env (EApp (e2, e1), loc))
+
| _ => e
in
(*Print.prefaces "exp'" [("r", MonoPrint.p_exp env (r, ErrorMsg.dummySpan))];*)
diff --git a/src/mono_util.sml b/src/mono_util.sml
index 9788a551..a85443d7 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -328,6 +328,12 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
S.map2 (mfe ctx e,
fn e' =>
(ESignalReturn e', loc))
+ | ESignalBind (e1, e2) =>
+ S.bind2 (mfe ctx e1,
+ fn e1' =>
+ S.map2 (mfe ctx e2,
+ fn e2' =>
+ (ESignalBind (e1', e2'), loc)))
in
mfe
end
diff --git a/src/monoize.sml b/src/monoize.sml
index 63d84d8c..30bd5daa 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -957,8 +957,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
val mt1 = (L'.TFun (un, t1), loc)
val mt2 = (L'.TFun (un, t2), loc)
in
- ((L'.EAbs ("m1", mt1, (L'.TFun (mt1, (L'.TFun (mt2, (L'.TFun (un, un), loc)), loc)), loc),
- (L'.EAbs ("m2", mt2, (L'.TFun (un, un), loc),
+ ((L'.EAbs ("m1", mt1, (L'.TFun ((L'.TFun (t1, mt2), loc), (L'.TFun (un, un), loc)), loc),
+ (L'.EAbs ("m2", (L'.TFun (t1, mt2), loc), (L'.TFun (un, un), loc),
(L'.EAbs ("_", un, un,
(L'.ELet ("r", t1, (L'.EApp ((L'.ERel 2, loc),
(L'.ERecord [], loc)), loc),
@@ -989,6 +989,20 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L'.ESignalReturn (L'.ERel 0, loc), loc)), loc),
fm)
end
+ | L.EApp ((L.ECApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "bind"), _), _), _), t1), _), t2), _),
+ (L.EFfi ("Basis", "signal_monad"), _)) =>
+ let
+ val t1 = monoType env t1
+ val t2 = monoType env t2
+ val un = (L'.TRecord [], loc)
+ val mt1 = (L'.TSignal t1, loc)
+ val mt2 = (L'.TSignal t2, loc)
+ in
+ ((L'.EAbs ("m1", mt1, (L'.TFun ((L'.TFun (t1, mt2), loc), mt2), loc),
+ (L'.EAbs ("m2", (L'.TFun (t1, mt2), loc), mt2,
+ (L'.ESignalBind ((L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc),
+ fm)
+ end
| L.ECApp ((L.EFfi ("Basis", "getCookie"), _), t) =>
let
diff --git a/tests/sbind.ur b/tests/sbind.ur
new file mode 100644
index 00000000..6e3ca782
--- /dev/null
+++ b/tests/sbind.ur
@@ -0,0 +1,5 @@
+fun main () : transaction page = return
+ Before
+ {[s]}
}/>
+ After
+
diff --git a/tests/sbind.urp b/tests/sbind.urp
new file mode 100644
index 00000000..d8735c70
--- /dev/null
+++ b/tests/sbind.urp
@@ -0,0 +1,3 @@
+debug
+
+sbind
--
cgit v1.2.3
From f60bcb83cf4d8e0a6176a1dca6e557c49e9f9375 Mon Sep 17 00:00:00 2001
From: Adam Chlipala
Date: Sun, 21 Dec 2008 12:56:39 -0500
Subject: Trivial use of a source
---
jslib/urweb.js | 3 ++
src/c/urweb.c | 111 ++++++++++++++++++++++++++++++++++------------------
src/cjrize.sml | 1 +
src/jscomp.sml | 17 ++++++--
src/mono.sml | 1 +
src/mono_print.sml | 5 ++-
src/mono_reduce.sml | 3 +-
src/mono_util.sml | 4 ++
src/monoize.sml | 10 ++++-
tests/reactive.ur | 7 ++--
10 files changed, 116 insertions(+), 46 deletions(-)
(limited to 'src/cjrize.sml')
diff --git a/jslib/urweb.js b/jslib/urweb.js
index f552b26b..eab67626 100644
--- a/jslib/urweb.js
+++ b/jslib/urweb.js
@@ -1,3 +1,6 @@
+function sc(v) { return {v : v} }
+
+function ss(s) { return {v : s.v} }
function sr(v) { return {v : v} }
function sb(x,y) { return {v : y(x.v).v} }
diff --git a/src/c/urweb.c b/src/c/urweb.c
index 64cdb81e..11b99f4c 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -387,12 +387,84 @@ char *uw_Basis_get_script(uw_context ctx, uw_unit u) {
}
}
-int uw_Basis_new_client_source(uw_context ctx, uw_unit u) {
+uw_Basis_string uw_Basis_jsifyString(uw_context ctx, uw_Basis_string s) {
+ char *r, *s2;
+
+ uw_check_heap(ctx, strlen(s) * 4 + 2);
+
+ r = s2 = ctx->heap_front;
+ *s2++ = '"';
+
+ for (; *s; s++) {
+ char c = *s;
+
+ switch (c) {
+ case '"':
+ strcpy(s2, "\\\"");
+ s2 += 2;
+ break;
+ case '\\':
+ strcpy(s2, "\\\\");
+ s2 += 2;
+ break;
+ default:
+ if (isprint(c))
+ *s2++ = c;
+ else {
+ sprintf(s2, "\\%3o", c);
+ s2 += 4;
+ }
+ }
+ }
+
+ strcpy(s2, "\"");
+ ctx->heap_front = s2 + 1;
+ return r;
+}
+
+uw_Basis_string uw_Basis_jsifyString_ws(uw_context ctx, uw_Basis_string s) {
+ char *r, *s2;
+
+ uw_check_script(ctx, strlen(s) * 4 + 2);
+
+ r = s2 = ctx->script_front;
+ *s2++ = '"';
+
+ for (; *s; s++) {
+ char c = *s;
+
+ switch (c) {
+ case '"':
+ strcpy(s2, "\\\"");
+ s2 += 2;
+ break;
+ case '\\':
+ strcpy(s2, "\\\\");
+ s2 += 2;
+ break;
+ default:
+ if (isprint(c))
+ *s2++ = c;
+ else {
+ sprintf(s2, "\\%3o", c);
+ s2 += 4;
+ }
+ }
+ }
+
+ strcpy(s2, "\"");
+ ctx->script_front = s2 + 1;
+ return r;
+}
+
+int uw_Basis_new_client_source(uw_context ctx, uw_Basis_string s) {
size_t len;
uw_check_script(ctx, 8 + INTS_MAX);
- sprintf(ctx->script_front, "var e%d=0\n%n", ctx->source_count, &len);
+ sprintf(ctx->script_front, "var s%d=sc(%n", ctx->source_count, &len);
ctx->script_front += len;
+ uw_Basis_jsifyString_ws(ctx, s);
+ uw_write_script(ctx, ");");
return ctx->source_count++;
}
@@ -1056,41 +1128,6 @@ char *uw_Basis_ensqlBool(uw_Basis_bool b) {
return (char *)&true;
}
-uw_Basis_string uw_Basis_jsifyString(uw_context ctx, uw_Basis_string s) {
- char *r, *s2;
-
- uw_check_heap(ctx, strlen(s) * 4 + 2);
-
- r = s2 = ctx->heap_front;
- *s2++ = '"';
-
- for (; *s; s++) {
- char c = *s;
-
- switch (c) {
- case '"':
- strcpy(s2, "\\\"");
- s2 += 2;
- break;
- case '\\':
- strcpy(s2, "\\\\");
- s2 += 2;
- break;
- default:
- if (isprint(c))
- *s2++ = c;
- else {
- sprintf(s2, "\\%3o", c);
- s2 += 4;
- }
- }
- }
-
- strcpy(s2, "\"");
- ctx->heap_front = s2 + 1;
- return r;
-}
-
uw_Basis_string uw_Basis_intToString(uw_context ctx, uw_Basis_int n) {
int len;
char *r;
diff --git a/src/cjrize.sml b/src/cjrize.sml
index a46c725e..a9c51826 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -424,6 +424,7 @@ fun cifyExp (eAll as (e, loc), sm) =
| L.EJavaScript _ => raise Fail "Cjrize: EJavaScript remains"
| L.ESignalReturn _ => raise Fail "Cjrize: ESignalReturn remains"
| L.ESignalBind _ => raise Fail "Cjrize: ESignalBind remains"
+ | L.ESignalSource _ => raise Fail "Cjrize: ESignalSource remains"
fun cifyDecl ((d, loc), sm) =
case d of
diff --git a/src/jscomp.sml b/src/jscomp.sml
index c38056e8..f7ef6927 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -34,7 +34,8 @@ structure E = MonoEnv
structure U = MonoUtil
val funcs = [(("Basis", "alert"), "alert"),
- (("Basis", "htmlifyString"), "escape")]
+ (("Basis", "htmlifyString"), "escape"),
+ (("Basis", "new_client_source"), "sc")]
structure FM = BinaryMapFn(struct
type ord_key = string * string
@@ -85,6 +86,7 @@ fun varDepth (e, _) =
| EJavaScript _ => 0
| ESignalReturn e => varDepth e
| ESignalBind (e1, e2) => Int.max (varDepth e1, varDepth e2)
+ | ESignalSource e => varDepth e
fun strcat loc es =
case es of
@@ -168,7 +170,7 @@ fun jsExp mode outer =
| EFfi k =>
let
val name = case ffi k of
- NONE => (EM.errorAt loc "Unsupported FFI identifier in JavaScript";
+ NONE => (EM.errorAt loc ("Unsupported FFI identifier " ^ #2 k ^ " in JavaScript");
"ERROR")
| SOME s => s
in
@@ -177,7 +179,7 @@ fun jsExp mode outer =
| EFfiApp (m, x, args) =>
let
val name = case ffi (m, x) of
- NONE => (EM.errorAt loc "Unsupported FFI function in JavaScript";
+ NONE => (EM.errorAt loc ("Unsupported FFI function " ^ x ^ " in JavaScript");
"ERROR")
| SOME s => s
in
@@ -366,6 +368,15 @@ fun jsExp mode outer =
str ")"],
st)
end
+ | ESignalSource e =>
+ let
+ val (e, st) = jsE inner (e, st)
+ in
+ (strcat [str "ss(",
+ e,
+ str ")"],
+ st)
+ end
end
in
jsE
diff --git a/src/mono.sml b/src/mono.sml
index 54b77550..ae9a06c7 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -106,6 +106,7 @@ datatype exp' =
| ESignalReturn of exp
| ESignalBind of exp * exp
+ | ESignalSource of exp
withtype exp = exp' located
diff --git a/src/mono_print.sml b/src/mono_print.sml
index 608fe269..b3c0a568 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -285,12 +285,15 @@ fun p_exp' par env (e, _) =
| ESignalReturn e => box [string "Return(",
p_exp env e,
string ")"]
- | ESignalBind (e1, e2) => box [string "Return(",
+ | ESignalBind (e1, e2) => box [string "Bind(",
p_exp env e1,
string ",",
space,
p_exp env e2,
string ")"]
+ | ESignalSource e => box [string "Source(",
+ p_exp env e,
+ string ")"]
and p_exp env = p_exp' false env
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 841e034e..a6777db5 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -78,6 +78,7 @@ fun impure (e, _) =
| EJavaScript (_, e) => impure e
| ESignalReturn e => impure e
| ESignalBind (e1, e2) => impure e1 orelse impure e2
+ | ESignalSource e => impure e
val liftExpInExp = Monoize.liftExpInExp
@@ -335,7 +336,7 @@ fun reduce file =
| EJavaScript (_, e) => summarize d e
| ESignalReturn e => summarize d e
| ESignalBind (e1, e2) => summarize d e1 @ summarize d e2
-
+ | ESignalSource e => summarize d e
fun exp env e =
let
diff --git a/src/mono_util.sml b/src/mono_util.sml
index a85443d7..b14e3ac9 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -334,6 +334,10 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
S.map2 (mfe ctx e2,
fn e2' =>
(ESignalBind (e1', e2'), loc)))
+ | ESignalSource e =>
+ S.map2 (mfe ctx e,
+ fn e' =>
+ (ESignalSource e', loc))
in
mfe
end
diff --git a/src/monoize.sml b/src/monoize.sml
index 30bd5daa..d3d20e7c 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -975,7 +975,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
in
((L'.EAbs ("x", t, (L'.TFun ((L'.TRecord [], loc), (L'.TFfi ("Basis", "int"), loc)), loc),
(L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "int"), loc),
- (L'.EFfiApp ("Basis", "new_client_source", [(L'.ERecord [], loc)]), loc)), loc)),
+ (L'.EFfiApp ("Basis", "new_client_source", [(L'.ERel 1, loc)]), loc)), loc)),
loc),
fm)
end
@@ -1003,6 +1003,14 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L'.ESignalBind ((L'.ERel 1, loc), (L'.ERel 0, loc)), loc)), loc)), loc),
fm)
end
+ | L.ECApp ((L.EFfi ("Basis", "signal"), _), t) =>
+ let
+ val t = monoType env t
+ in
+ ((L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc), (L'.TSignal t, loc),
+ (L'.ESignalSource (L'.ERel 0, loc), loc)), loc),
+ fm)
+ end
| L.ECApp ((L.EFfi ("Basis", "getCookie"), _), t) =>
let
diff --git a/tests/reactive.ur b/tests/reactive.ur
index cb49541f..95839c7d 100644
--- a/tests/reactive.ur
+++ b/tests/reactive.ur
@@ -1,4 +1,5 @@
fun main () : transaction page =
- x <- source ();
- y <- source ();
- return Hi!
+ x <- source TEST;
+ return
+
+
--
cgit v1.2.3
From 493ec594ea29706c85196d1b616ab28ed3da6797 Mon Sep 17 00:00:00 2001
From: Adam Chlipala
Date: Tue, 30 Dec 2008 10:49:42 -0500
Subject: Setting a source server-side
---
include/urweb.h | 4 +++-
src/c/urweb.c | 31 +++++++++++++++++++++++++------
src/cjrize.sml | 1 +
src/jscomp.sml | 14 +++++++++++++-
src/mono.sml | 1 +
src/mono_print.sml | 1 +
src/mono_reduce.sml | 2 ++
src/mono_util.sml | 5 +++++
src/monoize.sml | 14 ++++++++------
tests/reactive2.ur | 6 ++++++
tests/reactive2.urp | 3 +++
11 files changed, 68 insertions(+), 14 deletions(-)
create mode 100644 tests/reactive2.ur
create mode 100644 tests/reactive2.urp
(limited to 'src/cjrize.sml')
diff --git a/include/urweb.h b/include/urweb.h
index 647f153a..a5bb8dc0 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -36,7 +36,9 @@ char *uw_get_optional_input(uw_context, int name);
void uw_write(uw_context, const char*);
-int uw_Basis_new_client_source(uw_context, uw_unit);
+uw_Basis_int uw_Basis_new_client_source(uw_context, uw_Basis_string);
+uw_unit uw_Basis_set_client_source(uw_context, uw_Basis_int, uw_Basis_string);
+
char *uw_Basis_get_script(uw_context, uw_unit);
char *uw_Basis_htmlifyInt(uw_context, uw_Basis_int);
diff --git a/src/c/urweb.c b/src/c/urweb.c
index 11b99f4c..2c6d493a 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -363,6 +363,7 @@ static void uw_check_script(uw_context ctx, size_t extra) {
ctx->script_front = new_script + (ctx->script_front - ctx->script);
ctx->script_back = new_script + next;
ctx->script = new_script;
+ printf("new_script = %p\n", new_script);
}
}
@@ -434,7 +435,7 @@ uw_Basis_string uw_Basis_jsifyString_ws(uw_context ctx, uw_Basis_string s) {
char c = *s;
switch (c) {
- case '"':
+ case '\'':
strcpy(s2, "\\\"");
s2 += 2;
break;
@@ -457,18 +458,36 @@ uw_Basis_string uw_Basis_jsifyString_ws(uw_context ctx, uw_Basis_string s) {
return r;
}
-int uw_Basis_new_client_source(uw_context ctx, uw_Basis_string s) {
- size_t len;
+uw_Basis_int uw_Basis_new_client_source(uw_context ctx, uw_Basis_string s) {
+ int len;
+ size_t s_len = strlen(s);
- uw_check_script(ctx, 8 + INTS_MAX);
+ uw_check_script(ctx, 12 + INTS_MAX + s_len);
sprintf(ctx->script_front, "var s%d=sc(%n", ctx->source_count, &len);
ctx->script_front += len;
- uw_Basis_jsifyString_ws(ctx, s);
- uw_write_script(ctx, ");");
+ strcpy(ctx->script_front, s);
+ ctx->script_front += s_len;
+ strcpy(ctx->script_front, ");");
+ ctx->script_front += 2;
return ctx->source_count++;
}
+uw_unit uw_Basis_set_client_source(uw_context ctx, uw_Basis_int n, uw_Basis_string s) {
+ int len;
+ size_t s_len = strlen(s);
+
+ uw_check_script(ctx, 6 + INTS_MAX + s_len);
+ sprintf(ctx->script_front, "s%d.v=%n", (int)n, &len);
+ ctx->script_front += len;
+ strcpy(ctx->script_front, s);
+ ctx->script_front += s_len;
+ strcpy(ctx->script_front, ";");
+ ctx->script_front++;
+
+ return uw_unit_v;
+}
+
static void uw_check(uw_context ctx, size_t extra) {
size_t desired = ctx->page_front - ctx->page + extra, next;
char *new_page;
diff --git a/src/cjrize.sml b/src/cjrize.sml
index a9c51826..6d0ece61 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -120,6 +120,7 @@ fun cifyTyp x =
in
((L'.TOption t, loc), sm)
end
+ | L.TSource => ((L'.TFfi ("Basis", "int"), loc), sm)
| L.TSignal _ => raise Fail "Cjrize: TSignal remains"
in
cify IM.empty x
diff --git a/src/jscomp.sml b/src/jscomp.sml
index f7ef6927..8b874289 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -121,6 +121,13 @@ fun jsExp mode outer =
(str "ERROR", st))
val strcat = strcat loc
+
+ fun quoteExp (t : typ) e =
+ case #1 t of
+ TSource => strcat [str "s",
+ (EFfiApp ("Basis", "htmlifyInt", [e]), loc)]
+ | _ => (EM.errorAt loc "Don't know how to embed type in JavaScript";
+ str "ERROR")
in
case #1 e of
EPrim (Prim.String s) =>
@@ -130,6 +137,7 @@ fun jsExp mode outer =
"\\047"
else
"'"
+ | #"\"" => "\\\""
| #"<" =>
if mode = Script then
"<"
@@ -143,7 +151,11 @@ fun jsExp mode outer =
if n < inner then
(str ("uwr" ^ var n), st)
else
- (str ("uwo" ^ var n), st)
+ let
+ val n = n - inner
+ in
+ (quoteExp (List.nth (outer, n)) (ERel n, loc), st)
+ end
| ENamed _ => raise Fail "Named"
| ECon (_, pc, NONE) => (patCon pc, st)
| ECon (_, pc, SOME e) =>
diff --git a/src/mono.sml b/src/mono.sml
index ae9a06c7..41457071 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -37,6 +37,7 @@ datatype typ' =
| TDatatype of int * (datatype_kind * (string * int * typ option) list) ref
| TFfi of string * string
| TOption of typ
+ | TSource
| TSignal of typ
withtype typ = typ' located
diff --git a/src/mono_print.sml b/src/mono_print.sml
index b3c0a568..a876cfac 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -65,6 +65,7 @@ fun p_typ' par env (t, _) =
| TOption t => box [string "option(",
p_typ env t,
string ")"]
+ | TSource => string "source"
| TSignal t => box [string "signal(",
p_typ env t,
string ")"]
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index a6777db5..072c548e 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -55,6 +55,7 @@ fun impure (e, _) =
| EFfi _ => false
| EFfiApp ("Basis", "set_cookie", _) => true
| EFfiApp ("Basis", "new_client_source", _) => true
+ | EFfiApp ("Basis", "set_client_source", _) => true
| EFfiApp _ => false
| EApp ((EFfi _, _), _) => false
| EApp _ => true
@@ -263,6 +264,7 @@ fun reduce file =
| EFfi _ => []
| EFfiApp ("Basis", "set_cookie", _) => [Unsure]
| EFfiApp ("Basis", "new_client_source", _) => [Unsure]
+ | EFfiApp ("Basis", "set_client_source", _) => [Unsure]
| EFfiApp (_, _, es) => List.concat (map (summarize d) es)
| EApp ((EFfi _, _), e) => summarize d e
| EApp _ =>
diff --git a/src/mono_util.sml b/src/mono_util.sml
index b14e3ac9..3f9183d0 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -51,6 +51,7 @@ fun compare ((t1, _), (t2, _)) =
| (TDatatype (n1, _), TDatatype (n2, _)) => Int.compare (n1, n2)
| (TFfi (m1, x1), TFfi (m2, x2)) => join (String.compare (m1, m2), fn () => String.compare (x1, x2))
| (TOption t1, TOption t2) => compare (t1, t2)
+ | (TSource, TSource) => EQUAL
| (TSignal t1, TSignal t2) => compare (t1, t2)
| (TFun _, _) => LESS
@@ -68,6 +69,9 @@ fun compare ((t1, _), (t2, _)) =
| (TOption _, _) => LESS
| (_, TOption _) => GREATER
+ | (TSource, _) => LESS
+ | (_, TSource) => GREATER
+
and compareFields ((x1, t1), (x2, t2)) =
join (String.compare (x1, x2),
fn () => compare (t1, t2))
@@ -100,6 +104,7 @@ fun mapfold fc =
S.map2 (mft t,
fn t' =>
(TOption t, loc))
+ | TSource => S.return2 cAll
| TSignal t =>
S.map2 (mft t,
fn t' =>
diff --git a/src/monoize.sml b/src/monoize.sml
index e34ef162..f40d49d0 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -134,7 +134,7 @@ fun monoType env =
| L.CApp ((L.CFfi ("Basis", "transaction"), _), t) =>
(L'.TFun ((L'.TRecord [], loc), mt env dtmap t), loc)
| L.CApp ((L.CFfi ("Basis", "source"), _), t) =>
- (L'.TFfi ("Basis", "int"), loc)
+ (L'.TSource, loc)
| L.CApp ((L.CFfi ("Basis", "signal"), _), t) =>
(L'.TSignal (mt env dtmap t), loc)
| L.CApp ((L.CFfi ("Basis", "http_cookie"), _), _) =>
@@ -973,9 +973,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
let
val t = monoType env t
in
- ((L'.EAbs ("x", t, (L'.TFun ((L'.TRecord [], loc), (L'.TFfi ("Basis", "int"), loc)), loc),
- (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "int"), loc),
- (L'.EFfiApp ("Basis", "new_client_source", [(L'.ERel 1, loc)]), loc)), loc)),
+ ((L'.EAbs ("x", t, (L'.TFun ((L'.TRecord [], loc), (L'.TSource, loc)), loc),
+ (L'.EAbs ("_", (L'.TRecord [], loc), (L'.TSource, loc),
+ (L'.EFfiApp ("Basis", "new_client_source",
+ [(L'.EJavaScript (L'.File, (L'.ERel 1, loc)), loc)]), loc)), loc)),
loc),
fm)
end
@@ -983,12 +984,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
let
val t = monoType env t
in
- ((L'.EAbs ("src", (L'.TFfi ("Basis", "int"), loc),
+ ((L'.EAbs ("src", (L'.TSource, loc),
(L'.TFun (t, (L'.TFun ((L'.TRecord [], loc), (L'.TRecord [], loc)), loc)), loc),
(L'.EAbs ("v", t, (L'.TFun ((L'.TRecord [], loc), (L'.TRecord [], loc)), loc),
(L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
(L'.EFfiApp ("Basis", "set_client_source",
- [(L'.ERel 2, loc), (L'.ERel 1, loc)]),
+ [(L'.ERel 2, loc),
+ (L'.EJavaScript (L'.File, (L'.ERel 1, loc)), loc)]),
loc)), loc)), loc)), loc),
fm)
end
diff --git a/tests/reactive2.ur b/tests/reactive2.ur
new file mode 100644
index 00000000..7164468e
--- /dev/null
+++ b/tests/reactive2.ur
@@ -0,0 +1,6 @@
+fun main () : transaction page =
+ x <- source TEST;
+ set x HI;
+ return
+
+
diff --git a/tests/reactive2.urp b/tests/reactive2.urp
new file mode 100644
index 00000000..bdc0d1be
--- /dev/null
+++ b/tests/reactive2.urp
@@ -0,0 +1,3 @@
+debug
+
+reactive2
--
cgit v1.2.3
From 8d3edc5aaa4617dd06623447cf9357067eadc072 Mon Sep 17 00:00:00 2001
From: Adam Chlipala
Date: Tue, 30 Dec 2008 11:33:31 -0500
Subject: Harmonized source-setting between server and client
---
src/cjrize.sml | 2 ++
src/jscomp.sml | 15 ++++++++++-----
src/mono.sml | 2 +-
src/mono_opt.sml | 2 ++
src/mono_print.sml | 13 ++++++++-----
src/mono_reduce.sml | 4 ++--
src/mono_util.sml | 10 ++++++++--
src/monoize.sml | 16 ++++++++--------
8 files changed, 41 insertions(+), 23 deletions(-)
(limited to 'src/cjrize.sml')
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 6d0ece61..1a5d10c0 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -422,7 +422,9 @@ fun cifyExp (eAll as (e, loc), sm) =
((L'.EUnurlify (e, t), loc), sm)
end
+ | L.EJavaScript (_, _, SOME e) => cifyExp (e, sm)
| L.EJavaScript _ => raise Fail "Cjrize: EJavaScript remains"
+
| L.ESignalReturn _ => raise Fail "Cjrize: ESignalReturn remains"
| L.ESignalBind _ => raise Fail "Cjrize: ESignalBind remains"
| L.ESignalSource _ => raise Fail "Cjrize: ESignalSource remains"
diff --git a/src/jscomp.sml b/src/jscomp.sml
index 8b874289..a4e3dd35 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -190,6 +190,12 @@ fun jsExp mode outer =
end
| EFfiApp (m, x, args) =>
let
+ val args =
+ case (m, x, args) of
+ ("Basis", "new_client_source", [(EJavaScript (_, e, _), _)]) => [e]
+ | ("Basis", "set_client_source", [e1, (EJavaScript (_, e2, _), _)]) => [e1, e2]
+ | _ => args
+
val name = case ffi (m, x) of
NONE => (EM.errorAt loc ("Unsupported FFI function " ^ x ^ " in JavaScript");
"ERROR")
@@ -200,7 +206,6 @@ fun jsExp mode outer =
| [e] =>
let
val (e, st) = jsE inner (e, st)
-
in
(strcat [str (name ^ "("),
e,
@@ -398,7 +403,7 @@ val decl : state -> decl -> decl * state =
U.Decl.foldMapB {typ = fn x => x,
exp = fn (env, e, st) =>
let
- fun doCode m env e =
+ fun doCode m env orig e =
let
val len = length env
fun str s = (EPrim (Prim.String s), #2 e)
@@ -408,12 +413,12 @@ val decl : state -> decl -> decl * state =
fn i => str ("var uwr" ^ Int.toString (len + i) ^ ";"))
val (e, st) = jsExp m env 0 (e, st)
in
- (#1 (strcat (#2 e) (locals @ [e])), st)
+ (EJavaScript (m, orig, SOME (strcat (#2 e) (locals @ [e]))), st)
end
in
case e of
- EJavaScript (m, (EAbs (_, t, _, e), _)) => doCode m (t :: env) e
- | EJavaScript (m, e) => doCode m env e
+ EJavaScript (m, orig as (EAbs (_, t, _, e), _), _) => doCode m (t :: env) orig e
+ | EJavaScript (m, e, _) => doCode m env e e
| _ => (e, st)
end,
decl = fn (_, e, st) => (e, st),
diff --git a/src/mono.sml b/src/mono.sml
index 41457071..b58396fa 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -103,7 +103,7 @@ datatype exp' =
| EUnurlify of exp * typ
- | EJavaScript of javascript_mode * exp
+ | EJavaScript of javascript_mode * exp * exp option
| ESignalReturn of exp
| ESignalBind of exp * exp
diff --git a/src/mono_opt.sml b/src/mono_opt.sml
index 550a055c..7f23d8b1 100644
--- a/src/mono_opt.sml
+++ b/src/mono_opt.sml
@@ -363,6 +363,8 @@ fun exp e =
| ESignalBind ((ESignalReturn e1, loc), e2) =>
optExp (EApp (e2, e1), loc)
+ | EJavaScript (_, _, SOME (e, _)) => e
+
| _ => e
and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e)
diff --git a/src/mono_print.sml b/src/mono_print.sml
index a876cfac..f8a23d1d 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -216,10 +216,12 @@ fun p_exp' par env (e, _) =
p_exp env e,
string ")"]
- | ESeq (e1, e2) => box [p_exp env e1,
+ | ESeq (e1, e2) => box [string "(",
+ p_exp env e1,
string ";",
space,
- p_exp env e2]
+ p_exp env e2,
+ string ")"]
| ELet (x, t, e1, e2) => box [string "(let",
space,
string x,
@@ -279,9 +281,10 @@ fun p_exp' par env (e, _) =
| EUnurlify (e, _) => box [string "unurlify(",
p_exp env e,
string ")"]
- | EJavaScript (_, e) => box [string "JavaScript(",
- p_exp env e,
- string ")"]
+ | EJavaScript (_, e, NONE) => box [string "JavaScript(",
+ p_exp env e,
+ string ")"]
+ | EJavaScript (_, _, SOME e) => p_exp env e
| ESignalReturn e => box [string "Return(",
p_exp env e,
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 072c548e..c96f97cf 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -76,7 +76,7 @@ fun impure (e, _) =
| ELet (_, _, e1, e2) => impure e1 orelse impure e2
| EClosure (_, es) => List.exists impure es
- | EJavaScript (_, e) => impure e
+ | EJavaScript (_, e, _) => impure e
| ESignalReturn e => impure e
| ESignalBind (e1, e2) => impure e1 orelse impure e2
| ESignalSource e => impure e
@@ -335,7 +335,7 @@ fun reduce file =
| EDml e => summarize d e @ [WriteDb]
| ENextval e => summarize d e @ [WriteDb]
| EUnurlify (e, _) => summarize d e
- | EJavaScript (_, e) => summarize d e
+ | EJavaScript (_, e, _) => summarize d e
| ESignalReturn e => summarize d e
| ESignalBind (e1, e2) => summarize d e1 @ summarize d e2
| ESignalSource e => summarize d e
diff --git a/src/mono_util.sml b/src/mono_util.sml
index 3f9183d0..9ce3293b 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -324,10 +324,16 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
S.map2 (mft t,
fn t' =>
(EUnurlify (e', t'), loc)))
- | EJavaScript (m, e) =>
+ | EJavaScript (m, e, NONE) =>
S.map2 (mfe ctx e,
fn e' =>
- (EJavaScript (m, e'), loc))
+ (EJavaScript (m, e', NONE), loc))
+ | EJavaScript (m, e, SOME e2) =>
+ S.bind2 (mfe ctx e,
+ fn e' =>
+ S.map2 (mfe ctx e2,
+ fn e2' =>
+ (EJavaScript (m, e', SOME e2'), loc)))
| ESignalReturn e =>
S.map2 (mfe ctx e,
diff --git a/src/monoize.sml b/src/monoize.sml
index f40d49d0..f62848c5 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -976,7 +976,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
((L'.EAbs ("x", t, (L'.TFun ((L'.TRecord [], loc), (L'.TSource, loc)), loc),
(L'.EAbs ("_", (L'.TRecord [], loc), (L'.TSource, loc),
(L'.EFfiApp ("Basis", "new_client_source",
- [(L'.EJavaScript (L'.File, (L'.ERel 1, loc)), loc)]), loc)), loc)),
+ [(L'.EJavaScript (L'.File, (L'.ERel 1, loc), NONE), loc)]),
+ loc)), loc)),
loc),
fm)
end
@@ -990,7 +991,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
(L'.EFfiApp ("Basis", "set_client_source",
[(L'.ERel 2, loc),
- (L'.EJavaScript (L'.File, (L'.ERel 1, loc)), loc)]),
+ (L'.EJavaScript (L'.File, (L'.ERel 1, loc), NONE), loc)]),
loc)), loc)), loc)), loc),
fm)
end
@@ -1801,7 +1802,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L'.EStrcat (
(L'.EPrim (Prim.String s'), loc),
(L'.EStrcat (
- (L'.EJavaScript (L'.Attribute, e), loc),
+ (L'.EJavaScript (L'.Attribute, e, NONE), loc),
(L'.EPrim (Prim.String "'"), loc)), loc)),
loc)), loc),
fm)
@@ -1887,13 +1888,12 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
| "dyn" =>
(case #1 attrs of
- (*L'.ERecord [("Signal", (L'.EApp ((L'.EAbs (_, _, _, (L'.ESignalReturn (L'.ERel 0, _), _)), _),
- e), _), _)] => (e, fm) *)
-
- L'.ERecord [("Signal", e, _)] =>
+ L'.ERecord [("Signal", (L'.EApp ((L'.EAbs (_, _, _, (L'.ESignalReturn (L'.ERel 0, _), _)), _),
+ e), _), _)] => (e, fm)
+ | L'.ERecord [("Signal", e, _)] =>
((L'.EStrcat
((L'.EPrim (Prim.String ""), loc)), loc)), loc),
fm)
| _ => raise Fail "Monoize: Bad dyn attributes")
--
cgit v1.2.3
From e27335a18e8f4b1cca2749e8d41863b3cbef9b62 Mon Sep 17 00:00:00 2001
From: Adam Chlipala
Date: Sun, 15 Feb 2009 09:27:36 -0500
Subject: Export RPC functions and push RPC calls through to Mono
---
src/cjr_print.sml | 2 ++
src/cjrize.sml | 2 ++
src/core.sml | 1 +
src/core_print.sml | 1 +
src/jscomp.sml | 4 ++++
src/mono.sml | 2 ++
src/mono_print.sml | 9 +++++++++
src/mono_reduce.sml | 3 +++
src/mono_util.sml | 7 +++++++
src/monoize.sml | 8 +++++++-
src/rpcify.sml | 47 +++++++++++++++++++++++++++++++++++------------
11 files changed, 73 insertions(+), 13 deletions(-)
(limited to 'src/cjrize.sml')
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index f8b1f23b..8f5c8551 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -1849,6 +1849,7 @@ fun p_file env (ds, ps) =
val fields = foldl (fn ((ek, _, _, ts), fields) =>
case ek of
Core.Link => fields
+ | Core.Rpc => fields
| Core.Action =>
case List.nth (ts, length ts - 2) of
(TRecord i, _) =>
@@ -1971,6 +1972,7 @@ 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 =>
case List.nth (ts, length ts - 2) of
(TRecord i, _) =>
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 1a5d10c0..77674158 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -429,6 +429,8 @@ fun cifyExp (eAll as (e, loc), sm) =
| L.ESignalBind _ => raise Fail "Cjrize: ESignalBind remains"
| L.ESignalSource _ => raise Fail "Cjrize: ESignalSource remains"
+ | L.EServerCall _ => raise Fail "Cjrize EServerCall"
+
fun cifyDecl ((d, loc), sm) =
case d of
L.DDatatype (x, n, xncs) =>
diff --git a/src/core.sml b/src/core.sml
index fbe150c1..62f046fe 100644
--- a/src/core.sml
+++ b/src/core.sml
@@ -113,6 +113,7 @@ withtype exp = exp' located
datatype export_kind =
Link
| Action
+ | Rpc
datatype decl' =
DCon of string * int * kind * con
diff --git a/src/core_print.sml b/src/core_print.sml
index 64cead70..e9a36fbb 100644
--- a/src/core_print.sml
+++ b/src/core_print.sml
@@ -436,6 +436,7 @@ fun p_export_kind ck =
case ck of
Link => string "link"
| Action => string "action"
+ | Rpc => string "rpc"
fun p_datatype env (x, n, xs, cons) =
let
diff --git a/src/jscomp.sml b/src/jscomp.sml
index f61ec3f0..627ba8f6 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -98,6 +98,7 @@ fun varDepth (e, _) =
| 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)
fun closedUpto d =
let
@@ -138,6 +139,7 @@ fun closedUpto d =
| 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
in
cu 0
end
@@ -809,6 +811,8 @@ fun process file =
str ")"],
st)
end
+
+ | EServerCall _ => raise Fail "Jscomp EServerCall"
end
in
jsE
diff --git a/src/mono.sml b/src/mono.sml
index 8999704c..547f8a55 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -109,6 +109,8 @@ datatype exp' =
| ESignalBind of exp * exp
| ESignalSource of exp
+ | EServerCall of int * exp list * exp
+
withtype exp = exp' located
datatype decl' =
diff --git a/src/mono_print.sml b/src/mono_print.sml
index 1e9de3d8..a859a1bd 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -308,6 +308,15 @@ fun p_exp' par env (e, _) =
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
fun p_vali env (x, n, t, e, s) =
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 878fec92..7d39648a 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -81,6 +81,7 @@ fun impure (e, _) =
| ESignalReturn e => impure e
| ESignalBind (e1, e2) => impure e1 orelse impure e2
| ESignalSource e => impure e
+ | EServerCall _ => true
val liftExpInExp = Monoize.liftExpInExp
@@ -344,6 +345,8 @@ fun reduce file =
| ESignalReturn e => summarize d e
| 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]
in
(*Print.prefaces "Summarize"
[("e", MonoPrint.p_exp MonoEnv.empty (e, ErrorMsg.dummySpan)),
diff --git a/src/mono_util.sml b/src/mono_util.sml
index 9ce3293b..13e0d32c 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -349,6 +349,13 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
S.map2 (mfe ctx e,
fn e' =>
(ESignalSource e', loc))
+
+ | EServerCall (n, es, ek) =>
+ S.bind2 (ListUtil.mapfold (fn e => mfe ctx e) es,
+ fn es' =>
+ S.map2 (mfe ctx ek,
+ fn ek' =>
+ (EServerCall (n, es', ek'), loc)))
in
mfe
end
diff --git a/src/monoize.sml b/src/monoize.sml
index a1f61143..fb1ac2f1 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -2225,7 +2225,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
((L'.ELet (x, t', e1, e2), loc), fm)
end
- | L.EServerCall _ => raise Fail "Monoize EServerCall"
+ | L.EServerCall (n, es, ek) =>
+ let
+ val (es, fm) = ListUtil.foldlMap (fn (e, fm) => monoExp (env, st, fm) e) fm es
+ val (ek, fm) = monoExp (env, st, fm) ek
+ in
+ ((L'.EServerCall (n, es, ek), loc), fm)
+ end
end
fun monoDecl (env, fm) (all as (d, loc)) =
diff --git a/src/rpcify.sml b/src/rpcify.sml
index dec8dc18..09c44a7a 100644
--- a/src/rpcify.sml
+++ b/src/rpcify.sml
@@ -53,8 +53,11 @@ val csBasis = SS.addList (SS.empty,
"alert"])
type state = {
- exps : int IM.map,
- decls : (string * int * con * exp * string) list
+ cpsed : int IM.map,
+ cps_decls : (string * int * con * exp * string) list,
+
+ exported : IS.set,
+ export_decls : decl list
}
fun frob file =
@@ -114,6 +117,19 @@ fun frob file =
(0, []))
val (n, args) = getApp (trans1, [])
+
+ val (exported, export_decls) =
+ if IS.member (#exported st, n) then
+ (#exported st, #export_decls st)
+ else
+ (IS.add (#exported st, n),
+ (DExport (Rpc, n), loc) :: #export_decls st)
+
+ val st = {cpsed = #cpsed st,
+ cps_decls = #cps_decls st,
+
+ exported = exported,
+ export_decls = export_decls}
in
(EServerCall (n, args, trans2), st)
end
@@ -128,19 +144,26 @@ fun frob file =
decl = fn x => x}
st d
in
- (case #decls st of
- [] => [d]
- | ds =>
- case d of
- (DValRec vis, loc) => [(DValRec (ds @ vis), loc)]
- | (_, loc) => [(DValRec ds, loc), d],
- {decls = [],
- exps = #exps st})
+ (List.revAppend (case #cps_decls st of
+ [] => [d]
+ | ds =>
+ case d of
+ (DValRec vis, loc) => [(DValRec (ds @ vis), loc)]
+ | (_, loc) => [d, (DValRec ds, loc)],
+ #export_decls st),
+ {cpsed = #cpsed st,
+ cps_decls = [],
+
+ exported = #exported st,
+ export_decls = []})
end
val (file, _) = ListUtil.foldlMapConcat decl
- {decls = [],
- exps = IM.empty}
+ {cpsed = IM.empty,
+ cps_decls = [],
+
+ exported = IS.empty,
+ export_decls = []}
file
in
file
--
cgit v1.2.3
From 1557ac806159fe58eaa442527f73e569dd04f88e Mon Sep 17 00:00:00 2001
From: Adam Chlipala
Date: Sun, 15 Feb 2009 10:32:50 -0500
Subject: First gimpy RPC
---
lib/js/urweb.js | 29 +++++++++++++++++++++++++++++
src/cjr.sml | 2 +-
src/cjr_print.sml | 32 ++++++++++++++++++++++----------
src/cjrize.sml | 5 +++--
src/core.sml | 2 +-
src/core_print.sml | 16 ++++++++--------
src/core_util.sml | 10 ++++++----
src/jscomp.sml | 14 +++++++++++---
src/mono.sml | 4 ++--
src/mono_print.sml | 46 +++++++++++++++++++++++++---------------------
src/mono_reduce.sml | 2 +-
src/mono_shake.sml | 2 +-
src/mono_util.sml | 16 ++++++++++------
src/monoize.sml | 38 ++++++++++++++++++++++++++++----------
src/pathcheck.sml | 2 +-
src/reduce.sml | 2 +-
src/reduce_local.sml | 2 +-
src/rpcify.sml | 30 +++++++++++++++++++++++++++++-
src/shake.sml | 2 +-
tests/rpc.ur | 4 +++-
tests/rpc.urp | 2 +-
21 files changed, 185 insertions(+), 77 deletions(-)
(limited to 'src/cjrize.sml')
diff --git a/lib/js/urweb.js b/lib/js/urweb.js
index c46263b8..9dd4dbbe 100644
--- a/lib/js/urweb.js
+++ b/lib/js/urweb.js
@@ -111,3 +111,32 @@ function cr(n) {
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);
+}
diff --git a/src/cjr.sml b/src/cjr.sml
index 43a29a6c..a38a1b0d 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -113,6 +113,6 @@ datatype decl' =
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
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 8f5c8551..6074ca3b 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -1846,7 +1846,7 @@ fun p_file env (ds, ps) =
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 @@ fun p_file env (ds, ps) =
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 @@ fun p_file env (ds, ps) =
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, \"\");",
- 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, \"\");",
+ newline]),
box [string "{",
newline,
box (ListUtil.mapi (fn (i, t) => box [p_typ env t,
@@ -2073,6 +2075,14 @@ fun p_file env (ds, ps) =
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 @@ fun p_file env (ds, ps) =
inputsVar,
string ", uw_unit_v);",
newline,
- string "uw_write(ctx, \"\");",
- newline,
+ box (case ek of
+ Core.Rpc => []
+ | _ => [string "uw_write(ctx, \"\");",
+ newline]),
string "return;",
newline,
string "}",
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 77674158..16a82ec8 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -514,11 +514,12 @@ fun cifyDecl ((d, loc), sm) =
(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) =>
diff --git a/src/core.sml b/src/core.sml
index 62f046fe..c6e0cfef 100644
--- a/src/core.sml
+++ b/src/core.sml
@@ -106,7 +106,7 @@ datatype exp' =
| ELet of string * con * exp * exp
- | EServerCall of int * exp list * exp
+ | EServerCall of int * exp list * exp * con
withtype exp = exp' located
diff --git a/src/core_print.sml b/src/core_print.sml
index e9a36fbb..405ae14e 100644
--- a/src/core_print.sml
+++ b/src/core_print.sml
@@ -394,14 +394,14 @@ fun p_exp' par env (e, _) =
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
diff --git a/src/core_util.sml b/src/core_util.sml
index 3d6808f9..a222dca4 100644
--- a/src/core_util.sml
+++ b/src/core_util.sml
@@ -482,7 +482,7 @@ fun compare ((e1, _), (e2, _)) =
| (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 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} =
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
diff --git a/src/jscomp.sml b/src/jscomp.sml
index 627ba8f6..de671fef 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -98,7 +98,7 @@ fun varDepth (e, _) =
| 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 @@ fun closedUpto d =
| 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 @@ fun process file =
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
diff --git a/src/mono.sml b/src/mono.sml
index 547f8a55..ea2b9720 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -109,7 +109,7 @@ datatype exp' =
| 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 @@ 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
+ | DExport of Core.export_kind * string * int * typ list * typ
| DTable of string * (string * typ) list
| DSequence of string
diff --git a/src/mono_print.sml b/src/mono_print.sml
index a859a1bd..ba4c57f1 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -308,14 +308,14 @@ fun p_exp' par env (e, _) =
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 @@ fun p_decl env (dAll as (d, _) : decl) =
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,
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 7d39648a..2d0412fd 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -346,7 +346,7 @@ fun reduce file =
| 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)),
diff --git a/src/mono_shake.sml b/src/mono_shake.sml
index 34bd98be..4fd3caeb 100644
--- a/src/mono_shake.sml
+++ b/src/mono_shake.sml
@@ -44,7 +44,7 @@ type free = {
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)) =>
diff --git a/src/mono_util.sml b/src/mono_util.sml
index 13e0d32c..d1157218 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -350,12 +350,14 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
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 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} =
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
diff --git a/src/monoize.sml b/src/monoize.sml
index fb1ac2f1..43c3f47d 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -2225,12 +2225,28 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
((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
- in
- ((L'.EServerCall (n, es, ek), loc), fm)
+
+ 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 (name, es, ek, t), loc), fm)
end
end
@@ -2280,16 +2296,18 @@ fun monoDecl (env, fm) (all as (d, loc)) =
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
diff --git a/src/pathcheck.sml b/src/pathcheck.sml
index ed6a4124..036d286f 100644
--- a/src/pathcheck.sml
+++ b/src/pathcheck.sml
@@ -46,7 +46,7 @@ fun checkDecl ((d, loc), (funcs, rels)) =
(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
diff --git a/src/reduce.sml b/src/reduce.sml
index 89fce664..b428c01f 100644
--- a/src/reduce.sml
+++ b/src/reduce.sml
@@ -368,7 +368,7 @@ fun conAndExp (namedC, namedE) =
| 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
diff --git a/src/reduce_local.sml b/src/reduce_local.sml
index 55bb5198..7de7d799 100644
--- a/src/reduce_local.sml
+++ b/src/reduce_local.sml
@@ -131,7 +131,7 @@ fun exp env (all as (e, loc)) =
| 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
diff --git a/src/rpcify.sml b/src/rpcify.sml
index 09c44a7a..45d178ee 100644
--- a/src/rpcify.sml
+++ b/src/rpcify.sml
@@ -98,6 +98,29 @@ fun frob file =
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 @@ fun frob file =
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)
diff --git a/src/shake.sml b/src/shake.sml
index 58c1d2c6..4df64efa 100644
--- a/src/shake.sml
+++ b/src/shake.sml
@@ -116,7 +116,7 @@ fun shake file =
in
case e of
ENamed n => check n
- | EServerCall (n, _, _) => check n
+ | EServerCall (n, _, _, _) => check n
| _ => s
end
diff --git a/tests/rpc.ur b/tests/rpc.ur
index 85191229..b2e9722c 100644
--- a/tests/rpc.ur
+++ b/tests/rpc.ur
@@ -8,6 +8,8 @@ fun main () : transaction page =
return
+ set s n}/>
+
+ Current: {[n]}}/>
end
diff --git a/tests/rpc.urp b/tests/rpc.urp
index 16b72b8b..02fd0f2b 100644
--- a/tests/rpc.urp
+++ b/tests/rpc.urp
@@ -1,5 +1,5 @@
debug
sql rpc.sql
-database rpc
+database dbname=rpc
rpc
--
cgit v1.2.3
From b691dfb678a18667a623b45111683c480476051b Mon Sep 17 00:00:00 2001
From: Adam Chlipala
Date: Sun, 8 Mar 2009 13:28:21 -0400
Subject: RPC returning a default datatype
---
src/cjr_print.sml | 151 +++++++++++++++++++++++++-----------------------------
src/cjrize.sml | 11 ++--
tests/rpcDD.ur | 26 ++++++++++
tests/rpcDD.urp | 5 ++
4 files changed, 109 insertions(+), 84 deletions(-)
create mode 100644 tests/rpcDD.ur
create mode 100644 tests/rpcDD.urp
(limited to 'src/cjrize.sml')
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 630f9f7c..73024aa5 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -1004,11 +1004,14 @@ fun urlify env t =
newline]
end
- | TDatatype (Default, i, _) => box []
- (*if IS.member (rf, i) then
- box [string "unurlify_",
+ | TDatatype (Default, i, _) =>
+ if IS.member (rf, i) then
+ box [string "urlify_",
string (Int.toString i),
- string "()"]
+ string "(it",
+ string (Int.toString level),
+ string ");",
+ newline]
else
let
val (x, xncs) = E.lookupDatatype env i
@@ -1017,87 +1020,72 @@ fun urlify env t =
fun doEm xncs =
case xncs of
- [] => string ("(uw_error(ctx, FATAL, \"Error unurlifying datatype "
- ^ x ^ "\"), NULL)")
+ [] => box [string ("uw_error(ctx, FATAL, \"Error urlifying datatype "
+ ^ x ^ " (%d)\", it0->data);"),
+ newline]
| (x', n, to) :: rest =>
- box [string "((!strncmp(request, \"",
- string x',
- string "\", ",
- string (Int.toString (size x')),
- string ") && (request[",
- string (Int.toString (size x')),
- string "] == 0 || request[",
- string (Int.toString (size x')),
- string "] == '/')) ? ({",
- newline,
- string "struct",
+ box [string "if",
space,
- string ("__uwd_" ^ ident x ^ "_" ^ Int.toString i),
- space,
- string "*tmp = uw_malloc(ctx, sizeof(struct __uwd_",
- string x,
+ string "(it0->tag==__uwc_",
+ string (ident x'),
string "_",
- string (Int.toString i),
- string "));",
- newline,
- string "tmp->tag",
- space,
- string "=",
- space,
- string ("__uwc_" ^ ident x' ^ "_" ^ Int.toString n),
- string ";",
- newline,
- string "request",
- space,
- string "+=",
- space,
- string (Int.toString (size x')),
- string ";",
- newline,
- string "if (request[0] == '/') ++request;",
+ string (Int.toString n),
+ string ") {",
newline,
case to of
- NONE => box []
- | SOME (t, _) => box [string "tmp->data.uw_",
- p_ident x',
- space,
- string "=",
- space,
- unurlify' rf t,
- string ";",
- newline],
- string "tmp;",
+ NONE => box [string "uw_write(ctx, \"",
+ string x',
+ string "\");",
+ newline]
+ | SOME t => box [string "uw_write(ctx, \"",
+ string x',
+ string "/\");",
+ newline,
+ p_typ env t,
+ space,
+ string "it1",
+ space,
+ string "=",
+ space,
+ string "it0->data.uw_",
+ string x',
+ string ";",
+ newline,
+ urlify' rf 1 t,
+ newline],
+ string "} else {",
newline,
- string "})",
- space,
- string ":",
- space,
- doEm rest,
- string ")"]
+ box [doEm rest,
+ newline],
+ string "}",
+ newline]
in
box [string "({",
space,
- p_typ env (t, ErrorMsg.dummySpan),
+ string "void",
space,
- string "unurlify_",
+ string "urlify_",
string (Int.toString i),
- string "(void) {",
+ string "(",
+ p_typ env t,
+ space,
+ string "it0) {",
newline,
- box [string "return",
- space,
- doEm xncs,
- string ";",
+ box [doEm xncs,
newline],
- string "}",
newline,
+ string "}",
newline,
- string "unurlify_",
+ string "urlify_",
string (Int.toString i),
- string "();",
+ string "(it",
+ string (Int.toString level),
+ string ");",
newline,
- string "})"]
- end*)
+ string "});",
+ newline]
+ end
| TOption t => box []
(*box [string "(request[0] == '/' ? ++request : request, ",
@@ -1439,8 +1427,7 @@ fun p_exp' par env (e, loc) =
val wontLeakStrings = notLeaky env true state
val wontLeakAnything = notLeaky env false state
in
- box [string "(uw_begin_region(ctx), ",
- if wontLeakAnything then
+ box [if wontLeakAnything then
string "uw_begin_region(ctx), "
else
box [],
@@ -1448,6 +1435,18 @@ fun p_exp' par env (e, loc) =
newline,
string "PGconn *conn = uw_get_db(ctx);",
newline,
+ p_typ env state,
+ space,
+ string "acc",
+ space,
+ string "=",
+ space,
+ p_exp env initial,
+ string ";",
+ newline,
+ string "int n, i, dummy = (uw_begin_region(ctx), 0);",
+ newline,
+
case prepared of
NONE => box [string "char *query = ",
p_exp env query,
@@ -1481,17 +1480,7 @@ fun p_exp' par env (e, loc) =
newline,
newline]
end,
- string "int n, i;",
- newline,
- p_typ env state,
- space,
- string "acc",
- space,
- string "=",
- space,
- p_exp env initial,
- string ";",
- newline,
+
string "PGresult *res = ",
case prepared of
NONE => string "PQexecParams(conn, query, 0, NULL, NULL, NULL, NULL, 0);"
@@ -1589,7 +1578,7 @@ fun p_exp' par env (e, loc) =
box [],
string "acc;",
newline,
- string "}))"]
+ string "})"]
end
| EDml {dml, prepared} =>
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 16a82ec8..9d9ab36c 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -544,15 +544,20 @@ fun cjrize ds =
let
val (dop, pop, sm) = cifyDecl (d, sm)
+ val dsF = case dop of
+ SOME (L'.DDatatype (dk, x, n, _), loc) =>
+ (L'.DDatatypeForward (dk, x, n), loc) :: dsF
+ | _ => dsF
+
+ val dsF = map (fn v => (L'.DStruct v, ErrorMsg.dummySpan)) (Sm.declares sm)
+ @ dsF
+
val (dsF, ds) = case dop of
NONE => (dsF, ds)
| SOME (d as (L'.DDatatype _, loc)) =>
(d :: dsF, ds)
| SOME d => (dsF, d :: ds)
- val dsF = map (fn v => (L'.DStruct v, ErrorMsg.dummySpan)) (Sm.declares sm)
- @ dsF
-
val ps = case pop of
NONE => ps
| SOME p => p :: ps
diff --git a/tests/rpcDD.ur b/tests/rpcDD.ur
new file mode 100644
index 00000000..13293b83
--- /dev/null
+++ b/tests/rpcDD.ur
@@ -0,0 +1,26 @@
+datatype list t = Nil | OtherNil | Cons of t * list t
+
+table t : {A : int}
+
+fun main () : transaction page =
+ let
+ fun rows () =
+ query (SELECT * FROM t)
+ (fn r ls => return (Cons (r.T.A, ls)))
+ Nil
+
+ fun show ls =
+ case ls of
+ Nil =>
+ | OtherNil => That's impossible!
+ | Cons (x, ls') => {[x]}
{show ls'}
+ in
+ s <- source Nil;
+ return
+
+
+ Current:
+
+ end
diff --git a/tests/rpcDD.urp b/tests/rpcDD.urp
new file mode 100644
index 00000000..118ea723
--- /dev/null
+++ b/tests/rpcDD.urp
@@ -0,0 +1,5 @@
+debug
+sql rpcDD.sql
+database dbname=rpcdd
+
+rpcDD
--
cgit v1.2.3
From db7cd221444afce64803e66594d56dc8e7a0843c Mon Sep 17 00:00:00 2001
From: Adam Chlipala
Date: Tue, 10 Mar 2009 10:44:26 -0400
Subject: Avoid any JavaScript when pages don't need it; update demo prose
---
demo/metaform.ur | 6 +--
demo/metaform.urs | 2 +-
demo/prose | 29 ++++++++++---
demo/ref.ur | 4 +-
demo/sql.urp | 1 -
demo/sum.ur | 2 +-
demo/tcSum.ur | 2 +-
demo/tree.urp | 1 -
include/urweb.h | 1 +
lib/ur/top.ur | 6 +--
lib/ur/top.urs | 8 ++--
src/c/urweb.c | 12 ++++-
src/cjr.sml | 6 ++-
src/cjr_print.sml | 12 +++--
src/cjrize.sml | 2 +-
src/compiler.sig | 2 +
src/compiler.sml | 9 +++-
src/monoize.sml | 4 +-
src/scriptcheck.sig | 32 ++++++++++++++
src/scriptcheck.sml | 123 ++++++++++++++++++++++++++++++++++++++++++++++++++++
src/sources | 3 ++
21 files changed, 232 insertions(+), 35 deletions(-)
create mode 100644 src/scriptcheck.sig
create mode 100644 src/scriptcheck.sml
(limited to 'src/cjrize.sml')
diff --git a/demo/metaform.ur b/demo/metaform.ur
index 0e2e5ee3..26462215 100644
--- a/demo/metaform.ur
+++ b/demo/metaform.ur
@@ -1,7 +1,7 @@
functor Make (M : sig
con fs :: {Unit}
val fl : folder fs
- val names : $(mapUT string fs)
+ val names : $(mapU string fs)
end) = struct
fun handler values = return
@@ -14,9 +14,9 @@ functor Make (M : sig
fun main () = return
+
+fun main () =
+ x <- source ;
+ return
+
+
+
diff --git a/tests/rs.urs b/tests/rs.urs
new file mode 100644
index 00000000..6ac44e0b
--- /dev/null
+++ b/tests/rs.urs
@@ -0,0 +1 @@
+val main : unit -> transaction page
--
cgit v1.2.3
From 9a047b4f248ace0615eaf18ba130e14e49634723 Mon Sep 17 00:00:00 2001
From: Adam Chlipala
Date: Sat, 19 Nov 2011 10:26:19 -0500
Subject: Better error messages when client-side constructs are detected in
Cjrize
---
src/cjrize.sml | 446 ++++++++++++++++++++++++++++----------------------------
tests/badRpc.ur | 5 +
2 files changed, 231 insertions(+), 220 deletions(-)
create mode 100644 tests/badRpc.ur
(limited to 'src/cjrize.sml')
diff --git a/src/cjrize.sml b/src/cjrize.sml
index b48a4ebd..2b46c32d 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -237,106 +237,111 @@ fun cifyPat ((p, loc), sm) =
end
fun cifyExp (eAll as (e, loc), sm) =
- case e of
- L.EPrim p => ((L'.EPrim p, loc), sm)
- | L.ERel n => ((L'.ERel n, loc), sm)
- | L.ENamed n => ((L'.ENamed n, loc), sm)
- | L.ECon (dk, pc, eo) =>
- let
- val (eo, sm) =
- case eo of
- NONE => (NONE, sm)
- | SOME e =>
- let
- val (e, sm) = cifyExp (e, sm)
- in
- (SOME e, sm)
- end
- val (pc, sm) = cifyPatCon (pc, sm)
- in
- ((L'.ECon (dk, pc, eo), loc), sm)
- end
- | L.ENone t =>
- let
- val (t, sm) = cifyTyp (t, sm)
- in
- ((L'.ENone t, loc), sm)
- end
- | L.ESome (t, e) =>
- let
- val (t, sm) = cifyTyp (t, sm)
- val (e, sm) = cifyExp (e, sm)
- in
- ((L'.ESome (t, e), loc), sm)
- end
- | L.EFfi mx => ((L'.EFfi mx, loc), sm)
- | L.EFfiApp (m, x, es) =>
- let
- val (es, sm) = ListUtil.foldlMap cifyExp sm es
- in
- ((L'.EFfiApp (m, x, es), loc), sm)
- end
- | L.EApp (e1, e2) =>
- let
- fun unravel (e, args) =
- case e of
- (L.EApp (e1, e2), _) => unravel (e1, e2 :: args)
- | _ => (e, args)
+ let
+ fun fail msg =
+ (ErrorMsg.errorAt loc msg;
+ ((L'.EPrim (Prim.String ""), loc), sm))
+ in
+ case e of
+ L.EPrim p => ((L'.EPrim p, loc), sm)
+ | L.ERel n => ((L'.ERel n, loc), sm)
+ | L.ENamed n => ((L'.ENamed n, loc), sm)
+ | L.ECon (dk, pc, eo) =>
+ let
+ val (eo, sm) =
+ case eo of
+ NONE => (NONE, sm)
+ | SOME e =>
+ let
+ val (e, sm) = cifyExp (e, sm)
+ in
+ (SOME e, sm)
+ end
+ val (pc, sm) = cifyPatCon (pc, sm)
+ in
+ ((L'.ECon (dk, pc, eo), loc), sm)
+ end
+ | L.ENone t =>
+ let
+ val (t, sm) = cifyTyp (t, sm)
+ in
+ ((L'.ENone t, loc), sm)
+ end
+ | L.ESome (t, e) =>
+ let
+ val (t, sm) = cifyTyp (t, sm)
+ val (e, sm) = cifyExp (e, sm)
+ in
+ ((L'.ESome (t, e), loc), sm)
+ end
+ | L.EFfi mx => ((L'.EFfi mx, loc), sm)
+ | L.EFfiApp (m, x, es) =>
+ let
+ val (es, sm) = ListUtil.foldlMap cifyExp sm es
+ in
+ ((L'.EFfiApp (m, x, es), loc), sm)
+ end
+ | L.EApp (e1, e2) =>
+ let
+ fun unravel (e, args) =
+ case e of
+ (L.EApp (e1, e2), _) => unravel (e1, e2 :: args)
+ | _ => (e, args)
- val (f, es) = unravel (e1, [e2])
+ val (f, es) = unravel (e1, [e2])
- val (f, sm) = cifyExp (f, sm)
- val (es, sm) = ListUtil.foldlMap cifyExp sm es
- in
- ((L'.EApp (f, es), loc), sm)
- end
- | L.EAbs _ => (ErrorMsg.errorAt loc "Anonymous function remains at code generation";
- Print.prefaces' [("Function", MonoPrint.p_exp MonoEnv.empty eAll)];
- (dummye, sm))
+ val (f, sm) = cifyExp (f, sm)
+ val (es, sm) = ListUtil.foldlMap cifyExp sm es
+ in
+ ((L'.EApp (f, es), loc), sm)
+ end
+ | L.EAbs _ => (ErrorMsg.errorAt loc "Anonymous function remains at code generation";
+ Print.prefaces' [("Function", MonoPrint.p_exp MonoEnv.empty eAll)];
+ (dummye, sm))
- | L.EUnop (s, e1) =>
- let
- val (e1, sm) = cifyExp (e1, sm)
- in
- ((L'.EUnop (s, e1), loc), sm)
- end
- | L.EBinop (_, s, e1, e2) =>
- let
- val (e1, sm) = cifyExp (e1, sm)
- val (e2, sm) = cifyExp (e2, sm)
- in
- ((L'.EBinop (s, e1, e2), loc), sm)
- end
+ | L.EUnop (s, e1) =>
+ let
+ val (e1, sm) = cifyExp (e1, sm)
+ in
+ ((L'.EUnop (s, e1), loc), sm)
+ end
+ | L.EBinop (_, s, e1, e2) =>
+ let
+ val (e1, sm) = cifyExp (e1, sm)
+ val (e2, sm) = cifyExp (e2, sm)
+ in
+ ((L'.EBinop (s, e1, e2), loc), sm)
+ end
- | L.ERecord xes =>
- let
- val old_xts = map (fn (x, _, t) => (x, t)) xes
+ | L.ERecord xes =>
+ let
+ val old_xts = map (fn (x, _, t) => (x, t)) xes
- val (xets, sm) = ListUtil.foldlMap (fn ((x, e, t), sm) =>
- let
- val (e, sm) = cifyExp (e, sm)
- val (t, sm) = cifyTyp (t, sm)
- in
- ((x, e, t), sm)
- end)
- sm xes
+ val (xets, sm) = ListUtil.foldlMap (fn ((x, e, t), sm) =>
+ let
+ val (e, sm) = cifyExp (e, sm)
+ val (t, sm) = cifyTyp (t, sm)
+ in
+ ((x, e, t), sm)
+ end)
+ sm xes
- val (sm, si) = Sm.find (sm, old_xts, map (fn (x, _, t) => (x, t)) xets)
+ val (sm, si) = Sm.find (sm, old_xts, map (fn (x, _, t) => (x, t)) xets)
- val xes = map (fn (x, e, _) => (x, e)) xets
- val xes = ListMergeSort.sort (fn ((x1, _), (x2, _)) => String.compare (x1, x2) = GREATER) xes
- in
- ((L'.ERecord (si, xes), loc), sm)
- end
- | L.EField (e, x) =>
- let
- val (e, sm) = cifyExp (e, sm)
- in
- ((L'.EField (e, x), loc), sm)
- end
+ val xes = map (fn (x, e, _) => (x, e)) xets
+ val xes = ListMergeSort.sort (fn ((x1, _), (x2, _)) => String.compare (x1, x2) = GREATER) xes
+ in
+ ((L'.ERecord (si, xes), loc), sm)
+ end
+ | L.EField (e, x) =>
+ let
+ val (e, sm) = cifyExp (e, sm)
+ in
+ ((L'.EField (e, x), loc), sm)
+ end
- | L.ECase (e, pes, {disc, result}) =>
- let
+ | L.ECase (e, pes, {disc, result}) =>
+ let
val (e, sm) = cifyExp (e, sm)
val (pes, sm) = ListUtil.foldlMap
(fn ((p, e), sm) =>
@@ -352,148 +357,149 @@ fun cifyExp (eAll as (e, loc), sm) =
((L'.ECase (e, pes, {disc = disc, result = result}), loc), sm)
end
- | L.EError (e, t) =>
- let
- val (e, sm) = cifyExp (e, sm)
- val (t, sm) = cifyTyp (t, sm)
- in
- ((L'.EError (e, t), loc), sm)
- end
- | L.EReturnBlob {blob, mimeType, t} =>
- let
- val (blob, sm) = cifyExp (blob, sm)
- val (mimeType, sm) = cifyExp (mimeType, sm)
- val (t, sm) = cifyTyp (t, sm)
- in
- ((L'.EReturnBlob {blob = blob, mimeType = mimeType, t = t}, loc), sm)
- end
- | L.ERedirect (e, t) =>
- let
- val (e, sm) = cifyExp (e, sm)
- val (t, sm) = cifyTyp (t, sm)
- in
- ((L'.ERedirect (e, t), loc), sm)
- end
+ | L.EError (e, t) =>
+ let
+ val (e, sm) = cifyExp (e, sm)
+ val (t, sm) = cifyTyp (t, sm)
+ in
+ ((L'.EError (e, t), loc), sm)
+ end
+ | L.EReturnBlob {blob, mimeType, t} =>
+ let
+ val (blob, sm) = cifyExp (blob, sm)
+ val (mimeType, sm) = cifyExp (mimeType, sm)
+ val (t, sm) = cifyTyp (t, sm)
+ in
+ ((L'.EReturnBlob {blob = blob, mimeType = mimeType, t = t}, loc), sm)
+ end
+ | L.ERedirect (e, t) =>
+ let
+ val (e, sm) = cifyExp (e, sm)
+ val (t, sm) = cifyTyp (t, sm)
+ in
+ ((L'.ERedirect (e, t), loc), sm)
+ end
- | L.EStrcat (e1, e2) =>
- let
- val (e1, sm) = cifyExp (e1, sm)
- val (e2, sm) = cifyExp (e2, sm)
- in
- ((L'.EFfiApp ("Basis", "strcat", [e1, e2]), loc), sm)
- end
+ | L.EStrcat (e1, e2) =>
+ let
+ val (e1, sm) = cifyExp (e1, sm)
+ val (e2, sm) = cifyExp (e2, sm)
+ in
+ ((L'.EFfiApp ("Basis", "strcat", [e1, e2]), loc), sm)
+ end
- | L.EWrite e =>
- let
- val (e, sm) = cifyExp (e, sm)
- in
- ((L'.EWrite e, loc), sm)
- end
+ | L.EWrite e =>
+ let
+ val (e, sm) = cifyExp (e, sm)
+ in
+ ((L'.EWrite e, loc), sm)
+ end
- | L.ESeq (e1, e2) =>
- let
- val (e1, sm) = cifyExp (e1, sm)
- val (e2, sm) = cifyExp (e2, sm)
- in
- ((L'.ESeq (e1, e2), loc), sm)
- end
+ | L.ESeq (e1, e2) =>
+ let
+ val (e1, sm) = cifyExp (e1, sm)
+ val (e2, sm) = cifyExp (e2, sm)
+ in
+ ((L'.ESeq (e1, e2), loc), sm)
+ end
- | L.ELet (x, t, e1, e2) =>
- let
- val (t, sm) = cifyTyp (t, sm)
- val (e1, sm) = cifyExp (e1, sm)
- val (e2, sm) = cifyExp (e2, sm)
- in
- ((L'.ELet (x, t, e1, e2), loc), sm)
- end
+ | L.ELet (x, t, e1, e2) =>
+ let
+ val (t, sm) = cifyTyp (t, sm)
+ val (e1, sm) = cifyExp (e1, sm)
+ val (e2, sm) = cifyExp (e2, sm)
+ in
+ ((L'.ELet (x, t, e1, e2), loc), sm)
+ end
- | L.EClosure _ => (ErrorMsg.errorAt loc "Nested closure remains in code generation";
- (dummye, sm))
+ | L.EClosure _ => (ErrorMsg.errorAt loc "Nested closure remains in code generation";
+ (dummye, sm))
- | L.EQuery {exps, tables, state, query, body, initial} =>
- let
- val (exps', sm) = ListUtil.foldlMap (fn ((x, t), sm) =>
- let
- val (t, sm) = cifyTyp (t, sm)
- in
- ((x, t), sm)
- end) sm exps
- val (tables', sm) = ListUtil.foldlMap (fn ((x, xts), sm) =>
- let
- val (xts, sm) = ListUtil.foldlMap
- (fn ((x, t), sm) =>
- let
- val (t, sm) = cifyTyp (t, sm)
- in
- ((x, t), sm)
- end) sm xts
- in
- ((x, xts), sm)
- end) sm tables
-
- val row = exps @ map (fn (x, xts) => (x, (L.TRecord xts, loc))) tables
- val row = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) row
-
- val (tableRows, sm) = ListUtil.foldlMap (fn (((x, xts), (_, xts')), sm) =>
+ | L.EQuery {exps, tables, state, query, body, initial} =>
+ let
+ val (exps', sm) = ListUtil.foldlMap (fn ((x, t), sm) =>
let
- val (sm, rnum) = Sm.find (sm, xts, xts')
+ val (t, sm) = cifyTyp (t, sm)
in
- ((x, rnum), sm)
- end)
- sm (ListPair.zip (tables, tables'))
- val row' = exps' @ map (fn (x, n) => (x, (L'.TRecord n, loc))) tableRows
- val row' = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) row'
-
- val (sm, rnum) = Sm.find (sm, row, row')
-
- val (state, sm) = cifyTyp (state, sm)
- val (query, sm) = cifyExp (query, sm)
- val (body, sm) = cifyExp (body, sm)
- val (initial, sm) = cifyExp (initial, sm)
- in
- ((L'.EQuery {exps = exps', tables = tables', rnum = rnum, state = state,
- query = query, body = body, initial = initial, prepared = NONE}, loc), sm)
- end
+ ((x, t), sm)
+ end) sm exps
+ val (tables', sm) = ListUtil.foldlMap (fn ((x, xts), sm) =>
+ let
+ val (xts, sm) = ListUtil.foldlMap
+ (fn ((x, t), sm) =>
+ let
+ val (t, sm) = cifyTyp (t, sm)
+ in
+ ((x, t), sm)
+ end) sm xts
+ in
+ ((x, xts), sm)
+ end) sm tables
+
+ val row = exps @ map (fn (x, xts) => (x, (L.TRecord xts, loc))) tables
+ val row = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) row
+
+ val (tableRows, sm) = ListUtil.foldlMap (fn (((x, xts), (_, xts')), sm) =>
+ let
+ val (sm, rnum) = Sm.find (sm, xts, xts')
+ in
+ ((x, rnum), sm)
+ end)
+ sm (ListPair.zip (tables, tables'))
+ val row' = exps' @ map (fn (x, n) => (x, (L'.TRecord n, loc))) tableRows
+ val row' = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) row'
+
+ val (sm, rnum) = Sm.find (sm, row, row')
+
+ val (state, sm) = cifyTyp (state, sm)
+ val (query, sm) = cifyExp (query, sm)
+ val (body, sm) = cifyExp (body, sm)
+ val (initial, sm) = cifyExp (initial, sm)
+ in
+ ((L'.EQuery {exps = exps', tables = tables', rnum = rnum, state = state,
+ query = query, body = body, initial = initial, prepared = NONE}, loc), sm)
+ end
- | L.EDml (e, mode) =>
- let
- val (e, sm) = cifyExp (e, sm)
- in
- ((L'.EDml {dml = e, prepared = NONE, mode = mode}, loc), sm)
- end
+ | L.EDml (e, mode) =>
+ let
+ val (e, sm) = cifyExp (e, sm)
+ in
+ ((L'.EDml {dml = e, prepared = NONE, mode = mode}, loc), sm)
+ end
- | L.ENextval e =>
- let
- val (e, sm) = cifyExp (e, sm)
- in
- ((L'.ENextval {seq = e, prepared = NONE}, loc), sm)
- end
- | L.ESetval (e1, e2) =>
- let
- val (e1, sm) = cifyExp (e1, sm)
- val (e2, sm) = cifyExp (e2, sm)
- in
- ((L'.ESetval {seq = e1, count = e2}, loc), sm)
- end
+ | L.ENextval e =>
+ let
+ val (e, sm) = cifyExp (e, sm)
+ in
+ ((L'.ENextval {seq = e, prepared = NONE}, loc), sm)
+ end
+ | L.ESetval (e1, e2) =>
+ let
+ val (e1, sm) = cifyExp (e1, sm)
+ val (e2, sm) = cifyExp (e2, sm)
+ in
+ ((L'.ESetval {seq = e1, count = e2}, loc), sm)
+ end
- | L.EUnurlify (e, t, b) =>
- let
- val (e, sm) = cifyExp (e, sm)
- val (t, sm) = cifyTyp (t, sm)
- in
- ((L'.EUnurlify (e, t, b), loc), sm)
- end
+ | L.EUnurlify (e, t, b) =>
+ let
+ val (e, sm) = cifyExp (e, sm)
+ val (t, sm) = cifyTyp (t, sm)
+ in
+ ((L'.EUnurlify (e, t, b), loc), sm)
+ end
- | L.EJavaScript _ => raise Fail "Cjrize: EJavaScript remains"
+ | L.EJavaScript _ => fail "Uncompilable JavaScript remains"
- | L.ESignalReturn _ => raise Fail "Cjrize: ESignalReturn remains"
- | L.ESignalBind _ => raise Fail "Cjrize: ESignalBind remains"
- | L.ESignalSource _ => raise Fail "Cjrize: ESignalSource remains"
+ | L.ESignalReturn _ => fail "Signal monad 'return' remains in server-side code"
+ | L.ESignalBind _ => fail "Signal monad 'bind' remains in server-side code"
+ | L.ESignalSource _ => fail "Signal monad 'source' remains in server-side code"
- | L.EServerCall _ => raise Fail "Cjrize EServerCall"
- | L.ERecv _ => raise Fail "Cjrize ERecv"
- | L.ESleep _ => raise Fail "Cjrize ESleep"
- | L.ESpawn _ => raise Fail "Cjrize ESpawn"
+ | L.EServerCall _ => fail "RPC in server-side code"
+ | L.ERecv _ => fail "Message receive in server-side code"
+ | L.ESleep _ => fail "Sleep in server-side code"
+ | L.ESpawn _ => fail "Thread spawn in server-side code"
+ end
fun cifyDecl ((d, loc), sm) =
case d of
diff --git a/tests/badRpc.ur b/tests/badRpc.ur
new file mode 100644
index 00000000..25104134
--- /dev/null
+++ b/tests/badRpc.ur
@@ -0,0 +1,5 @@
+fun zero () = return 0
+
+fun main () : transaction page =
+ z <- rpc (zero ());
+ return {[z]}
--
cgit v1.2.3
From 09b5839acfe26561fa87c89168133fc93c1083cc Mon Sep 17 00:00:00 2001
From: Adam Chlipala
Date: Sat, 7 Jan 2012 15:56:22 -0500
Subject: First part of changes to avoid depending on C function call argument
order of evaluation (omitting normal Ur function calls, so far)
---
include/urweb.h | 8 +--
src/checknest.sml | 4 +-
src/cjr.sml | 2 +-
src/cjr_print.sml | 140 ++++++++++++++++++++++++++++++++--------------
src/cjrize.sml | 13 ++++-
src/core.sml | 2 +-
src/core_print.sml | 2 +-
src/core_util.sml | 10 +++-
src/corify.sml | 4 +-
src/css.sml | 2 +-
src/especialize.sml | 7 ++-
src/iflow.sml | 18 +++---
src/jscomp.sml | 25 +++++----
src/mono.sml | 2 +-
src/mono_opt.sml | 154 +++++++++++++++++++++++++--------------------------
src/mono_print.sml | 2 +-
src/mono_reduce.sml | 16 +++---
src/mono_util.sml | 10 +++-
src/monoize.sml | 151 +++++++++++++++++++++++++++-----------------------
src/prepare.sml | 34 +++++++-----
src/reduce.sml | 2 +-
src/reduce_local.sml | 2 +-
src/scriptcheck.sml | 8 +--
src/tag.sml | 16 +++---
24 files changed, 369 insertions(+), 265 deletions(-)
(limited to 'src/cjrize.sml')
diff --git a/include/urweb.h b/include/urweb.h
index 53f59c5a..4230da1a 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -30,7 +30,7 @@ void uw_free(uw_context);
void uw_reset(uw_context);
void uw_reset_keep_request(uw_context);
void uw_reset_keep_error_message(uw_context);
-const char *uw_get_url_prefix(uw_context);
+char *uw_get_url_prefix(uw_context);
failure_kind uw_begin_init(uw_context);
void uw_set_on_success(char *);
@@ -75,9 +75,9 @@ uw_Basis_source uw_Basis_new_client_source(uw_context, uw_Basis_string);
uw_unit uw_Basis_set_client_source(uw_context, uw_Basis_source, uw_Basis_string);
void uw_set_script_header(uw_context, const char*);
-const char *uw_Basis_get_settings(uw_context, uw_unit);
-const char *uw_Basis_get_script(uw_context, uw_unit);
-const char *uw_get_real_script(uw_context);
+char *uw_Basis_get_settings(uw_context, uw_unit);
+char *uw_Basis_get_script(uw_context, uw_unit);
+char *uw_get_real_script(uw_context);
uw_Basis_string uw_Basis_maybe_onload(uw_context, uw_Basis_string);
uw_Basis_string uw_Basis_maybe_onunload(uw_context, uw_Basis_string);
diff --git a/src/checknest.sml b/src/checknest.sml
index 1147d3e6..05ad8e9a 100644
--- a/src/checknest.sml
+++ b/src/checknest.sml
@@ -44,7 +44,7 @@ fun expUses globals =
| ENone _ => IS.empty
| ESome (_, e) => eu e
| EFfi _ => IS.empty
- | EFfiApp (_, _, es) => foldl IS.union IS.empty (map eu es)
+ | EFfiApp (_, _, es) => foldl IS.union IS.empty (map (eu o #1) es)
| EApp (e, es) => foldl IS.union (eu e) (map eu es)
| EUnop (_, e) => eu e
@@ -106,7 +106,7 @@ fun annotateExp globals =
| ENone _ => e
| ESome (t, e) => (ESome (t, ae e), loc)
| EFfi _ => e
- | EFfiApp (m, f, es) => (EFfiApp (m, f, map ae es), loc)
+ | EFfiApp (m, f, es) => (EFfiApp (m, f, map (fn (e, t) => (ae e, t)) es), loc)
| EApp (e, es) => (EApp (ae e, map ae es), loc)
| EUnop (uo, e) => (EUnop (uo, ae e), loc)
diff --git a/src/cjr.sml b/src/cjr.sml
index 7ea665ce..c348d01a 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -66,7 +66,7 @@ datatype exp' =
| ENone of typ
| ESome of typ * exp
| EFfi of string * string
- | EFfiApp of string * string * exp list
+ | EFfiApp of string * string * (exp * typ) list
| EApp of exp * exp list
| EUnop of string * exp
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 851fa02d..e69b87f1 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -490,23 +490,23 @@ fun p_sql_type t = string (Settings.p_sql_ctype t)
fun getPargs (e, _) =
case e of
EPrim (Prim.String _) => []
- | EFfiApp ("Basis", "strcat", [e1, e2]) => getPargs e1 @ getPargs e2
+ | EFfiApp ("Basis", "strcat", [(e1, _), (e2, _)]) => getPargs e1 @ getPargs e2
- | EFfiApp ("Basis", "sqlifyInt", [e]) => [(e, Int)]
- | EFfiApp ("Basis", "sqlifyFloat", [e]) => [(e, Float)]
- | EFfiApp ("Basis", "sqlifyString", [e]) => [(e, String)]
- | EFfiApp ("Basis", "sqlifyBool", [e]) => [(e, Bool)]
- | EFfiApp ("Basis", "sqlifyTime", [e]) => [(e, Time)]
- | EFfiApp ("Basis", "sqlifyBlob", [e]) => [(e, Blob)]
- | EFfiApp ("Basis", "sqlifyChannel", [e]) => [(e, Channel)]
- | EFfiApp ("Basis", "sqlifyClient", [e]) => [(e, Client)]
+ | EFfiApp ("Basis", "sqlifyInt", [(e, _)]) => [(e, Int)]
+ | EFfiApp ("Basis", "sqlifyFloat", [(e, _)]) => [(e, Float)]
+ | EFfiApp ("Basis", "sqlifyString", [(e, _)]) => [(e, String)]
+ | EFfiApp ("Basis", "sqlifyBool", [(e, _)]) => [(e, Bool)]
+ | EFfiApp ("Basis", "sqlifyTime", [(e, _)]) => [(e, Time)]
+ | EFfiApp ("Basis", "sqlifyBlob", [(e, _)]) => [(e, Blob)]
+ | EFfiApp ("Basis", "sqlifyChannel", [(e, _)]) => [(e, Channel)]
+ | EFfiApp ("Basis", "sqlifyClient", [(e, _)]) => [(e, Client)]
| ECase (e,
[((PNone _, _),
(EPrim (Prim.String "NULL"), _)),
((PSome (_, (PVar _, _)), _),
- (EFfiApp (m, x, [(ERel 0, _)]), _))],
- _) => map (fn (x, y) => (x, Nullable y)) (getPargs (EFfiApp (m, x, [e]), #2 e))
+ (EFfiApp (m, x, [((ERel 0, _), _)]), _))],
+ {disc = t, ...}) => map (fn (x, y) => (x, Nullable y)) (getPargs (EFfiApp (m, x, [(e, t)]), #2 e))
| ECase (e,
[((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, _), _),
@@ -1442,7 +1442,63 @@ fun potentiallyFancy (e, _) =
val self = ref (NONE : int option)
-fun p_exp' par tail env (e, loc) =
+(* The crucial thing to do here is assign arguments to local variables, to enforce order of evaluation.
+ * Otherwise, we are at the mercy of C's undefined order of function argument evaluation. *)
+fun pFuncall env (m, x, es, extra) =
+ case es of
+ [] => box [string "uw_",
+ p_ident m,
+ string "_",
+ p_ident x,
+ string "(ctx",
+ case extra of
+ NONE => box []
+ | SOME extra => box [string ",",
+ space,
+ string extra],
+ string ")"]
+ | [(e, _)] => box [string "uw_",
+ p_ident m,
+ string "_",
+ p_ident x,
+ string "(ctx,",
+ space,
+ p_exp' false false env e,
+ case extra of
+ NONE => box []
+ | SOME extra => box [string ",",
+ space,
+ string extra],
+ string ")"]
+ | _ => box [string "({",
+ newline,
+ p_list_sepi (box []) (fn i => fn (e, t) =>
+ box [p_typ env t,
+ space,
+ string "arg",
+ string (Int.toString i),
+ space,
+ string "=",
+ space,
+ p_exp' false false env e,
+ string ";",
+ newline]) es,
+ string "uw_",
+ p_ident m,
+ string "_",
+ p_ident x,
+ string "(ctx, ",
+ p_list_sepi (box [string ",", space]) (fn i => fn _ => box [string "arg", string (Int.toString i)]) es,
+ case extra of
+ NONE => box []
+ | SOME extra => box [string ",",
+ space,
+ string extra],
+ string ");",
+ newline,
+ string "})"]
+
+and p_exp' par tail env (e, loc) =
case e of
EPrim p => Prim.p_t_GCC p
| ERel n => p_rel env n
@@ -1571,16 +1627,30 @@ fun p_exp' par tail env (e, loc) =
string "})"]
| EReturnBlob {blob, mimeType, t} =>
box [string "({",
+ newline,
+ string "uw_Basis_blob",
+ space,
+ string "blob",
+ space,
+ string "=",
+ space,
+ p_exp' false false env blob,
+ string ";",
+ newline,
+ string "uw_Basis_string",
+ space,
+ string "mimeType",
+ space,
+ string "=",
+ space,
+ p_exp' false false env mimeType,
+ string ";",
newline,
p_typ env t,
space,
string "tmp;",
newline,
- string "uw_return_blob(ctx, ",
- p_exp' false false env blob,
- string ", ",
- p_exp' false false env mimeType,
- string ");",
+ string "uw_return_blob(ctx, blob, mimeType);",
newline,
string "tmp;",
newline,
@@ -1604,37 +1674,23 @@ fun p_exp' par tail env (e, loc) =
| EApp ((EReturnBlob {blob, mimeType, t = (TFun (_, ran), _)}, loc), _) =>
p_exp' false false env (EReturnBlob {blob = blob, mimeType = mimeType, t = ran}, loc)
- | EFfiApp ("Basis", "strcat", [e1, e2]) =>
+ | EFfiApp ("Basis", "strcat", [(e1, _), (e2, _)]) =>
let
fun flatten e =
case #1 e of
- EFfiApp ("Basis", "strcat", [e1, e2]) => flatten e1 @ flatten e2
+ EFfiApp ("Basis", "strcat", [(e1, _), (e2, _)]) => flatten e1 @ flatten e2
| _ => [e]
+
+ val es = flatten e1 @ flatten e2
+ val t = (TFfi ("Basis", "string"), loc)
+ val es = map (fn e => (e, t)) es
in
- case flatten e1 @ flatten e2 of
- [e1, e2] => box [string "uw_Basis_strcat(ctx, ",
- p_exp' false false env e1,
- string ",",
- p_exp' false false env e2,
- string ")"]
- | es => box [string "uw_Basis_mstrcat(ctx, ",
- p_list (p_exp' false false env) es,
- string ", NULL)"]
+ case es of
+ [_, _] => pFuncall env ("Basis", "strcat", es, NONE)
+ | _ => pFuncall env ("Basis", "mstrcat", es, SOME "NULL")
end
- | EFfiApp (m, x, []) => box [string "uw_",
- p_ident m,
- string "_",
- p_ident x,
- string "(ctx)"]
-
- | EFfiApp (m, x, es) => box [string "uw_",
- p_ident m,
- string "_",
- p_ident x,
- string "(ctx, ",
- p_list (p_exp' false false env) es,
- string ")"]
+ | EFfiApp (m, x, es) => pFuncall env (m, x, es, NONE)
| EApp (f, args) =>
let
fun default () = parenIf par (box [p_exp' true false env f,
@@ -3036,7 +3092,7 @@ fun p_file env (ds, ps) =
case e of
ECon (_, _, SOME e) => expDb e
| ESome (_, e) => expDb e
- | EFfiApp (_, _, es) => List.exists expDb es
+ | EFfiApp (_, _, es) => List.exists (expDb o #1) es
| EApp (e, es) => expDb e orelse List.exists expDb es
| EUnop (_, e) => expDb e
| EBinop (_, e1, e2) => expDb e1 orelse expDb e2
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 2b46c32d..a0ec2ece 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -277,7 +277,13 @@ fun cifyExp (eAll as (e, loc), sm) =
| L.EFfi mx => ((L'.EFfi mx, loc), sm)
| L.EFfiApp (m, x, es) =>
let
- val (es, sm) = ListUtil.foldlMap cifyExp sm es
+ val (es, sm) = ListUtil.foldlMap (fn ((e, t), sm) =>
+ let
+ val (t, sm) = cifyTyp (t, sm)
+ val (e, sm) = cifyExp (e, sm)
+ in
+ ((e, t), sm)
+ end) sm es
in
((L'.EFfiApp (m, x, es), loc), sm)
end
@@ -384,8 +390,9 @@ fun cifyExp (eAll as (e, loc), sm) =
let
val (e1, sm) = cifyExp (e1, sm)
val (e2, sm) = cifyExp (e2, sm)
+ val s = (L'.TFfi ("Basis", "string"), loc)
in
- ((L'.EFfiApp ("Basis", "strcat", [e1, e2]), loc), sm)
+ ((L'.EFfiApp ("Basis", "strcat", [(e1, s), (e2, s)]), loc), sm)
end
| L.EWrite e =>
@@ -673,7 +680,7 @@ fun cifyDecl ((d, loc), sm) =
val tk = case #1 e1 of
L.EFfi ("Basis", "initialize") => L'.Initialize
| L.EFfi ("Basis", "clientLeaves") => L'.ClientLeaves
- | L.EFfiApp ("Basis", "periodic", [(L.EPrim (Prim.Int n), _)]) => L'.Periodic n
+ | L.EFfiApp ("Basis", "periodic", [((L.EPrim (Prim.Int n), _), _)]) => L'.Periodic n
| _ => (ErrorMsg.errorAt loc "Task kind not fully determined";
L'.Initialize)
val (e, sm) = cifyExp (e, sm)
diff --git a/src/core.sml b/src/core.sml
index 6d9e56b6..4641d1ab 100644
--- a/src/core.sml
+++ b/src/core.sml
@@ -92,7 +92,7 @@ datatype exp' =
| ENamed of int
| ECon of datatype_kind * patCon * con list * exp option
| EFfi of string * string
- | EFfiApp of string * string * exp list
+ | EFfiApp of string * string * (exp * con) list
| EApp of exp * exp
| EAbs of string * con * con * exp
| ECApp of exp * con
diff --git a/src/core_print.sml b/src/core_print.sml
index 8e46db04..910ec10a 100644
--- a/src/core_print.sml
+++ b/src/core_print.sml
@@ -276,7 +276,7 @@ fun p_exp' par env (e, _) =
string ".",
string x,
string "(",
- p_list (p_exp env) es,
+ p_list (p_exp env o #1) es,
string "))"]
| EApp (e1, e2) => parenIf par (box [p_exp' true env e1,
space,
diff --git a/src/core_util.sml b/src/core_util.sml
index e71d7276..d41dfe33 100644
--- a/src/core_util.sml
+++ b/src/core_util.sml
@@ -468,7 +468,7 @@ fun compare ((e1, _), (e2, _)) =
| (EFfiApp (f1, x1, es1), EFfiApp (f2, x2, es2)) =>
join (String.compare (f1, f2),
fn () => join (String.compare (x1, x2),
- fn () => joinL compare (es1, es2)))
+ fn () => joinL (fn ((e1, _), (e2, _)) => compare (e1, e2))(es1, es2)))
| (EFfiApp _, _) => LESS
| (_, EFfiApp _) => GREATER
@@ -586,6 +586,12 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} =
fun mfe ctx e acc =
S.bindP (mfe' ctx e acc, fe ctx)
+ and mfet ctx (e, t) =
+ S.bind2 (mfe ctx e,
+ fn e' =>
+ S.map2 (mfc ctx t,
+ fn t' => (e', t')))
+
and mfe' ctx (eAll as (e, loc)) =
case e of
EPrim _ => S.return2 eAll
@@ -603,7 +609,7 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} =
(ECon (dk, n, cs', SOME e'), loc)))
| EFfi _ => S.return2 eAll
| EFfiApp (m, x, es) =>
- S.map2 (ListUtil.mapfold (mfe ctx) es,
+ S.map2 (ListUtil.mapfold (mfet ctx) es,
fn es' =>
(EFfiApp (m, x, es'), loc))
| EApp (e1, e2) =>
diff --git a/src/corify.sml b/src/corify.sml
index d9e5d30c..bc14d408 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -562,8 +562,8 @@ fun corifyExp st (e, loc) =
fun makeApp n =
let
- val (actuals, _) = foldr (fn (_, (actuals, n)) =>
- ((L'.ERel n, loc) :: actuals,
+ val (actuals, _) = foldr (fn (t, (actuals, n)) =>
+ (((L'.ERel n, loc), t) :: actuals,
n + 1)) ([], n) args
in
(L'.EFfiApp (m, x, actuals), loc)
diff --git a/src/css.sml b/src/css.sml
index 90c0b5dd..07160898 100644
--- a/src/css.sml
+++ b/src/css.sml
@@ -138,7 +138,7 @@ fun summarize file =
| ECon (_, _, _, NONE) => ([], classes)
| ECon (_, _, _, SOME e) => exp (e, classes)
| EFfi _ => ([], classes)
- | EFfiApp (_, _, es) => expList (es, classes)
+ | EFfiApp (_, _, es) => expList (map #1 es, classes)
| EApp (
(EApp (
diff --git a/src/especialize.sml b/src/especialize.sml
index 8720a7b1..74babe47 100644
--- a/src/especialize.sml
+++ b/src/especialize.sml
@@ -180,7 +180,12 @@ fun specialize' (funcs, specialized) file =
| EFfi _ => (e, st)
| EFfiApp (m, x, es) =>
let
- val (es, st) = ListUtil.foldlMap (fn (e, st) => exp (env, e, st)) st es
+ val (es, st) = ListUtil.foldlMap (fn ((e, t), st) =>
+ let
+ val (e, st) = exp (env, e, st)
+ in
+ ((e, t), st)
+ end) st es
in
((EFfiApp (m, x, es), loc), st)
end
diff --git a/src/iflow.sml b/src/iflow.sml
index f6e03271..c65271b3 100644
--- a/src/iflow.sml
+++ b/src/iflow.sml
@@ -1044,7 +1044,7 @@ fun known' chs =
fun sqlify chs =
case chs of
- Exp (EFfiApp ("Basis", f, [e]), _) :: chs =>
+ Exp (EFfiApp ("Basis", f, [(e, _)]), _) :: chs =>
if String.isPrefix "sqlify" f then
SOME (e, chs)
else
@@ -1859,7 +1859,7 @@ fun evalExp env (e as (_, loc)) k =
[] =>
(if s = "set_cookie" then
case es of
- [_, cname, _, _, _] =>
+ [_, (cname, _), _, _, _] =>
(case #1 cname of
EPrim (Prim.String cname) =>
St.havocCookie cname
@@ -1868,7 +1868,7 @@ fun evalExp env (e as (_, loc)) k =
else
();
k (Recd []))
- | e :: es =>
+ | (e, _) :: es =>
evalExp env e (fn e => (St.send (e, loc); doArgs es))
in
doArgs es
@@ -1880,7 +1880,7 @@ fun evalExp env (e as (_, loc)) k =
fun doArgs (es, acc) =
case es of
[] => k (Func (Other (m ^ "." ^ s), rev acc))
- | e :: es =>
+ | (e, _) :: es =>
evalExp env e (fn e => doArgs (es, e :: acc))
in
doArgs (es, [])
@@ -1904,7 +1904,7 @@ fun evalExp env (e as (_, loc)) k =
k e
end
| EFfiApp x => doFfi x
- | EApp ((EFfi (m, s), _), e) => doFfi (m, s, [e])
+ | EApp ((EFfi (m, s), _), e) => doFfi (m, s, [(e, (TRecord [], loc))])
| EApp (e1 as (EError _, _), _) => evalExp env e1 k
@@ -2051,7 +2051,7 @@ fun evalExp env (e as (_, loc)) k =
| Update (tab, _, _) =>
(cs, SS.add (ts, tab)))
| EFfiApp ("Basis", "set_cookie",
- [_, (EPrim (Prim.String cname), _),
+ [_, ((EPrim (Prim.String cname), _), _),
_, _, _]) =>
(SS.add (cs, cname), ts)
| _ => st}
@@ -2189,7 +2189,7 @@ fun evalExp env (e as (_, loc)) k =
| ENextval _ => default ()
| ESetval _ => default ()
- | EUnurlify ((EFfiApp ("Basis", "get_cookie", [(EPrim (Prim.String cname), _)]), _), _, _) =>
+ | EUnurlify ((EFfiApp ("Basis", "get_cookie", [((EPrim (Prim.String cname), _), _)]), _), _, _) =>
let
val e = Var (St.nextVar ())
val e' = Func (Other ("cookie/" ^ cname), [])
@@ -2301,10 +2301,10 @@ fun check file =
| EFfi _ => e
| EFfiApp (m, f, es) =>
(case (m, f, es) of
- ("Basis", "set_cookie", [_, (EPrim (Prim.String cname), _), _, _, _]) =>
+ ("Basis", "set_cookie", [_, ((EPrim (Prim.String cname), _), _), _, _, _]) =>
cookies := SS.add (!cookies, cname)
| _ => ();
- (EFfiApp (m, f, map (doExp env) es), loc))
+ (EFfiApp (m, f, map (fn (e, t) => (doExp env e, t)) es), loc))
| EApp (e1, e2) =>
let
diff --git a/src/jscomp.sml b/src/jscomp.sml
index 57f59b12..901ea9fe 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -91,7 +91,7 @@ fun process file =
fun quoteExp loc (t : typ) (e, st) =
case #1 t of
- TSource => ((EFfiApp ("Basis", "htmlifySource", [e]), loc), st)
+ TSource => ((EFfiApp ("Basis", "htmlifySource", [(e, t)]), loc), st)
| TRecord [] => (str loc "null", st)
| TRecord [(x, t)] =>
@@ -120,12 +120,12 @@ fun process file =
@ [str loc "}"]), st)
end
- | TFfi ("Basis", "string") => ((EFfiApp ("Basis", "jsifyString", [e]), loc), st)
- | TFfi ("Basis", "char") => ((EFfiApp ("Basis", "jsifyChar", [e]), loc), st)
- | TFfi ("Basis", "int") => ((EFfiApp ("Basis", "htmlifyInt", [e]), loc), st)
- | TFfi ("Basis", "float") => ((EFfiApp ("Basis", "htmlifyFloat", [e]), loc), st)
- | TFfi ("Basis", "channel") => ((EFfiApp ("Basis", "jsifyChannel", [e]), loc), st)
- | TFfi ("Basis", "time") => ((EFfiApp ("Basis", "jsifyTime", [e]), loc), st)
+ | TFfi ("Basis", "string") => ((EFfiApp ("Basis", "jsifyString", [(e, t)]), loc), st)
+ | TFfi ("Basis", "char") => ((EFfiApp ("Basis", "jsifyChar", [(e, t)]), loc), st)
+ | TFfi ("Basis", "int") => ((EFfiApp ("Basis", "htmlifyInt", [(e, t)]), loc), st)
+ | TFfi ("Basis", "float") => ((EFfiApp ("Basis", "htmlifyFloat", [(e, t)]), loc), st)
+ | TFfi ("Basis", "channel") => ((EFfiApp ("Basis", "jsifyChannel", [(e, t)]), loc), st)
+ | TFfi ("Basis", "time") => ((EFfiApp ("Basis", "jsifyTime", [(e, t)]), loc), st)
| TFfi ("Basis", "bool") => ((ECase (e,
[((PCon (Enum, PConFfi {mod = "Basis",
@@ -511,7 +511,7 @@ fun process file =
case e of
EPrim (Prim.String s) => jsifyStringMulti (level, s)
| EStrcat (e1, e2) => deStrcat level e1 ^ deStrcat level e2
- | EFfiApp ("Basis", "jsifyString", [e]) => "\"" ^ deStrcat (level + 1) e ^ "\""
+ | EFfiApp ("Basis", "jsifyString", [(e, _)]) => "\"" ^ deStrcat (level + 1) e ^ "\""
| _ => (Print.prefaces "deStrcat" [("e", MonoPrint.p_exp MonoEnv.empty all)];
raise Fail "Jscomp: deStrcat")
@@ -645,7 +645,7 @@ fun process file =
"ERROR")
| SOME s => s
- val (e, st) = foldr (fn (e, (acc, st)) =>
+ val (e, st) = foldr (fn ((e, _), (acc, st)) =>
let
val (e, st) = jsE inner (e, st)
in
@@ -1024,7 +1024,12 @@ fun process file =
| EFfi _ => (e, st)
| EFfiApp (m, x, es) =>
let
- val (es, st) = ListUtil.foldlMap (exp outer) st es
+ val (es, st) = ListUtil.foldlMap (fn ((e, t), st) =>
+ let
+ val (e, st) = exp outer (e, st)
+ in
+ ((e, t), st)
+ end) st es
in
((EFfiApp (m, x, es), loc), st)
end
diff --git a/src/mono.sml b/src/mono.sml
index bf38c0bc..2c83d1bc 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -78,7 +78,7 @@ datatype exp' =
| ENone of typ
| ESome of typ * exp
| EFfi of string * string
- | EFfiApp of string * string * exp list
+ | EFfiApp of string * string * (exp * typ) list
| EApp of exp * exp
| EAbs of string * typ * typ * exp
diff --git a/src/mono_opt.sml b/src/mono_opt.sml
index 5abbf900..199c807b 100644
--- a/src/mono_opt.sml
+++ b/src/mono_opt.sml
@@ -138,7 +138,7 @@ fun exp e =
EPrim (Prim.String (String.implode (rev chs)))
end
- | EFfiApp ("Basis", "strcat", [e1, e2]) => exp (EStrcat (e1, e2))
+ | EFfiApp ("Basis", "strcat", [(e1, _), (e2, _)]) => exp (EStrcat (e1, e2))
| EStrcat ((EPrim (Prim.String s1), loc), (EPrim (Prim.String s2), _)) =>
let
@@ -182,153 +182,153 @@ fun exp e =
ESeq ((EWrite (EPrim (Prim.String (s1 ^ s2)), loc), loc),
e)
- | EFfiApp ("Basis", "htmlifySpecialChar", [(EPrim (Prim.Char ch), _)]) =>
+ | EFfiApp ("Basis", "htmlifySpecialChar", [((EPrim (Prim.Char ch), _), _)]) =>
EPrim (Prim.String (htmlifySpecialChar ch))
| EWrite (EFfiApp ("Basis", "htmlifySpecialChar", [e]), _) =>
EFfiApp ("Basis", "htmlifySpecialChar_w", [e])
- | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "intToString", [(EPrim (Prim.Int n), _)]), _)]) =>
+ | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "intToString", [((EPrim (Prim.Int n), _), _)]), _), _)]) =>
EPrim (Prim.String (htmlifyInt n))
- | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "intToString", es), _)]) =>
+ | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "intToString", es), _), _)]) =>
EFfiApp ("Basis", "htmlifyInt", es)
- | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "intToString"), _),
- (EPrim (Prim.Int n), _)), _)]) =>
+ | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "intToString"), _),
+ (EPrim (Prim.Int n), _)), _), _)]) =>
EPrim (Prim.String (htmlifyInt n))
- | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "intToString"), _),
- e), _)]) =>
- EFfiApp ("Basis", "htmlifyInt", [e])
+ | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "intToString"), _),
+ e), loc), _)]) =>
+ EFfiApp ("Basis", "htmlifyInt", [(e, (TFfi ("Basis", "int"), loc))])
| EWrite (EFfiApp ("Basis", "htmlifyInt", [e]), _) =>
EFfiApp ("Basis", "htmlifyInt_w", [e])
- | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "floatToString", [(EPrim (Prim.Float n), _)]), _)]) =>
+ | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "floatToString", [((EPrim (Prim.Float n), _), _)]), _), _)]) =>
EPrim (Prim.String (htmlifyFloat n))
- | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "floatToString", es), _)]) =>
+ | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "floatToString", es), _), _)]) =>
EFfiApp ("Basis", "htmlifyFloat", es)
- | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "floatToString"), _),
- (EPrim (Prim.Float n), _)), _)]) =>
+ | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "floatToString"), _),
+ (EPrim (Prim.Float n), _)), _), _)]) =>
EPrim (Prim.String (htmlifyFloat n))
- | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "floatToString"), _),
- e), _)]) =>
- EFfiApp ("Basis", "htmlifyFloat", [e])
+ | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "floatToString"), _),
+ e), loc), _)]) =>
+ EFfiApp ("Basis", "htmlifyFloat", [(e, (TFfi ("Basis", "float"), loc))])
| EWrite (EFfiApp ("Basis", "htmlifyFloat", [e]), _) =>
EFfiApp ("Basis", "htmlifyFloat_w", [e])
- | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "boolToString",
- [(ECon (Enum, PConFfi {con = "True", ...}, NONE), _)]), _)]) =>
+ | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "boolToString",
+ [((ECon (Enum, PConFfi {con = "True", ...}, NONE), _), _)]), _), _)]) =>
EPrim (Prim.String "True")
- | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "boolToString",
- [(ECon (Enum, PConFfi {con = "False", ...}, NONE), _)]), _)]) =>
+ | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "boolToString",
+ [((ECon (Enum, PConFfi {con = "False", ...}, NONE), _), _)]), _), _)]) =>
EPrim (Prim.String "False")
- | EFfiApp ("Basis", "htmlifyString", [(EFfiApp ("Basis", "boolToString", es), _)]) =>
+ | EFfiApp ("Basis", "htmlifyString", [((EFfiApp ("Basis", "boolToString", es), _), _)]) =>
EFfiApp ("Basis", "htmlifyBool", es)
- | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "boolToString"), _),
- (ECon (Enum, PConFfi {con = "True", ...}, NONE), _)), _)]) =>
+ | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "boolToString"), _),
+ (ECon (Enum, PConFfi {con = "True", ...}, NONE), _)), _), _)]) =>
EPrim (Prim.String "True")
- | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "boolToString"), _),
- (ECon (Enum, PConFfi {con = "False", ...}, NONE), _)), _)]) =>
+ | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "boolToString"), _),
+ (ECon (Enum, PConFfi {con = "False", ...}, NONE), _)), _), _)]) =>
EPrim (Prim.String "False")
- | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "boolToString"), _),
- e), _)]) =>
- EFfiApp ("Basis", "htmlifyBool", [e])
+ | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "boolToString"), _),
+ e), loc), _)]) =>
+ EFfiApp ("Basis", "htmlifyBool", [(e, (TFfi ("Basis", "bool"), loc))])
| EWrite (EFfiApp ("Basis", "htmlifyBool", [e]), _) =>
EFfiApp ("Basis", "htmlifyBool_w", [e])
- | EFfiApp ("Basis", "htmlifyString", [(EApp ((EFfi ("Basis", "timeToString"), _), e), _)]) =>
- EFfiApp ("Basis", "htmlifyTime", [e])
- | EFfiApp ("Basis", "htmlifyString_w", [(EApp ((EFfi ("Basis", "timeToString"), _), e), _)]) =>
- EFfiApp ("Basis", "htmlifyTime_w", [e])
+ | EFfiApp ("Basis", "htmlifyString", [((EApp ((EFfi ("Basis", "timeToString"), _), e), loc), _)]) =>
+ EFfiApp ("Basis", "htmlifyTime", [(e, (TFfi ("Basis", "time"), loc))])
+ | EFfiApp ("Basis", "htmlifyString_w", [((EApp ((EFfi ("Basis", "timeToString"), loc), e), _), _)]) =>
+ EFfiApp ("Basis", "htmlifyTime_w", [(e, (TFfi ("Basis", "time"), loc))])
| EWrite (EFfiApp ("Basis", "htmlifyTime", [e]), _) =>
EFfiApp ("Basis", "htmlifyTime_w", [e])
- | EFfiApp ("Basis", "htmlifyString", [(EPrim (Prim.String s), _)]) =>
+ | EFfiApp ("Basis", "htmlifyString", [((EPrim (Prim.String s), _), _)]) =>
EPrim (Prim.String (htmlifyString s))
- | EWrite (EFfiApp ("Basis", "htmlifyString", [(EPrim (Prim.String s), _)]), loc) =>
+ | EWrite (EFfiApp ("Basis", "htmlifyString", [((EPrim (Prim.String s), _), _)]), loc) =>
EWrite (EPrim (Prim.String (htmlifyString s)), loc)
| EWrite (EFfiApp ("Basis", "htmlifyString", [e]), _) =>
EFfiApp ("Basis", "htmlifyString_w", [e])
- | EFfiApp ("Basis", "htmlifyString_w", [(EPrim (Prim.String s), loc)]) =>
+ | EFfiApp ("Basis", "htmlifyString_w", [((EPrim (Prim.String s), loc), _)]) =>
EWrite (EPrim (Prim.String (htmlifyString s)), loc)
| EWrite (EFfiApp ("Basis", "htmlifySource", [e]), _) =>
EFfiApp ("Basis", "htmlifySource_w", [e])
- | EFfiApp ("Basis", "attrifyInt", [(EPrim (Prim.Int n), _)]) =>
+ | EFfiApp ("Basis", "attrifyInt", [((EPrim (Prim.Int n), _), _)]) =>
EPrim (Prim.String (attrifyInt n))
- | EWrite (EFfiApp ("Basis", "attrifyInt", [(EPrim (Prim.Int n), _)]), loc) =>
+ | EWrite (EFfiApp ("Basis", "attrifyInt", [((EPrim (Prim.Int n), _), _)]), loc) =>
EWrite (EPrim (Prim.String (attrifyInt n)), loc)
| EWrite (EFfiApp ("Basis", "attrifyInt", [e]), _) =>
EFfiApp ("Basis", "attrifyInt_w", [e])
- | EFfiApp ("Basis", "attrifyFloat", [(EPrim (Prim.Float n), _)]) =>
+ | EFfiApp ("Basis", "attrifyFloat", [((EPrim (Prim.Float n), _), _)]) =>
EPrim (Prim.String (attrifyFloat n))
- | EWrite (EFfiApp ("Basis", "attrifyFloat", [(EPrim (Prim.Float n), _)]), loc) =>
+ | EWrite (EFfiApp ("Basis", "attrifyFloat", [((EPrim (Prim.Float n), _), _)]), loc) =>
EWrite (EPrim (Prim.String (attrifyFloat n)), loc)
| EWrite (EFfiApp ("Basis", "attrifyFloat", [e]), _) =>
EFfiApp ("Basis", "attrifyFloat_w", [e])
- | EFfiApp ("Basis", "attrifyString", [(EPrim (Prim.String s), _)]) =>
+ | EFfiApp ("Basis", "attrifyString", [((EPrim (Prim.String s), _), _)]) =>
EPrim (Prim.String (attrifyString s))
- | EWrite (EFfiApp ("Basis", "attrifyString", [(EPrim (Prim.String s), _)]), loc) =>
+ | EWrite (EFfiApp ("Basis", "attrifyString", [((EPrim (Prim.String s), _), _)]), loc) =>
EWrite (EPrim (Prim.String (attrifyString s)), loc)
| EWrite (EFfiApp ("Basis", "attrifyString", [e]), _) =>
EFfiApp ("Basis", "attrifyString_w", [e])
- | EFfiApp ("Basis", "attrifyChar", [(EPrim (Prim.Char s), _)]) =>
+ | EFfiApp ("Basis", "attrifyChar", [((EPrim (Prim.Char s), _), _)]) =>
EPrim (Prim.String (attrifyChar s))
- | EWrite (EFfiApp ("Basis", "attrifyChar", [(EPrim (Prim.Char s), _)]), loc) =>
+ | EWrite (EFfiApp ("Basis", "attrifyChar", [((EPrim (Prim.Char s), _), _)]), loc) =>
EWrite (EPrim (Prim.String (attrifyChar s)), loc)
| EWrite (EFfiApp ("Basis", "attrifyChar", [e]), _) =>
EFfiApp ("Basis", "attrifyChar_w", [e])
- | EFfiApp ("Basis", "attrifyCss_class", [(EPrim (Prim.String s), _)]) =>
+ | EFfiApp ("Basis", "attrifyCss_class", [((EPrim (Prim.String s), _), _)]) =>
EPrim (Prim.String s)
- | EWrite (EFfiApp ("Basis", "attrifyCss_class", [(EPrim (Prim.String s), _)]), loc) =>
+ | EWrite (EFfiApp ("Basis", "attrifyCss_class", [((EPrim (Prim.String s), _), _)]), loc) =>
EWrite (EPrim (Prim.String s), loc)
| EWrite (EFfiApp ("Basis", "attrifyCss_class", [e]), _) =>
EFfiApp ("Basis", "attrifyString_w", [e])
- | EFfiApp ("Basis", "urlifyInt", [(EPrim (Prim.Int n), _)]) =>
+ | EFfiApp ("Basis", "urlifyInt", [((EPrim (Prim.Int n), _), _)]) =>
EPrim (Prim.String (urlifyInt n))
- | EWrite (EFfiApp ("Basis", "urlifyInt", [(EPrim (Prim.Int n), _)]), loc) =>
+ | EWrite (EFfiApp ("Basis", "urlifyInt", [((EPrim (Prim.Int n), _), _)]), loc) =>
EWrite (EPrim (Prim.String (urlifyInt n)), loc)
| EWrite (EFfiApp ("Basis", "urlifyInt", [e]), _) =>
EFfiApp ("Basis", "urlifyInt_w", [e])
- | EFfiApp ("Basis", "urlifyFloat", [(EPrim (Prim.Float n), _)]) =>
+ | EFfiApp ("Basis", "urlifyFloat", [((EPrim (Prim.Float n), _), _)]) =>
EPrim (Prim.String (urlifyFloat n))
- | EWrite (EFfiApp ("Basis", "urlifyFloat", [(EPrim (Prim.Float n), _)]), loc) =>
+ | EWrite (EFfiApp ("Basis", "urlifyFloat", [((EPrim (Prim.Float n), _), _)]), loc) =>
EWrite (EPrim (Prim.String (urlifyFloat n)), loc)
| EWrite (EFfiApp ("Basis", "urlifyFloat", [e]), _) =>
EFfiApp ("Basis", "urlifyFloat_w", [e])
- | EFfiApp ("Basis", "urlifyString", [(EPrim (Prim.String s), _)]) =>
+ | EFfiApp ("Basis", "urlifyString", [((EPrim (Prim.String s), _), _)]) =>
EPrim (Prim.String (urlifyString s))
- | EWrite (EFfiApp ("Basis", "urlifyString", [(EPrim (Prim.String s), _)]), loc) =>
+ | EWrite (EFfiApp ("Basis", "urlifyString", [((EPrim (Prim.String s), _), _)]), loc) =>
EWrite (EPrim (Prim.String (urlifyString s)), loc)
| EWrite (EFfiApp ("Basis", "urlifyString", [e]), _) =>
EFfiApp ("Basis", "urlifyString_w", [e])
- | EFfiApp ("Basis", "urlifyBool", [(ECon (Enum, PConFfi {con = "True", ...}, NONE), _)]) =>
+ | EFfiApp ("Basis", "urlifyBool", [((ECon (Enum, PConFfi {con = "True", ...}, NONE), _), _)]) =>
EPrim (Prim.String "1")
- | EFfiApp ("Basis", "urlifyBool", [(ECon (Enum, PConFfi {con = "False", ...}, NONE), _)]) =>
+ | EFfiApp ("Basis", "urlifyBool", [((ECon (Enum, PConFfi {con = "False", ...}, NONE), _), _)]) =>
EPrim (Prim.String "0")
- | EWrite (EFfiApp ("Basis", "urlifyBool", [(ECon (Enum, PConFfi {con = "True", ...}, NONE), _)]), loc) =>
+ | EWrite (EFfiApp ("Basis", "urlifyBool", [((ECon (Enum, PConFfi {con = "True", ...}, NONE), _), _)]), loc) =>
EWrite (EPrim (Prim.String "1"), loc)
- | EWrite (EFfiApp ("Basis", "urlifyBool", [(ECon (Enum, PConFfi {con = "False", ...}, NONE), _)]), loc) =>
+ | EWrite (EFfiApp ("Basis", "urlifyBool", [((ECon (Enum, PConFfi {con = "False", ...}, NONE), _), _)]), loc) =>
EWrite (EPrim (Prim.String "0"), loc)
| EWrite (EFfiApp ("Basis", "urlifyBool", [e]), _) =>
EFfiApp ("Basis", "urlifyBool_w", [e])
- | EFfiApp ("Basis", "sqlifyInt", [(EPrim (Prim.Int n), _)]) =>
+ | EFfiApp ("Basis", "sqlifyInt", [((EPrim (Prim.Int n), _), _)]) =>
EPrim (Prim.String (sqlifyInt n))
- | EFfiApp ("Basis", "sqlifyIntN", [(ENone _, _)]) =>
+ | EFfiApp ("Basis", "sqlifyIntN", [((ENone _, _), _)]) =>
EPrim (Prim.String "NULL")
- | EFfiApp ("Basis", "sqlifyIntN", [(ESome (_, (EPrim (Prim.Int n), _)), _)]) =>
+ | EFfiApp ("Basis", "sqlifyIntN", [((ESome (_, (EPrim (Prim.Int n), _)), _), _)]) =>
EPrim (Prim.String (sqlifyInt n))
- | EFfiApp ("Basis", "sqlifyFloat", [(EPrim (Prim.Float n), _)]) =>
+ | EFfiApp ("Basis", "sqlifyFloat", [((EPrim (Prim.Float n), _), _)]) =>
EPrim (Prim.String (sqlifyFloat n))
- | EFfiApp ("Basis", "sqlifyBool", [b as (_, loc)]) =>
+ | EFfiApp ("Basis", "sqlifyBool", [(b as (_, loc), _)]) =>
optExp (ECase (b,
[((PCon (Enum, PConFfi {mod = "Basis", datatyp = "bool", con = "True", arg = NONE}, NONE), loc),
(EPrim (Prim.String (#trueString (Settings.currentDbms ()))), loc)),
@@ -336,9 +336,9 @@ fun exp e =
(EPrim (Prim.String (#falseString (Settings.currentDbms ()))), loc))],
{disc = (TFfi ("Basis", "bool"), loc),
result = (TFfi ("Basis", "string"), loc)}), loc)
- | EFfiApp ("Basis", "sqlifyString", [(EPrim (Prim.String n), _)]) =>
+ | EFfiApp ("Basis", "sqlifyString", [((EPrim (Prim.String n), _), _)]) =>
EPrim (Prim.String (sqlifyString n))
- | EFfiApp ("Basis", "sqlifyChar", [(EPrim (Prim.Char n), _)]) =>
+ | EFfiApp ("Basis", "sqlifyChar", [((EPrim (Prim.Char n), _), _)]) =>
EPrim (Prim.String (sqlifyChar n))
| EWrite (ECase (discE, pes, {disc, ...}), loc) =>
@@ -418,52 +418,52 @@ fun exp e =
| ESignalBind ((ESignalReturn e1, loc), e2) =>
optExp (EApp (e2, e1), loc)
- | EFfiApp ("Basis", "bless", [(se as EPrim (Prim.String s), loc)]) =>
+ | EFfiApp ("Basis", "bless", [((se as EPrim (Prim.String s), loc), _)]) =>
(if checkUrl s then
()
else
ErrorMsg.errorAt loc ("Invalid URL " ^ s ^ " passed to 'bless'");
se)
- | EFfiApp ("Basis", "checkUrl", [(se as EPrim (Prim.String s), loc)]) =>
+ | EFfiApp ("Basis", "checkUrl", [((se as EPrim (Prim.String s), loc), _)]) =>
(if checkUrl s then
ESome ((TFfi ("Basis", "string"), loc), (se, loc))
else
ENone (TFfi ("Basis", "string"), loc))
- | EFfiApp ("Basis", "blessMime", [(se as EPrim (Prim.String s), loc)]) =>
+ | EFfiApp ("Basis", "blessMime", [((se as EPrim (Prim.String s), loc), _)]) =>
(if Settings.checkMime s then
()
else
ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'blessMime'");
se)
- | EFfiApp ("Basis", "checkMime", [(se as EPrim (Prim.String s), loc)]) =>
+ | EFfiApp ("Basis", "checkMime", [((se as EPrim (Prim.String s), loc), _)]) =>
(if Settings.checkMime s then
ESome ((TFfi ("Basis", "string"), loc), (se, loc))
else
ENone (TFfi ("Basis", "string"), loc))
- | EFfiApp ("Basis", "blessRequestHeader", [(se as EPrim (Prim.String s), loc)]) =>
+ | EFfiApp ("Basis", "blessRequestHeader", [((se as EPrim (Prim.String s), loc), _)]) =>
(if Settings.checkRequestHeader s then
()
else
ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'blessRequestHeader'");
se)
- | EFfiApp ("Basis", "checkRequestHeader", [(se as EPrim (Prim.String s), loc)]) =>
+ | EFfiApp ("Basis", "checkRequestHeader", [((se as EPrim (Prim.String s), loc), _)]) =>
(if Settings.checkRequestHeader s then
ESome ((TFfi ("Basis", "string"), loc), (se, loc))
else
ENone (TFfi ("Basis", "string"), loc))
- | EFfiApp ("Basis", "blessResponseHeader", [(se as EPrim (Prim.String s), loc)]) =>
+ | EFfiApp ("Basis", "blessResponseHeader", [((se as EPrim (Prim.String s), loc), _)]) =>
(if Settings.checkResponseHeader s then
()
else
ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'blessResponseHeader'");
se)
- | EFfiApp ("Basis", "checkResponseHeader", [(se as EPrim (Prim.String s), loc)]) =>
+ | EFfiApp ("Basis", "checkResponseHeader", [((se as EPrim (Prim.String s), loc), _)]) =>
(if Settings.checkResponseHeader s then
ESome ((TFfi ("Basis", "string"), loc), (se, loc))
else
ENone (TFfi ("Basis", "string"), loc))
- | EFfiApp ("Basis", "checkString", [(EPrim (Prim.String s), loc)]) =>
+ | EFfiApp ("Basis", "checkString", [((EPrim (Prim.String s), loc), _)]) =>
let
fun uwify (cs, acc) =
case cs of
@@ -491,7 +491,7 @@ fun exp e =
EPrim (Prim.String s)
end
- | EFfiApp ("Basis", "viewify", [(EPrim (Prim.String s), loc)]) =>
+ | EFfiApp ("Basis", "viewify", [((EPrim (Prim.String s), loc), _)]) =>
let
fun uwify (cs, acc) =
case cs of
@@ -516,9 +516,9 @@ fun exp e =
EPrim (Prim.String s)
end
- | EFfiApp ("Basis", "unAs", [(EPrim (Prim.String s), _)]) =>
+ | EFfiApp ("Basis", "unAs", [((EPrim (Prim.String s), _), _)]) =>
EPrim (Prim.String (unAs s))
- | EFfiApp ("Basis", "unAs", [e']) =>
+ | EFfiApp ("Basis", "unAs", [(e', _)]) =>
let
fun parts (e as (_, loc)) =
case #1 e of
@@ -543,11 +543,11 @@ fun exp e =
| NONE => e
end
- | EFfiApp ("Basis", "str1", [(EPrim (Prim.Char ch), _)]) =>
+ | EFfiApp ("Basis", "str1", [((EPrim (Prim.Char ch), _), _)]) =>
EPrim (Prim.String (str ch))
- | EFfiApp ("Basis", "attrifyString", [(EFfiApp ("Basis", "str1", [e]), _)]) =>
+ | EFfiApp ("Basis", "attrifyString", [((EFfiApp ("Basis", "str1", [e]), _), _)]) =>
EFfiApp ("Basis", "attrifyChar", [e])
- | EFfiApp ("Basis", "attrifyString_w", [(EFfiApp ("Basis", "str1", [e]), _)]) =>
+ | EFfiApp ("Basis", "attrifyString_w", [((EFfiApp ("Basis", "str1", [e]), _), _)]) =>
EFfiApp ("Basis", "attrifyChar_w", [e])
| EBinop (_, "+", (EPrim (Prim.Int n1), _), (EPrim (Prim.Int n2), _)) => EPrim (Prim.Int (Int64.+ (n1, n2)))
diff --git a/src/mono_print.sml b/src/mono_print.sml
index 2d296745..bf1b0935 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -167,7 +167,7 @@ fun p_exp' par env (e, _) =
string ".",
string x,
string "(",
- p_list (p_exp env) es,
+ p_list (p_exp env o #1) es,
string "))"]
| EApp (e1, e2) => parenIf par (box [p_exp env e1,
space,
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 3507480e..88628ac2 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -390,20 +390,20 @@ fun reduce file =
| ENone _ => []
| ESome (_, e) => summarize d e
| EFfi _ => []
- | EFfiApp ("Basis", "get_cookie", [e]) =>
+ | EFfiApp ("Basis", "get_cookie", [(e, _)]) =>
summarize d e @ [ReadCookie]
| EFfiApp ("Basis", "set_cookie", es) =>
- List.concat (map (summarize d) es) @ [WriteCookie]
+ List.concat (map (summarize d o #1) es) @ [WriteCookie]
| EFfiApp ("Basis", "clear_cookie", es) =>
- List.concat (map (summarize d) es) @ [WriteCookie]
+ List.concat (map (summarize d o #1) es) @ [WriteCookie]
| EFfiApp (m, x, es) =>
if Settings.isEffectful (m, x) orelse Settings.isBenignEffectful (m, x) then
- List.concat (map (summarize d) es) @ [if m = "Basis" andalso String.isSuffix "_w" x then
- WritePage
- else
- Unsure]
+ List.concat (map (summarize d o #1) es) @ [if m = "Basis" andalso String.isSuffix "_w" x then
+ WritePage
+ else
+ Unsure]
else
- List.concat (map (summarize d) es)
+ List.concat (map (summarize d o #1) es)
| EApp ((EFfi _, _), e) => summarize d e
| EApp _ =>
let
diff --git a/src/mono_util.sml b/src/mono_util.sml
index 39305d1b..38016f85 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -156,6 +156,12 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
fun mfe ctx e acc =
S.bindP (mfe' ctx e acc, fe ctx)
+ and mfet ctx (e, t) =
+ S.bind2 (mfe ctx e,
+ fn e' =>
+ S.map2 (mft t,
+ fn t' => (e', t')))
+
and mfe' ctx (eAll as (e, loc)) =
case e of
EPrim _ => S.return2 eAll
@@ -178,7 +184,7 @@ fun mapfoldB {typ = fc, exp = fe, bind} =
(ESome (t', e'), loc)))
| EFfi _ => S.return2 eAll
| EFfiApp (m, x, es) =>
- S.map2 (ListUtil.mapfold (fn e => mfe ctx e) es,
+ S.map2 (ListUtil.mapfold (fn e => mfet ctx e) es,
fn es' =>
(EFfiApp (m, x, es'), loc))
| EApp (e1, e2) =>
@@ -479,7 +485,7 @@ fun appLoc f =
| ENone _ => ()
| ESome (_, e) => appl e
| EFfi _ => ()
- | EFfiApp (_, _, es) => app appl es
+ | EFfiApp (_, _, es) => app (appl o #1) es
| EApp (e1, e2) => (appl e1; appl e2)
| EAbs (_, _, _, e1) => appl e1
| EUnop (_, e1) => appl e1
diff --git a/src/monoize.sml b/src/monoize.sml
index 82e0030c..d952c396 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -509,7 +509,7 @@ fun fooifyExp fk env =
| _ =>
case t of
L'.TFfi ("Basis", "unit") => ((L'.EPrim (Prim.String ""), loc), fm)
- | L'.TFfi (m, x) => ((L'.EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [e]), loc), fm)
+ | L'.TFfi (m, x) => ((L'.EFfiApp (m, fk2s fk ^ "ify" ^ capitalize x, [(e, tAll)]), loc), fm)
| L'.TRecord [] => ((L'.EPrim (Prim.String ""), loc), fm)
| L'.TRecord ((x, t) :: xts) =>
@@ -944,7 +944,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L'.TFun ((L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
(L'.EAbs ("y", (L'.TFfi ("Basis", "time"), loc),
(L'.TFfi ("Basis", "bool"), loc),
- (L'.EFfiApp ("Basis", "eq_time", [(L'.ERel 1, loc), (L'.ERel 0, loc)]), loc)), loc)), loc),
+ (L'.EFfiApp ("Basis", "eq_time", [((L'.ERel 1, loc), (L'.TFfi ("Basis", "time"), loc)),
+ ((L'.ERel 0, loc), (L'.TFfi ("Basis", "time"), loc))]), loc)), loc)), loc),
fm)
| L.ECApp ((L.EFfi ("Basis", "mkEq"), _), t) =>
@@ -1169,7 +1170,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L'.TFun ((L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "bool"), loc)), loc),
(L'.EAbs ("y", (L'.TFfi ("Basis", "time"), loc),
(L'.TFfi ("Basis", "bool"), loc),
- (L'.EFfiApp ("Basis", s, [(L'.ERel 1, loc), (L'.ERel 0, loc)]), loc)), loc)), loc)
+ (L'.EFfiApp ("Basis", s, [((L'.ERel 1, loc), (L'.TFfi ("Basis", "time"), loc)),
+ ((L'.ERel 0, loc), (L'.TFfi ("Basis", "time"), loc))]), loc)), loc)), loc)
in
ordEx ((L'.TFfi ("Basis", "time"), loc),
boolBin "lt_time",
@@ -1368,14 +1370,14 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
end
| L.EFfiApp ("Basis", "recv", _) => poly ()
- | L.EFfiApp ("Basis", "float", [e]) =>
+ | L.EFfiApp ("Basis", "float", [(e, t)]) =>
let
val (e, fm) = monoExp (env, st, fm) e
in
- ((L'.EFfiApp ("Basis", "floatFromInt", [e]), loc), fm)
+ ((L'.EFfiApp ("Basis", "floatFromInt", [(e, monoType env t)]), loc), fm)
end
- | L.EFfiApp ("Basis", "sleep", [n]) =>
+ | L.EFfiApp ("Basis", "sleep", [(n, _)]) =>
let
val (n, fm) = monoExp (env, st, fm) n
in
@@ -1390,7 +1392,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
((L'.EAbs ("x", t, (L'.TFun ((L'.TRecord [], loc), (L'.TSource, loc)), loc),
(L'.EAbs ("_", (L'.TRecord [], loc), (L'.TSource, loc),
(L'.EFfiApp ("Basis", "new_client_source",
- [(L'.EJavaScript (L'.Source t, (L'.ERel 1, loc)), loc)]),
+ [((L'.EJavaScript (L'.Source t, (L'.ERel 1, loc)), loc),
+ (L'.TSource, loc))]),
loc)), loc)),
loc),
fm)
@@ -1404,9 +1407,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L'.EAbs ("v", t, (L'.TFun ((L'.TRecord [], loc), (L'.TRecord [], loc)), loc),
(L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
(L'.EFfiApp ("Basis", "set_client_source",
- [(L'.ERel 2, loc),
- (L'.EJavaScript (L'.Source t,
- (L'.ERel 1, loc)), loc)]),
+ [((L'.ERel 2, loc), (L'.TSource, loc)),
+ ((L'.EJavaScript (L'.Source t,
+ (L'.ERel 1, loc)), loc),
+ t)]),
loc)), loc)), loc)), loc),
fm)
end
@@ -1418,7 +1422,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L'.TFun ((L'.TRecord [], loc), t), loc),
(L'.EAbs ("_", (L'.TRecord [], loc), t,
(L'.EFfiApp ("Basis", "get_client_source",
- [(L'.ERel 1, loc)]),
+ [((L'.ERel 1, loc), (L'.TSource, loc))]),
loc)), loc)), loc),
fm)
end
@@ -1430,12 +1434,12 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L'.TFun ((L'.TRecord [], loc), t), loc),
(L'.EAbs ("_", (L'.TRecord [], loc), t,
(L'.EFfiApp ("Basis", "current",
- [(L'.ERel 1, loc)]),
+ [((L'.ERel 1, loc), (L'.TSource, loc))]),
loc)), loc)), loc),
fm)
end
- | L.EFfiApp ("Basis", "spawn", [e]) =>
+ | L.EFfiApp ("Basis", "spawn", [(e, _)]) =>
let
val (e, fm) = monoExp (env, st, fm) e
in
@@ -1480,7 +1484,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
in
((L'.EAbs ("c", s, (L'.TFun (un, s), loc),
(L'.EAbs ("_", un, s,
- (L'.EUnurlify ((L'.EFfiApp ("Basis", "get_cookie", [(L'.ERel 1, loc)]), loc),
+ (L'.EUnurlify ((L'.EFfiApp ("Basis", "get_cookie", [((L'.ERel 1, loc), s)]), loc),
t, true),
loc)), loc)), loc),
fm)
@@ -1502,13 +1506,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
((L'.EAbs ("c", s, (L'.TFun (rt, (L'.TFun (un, un), loc)), loc),
(L'.EAbs ("r", rt, (L'.TFun (un, un), loc),
(L'.EAbs ("_", un, un,
- (L'.EFfiApp ("Basis", "set_cookie", [(L'.EPrim (Prim.String
- (Settings.getUrlPrefix ())),
- loc),
- (L'.ERel 2, loc),
- e,
- fd "Expires",
- fd "Secure"])
+ (L'.EFfiApp ("Basis", "set_cookie", [((L'.EPrim (Prim.String
+ (Settings.getUrlPrefix ())),
+ loc), s),
+ ((L'.ERel 2, loc), s),
+ (e, s),
+ (fd "Expires", (L'.TOption (L'.TFfi ("Basis", "time"), loc), loc)),
+ (fd "Secure", (L'.TFfi ("Basis", "bool"), loc))])
, loc)), loc)), loc)), loc),
fm)
end
@@ -1521,17 +1525,17 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
((L'.EAbs ("c", s, (L'.TFun (un, un), loc),
(L'.EAbs ("_", un, un,
(L'.EFfiApp ("Basis", "clear_cookie",
- [(L'.EPrim (Prim.String
- (Settings.getUrlPrefix ())),
- loc),
- (L'.ERel 1, loc)]),
+ [((L'.EPrim (Prim.String
+ (Settings.getUrlPrefix ())),
+ loc), s),
+ ((L'.ERel 1, loc), s)]),
loc)), loc)), loc),
fm)
end
| L.ECApp ((L.EFfi ("Basis", "channel"), _), t) =>
((L'.EAbs ("_", (L'.TRecord [], loc), (L'.TFfi ("Basis", "channel"), loc),
- (L'.EFfiApp ("Basis", "new_channel", [(L'.ERecord [], loc)]), loc)), loc),
+ (L'.EFfiApp ("Basis", "new_channel", [((L'.ERecord [], loc), (L'.TRecord [], loc))]), loc)), loc),
fm)
| L.ECApp ((L.EFfi ("Basis", "send"), _), t) =>
let
@@ -1543,8 +1547,8 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(L'.EAbs ("v", t, (L'.TFun ((L'.TRecord [], loc), (L'.TRecord [], loc)), loc),
(L'.EAbs ("_", (L'.TRecord [], loc), (L'.TRecord [], loc),
(L'.EFfiApp ("Basis", "send",
- [(L'.ERel 2, loc),
- e]),
+ [((L'.ERel 2, loc), (L'.TFfi ("Basis", "channel"), loc)),
+ (e, (L'.TFfi ("Basis", "string"), loc))]),
loc)), loc)), loc)), loc),
fm)
end
@@ -1763,11 +1767,11 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
((L'.EAbs ("e", string, string,
(L'.EStrcat ((L'.EPrim (Prim.String "CHECK "), loc),
(L'.EFfiApp ("Basis", "checkString",
- [(L'.ERel 0, loc)]), loc)), loc)), loc),
+ [((L'.ERel 0, loc), string)]), loc)), loc)), loc),
fm)
end
- | L.EFfiApp ("Basis", "dml", [e]) =>
+ | L.EFfiApp ("Basis", "dml", [(e, _)]) =>
let
val (e, fm) = monoExp (env, st, fm) e
in
@@ -1775,7 +1779,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
fm)
end
- | L.EFfiApp ("Basis", "tryDml", [e]) =>
+ | L.EFfiApp ("Basis", "tryDml", [(e, _)]) =>
let
val (e, fm) = monoExp (env, st, fm) e
in
@@ -1841,13 +1845,14 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
strcat [sc ("uw_" ^ x
^ " = "),
(L'.EFfiApp ("Basis", "unAs",
- [(L'.EField
- ((L'.ERel 2,
- loc),
- x), loc)]), loc)])
+ [((L'.EField
+ ((L'.ERel 2,
+ loc),
+ x), loc),
+ s)]), loc)])
changed),
sc " WHERE ",
- (L'.EFfiApp ("Basis", "unAs", [(L'.ERel 0, loc)]), loc)]),
+ (L'.EFfiApp ("Basis", "unAs", [((L'.ERel 0, loc), s)]), loc)]),
loc)), loc)), loc),
fm)
end
@@ -1869,7 +1874,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
strcat [sc "DELETE FROM ",
(L'.ERel 1, loc),
sc " WHERE ",
- (L'.EFfiApp ("Basis", "unAs", [(L'.ERel 0, loc)]), loc)]), loc)), loc),
+ (L'.EFfiApp ("Basis", "unAs", [((L'.ERel 0, loc), s)]), loc)]), loc)), loc),
fm)
end
@@ -2108,43 +2113,43 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
| L.EFfi ("Basis", "sql_int") =>
((L'.EAbs ("x", (L'.TFfi ("Basis", "int"), loc), (L'.TFfi ("Basis", "string"), loc),
- (L'.EFfiApp ("Basis", "sqlifyInt", [(L'.ERel 0, loc)]), loc)), loc),
+ (L'.EFfiApp ("Basis", "sqlifyInt", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "int"), loc))]), loc)), loc),
fm)
| L.EFfi ("Basis", "sql_float") =>
((L'.EAbs ("x", (L'.TFfi ("Basis", "float"), loc), (L'.TFfi ("Basis", "string"), loc),
- (L'.EFfiApp ("Basis", "sqlifyFloat", [(L'.ERel 0, loc)]), loc)), loc),
+ (L'.EFfiApp ("Basis", "sqlifyFloat", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "float"), loc))]), loc)), loc),
fm)
| L.EFfi ("Basis", "sql_bool") =>
((L'.EAbs ("x", (L'.TFfi ("Basis", "bool"), loc), (L'.TFfi ("Basis", "string"), loc),
- (L'.EFfiApp ("Basis", "sqlifyBool", [(L'.ERel 0, loc)]), loc)), loc),
+ (L'.EFfiApp ("Basis", "sqlifyBool", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "bool"), loc))]), loc)), loc),
fm)
| L.EFfi ("Basis", "sql_string") =>
((L'.EAbs ("x", (L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "string"), loc),
- (L'.EFfiApp ("Basis", "sqlifyString", [(L'.ERel 0, loc)]), loc)), loc),
+ (L'.EFfiApp ("Basis", "sqlifyString", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "string"), loc))]), loc)), loc),
fm)
| L.EFfi ("Basis", "sql_char") =>
((L'.EAbs ("x", (L'.TFfi ("Basis", "char"), loc), (L'.TFfi ("Basis", "string"), loc),
- (L'.EFfiApp ("Basis", "sqlifyChar", [(L'.ERel 0, loc)]), loc)), loc),
+ (L'.EFfiApp ("Basis", "sqlifyChar", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "char"), loc))]), loc)), loc),
fm)
| L.EFfi ("Basis", "sql_time") =>
((L'.EAbs ("x", (L'.TFfi ("Basis", "time"), loc), (L'.TFfi ("Basis", "string"), loc),
- (L'.EFfiApp ("Basis", "sqlifyTime", [(L'.ERel 0, loc)]), loc)), loc),
+ (L'.EFfiApp ("Basis", "sqlifyTime", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "time"), loc))]), loc)), loc),
fm)
| L.EFfi ("Basis", "sql_blob") =>
((L'.EAbs ("x", (L'.TFfi ("Basis", "blob"), loc), (L'.TFfi ("Basis", "string"), loc),
- (L'.EFfiApp ("Basis", "sqlifyBlob", [(L'.ERel 0, loc)]), loc)), loc),
+ (L'.EFfiApp ("Basis", "sqlifyBlob", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "blob"), loc))]), loc)), loc),
fm)
| L.ECApp ((L.EFfi ("Basis", "sql_channel"), _), _) =>
((L'.EAbs ("x", (L'.TFfi ("Basis", "channel"), loc), (L'.TFfi ("Basis", "string"), loc),
- (L'.EFfiApp ("Basis", "sqlifyChannel", [(L'.ERel 0, loc)]), loc)), loc),
+ (L'.EFfiApp ("Basis", "sqlifyChannel", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "channel"), loc))]), loc)), loc),
fm)
| L.EFfi ("Basis", "sql_client") =>
((L'.EAbs ("x", (L'.TFfi ("Basis", "client"), loc), (L'.TFfi ("Basis", "string"), loc),
- (L'.EFfiApp ("Basis", "sqlifyClient", [(L'.ERel 0, loc)]), loc)), loc),
+ (L'.EFfiApp ("Basis", "sqlifyClient", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "client"), loc))]), loc)), loc),
fm)
| L.ECApp ((L.EFfi ("Basis", "sql_serialized"), _), _) =>
((L'.EAbs ("x", (L'.TFfi ("Basis", "string"), loc), (L'.TFfi ("Basis", "string"), loc),
- (L'.EFfiApp ("Basis", "sqlifyString", [(L'.ERel 0, loc)]), loc)), loc),
+ (L'.EFfiApp ("Basis", "sqlifyString", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "string"), loc))]), loc)), loc),
fm)
| L.ECApp ((L.EFfi ("Basis", "sql_prim"), _), t) =>
let
@@ -2430,26 +2435,26 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
| L.EFfi ("Basis", "sql_no_limit") =>
((L'.EPrim (Prim.String ""), loc), fm)
- | L.EFfiApp ("Basis", "sql_limit", [e]) =>
+ | L.EFfiApp ("Basis", "sql_limit", [(e, t)]) =>
let
val (e, fm) = monoExp (env, st, fm) e
in
(strcat [
(L'.EPrim (Prim.String " LIMIT "), loc),
- (L'.EFfiApp ("Basis", "sqlifyInt", [e]), loc)
+ (L'.EFfiApp ("Basis", "sqlifyInt", [(e, monoType env t)]), loc)
],
fm)
end
| L.EFfi ("Basis", "sql_no_offset") =>
((L'.EPrim (Prim.String ""), loc), fm)
- | L.EFfiApp ("Basis", "sql_offset", [e]) =>
+ | L.EFfiApp ("Basis", "sql_offset", [(e, t)]) =>
let
val (e, fm) = monoExp (env, st, fm) e
in
(strcat [
(L'.EPrim (Prim.String " OFFSET "), loc),
- (L'.EFfiApp ("Basis", "sqlifyInt", [e]), loc)
+ (L'.EFfiApp ("Basis", "sqlifyInt", [(e, monoType env t)]), loc)
],
fm)
end
@@ -2914,13 +2919,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
fm)
end
- | L.EFfiApp ("Basis", "nextval", [e]) =>
+ | L.EFfiApp ("Basis", "nextval", [(e, _)]) =>
let
val (e, fm) = monoExp (env, st, fm) e
in
((L'.ENextval e, loc), fm)
end
- | L.EFfiApp ("Basis", "setval", [e1, e2]) =>
+ | L.EFfiApp ("Basis", "setval", [(e1, _), (e2, _)]) =>
let
val (e1, fm) = monoExp (env, st, fm) e1
val (e2, fm) = monoExp (env, st, fm) e2
@@ -2930,7 +2935,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
| L.EFfi ("Basis", "null") => ((L'.EPrim (Prim.String ""), loc), fm)
- | L.EFfiApp ("Basis", "classes", [s1, s2]) =>
+ | L.EFfiApp ("Basis", "classes", [(s1, _), (s2, _)]) =>
let
val (s1, fm) = monoExp (env, st, fm) s1
val (s2, fm) = monoExp (env, st, fm) s2
@@ -2947,13 +2952,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
let
val (se, fm) = monoExp (env, st, fm) se
in
- ((L'.EFfiApp ("Basis", "htmlifyString", [se]), loc), fm)
+ ((L'.EFfiApp ("Basis", "htmlifyString", [(se, (L'.TFfi ("Basis", "string"), loc))]), loc), fm)
end
| L.ECApp (
(L.ECApp ((L.EFfi ("Basis", "cdataChar"), _), _), _),
_) =>
((L'.EAbs ("ch", (L'.TFfi ("Basis", "char"), loc), (L'.TFfi ("Basis", "string"), loc),
- (L'.EFfiApp ("Basis", "htmlifySpecialChar", [(L'.ERel 0, loc)]), loc)), loc), fm)
+ (L'.EFfiApp ("Basis", "htmlifySpecialChar", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "char"), loc))]), loc)), loc), fm)
| L.EApp (
(L.EApp (
@@ -3010,7 +3015,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
fun getTag (e, _) =
case e of
- L.EFfiApp ("Basis", tag, [(L.ERecord [], _)]) => (tag, [])
+ L.EFfiApp ("Basis", tag, [((L.ERecord [], _), _)]) => (tag, [])
| L.EApp (e, (L.ERecord [], _)) => getTag' e
| _ => (E.errorAt loc "Non-constant XML tag";
Print.eprefaces' [("Expression", CorePrint.p_exp env tag)];
@@ -3297,17 +3302,20 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
"body" => let
val onload = execify onload
val onunload = execify onunload
+ val s = (L'.TFfi ("Basis", "string"), loc)
in
normal ("body",
SOME (L'.EStrcat ((L'.EFfiApp ("Basis", "maybe_onload",
- [(L'.EStrcat ((L'.EFfiApp ("Basis", "get_settings",
- [(L'.ERecord [], loc)]), loc),
- onload), loc)]),
+ [((L'.EStrcat ((L'.EFfiApp ("Basis", "get_settings",
+ [((L'.ERecord [], loc),
+ (L'.TRecord [], loc))]), loc),
+ onload), loc),
+ s)]),
loc),
(L'.EFfiApp ("Basis", "maybe_onunload",
- [onunload]),
+ [(onunload, s)]),
loc)), loc),
- SOME (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]), loc))
+ SOME (L'.EFfiApp ("Basis", "get_script", [((L'.ERecord [], loc), (L'.TRecord [], loc))]), loc))
end
| "dyn" =>
@@ -3645,7 +3653,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
end
val sigName = getSigName ()
- val sigSet = (L'.EFfiApp ("Basis", "sigString", [(L'.ERecord [], loc)]), loc)
+ val sigSet = (L'.EFfiApp ("Basis", "sigString", [((L'.ERecord [], loc), (L'.TRecord [], loc))]), loc)
val sigSet = (L'.EStrcat ((L'.EPrim (Prim.String ("
+ | L.EFfiApp ("Basis", "url", [(e, _)]) =>
let
val (e, fm) = monoExp (env, st, fm) e
val (e, fm) = urlifyExp env fm (e, dummyTyp)
@@ -3815,7 +3823,12 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
| L.EFfi mx => ((L'.EFfi mx, loc), fm)
| L.EFfiApp (m, x, es) =>
let
- val (es, fm) = ListUtil.foldlMap (fn (e, fm) => monoExp (env, st, fm) e) fm es
+ val (es, fm) = ListUtil.foldlMap (fn ((e, t), fm) =>
+ let
+ val (e, fm) = monoExp (env, st, fm) e
+ in
+ ((e, monoType env t), fm)
+ end) fm es
in
((L'.EFfiApp (m, x, es), loc), fm)
end
@@ -4054,7 +4067,7 @@ fun monoDecl (env, fm) (all as (d, loc)) =
val xts = map (fn (x, t) => (monoName env x, monoType env t)) xts
val (e, fm) = monoExp (env, St.empty, fm) e
- val e = (L'.EFfiApp ("Basis", "viewify", [e]), loc)
+ val e = (L'.EFfiApp ("Basis", "viewify", [(e, t')]), loc)
in
SOME (Env.pushENamed env x n t NONE s,
fm,
@@ -4110,7 +4123,7 @@ fun monoDecl (env, fm) (all as (d, loc)) =
let
fun policies (e, fm) =
case #1 e of
- L.EFfiApp ("Basis", "also", [e1, e2]) =>
+ L.EFfiApp ("Basis", "also", [(e1, _), (e2, _)]) =>
let
val (ps1, fm) = policies (e1, fm)
val (ps2, fm) = policies (e2, fm)
@@ -4129,7 +4142,7 @@ fun monoDecl (env, fm) (all as (d, loc)) =
(e, L'.PolDelete)
| L.EApp ((L.ECApp ((L.ECApp ((L.EFfi ("Basis", "mayUpdate"), _), _), _), _), _), e) =>
(e, L'.PolUpdate)
- | L.EFfiApp ("Basis", "sendOwnIds", [e]) =>
+ | L.EFfiApp ("Basis", "sendOwnIds", [(e, _)]) =>
(e, L'.PolSequence)
| _ => (poly (); (e, L'.PolClient))
@@ -4186,7 +4199,7 @@ fun monoize env file =
fun expunger () =
let
- val target = (L'.EFfiApp ("Basis", "sqlifyClient", [(L'.ERel 0, loc)]), loc)
+ val target = (L'.EFfiApp ("Basis", "sqlifyClient", [((L'.ERel 0, loc), (L'.TFfi ("Basis", "client"), loc))]), loc)
fun doTable (tab, xts, e) =
case xts of
diff --git a/src/prepare.sml b/src/prepare.sml
index 1b7454dc..7f55959c 100644
--- a/src/prepare.sml
+++ b/src/prepare.sml
@@ -67,25 +67,25 @@ fun prepString (e, st) =
case #1 e of
EPrim (Prim.String s) =>
SOME (s :: ss, n)
- | EFfiApp ("Basis", "strcat", [e1, e2]) =>
+ | EFfiApp ("Basis", "strcat", [(e1, _), (e2, _)]) =>
(case prepString' (e1, ss, n) of
NONE => NONE
| SOME (ss, n) => prepString' (e2, ss, n))
- | EFfiApp ("Basis", "sqlifyInt", [e]) => doOne Int
- | EFfiApp ("Basis", "sqlifyFloat", [e]) => doOne Float
- | EFfiApp ("Basis", "sqlifyString", [e]) => doOne String
- | EFfiApp ("Basis", "sqlifyBool", [e]) => doOne Bool
- | EFfiApp ("Basis", "sqlifyTime", [e]) => doOne Time
- | EFfiApp ("Basis", "sqlifyBlob", [e]) => doOne Blob
- | EFfiApp ("Basis", "sqlifyChannel", [e]) => doOne Channel
- | EFfiApp ("Basis", "sqlifyClient", [e]) => doOne Client
+ | EFfiApp ("Basis", "sqlifyInt", [_]) => doOne Int
+ | EFfiApp ("Basis", "sqlifyFloat", [_]) => doOne Float
+ | EFfiApp ("Basis", "sqlifyString", [_]) => doOne String
+ | EFfiApp ("Basis", "sqlifyBool", [_]) => doOne Bool
+ | EFfiApp ("Basis", "sqlifyTime", [_]) => doOne Time
+ | EFfiApp ("Basis", "sqlifyBlob", [_]) => doOne Blob
+ | EFfiApp ("Basis", "sqlifyChannel", [_]) => doOne Channel
+ | EFfiApp ("Basis", "sqlifyClient", [_]) => doOne Client
| ECase (e,
[((PNone _, _),
(EPrim (Prim.String "NULL"), _)),
((PSome (_, (PVar _, _)), _),
- (EFfiApp (m, x, [(ERel 0, _)]), _))],
- _) => prepString' ((EFfiApp (m, x, [e]), #2 e), ss, n)
+ (EFfiApp (m, x, [((ERel 0, _), _)]), _))],
+ {disc = t, ...}) => prepString' ((EFfiApp (m, x, [(e, t)]), #2 e), ss, n)
| ECase (e,
[((PCon (_, PConFfi {mod = "Basis", con = "True", ...}, _), _),
@@ -130,7 +130,12 @@ fun prepExp (e as (_, loc), st) =
| EFfi _ => (e, st)
| EFfiApp (m, x, es) =>
let
- val (es, st) = ListUtil.foldlMap prepExp st es
+ val (es, st) = ListUtil.foldlMap (fn ((e, t), st) =>
+ let
+ val (e, st) = prepExp (e, st)
+ in
+ ((e, t), st)
+ end) st es
in
((EFfiApp (m, x, es), loc), st)
end
@@ -260,9 +265,10 @@ fun prepExp (e as (_, loc), st) =
(EPrim (Prim.String ("SELECT NEXTVAL('" ^ s ^ "')")), loc)
| _ =>
let
- val s' = (EFfiApp ("Basis", "strcat", [seq, (EPrim (Prim.String "')"), loc)]), loc)
+ val t = (TFfi ("Basis", "string"), loc)
+ val s' = (EFfiApp ("Basis", "strcat", [(seq, t), ((EPrim (Prim.String "')"), loc), t)]), loc)
in
- (EFfiApp ("Basis", "strcat", [(EPrim (Prim.String "SELECT NEXTVAL('"), loc), s']), loc)
+ (EFfiApp ("Basis", "strcat", [((EPrim (Prim.String "SELECT NEXTVAL('"), loc), t), (s', t)]), loc)
end
in
case prepString (s, st) of
diff --git a/src/reduce.sml b/src/reduce.sml
index 9371e9bd..1fbf526d 100644
--- a/src/reduce.sml
+++ b/src/reduce.sml
@@ -493,7 +493,7 @@ fun kindConAndExp (namedC, namedE) =
bindType (CFfi ("Basis", "signal"), loc) loc)], loc)
| EFfi _ => all
- | EFfiApp (m, f, es) => (EFfiApp (m, f, map (exp env) es), loc)
+ | EFfiApp (m, f, es) => (EFfiApp (m, f, map (fn (e, t) => (exp env e, con env t)) es), loc)
(*| EApp (
(EApp
diff --git a/src/reduce_local.sml b/src/reduce_local.sml
index 0e87e34a..a6e4f7fc 100644
--- a/src/reduce_local.sml
+++ b/src/reduce_local.sml
@@ -256,7 +256,7 @@ fun exp env (all as (e, loc)) =
| ENamed _ => all
| ECon (dk, pc, cs, eo) => (ECon (dk, patCon pc, map (con env) cs, Option.map (exp env) eo), loc)
| EFfi _ => all
- | EFfiApp (m, f, es) => (EFfiApp (m, f, map (exp env) es), loc)
+ | EFfiApp (m, f, es) => (EFfiApp (m, f, map (fn (e, t) => (exp env e, con env t)) es), loc)
| EApp (e1, e2) =>
let
diff --git a/src/scriptcheck.sml b/src/scriptcheck.sml
index 129f4281..6c6c5588 100644
--- a/src/scriptcheck.sml
+++ b/src/scriptcheck.sml
@@ -92,12 +92,12 @@ fun classify (ds, ps) =
| EFfi ("Basis", x) => SS.member (basis, x)
| EFfi _ => false
| EFfiApp ("Basis", "maybe_onload",
- [(EFfiApp ("Basis", "strcat", all as [_, (EPrim (Prim.String s), _)]), _)]) =>
- List.exists hasClient all
+ [((EFfiApp ("Basis", "strcat", all as [_, ((EPrim (Prim.String s), _), _)]), _), _)]) =>
+ List.exists (hasClient o #1) all
orelse (onload andalso size s > 0)
| EFfiApp ("Basis", x, es) => SS.member (basis, x)
- orelse List.exists hasClient es
- | EFfiApp (_, _, es) => List.exists hasClient es
+ orelse List.exists (hasClient o #1) es
+ | EFfiApp (_, _, es) => List.exists (hasClient o #1) es
| EApp (e, es) => hasClient e orelse List.exists hasClient es
| EUnop (_, e) => hasClient e
| EBinop (_, e1, e2) => hasClient e1 orelse hasClient e2
diff --git a/src/tag.sml b/src/tag.sml
index 26c23586..6037cb17 100644
--- a/src/tag.sml
+++ b/src/tag.sml
@@ -170,22 +170,22 @@ fun exp env (e, s) =
end
| _ => (e, s))
- | EFfiApp ("Basis", "url", [(ERel 0, _)]) => (e, s)
+ | EFfiApp ("Basis", "url", [((ERel 0, _), _)]) => (e, s)
- | EFfiApp ("Basis", "url", [e]) =>
+ | EFfiApp ("Basis", "url", [(e, t)]) =>
let
val (e, s) = tagIt (e, Link, "Url", s)
in
- (EFfiApp ("Basis", "url", [e]), s)
+ (EFfiApp ("Basis", "url", [(e, t)]), s)
end
- | EFfiApp ("Basis", "effectfulUrl", [(ERel 0, _)]) => (e, s)
+ | EFfiApp ("Basis", "effectfulUrl", [((ERel 0, _), _)]) => (e, s)
- | EFfiApp ("Basis", "effectfulUrl", [e]) =>
+ | EFfiApp ("Basis", "effectfulUrl", [(e, t)]) =>
let
val (e, s) = tagIt (e, Extern ReadCookieWrite, "Url", s)
in
- (EFfiApp ("Basis", "url", [e]), s)
+ (EFfiApp ("Basis", "url", [(e, t)]), s)
end
| EApp ((ENamed n, _), e') =>
@@ -193,11 +193,11 @@ fun exp env (e, s) =
val (_, _, eo, _) = E.lookupENamed env n
in
case eo of
- SOME (EAbs (_, _, _, (EFfiApp ("Basis", "url", [(ERel 0, _)]), _)), _) =>
+ SOME (EAbs (_, _, _, (EFfiApp ("Basis", "url", [((ERel 0, _), t)]), _)), _) =>
let
val (e, s) = tagIt (e', Link, "Url", s)
in
- (EFfiApp ("Basis", "url", [e]), s)
+ (EFfiApp ("Basis", "url", [(e, t)]), s)
end
| _ => (e, s)
end
--
cgit v1.2.3
From b1ae41e16f100084d9a1676335e4947d4484c040 Mon Sep 17 00:00:00 2001
From: Adam Chlipala
Date: Sun, 16 Sep 2012 08:31:54 -0400
Subject: Better error message about signals remaining in server-side code
---
src/cjrize.sml | 4 +++-
1 file changed, 3 insertions(+), 1 deletion(-)
(limited to 'src/cjrize.sml')
diff --git a/src/cjrize.sml b/src/cjrize.sml
index a0ec2ece..9e41fda4 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -162,7 +162,9 @@ fun cifyTyp x =
((L'.TList (t', si), loc), sm)
end
| L.TSource => ((L'.TFfi ("Basis", "source"), loc), sm)
- | L.TSignal _ => raise Fail "Cjrize: TSignal remains"
+ | L.TSignal _ => (ErrorMsg.errorAt loc "TSignal remains";
+ Print.epreface ("Full type", MonoPrint.p_typ MonoEnv.empty (#1 x));
+ ((L'.TFfi ("Basis", "bogus"), loc), sm))
in
cify IM.empty x
end
--
cgit v1.2.3
From 3d21914a4b831ee9c727dd4296e56961c1e4ea89 Mon Sep 17 00:00:00 2001
From: Adam Chlipala
Date: Fri, 15 Mar 2013 16:09:55 -0400
Subject: Make Scriptcheck catch more script/message-passing uses, and move the
phase earlier in compilation
---
src/cjr.sml | 5 +-
src/cjrize.sml | 9 +++-
src/compiler.sig | 4 +-
src/compiler.sml | 18 ++++----
src/fuse.sml | 4 +-
src/iflow.sml | 6 +--
src/jscomp.sml | 8 ++--
src/mono.sml | 7 ++-
src/mono_print.sml | 2 +-
src/mono_reduce.sml | 4 +-
src/mono_shake.sml | 34 +++++++-------
src/mono_util.sml | 55 +++++++++++-----------
src/monoize.sml | 2 +-
src/name_js.sml | 6 +--
src/pathcheck.sml | 2 +-
src/scriptcheck.sig | 2 +-
src/scriptcheck.sml | 131 +++++++++++-----------------------------------------
src/untangle.sml | 4 +-
18 files changed, 119 insertions(+), 184 deletions(-)
(limited to 'src/cjrize.sml')
diff --git a/src/cjr.sml b/src/cjr.sml
index c348d01a..3a37b26f 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -128,10 +128,7 @@ datatype decl' =
withtype decl = decl' located
-datatype sidedness =
- ServerOnly
- | ServerAndPull
- | ServerAndPullAndPush
+datatype sidedness = datatype Mono.sidedness
datatype effect = datatype Export.effect
datatype export_kind = datatype Export.export_kind
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 9e41fda4..0f4bdb42 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -694,7 +694,7 @@ fun cifyDecl ((d, loc), sm) =
| L.DPolicy _ => (NONE, NONE, sm)
| L.DOnError n => (SOME (L'.DOnError n, loc), NONE, sm)
-fun cjrize ds =
+fun cjrize (ds, sideInfo) =
let
val (dsF, ds, ps, sm) = foldl (fn (d, (dsF, ds, ps, sm)) =>
let
@@ -722,6 +722,13 @@ fun cjrize ds =
(dsF, ds, ps, Sm.clearDeclares sm)
end)
([], [], [], Sm.empty) ds
+
+ val sideInfo = foldl (fn ((n, mode), mp) => IM.insert (mp, n, mode)) IM.empty sideInfo
+
+ val ps = map (fn (ek, s, n, ts, t, _, b) =>
+ (ek, s, n, ts, t,
+ getOpt (IM.find (sideInfo, n), L'.ServerOnly),
+ b)) ps
in
(List.revAppend (dsF, rev ds),
ps)
diff --git a/src/compiler.sig b/src/compiler.sig
index 7e4f2f6a..fcf664eb 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -116,12 +116,12 @@ signature COMPILER = sig
val mono_shake : (Mono.file, Mono.file) phase
val iflow : (Mono.file, Mono.file) phase
val namejs : (Mono.file, Mono.file) phase
+ val scriptcheck : (Mono.file, Mono.file) phase
val jscomp : (Mono.file, Mono.file) phase
val fuse : (Mono.file, Mono.file) phase
val pathcheck : (Mono.file, Mono.file) phase
val sidecheck : (Mono.file, Mono.file) phase
val cjrize : (Mono.file, Cjr.file) phase
- val scriptcheck : (Cjr.file, Cjr.file) phase
val prepare : (Cjr.file, Cjr.file) phase
val checknest : (Cjr.file, Cjr.file) phase
val sqlify : (Mono.file, Cjr.file) phase
@@ -170,6 +170,7 @@ signature COMPILER = sig
val toIflow : (string, Mono.file) transform
val toNamejs : (string, Mono.file) transform
val toNamejs_untangle : (string, Mono.file) transform
+ val toScriptcheck : (string, Mono.file) transform
val toJscomp : (string, Mono.file) transform
val toMono_opt3 : (string, Mono.file) transform
val toFuse : (string, Mono.file) transform
@@ -184,7 +185,6 @@ signature COMPILER = sig
val toPathcheck : (string, Mono.file) transform
val toSidecheck : (string, Mono.file) transform
val toCjrize : (string, Cjr.file) transform
- val toScriptcheck : (string, Cjr.file) transform
val toPrepare : (string, Cjr.file) transform
val toChecknest : (string, Cjr.file) transform
val toSqlify : (string, Cjr.file) transform
diff --git a/src/compiler.sml b/src/compiler.sml
index f8dd07e2..77542811 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -1363,12 +1363,19 @@ val toNamejs = transform namejs "namejs" o toIflow
val toNamejs_untangle = transform untangle "namejs_untangle" o toNamejs
+val scriptcheck = {
+ func = ScriptCheck.classify,
+ print = MonoPrint.p_file MonoEnv.empty
+}
+
+val toScriptcheck = transform scriptcheck "scriptcheck" o toNamejs_untangle
+
val jscomp = {
func = JsComp.process,
print = MonoPrint.p_file MonoEnv.empty
}
-val toJscomp = transform jscomp "jscomp" o toNamejs_untangle
+val toJscomp = transform jscomp "jscomp" o toScriptcheck
val toMono_opt3 = transform mono_opt "mono_opt3" o toJscomp
@@ -1410,19 +1417,12 @@ val cjrize = {
val toCjrize = transform cjrize "cjrize" o toSidecheck
-val scriptcheck = {
- func = ScriptCheck.classify,
- print = CjrPrint.p_file CjrEnv.empty
-}
-
-val toScriptcheck = transform scriptcheck "scriptcheck" o toCjrize
-
val prepare = {
func = Prepare.prepare,
print = CjrPrint.p_file CjrEnv.empty
}
-val toPrepare = transform prepare "prepare" o toScriptcheck
+val toPrepare = transform prepare "prepare" o toCjrize
val checknest = {
func = fn f => if #supportsNestedPrepared (Settings.currentDbms ()) then f else Checknest.annotate f,
diff --git a/src/fuse.sml b/src/fuse.sml
index 565fc591..5193e59a 100644
--- a/src/fuse.sml
+++ b/src/fuse.sml
@@ -144,9 +144,9 @@ fun fuse file =
(funcs, maxName))
end
- val (file, _) = ListUtil.foldlMap doDecl (IM.empty, U.File.maxName file + 1) file
+ val (ds, _) = ListUtil.foldlMap doDecl (IM.empty, U.File.maxName file + 1) (#1 file)
in
- file
+ (ds, #2 file)
end
end
diff --git a/src/iflow.sml b/src/iflow.sml
index fe0be731..8c933dc4 100644
--- a/src/iflow.sml
+++ b/src/iflow.sml
@@ -1795,7 +1795,7 @@ fun evalExp env (e as (_, loc)) k =
datatype var_source = Input of int | SubInput of int | Unknown
-fun check file =
+fun check (file : file) =
let
val () = (St.reset ();
rfuns := IM.empty)
@@ -1810,7 +1810,7 @@ fun check file =
val exptd = foldl (fn ((d, _), exptd) =>
case d of
DExport (_, _, n, _, _, _) => IS.add (exptd, n)
- | _ => exptd) IS.empty file
+ | _ => exptd) IS.empty (#1 file)
fun decl (d, loc) =
case d of
@@ -2071,7 +2071,7 @@ fun check file =
| _ => ()
in
- app decl file
+ app decl (#1 file)
end
val check = fn file =>
diff --git a/src/jscomp.sml b/src/jscomp.sml
index ea34a3b5..ffb68ab2 100644
--- a/src/jscomp.sml
+++ b/src/jscomp.sml
@@ -61,7 +61,7 @@ exception CantEmbed of typ
fun inString {needle, haystack} = String.isSubstring needle haystack
-fun process file =
+fun process (file : file) =
let
val (someTs, nameds) =
foldl (fn ((DVal (_, n, t, e, _), _), (someTs, nameds)) => (someTs, IM.insert (nameds, n, e))
@@ -77,7 +77,7 @@ fun process file =
someTs) someTs dts,
nameds)
| (_, state) => state)
- (IM.empty, IM.empty) file
+ (IM.empty, IM.empty) (#1 file)
fun str loc s = (EPrim (Prim.String s), loc)
@@ -1304,7 +1304,7 @@ fun process file =
listInjectors = TM.empty,
decoders = IM.empty,
maxName = U.File.maxName file + 1}
- file
+ (#1 file)
val inf = TextIO.openIn (OS.Path.joinDirFile {dir = Settings.libJs (), file = "urweb.js"})
fun lines acc =
@@ -1334,7 +1334,7 @@ fun process file =
""
in
TextIO.closeIn inf;
- (DJavaScript script, ErrorMsg.dummySpan) :: ds
+ ((DJavaScript script, ErrorMsg.dummySpan) :: ds, #2 file)
end
end
diff --git a/src/mono.sml b/src/mono.sml
index 4a0278fd..f269c52d 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -157,6 +157,11 @@ datatype decl' =
withtype decl = decl' located
-type file = decl list
+datatype sidedness =
+ ServerOnly
+ | ServerAndPull
+ | ServerAndPullAndPush
+
+type file = decl list * (int * sidedness) list
end
diff --git a/src/mono_print.sml b/src/mono_print.sml
index e5ef4cf8..12b36f2a 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -530,7 +530,7 @@ fun p_decl env (dAll as (d, _) : decl) =
p_policy env p]
| DOnError _ => string "ONERROR"
-fun p_file env file =
+fun p_file env (file, _) =
let
val (pds, _) = ListUtil.foldlMap (fn (d, env) =>
(p_decl env d,
diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml
index 71c87095..e7fac5ed 100644
--- a/src/mono_reduce.sml
+++ b/src/mono_reduce.sml
@@ -308,7 +308,7 @@ val freeInAbs = U.Exp.existsB {typ = fn _ => false,
U.Exp.RelE _ => n + 1
| _ => n} 0
-fun reduce file =
+fun reduce (file : file) =
let
val (timpures, impures, absCounts) =
foldl (fn ((d, _), (timpures, impures, absCounts)) =>
@@ -366,7 +366,7 @@ fun reduce file =
absCounts vis)
| _ => (timpures, impures, absCounts)
end)
- (IS.empty, IS.empty, IM.empty) file
+ (IS.empty, IS.empty, IM.empty) (#1 file)
val uses = U.File.fold {typ = fn (_, m) => m,
exp = fn (e, m) =>
diff --git a/src/mono_shake.sml b/src/mono_shake.sml
index b6de9410..5818fea0 100644
--- a/src/mono_shake.sml
+++ b/src/mono_shake.sml
@@ -41,7 +41,7 @@ type free = {
exp : IS.set
}
-fun shake file =
+fun shake (file : file) =
let
val (cdef, edef) = foldl (fn ((DDatatype dts, _), (cdef, edef)) =>
(foldl (fn ((_, n, xncs), cdef) => IM.insert (cdef, n, xncs)) cdef dts, edef)
@@ -60,7 +60,7 @@ fun shake file =
| ((DTask _, _), acc) => acc
| ((DPolicy _, _), acc) => acc
| ((DOnError _, _), acc) => acc)
- (IM.empty, IM.empty) file
+ (IM.empty, IM.empty) (#1 file)
fun typ (c, s) =
case c of
@@ -130,7 +130,7 @@ fun shake file =
usedVars st e1
end
| ((DOnError n, _), (page_cs, page_es)) => (page_cs, IS.add (page_es, n))
- | (_, st) => st) (IS.empty, IS.empty) file
+ | (_, st) => st) (IS.empty, IS.empty) (#1 file)
val s = {con = page_cs, exp = page_es}
@@ -145,20 +145,20 @@ fun shake file =
NONE => raise Fail "MonoShake: Couldn't find 'val'"
| SOME (t, e) => shakeExp s e) s page_es
in
- List.filter (fn (DDatatype dts, _) => List.exists (fn (_, n, _) => IS.member (#con s, n)) dts
- | (DVal (_, n, _, _, _), _) => IS.member (#exp s, n)
- | (DValRec vis, _) => List.exists (fn (_, n, _, _, _) => IS.member (#exp s, n)) vis
- | (DExport _, _) => true
- | (DTable _, _) => true
- | (DSequence _, _) => true
- | (DView _, _) => true
- | (DDatabase _, _) => true
- | (DJavaScript _, _) => true
- | (DCookie _, _) => true
- | (DStyle _, _) => true
- | (DTask _, _) => true
- | (DPolicy _, _) => true
- | (DOnError _, _) => true) file
+ (List.filter (fn (DDatatype dts, _) => List.exists (fn (_, n, _) => IS.member (#con s, n)) dts
+ | (DVal (_, n, _, _, _), _) => IS.member (#exp s, n)
+ | (DValRec vis, _) => List.exists (fn (_, n, _, _, _) => IS.member (#exp s, n)) vis
+ | (DExport _, _) => true
+ | (DTable _, _) => true
+ | (DSequence _, _) => true
+ | (DView _, _) => true
+ | (DDatabase _, _) => true
+ | (DJavaScript _, _) => true
+ | (DCookie _, _) => true
+ | (DStyle _, _) => true
+ | (DTask _, _) => true
+ | (DPolicy _, _) => true
+ | (DOnError _, _) => true) (#1 file), #2 file)
end
end
diff --git a/src/mono_util.sml b/src/mono_util.sml
index 58498996..61638858 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -664,9 +664,9 @@ fun mapfoldB (all as {bind, ...}) =
let
val mfd = Decl.mapfoldB all
- fun mff ctx ds =
+ fun mff ctx (ds, ps) =
case ds of
- nil => S.return2 nil
+ nil => S.return2 (nil, ps)
| d :: ds' =>
S.bind2 (mfd ctx d,
fn d' =>
@@ -705,9 +705,9 @@ fun mapfoldB (all as {bind, ...}) =
| DPolicy _ => ctx
| DOnError _ => ctx
in
- S.map2 (mff ctx' ds',
- fn ds' =>
- d' :: ds')
+ S.map2 (mff ctx' (ds', ps),
+ fn (ds', _) =>
+ (d' :: ds', ps))
end)
in
mff
@@ -741,27 +741,28 @@ fun fold {typ, exp, decl} s d =
S.Continue (_, s) => s
| S.Return _ => raise Fail "MonoUtil.File.fold: Impossible"
-val maxName = foldl (fn ((d, _) : decl, count) =>
- case d of
- DDatatype dts =>
- foldl (fn ((_, n, ns), count) =>
- foldl (fn ((_, n', _), m) => Int.max (n', m))
- (Int.max (n, count)) ns) count dts
- | DVal (_, n, _, _, _) => Int.max (n, count)
- | DValRec vis => foldl (fn ((_, n, _, _, _), count) => Int.max (n, count)) count vis
- | DExport _ => count
- | DTable _ => count
- | DSequence _ => count
- | DView _ => count
- | DDatabase _ => count
- | DJavaScript _ => count
- | DCookie _ => count
- | DStyle _ => count
- | DTask _ => count
- | DPolicy _ => count
- | DOnError _ => count) 0
-
-fun appLoc f =
+fun maxName (f : file) =
+ foldl (fn ((d, _) : decl, count) =>
+ case d of
+ DDatatype dts =>
+ foldl (fn ((_, n, ns), count) =>
+ foldl (fn ((_, n', _), m) => Int.max (n', m))
+ (Int.max (n, count)) ns) count dts
+ | DVal (_, n, _, _, _) => Int.max (n, count)
+ | DValRec vis => foldl (fn ((_, n, _, _, _), count) => Int.max (n, count)) count vis
+ | DExport _ => count
+ | DTable _ => count
+ | DSequence _ => count
+ | DView _ => count
+ | DDatabase _ => count
+ | DJavaScript _ => count
+ | DCookie _ => count
+ | DStyle _ => count
+ | DTask _ => count
+ | DPolicy _ => count
+ | DOnError _ => count) 0 (#1 f)
+
+fun appLoc f (fl : file) =
let
val eal = Exp.appLoc f
@@ -790,7 +791,7 @@ fun appLoc f =
| PolUpdate e1 => eal e1
| PolSequence e1 => eal e1
in
- app appl
+ app appl (#1 fl)
end
end
diff --git a/src/monoize.sml b/src/monoize.sml
index e07c0c90..ce7bfbe9 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -4656,7 +4656,7 @@ fun monoize env file =
pvars := RM.empty;
pvarDefs := [];
pvarOldDefs := [];
- rev ds
+ (rev ds, [])
end
end
diff --git a/src/name_js.sml b/src/name_js.sml
index 70ac000c..53abd7a3 100644
--- a/src/name_js.sml
+++ b/src/name_js.sml
@@ -72,7 +72,7 @@ fun squish vs = U.Exp.mapB {typ = fn x => x,
fun rewrite file =
let
- val (file, _) = ListUtil.foldlMapConcat (fn (d, nextName) =>
+ val (ds, _) = ListUtil.foldlMapConcat (fn (d, nextName) =>
let
val (d, (nextName, newDs)) =
U.Decl.foldMapB {typ = fn x => x,
@@ -143,9 +143,9 @@ fun rewrite file =
DValRec vis => [(DValRec (vis @ newDs), #2 d)]
| _ => List.revAppend (map (fn vi => (DVal vi, #2 d)) newDs, [d]),
nextName)
- end) (U.File.maxName file + 1) file
+ end) (U.File.maxName file + 1) (#1 file)
in
- file
+ (ds, #2 file)
end
end
diff --git a/src/pathcheck.sml b/src/pathcheck.sml
index 15405db7..c1bb667b 100644
--- a/src/pathcheck.sml
+++ b/src/pathcheck.sml
@@ -110,6 +110,6 @@ fun checkDecl ((d, loc), (funcs, rels, cookies, styles)) =
| _ => (funcs, rels, cookies, styles)
end
-fun check ds = ignore (foldl checkDecl (SS.empty, SS.empty, SS.empty, SS.empty) ds)
+fun check (ds, _) = ignore (foldl checkDecl (SS.empty, SS.empty, SS.empty, SS.empty) ds)
end
diff --git a/src/scriptcheck.sig b/src/scriptcheck.sig
index bc9b6377..afb557b7 100644
--- a/src/scriptcheck.sig
+++ b/src/scriptcheck.sig
@@ -27,6 +27,6 @@
signature SCRIPT_CHECK = sig
- val classify : Cjr.file -> Cjr.file
+ val classify : Mono.file -> Mono.file
end
diff --git a/src/scriptcheck.sml b/src/scriptcheck.sml
index 6c6c5588..e5db476a 100644
--- a/src/scriptcheck.sml
+++ b/src/scriptcheck.sml
@@ -27,7 +27,7 @@
structure ScriptCheck :> SCRIPT_CHECK = struct
-open Cjr
+open Mono
structure SS = BinarySetFn(struct
type ord_key = string
@@ -35,98 +35,31 @@ structure SS = BinarySetFn(struct
end)
structure IS = IntBinarySet
-val pullBasis = SS.addList (SS.empty,
- ["new_client_source",
- "get_client_source",
- "set_client_source"])
-
val pushBasis = SS.addList (SS.empty,
["new_channel",
"self"])
-val events = ["abort",
- "blur",
- "change",
- "click",
- "dblclick",
- "error",
- "focus",
- "keydown",
- "keypress",
- "keyup",
- "load",
- "mousedown",
- "mousemove",
- "mouseout",
- "mouseover",
- "mouseup",
- "reset",
- "resize",
- "select",
- "submit",
- "unload"]
-
-val scriptWords = "")), loc)), loc)), loc),
+ strH ("))")), loc)), loc),
fm)
| _ => raise Fail "Monoize: Bad attributes"
end
@@ -3655,9 +3621,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(case attrs of
[("Code", e, _)] =>
((L'.EStrcat
- ((L'.EPrim (Prim.String ("")), loc)), loc)), loc),
+ strH "))"), loc)), loc),
fm)
| _ => raise Fail "Monoize: Bad attributes")
@@ -3665,9 +3631,9 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
(case attrs of
[("Code", e, _)] =>
((L'.EStrcat
- ((L'.EPrim (Prim.String ("")), loc)), loc)), loc),
+ strH "))"), loc)), loc),
fm)
| _ => raise Fail "Monoize: Bad