diff options
-rw-r--r-- | doc/manual.tex | 7 | ||||
-rw-r--r-- | lib/js/urweb.js | 54 | ||||
-rw-r--r-- | lib/ur/basis.urs | 1 | ||||
-rw-r--r-- | src/monoize.sml | 72 | ||||
-rw-r--r-- | src/urweb.grm | 34 | ||||
-rw-r--r-- | tests/dynClass.ur | 32 | ||||
-rw-r--r-- | tests/dynClass.urp | 2 |
7 files changed, 142 insertions, 60 deletions
diff --git a/doc/manual.tex b/doc/manual.tex index 0fdf9d2e..fa321c69 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -1957,6 +1957,7 @@ $$\begin{array}{l} \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 @@ Note that any tag may be assigned a CSS class, or left without a class by passin 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 @@ $$\begin{array}{rrcll} &&& \{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} diff --git a/lib/js/urweb.js b/lib/js/urweb.js index 74badd36..4f6a5f22 100644 --- a/lib/js/urweb.js +++ b/lib/js/urweb.js @@ -944,7 +944,7 @@ function tbx(s) { 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 @@ function dynClass(html, s) { 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) { diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index 1c9de4b9..760cc4d2 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -662,6 +662,7 @@ val tag : attrsGiven ::: {Type} -> attrsAbsent ::: {Type} css_class -> option (signal css_class) -> css_style + -> option (signal css_style) -> $attrsGiven -> tag (attrsGiven ++ attrsAbsent) ctxOuter ctxInner useOuter bindOuter diff --git a/src/monoize.sml b/src/monoize.sml index fe2d67bd..564be889 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -3033,19 +3033,21 @@ 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), _), - dynClass), _), - style), _), + (L.ECApp ( + (L.EFfi ("Basis", "tag"), + _), (L.CRecord (_, attrsGiven), _)), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), + class), _), + dynClass), _), + style), _), + dynStyle), _), attrs), _), tag), _), xml) => @@ -3104,15 +3106,22 @@ fun monoExp (env, st, fm) (all as (e, loc)) = 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 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | _ => 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 diff --git a/src/urweb.grm b/src/urweb.grm index 4605becf..c6545f47 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -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 @@ fun tagIn bt = 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 @@ fun parseStyle s pos = | 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 : eterm (eterm) | 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 @@ tag : tagHead attrs (let | 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 @@ tagHead: BEGIN_TAG (let 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 @@ attrs : (NONE, NONE, NONE, []) (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 = diff --git a/tests/dynClass.ur b/tests/dynClass.ur index 2c7068c8..37f931a2 100644 --- a/tests/dynClass.ur +++ b/tests/dynClass.ur @@ -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> diff --git a/tests/dynClass.urp b/tests/dynClass.urp index 4358782b..0818a3b2 100644 --- a/tests/dynClass.urp +++ b/tests/dynClass.urp @@ -1,4 +1,4 @@ rewrite all DynClass/* -allow url http://localhost/* +allow url http://adam.chlipala.net/* dynClass |