From 2f324fc9e868e0775e1401833b74af15652c6732 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 12 Apr 2009 14:19:15 -0400 Subject: Classes as optional arguments to Basis.tag --- src/c/urweb.c | 4 ++++ src/corify.sml | 2 +- src/elab_env.sml | 28 +++++++++++----------- src/elaborate.sml | 17 +++++++------ src/especialize.sml | 52 +++++++++++++--------------------------- src/mono_opt.sml | 7 ++++++ src/monoize.sml | 24 ++++++++++++++++--- src/reduce_local.sml | 8 +++++++ src/tag.sml | 20 +++++++++------- src/urweb.grm | 67 ++++++++++++++++++++++++++++++++++------------------ 10 files changed, 137 insertions(+), 92 deletions(-) (limited to 'src') diff --git a/src/c/urweb.c b/src/c/urweb.c index 89358a06..d3a93af9 100644 --- a/src/c/urweb.c +++ b/src/c/urweb.c @@ -922,6 +922,10 @@ char *uw_Basis_attrifyString(uw_context ctx, uw_Basis_string s) { 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; diff --git a/src/corify.sml b/src/corify.sml index c8da9df5..c1cd940e 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -1005,7 +1005,7 @@ fun corifyDecl mods (all as (d, loc : EM.span), st) = | 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 diff --git a/src/elab_env.sml b/src/elab_env.sml index 6dae1d4b..62a310f2 100644 --- a/src/elab_env.sml +++ b/src/elab_env.sml @@ -899,19 +899,19 @@ fun sgnS_con (str, (sgns, strs, cons)) c = 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 @@ fun enrichClasses env classes (m1, ms) sgn = | 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 diff --git a/src/elaborate.sml b/src/elaborate.sml index 72b7b8fc..ea4c28bd 100644 --- a/src/elaborate.sml +++ b/src/elaborate.sml @@ -1493,26 +1493,28 @@ fun unmodCon env (c, loc) = 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 @@ fun normClassConstraint env (c, loc) = 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 @@ fun elabSgn_item ((sgi, loc), (env, denv, gs)) = 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 diff --git a/src/especialize.sml b/src/especialize.sml index 6486842b..d1d018ee 100644 --- a/src/especialize.sml +++ b/src/especialize.sml @@ -114,35 +114,6 @@ fun default (_, x, st) = (x, st) 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 specialize' file = 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 @@ fun specialize' file = | _ => 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 @@ fun specialize' file = 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 @@ fun specialize' file = 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 = 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 @@ fun specialize file = (*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 diff --git a/src/mono_opt.sml b/src/mono_opt.sml index 205ae3fb..670774a2 100644 --- a/src/mono_opt.sml +++ b/src/mono_opt.sml @@ -242,6 +242,13 @@ fun exp e = | 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) => diff --git a/src/monoize.sml b/src/monoize.sml index f14b6021..51fae113 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -131,6 +131,7 @@ fun monoType env = (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 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | L.EApp ( (L.EApp ( (L.EApp ( - (L.ECApp ( + (L.EApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( @@ -2043,8 +2044,10 @@ fun monoExp (env, st, fm) (all as (e, loc)) = (L.ECApp ( (L.ECApp ( (L.ECApp ( - (L.EFfi ("Basis", "tag"), - _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), + (L.ECApp ( + (L.EFfi ("Basis", "tag"), + _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), + class), _), attrs), _), tag), _), xml) => @@ -2096,9 +2099,24 @@ fun monoExp (env, st, fm) (all as (e, loc)) = | 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 diff --git a/src/reduce_local.sml b/src/reduce_local.sml index cf602406..265cb2a4 100644 --- a/src/reduce_local.sml +++ b/src/reduce_local.sml @@ -72,6 +72,11 @@ fun exp env (all as (e, loc)) = | 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 @@ fun exp env (all as (e, loc)) = | 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) diff --git a/src/tag.sml b/src/tag.sml index 715da9ed..7a8fe128 100644 --- a/src/tag.sml +++ b/src/tag.sml @@ -46,7 +46,7 @@ fun exp env (e, s) = EApp ( (EApp ( (EApp ( - (ECApp ( + (EApp ( (ECApp ( (ECApp ( (ECApp ( @@ -54,9 +54,11 @@ fun exp env (e, s) = (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 @@ fun exp env (e, s) = (EApp ( (EApp ( (EApp ( - (ECApp ( + (EApp ( (ECApp ( (ECApp ( (ECApp ( @@ -132,9 +134,11 @@ fun exp env (e, s) = (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) diff --git a/src/urweb.grm b/src/urweb.grm index 0251d3f4..d47aaf47 100644 --- a/src/urweb.grm +++ b/src/urweb.grm @@ -176,6 +176,8 @@ fun tagIn bt = datatype prop_kind = Delete | Update +datatype attr = Class of exp | Normal of con * exp + %% %header (functor UrwebLrValsFn(structure Token : TOKEN)) @@ -296,8 +298,8 @@ datatype prop_kind = Delete | Update | 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 @@ xmlOne : NOTAGS (EApp ((EVar (["Basis"], "cdata", Infer) 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 @@ tagHead: BEGIN_TAG (let end) | tagHead LBRACE cexp RBRACE (#1 tagHead, (ECApp (#2 tagHead, cexp), s (tagHeadleft, RBRACEright))) -attrs : ([]) - | attr attrs (attr :: attrs) - -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 +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 (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)) -- cgit v1.2.3