From cbc7945fff250fe24dc91bcaa3fec2d635dc052a Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 27 Dec 2011 16:20:48 -0500 Subject: 'dynClass' pseudo-attribute --- src/monoize.sml | 475 +++++++++++++++++++++++++++++--------------------------- src/urweb.grm | 42 +++-- 2 files changed, 272 insertions(+), 245 deletions(-) (limited to 'src') diff --git a/src/monoize.sml b/src/monoize.sml index b1cccb81..3d3b0395 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -2967,17 +2967,19 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (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 @@ fun monoExp (env, st, fm) (all as (e, loc)) = 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 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (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 ("")), 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 ""], - 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 ""), - 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 ""), - 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 ""], - 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 ""], - 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 ""], - 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 ""], - 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 ""], - 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 ("")), 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 ""], + 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 ""), + 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 ""), + 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 ""], + 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 ""], + 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 ""], + 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 ""], + 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 ""], + fm) + end) + + | "tabl" => normal ("table", NONE, NONE) + | _ => normal (tag, NONE, NONE) + in + case #1 dynClass of + L'.ENone _ => baseAll + | _ => (strcat [str ""], + fm) end | L.EApp ( diff --git a/src/urweb.grm b/src/urweb.grm index 22616c79..167e841d 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -1,4 +1,4 @@ -(* Copyright (c) 2008-2010, Adam Chlipala +(* Copyright (c) 2008-2011, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -219,7 +219,7 @@ fun tagIn bt = datatype prop_kind = Delete | Update -datatype attr = Class of exp | Normal of con * exp +datatype attr = Class of exp | DynClass of exp | Normal of con * exp fun patType loc (p : pat) = case #1 p of @@ -355,7 +355,7 @@ fun tnamesOf (e, _) = | xml of exp | xmlOne of exp | xmlOpt of exp - | tag of (string * exp) * exp option * exp + | tag of (string * exp) * exp option * exp option * exp | tagHead of string * exp | bind of string * con option * exp | edecl of edecl @@ -376,7 +376,7 @@ fun tnamesOf (e, _) = | rpat of (string * pat) list * bool | ptuple of pat list - | attrs of exp option * (con * exp) list + | attrs of exp option * exp option * (con * exp) list | attr of attr | attrv of exp @@ -1442,7 +1442,7 @@ xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata", Infer) (EPrim (Prim.String ""), pos)), pos) in - (EApp (#3 tag, cdata), pos) + (EApp (#4 tag, cdata), pos) end) | tag GT xmlOpt END_TAG (let @@ -1461,6 +1461,9 @@ xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata", Infer) val e = (EApp (e, case #2 tag of NONE => (EVar (["Basis"], "None", Infer), pos) | SOME c => (EApp ((EVar (["Basis"], "Some", Infer), pos), c), pos)), pos) + val e = (EApp (e, case #3 tag of + NONE => (EVar (["Basis"], "None", Infer), pos) + | SOME c => (EApp ((EVar (["Basis"], "Some", Infer), pos), c), pos)), pos) in (EApp (e, xmlOpt), pos) end @@ -1471,7 +1474,7 @@ xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata", Infer) (EApp ((EVar (["Basis"], "entry", Infer), pos), xmlOpt), pos) else - (EApp (#3 tag, xmlOpt), pos) + (EApp (#4 tag, xmlOpt), pos) else (if ErrorMsg.anyErrors () then () @@ -1500,11 +1503,16 @@ tag : tagHead attrs (let | SOME e => (EApp ((EVar (["Basis"], "Some", Infer), pos), e), pos) val e = (EApp (e, eo), pos) - val e = (EApp (e, (ERecord (#2 attrs), pos)), pos) + val eo = case #2 attrs of + NONE => (EVar (["Basis"], "None", Infer), pos) + | SOME e => (EApp ((EVar (["Basis"], "Some", Infer), pos), + e), pos) + val e = (EApp (e, eo), pos) + val e = (EApp (e, (ERecord (#3 attrs), pos)), pos) val e = (EApp (e, (EApp (#2 tagHead, (ERecord [], pos)), pos)), pos) in - (tagHead, #1 attrs, e) + (tagHead, #1 attrs, #2 attrs, e) end) tagHead: BEGIN_TAG (let @@ -1516,7 +1524,7 @@ tagHead: BEGIN_TAG (let end) | tagHead LBRACE cexp RBRACE (#1 tagHead, (ECApp (#2 tagHead, cexp), s (tagHeadleft, RBRACEright))) -attrs : (NONE, []) +attrs : (NONE, NONE, []) | attr attrs (let val loc = s (attrleft, attrsright) in @@ -1525,14 +1533,20 @@ attrs : (NONE, []) (case #1 attrs of NONE => () | SOME _ => ErrorMsg.errorAt loc "Multiple classes specified for tag"; - (SOME e, #2 attrs)) + (SOME e, #2 attrs, #3 attrs)) + | DynClass e => + (case #2 attrs of + NONE => () + | SOME _ => ErrorMsg.errorAt loc "Multiple dynamic classes specified for tag"; + (#1 attrs, SOME e, #3 attrs)) | Normal xe => - (#1 attrs, xe :: #2 attrs) + (#1 attrs, #2 attrs, xe :: #3 attrs) end) -attr : SYMBOL EQ attrv (if SYMBOL = "class" then - Class attrv - else +attr : SYMBOL EQ attrv (case SYMBOL of + "class" => Class attrv + | "dynClass" => DynClass attrv + | _ => let val sym = case SYMBOL of -- cgit v1.2.3