diff options
author | Adam Chlipala <adam@chlipala.net> | 2012-05-06 15:15:46 -0400 |
---|---|---|
committer | Adam Chlipala <adam@chlipala.net> | 2012-05-06 15:15:46 -0400 |
commit | 7bb3cb12e6a013204e794db821069d8b9e0ecc58 (patch) | |
tree | 0b91d6fdd507e47f191183d49a4d5207ae515be7 /src | |
parent | d6d65ece7537f856f01fdc978a2560107cacc375 (diff) |
'dynStyle' pseudo-attribute
Diffstat (limited to 'src')
-rw-r--r-- | src/monoize.sml | 72 | ||||
-rw-r--r-- | src/urweb.grm | 34 |
2 files changed, 76 insertions, 30 deletions
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 = |