1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
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)
|
