From 811a3831805bf7a87ed3a64156f4ac6f6246edb9 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 13 Jul 2008 20:07:10 -0400 Subject: Passing an argument to a web function --- include/lacweb.h | 14 ++++++++ src/c/lacweb.c | 83 +++++++++++++++++++++++++++++++++++++++++++++++ src/cjr.sml | 2 +- src/cjr_print.sml | 53 +++++++++++++++++++++++++----- src/cjrize.sml | 7 +++- src/lacweb.lex | 8 ++--- src/list_util.sig | 2 ++ src/list_util.sml | 10 ++++++ src/mono.sml | 2 +- src/mono_opt.sml | 40 +++++++++++++++++++++++ src/mono_print.sml | 16 ++++++---- src/mono_util.sml | 5 ++- src/monoize.sml | 94 +++++++++++++++++++++++++++++++++--------------------- tests/plink.lac | 8 +++++ 14 files changed, 285 insertions(+), 59 deletions(-) create mode 100644 tests/plink.lac 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]+; {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 --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 #"\"" => """ 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 => + Hello World! + + +val main = fn () => +
  • Size 5
    • +
  • Size 10
    • + -- cgit v1.2.3