From 6b377719c10d5ab3343fd5221f99a4a21008e25a Mon Sep 17 00:00:00 2001 From: Sébastien Dailly Date: Thu, 14 Mar 2024 08:26:58 +0100 Subject: Initial commit --- lib/expression/filters.ml | 193 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 193 insertions(+) create mode 100644 lib/expression/filters.ml (limited to 'lib/expression/filters.ml') diff --git a/lib/expression/filters.ml b/lib/expression/filters.ml new file mode 100644 index 0000000..42c794b --- /dev/null +++ b/lib/expression/filters.ml @@ -0,0 +1,193 @@ +(** This module evaluate the sql query to use in order to filter an expression + + The result is built over [Query] except for the group function, which are + translated into a CTE in sql + *) + +open StdLabels +module Q = Query + +type 'a result = { + repr : Format.formatter -> nested:Query.QueryParameter.t -> unit; + group : 'a T.t option; +} + +module Filter = struct + type 'a repr = { + repr : 'a Q.Query.repr; + with_group : 'a T.t option; + } + + type 'a obs = 'a result + type 'a path_repr = 'a Q.Query.path_repr + + let observe : 'a Ast.obs * 'a repr -> 'a obs = + fun (_, v) -> { repr = Q.Query.observe v.repr; group = v.with_group } + + let empty : 'a Ast.obs -> 'a repr = + fun _ -> { repr = Q.Query.empty (); with_group = None } + + let expr : 'a Ast.obs * 'a repr -> 'a Ast.obs -> 'a repr = + fun (_, expr) _ -> + { repr = Q.Query.expr expr.repr; with_group = expr.with_group } + + let path : 'a path_repr -> 'a -> 'a Ast.obs -> 'a repr = + fun repr p _ -> { repr = Q.Query.path repr p; with_group = None } + + let literal : string -> 'a Ast.obs -> 'a repr = + fun l _ -> { repr = Q.Query.literal l; with_group = None } + + let integer : string -> 'a Ast.obs -> 'a repr = + fun l _ -> { repr = Q.Query.integer l; with_group = None } + + let nvl : ('a Ast.obs * 'a repr) list -> 'a Ast.obs -> 'a repr = + fun expression _ -> + let expr_repr = List.map ~f:(fun v -> (snd v).repr) expression in + let with_group = + List.find_map ~f:(fun v -> (snd v).with_group) expression + in + match with_group with + | None -> { repr = Q.Query.nvl expr_repr; with_group } + | Some _ -> raise ImportErrors.MisplacedWindow + + let concat : ('a Ast.obs * 'a repr) list -> 'a Ast.obs -> 'a repr = + fun expression _ -> + let expr_repr = List.map ~f:(fun v -> (snd v).repr) expression in + let with_group = + List.find_map ~f:(fun v -> (snd v).with_group) expression + in + match with_group with + | None -> { repr = Q.Query.concat expr_repr; with_group } + | Some _ -> raise ImportErrors.MisplacedWindow + + let join : string -> ('a Ast.obs * 'a repr) list -> 'a Ast.obs -> 'a repr = + fun sep expression _ -> + let expr_repr = List.map ~f:(fun v -> (snd v).repr) expression + and with_group = + List.find_map ~f:(fun v -> (snd v).with_group) expression + in + match with_group with + | None -> { repr = Q.Query.join sep expr_repr; with_group } + | Some _ -> raise ImportErrors.MisplacedWindow + + let boperator : + T.binary_operator -> + 'a Ast.obs * 'a repr -> + 'a Ast.obs * 'a repr -> + 'a Ast.obs -> + 'a repr = + fun name (_, e1) (_, e2) _ -> + let with_group = + match (e1.with_group, e2.with_group) with + | Some e, None -> Some e + | None, Some e -> Some e + | None, None -> None + | _ -> raise ImportErrors.MisplacedWindow + in + { repr = Q.Query.boperator name e1.repr e2.repr; with_group } + + let gequality : + T.binary_operator -> + 'a Ast.obs * 'a repr -> + ('a Ast.obs * 'a repr) list -> + 'a Ast.obs -> + 'a repr = + fun name (_, e1) group _ -> + let group_repr = List.map ~f:(fun v -> (snd v).repr) group + and with_group = List.find_map ~f:(fun v -> (snd v).with_group) group in + + match with_group with + | None -> + { + repr = Q.Query.gequality name e1.repr group_repr; + with_group = e1.with_group; + } + | _ -> raise ImportErrors.MisplacedWindow + + let funct : string -> ('a Ast.obs * 'a repr) list -> 'a Ast.obs -> 'a repr = + fun name expressions _ -> + let expr_repr = List.map ~f:(fun v -> (snd v).repr) expressions in + let with_group = + List.find_map ~f:(fun v -> (snd v).with_group) expressions + in + match with_group with + | None -> { repr = Q.Query.funct name expr_repr; with_group } + | Some _ -> raise ImportErrors.MisplacedWindow + + let function' : + T.funct -> ('a Ast.obs * 'a repr) list -> 'a Ast.obs -> 'a repr = + fun name expressions _ -> + let expr_repr = List.map ~f:(fun v -> (snd v).repr) expressions in + let with_group = + List.find_map ~f:(fun v -> (snd v).with_group) expressions + in + match with_group with + | None -> + { repr = Q.Query.funct (T.name_of_function name) expr_repr; with_group } + | Some _ -> raise ImportErrors.MisplacedWindow + + (** Window functions are not handled in the filters, we save them as an AST + in order to process them in a separated handler. + + It is not allowed to build nested window functions. *) + let window : + ('a Ast.obs * 'a repr) T.window -> + ('a Ast.obs * 'a repr) list -> + ('a Ast.obs * 'a repr) list -> + 'a Ast.obs -> + 'a repr = + fun name expressions order ast -> + ignore name; + let with_group_expr = + List.find_map ~f:(fun v -> (snd v).with_group) expressions + and with_group_order = + List.find_map ~f:(fun v -> (snd v).with_group) order + in + match (with_group_expr, with_group_order) with + | Some _, _ | _, Some _ -> raise ImportErrors.MisplacedWindow + | None, None -> + (* The column name used with the cte. The name is fixed here, and used + as is in [Analysers.Query.build_cte] and + [Analysers.Query.eval_filters] *) + let q = "cte.group0" in + { + with_group = Some ast; + repr = Q.Query.funct "expr" [ Q.Query.literal q ]; + } +end + +module ASTBuilder = + Compose.Expression + (Ast) + (struct + let v = () + end) + +module F : + Sym.SYM_EXPR + with type 'a obs = 'a result + and type 'a path_repr = Format.formatter -> 'a -> unit = + ASTBuilder.Make (Filter) + +module M = Sym.M (F) + +let query_of_expression : + type b. + b Q.binded_query -> + Format.formatter -> + (Format.formatter -> 'a -> unit) -> + 'a T.t -> + b * 'a T.t option = + fun parameter formatter printer expr -> + let repr = M.eval ~path_repr:printer expr in + match parameter with + | BindParam -> + let p = Queue.create () in + let parameter = Q.QueryParameter.Queue p in + let value = F.observe repr in + value.repr ~nested:parameter formatter; + (p, value.group) + | NoParam -> + let value = F.observe repr in + value.repr ~nested:Literal formatter; + ((), value.group) -- cgit v1.2.3