Mercurial > urweb
changeset 758:8323c1beef2e
Subforms type-checks; lists urlified and unurlified
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Thu, 30 Apr 2009 11:48:56 -0400 |
| parents | fa2019a63ea4 |
| children | 67cd8326f743 |
| files | lib/ur/basis.urs src/cjr_print.sml src/marshalcheck.sml src/monoize.sml src/urweb.grm tests/list.ur tests/subforms.ur tests/subforms.urp tests/subforms.urs |
| diffstat | 9 files changed, 224 insertions(+), 11 deletions(-) [+] |
line wrap: on
line diff
--- a/lib/ur/basis.urs Thu Apr 30 11:07:29 2009 -0400 +++ b/lib/ur/basis.urs Thu Apr 30 11:48:56 2009 -0400 @@ -566,7 +566,18 @@ nm :: Name -> [[nm] ~ use] => xml form [] bind -> xml ([Form] ++ ctx) use [nm = $bind] - + +val subforms : ctx ::: {Unit} -> use ::: {Type} -> bind ::: {Type} + -> [[Form] ~ ctx] => + nm :: Name -> [[nm] ~ use] => + xml [Body, Subform] [Entry = $bind] [] + -> xml ([Form] ++ ctx) use [nm = list ($bind)] + +val entry : ctx ::: {Unit} -> bind ::: {Type} + -> [[Subform] ~ ctx] => + xml form [] bind + -> xml ([Subform] ++ ctx) [Entry = $bind] [] + con formTag = fn (ty :: Type) (inner :: {Unit}) (attrs :: {Type}) => ctx ::: {Unit} -> [[Form] ~ ctx] =>
--- a/src/cjr_print.sml Thu Apr 30 11:07:29 2009 -0400 +++ b/src/cjr_print.sml Thu Apr 30 11:48:56 2009 -0400 @@ -333,10 +333,6 @@ in (box [string "{", newline, - string "/* ", - string (ErrorMsg.spanToString loc), - string "*/", - newline, p_typ env t, space, string "disc", @@ -864,6 +860,77 @@ 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) ",
--- a/src/marshalcheck.sml Thu Apr 30 11:07:29 2009 -0400 +++ b/src/marshalcheck.sml Thu Apr 30 11:48:56 2009 -0400 @@ -60,6 +60,7 @@ ("Basis", "file"), ("Basis", "unit"), ("Basis", "option"), + ("Basis", "list"), ("Basis", "bool")] val clientToServer = PS.addList (PS.empty, clientToServer)
--- a/src/monoize.sml Thu Apr 30 11:07:29 2009 -0400 +++ b/src/monoize.sml Thu Apr 30 11:48:56 2009 -0400 @@ -274,6 +274,7 @@ 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 @@ | (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 @@ 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 @@ 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 @@ 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 (
--- a/src/urweb.grm Thu Apr 30 11:07:29 2009 -0400 +++ b/src/urweb.grm Thu Apr 30 11:48:56 2009 -0400 @@ -1268,6 +1268,12 @@ 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
--- a/tests/list.ur Thu Apr 30 11:07:29 2009 -0400 +++ b/tests/list.ur Thu Apr 30 11:48:56 2009 -0400 @@ -8,10 +8,15 @@ Nil => <xml>Nil</xml> | Cons (h, t) => <xml>{[h]} :: {delist t}</xml> +fun callback ls = return <xml><body> + {delist ls} +</body></xml> + fun main () = return <xml><body> {[isNil (Nil : list bool)]}, {[isNil (Cons (1, Nil))]}, {[isNil (Cons ("A", Cons ("B", Nil)))]} <p>{delist (Cons ("X", Cons ("Y", Cons ("Z", Nil))))}</p> + <a link={callback (Cons ("A", Cons ("B", Nil)))}>Go!</a> </body></xml>
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/subforms.ur Thu Apr 30 11:48:56 2009 -0400 @@ -0,0 +1,23 @@ +fun handler' ls = + case ls of + Nil => <xml/> + | Cons (r, ls) => <xml><li>{[r.A]}, {[r.B]}, {[r.Sub]}</li>{handler' ls}</xml> + +fun handler r = return <xml><body> + {[r.A]}, {handler' r.Sub}, {[r.C]} +</body></xml> + +fun main () = return <xml><body> + <form> + <textbox{#A}/><br/> + <subforms{#Sub}> + <entry> + <textbox{#A}/><br/> + <textbox{#B}/><br/> + <textbox{#Sub}/><br/> + </entry> + </subforms> + <textbox{#C}/><br/> + <submit action={handler}/> + </form> +</body></xml>