summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--lib/ur/list.ur12
-rw-r--r--lib/ur/list.urs3
-rw-r--r--src/monoize.sml5
-rw-r--r--src/urweb.grm11
-rw-r--r--src/urweb.lex3
-rw-r--r--tests/attrMangle.ur5
-rw-r--r--tests/attrMangle.urp4
-rw-r--r--tests/goofy.urs1
8 files changed, 39 insertions, 5 deletions
diff --git a/lib/ur/list.ur b/lib/ur/list.ur
index bce5335e..cbb4faf2 100644
--- a/lib/ur/list.ur
+++ b/lib/ur/list.ur
@@ -437,3 +437,15 @@ fun mapXiM [m ::: Type -> Type] (_ : monad m) [a] [ctx ::: {Unit}] (f : int -> a
in
mapXiM' 0
end
+
+fun tabulateM [m] (_ : monad m) [a] (f : int -> m a) n =
+ let
+ fun tabulate' n acc =
+ if n <= 0 then
+ return acc
+ else
+ (v <- f (n-1);
+ tabulate' (n-1) (v :: acc))
+ in
+ tabulate' n []
+ end
diff --git a/lib/ur/list.urs b/lib/ur/list.urs
index b26c9ad9..66007a39 100644
--- a/lib/ur/list.urs
+++ b/lib/ur/list.urs
@@ -63,6 +63,9 @@ val all : a ::: Type -> (a -> bool) -> t a -> bool
val app : m ::: (Type -> Type) -> monad m -> a ::: Type
-> (a -> m unit) -> t a -> m unit
+val tabulateM : m ::: (Type -> Type) -> monad m -> a ::: Type
+ -> (int -> m a) -> int -> m (t a)
+
val mapQuery : tables ::: {{Type}} -> exps ::: {Type} -> t ::: Type
-> [tables ~ exps] =>
sql_query [] [] tables exps
diff --git a/src/monoize.sml b/src/monoize.sml
index 39e4853b..d324b235 100644
--- a/src/monoize.sml
+++ b/src/monoize.sml
@@ -3364,8 +3364,13 @@ fun monoExp (env, st, fm) (all as (e, loc)) =
val x =
case x of
"Typ" => "Type"
+ | "Nam" => "Name"
| "Link" => "Href"
| _ => x
+
+ val x = String.translate (fn #"_" => "-"
+ | ch => String.str ch) x
+
val xp = " " ^ lowercaseFirst x ^ "=\""
val (e, fm) = fooify env fm (e, t)
diff --git a/src/urweb.grm b/src/urweb.grm
index a45c7ffa..c2a48742 100644
--- a/src/urweb.grm
+++ b/src/urweb.grm
@@ -35,6 +35,12 @@ val dummy = ErrorMsg.dummySpan
fun capitalize "" = ""
| capitalize s = str (Char.toUpper (String.sub (s, 0))) ^ String.extract (s, 1, NONE)
+fun makeAttr s =
+ case s of
+ "type" => "Typ"
+ | "name" => "Nam"
+ | _ => capitalize (String.translate (fn ch => if ch = #"-" then "_" else str ch) s)
+
fun entable t =
case #1 t of
TRecord c => c
@@ -1648,10 +1654,7 @@ attr : SYMBOL EQ attrv (case SYMBOL of
| "dynStyle" => DynStyle attrv
| _ =>
let
- val sym =
- case SYMBOL of
- "type" => "Typ"
- | x => capitalize x
+ val sym = makeAttr SYMBOL
in
Normal ((CName sym, s (SYMBOLleft, SYMBOLright)),
if (sym = "Href" orelse sym = "Src")
diff --git a/src/urweb.lex b/src/urweb.lex
index 0994ecec..293c6dc6 100644
--- a/src/urweb.lex
+++ b/src/urweb.lex
@@ -177,6 +177,7 @@ fun unescape loc s =
%s COMMENT STRING CHAR XML XMLTAG;
id = [a-z_][A-Za-z0-9_']*;
+xmlid = [A-Za-z][A-Za-z0-9-_]*;
cid = [A-Z][A-Za-z0-9_]*;
ws = [\ \t\012\r];
intconst = [0-9]+;
@@ -313,7 +314,7 @@ xint = x[0-9a-fA-F][0-9a-fA-F];
<XMLTAG> {ws}+ => (lex ());
-<XMLTAG> {id} => (Tokens.SYMBOL (yytext, yypos, yypos + size yytext));
+<XMLTAG> {xmlid} => (Tokens.SYMBOL (yytext, yypos, yypos + size yytext));
<XMLTAG> "=" => (Tokens.EQ (yypos, yypos + size yytext));
<XMLTAG> {intconst} => (case Int64.fromString yytext of
diff --git a/tests/attrMangle.ur b/tests/attrMangle.ur
new file mode 100644
index 00000000..6efb0513
--- /dev/null
+++ b/tests/attrMangle.ur
@@ -0,0 +1,5 @@
+open Goofy
+
+fun main () : transaction page = return <xml><body>
+ <goofy name="beppo" data-role="excellence"/>
+</body></xml>
diff --git a/tests/attrMangle.urp b/tests/attrMangle.urp
new file mode 100644
index 00000000..5059998b
--- /dev/null
+++ b/tests/attrMangle.urp
@@ -0,0 +1,4 @@
+ffi goofy
+rewrite all AttrMangle/*
+
+attrMangle
diff --git a/tests/goofy.urs b/tests/goofy.urs
new file mode 100644
index 00000000..71b55f42
--- /dev/null
+++ b/tests/goofy.urs
@@ -0,0 +1 @@
+val goofy : bodyTag [Nam = string, Data_role = string]