hello compiles with CSS

3 files changed, 104 insertions, 82 deletions

diff --git a/lib/ur/basis.urs b/lib/ur/basis.urs
index 9eeb4891..7a55d8e4 100644
--- a/lib/ur/basis.urs
+++ b/lib/ur/basis.urs
@@ -408,40 +408,64 @@ val nextval : sql_sequence -> transaction int
 con css_class :: {Unit} -> Type
 (* The argument lists categories of properties that this class could set usefully. *)
 
-con tag :: {Type} -> {Unit} -> {Unit} -> {Type} -> {Type} -> Type
-
-
-con xml :: {Unit} -> {Type} -> {Type} -> Type
-val cdata : ctx ::: {Unit} -> use ::: {Type} -> string -> xml ctx use []
+con tag :: {Type} -> {Unit} -> {Unit} -> {Type} -> {Type} -> {Unit} -> Type
+(* Arguments:
+ * 1. Attributes
+ * 2. Context for this tag
+ * 3. Context for inner XML
+ * 4. Form fields used
+ * 5. Form fields defined
+ * 6. CSS property categories that the tag might use
+ *)
+
+con xml :: {Unit} -> {Type} -> {Type} -> {Unit} -> Type
+(* Arguments:
+ * 1. Context
+ * 2. Form fields used
+ * 3. Form fields defined
+ * 4. CSS property categories that this XML fragment might use
+ *)
+
+con css_subset :: {Unit} -> {Unit} -> Type
+val css_subset : cs1 ::: {Unit} -> cs2 ::: {Unit} -> [cs1 ~ cs2]
+    => css_subset cs1 (cs1 ++ cs2)
+
+val cdata : ctx ::: {Unit} -> use ::: {Type} -> css ::: {Unit} -> string -> xml ctx use [] css
 val tag : attrsGiven ::: {Type} -> attrsAbsent ::: {Type}
           -> ctxOuter ::: {Unit} -> ctxInner ::: {Unit}
           -> useOuter ::: {Type} -> useInner ::: {Type}
           -> bindOuter ::: {Type} -> bindInner ::: {Type}
+          -> css ::: {Unit} -> cssOuter ::: {Unit} -> cssInner ::: {Unit}
           -> [attrsGiven ~ attrsAbsent] =>
              [useOuter ~ useInner] =>
              [bindOuter ~ bindInner] =>
            $attrsGiven
            -> tag (attrsGiven ++ attrsAbsent)
-                  ctxOuter ctxInner useOuter bindOuter
-           -> xml ctxInner useInner bindInner
-           -> xml ctxOuter (useOuter ++ useInner) (bindOuter ++ bindInner)
+                  ctxOuter ctxInner useOuter bindOuter cssOuter
+           -> css_subset cssOuter css
+           -> css_subset cssInner css
+           -> xml ctxInner useInner bindInner cssInner
+           -> xml ctxOuter (useOuter ++ useInner) (bindOuter ++ bindInner) css
 val join : ctx ::: {Unit} 
-        -> use1 ::: {Type} -> bind1 ::: {Type} -> bind2 ::: {Type}
-        -> [use1 ~ bind1] => [bind1 ~ bind2] =>
-              xml ctx use1 bind1
-              -> xml ctx (use1 ++ bind1) bind2
-              -> xml ctx use1 (bind1 ++ bind2)
+           -> use1 ::: {Type} -> bind1 ::: {Type} -> bind2 ::: {Type}
+           -> css ::: {Unit} -> css1 ::: {Unit} -> css2 ::: {Unit}
+           -> [use1 ~ bind1] => [bind1 ~ bind2]
+    => xml ctx use1 bind1 css1
+       -> xml ctx (use1 ++ bind1) bind2 css2
+       -> css_subset css1 css
+       -> css_subset css2 css
+       -> xml ctx use1 (bind1 ++ bind2) css
 val useMore : ctx ::: {Unit} -> use1 ::: {Type} -> use2 ::: {Type}
-              -> bind ::: {Type}
+              -> bind ::: {Type} -> css ::: {Unit}
               -> [use1 ~ use2] =>
-                    xml ctx use1 bind
-                    -> xml ctx (use1 ++ use2) bind
+                    xml ctx use1 bind css
+                    -> xml ctx (use1 ++ use2) bind css
 
 con xhtml = xml [Html]
 con page = xhtml [] []
-con xbody = xml [Body] [] []
-con xtr = xml [Body, Tr] [] []
-con xform = xml [Body, Form] [] []
+con xbody = xml [Body] [] [] []
+con xtr = xml [Body, Tr] [] [] []
+con xform = xml [Body, Form] [] [] []
 
 
 (*** HTML details *)
@@ -453,21 +477,21 @@ con form = [Body, Form]
 con tabl = [Body, Table]
 con tr = [Body, Tr]
 
-val dyn : use ::: {Type} -> bind ::: {Type} -> unit
-          -> tag [Signal = signal (xml body use bind)] body [] use bind
+val dyn : use ::: {Type} -> bind ::: {Type} -> unit -> css ::: {Unit}
+          -> tag [Signal = signal (xml body use bind css)] body [] use bind css
 
-val head : unit -> tag [] html head [] []
-val title : unit -> tag [] head [] [] []
+val head : unit -> tag [] html head [] [] []
+val title : unit -> tag [] head [] [] [] []
 
-val body : unit -> tag [Onload = transaction unit] html body [] []
+val body : unit -> tag [Onload = transaction unit] html body [] [] []
 con bodyTag = fn (attrs :: {Type}) =>
                  ctx ::: {Unit} ->
                  [[Body] ~ ctx] =>
-                    unit -> tag attrs ([Body] ++ ctx) ([Body] ++ ctx) [] []
+                    unit -> tag attrs ([Body] ++ ctx) ([Body] ++ ctx) [] [] []
 con bodyTagStandalone = fn (attrs :: {Type}) =>
                            ctx ::: {Unit}
                            -> [[Body] ~ ctx] =>
-                                 unit -> tag attrs ([Body] ++ ctx) [] [] []
+                                 unit -> tag attrs ([Body] ++ ctx) [] [] [] []
 
 val br : bodyTagStandalone []
 
@@ -492,19 +516,19 @@ val hr : bodyTag []
 
 type url
 val bless : string -> url
-val a : bodyTag [Link = transaction page, Href = url, Onclick = transaction unit]
+val a : css ::: {Unit} -> bodyTag [Link = transaction (page css), Href = url, Onclick = transaction unit]
 
 val img : bodyTag [Src = url]
 
-val form : ctx ::: {Unit} -> bind ::: {Type}
+val form : ctx ::: {Unit} -> bind ::: {Type} -> css ::: {Unit}
             -> [[Body] ~ ctx] =>
-                  xml form [] bind
-                  -> xml ([Body] ++ ctx) [] []
+                  xml form [] bind css
+                  -> xml ([Body] ++ ctx) [] [] css
 con formTag = fn (ty :: Type) (inner :: {Unit}) (attrs :: {Type}) =>
                   ctx ::: {Unit}
                   -> [[Form] ~ ctx] =>
                         nm :: Name -> unit
-                        -> tag attrs ([Form] ++ ctx) inner [] [nm = ty]
+                        -> tag attrs ([Form] ++ ctx) inner [] [nm = ty] []
 val textbox : formTag string [] [Value = string, Size = int, Source = source string]
 val password : formTag string [] [Value = string, Size = int]
 val textarea : formTag string [] [Rows = int, Cols = int]
@@ -513,42 +537,40 @@ val checkbox : formTag bool [] [Checked = bool]
 
 con radio = [Body, Radio]
 val radio : formTag string radio []
-val radioOption : unit -> tag [Value = string] radio [] [] []
+val radioOption : unit -> tag [Value = string] radio [] [] [] []
 
 con select = [Select]
 val select : formTag string select []
-val option : unit -> tag [Value = string, Selected = bool] select [] [] []
+val option : unit -> tag [Value = string, Selected = bool] select [] [] [] []
 
-val submit : ctx ::: {Unit} -> use ::: {Type}
+val submit : ctx ::: {Unit} -> use ::: {Type} -> css ::: {Unit}
              -> [[Form] ~ ctx] =>
                    unit
-                   -> tag [Value = string, Action = $use -> transaction page]
-                          ([Form] ++ ctx) ([Form] ++ ctx) use []
+                   -> tag [Value = string, Action = $use -> transaction (page css)]
+                          ([Form] ++ ctx) ([Form] ++ ctx) use [] []
 
+(*** Tables *)
+
+val tabl : other ::: {Unit} -> [other ~ [Body, Table]] =>
+                                  unit -> tag [Border = int] ([Body] ++ other) ([Body, Table] ++ other) [] [] [Table]
+val tr : other ::: {Unit} -> [other ~ [Body, Table, Tr]] =>
+                                unit -> tag [] ([Body, Table] ++ other) ([Body, Tr] ++ other) [] [] []
+val th : other ::: {Unit} -> [other ~ [Body, Tr]] =>
+                                unit -> tag [] ([Body, Tr] ++ other) ([Body] ++ other) [] [] [Cell]
+val td : other ::: {Unit} -> [other ~ [Body, Tr]] =>
+                                unit -> tag [] ([Body, Tr] ++ other) ([Body] ++ other) [] [] [Cell]
+                                        
 (*** AJAX-oriented widgets *)
 
 con cformTag = fn (attrs :: {Type}) =>
                   ctx ::: {Unit}
                   -> [[Body] ~ ctx] =>
-                        unit -> tag attrs ([Body] ++ ctx) [] [] []
+                        unit -> tag attrs ([Body] ++ ctx) [] [] [] []
 
 val ctextbox : cformTag [Value = string, Size = int, Source = source string]
 val button : cformTag [Value = string, Onclick = transaction unit]
 
-(*** Tables *)
-
-val tabl : other ::: {Unit} -> [other ~ [Body, Table]] =>
-                                  unit -> tag [Border = int] ([Body] ++ other) ([Body, Table] ++ other) [] []
-val tr : other ::: {Unit} -> [other ~ [Body, Table, Tr]] =>
-                                unit -> tag [] ([Body, Table] ++ other) ([Body, Tr] ++ other) [] []
-val th : other ::: {Unit} -> [other ~ [Body, Tr]] =>
-                                unit -> tag [] ([Body, Tr] ++ other) ([Body] ++ other) [] []
-val td : other ::: {Unit} -> [other ~ [Body, Tr]] =>
-                                unit -> tag [] ([Body, Tr] ++ other) ([Body] ++ other) [] []
-
 
 (** Aborting *)
 
-val error : t ::: Type -> xml [Body] [] [] -> t
-
-
+val error : t ::: Type -> xml [Body] [] [] [] -> t
diff --git a/lib/ur/top.ur b/lib/ur/top.ur
index b9728158..9db8462d 100644
--- a/lib/ur/top.ur
+++ b/lib/ur/top.ur
@@ -71,7 +71,7 @@ fun ex (tf :: (Type -> Type)) (choice :: Type) (body : tf choice) : ex tf =
 fun compose (t1 ::: Type) (t2 ::: Type) (t3 ::: Type)
             (f1 : t2 -> t3) (f2 : t1 -> t2) (x : t1) = f1 (f2 x)
 
-fun txt (t ::: Type) (ctx ::: {Unit}) (use ::: {Type}) (_ : show t) (v : t) =
+fun txt (t ::: Type) (ctx ::: {Unit}) (use ::: {Type}) (css ::: {Unit}) (_ : show t) (v : t) =
     cdata (show v)
 
 fun foldUR (tf :: Type) (tr :: {Unit} -> Type)
@@ -94,11 +94,11 @@ fun foldUR2 (tf1 :: Type) (tf2 :: Type) (tr :: {Unit} -> Type)
            f [nm] [rest] ! r1.nm r2.nm (acc (r1 -- nm) (r2 -- nm)))
        (fn _ _ => i)
 
-fun foldURX2 (tf1 :: Type) (tf2 :: Type) (ctx :: {Unit})
+fun foldURX2 (css ::: {Unit}) (tf1 :: Type) (tf2 :: Type) (ctx :: {Unit})
            (f : nm :: Name -> rest :: {Unit}
                 -> [[nm] ~ rest] =>
-                      tf1 -> tf2 -> xml ctx [] []) =
-    foldUR2 [tf1] [tf2] [fn _ => xml ctx [] []]
+                      tf1 -> tf2 -> xml ctx [] [] css) =
+    foldUR2 [tf1] [tf2] [fn _ => xml ctx [] [] css]
             (fn (nm :: Name) (rest :: {Unit}) [[nm] ~ rest] v1 v2 acc =>
                 <xml>{f [nm] [rest] ! v1 v2}{acc}</xml>)
             <xml/>
@@ -124,20 +124,20 @@ fun foldR2 K (tf1 :: K -> Type) (tf2 :: K -> Type) (tr :: {K} -> Type)
            f [nm] [t] [rest] ! r1.nm r2.nm (acc (r1 -- nm) (r2 -- nm)))
        (fn _ _ => i)
 
-fun foldRX K (tf :: K -> Type) (ctx :: {Unit})
+fun foldRX K (css ::: {Unit}) (tf :: K -> Type) (ctx :: {Unit})
             (f : nm :: Name -> t :: K -> rest :: {K}
                  -> [[nm] ~ rest] =>
-                       tf t -> xml ctx [] []) =
-    foldR [tf] [fn _ => xml ctx [] []]
+                       tf t -> xml ctx [] [] css) =
+    foldR [tf] [fn _ => xml ctx [] [] css]
           (fn (nm :: Name) (t :: K) (rest :: {K}) [[nm] ~ rest] r acc =>
               <xml>{f [nm] [t] [rest] ! r}{acc}</xml>)
           <xml/>
 
-fun foldRX2 K (tf1 :: K -> Type) (tf2 :: K -> Type) (ctx :: {Unit})
+fun foldRX2 K (css ::: {Unit}) (tf1 :: K -> Type) (tf2 :: K -> Type) (ctx :: {Unit})
              (f : nm :: Name -> t :: K -> rest :: {K}
                   -> [[nm] ~ rest] =>
-                        tf1 t -> tf2 t -> xml ctx [] []) =
-    foldR2 [tf1] [tf2] [fn _ => xml ctx [] []]
+                        tf1 t -> tf2 t -> xml ctx [] [] css) =
+    foldR2 [tf1] [tf2] [fn _ => xml ctx [] [] css]
            (fn (nm :: Name) (t :: K) (rest :: {K}) [[nm] ~ rest]
                             r1 r2 acc =>
                <xml>{f [nm] [t] [rest] ! r1 r2}{acc}</xml>)
@@ -151,18 +151,18 @@ fun queryI (tables ::: {{Type}}) (exps ::: {Type})
           (fn fs _ => f fs)
           ()
 
-fun queryX (tables ::: {{Type}}) (exps ::: {Type}) (ctx ::: {Unit})
+fun queryX (tables ::: {{Type}}) (exps ::: {Type}) (ctx ::: {Unit}) (css ::: {Unit})
            [tables ~ exps] (q : sql_query tables exps)
            (f : $(exps ++ map (fn fields :: {Type} => $fields) tables)
-                -> xml ctx [] []) =
+                -> xml ctx [] [] css) =
     query q
           (fn fs acc => return <xml>{acc}{f fs}</xml>)
           <xml/>
 
-fun queryX' (tables ::: {{Type}}) (exps ::: {Type}) (ctx ::: {Unit})
+fun queryX' (tables ::: {{Type}}) (exps ::: {Type}) (ctx ::: {Unit}) (css ::: {Unit})
             [tables ~ exps] (q : sql_query tables exps)
             (f : $(exps ++ map (fn fields :: {Type} => $fields) tables)
-                 -> transaction (xml ctx [] [])) =
+                 -> transaction (xml ctx [] [] css)) =
     query q
           (fn fs acc =>
               r <- f fs;
diff --git a/lib/ur/top.urs b/lib/ur/top.urs
index 60b6dac2..2378e57a 100644
--- a/lib/ur/top.urs
+++ b/lib/ur/top.urs
@@ -39,8 +39,8 @@ val ex : tf :: (Type -> Type) -> choice :: Type -> tf choice -> ex tf
 val compose : t1 ::: Type -> t2 ::: Type -> t3 ::: Type
               -> (t2 -> t3) -> (t1 -> t2) -> (t1 -> t3)
 
-val txt : t ::: Type -> ctx ::: {Unit} -> use ::: {Type} -> show t -> t
-          -> xml ctx use []
+val txt : t ::: Type -> ctx ::: {Unit} -> use ::: {Type} -> css ::: {Unit} -> show t -> t
+          -> xml ctx use [] css
 
 val foldUR : tf :: Type -> tr :: ({Unit} -> Type)
              -> (nm :: Name -> rest :: {Unit}
@@ -54,11 +54,11 @@ val foldUR2 : tf1 :: Type -> tf2 :: Type -> tr :: ({Unit} -> Type)
                        tf1 -> tf2 -> tr rest -> tr ([nm] ++ rest))
              -> tr [] -> r :: {Unit} -> folder r -> $(mapU tf1 r) -> $(mapU tf2 r) -> tr r
 
-val foldURX2: tf1 :: Type -> tf2 :: Type -> ctx :: {Unit}
+val foldURX2: css ::: {Unit} -> tf1 :: Type -> tf2 :: Type -> ctx :: {Unit}
               -> (nm :: Name -> rest :: {Unit}
                   -> [[nm] ~ rest] =>
-                        tf1 -> tf2 -> xml ctx [] [])
-              -> r :: {Unit} -> folder r -> $(mapU tf1 r) -> $(mapU tf2 r) -> xml ctx [] []
+                        tf1 -> tf2 -> xml ctx [] [] css)
+              -> r :: {Unit} -> folder r -> $(mapU tf1 r) -> $(mapU tf2 r) -> xml ctx [] [] css
 
 val foldR : K --> tf :: (K -> Type) -> tr :: ({K} -> Type)
              -> (nm :: Name -> t :: K -> rest :: {K}
@@ -74,18 +74,18 @@ val foldR2 : K --> tf1 :: (K -> Type) -> tf2 :: (K -> Type)
              -> tr []
              -> r :: {K} -> folder r -> $(map tf1 r) -> $(map tf2 r) -> tr r
 
-val foldRX : K --> tf :: (K -> Type) -> ctx :: {Unit}
+val foldRX : K --> css ::: {Unit} -> tf :: (K -> Type) -> ctx :: {Unit}
              -> (nm :: Name -> t :: K -> rest :: {K}
                  -> [[nm] ~ rest] =>
-                       tf t -> xml ctx [] [])
-             -> r :: {K} -> folder r -> $(map tf r) -> xml ctx [] []
+                       tf t -> xml ctx [] [] css)
+             -> r :: {K} -> folder r -> $(map tf r) -> xml ctx [] [] css
 
-val foldRX2 : K --> tf1 :: (K -> Type) -> tf2 :: (K -> Type) -> ctx :: {Unit}
+val foldRX2 : K --> css ::: {Unit} -> tf1 :: (K -> Type) -> tf2 :: (K -> Type) -> ctx :: {Unit}
               -> (nm :: Name -> t :: K -> rest :: {K}
                   -> [[nm] ~ rest] =>
-                        tf1 t -> tf2 t -> xml ctx [] [])
+                        tf1 t -> tf2 t -> xml ctx [] [] css)
               -> r :: {K} -> folder r
-              -> $(map tf1 r) -> $(map tf2 r) -> xml ctx [] []
+              -> $(map tf1 r) -> $(map tf2 r) -> xml ctx [] [] css
 
 val queryI : tables ::: {{Type}} -> exps ::: {Type}
              -> [tables ~ exps] =>
@@ -94,19 +94,19 @@ val queryI : tables ::: {{Type}} -> exps ::: {Type}
                  -> transaction unit)
              -> transaction unit
 
-val queryX : tables ::: {{Type}} -> exps ::: {Type} -> ctx ::: {Unit}
+val queryX : tables ::: {{Type}} -> exps ::: {Type} -> ctx ::: {Unit} -> css ::: {Unit}
              -> [tables ~ exps] =>
              sql_query tables exps
              -> ($(exps ++ map (fn fields :: {Type} => $fields) tables)
-                 -> xml ctx [] [])
-             -> transaction (xml ctx [] [])
+                 -> xml ctx [] [] css)
+             -> transaction (xml ctx [] [] css)
 
-val queryX' : tables ::: {{Type}} -> exps ::: {Type} -> ctx ::: {Unit}
+val queryX' : tables ::: {{Type}} -> exps ::: {Type} -> ctx ::: {Unit} -> css ::: {Unit}
               -> [tables ~ exps] =>
               sql_query tables exps
               -> ($(exps ++ map (fn fields :: {Type} => $fields) tables)
-                  -> transaction (xml ctx [] []))
-              -> transaction (xml ctx [] [])
+                  -> transaction (xml ctx [] [] css))
+              -> transaction (xml ctx [] [] css)
                        
 val oneOrNoRows : tables ::: {{Type}} -> exps ::: {Type}
                   -> [tables ~ exps] =>