Mercurial > urweb
changeset 1840:146ec8e90063
Add some name-mangling rules to allow XML attribute 'name' and attributes with dashes
| author | Adam Chlipala <adam@chlipala.net> |
|---|---|
| date | Thu, 27 Dec 2012 15:34:11 -0500 |
| parents | d8c260bcc1f9 |
| children | 184d00f7be74 |
| files | lib/ur/list.ur lib/ur/list.urs src/monoize.sml src/urweb.grm src/urweb.lex tests/attrMangle.ur tests/attrMangle.urp tests/goofy.urs |
| diffstat | 8 files changed, 39 insertions(+), 5 deletions(-) [+] |
line wrap: on
line diff
--- a/lib/ur/list.ur Thu Dec 13 17:51:34 2012 -0500 +++ b/lib/ur/list.ur Thu Dec 27 15:34:11 2012 -0500 @@ -437,3 +437,15 @@ 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
--- a/lib/ur/list.urs Thu Dec 13 17:51:34 2012 -0500 +++ b/lib/ur/list.urs Thu Dec 27 15:34:11 2012 -0500 @@ -63,6 +63,9 @@ 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
--- a/src/monoize.sml Thu Dec 13 17:51:34 2012 -0500 +++ b/src/monoize.sml Thu Dec 27 15:34:11 2012 -0500 @@ -3364,8 +3364,13 @@ 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)
--- a/src/urweb.grm Thu Dec 13 17:51:34 2012 -0500 +++ b/src/urweb.grm Thu Dec 27 15:34:11 2012 -0500 @@ -35,6 +35,12 @@ 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 @@ | "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")
--- a/src/urweb.lex Thu Dec 13 17:51:34 2012 -0500 +++ b/src/urweb.lex Thu Dec 27 15:34:11 2012 -0500 @@ -177,6 +177,7 @@ %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 @@ <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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/attrMangle.ur Thu Dec 27 15:34:11 2012 -0500 @@ -0,0 +1,5 @@ +open Goofy + +fun main () : transaction page = return <xml><body> + <goofy name="beppo" data-role="excellence"/> +</body></xml>