summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorGravatar Adam Chlipala <adam@chlipala.net>2014-05-02 15:32:10 -0400
committerGravatar Adam Chlipala <adam@chlipala.net>2014-05-02 15:32:10 -0400
commit4e164132ec8a73a440c2299126fc11c2275d439b (patch)
treee35283c198e93ed20c6a38a6d01361630a6b0771 /src
parent0254362f5b743d4c5abc02d3e375387e5ef1394a (diff)
HTML5 data-* attributes
Diffstat (limited to 'src')
-rw-r--r--src/c/urweb.c10
-rw-r--r--src/mono_opt.sml10
-rw-r--r--src/monoize.sml32
-rw-r--r--src/settings.sml1
-rw-r--r--src/urweb.grm81
5 files changed, 107 insertions, 27 deletions
diff --git a/src/c/urweb.c b/src/c/urweb.c
index 9a1e40a7..26046461 100644
--- a/src/c/urweb.c
+++ b/src/c/urweb.c
@@ -4396,3 +4396,13 @@ uw_Basis_postField *uw_Basis_firstFormField(uw_context ctx, uw_Basis_string s) {
return f;
}
+
+uw_Basis_string uw_Basis_blessData(uw_context ctx, uw_Basis_string s) {
+ char *p = s;
+
+ for (; *p; ++p)
+ if (!isalnum(*p) && *p != '-' && *p != '_')
+ uw_error(ctx, FATAL, "Illegal HTML5 data-* attribute: %s", s);
+
+ return s;
+}
diff --git a/src/mono_opt.sml b/src/mono_opt.sml
index 228c53e6..ae306e68 100644
--- a/src/mono_opt.sml
+++ b/src/mono_opt.sml
@@ -118,6 +118,9 @@ fun unAs s =
end
fun checkUrl s = CharVector.all Char.isGraph s andalso Settings.checkUrl s
+val checkData = CharVector.all (fn ch => Char.isAlphaNum ch
+ orelse ch = #"_"
+ orelse ch = #"-")
val checkAtom = CharVector.all (fn ch => Char.isAlphaNum ch
orelse ch = #"+"
orelse ch = #"-"
@@ -442,6 +445,13 @@ fun exp e =
| ESignalBind ((ESignalReturn e1, loc), e2) =>
optExp (EApp (e2, e1), loc)
+ | EFfiApp ("Basis", "blessData", [((se as EPrim (Prim.String s), loc), _)]) =>
+ (if checkData s then
+ ()
+ else
+ ErrorMsg.errorAt loc ("Invalid HTML5 data-* attribute " ^ s);
+ se)
+
| EFfiApp ("Basis", "bless", [((se as EPrim (Prim.String s), loc), _)]) =>
(if checkUrl s then
()
diff --git a/src/monoize.sml b/src/monoize.sml
index 769a1e32..cdcd2bec 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -1,4 +1,4 @@
-(* Copyright (c) 2008-2013, Adam Chlipala
+(* Copyright (c) 2008-2014, Adam Chlipala
* All rights reserved.
*
* Redistribution and use in source and binary forms, with or without
@@ -235,6 +235,7 @@ fun monoType env =
| L.CFfi ("Basis", "requestHeader") => (L'.TFfi ("Basis", "string"), loc)
| L.CFfi ("Basis", "responseHeader") => (L'.TFfi ("Basis", "string"), loc)
| L.CFfi ("Basis", "envVar") => (L'.TFfi ("Basis", "string"), loc)
+ | L.CFfi ("Basis", "data_attr") => (L'.TFfi ("Basis", "string"), loc)
| L.CApp ((L.CFfi ("Basis", "serialized"), _), _) =>
(L'.TFfi ("Basis", "string"), loc)
@@ -3117,6 +3118,29 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
fm)
end
+ | L.EFfiApp ("Basis", "data_attr", [(s1, _), (s2, _)]) =>
+ let
+ val (s1, fm) = monoExp (env, st, fm) s1
+ val (s2, fm) = monoExp (env, st, fm) s2
+ in
+ ((L'.EStrcat ((L'.EPrim (Prim.String "data-"), loc),
+ (L'.EStrcat ((L'.EFfiApp ("Basis", "blessData", [(s1, (L'.TFfi ("Basis", "string"), loc))]), loc),
+ (L'.EStrcat ((L'.EPrim (Prim.String "=\""), loc),
+ (L'.EStrcat ((L'.EFfiApp ("Basis", "attrifyString", [(s2, (L'.TFfi ("Basis", "string"), loc))]), loc),
+ (L'.EPrim (Prim.String "\""), loc)), loc)),
+ loc)), loc)), loc),
+ fm)
+ end
+
+ | L.EFfiApp ("Basis", "data_attrs", [(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.EFfiApp ("Basis", "css_url", [(s, _)]) =>
let
val (s, fm) = monoExp (env, st, fm) s
@@ -3317,6 +3341,12 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
val (s, fm) = foldl (fn (("Action", _, _), acc) => acc
| (("Source", _, _), acc) => acc
+ | (("Data", e, _), (s, fm)) =>
+ ((L'.EStrcat (s,
+ (L'.EStrcat (
+ (L'.EPrim (Prim.String " "), loc),
+ e), loc)), loc),
+ fm)
| ((x, e, t), (s, fm)) =>
case t of
(L'.TFfi ("Basis", "bool"), _) =>
diff --git a/src/settings.sml b/src/settings.sml
index 6282577d..4cdb4119 100644
--- a/src/settings.sml
+++ b/src/settings.sml
@@ -309,6 +309,7 @@ val jsFuncsBase = basisM [("alert", "alert"),
("checkUrl", "checkUrl"),
("bless", "bless"),
+ ("blessData", "blessData"),
("eq_time", "eq"),
("lt_time", "lt"),
diff --git a/src/urweb.grm b/src/urweb.grm
index 84a337f8..bb195cda 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -225,7 +225,7 @@ fun tagIn bt =
datatype prop_kind = Delete | Update
-datatype attr = Class of exp | DynClass of exp | Style of exp | DynStyle of exp | Normal of con * exp
+datatype attr = Class of exp | DynClass of exp | Style of exp | DynStyle of exp | Normal of con * exp | Data of string * exp
fun patType loc (p : pat) =
case #1 p of
@@ -453,7 +453,7 @@ fun applyWindow loc e window =
| rpat of (string * pat) list * bool
| ptuple of pat list
- | attrs of exp option * exp option * exp option * exp option * (con * exp) list
+ | attrs of exp option * exp option * exp option * exp option * (string * exp) list * (con * exp) list
| attr of attr
| attrv of exp
@@ -1602,7 +1602,31 @@ 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 (#5 attrs), pos)), pos)
+
+ val atts = case #5 attrs of
+ [] => #6 attrs
+ | data :: datas =>
+ let
+ fun doOne (name, value) =
+ let
+ val e = (EVar (["Basis"], "data_attr", Infer), pos)
+ val e = (EApp (e, (EPrim (Prim.String name), pos)), pos)
+ in
+ (EApp (e, value), pos)
+ end
+
+ val datas' = foldl (fn (nv, acc) =>
+ let
+ val e = (EVar (["Basis"], "data_attrs", Infer), pos)
+ val e = (EApp (e, acc), pos)
+ in
+ (EApp (e, doOne nv), pos)
+ end) (doOne data) datas
+ in
+ ((CName "Data", pos), datas') :: #6 attrs
+ end
+
+ val e = (EApp (e, (ERecord atts, pos)), pos)
val e = (EApp (e, (EApp (#2 tagHead,
(ERecord [], pos)), pos)), pos)
in
@@ -1618,7 +1642,7 @@ tagHead: BEGIN_TAG (let
end)
| tagHead LBRACE cexp RBRACE (#1 tagHead, (ECApp (#2 tagHead, cexp), s (tagHeadleft, RBRACEright)))
-attrs : (NONE, NONE, NONE, NONE, [])
+attrs : (NONE, NONE, NONE, NONE, [], [])
| attr attrs (let
val loc = s (attrleft, attrsright)
in
@@ -1627,24 +1651,26 @@ attrs : (NONE, 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, #5 attrs))
+ (SOME e, #2 attrs, #3 attrs, #4 attrs, #5 attrs, #6 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, #5 attrs))
+ (#1 attrs, SOME e, #3 attrs, #4 attrs, #5 attrs, #6 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, #5 attrs))
+ (#1 attrs, #2 attrs, SOME e, #4 attrs, #5 attrs, #6 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))
+ (#1 attrs, #2 attrs, #3 attrs, SOME e, #5 attrs, #6 attrs))
+ | Data xe =>
+ (#1 attrs, #2 attrs, #3 attrs, #4 attrs, xe :: #5 attrs, #6 attrs)
| Normal xe =>
- (#1 attrs, #2 attrs, #3 attrs, #4 attrs, xe :: #5 attrs)
+ (#1 attrs, #2 attrs, #3 attrs, #4 attrs, #5 attrs, xe :: #6 attrs)
end)
attr : SYMBOL EQ attrv (case SYMBOL of
@@ -1653,23 +1679,26 @@ attr : SYMBOL EQ attrv (case SYMBOL of
| "style" => Style attrv
| "dynStyle" => DynStyle attrv
| _ =>
- let
- val sym = makeAttr SYMBOL
- in
- Normal ((CName sym, s (SYMBOLleft, SYMBOLright)),
- if (sym = "Href" orelse sym = "Src")
- andalso (case #1 attrv of
- EPrim _ => true
- | _ => false) then
- let
- val loc = s (attrvleft, attrvright)
- in
- (EApp ((EVar (["Basis"], "bless", Infer), loc),
- attrv), loc)
- end
- else
- attrv)
- end)
+ if String.isPrefix "data-" SYMBOL then
+ Data (String.extract (SYMBOL, 5, NONE), attrv)
+ else
+ let
+ val sym = makeAttr SYMBOL
+ in
+ Normal ((CName sym, s (SYMBOLleft, SYMBOLright)),
+ if (sym = "Href" orelse sym = "Src")
+ andalso (case #1 attrv of
+ EPrim _ => true
+ | _ => false) then
+ let
+ val loc = s (attrvleft, attrvright)
+ in
+ (EApp ((EVar (["Basis"], "bless", Infer), loc),
+ attrv), loc)
+ end
+ else
+ attrv)
+ end)
attrv : INT (EPrim (Prim.Int INT), s (INTleft, INTright))
| FLOAT (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright))
generated by cgit v1.2.3 (git 2.39.1) at 2024-07-02 04:49:34 +0000