Mercurial > urweb
diff src/monoize.sml @ 1643:b0720700c36e
'dynClass' pseudo-attribute
| author | Adam Chlipala <adam@chlipala.net> |
|---|---|
| date | Tue, 27 Dec 2011 16:20:48 -0500 |
| parents | 2b312f6d4007 |
| children | ca3b73a7b4d0 |
line wrap: on
line diff
--- a/src/monoize.sml Tue Dec 20 21:06:25 2011 -0500 +++ b/src/monoize.sml Tue Dec 27 16:20:48 2011 -0500 @@ -2967,17 +2967,19 @@ (L.EApp ( (L.EApp ( (L.EApp ( - (L.ECApp ( - (L.ECApp ( + (L.EApp ( + (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( - (L.EFfi ("Basis", "tag"), - _), (L.CRecord (_, attrsGiven), _)), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), - class), _), + (L.ECApp ( + (L.EFfi ("Basis", "tag"), + _), (L.CRecord (_, attrsGiven), _)), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), + class), _), + dynClass), _), attrs), _), tag), _), xml) => @@ -3030,6 +3032,7 @@ val (onload, onunload, attrs) = findOnload (attrs, NONE, NONE, []) val (class, fm) = monoExp (env, st, fm) class + val (dynClass, fm) = monoExp (env, st, fm) dynClass fun tagStart tag' = let @@ -3267,233 +3270,243 @@ (L'.EStrcat ((L'.EJavaScript (L'.Attribute, e), loc), (L'.EPrim (Prim.String ")"), loc)), loc)), loc) end - in - (case tag of - "body" => let - val onload = execify onload - val onunload = execify onunload - in - normal ("body", - SOME (L'.EStrcat ((L'.EFfiApp ("Basis", "maybe_onload", - [(L'.EStrcat ((L'.EFfiApp ("Basis", "get_settings", - [(L'.ERecord [], loc)]), loc), - onload), loc)]), - loc), - (L'.EFfiApp ("Basis", "maybe_onunload", - [onunload]), - loc)), loc), - SOME (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]), loc)) - end - - | "dyn" => - let - fun inTag tag = case targs of - (L.CRecord (_, ctx), _) :: _ => - List.exists (fn ((L.CName tag', _), _) => tag' = tag - | _ => false) ctx - | _ => false - - val tag = if inTag "Tr" then - "tr" - else if inTag "Table" then - "table" - else - "span" - in - case attrs of - [("Signal", e, _)] => - ((L'.EStrcat - ((L'.EPrim (Prim.String ("<script type=\"text/javascript\">dyn(\"" - ^ tag ^ "\", execD(")), loc), - (L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc), - (L'.EPrim (Prim.String ("))</script>")), loc)), loc)), loc), - fm) - | _ => raise Fail "Monoize: Bad dyn attributes" - end - - | "submit" => normal ("input type=\"submit\"", NONE, NONE) - | "image" => normal ("input type=\"image\"", NONE, NONE) - | "button" => normal ("input type=\"submit\"", NONE, NONE) - | "hidden" => input "hidden" - - | "textbox" => - (case targs of - [_, (L.CName name, _)] => - (case List.find (fn ("Source", _, _) => true | _ => false) attrs of - NONE => - let - val (ts, fm) = tagStart "input" - in - ((L'.EStrcat (ts, - (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\" />")), - loc)), loc), fm) - end - | SOME (_, src, _) => - (strcat [str "<script type=\"text/javascript\">inp(exec(", - (L'.EJavaScript (L'.Script, src), loc), - str "), \"", - str name, - str "\")</script>"], - fm)) - | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); - raise Fail "No name passed to textbox tag")) - | "password" => input "password" - | "textarea" => - (case targs of - [_, (L.CName name, _)] => - let - val (ts, fm) = tagStart "textarea" - val (xml, fm) = monoExp (env, st, fm) xml - in - ((L'.EStrcat ((L'.EStrcat (ts, - (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), loc)), loc), - (L'.EStrcat (xml, - (L'.EPrim (Prim.String "</textarea>"), - loc)), loc)), - loc), fm) - end - | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); - raise Fail "No name passed to ltextarea tag")) - - | "checkbox" => input "checkbox" - | "upload" => input "file" - - | "radio" => - (case targs of - [_, (L.CName name, _)] => - monoExp (env, St.setRadioGroup (st, name), fm) xml - | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); - raise Fail "No name passed to radio tag")) - | "radioOption" => - (case St.radioGroup st of - NONE => raise Fail "No name for radioGroup" - | SOME name => - normal ("input", - SOME (L'.EPrim (Prim.String (" type=\"radio\" name=\"" ^ name ^ "\"")), loc), - NONE)) - - | "select" => - (case targs of - [_, (L.CName name, _)] => - let - val (ts, fm) = tagStart "select" - val (xml, fm) = monoExp (env, st, fm) xml - in - ((L'.EStrcat ((L'.EStrcat (ts, - (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), - loc)), loc), - (L'.EStrcat (xml, - (L'.EPrim (Prim.String "</select>"), - loc)), loc)), - loc), - fm) - end - | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); - raise Fail "No name passed to lselect tag")) - - | "ctextbox" => - (case List.find (fn ("Source", _, _) => true | _ => false) attrs of - NONE => - let - val (ts, fm) = tagStart "input" - in - ((L'.EStrcat (ts, - (L'.EPrim (Prim.String " />"), loc)), - loc), fm) - end - | SOME (_, src, _) => - let - val sc = strcat [str "inp(exec(", - (L'.EJavaScript (L'.Script, src), loc), - str "))"] - val sc = setAttrs sc - in - (strcat [str "<script type=\"text/javascript\">", - sc, - str "</script>"], - fm) - end) - - | "ccheckbox" => - (case List.find (fn ("Source", _, _) => true | _ => false) attrs of - NONE => - let - val (ts, fm) = tagStart "input type=\"checkbox\"" - in - ((L'.EStrcat (ts, - (L'.EPrim (Prim.String " />"), loc)), - loc), fm) - end - | SOME (_, src, _) => - let - val sc = strcat [str "chk(exec(", - (L'.EJavaScript (L'.Script, src), loc), - str "))"] - val sc = setAttrs sc - in - (strcat [str "<script type=\"text/javascript\">", - sc, - str "</script>"], - fm) - end) - - | "cselect" => - (case List.find (fn ("Source", _, _) => true | _ => false) attrs of - NONE => - let - val (xml, fm) = monoExp (env, st, fm) xml - val (ts, fm) = tagStart "select" - in - (strcat [ts, - str ">", - xml, - str "</select>"], - fm) - end - | SOME (_, src, _) => - let - val (xml, fm) = monoExp (env, st, fm) xml - - val sc = strcat [str "sel(exec(", - (L'.EJavaScript (L'.Script, src), loc), - str "),exec(", - (L'.EJavaScript (L'.Script, xml), loc), - str "))"] - val sc = setAttrs sc - in - (strcat [str "<script type=\"text/javascript\">", - sc, - str "</script>"], - fm) - end) - - | "coption" => normal ("option", NONE, NONE) - - | "ctextarea" => - (case List.find (fn ("Source", _, _) => true | _ => false) attrs of - NONE => - let - val (ts, fm) = tagStart "textarea" - in - ((L'.EStrcat (ts, - (L'.EPrim (Prim.String " />"), loc)), - loc), fm) - end - | SOME (_, src, _) => - let - val sc = strcat [str "tbx(exec(", - (L'.EJavaScript (L'.Script, src), loc), - str "))"] - val sc = setAttrs sc - in - (strcat [str "<script type=\"text/javascript\">", - sc, - str "</script>"], - fm) - end) - - | "tabl" => normal ("table", NONE, NONE) - | _ => normal (tag, NONE, NONE)) + + val baseAll as (base, fm) = + case tag of + "body" => let + val onload = execify onload + val onunload = execify onunload + in + normal ("body", + SOME (L'.EStrcat ((L'.EFfiApp ("Basis", "maybe_onload", + [(L'.EStrcat ((L'.EFfiApp ("Basis", "get_settings", + [(L'.ERecord [], loc)]), loc), + onload), loc)]), + loc), + (L'.EFfiApp ("Basis", "maybe_onunload", + [onunload]), + loc)), loc), + SOME (L'.EFfiApp ("Basis", "get_script", [(L'.ERecord [], loc)]), loc)) + end + + | "dyn" => + let + fun inTag tag = case targs of + (L.CRecord (_, ctx), _) :: _ => + List.exists (fn ((L.CName tag', _), _) => tag' = tag + | _ => false) ctx + | _ => false + + val tag = if inTag "Tr" then + "tr" + else if inTag "Table" then + "table" + else + "span" + in + case attrs of + [("Signal", e, _)] => + ((L'.EStrcat + ((L'.EPrim (Prim.String ("<script type=\"text/javascript\">dyn(\"" + ^ tag ^ "\", execD(")), loc), + (L'.EStrcat ((L'.EJavaScript (L'.Script, e), loc), + (L'.EPrim (Prim.String ("))</script>")), loc)), loc)), loc), + fm) + | _ => raise Fail "Monoize: Bad dyn attributes" + end + + | "submit" => normal ("input type=\"submit\"", NONE, NONE) + | "image" => normal ("input type=\"image\"", NONE, NONE) + | "button" => normal ("input type=\"submit\"", NONE, NONE) + | "hidden" => input "hidden" + + | "textbox" => + (case targs of + [_, (L.CName name, _)] => + (case List.find (fn ("Source", _, _) => true | _ => false) attrs of + NONE => + let + val (ts, fm) = tagStart "input" + in + ((L'.EStrcat (ts, + (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\" />")), + loc)), loc), fm) + end + | SOME (_, src, _) => + (strcat [str "<script type=\"text/javascript\">inp(exec(", + (L'.EJavaScript (L'.Script, src), loc), + str "), \"", + str name, + str "\")</script>"], + fm)) + | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); + raise Fail "No name passed to textbox tag")) + | "password" => input "password" + | "textarea" => + (case targs of + [_, (L.CName name, _)] => + let + val (ts, fm) = tagStart "textarea" + val (xml, fm) = monoExp (env, st, fm) xml + in + ((L'.EStrcat ((L'.EStrcat (ts, + (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), loc)), loc), + (L'.EStrcat (xml, + (L'.EPrim (Prim.String "</textarea>"), + loc)), loc)), + loc), fm) + end + | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); + raise Fail "No name passed to ltextarea tag")) + + | "checkbox" => input "checkbox" + | "upload" => input "file" + + | "radio" => + (case targs of + [_, (L.CName name, _)] => + monoExp (env, St.setRadioGroup (st, name), fm) xml + | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); + raise Fail "No name passed to radio tag")) + | "radioOption" => + (case St.radioGroup st of + NONE => raise Fail "No name for radioGroup" + | SOME name => + normal ("input", + SOME (L'.EPrim (Prim.String (" type=\"radio\" name=\"" ^ name ^ "\"")), loc), + NONE)) + + | "select" => + (case targs of + [_, (L.CName name, _)] => + let + val (ts, fm) = tagStart "select" + val (xml, fm) = monoExp (env, st, fm) xml + in + ((L'.EStrcat ((L'.EStrcat (ts, + (L'.EPrim (Prim.String (" name=\"" ^ name ^ "\">")), + loc)), loc), + (L'.EStrcat (xml, + (L'.EPrim (Prim.String "</select>"), + loc)), loc)), + loc), + fm) + end + | _ => (Print.prefaces "Targs" (map (fn t => ("T", CorePrint.p_con env t)) targs); + raise Fail "No name passed to lselect tag")) + + | "ctextbox" => + (case List.find (fn ("Source", _, _) => true | _ => false) attrs of + NONE => + let + val (ts, fm) = tagStart "input" + in + ((L'.EStrcat (ts, + (L'.EPrim (Prim.String " />"), loc)), + loc), fm) + end + | SOME (_, src, _) => + let + val sc = strcat [str "inp(exec(", + (L'.EJavaScript (L'.Script, src), loc), + str "))"] + val sc = setAttrs sc + in + (strcat [str "<script type=\"text/javascript\">", + sc, + str "</script>"], + fm) + end) + + | "ccheckbox" => + (case List.find (fn ("Source", _, _) => true | _ => false) attrs of + NONE => + let + val (ts, fm) = tagStart "input type=\"checkbox\"" + in + ((L'.EStrcat (ts, + (L'.EPrim (Prim.String " />"), loc)), + loc), fm) + end + | SOME (_, src, _) => + let + val sc = strcat [str "chk(exec(", + (L'.EJavaScript (L'.Script, src), loc), + str "))"] + val sc = setAttrs sc + in + (strcat [str "<script type=\"text/javascript\">", + sc, + str "</script>"], + fm) + end) + + | "cselect" => + (case List.find (fn ("Source", _, _) => true | _ => false) attrs of + NONE => + let + val (xml, fm) = monoExp (env, st, fm) xml + val (ts, fm) = tagStart "select" + in + (strcat [ts, + str ">", + xml, + str "</select>"], + fm) + end + | SOME (_, src, _) => + let + val (xml, fm) = monoExp (env, st, fm) xml + + val sc = strcat [str "sel(exec(", + (L'.EJavaScript (L'.Script, src), loc), + str "),exec(", + (L'.EJavaScript (L'.Script, xml), loc), + str "))"] + val sc = setAttrs sc + in + (strcat [str "<script type=\"text/javascript\">", + sc, + str "</script>"], + fm) + end) + + | "coption" => normal ("option", NONE, NONE) + + | "ctextarea" => + (case List.find (fn ("Source", _, _) => true | _ => false) attrs of + NONE => + let + val (ts, fm) = tagStart "textarea" + in + ((L'.EStrcat (ts, + (L'.EPrim (Prim.String " />"), loc)), + loc), fm) + end + | SOME (_, src, _) => + let + val sc = strcat [str "tbx(exec(", + (L'.EJavaScript (L'.Script, src), loc), + str "))"] + val sc = setAttrs sc + in + (strcat [str "<script type=\"text/javascript\">", + sc, + str "</script>"], + fm) + end) + + | "tabl" => normal ("table", NONE, NONE) + | _ => normal (tag, NONE, NONE) + in + case #1 dynClass of + L'.ENone _ => baseAll + | _ => (strcat [str "<script type=\"text/javascript\">dynClass(execD(", + (L'.EJavaScript (L'.Script, base), loc), + str "),execD(", + (L'.EJavaScript (L'.Script, dynClass), loc), + str "))</script>"], + fm) end | L.EApp (