join and select now accept both tables and subquery aliases

lib/expr.ml

@@ -53,8 +53,8 @@ module Common = struct
 
   let unset l =
     match l with
-    | Types.FIELD (tbl, fld, ty) ->
-      Types.ASSIGN ((tbl, fld, (null ty)), Types.NULL (null ty))
+    | Types.FIELD ({ty; _} as f) ->
+      Types.ASSIGN ({f with ty = (null ty)}, Types.NULL (null ty))
     | _ -> invalid_arg "LHS of an unset must be a field"
 
   let (+) l r = Types.Common.ADD (Type.Numeric.Int, l, r)

lib/petrol.ml

@@ -9,7 +9,7 @@ module Type = struct
 end
 
 
-type table_name = Types.table_name
+type 'kind table_ref = 'kind Types.table_ref
 type ('ret_ty, 'query_kind) query = ('ret_ty, 'query_kind) Types.query
 
 
@@ -143,10 +143,10 @@ module StaticSchema = struct
         match table with
         | [] -> []
         | (field_name, field_ty, _) :: rest ->
-          ((Types.FIELD ((id, name), field_name,field_ty)) : _ Expr.t)
+          (Types.FIELD {table_name = name; name = field_name; ty = field_ty})
           :: to_table name rest in
     let table = to_table name tbl in
-    (id, name), table
+    Types.TABLE name, table
 
   let initialise tables (module DB: Caqti_lwt.CONNECTION) =
     let open Lwt_result.Syntax in
@@ -182,7 +182,7 @@ module VersionedSchema = struct
     tables: (int, wrapped_table) Hashtbl.t;
     migrations: (version * migration list) list;
     version_db: StaticSchema.t;
-    version_table_name: table_name;
+    version_table: [ `TABLE ] table_ref;
     version_table_field: string Expr.t;
   }
 
@@ -198,7 +198,7 @@ module VersionedSchema = struct
   let init ?(migrations=[]) version ~name =
     let migrations = order_by_version migrations in
     let version_db = StaticSchema.init () in
-    let version_table_name, Expr.[version_table_field] =
+    let version_table, Expr.[version_table_field] =
       StaticSchema.declare_table version_db ~name:("petrol_" ^ name ^ "_version_db") Schema.[
           field ~constraints:[primary_key (); not_null ()] "version" ~ty:Type.TEXT
         ] in
@@ -207,7 +207,7 @@ module VersionedSchema = struct
       tables=Hashtbl.create 10;
       migrations;
       version_db;
-      version_table_name; version_table_field;
+      version_table; version_table_field;
     }
 
   let declare_table t ?since ?(constraints : _ list =[]) ?(migrations=[]) ~name tbl =
@@ -220,22 +220,22 @@ module VersionedSchema = struct
         match table with
         | [] -> []
         | (field_name, field_ty, _) :: rest ->
-          ((Types.FIELD ((id, name), field_name,field_ty)) : _ Expr.t)
+          (Types.FIELD {table_name = name; name = field_name; ty = field_ty})
           :: to_table name rest in
     let table = to_table name tbl in
-    (id, name), table
+    Types.TABLE name, table
 
   let set_version t version con =
     let open Lwt_result.Syntax in
     let* () = StaticSchema.initialise t.version_db con in
     let version_str = String.concat "." (List.map Int.to_string version) in
     let (module DB: Caqti_lwt.CONNECTION) = con in
     let* () =
-      Query.delete ~from:t.version_table_name
+      Query.delete ~from:t.version_table
       |> Request.make_zero
       |> exec con in
     let* () =
-      Query.insert ~table:t.version_table_name
+      Query.insert ~table:t.version_table
         ~values:Expr.Common.[t.version_table_field := s version_str]
       |> Request.make_zero
       |> exec con in
@@ -245,7 +245,7 @@ module VersionedSchema = struct
     let open Lwt_result.Syntax in
     let* () = StaticSchema.initialise t.version_db con in
     let* res =
-      Query.select Expr.[t.version_table_field] ~from:t.version_table_name
+      Query.select Expr.[t.version_table_field] ~from:t.version_table
       |> Request.make_zero_or_one
       |> find_opt con in
     match res with

lib/petrol.mli

@@ -1,5 +1,9 @@
-type table_name
-(** Uniquely identifies a table in the system.  *)
+type 'kind table_ref
+(** Uniquely identifies a table or a subquery in the system.
+
+    - a [[` TABLE ] table_ref] references a physical table.
+    - a [[` SUBQUERY ] table_ref] references an aliased subquery (see
+      {!Query.as_}). *)
 
 module Expr : sig
 
@@ -871,7 +875,7 @@ module Schema : sig
     ?name:string ->
     ?on_update:foreign_conflict_clause ->
     ?on_delete:foreign_conflict_clause ->
-    table:table_name ->
+    table:([ `TABLE ] table_ref) ->
     columns:'a Expr.expr_list -> unit -> [ `Column ] constraint_
   (** [foreign_key ?name ?on_update ?on_delete ~table ~columns ()]
       returns a new SQL column constraint that specifies that the
@@ -888,7 +892,7 @@ module Schema : sig
     ?name:string ->
     ?on_update:foreign_conflict_clause ->
     ?on_delete:foreign_conflict_clause ->
-    table:table_name ->
+    table:([ `TABLE ] table_ref) ->
     columns:'a Expr.expr_list -> string list -> [ `Table ] constraint_
     (** [table_foreign_key ?name ?on_update ?on_delete ~table ~columns
         cols] returns a new SQL table constraint that specifies that the
@@ -940,8 +944,8 @@ module Query : sig
 
   type ('a, 'b, 'd, 'c) join_fun =
     ?op:join_op ->
-    on:bool Expr.t -> ('b, 'd) t -> ('c, 'a) t -> ('c, 'a) t
-    constraint 'a = [< `SELECT_CORE ] constraint 'd = [< `SELECT_CORE | `SELECT ]
+    on:bool Expr.t -> 'd table_ref -> ('c, 'a) t -> ('c, 'a) t
+    constraint 'a = [< `SELECT_CORE ] constraint 'd = [< `TABLE | `SUBQUERY ]
   (** [('a,'b,'c,'d) join_fun] defines the type of an SQL function
       that corresponds to SQL's JOIN clause.  *)
 
@@ -960,19 +964,19 @@ module Query : sig
       that corresponds to SQL's ON CONFLICT clause.  *)
 
   val select :
-    'a Expr.expr_list -> from:table_name -> ('a, [> `SELECT_CORE ]) t
+    'a Expr.expr_list -> from:([< `TABLE | `SUBQUERY ] table_ref) -> ('a, [> `SELECT_CORE ]) t
   (** [select fields ~from] corresponds to the SQL [SELECT {fields} FROM {from}]. *)
 
   val update :
-    table:table_name -> set:Expr.wrapped_assign list -> (unit, [> `UPDATE ]) t
+    table:([ `TABLE ] table_ref) -> set:Expr.wrapped_assign list -> (unit, [> `UPDATE ]) t
   (** [update ~table ~set] corresponds to the SQL [UPDATE {set} FROM {table}]. *)
 
   val insert :
-    table:table_name ->
+    table:([ `TABLE ] table_ref) ->
     values:Expr.wrapped_assign list -> (unit, [> `INSERT ]) t
   (** [insert ~table ~values] corresponds to the SQL [INSERT {values} INTO {table}]. *)
 
-  val delete : from:table_name -> (unit, [> `DELETE ]) t
+  val delete : from:[ `TABLE ] table_ref -> (unit, [> `DELETE ]) t
   (** [delete ~from] corresponds to the SQL [DELETE FROM {from}].  *)
 
   val where :
@@ -985,7 +989,7 @@ module Query : sig
   val having : ([< `SELECT | `SELECT_CORE ], 'c) having_fun
   (** [having fields expr] corresponds to the SQL [{expr} HAVING {fields}].  *)
 
-  val join : ([ `SELECT_CORE ], 'b, [< `SELECT_CORE | `SELECT ], 'c) join_fun
+  val join : ([ `SELECT_CORE ], 'b, [< `TABLE | `SUBQUERY ], 'c) join_fun
   (** [join ?op ~on oexpr expr] corresponds to the SQL [{expr} {op} JOIN {oexpr} ON {expr}].
 
       The ordering of the last two arguments has been chosen to allow
@@ -1027,6 +1031,16 @@ module Query : sig
       PostgreSQL since version 8.2 (2006-12-05), and by SQLite since version
       3.35.0 (2021-03-12). *)
 
+  val as_ :
+    name:string ->
+    ('a, [< `SELECT | `SELECT_CORE]) t ->
+    [ `SUBQUERY ] table_ref * 'a Expr.expr_list
+  (** [as_ ~name expr] corresponds to the SQL [{expr} AS {name}] where
+      [expr] must be a select query.
+
+      This function returns a table name and an expression list which can be
+      used in other select queries or join clauses. *)
+
 end
 
 module StaticSchema : sig
@@ -1052,7 +1066,7 @@ module StaticSchema : sig
 
   val declare_table : t ->
     ?constraints:[`Table] Schema.constraint_ list ->
-    name:string -> 'a Schema.table -> table_name * 'a Expr.expr_list
+    name:string -> 'a Schema.table -> [ `TABLE ] table_ref * 'a Expr.expr_list
   (** [declare_table t ?constraints ~name table_spec]
       declares a new table on the schema [t] with the name
       [name].
@@ -1112,7 +1126,7 @@ module VersionedSchema : sig
     ?since:version ->
     ?constraints:[`Table] Schema.constraint_ list ->
     ?migrations:(version * migration list) list ->
-    name:string -> 'a Schema.table -> table_name * 'a Expr.expr_list
+    name:string -> 'a Schema.table -> [ `TABLE ] table_ref * 'a Expr.expr_list
   (** [declare_table t ?since ?constraints ?migrations ~name table_spec]
       declares a new table on the schema [t] with the name
       [name].

lib/query.ml

@@ -19,7 +19,7 @@ type ('a,'c) having_fun =
 
 type ('a,'b,'d,'c) join_fun =
   ?op:Types.join_op -> on:bool Expr.t ->
-  ('b, [< `SELECT_CORE | `SELECT ] as 'd) t
+  ([< `TABLE | `SUBQUERY ] as 'd) Types.table_ref
   -> ('c, 'a) t -> ('c, 'a) t
   constraint 'a = ([< `SELECT_CORE]) as 'a
 
@@ -35,7 +35,6 @@ type ('a,'b,'c) on_conflict_fun =
   -> ('c, 'a) t
   constraint 'a = ([> `INSERT]) as 'a
 
-
 let query_values query = List.rev (Types.query_values [] query)
 
 let pp = Types.pp_query
@@ -110,8 +109,7 @@ let having : ('a,'c) having_fun =
   | Types.INSERT _ -> invalid_arg "group by only supported on select clause"
 
 let join : ('a,'b,'d,'c) join_fun =
-  fun ?(op=INNER) ~on (type a b c) (ot: (b, _) t)
-    (table : (c, a) t)  ->
+  fun ?(op=INNER) ~on (type a c) (ot: _ Types.table_ref) (table : (c, a) t) ->
     match table with
     | Types.SELECT_CORE { exprs; table; join; where; group_by; having } ->
       Types.SELECT_CORE {
@@ -127,7 +125,7 @@ let join : ('a,'b,'d,'c) join_fun =
     | Types.DELETE _ 
     | Types.UPDATE _ 
     | Types.INSERT _ ->
-      invalid_arg "group by only supported on select clause"
+      invalid_arg "join only supported on select clause"
 
 let on_err : 'a . [`ABORT | `FAIL | `IGNORE | `REPLACE | `ROLLBACK ] -> ('c, 'a) t -> ('c, 'a) t =
   fun on_err (type a) (table : (_, a) t) : (_, a) t ->
@@ -216,4 +214,27 @@ let returning :
   | Types.DELETE query -> DELETE { query with returning }
   | UPDATE query -> UPDATE { query with returning }
   | INSERT query -> INSERT { query with returning }
-  | SELECT_CORE _ | SELECT _ -> invalid_arg "returning not supported for select"
+  | SELECT_CORE _ | SELECT _ -> invalid_arg "returning not supported for select"
+
+let as_ :
+    'a 'b.
+    name:string ->
+    ('a, [< `SELECT | `SELECT_CORE ] as 'b) t ->
+    [ `SUBQUERY ] Types.table_ref * 'a Expr.expr_list =
+  fun (type a b) ~name (query : (a, b) t) : ([ `SUBQUERY ] Types.table_ref * a Expr.expr_list) ->
+  let rec update_fields : 'c. 'c Types.expr_list -> 'c Types.expr_list =
+    fun (type c) (exprs : c Types.expr_list) : c Types.expr_list ->
+    let open Types in
+    match exprs with
+    | [] -> []
+    | FIELD field :: exprs ->
+      FIELD {field with table_name = name} :: update_fields exprs
+    | e :: exprs -> e :: update_fields exprs
+  in
+  let exprs =
+    match query with
+    | SELECT_CORE {exprs; _} -> exprs
+    | SELECT {core = SELECT_CORE core; _} -> core.exprs
+    | UPDATE _ | INSERT _ | DELETE _ -> invalid_arg "as_ only supported for select"
+  in
+  Types.SUBQUERY (name, query), (update_fields exprs)

lib/schema.ml

@@ -1,4 +1,4 @@
-type table_name = Types.table_name
+type table_name = int * string
 
 type conflict_clause = [`ROLLBACK | `ABORT | `FAIL | `IGNORE | `REPLACE]
 type foreign_conflict_clause = [`SET_NULL | `SET_DEFAULT | `CASCADE | `RESTRICT | `NO_ACTION ]
@@ -23,7 +23,7 @@ type 'a sql_constraint =
   | ForeignKey of {
       local_columns: string list option;
       name: string option;
-      table: Types.table_name;
+      table: [ `TABLE ] Types.table_ref;
       columns: string list;
       on_update: foreign_conflict_clause option;
       on_delete: foreign_conflict_clause option;
@@ -116,7 +116,7 @@ let pp_sql_constraint fmt = function
            (pp_parens pp_column_list)
            vl)) local_columns
       (if Option.is_some name || Option.is_some local_columns then " " else "")
-      (snd table)
+      (Types.table_name table)
       (pp_parens pp_column_list) columns
       (pp_opt (fun fmt vl ->
          Format.fprintf fmt "ON UPDATE %a"
@@ -215,11 +215,11 @@ let table_unique ?name ?on_conflict columns : [`Table] sql_constraint =
     on_conflict;
   }
 
-let rec expr_list_to_column_names : 'a . Types.table_name -> 'a Expr.expr_list -> string list =
+let rec expr_list_to_column_names : 'a . string -> 'a Expr.expr_list -> string list =
   fun (type a) table_name (ls: a Types.expr_list) : string list ->
   match ls with
   | [] -> []
-  | Types.FIELD (table_name', name, _) :: t ->
+  | Types.FIELD {table_name = table_name'; name; _} :: t ->
     if not (table_name = table_name') then
       invalid_arg "foreign key constraint uses fields from a \
                    different table than the one specified";
@@ -229,21 +229,23 @@ let rec expr_list_to_column_names : 'a . Types.table_name -> 'a Expr.expr_list -
                  directly not derived expressions" 
 
 let foreign_key ?name ?on_update ?on_delete ~table ~columns () : [`Column] sql_constraint =
+  let table_name = Types.table_name table in
   ForeignKey {
     local_columns=None;
     name;
     table;
-    columns=expr_list_to_column_names table columns;
+    columns=expr_list_to_column_names table_name columns;
     on_update;
     on_delete;
   }
 
 let table_foreign_key ?name ?on_update ?on_delete ~table ~columns local_columns : [`Table] sql_constraint =
+  let table_name = Types.table_name table in
   ForeignKey {
     local_columns=Some local_columns;
     name;
     table;
-    columns=expr_list_to_column_names table columns;
+    columns=expr_list_to_column_names table_name columns;
     on_update;
     on_delete;
   }