Mercurial > urweb
changeset 718:f152f215a02c
style declarations
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sun, 12 Apr 2009 10:08:11 -0400 |
| parents | e28637743279 |
| children | 5c099b1308ae |
| files | lib/ur/basis.urs src/cjr.sml src/cjr_env.sml src/cjr_print.sml src/cjrize.sml src/core.sml src/core_env.sml src/core_print.sml src/core_util.sml src/corify.sml src/elab.sml src/elab_env.sml src/elab_print.sml src/elab_util.sml src/elaborate.sml src/elisp/urweb-mode.el src/expl.sml src/expl_env.sml src/expl_print.sml src/explify.sml src/mono.sml src/mono_env.sml src/mono_print.sml src/mono_shake.sml src/mono_util.sml src/monoize.sml src/prepare.sml src/reduce.sml src/reduce_local.sml src/shake.sml src/source.sml src/source_print.sml src/unnest.sml src/urweb.grm src/urweb.lex tests/style.ur tests/style.urp |
| diffstat | 37 files changed, 177 insertions(+), 10 deletions(-) [+] |
line wrap: on
line diff
--- a/lib/ur/basis.urs Thu Apr 09 16:36:50 2009 -0400 +++ b/lib/ur/basis.urs Sun Apr 12 10:08:11 2009 -0400 @@ -405,6 +405,9 @@ (** XML *) +con css_class :: {Unit} -> Type +(* The argument lists categories of properties that this class could set usefully. *) + con tag :: {Type} -> {Unit} -> {Unit} -> {Type} -> {Type} -> Type @@ -440,6 +443,7 @@ con xtr = xml [Body, Tr] [] [] con xform = xml [Body, Form] [] [] + (*** HTML details *) con html = [Html]
--- a/src/cjr.sml Thu Apr 09 16:36:50 2009 -0400 +++ b/src/cjr.sml Sun Apr 12 10:08:11 2009 -0400 @@ -110,6 +110,7 @@ | DPreparedStatements of (string * int) list | DJavaScript of string + | DStyle of string * string list withtype decl = decl' located
--- a/src/cjr_env.sml Thu Apr 09 16:36:50 2009 -0400 +++ b/src/cjr_env.sml Sun Apr 12 10:08:11 2009 -0400 @@ -167,6 +167,6 @@ | DDatabase _ => env | DPreparedStatements _ => env | DJavaScript _ => env - + | DStyle _ => env end
--- a/src/cjr_print.sml Thu Apr 09 16:36:50 2009 -0400 +++ b/src/cjr_print.sml Sun Apr 12 10:08:11 2009 -0400 @@ -2146,6 +2146,17 @@ | DJavaScript s => box [string "static char jslib[] = \"", string (String.toString s), string "\";"] + | DStyle (s, xs) => box [string "/*", + space, + string "style", + space, + string s, + space, + string ":", + space, + p_list string xs, + space, + string "*/"] datatype 'a search = Found of 'a
--- a/src/cjrize.sml Thu Apr 09 16:36:50 2009 -0400 +++ b/src/cjrize.sml Sun Apr 12 10:08:11 2009 -0400 @@ -556,6 +556,7 @@ (SOME (L'.DSequence s, loc), NONE, sm) | L.DDatabase s => (SOME (L'.DDatabase s, loc), NONE, sm) | L.DJavaScript s => (SOME (L'.DJavaScript s, loc), NONE, sm) + | L.DStyle args => (SOME (L'.DStyle args, loc), NONE, sm) fun cjrize ds = let
--- a/src/core.sml Thu Apr 09 16:36:50 2009 -0400 +++ b/src/core.sml Sun Apr 12 10:08:11 2009 -0400 @@ -134,6 +134,7 @@ | DSequence of string * int * string | DDatabase of string | DCookie of string * int * con * string + | DStyle of string * int * con * string withtype decl = decl' located
--- a/src/core_env.sml Thu Apr 09 16:36:50 2009 -0400 +++ b/src/core_env.sml Sun Apr 12 10:08:11 2009 -0400 @@ -334,6 +334,12 @@ in pushENamed env x n t NONE s end + | DStyle (x, n, c, s) => + let + val t = (CApp ((CFfi ("Basis", "css_class"), loc), c), loc) + in + pushENamed env x n t NONE s + end fun patBinds env (p, loc) = case p of
--- a/src/core_print.sml Thu Apr 09 16:36:50 2009 -0400 +++ b/src/core_print.sml Sun Apr 12 10:08:11 2009 -0400 @@ -586,6 +586,17 @@ string ":", space, p_con env c] + | DStyle (x, n, c, s) => box [string "style", + space, + p_named x n, + space, + string "as", + space, + string s, + space, + string ":", + space, + p_con env c] fun p_file env file = let
--- a/src/core_util.sml Thu Apr 09 16:36:50 2009 -0400 +++ b/src/core_util.sml Sun Apr 12 10:08:11 2009 -0400 @@ -951,6 +951,10 @@ S.map2 (mfc ctx c, fn c' => (DCookie (x, n, c', s), loc)) + | DStyle (x, n, c, s) => + S.map2 (mfc ctx c, + fn c' => + (DStyle (x, n, c', s), loc)) and mfvi ctx (x, n, t, e, s) = S.bind2 (mfc ctx t, @@ -1088,6 +1092,12 @@ in bind (ctx, NamedE (x, n, t, NONE, s)) end + | DStyle (x, n, c, s) => + let + val t = (CApp ((CFfi ("Basis", "css_class"), #2 d'), c), #2 d') + in + bind (ctx, NamedE (x, n, t, NONE, s)) + end in S.map2 (mff ctx' ds', fn ds' => @@ -1148,7 +1158,8 @@ | DTable (_, n, _, _, _, _, _, _) => Int.max (n, count) | DSequence (_, n, _) => Int.max (n, count) | DDatabase _ => count - | DCookie (_, n, _, _) => Int.max (n, count)) 0 + | DCookie (_, n, _, _) => Int.max (n, count) + | DStyle (_, n, _, _) => Int.max (n, count)) 0 end
--- a/src/corify.sml Thu Apr 09 16:36:50 2009 -0400 +++ b/src/corify.sml Sun Apr 12 10:08:11 2009 -0400 @@ -1002,6 +1002,13 @@ in ([(L'.DCookie (x, n, corifyCon st c, s), loc)], st) end + | L.DStyle (_, x, n, c) => + let + val (st, n) = St.bindVal st x n + val s = doRestify (mods, x) + in + ([(L'.DStyle (x, n, corifyCon st c, s), loc)], st) + end and corifyStr mods ((str, _), st) = case str of @@ -1057,7 +1064,8 @@ | L.DTable (_, _, n', _, _, _, _, _) => Int.max (n, n') | L.DSequence (_, _, n') => Int.max (n, n') | L.DDatabase _ => n - | L.DCookie (_, _, n', _) => Int.max (n, n')) + | L.DCookie (_, _, n', _) => Int.max (n, n') + | L.DStyle (_, _, n', _) => Int.max (n, n')) 0 ds and maxNameStr (str, _) =
--- a/src/elab.sml Thu Apr 09 16:36:50 2009 -0400 +++ b/src/elab.sml Sun Apr 12 10:08:11 2009 -0400 @@ -171,6 +171,7 @@ | DClass of string * int * kind * con | DDatabase of string | DCookie of int * string * int * con + | DStyle of int * string * int * con and str' = StrConst of decl list
--- a/src/elab_env.sml Thu Apr 09 16:36:50 2009 -0400 +++ b/src/elab_env.sml Sun Apr 12 10:08:11 2009 -0400 @@ -1434,6 +1434,12 @@ in pushENamedAs env x n t end + | DStyle (tn, x, n, c) => + let + val t = (CApp ((CModProj (tn, [], "css_class"), loc), c), loc) + in + pushENamedAs env x n t + end fun patBinds env (p, loc) = case p of
--- a/src/elab_print.sml Thu Apr 09 16:36:50 2009 -0400 +++ b/src/elab_print.sml Sun Apr 12 10:08:11 2009 -0400 @@ -779,6 +779,13 @@ string ":", space, p_con env c] + | DStyle (_, x, n, c) => box [string "style", + space, + p_named x n, + space, + string ":", + space, + p_con env c] and p_str env (str, _) = case str of
--- a/src/elab_util.sml Thu Apr 09 16:36:50 2009 -0400 +++ b/src/elab_util.sml Sun Apr 12 10:08:11 2009 -0400 @@ -796,6 +796,9 @@ | DDatabase _ => ctx | DCookie (tn, x, n, c) => bind (ctx, NamedE (x, (CApp ((CModProj (n, [], "cookie"), loc), + c), loc))) + | DStyle (tn, x, n, c) => + bind (ctx, NamedE (x, (CApp ((CModProj (n, [], "css_class"), loc), c), loc))), mfd ctx d)) ctx ds, fn ds' => (StrConst ds', loc)) @@ -911,6 +914,10 @@ S.map2 (mfc ctx c, fn c' => (DCookie (tn, x, n, c'), loc)) + | DStyle (tn, x, n, c) => + S.map2 (mfc ctx c, + fn c' => + (DStyle (tn, x, n, c'), loc)) and mfvi ctx (x, n, c, e) = S.bind2 (mfc ctx c, @@ -1050,6 +1057,7 @@ | DSequence (n1, _, n2) => Int.max (n1, n2) | DDatabase _ => 0 | DCookie (n1, _, n2, _) => Int.max (n1, n2) + | DStyle (n1, _, n2, _) => Int.max (n1, n2) and maxNameStr (str, _) = case str of
--- a/src/elaborate.sml Thu Apr 09 16:36:50 2009 -0400 +++ b/src/elaborate.sml Sun Apr 12 10:08:11 2009 -0400 @@ -1902,6 +1902,7 @@ fun tableOf () = (L'.CModProj (!basis_r, [], "sql_table"), ErrorMsg.dummySpan) fun sequenceOf () = (L'.CModProj (!basis_r, [], "sql_sequence"), ErrorMsg.dummySpan) fun cookieOf () = (L'.CModProj (!basis_r, [], "http_cookie"), ErrorMsg.dummySpan) +fun styleOf () = (L'.CModProj (!basis_r, [], "css_class"), ErrorMsg.dummySpan) fun dopenConstraints (loc, env, denv) {str, strs} = case E.lookupStr env str of @@ -2401,6 +2402,7 @@ | L'.DClass (x, n, k, c) => [(L'.SgiClass (x, n, k, c), loc)] | L'.DDatabase _ => [] | L'.DCookie (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (cookieOf (), c), loc)), loc)] + | L'.DStyle (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (styleOf (), c), loc)), loc)] and subSgn env sgn1 (sgn2 as (_, loc2)) = ((*prefaces "subSgn" [("sgn1", p_sgn env sgn1), @@ -3390,6 +3392,14 @@ checkKind env c' k (L'.KType, loc); ([(L'.DCookie (!basis_r, x, n, c'), loc)], (env, denv, enD gs' @ gs)) end + | L.DStyle (x, c) => + let + val (c', k, gs') = elabCon (env, denv) c + val (env, n) = E.pushENamed env x (L'.CApp (styleOf (), c'), loc) + in + checkKind env c' k (L'.KRecord (L'.KUnit, loc), loc); + ([(L'.DStyle (!basis_r, x, n, c'), loc)], (env, denv, enD gs' @ gs)) + end (*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 (#2 r))*) in
--- a/src/elisp/urweb-mode.el Thu Apr 09 16:36:50 2009 -0400 +++ b/src/elisp/urweb-mode.el Sun Apr 12 10:08:11 2009 -0400 @@ -136,7 +136,7 @@ "datatype" "else" "end" "extern" "fn" "map" "fun" "functor" "if" "include" "of" "open" "let" "in" - "rec" "sequence" "sig" "signature" "cookie" + "rec" "sequence" "sig" "signature" "cookie" "style" "struct" "structure" "table" "then" "type" "val" "where" "with" @@ -225,7 +225,7 @@ ("\\<\\(\\(data\\)?type\\|con\\|class\\)\\s-+\\(\\sw+\\)" (1 font-lock-keyword-face) (3 (amAttribute font-lock-type-def-face))) - ("\\<\\(val\\|table\\|sequence\\|cookie\\)\\s-+\\(\\sw+\\>\\s-*\\)?\\(\\sw+\\)\\s-*[=:]" + ("\\<\\(val\\|table\\|sequence\\|cookie\\|style\\)\\s-+\\(\\sw+\\>\\s-*\\)?\\(\\sw+\\)\\s-*[=:]" (1 font-lock-keyword-face) (3 (amAttribute font-lock-variable-name-face))) ("\\<\\(structure\\|functor\\)\\s-+\\(\\sw+\\)"
--- a/src/expl.sml Thu Apr 09 16:36:50 2009 -0400 +++ b/src/expl.sml Sun Apr 12 10:08:11 2009 -0400 @@ -145,6 +145,7 @@ | DSequence of int * string * int | DDatabase of string | DCookie of int * string * int * con + | DStyle of int * string * int * con and str' = StrConst of decl list
--- a/src/expl_env.sml Thu Apr 09 16:36:50 2009 -0400 +++ b/src/expl_env.sml Sun Apr 12 10:08:11 2009 -0400 @@ -319,6 +319,12 @@ in pushENamed env x n t end + | DStyle (tn, x, n, c) => + let + val t = (CApp ((CModProj (tn, [], "css_class"), loc), c), loc) + in + pushENamed env x n t + end fun sgiBinds env (sgi, loc) = case sgi of
--- a/src/expl_print.sml Thu Apr 09 16:36:50 2009 -0400 +++ b/src/expl_print.sml Sun Apr 12 10:08:11 2009 -0400 @@ -691,6 +691,13 @@ string ":", space, p_con env c] + | DStyle (_, x, n, c) => box [string "style", + space, + p_named x n, + space, + string ":", + space, + p_con env c] and p_str env (str, _) = case str of
--- a/src/explify.sml Thu Apr 09 16:36:50 2009 -0400 +++ b/src/explify.sml Sun Apr 12 10:08:11 2009 -0400 @@ -187,6 +187,7 @@ (L'.KArrow (explifyKind k, (L'.KType, loc)), loc), explifyCon c), loc) | L.DDatabase s => SOME (L'.DDatabase s, loc) | L.DCookie (nt, x, n, c) => SOME (L'.DCookie (nt, x, n, explifyCon c), loc) + | L.DStyle (nt, x, n, c) => SOME (L'.DStyle (nt, x, n, explifyCon c), loc) and explifyStr (str, loc) = case str of
--- a/src/mono.sml Thu Apr 09 16:36:50 2009 -0400 +++ b/src/mono.sml Sun Apr 12 10:08:11 2009 -0400 @@ -127,6 +127,8 @@ | DJavaScript of string + | DStyle of string * string list + withtype decl = decl' located
--- a/src/mono_env.sml Thu Apr 09 16:36:50 2009 -0400 +++ b/src/mono_env.sml Sun Apr 12 10:08:11 2009 -0400 @@ -111,6 +111,7 @@ | DSequence _ => env | DDatabase _ => env | DJavaScript _ => env + | DStyle _ => env fun patBinds env (p, loc) = case p of
--- a/src/mono_print.sml Thu Apr 09 16:36:50 2009 -0400 +++ b/src/mono_print.sml Sun Apr 12 10:08:11 2009 -0400 @@ -440,6 +440,14 @@ string s, string ")"] + | DStyle (s, xs) => box [string "style", + space, + string s, + space, + string ":", + space, + p_list string xs] + fun p_file env file = let
--- a/src/mono_shake.sml Thu Apr 09 16:36:50 2009 -0400 +++ b/src/mono_shake.sml Sun Apr 12 10:08:11 2009 -0400 @@ -58,7 +58,8 @@ | ((DTable _, _), acc) => acc | ((DSequence _, _), acc) => acc | ((DDatabase _, _), acc) => acc - | ((DJavaScript _, _), acc) => acc) + | ((DJavaScript _, _), acc) => acc + | ((DStyle _, _), acc) => acc) (IM.empty, IM.empty) file fun typ (c, s) = @@ -115,7 +116,8 @@ | (DTable _, _) => true | (DSequence _, _) => true | (DDatabase _, _) => true - | (DJavaScript _, _) => true) file + | (DJavaScript _, _) => true + | (DStyle _, _) => true) file end end
--- a/src/mono_util.sml Thu Apr 09 16:36:50 2009 -0400 +++ b/src/mono_util.sml Sun Apr 12 10:08:11 2009 -0400 @@ -474,6 +474,7 @@ | DSequence _ => S.return2 dAll | DDatabase _ => S.return2 dAll | DJavaScript _ => S.return2 dAll + | DStyle _ => S.return2 dAll and mfvi ctx (x, n, t, e, s) = S.bind2 (mft t, @@ -555,6 +556,7 @@ | DSequence _ => ctx | DDatabase _ => ctx | DJavaScript _ => ctx + | DStyle _ => ctx in S.map2 (mff ctx' ds', fn ds' => @@ -603,7 +605,8 @@ | DTable _ => count | DSequence _ => count | DDatabase _ => count - | DJavaScript _ => count) 0 + | DJavaScript _ => count + | DStyle _ => count) 0 end
--- a/src/monoize.sml Thu Apr 09 16:36:50 2009 -0400 +++ b/src/monoize.sml Sun Apr 12 10:08:11 2009 -0400 @@ -2705,6 +2705,23 @@ fm, [(L'.DVal (x, n, t', e, s), loc)]) end + | L.DStyle (x, n, (L.CRecord (_, xcs), _), s) => + let + val xs = map (fn ((L.CName x, _), _) => x + | (x, _) => (E.errorAt (#2 x) "Undetermined style component"; + Print.eprefaces' [("Name", CorePrint.p_con env x)]; + "")) xcs + + val t = (L.CFfi ("Basis", "string"), loc) + val t' = (L'.TFfi ("Basis", "string"), loc) + val e = (L'.EPrim (Prim.String s), loc) + in + SOME (Env.pushENamed env x n t NONE s, + fm, + [(L'.DStyle (s, xs), loc), + (L'.DVal (x, n, t', e, s), loc)]) + end + | L.DStyle _ => poly () end datatype expungable = Client | Channel
--- a/src/prepare.sml Thu Apr 09 16:36:50 2009 -0400 +++ b/src/prepare.sml Sun Apr 12 10:08:11 2009 -0400 @@ -259,6 +259,7 @@ | DDatabase _ => (d, sns) | DPreparedStatements _ => (d, sns) | DJavaScript _ => (d, sns) + | DStyle _ => (d, sns) fun prepare (ds, ps) = let
--- a/src/reduce.sml Thu Apr 09 16:36:50 2009 -0400 +++ b/src/reduce.sml Sun Apr 12 10:08:11 2009 -0400 @@ -469,6 +469,7 @@ | DSequence _ => (d, st) | DDatabase _ => (d, st) | DCookie (s, n, c, s') => ((DCookie (s, n, con namedC [] c, s'), loc), st) + | DStyle (s, n, c, s') => ((DStyle (s, n, con namedC [] c, s'), loc), st) val (file, _) = ListUtil.foldlMap doDecl (IM.empty, IM.empty) file in
--- a/src/reduce_local.sml Thu Apr 09 16:36:50 2009 -0400 +++ b/src/reduce_local.sml Sun Apr 12 10:08:11 2009 -0400 @@ -152,6 +152,7 @@ | DSequence _ => d | DDatabase _ => d | DCookie _ => d + | DStyle _ => d in map doDecl file end
--- a/src/shake.sml Thu Apr 09 16:36:50 2009 -0400 +++ b/src/shake.sml Sun Apr 12 10:08:11 2009 -0400 @@ -86,6 +86,8 @@ (cdef, IM.insert (edef, n, ([], dummyt, dummye))) | ((DDatabase _, _), acc) => acc | ((DCookie (_, n, c, _), _), (cdef, edef)) => + (cdef, IM.insert (edef, n, ([], c, dummye))) + | ((DStyle (_, n, c, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, ([], c, dummye)))) (IM.empty, IM.empty) file @@ -160,7 +162,8 @@ | (DTable _, _) => true | (DSequence _, _) => true | (DDatabase _, _) => true - | (DCookie _, _) => true) file + | (DCookie _, _) => true + | (DStyle _, _) => true) file end end
--- a/src/source.sml Thu Apr 09 16:36:50 2009 -0400 +++ b/src/source.sml Sun Apr 12 10:08:11 2009 -0400 @@ -164,6 +164,7 @@ | DClass of string * kind * con | DDatabase of string | DCookie of string * con + | DStyle of string * con and str' = StrConst of decl list
--- a/src/source_print.sml Thu Apr 09 16:36:50 2009 -0400 +++ b/src/source_print.sml Sun Apr 12 10:08:11 2009 -0400 @@ -640,6 +640,13 @@ string ":", space, p_con c] + | DStyle (x, c) => box [string "style", + space, + string x, + space, + string ":", + space, + p_con c] and p_str (str, _) = case str of
--- a/src/unnest.sml Thu Apr 09 16:36:50 2009 -0400 +++ b/src/unnest.sml Sun Apr 12 10:08:11 2009 -0400 @@ -407,6 +407,7 @@ | DClass _ => default () | DDatabase _ => default () | DCookie _ => default () + | DStyle _ => default () end and doStr (all as (str, loc), st) =
--- a/src/urweb.grm Thu Apr 09 16:36:50 2009 -0400 +++ b/src/urweb.grm Sun Apr 12 10:08:11 2009 -0400 @@ -194,7 +194,7 @@ | LET | IN | STRUCTURE | SIGNATURE | STRUCT | SIG | END | FUNCTOR | WHERE | EXTERN | SQL | INCLUDE | OPEN | CONSTRAINT | CONSTRAINTS | EXPORT | TABLE | SEQUENCE - | COOKIE + | COOKIE | STYLE | CASE | IF | THEN | ELSE | XML_BEGIN of string | XML_END | XML_BEGIN_END of string @@ -451,6 +451,7 @@ [(DClass (SYMBOL1, kind, c), s (CLASSleft, cexpright))] end) | COOKIE SYMBOL COLON cexp ([(DCookie (SYMBOL, cexp), s (COOKIEleft, cexpright))]) + | STYLE SYMBOL COLON cexp ([(DStyle (SYMBOL, cexp), s (STYLEleft, cexpright))]) kopt : (NONE) | DCOLON kind (SOME kind) @@ -707,6 +708,13 @@ in (SgiVal (SYMBOL, t), loc) end) + | STYLE SYMBOL COLON cexp (let + val loc = s (STYLEleft, cexpright) + val t = (CApp ((CVar (["Basis"], "css_class"), loc), + cexp), loc) + in + (SgiVal (SYMBOL, t), loc) + end) sgis : ([]) | sgi sgis (sgi :: sgis)
--- a/src/urweb.lex Thu Apr 09 16:36:50 2009 -0400 +++ b/src/urweb.lex Sun Apr 12 10:08:11 2009 -0400 @@ -319,6 +319,7 @@ <INITIAL> "sequence" => (Tokens.SEQUENCE (pos yypos, pos yypos + size yytext)); <INITIAL> "class" => (Tokens.CLASS (pos yypos, pos yypos + size yytext)); <INITIAL> "cookie" => (Tokens.COOKIE (pos yypos, pos yypos + size yytext)); +<INITIAL> "style" => (Tokens.STYLE (pos yypos, pos yypos + size yytext)); <INITIAL> "Type" => (Tokens.TYPE (pos yypos, pos yypos + size yytext)); <INITIAL> "Name" => (Tokens.NAME (pos yypos, pos yypos + size yytext));