Mercurial > urweb

changeset 120:6230bdd122e7

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Passing an argument to a web function
author Adam Chlipala <adamc@hcoop.net>
date Sun, 13 Jul 2008 20:07:10 -0400
parents 7fdc146b2bc2
children 91027db5a07c
files include/lacweb.h src/c/lacweb.c src/cjr.sml src/cjr_print.sml src/cjrize.sml src/lacweb.lex src/list_util.sig src/list_util.sml src/mono.sml src/mono_opt.sml src/mono_print.sml src/mono_util.sml src/monoize.sml tests/plink.lac
diffstat 14 files changed, 284 insertions(+), 58 deletions(-) [+]
line wrap: on
line diff
--- 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 **);
--- 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 "";
+}
--- 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
--- 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
--- 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
--- 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 @@
 <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)
--- 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
--- 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
--- 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
 
--- 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)
--- 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
--- 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    
--- 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
 
--- /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 => <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>