summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adam@chlipala.net>2011-12-27 16:20:48 -0500
committerGravatar Adam Chlipala <adam@chlipala.net>2011-12-27 16:20:48 -0500
commitcbc7945fff250fe24dc91bcaa3fec2d635dc052a (patch)
treeb79292fd3c487498c7837ad6008636a1ed5163cf
parenta8b2771f6e2526855ae3387b876d7f861b53c817 (diff)
'dynClass' pseudo-attribute
-rw-r--r--doc/manual.tex5
-rw-r--r--lib/js/urweb.js34
-rw-r--r--lib/ur/basis.urs1
-rw-r--r--src/monoize.sml475
-rw-r--r--src/urweb.grm42
-rw-r--r--tests/dynClass.ur21
-rw-r--r--tests/dynClass.urp4
7 files changed, 334 insertions, 248 deletions
diff --git a/doc/manual.tex b/doc/manual.tex
index 82bd5244..5b0ef6ec 100644
--- a/doc/manual.tex
+++ b/doc/manual.tex
@@ -1933,12 +1933,15 @@ $$\begin{array}{l}
\hspace{.1in} \to \mt{useOuter} ::: \{\mt{Type}\} \to \mt{useInner} ::: \{\mt{Type}\} \to \mt{bindOuter} ::: \{\mt{Type}\} \to \mt{bindInner} ::: \{\mt{Type}\} \\
\hspace{.1in} \to [\mt{attrsGiven} \sim \mt{attrsAbsent}] \Rightarrow [\mt{useOuter} \sim \mt{useInner}] \Rightarrow [\mt{bindOuter} \sim \mt{bindInner}] \\
\hspace{.1in} \Rightarrow \mt{option} \; \mt{css\_class} \\
+ \hspace{.1in} \to \mt{option} \; (\mt{signal} \; \mt{css\_class}) \\
\hspace{.1in} \to \$\mt{attrsGiven} \\
\hspace{.1in} \to \mt{tag} \; (\mt{attrsGiven} \rc \mt{attrsAbsent}) \; \mt{ctxOuter} \; \mt{ctxInner} \; \mt{useOuter} \; \mt{bindOuter} \\
\hspace{.1in} \to \mt{xml} \; \mt{ctxInner} \; \mt{useInner} \; \mt{bindInner} \to \mt{xml} \; \mt{ctxOuter} \; (\mt{useOuter} \rc \mt{useInner}) \; (\mt{bindOuter} \rc \mt{bindInner})
\end{array}$$
Note that any tag may be assigned a CSS class. This is the sole way of making use of the values produced by $\mt{style}$ declarations. Ur/Web itself doesn't deal with the syntax or semantics of style sheets; they can be linked via URLs with \texttt{link} tags. However, Ur/Web does make it easy to calculate upper bounds on usage of CSS classes through program analysis. The function $\mt{Basis.classes}$ can be used to specify a list of CSS classes for a single tag.
+Also note that two different arguments are available for setting CSS classes: the first, associated with the \texttt{class} pseudo-attribute syntactic sugar, fixes the class of a tag for the duration of the tag's life; while the second, associated with the \texttt{dynClass} pseudo-attribute, allows the class to vary over the tag's life. See Section \ref{signals} for an introduction to the $\mt{signal}$ type family.
+
Two XML fragments may be concatenated.
$$\begin{array}{l}
\mt{val} \; \mt{join} : \mt{ctx} ::: \{\mt{Unit}\} \to \mt{use_1} ::: \{\mt{Type}\} \to \mt{bind_1} ::: \{\mt{Type}\} \to \mt{bind_2} ::: \{\mt{Type}\} \\
@@ -2023,7 +2026,7 @@ $$\begin{array}{l}
The \cd{fresh} function is allowed on both server and client, but there is no other way to create IDs, which includes lack of a way to force an ID to match a particular string. The only semantic importance of IDs within Ur/Web is in uses of the HTML \cd{<label>} tag. IDs play a much more central role in mainstream JavaScript programming, but Ur/Web uses a very different model to enable changes to particular nodes of a page tree, as the next manual subsection explains. IDs may still be useful in interfacing with JavaScript code (for instance, through Ur/Web's FFI).
-\subsubsection{Functional-Reactive Page Generation}
+\subsubsection{\label{signals}Functional-Reactive Page Generation}
Most approaches to ``AJAX''-style coding involve imperative manipulation of the DOM tree representing an HTML document's structure. Ur/Web follows the \emph{functional-reactive} approach instead. Programs may allocate mutable \emph{sources} of arbitrary types, and an HTML page is effectively a pure function over the latest values of the sources. The page is not mutated directly, but rather it changes automatically as the sources are mutated.
diff --git a/lib/js/urweb.js b/lib/js/urweb.js
index a3976fef..ba73e744 100644
--- a/lib/js/urweb.js
+++ b/lib/js/urweb.js
@@ -47,7 +47,7 @@ function cons(v, ls) {
function rev(ls) {
var acc = null;
for (; ls; ls = ls.next)
- acc = cons(ls.data, acc);
+ acc = cons(ls.data, acc);
return acc;
}
function concat(ls1, ls2) {
@@ -562,7 +562,6 @@ function flattenLocal(s) {
}
-
// Dynamic tree management
function populate(node) {
@@ -899,6 +898,37 @@ function tbx(s) {
return x;
}
+function dynClass(html, s) {
+ var htmlCls = {v : null};
+ html = flatten(htmlCls, html);
+ htmlCls = htmlCls.v;
+
+ var dummy = document.createElement("body");
+ dummy.innerHTML = html;
+ runScripts(dummy);
+ var html = dummy.firstChild;
+ dummy.removeChild(html);
+ addNode(html);
+
+ var x = document.createElement("script");
+ x.dead = false;
+ x.signal = s;
+ x.sources = null;
+ x.closures = htmlCls;
+
+ x.recreate = function(v) {
+ for (var ls = x.closures; ls != htmlCls; ls = ls.next)
+ freeClosure(ls.data);
+
+ var cls = {v : null};
+ html.className = flatten(cls, v);
+ x.closures = concat(cls.v, htmlCls);
+ };
+
+ addNode(x);
+ populate(x);
+}
+
function addOnChange(x, f) {
var old = x.onchange;
if (old == null)
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index 17e969ef..08585546 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -645,6 +645,7 @@ val tag : attrsGiven ::: {Type} -> attrsAbsent ::: {Type}
[useOuter ~ useInner] =>
[bindOuter ~ bindInner] =>
option css_class
+ -> option (signal css_class)
-> $attrsGiven
-> tag (attrsGiven ++ attrsAbsent)
ctxOuter ctxInner useOuter bindOuter
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 ("<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 (
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
diff --git a/tests/dynClass.ur b/tests/dynClass.ur
new file mode 100644
index 00000000..2c7068c8
--- /dev/null
+++ b/tests/dynClass.ur
@@ -0,0 +1,21 @@
+style s1
+style s2
+
+fun main () : transaction page =
+ src <- source s1;
+ s <- source "";
+ toggle <- source False;
+ return <xml>
+ <head>
+ <link rel="stylesheet" type="text/css" href="http://localhost/test.css"/>
+ </head>
+ <body>
+ <button dynClass={signal src} onclick={set src s2}/>
+
+ <hr/>
+
+ <ctextbox source={s} dynClass={t <- signal toggle;
+ return (if t then s1 else s2)}
+ onkeyup={fn _ => t <- get toggle; set toggle (not t)}/>
+ </body>
+ </xml>
diff --git a/tests/dynClass.urp b/tests/dynClass.urp
new file mode 100644
index 00000000..4358782b
--- /dev/null
+++ b/tests/dynClass.urp
@@ -0,0 +1,4 @@
+rewrite all DynClass/*
+allow url http://localhost/*
+
+dynClass