diff options
author | Adam Chlipala <adamc@hcoop.net> | 2008-07-24 10:41:53 -0400 |
---|---|---|
committer | Adam Chlipala <adamc@hcoop.net> | 2008-07-24 10:41:53 -0400 |
commit | a8d4408b6a68c27dc88d8f7e37326c19296808db (patch) | |
tree | 1a5e9d5f469c8e29d4c0106086d8a029f4dc476b | |
parent | a729c94d397dc7731a711eea990092c90fbd5460 (diff) |
textarea
-rw-r--r-- | lib/basis.lig | 1 | ||||
-rw-r--r-- | src/elaborate.sml | 3 | ||||
-rw-r--r-- | src/monoize.sml | 44 | ||||
-rw-r--r-- | tests/textarea.lac | 10 |
4 files changed, 43 insertions, 15 deletions
diff --git a/lib/basis.lig b/lib/basis.lig index 64dee2a3..445ebc85 100644 --- a/lib/basis.lig +++ b/lib/basis.lig @@ -66,6 +66,7 @@ con lformTag = fn ty :: Type => fn attrs :: {Type} => -> nm :: Name -> unit -> tag attrs ([LForm] ++ ctx) [] [] [nm = ty] val textbox : lformTag string [] +val ltextarea : lformTag string [] val submit : ctx ::: {Unit} -> [LForm] ~ ctx -> use ::: {Type} -> unit diff --git a/src/elaborate.sml b/src/elaborate.sml index dd0b7187..c7b5bcf3 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -1915,8 +1915,9 @@ fun elabDecl ((d, loc), (env, denv, gs)) = ((L'.CApp (tf, arg1), _), []) => (case (hnormCon (env, denv) tf, hnormCon (env, denv) domR, + hnormCon (env, denv) arg1, hnormCon (env, denv) arg2) of - ((tf, []), (domR, []), + ((tf, []), (domR, []), (arg1, []), ((L'.CRecord (_, []), _), [])) => let val t = (L'.CApp (tf, arg1), loc) diff --git a/src/monoize.sml b/src/monoize.sml index b31613c1..33e1eba3 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -244,23 +244,14 @@ fun monoExp env (all as (e, loc)) = 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")) - | _ => + fun normal (tag, extra) = let val tagStart = tagStart tag - + val tagStart = case extra of + NONE => tagStart + | SOME extra => (L'.EStrcat (tagStart, extra), loc) + fun normal () = (L'.EStrcat ((L'.EStrcat (tagStart, (L'.EPrim (Prim.String ">"), loc)), loc), (L'.EStrcat (monoExp env xml, @@ -280,6 +271,31 @@ fun monoExp env (all as (e, loc)) = normal () | _ => normal () end + 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 textarea tag")) + | "ltextarea" => + (case targs of + [_, (L.CName name, _)] => + (L'.EStrcat ((L'.EStrcat (tagStart "textarea", + (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), loc)), loc), + (L'.EStrcat (monoExp env xml, + (L'.EPrim (Prim.String "</textarea>"), + loc)), loc)), + loc) + | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); + raise Fail "No named passed to ltextarea tag")) + + | _ => normal (tag, NONE) end | L.EApp ((L.ECApp ( diff --git a/tests/textarea.lac b/tests/textarea.lac new file mode 100644 index 00000000..708c9b03 --- /dev/null +++ b/tests/textarea.lac @@ -0,0 +1,10 @@ +val handler = fn x => <html><body> + You entered: {cdata x.A} +</body></html> + +val main = fn () => <html><body> + <lform> + <ltextarea{#A}/> + <submit action={handler}/> + </lform> +</body></html> |