summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--include/types.h1
-rw-r--r--include/urweb.h1
-rw-r--r--lib/ur/basis.urs7
-rw-r--r--src/c/urweb.c4
-rw-r--r--src/corify.sml2
-rw-r--r--src/elab_env.sml28
-rw-r--r--src/elaborate.sml17
-rw-r--r--src/especialize.sml52
-rw-r--r--src/mono_opt.sml7
-rw-r--r--src/monoize.sml24
-rw-r--r--src/reduce_local.sml8
-rw-r--r--src/tag.sml20
-rw-r--r--src/urweb.grm67
-rw-r--r--tests/style.ur2
14 files changed, 143 insertions, 97 deletions
diff --git a/include/types.h b/include/types.h
index ddbff76b..c80653d3 100644
--- a/include/types.h
+++ b/include/types.h
@@ -17,6 +17,7 @@ typedef struct uw_context *uw_context;
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 {
diff --git a/include/urweb.h b/include/urweb.h
index 2154a8ed..bbf7515a 100644
--- a/include/urweb.h
+++ b/include/urweb.h
@@ -74,6 +74,7 @@ char *uw_Basis_attrifyString(uw_context, uw_Basis_string);
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);
diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index 9eeb4891..50146dde 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -405,12 +405,10 @@ val nextval : sql_sequence -> transaction int
(** 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 @@ val tag : attrsGiven ::: {Type} -> attrsAbsent ::: {Type}
-> [attrsGiven ~ attrsAbsent] =>
[useOuter ~ useInner] =>
[bindOuter ~ bindInner] =>
- $attrsGiven
+ option css_class
+ -> $attrsGiven
-> tag (attrsGiven ++ attrsAbsent)
ctxOuter ctxInner useOuter bindOuter
-> xml ctxInner useInner bindInner
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))
diff --git a/tests/style.ur b/tests/style.ur
index 04b32a64..83f95594 100644
--- a/tests/style.ur
+++ b/tests/style.ur
@@ -2,5 +2,5 @@ style q
style r
fun main () : transaction page = return <xml><body>
- Hi.
+ Hi. <span class={q}>And hi again!</span>
</body></xml>
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-29 01:59:39 +0000