Created
July 2, 2021 12:08
Star
You must be signed in to star a gist
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
open Import | |
(** Database catalogue. *) | |
module Catalog = struct | |
type schema = string | |
and table = { | |
schema: schema; | |
name: string; | |
columns: column list; | |
} | |
and column = string | |
[@@deriving sexp_of, compare] | |
type t = schema | |
let pp_table ppf table = Fmt.pf ppf "%s.%s" table.schema table.name | |
end | |
(** Represent OCaml values. *) | |
module Value = struct | |
type t = | |
| String of string | |
| Int of int | |
| Float of float | |
| Bool of bool | |
[@@deriving sexp_of, compare] | |
let bool v = Bool v | |
let string v = String v | |
let int v = Int v | |
let float v = Float v | |
end | |
(** Binary operators. *) | |
module Bin_op = struct | |
type t = | |
| EQ | |
| NEQ | |
| AND | |
| OR | |
| MUL | |
| ADD | |
| SUB | |
| DIV | |
[@@deriving sexp_of, compare] | |
end | |
(** SQL Abstract Syntax Tree, used for codegen. *) | |
module Sql = struct | |
type select = { | |
fields : (expr * string option) list; | |
from : from; | |
where : expr option; | |
group_by : expr list option; | |
} | |
and expr = | |
| Expr_column of (string option * string) | |
| Expr_value of Value.t | |
| Expr_binop of Bin_op.t * expr * expr | |
| Expr_exists of select | |
| Expr_call of string * expr list | |
and from_one = | |
| From_table of Catalog.table * string option | |
| From_select of select * string option | |
and from = | |
| From of from_one | |
| From_join of from * from_one * expr | |
let rec ppsql_select ppf select = | |
Fmt.hovbox (fun ppf {fields; from; where; group_by;} -> | |
Fmt.pf ppf | |
"SELECT@ %a%a%a%a" | |
ppsql_fields fields | |
ppsql_from from | |
(Fmt.option ppsql_where) where | |
(Fmt.option ppsql_group_by) group_by | |
) ppf select | |
and ppsql_from ppf = | |
function | |
| From from_one -> | |
Fmt.pf ppf "@ FROM %a" ppsql_from_one from_one | |
| From_join (base, join, expr) -> | |
Fmt.pf ppf | |
"%a@ JOIN %a@ ON %a" | |
ppsql_from base | |
ppsql_from_one join | |
ppsql_expr expr | |
and ppsql_from_one ppf = | |
function | |
| From_table (table, alias) -> | |
let alias = Option.value alias ~default:"__query" in | |
Fmt.pf ppf "%a%a" ppsql_table table ppsql_alias alias | |
| From_select (select, alias) -> | |
let alias = Option.value alias ~default:"__query" in | |
Fmt.pf ppf "(%a)%a" ppsql_select select ppsql_alias alias | |
and ppsql_where ppf expr = | |
Fmt.pf ppf "@ WHERE %a" ppsql_expr expr | |
and ppsql_group_by ppf = function | |
| [] -> Fmt.pf ppf "@ GROUP BY ()" | |
| exprs -> Fmt.pf ppf "@ GROUP BY %a" Fmt.(list ppsql_expr) exprs | |
and ppsql_fields ppf = | |
let ppsql_field ppf (expr, alias) = | |
ppsql_expr ppf expr; | |
(Fmt.option ppsql_alias) ppf alias | |
in | |
let sep ppf () = Fmt.pf ppf ", " in | |
Fmt.(list ~sep ppsql_field) ppf | |
and ppsql_expr ppf = function | |
| Expr_value value -> ppsql_value ppf value | |
| Expr_column (qual, name) -> | |
let qual = Option.value qual ~default:"__query" in | |
Fmt.pf ppf "%a.%a" Fmt.(quote string) qual Fmt.(quote string) name | |
| Expr_binop (op, a, b) -> | |
Fmt.pf ppf "(%a %a %a)" ppsql_expr a ppsql_binop op ppsql_expr b | |
| Expr_exists select -> | |
Fmt.pf ppf "EXISTS (%a)" ppsql_select select | |
| Expr_call ("count" as name, []) -> | |
Fmt.pf ppf "%s(*)" name | |
| Expr_call (name, args) -> | |
Fmt.pf ppf "%s(%a)" name Fmt.(list ppsql_expr) args | |
and ppsql_binop ppf binop = | |
let v = | |
match binop with | |
| Bin_op.EQ -> "=" | |
| NEQ -> "!=" | |
| AND -> "AND" | |
| OR -> "OR" | |
| MUL -> "*" | |
| ADD -> "+" | |
| SUB -> "-" | |
| DIV -> "/" | |
in | |
Fmt.(const string) v ppf () | |
and ppsql_value ppf = function | |
| Value.String v -> Fmt.(quote ~mark:"'" string) ppf v | |
| Bool v -> Fmt.bool ppf v | |
| Int v -> Fmt.int ppf v | |
| Float v -> Fmt.float ppf v | |
and ppsql_table ppf table = | |
Fmt.pf ppf "%s.%s" table.Catalog.schema table.Catalog.name | |
and ppsql_alias ppf alias = | |
Fmt.pf ppf " AS %a" Fmt.(quote string) alias | |
let ppsql = ppsql_select | |
end | |
(** Query Language. *) | |
module Syntax = struct | |
type t = rel | |
(* Relational operators ... *) | |
and rel = | |
| From of Catalog.table | |
| Where of rel * expr | |
| Select of rel * (expr * string) list | |
| Name of rel * string | |
| Join of rel * rel * expr | |
| Define of rel * (expr * string) list | |
| Group of rel * (expr * string) list | |
(* ... and expressions. *) | |
and expr = | |
| Exists of rel | |
| Bin_op of Bin_op.t * expr * expr | |
| Value of Value.t | |
| Get of string | |
| Qual of string * expr | |
| Param of string | |
| Agg of string * expr list | |
| Call of string * expr list | |
[@@deriving sexp_of, compare] | |
let rec pp ppf syn = | |
match syn with | |
| From table -> Fmt.pf ppf "FROM %a" Catalog.pp_table table | |
| Name (base, alias) -> | |
Fmt.pf ppf "%a@ AS %s" pp base alias | |
| Join (base, join, expr) -> | |
Fmt.pf ppf "%a@ JOIN %a@ ON %a" pp base pp join pp_expr expr | |
| Where (base, expr) -> | |
Fmt.pf ppf "%a@ WHERE %a" pp base pp_expr expr | |
| Select (base, fields) -> | |
Fmt.pf ppf "%a@ SELECT %a" pp base pp_fields fields | |
| Define (base, fields) -> | |
Fmt.pf ppf "%a@ DEFINE %a" pp base pp_fields fields | |
| Group (base, fields) -> | |
Fmt.pf ppf "%a@ GROUP BY %a" pp base pp_fields fields | |
and pp_expr ppf = function | |
| Value value -> Sql.ppsql_value ppf value | |
| Bin_op (binop, a, b) -> | |
Fmt.pf ppf "%a %a %a" pp_expr a Sql.ppsql_binop binop pp_expr b | |
| Exists rel -> Fmt.pf ppf "EXISTS(%a)" pp rel | |
| Call (name, args) -> | |
Fmt.pf ppf "%s(%a)" name Fmt.(list pp_expr) args | |
| Agg (name, args) -> | |
Fmt.pf ppf "%s(%a)" name Fmt.(list pp_expr) args | |
| Get name -> Fmt.string ppf name | |
| Param name -> Fmt.pf ppf "$%s" name | |
| Qual (q, (Get _ as e)) -> Fmt.pf ppf "%s.%a" q pp_expr e | |
| Qual (q, e) -> Fmt.pf ppf "%s.(%a)" q pp_expr e | |
and pp_fields ppf fields = | |
Fmt.(list ~sep:comma) pp_field ppf fields | |
and pp_field ppf (e, label) = | |
Fmt.pf ppf "%a AS %s" pp_expr e label | |
end | |
(** | |
Scope requests. | |
This represents what could be requested to be fetched/computed from the | |
relation. | |
*) | |
module Req = struct | |
type t = | |
| N of string (* Columns: username *) | |
| A of string * Syntax.expr list (* Aggregations: MAX(value) *) | |
| Q of string * t (* Qualified requests: u.username, c.count() *) | |
[@@deriving sexp_of, compare] | |
let qual q req = Q (q, req) | |
include Comparator.Make(struct | |
type nonrec t = t | |
let compare = compare | |
let sexp_of_t = sexp_of_t | |
end) | |
let rec pp ppf = function | |
| N n -> Fmt.string ppf n | |
| Q (q, n) -> Fmt.pf ppf "%s.%a" q pp n | |
| A (name, args) -> Syntax.pp_expr ppf (Syntax.Call (name, args)) | |
end | |
(** | |
Desugared query pipelines. | |
*) | |
module Pipeline = struct | |
type t = info * rel | |
and rel = | |
| From of Catalog.table | |
| Where of t * expr | |
| Select of t * (expr * string) list | |
| Join of t * t * expr | |
| Group of t * (expr * string) list | |
and expr = | |
| Exists of t | |
| Bin_op of Bin_op.t * expr * expr | |
| Value of Value.t | |
| Qual of string * expr | |
| Call of string * expr list | |
| Lookup of Req.t | |
and info = { | |
scope : scope; | |
name : string option; | |
} | |
and scope = (Req.t, value * string, Req.comparator_witness) Map.t | |
and value = | |
| C of col | |
| E of expr * scope | |
and col = string option * string | |
let syntax (_, syn) = syn | |
let name ({name; _}, _) = name | |
let scope ({scope; _}, _) = scope | |
let rec pp ppf (_, syn) = | |
match syn with | |
| From table -> Fmt.pf ppf "FROM %a" Catalog.pp_table table | |
| Join (base, join, expr) -> | |
Fmt.pf ppf "%a@ JOIN %a@ ON %a" pp base pp join pp_expr expr | |
| Where (base, expr) -> | |
Fmt.pf ppf "%a@ WHERE %a" pp base pp_expr expr | |
| Select (base, fields) -> | |
Fmt.pf ppf "%a@ SELECT %a" pp base pp_fields fields | |
| Group (base, fields) -> | |
Fmt.pf ppf "%a@ GROUP BY %a" pp base pp_fields fields | |
and pp_expr ppf = function | |
| Value value -> Sql.ppsql_value ppf value | |
| Bin_op (binop, a, b) -> | |
Fmt.pf ppf "%a %a %a" pp_expr a Sql.ppsql_binop binop pp_expr b | |
| Exists rel -> Fmt.pf ppf "EXISTS(%a)" pp rel | |
| Call (name, args) -> | |
Fmt.pf ppf "%s(%a)" name Fmt.(list pp_expr) args | |
| Lookup req -> | |
Fmt.pf ppf "REQ %a" Req.pp req | |
| Qual (q, e) -> Fmt.pf ppf "%s.(%a)" q pp_expr e | |
and pp_fields ppf fields = | |
Fmt.(list ~sep:comma) pp_field ppf fields | |
and pp_field ppf (e, label) = | |
Fmt.pf ppf "%a AS %s" pp_expr e label | |
end | |
(** | |
Sets of requests [Req.t]. | |
*) | |
module Req_set = struct | |
type t = (Req.t, Req.comparator_witness) Set.t | |
let empty = Set.empty (module Req) | |
let pp fmt seq = | |
Fmt.pf fmt "{%a}" Fmt.(sequence ~sep:comma Req.pp) (Set.to_sequence seq) | |
[@@ocaml.warning "-32"] | |
let qualify q names = | |
Set.map (module Req) names ~f:(Req.qual q) | |
let unqualify q names = | |
Set.fold names | |
~init:empty | |
~f:(fun req name -> | |
match name with | |
| Req.Q (q', n) when String.(q = q') -> Set.add req n | |
| Req.Q _ | |
| Req.A _ | |
| Req.N _ -> req | |
) | |
(** [of_expr e] returns a set of names mentioned in [e] expression. *) | |
let of_expr expr = | |
let rec of_expr' found = function | |
| Syntax.Bin_op (_, a, b) -> | |
of_expr' (of_expr' found a) b | |
| Get n -> | |
Set.add found (Req.N n) | |
| Exists _ (* Only uncorrelated subqueries for now *) | |
| Param _ | |
| Value _ -> found | |
| Qual (n, e) -> | |
qualify n (of_expr' empty e) | |
| Call (_name, args) -> | |
List.fold_left args ~init:found ~f:of_expr' | |
| Agg (name, args) -> | |
Set.add found (Req.A (name, args)) | |
in of_expr' empty expr | |
end | |
(** | |
Scope maps names [Req.t] into columns (C) or other expressions with own | |
scopes (E). | |
*) | |
module Scope = struct | |
type t = Pipeline.scope | |
let empty = Map.empty (module Req) | |
let add scope name v = | |
match Map.add scope ~key:name ~data:v with | |
| `Ok scope -> scope | |
| `Duplicate -> scope | |
let add_name scope name v = | |
add scope (Req.N name) v | |
let resolve scope req = | |
Option.map (Map.find scope req) ~f:fst | |
let pp_col ppf = function | |
| None, name -> Fmt.string ppf name | |
| Some q, name -> Fmt.pf ppf "%s.%s" q name | |
(** | |
Sealed scopes are like scopes but map requests to compiled columns only. | |
*) | |
module Sealed = struct | |
type t = (Req.t, Pipeline.col, Req.comparator_witness) Map.t | |
let combine a b = | |
let prefix_col qual name = | |
let alias = | |
match qual with | |
| None -> name | |
| Some qual -> qual ^ "__" ^ name | |
in | |
Pipeline.C (qual, name), alias | |
in | |
Map.merge a b ~f:(fun ~key:_ c -> | |
match c with | |
| `Left (alias, name) | |
| `Right (alias, name) | |
| `Both ((alias, name), _) -> Some (prefix_col alias name) | |
) | |
let to_scope scope = | |
Map.fold scope | |
~init:(Map.empty (module Req)) | |
~f:(fun ~key:req ~data:(alias, name) export -> | |
let data = Pipeline.C (alias, name), name in | |
add export req data | |
) | |
let of_scope ~name:qual scope = | |
Map.fold scope | |
~init:(Map.empty (module Req)) | |
~f:(fun ~key:req ~data:(_, name) export -> | |
let data = qual, name in | |
add export req data | |
) | |
let pp ppf scope = | |
let pp_item ppf (k, col) = | |
Fmt.pf ppf "%a -> %a" Req.pp k pp_col col | |
in | |
Fmt.pf ppf | |
"@[<hov>{%a}@]" | |
Fmt.(sequence ~sep:comma pp_item) (Map.to_sequence scope) | |
[@@ocaml.warning "-32"] | |
end | |
let seal ~name scope : t = | |
Sealed.(to_scope (of_scope ~name scope)) | |
let filter_req ~req scope = | |
Map.fold scope | |
~init:empty | |
~f:(fun ~key ~data export -> | |
if Set.mem req key | |
then add export key data | |
else export) | |
let merge a b : t = | |
Map.merge a b ~f:(fun ~key:_ -> function | |
| `Left v | `Right v | `Both (v, _) -> Some v | |
) | |
let qualify q scope = | |
Map.fold | |
scope | |
~init:empty | |
~f:(fun ~key ~data map -> add map (Req.qual q key) data) | |
let of_table table : t = | |
List.fold_left | |
table.Catalog.columns | |
~init:empty | |
~f:(fun scope colname -> | |
let r = Req.N colname in | |
let c = Pipeline.C (None, colname), colname in | |
add scope r c) | |
let rec pp ppf scope = | |
let pp_item ppf (k, (expr, alias)) = | |
match expr with | |
| Pipeline.C col -> | |
Fmt.pf ppf "%a -> C %a AS %s" Req.pp k pp_col col alias | |
| E (e, s) -> | |
Fmt.pf ppf "%a -> E %a AT %a AS %s" Req.pp k Pipeline.pp_expr e pp s alias | |
in | |
Fmt.pf ppf | |
"@[<hov>{%a}@]" | |
Fmt.(sequence ~sep:comma pp_item) (Map.to_sequence scope) | |
[@@ocaml.warning "-32"] | |
end | |
exception Plan_error of string | |
(** [plan syn] produces a [Pipeline.t] out of [Syntax.t] *) | |
let plan ~lookup_param (syn : Syntax.t) : Pipeline.t = | |
let sealed_base_scope ?(req=None) base = | |
let scope = Pipeline.scope base in | |
let scope = Scope.seal ~name:(Pipeline.name base) scope in | |
match req with | |
| None -> scope | |
| Some req -> Scope.filter_req ~req scope | |
in | |
let rec plan_rel ~all ~(req : Req_set.t) (syn : Syntax.t) : Pipeline.t = | |
match syn with | |
| From table -> | |
let scope = | |
let scope = Scope.of_table table in | |
if all then scope else Scope.filter_req ~req scope | |
in | |
{scope; name = None;}, From table | |
| Where (base, expr) -> | |
let base = | |
let req = Set.union req (Req_set.of_expr expr) in | |
plan_rel ~all ~req base | |
in | |
let expr = plan_expr expr in | |
let scope = sealed_base_scope ~req:(if all then None else Some req) base in | |
{scope; name = None;}, Where (base, expr) | |
| Select (base, select) -> | |
let select, this_req = | |
List.fold_left select | |
~init:([], Req_set.empty) | |
~f:(fun (select, this_req) (expr, alias) -> | |
if all || Set.mem req (Req.N alias) | |
then | |
let this_req = Set.union this_req (Req_set.of_expr expr) in | |
(plan_expr expr, alias)::select, this_req | |
else select, this_req | |
) | |
in | |
let base = plan_rel ~all:false ~req:this_req base in | |
let scope = | |
let base_scope = sealed_base_scope base in | |
List.fold_left | |
select | |
~init:(Map.empty (module Req)) | |
~f:(fun export (expr, alias) -> | |
Scope.add_name export alias (Pipeline.E (expr, base_scope), alias)) | |
in | |
{scope; name = None;}, Select (base, List.rev select) | |
| Define (base, select) -> | |
let select, this_req = | |
List.fold_left select | |
~init:([], Req_set.empty) | |
~f:(fun (select, this_req) (expr, alias) -> | |
if Set.mem req (Req.N alias) | |
then | |
let this_req = Set.(union this_req (Req_set.of_expr expr)) in | |
(plan_expr expr, alias)::select, this_req | |
else select, this_req | |
) | |
in | |
let base = | |
plan_rel | |
~all | |
~req:(Set.union req this_req) | |
base | |
in | |
let scope = | |
let scope = Pipeline.scope base in | |
List.fold_left | |
select | |
~init:scope | |
~f:(fun newscope (expr, alias) -> | |
let v = Pipeline.E (expr, scope), alias in | |
Scope.add_name newscope alias v | |
) | |
in | |
{scope; name = Pipeline.name base}, Pipeline.syntax base | |
| Name (base, name) -> | |
let base = | |
(* Produce plan for [base] by only passing unqualified requests. *) | |
let req = Req_set.unqualify name req in | |
plan_rel ~all ~req base | |
in | |
let scope = | |
(* Before constructing the export scope we qualify base scope back. *) | |
let available = Pipeline.scope base in | |
Scope.qualify name available | |
in | |
{scope; name = Some name}, Pipeline.syntax base | |
| Join (base, join, expr) -> | |
let this_req = Set.union (Req_set.of_expr expr) req in | |
let base = plan_rel ~all ~req:this_req base in | |
let join = plan_rel ~all ~req:this_req join in | |
let expr = plan_expr expr in | |
let scope = | |
let seal node = | |
Scope.Sealed.of_scope | |
~name:(Pipeline.name node) | |
(Pipeline.scope node) | |
in | |
Scope.Sealed.combine (seal base) (seal join) | |
in | |
{scope; name = None;}, Join (base, join, expr) | |
| Group (base, fields) -> | |
let fields, this_req = | |
List.fold_left fields | |
~init:([], Req_set.empty) | |
~f:(fun (fields, req) (expr, name) -> | |
let field = plan_expr expr, name in | |
let req = Set.union req (Req_set.of_expr expr) in | |
field::fields, req | |
) | |
in | |
let aggregates, this_req = | |
Set.fold req | |
~init:([], this_req) | |
~f:(fun (aggregates, this_req) req -> | |
match req with | |
| Req.A (name, args) -> | |
let expr = Syntax.Call (name, args) in | |
let this_req = Set.union this_req (Req_set.of_expr expr) in | |
let aggregates = (plan_expr expr, req)::aggregates in | |
aggregates, this_req | |
| Req.N _ | Req.Q _ -> | |
aggregates, Set.add this_req req | |
) | |
in | |
let base = | |
plan_rel ~all:false ~req:this_req base | |
in | |
let scope = | |
let base_scope = sealed_base_scope base in | |
let scope = Scope.empty in | |
let scope = | |
List.fold_left | |
fields | |
~init:scope | |
~f:(fun export (expr, alias) -> | |
Scope.add_name export alias (Pipeline.E (expr, base_scope), alias)) | |
in | |
let scope, _ = | |
List.fold_left | |
aggregates | |
~init:(scope, 1) | |
~f:(fun (newscope, n) (expr, req) -> | |
let alias = "agg__" ^ Int.to_string n in | |
Scope.add newscope req (Pipeline.E (expr, base_scope), alias), n + 1) | |
in | |
scope | |
in | |
{scope; name = None;}, Group (base, List.rev fields) | |
and plan_expr = function | |
| Syntax.Exists rel -> | |
Pipeline.Exists (plan_rel ~all:true ~req:Req_set.empty rel) | |
| Bin_op (op, a, b) -> | |
Bin_op (op, plan_expr a, plan_expr b) | |
| Value v -> Value v | |
| Param name -> | |
begin match lookup_param name with | |
| None -> raise (Plan_error ("no such param provided: " ^ name)) | |
| Some v -> Value v | |
end | |
| Get name -> Lookup (Req.N name) | |
| Qual (name, e) -> Qual (name, plan_expr e) | |
| Call (name, args) -> | |
let args = List.map args ~f:plan_expr in | |
Call (name, args) | |
| Agg (name, args) -> | |
Lookup (Req.A (name, args)) | |
in | |
plan_rel ~all:true ~req:Req_set.empty syn | |
exception Translation_error of string | |
let rec translate (rel : Pipeline.t) = | |
translate_rel rel | |
and translate_rel (info, rel) = | |
let names (info, _ : Pipeline.t) = | |
Scope.seal ~name:info.name info.scope | |
in | |
match rel with | |
| From table -> | |
let fields = translate_export info.scope in | |
let from = Sql.From (From_table (table, None)) in | |
{Sql. fields; from; where = None; group_by = None;} | |
| Where (base, expr) -> | |
let alias = Pipeline.name base in | |
let fields = translate_export info.scope in | |
let where = translate_expr ~names:(names base) expr in | |
let from = Sql.From (From_select (translate_rel base, alias)) in | |
{Sql. fields; from; where = Some where; group_by = None;} | |
| Select (base, select) -> | |
let fields = translate_select ~names:(names base) select in | |
let alias = Pipeline.name base in | |
let from = Sql.From (From_select (translate_rel base, alias)) in | |
{Sql. fields; from; where = None; group_by = None;} | |
| Group (base, group) -> | |
let fields = translate_export info.scope in | |
let from = | |
let alias = Pipeline.name base in | |
Sql.From (From_select (translate_rel base, alias)) | |
in | |
let group_by = | |
List.map group ~f:(fun (e, _) -> translate_expr ~names:(names base) e) | |
in | |
{Sql. fields; from; where = None; group_by = Some group_by;} | |
| Join (base, join, expr) -> | |
let names = | |
Scope.merge | |
(names base) | |
(names join) | |
in | |
let fields = translate_export info.scope in | |
let from = | |
Sql.From_join ( | |
From (From_select (translate_rel base, Pipeline.name base)), | |
(From_select (translate_rel join, Pipeline.name join)), | |
translate_expr ~names expr | |
) | |
in | |
{Sql. fields; from; where = None; group_by = None;} | |
and translate_expr ~(names : Pipeline.scope) expr = | |
let rec translate_expr' qual expr = | |
match expr with | |
| Pipeline.Bin_op (op, a, b) -> | |
Sql.Expr_binop (op, translate_expr' qual a, translate_expr' qual b) | |
| Value v -> Sql.Expr_value v | |
| Exists rel -> Sql.Expr_exists (translate_rel rel) | |
| Qual (name, e) -> | |
let qual = name::qual in | |
translate_expr' qual e | |
| Call (name, args) -> | |
let args = List.map args ~f:(translate_expr' qual) in | |
Expr_call (name, args) | |
| Lookup req -> | |
let req = | |
List.fold_left qual | |
~init:req | |
~f:(fun req q -> Req.qual q req) | |
in | |
begin match Scope.resolve names req with | |
| Some C col -> Sql.Expr_column col | |
| Some E (expr, names) -> translate_expr ~names expr | |
| None -> | |
let msg = | |
Fmt.strf | |
"unable to find request %a in scope %a" | |
Req.pp req Scope.pp names | |
in | |
raise (Translation_error msg) | |
end | |
in | |
translate_expr' [] expr | |
and translate_select ~(names : Pipeline.scope) select = | |
List.map select ~f:(fun (expr, alias) -> translate_expr ~names expr, Some alias) | |
and translate_export (scope : Pipeline.scope) = | |
Map.fold scope | |
~init:[] | |
~f:(fun ~key:_ ~data fields -> | |
let field = | |
match data with | |
| C c, alias -> Sql.Expr_column c, Some alias | |
| E (expr, names), alias -> translate_expr ~names expr, Some alias | |
in | |
field::fields | |
) | |
(** PUBLIC API *) | |
type expr = Syntax.expr | |
let get name = Syntax.Get name | |
let qual name expr = Syntax.Qual (name, expr) | |
let param name = Syntax.Param name | |
let agg name args = Syntax.Agg (name, args) | |
let call name args = Syntax.Call (name, args) | |
let exists rel = Syntax.Exists rel | |
let bool v = Syntax.Value (Value.Bool v) | |
let string v = Syntax.Value (Value.String v) | |
let int v = Syntax.Value (Value.Int v) | |
let float v = Syntax.Value (Value.Float v) | |
let (+) a b = Syntax.Bin_op (ADD, a, b) | |
let (-) a b = Syntax.Bin_op (SUB, a, b) | |
let ( * ) a b = Syntax.Bin_op (MUL, a, b) | |
let ( / ) a b = Syntax.Bin_op (DIV, a, b) | |
let (&&) a b = Syntax.Bin_op (AND, a, b) | |
let (||) a b = Syntax.Bin_op (OR, a, b) | |
let ( == ) a b = Syntax.Bin_op (EQ, a, b) | |
let ( != ) a b = Syntax.Bin_op (NEQ, a, b) | |
let pp_expr = Syntax.pp_expr | |
let show_expr = Fmt.strf "%a" pp_expr | |
type rel = Syntax.t | |
let from table = Syntax.From table | |
let where expr base = Syntax.Where (base, expr) | |
let select select base = Syntax.Select (base, select) | |
let define select base = Syntax.Define (base, select) | |
let name name base = Syntax.Name (base, name) | |
let join join expr base = Syntax.Join (base, join, expr) | |
let group fields base = Syntax.Group (base, fields) | |
let pp_rel = Syntax.pp | |
let show_rel = Fmt.strf "%a" pp_rel | |
let no_params _ = None | |
let tosql ?(lookup_param=no_params) q = | |
let q = plan ~lookup_param q in | |
let sql = translate q in | |
try Ok (Fmt.strf "%a" Sql.ppsql sql) | |
with | |
| Plan_error err -> Error err | |
| Translation_error err -> Error err |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
(** | |
Rel is a composable query language which compiles to SQL. | |
*) | |
(** {1 Database Catalogue} | |
Database Catalogue contiains information about tables and columns in the | |
database. This information is needed to properly resolve names. | |
*) | |
module Catalog : sig | |
type t = schema | |
and schema = string | |
and table = { | |
schema: schema; | |
name: string; | |
columns: column list; | |
} | |
and column = string | |
end | |
(** {1 Expression Language} | |
Expression Language is used to define computations over relations: fields to | |
select, filter conditions, group by fields and etc. | |
*) | |
type expr | |
(** Type of Expression Language terms. *) | |
(** {2 Basic expressions} *) | |
val get : string -> expr | |
(** [get n] expressions refers to a name [n] in the current scope. *) | |
val qual : string -> expr -> expr | |
(** [qual n e] qualifies expression [e] with [n] namespace. *) | |
val param : string -> expr | |
(** [param n] creates a named parameter. *) | |
val call : string -> expr list -> expr | |
(** [call n args] calls a function [n] with [args]. *) | |
val agg : string -> expr list -> expr | |
(** [agg n args] calls an aggregate function [n] with [args]. | |
Aggregate functions are always evaluated in the context of the closest | |
group relation (created with {!val:group}). | |
*) | |
(** {2 Operators} *) | |
val ( && ) : expr -> expr -> expr | |
val ( || ) : expr -> expr -> expr | |
val ( == ) : expr -> expr -> expr | |
val ( != ) : expr -> expr -> expr | |
val ( + ) : expr -> expr -> expr | |
val ( - ) : expr -> expr -> expr | |
val ( * ) : expr -> expr -> expr | |
val ( / ) : expr -> expr -> expr | |
(** {2 Values} | |
Combinators below allow to create new {!type:expr} terms from OCaml values. | |
*) | |
val bool : bool -> expr | |
(** [bool v] constructs an {!type:expr} out of {!type:bool}. *) | |
val int : int -> expr | |
(** [int v] constructs an {!type:expr} out of {!type:int}. *) | |
val string : string -> expr | |
(** [string v] constructs an {!type:expr} out of {!type:string}. *) | |
val float : float -> expr | |
(** [float v] constructs an {!type:expr} out of {!type:float}. *) | |
(** {2 Other} *) | |
val pp_expr : expr Fmt.t | |
(** Pretty printer for {!type:expr}. *) | |
val show_expr : expr -> string | |
(** {1 Relational Language} | |
Relational Language is used to define relational structure. Such structure | |
has tree-like shape (because of {!val:join} combinator) with a hierarchical | |
namespaces (introduced via {!val:name} combinator). | |
The API is structured so it's convenient to use {!val:|>} operator to | |
compose multiple relational terms together: [q1 |> where ... |> select [...]]. | |
*) | |
type rel | |
(** Type of Relational Language terms. *) | |
(** {2 Combinators} *) | |
val from : Catalog.table -> rel | |
(** [from table] queries [table], all columns of the [table] are selected. *) | |
val where : expr -> rel -> rel | |
(** [q |> where e] filters [q] with condition specified by [e]. *) | |
val select : (expr * string) list -> rel -> rel | |
(** [q |> select fields] selects only specified [fields] from [q]. *) | |
val define : (expr * string) list -> rel -> rel | |
(** [q |> define fields] defines additional [fields] in [q]. | |
This works similar to {!val:select} but doesn't add fields in the output. | |
Such fields can be used by downstream rel terms. | |
*) | |
val name : string -> rel -> rel | |
(** [q |> name n] puts [q] under name [n]. *) | |
val join : rel -> expr -> rel -> rel | |
(** [q |> join q' e] joins [q] and [q'] using condition [e]. | |
The resulting term has scope merged from both [q] and [q'] relations. To | |
prevent clashes {!val:name} can be used to lift one (or both) of the | |
relations into a namespace: | |
{[ | |
q | |
|> join (q' |> name "join") (...) | |
|> select [ | |
get "name", "name"; (* select from q *) | |
qual "join" @@ get "name", "join_name"; (* select from q' *) | |
] | |
]} | |
*) | |
val group : (expr * string) list -> rel -> rel | |
(** [q |> group fields] groups [q] using expressions in [fields]. | |
All expressions in [fields] are available in the scope. | |
*) | |
(** {2 Other} *) | |
val pp_rel : rel Fmt.t | |
(** Pretty printer for {!type:rel}. *) | |
val show_rel : rel -> string | |
(** {1 Compilation} *) | |
(** Values. | |
Values are used to fill the parameters with concrete values. | |
*) | |
module Value : sig | |
type t | |
val bool : bool -> t | |
val int : int -> t | |
val string : string -> t | |
val float : float -> t | |
end | |
val tosql : ?lookup_param:(string -> Value.t option) -> rel -> (string, string) Result.t | |
(** [tosql q] compiles [q] into an SQL string. | |
The [lookup_param] argument can be provided to resolve parameters (see | |
{!val:param}) to values. | |
*) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment