summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adam@chlipala.net>2012-05-06 14:01:29 -0400
committerGravatar Adam Chlipala <adam@chlipala.net>2012-05-06 14:01:29 -0400
commit9e25c1ce13add31807463c913129c24643944e38 (patch)
treeccabcef63f0d66632cc4c8c486c6d3663eef3ced
parent4387731e477e2af050841f916a03f5d8a975a164 (diff)
'style' attributes
-rw-r--r--doc/manual.tex5
-rw-r--r--lib/ur/basis.urs13
-rw-r--r--src/mono_opt.sml38
-rw-r--r--src/monoize.sml67
-rw-r--r--src/urweb.grm66
-rw-r--r--tests/css.ur6
-rw-r--r--tests/css.urp2
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!