aboutsummaryrefslogtreecommitdiffhomepage
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adam@chlipala.net>2012-01-07 15:56:22 -0500
committerGravatar Adam Chlipala <adam@chlipala.net>2012-01-07 15:56:22 -0500
commit09b5839acfe26561fa87c89168133fc93c1083cc (patch)
tree587292f9b176c383c7b6332cdc30a817e355fe1d
parentbd78657f61d3783f9a282bf38ad0cbcb8b8bf5d4 (diff)
First part of changes to avoid depending on C function call argument order of evaluation (omitting normal Ur function calls, so far)
Diffstat
-rw-r--r--include/urweb.h8
-rw-r--r--src/checknest.sml4
-rw-r--r--src/cjr.sml2
-rw-r--r--src/cjr_print.sml140
-rw-r--r--src/cjrize.sml13
-rw-r--r--src/core.sml2
-rw-r--r--src/core_print.sml2
-rw-r--r--src/core_util.sml10
-rw-r--r--src/corify.sml4
-rw-r--r--src/css.sml2
-rw-r--r--src/especialize.sml7
-rw-r--r--src/iflow.sml18
-rw-r--r--src/jscomp.sml25
-rw-r--r--src/mono.sml2
-rw-r--r--src/mono_opt.sml154
-rw-r--r--src/mono_print.sml2
-rw-r--r--src/mono_reduce.sml16
-rw-r--r--src/mono_util.sml10
-rw-r--r--src/monoize.sml151
-rw-r--r--src/prepare.sml34
-rw-r--r--src/reduce.sml2
-rw-r--r--src/reduce_local.sml2
-rw-r--r--src/scriptcheck.sml8
-rw-r--r--src/tag.sml16
24 files changed, 369 insertions, 265 deletions
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
@@ -1572,15 +1628,29 @@ fun p_exp' par tail env (e, loc) =
| 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 ("<input type=\"hidden\" name=\""
^ sigName
^ "\" value=\"")), loc),
@@ -3788,7 +3796,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
fm)
end
- | L.EFfiApp ("Basis", "url", [e]) =>
+ | 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
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-21 14:07:48 +0000