Mercurial > urweb
changeset 143:4b9c2bd6157c
Almost ready to have a form work
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sun, 20 Jul 2008 13:30:19 -0400 |
| parents | 6f9e224692ec |
| children | f0d3402184d1 |
| files | src/cjr_print.sml src/monoize.sml src/tag.sml |
| diffstat | 3 files changed, 214 insertions(+), 73 deletions(-) [+] |
line wrap: on
line diff
--- a/src/cjr_print.sml Sun Jul 20 12:21:30 2008 -0400 +++ b/src/cjr_print.sml Sun Jul 20 13:30:19 2008 -0400 @@ -208,13 +208,48 @@ newline] end -fun unurlify (t, loc) = +fun unurlify env (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(ctx, &request)" | TRecord 0 => string "lw_unit_v" + | TRecord i => + let + val xts = E.lookupStruct env i + in + box [string "({", + newline, + box (map (fn (x, t) => + box [p_typ env t, + space, + string x, + space, + string "=", + space, + unurlify env t, + string ";", + newline]) xts), + string "struct", + space, + string "__lws_", + string (Int.toString i), + space, + string "__lw_tmp", + space, + string "=", + space, + string "{", + space, + p_list_sep (box [string ",", space]) (fn (x, _) => string x) xts, + space, + string "};", + newline, + string "__lw_tmp;", + newline, + string "})"] + end | _ => (ErrorMsg.errorAt loc "Unable to choose a URL decoding function"; space) @@ -241,7 +276,7 @@ space, string "=", space, - unurlify t, + unurlify env t, string ";", newline]) ts), p_enamed env n,
--- a/src/monoize.sml Sun Jul 20 12:21:30 2008 -0400 +++ b/src/monoize.sml Sun Jul 20 13:30:19 2008 -0400 @@ -61,7 +61,8 @@ (L'.TRecord (map (fn (x, t) => (monoName env x, monoType env t)) xcs), loc) | L.TRecord _ => poly () - | L.CApp ((L.CFfi ("Basis", "xml"), _), _) => (L'.TFfi ("Basis", "string"), loc) + | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "xml"), _), _), _), _), _), _) => + (L'.TFfi ("Basis", "string"), loc) | L.CRel _ => poly () | L.CNamed n => (L'.TNamed n, loc) @@ -124,6 +125,11 @@ val attrifyExp = fooifyExp "attr" val urlifyExp = fooifyExp "url" +datatype 'a failable_search = + Found of 'a + | NotFound + | Error + fun monoExp env (all as (e, loc)) = let fun poly () = @@ -176,30 +182,35 @@ let fun getTag' (e, _) = case e of - L.EFfi ("Basis", tag) => tag - | L.ECApp (e, _) => getTag' e + L.EFfi ("Basis", tag) => (tag, []) + | L.ECApp (e, t) => let + val (tag, ts) = getTag' e + in + (tag, ts @ [t]) + end | _ => (E.errorAt loc "Non-constant XML tag"; Print.eprefaces' [("Expression", CorePrint.p_exp env tag)]; - "") + ("", [])) fun getTag (e, _) = case e of - L.EFfiApp ("Basis", tag, [(L.ERecord [], _)]) => tag + L.EFfiApp ("Basis", tag, [(L.ERecord [], _)]) => (tag, []) | L.EApp (e, (L.ERecord [], _)) => getTag' e | _ => (E.errorAt loc "Non-constant XML tag"; Print.eprefaces' [("Expression", CorePrint.p_exp env tag)]; - "") + ("", [])) - val tag = getTag tag + val (tag, targs) = getTag tag val attrs = monoExp env attrs - val tagStart = + fun tagStart tag = case #1 attrs of L'.ERecord xes => let fun lowercaseFirst "" = "" - | lowercaseFirst s = str (Char.toLower (String.sub (s, 0))) ^ String.extract (s, 1, NONE) + | lowercaseFirst s = str (Char.toLower (String.sub (s, 0))) + ^ String.extract (s, 1, NONE) val s = (L'.EPrim (Prim.String (String.concat ["<", tag])), loc) in @@ -210,47 +221,135 @@ val fooify = case x of "Link" => urlifyExp + | "Action" => urlifyExp | _ => attrifyExp in (L'.EStrcat (s, (L'.EStrcat ((L'.EPrim (Prim.String xp), loc), (L'.EStrcat (fooify env (e, t), - (L'.EPrim (Prim.String "\""), loc)), + (L'.EPrim (Prim.String "\""), + loc)), loc)), loc)), loc) end) - s xes + s xes end - | _ => raise Fail "Attributes!" + | _ => raise Fail "Non-record attributes!" - fun normal () = - (L'.EStrcat ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String ">"), loc)), loc), - (L'.EStrcat (monoExp env xml, - (L'.EPrim (Prim.String (String.concat ["</", tag, ">"])), loc)), loc)), - loc) + fun input typ = + case targs of + [(L.CName name, _)] => + (L'.EStrcat (tagStart "input", + (L'.EPrim (Prim.String (" type=\"" ^ typ ^ "\" name=\"" ^ name ^ "\"/>")), + loc)), loc) + | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); + raise Fail "No named passed to input tag") + in + case tag of + "submit" => (L'.EPrim (Prim.String "<input type=\"submit\"/>"), loc) + | "textbox" => + (case targs of + [_, (L.CName name, _)] => + (L'.EStrcat (tagStart "input", + (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\"/>")), + loc)), loc) + | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); + raise Fail "No named passed to input tag")) - in - case xml of - (L.EApp ((L.ECApp ( - (L.ECApp ((L.EFfi ("Basis", "cdata"), _), - _), _), - _), _), - (L.EPrim (Prim.String s), _)), _) => - if CharVector.all Char.isSpace s then - (L'.EStrcat (tagStart, (L'.EPrim (Prim.String "/>"), loc)), loc) - else - normal () - | _ => normal () + | _ => + let + val tagStart = tagStart tag + + fun normal () = + (L'.EStrcat ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String ">"), loc)), loc), + (L'.EStrcat (monoExp env xml, + (L'.EPrim (Prim.String (String.concat ["</", tag, ">"])), + loc)), loc)), + loc) + in + case xml of + (L.EApp ((L.ECApp ( + (L.ECApp ((L.EFfi ("Basis", "cdata"), _), + _), _), + _), _), + (L.EPrim (Prim.String s), _)), _) => + if CharVector.all Char.isSpace s then + (L'.EStrcat (tagStart, (L'.EPrim (Prim.String "/>"), loc)), loc) + else + normal () + | _ => normal () + end end | L.EApp ((L.ECApp ( (L.ECApp ((L.EFfi ("Basis", "lform"), _), _), _), _), _), xml) => - (L'.EStrcat ((L'.EPrim (Prim.String "<form>"), loc), - (L'.EStrcat (monoExp env xml, - (L'.EPrim (Prim.String "</form>"), loc)), loc)), loc) + let + fun findSubmit (e, _) = + case e of + L.EApp ( + (L.EApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "join"), + _), _), _), + _), _), + _), _), + _), _), + xml1), _), + xml2) => (case findSubmit xml1 of + Error => Error + | NotFound => findSubmit xml2 + | Found e => + case findSubmit xml2 of + NotFound => Found e + | _ => Error) + | L.EApp ( + (L.EApp ( + (L.EApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.ECApp ( + (L.EFfi ("Basis", "tag"), + _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), + attrs), _), + _), _), + xml) => + (case #1 attrs of + L.ERecord xes => + (case ListUtil.search (fn ((L.CName "Action", _), e, t) => SOME (e, t) + | _ => NONE) xes of + NONE => findSubmit xml + | SOME et => + case findSubmit xml of + NotFound => Found et + | _ => Error) + | _ => findSubmit xml) + | _ => NotFound + + val (action, actionT) = case findSubmit xml of + NotFound => raise Fail "No submit found" + | Error => raise Fail "Not ready for multi-submit lforms yet" + | Found et => et + + val actionT = monoType env actionT + val action = monoExp env action + in + (L'.EStrcat ((L'.EStrcat ((L'.EPrim (Prim.String "<form action=\""), loc), + (L'.EStrcat (urlifyExp env (action, actionT), + (L'.EPrim (Prim.String "\">"), loc)), loc)), loc), + (L'.EStrcat (monoExp env xml, + (L'.EPrim (Prim.String "</form>"), loc)), loc)), loc) + end | L.EApp (e1, e2) => (L'.EApp (monoExp env e1, monoExp env e2), loc) | L.EAbs (x, dom, ran, e) =>
--- a/src/tag.sml Sun Jul 20 12:21:30 2008 -0400 +++ b/src/tag.sml Sun Jul 20 13:30:19 2008 -0400 @@ -65,50 +65,57 @@ let val (xets, s) = ListUtil.foldlMap (fn ((x, e, t), (count, tags, byTag, newTags)) => - case x of - (CName "Link", _) => - let - fun unravel (e, _) = - case e of - ENamed n => (n, []) - | EApp (e1, e2) => - let - val (n, es) = unravel e1 - in - (n, es @ [e2]) - end - | _ => (ErrorMsg.errorAt loc "Invalid link expression"; - (0, [])) + let + fun tagIt newAttr = + let + fun unravel (e, _) = + case e of + ENamed n => (n, []) + | EApp (e1, e2) => + let + val (n, es) = unravel e1 + in + (n, es @ [e2]) + end + | _ => (ErrorMsg.errorAt loc "Invalid link expression"; + (0, [])) - val (f, args) = unravel e - val (cn, count, tags, newTags) = - case IM.find (tags, f) of - NONE => - (count, count + 1, IM.insert (tags, f, count), - (f, count) :: newTags) - | SOME cn => (cn, count, tags, newTags) - val (_, _, _, s) = E.lookupENamed env f + val (f, args) = unravel e - val byTag = case SM.find (byTag, s) of - NONE => SM.insert (byTag, s, f) - | SOME f' => - (if f = f' then - () - else - ErrorMsg.errorAt loc - ("Duplicate HTTP tag " - ^ s); - byTag) + val (cn, count, tags, newTags) = + case IM.find (tags, f) of + NONE => + (count, count + 1, IM.insert (tags, f, count), + (f, count) :: newTags) + | SOME cn => (cn, count, tags, newTags) + + val (_, _, _, s) = E.lookupENamed env f - val e = (EClosure (cn, args), loc) - val t = (CFfi ("Basis", "string"), loc) - in - (((CName "href", loc), e, t), - (count, tags, byTag, newTags)) - end - | _ => ((x, e, t), (count, tags, byTag, newTags))) + val byTag = case SM.find (byTag, s) of + NONE => SM.insert (byTag, s, f) + | SOME f' => + (if f = f' then + () + else + ErrorMsg.errorAt loc + ("Duplicate HTTP tag " + ^ s); + byTag) + + val e = (EClosure (cn, args), loc) + val t = (CFfi ("Basis", "string"), loc) + in + (((CName newAttr, loc), e, t), + (count, tags, byTag, newTags)) + end + in + case x of + (CName "Link", _) => tagIt "Href" + | (CName "Action", _) => tagIt "Action" + | _ => ((x, e, t), (count, tags, byTag, newTags)) + end) s xets in (EApp (