summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--include/lacweb.h14
-rw-r--r--src/c/lacweb.c83
-rw-r--r--src/cjr.sml2
-rw-r--r--src/cjr_print.sml53
-rw-r--r--src/cjrize.sml7
-rw-r--r--src/lacweb.lex8
-rw-r--r--src/list_util.sig2
-rw-r--r--src/list_util.sml10
-rw-r--r--src/mono.sml2
-rw-r--r--src/mono_opt.sml40
-rw-r--r--src/mono_print.sml16
-rw-r--r--src/mono_util.sml5
-rw-r--r--src/monoize.sml94
-rw-r--r--tests/plink.lac8
14 files changed, 285 insertions, 59 deletions
diff --git a/include/lacweb.h b/include/lacweb.h
index 891b059d..e84e6bcd 100644
--- a/include/lacweb.h
+++ b/include/lacweb.h
@@ -12,6 +12,7 @@ int lw_send(lw_context, int sock);
void lw_write(lw_context, const char*);
+
char *lw_Basis_attrifyInt(lw_Basis_int);
char *lw_Basis_attrifyFloat(lw_Basis_float);
char *lw_Basis_attrifyString(lw_Basis_string);
@@ -19,3 +20,16 @@ char *lw_Basis_attrifyString(lw_Basis_string);
void lw_Basis_attrifyInt_w(lw_context, lw_Basis_int);
void lw_Basis_attrifyFloat_w(lw_context, lw_Basis_float);
void lw_Basis_attrifyString_w(lw_context, lw_Basis_string);
+
+
+char *lw_Basis_urlifyInt(lw_Basis_int);
+char *lw_Basis_urlifyFloat(lw_Basis_float);
+char *lw_Basis_urlifyString(lw_Basis_string);
+
+void lw_Basis_urlifyInt_w(lw_context, lw_Basis_int);
+void lw_Basis_urlifyFloat_w(lw_context, lw_Basis_float);
+void lw_Basis_urlifyString_w(lw_context, lw_Basis_string);
+
+lw_Basis_int lw_unurlifyInt(char **);
+lw_Basis_float lw_unurlifyFloat(char **);
+lw_Basis_string lw_unurlifyString(char **);
diff --git a/src/c/lacweb.c b/src/c/lacweb.c
index ef8e7184..fef9ed4c 100644
--- a/src/c/lacweb.c
+++ b/src/c/lacweb.c
@@ -124,3 +124,86 @@ void lw_Basis_attrifyString_w(lw_context ctx, lw_Basis_string s) {
}
}
}
+
+
+char *lw_Basis_urlifyInt(lw_Basis_int n) {
+ return "0";
+}
+
+char *lw_Basis_urlifyFloat(lw_Basis_float n) {
+ return "0.0";
+}
+
+char *lw_Basis_urlifyString(lw_Basis_string s) {
+ return "";
+}
+
+static void lw_Basis_urlifyInt_w_unsafe(lw_context ctx, lw_Basis_int n) {
+ int len;
+
+ sprintf(ctx->page_front, "%d%n", n, &len);
+ ctx->page_front += len;
+}
+
+void lw_Basis_urlifyInt_w(lw_context ctx, lw_Basis_int n) {
+ lw_check(ctx, INTS_MAX);
+ lw_Basis_urlifyInt_w_unsafe(ctx, n);
+}
+
+void lw_Basis_urlifyFloat_w(lw_context ctx, lw_Basis_float n) {
+ int len;
+
+ lw_check(ctx, FLOATS_MAX);
+ sprintf(ctx->page_front, "%g%n", n, &len);
+ ctx->page_front += len;
+}
+
+void lw_Basis_urlifyString_w(lw_context ctx, lw_Basis_string s) {
+ lw_check(ctx, strlen(s) * 3);
+
+ for (; *s; s++) {
+ char c = *s;
+
+ if (c == ' ')
+ lw_writec_unsafe(ctx, '+');
+ else if (isalnum(c))
+ lw_writec_unsafe(ctx, c);
+ else {
+ sprintf(ctx->page_front, "%%%02X", c);
+ ctx->page_front += 3;
+ }
+ }
+}
+
+
+lw_Basis_int lw_unurlifyInt(char **s) {
+ char *new_s = strchr(*s, '/');
+ int r;
+
+ if (new_s)
+ *new_s++ = 0;
+ else
+ new_s = strchr(*s, 0);
+
+ r = atoi(*s);
+ *s = new_s;
+ return r;
+}
+
+lw_Basis_float lw_unurlifyFloat(char **s) {
+ char *new_s = strchr(*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(char **s) {
+ return "";
+}
diff --git a/src/cjr.sml b/src/cjr.sml
index 1aacfb60..c262e326 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -61,6 +61,6 @@ datatype decl' =
withtype decl = decl' located
-type file = decl list * (string * int) list
+type file = decl list * (string * int * typ list) list
end
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index b037137e..a3796686 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -173,18 +173,55 @@ fun p_decl env ((d, _) : decl) =
string "}"]
end
-fun p_page env (s, n) =
- box [string "if (!strcmp(request, \"",
+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(&request)"
+
+ | TRecord 0 => string "lw_unit_v"
+
+ | _ => (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 "\", ",
+ string (Int.toString (size s)),
+ string ")) {",
newline,
- p_enamed env n,
- string "(ctx, lw_unit_v);",
+ string "request += ",
+ string (Int.toString (size s)),
+ string ";",
newline,
- string "return;",
+ string "if (*request == '/') ++request;",
newline,
- string "}",
- 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),
+ 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
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 78b73dba..e14f7db1 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -184,7 +184,12 @@ fun cifyDecl ((d, loc), sm) =
in
(SOME (d, loc), NONE, sm)
end
- | L.DExport (s, n) => (NONE, SOME ("/" ^ s, n), sm)
+ | L.DExport (s, n, ts) =>
+ let
+ val (ts, sm) = ListUtil.foldlMap cifyTyp sm ts
+ in
+ (NONE, SOME ("/" ^ s, n, ts), sm)
+ end
fun cjrize ds =
let
diff --git a/src/lacweb.lex b/src/lacweb.lex
index b54d9e21..9e261d9f 100644
--- a/src/lacweb.lex
+++ b/src/lacweb.lex
@@ -276,10 +276,10 @@ notags = [^<{\n]+;
<INITIAL> {cid} => (Tokens.CSYMBOL (yytext, pos yypos, pos yypos + size yytext));
<INITIAL> {intconst} => (case Int64.fromString yytext of
- SOME x => Tokens.INT (x, pos yypos, pos yypos + size yytext)
- | NONE => (ErrorMsg.errorAt' (pos yypos, pos yypos)
- ("Expected int, received: " ^ yytext);
- continue ()));
+ SOME x => Tokens.INT (x, pos yypos, pos yypos + size yytext)
+ | NONE => (ErrorMsg.errorAt' (pos yypos, pos yypos)
+ ("Expected int, received: " ^ yytext);
+ continue ()));
<INITIAL> {realconst} => (case Real64.fromString yytext of
SOME x => Tokens.FLOAT (x, pos yypos, pos yypos + size yytext)
| NONE => (ErrorMsg.errorAt' (pos yypos, pos yypos)
diff --git a/src/list_util.sig b/src/list_util.sig
index e0629c5d..7bc4452c 100644
--- a/src/list_util.sig
+++ b/src/list_util.sig
@@ -40,4 +40,6 @@ signature LIST_UTIL = sig
val search : ('a -> 'b option) -> 'a list -> 'b option
+ val mapi : (int * 'a -> 'b) -> 'a list -> 'b list
+
end
diff --git a/src/list_util.sml b/src/list_util.sml
index fff3e78e..976e4708 100644
--- a/src/list_util.sml
+++ b/src/list_util.sml
@@ -136,4 +136,14 @@ fun search f =
s
end
+fun mapi f =
+ let
+ fun m i acc ls =
+ case ls of
+ [] => rev acc
+ | h :: t => m (i + 1) (f (i, h) :: acc) t
+ in
+ m 0 []
+ end
+
end
diff --git a/src/mono.sml b/src/mono.sml
index 861b4db0..a1ce85c3 100644
--- a/src/mono.sml
+++ b/src/mono.sml
@@ -61,7 +61,7 @@ withtype exp = exp' located
datatype decl' =
DVal of string * int * typ * exp * string
- | DExport of string * int
+ | DExport of string * int * typ list
withtype decl = decl' located
diff --git a/src/mono_opt.sml b/src/mono_opt.sml
index 11e0acef..aa2c5234 100644
--- a/src/mono_opt.sml
+++ b/src/mono_opt.sml
@@ -51,6 +51,25 @@ val attrifyString = String.translate (fn #"\"" => "&quot;"
else
"&#" ^ Int.toString (ord ch) ^ ";")
+val urlifyInt = attrifyInt
+val urlifyFloat = attrifyFloat
+
+fun hexIt ch =
+ let
+ val s = Int.fmt StringCvt.HEX (ord ch)
+ in
+ case size s of
+ 0 => "00"
+ | 1 => "0" ^ s
+ | _ => s
+ end
+
+val urlifyString = String.translate (fn #" " => "+"
+ | ch => if Char.isAlphaNum ch then
+ str ch
+ else
+ "%" ^ hexIt ch)
+
fun exp e =
case e of
EPrim (Prim.String s) =>
@@ -124,6 +143,27 @@ fun exp e =
| EWrite (EFfiApp ("Basis", "attrifyString", [e]), _) =>
EFfiApp ("Basis", "attrifyString_w", [e])
+ | EFfiApp ("Basis", "urlifyInt", [(EPrim (Prim.Int n), _)]) =>
+ EPrim (Prim.String (urlifyInt n))
+ | 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), _)]) =>
+ EPrim (Prim.String (urlifyFloat n))
+ | 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), _)]) =>
+ EPrim (Prim.String (urlifyString s))
+ | 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])
+
| _ => e
and optExp e = #1 (U.Exp.map {typ = typ, exp = exp} e)
diff --git a/src/mono_print.sml b/src/mono_print.sml
index c3738c59..67369b1f 100644
--- a/src/mono_print.sml
+++ b/src/mono_print.sml
@@ -166,12 +166,16 @@ fun p_decl env ((d, _) : decl) =
p_exp env e]
end
- | DExport (s, n) => box [string "export",
- space,
- p_enamed env n,
- space,
- string "as",
- string s]
+ | DExport (s, n, ts) => box [string "export",
+ space,
+ p_enamed env n,
+ space,
+ string "as",
+ 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_util.sml b/src/mono_util.sml
index 0d5211cf..bb4e20b2 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -264,7 +264,10 @@ fun mapfoldB {typ = fc, exp = fe, decl = fd, bind} =
S.map2 (mfe ctx e,
fn e' =>
(DVal (x, n, t', e', s), loc)))
- | DExport _ => S.return2 dAll
+ | DExport (s, n, ts) =>
+ S.map2 (ListUtil.mapfold mft ts,
+ fn ts' =>
+ (DExport (s, n, ts'), loc))
in
mfd
end
diff --git a/src/monoize.sml b/src/monoize.sml
index a330a8bd..b5d9099f 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -79,41 +79,49 @@ fun monoType env (all as (c, loc)) =
val dummyExp = (L'.EPrim (Prim.Int 0), E.dummySpan)
-fun attrifyExp env (e, tAll as (t, loc)) =
- case #1 e of
- L'.EClosure (fnam, [(L'.ERecord [], _)]) =>
- let
- val (_, _, _, s) = Env.lookupENamed env fnam
- in
- (L'.EPrim (Prim.String s), loc)
- end
- | L'.EClosure (fnam, args) =>
- let
- val (_, ft, _, s) = Env.lookupENamed env fnam
- val ft = monoType env ft
-
- fun attrify (args, ft, e) =
- case (args, ft) of
- ([], _) => e
- | (arg :: args, (L'.TFun (t, ft), _)) =>
- (L'.EStrcat (e,
- (L'.EStrcat ((L'.EPrim (Prim.String "/"), loc),
- attrifyExp env (arg, t)), loc)), loc)
- | _ => (E.errorAt loc "Type mismatch encoding attribute";
- e)
- in
- attrify (args, ft, (L'.EPrim (Prim.String s), loc))
- end
- | _ =>
- case t of
- L'.TFfi ("Basis", "string") => (L'.EFfiApp ("Basis", "attrifyString", [e]), loc)
- | L'.TFfi ("Basis", "int") => (L'.EFfiApp ("Basis", "attrifyInt", [e]), loc)
- | L'.TFfi ("Basis", "float") => (L'.EFfiApp ("Basis", "attrifyFloat", [e]), loc)
- | L'.TRecord [] => (L'.EPrim (Prim.String ""), loc)
+fun fooifyExp name env =
+ let
+ fun fooify (e, tAll as (t, loc)) =
+ case #1 e of
+ L'.EClosure (fnam, [(L'.ERecord [], _)]) =>
+ let
+ val (_, _, _, s) = Env.lookupENamed env fnam
+ in
+ (L'.EPrim (Prim.String s), loc)
+ end
+ | L'.EClosure (fnam, args) =>
+ let
+ val (_, ft, _, s) = Env.lookupENamed env fnam
+ val ft = monoType env ft
- | _ => (E.errorAt loc "Don't know how to encode attribute type";
- Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)];
- dummyExp)
+ fun attrify (args, ft, e) =
+ case (args, ft) of
+ ([], _) => e
+ | (arg :: args, (L'.TFun (t, ft), _)) =>
+ (L'.EStrcat (e,
+ (L'.EStrcat ((L'.EPrim (Prim.String "/"), loc),
+ fooify (arg, t)), loc)), loc)
+ | _ => (E.errorAt loc "Type mismatch encoding attribute";
+ e)
+ in
+ attrify (args, ft, (L'.EPrim (Prim.String s), loc))
+ end
+ | _ =>
+ case t of
+ L'.TFfi ("Basis", "string") => (L'.EFfiApp ("Basis", name ^ "ifyString", [e]), loc)
+ | L'.TFfi ("Basis", "int") => (L'.EFfiApp ("Basis", name ^ "ifyInt", [e]), loc)
+ | L'.TFfi ("Basis", "float") => (L'.EFfiApp ("Basis", name ^ "ifyFloat", [e]), loc)
+ | L'.TRecord [] => (L'.EPrim (Prim.String ""), loc)
+
+ | _ => (E.errorAt loc "Don't know how to encode attribute type";
+ Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)];
+ dummyExp)
+ in
+ fooify
+ end
+
+val attrifyExp = fooifyExp "attr"
+val urlifyExp = fooifyExp "url"
fun monoExp env (all as (e, loc)) =
let
@@ -179,10 +187,15 @@ fun monoExp env (all as (e, loc)) =
foldl (fn ((x, e, t), s) =>
let
val xp = " " ^ lowercaseFirst x ^ "=\""
+
+ val fooify =
+ case x of
+ "Link" => urlifyExp
+ | _ => attrifyExp
in
(L'.EStrcat (s,
(L'.EStrcat ((L'.EPrim (Prim.String xp), loc),
- (L'.EStrcat (attrifyExp env (e, t),
+ (L'.EStrcat (fooify env (e, t),
(L'.EPrim (Prim.String "\""), loc)),
loc)),
loc)), loc)
@@ -236,9 +249,16 @@ fun monoDecl env (all as (d, loc)) =
(L'.DVal (x, n, monoType env t, monoExp env e, s), loc))
| L.DExport n =>
let
- val (_, _, _, s) = Env.lookupENamed env n
+ val (_, t, _, s) = Env.lookupENamed env n
+
+ fun unwind (t, _) =
+ case t of
+ L.TFun (dom, ran) => dom :: unwind ran
+ | _ => []
+
+ val ts = map (monoType env) (unwind t)
in
- SOME (env, (L'.DExport (s, n), loc))
+ SOME (env, (L'.DExport (s, n, ts), loc))
end
end
diff --git a/tests/plink.lac b/tests/plink.lac
new file mode 100644
index 00000000..9601f08a
--- /dev/null
+++ b/tests/plink.lac
@@ -0,0 +1,8 @@
+val pA = fn size => <html><body>
+ <font size={size}>Hello World!</font>
+</body></html>
+
+val main = fn () => <html><body>
+ <li> <a link={pA 5}>Size 5</a></li>
+ <li> <a link={pA 10}>Size 10</a></li>
+</body></html>
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-30 10:39:01 +0000