summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adamc@hcoop.net>2009-04-30 11:48:56 -0400
committerGravatar Adam Chlipala <adamc@hcoop.net>2009-04-30 11:48:56 -0400
commitcc1b670cf89bbc85ec987316f7c1a73cac6c04e2 (patch)
tree3c14a4c191641933ffd1dc31c3d4d34535687368 /src
parent43b09eea446f8d02ee82360d229b1ce2ba65f6f8 (diff)
Subforms type-checks; lists urlified and unurlified
Diffstat (limited to 'src')
-rw-r--r--src/cjr_print.sml75
-rw-r--r--src/marshalcheck.sml1
-rw-r--r--src/monoize.sml108
-rw-r--r--src/urweb.grm6
4 files changed, 180 insertions, 10 deletions
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index ee2307b6..babd0315 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -333,10 +333,6 @@ fun p_pat (env, exit, depth) (p, loc) =
in
(box [string "{",
newline,
- string "/* ",
- string (ErrorMsg.spanToString loc),
- string "*/",
- newline,
p_typ env t,
space,
string "disc",
@@ -864,6 +860,77 @@ fun unurlify env (t, loc) =
string "})"]
end
+ | TList (t', i) =>
+ if IS.member (rf, i) then
+ box [string "unurlify_list_",
+ string (Int.toString i),
+ string "()"]
+ else
+ let
+ val rf = IS.add (rf, i)
+ in
+ box [string "({",
+ space,
+ p_typ env (t, loc),
+ space,
+ string "unurlify_list_",
+ string (Int.toString i),
+ string "(void) {",
+ newline,
+ box [string "return (request[0] == '/' ? ++request : request,",
+ newline,
+ string "((!strncmp(request, \"Nil\", 3) && (request[3] == 0 ",
+ string "|| request[3] == '/')) ? (request",
+ space,
+ string "+=",
+ space,
+ string "3, NULL) : ((!strncmp(request, \"Cons\", 4) && (request[4] == 0 ",
+ string "|| request[4] == '/')) ? (request",
+ space,
+ string "+=",
+ space,
+ string "4, (request[0] == '/' ? ++request : NULL), ",
+ newline,
+
+ string "({",
+ newline,
+ p_typ env (t, loc),
+ space,
+ string "tmp",
+ space,
+ string "=",
+ space,
+ string "uw_malloc(ctx, sizeof(struct __uws_",
+ string (Int.toString i),
+ string "));",
+ newline,
+ string "*tmp",
+ space,
+ string "=",
+ space,
+ unurlify' rf (TRecord i),
+ string ";",
+ newline,
+ string "tmp;",
+ newline,
+ string "})",
+ string ")",
+ newline,
+ string ":",
+ space,
+ string ("(uw_error(ctx, FATAL, \"Error unurlifying list\"), NULL))));"),
+ newline],
+ string "}",
+ newline,
+ newline,
+
+ string "unurlify_list_",
+ string (Int.toString i),
+ string "();",
+ newline,
+ string "})"]
+ end
+
| TOption t =>
box [string "(request[0] == '/' ? ++request : request, ",
string "((!strncmp(request, \"None\", 4) ",
diff --git a/src/marshalcheck.sml b/src/marshalcheck.sml
index e39bf7c5..7dea28f3 100644
--- a/src/marshalcheck.sml
+++ b/src/marshalcheck.sml
@@ -60,6 +60,7 @@ val clientToServer = [("Basis", "int"),
("Basis", "file"),
("Basis", "unit"),
("Basis", "option"),
+ ("Basis", "list"),
("Basis", "bool")]
val clientToServer = PS.addList (PS.empty, clientToServer)
diff --git a/src/monoize.sml b/src/monoize.sml
index 1ecf7a20..e754452d 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -274,6 +274,7 @@ structure Fm :> sig
val empty : int -> t
val lookup : t -> foo_kind -> int -> (int -> t -> L'.decl * t) -> t * int
+ val lookupList : t -> foo_kind -> L'.typ -> (int -> t -> L'.decl * t) -> t * int
val enter : t -> t
val decls : t -> L'.decl list
@@ -291,23 +292,30 @@ structure M = BinaryMapFn(struct
| (Url, Url) => EQUAL
end)
+structure TM = BinaryMapFn(struct
+ type ord_key = L'.typ
+ val compare = MonoUtil.Typ.compare
+ end)
+
type t = {
count : int,
map : int IM.map M.map,
+ listMap : int TM.map M.map,
decls : L'.decl list
}
fun empty count = {
count = count,
map = M.empty,
+ listMap = M.empty,
decls = []
}
-fun enter ({count, map, ...} : t) = {count = count, map = map, decls = []}
-fun freshName {count, map, decls} = (count, {count = count + 1, map = map, decls = decls})
+fun enter ({count, map, listMap, ...} : t) = {count = count, map = map, listMap = listMap, decls = []}
+fun freshName {count, map, listMap, decls} = (count, {count = count + 1, map = map, listMap = listMap, decls = decls})
fun decls ({decls, ...} : t) = decls
-fun lookup (t as {count, map, decls}) k n thunk =
+fun lookup (t as {count, map, listMap, decls}) k n thunk =
let
val im = Option.getOpt (M.find (map, k), IM.empty)
in
@@ -315,12 +323,37 @@ fun lookup (t as {count, map, decls}) k n thunk =
NONE =>
let
val n' = count
- val (d, {count, map, decls}) = thunk count {count = count + 1,
- map = M.insert (map, k, IM.insert (im, n, n')),
- decls = decls}
+ val (d, {count, map, listMap, decls}) =
+ thunk count {count = count + 1,
+ map = M.insert (map, k, IM.insert (im, n, n')),
+ listMap = listMap,
+ decls = decls}
+ in
+ ({count = count,
+ map = map,
+ listMap = listMap,
+ decls = d :: decls}, n')
+ end
+ | SOME n' => (t, n')
+ end
+
+fun lookupList (t as {count, map, listMap, decls}) k tp thunk =
+ let
+ val tm = Option.getOpt (M.find (listMap, k), TM.empty)
+ in
+ case TM.find (tm, tp) of
+ NONE =>
+ let
+ val n' = count
+ val (d, {count, map, listMap, decls}) =
+ thunk count {count = count + 1,
+ map = map,
+ listMap = M.insert (listMap, k, TM.insert (tm, tp, n')),
+ decls = decls}
in
({count = count,
map = map,
+ listMap = listMap,
decls = d :: decls}, n')
end
| SOME n' => (t, n')
@@ -452,6 +485,41 @@ fun fooifyExp fk env =
fm)
end
+ | L'.TList t =>
+ let
+ fun makeDecl n fm =
+ let
+ val rt = (L'.TRecord [("1", t), ("2", (L'.TList t, loc))], loc)
+ val (arg, fm) = fooify fm ((L'.ERel 0, loc), rt)
+
+ val branches = [((L'.PNone rt, loc),
+ (L'.EPrim (Prim.String "Nil"), loc)),
+ ((L'.PSome (rt, (L'.PVar ("a", rt), loc)), loc),
+ (L'.EStrcat ((L'.EPrim (Prim.String "Cons/"), loc),
+ arg), loc))]
+
+ val dom = tAll
+ val ran = (L'.TFfi ("Basis", "string"), loc)
+ in
+ ((L'.DValRec [(fk2s fk ^ "ify_list",
+ n,
+ (L'.TFun (dom, ran), loc),
+ (L'.EAbs ("x",
+ dom,
+ ran,
+ (L'.ECase ((L'.ERel 0, loc),
+ branches,
+ {disc = dom,
+ result = ran}), loc)), loc),
+ "")], loc),
+ fm)
+ end
+
+ val (fm, n) = Fm.lookupList fm fk t makeDecl
+ in
+ ((L'.EApp ((L'.ENamed n, loc), e), loc), fm)
+ end
+
| _ => (E.errorAt loc "Don't know how to encode attribute/URL type";
Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)];
(dummyExp, fm))
@@ -2718,6 +2786,34 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
fm)
end
+ | L.ECApp ((L.ECApp ((L.ECApp ((L.ECApp (
+ (L.EFfi ("Basis", "subforms"), _), _), _), _),
+ _), _), _), (L.CName nm, loc)) =>
+ let
+ val s = (L'.TFfi ("Basis", "string"), loc)
+ in
+ ((L'.EAbs ("xml", s, s,
+ strcat [(L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".s\" value=\""
+ ^ nm ^ "\">")), loc),
+ (L'.ERel 0, loc),
+ (L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".e\" value=\"1\">")), loc)]),
+ loc),
+ fm)
+ end
+
+ | L.ECApp ((L.ECApp (
+ (L.EFfi ("Basis", "entry"), _), _), _), _) =>
+ let
+ val s = (L'.TFfi ("Basis", "string"), loc)
+ in
+ ((L'.EAbs ("xml", s, s,
+ strcat [(L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".i\" value=\"1\">")), loc),
+ (L'.ERel 0, loc),
+ (L'.EPrim (Prim.String ("<input type=\"hidden\" name=\".e\" value=\"1\">")), loc)]),
+ loc),
+ fm)
+ end
+
| L.EApp ((L.ECApp (
(L.ECApp (
(L.ECApp (
diff --git a/src/urweb.grm b/src/urweb.grm
index 55a38c57..a74a48c8 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -1268,6 +1268,12 @@ xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata", Infer)
else if et = "subform" then
(EApp ((EDisjointApp (#2 (#1 tag)), pos),
xml), pos)
+ else if et = "subforms" then
+ (EApp ((EDisjointApp (#2 (#1 tag)), pos),
+ xml), pos)
+ else if et = "entry" then
+ (EApp ((EVar (["Basis"], "entry", Infer), pos),
+ xml), pos)
else
(EApp (#2 tag, xml), pos)
else