This commit is contained in:
parent
aa2ff7b2f0
commit
2f3113f55d
11742 changed files with 1223940 additions and 0 deletions
|
|
@ -0,0 +1,100 @@
|
|||
(* Copyright (C) 2024--2025 Petter A. Urkedal <paurkedal@gmail.com>
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or modify it
|
||||
* under the terms of the GNU Lesser General Public License as published by
|
||||
* the Free Software Foundation, either version 3 of the License, or (at your
|
||||
* option) any later version, with the LGPL-3.0 Linking Exception.
|
||||
*
|
||||
* This library is distributed in the hope that it will be useful, but WITHOUT
|
||||
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
||||
* FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
|
||||
* License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public License
|
||||
* and the LGPL-3.0 Linking Exception along with this library. If not, see
|
||||
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
|
||||
*)
|
||||
|
||||
module Constructor = Constructor
|
||||
module Dialect = Dialect
|
||||
module Field_type = Field_type
|
||||
module Query = Query
|
||||
module Query_fmt = Query_fmt
|
||||
module Request = Request
|
||||
module Row_mult = Row_mult
|
||||
module Row_type = Row_type
|
||||
module Row = Row
|
||||
module Shims = Shims
|
||||
module Version = Version
|
||||
|
||||
module Type = struct
|
||||
include (Row_type : Row_type.STD)
|
||||
include Request_type.Infix
|
||||
end
|
||||
|
||||
module type CREATE = sig
|
||||
|
||||
module T = Type
|
||||
|
||||
module D = Dialect
|
||||
include module type of Version.Infix
|
||||
|
||||
module Q = Query
|
||||
module Qf = Query_fmt
|
||||
include module type of Query.Infix
|
||||
|
||||
val static :
|
||||
('a, 'b, 'm) Request_type.t -> string ->
|
||||
('a, 'b, 'm) Request.t
|
||||
|
||||
val static_gen :
|
||||
('a, 'b, 'm) Request_type.t -> (Dialect.t -> Query.t) ->
|
||||
('a, 'b, 'm) Request.t
|
||||
|
||||
val dynamic :
|
||||
('a, 'b, 'm) Request_type.t -> string ->
|
||||
('a, 'b, 'm) Request.t
|
||||
|
||||
val dynamic_gen :
|
||||
('a, 'b, 'm) Request_type.t -> (Dialect.t -> Query.t) ->
|
||||
('a, 'b, 'm) Request.t
|
||||
|
||||
val direct :
|
||||
('a, 'b, 'm) Request_type.t -> string ->
|
||||
('a, 'b, 'm) Request.t
|
||||
|
||||
val direct_gen :
|
||||
('a, 'b, 'm) Request_type.t -> (Dialect.t -> Query.t) ->
|
||||
('a, 'b, 'm) Request.t
|
||||
end
|
||||
|
||||
module Create = struct
|
||||
|
||||
module T = Type
|
||||
|
||||
module D = Dialect
|
||||
include Version.Infix
|
||||
|
||||
module Q = Query
|
||||
module Qf = Query_fmt
|
||||
include Query.Infix
|
||||
|
||||
let static req_type qs =
|
||||
Request.create Static req_type (Fun.const (Query.parse qs))
|
||||
|
||||
let static_gen req_type qf =
|
||||
Request.create Static req_type qf
|
||||
|
||||
let dynamic req_type qs =
|
||||
Request.create Dynamic req_type (Fun.const (Query.parse qs))
|
||||
|
||||
let dynamic_gen req_type qf =
|
||||
Request.create Dynamic req_type qf
|
||||
|
||||
let direct req_type qs =
|
||||
Request.create Direct req_type (Fun.const (Query.parse qs))
|
||||
|
||||
let direct_gen req_type qf =
|
||||
Request.create Direct req_type qf
|
||||
|
||||
end
|
||||
|
|
@ -0,0 +1,224 @@
|
|||
(* Copyright (C) 2024--2025 Petter A. Urkedal <paurkedal@gmail.com>
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or modify it
|
||||
* under the terms of the GNU Lesser General Public License as published by
|
||||
* the Free Software Foundation, either version 3 of the License, or (at your
|
||||
* option) any later version, with the LGPL-3.0 Linking Exception.
|
||||
*
|
||||
* This library is distributed in the hope that it will be useful, but WITHOUT
|
||||
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
||||
* FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
|
||||
* License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public License
|
||||
* and the LGPL-3.0 Linking Exception along with this library. If not, see
|
||||
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
|
||||
*)
|
||||
|
||||
[@@@alert caqti_unstable
|
||||
"This library is a preview; expect incompatible changes without prior notice."]
|
||||
|
||||
(** {2 Primitives}
|
||||
|
||||
These modules are part of the stable API, but the casual user may find it
|
||||
sufficient to use the {!Create} module. *)
|
||||
|
||||
(** {3 Prerequisities} *)
|
||||
|
||||
module Shims = Shims
|
||||
module Version = Version
|
||||
module Dialect = Dialect
|
||||
|
||||
(** {3 Data Types} *)
|
||||
|
||||
module Constructor = Constructor
|
||||
module Field_type = Field_type
|
||||
module Row_type = Row_type
|
||||
module Row_mult = Row_mult
|
||||
module Row = Row
|
||||
|
||||
module Type : sig
|
||||
include Row_type.STD
|
||||
include module type of Request_type.Infix
|
||||
end
|
||||
(** This module imports everything needed to describe a request type,
|
||||
including the parameter type, row type, and row multiplicity. *)
|
||||
|
||||
(** {3 Request Templates} *)
|
||||
|
||||
module Query = Query
|
||||
module Query_fmt = Query_fmt
|
||||
module Request = Request
|
||||
|
||||
(** {2 Convenience} *)
|
||||
|
||||
module type CREATE = sig
|
||||
(** This is a convenience API which collects everything needed to create
|
||||
{{!Caqti_template.Request} request templates}. A request template
|
||||
describes a database query and how to encode parameters and decode the
|
||||
result.
|
||||
|
||||
{1 Basic Usage}
|
||||
|
||||
Consider the example:
|
||||
{[
|
||||
let bounds_upto_req =
|
||||
let open Caqti_template.Create in
|
||||
static T.(t2 int32 float -->! option (t2 float float))
|
||||
"SELECT min(y), max(y) FROM samples WHERE series_id = ? AND x < ?"
|
||||
]}
|
||||
First we opening the current module.
|
||||
We then pick the function {!static} to create a template for prepared
|
||||
queries where the query template has static lifetime.
|
||||
The first argument describes the parameter type and the result row type
|
||||
combined with an arrow which describes the multiplicity of the result
|
||||
rows.
|
||||
The exclamation mark in the arrow indicates that precisely one result row
|
||||
is expected.
|
||||
The second argument is the query template, here in the form of a string.
|
||||
|
||||
In the query template, [?] refer to parameters, but you can also use the
|
||||
[PostgreSQL]-style [$1], [$2], etc. if you prefer, as long as you stick to
|
||||
the same convention for a given query template. Caqti drivers translate
|
||||
parameter references to fit the database system, rearranging parameters if
|
||||
necessary.
|
||||
|
||||
Caqti provides a way to handle dialectical differences between database
|
||||
systems apart from the parameter syntax.
|
||||
The example above uses a shortcut, since it does not need this
|
||||
functionality.
|
||||
In the full form it looks like:
|
||||
{[
|
||||
let bounds_upto_req =
|
||||
let open Caqti_template.Create in
|
||||
static_gen
|
||||
T.(t2 int32 float -->! option (t2 float float)) @@ Fun.const @@
|
||||
Q.parse
|
||||
"SELECT min(y), max(y) FROM samples WHERE series_id = ? AND x < ?"
|
||||
]}
|
||||
The callback receives a {!Dialect.t} and returns a {!Query.t}.
|
||||
We can now see that the still same query string is explicitly parsed.
|
||||
{!Query} and {!Query_fmt} provides alternative ways of constructing query
|
||||
template which is more suitable for dynamically generated queries.
|
||||
|
||||
The following example makes use of the dialect argument to handle
|
||||
dialectical differences regarding string concatenation:
|
||||
{[
|
||||
let concat_req =
|
||||
let open Caqti_template.Create in
|
||||
static_gen T.(t2 string string -->! string) @@ function
|
||||
| D.Mysql _ -> Q.parse "SELECT concat(?, ?)"
|
||||
| _ -> Q.parse "SELECT ? || ?"
|
||||
]}
|
||||
In summary
|
||||
|
||||
- Pick the main function according to the lifetime of prepared queries
|
||||
and whether to use the simplified or generic callback.
|
||||
- In the request type argument, the arrow decoration
|
||||
selects the expected multiplicity of result rows:
|
||||
[-->.] for zero, [-->!] for one, [-->?] for zero or one, [-->*] for
|
||||
zero or more.
|
||||
|
||||
{1 Supplementing}
|
||||
|
||||
If needed, you can supplement the current module with custom types:
|
||||
{[
|
||||
module Ct : sig
|
||||
open Caqti_template
|
||||
|
||||
include Caqti_template.CREATE
|
||||
|
||||
module T : sig
|
||||
include module type of T
|
||||
|
||||
val password : string Row_type.t
|
||||
val uri : Uri.t Row_type.t
|
||||
end
|
||||
end = struct
|
||||
open Caqti_template
|
||||
|
||||
include Caqti_template.Create
|
||||
|
||||
module T = struct
|
||||
include T
|
||||
|
||||
let password = redacted string (* a string redacted from logs *)
|
||||
|
||||
let uri =
|
||||
let encode x = Ok (Uri.to_string x) in
|
||||
let decode s = Ok (Uri.of_string s) in
|
||||
Row_type.custom ~encode ~decode string
|
||||
end
|
||||
end
|
||||
]}
|
||||
*)
|
||||
|
||||
(** {1 Reference} *)
|
||||
|
||||
(** {2 Type Descriptors} *)
|
||||
|
||||
module T = Type
|
||||
|
||||
(** {2 Dialect Descriptors} *)
|
||||
|
||||
module D = Dialect
|
||||
include module type of Version.Infix
|
||||
|
||||
(** {2 Query Templates} *)
|
||||
|
||||
module Q = Query
|
||||
module Qf = Query_fmt
|
||||
include module type of Query.Infix
|
||||
|
||||
(** {2 Request Templates}
|
||||
|
||||
The following are shortcuts for {!Request.create} and {!Query.parse}
|
||||
In particular {!static}, {!dynamic}, and {!direct} covers the most common
|
||||
case of sending a pre-composed query string to the database while the
|
||||
{!static_gen}, {!dynamic_gen}, and {!direct_gen} are the correspending
|
||||
fully generic variants. *)
|
||||
|
||||
val static :
|
||||
('a, 'b, 'm) Request_type.t -> string ->
|
||||
('a, 'b, 'm) Request.t
|
||||
(** Creates a template of static lifetime for prepared requests where the
|
||||
query template is provided as a string to be parsed by {!Query.parse}. *)
|
||||
|
||||
val static_gen :
|
||||
('a, 'b, 'm) Request_type.t -> (Dialect.t -> Query.t) ->
|
||||
('a, 'b, 'm) Request.t
|
||||
(** Creates a template of static lifetime for prepared requests where the
|
||||
query template is dialect-dependent and explicitly constructed by the
|
||||
caller. *)
|
||||
|
||||
val dynamic :
|
||||
('a, 'b, 'm) Request_type.t -> string ->
|
||||
('a, 'b, 'm) Request.t
|
||||
(** Creates a template of static lifetime for prepared requests where the
|
||||
query template is provided as a string to be parsed by {!Query.parse}. *)
|
||||
|
||||
val dynamic_gen :
|
||||
('a, 'b, 'm) Request_type.t -> (Dialect.t -> Query.t) ->
|
||||
('a, 'b, 'm) Request.t
|
||||
(** Creates a template of static lifetime for prepared requests where the
|
||||
query template is dialect-dependent and explicitly constructed by the
|
||||
caller. *)
|
||||
|
||||
val direct :
|
||||
('a, 'b, 'm) Request_type.t -> string ->
|
||||
('a, 'b, 'm) Request.t
|
||||
(** Creates a template for non-prepared requests where the query template is
|
||||
provided as a string to be parsed by {!Query.parse}.
|
||||
If non-prepared requests are not unsupported by the driver, a temporarily
|
||||
prepared request is used instead. *)
|
||||
|
||||
val direct_gen :
|
||||
('a, 'b, 'm) Request_type.t -> (Dialect.t -> Query.t) ->
|
||||
('a, 'b, 'm) Request.t
|
||||
(** Creates a template for non-prepared requests where the query template is
|
||||
dialect-dependent and explicitly constructed by the caller.
|
||||
If non-prepared requests are not unsupported by the driver, a temporarily
|
||||
prepared request is used instead. *)
|
||||
end
|
||||
|
||||
module Create : CREATE
|
||||
|
|
@ -0,0 +1,36 @@
|
|||
(* Copyright (C) 2025 Petter A. Urkedal <paurkedal@gmail.com>
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or modify it
|
||||
* under the terms of the GNU Lesser General Public License as published by
|
||||
* the Free Software Foundation, either version 3 of the License, or (at your
|
||||
* option) any later version, with the LGPL-3.0 Linking Exception.
|
||||
*
|
||||
* This library is distributed in the hope that it will be useful, but WITHOUT
|
||||
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
||||
* FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
|
||||
* License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public License
|
||||
* and the LGPL-3.0 Linking Exception along with this library. If not, see
|
||||
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
|
||||
*)
|
||||
|
||||
open Shims
|
||||
|
||||
type 'a return = ('a, string) result
|
||||
|
||||
type ('i, 'j) unifier =
|
||||
| Equal : ('i return, 'i return) unifier
|
||||
| Assume : (('a, 'b) Type.eq -> ('i, 'j) unifier) ->
|
||||
('a -> 'i, 'b -> 'j) unifier
|
||||
|
||||
type (_, _) tag = ..
|
||||
|
||||
type ('i, 'a) t = {
|
||||
tag: ('i, 'a) tag;
|
||||
unify_tag: 'j 'b. ('j, 'b) tag -> ('i, 'j) unifier option;
|
||||
construct: 'i;
|
||||
}
|
||||
|
||||
let unify : type i j a b. (i, a) t -> (j, b) t -> (i, j) unifier option =
|
||||
fun x y -> x.unify_tag y.tag
|
||||
|
|
@ -0,0 +1,165 @@
|
|||
(* Copyright (C) 2025 Petter A. Urkedal <paurkedal@gmail.com>
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or modify it
|
||||
* under the terms of the GNU Lesser General Public License as published by
|
||||
* the Free Software Foundation, either version 3 of the License, or (at your
|
||||
* option) any later version, with the LGPL-3.0 Linking Exception.
|
||||
*
|
||||
* This library is distributed in the hope that it will be useful, but WITHOUT
|
||||
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
||||
* FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
|
||||
* License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public License
|
||||
* and the LGPL-3.0 Linking Exception along with this library. If not, see
|
||||
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
|
||||
*)
|
||||
|
||||
(** Reified constructors for product row types.
|
||||
|
||||
Usage of this module is somewhat technical and only needed when defining
|
||||
type descriptors for custom {e parametric} types, or if, for some other
|
||||
reason, the type descriptor cannot be defined once statically.
|
||||
For statically defined types, {!Row_type.product} can generate a descriptor
|
||||
from the bare function.
|
||||
|
||||
This module bundles a bare constructor function with a fresh tag from an
|
||||
open GADT, used to identify it along with its type.
|
||||
The type may be parametric as long as parameters in the result type occurs
|
||||
in argument types.
|
||||
|
||||
As an example, consider the record type:
|
||||
{[
|
||||
type 'a acquired_value = {
|
||||
source: string;
|
||||
value: 'a;
|
||||
confidence: float;
|
||||
}
|
||||
]}
|
||||
A straight forward but not quite correct way to define a type descriptor for
|
||||
each parametric instance of this type constructor would be:
|
||||
{[
|
||||
open Caqti_template
|
||||
open Caqti_template.Shims
|
||||
|
||||
let acquired_value_rowtype value_rowtype =
|
||||
let open Row_type in
|
||||
product (fun source value confidence -> Ok {source; value; confidence})
|
||||
@@ proj string (fun {source; _} -> source)
|
||||
@@ proj value_rowtype (fun {value; _} -> value)
|
||||
@@ proj float (fun {confidence; _} -> confidence)
|
||||
@@ proj_end
|
||||
|
||||
let () =
|
||||
let t1 = acquired_value_rowtype Row_type.int in
|
||||
let t2 = acquired_value_rowtype Row_type.int in
|
||||
assert (Row_type.unify t1 t2 = None) (* Bad! *)
|
||||
]}
|
||||
The function [acquired_value_rowtype] is, however, generative; a fresh type
|
||||
descriptor is returned for each call, even for identical arguments.
|
||||
In particular, this means that {!Row_type.unify} will fail to unify two
|
||||
descriptors describing the same type, unless they are physically equal.
|
||||
|
||||
The correct way of defining this descriptor is to use {!Row_type.product'},
|
||||
which expects a constructor descriptor instead of a bare constructor
|
||||
function.
|
||||
This is the purpose of this module.
|
||||
To create the custom descriptor, first define a {!type-tag} with correct
|
||||
signature and a corresponding type-unifying equality predicate:
|
||||
{[
|
||||
type (_, _) Constructor.tag +=
|
||||
Acquired_value : (
|
||||
string -> 'a -> float -> 'a acquired_value Constructor.return,
|
||||
'a acquired_value
|
||||
) Constructor.tag
|
||||
|
||||
let acquired_value_constructor =
|
||||
let tag = Acquired_value in
|
||||
let unify_tag
|
||||
: type j b a. (j, b) Constructor.tag ->
|
||||
(string -> a -> float -> a acquired_value Constructor.return, j)
|
||||
Constructor.unifier option =
|
||||
(function
|
||||
| Acquired_value ->
|
||||
Some (Constructor.Assume (fun Type.Equal ->
|
||||
Constructor.Assume (fun Type.Equal ->
|
||||
Constructor.Assume (fun Type.Equal -> Constructor.Equal))))
|
||||
| _ -> None)
|
||||
in
|
||||
let construct source value confidence = Ok {source; value; confidence} in
|
||||
{Constructor.tag; unify_tag; construct}
|
||||
]}
|
||||
Our original attempt to define the descriptor can now be adjusted to support
|
||||
parametricity:
|
||||
{[
|
||||
let acquired_value_rowtype value_rowtype =
|
||||
let open Row_type in
|
||||
product' acquired_value_constructor
|
||||
@@ proj string (fun {source; _} -> source)
|
||||
@@ proj value_rowtype (fun {value; _} -> value)
|
||||
@@ proj float (fun {confidence; _} -> confidence)
|
||||
@@ proj_end
|
||||
|
||||
let () =
|
||||
let t1 = acquired_value_rowtype Row_type.int in
|
||||
let t2 = acquired_value_rowtype Row_type.int in
|
||||
assert (Row_type.unify t1 t2 <> None) (* Good! *)
|
||||
]} *)
|
||||
|
||||
open Shims
|
||||
|
||||
type 'a return = ('a, string) result
|
||||
(** The result type of a constructor function. *)
|
||||
|
||||
type ('i, 'j) unifier =
|
||||
| Equal : ('i return, 'i return) unifier
|
||||
| Assume : (('a, 'b) Type.eq -> ('i, 'j) unifier) ->
|
||||
('a -> 'i, 'b -> 'j) unifier (**)
|
||||
(** [('i, 'j) unifier] witness that two constructors of types [('i, _) t] and
|
||||
[('j, _) t] are equal, providing a dependent unification of ['i] and ['j] in
|
||||
the following sense:
|
||||
|
||||
- ['i] and ['j] are constrained by this definition to have the shape of a
|
||||
function which terminates in a {!result} type, like
|
||||
['a1 -> ... -> 'aN -> 'b return].
|
||||
- For each constructor argument, a node [Assume f] is provided, where [f]
|
||||
accepts an equality proof of the constructor argument and returns a
|
||||
proof of the remaining constructor type.
|
||||
- A final node [Equal] which, after resolving [Assume] nodes, witness that
|
||||
constructed values have the same type.
|
||||
|
||||
By constraining the return type to a non-abstract non-function type, we
|
||||
ensure that {!Equal}- and {!Assume}-patterns match disjoint types, so that
|
||||
we can refute {!Equal} patterns when the type in question is known to be a
|
||||
function type. *)
|
||||
|
||||
type (_, _) tag = ..
|
||||
(** [('a1 -> ... -> 'aN -> 'r return, 'r) tag] represents the type of a
|
||||
constructor which takes arguments of type ['a1], ..., ['aN] and returns
|
||||
values of type ['r].
|
||||
These tags is normally only passed around in the combination {!type-t}. *)
|
||||
|
||||
type ('i, 'a) t = {
|
||||
tag: ('i, 'a) tag;
|
||||
(** The constructor type. *)
|
||||
unify_tag: 'j 'b. ('j, 'b) tag -> ('i, 'j) unifier option;
|
||||
(** Unifying equality for the constructor type. *)
|
||||
construct: 'i;
|
||||
(** The bare constructor function. *)
|
||||
}
|
||||
(** [('a1 -> ... -> 'aN -> 'r return, 'r) t] represents a constructor which
|
||||
takes arguments of type ['a1], ..., ['aN] and constructs values of type
|
||||
['r]. The public record type is exposed to allow passing the {!unify_tag}
|
||||
field in a way which preserves universal quantification.
|
||||
|
||||
This type is only a reification of the constructor to allow comparison,
|
||||
disallowed for bare functions, and type unification.
|
||||
Ideally the {!field-construct} field is unique, while {!field-tag} and
|
||||
{!field-unify_tag} are implied by the type; the rest is technicalities which
|
||||
could be handle by a PPX or other kind of code generator. *)
|
||||
|
||||
val unify : ('i, 'a) t -> ('j, 'b) t -> ('i, 'j) unifier option
|
||||
(** [unify t t'] is [Some witness] if [t] and [t'] are equal, otherwise [None].
|
||||
In the former case, [witness] provides the unification of the result type of
|
||||
the construction, provided the unifications of each constructor argument
|
||||
type. *)
|
||||
|
|
@ -0,0 +1,33 @@
|
|||
(* Copyright (C) 2024 Petter A. Urkedal <paurkedal@gmail.com>
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or modify it
|
||||
* under the terms of the GNU Lesser General Public License as published by
|
||||
* the Free Software Foundation, either version 3 of the License, or (at your
|
||||
* option) any later version, with the LGPL-3.0 Linking Exception.
|
||||
*
|
||||
* This library is distributed in the hope that it will be useful, but WITHOUT
|
||||
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
||||
* FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
|
||||
* License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public License
|
||||
* and the LGPL-3.0 Linking Exception along with this library. If not, see
|
||||
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
|
||||
*)
|
||||
|
||||
type t = ..
|
||||
|
||||
type t +=
|
||||
| Pgsql of {
|
||||
server_version: Version.t;
|
||||
client_library: [`postgresql | `pgx];
|
||||
}
|
||||
| Mysql of {server_version: Version.t}
|
||||
| Sqlite of {server_version: Version.t}
|
||||
| Unknown of {purpose: [`Dummy | `Printing]}
|
||||
|
||||
let create_pgsql ~server_version ~client_library () =
|
||||
Pgsql {server_version; client_library}
|
||||
let create_mysql ~server_version () = Mysql {server_version}
|
||||
let create_sqlite ~server_version () = Sqlite {server_version}
|
||||
let create_unknown ~purpose () = Unknown {purpose}
|
||||
|
|
@ -0,0 +1,69 @@
|
|||
(* Copyright (C) 2024 Petter A. Urkedal <paurkedal@gmail.com>
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or modify it
|
||||
* under the terms of the GNU Lesser General Public License as published by
|
||||
* the Free Software Foundation, either version 3 of the License, or (at your
|
||||
* option) any later version, with the LGPL-3.0 Linking Exception.
|
||||
*
|
||||
* This library is distributed in the hope that it will be useful, but WITHOUT
|
||||
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
||||
* FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
|
||||
* License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public License
|
||||
* and the LGPL-3.0 Linking Exception along with this library. If not, see
|
||||
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
|
||||
*)
|
||||
|
||||
(** Identification of SQL Dialects and Related Information *)
|
||||
|
||||
type t = ..
|
||||
(** This type identifies the SQL dialect and other differences which may be
|
||||
relevant when composing query strings. This is an open type to allow future
|
||||
additions, either defined below or externally. Each case has the form of a
|
||||
constructor identifying the software which interprets the SQL code and its
|
||||
version number, if available, followed by any backend-specific details. *)
|
||||
|
||||
type t += private
|
||||
| Pgsql of {
|
||||
server_version: Version.t;
|
||||
(** The version number of the server, currently only available when using
|
||||
caqti-driver-postgresql. *)
|
||||
client_library: [`postgresql | `pgx];
|
||||
(** Which client library is being used to communicate with the server. *)
|
||||
}
|
||||
(** Identifies the backend as a PostgreSQL server. *)
|
||||
| Mysql of {
|
||||
server_version: Version.t;
|
||||
(** The version number of the server, but curretly unavailable, awaiting
|
||||
ocaml-mariadb support. *)
|
||||
}
|
||||
(** Identifies the backend as a MariaDB or MySQL server. No information is
|
||||
currently provided about the variant and version. *)
|
||||
| Sqlite of {
|
||||
server_version: Version.t;
|
||||
(** The version number of the Sqlite3 library. *)
|
||||
}
|
||||
(** Identifies the backend as an Sqlite3 library. *)
|
||||
| Unknown of {
|
||||
purpose: [`Dummy | `Printing];
|
||||
}
|
||||
(** The query is to be used for logging or other display purposes, and no
|
||||
information is been provided about a potential SQL backend. *)
|
||||
|
||||
(**/**)
|
||||
|
||||
val create_pgsql :
|
||||
server_version: Version.t ->
|
||||
client_library: [`postgresql | `pgx] ->
|
||||
unit -> t
|
||||
[@@alert caqti_private "Private function for used by Caqti drivers."]
|
||||
|
||||
val create_mysql : server_version: Version.t -> unit -> t
|
||||
[@@alert caqti_private "Private function for used by Caqti drivers."]
|
||||
|
||||
val create_sqlite : server_version: Version.t -> unit -> t
|
||||
[@@alert caqti_private "Private function for used by Caqti drivers."]
|
||||
|
||||
val create_unknown : purpose: [`Dummy | `Printing] -> unit -> t
|
||||
[@@alert caqti_private "Private function for used by Caqti drivers."]
|
||||
34
unikernel/duniverse/ocaml-caqti/caqti/lib-template/dune
Normal file
34
unikernel/duniverse/ocaml-caqti/caqti/lib-template/dune
Normal file
|
|
@ -0,0 +1,34 @@
|
|||
(library
|
||||
(name caqti_template)
|
||||
(public_name caqti.template)
|
||||
(libraries angstrom bigstringaf logs ptime uri))
|
||||
|
||||
(rule
|
||||
(target shims.mli)
|
||||
(deps shims.5.1.mli)
|
||||
(enabled_if (>= %{ocaml_version} 5.1))
|
||||
(action (copy# %{deps} %{target})))
|
||||
|
||||
(rule
|
||||
(target shims.ml)
|
||||
(deps shims.5.1.ml)
|
||||
(enabled_if (>= %{ocaml_version} 5.1))
|
||||
(action (copy# %{deps} %{target})))
|
||||
|
||||
(rule
|
||||
(target shims.mli)
|
||||
(deps shims.fallback.mli)
|
||||
(enabled_if (< %{ocaml_version} 5.1))
|
||||
(action (copy# %{deps} %{target})))
|
||||
|
||||
(rule
|
||||
(target shims.ml)
|
||||
(deps shims.fallback.ml)
|
||||
(enabled_if (< %{ocaml_version} 5.1))
|
||||
(action (copy# %{deps} %{target})))
|
||||
|
||||
(mdx
|
||||
(package caqti)
|
||||
(preludes mdx.prelude)
|
||||
(files :standard *.mli)
|
||||
(libraries caqti.template uri))
|
||||
108
unikernel/duniverse/ocaml-caqti/caqti/lib-template/field_type.ml
Normal file
108
unikernel/duniverse/ocaml-caqti/caqti/lib-template/field_type.ml
Normal file
|
|
@ -0,0 +1,108 @@
|
|||
(* Copyright (C) 2024 Petter A. Urkedal <paurkedal@gmail.com>
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or modify it
|
||||
* under the terms of the GNU Lesser General Public License as published by
|
||||
* the Free Software Foundation, either version 3 of the License, or (at your
|
||||
* option) any later version, with the LGPL-3.0 Linking Exception.
|
||||
*
|
||||
* This library is distributed in the hope that it will be useful, but WITHOUT
|
||||
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
||||
* FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
|
||||
* License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public License
|
||||
* and the LGPL-3.0 Linking Exception along with this library. If not, see
|
||||
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
|
||||
*)
|
||||
|
||||
open Shims
|
||||
|
||||
type 'a t =
|
||||
| Bool : bool t
|
||||
| Int : int t
|
||||
| Int16 : int t
|
||||
| Int32 : int32 t
|
||||
| Int64 : int64 t
|
||||
| Float : float t
|
||||
| String : string t
|
||||
| Octets : string t
|
||||
| Pdate : Ptime.t t
|
||||
| Ptime : Ptime.t t
|
||||
| Ptime_span : Ptime.span t
|
||||
| Enum : string -> string t
|
||||
|
||||
let unify : type a b. a t -> b t -> (a, b) Type.eq option =
|
||||
fun ft1 ft2 ->
|
||||
(match ft1, ft2 with
|
||||
| Bool, Bool -> Some Equal
|
||||
| Bool, _ | _, Bool -> None
|
||||
| Int, Int -> Some Equal
|
||||
| Int, _ | _, Int -> None
|
||||
| Int16, Int16 -> Some Equal
|
||||
| Int16, _ | _, Int16 -> None
|
||||
| Int32, Int32 -> Some Equal
|
||||
| Int32, _ | _, Int32 -> None
|
||||
| Int64, Int64 -> Some Equal
|
||||
| Int64, _ | _, Int64 -> None
|
||||
| Float, Float -> Some Equal
|
||||
| Float, _ | _, Float -> None
|
||||
| String, String -> Some Equal
|
||||
| String, _ | _, String -> None
|
||||
| Octets, Octets -> Some Equal
|
||||
| Octets, _ | _, Octets -> None
|
||||
| Pdate, Pdate -> Some Equal
|
||||
| Pdate, _ | _, Pdate -> None
|
||||
| Ptime, Ptime -> Some Equal
|
||||
| Ptime, _ | _, Ptime -> None
|
||||
| Ptime_span, Ptime_span -> Some Equal
|
||||
| Ptime_span, _ | _, Ptime_span -> None
|
||||
| Enum name1, Enum name2 when name1 = name2 -> Some Equal
|
||||
| Enum _, Enum _ -> None)
|
||||
|
||||
let equal_value : type a. a t -> a -> a -> bool = function
|
||||
| Bool -> Bool.equal
|
||||
| Int -> Int.equal
|
||||
| Int16 -> Int.equal
|
||||
| Int32 -> Int32.equal
|
||||
| Int64 -> Int64.equal
|
||||
| Float -> Float.equal
|
||||
| String -> String.equal
|
||||
| Octets -> String.equal
|
||||
| Pdate -> Ptime.equal
|
||||
| Ptime -> Ptime.equal
|
||||
| Ptime_span -> Ptime.Span.equal
|
||||
| Enum _ -> String.equal
|
||||
|
||||
let to_string : type a. a t -> string = function
|
||||
| Bool -> "bool"
|
||||
| Int -> "int"
|
||||
| Int16 -> "int16"
|
||||
| Int32 -> "int32"
|
||||
| Int64 -> "int64"
|
||||
| Float -> "float"
|
||||
| String -> "string"
|
||||
| Octets -> "octets"
|
||||
| Pdate -> "pdate"
|
||||
| Ptime -> "ptime"
|
||||
| Ptime_span -> "ptime_span"
|
||||
| Enum name -> name
|
||||
|
||||
let pp ppf ft = Format.pp_print_string ppf (to_string ft)
|
||||
|
||||
let pp_ptime = Ptime.pp_rfc3339 ~tz_offset_s:0 ~space:false ()
|
||||
|
||||
let pp_value : type a. _ -> a t * a -> unit = fun ppf -> function
|
||||
| Bool, x -> Format.pp_print_bool ppf x
|
||||
| Int, x -> Format.pp_print_int ppf x
|
||||
| Int16, x -> Format.pp_print_int ppf x
|
||||
| Int32, x -> Format.fprintf ppf "%ldl" x
|
||||
| Int64, x -> Format.fprintf ppf "%LdL" x
|
||||
| Float, x -> Format.fprintf ppf "%F" x
|
||||
| String, x -> Format.fprintf ppf "%S" x
|
||||
| Octets, x -> Format.fprintf ppf "%S" x
|
||||
| Pdate, x ->
|
||||
let y, m, d = Ptime.to_date x in
|
||||
Format.fprintf ppf "%d-%02d-%02d" y m d
|
||||
| Ptime, x -> pp_ptime ppf x
|
||||
| Ptime_span, x -> Ptime.Span.pp ppf x
|
||||
| Enum _, x -> Format.pp_print_string ppf x
|
||||
|
|
@ -0,0 +1,44 @@
|
|||
(* Copyright (C) 2024 Petter A. Urkedal <paurkedal@gmail.com>
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or modify it
|
||||
* under the terms of the GNU Lesser General Public License as published by
|
||||
* the Free Software Foundation, either version 3 of the License, or (at your
|
||||
* option) any later version, with the LGPL-3.0 Linking Exception.
|
||||
*
|
||||
* This library is distributed in the hope that it will be useful, but WITHOUT
|
||||
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
||||
* FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
|
||||
* License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public License
|
||||
* and the LGPL-3.0 Linking Exception along with this library. If not, see
|
||||
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
|
||||
*)
|
||||
|
||||
(** Database field types. *)
|
||||
|
||||
open Shims
|
||||
|
||||
type 'a t =
|
||||
| Bool : bool t
|
||||
| Int : int t
|
||||
| Int16 : int t
|
||||
| Int32 : int32 t
|
||||
| Int64 : int64 t
|
||||
| Float : float t
|
||||
| String : string t
|
||||
| Octets : string t
|
||||
| Pdate : Ptime.t t
|
||||
| Ptime : Ptime.t t
|
||||
| Ptime_span : Ptime.span t
|
||||
| Enum : string -> string t
|
||||
|
||||
val unify : 'a t -> 'b t -> ('a, 'b) Type.eq option
|
||||
|
||||
val equal_value : 'a t -> 'a -> 'a -> bool
|
||||
|
||||
val to_string : 'a t -> string
|
||||
|
||||
val pp : Format.formatter -> 'a t -> unit
|
||||
|
||||
val pp_value : Format.formatter -> 'a t * 'a -> unit
|
||||
|
|
@ -0,0 +1 @@
|
|||
[@@@alert "-caqti_unstable"]
|
||||
393
unikernel/duniverse/ocaml-caqti/caqti/lib-template/query.ml
Normal file
393
unikernel/duniverse/ocaml-caqti/caqti/lib-template/query.ml
Normal file
|
|
@ -0,0 +1,393 @@
|
|||
(* Copyright (C) 2019--2025 Petter A. Urkedal <paurkedal@gmail.com>
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or modify it
|
||||
* under the terms of the GNU Lesser General Public License as published by
|
||||
* the Free Software Foundation, either version 3 of the License, or (at your
|
||||
* option) any later version, with the LGPL-3.0 Linking Exception.
|
||||
*
|
||||
* This library is distributed in the hope that it will be useful, but WITHOUT
|
||||
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
||||
* FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
|
||||
* License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public License
|
||||
* and the LGPL-3.0 Linking Exception along with this library. If not, see
|
||||
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
|
||||
*)
|
||||
|
||||
open Shims
|
||||
|
||||
module Private = struct
|
||||
type t =
|
||||
| L of string
|
||||
| V : 'a Field_type.t * 'a -> t
|
||||
| Q of string
|
||||
| P of int
|
||||
| E of string
|
||||
| S of t list
|
||||
end
|
||||
open Private
|
||||
|
||||
type t = Private.t
|
||||
|
||||
let empty = S []
|
||||
let lit frag = L frag
|
||||
let quote str = Q str
|
||||
let param i = P i
|
||||
let var v = E v
|
||||
|
||||
let cat q1 q2 =
|
||||
(match q1, q2 with
|
||||
| S [], qs | qs, S [] -> qs
|
||||
| S qs1, S qs2 -> S (List.append qs1 qs2)
|
||||
| S qs1, q2 -> S (List.append qs1 [q2])
|
||||
| q1, S qs2 -> S (q1 :: qs2)
|
||||
| q1, q2 -> S [q1; q2])
|
||||
|
||||
let concat =
|
||||
let rec loop pfx acc = function
|
||||
| [] -> acc
|
||||
| q :: qs -> loop pfx (pfx :: q :: acc) qs
|
||||
in
|
||||
fun ?sep qs ->
|
||||
(match sep, qs with
|
||||
| _, [] -> S []
|
||||
| None, _ -> S qs
|
||||
| Some sep, q :: qs -> S (q :: loop (L sep) [] (List.rev qs)))
|
||||
|
||||
let parens q = concat [lit "("; q; lit ")"]
|
||||
|
||||
let bool x = V (Field_type.Bool, x)
|
||||
let int x = V (Field_type.Int, x)
|
||||
let int16 x = V (Field_type.Int16, x)
|
||||
let int32 x = V (Field_type.Int32, x)
|
||||
let int64 x = V (Field_type.Int64, x)
|
||||
let float x = V (Field_type.Float, x)
|
||||
let string x = V (Field_type.String, x)
|
||||
let octets x = V (Field_type.Octets, x)
|
||||
let pdate x = V (Field_type.Pdate, x)
|
||||
let ptime x = V (Field_type.Ptime, x)
|
||||
let ptime_span x = V (Field_type.Ptime_span, x)
|
||||
let const t v = V (t, v)
|
||||
|
||||
let rec const_fields_opt : type a. a Row_type.t -> a option -> t list =
|
||||
(function
|
||||
| Field ft ->
|
||||
(function None -> [L "NULL"] | Some x -> [V (ft, x)])
|
||||
| Option t ->
|
||||
let of_t = const_fields_opt t in
|
||||
(function None -> of_t None | Some x -> of_t x)
|
||||
| Product (_, pt) ->
|
||||
const_fields_opt_of_product pt
|
||||
| Annot (_, t) ->
|
||||
const_fields_opt t)
|
||||
and const_fields_opt_of_product
|
||||
: type i a. (i, a) Row_type.product -> a option -> t list =
|
||||
(function
|
||||
| Proj_end -> fun _ -> []
|
||||
| Proj (t, p, pt) ->
|
||||
let of_t = const_fields_opt t in
|
||||
let of_pt = const_fields_opt_of_product pt in
|
||||
fun x -> of_t (Option.map p x) @ of_pt x)
|
||||
|
||||
let const_fields (t : _ Row_type.t) =
|
||||
let f = const_fields_opt t in
|
||||
fun x -> f (Some x)
|
||||
|
||||
let rec equal_list f xs ys = (* stdlib 4.12.0 *)
|
||||
(match xs, ys with
|
||||
| [], [] -> true
|
||||
| x :: xs', y :: ys' -> f x y && equal_list f xs' ys'
|
||||
| [], _ :: _ | _ :: _, [] -> false)
|
||||
|
||||
let normal =
|
||||
let rec collect acc = function
|
||||
| [] -> List.rev acc
|
||||
| ((L"" | S[]) :: qs) -> collect acc qs
|
||||
| ((P _ | V _ | Q _ | E _ as q) :: qs) -> collect (q :: acc) qs
|
||||
| (S (q' :: qs') :: qs) -> collect acc (q' :: S qs' :: qs)
|
||||
| (L s :: qs) -> collectL acc [s] qs
|
||||
and collectL acc accL = function
|
||||
| ((L"" | S[]) :: qs) -> collectL acc accL qs
|
||||
| (L s :: qs) -> collectL acc (s :: accL) qs
|
||||
| (S (q' :: qs') :: qs) -> collectL acc accL (q' :: S qs' :: qs)
|
||||
| [] | ((P _ | V _ | Q _ | E _) :: _) as qs ->
|
||||
collect (L (String.concat "" (List.rev accL)) :: acc) qs
|
||||
in
|
||||
fun q ->
|
||||
(match collect [] [q] with
|
||||
| [] -> S[]
|
||||
| [q] -> q
|
||||
| qs -> S qs)
|
||||
|
||||
let rec equal t1 t2 =
|
||||
(match t1, t2 with
|
||||
| L s1, L s2 -> String.equal s1 s2
|
||||
| V (t1, v1), V (t2, v2) ->
|
||||
(match Field_type.unify t1 t2 with
|
||||
| None -> false
|
||||
| Some Type.Equal -> Field_type.equal_value t1 v1 v2)
|
||||
| Q s1, Q s2 -> String.equal s1 s2
|
||||
| P i1, P i2 -> Int.equal i1 i2
|
||||
| E n1, E n2 -> String.equal n1 n2
|
||||
| S ts1, S ts2 -> equal_list equal ts1 ts2
|
||||
| V _, _ -> false
|
||||
| L _, _ -> false
|
||||
| Q _, _ -> false
|
||||
| P _, _ -> false
|
||||
| E _, _ -> false
|
||||
| S _, _ -> false)
|
||||
|
||||
let hash = Hashtbl.hash
|
||||
|
||||
let rec pp ppf = function
|
||||
| L s -> Format.pp_print_string ppf s
|
||||
| V (t, v) -> Field_type.pp_value ppf (t, v)
|
||||
| Q s ->
|
||||
(* Using non-SQL quoting, to avoid issues with newlines and other control
|
||||
* characters when printing to log files. *)
|
||||
Format.pp_print_string ppf "E'";
|
||||
for i = 0 to String.length s - 1 do
|
||||
(match s.[i] with
|
||||
| '\\' -> Format.pp_print_string ppf {|\\|}
|
||||
| '\'' -> Format.pp_print_string ppf {|\'|}
|
||||
| '\t' -> Format.pp_print_string ppf {|\t|}
|
||||
| '\n' -> Format.pp_print_string ppf {|\n|}
|
||||
| '\r' -> Format.pp_print_string ppf {|\r|}
|
||||
| '\x00'..'\x1f' as c -> Format.fprintf ppf {|\x%02x|} (Char.code c)
|
||||
| _ -> Format.pp_print_char ppf s.[i])
|
||||
done;
|
||||
Format.pp_print_char ppf '\''
|
||||
| P n -> Format.pp_print_char ppf '$'; Format.pp_print_int ppf (n + 1)
|
||||
| E n -> Format.fprintf ppf "$(%s)" n
|
||||
| S qs -> List.iter (pp ppf) qs
|
||||
|
||||
let show q =
|
||||
let buf = Buffer.create 512 in
|
||||
let ppf = Format.formatter_of_buffer buf in
|
||||
pp ppf q; Format.pp_print_flush ppf ();
|
||||
Buffer.contents buf
|
||||
|
||||
module Expand_error = struct
|
||||
|
||||
type nonrec t = {
|
||||
query: t;
|
||||
var: string;
|
||||
reason: [`Undefined | `Invalid of t];
|
||||
}
|
||||
|
||||
let pp ppf {query; var; reason} =
|
||||
let open Format in
|
||||
(match reason with
|
||||
| `Undefined ->
|
||||
fprintf ppf "Undefined variable %s in query %a" var pp query
|
||||
| `Invalid expansion ->
|
||||
fprintf ppf
|
||||
"While expanding %a, lookup of %s gives %a, which is invalid \
|
||||
because it contains an environment or parameter reference."
|
||||
pp query var pp expansion)
|
||||
end
|
||||
|
||||
exception Expand_error of Expand_error.t
|
||||
|
||||
type subst = string -> t
|
||||
|
||||
let expand ?(final = false) f query =
|
||||
let rec is_valid = function
|
||||
| L _ | V _ | Q _ -> true
|
||||
| P _ | E _ -> false
|
||||
| S qs -> List.for_all is_valid qs
|
||||
in
|
||||
let rec recurse = function
|
||||
| L _ | V _ | Q _ | P _ as q -> q
|
||||
| E var as q ->
|
||||
let not_found () =
|
||||
if not final then q else
|
||||
raise (Expand_error {query; var; reason = `Undefined})
|
||||
in
|
||||
(match f var with
|
||||
| q' ->
|
||||
if is_valid q' then q' else
|
||||
raise (Expand_error {query; var; reason = `Invalid q'})
|
||||
| exception Not_found ->
|
||||
let l = String.length var in
|
||||
if l > 0 && var.[l - 1] = '.' then
|
||||
(match f (String.sub var 0 (l - 1)) with
|
||||
| frag ->
|
||||
(match normal frag with
|
||||
| S[] as q' -> q'
|
||||
| q' -> S[q'; L"."])
|
||||
| exception Not_found -> not_found ())
|
||||
else
|
||||
not_found ())
|
||||
| S qs -> S (List.map recurse qs)
|
||||
in
|
||||
recurse query
|
||||
|
||||
module Angstrom_parsers = struct
|
||||
open Angstrom
|
||||
|
||||
let failf = Printf.ksprintf fail
|
||||
let ign p = p >>| fun _ -> ()
|
||||
|
||||
let is_digit = function '0'..'9' -> true | _ -> false
|
||||
let is_digit_nz = function '1'..'9' -> true | _ -> false
|
||||
let is_idrfst = function 'a'..'z'|'A'..'Z' | '_' -> true | _ -> false
|
||||
let is_idrcnt = function 'a'..'z'|'A'..'Z' | '_' | '0'..'9' -> true | _ -> false
|
||||
let is_space = function ' ' | '\t' | '\n' | '\r' -> true | _ -> false
|
||||
|
||||
let single_quoted = skip_many (ign (not_char '\'') <|> ign (string "''"))
|
||||
let double_quoted = skip_many (ign (not_char '"') <|> ign (string "\"\""))
|
||||
|
||||
let tagged_quote_cont =
|
||||
consumed (skip is_idrfst *> skip_while is_idrcnt) <* char '$' >>= fun tag ->
|
||||
many_till any_char (char '$' *> string tag <* char '$') >>| (fun _ -> ())
|
||||
|
||||
let verbatim =
|
||||
let fragment = any_char >>= function
|
||||
| '\'' -> single_quoted <* char '\''
|
||||
| '"' -> double_quoted <* char '"'
|
||||
| '`' -> skip_many (not_char '`') <* char '`'
|
||||
| '-' ->
|
||||
(peek_char >>= function
|
||||
| Some '-' -> skip_while ((<>) '\n') <* char '\n'
|
||||
| _ -> return ())
|
||||
| '$' -> tagged_quote_cont
|
||||
| '?' | ';' as c -> failf "%C is not valid here" c
|
||||
| _ -> return ()
|
||||
in
|
||||
consumed (many1 fragment) >>| (fun s -> (L s))
|
||||
|
||||
let skip_idr = skip is_idrfst *> skip_while is_idrcnt
|
||||
let identifier_dot = consumed (skip_idr *> char '.')
|
||||
let identifier_dotopt = consumed (option () skip_idr *> option ' ' (char '.'))
|
||||
let parameter_number = consumed (skip is_digit_nz *> skip_while is_digit)
|
||||
|
||||
let lookup =
|
||||
choice ~failure_msg:"invalid environment lookup" [
|
||||
string "$(" *> identifier_dotopt <* char ')' >>| (fun v -> E v);
|
||||
string "$." >>| (fun _ -> E ".");
|
||||
char '$' *> identifier_dot >>| (fun v -> E v);
|
||||
]
|
||||
|
||||
let untagged_quote =
|
||||
let nonlookup =
|
||||
consumed (many1 (satisfy (function '$' -> false | _ -> true)))
|
||||
>>| (fun s -> (L s))
|
||||
in
|
||||
string "$$" *> many_till (lookup <|> nonlookup) (string "$$") >>| fun qs ->
|
||||
normal (S ([L "$$"] @ qs @ [L "$$"]))
|
||||
|
||||
let atom =
|
||||
peek_char_fail >>= function
|
||||
| '$' ->
|
||||
choice ~failure_msg:"invalid dollar sequence" [
|
||||
char '$' *> parameter_number >>| (fun iP -> P (int_of_string iP - 1));
|
||||
lookup;
|
||||
untagged_quote;
|
||||
verbatim;
|
||||
]
|
||||
| '?' ->
|
||||
let valid_lookahead = peek_char >>= function
|
||||
| Some ':' ->
|
||||
(peek_string 2 >>= function
|
||||
| "::" -> return ()
|
||||
| _ -> fail "':' is not allowed after parameter reference '?'")
|
||||
| Some ('A'..'Z' | 'a'..'z' | '0'..'9' | '_'
|
||||
| '!' | '"' | '#' | '$' | '%' | '&' | '\'' | '.'
|
||||
| '<' | '=' | '>' | '?' | '@' | '^' | '`' | '|' | '~' as c) ->
|
||||
failf "%C is not allowed after parameter reference '?'" c
|
||||
| None | Some _ ->
|
||||
return ()
|
||||
in
|
||||
char '?' >>| (fun _ -> P (-1)) <* valid_lookahead
|
||||
| _ ->
|
||||
verbatim
|
||||
|
||||
let atom_or_semi = (char ';' >>| fun _ -> L";") <|> atom
|
||||
|
||||
let reindex atoms =
|
||||
if List.for_all (function P (-1) -> false | _ -> true) atoms then
|
||||
return atoms
|
||||
else
|
||||
let rec loop iP acc = function
|
||||
| [] -> return (List.rev acc)
|
||||
| P (-1) :: frags -> loop (iP + 1) (P iP :: acc) frags
|
||||
| P _ :: _ -> fail "Inconsistent parameter style."
|
||||
| frag :: frags -> loop iP (frag :: acc) frags
|
||||
in
|
||||
loop 0 [] atoms
|
||||
|
||||
let expression =
|
||||
let stop =
|
||||
peek_char >>= function
|
||||
| None | Some ';' -> return ()
|
||||
| _ -> fail "unterminated"
|
||||
in
|
||||
fix (fun p -> (stop *> return []) <|> (List.cons <$> atom <*> p))
|
||||
>>= reindex >>| (function [q] -> q | qs -> S qs)
|
||||
|
||||
let expression_with_semi =
|
||||
let stop =
|
||||
peek_char >>= function
|
||||
| None -> return ()
|
||||
| _ -> fail "unterminated"
|
||||
in
|
||||
fix (fun p -> (stop *> return []) <|> (List.cons <$> atom_or_semi <*> p))
|
||||
>>= reindex >>| (function [q] -> q | qs -> S qs)
|
||||
|
||||
let expression_list =
|
||||
let white =
|
||||
many (take_while1 is_space <|> (string "--" *> take_till ((=) '\n')))
|
||||
<* commit
|
||||
in
|
||||
white *> many (expression <* char ';' <* white)
|
||||
end
|
||||
|
||||
let angstrom_parser = Angstrom_parsers.expression
|
||||
let angstrom_parser_with_semicolon = Angstrom_parsers.expression_with_semi
|
||||
let angstrom_list_parser = Angstrom_parsers.expression_list
|
||||
|
||||
module Parse_error = struct
|
||||
type t = {
|
||||
position: int;
|
||||
message: string;
|
||||
}
|
||||
|
||||
let create position message = {position; message}
|
||||
|
||||
let position err = err.position
|
||||
let message err = err.message
|
||||
|
||||
let pp ppf err =
|
||||
Format.fprintf ppf "Parse error at byte %d: %s" err.position err.message
|
||||
end
|
||||
|
||||
exception Parse_error of Parse_error.t
|
||||
|
||||
let parse_result s =
|
||||
let open Angstrom.Unbuffered in
|
||||
(match parse angstrom_parser_with_semicolon with
|
||||
| Partial {committed = 0; continue} ->
|
||||
let len = String.length s in
|
||||
let bs = Bigstringaf.of_string ~off:0 ~len s in
|
||||
(match continue bs ~off:0 ~len Complete with
|
||||
| Done (committed, q) when committed = len -> Ok q
|
||||
| Done (committed, _) | Partial {committed; _} ->
|
||||
let msg = "Expression cannot contain semicolon." in
|
||||
Error (Parse_error.create committed msg)
|
||||
| Fail (committed, _, msg) ->
|
||||
Error (Parse_error.create committed msg))
|
||||
| Partial _ | Done _ | Fail _ ->
|
||||
assert false)
|
||||
|
||||
let parse s =
|
||||
(match parse_result s with
|
||||
| Ok q -> q
|
||||
| Error err -> raise (Parse_error err))
|
||||
|
||||
module Infix = struct
|
||||
let (@++) = cat
|
||||
let (^++) pfx q = cat (lit pfx) q
|
||||
let (++^) q sfx = cat q (lit sfx)
|
||||
end
|
||||
285
unikernel/duniverse/ocaml-caqti/caqti/lib-template/query.mli
Normal file
285
unikernel/duniverse/ocaml-caqti/caqti/lib-template/query.mli
Normal file
|
|
@ -0,0 +1,285 @@
|
|||
(* Copyright (C) 2019--2025 Petter A. Urkedal <paurkedal@gmail.com>
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or modify it
|
||||
* under the terms of the GNU Lesser General Public License as published by
|
||||
* the Free Software Foundation, either version 3 of the License, or (at your
|
||||
* option) any later version, with the LGPL-3.0 Linking Exception.
|
||||
*
|
||||
* This library is distributed in the hope that it will be useful, but WITHOUT
|
||||
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
||||
* FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
|
||||
* License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public License
|
||||
* and the LGPL-3.0 Linking Exception along with this library. If not, see
|
||||
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
|
||||
*)
|
||||
|
||||
(** This module provides templating of database query strings. It helps
|
||||
mitigate differences between database systems, and provides additional
|
||||
functionality such as variable substitution and safe embedding of values.
|
||||
The representation is also suited for dynamic construction.
|
||||
|
||||
There are three ways to construct a template:
|
||||
|
||||
- Using the parser ({!parse}, {!parse_result}, etc.) if the query template
|
||||
is known at compile time.
|
||||
|
||||
- Using the {{!query_construction} constructors} of the current module.
|
||||
|
||||
- Using the {!Query_fmt} module, which provides an alternative to the
|
||||
previous option. *)
|
||||
|
||||
(**/**)
|
||||
module Private : sig
|
||||
type t =
|
||||
| L of string
|
||||
| V : 'a Field_type.t * 'a -> t
|
||||
| Q of string
|
||||
| P of int
|
||||
| E of string
|
||||
| S of t list
|
||||
end [@@alert caqti_private]
|
||||
(**/**)
|
||||
|
||||
type t = Private.t [@@alert "-caqti_private"]
|
||||
(** [t] is an intermediate representation of a query string to be send to a
|
||||
database, possibly combined with some hidden parameters used to safely embed
|
||||
values. Apart from embedding values, this representation provides indexed
|
||||
parameter references, independent of the target database system. For
|
||||
databases which use linear parameter references (like [?] for MariaDB), the
|
||||
driver will reshuffle, elide, and duplicate parameters as needed. *)
|
||||
|
||||
(** {2:query_construction Construction} *)
|
||||
|
||||
val empty : t
|
||||
(** [empty] is the empty query fragment; i.e. it expands to nothing. *)
|
||||
|
||||
val lit : string -> t
|
||||
(** [lit frag] expands to [frag], literally; i.e. the argument is passed
|
||||
unchanged to the database system as a substring of the query.
|
||||
Do not use this to inject untrusted data into the query string, since it can
|
||||
lead to an SQL injection vulnerability.
|
||||
Even when it can be done safely, it is probably easier and more portable to
|
||||
use the appropriate function from {!embeddingvalues} or the {!quote}
|
||||
function. *)
|
||||
|
||||
val quote : string -> t
|
||||
(** [quote str] expands to the literally quoted string [str] if an reliable
|
||||
escape function is available from the driver library, otherwise [quote] is
|
||||
equivalent to {!string}. *)
|
||||
|
||||
val param : int -> t
|
||||
(** [param i] expands to a reference to parameter number [i], counting from
|
||||
zero. That is, [param 0] expands to ["$1"] for PostgreSQL and to ["?1"] for
|
||||
SQLite3. For MariaDB, [param i] expands to ["?"] for any [i]; the driver
|
||||
will instead shuffle, elide, and duplicate the actual arguments to match
|
||||
their order of reference in the query string. *)
|
||||
|
||||
val var : string -> t
|
||||
(** [var v] expands to [subst v] where [subst] is the substitution function
|
||||
passed to {!expand} or one of the connector functions. *)
|
||||
|
||||
val concat : ?sep: string -> t list -> t
|
||||
(** [concat ?sep frags] concatenates [frags], optionally separated by [sep].
|
||||
Returns the empty fragment on the empty list of fragments. *)
|
||||
|
||||
val parens : t -> t
|
||||
(** [parens frag] wraps [frag] in paranthesis *)
|
||||
|
||||
val cat : t -> t -> t
|
||||
(** [cat q1 q2] expands to the juxtaposition of the expansions of [q1] followed
|
||||
by [q2]. This is an associative alternative to {!concat} when no separator
|
||||
is needed. *)
|
||||
|
||||
module Infix : sig
|
||||
(** This module provides a terser way to compose queries. As an example,
|
||||
consider the dynamic construction of a simple SELECT-request which
|
||||
extracts a list of named columns given a corresponding row type, and where
|
||||
conditions are given as query templates with any values embedded:
|
||||
{[
|
||||
open Caqti_template.Create
|
||||
|
||||
type cond =
|
||||
| Column_eq : string * 'a Caqti_template.Field_type.t * 'a -> cond
|
||||
|
||||
let query_of_cond = function
|
||||
| Column_eq (col, t, v) ->
|
||||
Q.lit col @++ " = " ^++ Q.const t v
|
||||
|
||||
let make_simple_select conds columns row_type =
|
||||
let query =
|
||||
"SELECT " ^++ Q.concat ~sep:", " (List.map Q.lit columns) @++
|
||||
" FROM $.foo" ^++
|
||||
" WHERE " ^++ Q.concat ~sep:" AND " (List.map query_of_cond conds)
|
||||
in
|
||||
direct_gen T.(unit -->* row_type) (fun _ -> query)
|
||||
]}
|
||||
*)
|
||||
|
||||
val (@++) : t -> t -> t
|
||||
(** An alias for {!Query.cat}. *)
|
||||
|
||||
val (^++) : string -> t -> t
|
||||
(** [pfx ^++ q] is [q] prefixed with the literal fragment [pfx], i.e.
|
||||
[cat (lit pfx) q]. *)
|
||||
|
||||
val (++^) : t -> string -> t
|
||||
(** [q ++^ sfx] is [q] suffixed with the literal fragment [sfx], i.e.
|
||||
[cat q (lit sfx)]. *)
|
||||
end
|
||||
|
||||
(** {3:embeddingvalues Embedding Values}
|
||||
|
||||
The following functions can be used to embed values into a query, including
|
||||
the generic {!const}, corresponding specialized variants. Additionally
|
||||
{!const_fields} can be used to extract fragments for multiple fields given a
|
||||
row type and a value. *)
|
||||
|
||||
val bool : bool -> t
|
||||
val int : int -> t
|
||||
val int16 : int -> t
|
||||
val int32 : int32 -> t
|
||||
val int64 : int64 -> t
|
||||
val float : float -> t
|
||||
val string : string -> t
|
||||
val octets : string -> t
|
||||
val pdate : Ptime.t -> t
|
||||
val ptime : Ptime.t -> t
|
||||
val ptime_span : Ptime.span -> t
|
||||
|
||||
val const : 'a Field_type.t -> 'a -> t
|
||||
(** [const t x] is a fragment representing the value [x] of field type [t],
|
||||
using driver-dependent serialization and escaping mechanisms.
|
||||
Drivers will typically expand this to a parameter reference which will
|
||||
receive the value [x] when executed, though the value may also be embedded
|
||||
in the query if it is deemed safe. *)
|
||||
|
||||
val const_fields : 'a Row_type.t -> 'a -> t list
|
||||
(** [const_fields t x] returns a list of fragments corresponding to the
|
||||
single-field projections of the value [x] as described by the type
|
||||
descriptor [t]. Each element of the returned list will be either a
|
||||
{!const}-fragment containing the projected value, or [lit "NULL"] if
|
||||
the projection is [None].
|
||||
|
||||
The result can be turned into a comma-separated list with {!concat}, except
|
||||
values of unitary types, i.e. types having no fields, may require special
|
||||
care. *)
|
||||
|
||||
|
||||
(** {2 Normalization and Equality} *)
|
||||
|
||||
val normal : t -> t
|
||||
(** [normal q] rewrites [q] to a normal form, flattening nested concatenations
|
||||
and removing empty fragments from the internal representation.
|
||||
This function can be used to post-process queries before using {!equal} and
|
||||
{!hash}. *)
|
||||
|
||||
val equal : t -> t -> bool
|
||||
(** [equal q1 q2] is true iff [q1] and [q2] has the same internal
|
||||
representation.
|
||||
It may be necessary to pre-process the query templates with {!normal} if
|
||||
they are not constructed by a common deterministic algorithm. *)
|
||||
|
||||
val hash : t -> int
|
||||
(** [hash q] computes a hash over the internal representation of [q] which is
|
||||
compatible with {!equal}.
|
||||
The hash function may change across minor versions and may depend on
|
||||
architecture.
|
||||
It may be necessary to pre-process the query template with {!normal}, unless
|
||||
the hash is to be used among a collection of query templates constructed by
|
||||
a common deterministic algorithm. *)
|
||||
|
||||
|
||||
(** {2 Parsing, Expansion, and Printing} *)
|
||||
|
||||
val pp : Format.formatter -> t -> unit
|
||||
(** [pp ppf q] prints a {e human}-readable representation of [q] on [ppf].
|
||||
The printed string is {e not suitable for sending to an SQL database}; doing
|
||||
so may lead to an SQL injection vulnerability. *)
|
||||
|
||||
val show : t -> string
|
||||
(** [show q] is the same {e human}-readable representation of [q] as printed by
|
||||
{!pp}.
|
||||
The returned string is {e not suitable for sending to an SQL database};
|
||||
doing so may lead to an SQL injection vulnerability. *)
|
||||
|
||||
module Expand_error : sig
|
||||
type t
|
||||
|
||||
val pp : Format.formatter -> t -> unit
|
||||
(** Formats a human-readable error message. *)
|
||||
end
|
||||
(** A description of the error caused during {!expand} if the environment lookup
|
||||
function returns an invalid result or fails to provide a value for a
|
||||
variable when the expansion is final. *)
|
||||
|
||||
exception Expand_error of Expand_error.t
|
||||
(** The exception raised by {!expand} when there are issues expanding an
|
||||
environment variable using the provided callback. *)
|
||||
|
||||
type subst = string -> t
|
||||
(** A partial mapping from variable names to query fragments, which raises
|
||||
[Not_found] for undefined variables. This is used by {!expand} to resolve
|
||||
variable references, with the special handling of a final period in the
|
||||
variable names described in {{!query_template} The Syntax of Query
|
||||
Templates}. *)
|
||||
|
||||
val expand : ?final: bool -> subst -> t -> t
|
||||
(** [expand subst query] replaces the occurrence of each variable [var] with
|
||||
[subst var] where it is defined, otherwise if [final] is [false], the
|
||||
variable is left unchanged, otherwise raises {!exception-Expand_error}.
|
||||
The result of the substitution function may not contain variable references.
|
||||
|
||||
@param final
|
||||
Whether this is the final expansion, as when invoked by the drivers.
|
||||
Defaults to [false].
|
||||
|
||||
@raise exception-Expand_error
|
||||
if the substitution function is invalid or if it is incomplete for a final
|
||||
expansion. *)
|
||||
|
||||
val angstrom_parser : t Angstrom.t
|
||||
(** Matches a single expression terminated by the end of input or a semicolon
|
||||
lookahead. The accepted languages is described in {{!query_template} The
|
||||
Syntax of Query Templates}. *)
|
||||
|
||||
val angstrom_parser_with_semicolon : t Angstrom.t
|
||||
(** A variant of [angstrom_parser] which accepts unquoted semicolons as part of
|
||||
the single statement, as is valid in some cases like in SQLite3 trigger
|
||||
definitions. This is the parser used by {!Caqti_template.Request}, where
|
||||
it's assumed that the input is a single SQL statement. *)
|
||||
|
||||
val angstrom_list_parser : t list Angstrom.t
|
||||
(** Matches a sequence of statements while ignoring surrounding white space and
|
||||
end-of-line comments starting with ["--"]. This parser can be used to load
|
||||
schema files with support for environment expansions, like substituting the
|
||||
name of the database schema. *)
|
||||
|
||||
module Parse_error : sig
|
||||
type t
|
||||
|
||||
val position : t -> int
|
||||
(** The byte position of the string at which the parser failed. *)
|
||||
|
||||
val message : t -> string
|
||||
(** A message describing the problem. *)
|
||||
|
||||
val pp : Format.formatter -> t -> unit
|
||||
(** Formats a human-readable error message. *)
|
||||
end
|
||||
(** Describes errors from the high-level parsing functions. *)
|
||||
|
||||
exception Parse_error of Parse_error.t
|
||||
(** The exception which may be raised by {!parse}. *)
|
||||
|
||||
val parse : string -> t
|
||||
(** Parses a single expression using {!angstrom_parser_with_semicolon}. The
|
||||
error indicates the byte position of the input string where the parse
|
||||
failure occurred in addition to an error message. See {{!query_template} The
|
||||
Syntax of Query Templates} for how the input string is interpreted.
|
||||
|
||||
@raise exception-Parse_error if the argument is syntactically invalid. *)
|
||||
|
||||
val parse_result : string -> (t, Parse_error.t) result
|
||||
(** Variant of {!parse} which returns a result instead of raising. *)
|
||||
158
unikernel/duniverse/ocaml-caqti/caqti/lib-template/query_fmt.ml
Normal file
158
unikernel/duniverse/ocaml-caqti/caqti/lib-template/query_fmt.ml
Normal file
|
|
@ -0,0 +1,158 @@
|
|||
(* Copyright (C) 2023--2024 Petter A. Urkedal <paurkedal@gmail.com>
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or modify it
|
||||
* under the terms of the GNU Lesser General Public License as published by
|
||||
* the Free Software Foundation, either version 3 of the License, or (at your
|
||||
* option) any later version, with the LGPL-3.0 Linking Exception.
|
||||
*
|
||||
* This library is distributed in the hope that it will be useful, but WITHOUT
|
||||
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
||||
* FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
|
||||
* License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public License
|
||||
* and the LGPL-3.0 Linking Exception along with this library. If not, see
|
||||
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
|
||||
*)
|
||||
|
||||
type 'a t = Format.formatter -> 'a -> unit
|
||||
|
||||
type Format.stag += Stag_query of Query.t
|
||||
|
||||
let query ppf q =
|
||||
Format.pp_open_stag ppf (Stag_query q);
|
||||
Format.pp_print_string ppf "... SQL FRAGMENT ...";
|
||||
Format.pp_close_stag ppf ()
|
||||
|
||||
let quote ppf q = query ppf (Query.quote q)
|
||||
let env ppf e = query ppf (Query.var e)
|
||||
let param ppf p = query ppf (Query.param p)
|
||||
|
||||
type mode = Mode_literal | Mode_ignore | Mode_raw of (string -> Query.t)
|
||||
|
||||
let kqprintf k fmt =
|
||||
(* The formatter can be in three different modes, which is determined
|
||||
depending on the currently open tags (we exploit the fact that
|
||||
[mark_open_stag] and [mark_close_tag] are called immediately before the tag
|
||||
would actually be output to the formatter, and so can we can effectively
|
||||
use them as control directives for the behavior of [output_string]).
|
||||
|
||||
Internally, the formatter holds a list of query elements in the reverse
|
||||
order that they have been produced in. Once we have finished parsing, that
|
||||
list is reversed, wrapped into the [S] constructor, and returned. We will
|
||||
call this list of elements we are building "the queue" in the following.
|
||||
|
||||
Initially, the formatter starts in literal mode. In literal mode, we simply
|
||||
push each string that we receive from the formatter into the queue
|
||||
unmodified as a literal.
|
||||
|
||||
When we encounter a tag in literal mode, we enter one of two auxiliary
|
||||
modes:
|
||||
|
||||
- If the tag is the string tag "Q" or "E" (denoting a nested quote or env
|
||||
var format, respectively), we enter raw mode, parameterized by a
|
||||
function that returns either [Q] or [E]. In raw mode, we accumulate the
|
||||
content that gets printed into a buffer, and when exiting raw mode
|
||||
(i.e. when the corresponding tag gets closed), we wrap the accumulated
|
||||
content as a string into either the [Q] or [E] constructor, and push it
|
||||
into the queue. Then, we exit go back to literal mode.
|
||||
|
||||
- If the tag is custom tag [Stag_query], added by the {!query} printer, we
|
||||
push the embedded query without modifications onto the queue, then
|
||||
switch to ignore mode. In ignore mode, we simply discard what is printed
|
||||
until we exit ignore mode by closing the corresponding tag. This is
|
||||
because, in ignore mode, the content that we are interested in is the
|
||||
parameter of the [Stag_query], not the textual content within the tag.
|
||||
|
||||
Nesting of tags is not supported, so if we see one of the tags above in
|
||||
either of these modes, we raise a [Failure] exception.
|
||||
*)
|
||||
let elems = ref [] in
|
||||
let buf = Buffer.create 512 in
|
||||
|
||||
let push q = elems := q :: !elems in
|
||||
let mode = ref Mode_literal in
|
||||
let flush_raw () =
|
||||
let mk = match !mode with Mode_raw f -> f | _ -> assert false in
|
||||
push @@ mk @@ Buffer.contents buf;
|
||||
Buffer.reset buf;
|
||||
mode := Mode_literal
|
||||
and flush_ignore () =
|
||||
match !mode with Mode_ignore -> mode := Mode_literal | _ -> assert false
|
||||
and flush_literal () =
|
||||
(* Unlike the similar cases in [flush_raw] and [flush_ignore], it is actually
|
||||
possible to call [flush_literal] while not in literal mode by nesting <Q>
|
||||
and/or <E> semantic tags.
|
||||
|
||||
There is actually nothing to do here, because we push output strings into
|
||||
the queue on the fly. *)
|
||||
begin
|
||||
match !mode with
|
||||
| Mode_literal -> ()
|
||||
| _ -> failwith "invalid nesting of query tags; did you forget a `@}`?"
|
||||
end
|
||||
and output_string s p n =
|
||||
match !mode with
|
||||
| Mode_literal ->
|
||||
if n > 0 then
|
||||
if p = 0 && n = String.length s then
|
||||
push (Query.lit s)
|
||||
else
|
||||
push (Query.lit (String.sub s p n))
|
||||
| Mode_raw _ -> Buffer.add_substring buf s p n
|
||||
| Mode_ignore -> ()
|
||||
in
|
||||
let ppf = Format.make_formatter output_string flush_literal in
|
||||
let Format.
|
||||
{ mark_open_stag; mark_close_stag; print_open_stag; print_close_stag } =
|
||||
Format.pp_get_formatter_stag_functions ppf ()
|
||||
in
|
||||
(* Note that we call [flush_literal] when *opening* tags but the other [flush]
|
||||
functions when *closing* tags. Since [Format] enforces the
|
||||
well-parenthesising of tags, we are guaranteed to always be in the correct
|
||||
mode when calling [flush_raw] and [flush_ignore], but that is *not* the
|
||||
case for [flush_litera].
|
||||
*)
|
||||
let mark_open_stag = function
|
||||
| Format.String_tag "Q" ->
|
||||
flush_literal ();
|
||||
mode := Mode_raw (fun s -> Query.quote s);
|
||||
""
|
||||
| Format.String_tag "E" ->
|
||||
flush_literal ();
|
||||
mode := Mode_raw (fun s -> Query.var s);
|
||||
""
|
||||
| Stag_query q ->
|
||||
flush_literal ();
|
||||
push q;
|
||||
mode := Mode_ignore;
|
||||
""
|
||||
| t -> mark_open_stag t
|
||||
and mark_close_stag = function
|
||||
| Format.String_tag ("Q" | "E") ->
|
||||
flush_raw ();
|
||||
""
|
||||
| Stag_query _ ->
|
||||
flush_ignore ();
|
||||
""
|
||||
| t -> mark_close_stag t
|
||||
in
|
||||
Format.pp_set_formatter_stag_functions ppf
|
||||
{ mark_open_stag; mark_close_stag; print_open_stag; print_close_stag };
|
||||
Format.pp_set_mark_tags ppf true;
|
||||
Format.kfprintf
|
||||
(fun ppf ->
|
||||
Format.pp_print_flush ppf ();
|
||||
k (Query.concat (List.rev !elems)))
|
||||
ppf fmt
|
||||
|
||||
let qprintf fmt = kqprintf Fun.id fmt
|
||||
|
||||
let bool ppf x = query ppf (Query.bool x)
|
||||
let int ppf x = query ppf (Query.int x)
|
||||
let float ppf x = query ppf (Query.float x)
|
||||
let string ppf x = query ppf (Query.string x)
|
||||
let octets ppf x = query ppf (Query.octets x)
|
||||
let pdate ppf x = query ppf (Query.pdate x)
|
||||
let ptime ppf x = query ppf (Query.ptime x)
|
||||
let ptime_span ppf x = query ppf (Query.ptime_span x)
|
||||
102
unikernel/duniverse/ocaml-caqti/caqti/lib-template/query_fmt.mli
Normal file
102
unikernel/duniverse/ocaml-caqti/caqti/lib-template/query_fmt.mli
Normal file
|
|
@ -0,0 +1,102 @@
|
|||
(* Copyright (C) 2023--2025 Petter A. Urkedal <paurkedal@gmail.com>
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or modify it
|
||||
* under the terms of the GNU Lesser General Public License as published by
|
||||
* the Free Software Foundation, either version 3 of the License, or (at your
|
||||
* option) any later version, with the LGPL-3.0 Linking Exception.
|
||||
*
|
||||
* This library is distributed in the hope that it will be useful, but WITHOUT
|
||||
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
||||
* FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
|
||||
* License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public License
|
||||
* and the LGPL-3.0 Linking Exception along with this library. If not, see
|
||||
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
|
||||
*)
|
||||
|
||||
(** Format-based query construction. *)
|
||||
|
||||
type 'a t = Format.formatter -> 'a -> unit
|
||||
(** The type of a function which formats values of type ['a] or fragments based
|
||||
on an input of type ['a]. *)
|
||||
|
||||
val qprintf : ('a, Format.formatter, unit, Query.t) format4 -> 'a
|
||||
(** {!qprintf} allows building Caqti queries using a printf-style interface.
|
||||
|
||||
When using {!qprintf}, you can use the {!query}, {!quote}, {!env} and
|
||||
{!param} printers from this module to generate the corresponding query
|
||||
fragments.
|
||||
|
||||
In addition, you can use the "Q" and "E" string tags to delimit portions of
|
||||
the formatting string that should be interpreted as quotes and environment
|
||||
variables, respectively. The "Q" and "E" tags can not be nested: within the
|
||||
tags, {!qprintf} behaves no differently than {!Format.asprintf} and will
|
||||
generate a string, not a query (only when the tag is closed does the string
|
||||
get converted into a query).
|
||||
|
||||
The two following calls to {!qprintf}:
|
||||
{@ocaml skip[
|
||||
qprintf "FUNC(@{<Q>Quoted value with %d format(s)})" 1
|
||||
]}
|
||||
and
|
||||
{@ocaml skip[
|
||||
qprintf "FUNC(%a)" quote (Format.asprintf "Quoted value with %d format(s)" 1)
|
||||
]}
|
||||
are functionally equivalent. Both compute
|
||||
{@ocaml skip[
|
||||
S [L "FUNC("; Q "Quoted value with 1 format(s)"; L ")"]
|
||||
]}
|
||||
but the first one is nicer to work with.
|
||||
|
||||
@raise Failure if the "Q" and "E" tags are nested.
|
||||
*)
|
||||
|
||||
val kqprintf : (Query.t -> 'a) -> ('b, Format.formatter, unit, 'a) format4 -> 'b
|
||||
(** {!kqprintf} is the continuation-passing version of {!qprintf} (like
|
||||
{!Format.kasprintf} for {!Format.asprintf}).
|
||||
|
||||
You usually want [qprintf] instead. *)
|
||||
|
||||
val param : int t
|
||||
(** {!param} is a formatter that includes the corresponding parameter in a
|
||||
query built by {!qprintf}.
|
||||
|
||||
Note that to include a parameter in a query, {!param} *must* be used: using
|
||||
literal ["$"] or ["?"] will be sent as-is to the SQL driver and will not be
|
||||
processed by Caqti.
|
||||
*)
|
||||
|
||||
val env : string t
|
||||
(** {!env} is a formatter that includes the corresponding environment variable
|
||||
in a query built by {!qprintf}.
|
||||
|
||||
Note that to include an environment variable in a query, {!env} *must* be
|
||||
used: using literal ["$(...)"] will be sent as-is to the SQL driver and
|
||||
will not be processed by Caqti. *)
|
||||
|
||||
val quote : string t
|
||||
(** {!quote} is a formatter that includes a TEXT literal in a query built by
|
||||
{!qprintf}. *)
|
||||
|
||||
val query : Query.t t
|
||||
(** {!query} can be used with {!qprintf} to embed a query that was already
|
||||
parsed in the format string. Direct use of {!query} should be rare, and
|
||||
{!param}, {!env}, or {!quote} should be used instead when possible.
|
||||
|
||||
Using {!query} with any other formatter will ignore the query and instead
|
||||
print a dummy value (currently ["... SQL FRAGMENT ..."]) instead. *)
|
||||
|
||||
(** {2 Value Formatters}
|
||||
|
||||
The following formatters emit values of basic field types by passing them as
|
||||
parameters. *)
|
||||
|
||||
val bool : bool t
|
||||
val int : int t
|
||||
val float : float t
|
||||
val string : string t
|
||||
val octets : string t
|
||||
val pdate : Ptime.t t
|
||||
val ptime : Ptime.t t
|
||||
val ptime_span : Ptime.span t
|
||||
|
|
@ -0,0 +1,92 @@
|
|||
(* Copyright (C) 2017--2025 Petter A. Urkedal <paurkedal@gmail.com>
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or modify it
|
||||
* under the terms of the GNU Lesser General Public License as published by
|
||||
* the Free Software Foundation, either version 3 of the License, or (at your
|
||||
* option) any later version, with the LGPL-3.0 Linking Exception.
|
||||
*
|
||||
* This library is distributed in the hope that it will be useful, but WITHOUT
|
||||
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
||||
* FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
|
||||
* License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public License
|
||||
* and the LGPL-3.0 Linking Exception along with this library. If not, see
|
||||
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
|
||||
*)
|
||||
|
||||
[@@@alert "-caqti_private"]
|
||||
|
||||
module Log = (val Logs.src_log (Logs.Src.create "caqti"))
|
||||
|
||||
type prepare_policy =
|
||||
| Direct
|
||||
| Dynamic
|
||||
| Static
|
||||
|
||||
type ('a, 'b, +'m) t = {
|
||||
id: int option;
|
||||
prepare_policy: prepare_policy;
|
||||
query: Dialect.t -> Query.t;
|
||||
param_type: 'a Row_type.t;
|
||||
row_type: 'b Row_type.t;
|
||||
row_mult: 'm Row_mult.t;
|
||||
} constraint 'm = [< `Zero | `One | `Many]
|
||||
|
||||
let last_id = ref (-1)
|
||||
|
||||
let create prepare_policy (param_type, row_type, row_mult) query =
|
||||
let id =
|
||||
(match prepare_policy with
|
||||
| Direct -> None
|
||||
| Static | Dynamic -> incr last_id; Some !last_id)
|
||||
in
|
||||
{id; prepare_policy; query; param_type; row_type; row_mult}
|
||||
|
||||
let prepare_policy request = request.prepare_policy
|
||||
let param_type request = request.param_type
|
||||
let row_type request = request.row_type
|
||||
let row_mult request = request.row_mult
|
||||
|
||||
let query_id request = request.id
|
||||
let query request = request.query
|
||||
|
||||
let empty_subst _ = raise Not_found
|
||||
|
||||
let default_dialect = Dialect.create_unknown ~purpose:`Printing ()
|
||||
|
||||
let make_pp ?(dialect = default_dialect) ?(subst = empty_subst) () ppf req =
|
||||
let query = Query.expand subst (req.query dialect) in
|
||||
Format.fprintf ppf "(%a -->%s %a) {|%a|}"
|
||||
Row_type.pp req.param_type
|
||||
(match Row_mult.expose req.row_mult with
|
||||
| `Zero -> "."
|
||||
| `One -> ""
|
||||
| `Zero_or_one -> "?"
|
||||
| `Zero_or_more -> "*")
|
||||
Row_type.pp req.row_type
|
||||
Query.pp query
|
||||
|
||||
let pp ppf = make_pp () ppf
|
||||
|
||||
let pp_with_param_enabled =
|
||||
(match Sys.getenv "CAQTI_DEBUG_PARAM" with
|
||||
| "true" -> true
|
||||
| "false" -> false
|
||||
| s ->
|
||||
Log.err (fun f ->
|
||||
f "Invalid value %s for CAQTI_DEBUG_PARAM, assuming false." s);
|
||||
false
|
||||
| exception Not_found -> false)
|
||||
|
||||
let make_pp_with_param ?dialect ?subst () ppf (req, param) =
|
||||
let pp = make_pp ?subst ?dialect () in
|
||||
pp ppf req;
|
||||
if pp_with_param_enabled then
|
||||
Format.fprintf ppf " %a" (Row.pp req.param_type) param
|
||||
|
||||
type liveness_witness = int option
|
||||
|
||||
let liveness_witness request =
|
||||
assert (request.id <> None);
|
||||
request.id
|
||||
146
unikernel/duniverse/ocaml-caqti/caqti/lib-template/request.mli
Normal file
146
unikernel/duniverse/ocaml-caqti/caqti/lib-template/request.mli
Normal file
|
|
@ -0,0 +1,146 @@
|
|||
(* Copyright (C) 2017--2025 Petter A. Urkedal <paurkedal@gmail.com>
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or modify it
|
||||
* under the terms of the GNU Lesser General Public License as published by
|
||||
* the Free Software Foundation, either version 3 of the License, or (at your
|
||||
* option) any later version, with the LGPL-3.0 Linking Exception.
|
||||
*
|
||||
* This library is distributed in the hope that it will be useful, but WITHOUT
|
||||
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
||||
* FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
|
||||
* License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public License
|
||||
* and the LGPL-3.0 Linking Exception along with this library. If not, see
|
||||
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
|
||||
*)
|
||||
|
||||
(** Request template.
|
||||
|
||||
A request template combines a function to generate an SQL query template
|
||||
with type descriptors use to encode parameters and decode result rows.
|
||||
The function will receive information about the SQL dialect when called by
|
||||
the chosen database driver library.
|
||||
|
||||
Requests are passed to {!Caqti_connection_sig.S.call} or one of its shortcut
|
||||
methods provided by a database connection handle, and will be turned into a
|
||||
prepared query, cached by the connection handle, if prepared queries are
|
||||
supported by the driver and unless explicitly disabled, see {!create} for
|
||||
details on the latter. *)
|
||||
|
||||
(** {2 Primitive Constructor and Accessors} *)
|
||||
|
||||
type prepare_policy =
|
||||
| Direct
|
||||
(** The query string is sent to the database on each request, or if the
|
||||
driver only supports prepared queries, the preprepared query will be
|
||||
released after each use.
|
||||
Most importantly nothing is retained by the driver related to request
|
||||
template created with this policy, so this is a safe option for
|
||||
dynamically generated request templates.
|
||||
This option is only a suitable choice when it is known in advance that
|
||||
the request will be executed at most once, or very rarely, such as
|
||||
schema updates. *)
|
||||
| Dynamic
|
||||
(** The query string is prepared once per connection and scheduled for
|
||||
release after the request object has been garbage collected. *)
|
||||
| Static
|
||||
(** The query string is prepared once per connection on not released before
|
||||
the connection is closed.
|
||||
This policy will cause a resource leak on long-lived connections if the
|
||||
template is dynamically generated.
|
||||
As the name suggest, this policy should only be used when the request
|
||||
template has static lifetime. *)
|
||||
(** The prepare policy decides whether Caqti drivers use prepared queries and,
|
||||
if so, the expected lifetime of the template. *)
|
||||
|
||||
type ('a, 'b, +'m) t constraint 'm = [< `Zero | `One | `Many]
|
||||
(** A request specification embedding a query generator, parameter encoder, and
|
||||
row decoder.
|
||||
- ['a] is the type of the expected parameter bundle.
|
||||
- ['b] is the type of a returned row.
|
||||
- ['m] is the possible multiplicities of returned rows. *)
|
||||
|
||||
val create :
|
||||
prepare_policy -> ('a, 'b, 'm) Request_type.t -> (Dialect.t -> Query.t) ->
|
||||
('a, 'b, 'm) t
|
||||
(** [create prepare_policy (arg_type, row_type, row_mult) f] is a request
|
||||
template
|
||||
|
||||
- whose query will be prepared (or not) according to [prepare_policy],
|
||||
- which takes parameters of type [arg_type],
|
||||
- which returns rows of type [row_type] with multiplicity [row_mult], and
|
||||
- which submits a query string rendered from the {!Query.t} returned by
|
||||
[f di], where [di] is the {!Dialect.t} supplied by the driver library of
|
||||
the connection.
|
||||
|
||||
The driver is responsible for turning parameter references into a form
|
||||
accepted by the database system, while other dialectical differences must be
|
||||
handled by [f]. *)
|
||||
|
||||
val prepare_policy : (_, _, _) t -> prepare_policy
|
||||
(** [prepare_policy req] is the prepare policy of [req]. *)
|
||||
|
||||
val param_type : ('a, _, _) t -> 'a Row_type.t
|
||||
(** [param_type req] is the type of parameter bundles expected by [req]. *)
|
||||
|
||||
val row_type : (_, 'b, _) t -> 'b Row_type.t
|
||||
(** [row_type req] is the type of rows returned by [req]. *)
|
||||
|
||||
val row_mult : (_, _, 'm) t -> 'm Row_mult.t
|
||||
(** [row_mult req] indicates how many rows [req] may return. This is asserted
|
||||
when constructing the query. *)
|
||||
|
||||
val query : ('a, 'b, 'm) t -> Dialect.t -> Query.t
|
||||
(** [query req] is the function which generates the query of this request
|
||||
possibly tailored for the given driver. *)
|
||||
|
||||
|
||||
(** {2 Formatting} *)
|
||||
|
||||
val make_pp :
|
||||
?dialect: Dialect.t ->
|
||||
?subst: Query.subst ->
|
||||
unit -> Format.formatter -> ('a, 'b, 'm) t -> unit
|
||||
(** [make_pp ?subst ?dialect ()] is a pretty-printer for a request, which
|
||||
expands the query using [subst] and [dialect].
|
||||
|
||||
@param subst
|
||||
Used to partially expand the query string. Defaults to the empty
|
||||
substitution.
|
||||
|
||||
@param dialect
|
||||
The driver info to pass to the call-back which returns the query.
|
||||
Defaults to {!Dialect.Unknown}. *)
|
||||
|
||||
val pp : Format.formatter -> ('a, 'b, 'm) t -> unit
|
||||
(** [pp ppf req] prints [req] on [ppf] in a form suitable for human
|
||||
inspection. *)
|
||||
|
||||
val make_pp_with_param :
|
||||
?dialect: Dialect.t ->
|
||||
?subst: Query.subst ->
|
||||
unit -> Format.formatter -> ('a, 'b, 'm) t * 'a -> unit
|
||||
(** [make_pp_with_param ?subst ?dialect ()] is a pretty-printer for a
|
||||
request and parameter pair. See {!make_pp} for the optional arguments.
|
||||
This functions is meant for debugging; the output is neither guaranteed to
|
||||
be consistent across releases nor to contain a complete record of the data.
|
||||
Lost database records cannot be reconstructed from the logs.
|
||||
|
||||
Due to concerns about exposure of sensitive data in debug logs, this
|
||||
function only prints the parameter values if [CAQTI_DEBUG_PARAM] is set to
|
||||
[true]. If you enable it for applications which do not consistenly annotate
|
||||
sensitive parameters with {!Row_type.redacted}, make sure your debug logs
|
||||
are well-secured. *)
|
||||
|
||||
(**/**)
|
||||
[@@@alert "-caqti_private"]
|
||||
|
||||
val query_id : ('a, 'b, 'm) t -> int option
|
||||
[@@alert caqti_private]
|
||||
|
||||
type liveness_witness
|
||||
[@@alert caqti_private]
|
||||
|
||||
val liveness_witness : (_, _, _) t -> liveness_witness
|
||||
[@@alert caqti_private]
|
||||
|
|
@ -0,0 +1,29 @@
|
|||
(* Copyright (C) 2025 Petter A. Urkedal <paurkedal@gmail.com>
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or modify it
|
||||
* under the terms of the GNU Lesser General Public License as published by
|
||||
* the Free Software Foundation, either version 3 of the License, or (at your
|
||||
* option) any later version, with the LGPL-3.0 Linking Exception.
|
||||
*
|
||||
* This library is distributed in the hope that it will be useful, but WITHOUT
|
||||
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
||||
* FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
|
||||
* License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public License
|
||||
* and the LGPL-3.0 Linking Exception along with this library. If not, see
|
||||
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
|
||||
*)
|
||||
|
||||
type ('a, 'b, 'm) t = 'a Row_type.t * 'b Row_type.t * 'm Row_mult.t
|
||||
|
||||
module Infix = struct
|
||||
let ( -->. ) t u = (t, u, Row_mult.zero)
|
||||
let ( -->! ) t u = (t, u, Row_mult.one)
|
||||
let ( -->? ) t u = (t, u, Row_mult.zero_or_one)
|
||||
let ( -->* ) t u = (t, u, Row_mult.zero_or_more)
|
||||
end
|
||||
|
||||
let param_type (t, _, _) = t
|
||||
let row_type (_, u, _) = u
|
||||
let row_mult (_, _, m) = m
|
||||
|
|
@ -0,0 +1,40 @@
|
|||
(* Copyright (C) 2025 Petter A. Urkedal <paurkedal@gmail.com>
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or modify it
|
||||
* under the terms of the GNU Lesser General Public License as published by
|
||||
* the Free Software Foundation, either version 3 of the License, or (at your
|
||||
* option) any later version, with the LGPL-3.0 Linking Exception.
|
||||
*
|
||||
* This library is distributed in the hope that it will be useful, but WITHOUT
|
||||
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
||||
* FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
|
||||
* License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public License
|
||||
* and the LGPL-3.0 Linking Exception along with this library. If not, see
|
||||
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
|
||||
*)
|
||||
|
||||
(** Type descriptors for requests. *)
|
||||
|
||||
type ('a, 'b, +'m) t = 'a Row_type.t * 'b Row_type.t * 'm Row_mult.t
|
||||
|
||||
module Infix : sig
|
||||
|
||||
val ( -->. ) :
|
||||
'a Row_type.t -> unit Row_type.t -> ('a, unit, Row_mult.zero) t
|
||||
|
||||
val ( -->! ) :
|
||||
'a Row_type.t -> 'b Row_type.t -> ('a, 'b, Row_mult.one) t
|
||||
|
||||
val ( -->? ) :
|
||||
'a Row_type.t -> 'b Row_type.t -> ('a, 'b, Row_mult.zero_or_one) t
|
||||
|
||||
val ( -->* ) :
|
||||
'a Row_type.t -> 'b Row_type.t -> ('a, 'b, Row_mult.zero_or_more) t
|
||||
|
||||
end
|
||||
|
||||
val param_type : ('a, _, _) t -> 'a Row_type.t
|
||||
val row_type : (_, 'b, _) t -> 'b Row_type.t
|
||||
val row_mult : (_, _, 'm) t -> 'm Row_mult.t
|
||||
100
unikernel/duniverse/ocaml-caqti/caqti/lib-template/row.ml
Normal file
100
unikernel/duniverse/ocaml-caqti/caqti/lib-template/row.ml
Normal file
|
|
@ -0,0 +1,100 @@
|
|||
(* Copyright (C) 2025 Petter A. Urkedal <paurkedal@gmail.com>
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or modify it
|
||||
* under the terms of the GNU Lesser General Public License as published by
|
||||
* the Free Software Foundation, either version 3 of the License, or (at your
|
||||
* option) any later version, with the LGPL-3.0 Linking Exception.
|
||||
*
|
||||
* This library is distributed in the hope that it will be useful, but WITHOUT
|
||||
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
||||
* FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
|
||||
* License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public License
|
||||
* and the LGPL-3.0 Linking Exception along with this library. If not, see
|
||||
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
|
||||
*)
|
||||
|
||||
(* equal *)
|
||||
|
||||
let rec equal_poly : type a. a Row_type.t -> a -> a -> bool =
|
||||
(function
|
||||
| Field ft ->
|
||||
Field_type.equal_value ft
|
||||
| Option t ->
|
||||
let equal_t = equal_poly t in
|
||||
fun x y ->
|
||||
(match x, y with
|
||||
| None, None -> true
|
||||
| Some x, Some y -> equal_t x y
|
||||
| None, Some _ | Some _, None -> false)
|
||||
| Product (_, pt) -> equal_product pt
|
||||
| Annot (_, t) -> equal_poly t)
|
||||
|
||||
and equal_product : type i a. (i, a) Row_type.product -> a -> a -> bool =
|
||||
(function
|
||||
| Proj_end -> fun _ _ -> true
|
||||
| Proj (t, p, pt) ->
|
||||
let equal_t = equal_poly t in
|
||||
let equal_pt = equal_product pt in
|
||||
fun x y -> equal_t (p x) (p y) && equal_pt x y)
|
||||
|
||||
let equal (t : _ Row_type.t) = equal_poly t
|
||||
|
||||
(* pp *)
|
||||
|
||||
type pp_state = {
|
||||
mutable field_num: int;
|
||||
}
|
||||
|
||||
let pp_field_sep state ppf () =
|
||||
if state.field_num > 0 then
|
||||
begin
|
||||
Format.pp_print_char ppf ',';
|
||||
Format.pp_print_space ppf ()
|
||||
end;
|
||||
state.field_num <- state.field_num + 1
|
||||
|
||||
let pp_rep_lit n lit state =
|
||||
fun ppf () ->
|
||||
for _ = 1 to n do
|
||||
pp_field_sep state ppf ();
|
||||
Format.pp_print_string ppf lit
|
||||
done
|
||||
|
||||
let rec pp_poly
|
||||
: type a. a Row_type.t -> pp_state -> Format.formatter -> a -> unit =
|
||||
(function
|
||||
| Field ft ->
|
||||
fun state ppf x ->
|
||||
pp_field_sep state ppf ();
|
||||
Field_type.pp_value ppf (ft, x)
|
||||
| Option t ->
|
||||
let pp_t = pp_poly t in
|
||||
let length_t = Row_type.length t in
|
||||
fun state ->
|
||||
let case_none = pp_rep_lit length_t "NONE" state in
|
||||
let case_some = pp_t state in
|
||||
fun ppf ->
|
||||
(function None -> case_none ppf () | Some x -> case_some ppf x)
|
||||
| Product (_, pt) -> pp_product pt
|
||||
| Annot (`Redacted, t) ->
|
||||
let length_t = Row_type.length t in
|
||||
fun state ppf _ -> pp_rep_lit length_t "#redacted#" state ppf ())
|
||||
|
||||
and pp_product
|
||||
: type i a. (i, a) Row_type.product -> pp_state ->
|
||||
Format.formatter -> a -> unit =
|
||||
(function
|
||||
| Proj_end -> fun _state _ppf _x -> ()
|
||||
| Proj (t, p, pt) ->
|
||||
let pp_t = pp_poly t in
|
||||
let pp_pt = pp_product pt in
|
||||
fun state ->
|
||||
let pp_t_state = pp_t state in
|
||||
let pp_pt_state = pp_pt state in
|
||||
fun ppf x ->
|
||||
pp_t_state ppf (p x);
|
||||
pp_pt_state ppf x)
|
||||
|
||||
let pp (t : _ Row_type.t) = pp_poly t {field_num = 1}
|
||||
25
unikernel/duniverse/ocaml-caqti/caqti/lib-template/row.mli
Normal file
25
unikernel/duniverse/ocaml-caqti/caqti/lib-template/row.mli
Normal file
|
|
@ -0,0 +1,25 @@
|
|||
(* Copyright (C) 2025 Petter A. Urkedal <paurkedal@gmail.com>
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or modify it
|
||||
* under the terms of the GNU Lesser General Public License as published by
|
||||
* the Free Software Foundation, either version 3 of the License, or (at your
|
||||
* option) any later version, with the LGPL-3.0 Linking Exception.
|
||||
*
|
||||
* This library is distributed in the hope that it will be useful, but WITHOUT
|
||||
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
||||
* FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
|
||||
* License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public License
|
||||
* and the LGPL-3.0 Linking Exception along with this library. If not, see
|
||||
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
|
||||
*)
|
||||
|
||||
val equal : 'a Row_type.t -> 'a -> 'a -> bool
|
||||
(** [equal_value t] is the equality predicate for values of row type [t]. *)
|
||||
|
||||
val pp : 'a Row_type.t -> Format.formatter -> 'a -> unit
|
||||
(** [pp_value ppf (t, v)] prints a human representation of [v] given the type
|
||||
descriptor [t]. This function is meant for debugging; the output is neither
|
||||
guaranteed to be consistent across releases nor to contain a complete record
|
||||
of the data. *)
|
||||
|
|
@ -0,0 +1,56 @@
|
|||
(* Copyright (C) 2017--2024 Petter A. Urkedal <paurkedal@gmail.com>
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or modify it
|
||||
* under the terms of the GNU Lesser General Public License as published by
|
||||
* the Free Software Foundation, either version 3 of the License, or (at your
|
||||
* option) any later version, with the LGPL-3.0 Linking Exception.
|
||||
*
|
||||
* This library is distributed in the hope that it will be useful, but WITHOUT
|
||||
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
||||
* FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
|
||||
* License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public License
|
||||
* and the LGPL-3.0 Linking Exception along with this library. If not, see
|
||||
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
|
||||
*)
|
||||
|
||||
(** Multiplicities of zero, one, and many. *)
|
||||
|
||||
type +'m t = (* not GADT due to variance *)
|
||||
| Zero
|
||||
| One
|
||||
| Zero_or_one
|
||||
| Zero_or_more
|
||||
constraint 'm = [< `Zero | `One | `Many]
|
||||
|
||||
type zero = [`Zero]
|
||||
type one = [`One]
|
||||
type zero_or_one = [`Zero | `One]
|
||||
type zero_or_more = [`Zero | `One | `Many]
|
||||
|
||||
let zero : [> `Zero] t = Zero
|
||||
let one : [> `One] t = One
|
||||
let zero_or_one : [> `Zero | `One] t = Zero_or_one
|
||||
let zero_or_more : ([> `Zero | `One | `Many] as 'a) t = Zero_or_more
|
||||
|
||||
let only_zero : [< `Zero] t -> unit =
|
||||
function Zero -> () | _ -> assert false
|
||||
let only_one : [< `One] t -> unit =
|
||||
function One -> () | _ -> assert false
|
||||
let only_zero_or_one : [< `Zero | `One] t -> unit =
|
||||
function Zero | One -> () | _ -> assert false
|
||||
|
||||
let expose = function
|
||||
| Zero -> `Zero
|
||||
| One -> `One
|
||||
| Zero_or_one -> `Zero_or_one
|
||||
| Zero_or_more -> `Zero_or_more
|
||||
|
||||
let can_be_zero = function
|
||||
| One -> false
|
||||
| Zero | Zero_or_one | Zero_or_more -> true
|
||||
|
||||
let can_be_many = function
|
||||
| Zero | One | Zero_or_one -> false
|
||||
| Zero_or_more -> true
|
||||
|
|
@ -0,0 +1,39 @@
|
|||
(* Copyright (C) 2017--2024 Petter A. Urkedal <paurkedal@gmail.com>
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or modify it
|
||||
* under the terms of the GNU Lesser General Public License as published by
|
||||
* the Free Software Foundation, either version 3 of the License, or (at your
|
||||
* option) any later version, with the LGPL-3.0 Linking Exception.
|
||||
*
|
||||
* This library is distributed in the hope that it will be useful, but WITHOUT
|
||||
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
||||
* FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
|
||||
* License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public License
|
||||
* and the LGPL-3.0 Linking Exception along with this library. If not, see
|
||||
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
|
||||
*)
|
||||
|
||||
(** Row multiplicity. *)
|
||||
|
||||
type +'m t constraint 'm = [< `Zero | `One | `Many]
|
||||
|
||||
type zero = [`Zero]
|
||||
type one = [`One]
|
||||
type zero_or_one = [`Zero | `One]
|
||||
type zero_or_more = [`Zero | `One | `Many]
|
||||
|
||||
val zero : [> `Zero] t
|
||||
val one : [> `One] t
|
||||
val zero_or_one : [> `Zero | `One] t
|
||||
val zero_or_more : [> `Zero | `One | `Many] t
|
||||
|
||||
val only_zero : [< `Zero] t -> unit
|
||||
val only_one : [< `One] t -> unit
|
||||
val only_zero_or_one : [< `Zero | `One] t -> unit
|
||||
|
||||
val expose : 'm t -> [`Zero | `One | `Zero_or_one | `Zero_or_more]
|
||||
|
||||
val can_be_zero : 'm t -> bool
|
||||
val can_be_many : 'm t -> bool
|
||||
817
unikernel/duniverse/ocaml-caqti/caqti/lib-template/row_type.ml
Normal file
817
unikernel/duniverse/ocaml-caqti/caqti/lib-template/row_type.ml
Normal file
|
|
@ -0,0 +1,817 @@
|
|||
(* Copyright (C) 2017--2025 Petter A. Urkedal <paurkedal@gmail.com>
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or modify it
|
||||
* under the terms of the GNU Lesser General Public License as published by
|
||||
* the Free Software Foundation, either version 3 of the License, or (at your
|
||||
* option) any later version, with the LGPL-3.0 Linking Exception.
|
||||
*
|
||||
* This library is distributed in the hope that it will be useful, but WITHOUT
|
||||
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
||||
* FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
|
||||
* License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public License
|
||||
* and the LGPL-3.0 Linking Exception along with this library. If not, see
|
||||
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
|
||||
*)
|
||||
|
||||
open Shims
|
||||
|
||||
type annot = [`Redacted] (* TODO: Consider open type. *)
|
||||
|
||||
module Private = struct
|
||||
type _ t =
|
||||
| Field : 'a Field_type.t -> 'a t
|
||||
| Option : 'a t -> 'a option t
|
||||
| Product : ('i, 'a) Constructor.t * ('i, 'a) product -> 'a t
|
||||
| Annot : annot * 'a t -> 'a t
|
||||
and (_, _) product =
|
||||
| Proj_end : ('a Constructor.return, 'a) product
|
||||
| Proj : 'b t * ('a -> 'b) * ('i, 'a) product -> ('b -> 'i, 'a) product
|
||||
end
|
||||
open Private
|
||||
|
||||
type 'a t = 'a Private.t
|
||||
type ('i, 'a) product = ('i, 'a) Private.product
|
||||
|
||||
type any = Any : 'a t -> any
|
||||
|
||||
let rec unify : type a b. a t -> b t -> (a, b) Type.eq option =
|
||||
fun t1 t2 ->
|
||||
(match t1, t2 with
|
||||
| Field ft1, Field ft2 -> Field_type.unify ft1 ft2
|
||||
| Field _, _ | _, Field _ -> None
|
||||
| Option t1, Option t2 ->
|
||||
(match unify t1 t2 with
|
||||
| None -> None
|
||||
| Some Equal -> Some Equal)
|
||||
| Option _, _ | _, Option _ -> None
|
||||
| Product (name1, pt1), Product (name2, pt2) ->
|
||||
(match Constructor.unify name1 name2 with
|
||||
| Some dep -> unify_product pt1 pt2 dep
|
||||
| None -> None)
|
||||
| Product _, _ | _, Product _ -> None
|
||||
| Annot (`Redacted, t1), Annot (`Redacted, t2) -> unify t1 t2)
|
||||
and unify_product
|
||||
: type i j a b. (i, a) product -> (j, b) product ->
|
||||
(i, j) Constructor.unifier -> (a, b) Type.eq option =
|
||||
fun pt1 pt2 deq ->
|
||||
(match pt1, pt2, deq with
|
||||
| Proj_end, Proj_end, Equal -> Some Type.Equal
|
||||
| Proj (t1, _, pt1), Proj (t2, _, pt2), Assume dep ->
|
||||
Option.bind (unify t1 t2) (fun p -> unify_product pt1 pt2 (dep p))
|
||||
| _ -> .)
|
||||
|
||||
(* length *)
|
||||
|
||||
let rec length : type a. a t -> int =
|
||||
(function
|
||||
| Field _ -> 1
|
||||
| Option t -> length t
|
||||
| Product (_, pt) -> length_product pt
|
||||
| Annot (_, t) -> length t)
|
||||
and length_product : type a i. (i, a) product -> int =
|
||||
(function
|
||||
| Proj_end -> 0
|
||||
| Proj (t, _, pt) -> length t + length_product pt)
|
||||
|
||||
(* pp *)
|
||||
|
||||
let rec pp : type a. a t -> int -> Format.formatter -> unit -> unit =
|
||||
(function
|
||||
| Field ft ->
|
||||
let string_of_ft = Field_type.to_string ft in
|
||||
fun _ ppf () -> Format.pp_print_string ppf string_of_ft
|
||||
| Option t ->
|
||||
let pp_t = pp t 1 in
|
||||
fun _ ppf () -> Format.fprintf ppf "@[%a@ option@]" pp_t ()
|
||||
| Product (_, Proj_end) ->
|
||||
fun _ ppf () -> Format.pp_print_string ppf "unit"
|
||||
| Product (_, Proj (t0, _, pt)) ->
|
||||
let pp_t0 = pp t0 1 in
|
||||
let pp_pt = pp_product_tail pt in
|
||||
fun prec ->
|
||||
fun ppf () ->
|
||||
if prec > 0 then Format.pp_print_char ppf '(';
|
||||
pp_t0 ppf ();
|
||||
pp_pt ppf ();
|
||||
if prec > 0 then Format.pp_print_char ppf ')'
|
||||
| Annot (`Redacted, t) ->
|
||||
let pp_t = pp t 1 in
|
||||
fun _prec ppf () ->
|
||||
pp_t ppf ();
|
||||
Format.pp_print_string ppf " redacted")
|
||||
and pp_product_tail
|
||||
: type a i. (i, a) product -> Format.formatter -> unit -> unit =
|
||||
(function
|
||||
| Proj_end -> fun _ () -> ()
|
||||
| Proj (t, _, pt) ->
|
||||
let pp_t = pp t 1 in
|
||||
let pp_pt = pp_product_tail pt in
|
||||
fun ppf () ->
|
||||
Format.pp_print_string ppf " × ";
|
||||
pp_t ppf ();
|
||||
pp_pt ppf ())
|
||||
|
||||
let pp ppf t = pp t 1 ppf ()
|
||||
let pp_any ppf (Any t) = pp ppf t
|
||||
let show t = Format.asprintf "%a" pp t
|
||||
|
||||
let field ft = Field ft
|
||||
|
||||
module type STD = sig
|
||||
val bool : bool t
|
||||
val int : int t
|
||||
val int16 : int t
|
||||
val int32 : int32 t
|
||||
val int64 : int64 t
|
||||
val float : float t
|
||||
val string : string t
|
||||
val octets : string t
|
||||
val pdate : Ptime.t t
|
||||
val ptime : Ptime.t t
|
||||
val ptime_span : Ptime.span t
|
||||
val option : 'a t -> 'a option t
|
||||
val redacted : 'a t -> 'a t
|
||||
val unit : unit t
|
||||
val t2 : 'a1 t -> 'a2 t -> ('a1 * 'a2) t
|
||||
val elim_t2 : ('a1 * 'a2) t -> ('a1 t * 'a2 t) option
|
||||
val t3 : 'a1 t -> 'a2 t -> 'a3 t -> ('a1 * 'a2 * 'a3) t
|
||||
val elim_t3 : ('a1 * 'a2 * 'a3) t -> ('a1 t * 'a2 t * 'a3 t) option
|
||||
val t4 : 'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> ('a1 * 'a2 * 'a3 * 'a4) t
|
||||
val elim_t4 :
|
||||
('a1 * 'a2 * 'a3 * 'a4) t -> ('a1 t * 'a2 t * 'a3 t * 'a4 t) option
|
||||
val t5 :
|
||||
'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t ->
|
||||
('a1 * 'a2 * 'a3 * 'a4 * 'a5) t
|
||||
val elim_t5 :
|
||||
('a1 * 'a2 * 'a3 * 'a4 * 'a5) t ->
|
||||
('a1 t * 'a2 t * 'a3 t * 'a4 t * 'a5 t) option
|
||||
val t6 :
|
||||
'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t -> 'a6 t ->
|
||||
('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6) t
|
||||
val elim_t6 :
|
||||
('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6) t ->
|
||||
('a1 t * 'a2 t * 'a3 t * 'a4 t * 'a5 t * 'a6 t) option
|
||||
val t7 :
|
||||
'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t -> 'a6 t -> 'a7 t ->
|
||||
('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7) t
|
||||
val elim_t7 :
|
||||
('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7) t ->
|
||||
('a1 t * 'a2 t * 'a3 t * 'a4 t * 'a5 t * 'a6 t * 'a7 t) option
|
||||
val t8 :
|
||||
'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t -> 'a6 t -> 'a7 t -> 'a8 t ->
|
||||
('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8) t
|
||||
val elim_t8 :
|
||||
('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8) t ->
|
||||
('a1 t * 'a2 t * 'a3 t * 'a4 t * 'a5 t * 'a6 t * 'a7 t * 'a8 t) option
|
||||
val t9 :
|
||||
'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t -> 'a6 t -> 'a7 t -> 'a8 t ->
|
||||
'a9 t ->
|
||||
('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9) t
|
||||
val elim_t9 :
|
||||
('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9) t ->
|
||||
('a1 t * 'a2 t * 'a3 t * 'a4 t * 'a5 t * 'a6 t * 'a7 t * 'a8 t * 'a9 t)
|
||||
option
|
||||
val t10 :
|
||||
'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t -> 'a6 t -> 'a7 t -> 'a8 t ->
|
||||
'a9 t -> 'a10 t ->
|
||||
('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10) t
|
||||
val elim_t10 :
|
||||
('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10) t ->
|
||||
('a1 t * 'a2 t * 'a3 t * 'a4 t * 'a5 t * 'a6 t * 'a7 t * 'a8 t * 'a9 t
|
||||
* 'a10 t) option
|
||||
val t11 :
|
||||
'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t -> 'a6 t -> 'a7 t -> 'a8 t ->
|
||||
'a9 t -> 'a10 t -> 'a11 t ->
|
||||
('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10 * 'a11) t
|
||||
val elim_t11 :
|
||||
('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10 * 'a11) t ->
|
||||
('a1 t * 'a2 t * 'a3 t * 'a4 t * 'a5 t * 'a6 t * 'a7 t * 'a8 t * 'a9 t
|
||||
* 'a10 t * 'a11 t) option
|
||||
val t12 :
|
||||
'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t -> 'a6 t -> 'a7 t -> 'a8 t ->
|
||||
'a9 t -> 'a10 t -> 'a11 t -> 'a12 t ->
|
||||
('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10 * 'a11 * 'a12) t
|
||||
val elim_t12 :
|
||||
('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10 * 'a11
|
||||
* 'a12) t ->
|
||||
('a1 t * 'a2 t * 'a3 t * 'a4 t * 'a5 t * 'a6 t * 'a7 t * 'a8 t * 'a9 t
|
||||
* 'a10 t * 'a11 t * 'a12 t) option
|
||||
end
|
||||
|
||||
let option t = Option t
|
||||
|
||||
let rec product_unifier
|
||||
: type a i. (i, a) product -> (i, i) Constructor.unifier =
|
||||
let open Constructor in
|
||||
(function
|
||||
| Proj_end -> Equal
|
||||
| Proj (_, _, prod) -> Assume (fun Type.Equal -> product_unifier prod))
|
||||
|
||||
exception Reject of string
|
||||
|
||||
let product : type i a. i -> (i, a) product -> a t =
|
||||
fun intro prod ->
|
||||
let open struct
|
||||
open Constructor
|
||||
type (_, _) tag += Tag : (i, a) tag
|
||||
let unify_tag : type j b. (j, b) tag -> (i, j) unifier option =
|
||||
(function
|
||||
| Tag -> Some (product_unifier prod)
|
||||
| _ -> None)
|
||||
let ctor = {tag = Tag; unify_tag; construct = intro}
|
||||
end in
|
||||
Product (ctor, prod)
|
||||
|
||||
let product' ctor prod = Product (ctor, prod)
|
||||
|
||||
let proj t p prod = Proj (t, p, prod)
|
||||
let proj_end = Proj_end
|
||||
|
||||
let enum ~encode ~decode name =
|
||||
product decode
|
||||
@@ proj (Field (Enum name)) encode
|
||||
@@ proj_end
|
||||
|
||||
let unit = product (Ok ()) proj_end
|
||||
|
||||
type (_, _) Constructor.tag +=
|
||||
| T2 : (
|
||||
'a0 -> 'a1 -> ('a0 * 'a1) Constructor.return,
|
||||
'a0 * 'a1
|
||||
) Constructor.tag
|
||||
| T3 : (
|
||||
'a0 -> 'a1 -> 'a2 -> ('a0 * 'a1 * 'a2) Constructor.return,
|
||||
'a0 * 'a1 * 'a2
|
||||
) Constructor.tag
|
||||
| T4 : (
|
||||
'a0 -> 'a1 -> 'a2 -> 'a3 ->
|
||||
('a0 * 'a1 * 'a2 * 'a3) Constructor.return,
|
||||
'a0 * 'a1 * 'a2 * 'a3
|
||||
) Constructor.tag
|
||||
| T5 : (
|
||||
'a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 ->
|
||||
('a0 * 'a1 * 'a2 * 'a3 * 'a4) Constructor.return,
|
||||
'a0 * 'a1 * 'a2 * 'a3 * 'a4
|
||||
) Constructor.tag
|
||||
| T6 : (
|
||||
'a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 ->
|
||||
('a0 * 'a1 * 'a2 * 'a3 * 'a4 * 'a5) Constructor.return,
|
||||
'a0 * 'a1 * 'a2 * 'a3 * 'a4 * 'a5
|
||||
) Constructor.tag
|
||||
| T7 : (
|
||||
'a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 ->
|
||||
('a0 * 'a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6) Constructor.return,
|
||||
'a0 * 'a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6
|
||||
) Constructor.tag
|
||||
| T8 : (
|
||||
'a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 -> 'a7 ->
|
||||
('a0 * 'a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7) Constructor.return,
|
||||
'a0 * 'a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7
|
||||
) Constructor.tag
|
||||
| T9 : (
|
||||
'a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 -> 'a7 -> 'a8 ->
|
||||
('a0 * 'a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8)
|
||||
Constructor.return,
|
||||
'a0 * 'a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8
|
||||
) Constructor.tag
|
||||
| T10 : (
|
||||
'a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 -> 'a7 -> 'a8 -> 'a9 ->
|
||||
('a0 * 'a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9)
|
||||
Constructor.return,
|
||||
'a0 * 'a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9
|
||||
) Constructor.tag
|
||||
| T11 : (
|
||||
'a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 -> 'a7 -> 'a8 -> 'a9 ->
|
||||
'a10 ->
|
||||
('a0 * 'a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10)
|
||||
Constructor.return,
|
||||
'a0 * 'a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10
|
||||
) Constructor.tag
|
||||
| T12 : (
|
||||
'a0 -> 'a1 -> 'a2 -> 'a3 -> 'a4 -> 'a5 -> 'a6 -> 'a7 -> 'a8 -> 'a9 ->
|
||||
'a10 -> 'a11 ->
|
||||
('a0 * 'a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10 * 'a11)
|
||||
Constructor.return,
|
||||
'a0 * 'a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10 * 'a11
|
||||
) Constructor.tag
|
||||
|
||||
let t2 =
|
||||
let unify_tag
|
||||
: type j b a0 a1.
|
||||
(j, b) Constructor.tag ->
|
||||
(a0 -> a1 -> (a0 * a1) Constructor.return, j) Constructor.unifier option =
|
||||
(function
|
||||
| T2 ->
|
||||
Some (Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal -> Equal)))
|
||||
| _ -> None)
|
||||
in
|
||||
let construct x0 x1 = Ok (x0, x1) in
|
||||
fun t0 t1 ->
|
||||
product' {tag = T2; unify_tag; construct}
|
||||
@@ proj t0 fst
|
||||
@@ proj t1 snd
|
||||
@@ proj_end
|
||||
|
||||
let elim_t2 : type a0 a1. (a0 * a1) t -> (a0 t * a1 t) option =
|
||||
(function
|
||||
| Product ({tag = T2; _}, Proj (t0, _, Proj (t1, _, Proj_end))) ->
|
||||
Some (t0, t1)
|
||||
| _ -> None)
|
||||
|
||||
let t3 =
|
||||
let unify_tag
|
||||
: type j b a0 a1 a2.
|
||||
(j, b) Constructor.tag ->
|
||||
(a0 -> a1 -> a2 -> (a0 * a1 * a2) Constructor.return, j)
|
||||
Constructor.unifier option =
|
||||
(function
|
||||
| T3 ->
|
||||
Some (Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal -> Equal))))
|
||||
| _ -> None)
|
||||
in
|
||||
let construct x0 x1 x2 = Ok (x0, x1, x2) in
|
||||
fun t0 t1 t2 ->
|
||||
product' {tag = T3; unify_tag; construct}
|
||||
@@ proj t0 (fun (x, _, _) -> x)
|
||||
@@ proj t1 (fun (_, x, _) -> x)
|
||||
@@ proj t2 (fun (_, _, x) -> x)
|
||||
@@ proj_end
|
||||
|
||||
let elim_t3 : type a0 a1 a2. (a0 * a1 * a2) t -> (a0 t * a1 t * a2 t) option =
|
||||
(function
|
||||
| Product ({tag = T3; _},
|
||||
Proj (t0, _,
|
||||
Proj (t1, _,
|
||||
Proj (t2, _, Proj_end)))) ->
|
||||
Some (t0, t1, t2)
|
||||
| _ -> None)
|
||||
|
||||
let t4 =
|
||||
let unify_tag
|
||||
: type j b a0 a1 a2 a3.
|
||||
(j, b) Constructor.tag ->
|
||||
(a0 -> a1 -> a2 -> a3 -> (a0 * a1 * a2 * a3) Constructor.return, j)
|
||||
Constructor.unifier option =
|
||||
(function
|
||||
| T4 ->
|
||||
Some (Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal -> Equal)))))
|
||||
| _ -> None)
|
||||
in
|
||||
let construct x0 x1 x2 x3 = Ok (x0, x1, x2, x3) in
|
||||
fun t0 t1 t2 t3 ->
|
||||
product' {tag = T4; unify_tag; construct}
|
||||
@@ proj t0 (fun (x, _, _, _) -> x)
|
||||
@@ proj t1 (fun (_, x, _, _) -> x)
|
||||
@@ proj t2 (fun (_, _, x, _) -> x)
|
||||
@@ proj t3 (fun (_, _, _, x) -> x)
|
||||
@@ proj_end
|
||||
|
||||
let elim_t4
|
||||
: type a0 a1 a2 a3.
|
||||
(a0 * a1 * a2 * a3) t -> (a0 t * a1 t * a2 t * a3 t) option =
|
||||
(function
|
||||
| Product ({tag = T4; _},
|
||||
Proj (t0, _,
|
||||
Proj (t1, _,
|
||||
Proj (t2, _,
|
||||
Proj (t3, _, Proj_end))))) ->
|
||||
Some (t0, t1, t2, t3)
|
||||
| _ -> None)
|
||||
|
||||
let t5 =
|
||||
let unify_tag
|
||||
: type j b a0 a1 a2 a3 a4.
|
||||
(j, b) Constructor.tag ->
|
||||
(a0 -> a1 -> a2 -> a3 -> a4 ->
|
||||
(a0 * a1 * a2 * a3 * a4) Constructor.return, j)
|
||||
Constructor.unifier option =
|
||||
(function
|
||||
| T5 ->
|
||||
Some (Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal -> Equal))))))
|
||||
| _ -> None)
|
||||
in
|
||||
let construct x0 x1 x2 x3 x4 = Ok (x0, x1, x2, x3, x4) in
|
||||
fun t0 t1 t2 t3 t4 ->
|
||||
product' {tag = T5; unify_tag; construct}
|
||||
@@ proj t0 (fun (x, _, _, _, _) -> x)
|
||||
@@ proj t1 (fun (_, x, _, _, _) -> x)
|
||||
@@ proj t2 (fun (_, _, x, _, _) -> x)
|
||||
@@ proj t3 (fun (_, _, _, x, _) -> x)
|
||||
@@ proj t4 (fun (_, _, _, _, x) -> x)
|
||||
@@ proj_end
|
||||
|
||||
let elim_t5
|
||||
: type a0 a1 a2 a3 a4.
|
||||
(a0 * a1 * a2 * a3 * a4) t -> (a0 t * a1 t * a2 t * a3 t * a4 t) option =
|
||||
(function
|
||||
| Product ({tag = T5; _},
|
||||
Proj (t0, _,
|
||||
Proj (t1, _,
|
||||
Proj (t2, _,
|
||||
Proj (t3, _,
|
||||
Proj (t4, _, Proj_end)))))) ->
|
||||
Some (t0, t1, t2, t3, t4)
|
||||
| _ -> None)
|
||||
|
||||
let t6 =
|
||||
let unify_tag
|
||||
: type j b a0 a1 a2 a3 a4 a5.
|
||||
(j, b) Constructor.tag ->
|
||||
(a0 -> a1 -> a2 -> a3 -> a4 -> a5 ->
|
||||
(a0 * a1 * a2 * a3 * a4 * a5) Constructor.return, j)
|
||||
Constructor.unifier option =
|
||||
(function
|
||||
| T6 ->
|
||||
Some (Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal -> Equal)))))))
|
||||
| _ -> None)
|
||||
in
|
||||
fun t0 t1 t2 t3 t4 t5 ->
|
||||
let construct x0 x1 x2 x3 x4 x5 = Ok (x0, x1, x2, x3, x4, x5) in
|
||||
product' {tag = T6; unify_tag; construct}
|
||||
@@ proj t0 (fun (x, _, _, _, _, _) -> x)
|
||||
@@ proj t1 (fun (_, x, _, _, _, _) -> x)
|
||||
@@ proj t2 (fun (_, _, x, _, _, _) -> x)
|
||||
@@ proj t3 (fun (_, _, _, x, _, _) -> x)
|
||||
@@ proj t4 (fun (_, _, _, _, x, _) -> x)
|
||||
@@ proj t5 (fun (_, _, _, _, _, x) -> x)
|
||||
@@ proj_end
|
||||
|
||||
let elim_t6
|
||||
: type a0 a1 a2 a3 a4 a5.
|
||||
(a0 * a1 * a2 * a3 * a4 * a5) t ->
|
||||
(a0 t * a1 t * a2 t * a3 t * a4 t * a5 t) option =
|
||||
(function
|
||||
| Product ({tag = T6; _},
|
||||
Proj (t0, _,
|
||||
Proj (t1, _,
|
||||
Proj (t2, _,
|
||||
Proj (t3, _,
|
||||
Proj (t4, _,
|
||||
Proj (t5, _, Proj_end))))))) ->
|
||||
Some (t0, t1, t2, t3, t4, t5)
|
||||
| _ -> None)
|
||||
|
||||
let t7 t0 t1 t2 t3 t4 t5 t6 =
|
||||
let unify_tag
|
||||
: type j b a0 a1 a2 a3 a4 a5 a6.
|
||||
(j, b) Constructor.tag ->
|
||||
(a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 ->
|
||||
(a0 * a1 * a2 * a3 * a4 * a5 * a6) Constructor.return, j)
|
||||
Constructor.unifier option =
|
||||
(function
|
||||
| T7 ->
|
||||
Some (Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal -> Equal))))))))
|
||||
| _ -> None)
|
||||
in
|
||||
let construct x0 x1 x2 x3 x4 x5 x6 = Ok (x0, x1, x2, x3, x4, x5, x6) in
|
||||
product' {tag = T7; unify_tag; construct}
|
||||
@@ proj t0 (fun (x, _, _, _, _, _, _) -> x)
|
||||
@@ proj t1 (fun (_, x, _, _, _, _, _) -> x)
|
||||
@@ proj t2 (fun (_, _, x, _, _, _, _) -> x)
|
||||
@@ proj t3 (fun (_, _, _, x, _, _, _) -> x)
|
||||
@@ proj t4 (fun (_, _, _, _, x, _, _) -> x)
|
||||
@@ proj t5 (fun (_, _, _, _, _, x, _) -> x)
|
||||
@@ proj t6 (fun (_, _, _, _, _, _, x) -> x)
|
||||
@@ proj_end
|
||||
|
||||
let elim_t7
|
||||
: type a0 a1 a2 a3 a4 a5 a6.
|
||||
(a0 * a1 * a2 * a3 * a4 * a5 * a6) t ->
|
||||
(a0 t * a1 t * a2 t * a3 t * a4 t * a5 t * a6 t) option =
|
||||
(function
|
||||
| Product ({tag = T7; _},
|
||||
Proj (t0, _,
|
||||
Proj (t1, _,
|
||||
Proj (t2, _,
|
||||
Proj (t3, _,
|
||||
Proj (t4, _,
|
||||
Proj (t5, _,
|
||||
Proj (t6, _, Proj_end)))))))) ->
|
||||
Some (t0, t1, t2, t3, t4, t5, t6)
|
||||
| _ -> None)
|
||||
|
||||
let t8 t0 t1 t2 t3 t4 t5 t6 t7 =
|
||||
let unify_tag
|
||||
: type j b a0 a1 a2 a3 a4 a5 a6 a7.
|
||||
(j, b) Constructor.tag ->
|
||||
(a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 ->
|
||||
(a0 * a1 * a2 * a3 * a4 * a5 * a6 * a7) Constructor.return, j)
|
||||
Constructor.unifier option =
|
||||
(function
|
||||
| T8 ->
|
||||
Some (Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal -> Equal)))))))))
|
||||
| _ -> None)
|
||||
in
|
||||
let construct x0 x1 x2 x3 x4 x5 x6 x7 = Ok (x0, x1, x2, x3, x4, x5, x6, x7) in
|
||||
product' {tag = T8; unify_tag; construct}
|
||||
@@ proj t0 (fun (x, _, _, _, _, _, _, _) -> x)
|
||||
@@ proj t1 (fun (_, x, _, _, _, _, _, _) -> x)
|
||||
@@ proj t2 (fun (_, _, x, _, _, _, _, _) -> x)
|
||||
@@ proj t3 (fun (_, _, _, x, _, _, _, _) -> x)
|
||||
@@ proj t4 (fun (_, _, _, _, x, _, _, _) -> x)
|
||||
@@ proj t5 (fun (_, _, _, _, _, x, _, _) -> x)
|
||||
@@ proj t6 (fun (_, _, _, _, _, _, x, _) -> x)
|
||||
@@ proj t7 (fun (_, _, _, _, _, _, _, x) -> x)
|
||||
@@ proj_end
|
||||
|
||||
let elim_t8
|
||||
: type a0 a1 a2 a3 a4 a5 a6 a7.
|
||||
(a0 * a1 * a2 * a3 * a4 * a5 * a6 * a7) t ->
|
||||
(a0 t * a1 t * a2 t * a3 t * a4 t * a5 t * a6 t * a7 t) option =
|
||||
(function
|
||||
| Product ({tag = T8; _},
|
||||
Proj (t0, _,
|
||||
Proj (t1, _,
|
||||
Proj (t2, _,
|
||||
Proj (t3, _,
|
||||
Proj (t4, _,
|
||||
Proj (t5, _,
|
||||
Proj (t6, _,
|
||||
Proj (t7, _, Proj_end))))))))) ->
|
||||
Some (t0, t1, t2, t3, t4, t5, t6, t7)
|
||||
| _ -> None)
|
||||
|
||||
let t9 t1 t2 t3 t4 t5 t6 t7 t8 t9 =
|
||||
let unify_tag
|
||||
: type j b a0 a1 a2 a3 a4 a5 a6 a7 a8.
|
||||
(j, b) Constructor.tag ->
|
||||
(a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 ->
|
||||
(a0 * a1 * a2 * a3 * a4 * a5 * a6 * a7 * a8) Constructor.return, j)
|
||||
Constructor.unifier option =
|
||||
(function
|
||||
| T9 ->
|
||||
Some (Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal -> Equal))))))))))
|
||||
| _ -> None)
|
||||
in
|
||||
let construct x0 x1 x2 x3 x4 x5 x6 x7 x8 =
|
||||
Ok (x0, x1, x2, x3, x4, x5, x6, x7, x8)
|
||||
in
|
||||
product' {tag = T9; unify_tag; construct}
|
||||
@@ proj t1 (fun (x, _, _, _, _, _, _, _, _) -> x)
|
||||
@@ proj t2 (fun (_, x, _, _, _, _, _, _, _) -> x)
|
||||
@@ proj t3 (fun (_, _, x, _, _, _, _, _, _) -> x)
|
||||
@@ proj t4 (fun (_, _, _, x, _, _, _, _, _) -> x)
|
||||
@@ proj t5 (fun (_, _, _, _, x, _, _, _, _) -> x)
|
||||
@@ proj t6 (fun (_, _, _, _, _, x, _, _, _) -> x)
|
||||
@@ proj t7 (fun (_, _, _, _, _, _, x, _, _) -> x)
|
||||
@@ proj t8 (fun (_, _, _, _, _, _, _, x, _) -> x)
|
||||
@@ proj t9 (fun (_, _, _, _, _, _, _, _, x) -> x)
|
||||
@@ proj_end
|
||||
|
||||
let elim_t9
|
||||
: type a0 a1 a2 a3 a4 a5 a6 a7 a8.
|
||||
(a0 * a1 * a2 * a3 * a4 * a5 * a6 * a7 * a8) t ->
|
||||
(a0 t * a1 t * a2 t * a3 t * a4 t * a5 t * a6 t * a7 t * a8 t) option =
|
||||
(function
|
||||
| Product ({tag = T9; _},
|
||||
Proj (t0, _,
|
||||
Proj (t1, _,
|
||||
Proj (t2, _,
|
||||
Proj (t3, _,
|
||||
Proj (t4, _,
|
||||
Proj (t5, _,
|
||||
Proj (t6, _,
|
||||
Proj (t7, _,
|
||||
Proj (t8, _, Proj_end)))))))))) ->
|
||||
Some (t0, t1, t2, t3, t4, t5, t6, t7, t8)
|
||||
| _ -> None)
|
||||
|
||||
let t10 t0 t1 t2 t3 t4 t5 t6 t7 t8 t9 =
|
||||
let unify_tag
|
||||
: type j b a0 a1 a2 a3 a4 a5 a6 a7 a8 a9.
|
||||
(j, b) Constructor.tag ->
|
||||
(a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 ->
|
||||
(a0 * a1 * a2 * a3 * a4 * a5 * a6 * a7 * a8 * a9)
|
||||
Constructor.return, j) Constructor.unifier option =
|
||||
(function
|
||||
| T10 ->
|
||||
Some (Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal -> Equal)))))))))))
|
||||
| _ -> None)
|
||||
in
|
||||
let construct x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 =
|
||||
Ok (x0, x1, x2, x3, x4, x5, x6, x7, x8, x9)
|
||||
in
|
||||
product' {tag = T10; unify_tag; construct}
|
||||
@@ proj t0 (fun (x, _, _, _, _, _, _, _, _, _) -> x)
|
||||
@@ proj t1 (fun (_, x, _, _, _, _, _, _, _, _) -> x)
|
||||
@@ proj t2 (fun (_, _, x, _, _, _, _, _, _, _) -> x)
|
||||
@@ proj t3 (fun (_, _, _, x, _, _, _, _, _, _) -> x)
|
||||
@@ proj t4 (fun (_, _, _, _, x, _, _, _, _, _) -> x)
|
||||
@@ proj t5 (fun (_, _, _, _, _, x, _, _, _, _) -> x)
|
||||
@@ proj t6 (fun (_, _, _, _, _, _, x, _, _, _) -> x)
|
||||
@@ proj t7 (fun (_, _, _, _, _, _, _, x, _, _) -> x)
|
||||
@@ proj t8 (fun (_, _, _, _, _, _, _, _, x, _) -> x)
|
||||
@@ proj t9 (fun (_, _, _, _, _, _, _, _, _, x) -> x)
|
||||
@@ proj_end
|
||||
|
||||
let elim_t10
|
||||
: type a0 a1 a2 a3 a4 a5 a6 a7 a8 a9.
|
||||
(a0 * a1 * a2 * a3 * a4 * a5 * a6 * a7 * a8 * a9) t ->
|
||||
(a0 t * a1 t * a2 t * a3 t * a4 t * a5 t * a6 t * a7 t * a8 t * a9 t)
|
||||
option =
|
||||
(function
|
||||
| Product ({tag = T10; _},
|
||||
Proj (t0, _,
|
||||
Proj (t1, _,
|
||||
Proj (t2, _,
|
||||
Proj (t3, _,
|
||||
Proj (t4, _,
|
||||
Proj (t5, _,
|
||||
Proj (t6, _,
|
||||
Proj (t7, _,
|
||||
Proj (t8, _,
|
||||
Proj (t9, _, Proj_end))))))))))) ->
|
||||
Some (t0, t1, t2, t3, t4, t5, t6, t7, t8, t9)
|
||||
| _ -> None)
|
||||
|
||||
let t11 t0 t1 t2 t3 t4 t5 t6 t7 t8 t9 t10 =
|
||||
let unify_tag
|
||||
: type j b a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10.
|
||||
(j, b) Constructor.tag ->
|
||||
(a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 -> a10 ->
|
||||
(a0 * a1 * a2 * a3 * a4 * a5 * a6 * a7 * a8 * a9 * a10)
|
||||
Constructor.return, j) Constructor.unifier option =
|
||||
(function
|
||||
| T11 ->
|
||||
Some (Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal -> Equal))))))))))))
|
||||
| _ -> None)
|
||||
in
|
||||
let construct x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 =
|
||||
Ok (x0, x1, x2, x3, x4, x5, x6, x7, x8, x9, x10)
|
||||
in
|
||||
product' {tag = T11; unify_tag; construct}
|
||||
@@ proj t0 (fun (x, _, _, _, _, _, _, _, _, _, _) -> x)
|
||||
@@ proj t1 (fun (_, x, _, _, _, _, _, _, _, _, _) -> x)
|
||||
@@ proj t2 (fun (_, _, x, _, _, _, _, _, _, _, _) -> x)
|
||||
@@ proj t3 (fun (_, _, _, x, _, _, _, _, _, _, _) -> x)
|
||||
@@ proj t4 (fun (_, _, _, _, x, _, _, _, _, _, _) -> x)
|
||||
@@ proj t5 (fun (_, _, _, _, _, x, _, _, _, _, _) -> x)
|
||||
@@ proj t6 (fun (_, _, _, _, _, _, x, _, _, _, _) -> x)
|
||||
@@ proj t7 (fun (_, _, _, _, _, _, _, x, _, _, _) -> x)
|
||||
@@ proj t8 (fun (_, _, _, _, _, _, _, _, x, _, _) -> x)
|
||||
@@ proj t9 (fun (_, _, _, _, _, _, _, _, _, x, _) -> x)
|
||||
@@ proj t10 (fun (_, _, _, _, _, _, _, _, _, _, x) -> x)
|
||||
@@ proj_end
|
||||
|
||||
let elim_t11
|
||||
: type a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10.
|
||||
(a0 * a1 * a2 * a3 * a4 * a5 * a6 * a7 * a8 * a9 * a10) t ->
|
||||
(a0 t * a1 t * a2 t * a3 t * a4 t * a5 t * a6 t * a7 t * a8 t * a9 t
|
||||
* a10 t) option =
|
||||
(function
|
||||
| Product ({tag = T11; _},
|
||||
Proj (t0, _,
|
||||
Proj (t1, _,
|
||||
Proj (t2, _,
|
||||
Proj (t3, _,
|
||||
Proj (t4, _,
|
||||
Proj (t5, _,
|
||||
Proj (t6, _,
|
||||
Proj (t7, _,
|
||||
Proj (t8, _,
|
||||
Proj (t9, _,
|
||||
Proj (t10, _, Proj_end)))))))))))) ->
|
||||
Some (t0, t1, t2, t3, t4, t5, t6, t7, t8, t9, t10)
|
||||
| _ -> None)
|
||||
|
||||
let t12 t0 t1 t2 t3 t4 t5 t6 t7 t8 t9 t10 t11 =
|
||||
let unify_tag
|
||||
: type j b a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11.
|
||||
(j, b) Constructor.tag ->
|
||||
(a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 -> a10 -> a11 ->
|
||||
(a0 * a1 * a2 * a3 * a4 * a5 * a6 * a7 * a8 * a9 * a10 * a11)
|
||||
Constructor.return, j) Constructor.unifier option =
|
||||
(function
|
||||
| T12 ->
|
||||
Some (Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal ->
|
||||
Assume (fun Type.Equal -> Equal)))))))))))))
|
||||
| _ -> None)
|
||||
in
|
||||
let construct x0 x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 =
|
||||
Ok (x0, x1, x2, x3, x4, x5, x6, x7, x8, x9, x10, x11)
|
||||
in
|
||||
product' {tag = T12; unify_tag; construct}
|
||||
@@ proj t0 (fun (x, _, _, _, _, _, _, _, _, _, _, _) -> x)
|
||||
@@ proj t1 (fun (_, x, _, _, _, _, _, _, _, _, _, _) -> x)
|
||||
@@ proj t2 (fun (_, _, x, _, _, _, _, _, _, _, _, _) -> x)
|
||||
@@ proj t3 (fun (_, _, _, x, _, _, _, _, _, _, _, _) -> x)
|
||||
@@ proj t4 (fun (_, _, _, _, x, _, _, _, _, _, _, _) -> x)
|
||||
@@ proj t5 (fun (_, _, _, _, _, x, _, _, _, _, _, _) -> x)
|
||||
@@ proj t6 (fun (_, _, _, _, _, _, x, _, _, _, _, _) -> x)
|
||||
@@ proj t7 (fun (_, _, _, _, _, _, _, x, _, _, _, _) -> x)
|
||||
@@ proj t8 (fun (_, _, _, _, _, _, _, _, x, _, _, _) -> x)
|
||||
@@ proj t9 (fun (_, _, _, _, _, _, _, _, _, x, _, _) -> x)
|
||||
@@ proj t10 (fun (_, _, _, _, _, _, _, _, _, _, x, _) -> x)
|
||||
@@ proj t11 (fun (_, _, _, _, _, _, _, _, _, _, _, x) -> x)
|
||||
@@ proj_end
|
||||
|
||||
let elim_t12
|
||||
: type a0 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11.
|
||||
(a0 * a1 * a2 * a3 * a4 * a5 * a6 * a7 * a8 * a9 * a10 * a11) t ->
|
||||
(a0 t * a1 t * a2 t * a3 t * a4 t * a5 t * a6 t * a7 t * a8 t * a9 t
|
||||
* a10 t * a11 t) option =
|
||||
(function
|
||||
| Product ({tag = T12; _},
|
||||
Proj (t0, _,
|
||||
Proj (t1, _,
|
||||
Proj (t2, _,
|
||||
Proj (t3, _,
|
||||
Proj (t4, _,
|
||||
Proj (t5, _,
|
||||
Proj (t6, _,
|
||||
Proj (t7, _,
|
||||
Proj (t8, _,
|
||||
Proj (t9, _,
|
||||
Proj (t10, _,
|
||||
Proj (t11, _, Proj_end))))))))))))) ->
|
||||
Some (t0, t1, t2, t3, t4, t5, t6, t7, t8, t9, t10, t11)
|
||||
| _ -> None)
|
||||
|
||||
let custom ~encode ~decode rep =
|
||||
let encode' x =
|
||||
(match encode x with
|
||||
| Ok y -> y
|
||||
| Error msg -> raise (Reject msg))
|
||||
in
|
||||
product decode @@ proj rep encode' @@ proj_end
|
||||
|
||||
let redacted t = Annot (`Redacted, t)
|
||||
|
||||
let bool = field Bool
|
||||
let int = field Int
|
||||
let int16 = field Int16
|
||||
let int32 = field Int32
|
||||
let int64 = field Int64
|
||||
let float = field Float
|
||||
let string = field String
|
||||
let octets = field Octets
|
||||
let pdate = field Pdate
|
||||
let ptime = field Ptime
|
||||
let ptime_span = field Ptime_span
|
||||
346
unikernel/duniverse/ocaml-caqti/caqti/lib-template/row_type.mli
Normal file
346
unikernel/duniverse/ocaml-caqti/caqti/lib-template/row_type.mli
Normal file
|
|
@ -0,0 +1,346 @@
|
|||
(* Copyright (C) 2018--2025 Petter A. Urkedal <paurkedal@gmail.com>
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or modify it
|
||||
* under the terms of the GNU Lesser General Public License as published by
|
||||
* the Free Software Foundation, either version 3 of the License, or (at your
|
||||
* option) any later version, with the LGPL-3.0 Linking Exception.
|
||||
*
|
||||
* This library is distributed in the hope that it will be useful, but WITHOUT
|
||||
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
||||
* FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
|
||||
* License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public License
|
||||
* and the LGPL-3.0 Linking Exception along with this library. If not, see
|
||||
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
|
||||
*)
|
||||
|
||||
(** Database row types, also used for parameters. *)
|
||||
|
||||
[@@@alert "-caqti_private"]
|
||||
|
||||
open Shims
|
||||
|
||||
type annot = [`Redacted] (* TODO: Consider open type. *)
|
||||
|
||||
(**/**)
|
||||
module Private : sig
|
||||
|
||||
type _ t =
|
||||
| Field : 'a Field_type.t -> 'a t
|
||||
| Option : 'a t -> 'a option t
|
||||
| Product : ('i, 'a) Constructor.t * ('i, 'a) product -> 'a t
|
||||
| Annot : annot * 'a t -> 'a t
|
||||
and (_, _) product =
|
||||
| Proj_end : ('a Constructor.return, 'a) product
|
||||
| Proj : 'b t * ('a -> 'b) * ('i, 'a) product -> ('b -> 'i, 'a) product
|
||||
end
|
||||
[@@alert caqti_private
|
||||
"This module exposes the internal representation of row types, which may \
|
||||
change between minor relases without prior notice."]
|
||||
(**/**)
|
||||
|
||||
(** {2:row_types Row Types} *)
|
||||
|
||||
type 'a t = 'a Private.t
|
||||
(** Type descriptor for row types. *)
|
||||
|
||||
type ('i, 'a) product = ('i, 'a) Private.product
|
||||
(** Type descriptor used for building cartesian products of row types. *)
|
||||
|
||||
type any = Any : 'a t -> any
|
||||
(** {!t} with existentially wrapped static type. *)
|
||||
|
||||
val unify : 'a t -> 'b t -> ('a, 'b) Type.eq option
|
||||
(** If [t1] and [t2] are the same row type representations, then [unify t1 t2]
|
||||
is the witness of the unification of their static type parameters, otherwise
|
||||
it is [None]. *)
|
||||
|
||||
val length : 'a t -> int
|
||||
(** [length t] is the number of fields used to represent [t]. *)
|
||||
|
||||
val pp : Format.formatter -> 'a t -> unit
|
||||
(** [pp ppf t] prints a human presentation of [t] on [ppf]. *)
|
||||
|
||||
val pp_any : Format.formatter -> any -> unit
|
||||
(** [pp_any ppf t] prints a human presentation of [t] on [ppf]. *)
|
||||
|
||||
val show : 'a t -> string
|
||||
(** [show t] is a human presentation of [t]. *)
|
||||
|
||||
val field : 'a Field_type.t -> 'a t
|
||||
(** [field ft] is a row of a single field of type [ft]. This function can be
|
||||
used when adding new field types; use the below functions otherwise. *)
|
||||
|
||||
exception Reject of string
|
||||
(** Implementers of {!val-product} types may raise this exception to signal that
|
||||
a conversion cannot be carried out. *)
|
||||
|
||||
val product : 'i -> ('i, 'a) product -> 'a t
|
||||
val product' : ('i, 'a) Constructor.t -> ('i, 'a) product -> 'a t
|
||||
val proj : 'b t -> ('a -> 'b) -> ('i, 'a) product -> ('b -> 'i, 'a) product
|
||||
val proj_end : ('a Constructor.return, 'a) product
|
||||
(** Given a set of projection functions [p1 : t -> t1], ..., [pN : t -> tN] and
|
||||
a function [intro : t1 -> ... -> tN -> t] to reconstruct values of [t] from
|
||||
the projections,
|
||||
{@ocaml skip[
|
||||
product intro
|
||||
@@ proj t1 p1
|
||||
@@ ...
|
||||
@@ proj tN pN
|
||||
@@ proj_end
|
||||
]}
|
||||
defines a Caqti type for [t], which on the database side will be represented
|
||||
by a consecutive list of fields corresponding to the types [t1], ..., [tN],
|
||||
each of which may be represented by multiple fields.
|
||||
That is, [intro [project1 x] ... [projectN x]] is equivalent to [x]
|
||||
according to an enforced or effective abstraction of [t] deemed adequate for
|
||||
the application logic.
|
||||
|
||||
[intro] may raise {!Reject} to indicate that a value cannot be constructed
|
||||
from the given arguments.
|
||||
Projection operators may also raise this exception to indicate that an
|
||||
object cannot be represented in the database, e.g. due to an overflow.
|
||||
|
||||
The above only states that [intro] is a left (pseudo-)inverse of the
|
||||
projections, which is what matters for a faithful representation of OCaml
|
||||
values.
|
||||
The opposite (projection functions being the left inverse of [intro]) may
|
||||
be relevant if the application needs preserve the database representation
|
||||
when updating objects. *)
|
||||
|
||||
val enum :
|
||||
encode: ('a -> string) ->
|
||||
decode: (string -> ('a, string) result) ->
|
||||
string -> 'a t
|
||||
(** [enum ~encode ~decode name] creates an enum type which on the SQL side is
|
||||
named [name], with cases which are converted with [encode] and [decode]
|
||||
functions. This is implemented in terms of the {!Field_type.Enum} field
|
||||
type. *)
|
||||
|
||||
val custom :
|
||||
encode: ('a -> ('b, string) result) ->
|
||||
decode: ('b -> ('a, string) result) ->
|
||||
'b t -> 'a t
|
||||
(** [custom ~encode ~decode rep] creates a custom type represented by [rep],
|
||||
where [encode] is used to encode parameters into [rep] and [decode] is used
|
||||
to decode result rows from [rep]. *)
|
||||
|
||||
(** Standard type descriptors to use for request construction. *)
|
||||
module type STD = sig
|
||||
|
||||
(** {3 Field Types}
|
||||
|
||||
The following types correspond to what usually fits in a single field of a
|
||||
result row or input parameter set. *)
|
||||
|
||||
val bool : bool t
|
||||
(** A [bool] mapped to [boolean] on the SQL side if supported, otherwise
|
||||
mapped to an integer. *)
|
||||
|
||||
val int : int t
|
||||
(** An [int] mapped to a sufficiently wide integer on the SQL side. *)
|
||||
|
||||
val int16 : int t
|
||||
(** An [int] mapped to a [smallint] (16 bits) on the SQL side. *)
|
||||
|
||||
val int32 : int32 t
|
||||
(** An [int32] mapped to an [integer] (32 bits) on the SQL side. *)
|
||||
|
||||
val int64 : int64 t
|
||||
(** An [int64] mapped to a [bigint] (64 bits) on the SQL side. *)
|
||||
|
||||
val float : float t
|
||||
(** A [float] mapped to [double precision] or (best alternative) on the SQL
|
||||
side. Serialization may be lossy (e.g. base 10 may be used), so even if
|
||||
both sides support IEEE 754 double precision numbers, there may be
|
||||
discrepancies in the last digits of the binary representaton. *)
|
||||
|
||||
val string : string t
|
||||
(** An UTF-8 string. The database should accept UTF-8 if non-ASCII characters
|
||||
are present. *)
|
||||
|
||||
val octets : string t
|
||||
(** A [string] mapped to whichever type is used to represent binary data on
|
||||
the SQL side. *)
|
||||
|
||||
val pdate : Ptime.t t
|
||||
(** A time truncated to a date and mapped to the SQL [date] type. *)
|
||||
|
||||
val ptime : Ptime.t t
|
||||
(** An absolute time with driver-dependent precision. This corresponds to an
|
||||
SQL [timestamp with time zone] or a suitable alternative where not
|
||||
available:
|
||||
|
||||
- MariaDB has [datetime] which is similar to the SQL [timestamp] and
|
||||
[timestamp] which is similar to the SQL [timestamp with time zone],
|
||||
but the driver does not make the distinction. Caqti sets the session
|
||||
time zone to UTC to avoid misinterpretation, since time values are
|
||||
passed in both directions without time zones. Values have microsecond
|
||||
precision, but you will need to specify the desired precision in the
|
||||
database schema to avoid truncation.
|
||||
|
||||
- PostgreSQL supports this type and it's a good option to avoid any time
|
||||
zone issues if used conistently both on the client side, in SQL
|
||||
expressions, and in the database schema.
|
||||
Note that [timestamp with time zone] is stored as UTC without time
|
||||
zone, taking up no more space then [timestamp].
|
||||
The PostgreSQL [timestamp] type is problematic since how conversions
|
||||
work and the manual indicate that it is meant to be a local time, and
|
||||
since database columns of this type stores the value without
|
||||
conversion to UTC, it becomes prone to time zone changes.
|
||||
To mitigate the issue, Caqti sets the time zone of sessions to UTC.
|
||||
|
||||
- Sqlite3 does not have a dedicated type for absolute time. The date
|
||||
and time is sent as strings expressed at the UTC time zone using same
|
||||
format that the SQLite {{:https://sqlite.org/lang_datefunc.html}
|
||||
datetime} function and [CURRENT_TIMESTAMP] return, except for an
|
||||
additional three decimals to achive millisecond precision.
|
||||
|
||||
It might seem better to use standard RFC3339 format, since it is
|
||||
accepted by the SQLite functions, but that would misorder some time
|
||||
values if mixed with the results of these functions, even just the "Z"
|
||||
suffix would misorder values with different precision.
|
||||
|
||||
Date and time values which comes from the database without time zone are
|
||||
interpreted as UTC. This is not necessarily correct, and it is highly
|
||||
recommended to use SQL types which are transmitted with time zone
|
||||
information, even if this is UTC. *)
|
||||
|
||||
val ptime_span : Ptime.span t
|
||||
(** A period of time. If the database lacks a dedicated representation, the
|
||||
integer number of seconds is used. *)
|
||||
|
||||
|
||||
(** {3 Composite Types} *)
|
||||
|
||||
val option : 'a t -> 'a option t
|
||||
(** [option t] turns a set of fields encoded as [t] into a correspending set
|
||||
of nullable fields. The encoder will encode [None] as into a tuple of
|
||||
[NULL] values and the decoder will return [None] if all fields are [NULL].
|
||||
|
||||
If the type [t] itself is [option t'] for some [t'], or contains nested
|
||||
tuples and options such that all field types are nested under an option
|
||||
type, then it would have been possible to decode an all-[NULL] segment of
|
||||
a row as [Some x] where [x] is a corresponding tuple-option-tree
|
||||
terminating in [None] values. The above paragraph resolves this ambiguity
|
||||
since it implies that the outermost option possible will be decoded as
|
||||
[None]. *)
|
||||
|
||||
val redacted : 'a t -> 'a t
|
||||
(** [redacted t] is the same type as [t] but sealed as potentially containing
|
||||
sensitive information to be redacted from pretty-printers and logs. *)
|
||||
|
||||
|
||||
(** {3 Tuple Types}
|
||||
|
||||
As a common case of composite types, constructors for tuples up to 12
|
||||
components are predefined here. Higher tuples can be created with
|
||||
{!Row_type.val-product}. *)
|
||||
|
||||
val unit : unit t
|
||||
(** A type holding no fields. This is used to pass no parameters and as the
|
||||
result for queries which does not return any rows. It can also be nested
|
||||
in tuples, in which case it will not contribute to the total number of
|
||||
fields. *)
|
||||
|
||||
val t2 : 'a1 t -> 'a2 t -> ('a1 * 'a2) t
|
||||
(** Creates a pair type. *)
|
||||
|
||||
val elim_t2 : ('a1 * 'a2) t -> ('a1 t * 'a2 t) option
|
||||
|
||||
val t3 : 'a1 t -> 'a2 t -> 'a3 t -> ('a1 * 'a2 * 'a3) t
|
||||
(** Creates a 3-tuple type. *)
|
||||
|
||||
val elim_t3 : ('a1 * 'a2 * 'a3) t -> ('a1 t * 'a2 t * 'a3 t) option
|
||||
|
||||
val t4 : 'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> ('a1 * 'a2 * 'a3 * 'a4) t
|
||||
(** Creates a 4-tuple type. *)
|
||||
|
||||
val elim_t4 :
|
||||
('a1 * 'a2 * 'a3 * 'a4) t -> ('a1 t * 'a2 t * 'a3 t * 'a4 t) option
|
||||
|
||||
val t5 :
|
||||
'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t ->
|
||||
('a1 * 'a2 * 'a3 * 'a4 * 'a5) t
|
||||
(** Creates a 5-tuple type. *)
|
||||
|
||||
val elim_t5 :
|
||||
('a1 * 'a2 * 'a3 * 'a4 * 'a5) t ->
|
||||
('a1 t * 'a2 t * 'a3 t * 'a4 t * 'a5 t) option
|
||||
|
||||
val t6 :
|
||||
'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t -> 'a6 t ->
|
||||
('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6) t
|
||||
(** Creates a 6-tuple type. *)
|
||||
|
||||
val elim_t6 :
|
||||
('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6) t ->
|
||||
('a1 t * 'a2 t * 'a3 t * 'a4 t * 'a5 t * 'a6 t) option
|
||||
|
||||
val t7 :
|
||||
'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t -> 'a6 t -> 'a7 t ->
|
||||
('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7) t
|
||||
(** Creates a 7-tuple type. *)
|
||||
|
||||
val elim_t7 :
|
||||
('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7) t ->
|
||||
('a1 t * 'a2 t * 'a3 t * 'a4 t * 'a5 t * 'a6 t * 'a7 t) option
|
||||
|
||||
val t8 :
|
||||
'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t -> 'a6 t -> 'a7 t -> 'a8 t ->
|
||||
('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8) t
|
||||
(** Creates a 8-tuple type. *)
|
||||
|
||||
val elim_t8 :
|
||||
('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8) t ->
|
||||
('a1 t * 'a2 t * 'a3 t * 'a4 t * 'a5 t * 'a6 t * 'a7 t * 'a8 t) option
|
||||
|
||||
val t9 :
|
||||
'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t -> 'a6 t -> 'a7 t -> 'a8 t ->
|
||||
'a9 t ->
|
||||
('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9) t
|
||||
(** Creates a 9-tuple type. *)
|
||||
|
||||
val elim_t9 :
|
||||
('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9) t ->
|
||||
('a1 t * 'a2 t * 'a3 t * 'a4 t * 'a5 t * 'a6 t * 'a7 t * 'a8 t * 'a9 t)
|
||||
option
|
||||
|
||||
val t10 :
|
||||
'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t -> 'a6 t -> 'a7 t -> 'a8 t ->
|
||||
'a9 t -> 'a10 t ->
|
||||
('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10) t
|
||||
(** Creates a 10-tuple type. *)
|
||||
|
||||
val elim_t10 :
|
||||
('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10) t ->
|
||||
('a1 t * 'a2 t * 'a3 t * 'a4 t * 'a5 t * 'a6 t * 'a7 t * 'a8 t * 'a9 t
|
||||
* 'a10 t) option
|
||||
|
||||
val t11 :
|
||||
'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t -> 'a6 t -> 'a7 t -> 'a8 t ->
|
||||
'a9 t -> 'a10 t -> 'a11 t ->
|
||||
('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10 * 'a11) t
|
||||
(** Creates a 11-tuple type. *)
|
||||
|
||||
val elim_t11 :
|
||||
('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10 * 'a11) t ->
|
||||
('a1 t * 'a2 t * 'a3 t * 'a4 t * 'a5 t * 'a6 t * 'a7 t * 'a8 t * 'a9 t
|
||||
* 'a10 t * 'a11 t) option
|
||||
|
||||
val t12 :
|
||||
'a1 t -> 'a2 t -> 'a3 t -> 'a4 t -> 'a5 t -> 'a6 t -> 'a7 t -> 'a8 t ->
|
||||
'a9 t -> 'a10 t -> 'a11 t -> 'a12 t ->
|
||||
('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10 * 'a11 * 'a12) t
|
||||
(** Creates a 12-tuple type. *)
|
||||
|
||||
val elim_t12 :
|
||||
('a1 * 'a2 * 'a3 * 'a4 * 'a5 * 'a6 * 'a7 * 'a8 * 'a9 * 'a10 * 'a11
|
||||
* 'a12) t ->
|
||||
('a1 t * 'a2 t * 'a3 t * 'a4 t * 'a5 t * 'a6 t * 'a7 t * 'a8 t * 'a9 t
|
||||
* 'a10 t * 'a11 t * 'a12 t) option
|
||||
|
||||
end
|
||||
|
||||
include STD
|
||||
|
|
@ -0,0 +1,20 @@
|
|||
(* Copyright (C) 2025 Petter A. Urkedal <paurkedal@gmail.com>
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or modify it
|
||||
* under the terms of the GNU Lesser General Public License as published by
|
||||
* the Free Software Foundation, either version 3 of the License, or (at your
|
||||
* option) any later version, with the LGPL-3.0 Linking Exception.
|
||||
*
|
||||
* This library is distributed in the hope that it will be useful, but WITHOUT
|
||||
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
||||
* FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
|
||||
* License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public License
|
||||
* and the LGPL-3.0 Linking Exception along with this library. If not, see
|
||||
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
|
||||
*)
|
||||
|
||||
module Type = struct
|
||||
type ('a, 'b) eq = ('a, 'b) Stdlib.Type.eq = Equal : ('a, 'a) eq
|
||||
end
|
||||
|
|
@ -0,0 +1,26 @@
|
|||
(* Copyright (C) 2025 Petter A. Urkedal <paurkedal@gmail.com>
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or modify it
|
||||
* under the terms of the GNU Lesser General Public License as published by
|
||||
* the Free Software Foundation, either version 3 of the License, or (at your
|
||||
* option) any later version, with the LGPL-3.0 Linking Exception.
|
||||
*
|
||||
* This library is distributed in the hope that it will be useful, but WITHOUT
|
||||
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
||||
* FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
|
||||
* License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public License
|
||||
* and the LGPL-3.0 Linking Exception along with this library. If not, see
|
||||
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
|
||||
*)
|
||||
|
||||
(** Compatibility shims.
|
||||
|
||||
The documentation of this interface is generated for OCaml 5.1 and later.
|
||||
It depends on recent additions to the standard library.
|
||||
For older compilers, an equivalent implementation is provided. *)
|
||||
|
||||
module Type : sig
|
||||
type ('a, 'b) eq = ('a, 'b) Stdlib.Type.eq = Equal : ('a, 'a) eq
|
||||
end
|
||||
|
|
@ -0,0 +1,20 @@
|
|||
(* Copyright (C) 2024 Petter A. Urkedal <paurkedal@gmail.com>
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or modify it
|
||||
* under the terms of the GNU Lesser General Public License as published by
|
||||
* the Free Software Foundation, either version 3 of the License, or (at your
|
||||
* option) any later version, with the LGPL-3.0 Linking Exception.
|
||||
*
|
||||
* This library is distributed in the hope that it will be useful, but WITHOUT
|
||||
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
||||
* FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
|
||||
* License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public License
|
||||
* and the LGPL-3.0 Linking Exception along with this library. If not, see
|
||||
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
|
||||
*)
|
||||
|
||||
module Type = struct
|
||||
type (_, _) eq = Equal : ('a, 'a) eq (* OCaml 5.1 *)
|
||||
end
|
||||
|
|
@ -0,0 +1,28 @@
|
|||
(* Copyright (C) 2024 Petter A. Urkedal <paurkedal@gmail.com>
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or modify it
|
||||
* under the terms of the GNU Lesser General Public License as published by
|
||||
* the Free Software Foundation, either version 3 of the License, or (at your
|
||||
* option) any later version, with the LGPL-3.0 Linking Exception.
|
||||
*
|
||||
* This library is distributed in the hope that it will be useful, but WITHOUT
|
||||
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
||||
* FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
|
||||
* License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public License
|
||||
* and the LGPL-3.0 Linking Exception along with this library. If not, see
|
||||
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
|
||||
*)
|
||||
|
||||
(** Compatibility shims.
|
||||
|
||||
This is the fallback implementation providing replacements for recent
|
||||
additions to the standard library. *)
|
||||
|
||||
module Type : sig
|
||||
type (_, _) eq = Equal : ('a, 'a) eq
|
||||
(** Type equality witness. This will eventually be replaced by the equavalent
|
||||
definition available in [Stdlib.Type] since OCaml 5.1, but for now, we
|
||||
must keep backwards compatibility with older compilers. *)
|
||||
end
|
||||
106
unikernel/duniverse/ocaml-caqti/caqti/lib-template/version.ml
Normal file
106
unikernel/duniverse/ocaml-caqti/caqti/lib-template/version.ml
Normal file
|
|
@ -0,0 +1,106 @@
|
|||
(* Copyright (C) 2024--2025 Petter A. Urkedal <paurkedal@gmail.com>
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or modify it
|
||||
* under the terms of the GNU Lesser General Public License as published by
|
||||
* the Free Software Foundation, either version 3 of the License, or (at your
|
||||
* option) any later version, with the LGPL-3.0 Linking Exception.
|
||||
*
|
||||
* This library is distributed in the hope that it will be useful, but WITHOUT
|
||||
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
||||
* FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
|
||||
* License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public License
|
||||
* and the LGPL-3.0 Linking Exception along with this library. If not, see
|
||||
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
|
||||
*)
|
||||
|
||||
type t = string
|
||||
|
||||
let is_known v = v <> ""
|
||||
|
||||
let rec skip_zeros_from s i =
|
||||
if i = String.length s || s.[i] <> '0' then i else
|
||||
skip_zeros_from s (i + 1)
|
||||
|
||||
let rec skip_digits_from s i =
|
||||
if i = String.length s then i else
|
||||
(match s.[i] with
|
||||
| '0'..'9' -> skip_digits_from s (i + 1)
|
||||
| _ -> i)
|
||||
|
||||
let rec compare_with_empty v i j =
|
||||
if i = j then 0 else
|
||||
(match v.[i] with
|
||||
| '~' -> -1
|
||||
| '0' | '.' | '-' -> compare_with_empty v (i + 1) j
|
||||
| _ -> 1)
|
||||
|
||||
let compare_char chL chR =
|
||||
if chL = chR then 0 else
|
||||
if chL = '~' then -1 else
|
||||
if chR = '~' then +1 else
|
||||
Char.compare chL chR
|
||||
|
||||
let skip_group s i =
|
||||
(match String.index_from_opt s i '-' with
|
||||
| None -> String.length s
|
||||
| Some j -> j)
|
||||
|
||||
let compare vL vR =
|
||||
let nL, nR = String.length vL, String.length vR in
|
||||
let rec start iL iR =
|
||||
if iL = nL && iR = nR then 0 else
|
||||
if iL = nL then - compare_with_empty vR iR nR else
|
||||
if iR = nR then + compare_with_empty vL iL nL else
|
||||
(match vL.[iL], vR.[iR] with
|
||||
| '.', '.' -> start (iL + 1) (iR + 1)
|
||||
| '-', '-' -> start (iL + 1) (iR + 1)
|
||||
| '.', '-' ->
|
||||
let jL = skip_group vL (iL + 1) in
|
||||
let c = compare_with_empty vL (iL + 1) jL in
|
||||
if c <> 0 then +c else start jL iR
|
||||
| '-', '.' ->
|
||||
let jR = skip_group vR (iR + 1) in
|
||||
let c = compare_with_empty vR (iR + 1) jR in
|
||||
if c <> 0 then -c else start iL jR
|
||||
| '0'..'9', '0'..'9' ->
|
||||
let iL = skip_zeros_from vL iL in
|
||||
let iR = skip_zeros_from vR iR in
|
||||
let kL = skip_digits_from vL iL in
|
||||
let kR = skip_digits_from vR iR in
|
||||
if kL - iL < kR - iR then -1 else
|
||||
if kL - iL > kR - iR then +1 else
|
||||
let c = digits iL iR (kL - iL) in
|
||||
if c < 0 then -1 else
|
||||
if c > 0 then +1 else
|
||||
start kL kR
|
||||
| chL, chR ->
|
||||
let c = compare_char chL chR in
|
||||
if c < 0 then -1 else
|
||||
if c > 0 then +1 else
|
||||
start (iL + 1) (iR + 1))
|
||||
and digits iL iR n =
|
||||
if n = 0 then start iL iR else
|
||||
let c = Char.compare vL.[iL] vR.[iR] in
|
||||
if c < 0 then -1 else
|
||||
if c > 0 then +1 else
|
||||
digits (iL + 1) (iR + 1) (n - 1)
|
||||
in
|
||||
start 0 0
|
||||
|
||||
let equal vL vR = compare vL vR = 0
|
||||
|
||||
let pp ppf version =
|
||||
Format.pp_print_string ppf (if is_known version then version else "[unknown]")
|
||||
|
||||
let of_string_unsafe version = version
|
||||
|
||||
module Infix = struct
|
||||
let ( =* ) v1 v2 = compare v1 v2 = 0
|
||||
let ( <>* ) v1 v2 = compare v1 v2 <> 0
|
||||
let ( <* ) v1 v2 = compare v1 v2 < 0
|
||||
let ( <=* ) v1 v2 = compare v1 v2 <= 0
|
||||
let ( >* ) v1 v2 = compare v1 v2 > 0
|
||||
let ( >=* ) v1 v2 = compare v1 v2 >= 0
|
||||
end
|
||||
|
|
@ -0,0 +1,84 @@
|
|||
(* Copyright (C) 2024--2025 Petter A. Urkedal <paurkedal@gmail.com>
|
||||
*
|
||||
* This library is free software; you can redistribute it and/or modify it
|
||||
* under the terms of the GNU Lesser General Public License as published by
|
||||
* the Free Software Foundation, either version 3 of the License, or (at your
|
||||
* option) any later version, with the LGPL-3.0 Linking Exception.
|
||||
*
|
||||
* This library is distributed in the hope that it will be useful, but WITHOUT
|
||||
* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
|
||||
* FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
|
||||
* License for more details.
|
||||
*
|
||||
* You should have received a copy of the GNU Lesser General Public License
|
||||
* and the LGPL-3.0 Linking Exception along with this library. If not, see
|
||||
* <http://www.gnu.org/licenses/> and <https://spdx.org>, respectively.
|
||||
*)
|
||||
|
||||
(** Opaque version strings with comparison.
|
||||
|
||||
This version number module is intended for dispatching on details about an
|
||||
SQL intepreter or other relevant aspects of a relational database system.
|
||||
The only constructor is private, instead the {!Infix} module provides direct
|
||||
comparison to strings for ideomatic usage in the query-returning callback of
|
||||
request templates.
|
||||
|
||||
Some care is needed to match ranges of versions correctly:
|
||||
|
||||
- A version provided by {!Dialect} may by unknown. An unknown version
|
||||
compares like the empty string, meaning that it compares before any
|
||||
other (sensible) version. If another logic is desired, {!is_known} can
|
||||
be used to distinugish it.
|
||||
|
||||
- A version provided by {!Dialect} may also include build numbers,
|
||||
distribution details, etc. Therefore it seldom makes sense to compare
|
||||
it agains the exact version of the software release. Such versions will
|
||||
instead compare between the version of the corresponding software
|
||||
release and the next possible version using a normal decimal-dotted
|
||||
versioning scheme. *)
|
||||
|
||||
type t
|
||||
|
||||
val is_known : t -> bool
|
||||
(** Tests whether a version from the database server is available. *)
|
||||
|
||||
val compare : t -> t -> int
|
||||
(** Compares two versions lexicographically group-by-group and
|
||||
component-by-component, using common conventions for comparing version
|
||||
numbers:
|
||||
|
||||
- Groups of components are separated by ['-'].
|
||||
- Components are separated by ['.'].
|
||||
- Continuous sequences of digits are compared numerically, i.e. after
|
||||
skipping leading zeros, longer such sequences compare after shorter
|
||||
ones.
|
||||
- ['~'] compares before anything else, including the empty suffix.
|
||||
|
||||
The ordering subject to change if we should encounter problematic
|
||||
differences with versioning schemes used by supported database systems. *)
|
||||
|
||||
val equal : t -> t -> bool
|
||||
(** [equal x y] is equivalent to [compare x y = 0]. *)
|
||||
|
||||
module Infix : sig
|
||||
val ( =* ) : t -> string -> bool
|
||||
val ( <>* ) : t -> string -> bool
|
||||
val ( <* ) : t -> string -> bool
|
||||
val ( <=* ) : t -> string -> bool
|
||||
val ( >* ) : t -> string -> bool
|
||||
val ( >=* ) : t -> string -> bool
|
||||
end
|
||||
(** Asymmetric infix oparator for testing version ranges. The first argument is
|
||||
a version number, typically obtained from the [server_version] fields of
|
||||
{!Dialect.t}, and the second argument is a string representation of the
|
||||
version to compare against.
|
||||
|
||||
An unknown version compares before other versions. Use {!Version.is_known}
|
||||
to implement a different logic. See {!Version.compare} for details about
|
||||
the comparison algorithm. *)
|
||||
|
||||
val pp : Format.formatter -> t -> unit
|
||||
|
||||
(**/**)
|
||||
val of_string_unsafe : string -> t
|
||||
[@@alert caqti_private "For use by Caqti drivers."]
|
||||
Loading…
Add table
Add a link
Reference in a new issue