Mercurial > urweb
changeset 721:9864b64b1700
Classes as optional arguments to Basis.tag
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sun, 12 Apr 2009 14:19:15 -0400 |
| parents | acb8537f58f0 |
| children | f06880c8bf68 |
| files | include/types.h include/urweb.h lib/ur/basis.urs src/c/urweb.c src/corify.sml src/elab_env.sml src/elaborate.sml src/especialize.sml src/mono_opt.sml src/monoize.sml src/reduce_local.sml src/tag.sml src/urweb.grm tests/style.ur |
| diffstat | 14 files changed, 142 insertions(+), 96 deletions(-) [+] |
line wrap: on
line diff
--- a/include/types.h Sun Apr 12 12:31:54 2009 -0400 +++ b/include/types.h Sun Apr 12 14:19:15 2009 -0400 @@ -17,6 +17,7 @@ typedef uw_Basis_string uw_Basis_xhtml; typedef uw_Basis_string uw_Basis_page; +typedef uw_Basis_string uw_Basis_css_class; typedef unsigned uw_Basis_client; typedef struct {
--- a/include/urweb.h Sun Apr 12 12:31:54 2009 -0400 +++ b/include/urweb.h Sun Apr 12 14:19:15 2009 -0400 @@ -74,6 +74,7 @@ char *uw_Basis_attrifyTime(uw_context, uw_Basis_time); char *uw_Basis_attrifyChannel(uw_context, uw_Basis_channel); char *uw_Basis_attrifyClient(uw_context, uw_Basis_client); +char *uw_Basis_attrifyCss_class(uw_context, uw_Basis_css_class); uw_unit uw_Basis_attrifyInt_w(uw_context, uw_Basis_int); uw_unit uw_Basis_attrifyFloat_w(uw_context, uw_Basis_float);
--- a/lib/ur/basis.urs Sun Apr 12 12:31:54 2009 -0400 +++ b/lib/ur/basis.urs Sun Apr 12 14:19:15 2009 -0400 @@ -405,12 +405,10 @@ (** XML *) -con css_class :: {Unit} -> Type -(* The argument lists categories of properties that this class could set usefully. *) +type css_class con tag :: {Type} -> {Unit} -> {Unit} -> {Type} -> {Type} -> Type - con xml :: {Unit} -> {Type} -> {Type} -> Type val cdata : ctx ::: {Unit} -> use ::: {Type} -> string -> xml ctx use [] val tag : attrsGiven ::: {Type} -> attrsAbsent ::: {Type} @@ -420,7 +418,8 @@ -> [attrsGiven ~ attrsAbsent] => [useOuter ~ useInner] => [bindOuter ~ bindInner] => - $attrsGiven + option css_class + -> $attrsGiven -> tag (attrsGiven ++ attrsAbsent) ctxOuter ctxInner useOuter bindOuter -> xml ctxInner useInner bindInner
--- a/src/c/urweb.c Sun Apr 12 12:31:54 2009 -0400 +++ b/src/c/urweb.c Sun Apr 12 14:19:15 2009 -0400 @@ -922,6 +922,10 @@ return result; } +char *uw_Basis_attrifyCss_class(uw_context ctx, uw_Basis_css_class s) { + return s; +} + static void uw_Basis_attrifyInt_w_unsafe(uw_context ctx, uw_Basis_int n) { int len;
--- a/src/corify.sml Sun Apr 12 12:31:54 2009 -0400 +++ b/src/corify.sml Sun Apr 12 14:19:15 2009 -0400 @@ -1005,7 +1005,7 @@ | L.DStyle (_, x, n) => let val (st, n) = St.bindVal st x n - val s = doRestify (mods, x) + val s = relify (doRestify (mods, x)) in ([(L'.DStyle (x, n, s), loc)], st) end
--- a/src/elab_env.sml Sun Apr 12 12:31:54 2009 -0400 +++ b/src/elab_env.sml Sun Apr 12 14:19:15 2009 -0400 @@ -899,19 +899,19 @@ end) | _ => c -fun sgnS_con' (arg as (m1, ms', (sgns, strs, cons))) c = - case c of - CModProj (m1, ms, x) => - (case IM.find (strs, m1) of - NONE => c - | SOME m1x => CModProj (m1, ms' @ m1x :: ms, x)) - | CNamed n => - (case IM.find (cons, n) of - NONE => c - | SOME nx => CModProj (m1, ms', nx)) - | CApp (c1, c2) => CApp ((sgnS_con' arg (#1 c1), #2 c1), - (sgnS_con' arg (#1 c2), #2 c2)) - | _ => c +fun sgnS_con' (m1, ms', (sgns, strs, cons)) = + U.Con.map {kind = fn x => x, + con = fn c => + case c of + CModProj (m1, ms, x) => + (case IM.find (strs, m1) of + NONE => c + | SOME m1x => CModProj (m1, ms' @ m1x :: ms, x)) + | CNamed n => + (case IM.find (cons, n) of + NONE => c + | SOME nx => CModProj (m1, ms', nx)) + | _ => c} fun sgnS_sgn (str, (sgns, strs, cons)) sgn = case sgn of @@ -1026,7 +1026,7 @@ | SOME (cn, nvs, cs, c) => let val loc = #2 c - fun globalize (c, loc) = (sgnS_con' (m1, ms, fmap) c, loc) + val globalize = sgnS_con' (m1, ms, fmap) val nc = case cn of
--- a/src/elaborate.sml Sun Apr 12 12:31:54 2009 -0400 +++ b/src/elaborate.sml Sun Apr 12 14:19:15 2009 -0400 @@ -1493,26 +1493,28 @@ end | _ => (c, loc) -fun normClassKey envs c = +fun normClassKey env c = let - val c = hnormCon envs c + val c = hnormCon env c in case #1 c of L'.CApp (c1, c2) => let - val c1 = normClassKey envs c1 - val c2 = normClassKey envs c2 + val c1 = normClassKey env c1 + val c2 = normClassKey env c2 in (L'.CApp (c1, c2), #2 c) end - | _ => c + | L'.CRecord (k, xcs) => (L'.CRecord (k, map (fn (x, c) => (normClassKey env x, + normClassKey env c)) xcs), #2 c) + | _ => unmodCon env c end fun normClassConstraint env (c, loc) = case c of L'.CApp (f, x) => let - val f = unmodCon env f + val f = normClassKey env f val x = normClassKey env x in (L'.CApp (f, x), loc) @@ -1526,7 +1528,7 @@ end | L'.TCFun (expl, x, k, c1) => (L'.TCFun (expl, x, k, normClassConstraint env c1), loc) | L'.CUnif (_, _, _, ref (SOME c)) => normClassConstraint env c - | _ => (c, loc) + | _ => unmodCon env (c, loc) fun elabExp (env, denv) (eAll as (e, loc)) = let @@ -2047,6 +2049,7 @@ let val (c', ck, gs') = elabCon (env, denv) c + val old = c' val c' = normClassConstraint env c' val (env', n) = E.pushENamed env x c' in
--- a/src/especialize.sml Sun Apr 12 12:31:54 2009 -0400 +++ b/src/especialize.sml Sun Apr 12 14:19:15 2009 -0400 @@ -114,35 +114,6 @@ fun specialize' file = let - fun default' (_, fs) = fs - - fun actionableExp (e, fs) = - case e of - ERecord xes => - foldl (fn (((CName s, _), e, _), fs) => - if s = "Action" orelse s = "Link" then - let - fun findHead (e, _) = - case e of - ENamed n => IS.add (fs, n) - | EApp (e, _) => findHead e - | _ => fs - in - findHead e - end - else - fs - | (_, fs) => fs) - fs xes - | _ => fs - - val actionable = - U.File.fold {kind = default', - con = default', - exp = actionableExp, - decl = default'} - IS.empty file - fun bind (env, b) = case b of U.Decl.RelE xt => xt :: env @@ -150,6 +121,9 @@ fun exp (env, e, st : state) = let + (*val () = Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty + (e, ErrorMsg.dummySpan))]*) + fun getApp e = case e of ENamed f => SOME (f, []) @@ -160,12 +134,17 @@ | _ => NONE in case getApp e of - NONE => (e, st) + NONE => ((*Print.prefaces "No" [("e", CorePrint.p_exp CoreEnv.empty + (e, ErrorMsg.dummySpan))];*) + (e, st)) | SOME (f, xs) => case IM.find (#funcs st, f) of NONE => (e, st) | SOME {name, args, body, typ, tag} => let + (*val () = Print.prefaces "Consider" [("e", CorePrint.p_exp CoreEnv.empty + (e, ErrorMsg.dummySpan))]*) + val functionInside = U.Con.exists {kind = fn _ => false, con = fn TFun _ => true | CFfi ("Basis", "transaction") => true @@ -208,7 +187,7 @@ e xs in (*Print.prefaces "Brand new (reuse)" - [("e'", CorePrint.p_exp env e)];*) + [("e'", CorePrint.p_exp CoreEnv.empty e)];*) (#1 e, st) end | NONE => @@ -267,9 +246,9 @@ val e' = foldl (fn (arg, e) => (EApp (e, arg), loc)) e' xs (*val () = Print.prefaces "Brand new" - [("e'", CorePrint.p_exp env e'), - ("e", CorePrint.p_exp env (e, loc)), - ("body'", CorePrint.p_exp env body')]*) + [("e'", CorePrint.p_exp CoreEnv.empty e'), + ("e", CorePrint.p_exp CoreEnv.empty (e, loc)), + ("body'", CorePrint.p_exp CoreEnv.empty body')]*) in (#1 e', {maxName = #maxName st, @@ -358,7 +337,8 @@ fun specialize file = let - (*val () = Print.prefaces "Intermediate" [("file", CorePrint.p_file CoreEnv.empty file)];*) + val file = ReduceLocal.reduce file + (*val () = Print.prefaces "Intermediate" [("file", CorePrint.p_file CoreEnv.empty file)]*) (*val file = ReduceLocal.reduce file*) val (changed, file) = specialize' file (*val file = ReduceLocal.reduce file @@ -368,7 +348,7 @@ (*print "Round over\n";*) if changed then let - val file = ReduceLocal.reduce file + (*val file = ReduceLocal.reduce file*) val file = CoreUntangle.untangle file val file = Shake.shake file in
--- a/src/mono_opt.sml Sun Apr 12 12:31:54 2009 -0400 +++ b/src/mono_opt.sml Sun Apr 12 14:19:15 2009 -0400 @@ -242,6 +242,13 @@ | EWrite (EFfiApp ("Basis", "attrifyString", [e]), _) => EFfiApp ("Basis", "attrifyString_w", [e]) + | EFfiApp ("Basis", "attrifyCss_class", [(EPrim (Prim.String s), _)]) => + EPrim (Prim.String s) + | EWrite (EFfiApp ("Basis", "attrifyCss_class", [(EPrim (Prim.String s), _)]), loc) => + EWrite (EPrim (Prim.String s), loc) + | EWrite (EFfiApp ("Basis", "attrifyCss_class", [e]), _) => + EFfiApp ("Basis", "attrifyString_w", [e]) + | EFfiApp ("Basis", "urlifyInt", [(EPrim (Prim.Int n), _)]) => EPrim (Prim.String (urlifyInt n)) | EWrite (EFfiApp ("Basis", "urlifyInt", [(EPrim (Prim.Int n), _)]), loc) =>
--- a/src/monoize.sml Sun Apr 12 12:31:54 2009 -0400 +++ b/src/monoize.sml Sun Apr 12 14:19:15 2009 -0400 @@ -131,6 +131,7 @@ (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CApp ((L.CFfi ("Basis", "xhtml"), _), _), _), _) => (L'.TFfi ("Basis", "string"), loc) + | L.CFfi ("Basis", "css_class") => (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CFfi ("Basis", "transaction"), _), t) => (L'.TFun ((L'.TRecord [], loc), mt env dtmap t), loc) @@ -2035,7 +2036,7 @@ | L.EApp ( (L.EApp ( (L.EApp ( - (L.ECApp ( + (L.EApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( @@ -2043,8 +2044,10 @@ (L.ECApp ( (L.ECApp ( (L.ECApp ( - (L.EFfi ("Basis", "tag"), - _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), + (L.ECApp ( + (L.EFfi ("Basis", "tag"), + _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), + class), _), attrs), _), tag), _), xml) => @@ -2096,9 +2099,24 @@ | lowercaseFirst s = String.str (Char.toLower (String.sub (s, 0))) ^ String.extract (s, 1, NONE) + val (class, fm) = monoExp (env, st, fm) class + fun tagStart tag = let + val t = (L'.TFfi ("Basis", "string"), loc) val s = (L'.EPrim (Prim.String (String.concat ["<", tag])), loc) + + val s = (L'.ECase (class, + [((L'.PNone t, loc), + s), + ((L'.PSome (t, (L'.PVar ("x", t), loc)), loc), + (L'.EStrcat (s, + (L'.EStrcat ((L'.EPrim (Prim.String " class=\""), loc), + (L'.EStrcat ((L'.ERel 0, loc), + (L'.EPrim (Prim.String "\""), loc)), + loc)), loc)), loc))], + {disc = (L'.TOption t, loc), + result = t}), loc) in foldl (fn (("Action", _, _), acc) => acc | (("Source", _, _), acc) => acc
--- a/src/reduce_local.sml Sun Apr 12 12:31:54 2009 -0400 +++ b/src/reduce_local.sml Sun Apr 12 14:19:15 2009 -0400 @@ -72,6 +72,11 @@ | EFfi _ => all | EFfiApp (m, f, es) => (EFfiApp (m, f, map (exp env) es), loc) + | EApp ((ECApp ((ECAbs (_, _, (EAbs (_, (CRel 0, _), _, + (ECon (dk, pc, [(CRel 0, loc)], SOME (ERel 0, _)), _)), _)), _), + t), _), e) => + (ECon (dk, pc, [t], SOME (exp env e)), loc) + | EApp (e1, e2) => let val e1 = exp env e1 @@ -84,6 +89,9 @@ | EAbs (x, dom, ran, e) => (EAbs (x, dom, ran, exp (Unknown :: env) e), loc) + | ECApp ((ECAbs (_, _, (ECon (dk, pc, [(CRel 0, loc)], NONE), _)), _), t) => + (ECon (dk, pc, [t], NONE), loc) + | ECApp (e, c) => (ECApp (exp env e, c), loc) | ECAbs (x, k, e) => (ECAbs (x, k, exp env e), loc)
--- a/src/tag.sml Sun Apr 12 12:31:54 2009 -0400 +++ b/src/tag.sml Sun Apr 12 14:19:15 2009 -0400 @@ -46,7 +46,7 @@ EApp ( (EApp ( (EApp ( - (ECApp ( + (EApp ( (ECApp ( (ECApp ( (ECApp ( @@ -54,9 +54,11 @@ (ECApp ( (ECApp ( (ECApp ( - (EFfi ("Basis", "tag"), - loc), given), _), absent), _), outer), _), inner), _), - useOuter), _), useInner), _), bindOuter), _), bindInner), _), + (ECApp ( + (EFfi ("Basis", "tag"), + loc), given), _), absent), _), outer), _), inner), _), + useOuter), _), useInner), _), bindOuter), _), bindInner), _), + class), _), attrs), _), tag), _), xml) => @@ -124,7 +126,7 @@ (EApp ( (EApp ( (EApp ( - (ECApp ( + (EApp ( (ECApp ( (ECApp ( (ECApp ( @@ -132,9 +134,11 @@ (ECApp ( (ECApp ( (ECApp ( - (EFfi ("Basis", "tag"), - loc), given), loc), absent), loc), outer), loc), inner), loc), - useOuter), loc), useInner), loc), bindOuter), loc), bindInner), loc), + (ECApp ( + (EFfi ("Basis", "tag"), + loc), given), loc), absent), loc), outer), loc), inner), loc), + useOuter), loc), useInner), loc), bindOuter), loc), bindInner), loc), + class), loc), (ERecord xets, loc)), loc), tag), loc), xml), s)
--- a/src/urweb.grm Sun Apr 12 12:31:54 2009 -0400 +++ b/src/urweb.grm Sun Apr 12 14:19:15 2009 -0400 @@ -176,6 +176,8 @@ datatype prop_kind = Delete | Update +datatype attr = Class of exp | Normal of con * exp + %% %header (functor UrwebLrValsFn(structure Token : TOKEN)) @@ -296,8 +298,8 @@ | rpat of (string * pat) list * bool | ptuple of pat list - | attrs of (con * exp) list - | attr of con * exp + | attrs of exp option * (con * exp) list + | attr of attr | attrv of exp | query of exp @@ -1266,13 +1268,18 @@ tag : tagHead attrs (let val pos = s (tagHeadleft, attrsright) + + val e = (EVar (["Basis"], "tag", Infer), pos) + val eo = case #1 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 (#2 attrs), pos)), pos) + val e = (EApp (e, (EApp (#2 tagHead, + (ERecord [], pos)), pos)), pos) in - (#1 tagHead, - (EApp ((EApp ((EVar (["Basis"], "tag", Infer), pos), - (ERecord attrs, pos)), pos), - (EApp (#2 tagHead, - (ERecord [], pos)), pos)), - pos)) + (#1 tagHead, e) end) tagHead: BEGIN_TAG (let @@ -1284,22 +1291,36 @@ end) | tagHead LBRACE cexp RBRACE (#1 tagHead, (ECApp (#2 tagHead, cexp), s (tagHeadleft, RBRACEright))) -attrs : ([]) - | attr attrs (attr :: attrs) +attrs : (NONE, []) + | attr attrs (let + val loc = s (attrleft, attrsright) + in + case attr of + Class e => + (case #1 attrs of + NONE => () + | SOME _ => ErrorMsg.errorAt loc "Multiple classes specified for tag"; + (SOME e, #2 attrs)) + | Normal xe => + (#1 attrs, xe :: #2 attrs) + end) -attr : SYMBOL EQ attrv ((CName (capitalize SYMBOL), s (SYMBOLleft, SYMBOLright)), - if (SYMBOL = "href" orelse SYMBOL = "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 +attr : SYMBOL EQ attrv (if SYMBOL = "class" then + Class attrv else - attrv) + Normal ((CName (capitalize SYMBOL), s (SYMBOLleft, SYMBOLright)), + if (SYMBOL = "href" orelse SYMBOL = "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)) attrv : INT (EPrim (Prim.Int INT), s (INTleft, INTright)) | FLOAT (EPrim (Prim.Float FLOAT), s (FLOATleft, FLOATright))