diff lib/ur/basis.urs @ 1778:818d4097e2ed

Lighter-weight encoding of window function use
author Adam Chlipala <adam@chlipala.net>
date Sun, 03 Jun 2012 11:29:31 -0400
parents 59b07fdae1ff
children 5bc4fbf9c0fe
line wrap: on
line diff
--- a/lib/ur/basis.urs	Sat Jun 02 16:47:09 2012 -0400
+++ b/lib/ur/basis.urs	Sun Jun 03 11:29:31 2012 -0400
@@ -305,23 +305,15 @@
            OnUpdate : propagation_mode ([mine1 = t] ++ mine)}
        -> sql_constraint ([mine1 = t] ++ mine ++ munused) []
 
-con allow_window :: {Unit}
-con disallow_window :: {Unit}
-
-con sql_exp :: {{Type}} (* Free tables, for normal use *)
-    -> {{Type}}         (* Free tables, for use in arguments to aggregate functions *)
-    -> {Type}           (* Free ad-hoc variables *)
-    -> {Unit}           (* Allow window functions here?  ([allow_window] indicates yes.) *)
-    -> Type             (* SQL type of this expression *)
-    -> Type
-val sql_exp_weaken : fs ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> aw ::: {Unit} -> t ::: Type
+con sql_exp :: {{Type}} -> {{Type}} -> {Type} -> Type -> Type
+val sql_exp_weaken : fs ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> t ::: Type
                      -> fs' ::: {{Type}} -> agg' ::: {{Type}} -> exps' ::: {Type}
                      -> [fs ~ fs'] => [agg ~ agg'] => [exps ~ exps'] =>
-                     sql_exp fs agg exps aw t
-                     -> sql_exp (fs ++ fs') (agg ++ agg') (exps ++ exps') aw t
+                     sql_exp fs agg exps t
+                     -> sql_exp (fs ++ fs') (agg ++ agg') (exps ++ exps') t
 
 val check : fs ::: {Type}
-            -> sql_exp [] [] fs disallow_window bool
+            -> sql_exp [] [] fs bool
             -> sql_constraint fs []
 
 
@@ -359,7 +351,7 @@
 val sql_inner_join : free ::: {{Type}} -> tabs1 ::: {{Type}} -> tabs2 ::: {{Type}}
                      -> [free ~ tabs1] => [free ~ tabs2] => [tabs1 ~ tabs2]
     => sql_from_items free tabs1 -> sql_from_items free tabs2
-       -> sql_exp (free ++ tabs1 ++ tabs2) [] [] disallow_window bool
+       -> sql_exp (free ++ tabs1 ++ tabs2) [] [] bool
        -> sql_from_items free (tabs1 ++ tabs2)
 
 class nullify :: Type -> Type -> Type
@@ -370,14 +362,14 @@
                      -> [free ~ tabs1] => [free ~ tabs2] => [tabs1 ~ tabs2]
     => $(map (fn r => $(map (fn p :: (Type * Type) => nullify p.1 p.2) r)) tabs2)
        -> sql_from_items free tabs1 -> sql_from_items free (map (map (fn p :: (Type * Type) => p.1)) tabs2)
-       -> sql_exp (free ++ tabs1 ++ map (map (fn p :: (Type * Type) => p.1)) tabs2) [] [] disallow_window bool
+       -> sql_exp (free ++ tabs1 ++ map (map (fn p :: (Type * Type) => p.1)) tabs2) [] [] bool
        -> sql_from_items free (tabs1 ++ map (map (fn p :: (Type * Type) => p.2)) tabs2)
 
 val sql_right_join : free ::: {{Type}} -> tabs1 ::: {{(Type * Type)}} -> tabs2 ::: {{Type}}
                      -> [free ~ tabs1] => [free ~ tabs2] => [tabs1 ~ tabs2]
     => $(map (fn r => $(map (fn p :: (Type * Type) => nullify p.1 p.2) r)) tabs1)
        -> sql_from_items free (map (map (fn p :: (Type * Type) => p.1)) tabs1) -> sql_from_items free tabs2
-       -> sql_exp (free ++ map (map (fn p :: (Type * Type) => p.1)) tabs1 ++ tabs2) [] [] disallow_window bool
+       -> sql_exp (free ++ map (map (fn p :: (Type * Type) => p.1)) tabs1 ++ tabs2) [] [] bool
        -> sql_from_items free (map (map (fn p :: (Type * Type) => p.2)) tabs1 ++ tabs2)
 
 val sql_full_join : free ::: {{Type}} -> tabs1 ::: {{(Type * Type)}} -> tabs2 ::: {{(Type * Type)}}
@@ -385,9 +377,12 @@
     => $(map (fn r => $(map (fn p :: (Type * Type) => nullify p.1 p.2) r)) (tabs1 ++ tabs2))
        -> sql_from_items free (map (map (fn p :: (Type * Type) => p.1)) tabs1)
        -> sql_from_items free (map (map (fn p :: (Type * Type) => p.1)) tabs2)
-       -> sql_exp (free ++ map (map (fn p :: (Type * Type) => p.1)) (tabs1 ++ tabs2)) [] [] disallow_window bool
+       -> sql_exp (free ++ map (map (fn p :: (Type * Type) => p.1)) (tabs1 ++ tabs2)) [] [] bool
        -> sql_from_items free (map (map (fn p :: (Type * Type) => p.2)) (tabs1 ++ tabs2))
 
+(** [ORDER BY] and [SELECT] expressions may use window functions, so we introduce a type family for such expressions. *)
+con sql_expw :: {{Type}} -> {{Type}} -> {Type} -> Type -> Type
+
 val sql_query1 : free ::: {{Type}}
                  -> afree ::: {{Type}}
                  -> tables ::: {{Type}}
@@ -401,11 +396,11 @@
                  => [empties ~ selectedFields]
                  => {Distinct : bool,
                      From : sql_from_items free tables,
-                     Where : sql_exp (free ++ tables) afree [] disallow_window bool,
+                     Where : sql_exp (free ++ tables) afree [] bool,
                      GroupBy : sql_subset tables grouped,
-                     Having : sql_exp (free ++ grouped) (afree ++ tables) [] disallow_window bool,
+                     Having : sql_exp (free ++ grouped) (afree ++ tables) [] bool,
                      SelectFields : sql_subset grouped (map (fn _ => []) empties ++ selectedFields),
-                     SelectExps : $(map (sql_exp (free ++ grouped) (afree ++ tables) [] allow_window)
+                     SelectExps : $(map (sql_expw (free ++ grouped) (afree ++ tables) [])
                                             selectedExps) }
                  -> sql_query1 free afree tables selectedFields selectedExps
 
@@ -432,10 +427,21 @@
 val sql_asc : sql_direction
 val sql_desc : sql_direction
 
+(** This type class supports automatic injection of either regular or window expressions into [sql_expw]. *)
+class sql_window :: ({{Type}} -> {{Type}} -> {Type} -> Type -> Type) -> Type
+val sql_window_normal : sql_window sql_exp
+val sql_window_fancy : sql_window sql_expw
+val sql_window : tf ::: ({{Type}} -> {{Type}} -> {Type} -> Type -> Type)
+                 -> tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> t ::: Type
+                 -> sql_window tf
+                 -> tf tables agg exps t
+                 -> sql_expw tables agg exps t
+
 con sql_order_by :: {{Type}} -> {Type} -> Type
 val sql_order_by_Nil : tables ::: {{Type}} -> exps :: {Type} -> sql_order_by tables exps
-val sql_order_by_Cons : tables ::: {{Type}} -> exps ::: {Type} -> t ::: Type
-                        -> sql_exp tables [] exps allow_window t -> sql_direction
+val sql_order_by_Cons : tf ::: ({{Type}} -> {{Type}} -> {Type} -> Type -> Type) -> tables ::: {{Type}} -> exps ::: {Type} -> t ::: Type
+                        -> sql_window tf
+                        -> tf tables [] exps t -> sql_direction
                         -> sql_order_by tables exps
                         -> sql_order_by tables exps
 val sql_order_by_random : tables ::: {{Type}} -> exps ::: {Type}
@@ -462,42 +468,42 @@
                 -> sql_query free afree selectedFields selectedExps
 
 val sql_field : otherTabs ::: {{Type}} -> otherFields ::: {Type}
-                -> aw ::: {Unit} -> fieldType ::: Type -> agg ::: {{Type}}
+                -> fieldType ::: Type -> agg ::: {{Type}}
                 -> exps ::: {Type}
                 -> tab :: Name -> field :: Name
                 -> sql_exp
                        ([tab = [field = fieldType] ++ otherFields] ++ otherTabs)
-                       agg exps aw fieldType
+                       agg exps fieldType
 
-val sql_exp : tabs ::: {{Type}} -> agg ::: {{Type}} -> aw ::: {Unit} -> t ::: Type -> rest ::: {Type}
+val sql_exp : tabs ::: {{Type}} -> agg ::: {{Type}} -> t ::: Type -> rest ::: {Type}
               -> nm :: Name
-              -> sql_exp tabs agg ([nm = t] ++ rest) aw t
+              -> sql_exp tabs agg ([nm = t] ++ rest) t
 
 class sql_injectable
 val sql_prim : t ::: Type -> sql_injectable_prim t -> sql_injectable t
 val sql_option_prim : t ::: Type -> sql_injectable_prim t -> sql_injectable (option t)
 
 val sql_inject : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
-                 -> aw ::: {Unit} -> t ::: Type
-                 -> sql_injectable t -> t -> sql_exp tables agg exps aw t
+                 -> t ::: Type
+                 -> sql_injectable t -> t -> sql_exp tables agg exps t
 
 val sql_is_null : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
-                  -> aw ::: {Unit} -> t ::: Type
-                  -> sql_exp tables agg exps aw (option t)
-                  -> sql_exp tables agg exps aw bool
+                  -> t ::: Type
+                  -> sql_exp tables agg exps (option t)
+                  -> sql_exp tables agg exps bool
 
 val sql_coalesce : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
-                  -> aw ::: {Unit} -> t ::: Type
-                  -> sql_exp tables agg exps aw (option t)
-                  -> sql_exp tables agg exps aw t
-                  -> sql_exp tables agg exps aw t
+                  -> t ::: Type
+                  -> sql_exp tables agg exps (option t)
+                  -> sql_exp tables agg exps t
+                  -> sql_exp tables agg exps t
 
 val sql_if_then_else : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
-                       -> aw ::: {Unit} -> t ::: Type
-                       -> sql_exp tables agg exps aw bool
-                       -> sql_exp tables agg exps aw t
-                       -> sql_exp tables agg exps aw t
-                       -> sql_exp tables agg exps aw t
+                       -> t ::: Type
+                       -> sql_exp tables agg exps bool
+                       -> sql_exp tables agg exps t
+                       -> sql_exp tables agg exps t
+                       -> sql_exp tables agg exps t
 
 class sql_arith
 val sql_arith_int : sql_arith int
@@ -507,9 +513,9 @@
 con sql_unary :: Type -> Type -> Type
 val sql_not : sql_unary bool bool
 val sql_unary : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
-                -> aw ::: {Unit} -> arg ::: Type -> res ::: Type
-                -> sql_unary arg res -> sql_exp tables agg exps aw arg
-                -> sql_exp tables agg exps aw res
+                -> arg ::: Type -> res ::: Type
+                -> sql_unary arg res -> sql_exp tables agg exps arg
+                -> sql_exp tables agg exps res
 
 val sql_neg : t ::: Type -> sql_arith t -> sql_unary t t
 
@@ -517,10 +523,10 @@
 val sql_and : sql_binary bool bool bool
 val sql_or : sql_binary bool bool bool
 val sql_binary : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
-                 -> aw ::: {Unit} -> arg1 ::: Type -> arg2 ::: Type -> res ::: Type
-                 -> sql_binary arg1 arg2 res -> sql_exp tables agg exps aw arg1
-                 -> sql_exp tables agg exps aw arg2
-                 -> sql_exp tables agg exps aw res
+                 -> arg1 ::: Type -> arg2 ::: Type -> res ::: Type
+                 -> sql_binary arg1 arg2 res -> sql_exp tables agg exps arg1
+                 -> sql_exp tables agg exps arg2
+                 -> sql_exp tables agg exps res
 
 val sql_plus : t ::: Type -> sql_arith t -> sql_binary t t t
 val sql_minus : t ::: Type -> sql_arith t -> sql_binary t t t
@@ -537,14 +543,14 @@
 
 val sql_like : sql_binary string string bool
 
-val sql_count : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> aw ::: {Unit}
-                -> sql_exp tables agg exps aw int
+val sql_count : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
+                -> sql_exp tables agg exps int
 
 con sql_aggregate :: Type -> Type -> Type
 val sql_aggregate : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
-                    -> aw ::: {Unit} -> dom ::: Type -> ran ::: Type
-                    -> sql_aggregate dom ran -> sql_exp agg agg exps aw dom
-                    -> sql_exp tables agg exps aw ran
+                    -> dom ::: Type -> ran ::: Type
+                    -> sql_aggregate dom ran -> sql_exp agg agg exps dom
+                    -> sql_exp tables agg exps ran
 
 val sql_count_col : t ::: Type -> sql_aggregate (option t) int
 
@@ -564,56 +570,59 @@
 val sql_max : t ::: Type -> nt ::: Type -> sql_maxable t -> nullify t nt -> sql_aggregate t nt
 val sql_min : t ::: Type -> nt ::: Type -> sql_maxable t -> nullify t nt -> sql_aggregate t nt
 
-con sql_partition :: {{Type}} -> {{Type}} -> {Type} -> Type
-val sql_no_partition : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
-                       -> sql_partition tables agg exps
-val sql_partition : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> t ::: Type
-                    -> sql_exp tables agg exps disallow_window t
-                    -> sql_partition tables agg exps
-
-con sql_window :: {{Type}} -> {{Type}} -> {Type} -> Type -> Type
-val sql_window : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
-                 -> t ::: Type
-                 -> sql_window tables agg exps t
-                 -> sql_partition tables agg exps
-                 -> sql_order_by tables exps
-                 -> sql_exp tables agg exps allow_window t
-
-val sql_window_aggregate : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
-                           -> t ::: Type -> nt ::: Type
-                           -> sql_aggregate t nt
-                           -> sql_exp tables agg exps disallow_window t
-                           -> sql_window tables agg exps nt
-val sql_window_count : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
-                       -> sql_window tables agg exps int
-val sql_window_rank : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
-                      -> sql_window tables agg exps int
-
 con sql_nfunc :: Type -> Type
 val sql_nfunc : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
-                -> aw ::: {Unit} -> t ::: Type
-                -> sql_nfunc t -> sql_exp tables agg exps aw t
+                -> t ::: Type
+                -> sql_nfunc t -> sql_exp tables agg exps t
 val sql_current_timestamp : sql_nfunc time
 
 con sql_ufunc :: Type -> Type -> Type
 val sql_ufunc : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
-                -> aw ::: {Unit} -> dom ::: Type -> ran ::: Type
-                -> sql_ufunc dom ran -> sql_exp tables agg exps aw dom
-                -> sql_exp tables agg exps aw ran
+                -> dom ::: Type -> ran ::: Type
+                -> sql_ufunc dom ran -> sql_exp tables agg exps dom
+                -> sql_exp tables agg exps ran
 val sql_octet_length : sql_ufunc blob int
 val sql_known : t ::: Type -> sql_ufunc t bool
 val sql_lower : sql_ufunc string string
 val sql_upper : sql_ufunc string string
 
-val sql_nullable : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> aw ::: {Unit} -> t ::: Type
+val sql_nullable : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> t ::: Type
                    -> sql_injectable_prim t
-                   -> sql_exp tables agg exps aw t
-                   -> sql_exp tables agg exps aw (option t)
+                   -> sql_exp tables agg exps t
+                   -> sql_exp tables agg exps (option t)
 
-val sql_subquery : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> nm ::: Name -> aw ::: {Unit} -> t ::: Type -> nt ::: Type
+val sql_subquery : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> nm ::: Name -> t ::: Type -> nt ::: Type
                    -> nullify t nt
                    -> sql_query tables agg [] [nm = t]
-                   -> sql_exp tables agg exps aw nt
+                   -> sql_exp tables agg exps nt
+
+(** Window function expressions *)
+
+con sql_partition :: {{Type}} -> {{Type}} -> {Type} -> Type
+val sql_no_partition : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
+                       -> sql_partition tables agg exps
+val sql_partition : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type} -> t ::: Type
+                    -> sql_exp tables agg exps t
+                    -> sql_partition tables agg exps
+
+con sql_window_function :: {{Type}} -> {{Type}} -> {Type} -> Type -> Type
+val sql_window_function : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
+                          -> t ::: Type
+                          -> sql_window_function tables agg exps t
+                          -> sql_partition tables agg exps
+                          -> sql_order_by tables exps
+                          -> sql_expw tables agg exps t
+
+val sql_window_aggregate : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
+                           -> t ::: Type -> nt ::: Type
+                           -> sql_aggregate t nt
+                           -> sql_exp tables agg exps t
+                           -> sql_window_function tables agg exps nt
+val sql_window_count : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
+                       -> sql_window_function tables agg exps int
+val sql_rank : tables ::: {{Type}} -> agg ::: {{Type}} -> exps ::: {Type}
+               -> sql_window_function tables agg exps int
+
 
 (*** Executing queries *)
 
@@ -637,19 +646,19 @@
 
 val insert : fields ::: {Type} -> uniques ::: {{Unit}}
              -> sql_table fields uniques
-             -> $(map (fn t :: Type => sql_exp [] [] [] disallow_window t) fields)
+             -> $(map (fn t :: Type => sql_exp [] [] [] t) fields)
              -> dml
 
 val update : unchanged ::: {Type} -> uniques ::: {{Unit}} -> changed :: {Type} ->
              [changed ~ unchanged] =>
-                $(map (fn t :: Type => sql_exp [T = changed ++ unchanged] [] [] disallow_window t) changed)
+                $(map (fn t :: Type => sql_exp [T = changed ++ unchanged] [] [] t) changed)
                 -> sql_table (changed ++ unchanged) uniques
-                -> sql_exp [T = changed ++ unchanged] [] [] disallow_window bool
+                -> sql_exp [T = changed ++ unchanged] [] [] bool
                 -> dml
 
 val delete : fields ::: {Type} -> uniques ::: {{Unit}}
              -> sql_table fields uniques
-             -> sql_exp [T = fields] [] [] disallow_window bool
+             -> sql_exp [T = fields] [] [] bool
              -> dml
 
 (*** Sequences *)