diff options
author | 2012-05-06 14:01:29 -0400 | |
---|---|---|
committer | 2012-05-06 14:01:29 -0400 | |
commit | d6d65ece7537f856f01fdc978a2560107cacc375 (patch) | |
tree | ccabcef63f0d66632cc4c8c486c6d3663eef3ced /src | |
parent | b9cd9e281652a8b74887a5f86328712b3170d890 (diff) |
'style' attributes
Diffstat (limited to 'src')
-rw-r--r-- | src/mono_opt.sml | 38 | ||||
-rw-r--r-- | src/monoize.sml | 67 | ||||
-rw-r--r-- | src/urweb.grm | 66 |
3 files changed, 158 insertions, 13 deletions
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 = |