# HG changeset patch # User Adam Chlipala # Date 1215994030 14400 # Node ID 6230bdd122e71100cb9376db60121e63d9612aa2 # Parent 7fdc146b2bc2b3f264efe3c77b047213a3cf8f80 Passing an argument to a web function diff -r 7fdc146b2bc2 -r 6230bdd122e7 include/lacweb.h --- a/include/lacweb.h Sun Jul 13 16:11:25 2008 -0400 +++ b/include/lacweb.h Sun Jul 13 20:07:10 2008 -0400 @@ -12,6 +12,7 @@ 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 @@ 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 -r 7fdc146b2bc2 -r 6230bdd122e7 src/c/lacweb.c --- a/src/c/lacweb.c Sun Jul 13 16:11:25 2008 -0400 +++ b/src/c/lacweb.c Sun Jul 13 20:07:10 2008 -0400 @@ -124,3 +124,86 @@ } } } + + +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 -r 7fdc146b2bc2 -r 6230bdd122e7 src/cjr.sml --- a/src/cjr.sml Sun Jul 13 16:11:25 2008 -0400 +++ b/src/cjr.sml Sun Jul 13 20:07:10 2008 -0400 @@ -61,6 +61,6 @@ withtype decl = decl' located -type file = decl list * (string * int) list +type file = decl list * (string * int * typ list) list end diff -r 7fdc146b2bc2 -r 6230bdd122e7 src/cjr_print.sml --- a/src/cjr_print.sml Sun Jul 13 16:11:25 2008 -0400 +++ b/src/cjr_print.sml Sun Jul 13 20:07:10 2008 -0400 @@ -173,18 +173,55 @@ 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 -r 7fdc146b2bc2 -r 6230bdd122e7 src/cjrize.sml --- a/src/cjrize.sml Sun Jul 13 16:11:25 2008 -0400 +++ b/src/cjrize.sml Sun Jul 13 20:07:10 2008 -0400 @@ -184,7 +184,12 @@ 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 -r 7fdc146b2bc2 -r 6230bdd122e7 src/lacweb.lex --- a/src/lacweb.lex Sun Jul 13 16:11:25 2008 -0400 +++ b/src/lacweb.lex Sun Jul 13 20:07:10 2008 -0400 @@ -276,10 +276,10 @@ {cid} => (Tokens.CSYMBOL (yytext, pos yypos, pos yypos + size yytext)); {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 ())); {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 -r 7fdc146b2bc2 -r 6230bdd122e7 src/list_util.sig --- a/src/list_util.sig Sun Jul 13 16:11:25 2008 -0400 +++ b/src/list_util.sig Sun Jul 13 20:07:10 2008 -0400 @@ -40,4 +40,6 @@ val search : ('a -> 'b option) -> 'a list -> 'b option + val mapi : (int * 'a -> 'b) -> 'a list -> 'b list + end diff -r 7fdc146b2bc2 -r 6230bdd122e7 src/list_util.sml --- a/src/list_util.sml Sun Jul 13 16:11:25 2008 -0400 +++ b/src/list_util.sml Sun Jul 13 20:07:10 2008 -0400 @@ -136,4 +136,14 @@ 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 -r 7fdc146b2bc2 -r 6230bdd122e7 src/mono.sml --- a/src/mono.sml Sun Jul 13 16:11:25 2008 -0400 +++ b/src/mono.sml Sun Jul 13 20:07:10 2008 -0400 @@ -61,7 +61,7 @@ datatype decl' = DVal of string * int * typ * exp * string - | DExport of string * int + | DExport of string * int * typ list withtype decl = decl' located diff -r 7fdc146b2bc2 -r 6230bdd122e7 src/mono_opt.sml --- a/src/mono_opt.sml Sun Jul 13 16:11:25 2008 -0400 +++ b/src/mono_opt.sml Sun Jul 13 20:07:10 2008 -0400 @@ -51,6 +51,25 @@ 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 @@ | 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 -r 7fdc146b2bc2 -r 6230bdd122e7 src/mono_print.sml --- a/src/mono_print.sml Sun Jul 13 16:11:25 2008 -0400 +++ b/src/mono_print.sml Sun Jul 13 20:07:10 2008 -0400 @@ -166,12 +166,16 @@ 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 -r 7fdc146b2bc2 -r 6230bdd122e7 src/mono_util.sml --- a/src/mono_util.sml Sun Jul 13 16:11:25 2008 -0400 +++ b/src/mono_util.sml Sun Jul 13 20:07:10 2008 -0400 @@ -264,7 +264,10 @@ 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 -r 7fdc146b2bc2 -r 6230bdd122e7 src/monoize.sml --- a/src/monoize.sml Sun Jul 13 16:11:25 2008 -0400 +++ b/src/monoize.sml Sun Jul 13 20:07:10 2008 -0400 @@ -79,41 +79,49 @@ 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 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 - 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 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) + | _ => (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 @@ 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 @@ (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 -r 7fdc146b2bc2 -r 6230bdd122e7 tests/plink.lac --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/plink.lac Sun Jul 13 20:07:10 2008 -0400 @@ -0,0 +1,8 @@ +val pA = fn size => + Hello World! + + +val main = fn () => +
  • Size 5
    • +
  • Size 10
    • +