diff options
author | 2009-04-30 11:48:56 -0400 | |
---|---|---|
committer | 2009-04-30 11:48:56 -0400 | |
commit | 1a60a233b9349f320e67f35db1aa3b87d7c2a591 (patch) | |
tree | 3c14a4c191641933ffd1dc31c3d4d34535687368 | |
parent | 7a3ba5558cb363006aae188e02dd57dda833d356 (diff) |
Subforms type-checks; lists urlified and unurlified
-rw-r--r-- | lib/ur/basis.urs | 13 | ||||
-rw-r--r-- | src/cjr_print.sml | 75 | ||||
-rw-r--r-- | src/marshalcheck.sml | 1 | ||||
-rw-r--r-- | src/monoize.sml | 108 | ||||
-rw-r--r-- | src/urweb.grm | 6 | ||||
-rw-r--r-- | tests/list.ur | 5 | ||||
-rw-r--r-- | tests/subforms.ur | 23 | ||||
-rw-r--r-- | tests/subforms.urp | 3 | ||||
-rw-r--r-- | tests/subforms.urs | 1 |
9 files changed, 224 insertions, 11 deletions
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index ea6f6f4a..117f944c 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -566,7 +566,18 @@ val subform : ctx ::: {Unit} -> use ::: {Type} -> bind ::: {Type} 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] => 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 diff --git a/tests/list.ur b/tests/list.ur index 815c0075..480bdd3e 100644 --- a/tests/list.ur +++ b/tests/list.ur @@ -8,10 +8,15 @@ fun delist (ls : list string) : xbody = 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> diff --git a/tests/subforms.ur b/tests/subforms.ur new file mode 100644 index 00000000..3db55a43 --- /dev/null +++ b/tests/subforms.ur @@ -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> diff --git a/tests/subforms.urp b/tests/subforms.urp new file mode 100644 index 00000000..f0d5c239 --- /dev/null +++ b/tests/subforms.urp @@ -0,0 +1,3 @@ +debug + +subforms diff --git a/tests/subforms.urs b/tests/subforms.urs new file mode 100644 index 00000000..6ac44e0b --- /dev/null +++ b/tests/subforms.urs @@ -0,0 +1 @@ +val main : unit -> transaction page |