diff options
Diffstat (limited to 'lib/ur')
-rw-r--r-- | lib/ur/basis.urs | 124 | ||||
-rw-r--r-- | lib/ur/top.ur | 28 | ||||
-rw-r--r-- | lib/ur/top.urs | 34 |
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] => |