Classes as optional arguments to Basis.tag

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>