summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/c/http.c32
-rw-r--r--src/c/static.c1
-rw-r--r--src/c/urweb.c9
-rw-r--r--src/cjr_print.sml6
-rw-r--r--src/compiler.sig1
-rw-r--r--src/compiler.sml41
-rw-r--r--src/demo.sml7
-rw-r--r--src/elab_env.sig3
-rw-r--r--src/elab_env.sml93
-rw-r--r--src/elab_print.sml6
-rw-r--r--src/elaborate.sml69
-rw-r--r--src/main.mlton.sml3
-rw-r--r--src/settings.sig3
-rw-r--r--src/settings.sml19
-rw-r--r--src/source.sml2
-rw-r--r--src/source_print.sml10
-rw-r--r--src/sqlite.sml2
-rw-r--r--src/urweb.grm44
18 files changed, 269 insertions, 82 deletions
diff --git a/src/c/http.c b/src/c/http.c
index 1bc58677..21ad809f 100644
--- a/src/c/http.c
+++ b/src/c/http.c
@@ -75,6 +75,8 @@ static void log_debug(void *data, const char *fmt, ...) {
static uw_loggers ls = {NULL, log_error, log_debug};
+static unsigned max_buf_size = 1024 * 1024; // That's 1MB.
+
static void *worker(void *data) {
int me = *(int *)data;
uw_context ctx = uw_request_new_context(me, &uw_application, &ls);
@@ -100,6 +102,12 @@ static void *worker(void *data) {
if (back - buf == buf_size - 1) {
char *new_buf;
size_t new_buf_size = buf_size*2;
+ if (new_buf_size > max_buf_size) {
+ qfprintf(stderr, "HTTP input exceeds buffer-size limit of %u bytes.\n", max_buf_size);
+ close(sock);
+ sock = 0;
+ break;
+ }
new_buf = realloc(buf, new_buf_size);
if(!new_buf) {
qfprintf(stderr, "Realloc failed while receiving header\n");
@@ -156,6 +164,12 @@ static void *worker(void *data) {
if (back - buf == buf_size - 1) {
char *new_buf;
size_t new_buf_size = buf_size * 2;
+ if (new_buf_size > max_buf_size) {
+ qfprintf(stderr, "HTTP input exceeds buffer-size limit of %u bytes.\n", max_buf_size);
+ close(sock);
+ sock = 0;
+ break;
+ }
new_buf = realloc(buf, new_buf_size);
if(!new_buf) {
qfprintf(stderr, "Realloc failed while receiving content\n");
@@ -314,7 +328,7 @@ static void *worker(void *data) {
}
static void help(char *cmd) {
- printf("Usage: %s [-p <port>] [-a <IPv4 address>] [-A <IPv6 address>] [-t <thread count>] [-k] [-q] [-T SEC]\nThe '-k' option turns on HTTP keepalive.\nThe '-q' option turns off some chatter on stdout.\nThe '-T' option sets socket recv timeout (0 disables timeout, default is 5 sec).\n", cmd);
+ printf("Usage: %s [-p <port>] [-a <IPv4 address>] [-A <IPv6 address>] [-t <thread count>] [-m <bytes>] [-k] [-q] [-T SEC]\nThe '-k' option turns on HTTP keepalive.\nThe '-q' option turns off some chatter on stdout.\nThe '-T' option sets socket recv timeout (0 disables timeout, default is 5 sec).\nThe '-m' sets the maximum size (in bytes) for any buffer used to hold HTTP data sent by clients. (The default is 1 MB.)\n", cmd);
}
static void sigint(int signum) {
@@ -345,7 +359,7 @@ int main(int argc, char *argv[]) {
my_addr.sa.sa_family = AF_INET;
my_addr.ipv4.sin_addr.s_addr = INADDR_ANY; // auto-fill with my IP
- while ((opt = getopt(argc, argv, "hp:a:A:t:kqT:")) != -1) {
+ while ((opt = getopt(argc, argv, "hp:a:A:t:kqT:m:")) != -1) {
switch (opt) {
case '?':
fprintf(stderr, "Unknown command-line option\n");
@@ -409,6 +423,16 @@ int main(int argc, char *argv[]) {
quiet = 1;
break;
+ case 'm':
+ opt = atoi(optarg);
+ if (opt <= 0) {
+ fprintf(stderr, "Invalid maximum buffer size\n");
+ help(argv[0]);
+ return 1;
+ }
+ max_buf_size = opt;
+ break;
+
default:
fprintf(stderr, "Unexpected getopt() behavior\n");
return 1;
@@ -456,6 +480,10 @@ int main(int argc, char *argv[]) {
sin_size = sizeof their_addr;
+ qprintf("Starting the Ur/Web native HTTP server, which is intended for use\n"
+ "ONLY DURING DEVELOPMENT. You probably want to use one of the other backends,\n"
+ "behind a production-quality HTTP server, for a real deployment.\n\n");
+
qprintf("Listening on port %d....\n", uw_port);
{
diff --git a/src/c/static.c b/src/c/static.c
index 7f63d393..d70881e2 100644
--- a/src/c/static.c
+++ b/src/c/static.c
@@ -38,6 +38,7 @@ int main(int argc, char *argv[]) {
fk = uw_begin(ctx, argv[1]);
if (fk == SUCCESS || fk == RETURN_INDIRECTLY) {
+ uw_commit(ctx);
uw_print(ctx, 1);
puts("");
return 0;
diff --git a/src/c/urweb.c b/src/c/urweb.c
index afe8457b..6f2dde38 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -180,8 +180,11 @@ static uw_Basis_int my_rand() {
return -1;
}
-static client *new_client() {
+static client *new_client(uw_context ctx) {
client *c;
+ int pass = my_rand();
+
+ if (pass < 0) uw_error(ctx, FATAL, "Random number generation failed during client initialization");
pthread_mutex_lock(&clients_mutex);
@@ -205,7 +208,7 @@ static client *new_client() {
pthread_mutex_lock(&c->lock);
c->mode = USED;
- c->pass = my_rand();
+ c->pass = pass;
c->sock = -1;
c->last_contact = time(NULL);
uw_buffer_reset(&c->msgs);
@@ -817,7 +820,7 @@ void uw_login(uw_context ctx) {
uw_error(ctx, FATAL, "Wrong client password (%u, %d) in subscription request", id, pass);
}
} else if (ctx->needs_push) {
- client *c = new_client();
+ client *c = new_client(ctx);
if (c == NULL)
uw_error(ctx, FATAL, "Limit exceeded on number of message-passing clients");
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 688b3e4d..53587ff7 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -2513,8 +2513,12 @@ fun p_decl env (dAll as (d, loc) : decl) =
| DJavaScript s =>
let
+ val name =
+ (case Settings.getOutputJsFile () of
+ NONE => "app." ^ SHA1.bintohex (SHA1.hash s) ^ ".js"
+ | SOME s => s)
val () = app_js := OS.Path.joinDirFile {dir = Settings.getUrlPrefix (),
- file = "app." ^ SHA1.bintohex (SHA1.hash s) ^ ".js"}
+ file = name}
in
box [string "static char jslib[] = \"",
string (Prim.toCString s),
diff --git a/src/compiler.sig b/src/compiler.sig
index a4b3e562..952c7070 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -48,6 +48,7 @@ signature COMPILER = sig
benignEffectful : Settings.ffi list,
clientOnly : Settings.ffi list,
serverOnly : Settings.ffi list,
+ jsModule : string option,
jsFuncs : (Settings.ffi * string) list,
rewrites : Settings.rewrite list,
filterUrl : Settings.rule list,
diff --git a/src/compiler.sml b/src/compiler.sml
index 481f04b6..c13de304 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -52,6 +52,7 @@ type job = {
benignEffectful : Settings.ffi list,
clientOnly : Settings.ffi list,
serverOnly : Settings.ffi list,
+ jsModule : string option,
jsFuncs : (Settings.ffi * string) list,
rewrites : Settings.rewrite list,
filterUrl : Settings.rule list,
@@ -273,7 +274,7 @@ val parseUr = {
fun p_job ({prefix, database, exe, sql, sources, debug, profile,
timeout, ffi, link, headers, scripts,
- clientToServer, effectful, benignEffectful, clientOnly, serverOnly, jsFuncs, ...} : job) =
+ clientToServer, effectful, benignEffectful, clientOnly, serverOnly, jsModule, jsFuncs, ...} : job) =
let
open Print.PD
open Print
@@ -312,6 +313,9 @@ fun p_job ({prefix, database, exe, sql, sources, debug, profile,
p_ffi "BenignEffectful" benignEffectful,
p_ffi "ClientOnly" clientOnly,
p_ffi "ServerOnly" serverOnly,
+ case jsModule of
+ NONE => string "No JavaScript FFI module"
+ | SOME m => string ("JavaScript FFI module: " ^ m),
p_list_sep (box []) (fn ((m, s), s') =>
box [string "JsFunc", space, string m, string ".", string s,
space, string "=", space, string s', newline]) jsFuncs,
@@ -368,6 +372,7 @@ fun institutionalizeJob (job : job) =
Settings.setBenignEffectful (#benignEffectful job);
Settings.setClientOnly (#clientOnly job);
Settings.setServerOnly (#serverOnly job);
+ Settings.setJsModule (#jsModule job);
Settings.setJsFuncs (#jsFuncs job);
Settings.setRewriteRules (#rewrites job);
Settings.setUrlRules (#filterUrl job);
@@ -445,6 +450,7 @@ fun parseUrp' accLibs fname =
benignEffectful = [],
clientOnly = [],
serverOnly = [],
+ jsModule = NONE,
jsFuncs = [],
rewrites = [{pkind = Settings.Any,
kind = Settings.Prefix,
@@ -543,9 +549,16 @@ fun parseUrp' accLibs fname =
acc
else
let
- val fname = String.implode (List.filter (fn x => not (Char.isSpace x))
- (String.explode line))
- val fname = relifyA fname
+ fun trim s =
+ let
+ val s = Substring.full s
+ val (_, s) = Substring.splitl Char.isSpace s
+ val (s, _) = Substring.splitr Char.isSpace s
+ in
+ Substring.string s
+ end
+
+ val fname = relifyA (trim line)
in
fname :: acc
end
@@ -572,6 +585,7 @@ fun parseUrp' accLibs fname =
val benignEffectful = ref []
val clientOnly = ref []
val serverOnly = ref []
+ val jsModule = ref NONE
val jsFuncs = ref []
val rewrites = ref []
val url = ref []
@@ -609,6 +623,7 @@ fun parseUrp' accLibs fname =
benignEffectful = rev (!benignEffectful),
clientOnly = rev (!clientOnly),
serverOnly = rev (!serverOnly),
+ jsModule = !jsModule,
jsFuncs = rev (!jsFuncs),
rewrites = rev (!rewrites),
filterUrl = rev (!url),
@@ -667,6 +682,7 @@ fun parseUrp' accLibs fname =
benignEffectful = #benignEffectful old @ #benignEffectful new,
clientOnly = #clientOnly old @ #clientOnly new,
serverOnly = #serverOnly old @ #serverOnly new,
+ jsModule = #jsModule old,
jsFuncs = #jsFuncs old @ #jsFuncs new,
rewrites = #rewrites old @ #rewrites new,
filterUrl = #filterUrl old @ #filterUrl new,
@@ -802,6 +818,10 @@ fun parseUrp' accLibs fname =
| "benignEffectful" => benignEffectful := ffiS () :: !benignEffectful
| "clientOnly" => clientOnly := ffiS () :: !clientOnly
| "serverOnly" => serverOnly := ffiS () :: !serverOnly
+ | "jsModule" =>
+ (case !jsModule of
+ NONE => jsModule := SOME arg
+ | SOME _ => ())
| "jsFunc" => jsFuncs := ffiM () :: !jsFuncs
| "rewrite" =>
let
@@ -1005,6 +1025,8 @@ val parse = {
val defed = ref SS.empty
val fulls = ref SS.empty
+ val caughtOneThatIsn'tAFile = ref false
+
fun parseOne fname =
let
val mname = nameOf fname
@@ -1129,7 +1151,16 @@ val parse = {
in
checkErrors ();
d
- end handle MissingFile fname => (ErrorMsg.error ("Missing source file: " ^ fname);
+ end handle MissingFile fname => (if not (!caughtOneThatIsn'tAFile)
+ andalso CharVector.exists Char.isSpace fname then
+ (caughtOneThatIsn'tAFile := true;
+ ErrorMsg.error ("In .urp files, all configuration directives must come before any blank lines.\n"
+ ^ "However, this .urp file contains at least one suspicious line in a position\n"
+ ^ "where filenames belong (after the first blank line) but containing a space\n"
+ ^ "character."))
+ else
+ ();
+ ErrorMsg.error ("Missing source file: " ^ fname);
(Source.DSequence "", ErrorMsg.dummySpan))
val dsFfi = map parseFfi ffi
diff --git a/src/demo.sml b/src/demo.sml
index 47d22395..62b9037a 100644
--- a/src/demo.sml
+++ b/src/demo.sml
@@ -16,7 +16,7 @@
* AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
* IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
- * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
* CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
* SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
* INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
@@ -111,6 +111,7 @@ fun make' {prefix, dirname, guided} =
benignEffectful = [],
clientOnly = [],
serverOnly = [],
+ jsModule = NONE,
jsFuncs = [],
rewrites = #rewrites combined @ #rewrites urp,
filterUrl = #filterUrl combined @ #filterUrl urp,
@@ -280,7 +281,7 @@ fun make' {prefix, dirname, guided} =
val (urpData, out) = startUrp urp
in
finished ();
-
+
SOME (readUrp (urpData,
out))
end
@@ -399,7 +400,7 @@ fun make' {prefix, dirname, guided} =
case #kind rule of
Settings.Exact => ()
| Settings.Prefix => TextIO.output (outf, "*");
- TextIO.output (outf, "\n")))
+ TextIO.output (outf, "\n")))
in
Option.app (fn db => (TextIO.output (outf, "database ");
TextIO.output (outf, db);
diff --git a/src/elab_env.sig b/src/elab_env.sig
index cbc85cdd..47b31c08 100644
--- a/src/elab_env.sig
+++ b/src/elab_env.sig
@@ -96,6 +96,7 @@ signature ELAB_ENV = sig
val pushStrNamed : env -> string -> Elab.sgn -> env * int
val pushStrNamedAs : env -> string -> int -> Elab.sgn -> env
+ val pushStrNamedAs' : bool (* also enrich typeclass instances? *) -> env -> string -> int -> Elab.sgn -> env
val lookupStrNamed : env -> int -> string * Elab.sgn
val lookupStr : env -> string -> (int * Elab.sgn) option
@@ -123,6 +124,4 @@ signature ELAB_ENV = sig
val patBinds : env -> Elab.pat -> env
val patBindsN : Elab.pat -> int
- exception Bad of Elab.con * Elab.con
-
end
diff --git a/src/elab_env.sml b/src/elab_env.sml
index cb08f348..8402bcba 100644
--- a/src/elab_env.sml
+++ b/src/elab_env.sml
@@ -1097,14 +1097,21 @@ fun sgnS_sgn (str, (sgns, strs, cons)) sgn =
end)
| _ => sgn
-fun sgnSubSgn x =
+fun projectStr env {sgn, str, field} =
+ case #1 (hnormSgn env sgn) of
+ SgnConst sgis =>
+ (case sgnSeek (fn SgiStr (_, x, _, sgn) => if x = field then SOME sgn else NONE | _ => NONE) sgis of
+ NONE => NONE
+ | SOME (sgn, subs) => SOME (sgnSubSgn (str, subs) sgn))
+ | SgnError => SOME (SgnError, ErrorMsg.dummySpan)
+ | _ => NONE
+
+and sgnSubSgn x =
ElabUtil.Sgn.map {kind = id,
con = sgnS_con x,
sgn_item = id,
sgn = sgnS_sgn x}
-
-
and projectSgn env {sgn, str, field} =
case #1 (hnormSgn env sgn) of
SgnConst sgis =>
@@ -1123,12 +1130,23 @@ and hnormSgn env (all as (sgn, loc)) =
| SgnProj (m, ms, x) =>
let
val (_, sgn) = lookupStrNamed env m
+
+ fun doProjection (m1, NONE) = NONE
+ | doProjection (m1, SOME (str, sgn)) =
+ case projectStr env {str = str,
+ sgn = sgn,
+ field = m1} of
+ NONE => NONE
+ | SOME sgn' => SOME ((StrProj (str, m1), loc), sgn')
in
- case projectSgn env {str = foldl (fn (m, str) => (StrProj (str, m), loc)) (StrVar m, loc) ms,
- sgn = sgn,
- field = x} of
- NONE => raise Fail "ElabEnv.hnormSgn: projectSgn failed"
- | SOME sgn => hnormSgn env sgn
+ case foldl doProjection (SOME ((StrVar m, loc), sgn)) ms of
+ NONE => raise Fail "ElabEnv.hnormSgn: pre-projectSgn failed"
+ | SOME (str, sgn) =>
+ case projectSgn env {str = str,
+ sgn = sgn,
+ field = x} of
+ NONE => raise Fail "ElabEnv.hnormSgn: projectSgn failed"
+ | SOME sgn => hnormSgn env sgn
end
| SgnWhere (sgn, ms, x, c) =>
let
@@ -1281,28 +1299,40 @@ fun enrichClasses env classes (m1, ms) sgn =
end
| _ => classes
-fun pushStrNamedAs (env : env) x n sgn =
- {renameK = #renameK env,
- relK = #relK env,
+and pushStrNamedAs' enrich (env : env) x n sgn =
+ let
+ val renameStr = SM.insert (#renameStr env, x, (n, sgn))
+ val str = IM.insert (#str env, n, (x, sgn))
+ fun newEnv classes =
+ {renameK = #renameK env,
+ relK = #relK env,
- renameC = #renameC env,
- relC = #relC env,
- namedC = #namedC env,
+ renameC = #renameC env,
+ relC = #relC env,
+ namedC = #namedC env,
- datatypes = #datatypes env,
- constructors = #constructors env,
+ datatypes = #datatypes env,
+ constructors = #constructors env,
- classes = enrichClasses env (#classes env) (n, []) sgn,
+ classes = classes,
- renameE = #renameE env,
- relE = #relE env,
- namedE = #namedE env,
+ renameE = #renameE env,
+ relE = #relE env,
+ namedE = #namedE env,
- renameSgn = #renameSgn env,
- sgn = #sgn env,
+ renameSgn = #renameSgn env,
+ sgn = #sgn env,
+
+ renameStr = renameStr,
+ str = str}
+ in
+ if enrich then
+ newEnv (enrichClasses (newEnv (#classes env)) (#classes env) (n, []) sgn)
+ else
+ newEnv (#classes env)
+ end
- renameStr = SM.insert (#renameStr env, x, (n, sgn)),
- str = IM.insert (#str env, n, (x, sgn))}
+and pushStrNamedAs env = pushStrNamedAs' true env
fun pushStrNamed env x sgn =
let
@@ -1364,7 +1394,7 @@ fun sgiBinds env (sgi, loc) =
env xncs
end
| SgiVal (x, n, t) => pushENamedAs env x n t
- | SgiStr (_, x, n, sgn) => pushStrNamedAs env x n sgn
+ | SgiStr (_, x, n, sgn) => pushStrNamedAs' false env x n sgn
| SgiSgn (x, n, sgn) => pushSgnNamedAs env x n sgn
| SgiConstraint _ => env
@@ -1375,15 +1405,6 @@ fun sgnSubCon x =
ElabUtil.Con.map {kind = id,
con = sgnS_con x}
-fun projectStr env {sgn, str, field} =
- case #1 (hnormSgn env sgn) of
- SgnConst sgis =>
- (case sgnSeek (fn SgiStr (_, x, _, sgn) => if x = field then SOME sgn else NONE | _ => NONE) sgis of
- NONE => NONE
- | SOME (sgn, subs) => SOME (sgnSubSgn (str, subs) sgn))
- | SgnError => SOME (SgnError, ErrorMsg.dummySpan)
- | _ => NONE
-
fun chaseMpath env (n, ms) =
let
val (_, sgn) = lookupStrNamed env n
@@ -1642,8 +1663,8 @@ fun declBinds env (d, loc) =
| DVal (x, n, t, _) => pushENamedAs env x n t
| DValRec vis => foldl (fn ((x, n, t, _), env) => pushENamedAs env x n t) env vis
| DSgn (x, n, sgn) => pushSgnNamedAs env x n sgn
- | DStr (x, n, sgn, _) => pushStrNamedAs env x n sgn
- | DFfiStr (x, n, sgn) => pushStrNamedAs env x n sgn
+ | DStr (x, n, sgn, _) => pushStrNamedAs' false env x n sgn
+ | DFfiStr (x, n, sgn) => pushStrNamedAs' false env x n sgn
| DConstraint _ => env
| DExport _ => env
| DTable (tn, x, n, c, _, pc, _, cc) =>
diff --git a/src/elab_print.sml b/src/elab_print.sml
index 06ea097f..8a6a651a 100644
--- a/src/elab_print.sml
+++ b/src/elab_print.sml
@@ -678,7 +678,7 @@ and p_sgn env (sgn, _) =
space,
string ":",
space,
- p_sgn (E.pushStrNamedAs env x n sgn) sgn']
+ p_sgn (E.pushStrNamedAs' false env x n sgn) sgn']
| SgnWhere (sgn, ms, x, c) => box [p_sgn env sgn,
space,
string "where",
@@ -695,7 +695,7 @@ and p_sgn env (sgn, _) =
val m1x = #1 (E.lookupStrNamed env m1)
handle E.UnboundNamed _ => "UNBOUND_SGN_" ^ Int.toString m1
- val m1s = if !debug then
+ val m1x = if !debug then
m1x ^ "__" ^ Int.toString m1
else
m1x
@@ -867,7 +867,7 @@ and p_str env (str, _) =
string s]
| StrFun (x, n, sgn, sgn', str) =>
let
- val env' = E.pushStrNamedAs env x n sgn
+ val env' = E.pushStrNamedAs' false env x n sgn
in
box [string "functor",
space,
diff --git a/src/elaborate.sml b/src/elaborate.sml
index 6965adfd..4a04d4bf 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -2489,6 +2489,15 @@ fun queryOf () = (L'.CModProj (!basis_r, [], "sql_query"), ErrorMsg.dummySpan)
fun cookieOf () = (L'.CModProj (!basis_r, [], "http_cookie"), ErrorMsg.dummySpan)
fun styleOf () = (L'.CModProj (!basis_r, [], "css_class"), ErrorMsg.dummySpan)
+fun patVarsOf (p : L.pat) =
+ case #1 p of
+ L.PVar x => [x]
+ | L.PPrim _ => []
+ | L.PCon (_, _, NONE) => []
+ | L.PCon (_, _, SOME p) => patVarsOf p
+ | L.PRecord (xps, _) => ListUtil.mapConcat (fn (_, p) => patVarsOf p) xps
+ | L.PAnnot (p', _) => patVarsOf p'
+
fun dopenConstraints (loc, env, denv) {str, strs} =
case E.lookupStr env str of
NONE => (strError env (UnboundStr (loc, str));
@@ -3807,7 +3816,8 @@ and wildifyStr env (str, sgn) =
foldl (fn ((d, _), nd) =>
case d of
L.DCon (x, _, _) => ndelCon (nd, x)
- | L.DVal (x, _, _) => ndelVal (nd, x)
+ | L.DVal (p, _) =>
+ foldl (fn (x, nd) => ndelVal (nd, x)) nd (patVarsOf p)
| L.DOpen _ => nempty
| L.DStr (x, _, _, (L.StrConst ds', _), _) =>
(case SM.find (nmods nd, x) of
@@ -3855,7 +3865,7 @@ and wildifyStr env (str, sgn) =
| xs =>
let
val ewild = (L.EWild, #2 str)
- val ds'' = map (fn x => (L.DVal (x, NONE, ewild), #2 str)) xs
+ val ds'' = map (fn x => (L.DVal ((L.PVar x, #2 str), ewild), #2 str)) xs
in
ds'' @ ds'
end
@@ -4022,22 +4032,55 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) =
([], (env, denv, [])))
end)
- | L.DVal (x, co, e) =>
+ | L.DVal (p, e) =>
let
- val (c', _, gs1) = case co of
- NONE => (cunif env (loc, ktype), ktype, [])
- | SOME c => elabCon (env, denv) c
+ val ((p', pt), (env', bound)) = elabPat (p, (env, SS.empty))
- val (e', et, gs2) = elabExp (env, denv) e
+ val (e', et, gs1) = elabExp (env, denv) e
- val () = checkCon env e' et c'
+ val c' = normClassConstraint env et
- val c' = normClassConstraint env c'
- val (env', n) = E.pushENamed env x c'
+ fun singleVar (p : L.pat) =
+ case #1 p of
+ L.PVar x => SOME x
+ | L.PAnnot (p', _) => singleVar p'
+ | _ => NONE
in
- (*prefaces "DVal" [("x", Print.PD.string x),
- ("c'", p_con env c')];*)
- ([(L'.DVal (x, n, c', e'), loc)], (env', denv, enD gs1 @ gs2 @ gs))
+ unifyCons env loc et pt;
+
+ (case exhaustive (env, et, [p'], loc) of
+ NONE => ()
+ | SOME p => if !mayDelay then
+ delayedExhaustives := (env, et, [p'], loc) :: !delayedExhaustives
+ else
+ expError env (Inexhaustive (loc, p)));
+
+ case singleVar p of
+ SOME x =>
+ let
+ val (env', n) = E.pushENamed env x et
+ in
+ ([(L'.DVal (x, n, c', e'), loc)], (env', denv, gs1 @ gs))
+ end
+ | NONE =>
+ let
+ val (env', n) = E.pushENamed env "$tmp" et
+ val vars = SS.listItems bound
+ val (decls, env') =
+ ListUtil.foldlMap (fn (x, env') =>
+ let
+ val e = (L.ECase ((L.EVar ([], "$tmp", L.Infer), loc),
+ [(p, (L.EVar ([], x, L.Infer), loc))]), loc)
+ val (e', t, _) = elabExp (env', denv) e
+ val (env', n) = E.pushENamed env' x t
+ in
+ ((L'.DVal (x, n, t, e'), loc),
+ env')
+ end) env' vars
+ in
+ ((L'.DVal ("$tmp", n, c', e'), loc) :: decls,
+ (env', denv, gs1 @ gs))
+ end
end
| L.DValRec vis =>
let
diff --git a/src/main.mlton.sml b/src/main.mlton.sml
index fb1a1723..2caa43f8 100644
--- a/src/main.mlton.sml
+++ b/src/main.mlton.sml
@@ -134,6 +134,9 @@ fun oneRun args =
| "-output" :: s :: rest =>
(Settings.setExe (SOME s);
doArgs rest)
+ | "-js" :: s :: rest =>
+ (Settings.setOutputJsFile (SOME s);
+ doArgs rest)
| "-sql" :: s :: rest =>
(Settings.setSql (SOME s);
doArgs rest)
diff --git a/src/settings.sig b/src/settings.sig
index 05ab5e23..256a12b5 100644
--- a/src/settings.sig
+++ b/src/settings.sig
@@ -96,6 +96,7 @@ signature SETTINGS = sig
val isServerOnly : ffi -> bool
(* Which FFI functions may be run in JavaScript? (JavaScript function names included) *)
+ val setJsModule : string option -> unit
val setJsFuncs : (ffi * string) list -> unit
val addJsFunc : ffi * string -> unit
val jsFunc : ffi -> string option
@@ -303,4 +304,6 @@ signature SETTINGS = sig
val addJsFile : string (* filename *) -> unit
val listJsFiles : unit -> {Filename : string, Content : string} list
+ val setOutputJsFile : string option (* filename *) -> unit
+ val getOutputJsFile : unit -> string option
end
diff --git a/src/settings.sml b/src/settings.sml
index 70ea1861..a3263c06 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -346,7 +346,7 @@ val jsFuncsBase = basisM [("alert", "alert"),
("asin", "asin"),
("acos", "acos"),
("atan", "atan"),
- ("atan2", "atan2"),
+ ("atan2", "atan2"),
("abs", "abs"),
("now", "now"),
@@ -395,9 +395,15 @@ val jsFuncsBase = basisM [("alert", "alert"),
("htmlifySpecialChar", "htmlifySpecialChar"),
("chr", "chr")]
val jsFuncs = ref jsFuncsBase
-fun setJsFuncs ls = jsFuncs := foldl (fn ((k, v), m) => M.insert (m, k, v)) jsFuncsBase ls
+val jsModule = ref (NONE : string option)
+fun setJsModule m = jsModule := m
+fun jsFuncName f =
+ case !jsModule of
+ SOME m => m ^ "." ^ f
+ | NONE => f
+fun setJsFuncs ls = jsFuncs := foldl (fn ((k, v), m) => M.insert (m, k, jsFuncName v)) jsFuncsBase ls
fun jsFunc x = M.find (!jsFuncs, x)
-fun addJsFunc (k, v) = jsFuncs := M.insert (!jsFuncs, k, v)
+fun addJsFunc (k, v) = jsFuncs := M.insert (!jsFuncs, k, jsFuncName v)
fun allJsFuncs () = M.listItemsi (!jsFuncs)
datatype pattern_kind = Exact | Prefix
@@ -951,6 +957,10 @@ fun addJsFile LoadFromFilename =
fun listJsFiles () = SM.listItems (!jsFiles)
+val jsOutput = ref (NONE : string option)
+fun setOutputJsFile so = jsOutput := so
+fun getOutputJsFile () = !jsOutput
+
fun reset () =
(Globals.setResetTime ();
urlPrefixFull := "/";
@@ -996,6 +1006,7 @@ fun reset () =
mimeTypes := NONE;
files := SM.empty;
jsFiles := SM.empty;
- filePath := ".")
+ filePath := ".";
+ jsOutput := NONE)
end
diff --git a/src/source.sml b/src/source.sml
index 9971ca93..2d8c1ed3 100644
--- a/src/source.sml
+++ b/src/source.sml
@@ -157,7 +157,7 @@ datatype decl' =
DCon of string * kind option * con
| DDatatype of (string * string list * (string * con option) list) list
| DDatatypeImp of string * string list * string
- | DVal of string * con option * exp
+ | DVal of pat * exp
| DValRec of (string * con option * exp) list
| DSgn of string * sgn
| DStr of string * sgn option * Time.time option * str * bool (* did this module come from the '-root' directive? *)
diff --git a/src/source_print.sml b/src/source_print.sml
index 7b657422..e18a82f9 100644
--- a/src/source_print.sml
+++ b/src/source_print.sml
@@ -560,9 +560,13 @@ fun p_decl ((d, _) : decl) =
string "datatype",
space,
p_list_sep (string ".") string (ms @ [x'])]
- | DVal vi => box [string "val",
- space,
- p_vali vi]
+ | DVal (p, e) => box [string "val",
+ space,
+ p_pat p,
+ space,
+ string "=",
+ space,
+ p_exp e]
| DValRec vis => box [string "val",
space,
string "rec",
diff --git a/src/sqlite.sml b/src/sqlite.sml
index c7694cde..a9b6389d 100644
--- a/src/sqlite.sml
+++ b/src/sqlite.sml
@@ -850,6 +850,6 @@ val () = addDbms {name = "sqlite",
onlyUnion = false,
nestedRelops = false,
windowFunctions = false,
- supportsIsDistinctFrom = true}
+ supportsIsDistinctFrom = false}
end
diff --git a/src/urweb.grm b/src/urweb.grm
index db5473a6..afebff0a 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -490,7 +490,7 @@ fun patternOut (e : exp) =
| earga of exp * con -> exp * con
| eargs of exp * con -> exp * con
| eargl of exp * con -> exp * con
- | eargl2 of exp * con -> exp * con
+ | eargl2 of bool * (exp * con -> exp * con)
| branch of pat * exp
| branchs of (pat * exp) list
@@ -622,7 +622,41 @@ decl : CON SYMBOL cargl2 kopt EQ cexp (let
(case dargs of
[] => [(DDatatypeImp (SYMBOL, CSYMBOL :: #1 path, #2 path), s (DATATYPEleft, pathright))]
| _ => raise Fail "Arguments specified for imported datatype")
- | VAL vali ([(DVal vali, s (VALleft, valiright))])
+ | VAL pat eargl2 copt EQ eexp (let
+ fun justVar (p : pat) =
+ case #1 p of
+ PVar x => SOME x
+ | PAnnot (p', _) => justVar p'
+ | _ => NONE
+
+ val loc = s (VALleft, eexpright)
+ in
+ case justVar pat of
+ SOME x =>
+ let
+ val t = Option.getOpt (copt, (CWild (KType, loc), loc))
+ val (e, t) = #2 eargl2 (eexp, t)
+ val pat =
+ case #1 t of
+ CWild _ => pat
+ | _ => (PAnnot (pat, t), loc)
+ in
+ [(DVal (pat, e), loc)]
+ end
+ | NONE =>
+ let
+ val pat =
+ case copt of
+ SOME t => (PAnnot (pat, t), loc)
+ | _ => pat
+ in
+ (if #1 eargl2 then
+ ErrorMsg.errorAt loc "Additional arguments not allowed after pattern"
+ else
+ ());
+ [(DVal (pat, eexp), loc)]
+ end
+ end)
| VAL REC valis ([(DValRec valis, s (VALleft, valisright))])
| FUN valis ([(DValRec valis, s (FUNleft, valisright))])
@@ -695,7 +729,7 @@ vali : SYMBOL eargl2 copt EQ eexp (let
val loc = s (SYMBOLleft, eexpright)
val t = Option.getOpt (copt, (CWild (KType, loc), loc))
- val (e, t) = eargl2 (eexp, t)
+ val (e, t) = #2 eargl2 (eexp, t)
in
(SYMBOL, SOME t, e)
end)
@@ -1279,8 +1313,8 @@ eargs : earg (earg)
eargl : eargp eargp (eargp1 o eargp2)
| eargp eargl (eargp o eargl)
-eargl2 : (fn x => x)
- | eargp eargl2 (eargp o eargl2)
+eargl2 : (false, fn x => x)
+ | eargp eargl2 (true, eargp o #2 eargl2)
earg : patS (fn (e, t) =>
let
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-22 18:03:44 +0000