diff src/urweb.grm @ 1751:acadf9d1214a

'dynStyle' pseudo-attribute
author Adam Chlipala <adam@chlipala.net>
date Sun, 06 May 2012 15:15:46 -0400
parents 277480862cef
children f8ddaa296115
line wrap: on
line diff
--- a/src/urweb.grm	Sun May 06 14:01:29 2012 -0400
+++ b/src/urweb.grm	Sun May 06 15:15:46 2012 -0400
@@ -1,4 +1,4 @@
-(* Copyright (c) 2008-2011, Adam Chlipala
+(* Copyright (c) 2008-2012, Adam Chlipala
  * All rights reserved.
  *
  * Redistribution and use in source and binary forms, with or without
@@ -219,7 +219,7 @@
 
 datatype prop_kind = Delete | Update
 
-datatype attr = Class of exp | DynClass of exp | Style of exp | Normal of con * exp
+datatype attr = Class of exp | DynClass of exp | Style of exp | DynStyle of exp | Normal of con * exp
 
 fun patType loc (p : pat) =
     case #1 p of
@@ -427,7 +427,7 @@
  | rpat of (string * pat) list * bool
  | ptuple of pat list
 
- | attrs of exp option * exp option * exp option * (con * exp) list
+ | attrs of exp option * exp option * exp option * exp option * (con * exp) list
  | attr of attr
  | attrv of exp
 
@@ -1105,7 +1105,10 @@
        | eapps LBRACK cexp RBRACK       (ECApp (eapps, cexp), s (eappsleft, RBRACKright))
        | eapps BANG                     (EDisjointApp eapps, s (eappsleft, BANGright))
 
-eexp   : eapps                          (eapps)
+eexp   : eapps                          (case #1 eapps of
+                                             EApp ((EVar ([], "CLASS", _), _), (EPrim (Prim.String s), loc)) => parseClass s loc
+                                           | EApp ((EVar ([], "STYLE", _), _), (EPrim (Prim.String s), loc)) => parseStyle s loc
+                                           | _ => eapps)
        | FN eargs DARROW eexp           (let
                                              val loc = s (FNleft, eexpright)
                                          in
@@ -1585,7 +1588,12 @@
                                                         | SOME (EPrim (Prim.String s), pos) => parseStyle s pos
                                                         | SOME e => e
                                              val e = (EApp (e, eo), pos)
-                                             val e = (EApp (e, (ERecord (#4 attrs), pos)), pos)
+                                             val eo = case #4 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 (#5 attrs), pos)), pos)
                                              val e = (EApp (e, (EApp (#2 tagHead,
                                                                       (ERecord [], pos)), pos)), pos)
                                          in
@@ -1601,7 +1609,7 @@
                                          end)
        | tagHead LBRACE cexp RBRACE     (#1 tagHead, (ECApp (#2 tagHead, cexp), s (tagHeadleft, RBRACEright)))
                                           
-attrs  :                                (NONE, NONE, NONE, [])
+attrs  :                                (NONE, NONE, NONE, NONE, [])
        | attr attrs                     (let
                                              val loc = s (attrleft, attrsright)
                                          in
@@ -1610,25 +1618,31 @@
                                                  (case #1 attrs of
                                                       NONE => ()
                                                     | SOME _ => ErrorMsg.errorAt loc "Multiple classes specified for tag";
-                                                  (SOME e, #2 attrs, #3 attrs, #4 attrs))
+                                                  (SOME e, #2 attrs, #3 attrs, #4 attrs, #5 attrs))
                                                | DynClass e =>
                                                  (case #2 attrs of
                                                       NONE => ()
                                                     | SOME _ => ErrorMsg.errorAt loc "Multiple dynamic classes specified for tag";
-                                                  (#1 attrs, SOME e, #3 attrs, #4 attrs))
+                                                  (#1 attrs, SOME e, #3 attrs, #4 attrs, #5 attrs))
                                                | Style e =>
                                                  (case #3 attrs of
                                                       NONE => ()
                                                     | SOME _ => ErrorMsg.errorAt loc "Multiple styles specified for tag";
-                                                  (#1 attrs, #2 attrs, SOME e, #4 attrs))
+                                                  (#1 attrs, #2 attrs, SOME e, #4 attrs, #5 attrs))
+                                               | DynStyle e =>
+                                                 (case #4 attrs of
+                                                      NONE => ()
+                                                    | SOME _ => ErrorMsg.errorAt loc "Multiple dynamic classes specified for tag";
+                                                  (#1 attrs, #2 attrs, #3 attrs, SOME e, #5 attrs))
                                                | Normal xe =>
-                                                 (#1 attrs, #2 attrs, #3 attrs, xe :: #4 attrs)
+                                                 (#1 attrs, #2 attrs, #3 attrs, #4 attrs, xe :: #5 attrs)
                                          end)
 
 attr   : SYMBOL EQ attrv                (case SYMBOL of
 					     "class" => Class attrv
 					   | "dynClass" => DynClass attrv
                                            | "style" => Style attrv
+					   | "dynStyle" => DynStyle attrv
 					   | _ =>
                                              let
                                                  val sym =