diff options
| -rw-r--r-- | doc/manual.tex | 5 | ||||
| -rw-r--r-- | lib/ur/basis.urs | 13 | ||||
| -rw-r--r-- | src/mono_opt.sml | 38 | ||||
| -rw-r--r-- | src/monoize.sml | 67 | ||||
| -rw-r--r-- | src/urweb.grm | 66 | ||||
| -rw-r--r-- | tests/css.ur | 6 | ||||
| -rw-r--r-- | tests/css.urp | 2 |
7 files changed, 182 insertions, 15 deletions
diff --git a/doc/manual.tex b/doc/manual.tex index 532e0ea9..0fdf9d2e 100644 --- a/doc/manual.tex +++ b/doc/manual.tex @@ -1956,14 +1956,17 @@ $$\begin{array}{l} \hspace{.1in} \to [\mt{attrsGiven} \sim \mt{attrsAbsent}] \Rightarrow [\mt{useOuter} \sim \mt{useInner}] \Rightarrow [\mt{bindOuter} \sim \mt{bindInner}] \\ \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{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, or left without a class by passing $\mt{Basis.null}$ as the first value-level argument. 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. +Note that any tag may be assigned a CSS class, or left without a class by passing $\mt{Basis.null}$ as the first value-level argument. This is the sole way of making use of the values produced by $\mt{style}$ declarations. The function $\mt{Basis.classes}$ can be used to specify a list of CSS classes for a single tag. Stylesheets to assign properties to the classes can be linked via URL's with \texttt{link} tags. Ur/Web makes it easy to calculate upper bounds on usage of CSS classes through program analysis, with the \cd{-css} command-line flag. 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. + 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}\} \\ diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs index ef2b9156..1c9de4b9 100644 --- a/lib/ur/basis.urs +++ b/lib/ur/basis.urs @@ -636,6 +636,17 @@ val classes : css_class -> css_class -> css_class (* The equivalent of writing one class after the other, separated by a space, in * an HTML 'class' attribute *) +type css_value +val atom : string -> css_value +type url +val css_url : url -> css_value +type css_property +val property : string -> css_property +val value : css_property -> css_value -> css_property +type css_style +val noStyle : css_style +val oneProperty : css_style -> css_property -> css_style + con tag :: {Type} -> {Unit} -> {Unit} -> {Type} -> {Type} -> Type con xml :: {Unit} -> {Type} -> {Type} -> Type @@ -650,6 +661,7 @@ val tag : attrsGiven ::: {Type} -> attrsAbsent ::: {Type} [bindOuter ~ bindInner] => css_class -> option (signal css_class) + -> css_style -> $attrsGiven -> tag (attrsGiven ++ attrsAbsent) ctxOuter ctxInner useOuter bindOuter @@ -695,7 +707,6 @@ con xform = xml form [] [] type queryString val show_queryString : show queryString -type url val show_url : show url val bless : string -> url val checkUrl : string -> option url diff --git a/src/mono_opt.sml b/src/mono_opt.sml index 199c807b..af9e9a9c 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -118,6 +118,26 @@ fun unAs s = end fun checkUrl s = CharVector.all Char.isGraph s andalso Settings.checkUrl s +val checkAtom = CharVector.all (fn ch => Char.isAlphaNum ch + orelse ch = #"+" + orelse ch = #"-" + orelse ch = #"." + orelse ch = #"%" + orelse ch = #"#") +val checkCssUrl = CharVector.all (fn ch => Char.isAlphaNum ch + orelse ch = #":" + orelse ch = #"/" + orelse ch = #"." + orelse ch = #"_" + orelse ch = #"-" + orelse ch = #"%" + orelse ch = #"?" + orelse ch = #"&" + orelse ch = #"=" + orelse ch = #"#") +fun checkProperty s = size s > 0 + andalso (Char.isLower (String.sub (s, 0)) orelse String.sub (s, 0) = #"_") + andalso CharVector.all (fn ch => Char.isLower ch orelse Char.isDigit ch orelse ch = #"_" orelse ch = #"-") s fun exp e = case e of @@ -440,6 +460,24 @@ fun exp e = ESome ((TFfi ("Basis", "string"), loc), (se, loc)) else ENone (TFfi ("Basis", "string"), loc)) + | EFfiApp ("Basis", "atom", [((se as EPrim (Prim.String s), loc), _)]) => + (if checkAtom s then + () + else + ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'atom'"); + se) + | EFfiApp ("Basis", "css_url", [((se as EPrim (Prim.String s), loc), _)]) => + (if checkCssUrl s then + () + else + ErrorMsg.errorAt loc ("Invalid URL " ^ s ^ " passed to 'css_url'"); + se) + | EFfiApp ("Basis", "property", [((se as EPrim (Prim.String s), loc), _)]) => + (if checkProperty s then + () + else + ErrorMsg.errorAt loc ("Invalid string " ^ s ^ " passed to 'property'"); + se) | EFfiApp ("Basis", "blessRequestHeader", [((se as EPrim (Prim.String s), loc), _)]) => (if Settings.checkRequestHeader s then () diff --git a/src/monoize.sml b/src/monoize.sml index 1b7018de..fe2d67bd 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -221,6 +221,9 @@ fun monoType env = | L.CApp ((L.CApp ((L.CFfi ("Basis", "xhtml"), _), _), _), _) => (L'.TFfi ("Basis", "string"), loc) | L.CFfi ("Basis", "css_class") => (L'.TFfi ("Basis", "string"), loc) + | L.CFfi ("Basis", "css_value") => (L'.TFfi ("Basis", "string"), loc) + | L.CFfi ("Basis", "css_property") => (L'.TFfi ("Basis", "string"), loc) + | L.CFfi ("Basis", "css_style") => (L'.TFfi ("Basis", "string"), loc) | L.CFfi ("Basis", "id") => (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CFfi ("Basis", "serialized"), _), _) => @@ -2951,6 +2954,43 @@ fun monoExp (env, st, fm) (all as (e, loc)) = fm) end + | L.EFfiApp ("Basis", "css_url", [(s, _)]) => + let + val (s, fm) = monoExp (env, st, fm) s + in + ((L'.EStrcat ((L'.EPrim (Prim.String "url("), loc), + (L'.EStrcat ((L'.EFfiApp ("Basis", "css_url", [(s, (L'.TFfi ("Basis", "string"), loc))]), loc), + (L'.EPrim (Prim.String ")"), loc)), loc)), loc), + fm) + end + + | L.EFfiApp ("Basis", "property", [(s, _)]) => + let + val (s, fm) = monoExp (env, st, fm) s + in + ((L'.EStrcat ((L'.EFfiApp ("Basis", "property", [(s, (L'.TFfi ("Basis", "string"), loc))]), loc), + (L'.EPrim (Prim.String ":"), loc)), loc), + fm) + end + | L.EFfiApp ("Basis", "value", [(s1, _), (s2, _)]) => + let + val (s1, fm) = monoExp (env, st, fm) s1 + val (s2, fm) = monoExp (env, st, fm) s2 + in + ((L'.EStrcat (s1, (L'.EStrcat ((L'.EPrim (Prim.String " "), loc), s2), loc)), loc), + fm) + end + + | L.EFfi ("Basis", "noStyle") => ((L'.EPrim (Prim.String ""), loc), fm) + | L.EFfiApp ("Basis", "oneProperty", [(s1, _), (s2, _)]) => + let + val (s1, fm) = monoExp (env, st, fm) s1 + val (s2, fm) = monoExp (env, st, fm) s2 + in + ((L'.EStrcat (s1, (L'.EStrcat (s2, (L'.EPrim (Prim.String ";"), loc)), loc)), loc), + fm) + end + | L.EApp ( (L.ECApp ( (L.ECApp ((L.EFfi ("Basis", "cdata"), _), _), _), @@ -2992,18 +3032,20 @@ 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), _), + (L.ECApp ( + (L.EFfi ("Basis", "tag"), + _), (L.CRecord (_, attrsGiven), _)), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), + class), _), + dynClass), _), + style), _), attrs), _), tag), _), xml) => @@ -3061,6 +3103,7 @@ 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 dynamics = ["dyn", "ctextbox", "ccheckbox", "cselect", "coption", "ctextarea"] @@ -3088,6 +3131,18 @@ fun monoExp (env, st, fm) (all as (e, loc)) = {disc = t, result = t}), loc) + val s = (L'.ECase (style, + [((L'.PPrim (Prim.String ""), loc), + s), + ((L'.PVar ("x", t), loc), + (L'.EStrcat (s, + (L'.EStrcat ((L'.EPrim (Prim.String " style=\""), loc), + (L'.EStrcat ((L'.ERel 0, loc), + (L'.EPrim (Prim.String "\""), loc)), + loc)), loc)), loc))], + {disc = t, + result = t}), loc) + val (s, fm) = foldl (fn (("Action", _, _), acc) => acc | (("Source", _, _), acc) => acc | ((x, e, t), (s, fm)) => diff --git a/src/urweb.grm b/src/urweb.grm index 6d175c48..4605becf 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -219,7 +219,7 @@ fun tagIn bt = datatype prop_kind = Delete | Update -datatype attr = Class of exp | DynClass of exp | Normal of con * exp +datatype attr = Class of exp | DynClass of exp | Style of exp | Normal of con * exp fun patType loc (p : pat) = case #1 p of @@ -255,6 +255,47 @@ fun parseClass s pos = foldl (fn (s, e) => (EApp ((EApp ((EVar (["Basis"], "classes", Infer), pos), e), pos), classOut (s, pos)), pos)) (classOut (class, pos)) classes +fun parseValue s pos = + if String.isPrefix "url(" s andalso String.isSuffix ")" s then + let + val s = String.substring (s, 4, size s - 5) + + val s = if size s >= 2 + andalso ((String.isPrefix "\"" s andalso String.isSuffix "\"" s) + orelse (String.isPrefix "'" s andalso String.isSuffix "'" s)) then + String.substring (s, 1, size s - 2) + else + s + in + (EApp ((EVar (["Basis"], "css_url", Infer), pos), + (EApp ((EVar (["Basis"], "bless", Infer), pos), + (EPrim (Prim.String s), pos)), pos)), pos) + end + else + (EApp ((EVar (["Basis"], "atom", Infer), pos), + (EPrim (Prim.String s), pos)), pos) + +fun parseProperty s pos = + let + val (befor, after) = Substring.splitl (fn ch => ch <> #":") (Substring.full s) + in + if Substring.isEmpty after then + (ErrorMsg.errorAt pos ("Invalid CSS property syntax: " ^ s); + (EPrim (Prim.String ""), pos)) + else + foldl (fn (value, e) => (EApp ((EApp ((EVar (["Basis"], "value", Infer), pos), e), pos), parseValue value pos), pos)) + (EApp ((EVar (["Basis"], "property", Infer), pos), + (EPrim (Prim.String (Substring.string (#2 (Substring.splitl Char.isSpace befor)))), pos)), pos) + (String.tokens Char.isSpace (Substring.string (Substring.slice (after, 1, NONE)))) + end + +fun parseStyle s pos = + case String.tokens (fn ch => ch = #";") s of + [] => (EVar (["Basis"], "noStyle", Infer), pos) + | props => + foldl (fn (s, e) => (EApp ((EApp ((EVar (["Basis"], "oneProperty", Infer), pos), e), pos), parseProperty s pos), pos)) + (EVar (["Basis"], "noStyle", Infer), pos) props + %% %header (functor UrwebLrValsFn(structure Token : TOKEN)) @@ -386,7 +427,7 @@ fun parseClass s pos = | rpat of (string * pat) list * bool | ptuple of pat list - | attrs of exp option * exp option * (con * exp) list + | attrs of exp option * exp option * exp option * (con * exp) list | attr of attr | attrv of exp @@ -1539,7 +1580,12 @@ 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 (#3 attrs), pos)), pos) + val eo = case #3 attrs of + NONE => (EVar (["Basis"], "noStyle", Infer), pos) + | 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 e = (EApp (e, (EApp (#2 tagHead, (ERecord [], pos)), pos)), pos) in @@ -1555,7 +1601,7 @@ tagHead: BEGIN_TAG (let end) | tagHead LBRACE cexp RBRACE (#1 tagHead, (ECApp (#2 tagHead, cexp), s (tagHeadleft, RBRACEright))) -attrs : (NONE, NONE, []) +attrs : (NONE, NONE, NONE, []) | attr attrs (let val loc = s (attrleft, attrsright) in @@ -1564,19 +1610,25 @@ attrs : (NONE, NONE, []) (case #1 attrs of NONE => () | SOME _ => ErrorMsg.errorAt loc "Multiple classes specified for tag"; - (SOME e, #2 attrs, #3 attrs)) + (SOME e, #2 attrs, #3 attrs, #4 attrs)) | DynClass e => (case #2 attrs of NONE => () | SOME _ => ErrorMsg.errorAt loc "Multiple dynamic classes specified for tag"; - (#1 attrs, SOME e, #3 attrs)) + (#1 attrs, SOME e, #3 attrs, #4 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)) | Normal xe => - (#1 attrs, #2 attrs, xe :: #3 attrs) + (#1 attrs, #2 attrs, #3 attrs, xe :: #4 attrs) end) attr : SYMBOL EQ attrv (case SYMBOL of "class" => Class attrv | "dynClass" => DynClass attrv + | "style" => Style attrv | _ => let val sym = diff --git a/tests/css.ur b/tests/css.ur index 04d3a701..6806c84d 100644 --- a/tests/css.ur +++ b/tests/css.ur @@ -7,4 +7,10 @@ fun main () = return <xml><body> <span class="st-3 st2">Bye!</span> <span class="st1">Appendix!</span> <span class="">Sequel!</span> + + <span style="width: 30%">A</span> + <span class="st-3" style="color: blue red">B</span> + <span style="background: url(http://www.google.com/image.png)">C</span> + <span style="background: url('http://www.google.com/image.png') red 10% 66px">D</span> + <span style="color: red; width: 90 green; background: url(http://www.google.com/foo.jpg);">C</span> </body></xml> diff --git a/tests/css.urp b/tests/css.urp index 08a48817..38d47f29 100644 --- a/tests/css.urp +++ b/tests/css.urp @@ -1,3 +1,5 @@ +allow url http://www.google.com/* + # Comment here css # Comment at end of line! # Comments everywhere! |