Mercurial > urweb
changeset 720:acb8537f58f0
Stop tracking CSS classes in XML types
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sun, 12 Apr 2009 12:31:54 -0400 |
| parents | 5c099b1308ae |
| children | 9864b64b1700 |
| files | demo/hello.urs lib/ur/basis.urs lib/ur/top.ur lib/ur/top.urs src/cjr.sml src/cjr_print.sml src/core.sml src/core_env.sml src/core_print.sml src/core_util.sml src/corify.sml src/elab.sml src/elab_env.sml src/elab_print.sig src/elab_print.sml src/elab_util.sml src/elaborate.sml src/expl.sml src/expl_env.sml src/expl_print.sml src/explify.sml src/mono.sml src/mono_print.sml src/monoize.sml src/reduce.sml src/shake.sml src/source.sml src/source_print.sml src/urweb.grm tests/style.ur |
| diffstat | 30 files changed, 199 insertions(+), 312 deletions(-) [+] |
line wrap: on
line diff
--- a/demo/hello.urs Sun Apr 12 11:08:00 2009 -0400 +++ b/demo/hello.urs Sun Apr 12 12:31:54 2009 -0400 @@ -1,1 +1,1 @@ -val main : unit -> transaction (page []) +val main : unit -> transaction page
--- a/lib/ur/basis.urs Sun Apr 12 11:08:00 2009 -0400 +++ b/lib/ur/basis.urs Sun Apr 12 12:31:54 2009 -0400 @@ -408,64 +408,40 @@ con css_class :: {Unit} -> Type (* The argument lists categories of properties that this class could set usefully. *) -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 tag :: {Type} -> {Unit} -> {Unit} -> {Type} -> {Type} -> Type -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 +con xml :: {Unit} -> {Type} -> {Type} -> Type +val cdata : ctx ::: {Unit} -> use ::: {Type} -> string -> xml ctx use [] 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 cssOuter - -> css_subset cssOuter css - -> css_subset cssInner css - -> xml ctxInner useInner bindInner cssInner - -> xml ctxOuter (useOuter ++ useInner) (bindOuter ++ bindInner) css + ctxOuter ctxInner useOuter bindOuter + -> xml ctxInner useInner bindInner + -> xml ctxOuter (useOuter ++ useInner) (bindOuter ++ bindInner) val join : ctx ::: {Unit} - -> 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 + -> use1 ::: {Type} -> bind1 ::: {Type} -> bind2 ::: {Type} + -> [use1 ~ bind1] => [bind1 ~ bind2] => + xml ctx use1 bind1 + -> xml ctx (use1 ++ bind1) bind2 + -> xml ctx use1 (bind1 ++ bind2) val useMore : ctx ::: {Unit} -> use1 ::: {Type} -> use2 ::: {Type} - -> bind ::: {Type} -> css ::: {Unit} + -> bind ::: {Type} -> [use1 ~ use2] => - xml ctx use1 bind css - -> xml ctx (use1 ++ use2) bind css + xml ctx use1 bind + -> xml ctx (use1 ++ use2) bind 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 *) @@ -477,21 +453,21 @@ con tabl = [Body, Table] con tr = [Body, Tr] -val dyn : use ::: {Type} -> bind ::: {Type} -> unit -> css ::: {Unit} - -> tag [Signal = signal (xml body use bind css)] body [] use bind css +val dyn : use ::: {Type} -> bind ::: {Type} -> unit + -> tag [Signal = signal (xml body use bind)] body [] use bind -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 [] @@ -516,19 +492,19 @@ type url val bless : string -> url -val a : css ::: {Unit} -> bodyTag [Link = transaction (page css), Href = url, Onclick = transaction unit] +val a : bodyTag [Link = transaction page, Href = url, Onclick = transaction unit] val img : bodyTag [Src = url] -val form : ctx ::: {Unit} -> bind ::: {Type} -> css ::: {Unit} +val form : ctx ::: {Unit} -> bind ::: {Type} -> [[Body] ~ ctx] => - xml form [] bind css - -> xml ([Body] ++ ctx) [] [] css + xml form [] bind + -> xml ([Body] ++ ctx) [] [] 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] @@ -537,40 +513,42 @@ 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} -> css ::: {Unit} +val submit : ctx ::: {Unit} -> use ::: {Type} -> [[Form] ~ ctx] => unit - -> tag [Value = string, Action = $use -> transaction (page css)] - ([Form] ++ ctx) ([Form] ++ ctx) use [] [] + -> tag [Value = string, Action = $use -> transaction page] + ([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 + +
--- a/lib/ur/top.ur Sun Apr 12 11:08:00 2009 -0400 +++ b/lib/ur/top.ur Sun Apr 12 12:31:54 2009 -0400 @@ -71,7 +71,7 @@ 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}) (css ::: {Unit}) (_ : show t) (v : t) = +fun txt (t ::: Type) (ctx ::: {Unit}) (use ::: {Type}) (_ : show t) (v : t) = cdata (show v) fun foldUR (tf :: Type) (tr :: {Unit} -> Type) @@ -94,11 +94,11 @@ f [nm] [rest] ! r1.nm r2.nm (acc (r1 -- nm) (r2 -- nm))) (fn _ _ => i) -fun foldURX2 (css ::: {Unit}) (tf1 :: Type) (tf2 :: Type) (ctx :: {Unit}) +fun foldURX2 (tf1 :: Type) (tf2 :: Type) (ctx :: {Unit}) (f : nm :: Name -> rest :: {Unit} -> [[nm] ~ rest] => - tf1 -> tf2 -> xml ctx [] [] css) = - foldUR2 [tf1] [tf2] [fn _ => xml ctx [] [] css] + tf1 -> tf2 -> xml ctx [] []) = + foldUR2 [tf1] [tf2] [fn _ => xml ctx [] []] (fn (nm :: Name) (rest :: {Unit}) [[nm] ~ rest] v1 v2 acc => <xml>{f [nm] [rest] ! v1 v2}{acc}</xml>) <xml/> @@ -124,20 +124,20 @@ f [nm] [t] [rest] ! r1.nm r2.nm (acc (r1 -- nm) (r2 -- nm))) (fn _ _ => i) -fun foldRX K (css ::: {Unit}) (tf :: K -> Type) (ctx :: {Unit}) +fun foldRX K (tf :: K -> Type) (ctx :: {Unit}) (f : nm :: Name -> t :: K -> rest :: {K} -> [[nm] ~ rest] => - tf t -> xml ctx [] [] css) = - foldR [tf] [fn _ => xml ctx [] [] css] + tf t -> xml ctx [] []) = + foldR [tf] [fn _ => xml ctx [] []] (fn (nm :: Name) (t :: K) (rest :: {K}) [[nm] ~ rest] r acc => <xml>{f [nm] [t] [rest] ! r}{acc}</xml>) <xml/> -fun foldRX2 K (css ::: {Unit}) (tf1 :: K -> Type) (tf2 :: K -> Type) (ctx :: {Unit}) +fun foldRX2 K (tf1 :: K -> Type) (tf2 :: K -> Type) (ctx :: {Unit}) (f : nm :: Name -> t :: K -> rest :: {K} -> [[nm] ~ rest] => - tf1 t -> tf2 t -> xml ctx [] [] css) = - foldR2 [tf1] [tf2] [fn _ => xml ctx [] [] css] + tf1 t -> tf2 t -> xml ctx [] []) = + foldR2 [tf1] [tf2] [fn _ => xml ctx [] []] (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 @@ (fn fs _ => f fs) () -fun queryX (tables ::: {{Type}}) (exps ::: {Type}) (ctx ::: {Unit}) (css ::: {Unit}) +fun queryX (tables ::: {{Type}}) (exps ::: {Type}) (ctx ::: {Unit}) [tables ~ exps] (q : sql_query tables exps) (f : $(exps ++ map (fn fields :: {Type} => $fields) tables) - -> xml ctx [] [] css) = + -> xml ctx [] []) = query q (fn fs acc => return <xml>{acc}{f fs}</xml>) <xml/> -fun queryX' (tables ::: {{Type}}) (exps ::: {Type}) (ctx ::: {Unit}) (css ::: {Unit}) +fun queryX' (tables ::: {{Type}}) (exps ::: {Type}) (ctx ::: {Unit}) [tables ~ exps] (q : sql_query tables exps) (f : $(exps ++ map (fn fields :: {Type} => $fields) tables) - -> transaction (xml ctx [] [] css)) = + -> transaction (xml ctx [] [])) = query q (fn fs acc => r <- f fs;
--- a/lib/ur/top.urs Sun Apr 12 11:08:00 2009 -0400 +++ b/lib/ur/top.urs Sun Apr 12 12:31:54 2009 -0400 @@ -39,8 +39,8 @@ val compose : t1 ::: Type -> t2 ::: Type -> t3 ::: Type -> (t2 -> t3) -> (t1 -> t2) -> (t1 -> t3) -val txt : t ::: Type -> ctx ::: {Unit} -> use ::: {Type} -> css ::: {Unit} -> show t -> t - -> xml ctx use [] css +val txt : t ::: Type -> ctx ::: {Unit} -> use ::: {Type} -> show t -> t + -> xml ctx use [] val foldUR : tf :: Type -> tr :: ({Unit} -> Type) -> (nm :: Name -> rest :: {Unit} @@ -54,11 +54,11 @@ tf1 -> tf2 -> tr rest -> tr ([nm] ++ rest)) -> tr [] -> r :: {Unit} -> folder r -> $(mapU tf1 r) -> $(mapU tf2 r) -> tr r -val foldURX2: css ::: {Unit} -> tf1 :: Type -> tf2 :: Type -> ctx :: {Unit} +val foldURX2: tf1 :: Type -> tf2 :: Type -> ctx :: {Unit} -> (nm :: Name -> rest :: {Unit} -> [[nm] ~ rest] => - tf1 -> tf2 -> xml ctx [] [] css) - -> r :: {Unit} -> folder r -> $(mapU tf1 r) -> $(mapU tf2 r) -> xml ctx [] [] css + tf1 -> tf2 -> xml ctx [] []) + -> r :: {Unit} -> folder r -> $(mapU tf1 r) -> $(mapU tf2 r) -> xml ctx [] [] val foldR : K --> tf :: (K -> Type) -> tr :: ({K} -> Type) -> (nm :: Name -> t :: K -> rest :: {K} @@ -74,18 +74,18 @@ -> tr [] -> r :: {K} -> folder r -> $(map tf1 r) -> $(map tf2 r) -> tr r -val foldRX : K --> css ::: {Unit} -> tf :: (K -> Type) -> ctx :: {Unit} +val foldRX : K --> tf :: (K -> Type) -> ctx :: {Unit} -> (nm :: Name -> t :: K -> rest :: {K} -> [[nm] ~ rest] => - tf t -> xml ctx [] [] css) - -> r :: {K} -> folder r -> $(map tf r) -> xml ctx [] [] css + tf t -> xml ctx [] []) + -> r :: {K} -> folder r -> $(map tf r) -> xml ctx [] [] -val foldRX2 : K --> css ::: {Unit} -> tf1 :: (K -> Type) -> tf2 :: (K -> Type) -> ctx :: {Unit} +val foldRX2 : K --> tf1 :: (K -> Type) -> tf2 :: (K -> Type) -> ctx :: {Unit} -> (nm :: Name -> t :: K -> rest :: {K} -> [[nm] ~ rest] => - tf1 t -> tf2 t -> xml ctx [] [] css) + tf1 t -> tf2 t -> xml ctx [] []) -> r :: {K} -> folder r - -> $(map tf1 r) -> $(map tf2 r) -> xml ctx [] [] css + -> $(map tf1 r) -> $(map tf2 r) -> xml ctx [] [] val queryI : tables ::: {{Type}} -> exps ::: {Type} -> [tables ~ exps] => @@ -94,19 +94,19 @@ -> transaction unit) -> transaction unit -val queryX : tables ::: {{Type}} -> exps ::: {Type} -> ctx ::: {Unit} -> css ::: {Unit} +val queryX : tables ::: {{Type}} -> exps ::: {Type} -> ctx ::: {Unit} -> [tables ~ exps] => sql_query tables exps -> ($(exps ++ map (fn fields :: {Type} => $fields) tables) - -> xml ctx [] [] css) - -> transaction (xml ctx [] [] css) + -> xml ctx [] []) + -> transaction (xml ctx [] []) -val queryX' : tables ::: {{Type}} -> exps ::: {Type} -> ctx ::: {Unit} -> css ::: {Unit} +val queryX' : tables ::: {{Type}} -> exps ::: {Type} -> ctx ::: {Unit} -> [tables ~ exps] => sql_query tables exps -> ($(exps ++ map (fn fields :: {Type} => $fields) tables) - -> transaction (xml ctx [] [] css)) - -> transaction (xml ctx [] [] css) + -> transaction (xml ctx [] [])) + -> transaction (xml ctx [] []) val oneOrNoRows : tables ::: {{Type}} -> exps ::: {Type} -> [tables ~ exps] =>
--- a/src/cjr.sml Sun Apr 12 11:08:00 2009 -0400 +++ b/src/cjr.sml Sun Apr 12 12:31:54 2009 -0400 @@ -110,7 +110,7 @@ | DPreparedStatements of (string * int) list | DJavaScript of string - | DStyle of string * string list + | DStyle of string withtype decl = decl' located
--- a/src/cjr_print.sml Sun Apr 12 11:08:00 2009 -0400 +++ b/src/cjr_print.sml Sun Apr 12 12:31:54 2009 -0400 @@ -2146,17 +2146,13 @@ | DJavaScript s => box [string "static char jslib[] = \"", string (String.toString s), string "\";"] - | DStyle (s, xs) => box [string "/*", - space, - string "style", - space, - string s, - space, - string ":", - space, - p_list string xs, - space, - string "*/"] + | DStyle s => box [string "/*", + space, + string "style", + space, + string s, + space, + string "*/"] datatype 'a search = Found of 'a
--- a/src/core.sml Sun Apr 12 11:08:00 2009 -0400 +++ b/src/core.sml Sun Apr 12 12:31:54 2009 -0400 @@ -134,7 +134,7 @@ | DSequence of string * int * string | DDatabase of string | DCookie of string * int * con * string - | DStyle of string * int * con * string + | DStyle of string * int * string withtype decl = decl' located
--- a/src/core_env.sml Sun Apr 12 11:08:00 2009 -0400 +++ b/src/core_env.sml Sun Apr 12 12:31:54 2009 -0400 @@ -334,9 +334,9 @@ in pushENamed env x n t NONE s end - | DStyle (x, n, c, s) => + | DStyle (x, n, s) => let - val t = (CApp ((CFfi ("Basis", "css_class"), loc), c), loc) + val t = (CFfi ("Basis", "css_class"), loc) in pushENamed env x n t NONE s end
--- a/src/core_print.sml Sun Apr 12 11:08:00 2009 -0400 +++ b/src/core_print.sml Sun Apr 12 12:31:54 2009 -0400 @@ -586,17 +586,13 @@ string ":", space, p_con env c] - | DStyle (x, n, c, s) => box [string "style", - space, - p_named x n, - space, - string "as", - space, - string s, - space, - string ":", - space, - p_con env c] + | DStyle (x, n, s) => box [string "style", + space, + p_named x n, + space, + string "as", + space, + string s] fun p_file env file = let
--- a/src/core_util.sml Sun Apr 12 11:08:00 2009 -0400 +++ b/src/core_util.sml Sun Apr 12 12:31:54 2009 -0400 @@ -951,10 +951,7 @@ S.map2 (mfc ctx c, fn c' => (DCookie (x, n, c', s), loc)) - | DStyle (x, n, c, s) => - S.map2 (mfc ctx c, - fn c' => - (DStyle (x, n, c', s), loc)) + | DStyle _ => S.return2 dAll and mfvi ctx (x, n, t, e, s) = S.bind2 (mfc ctx t, @@ -1092,9 +1089,9 @@ in bind (ctx, NamedE (x, n, t, NONE, s)) end - | DStyle (x, n, c, s) => + | DStyle (x, n, s) => let - val t = (CApp ((CFfi ("Basis", "css_class"), #2 d'), c), #2 d') + val t = (CFfi ("Basis", "css_class"), #2 d') in bind (ctx, NamedE (x, n, t, NONE, s)) end @@ -1159,7 +1156,7 @@ | DSequence (_, n, _) => Int.max (n, count) | DDatabase _ => count | DCookie (_, n, _, _) => Int.max (n, count) - | DStyle (_, n, _, _) => Int.max (n, count)) 0 + | DStyle (_, n, _) => Int.max (n, count)) 0 end
--- a/src/corify.sml Sun Apr 12 11:08:00 2009 -0400 +++ b/src/corify.sml Sun Apr 12 12:31:54 2009 -0400 @@ -923,11 +923,10 @@ ran' as (L.CApp ((L.CApp - ((L.CApp - ((L.CApp ((L.CModProj (basis', [], "xml"), _), - (L.CRecord (_, [((L.CName "Html", _), - _)]), _)), _), _), - _), _), _), _), _))) => + ((L.CApp ((L.CModProj (basis', [], "xml"), _), + (L.CRecord (_, [((L.CName "Html", _), + _)]), _)), _), _), + _), _), _))) => let val ran = (L.TRecord (L.CRecord ((L.KType, loc), []), loc), loc) val ranT = (L.CApp ((L.CModProj (basis, [], "transaction"), loc), @@ -1003,12 +1002,12 @@ in ([(L'.DCookie (x, n, corifyCon st c, s), loc)], st) end - | L.DStyle (_, x, n, c) => + | L.DStyle (_, x, n) => let val (st, n) = St.bindVal st x n val s = doRestify (mods, x) in - ([(L'.DStyle (x, n, corifyCon st c, s), loc)], st) + ([(L'.DStyle (x, n, s), loc)], st) end and corifyStr mods ((str, _), st) = @@ -1066,7 +1065,7 @@ | L.DSequence (_, _, n') => Int.max (n, n') | L.DDatabase _ => n | L.DCookie (_, _, n', _) => Int.max (n, n') - | L.DStyle (_, _, n', _) => Int.max (n, n')) + | L.DStyle (_, _, n') => Int.max (n, n')) 0 ds and maxNameStr (str, _) =
--- a/src/elab.sml Sun Apr 12 11:08:00 2009 -0400 +++ b/src/elab.sml Sun Apr 12 12:31:54 2009 -0400 @@ -171,7 +171,7 @@ | DClass of string * int * kind * con | DDatabase of string | DCookie of int * string * int * con - | DStyle of int * string * int * con + | DStyle of int * string * int and str' = StrConst of decl list
--- a/src/elab_env.sml Sun Apr 12 11:08:00 2009 -0400 +++ b/src/elab_env.sml Sun Apr 12 12:31:54 2009 -0400 @@ -1434,9 +1434,9 @@ in pushENamedAs env x n t end - | DStyle (tn, x, n, c) => + | DStyle (tn, x, n) => let - val t = (CApp ((CModProj (tn, [], "css_class"), loc), c), loc) + val t = (CModProj (tn, [], "css_class"), loc) in pushENamedAs env x n t end
--- a/src/elab_print.sig Sun Apr 12 11:08:00 2009 -0400 +++ b/src/elab_print.sig Sun Apr 12 12:31:54 2009 -0400 @@ -36,7 +36,6 @@ val p_decl : ElabEnv.env -> Elab.decl Print.printer val p_sgn_item : ElabEnv.env -> Elab.sgn_item Print.printer val p_sgn : ElabEnv.env -> Elab.sgn Print.printer - val p_str : ElabEnv.env -> Elab.str Print.printer val p_file : ElabEnv.env -> Elab.file Print.printer val debug : bool ref
--- a/src/elab_print.sml Sun Apr 12 11:08:00 2009 -0400 +++ b/src/elab_print.sml Sun Apr 12 12:31:54 2009 -0400 @@ -779,13 +779,9 @@ string ":", space, p_con env c] - | DStyle (_, x, n, c) => box [string "style", - space, - p_named x n, - space, - string ":", - space, - p_con env c] + | DStyle (_, x, n) => box [string "style", + space, + p_named x n] and p_str env (str, _) = case str of
--- a/src/elab_util.sml Sun Apr 12 11:08:00 2009 -0400 +++ b/src/elab_util.sml Sun Apr 12 12:31:54 2009 -0400 @@ -797,9 +797,8 @@ | DCookie (tn, x, n, c) => bind (ctx, NamedE (x, (CApp ((CModProj (n, [], "cookie"), loc), c), loc))) - | DStyle (tn, x, n, c) => - bind (ctx, NamedE (x, (CApp ((CModProj (n, [], "css_class"), loc), - c), loc))), + | DStyle (tn, x, n) => + bind (ctx, NamedE (x, (CModProj (n, [], "css_class"), loc))), mfd ctx d)) ctx ds, fn ds' => (StrConst ds', loc)) | StrVar _ => S.return2 strAll @@ -914,10 +913,7 @@ S.map2 (mfc ctx c, fn c' => (DCookie (tn, x, n, c'), loc)) - | DStyle (tn, x, n, c) => - S.map2 (mfc ctx c, - fn c' => - (DStyle (tn, x, n, c'), loc)) + | DStyle _ => S.return2 dAll and mfvi ctx (x, n, c, e) = S.bind2 (mfc ctx c, @@ -1057,8 +1053,7 @@ | DSequence (n1, _, n2) => Int.max (n1, n2) | DDatabase _ => 0 | DCookie (n1, _, n2, _) => Int.max (n1, n2) - | DStyle (n1, _, n2, _) => Int.max (n1, n2) - + | DStyle (n1, _, n2) => Int.max (n1, n2) and maxNameStr (str, _) = case str of StrConst ds => maxName ds
--- a/src/elaborate.sml Sun Apr 12 11:08:00 2009 -0400 +++ b/src/elaborate.sml Sun Apr 12 12:31:54 2009 -0400 @@ -2402,7 +2402,7 @@ | L'.DClass (x, n, k, c) => [(L'.SgiClass (x, n, k, c), loc)] | L'.DDatabase _ => [] | L'.DCookie (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (cookieOf (), c), loc)), loc)] - | L'.DStyle (tn, x, n, c) => [(L'.SgiVal (x, n, (L'.CApp (styleOf (), c), loc)), loc)] + | L'.DStyle (tn, x, n) => [(L'.SgiVal (x, n, styleOf ()), loc)] and subSgn env sgn1 (sgn2 as (_, loc2)) = ((*prefaces "subSgn" [("sgn1", p_sgn env sgn1), @@ -3284,40 +3284,30 @@ (L'.CApp (tf, arg), _) => (case (hnormCon env tf, hnormCon env arg) of ((L'.CModProj (basis, [], "transaction"), _), - (L'.CApp (tf, arg4), _)) => + (L'.CApp (tf, arg3), _)) => (case (basis = !basis_r, - hnormCon env tf, hnormCon env arg4) of + hnormCon env tf, hnormCon env arg3) of (true, - (L'.CApp (tf, arg3), _), + (L'.CApp (tf, arg2), _), ((L'.CRecord (_, []), _))) => - (case hnormCon env tf of - (L'.CApp (tf, arg2), _) => - (case hnormCon env tf of - (L'.CApp (tf, arg1), _) => - (case (hnormCon env tf, - hnormCon env arg1, - hnormCon env arg2, - hnormCon env arg3, - hnormCon env arg4) of - (tf, - arg1, - (L'.CRecord (_, []), _), - arg2, - arg4) => - let - val t = (L'.CApp (tf, arg1), loc) - val t = (L'.CApp (t, arg2), loc) - val t = (L'.CApp (t, arg3), loc) - val t = (L'.CApp (t, arg4), loc) - - val t = (L'.CApp ( - (L'.CModProj - (basis, [], "transaction"), loc), + (case (hnormCon env tf) of + (L'.CApp (tf, arg1), _) => + (case (hnormCon env tf, + hnormCon env arg1, + hnormCon env arg2) of + (tf, arg1, + (L'.CRecord (_, []), _)) => + let + val t = (L'.CApp (tf, arg1), loc) + val t = (L'.CApp (t, arg2), loc) + val t = (L'.CApp (t, arg3), loc) + val t = (L'.CApp ( + (L'.CModProj + (basis, [], "transaction"), loc), t), loc) - in - (L'.SgiVal (x, n, makeRes t), loc) - end - | _ => all) + in + (L'.SgiVal (x, n, makeRes t), loc) + end | _ => all) | _ => all) | _ => all) @@ -3402,13 +3392,11 @@ checkKind env c' k (L'.KType, loc); ([(L'.DCookie (!basis_r, x, n, c'), loc)], (env, denv, enD gs' @ gs)) end - | L.DStyle (x, c) => + | L.DStyle x => let - val (c', k, gs') = elabCon (env, denv) c - val (env, n) = E.pushENamed env x (L'.CApp (styleOf (), c'), loc) + val (env, n) = E.pushENamed env x (styleOf ()) in - checkKind env c' k (L'.KRecord (L'.KUnit, loc), loc); - ([(L'.DStyle (!basis_r, x, n, c'), loc)], (env, denv, enD gs' @ gs)) + ([(L'.DStyle (!basis_r, x, n), loc)], (env, denv, gs)) end (*val tcs = List.filter (fn TypeClass _ => true | _ => false) (#3 (#2 r))*) @@ -3632,16 +3620,6 @@ [] => () | _ => raise Fail "Unresolved disjointness constraints in top.urs" val (topStr, topSgn', gs) = elabStr (env', D.empty) (L.StrConst topStr, ErrorMsg.dummySpan) - - val () = subSgn env' topSgn' topSgn - - val () = app (fn (env, k, s1, s2) => - unifySummaries env (k, normalizeRecordSummary env s1, normalizeRecordSummary env s2) - handle CUnify' err => (ErrorMsg.errorAt (#2 k) "Error in Top final record unification"; - cunifyError env err)) - (!delayedUnifs) - val () = delayedUnifs := [] - val () = case gs of [] => () | _ => app (fn Disjoint (loc, env, denv, c1, c2) => @@ -3651,8 +3629,7 @@ (prefaces "Unresolved constraint in top.ur" [("loc", PD.string (ErrorMsg.spanToString loc)), ("c1", p_con env c1), - ("c2", p_con env c2), - ("topStr", p_str env topStr)]; + ("c2", p_con env c2)]; raise Fail "Unresolved constraint in top.ur")) | TypeClass (env, c, r, loc) => let @@ -3663,6 +3640,8 @@ | NONE => expError env (Unresolvable (loc, c)) end) gs + val () = subSgn env' topSgn' topSgn + val (env', top_n) = E.pushStrNamed env' "Top" topSgn val () = top_r := top_n
--- a/src/expl.sml Sun Apr 12 11:08:00 2009 -0400 +++ b/src/expl.sml Sun Apr 12 12:31:54 2009 -0400 @@ -145,7 +145,7 @@ | DSequence of int * string * int | DDatabase of string | DCookie of int * string * int * con - | DStyle of int * string * int * con + | DStyle of int * string * int and str' = StrConst of decl list
--- a/src/expl_env.sml Sun Apr 12 11:08:00 2009 -0400 +++ b/src/expl_env.sml Sun Apr 12 12:31:54 2009 -0400 @@ -319,9 +319,9 @@ in pushENamed env x n t end - | DStyle (tn, x, n, c) => + | DStyle (tn, x, n) => let - val t = (CApp ((CModProj (tn, [], "css_class"), loc), c), loc) + val t = (CModProj (tn, [], "css_class"), loc) in pushENamed env x n t end
--- a/src/expl_print.sml Sun Apr 12 11:08:00 2009 -0400 +++ b/src/expl_print.sml Sun Apr 12 12:31:54 2009 -0400 @@ -691,13 +691,9 @@ string ":", space, p_con env c] - | DStyle (_, x, n, c) => box [string "style", - space, - p_named x n, - space, - string ":", - space, - p_con env c] + | DStyle (_, x, n) => box [string "style", + space, + p_named x n] and p_str env (str, _) = case str of
--- a/src/explify.sml Sun Apr 12 11:08:00 2009 -0400 +++ b/src/explify.sml Sun Apr 12 12:31:54 2009 -0400 @@ -187,7 +187,7 @@ (L'.KArrow (explifyKind k, (L'.KType, loc)), loc), explifyCon c), loc) | L.DDatabase s => SOME (L'.DDatabase s, loc) | L.DCookie (nt, x, n, c) => SOME (L'.DCookie (nt, x, n, explifyCon c), loc) - | L.DStyle (nt, x, n, c) => SOME (L'.DStyle (nt, x, n, explifyCon c), loc) + | L.DStyle (nt, x, n) => SOME (L'.DStyle (nt, x, n), loc) and explifyStr (str, loc) = case str of
--- a/src/mono.sml Sun Apr 12 11:08:00 2009 -0400 +++ b/src/mono.sml Sun Apr 12 12:31:54 2009 -0400 @@ -127,7 +127,7 @@ | DJavaScript of string - | DStyle of string * string list + | DStyle of string withtype decl = decl' located
--- a/src/mono_print.sml Sun Apr 12 11:08:00 2009 -0400 +++ b/src/mono_print.sml Sun Apr 12 12:31:54 2009 -0400 @@ -440,13 +440,9 @@ string s, string ")"] - | DStyle (s, xs) => box [string "style", - space, - string s, - space, - string ":", - space, - p_list string xs] + | DStyle s => box [string "style", + space, + string s] fun p_file env file =
--- a/src/monoize.sml Sun Apr 12 11:08:00 2009 -0400 +++ b/src/monoize.sml Sun Apr 12 12:31:54 2009 -0400 @@ -127,14 +127,10 @@ readType (mt env dtmap t, loc) | L.CFfi ("Basis", "url") => (L'.TFfi ("Basis", "string"), loc) - | L.CApp ((L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "xml"), _), _), _), _), _), _), _), _) => + | L.CApp ((L.CApp ((L.CApp ((L.CFfi ("Basis", "xml"), _), _), _), _), _), _) => (L'.TFfi ("Basis", "string"), loc) | L.CApp ((L.CApp ((L.CFfi ("Basis", "xhtml"), _), _), _), _) => (L'.TFfi ("Basis", "string"), loc) - | L.CApp ((L.CFfi ("Basis", "css_class"), _), _) => - (L'.TFfi ("Basis", "string"), loc) - | L.CApp ((L.CApp ((L.CFfi ("Basis", "css_subset"), _), _), _), _) => - (L'.TRecord [], loc) | L.CApp ((L.CFfi ("Basis", "transaction"), _), t) => (L'.TFun ((L'.TRecord [], loc), mt env dtmap t), loc) @@ -2007,9 +2003,7 @@ | L.EApp ( (L.ECApp ( - (L.ECApp ( - (L.ECApp ((L.EFfi ("Basis", "cdata"), _), _), _), - _), _), + (L.ECApp ((L.EFfi ("Basis", "cdata"), _), _), _), _), _), se) => let @@ -2018,32 +2012,19 @@ ((L'.EFfiApp ("Basis", "htmlifyString", [se]), loc), fm) end - | L.ECApp ((L.ECApp ((L.EFfi ("Basis", "css_subset"), _), _), _), _) => - ((L'.ERecord [], loc), fm) - | L.EApp ( (L.EApp ( - (L.EApp ( - (L.EApp ( + (L.ECApp ( + (L.ECApp ( (L.ECApp ( (L.ECApp ( - (L.ECApp ( - (L.ECApp ( - (L.ECApp ( - (L.ECApp ( - (L.ECApp ( - (L.EFfi ("Basis", "join"), - _), _), _), - _), _), - _), _), - _), _), - _), _), - _), _), + (L.EFfi ("Basis", "join"), + _), _), _), _), _), - xml1), _), - xml2), _), - _), _), - _) => + _), _), + _), _), + xml1), _), + xml2) => let val (xml1, fm) = monoExp (env, st, fm) xml1 val (xml2, fm) = monoExp (env, st, fm) xml2 @@ -2054,26 +2035,18 @@ | L.EApp ( (L.EApp ( (L.EApp ( - (L.EApp ( - (L.EApp ( + (L.ECApp ( + (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( (L.ECApp ( - (L.ECApp ( - (L.ECApp ( - (L.ECApp ( - (L.ECApp ( - (L.ECApp ( - (L.EFfi ("Basis", "tag"), - _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), - _), _), _), _), _), _), - attrs), _), - tag), _), - _), _), - _), _), + (L.EFfi ("Basis", "tag"), + _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), _), + attrs), _), + tag), _), xml) => let fun getTag' (e, _) = @@ -2732,23 +2705,17 @@ fm, [(L'.DVal (x, n, t', e, s), loc)]) end - | L.DStyle (x, n, (L.CRecord (_, xcs), _), s) => + | L.DStyle (x, n, s) => let - val xs = map (fn ((L.CName x, _), _) => x - | (x, _) => (E.errorAt (#2 x) "Undetermined style component"; - Print.eprefaces' [("Name", CorePrint.p_con env x)]; - "")) xcs - val t = (L.CFfi ("Basis", "string"), loc) val t' = (L'.TFfi ("Basis", "string"), loc) val e = (L'.EPrim (Prim.String s), loc) in SOME (Env.pushENamed env x n t NONE s, fm, - [(L'.DStyle (s, xs), loc), + [(L'.DStyle s, loc), (L'.DVal (x, n, t', e, s), loc)]) end - | L.DStyle _ => poly () end datatype expungable = Client | Channel
--- a/src/reduce.sml Sun Apr 12 11:08:00 2009 -0400 +++ b/src/reduce.sml Sun Apr 12 12:31:54 2009 -0400 @@ -469,7 +469,7 @@ | DSequence _ => (d, st) | DDatabase _ => (d, st) | DCookie (s, n, c, s') => ((DCookie (s, n, con namedC [] c, s'), loc), st) - | DStyle (s, n, c, s') => ((DStyle (s, n, con namedC [] c, s'), loc), st) + | DStyle (s, n, s') => ((DStyle (s, n, s'), loc), st) val (file, _) = ListUtil.foldlMap doDecl (IM.empty, IM.empty) file in
--- a/src/shake.sml Sun Apr 12 11:08:00 2009 -0400 +++ b/src/shake.sml Sun Apr 12 12:31:54 2009 -0400 @@ -87,8 +87,8 @@ | ((DDatabase _, _), acc) => acc | ((DCookie (_, n, c, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, ([], c, dummye))) - | ((DStyle (_, n, c, _), _), (cdef, edef)) => - (cdef, IM.insert (edef, n, ([], c, dummye)))) + | ((DStyle (_, n, _), _), (cdef, edef)) => + (cdef, IM.insert (edef, n, ([], dummyt, dummye)))) (IM.empty, IM.empty) file fun kind (_, s) = s
--- a/src/source.sml Sun Apr 12 11:08:00 2009 -0400 +++ b/src/source.sml Sun Apr 12 12:31:54 2009 -0400 @@ -164,7 +164,7 @@ | DClass of string * kind * con | DDatabase of string | DCookie of string * con - | DStyle of string * con + | DStyle of string and str' = StrConst of decl list
--- a/src/source_print.sml Sun Apr 12 11:08:00 2009 -0400 +++ b/src/source_print.sml Sun Apr 12 12:31:54 2009 -0400 @@ -640,13 +640,9 @@ string ":", space, p_con c] - | DStyle (x, c) => box [string "style", - space, - string x, - space, - string ":", - space, - p_con c] + | DStyle x => box [string "style", + space, + string x] and p_str (str, _) = case str of
--- a/src/urweb.grm Sun Apr 12 11:08:00 2009 -0400 +++ b/src/urweb.grm Sun Apr 12 12:31:54 2009 -0400 @@ -451,7 +451,7 @@ [(DClass (SYMBOL1, kind, c), s (CLASSleft, cexpright))] end) | COOKIE SYMBOL COLON cexp ([(DCookie (SYMBOL, cexp), s (COOKIEleft, cexpright))]) - | STYLE SYMBOL COLON cexp ([(DStyle (SYMBOL, cexp), s (STYLEleft, cexpright))]) + | STYLE SYMBOL ([(DStyle SYMBOL, s (STYLEleft, SYMBOLright))]) kopt : (NONE) | DCOLON kind (SOME kind) @@ -708,10 +708,9 @@ in (SgiVal (SYMBOL, t), loc) end) - | STYLE SYMBOL COLON cexp (let - val loc = s (STYLEleft, cexpright) - val t = (CApp ((CVar (["Basis"], "css_class"), loc), - cexp), loc) + | STYLE SYMBOL (let + val loc = s (STYLEleft, SYMBOLright) + val t = (CVar (["Basis"], "css_class"), loc) in (SgiVal (SYMBOL, t), loc) end) @@ -1208,12 +1207,11 @@ xml : xmlOne xml (let val pos = s (xmlOneleft, xmlright) - val e = (EVar (["Basis"], "join", Infer), pos) - val e = (EApp (e, xmlOne), pos) - val e = (EApp (e, xml), pos) - val e = (EApp (e, (EVar (["Basis"], "css_subset", Infer), pos)), pos) in - (EApp (e, (EVar (["Basis"], "css_subset", Infer), pos)), pos) + (EApp ((EApp ( + (EVar (["Basis"], "join", Infer), pos), + xmlOne), pos), + xml), pos) end) | xmlOne (xmlOne) @@ -1228,7 +1226,6 @@ let val e = (EVar (["Basis"], "cdata", DontInfer), pos) val e = (ECApp (e, (CWild (KWild, pos), pos)), pos) - val e = (ECApp (e, (CRecord [], pos)), pos) in (ECApp (e, (CRecord [], pos)), pos) end @@ -1269,13 +1266,13 @@ tag : tagHead attrs (let val pos = s (tagHeadleft, attrsright) - val e = (EVar (["Basis"], "tag", Infer), pos) - val e = (EApp (e, (ERecord attrs, pos)), pos) - val e = (EApp (e, (EApp (#2 tagHead, (ERecord [], pos)), pos)), pos) - val e = (EApp (e, (EVar (["Basis"], "css_subset", Infer), pos)), pos) - val e = (EApp (e, (EVar (["Basis"], "css_subset", Infer), pos)), pos) in - (#1 tagHead, e) + (#1 tagHead, + (EApp ((EApp ((EVar (["Basis"], "tag", Infer), pos), + (ERecord attrs, pos)), pos), + (EApp (#2 tagHead, + (ERecord [], pos)), pos)), + pos)) end) tagHead: BEGIN_TAG (let