summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/c/driver.c30
-rw-r--r--src/c/lacweb.c85
-rw-r--r--src/cjr.sml2
-rw-r--r--src/cjr_print.sml410
-rw-r--r--src/cjrize.sml4
-rw-r--r--src/core.sml6
-rw-r--r--src/core_print.sig1
-rw-r--r--src/core_print.sml17
-rw-r--r--src/corify.sml2
-rw-r--r--src/mono.sml2
-rw-r--r--src/mono_print.sml24
-rw-r--r--src/mono_shake.sml2
-rw-r--r--src/mono_util.sml4
-rw-r--r--src/monoize.sml4
-rw-r--r--src/shake.sml2
-rw-r--r--src/tag.sml30
16 files changed, 476 insertions, 149 deletions
diff --git a/src/c/driver.c b/src/c/driver.c
index ac0b0c86..af3bca08 100644
--- a/src/c/driver.c
+++ b/src/c/driver.c
@@ -86,9 +86,11 @@ static void *worker(void *data) {
*back = 0;
if (s = strstr(buf, "\r\n\r\n")) {
- char *cmd, *path;
+ char *cmd, *path, *inputs;
*s = 0;
+
+ printf("Read: %s\n", buf);
if (!(s = strstr(buf, "\r\n"))) {
fprintf(stderr, "No newline in buf\n");
@@ -114,9 +116,33 @@ static void *worker(void *data) {
break;
}
+ if (inputs = strchr(path, '?')) {
+ char *name, *value;
+ *inputs++ = 0;
+
+ while (*inputs) {
+ name = inputs;
+ if (value = strchr(inputs, '=')) {
+ *value++ = 0;
+ if (inputs = strchr(value, '&'))
+ *inputs++ = 0;
+ else
+ inputs = strchr(value, 0);
+ lw_set_input(ctx, name, value);
+ }
+ else if (inputs = strchr(value, '&')) {
+ *inputs++ = 0;
+ lw_set_input(ctx, name, "");
+ }
+ else {
+ inputs = strchr(value, 0);
+ lw_set_input(ctx, name, "");
+ }
+ }
+ }
+
printf("Serving URI %s....\n", path);
- ctx = lw_init(1024, 1024);
lw_write (ctx, "HTTP/1.1 200 OK\r\n");
lw_write(ctx, "Content-type: text/html\r\n\r\n");
lw_write(ctx, "<html>");
diff --git a/src/c/lacweb.c b/src/c/lacweb.c
index 2b806f86..9543c642 100644
--- a/src/c/lacweb.c
+++ b/src/c/lacweb.c
@@ -11,8 +11,11 @@ lw_unit lw_unit_v = {};
struct lw_context {
char *page, *page_front, *page_back;
char *heap, *heap_front, *heap_back;
+ char **inputs;
};
+extern int lw_inputs_len;
+
lw_context lw_init(size_t page_len, size_t heap_len) {
lw_context ctx = malloc(sizeof(struct lw_context));
@@ -22,18 +25,45 @@ lw_context lw_init(size_t page_len, size_t heap_len) {
ctx->heap_front = ctx->heap = malloc(heap_len);
ctx->heap_back = ctx->heap_front + heap_len;
+ ctx->inputs = calloc(lw_inputs_len, sizeof(char *));
+
return ctx;
}
void lw_free(lw_context ctx) {
free(ctx->page);
free(ctx->heap);
+ free(ctx->inputs);
free(ctx);
}
void lw_reset(lw_context ctx) {
ctx->page_front = ctx->page;
ctx->heap_front = ctx->heap;
+ memset(ctx->inputs, 0, lw_inputs_len * sizeof(char *));
+}
+
+int lw_input_num(char*);
+
+void lw_set_input(lw_context ctx, char *name, char *value) {
+ int n = lw_input_num(name);
+
+ if (n < 0) {
+ printf("Bad input name");
+ exit(1);
+ }
+
+ assert(n < lw_inputs_len);
+ ctx->inputs[n] = value;
+
+ printf("[%d] %s = %s\n", n, name, value);
+}
+
+char *lw_get_input(lw_context ctx, int n) {
+ assert(n >= 0);
+ assert(n < lw_inputs_len);
+ printf("[%d] = %s\n", n, ctx->inputs[n]);
+ return ctx->inputs[n];
}
static void lw_check_heap(lw_context ctx, size_t extra) {
@@ -294,14 +324,20 @@ void lw_Basis_urlifyString_w(lw_context ctx, lw_Basis_string s) {
}
-lw_Basis_int lw_unurlifyInt(char **s) {
- char *new_s = strchr(*s, '/');
- int r;
+static char *lw_unurlify_advance(char *s) {
+ char *new_s = strchr(s, '/');
if (new_s)
*new_s++ = 0;
else
- new_s = strchr(*s, 0);
+ new_s = strchr(s, 0);
+
+ return new_s;
+}
+
+lw_Basis_int lw_unurlifyInt(char **s) {
+ char *new_s = lw_unurlify_advance(*s);
+ int r;
r = atoi(*s);
*s = new_s;
@@ -309,34 +345,19 @@ lw_Basis_int lw_unurlifyInt(char **s) {
}
lw_Basis_float lw_unurlifyFloat(char **s) {
- char *new_s = strchr(*s, '/');
+ char *new_s = lw_unurlify_advance(*s);
int r;
- if (new_s)
- *new_s++ = 0;
- else
- new_s = strchr(*s, 0);
-
r = atof(*s);
*s = new_s;
return r;
}
-lw_Basis_string lw_unurlifyString(lw_context ctx, char **s) {
- char *new_s = strchr(*s, '/');
- char *r, *s1, *s2;
- int len, n;
+static lw_Basis_string lw_unurlifyString_to(char *r, char *s) {
+ char *s1, *s2;
+ int n;
- if (new_s)
- *new_s++ = 0;
- else
- new_s = strchr(*s, 0);
-
- len = strlen(*s);
- lw_check_heap(ctx, len + 1);
-
- r = ctx->heap_front;
- for (s1 = r, s2 = *s; *s2; ++s1, ++s2) {
+ for (s1 = r, s2 = s; *s2; ++s1, ++s2) {
char c = *s2;
switch (c) {
@@ -344,7 +365,7 @@ lw_Basis_string lw_unurlifyString(lw_context ctx, char **s) {
*s1 = ' ';
break;
case '%':
- assert(s2 + 2 < new_s);
+ assert(s2[1] != 0 && s2[2] != 0);
sscanf(s2+1, "%02X", &n);
*s1 = n;
s2 += 2;
@@ -354,7 +375,19 @@ lw_Basis_string lw_unurlifyString(lw_context ctx, char **s) {
}
}
*s1++ = 0;
- ctx->heap_front = s1;
+ return s1;
+}
+
+lw_Basis_string lw_unurlifyString(lw_context ctx, char **s) {
+ char *new_s = lw_unurlify_advance(*s);
+ char *r, *s1, *s2;
+ int len, n;
+
+ len = strlen(*s);
+ lw_check_heap(ctx, len + 1);
+
+ r = ctx->heap_front;
+ ctx->heap_front = lw_unurlifyString_to(ctx->heap_front, *s);
*s = new_s;
return r;
}
diff --git a/src/cjr.sml b/src/cjr.sml
index 8e8e6cab..129ff4e9 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -62,6 +62,6 @@ datatype decl' =
withtype decl = decl' located
-type file = decl list * (string * int * typ list) list
+type file = decl list * (Core.export_kind * string * int * typ list) list
end
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index 218fcdee..f483d400 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -37,6 +37,20 @@ open Cjr
structure E = CjrEnv
structure EM = ErrorMsg
+structure SK = struct
+type ord_key = string
+val compare = String.compare
+end
+
+structure SS = BinarySetFn(SK)
+structure SM = BinaryMapFn(SK)
+structure IS = IntBinarySet
+
+structure CM = BinaryMapFn(struct
+ type ord_key = char
+ val compare = Char.compare
+ end)
+
val debug = ref false
val dummyTyp = (TNamed 0, ErrorMsg.dummySpan)
@@ -208,90 +222,11 @@ fun p_decl env (dAll as (d, _) : decl) =
newline]
end
-fun unurlify env (t, loc) =
- case t of
- TFfi ("Basis", "int") => string "lw_unurlifyInt(&request)"
- | TFfi ("Basis", "float") => string "lw_unurlifyFloat(&request)"
- | TFfi ("Basis", "string") => string "lw_unurlifyString(ctx, &request)"
+datatype 'a search =
+ Found of 'a
+ | NotFound
+ | Error
- | TRecord 0 => string "lw_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 x,
- space,
- string "=",
- space,
- unurlify env t,
- string ";",
- newline]) xts),
- string "struct",
- space,
- string "__lws_",
- string (Int.toString i),
- space,
- string "__lw_tmp",
- space,
- string "=",
- space,
- string "{",
- space,
- p_list_sep (box [string ",", space]) (fn (x, _) => string x) xts,
- space,
- string "};",
- newline,
- string "__lw_tmp;",
- newline,
- string "})"]
- end
-
- | _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function";
- space)
-
-fun p_page env (s, n, ts) =
- box [string "if (!strncmp(request, \"",
- string (String.toString s),
- string "\", ",
- string (Int.toString (size s)),
- string ")) {",
- newline,
- string "request += ",
- string (Int.toString (size s)),
- string ";",
- newline,
- string "if (*request == '/') ++request;",
- newline,
- box [string "{",
- newline,
- box (ListUtil.mapi (fn (i, t) => box [p_typ env t,
- space,
- string "arg",
- string (Int.toString i),
- space,
- string "=",
- space,
- unurlify env t,
- string ";",
- newline]) ts),
- p_enamed env n,
- string "(",
- p_list_sep (box [string ",", space])
- (fn x => x)
- (string "ctx" :: ListUtil.mapi (fn (i, _) => string ("arg" ^ Int.toString i)) ts),
- string ");",
- newline,
- string "return;",
- newline,
- string "}",
- newline,
- string "}"]
- ]
fun p_file env (ds, ps) =
let
@@ -299,13 +234,318 @@ fun p_file env (ds, ps) =
(p_decl env d,
E.declBinds env d))
env ds
- val pds' = map (p_page env) ps
+
+ val fields = foldl (fn ((ek, _, _, ts), fields) =>
+ case ek of
+ Core.Link => fields
+ | Core.Action =>
+ case List.last ts of
+ (TRecord i, _) =>
+ let
+ val xts = E.lookupStruct env i
+ val xtsSet = SS.addList (SS.empty, map #1 xts)
+ in
+ foldl (fn ((x, _), fields) =>
+ let
+ val xtsSet' = Option.getOpt (SM.find (fields, x), SS.empty)
+ in
+ SM.insert (fields, x, SS.union (SS.delete (xtsSet, x),
+ xtsSet'))
+ end) fields xts
+ end
+ | _ => raise Fail "CjrPrint: Last argument of action isn't record")
+ SM.empty ps
+
+ val fnums = SM.foldli (fn (x, xs, fnums) =>
+ let
+ val unusable = SS.foldl (fn (x', unusable) =>
+ case SM.find (fnums, x') of
+ NONE => unusable
+ | SOME n => IS.add (unusable, n))
+ IS.empty xs
+
+ fun findAvailable n =
+ if IS.member (unusable, n) then
+ findAvailable (n + 1)
+ else
+ n
+ in
+ SM.insert (fnums, x, findAvailable 0)
+ end)
+ SM.empty fields
+
+ fun makeSwitch (fnums, i) =
+ case SM.foldl (fn (n, NotFound) => Found n
+ | (n, Error) => Error
+ | (n, Found n') => if n = n' then
+ Found n'
+ else
+ Error) NotFound fnums of
+ NotFound => box [string "return",
+ space,
+ string "-1;"]
+ | Found n => box [string "return",
+ space,
+ string (Int.toString n),
+ string ";"]
+ | Error =>
+ let
+ val cmap = SM.foldli (fn (x, n, cmap) =>
+ let
+ val ch = if i < size x then
+ String.sub (x, i)
+ else
+ chr 0
+
+ val fnums = case CM.find (cmap, ch) of
+ NONE => SM.empty
+ | SOME fnums => fnums
+ val fnums = SM.insert (fnums, x, n)
+ in
+ CM.insert (cmap, ch, fnums)
+ end)
+ CM.empty fnums
+
+ val cmap = CM.listItemsi cmap
+ in
+ case cmap of
+ [(_, fnums)] =>
+ box [string "if",
+ space,
+ string "(name[",
+ string (Int.toString i),
+ string "]",
+ space,
+ string "==",
+ space,
+ string "0)",
+ space,
+ string "return",
+ space,
+ string "-1;",
+ newline,
+ makeSwitch (fnums, i+1)]
+ | _ =>
+ box [string "switch",
+ space,
+ string "(name[",
+ string (Int.toString i),
+ string "])",
+ space,
+ string "{",
+ newline,
+ box (map (fn (ch, fnums) =>
+ box [string "case",
+ space,
+ if ch = chr 0 then
+ string "0:"
+ else
+ box [string "'",
+ string (Char.toString ch),
+ string "':"],
+ newline,
+ makeSwitch (fnums, i+1),
+ newline]) cmap),
+ string "default:",
+ newline,
+ string "return",
+ space,
+ string "-1;",
+ newline,
+ string "}"]
+ end
+
+ fun unurlify (t, loc) =
+ case t of
+ TFfi ("Basis", "int") => string "lw_unurlifyInt(&request)"
+ | TFfi ("Basis", "float") => string "lw_unurlifyFloat(&request)"
+ | TFfi ("Basis", "string") => string "lw_unurlifyString(ctx, &request)"
+
+ | TRecord 0 => string "lw_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 x,
+ space,
+ string "=",
+ space,
+ unurlify t,
+ string ";",
+ newline]) xts),
+ string "struct",
+ space,
+ string "__lws_",
+ string (Int.toString i),
+ space,
+ string "__lw_tmp",
+ space,
+ string "=",
+ space,
+ string "{",
+ space,
+ p_list_sep (box [string ",", space]) (fn (x, _) => string x) xts,
+ space,
+ string "};",
+ newline,
+ string "__lw_tmp;",
+ newline,
+ string "})"]
+ end
+
+ | _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function";
+ space)
+
+
+ fun p_page (ek, s, n, ts) =
+ let
+ val (ts, defInputs, inputsVar) =
+ case ek of
+ Core.Link => (ts, string "", string "")
+ | Core.Action =>
+ case List.last ts of
+ (TRecord i, _) =>
+ let
+ val xts = E.lookupStruct env i
+ in
+ (List.drop (ts, 1),
+ box [box (map (fn (x, t) => box [p_typ env t,
+ space,
+ string "lw_input_",
+ string x,
+ string ";",
+ newline]) xts),
+ newline,
+ box (map (fn (x, t) =>
+ let
+ val n = case SM.find (fnums, x) of
+ NONE => raise Fail "CjrPrint: Can't find in fnums"
+ | SOME n => n
+ in
+ box [string "request = lw_get_input(ctx, ",
+ string (Int.toString n),
+ string ");",
+ newline,
+ string "if (request == NULL) {",
+ newline,
+ box [string "printf(\"Missing input ",
+ string x,
+ string "\\n\");",
+ newline,
+ string "exit(1);"],
+ newline,
+ string "}",
+ newline,
+ string "lw_input_",
+ string x,
+ space,
+ string "=",
+ space,
+ unurlify t,
+ string ";",
+ newline]
+ end) xts),
+ string "struct __lws_",
+ string (Int.toString i),
+ space,
+ string "lw_inputs",
+ space,
+ string "= {",
+ newline,
+ box (map (fn (x, _) => box [string "lw_input_",
+ string x,
+ string ",",
+ newline]) xts),
+ string "};",
+ newline],
+ box [string ",",
+ space,
+ string "lw_inputs"])
+ end
+
+ | _ => raise Fail "CjrPrint: Last argument to an action isn't a record"
+ in
+ box [string "if (!strncmp(request, \"",
+ string (String.toString s),
+ string "\", ",
+ string (Int.toString (size s)),
+ string ")) {",
+ newline,
+ string "request += ",
+ string (Int.toString (size s)),
+ string ";",
+ newline,
+ string "if (*request == '/') ++request;",
+ newline,
+ box [string "{",
+ newline,
+ box (ListUtil.mapi (fn (i, t) => box [p_typ env t,
+ space,
+ string "arg",
+ string (Int.toString i),
+ space,
+ string "=",
+ space,
+ unurlify t,
+ string ";",
+ newline]) ts),
+ defInputs,
+ p_enamed env n,
+ string "(",
+ p_list_sep (box [string ",", space])
+ (fn x => x)
+ (string "ctx" :: ListUtil.mapi (fn (i, _) => string ("arg" ^ Int.toString i)) ts),
+ inputsVar,
+ string ");",
+ newline,
+ string "return;",
+ newline,
+ string "}",
+ newline,
+ string "}"]
+ ]
+ end
+
+ val pds' = map p_page ps
in
- box [string "#include \"lacweb.h\"",
+ box [string "#include <stdio.h>",
+ newline,
+ string "#include <stdlib.h>",
+ newline,
+ newline,
+ string "#include \"lacweb.h\"",
newline,
newline,
p_list_sep newline (fn x => x) pds,
newline,
+ string "int lw_inputs_len = ",
+ string (Int.toString (SM.foldl Int.max 0 fnums + 1)),
+ string ";",
+ newline,
+ newline,
+ string "int lw_input_num(char *name) {",
+ newline,
+ string "if",
+ space,
+ string "(name[0]",
+ space,
+ string "==",
+ space,
+ string "0)",
+ space,
+ string "return",
+ space,
+ string "-1;",
+ newline,
+ makeSwitch (fnums, 0),
+ string "}",
+ newline,
+ newline,
string "void lw_handle(lw_context ctx, char *request) {",
newline,
p_list_sep newline (fn x => x) pds',
diff --git a/src/cjrize.sml b/src/cjrize.sml
index cb2557f6..6796b467 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -225,11 +225,11 @@ fun cifyDecl ((d, loc), sm) =
(SOME (L'.DFunRec vis, loc), NONE, sm)
end
- | L.DExport (s, n, ts) =>
+ | L.DExport (ek, s, n, ts) =>
let
val (ts, sm) = ListUtil.foldlMap cifyTyp sm ts
in
- (NONE, SOME ("/" ^ s, n, ts), sm)
+ (NONE, SOME (ek, "/" ^ s, n, ts), sm)
end
fun cjrize ds =
diff --git a/src/core.sml b/src/core.sml
index 448113cc..ffd149f3 100644
--- a/src/core.sml
+++ b/src/core.sml
@@ -80,11 +80,15 @@ datatype exp' =
withtype exp = exp' located
+datatype export_kind =
+ Link
+ | Action
+
datatype decl' =
DCon of string * int * kind * con
| DVal of string * int * con * exp * string
| DValRec of (string * int * con * exp * string) list
- | DExport of int
+ | DExport of export_kind * int
withtype decl = decl' located
diff --git a/src/core_print.sig b/src/core_print.sig
index ecc7fdeb..1899ce15 100644
--- a/src/core_print.sig
+++ b/src/core_print.sig
@@ -33,6 +33,7 @@ signature CORE_PRINT = sig
val p_exp : CoreEnv.env -> Core.exp Print.printer
val p_decl : CoreEnv.env -> Core.decl Print.printer
val p_file : CoreEnv.env -> Core.file Print.printer
+ val p_export_kind : Core.export_kind Print.printer
val debug : bool ref
end
diff --git a/src/core_print.sml b/src/core_print.sml
index 3436d313..590b90fd 100644
--- a/src/core_print.sml
+++ b/src/core_print.sml
@@ -264,6 +264,11 @@ fun p_vali env (x, n, t, e, s) =
p_exp env e]
end
+fun p_export_kind ck =
+ case ck of
+ Link => string "link"
+ | Action => string "action"
+
fun p_decl env (dAll as (d, _) : decl) =
case d of
DCon (x, n, k, c) =>
@@ -300,9 +305,15 @@ fun p_decl env (dAll as (d, _) : decl) =
space,
p_list_sep (box [newline, string "and", space]) (p_vali env) vis]
end
- | DExport n => box [string "export",
- space,
- p_enamed env n]
+ | DExport (ek, n) => box [string "export",
+ space,
+ p_export_kind ek,
+ space,
+ p_enamed env n,
+ space,
+ string "as",
+ space,
+ p_con env (#2 (E.lookupENamed env n))]
fun p_file env file =
let
diff --git a/src/corify.sml b/src/corify.sml
index 719b4215..d1b44384 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -496,7 +496,7 @@ fun corifyDecl ((d, loc : EM.span), st) =
e), loc) :: wds,
(fn st =>
case #1 (corifyExp st (L.EModProj (en, [], "wrap_" ^ s), loc)) of
- L'.ENamed n => (L'.DExport n, loc)
+ L'.ENamed n => (L'.DExport (L'.Link, n), loc)
| _ => raise Fail "Corify: Value to export didn't corify properly")
:: eds)
end
diff --git a/src/mono.sml b/src/mono.sml
index 22a5a8e0..13ba3adf 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -62,7 +62,7 @@ withtype exp = exp' located
datatype decl' =
DVal of string * int * typ * exp * string
| DValRec of (string * int * typ * exp * string) list
- | DExport of string * int * typ list
+ | DExport of Core.export_kind * string * int * typ list
withtype decl = decl' located
diff --git a/src/mono_print.sml b/src/mono_print.sml
index 6f9c1b66..c485e3c8 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -178,17 +178,19 @@ fun p_decl env (dAll as (d, _) : decl) =
p_list_sep (box [newline, string "and", space]) (p_vali env) vis]
end
- | DExport (s, n, ts) => box [string "export",
- 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) => 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]
fun p_file env file =
let
diff --git a/src/mono_shake.sml b/src/mono_shake.sml
index b5b45a0e..76d05061 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 ((DVal (_, n, t, e, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, (t, e)))
diff --git a/src/mono_util.sml b/src/mono_util.sml
index 99393b10..2395cc90 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -266,10 +266,10 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} =
S.map2 (ListUtil.mapfold (mfvi ctx) vis,
fn vis' =>
(DValRec vis', loc))
- | DExport (s, n, ts) =>
+ | DExport (ek, s, n, ts) =>
S.map2 (ListUtil.mapfold mft ts,
fn ts' =>
- (DExport (s, n, ts'), loc))
+ (DExport (ek, s, n, ts'), loc))
and mfvi ctx (x, n, t, e, s) =
S.bind2 (mft t,
diff --git a/src/monoize.sml b/src/monoize.sml
index dbe69c6a..e6c6b6c8 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -383,7 +383,7 @@ fun monoDecl env (all as (d, loc)) =
SOME (env,
(L'.DValRec (map (fn (x, n, t, e, s) => (x, n, monoType env t, monoExp env e, s)) vis), loc))
end
- | L.DExport n =>
+ | L.DExport (ek, n) =>
let
val (_, t, _, s) = Env.lookupENamed env n
@@ -394,7 +394,7 @@ fun monoDecl env (all as (d, loc)) =
val ts = map (monoType env) (unwind t)
in
- SOME (env, (L'.DExport (s, n, ts), loc))
+ SOME (env, (L'.DExport (ek, s, n, ts), loc))
end
end
diff --git a/src/shake.sml b/src/shake.sml
index 038dc8f9..693385d9 100644
--- a/src/shake.sml
+++ b/src/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 ((DCon (_, n, _, c), _), (cdef, edef)) => (IM.insert (cdef, n, c), edef)
diff --git a/src/tag.sml b/src/tag.sml
index 3bd9f3f1..c61fc23f 100644
--- a/src/tag.sml
+++ b/src/tag.sml
@@ -66,7 +66,7 @@ fun exp env (e, s) =
val (xets, s) =
ListUtil.foldlMap (fn ((x, e, t), (count, tags, byTag, newTags)) =>
let
- fun tagIt newAttr =
+ fun tagIt (ek, newAttr) =
let
fun unravel (e, _) =
case e of
@@ -88,20 +88,25 @@ fun exp env (e, s) =
case IM.find (tags, f) of
NONE =>
(count, count + 1, IM.insert (tags, f, count),
- (f, count) :: newTags)
+ (ek, f, count) :: newTags)
| SOME cn => (cn, count, tags, newTags)
val (_, _, _, s) = E.lookupENamed env f
val byTag = case SM.find (byTag, s) of
- NONE => SM.insert (byTag, s, f)
- | SOME f' =>
+ NONE => SM.insert (byTag, s, (ek, f))
+ | SOME (ek', f') =>
(if f = f' then
()
else
ErrorMsg.errorAt loc
("Duplicate HTTP tag "
^ s);
+ if ek = ek' then
+ ()
+ else
+ ErrorMsg.errorAt loc
+ "Function needed as both a link and a form ";
byTag)
val e = (EClosure (cn, args), loc)
@@ -112,8 +117,8 @@ fun exp env (e, s) =
end
in
case x of
- (CName "Link", _) => tagIt "Href"
- | (CName "Action", _) => tagIt "Action"
+ (CName "Link", _) => tagIt (Link, "Href")
+ | (CName "Action", _) => tagIt (Action, "Action")
| _ => ((x, e, t), (count, tags, byTag, newTags))
end)
s xets
@@ -154,13 +159,18 @@ fun tag file =
fun doDecl (d as (d', loc), (env, count, tags, byTag)) =
case d' of
- DExport n =>
+ DExport (ek, n) =>
let
val (_, _, _, s) = E.lookupENamed env n
in
case SM.find (byTag, s) of
NONE => ([d], (env, count, tags, byTag))
- | SOME n' => ([], (env, count, tags, byTag))
+ | SOME (ek', n') =>
+ (if ek = ek' then
+ ()
+ else
+ ErrorMsg.errorAt loc "Function needed for both a link and a form";
+ ([], (env, count, tags, byTag)))
end
| _ =>
let
@@ -179,7 +189,7 @@ fun tag file =
val env = env'
val newDs = map
- (fn (f, cn) =>
+ (fn (ek, f, cn) =>
let
fun unravel (all as (t, _)) =
case t of
@@ -225,7 +235,7 @@ fun tag file =
end
in
(("wrap_" ^ fnam, cn, t, abs, tag),
- (DExport cn, loc))
+ (DExport (ek, cn), loc))
end) newTags
val (newVals, newExports) = ListPair.unzip newDs
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-03 02:27:25 +0000