Mercurial > urweb
changeset 1751:acadf9d1214a
'dynStyle' pseudo-attribute
| author | Adam Chlipala <adam@chlipala.net> |
|---|---|
| date | Sun, 06 May 2012 15:15:46 -0400 |
| parents | 277480862cef |
| children | 675ce534e3ec |
| files | doc/manual.tex lib/js/urweb.js lib/ur/basis.urs src/monoize.sml src/urweb.grm tests/dynClass.ur tests/dynClass.urp |
| diffstat | 7 files changed, 142 insertions(+), 60 deletions(-) [+] |
line wrap: on
line diff
--- a/doc/manual.tex Sun May 06 14:01:29 2012 -0400 +++ b/doc/manual.tex Sun May 06 15:15:46 2012 -0400 @@ -1957,6 +1957,7 @@ \hspace{.1in} \Rightarrow \mt{css\_class} \\ \hspace{.1in} \to \mt{option} \; (\mt{signal} \; \mt{css\_class}) \\ \hspace{.1in} \to \mt{css\_style} \\ + \hspace{.1in} \to \mt{option} \; (\mt{signal} \; \mt{css\_style}) \\ \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}) @@ -1965,7 +1966,7 @@ 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. -The third value-level argument makes it possible to generate an HTML \cd{style} attribute. +The third and fourth value-level arguments makes it possible to generate HTML \cd{style} attributes, either with fixed content (\cd{style} attribute) or dynamic content (\cd{dynStyle} pseudo-attribute). Two XML fragments may be concatenated. $$\begin{array}{l} @@ -2237,7 +2238,9 @@ &&& \{e\} & \textrm{computed value} \\ \end{array}$$ -Further, there is a special convenience and compatibility form for setting CSS classes of tags. If a \cd{class} attribute has a value that is a string literal, the literal is parsed in the usual HTML way and replaced with calls to appropriate Ur/Web combinators. Any dashes in the text are replaced with underscores to determine Ur identifiers. +Further, there is a special convenience and compatibility form for setting CSS classes of tags. If a \cd{class} attribute has a value that is a string literal, the literal is parsed in the usual HTML way and replaced with calls to appropriate Ur/Web combinators. Any dashes in the text are replaced with underscores to determine Ur identifiers. The same desugaring can be accessed in a normal expression context by calling the pseudo-function \cd{CLASS} on a string literal. + +Similar support is provided for \cd{style} attributes. Normal CSS syntax may be used in string literals that are \cd{style} attribute values, and the desugaring may be accessed elsewhere with the pseudo-function \cd{STYLE}. \section{\label{structure}The Structure of Web Applications}
--- a/lib/js/urweb.js Sun May 06 14:01:29 2012 -0400 +++ b/lib/js/urweb.js Sun May 06 15:15:46 2012 -0400 @@ -944,7 +944,7 @@ return x; } -function dynClass(html, s) { +function dynClass(html, s_class, s_style) { var htmlCls = {v : null}; html = flatten(htmlCls, html); htmlCls = htmlCls.v; @@ -956,23 +956,45 @@ 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); + if (s_class) { + var x = document.createElement("script"); + x.dead = false; + x.signal = s_class; + 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); - }; + var cls = {v : null}; + html.className = flatten(cls, v); + x.closures = concat(cls.v, htmlCls); + } - addNode(x); - populate(x); + addNode(x); + populate(x); + } + + if (s_style) { + var x = document.createElement("script"); + x.dead = false; + x.signal = s_style; + 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.style.cssText = flatten(cls, v); + x.closures = concat(cls.v, htmlCls); + } + + addNode(x); + populate(x); + } } function addOnChange(x, f) {
--- a/lib/ur/basis.urs Sun May 06 14:01:29 2012 -0400 +++ b/lib/ur/basis.urs Sun May 06 15:15:46 2012 -0400 @@ -662,6 +662,7 @@ css_class -> option (signal css_class) -> css_style + -> option (signal css_style) -> $attrsGiven -> tag (attrsGiven ++ attrsAbsent) ctxOuter ctxInner useOuter bindOuter
--- a/src/monoize.sml Sun May 06 14:01:29 2012 -0400 +++ b/src/monoize.sml Sun May 06 15:15:46 2012 -0400 @@ -3033,19 +3033,21 @@ (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), _), - dynClass), _), - style), _), + (L.ECApp ( + (L.EFfi ("Basis", "tag"), + _), (L.CRecord (_, attrsGiven), _)), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), + class), _), + dynClass), _), + style), _), + dynStyle), _), attrs), _), tag), _), xml) => @@ -3104,15 +3106,22 @@ val (class, fm) = monoExp (env, st, fm) class val (dynClass, fm) = monoExp (env, st, fm) dynClass val (style, fm) = monoExp (env, st, fm) style + val (dynStyle, fm) = monoExp (env, st, fm) dynStyle val dynamics = ["dyn", "ctextbox", "ccheckbox", "cselect", "coption", "ctextarea"] - val () = case #1 dynClass of - L'.ENone _ => () - | _ => if List.exists (fn x => x = tag) dynamics then - E.errorAt loc ("Dynamic tag <" ^ tag ^ "> cannot be combined with 'dynClass' attribute; an additional <span> may be useful") - else - () + fun isSome (e, _) = + case e of + L'.ESome _ => true + | _ => false + + val () = if isSome dynClass orelse isSome dynStyle then + if List.exists (fn x => x = tag) dynamics then + E.errorAt loc ("Dynamic tag <" ^ tag ^ "> cannot be combined with 'dynClass' or 'dynStyle' attribute; an additional <span> may be useful") + else + () + else + () fun tagStart tag' = let @@ -3587,13 +3596,36 @@ | _ => normal (tag, NONE) in case #1 dynClass of - L'.ENone _ => baseAll - | L'.ESome (_, dc) => (strcat [str "<script type=\"text/javascript\">dynClass(execD(", - (L'.EJavaScript (L'.Script, base), loc), - str "),execD(", - (L'.EJavaScript (L'.Script, dc), loc), - str "))</script>"], - fm) + L'.ENone _ => + (case #1 dynStyle of + L'.ENone _ => baseAll + | L'.ESome (_, ds) => (strcat [str "<script type=\"text/javascript\">dynClass(execD(", + (L'.EJavaScript (L'.Script, base), loc), + str "),null,execD(", + (L'.EJavaScript (L'.Script, ds), loc), + str "))</script>"], + fm) + | _ => (E.errorAt loc "Absence/presence of 'dynStyle' unknown"; + baseAll)) + | L'.ESome (_, dc) => + let + val e = case #1 dynStyle of + L'.ENone _ => str "null" + | L'.ESome (_, ds) => strcat [str "execD(", + (L'.EJavaScript (L'.Script, ds), loc), + str ")"] + | _ => (E.errorAt loc "Absence/presence of 'dynStyle' unknown"; + str "null") + in + (strcat [str "<script type=\"text/javascript\">dynClass(execD(", + (L'.EJavaScript (L'.Script, base), loc), + str "),execD(", + (L'.EJavaScript (L'.Script, dc), loc), + str "),", + e, + str ")</script>"], + fm) + end | _ => (E.errorAt loc "Absence/presence of 'dynClass' unknown"; baseAll) end
--- a/src/urweb.grm Sun May 06 14:01:29 2012 -0400 +++ b/src/urweb.grm Sun May 06 15:15:46 2012 -0400 @@ -1,4 +1,4 @@ -(* Copyright (c) 2008-2011, Adam Chlipala +(* Copyright (c) 2008-2012, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -219,7 +219,7 @@ datatype prop_kind = Delete | Update -datatype attr = Class of exp | DynClass of exp | Style of exp | Normal of con * exp +datatype attr = Class of exp | DynClass of exp | Style of exp | DynStyle of exp | Normal of con * exp fun patType loc (p : pat) = case #1 p of @@ -427,7 +427,7 @@ | rpat of (string * pat) list * bool | ptuple of pat list - | attrs of exp option * exp option * exp option * (con * exp) list + | attrs of exp option * exp option * exp option * exp option * (con * exp) list | attr of attr | attrv of exp @@ -1105,7 +1105,10 @@ | eapps LBRACK cexp RBRACK (ECApp (eapps, cexp), s (eappsleft, RBRACKright)) | eapps BANG (EDisjointApp eapps, s (eappsleft, BANGright)) -eexp : eapps (eapps) +eexp : eapps (case #1 eapps of + EApp ((EVar ([], "CLASS", _), _), (EPrim (Prim.String s), loc)) => parseClass s loc + | EApp ((EVar ([], "STYLE", _), _), (EPrim (Prim.String s), loc)) => parseStyle s loc + | _ => eapps) | FN eargs DARROW eexp (let val loc = s (FNleft, eexpright) in @@ -1585,7 +1588,12 @@ | SOME (EPrim (Prim.String s), pos) => parseStyle s pos | SOME e => e val e = (EApp (e, eo), pos) - val e = (EApp (e, (ERecord (#4 attrs), pos)), pos) + val eo = case #4 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 (#5 attrs), pos)), pos) val e = (EApp (e, (EApp (#2 tagHead, (ERecord [], pos)), pos)), pos) in @@ -1601,7 +1609,7 @@ end) | tagHead LBRACE cexp RBRACE (#1 tagHead, (ECApp (#2 tagHead, cexp), s (tagHeadleft, RBRACEright))) -attrs : (NONE, NONE, NONE, []) +attrs : (NONE, NONE, NONE, NONE, []) | attr attrs (let val loc = s (attrleft, attrsright) in @@ -1610,25 +1618,31 @@ (case #1 attrs of NONE => () | SOME _ => ErrorMsg.errorAt loc "Multiple classes specified for tag"; - (SOME e, #2 attrs, #3 attrs, #4 attrs)) + (SOME e, #2 attrs, #3 attrs, #4 attrs, #5 attrs)) | DynClass e => (case #2 attrs of NONE => () | SOME _ => ErrorMsg.errorAt loc "Multiple dynamic classes specified for tag"; - (#1 attrs, SOME e, #3 attrs, #4 attrs)) + (#1 attrs, SOME e, #3 attrs, #4 attrs, #5 attrs)) | Style e => (case #3 attrs of NONE => () | SOME _ => ErrorMsg.errorAt loc "Multiple styles specified for tag"; - (#1 attrs, #2 attrs, SOME e, #4 attrs)) + (#1 attrs, #2 attrs, SOME e, #4 attrs, #5 attrs)) + | DynStyle e => + (case #4 attrs of + NONE => () + | SOME _ => ErrorMsg.errorAt loc "Multiple dynamic classes specified for tag"; + (#1 attrs, #2 attrs, #3 attrs, SOME e, #5 attrs)) | Normal xe => - (#1 attrs, #2 attrs, #3 attrs, xe :: #4 attrs) + (#1 attrs, #2 attrs, #3 attrs, #4 attrs, xe :: #5 attrs) end) attr : SYMBOL EQ attrv (case SYMBOL of "class" => Class attrv | "dynClass" => DynClass attrv | "style" => Style attrv + | "dynStyle" => DynStyle attrv | _ => let val sym =
--- a/tests/dynClass.ur Sun May 06 14:01:29 2012 -0400 +++ b/tests/dynClass.ur Sun May 06 15:15:46 2012 -0400 @@ -1,21 +1,31 @@ -style s1 -style s2 +style date +style topic 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"/> + <link rel="stylesheet" type="text/css" href="http://adam.chlipala.net/style.css"/> </head> <body> - <button dynClass={signal src} onclick={set src s2}/> + <button dynClass={b <- signal toggle; + return (if b then date else topic)} + dynStyle={b <- signal toggle; + return (if b then + STYLE "width: 500px" + else + STYLE "width: 200px")} + onclick={b <- get toggle; set toggle (not b)}/> - <hr/> - - <ctextbox source={s} dynClass={t <- signal toggle; - return (if t then s1 else s2)} - onkeyup={fn _ => t <- get toggle; set toggle (not t)}/> + <button dynStyle={b <- signal toggle; + return (if b then + STYLE "width: 200px" + else + STYLE "width: 100px")}/> + <button dynClass={b <- signal toggle; + return (if b then + topic + else + date)}/> </body> </xml>