gazagnaire.org
SQL frontend over the catalog engine
Split SQL frontend from sqlite backend
author
Thomas Gazagnaire
date
(Jun 9, 2026, 9:02 PM -0700)
commit
254ed906
254ed906da609816881b2290d321426360bf1346
+8441
+31
dune-project
+31
dune-project
···
1
+
(lang dune 3.21)
2
+
(using mdx 0.4)
3
+
(using menhir 3.0)
4
+
5
+
(name sql)
6
+
7
+
(generate_opam_files true)
8
+
(implicit_transitive_deps false)
9
+
10
+
(license MIT)
11
+
(authors "Thomas Gazagnaire")
12
+
(maintainers "Thomas Gazagnaire")
13
+
(source (tangled gazagnaire.org/ocaml-sql))
14
+
15
+
(package
16
+
(name sql)
17
+
(synopsis "SQL frontend over the catalog engine")
18
+
(tags (org:blacksun storage))
19
+
(description
20
+
"A SQL parser, AST, renderer, value semantics, and executor over the storage-agnostic catalog engine.")
21
+
(depends
22
+
(ocaml (>= 5.1))
23
+
catalog
24
+
(fmt (>= 0.9))
25
+
re
26
+
(uutf (>= 1.0))
27
+
ohex
28
+
nox-json
29
+
(menhir :build)
30
+
(alcotest :with-test)
31
+
(mdx :with-test)))
+481
lib/ast.ml
+481
lib/ast.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(* ── CREATE TABLE ──────────────────────────────────────────────── *)
7
+
8
+
type col_token = Word of string | Number of string | Parens of col_token list
9
+
10
+
type table_constraint =
11
+
| Unique of string list
12
+
| Primary_key of string list
13
+
| Other
14
+
15
+
type column_def = {
16
+
name : string;
17
+
affinity : string;
18
+
is_rowid_alias : bool;
19
+
has_unique : bool;
20
+
has_primary_key : bool;
21
+
has_not_null : bool;
22
+
collation : string option; (** declared [COLLATE name], uppercased *)
23
+
}
24
+
25
+
(* Column constraint keywords — when we see one of these after the column
26
+
name and type, everything that follows is constraints, not type. *)
27
+
let constraint_kw = function
28
+
| "PRIMARY" | "NOT" | "UNIQUE" | "DEFAULT" | "CHECK" | "REFERENCES"
29
+
| "COLLATE" | "GENERATED" | "AUTOINCREMENT" | "CONSTRAINT" | "ON" | "ASC"
30
+
| "DESC" ->
31
+
true
32
+
| _ -> false
33
+
34
+
let rec token_string = function
35
+
| Word s | Number s -> s
36
+
| Parens inner -> "(" ^ String.concat "" (List.map token_string inner) ^ ")"
37
+
38
+
(* The affinity string for a column's type tokens. Parenthesised params attach
39
+
to the preceding name without a space: DECIMAL(10,2), not DECIMAL (10,2). *)
40
+
let rec affinity_of_tokens = function
41
+
| [] -> ""
42
+
| [ t ] -> token_string t
43
+
| t :: (Parens _ :: _ as rest) -> token_string t ^ affinity_of_tokens rest
44
+
| t :: rest -> token_string t ^ " " ^ affinity_of_tokens rest
45
+
46
+
(* Classify a column's token stream into type affinity + constraints. *)
47
+
let classify_column name tokens =
48
+
(* Split tokens into type part and constraint part.
49
+
Type tokens: everything before the first constraint keyword.
50
+
Constraint tokens: everything from the first constraint keyword on. *)
51
+
let rec split_type acc = function
52
+
| Word w :: rest when constraint_kw (String.uppercase_ascii w) ->
53
+
(List.rev acc, Word w :: rest)
54
+
| (Word _ as t) :: rest -> split_type (t :: acc) rest
55
+
| (Number _ as t) :: rest -> split_type (t :: acc) rest
56
+
| (Parens _ as t) :: rest ->
57
+
(* Parenthesized content after a type name is type params like
58
+
DECIMAL(10,2). But only if we've seen a type name. *)
59
+
if acc = [] then (List.rev acc, Parens [] :: rest)
60
+
else split_type (t :: acc) rest
61
+
| [] -> (List.rev acc, [])
62
+
in
63
+
let type_tokens, constraint_tokens = split_type [] tokens in
64
+
let affinity = affinity_of_tokens type_tokens in
65
+
(* Scan constraint tokens for PRIMARY KEY and UNIQUE *)
66
+
let words =
67
+
List.filter_map
68
+
(function Word w -> Some (String.uppercase_ascii w) | _ -> None)
69
+
constraint_tokens
70
+
in
71
+
let rec has_pk = function
72
+
| "PRIMARY" :: "KEY" :: _ -> true
73
+
| _ :: rest -> has_pk rest
74
+
| [] -> false
75
+
in
76
+
let rec has_nn = function
77
+
| "NOT" :: "NULL" :: _ -> true
78
+
| _ :: rest -> has_nn rest
79
+
| [] -> false
80
+
in
81
+
let has_unique = List.mem "UNIQUE" words in
82
+
let has_primary_key = has_pk words in
83
+
let has_not_null = has_nn words in
84
+
let is_rowid_alias =
85
+
String.uppercase_ascii affinity = "INTEGER" && has_primary_key
86
+
in
87
+
(* A declared [COLLATE name] on the column: the word after COLLATE. *)
88
+
let rec find_collation = function
89
+
| Word w :: Word n :: _ when String.uppercase_ascii w = "COLLATE" ->
90
+
Some (String.uppercase_ascii n)
91
+
| _ :: rest -> find_collation rest
92
+
| [] -> None
93
+
in
94
+
let collation = find_collation constraint_tokens in
95
+
{
96
+
name;
97
+
affinity;
98
+
is_rowid_alias;
99
+
has_unique;
100
+
has_primary_key;
101
+
has_not_null;
102
+
collation;
103
+
}
104
+
105
+
(* ── Query subset ──────────────────────────────────────────────── *)
106
+
107
+
(* A SQL literal / column value -- the engine core's value type, so the frontend,
108
+
the storage adapter, and the engine all speak one type with no conversion. *)
109
+
type value = Catalog.Value.t =
110
+
| Null
111
+
| Int of int64
112
+
| Float of float
113
+
| Blob of string
114
+
| Text of string
115
+
116
+
type binop =
117
+
| Eq
118
+
| Neq
119
+
| Lt
120
+
| Le
121
+
| Gt
122
+
| Ge
123
+
| And
124
+
| Or
125
+
| Like
126
+
| Glob
127
+
| Add
128
+
| Sub
129
+
| Mul
130
+
| Div
131
+
| Mod
132
+
| Bit_and
133
+
| Bit_or
134
+
| Shl
135
+
| Shr
136
+
| Concat
137
+
| Json_get (** [->]: extract as JSON text *)
138
+
| Json_get_text (** [->>]: extract as a SQL value *)
139
+
140
+
type join_type =
141
+
| Inner (** [JOIN] / [INNER JOIN] / comma cross-join *)
142
+
| Left (** [LEFT [OUTER] JOIN]: unmatched left rows kept, right cols NULL *)
143
+
| Right
144
+
(** [RIGHT [OUTER] JOIN]: unmatched right rows kept, left cols NULL *)
145
+
| Full (** [FULL OUTER JOIN]: unmatched rows from both sides kept *)
146
+
147
+
type expr =
148
+
| Lit of value
149
+
| Param of int (** [?] placeholder; numbered left-to-right from 0. *)
150
+
| Col of string option * string (** [t.col] or bare [col]. *)
151
+
| Star (** [*], as a select item or the argument of [count]. *)
152
+
| Qualified_star of string
153
+
(** [t.*]: every column of the table aliased [t], as a select item. *)
154
+
| Unop_not of expr
155
+
| Binary of binop * expr * expr
156
+
| Is_null of expr
157
+
| Is_not_null of expr
158
+
| Is of expr * expr
159
+
| In_list of expr * expr list
160
+
| In_select of expr * select
161
+
| Scalar_select of select
162
+
| Exists of select
163
+
| Func of string * expr list (** lowercased name, e.g. ["coalesce"]. *)
164
+
| Distinct_agg of string * expr
165
+
(** [agg(DISTINCT e)]: an aggregate over the distinct non-NULL values of
166
+
[e] within the group, e.g. [count(DISTINCT x)]. *)
167
+
| Filter of expr * expr
168
+
(** [agg(...) FILTER (WHERE p)]: the aggregate over only the group rows
169
+
satisfying [p]. The left expr is the aggregate call. *)
170
+
| Ordered_agg of expr * (expr * dir) list
171
+
(** [agg(... ORDER BY ...)]: the aggregate over the group rows sorted by
172
+
the keys (matters for order-sensitive aggregates like group_concat).
173
+
The left expr is the aggregate call. *)
174
+
| Window of expr * window
175
+
(** [f(...) OVER (PARTITION BY ... ORDER BY ...)]: a window function. The
176
+
left expr is the function call (e.g. [row_number()], [sum(x)]). *)
177
+
| Cast of expr * string
178
+
(** [CAST(e AS type)]; the type name drives SQLite type affinity. *)
179
+
| Case of expr option * (expr * expr) list * expr option
180
+
(** [CASE [base] WHEN c THEN r ... [ELSE e] END]. With a [base] (simple
181
+
form) each [c] is compared to [base] with [=] semantics; without
182
+
(searched form) each [c] is a boolean. First match wins; no match and
183
+
no [ELSE] yields NULL. *)
184
+
| Collate of expr * string
185
+
186
+
and result_col = { expr : expr; alias : string option }
187
+
188
+
and table_ref = {
189
+
name : string;
190
+
alias : string option;
191
+
subquery : select option;
192
+
}
193
+
194
+
and window = {
195
+
partition : expr list;
196
+
order : (expr * dir) list;
197
+
frame : frame option;
198
+
(** explicit [ROWS]/[RANGE] frame; [None] uses the default frame (the
199
+
whole partition without ORDER BY, else running to the current row's
200
+
peers). *)
201
+
}
202
+
(** An [OVER (PARTITION BY ... ORDER BY ...)] window specification. *)
203
+
204
+
and frame = { rows : bool; start : frame_bound; end_ : frame_bound }
205
+
(** A frame: [rows] is [ROWS] (positional) vs [RANGE] (peer-based). *)
206
+
207
+
and frame_bound =
208
+
| Unbounded_preceding
209
+
| Preceding of expr (** [n PRECEDING] *)
210
+
| Current_row
211
+
| Following of expr (** [n FOLLOWING] *)
212
+
| Unbounded_following
213
+
214
+
and join = {
215
+
table : table_ref;
216
+
on : expr;
217
+
type_ : join_type;
218
+
natural : bool;
219
+
(** [NATURAL]: the ON is implicit (equality on the columns common to the
220
+
left and this table), resolved at execution, and [SELECT *] lists each
221
+
common column once. *)
222
+
using : string list;
223
+
(** [USING (cols)]: like NATURAL but on these named columns; [] when
224
+
absent. *)
225
+
}
226
+
227
+
and dir = Asc | Desc
228
+
and set_op = Union | Union_all | Except | Intersect
229
+
230
+
and from_clause =
231
+
| Unit (** No [FROM]: [SELECT <expr>] evaluates over a single empty row. *)
232
+
| Table of table_ref
233
+
| Select of { fs_select : select; fs_alias : string option }
234
+
(** A derived table: a parenthesised subquery in [FROM]. *)
235
+
| Values of expr list list
236
+
(** A [VALUES (..), (..)] row source; columns named [column1]..[columnN].
237
+
*)
238
+
| Table_function of {
239
+
tf_name : string;
240
+
(** the table-valued function, e.g. [generate_series] *)
241
+
tf_args : expr list;
242
+
tf_alias : string option;
243
+
}
244
+
(** A table-valued function in [FROM], e.g. [generate_series(1, 10)]: it
245
+
produces rows that the query scans like a table. *)
246
+
247
+
and cte = {
248
+
name : string;
249
+
columns : string list; (** optional column rename; [] uses the query's *)
250
+
query : select;
251
+
}
252
+
(** A [WITH] common table expression: a named subquery usable in [FROM]. *)
253
+
254
+
and select = {
255
+
ctes : cte list; (** [WITH] table expressions in scope; empty when absent. *)
256
+
distinct : bool;
257
+
cols : result_col list;
258
+
from : from_clause;
259
+
joins : join list;
260
+
where : expr option;
261
+
group_by : expr list; (** [GROUP BY] keys; empty when absent. *)
262
+
having : expr option; (** [HAVING] group filter; evaluated per group. *)
263
+
compound : (set_op * select) list;
264
+
(** trailing [UNION]/[EXCEPT]/[INTERSECT] arms; [order_by]/[limit] apply
265
+
to the whole compound. Each arm carries only its own core. *)
266
+
order_by : (expr * dir) list;
267
+
limit : expr option; (** [LIMIT] count; an expression so [LIMIT ?] works. *)
268
+
offset : expr option; (** [OFFSET] skip count; only valid with [limit]. *)
269
+
}
270
+
271
+
type check_constraint = {
272
+
expr : expr; (** the [CHECK (...)] predicate, parsed *)
273
+
start : int; (** byte offset of the predicate's source in the CREATE text *)
274
+
stop : int; (** byte offset just past the predicate's source *)
275
+
}
276
+
(** A [CHECK] constraint. The offsets bracket the predicate's verbatim source so
277
+
a violation can name it exactly as written (e.g. ["x<5"]). *)
278
+
279
+
type fk_action =
280
+
| No_action (** the default: reject if it would orphan a child *)
281
+
| Restrict
282
+
| Cascade
283
+
| Set_null
284
+
| Set_default
285
+
286
+
type foreign_key = {
287
+
cols : string list; (** the child (referencing) columns *)
288
+
parent : string; (** the referenced parent table *)
289
+
parent_cols : string list;
290
+
(** the referenced parent columns; [] means the parent's primary key *)
291
+
on_delete : fk_action;
292
+
on_update : fk_action;
293
+
}
294
+
295
+
type create_table = {
296
+
tbl_name : string;
297
+
ct_if_not_exists : bool;
298
+
columns : column_def list;
299
+
table_constraints : table_constraint list;
300
+
checks : check_constraint list;
301
+
(** every [CHECK], column- and table-level, in declared order *)
302
+
defaults : (string * expr) list;
303
+
(** [(column, DEFAULT expr)] for each column with a [DEFAULT] clause *)
304
+
generated : (string * expr) list;
305
+
(** [(column, generation expr)] for each [... AS (expr)] /
306
+
[GENERATED ALWAYS AS (expr)] column. The value is computed from the
307
+
row's other columns on every write (VIRTUAL and STORED both behave as
308
+
stored here, which gives identical query results). *)
309
+
foreign_keys : foreign_key list;
310
+
(** every [FOREIGN KEY] / column [REFERENCES], in declared order *)
311
+
ct_without_rowid : bool;
312
+
(** [CREATE TABLE ... WITHOUT ROWID]: the table is ordered by its PRIMARY
313
+
KEY and has no implicit rowid. *)
314
+
}
315
+
316
+
(* Recover a column-level foreign key from a column's token stream
317
+
([col REFERENCES parent [(pcol, ...)]]), the same token-classification path as
318
+
{!classify_column}. Referential actions on a column reference are not picked up
319
+
here (only the table-level FOREIGN KEY grammar carries them), so the default
320
+
NO ACTION applies. *)
321
+
let column_foreign_key name tokens =
322
+
let rec find = function
323
+
| Word w :: rest when String.uppercase_ascii w = "REFERENCES" -> Some rest
324
+
| _ :: rest -> find rest
325
+
| [] -> None
326
+
in
327
+
match find tokens with
328
+
| Some (Word parent :: rest) ->
329
+
let parent_cols =
330
+
match rest with
331
+
| Parens inner :: _ ->
332
+
List.filter_map (function Word c -> Some c | _ -> None) inner
333
+
| _ -> []
334
+
in
335
+
Some
336
+
{
337
+
cols = [ name ];
338
+
parent;
339
+
parent_cols;
340
+
on_delete = No_action;
341
+
on_update = No_action;
342
+
}
343
+
| _ -> None
344
+
345
+
type create_view = {
346
+
name : string;
347
+
if_not_exists : bool;
348
+
columns : string list; (** optional column rename; [] uses the query's *)
349
+
select : select; (** the stored query the view stands for *)
350
+
}
351
+
352
+
type create_table_as = { name : string; if_not_exists : bool; query : select }
353
+
354
+
type insert_source =
355
+
| Values of expr list list (** one list per [VALUES (...)] tuple *)
356
+
| Select of select (** [INSERT ... SELECT]: rows from a query *)
357
+
| Default_values
358
+
359
+
type upsert_action =
360
+
| Nothing (** skip the row on a uniqueness conflict *)
361
+
| Update of (string * expr) list * expr option
362
+
(** [DO UPDATE SET ... [WHERE ...]]: rewrite the conflicting row;
363
+
[excluded.col] in the expressions is the would-be-inserted value. *)
364
+
365
+
type upsert = {
366
+
target : string list; (** [ON CONFLICT (cols)] target; [] when omitted *)
367
+
action : upsert_action;
368
+
}
369
+
370
+
type insert_conflict = Abort | Fail | Ignore | Replace | Rollback
371
+
372
+
type insert = {
373
+
conflict : insert_conflict;
374
+
table : string;
375
+
columns : string list; (** empty means all columns, in declared order *)
376
+
source : insert_source;
377
+
upsert : upsert option; (** [ON CONFLICT ...] clause; [None] when absent *)
378
+
returning : result_col list; (** [RETURNING] columns; [] when absent *)
379
+
}
380
+
381
+
type delete = {
382
+
ctes : cte list;
383
+
table : string;
384
+
alias : string option;
385
+
(** [DELETE FROM t AS x]: the alias the WHERE qualifies columns by *)
386
+
where : expr option;
387
+
returning : result_col list;
388
+
}
389
+
390
+
type update = {
391
+
ctes : cte list;
392
+
table : string;
393
+
sets : (string * expr) list; (** [SET col = expr] assignments, in order *)
394
+
from : (from_clause * join list) option;
395
+
where : expr option;
396
+
returning : result_col list;
397
+
}
398
+
399
+
type create_index = {
400
+
if_not_exists : bool;
401
+
unique : bool; (** [CREATE UNIQUE INDEX]: enforce distinct keys *)
402
+
name : string;
403
+
table : string;
404
+
columns : string list;
405
+
where : expr option;
406
+
(** [CREATE INDEX ... WHERE p]: a partial index, indexing only the rows
407
+
satisfying [p]. For a non-unique index this is a pure optimisation, so
408
+
the predicate is ignored (the index is built over every row, giving
409
+
identical query results); a partial {e unique} index is rejected, as
410
+
ignoring [p] would over-enforce uniqueness. *)
411
+
has_expr : bool;
412
+
(** [CREATE INDEX ... ON t(a+b)]: an expression key. The executor cannot
413
+
use such an index, so for a non-unique index no index is built (a pure
414
+
optimisation, identical results); an expression {e unique} index is
415
+
rejected, as its uniqueness cannot be enforced. *)
416
+
}
417
+
418
+
type drop_object = Table | Index | View | Trigger
419
+
420
+
type drop = {
421
+
object_ : drop_object;
422
+
name : string;
423
+
if_exists : bool; (** [DROP ... IF EXISTS]: a missing object is a no-op *)
424
+
}
425
+
426
+
type pragma = { name : string; value : value option }
427
+
428
+
type alter_op =
429
+
| Add_column of {
430
+
ac_name : string;
431
+
ac_affinity : string; (** column type text, [""] when none was given *)
432
+
ac_default : value option;
433
+
(** the [DEFAULT] literal; [None] for no clause, [Some Null] for
434
+
[DEFAULT NULL] -- both leave existing rows reading NULL *)
435
+
}
436
+
| Rename_table of string (** [RENAME TO new_name] *)
437
+
| Rename_column of string * string (** [RENAME COLUMN old TO new] *)
438
+
| Drop_column of string (** [DROP COLUMN name] *)
439
+
440
+
type alter_table = { table : string; op : alter_op }
441
+
type trigger_timing = Before | After | Instead_of
442
+
443
+
type trigger_event =
444
+
| Insert
445
+
| Delete
446
+
| Update of string list (** [UPDATE OF cols]; [] means any column *)
447
+
448
+
type create_trigger = {
449
+
name : string;
450
+
if_not_exists : bool;
451
+
timing : trigger_timing;
452
+
event : trigger_event;
453
+
table : string;
454
+
when_ : expr option; (** [WHEN] guard, evaluated per row before the body *)
455
+
body : stmt list; (** action statements between [BEGIN] and [END] *)
456
+
}
457
+
458
+
and stmt =
459
+
| Select of select
460
+
| Insert of insert
461
+
| Delete of delete
462
+
| Update of update
463
+
| Create_table of create_table
464
+
| Create_table_as of create_table_as
465
+
| Create_index of create_index
466
+
| Create_view of create_view
467
+
| Create_trigger of create_trigger
468
+
| Drop of drop
469
+
| Alter_table of alter_table
470
+
| Pragma of pragma
471
+
| Begin
472
+
| Commit
473
+
| Rollback
474
+
| Savepoint of string (** [SAVEPOINT name]: a nested rollback point *)
475
+
| Release of string (** [RELEASE [SAVEPOINT] name]: discard a savepoint *)
476
+
| Rollback_to of string (** [ROLLBACK TO [SAVEPOINT] name] *)
477
+
| Vacuum
478
+
| Analyze
479
+
(** [ANALYZE [schema | table | index]]: gather query-planner statistics.
480
+
It changes only the planner's stat tables, never query results, so it
481
+
is run as a no-op here. *)
+403
lib/ast.mli
+403
lib/ast.mli
···
1
+
(** SQLite SQL AST: CREATE TABLE classification plus the query subset. *)
2
+
3
+
(** {1 CREATE TABLE} *)
4
+
5
+
type col_token = Word of string | Number of string | Parens of col_token list
6
+
7
+
type table_constraint =
8
+
| Unique of string list
9
+
| Primary_key of string list
10
+
| Other
11
+
12
+
type column_def = {
13
+
name : string;
14
+
affinity : string;
15
+
is_rowid_alias : bool;
16
+
has_unique : bool;
17
+
has_primary_key : bool;
18
+
has_not_null : bool;
19
+
collation : string option; (** declared [COLLATE name], uppercased *)
20
+
}
21
+
22
+
val classify_column : string -> col_token list -> column_def
23
+
(** [classify_column name tokens] splits [tokens] into type affinity and
24
+
constraints, returning a column definition. *)
25
+
26
+
(** {1 Query subset} *)
27
+
28
+
type value = Catalog.Value.t =
29
+
| Null
30
+
| Int of int64
31
+
| Float of float
32
+
| Blob of string
33
+
| Text of string
34
+
(** A SQL literal / column value -- the engine core's {!Catalog.Value.t},
35
+
so the frontend, the storage adapter, and the engine all speak one
36
+
value type with no conversion. *)
37
+
38
+
type binop =
39
+
| Eq
40
+
| Neq
41
+
| Lt
42
+
| Le
43
+
| Gt
44
+
| Ge
45
+
| And
46
+
| Or
47
+
| Like
48
+
| Glob
49
+
| Add
50
+
| Sub
51
+
| Mul
52
+
| Div
53
+
| Mod
54
+
| Bit_and
55
+
| Bit_or
56
+
| Shl
57
+
| Shr
58
+
| Concat
59
+
| Json_get (** [->]: extract as JSON text *)
60
+
| Json_get_text (** [->>]: extract as a SQL value *)
61
+
62
+
type join_type =
63
+
| Inner (** [JOIN] / [INNER JOIN] / comma cross-join *)
64
+
| Left (** [LEFT [OUTER] JOIN]: unmatched left rows kept, right cols NULL *)
65
+
| Right
66
+
(** [RIGHT [OUTER] JOIN]: unmatched right rows kept, left cols NULL *)
67
+
| Full (** [FULL OUTER JOIN]: unmatched rows from both sides kept *)
68
+
69
+
type expr =
70
+
| Lit of value
71
+
| Param of int (** [?] placeholder; numbered left-to-right from 0. *)
72
+
| Col of string option * string (** [t.col] or bare [col]. *)
73
+
| Star (** [*], as a select item or the argument of [count]. *)
74
+
| Qualified_star of string
75
+
(** [t.*]: every column of the table aliased [t], as a select item. *)
76
+
| Unop_not of expr
77
+
| Binary of binop * expr * expr
78
+
| Is_null of expr
79
+
| Is_not_null of expr
80
+
| Is of expr * expr
81
+
(** [a IS b]: NULL-safe equality (a is not distinct from b), 1 or 0, never
82
+
NULL. [a IS NOT b] is [NOT (a IS b)]; [a IS NULL] folds to {!Is_null}.
83
+
*)
84
+
| In_list of expr * expr list
85
+
| In_select of expr * select
86
+
| Scalar_select of select
87
+
(** [(SELECT ...)] used as a value: the first column of the first row, or
88
+
NULL if the subquery returns no rows. Correlated via the outer scope.
89
+
*)
90
+
| Exists of select
91
+
(** [EXISTS (SELECT ...)]: 1 if the subquery returns any row, else 0. *)
92
+
| Func of string * expr list (** lowercased name, e.g. ["coalesce"]. *)
93
+
| Distinct_agg of string * expr
94
+
(** [agg(DISTINCT e)]: an aggregate over the distinct non-NULL values of
95
+
[e] within the group, e.g. [count(DISTINCT x)]. *)
96
+
| Filter of expr * expr
97
+
(** [agg(...) FILTER (WHERE p)]: the aggregate over only the group rows
98
+
satisfying [p]. The left expr is the aggregate call. *)
99
+
| Ordered_agg of expr * (expr * dir) list
100
+
(** [agg(... ORDER BY ...)]: the aggregate over the group rows sorted by
101
+
the keys (matters for order-sensitive aggregates like group_concat).
102
+
The left expr is the aggregate call. *)
103
+
| Window of expr * window
104
+
(** [f(...) OVER (PARTITION BY ... ORDER BY ...)]: a window function. *)
105
+
| Cast of expr * string
106
+
(** [CAST(e AS type)]; the type name drives SQLite type affinity. *)
107
+
| Case of expr option * (expr * expr) list * expr option
108
+
(** [CASE [base] WHEN c THEN r ... [ELSE e] END]. With a [base] (simple
109
+
form) each [c] is compared to [base] with [=] semantics; without
110
+
(searched form) each [c] is a boolean. First match wins; no match and
111
+
no [ELSE] yields NULL. *)
112
+
| Collate of expr * string
113
+
(** [e COLLATE name]: assigns the collating sequence [name] (uppercased:
114
+
[BINARY], [NOCASE], [RTRIM]) to [e] for comparison and ordering. The
115
+
value of [e] is unchanged; only text comparisons consult it. *)
116
+
117
+
and result_col = { expr : expr; alias : string option }
118
+
119
+
and table_ref = {
120
+
name : string;
121
+
alias : string option;
122
+
subquery : select option;
123
+
(** [Some q] for a derived table [(q) alias] in JOIN position: [name] is
124
+
the alias the subquery's rows are bound under. [None] for a named
125
+
table. *)
126
+
}
127
+
128
+
and window = {
129
+
partition : expr list;
130
+
order : (expr * dir) list;
131
+
frame : frame option;
132
+
(** explicit [ROWS]/[RANGE] frame; [None] uses the default frame. *)
133
+
}
134
+
(** An [OVER (PARTITION BY ... ORDER BY ...)] window specification. *)
135
+
136
+
and frame = { rows : bool; start : frame_bound; end_ : frame_bound }
137
+
(** A frame: {!field-rows} is [ROWS] (positional) vs [RANGE] (peer-based). *)
138
+
139
+
and frame_bound =
140
+
| Unbounded_preceding
141
+
| Preceding of expr (** [n PRECEDING] *)
142
+
| Current_row
143
+
| Following of expr (** [n FOLLOWING] *)
144
+
| Unbounded_following
145
+
146
+
and join = {
147
+
table : table_ref;
148
+
on : expr;
149
+
type_ : join_type;
150
+
natural : bool;
151
+
(** [NATURAL]: the ON is implicit (equality on the columns common to the
152
+
left and this table), resolved at execution, and [SELECT *] lists each
153
+
common column once. *)
154
+
using : string list;
155
+
(** [USING (cols)]: like NATURAL but on these named columns; [] when
156
+
absent. *)
157
+
}
158
+
159
+
and dir = Asc | Desc
160
+
and set_op = Union | Union_all | Except | Intersect
161
+
162
+
and from_clause =
163
+
| Unit (** No [FROM]: [SELECT <expr>] evaluates over a single empty row. *)
164
+
| Table of table_ref
165
+
| Select of { fs_select : select; fs_alias : string option }
166
+
(** A derived table: a parenthesised subquery in [FROM]. *)
167
+
| Values of expr list list
168
+
(** A [VALUES (..), (..)] row source; columns named [column1]..[columnN].
169
+
*)
170
+
| Table_function of {
171
+
tf_name : string;
172
+
(** the table-valued function, e.g. [generate_series] *)
173
+
tf_args : expr list;
174
+
tf_alias : string option;
175
+
}
176
+
(** A table-valued function in [FROM], e.g. [generate_series(1, 10)]: it
177
+
produces rows that the query scans like a table. *)
178
+
179
+
and cte = {
180
+
name : string;
181
+
columns : string list; (** optional column rename; [] uses the query's *)
182
+
query : select;
183
+
}
184
+
(** A [WITH] common table expression: a named subquery usable in [FROM]. *)
185
+
186
+
and select = {
187
+
ctes : cte list; (** [WITH] table expressions in scope; empty when absent. *)
188
+
distinct : bool;
189
+
cols : result_col list;
190
+
from : from_clause;
191
+
joins : join list;
192
+
where : expr option;
193
+
group_by : expr list; (** [GROUP BY] keys; empty when absent. *)
194
+
having : expr option; (** [HAVING] group filter; evaluated per group. *)
195
+
compound : (set_op * select) list;
196
+
(** trailing [UNION]/[EXCEPT]/[INTERSECT] arms; [order_by]/[limit] apply
197
+
to the whole compound. Each arm carries only its own core. *)
198
+
order_by : (expr * dir) list;
199
+
limit : expr option; (** [LIMIT] count; an expression so [LIMIT ?] works. *)
200
+
offset : expr option; (** [OFFSET] skip count; only valid with [limit]. *)
201
+
}
202
+
203
+
type check_constraint = {
204
+
expr : expr; (** the [CHECK (...)] predicate, parsed *)
205
+
start : int; (** byte offset of the predicate's source in the CREATE text *)
206
+
stop : int; (** byte offset just past the predicate's source *)
207
+
}
208
+
(** A [CHECK] constraint. The offsets bracket the predicate's verbatim source so
209
+
a violation can name it exactly as written (e.g. ["x<5"]). *)
210
+
211
+
type fk_action =
212
+
| No_action (** the default: reject if it would orphan a child *)
213
+
| Restrict
214
+
| Cascade
215
+
| Set_null
216
+
| Set_default
217
+
218
+
type foreign_key = {
219
+
cols : string list; (** the child (referencing) columns *)
220
+
parent : string; (** the referenced parent table *)
221
+
parent_cols : string list;
222
+
(** the referenced parent columns; [] means the parent's primary key *)
223
+
on_delete : fk_action;
224
+
on_update : fk_action;
225
+
}
226
+
227
+
type create_table = {
228
+
tbl_name : string;
229
+
ct_if_not_exists : bool;
230
+
columns : column_def list;
231
+
table_constraints : table_constraint list;
232
+
checks : check_constraint list;
233
+
(** every [CHECK], column- and table-level, in declared order *)
234
+
defaults : (string * expr) list;
235
+
(** [(column, DEFAULT expr)] for each column with a [DEFAULT] clause *)
236
+
generated : (string * expr) list;
237
+
(** [(column, generation expr)] for each [... AS (expr)] /
238
+
[GENERATED ALWAYS AS (expr)] column; computed from the row's other
239
+
columns on every write (VIRTUAL and STORED both behave as stored). *)
240
+
foreign_keys : foreign_key list;
241
+
(** every [FOREIGN KEY] / column [REFERENCES], in declared order *)
242
+
ct_without_rowid : bool;
243
+
(** [CREATE TABLE ... WITHOUT ROWID]: ordered by its PRIMARY KEY, no
244
+
implicit rowid. *)
245
+
}
246
+
247
+
val column_foreign_key : string -> col_token list -> foreign_key option
248
+
(** [column_foreign_key name tokens] recovers a column-level
249
+
[name REFERENCES parent [(cols)]] foreign key from the column's token
250
+
stream, or [None] if it has no [REFERENCES]. *)
251
+
252
+
type create_view = {
253
+
name : string;
254
+
if_not_exists : bool;
255
+
columns : string list; (** optional column rename; [] uses the query's *)
256
+
select : select; (** the stored query the view stands for *)
257
+
}
258
+
259
+
type create_table_as = {
260
+
name : string;
261
+
if_not_exists : bool;
262
+
query : select;
263
+
(** [CREATE TABLE name AS query]: the new table's columns are the query's
264
+
output column names, and it is populated with the query's rows. *)
265
+
}
266
+
267
+
type insert_source =
268
+
| Values of expr list list (** one list per [VALUES (...)] tuple *)
269
+
| Select of select (** [INSERT ... SELECT]: rows from a query *)
270
+
| Default_values
271
+
(** [INSERT ... DEFAULT VALUES]: one row, every column its default. *)
272
+
273
+
type upsert_action =
274
+
| Nothing (** skip the row on a uniqueness conflict *)
275
+
| Update of (string * expr) list * expr option
276
+
(** [DO UPDATE SET ... [WHERE ...]]: rewrite the conflicting row;
277
+
[excluded.col] in the expressions is the would-be-inserted value. *)
278
+
279
+
type upsert = {
280
+
target : string list; (** [ON CONFLICT (cols)] target; [] when omitted *)
281
+
action : upsert_action;
282
+
}
283
+
284
+
(** [INSERT OR <action>]: the conflict-resolution algorithm. FAIL and ROLLBACK
285
+
currently behave like ABORT (the violation errors); their undo-scope
286
+
distinction is a transaction-semantics follow-up. *)
287
+
type insert_conflict =
288
+
| Abort
289
+
(** the default: a constraint violation undoes the statement, errors *)
290
+
| Fail (** stop at the violating row, keeping prior rows (no rollback) *)
291
+
| Ignore (** skip the violating row and continue, no error *)
292
+
| Replace (** delete the conflicting row(s), then insert *)
293
+
| Rollback (** a violation aborts the whole transaction *)
294
+
295
+
type insert = {
296
+
conflict : insert_conflict;
297
+
table : string;
298
+
columns : string list; (** empty means all columns, in declared order *)
299
+
source : insert_source;
300
+
upsert : upsert option; (** [ON CONFLICT ...] clause; [None] when absent *)
301
+
returning : result_col list; (** [RETURNING] columns; [] when absent *)
302
+
}
303
+
304
+
type delete = {
305
+
ctes : cte list; (** leading [WITH] table expressions; [] when absent *)
306
+
table : string;
307
+
alias : string option;
308
+
(** [DELETE FROM t AS x]: the alias the WHERE qualifies columns by *)
309
+
where : expr option;
310
+
returning : result_col list;
311
+
}
312
+
313
+
type update = {
314
+
ctes : cte list; (** leading [WITH] table expressions; [] when absent *)
315
+
table : string;
316
+
sets : (string * expr) list; (** [SET col = expr] assignments, in order *)
317
+
from : (from_clause * join list) option;
318
+
(** [UPDATE ... SET ... FROM t ...]: auxiliary tables joined to the
319
+
target; their columns are in scope in the SET expressions and WHERE.
320
+
*)
321
+
where : expr option;
322
+
returning : result_col list;
323
+
}
324
+
325
+
type create_index = {
326
+
if_not_exists : bool;
327
+
unique : bool; (** [CREATE UNIQUE INDEX]: enforce distinct keys *)
328
+
name : string;
329
+
table : string;
330
+
columns : string list;
331
+
where : expr option;
332
+
(** [CREATE INDEX ... WHERE p]: a partial index. For a non-unique index
333
+
the predicate is ignored (a pure optimisation, identical query
334
+
results); a partial {e unique} index is rejected. *)
335
+
has_expr : bool;
336
+
(** [CREATE INDEX ... ON t(a+b)]: an expression key -- a non-unique such
337
+
index builds nothing (identical results); a unique one is rejected. *)
338
+
}
339
+
340
+
type drop_object = Table | Index | View | Trigger
341
+
342
+
type drop = {
343
+
object_ : drop_object;
344
+
name : string;
345
+
if_exists : bool; (** [DROP ... IF EXISTS]: a missing object is a no-op *)
346
+
}
347
+
348
+
type pragma = { name : string; value : value option }
349
+
350
+
type alter_op =
351
+
| Add_column of {
352
+
ac_name : string;
353
+
ac_affinity : string; (** column type text, [""] when none was given *)
354
+
ac_default : value option;
355
+
(** the [DEFAULT] literal; [None] for no clause, [Some Null] for
356
+
[DEFAULT NULL] -- both leave existing rows reading NULL *)
357
+
}
358
+
| Rename_table of string (** [RENAME TO new_name] *)
359
+
| Rename_column of string * string (** [RENAME COLUMN old TO new] *)
360
+
| Drop_column of string (** [DROP COLUMN name] *)
361
+
362
+
type alter_table = { table : string; op : alter_op }
363
+
type trigger_timing = Before | After | Instead_of
364
+
365
+
type trigger_event =
366
+
| Insert
367
+
| Delete
368
+
| Update of string list (** [UPDATE OF cols]; [] means any column *)
369
+
370
+
type create_trigger = {
371
+
name : string;
372
+
if_not_exists : bool;
373
+
timing : trigger_timing;
374
+
event : trigger_event;
375
+
table : string;
376
+
when_ : expr option; (** [WHEN] guard, evaluated per row before the body *)
377
+
body : stmt list; (** action statements between [BEGIN] and [END] *)
378
+
}
379
+
380
+
and stmt =
381
+
| Select of select
382
+
| Insert of insert
383
+
| Delete of delete
384
+
| Update of update
385
+
| Create_table of create_table
386
+
| Create_table_as of create_table_as
387
+
| Create_index of create_index
388
+
| Create_view of create_view
389
+
| Create_trigger of create_trigger
390
+
| Drop of drop
391
+
| Alter_table of alter_table
392
+
| Pragma of pragma
393
+
| Begin
394
+
| Commit
395
+
| Rollback
396
+
| Savepoint of string (** [SAVEPOINT name]: a nested rollback point *)
397
+
| Release of string (** [RELEASE [SAVEPOINT] name]: discard a savepoint *)
398
+
| Rollback_to of string (** [ROLLBACK TO [SAVEPOINT] name] *)
399
+
| Vacuum
400
+
| Analyze
401
+
(** [ANALYZE [schema | table | index]]: gather query-planner statistics.
402
+
It changes only the planner's stat tables, never query results, so it
403
+
is run as a no-op here. *)
+337
lib/datetime.ml
+337
lib/datetime.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(* SQLite date and time functions (lang_datefunc.html).
7
+
8
+
Time is carried as a Julian Day count in integer milliseconds, exactly as
9
+
sqlite3's date.c does, so day/second arithmetic is exact and the broken-down
10
+
calendar fields round-trip. The deterministic surface -- explicit time
11
+
strings and Julian/unix numbers, the unit and "start of" modifiers, the named
12
+
functions and strftime -- is implemented; the wall-clock forms ('now',
13
+
'localtime', 'utc') need an injected clock and raise until one is wired. *)
14
+
15
+
let ms_per_day = 86_400_000L
16
+
17
+
(* Unix epoch 1970-01-01 is Julian Day 2440587.5. *)
18
+
let unix_epoch_ms = 210_866_760_000_000L
19
+
20
+
let text_of_value = function
21
+
| Ast.Text s -> s
22
+
| Blob s -> s
23
+
| Int i -> Int64.to_string i
24
+
| Float f -> Fmt.str "%g" f
25
+
| Null -> ""
26
+
27
+
(* Broken-down calendar fields -> Julian Day in integer ms. Out-of-range day or
28
+
month values are accepted and normalised by the arithmetic, so Feb 31 lands
29
+
in March, as sqlite3 does for month arithmetic. *)
30
+
let ijd_of_fields y mo d h mi s =
31
+
let y, mo = if mo <= 2 then (y - 1, mo + 12) else (y, mo) in
32
+
let a = y / 100 in
33
+
let b = 2 - a + (a / 4) in
34
+
let x1 = 36525 * (y + 4716) / 100 in
35
+
let x2 = 306001 * (mo + 1) / 10000 in
36
+
let days = float_of_int (x1 + x2 + d + b) -. 1524.5 in
37
+
let day_ms = Int64.of_float (days *. 86_400_000.) in
38
+
let time_ms = Int64.of_int ((h * 3_600_000) + (mi * 60_000)) in
39
+
let sec_ms = Int64.of_float (Float.round (s *. 1000.)) in
40
+
Int64.add (Int64.add day_ms time_ms) sec_ms
41
+
42
+
(* Julian Day in ms -> (year, month, day, hour, minute, seconds-with-fraction).
43
+
The inverse of {!ijd_of_fields}, using the standard Gregorian conversion. *)
44
+
let fields_of_ijd ijd =
45
+
let z = Int64.to_int (Int64.div (Int64.add ijd 43_200_000L) ms_per_day) in
46
+
let a = int_of_float ((float_of_int z -. 1_867_216.25) /. 36524.25) in
47
+
let a = z + 1 + a - (a / 4) in
48
+
let b = a + 1524 in
49
+
let c = int_of_float ((float_of_int b -. 122.1) /. 365.25) in
50
+
let d = int_of_float (365.25 *. float_of_int c) in
51
+
let e = int_of_float (float_of_int (b - d) /. 30.6001) in
52
+
let x1 = int_of_float (30.6001 *. float_of_int e) in
53
+
let day = b - d - x1 in
54
+
let month = if e < 14 then e - 1 else e - 13 in
55
+
let year = if month > 2 then c - 4716 else c - 4715 in
56
+
let into = Int64.to_int (Int64.rem (Int64.add ijd 43_200_000L) ms_per_day) in
57
+
let into = if into < 0 then into + 86_400_000 else into in
58
+
let h = into / 3_600_000 in
59
+
let mi = into mod 3_600_000 / 60_000 in
60
+
let sec = float_of_int (into mod 60_000) /. 1000. in
61
+
(year, month, day, h, mi, sec)
62
+
63
+
(* ── Parsing a time value ────────────────────────────────────── *)
64
+
65
+
let sub_int s a b = int_of_string (String.sub s a (b - a))
66
+
67
+
(* Parse the [HH:MM[:SS[.fff]]] tail of a time string into (h, mi, seconds). *)
68
+
let parse_hms t =
69
+
match String.split_on_char ':' t with
70
+
| [ h; m ] -> (int_of_string h, int_of_string m, 0.)
71
+
| [ h; m; s ] -> (int_of_string h, int_of_string m, float_of_string s)
72
+
| _ -> failwith "bad time"
73
+
74
+
(* Reject calendar fields outside sqlite3's accepted ranges; an out-of-range
75
+
literal date/time yields NULL rather than a value. *)
76
+
let validate y mo d h mi s =
77
+
if
78
+
mo < 1 || mo > 12 || d < 1 || d > 31 || h > 24 || mi > 59 || s >= 60.
79
+
|| y < 0
80
+
then failwith "date/time field out of range"
81
+
82
+
(* Strip a trailing 'Z' or +/-HH:MM timezone, returning the offset in minutes,
83
+
the remaining time text, and whether a timezone was present (so a later 'utc'
84
+
modifier knows the value is already UTC and is a no-op). *)
85
+
let split_tz t =
86
+
let n = String.length t in
87
+
if n > 0 && (t.[n - 1] = 'Z' || t.[n - 1] = 'z') then
88
+
(0, String.sub t 0 (n - 1), true)
89
+
else if n >= 6 && (t.[n - 6] = '+' || t.[n - 6] = '-') && t.[n - 3] = ':' then
90
+
let sign = if t.[n - 6] = '+' then 1 else -1 in
91
+
let hh = int_of_string (String.sub t (n - 5) 2) in
92
+
let mm = int_of_string (String.sub t (n - 2) 2) in
93
+
(sign * ((hh * 60) + mm), String.sub t 0 (n - 6), true)
94
+
else (0, t, false)
95
+
96
+
let parse_string str =
97
+
let str = String.trim str in
98
+
if String.length str >= 6 && String.contains str '-' then begin
99
+
(* date, optionally followed by ' ' or 'T' and a time *)
100
+
let date_part, time_part =
101
+
match String.index_opt str ' ' with
102
+
| Some i ->
103
+
( String.sub str 0 i,
104
+
Some (String.sub str (i + 1) (String.length str - i - 1)) )
105
+
| None -> (
106
+
match String.index_opt str 'T' with
107
+
| Some i ->
108
+
( String.sub str 0 i,
109
+
Some (String.sub str (i + 1) (String.length str - i - 1)) )
110
+
| None -> (str, None))
111
+
in
112
+
let y = sub_int date_part 0 4 in
113
+
let mo = sub_int date_part 5 7 in
114
+
let d = sub_int date_part 8 10 in
115
+
let offset, h, mi, s, had_tz =
116
+
match time_part with
117
+
| None -> (0, 0, 0, 0., false)
118
+
| Some t ->
119
+
let offset, t, had_tz = split_tz t in
120
+
let h, mi, s = parse_hms (String.trim t) in
121
+
(offset, h, mi, s, had_tz)
122
+
in
123
+
validate y mo d h mi s;
124
+
(* Shift an offset-bearing local time back to UTC (SQLite stores UTC); the
125
+
Julian Day is in integer milliseconds. *)
126
+
( Int64.sub (ijd_of_fields y mo d h mi s) (Int64.of_int (offset * 60_000)),
127
+
had_tz )
128
+
end
129
+
else if String.contains str ':' then begin
130
+
let offset, t, had_tz = split_tz (String.trim str) in
131
+
let h, mi, s = parse_hms (String.trim t) in
132
+
validate 2000 1 1 h mi s;
133
+
( Int64.sub (ijd_of_fields 2000 1 1 h mi s) (Int64.of_int (offset * 60_000)),
134
+
had_tz )
135
+
end
136
+
else failwith "unrecognized date/time string"
137
+
138
+
(* Parse the leading time value, honouring an 'unixepoch' modifier (numbers are
139
+
unix seconds) or treating a bare number as a Julian Day. Returns the Julian
140
+
Day in integer milliseconds and whether the value is already in UTC (a number,
141
+
or a tz-bearing string), so a 'utc' modifier is a no-op. *)
142
+
let parse_value ~unixepoch v =
143
+
match v with
144
+
| Ast.Int _ | Float _ ->
145
+
let n =
146
+
match v with Int i -> Int64.to_float i | Float f -> f | _ -> 0.
147
+
in
148
+
let ijd =
149
+
if unixepoch then Int64.add unix_epoch_ms (Int64.of_float (n *. 1000.))
150
+
else Int64.of_float (n *. 86_400_000.)
151
+
in
152
+
(ijd, true)
153
+
| _ ->
154
+
let s = String.trim (text_of_value v) in
155
+
if unixepoch then
156
+
( Int64.add unix_epoch_ms (Int64.of_float (float_of_string s *. 1000.)),
157
+
true )
158
+
else parse_string s
159
+
160
+
(* ── Modifiers ───────────────────────────────────────────────── *)
161
+
162
+
(* "+N unit" / "-N unit" / "N unit": the numeric prefix and the unit word. *)
163
+
let split_amount s =
164
+
let n = String.length s in
165
+
let i = ref 0 in
166
+
if !i < n && (s.[!i] = '+' || s.[!i] = '-') then incr i;
167
+
while !i < n && (s.[!i] = '.' || (s.[!i] >= '0' && s.[!i] <= '9')) do
168
+
incr i
169
+
done;
170
+
let num = String.sub s 0 !i in
171
+
let unit = String.trim (String.sub s !i (n - !i)) in
172
+
(float_of_string num, unit)
173
+
174
+
let normalize_month y mo =
175
+
let total = (y * 12) + (mo - 1) in
176
+
(total / 12, (total mod 12) + 1)
177
+
178
+
let apply_modifier ~had_tz ijd m =
179
+
let m = String.lowercase_ascii (String.trim m) in
180
+
if m = "start of day" then
181
+
let y, mo, d, _, _, _ = fields_of_ijd ijd in
182
+
ijd_of_fields y mo d 0 0 0.
183
+
else if m = "start of month" then
184
+
let y, mo, _, _, _, _ = fields_of_ijd ijd in
185
+
ijd_of_fields y mo 1 0 0 0.
186
+
else if m = "start of year" then
187
+
let y, _, _, _, _, _ = fields_of_ijd ijd in
188
+
ijd_of_fields y 1 1 0 0 0.
189
+
else if m = "utc" then
190
+
(* The value is stored in UTC. 'utc' is a no-op when it already carries a
191
+
timezone (so [datetime('..Z','utc')] keeps the time); otherwise it would
192
+
assume localtime and needs the machine clock, which is not wired. *)
193
+
if had_tz then ijd
194
+
else failwith "date/time: 'utc' on a local time needs a timezone"
195
+
else if m = "localtime" then
196
+
failwith "date/time: 'localtime' needs the machine timezone"
197
+
else
198
+
let amount, unit = split_amount m in
199
+
match unit with
200
+
| "day" | "days" -> Int64.add ijd (Int64.of_float (amount *. 86_400_000.))
201
+
| "hour" | "hours" -> Int64.add ijd (Int64.of_float (amount *. 3_600_000.))
202
+
| "minute" | "minutes" -> Int64.add ijd (Int64.of_float (amount *. 60_000.))
203
+
| "second" | "seconds" -> Int64.add ijd (Int64.of_float (amount *. 1000.))
204
+
| "month" | "months" ->
205
+
let y, mo, d, h, mi, s = fields_of_ijd ijd in
206
+
let y, mo = normalize_month y (mo + int_of_float amount) in
207
+
ijd_of_fields y mo d h mi s
208
+
| "year" | "years" ->
209
+
let y, mo, d, h, mi, s = fields_of_ijd ijd in
210
+
ijd_of_fields (y + int_of_float amount) mo d h mi s
211
+
| _ -> Fmt.failwith "date/time: unknown modifier %S" m
212
+
213
+
(* The full evaluation: parse the time value, then fold the modifiers. Any
214
+
unparseable value, out-of-range field, or unknown modifier yields None, which
215
+
the SQL functions surface as NULL -- sqlite3 never errors on a bad date. *)
216
+
let evaluate args =
217
+
match args with
218
+
| [] -> None
219
+
| Ast.Null :: _ -> None
220
+
| v :: mods -> (
221
+
try
222
+
let mod_strings = List.map text_of_value mods in
223
+
let is_unix m = String.lowercase_ascii (String.trim m) = "unixepoch" in
224
+
let unixepoch = List.exists is_unix mod_strings in
225
+
let mods = List.filter (fun m -> not (is_unix m)) mod_strings in
226
+
let ijd, had_tz = parse_value ~unixepoch v in
227
+
Some (List.fold_left (apply_modifier ~had_tz) ijd mods)
228
+
with Failure _ | Invalid_argument _ -> None)
229
+
230
+
(* ── Formatting ──────────────────────────────────────────────── *)
231
+
232
+
let day_of_week ijd =
233
+
(* 0 = Sunday. JD+0.5 floored is the civil day; +1 mod 7 puts Sunday at 0. *)
234
+
let z = Int64.to_int (Int64.div (Int64.add ijd 43_200_000L) ms_per_day) in
235
+
((z mod 7) + 7 + 1) mod 7
236
+
237
+
let day_of_year y mo d =
238
+
let jan1 = ijd_of_fields y 1 1 0 0 0. in
239
+
let this = ijd_of_fields y mo d 0 0 0. in
240
+
1 + Int64.to_int (Int64.div (Int64.sub this jan1) ms_per_day)
241
+
242
+
let fmt_date ijd =
243
+
let y, mo, d, _, _, _ = fields_of_ijd ijd in
244
+
Fmt.str "%04d-%02d-%02d" y mo d
245
+
246
+
let fmt_time ijd =
247
+
let _, _, _, h, mi, s = fields_of_ijd ijd in
248
+
Fmt.str "%02d:%02d:%02d" h mi (int_of_float s)
249
+
250
+
let fmt_datetime ijd = fmt_date ijd ^ " " ^ fmt_time ijd
251
+
let julianday ijd = Int64.to_float ijd /. 86_400_000.
252
+
let unixepoch_of ijd = Int64.div (Int64.sub ijd unix_epoch_ms) 1000L
253
+
254
+
(* Left-pad an integer with zeros to [width] digits. *)
255
+
let zpad width n =
256
+
let s = string_of_int n in
257
+
let p = width - String.length s in
258
+
if p <= 0 then s else String.make p '0' ^ s
259
+
260
+
(* strftime substitutions. The field strings are computed once, so the loop over
261
+
the format only selects among them. *)
262
+
let strftime fmt ijd =
263
+
let y, mo, d, h, mi, s = fields_of_ijd ijd in
264
+
let doy = day_of_year y mo d in
265
+
let dow = day_of_week ijd in
266
+
let sec_frac =
267
+
let whole = int_of_float s in
268
+
let frac =
269
+
int_of_float (Float.round ((s -. float_of_int whole) *. 1000.))
270
+
in
271
+
zpad 2 whole ^ "." ^ zpad 3 frac
272
+
in
273
+
(* Monday-based week number, as sqlite3's %W computes it. *)
274
+
let week = zpad 2 ((doy + 6 - ((dow + 6) mod 7)) / 7) in
275
+
let subst = function
276
+
| 'Y' -> zpad 4 y
277
+
| 'm' -> zpad 2 mo
278
+
| 'd' -> zpad 2 d
279
+
| 'H' -> zpad 2 h
280
+
| 'M' -> zpad 2 mi
281
+
| 'S' -> zpad 2 (int_of_float s)
282
+
| 'j' -> zpad 3 doy
283
+
| 'w' -> string_of_int dow
284
+
| 'W' -> week
285
+
| 'f' -> sec_frac
286
+
| 's' -> Int64.to_string (unixepoch_of ijd)
287
+
| 'J' -> string_of_float (julianday ijd)
288
+
| '%' -> "%"
289
+
| c -> "%" ^ String.make 1 c
290
+
in
291
+
let buf = Buffer.create (String.length fmt) in
292
+
let n = String.length fmt in
293
+
let i = ref 0 in
294
+
while !i < n do
295
+
if fmt.[!i] = '%' && !i + 1 < n then begin
296
+
Buffer.add_string buf (subst fmt.[!i + 1]);
297
+
i := !i + 2
298
+
end
299
+
else begin
300
+
Buffer.add_char buf fmt.[!i];
301
+
incr i
302
+
end
303
+
done;
304
+
Buffer.contents buf
305
+
306
+
(* ── Public entry: the SQL date/time functions ───────────────── *)
307
+
308
+
let call name args =
309
+
match name with
310
+
| "date" -> (
311
+
match evaluate args with
312
+
| Some ijd -> Ast.Text (fmt_date ijd)
313
+
| None -> Null)
314
+
| "time" -> (
315
+
match evaluate args with
316
+
| Some ijd -> Ast.Text (fmt_time ijd)
317
+
| None -> Null)
318
+
| "datetime" -> (
319
+
match evaluate args with
320
+
| Some ijd -> Ast.Text (fmt_datetime ijd)
321
+
| None -> Null)
322
+
| "julianday" -> (
323
+
match evaluate args with
324
+
| Some ijd -> Ast.Float (julianday ijd)
325
+
| None -> Null)
326
+
| "unixepoch" -> (
327
+
match evaluate args with
328
+
| Some ijd -> Ast.Int (unixepoch_of ijd)
329
+
| None -> Null)
330
+
| "strftime" -> (
331
+
match args with
332
+
| fmt :: rest -> (
333
+
match evaluate rest with
334
+
| Some ijd -> Ast.Text (strftime (text_of_value fmt) ijd)
335
+
| None -> Null)
336
+
| [] -> Null)
337
+
| _ -> invalid_arg ("Datetime.call: not a date/time function: " ^ name)
+21
lib/datetime.mli
+21
lib/datetime.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** SQLite date and time functions (lang_datefunc.html).
7
+
8
+
Time is carried internally as a Julian Day count in integer milliseconds,
9
+
exactly as sqlite3 does, so the deterministic surface -- explicit time
10
+
strings, Julian and unix numbers, the unit and "start of" modifiers -- is
11
+
exact and round-trips. The wall-clock forms ('now', 'localtime', 'utc')
12
+
yield NULL until a clock is injected. *)
13
+
14
+
val call : string -> Ast.value list -> Ast.value
15
+
(** [call name args] evaluates the date/time function [name] (one of ["date"],
16
+
["time"], ["datetime"], ["julianday"], ["unixepoch"], ["strftime"]) on
17
+
[args]: the first argument (after the format string for [strftime]) is the
18
+
time value and the rest are modifiers. An unparseable value, out-of-range
19
+
field, or unknown modifier yields [Null], as in sqlite3.
20
+
21
+
@raise Invalid_argument if [name] is not a date/time function. *)
+9
lib/dune
+9
lib/dune
+770
lib/func.ml
+770
lib/func.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2026 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(* SQLite's built-in scalar and table-valued functions, over {!Catalog.Value.t}.
7
+
A pure value-level layer (no AST, no evaluator): the dispatcher {!apply} maps a
8
+
function name and its already-evaluated argument values to a result, sharing
9
+
the value semantics in {!Value_ops}, so the tree-walker and the register VM
10
+
apply a function the same way. *)
11
+
12
+
open Catalog.Value
13
+
open Value_ops
14
+
15
+
type value = Catalog.Value.t
16
+
17
+
let series_cap = 10_000_000
18
+
let format_cap = 1_000_000
19
+
20
+
(* [generate_series(start, stop [, step])] yields one [value] column from [start]
21
+
to [stop] inclusive, stepping by [step] (default 1, must be non-zero). A
22
+
single-argument (unbounded) or over-[series_cap] range cannot be materialised
23
+
eagerly and raises, rather than hanging. *)
24
+
let generate_series_rows (args : value list) : value list list =
25
+
let to_int = function
26
+
| Int n -> n
27
+
| Float f -> Int64.of_float f
28
+
| _ -> failwith "generate_series: integer arguments expected"
29
+
in
30
+
let start, stop, step =
31
+
match args with
32
+
| [ a; b ] -> (to_int a, to_int b, 1L)
33
+
| [ a; b; c ] -> (to_int a, to_int b, to_int c)
34
+
| [ _ ] -> failwith "generate_series: a stop bound is required"
35
+
| _ -> failwith "generate_series: 1 to 3 arguments expected"
36
+
in
37
+
if step = 0L then failwith "generate_series: step must be non-zero";
38
+
let span = if step > 0L then Int64.sub stop start else Int64.sub start stop in
39
+
let count =
40
+
if span < 0L then 0L else Int64.add (Int64.div span (Int64.abs step)) 1L
41
+
in
42
+
if count > Int64.of_int series_cap then
43
+
failwith "generate_series: range too large to materialise";
44
+
List.init (Int64.to_int count) (fun i ->
45
+
[ Int (Int64.add start (Int64.mul step (Int64.of_int i))) ])
46
+
47
+
(* A table-valued function's output column names (without materialising rows). *)
48
+
let table_function_columns name =
49
+
match name with
50
+
| "generate_series" -> [ "value" ]
51
+
| _ -> Fmt.failwith "no such table-valued function: %s" name
52
+
53
+
(* Dispatch a table-valued function to its [(column names, rows)]. *)
54
+
let table_function name (args : value list) : string list * value list list =
55
+
match name with
56
+
| "generate_series" -> ([ "value" ], generate_series_rows args)
57
+
| _ -> Fmt.failwith "no such table-valued function: %s" name
58
+
59
+
(* Number of UTF-8 characters (each malformed byte sequence counts as one),
60
+
matching SQLite's length() on TEXT. *)
61
+
let utf8_length s = Uutf.String.fold_utf_8 (fun n _ _ -> n + 1) 0 s
62
+
63
+
(* upper/lower fold ASCII only by default (lang_corefunc.html); other bytes pass
64
+
through, matching SQLite built without ICU. *)
65
+
let ascii_upper =
66
+
String.map (fun c ->
67
+
if c >= 'a' && c <= 'z' then Char.chr (Char.code c - 32) else c)
68
+
69
+
let ascii_lower =
70
+
String.map (fun c ->
71
+
if c >= 'A' && c <= 'Z' then Char.chr (Char.code c + 32) else c)
72
+
73
+
(* round(X, n): always REAL, rounding half away from zero (OCaml's Float.round).
74
+
Scaling by 10^n is exact enough for ordinary magnitudes (SQLite's own result
75
+
is bounded by IEEE-754 double precision regardless). *)
76
+
let round_value x n =
77
+
let n = max 0 (min 30 n) in
78
+
let s = 10. ** float_of_int n in
79
+
Float (Float.round (x *. s) /. s)
80
+
81
+
(* Trim characters in [set] (default a single space, per SQLite) from [side] of
82
+
[s]. Byte-based, exact for ASCII; multi-byte trim sets are a TODO. *)
83
+
let trim_value side set s =
84
+
let is_trim c = String.contains set c in
85
+
let n = String.length s in
86
+
let i = ref 0 and j = ref n in
87
+
if side <> `Right then
88
+
while !i < !j && is_trim s.[!i] do
89
+
incr i
90
+
done;
91
+
if side <> `Left then
92
+
while !j > !i && is_trim s.[!j - 1] do
93
+
decr j
94
+
done;
95
+
String.sub s !i (!j - !i)
96
+
97
+
let typeof_name = function
98
+
| Null -> "null"
99
+
| Int _ -> "integer"
100
+
| Float _ -> "real"
101
+
| Text _ -> "text"
102
+
| Blob _ -> "blob"
103
+
104
+
let as_float = function
105
+
| Int i -> Int64.to_float i
106
+
| Float f -> f
107
+
| v -> (
108
+
match float_of_string_opt (String.trim (text_of_value v)) with
109
+
| Some f -> f
110
+
| None -> 0.)
111
+
112
+
let trim_func side v set =
113
+
match (v, set) with
114
+
| Null, _ | _, Null -> Null
115
+
| _ -> Text (trim_value side (text_of_value set) (text_of_value v))
116
+
117
+
(* A real-valued math function: NULL on NULL, and NULL when the result is not
118
+
finite (domain errors like sqrt(-1) -> NaN, ln(0) -> -inf), per
119
+
lang_mathfunc.html. *)
120
+
let math1 f = function
121
+
| Null -> Null
122
+
| v ->
123
+
let r = f (as_float v) in
124
+
if Float.is_finite r then Float r else Null
125
+
126
+
let math2 f a b =
127
+
match (a, b) with
128
+
| Null, _ | _, Null -> Null
129
+
| _ ->
130
+
let r = f (as_float a) (as_float b) in
131
+
if Float.is_finite r then Float r else Null
132
+
133
+
(* ceil/floor/trunc preserve an integer argument and otherwise round a real
134
+
(func7.test: floor(17) -> 17, ceil(42.2) -> 43.0). *)
135
+
let round_like f = function
136
+
| Null -> Null
137
+
| Int _ as v -> v
138
+
| v -> Float (f (as_float v))
139
+
140
+
(* SQLite hex() and the X'..' blob literal use uppercase hex; Ohex.encode is
141
+
lowercase. *)
142
+
let hex_of_string s = String.uppercase_ascii (Ohex.encode s)
143
+
144
+
(* UTF-8 encoding of a Unicode code point, for char(); an out-of-range value
145
+
yields the replacement character, as SQLite substitutes for invalid input. *)
146
+
let utf8_of_cp cp =
147
+
let b = Buffer.create 4 in
148
+
let u = if Uchar.is_valid cp then Uchar.of_int cp else Uchar.rep in
149
+
Uutf.Buffer.add_utf_8 b u;
150
+
Buffer.contents b
151
+
152
+
(* Code point of the first character of a UTF-8 string, for unicode(). *)
153
+
let first_cp s =
154
+
Uutf.String.fold_utf_8
155
+
(fun acc _ d ->
156
+
match acc with
157
+
| Some _ -> acc
158
+
| None -> (
159
+
match d with
160
+
| `Uchar u -> Some (Uchar.to_int u)
161
+
| `Malformed _ -> Some (Uchar.to_int Uchar.rep)))
162
+
None s
163
+
164
+
let fn_coalesce args =
165
+
match List.find_opt (fun v -> v <> Null) args with
166
+
| Some v -> v
167
+
| None -> Null
168
+
169
+
(* NULL for NULL, else apply [f] to the text form. *)
170
+
let fn_text_map f v =
171
+
match v with Null -> Null | _ -> Text (f (text_of_value v))
172
+
173
+
(* length(X): characters for TEXT (lang_corefunc.html), bytes for BLOB, the
174
+
length of the string form for numbers, NULL for NULL. *)
175
+
let fn_length v =
176
+
match v with
177
+
| Null -> Null
178
+
| Text s -> Int (Int64.of_int (utf8_length s))
179
+
| Blob s -> Int (Int64.of_int (String.length s))
180
+
| Int _ | Float _ -> Int (Int64.of_int (String.length (text_of_value v)))
181
+
182
+
(* octet_length(X): the number of bytes in X's text/blob representation (so
183
+
multi-byte UTF-8 counts each byte), NULL for NULL. *)
184
+
let fn_octet_length = function
185
+
| Null -> Null
186
+
| v -> Int (Int64.of_int (String.length (text_of_value v)))
187
+
188
+
let is_hex_digit c =
189
+
(c >= '0' && c <= '9') || (c >= 'a' && c <= 'f') || (c >= 'A' && c <= 'F')
190
+
191
+
(* unhex(X): the blob whose bytes are the hex digit pairs of X; NULL if X has an
192
+
odd length or any non-hex character. *)
193
+
let fn_unhex = function
194
+
| Null -> Null
195
+
| v ->
196
+
let s = text_of_value v in
197
+
let n = String.length s in
198
+
if n mod 2 <> 0 || not (String.for_all is_hex_digit s) then Null
199
+
else begin
200
+
let b = Bytes.create (n / 2) in
201
+
for i = 0 to (n / 2) - 1 do
202
+
Bytes.set b i
203
+
(Char.chr (int_of_string ("0x" ^ String.sub s (2 * i) 2)))
204
+
done;
205
+
Blob (Bytes.unsafe_to_string b)
206
+
end
207
+
208
+
(* zeroblob(N): a blob of N zero bytes (N clamped at 0), NULL for NULL. *)
209
+
let fn_zeroblob = function
210
+
| Null -> Null
211
+
| v -> Blob (String.make (max 0 (Int64.to_int (intify v))) '\000')
212
+
213
+
(* instr(X, Y): 1-based byte position of the first Y in X, 0 if absent, NULL
214
+
if either is NULL. Byte-based, so exact for ASCII/BLOB. *)
215
+
let fn_instr x y =
216
+
match (x, y) with
217
+
| Null, _ | _, Null -> Null
218
+
| _ ->
219
+
let hay = text_of_value x and needle = text_of_value y in
220
+
let pos =
221
+
if needle = "" then 1
222
+
else
223
+
match Re.exec_opt Re.(compile (str needle)) hay with
224
+
| None -> 0
225
+
| Some g -> Re.Group.start g 0 + 1
226
+
in
227
+
Int (Int64.of_int pos)
228
+
229
+
(* substr(X, Y[, Z]): substring from 1-based byte offset Y (negative counts
230
+
from the end) of length Z (to the end if omitted). *)
231
+
let fn_substr x y rest =
232
+
match x with
233
+
| Null -> Null
234
+
| _ ->
235
+
(* substr of a blob is a blob (byte offsets); of anything else, text. *)
236
+
let wrap =
237
+
match x with Blob _ -> fun s -> Blob s | _ -> fun s -> Text s
238
+
in
239
+
let s = text_of_value x in
240
+
let len = String.length s in
241
+
let y =
242
+
match y with
243
+
| Null -> 0
244
+
| v -> Int64.to_int (Int64.of_float (float_of_value v))
245
+
in
246
+
let start = if y < 0 then max 0 (len + y) else max 0 (y - 1) in
247
+
let avail = len - start in
248
+
let n =
249
+
match rest with
250
+
| z :: _ ->
251
+
min avail (max 0 (Int64.to_int (Int64.of_float (float_of_value z))))
252
+
| [] -> avail
253
+
in
254
+
if start >= len then wrap "" else wrap (String.sub s start n)
255
+
256
+
(* abs(X): type-preserving; the most-negative integer overflows (func-18.32);
257
+
text/blob coerce to a number. *)
258
+
let fn_abs v =
259
+
match v with
260
+
| Null -> Null
261
+
| Int i ->
262
+
if i = Int64.min_int then Fmt.failwith "integer overflow"
263
+
else Int (Int64.abs i)
264
+
| Float f -> Float (Float.abs f)
265
+
| _ -> Float (Float.abs (as_float v))
266
+
267
+
let fn_round1 v = match v with Null -> Null | _ -> round_value (as_float v) 0
268
+
269
+
let fn_round2 v d =
270
+
match (v, d) with
271
+
| Null, _ | _, Null -> Null
272
+
| _ -> round_value (as_float v) (Int64.to_int (Int64.of_float (as_float d)))
273
+
274
+
(* replace(X, Y, Z): all non-overlapping; empty Y returns X; NULL is
275
+
contagious. *)
276
+
let fn_replace x y z =
277
+
match (x, y, z) with
278
+
| Null, _, _ | _, Null, _ | _, _, Null -> Null
279
+
| _ ->
280
+
let hay = text_of_value x and needle = text_of_value y in
281
+
if needle = "" then Text hay
282
+
else
283
+
Text
284
+
(Re.replace_string
285
+
Re.(compile (str needle))
286
+
~by:(text_of_value z) hay)
287
+
288
+
(* sign(X): integer -1/0/+1 for a number, NULL otherwise (func7.test). *)
289
+
let fn_sign v =
290
+
match v with
291
+
| Null -> Null
292
+
| Int _ | Float _ ->
293
+
let f = as_float v in
294
+
Int (if f < 0. then -1L else if f > 0. then 1L else 0L)
295
+
| _ -> Null
296
+
297
+
let fn_quote v =
298
+
Text
299
+
(match v with
300
+
| Null -> "NULL"
301
+
(* quote() renders an overflowed real as sqlite3's roundtrippable
302
+
9.0e+999 sentinel, not the "Inf" text form. *)
303
+
| Float f when f = Float.infinity -> "9.0e+999"
304
+
| Float f when f = Float.neg_infinity -> "-9.0e+999"
305
+
| Int _ | Float _ -> text_of_value v
306
+
| Text s -> "'" ^ String.concat "''" (String.split_on_char '\'' s) ^ "'"
307
+
| Blob s -> "X'" ^ hex_of_string s ^ "'")
308
+
309
+
let fn_char args =
310
+
Text
311
+
(String.concat ""
312
+
(List.map
313
+
(fun v -> utf8_of_cp (Int64.to_int (Int64.of_float (as_float v))))
314
+
args))
315
+
316
+
let fn_unicode v =
317
+
match v with
318
+
| Null -> Null
319
+
| _ -> (
320
+
match first_cp (text_of_value v) with
321
+
| Some cp -> Int (Int64.of_int cp)
322
+
| None -> Null)
323
+
324
+
(* concat/concat_ws: NULL arguments are skipped (func9.test); concat_ws takes
325
+
the separator first and is NULL if the separator is NULL. *)
326
+
let fn_concat args =
327
+
Text
328
+
(String.concat ""
329
+
(List.filter_map
330
+
(function Null -> None | v -> Some (text_of_value v))
331
+
args))
332
+
333
+
let fn_concat_ws sep rest =
334
+
match sep with
335
+
| Null -> Null
336
+
| _ ->
337
+
Text
338
+
(String.concat (text_of_value sep)
339
+
(List.filter_map
340
+
(function Null -> None | v -> Some (text_of_value v))
341
+
rest))
342
+
343
+
(* Scalar max/min: NULL if any argument is NULL, else the argument that wins
344
+
under [keep] (a sign-of-comparison predicate) against the running extreme. *)
345
+
let fn_extreme keep = function
346
+
| [] -> Null
347
+
| v :: vs ->
348
+
if List.exists (fun x -> x = Null) (v :: vs) then Null
349
+
else
350
+
List.fold_left
351
+
(fun a x -> if keep (compare_values x a) then x else a)
352
+
v vs
353
+
354
+
(* printf/format: a C-style formatter, matching sqlite3's printf() (the SQL
355
+
[format] function). Supports flags [- + space 0 #], width and precision
356
+
(literal or [*] consuming an argument), and conversions d i u x X o f e E g G
357
+
s c % plus sqlite's q (escape '), Q (quote + NULL-aware). sqlite extensions
358
+
like the ',' grouping flag are accepted and ignored. *)
359
+
type fmt_spec = {
360
+
left : bool;
361
+
zero : bool;
362
+
plus : bool;
363
+
space : bool;
364
+
alt : bool;
365
+
width : int;
366
+
prec : int option;
367
+
}
368
+
369
+
let coerce_float v =
370
+
match v with
371
+
| Int i -> Int64.to_float i
372
+
| Float x -> x
373
+
| _ -> (
374
+
match float_of_string_opt (String.trim (text_of_value v)) with
375
+
| Some x -> x
376
+
| None -> 0.)
377
+
378
+
let fmt_quote s = String.concat "''" (String.split_on_char '\'' s)
379
+
380
+
(* Right- or left-justify [s] in the field width with spaces. *)
381
+
let fmt_pad spec s =
382
+
let p = spec.width - String.length s in
383
+
if p <= 0 then s
384
+
else if spec.left then s ^ String.make p ' '
385
+
else String.make p ' ' ^ s
386
+
387
+
(* Place [pfx] (sign or radix prefix) then [digits] in the field; zero-padding
388
+
goes between the prefix and the digits, unless a precision was given. *)
389
+
let fmt_pad_num spec pfx digits =
390
+
let body = pfx ^ digits in
391
+
let p = spec.width - String.length body in
392
+
if p <= 0 then body
393
+
else if spec.left then body ^ String.make p ' '
394
+
else if spec.zero && spec.prec = None then pfx ^ String.make p '0' ^ digits
395
+
else String.make p ' ' ^ body
396
+
397
+
(* Left-pad a digit string with zeros up to the precision. *)
398
+
let fmt_prec prec d =
399
+
match prec with
400
+
| Some p when String.length d < p -> String.make (p - String.length d) '0' ^ d
401
+
| _ -> d
402
+
403
+
let fmt_int spec conv v =
404
+
match conv with
405
+
| 'u' -> fmt_pad_num spec "" (Fmt.kstr (fmt_prec spec.prec) "%Lu" (intify v))
406
+
| 'x' | 'X' | 'o' ->
407
+
let x = intify v in
408
+
let body =
409
+
fmt_prec spec.prec
410
+
(match conv with
411
+
| 'x' -> Fmt.str "%Lx" x
412
+
| 'X' -> Fmt.str "%LX" x
413
+
| _ -> Fmt.str "%Lo" x)
414
+
in
415
+
let pfx =
416
+
if (not spec.alt) || x = 0L then ""
417
+
else match conv with 'x' -> "0x" | 'X' -> "0X" | _ -> "0"
418
+
in
419
+
fmt_pad_num spec pfx body
420
+
| _ ->
421
+
let x = intify v in
422
+
let neg = x < 0L in
423
+
let mag = if neg then Int64.neg x else x in
424
+
let pfx =
425
+
if neg then "-"
426
+
else if spec.plus then "+"
427
+
else if spec.space then " "
428
+
else ""
429
+
in
430
+
fmt_pad_num spec pfx (Fmt.kstr (fmt_prec spec.prec) "%Lu" mag)
431
+
432
+
let fmt_float_core conv p x =
433
+
match conv with
434
+
| 'f' -> Fmt.str "%.*f" p x
435
+
| 'e' -> Fmt.str "%.*e" p x
436
+
| 'E' -> Fmt.str "%.*E" p x
437
+
| 'g' -> Fmt.str "%.*g" p x
438
+
| _ -> Fmt.str "%.*G" p x
439
+
440
+
(* Zero-pad [signed] (which may carry a leading sign) to the field width, with
441
+
the zeros falling after any sign. *)
442
+
let fmt_float_zeropad spec signed =
443
+
let has_sign =
444
+
signed <> "" && (signed.[0] = '-' || signed.[0] = '+' || signed.[0] = ' ')
445
+
in
446
+
let zeros = String.make (spec.width - String.length signed) '0' in
447
+
if has_sign then
448
+
String.sub signed 0 1 ^ zeros
449
+
^ String.sub signed 1 (String.length signed - 1)
450
+
else zeros ^ signed
451
+
452
+
let fmt_float spec conv v =
453
+
let x = coerce_float v in
454
+
let core = fmt_float_core conv (Option.value spec.prec ~default:6) x in
455
+
let signed =
456
+
if x >= 0. && spec.plus then "+" ^ core
457
+
else if x >= 0. && spec.space then " " ^ core
458
+
else core
459
+
in
460
+
if (not spec.left) && spec.zero && String.length signed < spec.width then
461
+
fmt_float_zeropad spec signed
462
+
else fmt_pad spec signed
463
+
464
+
(* Render one conversion [conv] under [spec], pulling argument(s) from [pop]. *)
465
+
let fmt_conv spec conv pop =
466
+
let text () = match pop () with Null -> "" | v -> text_of_value v in
467
+
match conv with
468
+
| 'd' | 'i' | 'u' | 'x' | 'X' | 'o' -> fmt_int spec conv (pop ())
469
+
| 'f' | 'e' | 'E' | 'g' | 'G' -> fmt_float spec conv (pop ())
470
+
| 's' ->
471
+
let s = text () in
472
+
let s =
473
+
match spec.prec with
474
+
| Some p when p < String.length s -> String.sub s 0 p
475
+
| _ -> s
476
+
in
477
+
fmt_pad spec s
478
+
| 'c' ->
479
+
let s = text () in
480
+
fmt_pad spec (if s = "" then "" else String.sub s 0 1)
481
+
| 'q' -> fmt_pad spec (fmt_quote (text ()))
482
+
| 'Q' -> (
483
+
match pop () with
484
+
| Null -> fmt_pad spec "NULL"
485
+
| v -> fmt_pad spec ("'" ^ fmt_quote (text_of_value v) ^ "'"))
486
+
| c -> String.make 1 c
487
+
488
+
(* Parse the flags of a conversion spec starting at [i]; returns the flag record
489
+
and the index of the first non-flag character. *)
490
+
let fmt_parse_flags f n i =
491
+
let left = ref false
492
+
and zero = ref false
493
+
and plus = ref false
494
+
and space = ref false
495
+
and alt = ref false in
496
+
let j = ref i and scanning = ref true in
497
+
while !scanning && !j < n do
498
+
(match f.[!j] with
499
+
| '-' -> left := true
500
+
| '0' -> zero := true
501
+
| '+' -> plus := true
502
+
| ' ' -> space := true
503
+
| '#' -> alt := true
504
+
| ',' | '!' -> ()
505
+
| _ -> scanning := false);
506
+
if !scanning then incr j
507
+
done;
508
+
((!left, !zero, !plus, !space, !alt), !j)
509
+
510
+
(* Parse a width/precision number at [i]: a literal integer, a [*] consuming an
511
+
argument via [pop], or none. Returns the value (if any) and the next index. *)
512
+
let fmt_checked_bound n =
513
+
let limit = Int64.of_int format_cap in
514
+
if n > limit || n < Int64.neg limit then
515
+
failwith "format: width or precision too large";
516
+
Int64.to_int n
517
+
518
+
let fmt_parse_num f n pop i =
519
+
if i < n && f.[i] = '*' then
520
+
(Some (fmt_checked_bound (intify (pop ()))), i + 1)
521
+
else
522
+
let j = ref i in
523
+
while !j < n && f.[!j] >= '0' && f.[!j] <= '9' do
524
+
incr j
525
+
done;
526
+
if !j > i then
527
+
let s = String.sub f i (!j - i) in
528
+
let n =
529
+
match Int64.of_string_opt s with
530
+
| Some n -> fmt_checked_bound n
531
+
| None -> failwith "format: width or precision too large"
532
+
in
533
+
(Some n, !j)
534
+
else (None, i)
535
+
536
+
(* Parse a full conversion spec just past the [%] at [start]. Returns the spec,
537
+
the conversion character (None for a trailing [%]), and the next index. *)
538
+
let fmt_parse_spec f n pop start =
539
+
let (left, zero, plus, space, alt), i = fmt_parse_flags f n start in
540
+
let width0, i = fmt_parse_num f n pop i in
541
+
let left, width =
542
+
match width0 with
543
+
| Some w when w < 0 -> (true, -w)
544
+
| Some w -> (left, w)
545
+
| None -> (left, 0)
546
+
in
547
+
let prec, i =
548
+
if i < n && f.[i] = '.' then
549
+
let p, i = fmt_parse_num f n pop (i + 1) in
550
+
let p =
551
+
match p with
552
+
| Some p when p < 0 -> None
553
+
| Some p -> Some p
554
+
| None -> Some 0
555
+
in
556
+
(p, i)
557
+
else (None, i)
558
+
in
559
+
let spec = { left; zero; plus; space; alt; width; prec } in
560
+
if i < n then (spec, Some f.[i], i + 1) else (spec, None, i)
561
+
562
+
(* Emit the directive that begins just past the [%] at [start]; return the next
563
+
index. A doubled [%%] is a literal percent. *)
564
+
let fmt_directive buf f n pop start =
565
+
if start < n && f.[start] = '%' then begin
566
+
Buffer.add_char buf '%';
567
+
start + 1
568
+
end
569
+
else
570
+
let spec, conv, j = fmt_parse_spec f n pop start in
571
+
(match conv with
572
+
| None -> ()
573
+
| Some c -> Buffer.add_string buf (fmt_conv spec c pop));
574
+
j
575
+
576
+
let fn_format args =
577
+
match args with
578
+
| [] | Null :: _ -> Null
579
+
| fmt :: rest ->
580
+
let f = text_of_value fmt in
581
+
let n = String.length f in
582
+
let buf = Buffer.create (n * 2) in
583
+
let pending = ref rest in
584
+
let pop () =
585
+
match !pending with
586
+
| x :: tl ->
587
+
pending := tl;
588
+
x
589
+
| [] -> Null
590
+
in
591
+
let i = ref 0 in
592
+
while !i < n do
593
+
if f.[!i] <> '%' then begin
594
+
Buffer.add_char buf f.[!i];
595
+
incr i
596
+
end
597
+
else i := fmt_directive buf f n pop (!i + 1)
598
+
done;
599
+
Text (Buffer.contents buf)
600
+
601
+
(* ── JSON (json1) ────────────────────────────────────────────── *)
602
+
603
+
let json_of_sql = function
604
+
| Null -> Jsonval.Null
605
+
| Int i -> Jsonval.Int i
606
+
| Float f -> Jsonval.real f
607
+
| Text s -> Jsonval.Str s
608
+
| Blob s -> Jsonval.Str s
609
+
610
+
(* A json_extract / ->> result as a SQL value: scalars become their SQL form,
611
+
containers their JSON text. *)
612
+
let sql_of_json = function
613
+
| Jsonval.Null -> Null
614
+
| Jsonval.Bool b -> Int (if b then 1L else 0L)
615
+
| Jsonval.Int i -> Int i
616
+
| Jsonval.Real s -> (
617
+
match float_of_string_opt s with Some f -> Float f | None -> Null)
618
+
| Jsonval.Str s -> Text s
619
+
| (Jsonval.Arr _ | Jsonval.Obj _) as j -> Text (Jsonval.to_text j)
620
+
621
+
let json_parse_arg v =
622
+
match Jsonval.parse (text_of_value v) with
623
+
| Some j -> j
624
+
| None -> failwith "malformed JSON"
625
+
626
+
(* json_extract(X, P, ...): one path returns the SQL value at P (NULL if
627
+
absent); several paths return a JSON array of the results. *)
628
+
let fn_json_extract jv paths =
629
+
let j = json_parse_arg jv in
630
+
match paths with
631
+
| [ p ] -> (
632
+
match Jsonval.lookup j (text_of_value p) with
633
+
| Some r -> sql_of_json r
634
+
| None -> Null)
635
+
| _ ->
636
+
let pick p =
637
+
match Jsonval.lookup j (text_of_value p) with
638
+
| Some r -> r
639
+
| None -> Jsonval.Null
640
+
in
641
+
Text (Jsonval.to_text (Jsonval.Arr (List.map pick paths)))
642
+
643
+
(* The path of a [->]/[->>] right operand: a full [$...] path passes through, an
644
+
integer becomes [$[n]], any other label becomes [$.label]. *)
645
+
let arrow_path = function
646
+
| Int i -> Fmt.str "$[%Ld]" i
647
+
| v ->
648
+
let s = text_of_value v in
649
+
if String.length s > 0 && s.[0] = '$' then s else "$." ^ s
650
+
651
+
(* a -> p : the element at p as JSON text. a ->> p : as a SQL value. *)
652
+
let json_arrow ~as_text jv pv =
653
+
match (jv, pv) with
654
+
| Null, _ | _, Null -> Null
655
+
| _ -> (
656
+
let j = json_parse_arg jv in
657
+
match Jsonval.lookup j (arrow_path pv) with
658
+
| None -> Null
659
+
| Some r -> if as_text then sql_of_json r else Text (Jsonval.to_text r))
660
+
661
+
(* json_type / json_array_length, optionally at a path. *)
662
+
let json_at jv path_opt =
663
+
let j = json_parse_arg jv in
664
+
match path_opt with
665
+
| None -> Some j
666
+
| Some p -> Jsonval.lookup j (text_of_value p)
667
+
668
+
let apply name args =
669
+
match (name, args) with
670
+
| "coalesce", _ -> fn_coalesce args
671
+
(* like(Y, X [, E]) is the function form of [X LIKE Y [ESCAPE E]] -- the
672
+
pattern is the first argument (lang_corefunc.html). *)
673
+
| "like", [ y; x ] -> like_op x y
674
+
| "like", [ y; x; e ] -> like_op ~escape:e x y
675
+
| "glob", [ y; x ] -> glob_op x y
676
+
| "length", [ v ] -> fn_length v
677
+
| "instr", [ x; y ] -> fn_instr x y
678
+
| "substr", x :: y :: rest -> fn_substr x y rest
679
+
| "upper", [ v ] -> fn_text_map ascii_upper v
680
+
| "lower", [ v ] -> fn_text_map ascii_lower v
681
+
| "abs", [ v ] -> fn_abs v
682
+
| "round", [ v ] -> fn_round1 v
683
+
| "round", [ v; d ] -> fn_round2 v d
684
+
| "trim", [ v ] -> fn_text_map (trim_value `Both " ") v
685
+
| "ltrim", [ v ] -> fn_text_map (trim_value `Left " ") v
686
+
| "rtrim", [ v ] -> fn_text_map (trim_value `Right " ") v
687
+
| "trim", [ v; set ] -> trim_func `Both v set
688
+
| "ltrim", [ v; set ] -> trim_func `Left v set
689
+
| "rtrim", [ v; set ] -> trim_func `Right v set
690
+
| "replace", [ x; y; z ] -> fn_replace x y z
691
+
| "ifnull", [ a; b ] -> if a <> Null then a else b
692
+
(* nullif(X, Y): NULL if X = Y (so nullif(1, NULL) is 1, since 1=NULL is not
693
+
true), else X. *)
694
+
| "nullif", [ a; b ] -> (
695
+
(* NULLIF(a,b) is a unless a and b are non-NULL and compare equal *)
696
+
match (a, b) with
697
+
| Null, _ | _, Null -> a
698
+
| _ -> if compare_values a b = 0 then Null else a)
699
+
| "typeof", [ v ] -> Text (typeof_name v)
700
+
(* Optimizer-hint no-ops (lang_corefunc.html): they return their first
701
+
argument unchanged. *)
702
+
| ("likely" | "unlikely"), [ x ] -> x
703
+
| "likelihood", [ x; _ ] -> x
704
+
(* Math functions (lang_mathfunc.html); all real-valued except ceil/floor/
705
+
trunc, which preserve an integer argument. *)
706
+
| "sqrt", [ v ] -> math1 sqrt v
707
+
| ("pow" | "power"), [ a; b ] -> math2 Float.pow a b
708
+
| ("ceil" | "ceiling"), [ v ] -> round_like Float.ceil v
709
+
| "floor", [ v ] -> round_like Float.floor v
710
+
| "trunc", [ v ] -> round_like Float.trunc v
711
+
| "exp", [ v ] -> math1 exp v
712
+
| "ln", [ v ] -> math1 log v
713
+
| ("log10" | "log"), [ v ] -> math1 log10 v
714
+
| "log2", [ v ] -> math1 Float.log2 v
715
+
| "log", [ b; v ] -> math2 (fun b x -> log x /. log b) b v
716
+
| "sin", [ v ] -> math1 sin v
717
+
| "cos", [ v ] -> math1 cos v
718
+
| "tan", [ v ] -> math1 tan v
719
+
| "asin", [ v ] -> math1 asin v
720
+
| "acos", [ v ] -> math1 acos v
721
+
| "atan", [ v ] -> math1 atan v
722
+
| "atan2", [ y; x ] -> math2 atan2 y x
723
+
| "degrees", [ v ] -> math1 (fun r -> r *. 180. /. Float.pi) v
724
+
| "radians", [ v ] -> math1 (fun d -> d *. Float.pi /. 180.) v
725
+
| "pi", [] -> Float Float.pi
726
+
| "sign", [ v ] -> fn_sign v
727
+
| "hex", [ v ] -> fn_text_map hex_of_string v
728
+
| "unhex", [ v ] -> fn_unhex v
729
+
| "octet_length", [ v ] -> fn_octet_length v
730
+
| "zeroblob", [ v ] -> fn_zeroblob v
731
+
| "quote", [ v ] -> fn_quote v
732
+
| "char", args -> fn_char args
733
+
| "unicode", [ v ] -> fn_unicode v
734
+
| "concat", args -> fn_concat args
735
+
| "concat_ws", sep :: rest -> fn_concat_ws sep rest
736
+
| ("printf" | "format"), args -> fn_format args
737
+
| ( ("date" | "time" | "datetime" | "julianday" | "unixepoch" | "strftime"),
738
+
args ) ->
739
+
Datetime.call name args
740
+
| "json", [ Null ] -> Null
741
+
| "json", [ v ] -> Text (Jsonval.to_text (json_parse_arg v))
742
+
| "json_valid", [ Null ] -> Null
743
+
| "json_valid", [ v ] ->
744
+
Int (if Jsonval.parse (text_of_value v) <> None then 1L else 0L)
745
+
| "json_quote", [ v ] -> Text (Jsonval.to_text (json_of_sql v))
746
+
| "json_array", args ->
747
+
Text (Jsonval.to_text (Jsonval.Arr (List.map json_of_sql args)))
748
+
| "json_object", args ->
749
+
let rec pairs = function
750
+
| k :: v :: rest -> (text_of_value k, json_of_sql v) :: pairs rest
751
+
| _ -> []
752
+
in
753
+
Text (Jsonval.to_text (Jsonval.Obj (pairs args)))
754
+
| "json_extract", jv :: (_ :: _ as paths) -> fn_json_extract jv paths
755
+
| "json_type", [ v ] -> Text (Jsonval.type_name (json_parse_arg v))
756
+
| "json_type", [ v; p ] -> (
757
+
match json_at v (Some p) with
758
+
| Some j -> Text (Jsonval.type_name j)
759
+
| None -> Null)
760
+
| "json_array_length", ([ v ] | [ v; _ ]) -> (
761
+
let path_opt = match args with [ _; p ] -> Some p | _ -> None in
762
+
match json_at v path_opt with
763
+
| Some (Jsonval.Arr xs) -> Int (Int64.of_int (List.length xs))
764
+
| Some _ -> Int 0L
765
+
| None -> Null)
766
+
(* Scalar max/min (two or more arguments): NULL if any argument is NULL, else
767
+
the largest/smallest by SQLite value ordering. *)
768
+
| "max", (_ :: _ :: _ as args) -> fn_extreme (fun c -> c > 0) args
769
+
| "min", (_ :: _ :: _ as args) -> fn_extreme (fun c -> c < 0) args
770
+
| _ -> Fmt.failwith "unknown function %s()" name
+29
lib/func.mli
+29
lib/func.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2026 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** SQLite's built-in scalar and table-valued functions over {!Catalog.Value.t}.
7
+
8
+
A pure value-level layer (no AST, no evaluator) shared by the tree-walker
9
+
and the register VM, so a function applies the same way in both. *)
10
+
11
+
val apply : string -> Catalog.Value.t list -> Catalog.Value.t
12
+
(** [apply name args] applies the scalar function [name] to its evaluated
13
+
argument values (length/substr/abs/round/coalesce/json_extract/printf/...).
14
+
@raise Failure on an unknown function or a domain error (e.g. a bad ESCAPE).
15
+
*)
16
+
17
+
val json_arrow :
18
+
as_text:bool -> Catalog.Value.t -> Catalog.Value.t -> Catalog.Value.t
19
+
(** [json_arrow ~as_text doc path] is the JSON [->] ([~as_text:false]) / [->>]
20
+
([~as_text:true]) accessor: extract [path] from the JSON [doc]. *)
21
+
22
+
val table_function :
23
+
string -> Catalog.Value.t list -> string list * Catalog.Value.t list list
24
+
(** [table_function name args] materialises a table-valued function (e.g.
25
+
[generate_series]) to its column names and rows. *)
26
+
27
+
val table_function_columns : string -> string list
28
+
(** [table_function_columns name] is a table-valued function's output column
29
+
names, without materialising its rows. *)
+183
lib/jsonval.ml
+183
lib/jsonval.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(* SQLite's json1 value dialect (json.html). Parsing and validation reuse the
7
+
{!Json} library (nox-json); this module adds what is sqlite-specific: the
8
+
minified text serialisation sqlite3 emits (number and string formatting
9
+
byte-compatible) and [$.a.b[2]] path navigation. The SQL functions in
10
+
{!Query} build on it. *)
11
+
12
+
type t =
13
+
| Null
14
+
| Bool of bool
15
+
| Int of int64
16
+
| Real of string (** the number's text, formatted by {!real} *)
17
+
| Str of string
18
+
| Arr of t list
19
+
| Obj of (string * t) list
20
+
21
+
exception Error of string
22
+
23
+
let type_name = function
24
+
| Null -> "null"
25
+
| Bool true -> "true"
26
+
| Bool false -> "false"
27
+
| Int _ -> "integer"
28
+
| Real _ -> "real"
29
+
| Str _ -> "text"
30
+
| Arr _ -> "array"
31
+
| Obj _ -> "object"
32
+
33
+
(* ── Serialisation ───────────────────────────────────────────── *)
34
+
35
+
(* A real as sqlite3 renders it in JSON: C [%.15g] (shortest within 15
36
+
significant digits, trailing zeros stripped), then a forced decimal point --
37
+
"10000000000.0", "1.0e+15", "0.1" -- so it always reads back as a real. *)
38
+
let real_text f =
39
+
let s = Fmt.str "%.15g" f in
40
+
match String.index_opt s 'e' with
41
+
| Some i ->
42
+
let mant = String.sub s 0 i
43
+
and ex = String.sub s i (String.length s - i) in
44
+
let mant = if String.contains mant '.' then mant else mant ^ ".0" in
45
+
mant ^ ex
46
+
| None -> if String.contains s '.' then s else s ^ ".0"
47
+
48
+
(* Build a real node from a SQL double, formatted as sqlite3 would. *)
49
+
let real f = Real (real_text f)
50
+
51
+
let escape_into buf s =
52
+
Buffer.add_char buf '"';
53
+
String.iter
54
+
(fun c ->
55
+
match c with
56
+
| '"' -> Buffer.add_string buf "\\\""
57
+
| '\\' -> Buffer.add_string buf "\\\\"
58
+
| '\n' -> Buffer.add_string buf "\\n"
59
+
| '\r' -> Buffer.add_string buf "\\r"
60
+
| '\t' -> Buffer.add_string buf "\\t"
61
+
| '\b' -> Buffer.add_string buf "\\b"
62
+
| '\012' -> Buffer.add_string buf "\\f"
63
+
| c when Char.code c < 0x20 ->
64
+
(* control characters as \u00XX; built directly to avoid a formatter
65
+
allocation per character *)
66
+
let hex = "0123456789abcdef" in
67
+
Buffer.add_string buf "\\u00";
68
+
Buffer.add_char buf hex.[(Char.code c lsr 4) land 0xf];
69
+
Buffer.add_char buf hex.[Char.code c land 0xf]
70
+
| c -> Buffer.add_char buf c)
71
+
s;
72
+
Buffer.add_char buf '"'
73
+
74
+
let to_text j =
75
+
let buf = Buffer.create 64 in
76
+
let rec go = function
77
+
| Null -> Buffer.add_string buf "null"
78
+
| Bool b -> Buffer.add_string buf (if b then "true" else "false")
79
+
| Int i -> Buffer.add_string buf (Int64.to_string i)
80
+
| Real s -> Buffer.add_string buf s
81
+
| Str s -> escape_into buf s
82
+
| Arr xs ->
83
+
Buffer.add_char buf '[';
84
+
List.iteri
85
+
(fun i x ->
86
+
if i > 0 then Buffer.add_char buf ',';
87
+
go x)
88
+
xs;
89
+
Buffer.add_char buf ']'
90
+
| Obj kvs ->
91
+
Buffer.add_char buf '{';
92
+
List.iteri
93
+
(fun i (k, v) ->
94
+
if i > 0 then Buffer.add_char buf ',';
95
+
escape_into buf k;
96
+
Buffer.add_char buf ':';
97
+
go v)
98
+
kvs;
99
+
Buffer.add_char buf '}'
100
+
in
101
+
go j;
102
+
Buffer.contents buf
103
+
104
+
let pp ppf j = Fmt.string ppf (to_text j)
105
+
106
+
(* ── Parsing (delegated to nox-json) ─────────────────────────── *)
107
+
108
+
(* Map a parsed nox-json value into the sqlite dialect tree. A number with a
109
+
fraction/exponent (nox-json [Float]) is re-formatted via {!real}; sqlite3
110
+
preserves the original lexeme of such a number, which this does not (the one
111
+
intentional divergence -- integers, strings, and structure are exact). *)
112
+
let rec of_json (j : Json.t) : t =
113
+
match j with
114
+
| Json.Null _ -> Null
115
+
| Json.Bool (b, _) -> Bool b
116
+
| Json.Number (n, _) -> (
117
+
match n with
118
+
| Json.Number.Int i | Json.Number.Uint i -> Int i
119
+
| Json.Number.Float f -> real f)
120
+
| Json.String (s, _) -> Str s
121
+
| Json.Array (xs, _) -> Arr (List.map of_json xs)
122
+
| Json.Object (members, _) ->
123
+
Obj (List.map (fun ((k, _), v) -> (k, of_json v)) members)
124
+
125
+
let parse s =
126
+
match Json.Value.of_string s with Ok v -> Some (of_json v) | Error _ -> None
127
+
128
+
let parse_exn s =
129
+
match parse s with Some j -> j | None -> raise (Error "malformed JSON")
130
+
131
+
(* ── Path navigation ($.a.b[2]) ──────────────────────────────── *)
132
+
133
+
type step = Key of string | Index of int
134
+
135
+
(* Parse a path expression like [$.a.b[2]] or [$[0]] into steps. *)
136
+
let parse_path p =
137
+
let n = String.length p in
138
+
if n = 0 || p.[0] <> '$' then None
139
+
else begin
140
+
let i = ref 1 and steps = ref [] and ok = ref true in
141
+
while !ok && !i < n do
142
+
match p.[!i] with
143
+
| '.' ->
144
+
incr i;
145
+
let start = !i in
146
+
while !i < n && match p.[!i] with '.' | '[' -> false | _ -> true do
147
+
incr i
148
+
done;
149
+
steps := Key (String.sub p start (!i - start)) :: !steps
150
+
| '[' ->
151
+
incr i;
152
+
let start = !i in
153
+
while !i < n && p.[!i] <> ']' do
154
+
incr i
155
+
done;
156
+
(match int_of_string_opt (String.sub p start (!i - start)) with
157
+
| Some k -> steps := Index k :: !steps
158
+
| None -> ok := false);
159
+
if !i < n then incr i (* past ']' *)
160
+
| _ -> ok := false
161
+
done;
162
+
if !ok then Some (List.rev !steps) else None
163
+
end
164
+
165
+
let rec navigate j = function
166
+
| [] -> Some j
167
+
| Key k :: rest -> (
168
+
match j with
169
+
| Obj kvs -> (
170
+
match List.assoc_opt k kvs with
171
+
| Some v -> navigate v rest
172
+
| None -> None)
173
+
| _ -> None)
174
+
| Index k :: rest -> (
175
+
match j with
176
+
| Arr xs -> (
177
+
match List.nth_opt xs k with
178
+
| Some v -> navigate v rest
179
+
| None -> None)
180
+
| _ -> None)
181
+
182
+
let lookup j path =
183
+
match parse_path path with None -> None | Some steps -> navigate j steps
+44
lib/jsonval.mli
+44
lib/jsonval.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** SQLite's json1 value dialect (json.html). Parsing reuses the {!Json} library
7
+
(nox-json); this module adds the minified text serialisation sqlite3 emits
8
+
(number and string formatting byte-compatible) and [$.a.b[2]] path lookup.
9
+
*)
10
+
11
+
type t =
12
+
| Null
13
+
| Bool of bool
14
+
| Int of int64
15
+
| Real of string (** the number's text, formatted by {!real} *)
16
+
| Str of string
17
+
| Arr of t list
18
+
| Obj of (string * t) list
19
+
20
+
exception Error of string
21
+
22
+
val real : float -> t
23
+
(** A real node from a SQL double, formatted as sqlite3 renders JSON reals. *)
24
+
25
+
val type_name : t -> string
26
+
(** [type_name j] is the sqlite3 json_type name of [j]: ["null"], ["true"],
27
+
["false"], ["integer"], ["real"], ["text"], ["array"], or ["object"]. *)
28
+
29
+
val pp : Format.formatter -> t -> unit
30
+
(** Pretty-print as minified JSON text (same as {!to_text}). *)
31
+
32
+
val to_text : t -> string
33
+
(** Minified JSON text, byte-compatible with sqlite3. *)
34
+
35
+
val parse : string -> t option
36
+
(** [parse s] parses the JSON text [s] via nox-json, or [None] if it is
37
+
malformed. *)
38
+
39
+
val parse_exn : string -> t
40
+
(** Parse JSON text. @raise Error on malformed input. *)
41
+
42
+
val lookup : t -> string -> t option
43
+
(** [lookup j path] evaluates a path like [$.a.b[2]] against [j], or [None] if
44
+
the path is malformed or does not resolve. *)
+18
lib/lexer.mli
+18
lib/lexer.mli
···
1
+
(** ocamllex lexer for SQLite CREATE TABLE statements. *)
2
+
3
+
exception Error of string
4
+
(** Raised on lexer errors (unterminated strings, unexpected input). *)
5
+
6
+
val token : Lexing.lexbuf -> Parser.token
7
+
(** [token lexbuf] returns the next token. *)
8
+
9
+
val parse : string -> (Ast.create_table, string) result
10
+
(** [parse sql] parses a single CREATE TABLE statement. *)
11
+
12
+
val parse_statements : string -> (Ast.stmt list, string) result
13
+
(** [parse_statements sql] parses a [;]-separated sequence of statements. *)
14
+
15
+
val split_statements : string -> string list
16
+
(** [split_statements sql] returns the raw text of each top-level statement,
17
+
trimmed, with empty statements dropped. A [;] inside a string literal is not
18
+
a separator. *)
+300
lib/lexer.mll
+300
lib/lexer.mll
···
1
+
{
2
+
(*---------------------------------------------------------------------------
3
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
4
+
SPDX-License-Identifier: MIT
5
+
6
+
ocamllex lexer for the SQLite SQL subset (CREATE TABLE plus queries).
7
+
8
+
The grammar is ASCII-only at the punctuation / keyword level; quoted
9
+
identifiers and string literals pass through the body bytes verbatim,
10
+
which means UTF-8 content round-trips untouched.
11
+
---------------------------------------------------------------------------*)
12
+
13
+
exception Error of string
14
+
15
+
(* Keyword constructors — all carry the original text for case preservation *)
16
+
let keywords =
17
+
[
18
+
("CREATE", fun s -> Parser.CREATE s);
19
+
("TABLE", fun s -> Parser.TABLE s);
20
+
("RENAME", fun s -> Parser.RENAME s);
21
+
("VIEW", fun s -> Parser.VIEW s);
22
+
("TRIGGER", fun s -> Parser.TRIGGER s);
23
+
("BEFORE", fun s -> Parser.BEFORE s);
24
+
("AFTER", fun s -> Parser.AFTER s);
25
+
("INSTEAD", fun s -> Parser.INSTEAD s);
26
+
("FOR", fun s -> Parser.FOR s);
27
+
("EACH", fun s -> Parser.EACH s);
28
+
("ROW", fun s -> Parser.ROW s);
29
+
("OF", fun s -> Parser.OF s);
30
+
("CROSS", fun s -> Parser.CROSS s);
31
+
("SAVEPOINT", fun s -> Parser.SAVEPOINT s);
32
+
("RELEASE", fun s -> Parser.RELEASE s);
33
+
("TO", fun s -> Parser.TO s);
34
+
("CASCADE", fun s -> Parser.CASCADE s);
35
+
("RESTRICT", fun s -> Parser.RESTRICT s);
36
+
("NO", fun s -> Parser.NO s);
37
+
("ACTION", fun s -> Parser.ACTION s);
38
+
("ALTER", fun s -> Parser.ALTER s);
39
+
("DROP", fun s -> Parser.DROP s);
40
+
("ADD", fun s -> Parser.ADD s);
41
+
("COLUMN", fun s -> Parser.COLUMN s);
42
+
("IF", fun s -> Parser.IF s);
43
+
("NOT", fun s -> Parser.NOT s);
44
+
("EXISTS", fun s -> Parser.EXISTS s);
45
+
("PRIMARY", fun s -> Parser.PRIMARY s);
46
+
("KEY", fun s -> Parser.KEY s);
47
+
("UNIQUE", fun s -> Parser.UNIQUE s);
48
+
("NULL", fun s -> Parser.NULL s);
49
+
("TRUE", fun s -> Parser.TRUE s);
50
+
("FALSE", fun s -> Parser.FALSE s);
51
+
("DEFAULT", fun s -> Parser.DEFAULT s);
52
+
("CHECK", fun s -> Parser.CHECK s);
53
+
("REFERENCES", fun s -> Parser.REFERENCES s);
54
+
("COLLATE", fun s -> Parser.COLLATE s);
55
+
("GENERATED", fun s -> Parser.GENERATED s);
56
+
("ALWAYS", fun s -> Parser.ALWAYS s);
57
+
("AS", fun s -> Parser.AS s);
58
+
("AUTOINCREMENT", fun s -> Parser.AUTOINCREMENT s);
59
+
("FOREIGN", fun s -> Parser.FOREIGN s);
60
+
("CONSTRAINT", fun s -> Parser.CONSTRAINT s);
61
+
("ON", fun s -> Parser.ON s);
62
+
("ASC", fun s -> Parser.ASC s);
63
+
("DESC", fun s -> Parser.DESC s);
64
+
(* Query keywords *)
65
+
("SELECT", fun s -> Parser.SELECT s);
66
+
("DISTINCT", fun s -> Parser.DISTINCT s);
67
+
("FROM", fun s -> Parser.FROM s);
68
+
("WHERE", fun s -> Parser.WHERE s);
69
+
("JOIN", fun s -> Parser.JOIN s);
70
+
("INNER", fun s -> Parser.INNER s);
71
+
("LEFT", fun s -> Parser.LEFT s);
72
+
("OUTER", fun s -> Parser.OUTER s);
73
+
("ORDER", fun s -> Parser.ORDER s);
74
+
("GROUP", fun s -> Parser.GROUP s);
75
+
("HAVING", fun s -> Parser.HAVING s);
76
+
("FILTER", fun s -> Parser.FILTER s);
77
+
("OVER", fun s -> Parser.OVER s);
78
+
("PARTITION", fun s -> Parser.PARTITION s);
79
+
("ROWS", fun s -> Parser.ROWS s);
80
+
("RANGE", fun s -> Parser.RANGE s);
81
+
("PRECEDING", fun s -> Parser.PRECEDING s);
82
+
("FOLLOWING", fun s -> Parser.FOLLOWING s);
83
+
("UNBOUNDED", fun s -> Parser.UNBOUNDED s);
84
+
("CURRENT", fun s -> Parser.CURRENT s);
85
+
("BY", fun s -> Parser.BY s);
86
+
("OFFSET", fun s -> Parser.OFFSET s);
87
+
("RETURNING", fun s -> Parser.RETURNING s);
88
+
("CONFLICT", fun s -> Parser.CONFLICT s);
89
+
("DO", fun s -> Parser.DO s);
90
+
("NOTHING", fun s -> Parser.NOTHING s);
91
+
("CASE", fun s -> Parser.CASE s);
92
+
("WHEN", fun s -> Parser.WHEN s);
93
+
("THEN", fun s -> Parser.THEN s);
94
+
("ELSE", fun s -> Parser.ELSE s);
95
+
("END", fun s -> Parser.END s);
96
+
("WITH", fun s -> Parser.WITH s);
97
+
("RECURSIVE", fun s -> Parser.RECURSIVE s);
98
+
("UNION", fun s -> Parser.UNION s);
99
+
("ALL", fun s -> Parser.ALL s);
100
+
("EXCEPT", fun s -> Parser.EXCEPT s);
101
+
("INTERSECT", fun s -> Parser.INTERSECT s);
102
+
("LIMIT", fun s -> Parser.LIMIT s);
103
+
("AND", fun s -> Parser.AND s);
104
+
("OR", fun s -> Parser.OR s);
105
+
("IN", fun s -> Parser.IN s);
106
+
("IS", fun s -> Parser.IS s);
107
+
("ISNULL", fun s -> Parser.ISNULL s);
108
+
("NOTNULL", fun s -> Parser.NOTNULL s);
109
+
("MATERIALIZED", fun s -> Parser.MATERIALIZED s);
110
+
("WITHOUT", fun s -> Parser.WITHOUT s);
111
+
("LIKE", fun s -> Parser.LIKE s);
112
+
("ESCAPE", fun s -> Parser.ESCAPE s);
113
+
("GLOB", fun s -> Parser.GLOB s);
114
+
("NATURAL", fun s -> Parser.NATURAL s);
115
+
("RIGHT", fun s -> Parser.RIGHT s);
116
+
("FULL", fun s -> Parser.FULL s);
117
+
("USING", fun s -> Parser.USING s);
118
+
("BETWEEN", fun s -> Parser.BETWEEN s);
119
+
("CAST", fun s -> Parser.CAST s);
120
+
(* Write keywords *)
121
+
("INSERT", fun s -> Parser.INSERT s);
122
+
("INTO", fun s -> Parser.INTO s);
123
+
("VALUES", fun s -> Parser.VALUES s);
124
+
("REPLACE", fun s -> Parser.REPLACE s);
125
+
("DELETE", fun s -> Parser.DELETE s);
126
+
("UPDATE", fun s -> Parser.UPDATE s);
127
+
("SET", fun s -> Parser.SET s);
128
+
("INDEX", fun s -> Parser.INDEX s);
129
+
("PRAGMA", fun s -> Parser.PRAGMA s);
130
+
("BEGIN", fun s -> Parser.BEGIN s);
131
+
("COMMIT", fun s -> Parser.COMMIT s);
132
+
("ROLLBACK", fun s -> Parser.ROLLBACK s);
133
+
("TRANSACTION", fun s -> Parser.TRANSACTION s);
134
+
("VACUUM", fun s -> Parser.VACUUM s);
135
+
("ANALYZE", fun s -> Parser.ANALYZE s);
136
+
]
137
+
138
+
let classify s =
139
+
match List.assoc_opt (String.uppercase_ascii s) keywords with
140
+
| Some mk -> mk s
141
+
| None -> Parser.IDENT s
142
+
}
143
+
144
+
let digit = ['0'-'9']
145
+
let alpha = ['a'-'z' 'A'-'Z']
146
+
let ident_start = alpha | '_'
147
+
let ident_char = ident_start | digit
148
+
let ident = ident_start ident_char*
149
+
(* No leading sign: [-] / [+] are operators (unary or binary), so [x+1] and
150
+
[-2.0] lex as operator-then-number, not as a single signed literal. *)
151
+
let number = digit+ ('.' digit+)? (['e' 'E'] ['+' '-']? digit+)?
152
+
let hex_int = '0' ['x' 'X'] ['0'-'9' 'a'-'f' 'A'-'F']+
153
+
let ws = [' ' '\t' '\n' '\r']+
154
+
155
+
rule token = parse
156
+
| ws { token lexbuf }
157
+
| "--" [^ '\n']* { token lexbuf }
158
+
| '(' { Parser.LPAREN }
159
+
| ')' { Parser.RPAREN }
160
+
| ',' { Parser.COMMA }
161
+
| ';' { Parser.SEMI }
162
+
| '.' { Parser.DOT }
163
+
| '*' { Parser.STAR }
164
+
| '+' { Parser.PLUS }
165
+
| '-' { Parser.MINUS }
166
+
| '/' { Parser.SLASH }
167
+
| '%' { Parser.PERCENT }
168
+
| '?' { Parser.QUESTION }
169
+
| "<<" { Parser.SHL }
170
+
| ">>" { Parser.SHR }
171
+
| '&' { Parser.BITAND }
172
+
| "<=" { Parser.LE }
173
+
| ">=" { Parser.GE }
174
+
| "<>" { Parser.NEQ }
175
+
| "!=" { Parser.NEQ }
176
+
| '<' { Parser.LT }
177
+
| '>' { Parser.GT }
178
+
| "==" { Parser.EQ }
179
+
| '=' { Parser.EQ }
180
+
| "||" { Parser.CONCAT }
181
+
| "->>" { Parser.ARROW2 }
182
+
| "->" { Parser.ARROW }
183
+
| '|' { Parser.BITOR }
184
+
(* A blob literal x'48...' / X'48...': hex digit pairs between single quotes,
185
+
adjacent to the leading x (a space would lex x as an identifier). *)
186
+
| ('x' | 'X') '\'' { Parser.BLOB (read_blob (Buffer.create 16) lexbuf) }
187
+
| hex_int as n { Parser.NUMBER n }
188
+
| number as n { Parser.NUMBER n }
189
+
| ident as s { classify s }
190
+
| '"'
191
+
{ Parser.IDENT (read_until '"' "\"" (Buffer.create 32) lexbuf) }
192
+
| '['
193
+
{ Parser.IDENT (read_until ']' "]" (Buffer.create 32) lexbuf) }
194
+
| '`'
195
+
{ Parser.IDENT (read_until '`' "`" (Buffer.create 32) lexbuf) }
196
+
| '\''
197
+
{ Parser.STRING (read_single_quoted (Buffer.create 32) lexbuf) }
198
+
| eof { Parser.EOF }
199
+
| _ as c { Parser.NUMBER (String.make 1 c) }
200
+
201
+
and read_until stop label buf = parse
202
+
| eof
203
+
{ raise (Error ("unterminated " ^ label ^ "-quoted identifier")) }
204
+
| _ as c
205
+
{
206
+
if c = stop then Buffer.contents buf
207
+
else begin
208
+
Buffer.add_char buf c;
209
+
read_until stop label buf lexbuf
210
+
end
211
+
}
212
+
213
+
and read_single_quoted buf = parse
214
+
| "''"
215
+
{
216
+
Buffer.add_char buf '\'';
217
+
read_single_quoted buf lexbuf
218
+
}
219
+
| '\'' { Buffer.contents buf }
220
+
| eof { raise (Error "unterminated string literal") }
221
+
(* Consume a whole run of non-quote bytes in a single engine call rather than
222
+
one character at a time -- the bulk of lexer allocation on literal-heavy
223
+
scripts. *)
224
+
| [^ '\'' ]+ as s
225
+
{
226
+
Buffer.add_string buf s;
227
+
read_single_quoted buf lexbuf
228
+
}
229
+
230
+
(* Read the hex body of a blob literal up to the closing quote, decoding each
231
+
pair of hex digits into a byte. An odd digit count or a non-hex digit is a
232
+
malformed blob, as in sqlite3. *)
233
+
and read_blob buf = parse
234
+
| '\''
235
+
{
236
+
let hex = Buffer.contents buf in
237
+
let n = String.length hex in
238
+
if n mod 2 <> 0 then raise (Error "odd number of digits in blob literal");
239
+
let b = Buffer.create (n / 2) in
240
+
for i = 0 to (n / 2) - 1 do
241
+
Buffer.add_char b
242
+
(Char.chr (int_of_string ("0x" ^ String.sub hex (2 * i) 2)))
243
+
done;
244
+
Buffer.contents b
245
+
}
246
+
| eof { raise (Error "unterminated blob literal") }
247
+
| (['0'-'9' 'a'-'f' 'A'-'F']) as c
248
+
{
249
+
Buffer.add_char buf c;
250
+
read_blob buf lexbuf
251
+
}
252
+
| _ { raise (Error "malformed hex in blob literal") }
253
+
254
+
{
255
+
let parse sql =
256
+
let lexbuf = Lexing.from_string sql in
257
+
try Ok (Parser.create_table token lexbuf) with
258
+
| Parser.Error -> Error "parse error"
259
+
| Error msg -> Error msg
260
+
261
+
let parse_statements sql =
262
+
let lexbuf = Lexing.from_string sql in
263
+
try Ok (Parser.statements token lexbuf) with
264
+
| Parser.Error -> Error "parse error"
265
+
| Error msg -> Error msg
266
+
267
+
let split_statements sql =
268
+
(* Cut [sql] into the raw text of each top-level statement. The lexer reads a
269
+
quoted string as one token, so a [;] inside a literal is never a separator.
270
+
A CREATE TRIGGER body holds its own [;]-separated statements between
271
+
BEGIN and END, so while inside one a [;] is not a separator: track the
272
+
BEGIN/CASE..END nesting (CASE also closes with END) and only treat a [;] as
273
+
a separator once that nesting is back to zero. *)
274
+
let lexbuf = Lexing.from_string sql in
275
+
let rec go start acc ~in_trigger ~depth ~after_create =
276
+
let next = go start acc in
277
+
match token lexbuf with
278
+
| Parser.EOF ->
279
+
let piece = String.sub sql start (String.length sql - start) in
280
+
List.rev (piece :: acc)
281
+
| Parser.TRIGGER _ when after_create ->
282
+
next ~in_trigger:true ~depth ~after_create:false
283
+
| (Parser.BEGIN _ | Parser.CASE _) when in_trigger ->
284
+
next ~in_trigger ~depth:(depth + 1) ~after_create:false
285
+
| Parser.END _ when in_trigger ->
286
+
next ~in_trigger ~depth:(depth - 1) ~after_create:false
287
+
| Parser.SEMI when in_trigger && depth > 0 ->
288
+
next ~in_trigger ~depth ~after_create:false
289
+
| Parser.SEMI ->
290
+
let stop = Lexing.lexeme_start lexbuf in
291
+
let piece = String.sub sql start (stop - start) in
292
+
go (Lexing.lexeme_end lexbuf) (piece :: acc) ~in_trigger:false ~depth:0
293
+
~after_create:false
294
+
| Parser.CREATE _ -> next ~in_trigger ~depth ~after_create:true
295
+
| _ -> next ~in_trigger ~depth ~after_create:false
296
+
in
297
+
go 0 [] ~in_trigger:false ~depth:0 ~after_create:false
298
+
|> List.map String.trim
299
+
|> List.filter (fun s -> s <> "")
300
+
}
+727
lib/lower.ml
+727
lib/lower.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2026 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
module Ir = Catalog.Ir
7
+
module V = Catalog.Value
8
+
9
+
let unsupported () = raise Ir.Unsupported
10
+
11
+
(* The correlated subqueries found while lowering a select, in id order. [expr]
12
+
registers each scalar / [EXISTS] / [IN (SELECT)] here as it emits the matching
13
+
[Ir.Subquery] node, and [query] reads the table back so the caller can wire a
14
+
runner (the engine has no SQL; it calls the injected runner by id). A
15
+
reset-per-[query] accumulator is safe: lowering does not recurse into a
16
+
subquery's body (it keeps the [Ast.select] for the runner), and lowering
17
+
finishes -- the [query] result captures this list -- before the engine runs
18
+
and fires any nested subquery lowering. [allow] is cleared while lowering an
19
+
aggregate select, where the grouped path has no runner, so a subquery there
20
+
falls back. *)
21
+
type subkind = Scalar | Exists | In
22
+
23
+
let sub_acc : (subkind * Ast.select) list ref = ref []
24
+
let sub_count = ref 0
25
+
let sub_allow = ref true
26
+
27
+
let register_sub kind sub =
28
+
if not !sub_allow then unsupported ();
29
+
let id = !sub_count in
30
+
sub_acc := (kind, sub) :: !sub_acc;
31
+
incr sub_count;
32
+
id
33
+
34
+
(* Compare two values under a named collation -- the tree-walker's own collated
35
+
comparison, for an [ORDER BY] key that carries a [COLLATE]. *)
36
+
let collate = Value_ops.compare_values_coll
37
+
38
+
(* The IR's value layer is the tree-walker's own functions, called directly: the
39
+
frontend and the engine share {!Catalog.Value.t}, so no value conversion sits
40
+
between them and a compiled query agrees with an interpreted one by sharing
41
+
the code. Only the operator enums differ, mapped by {!ast_cmp}/{!ast_logic}. *)
42
+
let ast_cmp : Ir.binop -> Ast.binop = function
43
+
| Eq -> Eq
44
+
| Ne -> Neq
45
+
| Lt -> Lt
46
+
| Le -> Le
47
+
| Gt -> Gt
48
+
| Ge -> Ge
49
+
| _ -> assert false
50
+
51
+
let ast_logic : Ir.logicop -> Ast.binop = function
52
+
| And -> And
53
+
| Or -> Or
54
+
| Like -> Like
55
+
| Glob -> Glob
56
+
| Concat -> Concat
57
+
| Json_get -> Json_get
58
+
| Json_get_text -> Json_get_text
59
+
60
+
let builtins : Ir.builtins =
61
+
{
62
+
call = Func.apply;
63
+
compare =
64
+
(fun op coll a_col b_col va vb ->
65
+
Value_op.compare_with_affinity ?coll ~a_col ~b_col (ast_cmp op) va vb);
66
+
logic = (fun op va vb -> Value_op.binop_value (ast_logic op) va vb);
67
+
not_ = Value_ops.not_value;
68
+
is_eq = Value_ops.is_value;
69
+
in_list =
70
+
(fun coll e_col v cands -> Value_op.in_list_value ?coll ~e_col v cands);
71
+
cast = Value_ops.cast;
72
+
subquery = (fun _ _ _ -> unsupported ());
73
+
}
74
+
75
+
type layout = (string * string list) list
76
+
77
+
(* The comparison, opcode-free, and arithmetic operator groups of [Ast.binop]. *)
78
+
let is_cmp : Ast.binop -> bool = function
79
+
| Eq | Neq | Lt | Le | Gt | Ge -> true
80
+
| _ -> false
81
+
82
+
let is_logic : Ast.binop -> bool = function
83
+
| And | Or | Like | Glob | Concat | Json_get | Json_get_text -> true
84
+
| _ -> false
85
+
86
+
let ir_cmp : Ast.binop -> Ir.binop = function
87
+
| Eq -> Eq
88
+
| Neq -> Ne
89
+
| Lt -> Lt
90
+
| Le -> Le
91
+
| Gt -> Gt
92
+
| Ge -> Ge
93
+
| _ -> unsupported ()
94
+
95
+
let ir_logic : Ast.binop -> Ir.logicop = function
96
+
| And -> And
97
+
| Or -> Or
98
+
| Like -> Like
99
+
| Glob -> Glob
100
+
| Concat -> Concat
101
+
| Json_get -> Json_get
102
+
| Json_get_text -> Json_get_text
103
+
| _ -> unsupported ()
104
+
105
+
let ir_arith : Ast.binop -> Ir.binop = function
106
+
| Add -> Add
107
+
| Sub -> Sub
108
+
| Mul -> Mul
109
+
| Div -> Div
110
+
| Mod -> Mod
111
+
| Bit_and -> Band
112
+
| Bit_or -> Bor
113
+
| Shl -> Shl
114
+
| Shr -> Shr
115
+
| _ -> unsupported ()
116
+
117
+
(* The position of the column named [name] in [cols] (case-insensitive). *)
118
+
let col_index name cols =
119
+
let uname = String.uppercase_ascii name in
120
+
let rec go j = function
121
+
| c :: _ when String.uppercase_ascii c = uname -> Some j
122
+
| _ :: t -> go (j + 1) t
123
+
| [] -> None
124
+
in
125
+
go 0 cols
126
+
127
+
(* Resolve [alias.name] (or a bare [name]) to its [(cursor, column)] position: a
128
+
qualified name picks the source with that alias, a bare name takes the first
129
+
source that has it. *)
130
+
let resolve_col (layout : layout) alias name =
131
+
match alias with
132
+
| Some a ->
133
+
let ua = String.uppercase_ascii a in
134
+
let rec go ci = function
135
+
| (al, cols) :: t ->
136
+
if String.uppercase_ascii al = ua then
137
+
match col_index name cols with
138
+
| Some j -> (ci, j)
139
+
| None -> unsupported ()
140
+
else go (ci + 1) t
141
+
| [] -> unsupported ()
142
+
in
143
+
go 0 layout
144
+
| None ->
145
+
let rec go ci = function
146
+
| (_, cols) :: t -> (
147
+
match col_index name cols with
148
+
| Some j -> (ci, j)
149
+
| None -> go (ci + 1) t)
150
+
| [] -> unsupported ()
151
+
in
152
+
go 0 layout
153
+
154
+
(* A comparison's collation -- sqlite3's left-operand rule, made explicit by
155
+
[Query.resolve_collations] as a [Collate] wrapper on an operand -- and the bare
156
+
operand under it. [is_col_ast] treats a [Collate] wrapper as not a column, so a
157
+
collated comparison carries no affinity on that side, matching the tree-walker. *)
158
+
let is_col_ast = function Ast.Col _ -> true | _ -> false
159
+
let collation_of = function Ast.Collate (_, c) -> Some c | _ -> None
160
+
161
+
let comparison_collation a b =
162
+
match collation_of a with Some _ as c -> c | None -> collation_of b
163
+
164
+
(* The collation an operand carries for membership/comparison, the default
165
+
[BINARY] (unary plus, which only strips affinity) carrying none. *)
166
+
let nonbinary_collation e =
167
+
match collation_of e with Some c when c <> "BINARY" -> Some c | _ -> None
168
+
169
+
let strip_collate = function Ast.Collate (e, _) -> e | e -> e
170
+
171
+
let rec expr (layout : layout) (e : Ast.expr) : Ir.expr =
172
+
match e with
173
+
| Lit v -> Lit v
174
+
| Param i -> Param i
175
+
| Col (alias, name) ->
176
+
let c, j = resolve_col layout alias name in
177
+
Col (c, j)
178
+
| Unop_not e -> Not (expr layout e)
179
+
| Binary (op, a, b) ->
180
+
if is_cmp op then cmp_expr layout op a b
181
+
else if is_logic op then Logic (ir_logic op, expr layout a, expr layout b)
182
+
else Arith (ir_arith op, expr layout a, expr layout b)
183
+
| Is_null e -> Null_value (true, expr layout e)
184
+
| Is_not_null e -> Null_value (false, expr layout e)
185
+
| Is (a, b) -> Is (expr layout a, expr layout b)
186
+
| In_list (e, cands) ->
187
+
In
188
+
( expr layout (strip_collate e),
189
+
nonbinary_collation e,
190
+
is_col_ast e,
191
+
List.map (expr layout) cands )
192
+
(* [iif(c, t, f)] short-circuits, so it is the searched [CASE WHEN c THEN t ELSE
193
+
f] -- lower it as one rather than an eager function call. An aggregate
194
+
reaching [expr] is in a WHERE/ON/ORDER BY/scan position (a select-list
195
+
aggregate makes the query aggregate, lowered elsewhere) -- always an error,
196
+
raised here so the engine reports it without deferring to the tree-walker. *)
197
+
| Func ("iif", [ c; t; f ]) -> expr layout (Case (None, [ (c, t) ], Some f))
198
+
| Func (name, args) when not (Query.is_agg name args) ->
199
+
Func (name, List.map (expr layout) args)
200
+
| Func (name, _) ->
201
+
Fmt.failwith
202
+
"%s() is an aggregate function and is only valid as a select item, not \
203
+
in WHERE, ON, or ORDER BY"
204
+
name
205
+
| Case (base, branches, els) ->
206
+
let branch (c, r) =
207
+
let p =
208
+
match base with
209
+
| None -> predicate layout c
210
+
| Some b -> Compare (Eq, expr layout b, expr layout c)
211
+
in
212
+
(p, expr layout r)
213
+
in
214
+
Case (List.map branch branches, Option.map (expr layout) els)
215
+
| Cast (e, ty) -> Cast (expr layout e, ty)
216
+
(* A correlated subquery becomes an opaque [Subquery] node: register the
217
+
[Ast.select] and its kind, and (for [IN]) lower the left operand whose value
218
+
the membership test reads. An uncorrelated one is already folded to a
219
+
constant before lowering ([Query.hoist_subqueries]), so what reaches here is
220
+
correlated, run per outer row by the injected runner. *)
221
+
| Scalar_select sub -> Subquery (register_sub Scalar sub, None)
222
+
| Exists sub -> Subquery (register_sub Exists sub, None)
223
+
| In_select (e, sub) -> Subquery (register_sub In sub, Some (expr layout e))
224
+
| Star | Qualified_star _ | Distinct_agg _ | Filter _ | Ordered_agg _
225
+
| Window _ | Collate _ ->
226
+
unsupported ()
227
+
228
+
(* Lower a [WHERE]/[ON]/[HAVING] expression to a filter predicate: an [AND]/[OR]
229
+
of comparisons, null tests, and bare truthy expressions. *)
230
+
and predicate (layout : layout) (e : Ast.expr) : Ir.predicate =
231
+
match e with
232
+
| Binary (And, a, b) -> And (predicate layout a, predicate layout b)
233
+
| Binary (Or, a, b) -> Or (predicate layout a, predicate layout b)
234
+
| Binary (op, a, b) when is_cmp op -> cmp_pred layout op a b
235
+
| Is_null e -> Null_test (true, expr layout e)
236
+
| Is_not_null e -> Null_test (false, expr layout e)
237
+
(* a bare [WHERE expr] keeps the truthy rows; [expr] itself rejects a shape the
238
+
IR cannot model (a subquery, a window), falling the whole predicate back *)
239
+
| e -> Truthy (expr layout e)
240
+
241
+
(* Lower a comparison. A [COLLATE]-wrapped operand -- a declared collation, or a
242
+
[BINARY] one (which is unary plus, stripping affinity) -- routes through the
243
+
value-level {!Ir.Cmp_coll}: the binary VM compare cannot honour a non-binary
244
+
collation, and stripping the wrapper for the plain path would let the IR
245
+
re-derive affinity from the bare column the wrapper suppressed. The explicit
246
+
affinity flags read the original operands ([is_col_ast] of a wrapper is
247
+
[false]), matching the tree-walker; an unwrapped comparison takes the binary
248
+
value comparison / filter jump. *)
249
+
and cmp_expr layout op a b : Ir.expr =
250
+
let a' = expr layout (strip_collate a)
251
+
and b' = expr layout (strip_collate b) in
252
+
match comparison_collation a b with
253
+
| Some c -> Cmp_coll (ir_cmp op, c, is_col_ast a, is_col_ast b, a', b')
254
+
| None -> Cmp (ir_cmp op, a', b')
255
+
256
+
and cmp_pred layout op a b : Ir.predicate =
257
+
let a' = expr layout (strip_collate a)
258
+
and b' = expr layout (strip_collate b) in
259
+
match comparison_collation a b with
260
+
| Some c ->
261
+
Truthy (Cmp_coll (ir_cmp op, c, is_col_ast a, is_col_ast b, a', b'))
262
+
| None -> Compare (ir_cmp op, a', b')
263
+
264
+
let ir_dir = function Ast.Asc -> Ir.Asc | Ast.Desc -> Ir.Desc
265
+
266
+
(* An [ORDER BY] key's explicit collation, if any -- a [BINARY] wrapper is the
267
+
default, so it carries no collation. *)
268
+
let order_collation e =
269
+
match collation_of e with Some c when c <> "BINARY" -> Some c | _ -> None
270
+
271
+
(* Lower an [ORDER BY] key with [lower_key] (over the scan, or the synthetic
272
+
group row): its expression, direction, and collation. *)
273
+
let order_key lower_key (e, d) =
274
+
(lower_key (strip_collate e), ir_dir d, order_collation e)
275
+
276
+
(* The per-output-column collations a DISTINCT dedups under (one per result
277
+
column; [[]] when not DISTINCT, so the engine dedups by binary value). *)
278
+
let distinct_collations (s : Ast.select) =
279
+
if s.distinct then
280
+
List.map (fun (rc : Ast.result_col) -> order_collation rc.expr) s.cols
281
+
else []
282
+
283
+
(* Expand a select item into its projected expressions: [*] and [t.*] become one
284
+
column reference per source column. *)
285
+
let project_item (layout : layout) (rc : Ast.result_col) : Ir.expr list =
286
+
match rc.expr with
287
+
| Star ->
288
+
List.concat
289
+
(List.mapi
290
+
(fun ci (_, cols) -> List.mapi (fun j _ -> Ir.Col (ci, j)) cols)
291
+
layout)
292
+
| Qualified_star q ->
293
+
let uq = String.uppercase_ascii q in
294
+
let rec go ci = function
295
+
| (al, cols) :: t ->
296
+
if String.uppercase_ascii al = uq then
297
+
List.mapi (fun j _ -> Ir.Col (ci, j)) cols
298
+
else go (ci + 1) t
299
+
| [] -> unsupported ()
300
+
in
301
+
go 0 layout
302
+
(* A projected [COLLATE] (or unary plus) produces the bare value -- the
303
+
collation governs only comparison/ordering/dedup, captured separately in the
304
+
query's ORDER BY keys and [distinct_colls]. *)
305
+
| e -> [ expr layout (strip_collate e) ]
306
+
307
+
(* The [int64] value of a literal / bound-parameter [LIMIT]/[OFFSET] expression,
308
+
or [None] for any other shape (a column, an expression) -- which falls back. *)
309
+
let lit_int64 params (e : Ast.expr) =
310
+
match e with
311
+
| Ast.Lit (Ast.Int n) -> Some n
312
+
| Param i when i >= 0 && i < Array.length params -> (
313
+
match params.(i) with Ast.Int n -> Some n | _ -> None)
314
+
| _ -> None
315
+
316
+
(* A non-negative row count clamped to a native int: a value beyond the native
317
+
range exceeds any materialised row count, so [max_int] is exact (keep all for a
318
+
limit, skip all for an offset) without truncating to a wrong small number. *)
319
+
let clamp_count n =
320
+
if Int64.compare n (Int64.of_int max_int) >= 0 then max_int
321
+
else Int64.to_int n
322
+
323
+
(* The [ON] of an inner join, folded into the filter; an outer/natural/using join
324
+
falls back. *)
325
+
let join_on (j : Ast.join) =
326
+
if j.type_ <> Inner || j.natural || j.using <> [] then unsupported ();
327
+
j.on
328
+
329
+
(* The scan filter: the [WHERE] conjoined with every inner-join [ON]. *)
330
+
let filter_of (layout : layout) (s : Ast.select) =
331
+
let fexprs =
332
+
(match s.where with Some w -> [ w ] | None -> [])
333
+
@ List.map join_on s.joins
334
+
in
335
+
match fexprs with
336
+
| [] -> Ir.Always
337
+
| e :: rest ->
338
+
List.fold_left
339
+
(fun acc e -> Ir.And (acc, predicate layout e))
340
+
(predicate layout e) rest
341
+
342
+
(* A negative LIMIT is unbounded ([None]); a huge one clamps to [max_int] (every
343
+
row kept); a non-literal one falls back (sqlite3). *)
344
+
let limit_of params (s : Ast.select) =
345
+
match s.limit with
346
+
| None -> None
347
+
| Some e -> (
348
+
match lit_int64 params e with
349
+
| None -> unsupported ()
350
+
| Some n when n < 0L -> None
351
+
| Some n -> Some (clamp_count n))
352
+
353
+
(* A negative OFFSET is zero; a huge one clamps to [max_int] (every row skipped);
354
+
a non-literal one falls back (sqlite3). *)
355
+
let offset_of params (s : Ast.select) =
356
+
match s.offset with
357
+
| None -> 0
358
+
| Some e -> (
359
+
match lit_int64 params e with
360
+
| None -> unsupported ()
361
+
| Some n when n < 0L -> 0
362
+
| Some n -> clamp_count n)
363
+
364
+
(* A single trailing [LEFT JOIN] (one [FROM] table, one left-joined table, no
365
+
[NATURAL]/[USING]): its [ON] predicate, the [WHERE] kept separate from it so
366
+
the engine can null-fill. Any other join shape returns [None], so the inner
367
+
path folds every [ON] into one filter. *)
368
+
let left_join (layout : layout) (s : Ast.select) =
369
+
match s.joins with
370
+
| [ j ] when j.type_ = Left && (not j.natural) && j.using = [] ->
371
+
let where =
372
+
match s.where with Some w -> predicate layout w | None -> Ir.Always
373
+
in
374
+
Some (predicate layout j.on, where)
375
+
| _ -> None
376
+
377
+
let query ?(params = [||]) (layout : layout) (s : Ast.select) :
378
+
Ir.query * (subkind * Ast.select) list =
379
+
if s.group_by <> [] || s.having <> None || s.compound <> [] then
380
+
unsupported ();
381
+
sub_acc := [];
382
+
sub_count := 0;
383
+
sub_allow := true;
384
+
let arities = List.map (fun (_, cols) -> List.length cols) layout in
385
+
let left, filter =
386
+
match left_join layout s with
387
+
| Some (on, where) -> (Some on, where)
388
+
| None -> (None, filter_of layout s)
389
+
in
390
+
let project = List.concat_map (project_item layout) s.cols in
391
+
let select = { Ir.arities; left; filter; project } in
392
+
let order_by = List.map (order_key (expr layout)) s.order_by in
393
+
let q =
394
+
{
395
+
Ir.select;
396
+
order_by;
397
+
distinct = s.distinct;
398
+
distinct_colls = distinct_collations s;
399
+
limit = limit_of params s;
400
+
offset = offset_of params s;
401
+
}
402
+
in
403
+
(q, List.rev !sub_acc)
404
+
405
+
(* The aggregates {!agg_fold} folds: a star [count], the numeric aggregates, and
406
+
the string aggregate (group_concat / string_agg). A FILTER / ORDER-BY
407
+
aggregate and a window are not here, so they fall back to the tree-walker. *)
408
+
let numeric_aggs = [ "count"; "sum"; "min"; "max"; "avg"; "total" ]
409
+
let string_aggs = [ "group_concat"; "string_agg" ]
410
+
411
+
(* A plain aggregate call: a star [count], a numeric aggregate of an argument, or
412
+
a string aggregate ([group_concat]/[string_agg], with an optional separator
413
+
argument), optionally [DISTINCT] -- its name, distinctness, and argument
414
+
expressions ([] for a star count). [None] for anything else. *)
415
+
let core_aggregate : Ast.expr -> (string * bool * Ast.expr list) option =
416
+
function
417
+
| Func ("count", [ Star ]) -> Some ("count", false, [])
418
+
| Func (name, args)
419
+
when (List.mem name numeric_aggs || List.mem name string_aggs)
420
+
&& Query.is_agg name args ->
421
+
Some (name, false, args)
422
+
| Distinct_agg (name, arg)
423
+
when List.mem name numeric_aggs || List.mem name string_aggs ->
424
+
Some (name, true, [ arg ])
425
+
| _ -> None
426
+
427
+
(* A plain aggregate call, peeling any [FILTER (WHERE p)] and [ORDER BY] around
428
+
the core call: its name, distinctness, arguments, optional FILTER predicate,
429
+
and ORDER BY keys. [None] for anything that is not an aggregate. *)
430
+
let as_aggregate e =
431
+
let rec peel filter order = function
432
+
| Ast.Filter (inner, p) -> peel (Some p) order inner
433
+
| Ast.Ordered_agg (inner, ob) -> peel filter ob inner
434
+
| core -> (
435
+
match core_aggregate core with
436
+
| Some (name, distinct, args) ->
437
+
Some (name, distinct, args, filter, order)
438
+
| None -> None)
439
+
in
440
+
peel None [] e
441
+
442
+
(* The value-level aggregate fold injected into {!Catalog.Ir.run_grouped}: one
443
+
{!Catalog.Value.t} list per group row (empty for a star [count]; each
444
+
argument's value otherwise), already deduped under [DISTINCT]. [count] counts
445
+
rows (star) or non-NULL first arguments; [group_concat]/[string_agg] join the
446
+
non-NULL first arguments by the separator (the second argument, default ",");
447
+
the rest fold the non-NULL first arguments through {!Value_ops.numeric_agg} -- the
448
+
same folds the tree-walker uses. *)
449
+
let agg_fold name _distinct (rows : V.t list list) : V.t =
450
+
let first_args =
451
+
List.filter_map
452
+
(function v :: _ when v <> V.Null -> Some v | _ -> None)
453
+
rows
454
+
in
455
+
match rows with
456
+
| r :: _ when r = [] -> Int (Int64.of_int (List.length rows))
457
+
| _ when List.mem name string_aggs -> (
458
+
match first_args with
459
+
| [] -> Null
460
+
| vs ->
461
+
let sep =
462
+
match rows with
463
+
| (_ :: s :: _) :: _ -> Value_ops.text_of_value s
464
+
| _ -> ","
465
+
in
466
+
Text (String.concat sep (List.map Value_ops.text_of_value vs)))
467
+
| _ when name = "count" -> Int (Int64.of_int (List.length first_args))
468
+
| _ -> Value_ops.numeric_agg name first_args
469
+
470
+
(* Map an output expression over the synthetic per-group row, whose columns are
471
+
the group keys ([0..nkeys-1]) then the aggregate results. A group key or an
472
+
aggregate becomes a column reference; a literal or parameter stays itself; a
473
+
compound expression (arithmetic, a comparison, a scalar function, CAST)
474
+
recurses on its operands, so an aggregate expression like [count() + 1] or a
475
+
scalar function of a key is computed over the group row. Anything else (a bare
476
+
non-key column, a window) falls back. [collect] registers an aggregate and
477
+
returns its slot. *)
478
+
let rec out_operand ~nkeys ~ncols ~key_index ~collect ~resolve_bare
479
+
(e : Ast.expr) : Ir.expr =
480
+
let recur = out_operand ~nkeys ~ncols ~key_index ~collect ~resolve_bare in
481
+
match key_index e with
482
+
| Some i -> Col (0, i)
483
+
| None -> (
484
+
match as_aggregate e with
485
+
(* the synthetic row is [keys, representative columns, aggregate results],
486
+
so an aggregate sits past the [ncols] representative columns *)
487
+
| Some info -> Col (0, nkeys + ncols + collect e info)
488
+
| None -> (
489
+
match e with
490
+
| Lit v -> Lit v
491
+
| Param i -> Param i
492
+
| Unop_not e -> Not (recur e)
493
+
| Binary (op, a, b) ->
494
+
if is_cmp op then Cmp (ir_cmp op, recur a, recur b)
495
+
else if is_logic op then Logic (ir_logic op, recur a, recur b)
496
+
else Arith (ir_arith op, recur a, recur b)
497
+
| Is_null e -> Null_value (true, recur e)
498
+
| Is_not_null e -> Null_value (false, recur e)
499
+
| Is (a, b) -> Is (recur a, recur b)
500
+
| In_list (e, cands) ->
501
+
In
502
+
( recur (strip_collate e),
503
+
nonbinary_collation e,
504
+
is_col_ast e,
505
+
List.map recur cands )
506
+
| Func (name, args) when name <> "iif" && not (Query.is_agg name args)
507
+
->
508
+
Func (name, List.map recur args)
509
+
| Cast (e, ty) -> Cast (recur e, ty)
510
+
(* a bare (non-key) column reads from the group's representative row *)
511
+
| Col _ -> resolve_bare e
512
+
| _ -> unsupported ()))
513
+
514
+
let rec out_pred ~op_of (e : Ast.expr) : Ir.predicate =
515
+
match e with
516
+
| Binary (And, a, b) -> And (out_pred ~op_of a, out_pred ~op_of b)
517
+
| Binary (Or, a, b) -> Or (out_pred ~op_of a, out_pred ~op_of b)
518
+
| Binary (op, a, b) when is_cmp op -> Compare (ir_cmp op, op_of a, op_of b)
519
+
| Is_null e -> Null_test (true, op_of e)
520
+
| Is_not_null e -> Null_test (false, op_of e)
521
+
| _ -> unsupported ()
522
+
523
+
(* The position of [e] among the group keys (by structural expression, ignoring a
524
+
[COLLATE] wrapper on either side: [GROUP BY a COLLATE NOCASE] groups by [a], so
525
+
a projected bare [a] is that key). *)
526
+
let key_index keys e =
527
+
let e = strip_collate e in
528
+
let rec go i = function
529
+
| k :: _ when strip_collate k = e -> Some i
530
+
| _ :: t -> go (i + 1) t
531
+
| [] -> None
532
+
in
533
+
go 0 keys
534
+
535
+
(* Whether [s]'s output (select list, HAVING, ORDER BY) reads a bare (non-key,
536
+
non-aggregate) column or a [*] -- the cases that need a representative group
537
+
row materialised. A column matching a group key (ignoring a [COLLATE] wrapper)
538
+
or sitting inside an aggregate does not. *)
539
+
let references_bare_or_star keys (s : Ast.select) =
540
+
let is_key e = key_index keys e <> None in
541
+
let rec bare (e : Ast.expr) =
542
+
if is_key e then false
543
+
else if as_aggregate e <> None then false
544
+
else
545
+
match e with
546
+
| Star | Qualified_star _ | Col _ -> true
547
+
| Lit _ | Param _ -> false
548
+
| Unop_not e
549
+
| Is_null e
550
+
| Is_not_null e
551
+
| Cast (e, _)
552
+
| Collate (e, _)
553
+
| Distinct_agg (_, e) ->
554
+
bare e
555
+
| Binary (_, a, b) | Is (a, b) | Filter (a, b) -> bare a || bare b
556
+
| In_list (e, l) -> bare e || List.exists bare l
557
+
| Func (_, args) -> List.exists bare args
558
+
| Ordered_agg (a, ob) -> bare a || List.exists (fun (e, _) -> bare e) ob
559
+
| Case (base, brs, els) ->
560
+
Option.fold ~none:false ~some:bare base
561
+
|| List.exists (fun (c, x) -> bare c || bare x) brs
562
+
|| Option.fold ~none:false ~some:bare els
563
+
| Window _ | In_select _ | Scalar_select _ | Exists _ -> false
564
+
in
565
+
List.exists (fun (rc : Ast.result_col) -> bare rc.expr) s.cols
566
+
|| (match s.having with Some h -> bare h | None -> false)
567
+
|| List.exists (fun (e, _) -> bare e) s.order_by
568
+
569
+
let column_bases arities =
570
+
let a = Array.of_list arities in
571
+
let b = Array.make (Array.length a) 0 in
572
+
for c = 1 to Array.length a - 1 do
573
+
b.(c) <- b.(c - 1) + a.(c - 1)
574
+
done;
575
+
b
576
+
577
+
let representative_shape layout keys s =
578
+
let arities = List.map (fun (_, cols) -> List.length cols) layout in
579
+
let bases = column_bases arities in
580
+
let needs_rep = references_bare_or_star keys s in
581
+
let ncols = if needs_rep then List.fold_left ( + ) 0 arities else 0 in
582
+
(arities, bases, needs_rep, ncols)
583
+
584
+
let representative_choice layout needs_rep (s : Ast.select) =
585
+
if not needs_rep then None
586
+
else
587
+
List.find_map
588
+
(fun (rc : Ast.result_col) ->
589
+
match rc.expr with
590
+
| Func ("min", [ a ]) -> Some (false, expr layout a)
591
+
| Func ("max", [ a ]) -> Some (true, expr layout a)
592
+
| _ -> None)
593
+
s.cols
594
+
595
+
let bare_resolver layout ~nkeys ~bases = function
596
+
| Ast.Col (alias, name) ->
597
+
let c, j = resolve_col layout alias name in
598
+
Ir.Col (0, nkeys + bases.(c) + j)
599
+
| _ -> unsupported ()
600
+
601
+
let aggregate_collector layout =
602
+
let aggs = ref [] and nagg = ref 0 in
603
+
let collect e info =
604
+
let rec go i = function
605
+
| (e', _) :: _ when e' = e -> Some i
606
+
| _ :: t -> go (i + 1) t
607
+
| [] -> None
608
+
in
609
+
match go 0 (List.rev !aggs) with
610
+
| Some i -> i
611
+
| None ->
612
+
let name, distinct, args, filter, order = info in
613
+
let agg =
614
+
{
615
+
Ir.name;
616
+
distinct;
617
+
args = List.map (expr layout) args;
618
+
filter = Option.map (expr layout) filter;
619
+
order = List.map (fun (e, d) -> (expr layout e, ir_dir d)) order;
620
+
}
621
+
in
622
+
aggs := (e, agg) :: !aggs;
623
+
let slot = !nagg in
624
+
incr nagg;
625
+
slot
626
+
in
627
+
(collect, (fun () -> !nagg), fun () -> List.rev_map snd !aggs)
628
+
629
+
let aggregate_star_cols layout ~nkeys ~bases qopt =
630
+
List.concat
631
+
(List.mapi
632
+
(fun c (al, cols) ->
633
+
match qopt with
634
+
| Some q when String.uppercase_ascii q <> String.uppercase_ascii al ->
635
+
[]
636
+
| _ -> List.mapi (fun j _ -> Ir.Col (0, nkeys + bases.(c) + j)) cols)
637
+
layout)
638
+
639
+
let aggregate_project layout ~nkeys ~bases op (s : Ast.select) =
640
+
let star_cols = aggregate_star_cols layout ~nkeys ~bases in
641
+
List.concat_map
642
+
(fun (rc : Ast.result_col) ->
643
+
match rc.expr with
644
+
| Star -> star_cols None
645
+
| Qualified_star q ->
646
+
if
647
+
List.exists
648
+
(fun (al, _) ->
649
+
String.uppercase_ascii al = String.uppercase_ascii q)
650
+
layout
651
+
then star_cols (Some q)
652
+
else unsupported ()
653
+
| e -> [ op e ])
654
+
s.cols
655
+
656
+
let aggregate_output ?(params = [||]) ~nkeys ~ncols ~nagg op project
657
+
(s : Ast.select) =
658
+
(* HAVING and ORDER BY register their aggregates through [op] too, so [nagg]
659
+
(the live count) is read only after both are lowered -- an aggregate that
660
+
appears solely in HAVING / ORDER BY still gets a synthetic-row slot. *)
661
+
let filter =
662
+
match s.having with Some h -> out_pred ~op_of:op h | None -> Always
663
+
in
664
+
let order_by = List.map (order_key op) s.order_by in
665
+
let arities = [ nkeys + ncols + nagg () ] in
666
+
{
667
+
Ir.select = { arities; left = None; filter; project };
668
+
order_by;
669
+
distinct = s.distinct;
670
+
distinct_colls = distinct_collations s;
671
+
limit = limit_of params s;
672
+
offset = offset_of params s;
673
+
}
674
+
675
+
let aggregate_scan layout keys (s : Ast.select) =
676
+
let left, filter =
677
+
match left_join layout s with
678
+
| Some (on, where) -> (Some on, where)
679
+
| None -> (None, filter_of layout s)
680
+
in
681
+
(left, filter, List.map (fun e -> expr layout (strip_collate e)) keys)
682
+
683
+
let aggregate_query ?(params = [||]) (layout : layout) (s : Ast.select) :
684
+
Ir.grouped * (subkind * Ast.select) list =
685
+
if s.compound <> [] then unsupported ();
686
+
(* a correlated scalar / EXISTS / IN subquery in the scan filter (WHERE / ON)
687
+
registers here, for the caller to wire a runner -- the per-source-row scope
688
+
the engine passes matches what the grouped scan sees *)
689
+
sub_acc := [];
690
+
sub_count := 0;
691
+
sub_allow := true;
692
+
let keys = s.group_by in
693
+
let nkeys = List.length keys in
694
+
let key_index = key_index keys in
695
+
let arities, bases, needs_rep, ncols = representative_shape layout keys s in
696
+
(* sqlite3's companion rule: a bare column takes its value from the row holding
697
+
a lone min/max in the select list (else an arbitrary, here the first, row) *)
698
+
let rep = representative_choice layout needs_rep s in
699
+
let resolve_bare = bare_resolver layout ~nkeys ~bases in
700
+
(* aggregates in first-seen order, structurally deduped so a repeated aggregate
701
+
shares one slot *)
702
+
let collect, nagg, aggs = aggregate_collector layout in
703
+
let op = out_operand ~nkeys ~ncols ~key_index ~collect ~resolve_bare in
704
+
(* [*] (or [t.*]) expands to the representative row's scanned columns, of the
705
+
matching cursor for a qualified star; an unmatched qualified star falls back
706
+
so the tree-walker reports "no such table". *)
707
+
(* project / HAVING / ORDER BY all register their aggregates through [op] *)
708
+
let project = aggregate_project layout ~nkeys ~bases op s in
709
+
let output = aggregate_output ~params ~nkeys ~ncols ~nagg op project s in
710
+
(* A single trailing LEFT JOIN null-fills before grouping; its [ON] is the
711
+
[left] predicate, the [WHERE] the scan filter. Otherwise every [ON] folds
712
+
into the filter, as for an inner join. *)
713
+
let left, filter, group_by = aggregate_scan layout keys s in
714
+
let g =
715
+
{
716
+
Ir.arities;
717
+
left;
718
+
filter;
719
+
group_by;
720
+
group_colls = List.map order_collation keys;
721
+
ncols;
722
+
rep;
723
+
aggs = aggs ();
724
+
output;
725
+
}
726
+
in
727
+
(g, List.rev !sub_acc)
+75
lib/lower.mli
+75
lib/lower.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2026 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Lower a resolved SQL {!Ast} to the backend-agnostic {!Catalog.Ir}.
7
+
8
+
This is the SQL frontend's half of the engine migration: it resolves every
9
+
column reference to a positional [(cursor, column)] index against the
10
+
scanned sources, turns every literal into a {!Catalog.Value.t}, and maps the
11
+
AST's operators onto the IR's, so {!Catalog.Ir} can compile and run the
12
+
query over any backend cursor. A node the IR does not model raises
13
+
{!Catalog.Ir.Unsupported}, so the caller falls back to the tree-walker. *)
14
+
15
+
val collate : string -> Catalog.Value.t -> Catalog.Value.t -> int
16
+
(** [collate name a b] compares two values under the named collation -- the
17
+
tree-walker's own collated comparison, to inject into {!Catalog.Ir.run} for
18
+
a collated [ORDER BY] key. *)
19
+
20
+
val builtins : Catalog.Ir.builtins
21
+
(** The IR's injected value layer, wired directly to the shared value semantics
22
+
({!Query.func}, {!Query.compare_with_affinity}, {!Query.binop_value},
23
+
{!Value_ops.not_value}, {!Value_ops.is_value}, {!Query.in_list_value}), so a
24
+
compiled query and an interpreted one agree on a shared {!Catalog.Value.t}.
25
+
*)
26
+
27
+
type layout = (string * string list) list
28
+
(** The scanned sources in nested-loop order: each [(alias, column names)], the
29
+
[FROM] table then every inner-joined table. A column resolves to the cursor
30
+
index of its source and the position of its name within that source. *)
31
+
32
+
val agg_fold : string -> bool -> Catalog.Value.t list list -> Catalog.Value.t
33
+
(** The value-level aggregate fold injected into {!Catalog.Ir.run_grouped}:
34
+
[count] counts rows (a star [count], whose tuples are empty) or non-NULL
35
+
arguments, and [sum]/[min]/[max]/[avg]/[total] fold the non-NULL arguments
36
+
through the shared {!Value_ops.numeric_agg}. *)
37
+
38
+
type subkind =
39
+
| Scalar
40
+
| Exists
41
+
| In
42
+
(** The kind of a registered correlated subquery: a scalar value, an
43
+
[EXISTS] test, or the [IN (SELECT)] membership whose left operand the
44
+
[Ir.Subquery] node carries. *)
45
+
46
+
val query :
47
+
?params:Ast.value array ->
48
+
layout ->
49
+
Ast.select ->
50
+
Catalog.Ir.query * (subkind * Ast.select) list
51
+
(** [query layout s] lowers a plain (non-aggregate, non-window, non-compound)
52
+
select to a {!Catalog.Ir.query} and the correlated subqueries it references,
53
+
in id order (the {!Catalog.Ir.constructor-Subquery} ids index this list):
54
+
the scan over [layout]'s cursors, the [WHERE] filter, the projection
55
+
(expanding [*] and [t.*]), [ORDER BY], [DISTINCT], and a literal/parameter
56
+
[LIMIT]/[OFFSET]. [params] resolves a bound [LIMIT ?]/[OFFSET ?]. The caller
57
+
wires a runner for each subquery into {!Catalog.Ir.field-subquery}. Raises
58
+
{!Catalog.Ir.Unsupported} for a select outside the subset (grouping, a
59
+
window, a compound arm, a non-literal limit). *)
60
+
61
+
val aggregate_query :
62
+
?params:Ast.value array ->
63
+
layout ->
64
+
Ast.select ->
65
+
Catalog.Ir.grouped * (subkind * Ast.select) list
66
+
(** [aggregate_query layout s] lowers an aggregate / [GROUP BY] select to a
67
+
{!Catalog.Ir.grouped} and the correlated subqueries its scan filter ([WHERE]
68
+
/ [ON]) references, in id order (the caller wires a runner for each): the
69
+
group keys, the aggregates (each select / [HAVING] / [ORDER BY] item that is
70
+
a plain aggregate call), a representative-row section for any bare column or
71
+
[*], and an output query over the synthetic per-group row (the keys, the
72
+
representative columns, then the aggregate results). Raises
73
+
{!Catalog.Ir.Unsupported} for a shape outside the subset: a select item that
74
+
is neither a group key, a bare column, a plain aggregate, nor a literal (an
75
+
expression mixing keys and aggregates), a window, or a compound arm. *)
+1104
lib/parser.mly
+1104
lib/parser.mly
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
5
+
Menhir grammar for the SQLite SQL subset.
6
+
7
+
CREATE TABLE column bodies are collected as token lists and classified in
8
+
Ast.classify_column — the grammar handles structure (parens, commas,
9
+
table-vs-column dispatch), OCaml handles the type/constraint semantics.
10
+
Queries (SELECT) get a real expression grammar with precedence.
11
+
---------------------------------------------------------------------------*)
12
+
13
+
%{ open Ast
14
+
15
+
let number_to_value s =
16
+
match Int64.of_string_opt s with
17
+
| Some i -> Int i
18
+
| None -> (
19
+
match float_of_string_opt s with Some f -> Float f | None -> Text s)
20
+
21
+
(* Wrap an aggregate call [base] in its optional FILTER then OVER decorations. *)
22
+
let decorate base filter window =
23
+
let base = match filter with Some p -> Filter (base, p) | None -> base in
24
+
match window with Some w -> Window (base, w) | None -> base
25
+
26
+
(* [e d NULLS FIRST|LAST]: NULLS is a soft keyword (a plain identifier elsewhere),
27
+
matched contextually here. The default null ordering already matches sqlite3
28
+
(NULL sorts lowest, so ASC is nulls-first and DESC nulls-last); an explicit
29
+
clause overrides it with a leading [e IS NULL] key. *)
30
+
let nulls_order e d kw pos =
31
+
if String.uppercase_ascii kw <> "NULLS" then
32
+
failwith "syntax error: expected NULLS in ORDER BY term";
33
+
match String.uppercase_ascii pos with
34
+
| "FIRST" -> [ (Is_null e, Desc); (e, d) ]
35
+
| "LAST" -> [ (Is_null e, Asc); (e, d) ]
36
+
| _ -> failwith "syntax error: expected NULLS FIRST or NULLS LAST"
37
+
38
+
(* [a IS b] / [a IS NOT b]: NULL-safe (not-)distinct. A NULL right operand folds
39
+
to the dedicated Is_null/Is_not_null nodes; otherwise it is the general
40
+
NULL-safe equality node (IS NOT is its boolean complement). *)
41
+
let mk_is a = function Lit Null -> Is_null a | b -> Is (a, b)
42
+
let mk_is_not a = function
43
+
| Lit Null -> Is_not_null a
44
+
| b -> Unop_not (Is (a, b))
45
+
46
+
(* [a IS TRUE]/[IS FALSE] (and their NOT forms) test truthiness, not equality:
47
+
sqlite3 defines [a IS TRUE] as [a<>0] and [a IS FALSE] as [a=0], each mapping
48
+
a NULL [a] to 0 (false). Desugar to a CASE so [a] is evaluated once and the
49
+
result is always 0/1, never NULL. *)
50
+
(* [x IN (list)]: a list whose sole element is a parenthesised subquery (so the
51
+
source wrote [x IN ((SELECT ...))], any depth of extra parens collapsing to a
52
+
scalar subquery) is the subquery membership test [x IN (SELECT ...)], matching
53
+
every result row -- not a one-element value list. *)
54
+
let mk_in e = function [ Scalar_select s ] -> In_select (e, s) | l -> In_list (e, l)
55
+
56
+
let zero = Lit (Int 0L)
57
+
let one = Lit (Int 1L)
58
+
let is_true a = Case (None, [ (Binary (Neq, a, zero), one) ], Some zero)
59
+
let is_false a = Case (None, [ (Binary (Eq, a, zero), one) ], Some zero)
60
+
let is_not_true a = Case (None, [ (Binary (Neq, a, zero), zero) ], Some one)
61
+
let is_not_false a = Case (None, [ (Binary (Eq, a, zero), zero) ], Some one)
62
+
63
+
(* Build a [create_table] from a parsed column/constraint list (shared by the
64
+
standalone CREATE TABLE parser and the statement form). *)
65
+
let make_create_table ?(without_rowid = false) name if_not_exists defs =
66
+
let mk_fk cols (parent, pcols, od, ou) =
67
+
{ cols = cols; parent = parent; parent_cols = pcols;
68
+
on_delete = od; on_update = ou }
69
+
in
70
+
let columns, tcs, checks, defaults, gens, fks =
71
+
List.fold_left (fun (cs, ts, ks, ds, gs, fs) -> function
72
+
| `Col (cname, (toks, col_checks, def, gen)) ->
73
+
let ds = match def with Some e -> (cname, e) :: ds | None -> ds in
74
+
let gs = match gen with Some e -> (cname, e) :: gs | None -> gs in
75
+
let fs =
76
+
match column_foreign_key cname toks with
77
+
| Some fk -> fk :: fs
78
+
| None -> fs
79
+
in
80
+
(classify_column cname toks :: cs, ts,
81
+
List.rev_append col_checks ks, ds, gs, fs)
82
+
| `Tbl t -> (cs, t :: ts, ks, ds, gs, fs)
83
+
| `Check k -> (cs, ts, k :: ks, ds, gs, fs)
84
+
| `Fk (cols, r) -> (cs, ts, ks, ds, gs, mk_fk cols r :: fs))
85
+
([], [], [], [], [], []) defs
86
+
in
87
+
{ tbl_name = name;
88
+
ct_if_not_exists = if_not_exists;
89
+
columns = List.rev columns;
90
+
table_constraints = List.rev tcs;
91
+
checks = List.rev checks;
92
+
defaults = List.rev defaults;
93
+
generated = List.rev gens;
94
+
foreign_keys = List.rev fks;
95
+
ct_without_rowid = without_rowid }
96
+
%}
97
+
98
+
(* Payload tokens *)
99
+
%token <string> IDENT
100
+
%token <string> NUMBER
101
+
%token <string> STRING
102
+
103
+
(* SQL keywords — all carry original text for case preservation *)
104
+
%token <string> CREATE TABLE ALTER ADD COLUMN IF NOT EXISTS DROP VIEW RENAME
105
+
%token <string> TRIGGER BEFORE AFTER INSTEAD FOR EACH ROW OF
106
+
%token <string> CASCADE RESTRICT NO ACTION CROSS SAVEPOINT RELEASE TO
107
+
%token <string> PRIMARY KEY UNIQUE NULL DEFAULT CHECK REFERENCES TRUE FALSE
108
+
%token <string> COLLATE GENERATED ALWAYS AS AUTOINCREMENT
109
+
%token <string> FOREIGN CONSTRAINT ON ASC DESC
110
+
%token <string> SELECT DISTINCT FROM WHERE JOIN INNER LEFT OUTER ORDER GROUP BY LIMIT
111
+
%token <string> NATURAL RIGHT FULL USING
112
+
%token <string> HAVING OFFSET CASE WHEN THEN ELSE END RETURNING FILTER
113
+
%token <string> OVER PARTITION ROWS RANGE PRECEDING FOLLOWING UNBOUNDED CURRENT
114
+
%token <string> CONFLICT DO NOTHING
115
+
%token <string> WITH RECURSIVE UNION ALL EXCEPT INTERSECT
116
+
%token <string> AND OR IN IS LIKE GLOB BETWEEN CAST ESCAPE ISNULL NOTNULL
117
+
%token <string> MATERIALIZED WITHOUT
118
+
%token <string> INSERT INTO VALUES REPLACE DELETE UPDATE SET INDEX PRAGMA
119
+
%token <string> BEGIN COMMIT ROLLBACK TRANSACTION VACUUM ANALYZE
120
+
121
+
(* Delimiters and operators *)
122
+
%token LPAREN RPAREN COMMA SEMI DOT STAR QUESTION PLUS MINUS SLASH PERCENT
123
+
%token EQ NEQ LT LE GT GE EOF CONCAT
124
+
%token BITAND BITOR SHL SHR ARROW ARROW2
125
+
%token <string> BLOB
126
+
(* Phantom token: precedence marker for an absent join constraint (never lexed). *)
127
+
%token NO_CONSTRAINT
128
+
129
+
%start <Ast.create_table> create_table
130
+
%start <Ast.stmt list> statements
131
+
132
+
(* Precedence: lowest first. NOT binds tighter than AND/OR but looser than the
133
+
comparison operators; bitwise (& | << >>) binds tighter than comparison,
134
+
additive tighter still, then multiplicative, matching SQLite. *)
135
+
(* A bare join with no [ON]/[USING] reduces at the lowest precedence, so a
136
+
following [ON] is shifted into the join constraint rather than ending the
137
+
join (which would mis-bind [INSERT ... SELECT ... JOIN b ON CONFLICT]). *)
138
+
%nonassoc NO_CONSTRAINT
139
+
%nonassoc ON
140
+
%left OR
141
+
%left AND
142
+
%right NOT
143
+
%nonassoc EQ NEQ LT LE GT GE LIKE GLOB IN IS BETWEEN ISNULL NOTNULL
144
+
(* ESCAPE binds tighter than LIKE so [a LIKE b ESCAPE c] shifts the ESCAPE
145
+
rather than reducing [a LIKE b] first. *)
146
+
%nonassoc ESCAPE
147
+
%left BITAND BITOR SHL SHR
148
+
%left PLUS MINUS
149
+
%left STAR SLASH PERCENT
150
+
%left CONCAT ARROW ARROW2
151
+
%right UMINUS
152
+
(* COLLATE is the highest-precedence operator (datatype3.html), binding tighter
153
+
than any arithmetic or comparison operator. *)
154
+
%left COLLATE
155
+
156
+
%%
157
+
158
+
(* ── Statements ──────────────────────────────────────────────── *)
159
+
160
+
statements:
161
+
| EOF { [] }
162
+
| s = statement; t = stmt_tail { s :: t }
163
+
| SEMI; t = statements { t }
164
+
165
+
stmt_tail:
166
+
| EOF { [] }
167
+
| SEMI; t = statements { t }
168
+
169
+
statement:
170
+
| s = select_stmt { Select s }
171
+
| i = insert_stmt { Insert i }
172
+
(* [WITH ctes INSERT ... SELECT ...]: the CTEs are in scope for the inserted
173
+
query, so inject them into its embedded SELECT (a recursive CTE feeding an
174
+
INSERT is the common shape). *)
175
+
| l = with_clause; i = insert_stmt
176
+
{ Insert (match i.source with
177
+
| Ast.Select s -> { i with source = Ast.Select { s with ctes = l } }
178
+
| _ -> i) }
179
+
| d = delete_stmt { Delete d }
180
+
| u = update_stmt { Update u }
181
+
(* [WITH ctes UPDATE/DELETE ...]: the CTEs are in scope for the statement's
182
+
WHERE and SET subqueries. *)
183
+
| l = with_clause; u = update_stmt { Update { u with ctes = l } }
184
+
| l = with_clause; d = delete_stmt { Delete { d with ctes = l } }
185
+
| s = create_table_statement { s }
186
+
| c = create_index_stmt { Create_index c }
187
+
| v = create_view_stmt { Create_view v }
188
+
| tg = create_trigger_stmt { Create_trigger tg }
189
+
| d = drop_stmt { Drop d }
190
+
| a = alter_table_stmt { Alter_table a }
191
+
| p = pragma_stmt { Pragma p }
192
+
| BEGIN; option(TRANSACTION) { Begin }
193
+
| COMMIT; option(TRANSACTION) { Commit }
194
+
| ROLLBACK; option(TRANSACTION); r = rollback_tail { r }
195
+
| SAVEPOINT; name = ident { Savepoint name }
196
+
| RELEASE; ioption(SAVEPOINT); name = ident { Release name }
197
+
| VACUUM; option(ident) { Vacuum }
198
+
| ANALYZE; ioption(analyze_target) { Analyze }
199
+
200
+
(* ANALYZE's optional argument: a schema, table, or index name, optionally
201
+
schema-qualified. The name is ignored -- ANALYZE is run as a no-op. *)
202
+
analyze_target:
203
+
| ident { () }
204
+
| ident; DOT; ident { () }
205
+
206
+
(* Plain ROLLBACK, or ROLLBACK TO a savepoint. *)
207
+
rollback_tail:
208
+
| { Rollback }
209
+
| TO; ioption(SAVEPOINT); name = ident { Rollback_to name }
210
+
211
+
(* ── INSERT ──────────────────────────────────────────────────── *)
212
+
213
+
(* The source is a query: a bare [VALUES (..), (..)] list or a [SELECT]. Both
214
+
are [select_stmt] cores, so [INSERT ... VALUES] and [INSERT ... SELECT] share
215
+
one production (the executor fast-paths a literal VALUES list). *)
216
+
insert_stmt:
217
+
| INSERT; c = insert_conflict; INTO; name = ident;
218
+
cols = loption(insert_columns); s = select_stmt;
219
+
up = ioption(upsert_clause); ret = loption(returning_clause)
220
+
{ { conflict = c; table = name; columns = cols;
221
+
source = Select s; upsert = up; returning = ret } }
222
+
| INSERT; c = insert_conflict; INTO; name = ident; DEFAULT; VALUES;
223
+
ret = loption(returning_clause)
224
+
{ { conflict = c; table = name; columns = [];
225
+
source = Default_values; upsert = None; returning = ret } }
226
+
| REPLACE; INTO; name = ident;
227
+
cols = loption(insert_columns); s = select_stmt;
228
+
ret = loption(returning_clause)
229
+
{ { conflict = Replace; table = name; columns = cols;
230
+
source = Select s; upsert = None; returning = ret } }
231
+
232
+
(* [INSERT OR <action>]; a bare INSERT defaults to ABORT. REPLACE and ROLLBACK
233
+
are keyword tokens; IGNORE/ABORT/FAIL are context-sensitive (lexed as IDENT,
234
+
so they stay usable as identifiers elsewhere). *)
235
+
insert_conflict:
236
+
| { Abort }
237
+
| OR; REPLACE { Replace }
238
+
| OR; ROLLBACK { Rollback }
239
+
| OR; id = IDENT
240
+
{ match String.uppercase_ascii id with
241
+
| "IGNORE" -> Ignore
242
+
| "ABORT" -> Abort
243
+
| "FAIL" -> Fail
244
+
| "REPLACE" -> Replace
245
+
| "ROLLBACK" -> Rollback
246
+
| _ -> failwith ("INSERT OR: unknown conflict action " ^ id) }
247
+
248
+
insert_columns:
249
+
| LPAREN; cs = names; RPAREN { cs }
250
+
251
+
(* ON CONFLICT [(target cols)] DO NOTHING | DO UPDATE SET ... [WHERE ...] *)
252
+
upsert_clause:
253
+
| ON; CONFLICT; target = loption(conflict_target); DO; NOTHING
254
+
{ { target = target; action = Nothing } }
255
+
| ON; CONFLICT; target = loption(conflict_target); DO; UPDATE; SET;
256
+
sets = separated_nonempty_list(COMMA, assignment);
257
+
w = option(where_clause)
258
+
{ { target = target; action = Update (sets, w) } }
259
+
260
+
conflict_target:
261
+
| LPAREN; cs = names; RPAREN { cs }
262
+
263
+
value_tuple:
264
+
| LPAREN; es = separated_nonempty_list(COMMA, expr); RPAREN { es }
265
+
266
+
(* RETURNING expr, expr, ... (shared by INSERT / UPDATE / DELETE). *)
267
+
returning_clause:
268
+
| RETURNING; cs = separated_nonempty_list(COMMA, result_col) { cs }
269
+
270
+
(* ── DELETE ──────────────────────────────────────────────────── *)
271
+
272
+
delete_stmt:
273
+
| DELETE; FROM; name = ident; alias = option(table_alias);
274
+
where = option(where_clause); ret = loption(returning_clause)
275
+
{ { ctes = []; table = name; alias = alias; where = where;
276
+
returning = ret } }
277
+
278
+
(* ── UPDATE ──────────────────────────────────────────────────── *)
279
+
280
+
update_stmt:
281
+
| UPDATE; name = ident; SET;
282
+
sets = separated_nonempty_list(COMMA, assignment);
283
+
f = ioption(from_part);
284
+
where = option(where_clause); ret = loption(returning_clause)
285
+
{ { ctes = []; table = name; sets = sets; from = f;
286
+
where = where; returning = ret } }
287
+
288
+
assignment:
289
+
| col = ident; EQ; e = expr { (col, e) }
290
+
291
+
(* ── CREATE INDEX ────────────────────────────────────────────── *)
292
+
293
+
create_index_stmt:
294
+
| CREATE; u = boption(UNIQUE); INDEX; e = if_not_exists_b; name = ident;
295
+
ON; table = ident;
296
+
LPAREN; cs = separated_nonempty_list(COMMA, indexed_column); RPAREN;
297
+
w = ioption(index_where)
298
+
{ { if_not_exists = e; unique = u; name = name; table = table;
299
+
columns = List.filter_map (fun c -> c) cs;
300
+
has_expr = List.exists (fun c -> c = None) cs;
301
+
where = w } }
302
+
303
+
(* An indexed key: a plain column ([Some name]) or an expression ([None]). An
304
+
ASC/DESC qualifier is ignored (the index is unordered); COLLATE is part of the
305
+
key expression. *)
306
+
indexed_column:
307
+
| e = expr; ioption(ASC); ioption(DESC)
308
+
{ match e with
309
+
| Col (_, name) | Collate (Col (_, name), _) -> Some name
310
+
| _ -> None }
311
+
312
+
(* [WHERE p] makes a partial index; the predicate is kept on the AST and used by
313
+
the executor only to reject a partial UNIQUE index. *)
314
+
index_where:
315
+
| WHERE; e = expr { e }
316
+
317
+
(* ── CREATE VIEW ─────────────────────────────────────────────── *)
318
+
319
+
create_view_stmt:
320
+
| CREATE; VIEW; e = if_not_exists_b; name = ident;
321
+
cols = loption(view_columns); AS; s = select_stmt
322
+
{ { name = name; if_not_exists = e; columns = cols;
323
+
select = s } }
324
+
325
+
view_columns:
326
+
| LPAREN; cs = names; RPAREN { cs }
327
+
328
+
(* ── CREATE TRIGGER ──────────────────────────────────────────── *)
329
+
330
+
(* [CREATE TRIGGER name [BEFORE|AFTER|INSTEAD OF] event ON table [FOR EACH ROW]
331
+
[WHEN expr] BEGIN stmt; ... END]. Each body statement is terminated by its own
332
+
semicolon (including the last, before END). *)
333
+
create_trigger_stmt:
334
+
| CREATE; TRIGGER; e = if_not_exists_b; name = ident;
335
+
timing = trigger_timing; ev = trigger_event; ON; tbl = ident;
336
+
ioption(for_each_row); w = ioption(when_clause);
337
+
BEGIN; body = trigger_body; END
338
+
{ { name = name; if_not_exists = e; timing = timing;
339
+
event = ev; table = tbl; when_ = w; body = body } }
340
+
341
+
trigger_timing:
342
+
| BEFORE { Before }
343
+
| AFTER { After }
344
+
| INSTEAD; OF { Instead_of }
345
+
| { Before }
346
+
347
+
trigger_event:
348
+
(* These constructor names are shared with [stmt]; the [stmt] arm wins as the
349
+
last definition, so a [trigger_event] use needs the cast. *)
350
+
| INSERT { (Insert : trigger_event) }
351
+
| DELETE { (Delete : trigger_event) }
352
+
| UPDATE { (Update [] : trigger_event) }
353
+
| UPDATE; OF; cs = names { (Update cs : trigger_event) }
354
+
355
+
for_each_row:
356
+
| FOR; EACH; ROW { () }
357
+
358
+
when_clause:
359
+
| WHEN; e = expr { e }
360
+
361
+
trigger_body:
362
+
| { [] }
363
+
| s = trigger_action; SEMI; rest = trigger_body { s :: rest }
364
+
365
+
trigger_action:
366
+
| s = select_stmt { Select s }
367
+
| i = insert_stmt { Insert i }
368
+
| u = update_stmt { Update u }
369
+
| d = delete_stmt { Delete d }
370
+
371
+
(* ── DROP TABLE / INDEX / VIEW / TRIGGER ─────────────────────── *)
372
+
373
+
drop_stmt:
374
+
| DROP; TABLE; e = if_exists_b; name = ident
375
+
{ { object_ = Table; name = name; if_exists = e } }
376
+
| DROP; INDEX; e = if_exists_b; name = ident
377
+
{ { object_ = Index; name = name; if_exists = e } }
378
+
| DROP; VIEW; e = if_exists_b; name = ident
379
+
{ { object_ = View; name = name; if_exists = e } }
380
+
| DROP; TRIGGER; e = if_exists_b; name = ident
381
+
{ { object_ = Trigger; name = name; if_exists = e } }
382
+
383
+
if_exists_b:
384
+
| IF; EXISTS { true }
385
+
| { false }
386
+
387
+
(* ── ALTER TABLE ADD COLUMN ──────────────────────────────────── *)
388
+
389
+
(* [ADD [COLUMN] name [type] [DEFAULT literal]]. Column constraints
390
+
(PRIMARY KEY / UNIQUE / NOT NULL) are not accepted: the executor cannot
391
+
honour them on an existing table, so rejecting them at parse time keeps a
392
+
stub from silently dropping a constraint. *)
393
+
alter_table_stmt:
394
+
| ALTER; TABLE; name = ident; ADD; ioption(COLUMN);
395
+
col = name; ty = ioption(add_type); def = ioption(default_clause)
396
+
{ { table = name;
397
+
op = Add_column {
398
+
ac_name = col;
399
+
ac_affinity = (match ty with Some t -> t | None -> "");
400
+
ac_default = def } } }
401
+
| ALTER; TABLE; name = ident; RENAME; TO; nn = ident
402
+
{ { table = name; op = Rename_table nn } }
403
+
| ALTER; TABLE; name = ident; RENAME; ioption(COLUMN); c = ident; TO;
404
+
nn = ident
405
+
{ { table = name; op = Rename_column (c, nn) } }
406
+
| ALTER; TABLE; name = ident; DROP; ioption(COLUMN); c = ident
407
+
{ { table = name; op = Drop_column c } }
408
+
409
+
add_type:
410
+
| name = IDENT; p = ioption(type_params)
411
+
{ match p with Some s -> name ^ s | None -> name }
412
+
413
+
type_params:
414
+
| LPAREN; ns = separated_nonempty_list(COMMA, NUMBER); RPAREN
415
+
{ "(" ^ String.concat "," ns ^ ")" }
416
+
417
+
default_clause:
418
+
| DEFAULT; l = literal { l }
419
+
| DEFAULT; MINUS; n = NUMBER
420
+
{ match number_to_value n with
421
+
| Int i -> Int (Int64.neg i)
422
+
| Float f -> Float (-. f)
423
+
| v -> v }
424
+
| DEFAULT; PLUS; n = NUMBER { number_to_value n }
425
+
426
+
if_not_exists_b:
427
+
| IF; NOT; EXISTS { true }
428
+
| { false }
429
+
430
+
(* ── PRAGMA ──────────────────────────────────────────────────── *)
431
+
432
+
pragma_stmt:
433
+
| PRAGMA; name = ident { { name = name; value = None } }
434
+
| PRAGMA; name = ident; EQ; v = pragma_value { { name = name; value = Some v } }
435
+
| PRAGMA; name = ident; LPAREN; v = pragma_value; RPAREN
436
+
{ { name = name; value = Some v } }
437
+
438
+
(* A PRAGMA value is a literal or a bareword keyword like WAL / NORMAL / ON. *)
439
+
pragma_value:
440
+
| l = literal { l }
441
+
| s = IDENT { Text s }
442
+
| s = ON { Text s } (* a bareword value that is also a keyword, e.g. [= on] *)
443
+
444
+
(* ── SELECT ──────────────────────────────────────────────────── *)
445
+
446
+
(* A query: one core, then [UNION]/[EXCEPT]/[INTERSECT] arms, then the
447
+
compound-wide ORDER BY / LIMIT, optionally prefixed by WITH. The arms and the
448
+
trailing clauses are folded onto the first core's record. *)
449
+
select_stmt:
450
+
| ctes = loption(with_clause); first = select_core;
451
+
arms = list(compound_arm);
452
+
order_by = loption(order_clause); lim = option(limit_clause)
453
+
{ let limit, offset =
454
+
match lim with None -> (None, None) | Some (l, o) -> (Some l, o)
455
+
in
456
+
{ first with ctes; compound = arms; order_by; limit; offset } }
457
+
458
+
select_core:
459
+
| SELECT; d = boption(DISTINCT);
460
+
cols = separated_nonempty_list(COMMA, result_col);
461
+
src = option(from_part);
462
+
where = option(where_clause);
463
+
group_by = loption(group_clause);
464
+
having = option(having_clause)
465
+
{ let from, joins =
466
+
match src with Some (f, js) -> (f, js) | None -> (Unit, [])
467
+
in
468
+
{ ctes = []; distinct = d; cols; from; joins; where; group_by; having;
469
+
compound = []; order_by = []; limit = None; offset = None } }
470
+
(* A bare VALUES list is a core: rows over columns column1..columnN. *)
471
+
| VALUES; rows = separated_nonempty_list(COMMA, value_tuple)
472
+
{ { ctes = []; distinct = false;
473
+
cols = [ { expr = Star; alias = None } ];
474
+
from = Values rows; joins = []; where = None; group_by = [];
475
+
having = None;
476
+
compound = []; order_by = []; limit = None; offset = None } }
477
+
478
+
from_part:
479
+
| FROM; from = from_clause; joins = list(join_item) { (from, joins) }
480
+
481
+
having_clause:
482
+
| HAVING; e = expr { e }
483
+
484
+
compound_arm:
485
+
| UNION; ALL; c = select_core { (Union_all, c) }
486
+
| UNION; c = select_core { (Union, c) }
487
+
| EXCEPT; c = select_core { (Except, c) }
488
+
| INTERSECT; c = select_core { (Intersect, c) }
489
+
490
+
(* WITH [RECURSIVE] cte, cte, ... (RECURSIVE is accepted; a self-referential
491
+
body is handled by the recursive runner.) *)
492
+
with_clause:
493
+
| WITH; option(RECURSIVE); l = separated_nonempty_list(COMMA, cte_def) { l }
494
+
495
+
cte_def:
496
+
| name = ident; cols = loption(cte_columns); AS; ioption(materialized);
497
+
LPAREN; s = select_stmt; RPAREN
498
+
{ { Ast.name; columns = cols; query = s } }
499
+
500
+
(* An [AS [NOT] MATERIALIZED] hint on a CTE: a planner directive that does not
501
+
change results, so it is accepted and ignored. *)
502
+
materialized:
503
+
| MATERIALIZED { () }
504
+
| NOT; MATERIALIZED { () }
505
+
506
+
cte_columns:
507
+
| LPAREN; cs = names; RPAREN { cs }
508
+
509
+
group_clause:
510
+
| GROUP; BY; l = separated_nonempty_list(COMMA, expr) { l }
511
+
512
+
from_clause:
513
+
(* [Table]/[Select]/[Values] are shared with other Ast types whose definitions
514
+
come later and so win by default; cast to pick the [from_clause] arm. *)
515
+
| t = table_ref { (Table t : from_clause) }
516
+
| LPAREN; s = select_stmt; RPAREN; a = option(table_alias)
517
+
{ (Select { fs_select = s; fs_alias = a } : from_clause) }
518
+
| name = IDENT; LPAREN; args = separated_list(COMMA, expr); RPAREN;
519
+
a = option(table_alias)
520
+
{ (Table_function { tf_name = String.lowercase_ascii name;
521
+
tf_args = args; tf_alias = a } : from_clause) }
522
+
523
+
result_col:
524
+
| STAR { { expr = Star; alias = None } }
525
+
| q = IDENT; DOT; STAR { { expr = Qualified_star q; alias = None } }
526
+
| e = expr; a = option(col_alias) { { expr = e; alias = a } }
527
+
528
+
col_alias:
529
+
| AS; s = IDENT { s }
530
+
| AS; s = STRING { s } (* a quoted string is accepted as a column alias *)
531
+
| s = IDENT { s }
532
+
533
+
table_ref:
534
+
| name = IDENT; a = option(table_alias)
535
+
{ { name = name; alias = a; subquery = None } }
536
+
537
+
table_alias:
538
+
| AS; s = IDENT { s }
539
+
| s = IDENT { s }
540
+
541
+
(* A join operand: a named table, or a parenthesised subquery bound under its
542
+
alias (an unaliased one gets a unique synthetic name from its source offset,
543
+
never referenced by the user). *)
544
+
join_source:
545
+
| t = table_ref { t }
546
+
| LPAREN; s = select_stmt; RPAREN; a = table_alias
547
+
{ { name = a; alias = Some a; subquery = Some s } }
548
+
| LPAREN; s = select_stmt; RPAREN
549
+
{ let nm = Printf.sprintf "__sub%d" $startofs in
550
+
{ name = nm; alias = None; subquery = Some s } }
551
+
552
+
(* An extra FROM table: a join (with an optional ON/USING constraint -- an
553
+
unconstrained [A JOIN B] is allowed, like sqlite3), or a Cartesian product --
554
+
[CROSS JOIN] or a comma join. *)
555
+
join_item:
556
+
| k = join_kw; t = join_source; c = join_constraint
557
+
{ let on, using = c in
558
+
{ table = t; on; type_ = k; natural = false; using } }
559
+
| NATURAL; k = join_kw; t = join_source
560
+
{ { table = t; on = Lit (Int 1L); type_ = k; natural = true;
561
+
using = [] } }
562
+
| CROSS; JOIN; t = join_source
563
+
{ { table = t; on = Lit (Int 1L); type_ = Inner; natural = false;
564
+
using = [] } }
565
+
| COMMA; t = join_source
566
+
{ { table = t; on = Lit (Int 1L); type_ = Inner; natural = false;
567
+
using = [] } }
568
+
569
+
(* The optional join constraint: [ON expr], [USING (cols)], or nothing (an
570
+
unconstrained join, equivalent to ON true). *)
571
+
join_constraint:
572
+
| ON; e = expr { (e, []) }
573
+
| USING; LPAREN; cs = names; RPAREN { (Lit (Int 1L), cs) }
574
+
| %prec NO_CONSTRAINT { (Lit (Int 1L), []) }
575
+
576
+
join_kw:
577
+
| JOIN { Inner }
578
+
| INNER; JOIN { Inner }
579
+
| LEFT; JOIN { Left }
580
+
| LEFT; OUTER; JOIN { Left }
581
+
| RIGHT; JOIN { Right }
582
+
| RIGHT; OUTER; JOIN { Right }
583
+
| FULL; JOIN { Full }
584
+
| FULL; OUTER; JOIN { Full }
585
+
586
+
where_clause:
587
+
| WHERE; e = expr { e }
588
+
589
+
order_clause:
590
+
| ORDER; BY; l = separated_nonempty_list(COMMA, order_term)
591
+
{ List.concat l }
592
+
593
+
order_term:
594
+
| e = expr; d = dir { [ (e, d) ] }
595
+
| e = expr; d = dir; kw = IDENT; pos = IDENT { nulls_order e d kw pos }
596
+
597
+
dir:
598
+
| ASC { Asc }
599
+
| DESC { Desc }
600
+
| { Asc }
601
+
602
+
(* Returns (limit, offset option). Note the comma form [LIMIT off, cnt] puts the
603
+
OFFSET first -- the reverse of the [OFFSET] keyword form. *)
604
+
limit_clause:
605
+
| LIMIT; n = limit_value { (n, None) }
606
+
| LIMIT; n = limit_value; OFFSET; o = limit_value { (n, Some o) }
607
+
| LIMIT; o = limit_value; COMMA; n = limit_value { (n, Some o) }
608
+
609
+
limit_value:
610
+
| n = NUMBER { Lit (number_to_value n) }
611
+
| MINUS; n = NUMBER
612
+
{ Lit (match number_to_value n with
613
+
| Int i -> Int (Int64.neg i)
614
+
| Float f -> Float (-. f)
615
+
| v -> v) }
616
+
| QUESTION { Param 0 }
617
+
618
+
(* ── Expressions ─────────────────────────────────────────────── *)
619
+
620
+
expr:
621
+
| e1 = expr; OR; e2 = expr { Binary (Or, e1, e2) }
622
+
| e1 = expr; AND; e2 = expr { Binary (And, e1, e2) }
623
+
| NOT; e = expr { Unop_not e }
624
+
| e1 = expr; EQ; e2 = expr { Binary (Eq, e1, e2) }
625
+
| e1 = expr; NEQ; e2 = expr { Binary (Neq, e1, e2) }
626
+
| e1 = expr; LT; e2 = expr { Binary (Lt, e1, e2) }
627
+
| e1 = expr; LE; e2 = expr { Binary (Le, e1, e2) }
628
+
| e1 = expr; GT; e2 = expr { Binary (Gt, e1, e2) }
629
+
| e1 = expr; GE; e2 = expr { Binary (Ge, e1, e2) }
630
+
| e1 = expr; LIKE; e2 = expr { Binary (Like, e1, e2) }
631
+
| e1 = expr; LIKE; e2 = expr; ESCAPE; e3 = expr
632
+
{ Func ("like", [ e2; e1; e3 ]) }
633
+
| e1 = expr; NOT; LIKE; e2 = expr %prec LIKE
634
+
{ Unop_not (Binary (Like, e1, e2)) }
635
+
| e1 = expr; NOT; LIKE; e2 = expr; ESCAPE; e3 = expr
636
+
{ Unop_not (Func ("like", [ e2; e1; e3 ])) }
637
+
| e1 = expr; GLOB; e2 = expr { Binary (Glob, e1, e2) }
638
+
| e1 = expr; NOT; GLOB; e2 = expr %prec GLOB
639
+
{ Unop_not (Binary (Glob, e1, e2)) }
640
+
| e1 = expr; PLUS; e2 = expr { Binary (Add, e1, e2) }
641
+
| e1 = expr; MINUS; e2 = expr { Binary (Sub, e1, e2) }
642
+
| e1 = expr; STAR; e2 = expr { Binary (Mul, e1, e2) }
643
+
| e1 = expr; SLASH; e2 = expr { Binary (Div, e1, e2) }
644
+
| e1 = expr; PERCENT; e2 = expr { Binary (Mod, e1, e2) }
645
+
| e1 = expr; BITAND; e2 = expr { Binary (Bit_and, e1, e2) }
646
+
| e1 = expr; BITOR; e2 = expr { Binary (Bit_or, e1, e2) }
647
+
| e1 = expr; SHL; e2 = expr { Binary (Shl, e1, e2) }
648
+
| e1 = expr; SHR; e2 = expr { Binary (Shr, e1, e2) }
649
+
| e1 = expr; CONCAT; e2 = expr { Binary (Concat, e1, e2) }
650
+
| e1 = expr; ARROW; e2 = expr { Binary (Json_get, e1, e2) }
651
+
| e1 = expr; ARROW2; e2 = expr { Binary (Json_get_text, e1, e2) }
652
+
(* [e COLLATE name]: highest precedence, so it binds to the nearest operand. *)
653
+
| e = expr; COLLATE; c = IDENT { Collate (e, String.uppercase_ascii c) }
654
+
(* Unary [-e] is [0 - e]; unary [+e] is [e]. *)
655
+
| MINUS; e = expr %prec UMINUS { Binary (Sub, Lit (Int 0L), e) }
656
+
(* Unary [+] is a value no-op but strips the operand's affinity and collation
657
+
(lang_expr.html): wrapping in [COLLATE BINARY] preserves the value, removes
658
+
the column-affinity coercion (which only fires on a bare column), and pins
659
+
the default binary collation -- so [a = +b] does not coerce like [a = b]. *)
660
+
| PLUS; e = expr %prec UMINUS
661
+
(* Unary [+] strips affinity but is a no-op for collation, so it must not
662
+
override an explicit inner COLLATE ([+x COLLATE nocase] stays nocase);
663
+
the wrapper itself already suppresses affinity coercion. *)
664
+
{ match e with Collate _ -> e | _ -> Collate (e, "BINARY") }
665
+
(* [x BETWEEN lo AND hi] desugars to [x >= lo AND x <= hi]; bounds are atoms
666
+
(optionally with a trailing COLLATE) so the inner AND can't be mistaken for
667
+
a boolean conjunction. *)
668
+
| e = expr; BETWEEN; lo = between_bound; AND; hi = between_bound
669
+
{ Binary (And, Binary (Ge, e, lo), Binary (Le, e, hi)) }
670
+
| e = expr; NOT; BETWEEN; lo = between_bound; AND; hi = between_bound
671
+
{ Unop_not (Binary (And, Binary (Ge, e, lo), Binary (Le, e, hi))) }
672
+
(* The right operand is an [atom] (not a full [expr]): an atom cannot begin
673
+
with NOT, so [IS NOT] is unambiguous, and atoms bind tighter than IS so
674
+
there is no associativity conflict. A complex RHS is parenthesised. This
675
+
covers [IS NULL], [IS NOT NULL], [col IS col], [x IS <literal>]. *)
676
+
(* [IS TRUE]/[IS FALSE] test truthiness, distinct from [IS 1]/[IS 0] equality,
677
+
so they take the keyword tokens; the general RHS is a [nonbool_atom], which
678
+
excludes the bare TRUE/FALSE literals to keep these unambiguous. *)
679
+
| e1 = expr; IS; TRUE { is_true e1 }
680
+
| e1 = expr; IS; FALSE { is_false e1 }
681
+
| e1 = expr; IS; NOT; TRUE { is_not_true e1 }
682
+
| e1 = expr; IS; NOT; FALSE { is_not_false e1 }
683
+
| e1 = expr; IS; e2 = nonbool_atom { mk_is e1 e2 }
684
+
| e1 = expr; IS; NOT; e2 = nonbool_atom { mk_is_not e1 e2 }
685
+
(* [x ISNULL] / [x NOTNULL]: the one-word postfix synonyms for IS [NOT] NULL. *)
686
+
| e = expr; ISNULL { Is_null e }
687
+
| e = expr; NOTNULL { Is_not_null e }
688
+
| e = expr; IN; LPAREN; l = separated_nonempty_list(COMMA, expr); RPAREN
689
+
{ mk_in e l }
690
+
| e = expr; IN; LPAREN; RPAREN
691
+
{ In_list (e, []) }
692
+
| e = expr; IN; LPAREN; s = select_stmt; RPAREN
693
+
{ In_select (e, s) }
694
+
| e = expr; NOT; IN; LPAREN; l = separated_nonempty_list(COMMA, expr); RPAREN
695
+
{ Unop_not (mk_in e l) }
696
+
| e = expr; NOT; IN; LPAREN; RPAREN
697
+
{ Unop_not (In_list (e, [])) }
698
+
| e = expr; NOT; IN; LPAREN; s = select_stmt; RPAREN
699
+
{ Unop_not (In_select (e, s)) }
700
+
| a = atom { a }
701
+
702
+
(* A BETWEEN bound: an atom, optionally with a trailing COLLATE (which binds
703
+
tighter than the comparison the bound feeds into). *)
704
+
between_bound:
705
+
(* [%prec BETWEEN] (below COLLATE) makes a trailing COLLATE bind to the bound,
706
+
[b COLLATE c], rather than to the whole BETWEEN expression. *)
707
+
| a = atom %prec BETWEEN { a }
708
+
| a = atom; COLLATE; c = IDENT { Collate (a, String.uppercase_ascii c) }
709
+
710
+
(* [atom] is a [nonbool_atom] plus the bare TRUE/FALSE literals. The IS rules use
711
+
[nonbool_atom] so [IS TRUE]/[IS FALSE] (truthiness) stay distinct from
712
+
[IS <literal>] (equality) without a grammar conflict; every other context uses
713
+
[atom], where TRUE/FALSE are the integers 1/0 (lang_expr.html). *)
714
+
atom:
715
+
| a = nonbool_atom { a }
716
+
| TRUE { Lit (Int 1L) }
717
+
| FALSE { Lit (Int 0L) }
718
+
719
+
nonbool_atom:
720
+
| LPAREN; e = expr; RPAREN { e }
721
+
(* A parenthesised subquery used as a value: SELECT/WITH/VALUES after LPAREN
722
+
are not in [expr]'s first set, so this never conflicts with [( expr )]. *)
723
+
| LPAREN; s = select_stmt; RPAREN { Scalar_select s }
724
+
| EXISTS; LPAREN; s = select_stmt; RPAREN { Exists s }
725
+
| l = literal { Lit l }
726
+
| QUESTION { Param 0 }
727
+
| CAST; LPAREN; e = expr; AS; ty = IDENT; RPAREN
728
+
{ Cast (e, ty) }
729
+
(* CASE [base] WHEN c THEN r ... [ELSE e] END. The optional base before the
730
+
first WHEN gives the simple form; without it, the searched form. *)
731
+
| CASE; base = ioption(expr); branches = nonempty_list(case_when);
732
+
els = ioption(case_else); END
733
+
{ Case (base, branches, els) }
734
+
| name = IDENT; LPAREN; DISTINCT; e = expr; RPAREN; f = ioption(filter_clause);
735
+
w = ioption(window_clause)
736
+
{ decorate (Distinct_agg (String.lowercase_ascii name, e)) f w }
737
+
| name = IDENT; LPAREN; args = func_args; RPAREN; f = ioption(filter_clause);
738
+
w = ioption(window_clause)
739
+
{ decorate (Func (String.lowercase_ascii name, args)) f w }
740
+
| name = IDENT; LPAREN; args = func_args; ob = order_clause; RPAREN;
741
+
f = ioption(filter_clause)
742
+
{ let a = Ordered_agg (Func (String.lowercase_ascii name, args), ob) in
743
+
match f with Some p -> Filter (a, p) | None -> a }
744
+
(* [replace] is also a function, but REPLACE is a keyword token (INSERT OR
745
+
REPLACE), so it does not arrive as IDENT. *)
746
+
| REPLACE; LPAREN; args = func_args; RPAREN
747
+
{ Func ("replace", args) }
748
+
(* [like]/[glob] are also functions, but LIKE/GLOB are keyword tokens (the
749
+
binary operators), so they do not arrive as IDENT. *)
750
+
| LIKE; LPAREN; args = func_args; RPAREN { Func ("like", args) }
751
+
| GLOB; LPAREN; args = func_args; RPAREN { Func ("glob", args) }
752
+
(* KEY is a non-reserved keyword in sqlite3: [key] is an ordinary column
753
+
name outside PRIMARY/FOREIGN KEY. *)
754
+
| q = IDENT; DOT; name = IDENT { Col (Some q, name) }
755
+
| q = IDENT; DOT; name = KEY { Col (Some q, name) }
756
+
| name = IDENT { Col (None, name) }
757
+
| name = KEY { Col (None, name) }
758
+
759
+
filter_clause:
760
+
| FILTER; LPAREN; WHERE; p = expr; RPAREN { p }
761
+
762
+
(* OVER (PARTITION BY ... ORDER BY ...): an explicit frame clause is not parsed;
763
+
the default frame applies. *)
764
+
window_clause:
765
+
| OVER; LPAREN; pb = loption(partition_clause); ob = loption(order_clause);
766
+
fr = ioption(frame_clause); RPAREN
767
+
{ { partition = pb; order = ob; frame = fr } }
768
+
769
+
partition_clause:
770
+
| PARTITION; BY; l = separated_nonempty_list(COMMA, expr) { l }
771
+
772
+
(* A frame: [ROWS|RANGE] BETWEEN lo AND hi, or a single bound [ROWS|RANGE] lo
773
+
(shorthand for BETWEEN lo AND CURRENT ROW). *)
774
+
frame_clause:
775
+
| k = frame_kind; BETWEEN; lo = frame_bound; AND; hi = frame_bound
776
+
{ { rows = k; start = lo; end_ = hi } }
777
+
| k = frame_kind; lo = frame_bound
778
+
{ { rows = k; start = lo; end_ = Current_row } }
779
+
780
+
frame_kind:
781
+
| ROWS { true }
782
+
| RANGE { false }
783
+
784
+
frame_bound:
785
+
| UNBOUNDED; PRECEDING { Unbounded_preceding }
786
+
| UNBOUNDED; FOLLOWING { Unbounded_following }
787
+
| CURRENT; ROW { Current_row }
788
+
| n = expr; PRECEDING { Preceding n }
789
+
| n = expr; FOLLOWING { Following n }
790
+
791
+
case_when:
792
+
| WHEN; c = expr; THEN; r = expr { (c, r) }
793
+
794
+
case_else:
795
+
| ELSE; e = expr { e }
796
+
797
+
func_args:
798
+
| STAR { [ Star ] }
799
+
| l = separated_list(COMMA, expr) { l }
800
+
801
+
literal:
802
+
| n = NUMBER { number_to_value n }
803
+
| s = STRING { Text s }
804
+
| b = BLOB { Blob b }
805
+
| NULL { Null }
806
+
807
+
(* ── CREATE TABLE ────────────────────────────────────────────── *)
808
+
809
+
create_table:
810
+
| b = create_table_body; EOF { b }
811
+
812
+
create_table_body:
813
+
| CREATE; TABLE; e = if_not_exists_b; name = ident;
814
+
LPAREN; defs = separated_nonempty_list(COMMA, column_or_constraint); RPAREN;
815
+
wr = table_options
816
+
{ make_create_table ~without_rowid:wr name e defs }
817
+
818
+
(* The statement form left-factors the column-def and [AS query] tails so the
819
+
shared [CREATE TABLE name] prefix has no conflict. *)
820
+
create_table_statement:
821
+
| CREATE; TABLE; e = if_not_exists_b; name = ident; r = create_table_tail
822
+
{ match r with
823
+
| `Cols (defs, wr) ->
824
+
Create_table (make_create_table ~without_rowid:wr name e defs)
825
+
| `As s ->
826
+
Create_table_as
827
+
{ name = name; if_not_exists = e; query = s } }
828
+
829
+
create_table_tail:
830
+
| LPAREN; defs = separated_nonempty_list(COMMA, column_or_constraint); RPAREN;
831
+
opts = table_options
832
+
{ `Cols (defs, opts) }
833
+
| AS; s = select_stmt { `As s }
834
+
835
+
(* Trailing table options after the column list: [WITHOUT ROWID] (kept) and
836
+
[STRICT] (accepted, ignored), comma-separated in any order. *)
837
+
table_options:
838
+
| (* empty *) { false }
839
+
| WITHOUT; ident; ioption(other_table_options) { true }
840
+
| IDENT; ioption(other_table_options) { false }
841
+
842
+
other_table_options:
843
+
| COMMA; WITHOUT; ident; ioption(other_table_options) { () }
844
+
| COMMA; IDENT; ioption(other_table_options) { () }
845
+
846
+
(* Dispatch: table constraints start with PRIMARY, UNIQUE, FOREIGN,
847
+
CHECK, or CONSTRAINT. Everything else is a column definition. *)
848
+
column_or_constraint:
849
+
| t = table_constraint { `Tbl t }
850
+
| k = table_check { `Check k }
851
+
| f = table_fk { `Fk f }
852
+
| name = name; body = col_body { `Col (name, body) }
853
+
854
+
(* Column names: IDENT plus keywords that never start a table constraint *)
855
+
name:
856
+
| s = IDENT { s }
857
+
| s = TABLE { s }
858
+
| s = CREATE { s }
859
+
| s = KEY { s }
860
+
| s = NOT { s }
861
+
| s = NULL { s }
862
+
| s = DEFAULT { s }
863
+
| s = REFERENCES { s }
864
+
| s = COLLATE { s }
865
+
| s = GENERATED { s }
866
+
| s = ALWAYS { s }
867
+
| s = AS { s }
868
+
| s = AUTOINCREMENT { s }
869
+
| s = EXISTS { s }
870
+
| s = IF { s }
871
+
| s = ON { s }
872
+
| s = ASC { s }
873
+
| s = DESC { s }
874
+
| s = SELECT { s }
875
+
| s = DISTINCT { s }
876
+
| s = FROM { s }
877
+
| s = WHERE { s }
878
+
| s = JOIN { s }
879
+
| s = INNER { s }
880
+
| s = LEFT { s }
881
+
| s = OUTER { s }
882
+
| s = ORDER { s }
883
+
| s = BY { s }
884
+
| s = LIMIT { s }
885
+
| s = AND { s }
886
+
| s = OR { s }
887
+
| s = IN { s }
888
+
| s = IS { s }
889
+
| s = LIKE { s }
890
+
891
+
(* ── Table-level constraints ─────────────────────────────────── *)
892
+
893
+
table_constraint:
894
+
| UNIQUE; LPAREN; cs = indexed_names; RPAREN
895
+
{ Unique cs }
896
+
| PRIMARY; KEY; LPAREN; cs = indexed_names; RPAREN
897
+
{ Primary_key cs }
898
+
| CONSTRAINT; ident; UNIQUE; LPAREN; cs = indexed_names; RPAREN
899
+
{ Unique cs }
900
+
| CONSTRAINT; ident; PRIMARY; KEY; LPAREN; cs = indexed_names; RPAREN
901
+
{ Primary_key cs }
902
+
903
+
(* A PRIMARY KEY / UNIQUE column list: each column may carry a COLLATE and an
904
+
ASC/DESC qualifier, of which only the column name is kept. *)
905
+
indexed_names:
906
+
| separated_nonempty_list(COMMA, indexed_name) { $1 }
907
+
908
+
indexed_name:
909
+
| c = ident; ioption(constraint_collate); ioption(ASC); ioption(DESC) { c }
910
+
911
+
constraint_collate:
912
+
| COLLATE; ident { () }
913
+
914
+
(* A CHECK constraint, column- or table-level. The predicate is parsed as a real
915
+
expression and its verbatim source offsets are captured so a violation can
916
+
quote it exactly. CONSTRAINT names are accepted but unused (SQLite reports the
917
+
predicate text, not the name). *)
918
+
table_check:
919
+
| CHECK; LPAREN; e = expr; RPAREN
920
+
{ { expr = e; start = $startofs(e); stop = $endofs(e) } }
921
+
| CONSTRAINT; ident; CHECK; LPAREN; e = expr; RPAREN
922
+
{ { expr = e; start = $startofs(e); stop = $endofs(e) } }
923
+
924
+
(* A table-level FOREIGN KEY. The child columns pair with a [fk_clause]
925
+
([REFERENCES parent [(cols)] [ON DELETE/UPDATE action]]); the result carries
926
+
the child columns so [create_table_body] can build the {!Ast.foreign_key}. *)
927
+
table_fk:
928
+
| FOREIGN; KEY; LPAREN; cs = names; RPAREN; r = fk_clause
929
+
{ (cs, r) }
930
+
| CONSTRAINT; ident; FOREIGN; KEY; LPAREN; cs = names; RPAREN; r = fk_clause
931
+
{ (cs, r) }
932
+
933
+
(* The shared REFERENCES tail, also used for a column-level [col REFERENCES ...].
934
+
Returns [(parent, parent_cols, on_delete, on_update)]; parent_cols [] means
935
+
the parent's primary key. *)
936
+
fk_clause:
937
+
| REFERENCES; parent = ident; pcols = loption(paren_names);
938
+
acts = list(fk_ref_action)
939
+
{ let pick sel =
940
+
List.fold_left (fun a x -> match sel x with Some v -> v | None -> a)
941
+
No_action acts
942
+
in
943
+
(parent, pcols,
944
+
pick (function `Del d -> Some d | `Upd _ -> None),
945
+
pick (function `Upd u -> Some u | `Del _ -> None)) }
946
+
947
+
fk_ref_action:
948
+
| ON; DELETE; a = fk_action { `Del a }
949
+
| ON; UPDATE; a = fk_action { `Upd a }
950
+
951
+
fk_action:
952
+
| SET; NULL { Set_null }
953
+
| SET; DEFAULT { Set_default }
954
+
| CASCADE { Cascade }
955
+
| RESTRICT { Restrict }
956
+
| NO; ACTION { No_action }
957
+
958
+
paren_names:
959
+
| LPAREN; cs = names; RPAREN { cs }
960
+
961
+
names:
962
+
| separated_nonempty_list(COMMA, ident) { $1 }
963
+
964
+
(* ── Column body: flat token list ────────────────────────────── *)
965
+
966
+
col_body:
967
+
| items = list(col_body_item)
968
+
{ let toks =
969
+
List.filter_map
970
+
(function `T t -> Some t | `K _ | `D _ | `G _ -> None) items
971
+
in
972
+
let checks =
973
+
List.filter_map
974
+
(function `K k -> Some k | `T _ | `D _ | `G _ -> None) items
975
+
in
976
+
(* A column has at most one DEFAULT and one generation expr; keep the
977
+
first if repeated. *)
978
+
let default =
979
+
List.find_map (function `D e -> Some e | `T _ | `K _ | `G _ -> None) items
980
+
in
981
+
let generated =
982
+
List.find_map (function `G e -> Some e | `T _ | `K _ | `D _ -> None) items
983
+
in
984
+
(toks, checks, default, generated) }
985
+
986
+
col_body_item:
987
+
| t = col_token { `T t }
988
+
| k = col_check { `K k }
989
+
| e = col_default { `D e }
990
+
| e = col_generated { `G e }
991
+
992
+
(* A generated (computed) column: [[GENERATED ALWAYS] AS (expr) [VIRTUAL|STORED]].
993
+
A trailing STORED/VIRTUAL keyword is left to be collected as an opaque column
994
+
token and ignored -- both behave as stored here. *)
995
+
col_generated:
996
+
| GENERATED; ALWAYS; AS; LPAREN; e = expr; RPAREN { e }
997
+
| AS; LPAREN; e = expr; RPAREN { e }
998
+
999
+
(* A column-level CHECK. Like the table-level form, the predicate is a real
1000
+
expression whose verbatim source offsets are captured for the error text. *)
1001
+
col_check:
1002
+
| CHECK; LPAREN; e = expr; RPAREN
1003
+
{ { expr = e; start = $startofs(e); stop = $endofs(e) } }
1004
+
1005
+
(* A column DEFAULT: a constant literal, a signed number, or a parenthesised
1006
+
expression. The parenthesised form is checked for constancy when the table is
1007
+
created (a column reference there is an error). *)
1008
+
col_default:
1009
+
| DEFAULT; l = literal { Lit l }
1010
+
| DEFAULT; MINUS; n = NUMBER
1011
+
{ Lit (match number_to_value n with
1012
+
| Int i -> Int (Int64.neg i)
1013
+
| Float f -> Float (-. f)
1014
+
| v -> v) }
1015
+
| DEFAULT; PLUS; n = NUMBER { Lit (number_to_value n) }
1016
+
| DEFAULT; LPAREN; e = expr; RPAREN { e }
1017
+
1018
+
%inline col_token:
1019
+
| s = IDENT { Word s }
1020
+
| s = NUMBER { Number s }
1021
+
| s = STRING { Number ("'" ^ s ^ "'") }
1022
+
| k = keyword { Word k }
1023
+
| p = punct { Word p }
1024
+
| LPAREN; ts = list(paren_token); RPAREN { Parens ts }
1025
+
1026
+
paren_token:
1027
+
| s = IDENT { Word s }
1028
+
| s = NUMBER { Number s }
1029
+
| s = STRING { Number ("'" ^ s ^ "'") }
1030
+
| k = keyword { Word k }
1031
+
| p = punct { Word p }
1032
+
| COMMA { Word "," }
1033
+
| LPAREN; ts = list(paren_token); RPAREN { Parens ts }
1034
+
1035
+
(* Operators that may appear inside CHECK / DEFAULT / GENERATED expressions.
1036
+
They are opaque to column classification, but must be accepted so the
1037
+
DDL parser does not choke on them. *)
1038
+
%inline punct:
1039
+
| EQ { "=" }
1040
+
| NEQ { "<>" }
1041
+
| LT { "<" }
1042
+
| LE { "<=" }
1043
+
| GT { ">" }
1044
+
| GE { ">=" }
1045
+
| STAR { "*" }
1046
+
| DOT { "." }
1047
+
| PLUS { "+" }
1048
+
| MINUS { "-" }
1049
+
| SLASH { "/" }
1050
+
| PERCENT { "%" }
1051
+
| BITAND { "&" }
1052
+
| BITOR { "|" }
1053
+
| SHL { "<<" }
1054
+
| SHR { ">>" }
1055
+
| CONCAT { "||" }
1056
+
1057
+
(* ── Keywords usable as column body tokens ───────────────────── *)
1058
+
1059
+
%inline keyword:
1060
+
| s = PRIMARY { s }
1061
+
| s = KEY { s }
1062
+
| s = NOT { s }
1063
+
| s = NULL { s }
1064
+
| s = UNIQUE { s }
1065
+
| s = REFERENCES { s }
1066
+
| s = COLLATE { s }
1067
+
| s = AUTOINCREMENT { s }
1068
+
| s = CONSTRAINT { s }
1069
+
(* [ON CONFLICT <action>] on a column constraint: collected as opaque tokens
1070
+
so the column still parses (the action keywords ABORT/FAIL/IGNORE lex as
1071
+
IDENT; REPLACE/ROLLBACK/CONFLICT are keyword tokens). *)
1072
+
| s = CONFLICT { s }
1073
+
| s = REPLACE { s }
1074
+
| s = ROLLBACK { s }
1075
+
| s = EXISTS { s }
1076
+
| s = CREATE { s }
1077
+
| s = TABLE { s }
1078
+
| s = IF { s }
1079
+
| s = ON { s }
1080
+
| s = ASC { s }
1081
+
| s = DESC { s }
1082
+
| s = FOREIGN { s }
1083
+
| s = SELECT { s }
1084
+
| s = DISTINCT { s }
1085
+
| s = FROM { s }
1086
+
| s = WHERE { s }
1087
+
| s = JOIN { s }
1088
+
| s = INNER { s }
1089
+
| s = LEFT { s }
1090
+
| s = OUTER { s }
1091
+
| s = ORDER { s }
1092
+
| s = BY { s }
1093
+
| s = LIMIT { s }
1094
+
| s = AND { s }
1095
+
| s = OR { s }
1096
+
| s = IN { s }
1097
+
| s = IS { s }
1098
+
| s = LIKE { s }
1099
+
1100
+
(* ── Identifiers (including quoted) ──────────────────────────── *)
1101
+
1102
+
ident:
1103
+
| s = IDENT { s }
1104
+
| s = KEY { s }
+2539
lib/query.ml
+2539
lib/query.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
open Ast
7
+
8
+
(* SQLite's value-level semantics (comparison order, collation, text conversion,
9
+
aggregate folds) live in {!Value_ops}, shared with the register-VM paths;
10
+
open it so the tree-walker uses the same folds and orders by the same rule. *)
11
+
open Value_ops
12
+
13
+
(* The built-in scalar / table-valued functions live in {!Func} (also shared
14
+
with the VM); open it so the tree-walker dispatches them through the same
15
+
value-level implementations. *)
16
+
open Func
17
+
18
+
(* The value-level binary operators (comparison with affinity, AND/OR/LIKE/GLOB/
19
+
JSON, IN-list) live in {!Value_op}; open it so the tree-walker evaluates an
20
+
operator through the same shared implementation as the VM. *)
21
+
open Value_op
22
+
23
+
type catalog = {
24
+
columns : string -> string list;
25
+
rows : string -> Catalog.Value.t list list;
26
+
rows_rowid : string -> (int64 option * Catalog.Value.t list) list;
27
+
(** Each row paired with its rowid, or [None] for a row source that has no
28
+
rowid (a view, a derived table, [VALUES]). Lets the executor resolve
29
+
the implicit [rowid]/[oid]/[_rowid_] column of a full table scan. *)
30
+
index_scan :
31
+
string ->
32
+
(string * Catalog.Value.t) list ->
33
+
(string * Catalog.Value.t list list) option;
34
+
(** [index_scan table eqs] returns [Some (index_name, rows)] if an index
35
+
on [table] serves the column-equality bindings [eqs] -- the rows whose
36
+
indexed columns match, by which the caller narrows a scan -- or [None]
37
+
to fall back to a full {!rows} scan. *)
38
+
index_for : string -> string list -> string option;
39
+
(** [index_for table cols] is the name of a unique index on [table] all of
40
+
whose columns are among [cols], if any -- the structural counterpart
41
+
of {!index_scan} (no values), used to explain the plan. *)
42
+
collation : string -> string -> string option;
43
+
(** [collation table col] is [col]'s declared [COLLATE] sequence
44
+
(uppercase) on [table], or [None] for the default binary / a derived
45
+
source. *)
46
+
}
47
+
48
+
let of_catalog cat =
49
+
{
50
+
columns = Catalog.Spi.columns cat;
51
+
rows = Catalog.Spi.rows cat;
52
+
rows_rowid = Catalog.Spi.rows_rowid cat;
53
+
index_scan = Catalog.Spi.index_scan cat;
54
+
index_for = Catalog.Spi.index_for cat;
55
+
collation = Catalog.Spi.collation cat;
56
+
}
57
+
58
+
(* The runner [eval] reaches for a scalar / [IN] / [EXISTS] subquery, given the
59
+
subquery's enclosing-row [cat], its outer scope, the subquery, and the params.
60
+
Held in a private ref behind {!set_cat_subquery_runner} (the catalog VM that
61
+
fulfils it depends on this module, so it is injected, not called directly).
62
+
The default -- and a pure storage catalog -- is the tree-walker {!exec_select},
63
+
tied off once that is defined; the engine overrides it to run the subquery
64
+
over the {e same} [cat]'s rows on the catalog VM, falling back here. *)
65
+
let cat_subquery_runner :
66
+
(catalog ->
67
+
(string * (string * Catalog.Value.t) list) list ->
68
+
Ast.select ->
69
+
Catalog.Value.t array ->
70
+
Catalog.Value.t list list)
71
+
ref =
72
+
ref (fun _ _ _ _ -> failwith "Query.cat_subquery_runner: not initialised")
73
+
74
+
let set_cat_subquery_runner f = cat_subquery_runner := f
75
+
76
+
(* ── Parameter numbering ─────────────────────────────────────── *)
77
+
78
+
(* Renumber [?] placeholders left-to-right. [next] is a monotonic counter; the
79
+
explicit [let] bindings force left-to-right traversal so placeholders are
80
+
numbered in source order regardless of OCaml's argument evaluation. *)
81
+
let rec renum_expr next = function
82
+
| Param _ -> Param (next ())
83
+
| (Lit _ | Col _ | Star | Qualified_star _) as e -> e
84
+
| Unop_not e -> Unop_not (renum_expr next e)
85
+
| Binary (op, a, b) ->
86
+
let a = renum_expr next a in
87
+
let b = renum_expr next b in
88
+
Binary (op, a, b)
89
+
| Is_null e -> Is_null (renum_expr next e)
90
+
| Is_not_null e -> Is_not_null (renum_expr next e)
91
+
| Is (a, b) ->
92
+
let a = renum_expr next a in
93
+
Is (a, renum_expr next b)
94
+
| In_list (e, l) ->
95
+
let e = renum_expr next e in
96
+
In_list (e, renum_exprs next l)
97
+
| In_select (e, s) ->
98
+
let e = renum_expr next e in
99
+
In_select (e, renum_select next s)
100
+
| Scalar_select s -> Scalar_select (renum_select next s)
101
+
| Exists s -> Exists (renum_select next s)
102
+
| Func (n, args) -> Func (n, renum_exprs next args)
103
+
| Distinct_agg (n, e) -> Distinct_agg (n, renum_expr next e)
104
+
| Filter (a, p) -> Filter (renum_expr next a, renum_expr next p)
105
+
| Ordered_agg (a, ob) ->
106
+
Ordered_agg
107
+
(renum_expr next a, List.map (fun (e, d) -> (renum_expr next e, d)) ob)
108
+
| Window (a, w) ->
109
+
let bound = function
110
+
| (Unbounded_preceding | Current_row | Unbounded_following) as b -> b
111
+
| Preceding e -> Preceding (renum_expr next e)
112
+
| Following e -> Following (renum_expr next e)
113
+
in
114
+
Window
115
+
( renum_expr next a,
116
+
{
117
+
partition = List.map (renum_expr next) w.partition;
118
+
order = List.map (fun (e, d) -> (renum_expr next e, d)) w.order;
119
+
frame =
120
+
Option.map
121
+
(fun (f : frame) ->
122
+
{ f with start = bound f.start; end_ = bound f.end_ })
123
+
w.frame;
124
+
} )
125
+
| Cast (e, ty) -> Cast (renum_expr next e, ty)
126
+
| Collate (e, c) -> Collate (renum_expr next e, c)
127
+
| Case (base, branches, els) ->
128
+
let base = Option.map (renum_expr next) base in
129
+
let branches =
130
+
List.map
131
+
(fun (c, r) ->
132
+
let c = renum_expr next c in
133
+
(c, renum_expr next r))
134
+
branches
135
+
in
136
+
let els = Option.map (renum_expr next) els in
137
+
Case (base, branches, els)
138
+
139
+
and renum_exprs next = function
140
+
| [] -> []
141
+
| e :: rest ->
142
+
let e = renum_expr next e in
143
+
e :: renum_exprs next rest
144
+
145
+
(* Source order: SELECT cols, FROM (subquery), JOINs, WHERE, ORDER BY, LIMIT. *)
146
+
and renum_select next (s : select) =
147
+
let ctes =
148
+
List.map
149
+
(fun (c : cte) -> { c with query = renum_select next c.query })
150
+
s.ctes
151
+
in
152
+
let cols =
153
+
List.map
154
+
(fun (rc : result_col) -> { rc with expr = renum_expr next rc.expr })
155
+
s.cols
156
+
in
157
+
let from =
158
+
match s.from with
159
+
| (Unit | Table _) as f -> f
160
+
| Select fs -> Select { fs with fs_select = renum_select next fs.fs_select }
161
+
| Values rows -> Values (List.map (List.map (renum_expr next)) rows)
162
+
| Table_function tf ->
163
+
Table_function
164
+
{ tf with tf_args = List.map (renum_expr next) tf.tf_args }
165
+
in
166
+
let joins =
167
+
List.map
168
+
(fun (j : join) ->
169
+
let table =
170
+
match j.table.subquery with
171
+
| Some q -> { j.table with subquery = Some (renum_select next q) }
172
+
| None -> j.table
173
+
in
174
+
{ j with table; on = renum_expr next j.on })
175
+
s.joins
176
+
in
177
+
let where = Option.map (renum_expr next) s.where in
178
+
let group_by = List.map (renum_expr next) s.group_by in
179
+
let having = Option.map (renum_expr next) s.having in
180
+
let compound =
181
+
List.map (fun (op, arm) -> (op, renum_select next arm)) s.compound
182
+
in
183
+
let order_by = List.map (fun (e, d) -> (renum_expr next e, d)) s.order_by in
184
+
let limit = Option.map (renum_expr next) s.limit in
185
+
let offset = Option.map (renum_expr next) s.offset in
186
+
{
187
+
s with
188
+
ctes;
189
+
cols;
190
+
from;
191
+
joins;
192
+
where;
193
+
group_by;
194
+
having;
195
+
compound;
196
+
order_by;
197
+
limit;
198
+
offset;
199
+
}
200
+
201
+
let number_params stmt =
202
+
let counter = ref 0 in
203
+
let next () =
204
+
let i = !counter in
205
+
incr counter;
206
+
i
207
+
in
208
+
let e = renum_expr next and es = renum_exprs next in
209
+
let rcs l =
210
+
List.map (fun (rc : result_col) -> { rc with expr = e rc.expr }) l
211
+
in
212
+
match stmt with
213
+
| Select s -> Select (renum_select next s)
214
+
| Insert (i : insert) ->
215
+
let source =
216
+
match i.source with
217
+
| Values rows -> Values (List.map es rows)
218
+
| Select s -> Select (renum_select next s)
219
+
| Default_values -> Default_values
220
+
in
221
+
let upsert =
222
+
Option.map
223
+
(fun (u : upsert) ->
224
+
match u.action with
225
+
| Nothing -> u
226
+
| Update (sets, w) ->
227
+
let sets = List.map (fun (c, x) -> (c, e x)) sets in
228
+
{ u with action = Update (sets, Option.map e w) })
229
+
i.upsert
230
+
in
231
+
let returning = rcs i.returning in
232
+
Insert { i with source; upsert; returning }
233
+
| Delete d ->
234
+
let where = Option.map e d.where in
235
+
Delete { d with where; returning = rcs d.returning }
236
+
| Update u ->
237
+
let sets = List.map (fun (c, x) -> (c, e x)) u.sets in
238
+
let where = Option.map e u.where in
239
+
Update { u with sets; where; returning = rcs u.returning }
240
+
| Create_table_as cta ->
241
+
Create_table_as { cta with query = renum_select next cta.query }
242
+
| ( Create_table _ | Create_index _ | Create_view _ | Create_trigger _
243
+
| Drop _ | Alter_table _ | Pragma _ | Begin | Commit | Rollback
244
+
| Savepoint _ | Release _ | Rollback_to _ | Vacuum | Analyze ) as s ->
245
+
s
246
+
247
+
(* ── Values ──────────────────────────────────────────────────── *)
248
+
249
+
(* ── Three-valued logic ──────────────────────────────────────── *)
250
+
251
+
(* The collating sequence an operand assigns by a top-level [COLLATE], if any.
252
+
In a comparison the left operand's explicit collation wins, else the right's
253
+
(datatype3.html sec.7.1). Column-declared collation is not yet threaded here. *)
254
+
let explicit_collation = function Collate (_, c) -> Some c | _ -> None
255
+
256
+
(* SQLite integer coercion (as the bitwise/modulo operators apply it): an
257
+
integer stays itself, a real truncates toward zero, text parses its leading
258
+
numeric prefix (else 0), NULL is handled by the caller. *)
259
+
260
+
(* [a << b] / [a >> b]: a negative shift count shifts the other way; a count of
261
+
64 or more clears the value, matching sqlite3. *)
262
+
let shift dir x n =
263
+
let n = Int64.to_int n in
264
+
let lsl_ x n = if n >= 64 then 0L else Int64.shift_left x n in
265
+
(* arithmetic right shift, so a negative x keeps its sign, as in sqlite3 *)
266
+
let asr_ x n =
267
+
if n >= 64 then if x < 0L then -1L else 0L else Int64.shift_right x n
268
+
in
269
+
match dir with
270
+
| `Left -> if n >= 0 then lsl_ x n else asr_ x (-n)
271
+
| `Right -> if n >= 0 then asr_ x n else lsl_ x (-n)
272
+
273
+
(* SQLite arithmetic: NULL is contagious; integer op integer stays integer
274
+
(with [/] truncating and division-by-zero giving NULL); any real operand, or
275
+
a text operand coerced to a number, makes the result real. The bitwise and
276
+
modulo operators always work on integers (operands coerced via {!intify}). *)
277
+
(* Does this operand carry REAL affinity? A real literal, or text that parses as
278
+
a real but not an integer. Mod is computed on integers but returns a real when
279
+
either operand is real, as sqlite3 does. *)
280
+
(* Add/Sub/Mul/Div: integer when both operands are integers ([/] truncates, /0
281
+
is NULL), otherwise real (text operands coerced to a number). *)
282
+
(* SQLite computes an integer Add/Sub/Mul/Div that would overflow [int64] as
283
+
floating point instead of wrapping (e.g. [9223372036854775807 + 1] is a real).
284
+
Each op detects overflow on the native result and falls back to a float. *)
285
+
let add_checked x y =
286
+
let r = Int64.add x y in
287
+
(* overflow iff the operands share a sign and the result's sign flips *)
288
+
if x >= 0L = (y >= 0L) && r >= 0L <> (x >= 0L) then
289
+
Float (Int64.to_float x +. Int64.to_float y)
290
+
else Int r
291
+
292
+
let sub_checked x y =
293
+
let r = Int64.sub x y in
294
+
if x >= 0L <> (y >= 0L) && r >= 0L <> (x >= 0L) then
295
+
Float (Int64.to_float x -. Int64.to_float y)
296
+
else Int r
297
+
298
+
let mul_checked x y =
299
+
let r = Int64.mul x y in
300
+
(* check the special [min_int * -1] first so the div below never hits it *)
301
+
let overflow =
302
+
x <> 0L && ((x = -1L && y = Int64.min_int) || Int64.div r x <> y)
303
+
in
304
+
if overflow then Float (Int64.to_float x *. Int64.to_float y) else Int r
305
+
306
+
let arith_int op x y =
307
+
match op with
308
+
| Add -> add_checked x y
309
+
| Sub -> sub_checked x y
310
+
| Mul -> mul_checked x y
311
+
| Div ->
312
+
if y = 0L then Null
313
+
else if x = Int64.min_int && y = -1L then
314
+
Float (Int64.to_float x /. Int64.to_float y)
315
+
else Int (Int64.div x y)
316
+
| _ -> assert false
317
+
318
+
let arith_float op a b =
319
+
let f = function
320
+
| Int i -> Int64.to_float i
321
+
| Float f -> f
322
+
| v -> (
323
+
match float_of_string_opt (String.trim (text_of_value v)) with
324
+
| Some f -> f
325
+
| None -> 0.)
326
+
in
327
+
let x = f a and y = f b in
328
+
match op with
329
+
| Add -> Float (x +. y)
330
+
| Sub -> Float (x -. y)
331
+
| Mul -> Float (x *. y)
332
+
| Div -> if y = 0. then Null else Float (x /. y)
333
+
| _ -> assert false
334
+
335
+
let arith op a b =
336
+
if a = Null || b = Null then Null
337
+
else
338
+
match op with
339
+
| Mod ->
340
+
let y = intify b in
341
+
if y = 0L then Null
342
+
else
343
+
let r = Int64.rem (intify a) y in
344
+
if is_real a || is_real b then Float (Int64.to_float r) else Int r
345
+
| Bit_and -> Int (Int64.logand (intify a) (intify b))
346
+
| Bit_or -> Int (Int64.logor (intify a) (intify b))
347
+
| Shl -> Int (shift `Left (intify a) (intify b))
348
+
| Shr -> Int (shift `Right (intify a) (intify b))
349
+
| _ -> (
350
+
(* Apply numeric affinity to text operands first, so '5'+2 is integer
351
+
arithmetic (7) while '5.5'+2 is real (7.5), matching sqlite3. *)
352
+
match (numeric_affinity a, numeric_affinity b) with
353
+
| Int x, Int y -> arith_int op x y
354
+
| a, b -> arith_float op a b)
355
+
356
+
(* ── Environments and lookup ─────────────────────────────────── *)
357
+
358
+
(* A [binding] is one named row fragment: an (alias, [(column, value)]) pair --
359
+
the public form used for an outer [scope] (a correlated subquery's enclosing
360
+
row, or a trigger's OLD/NEW rows). *)
361
+
type binding = string * (string * value) list
362
+
363
+
(* Internally a row is a list of [frame]s -- one per table joined in, plus the
364
+
scope at the tail so inner tables shadow it for unqualified names. A table row
365
+
is a [Pos] frame: the alias, the shared column-name list (one allocation,
366
+
reused across every row of that table), and the row's values -- so building a
367
+
row's environment costs a 3-word record, not an n-pair association list. A
368
+
scope binding becomes an [Assoc] frame. *)
369
+
(* A [Pos] frame carries the optional rowid of a real-table row (for the
370
+
implicit [rowid]/[oid]/[_rowid_] column); [None] for an index-narrowed scan,
371
+
a derived table, or a scope binding, where rowid is not resolvable. *)
372
+
type frame =
373
+
| Pos of string * string list * value list * int64 option
374
+
| Assoc of binding
375
+
376
+
type env = frame list
377
+
378
+
(* The [rowid] pseudo-column and its two aliases, matched case-insensitively. A
379
+
real column of the same name shadows the implicit one, so this is consulted
380
+
only after the declared columns. *)
381
+
let is_rowid_name n =
382
+
match String.lowercase_ascii n with
383
+
| "rowid" | "_rowid_" | "oid" -> true
384
+
| _ -> false
385
+
386
+
(* Parallel-list lookup: the value paired with [name] in [cols]/[vals] (short
387
+
[vals] reads as trailing NULLs), or [None]. Column names match exactly, as the
388
+
association-list lookup it replaces did. *)
389
+
let rec assoc2 name cols vals =
390
+
match (cols, vals) with
391
+
| c :: cs, v :: vs -> if c = name then Some v else assoc2 name cs vs
392
+
| c :: cs, [] -> if c = name then Some Null else assoc2 name cs []
393
+
| [], _ -> None
394
+
395
+
let frame_alias = function Pos (a, _, _, _) | Assoc (a, _) -> a
396
+
397
+
let frame_lookup name = function
398
+
| Pos (_, cols, vals, rid) -> (
399
+
match assoc2 name cols vals with
400
+
| Some _ as r -> r
401
+
| None -> (
402
+
match rid with
403
+
| Some r when is_rowid_name name -> Some (Int r)
404
+
| _ -> None))
405
+
| Assoc (_, row) -> List.assoc_opt name row
406
+
407
+
(* The frame's values in column order -- the expansion of [alias.*]. The rowid is
408
+
a hidden column and never part of [*]. *)
409
+
let frame_values = function
410
+
| Pos (_, _, vals, _) -> vals
411
+
| Assoc (_, row) -> List.map snd row
412
+
413
+
(* The same frame with every value NULL -- the inner side of an unmatched outer
414
+
join row. The synthetic row has no rowid. *)
415
+
let null_pad_frame = function
416
+
| Pos (a, cols, vals, _) -> Pos (a, cols, List.map (fun _ -> Null) vals, None)
417
+
| Assoc (a, row) -> Assoc (a, List.map (fun (c, _) -> (c, Null)) row)
418
+
419
+
(* Drop the [drop] columns from a frame -- the NATURAL/USING common columns,
420
+
which survive on the left side and so are listed once. *)
421
+
let trim_frame drop = function
422
+
| Pos (a, cols, vals, rid) ->
423
+
let keep =
424
+
List.filter
425
+
(fun (c, _) -> not (List.mem c drop))
426
+
(List.combine cols vals)
427
+
in
428
+
Pos (a, List.map fst keep, List.map snd keep, rid)
429
+
| Assoc (a, row) ->
430
+
Assoc (a, List.filter (fun (c, _) -> not (List.mem c drop)) row)
431
+
432
+
let frames_of_scope (scope : binding list) : env =
433
+
List.map (fun b -> Assoc b) scope
434
+
435
+
(* Materialise an environment as public [binding]s -- used only to hand the
436
+
current row to a correlated subquery as its outer scope. Re-pairs a [Pos]
437
+
frame's columns with its values (short values read as trailing NULLs); this is
438
+
the one place a row's association list is rebuilt, and only per outer row, not
439
+
per scanned row. *)
440
+
let bindings_of_frames (env : env) : binding list =
441
+
let rec pairs cols vals =
442
+
match (cols, vals) with
443
+
| c :: cs, v :: vs -> (c, v) :: pairs cs vs
444
+
| c :: cs, [] -> (c, Null) :: pairs cs []
445
+
| [], _ -> []
446
+
in
447
+
List.map
448
+
(function Pos (a, cols, vals, _) -> (a, pairs cols vals) | Assoc b -> b)
449
+
env
450
+
451
+
(* These walkers are top-level (capturing nothing) so a column lookup -- run once
452
+
per [Col] per row -- allocates neither a closure nor a [lazy] cell. *)
453
+
let rec aliased q = function
454
+
| [] -> None
455
+
| f :: rest -> if frame_alias f = q then Some f else aliased q rest
456
+
457
+
let rec aliased_ci qu = function
458
+
| [] -> None
459
+
| f :: rest ->
460
+
if String.uppercase_ascii (frame_alias f) = qu then Some f
461
+
else aliased_ci qu rest
462
+
463
+
let rec lookup_unqual name = function
464
+
| [] -> Fmt.failwith "unknown column %S" name
465
+
| f :: rest -> (
466
+
match frame_lookup name f with
467
+
| Some v -> v
468
+
| None -> lookup_unqual name rest)
469
+
470
+
let lookup env qual name =
471
+
match qual with
472
+
| Some q -> (
473
+
(* Exact alias first; then a case-insensitive match (the uppercase form is
474
+
built only if the exact match fails), since SQL identifiers (and the
475
+
OLD/NEW pseudo-tables, written in any case) are case-insensitive. *)
476
+
let frame =
477
+
match aliased q env with
478
+
| Some _ as r -> r
479
+
| None -> aliased_ci (String.uppercase_ascii q) env
480
+
in
481
+
match frame with
482
+
| None -> Fmt.failwith "unknown table %S in %s.%s" q q name
483
+
| Some f -> (
484
+
match frame_lookup name f with
485
+
| Some v -> v
486
+
| None -> Fmt.failwith "unknown column %s.%s" q name))
487
+
| None -> lookup_unqual name env
488
+
489
+
(* ── Evaluation ──────────────────────────────────────────────── *)
490
+
491
+
let frag cat (tr : table_ref) =
492
+
let alias = Option.value tr.alias ~default:tr.name in
493
+
let cols = cat.columns tr.name in
494
+
(alias, cols)
495
+
496
+
(* An all-NULL environment carrying the FROM tables' column names. It resolves a
497
+
bare column over an EMPTY aggregate group (no rows): the aggregate is still
498
+
folded over zero rows, but a bare column reads as NULL -- as sqlite3 does for
499
+
an aggregate select list (or a HAVING) that names a column on an empty
500
+
table. *)
501
+
let schema_env cat (s : select) : env =
502
+
(* Best-effort: a derived/subquery operand whose columns are not in the base
503
+
catalog is skipped (its bare columns simply stay unresolved, as before). *)
504
+
let frame tr =
505
+
match frag cat tr with
506
+
| alias, cols ->
507
+
Some (Pos (alias, cols, List.map (fun _ -> Null) cols, None))
508
+
| exception Failure _ -> None
509
+
in
510
+
let from_frames =
511
+
match s.from with Table tr -> Option.to_list (frame tr) | _ -> []
512
+
in
513
+
from_frames @ List.filter_map (fun (j : join) -> frame j.table) s.joins
514
+
515
+
(* [max]/[min] are aggregates only in their one-argument form; [max(a,b,...)]
516
+
and [min(a,b,...)] are scalar functions over their arguments. *)
517
+
let is_agg name args =
518
+
match name with
519
+
| "count" | "sum" | "avg" | "total" | "group_concat" | "string_agg" -> true
520
+
| "min" | "max" -> List.length args <= 1
521
+
| _ -> false
522
+
523
+
(* Is [e] an aggregate call, possibly wrapped in FILTER/ORDER BY decorations? *)
524
+
let rec is_agg_expr = function
525
+
| Func (n, a) -> is_agg n a
526
+
| Distinct_agg _ -> true
527
+
| Filter (e, _) | Ordered_agg (e, _) -> is_agg_expr e
528
+
| _ -> false
529
+
530
+
(* Does [e] contain an aggregate of {e this} query anywhere? Unlike
531
+
{!is_agg_expr} this looks inside ordinary sub-expressions ([f(a, max(b))],
532
+
[a + count(c)]) but NOT into a subquery -- an aggregate there is the inner
533
+
query's, so it does not make the enclosing query an aggregate query. *)
534
+
let rec contains_agg = function
535
+
| Func (n, args) -> is_agg n args || List.exists contains_agg args
536
+
| Distinct_agg _ | Filter _ | Ordered_agg _ -> true
537
+
| Binary (_, a, b) | Is (a, b) -> contains_agg a || contains_agg b
538
+
| Unop_not a | Is_null a | Is_not_null a | Cast (a, _) | Collate (a, _) ->
539
+
contains_agg a
540
+
| In_list (a, l) -> contains_agg a || List.exists contains_agg l
541
+
| In_select (a, _) -> contains_agg a
542
+
| Case (base, brs, els) ->
543
+
Option.fold ~none:false ~some:contains_agg base
544
+
|| List.exists (fun (c, r) -> contains_agg c || contains_agg r) brs
545
+
|| Option.fold ~none:false ~some:contains_agg els
546
+
| Window _ | Scalar_select _ | Exists _ | Lit _ | Col _ | Param _ | Star
547
+
| Qualified_star _ ->
548
+
false
549
+
550
+
let is_aggregate (rc : Ast.result_col) = contains_agg rc.expr
551
+
552
+
let dedup rows =
553
+
let seen = Hashtbl.create 64 in
554
+
List.filter
555
+
(fun r ->
556
+
if Hashtbl.mem seen r then false
557
+
else (
558
+
Hashtbl.add seen r ();
559
+
true))
560
+
rows
561
+
562
+
(* DISTINCT keyed by each output column's collation: a text value is reduced to
563
+
its [collate_key] so two rows differing only in case (under NOCASE) or
564
+
trailing spaces (under RTRIM) count as one. [colls] is one entry per output
565
+
column ([None] = the default BINARY). The first row of each class is kept. *)
566
+
let dedup_coll colls rows =
567
+
let key row =
568
+
List.map2
569
+
(fun coll v ->
570
+
match (coll, v) with
571
+
| Some c, Ast.Text s -> collation_key c (Ast.Text s)
572
+
| _ -> v)
573
+
colls row
574
+
in
575
+
let seen = Hashtbl.create 64 in
576
+
List.filter
577
+
(fun r ->
578
+
let k = key r in
579
+
if Hashtbl.mem seen k then false
580
+
else (
581
+
Hashtbl.add seen k ();
582
+
true))
583
+
rows
584
+
585
+
(* DISTINCT over the output [cols]: when a column carries an explicit [COLLATE]
586
+
the dedup honours it ({!dedup_coll}); the common all-binary case (and a [*]
587
+
whose width does not line up with [cols]) takes the plain {!dedup}. *)
588
+
let distinct_dedup cols rows =
589
+
let colls =
590
+
List.map (fun (rc : Ast.result_col) -> explicit_collation rc.expr) cols
591
+
in
592
+
let is_star (rc : Ast.result_col) =
593
+
match rc.expr with Star | Qualified_star _ -> true | _ -> false
594
+
in
595
+
let width_ok =
596
+
match rows with r :: _ -> List.length r = List.length colls | [] -> true
597
+
in
598
+
if
599
+
List.exists is_star cols
600
+
|| (not (List.exists Option.is_some colls))
601
+
|| not width_ok
602
+
then dedup rows
603
+
else dedup_coll colls rows
604
+
605
+
let take n rows =
606
+
let rec go n = function
607
+
| _ when n <= 0 -> []
608
+
| [] -> []
609
+
| x :: rest -> x :: go (n - 1) rest
610
+
in
611
+
go n rows
612
+
613
+
let rec drop n = function
614
+
| rows when n <= 0 -> rows
615
+
| [] -> []
616
+
| _ :: rest -> drop (n - 1) rest
617
+
618
+
(* ── Index access ────────────────────────────────────────────── *)
619
+
620
+
(* Top-level ANDed equalities [col = const] on table alias [alias], with the
621
+
right-hand side resolved to a constant (a literal or a bound parameter).
622
+
These are the predicates an index can drive; anything else is left to the
623
+
row filter. *)
624
+
let collect_eqs params alias where =
625
+
let const = function
626
+
| Lit v -> Some v
627
+
| Param i -> if i < Array.length params then Some params.(i) else None
628
+
| _ -> None
629
+
in
630
+
let here = function None -> true | Some q -> q = alias in
631
+
let rec go acc = function
632
+
| Binary (And, a, b) -> go (go acc a) b
633
+
| Binary (Eq, Col (q, c), rhs) when here q -> (
634
+
match const rhs with Some v -> (c, v) :: acc | None -> acc)
635
+
| Binary (Eq, lhs, Col (q, c)) when here q -> (
636
+
match const lhs with Some v -> (c, v) :: acc | None -> acc)
637
+
| _ -> acc
638
+
in
639
+
match where with None -> [] | Some w -> go [] w
640
+
641
+
(* The columns of [alias] equated to a constant (literal or parameter) at top
642
+
level -- the structural view of {!collect_eqs}, independent of any parameter
643
+
values, used to explain the plan. *)
644
+
let eq_columns alias where =
645
+
let is_const = function Lit _ | Param _ -> true | _ -> false in
646
+
let here = function None -> true | Some q -> q = alias in
647
+
let rec go acc = function
648
+
| Binary (And, a, b) -> go (go acc a) b
649
+
| Binary (Eq, Col (q, c), e) when here q && is_const e -> c :: acc
650
+
| Binary (Eq, e, Col (q, c)) when here q && is_const e -> c :: acc
651
+
| _ -> acc
652
+
in
653
+
match where with None -> [] | Some w -> go [] w
654
+
655
+
(* Does [e] reference table alias [a]? A join's inner table can be looked up by
656
+
index only when the other side of the equality does not. *)
657
+
let rec mentions a = function
658
+
| Col (Some q, _) | Qualified_star q -> q = a
659
+
| Col (None, _) | Lit _ | Param _ | Star -> false
660
+
| Unop_not e | Is_null e | Is_not_null e -> mentions a e
661
+
| Binary (_, x, y) | Is (x, y) -> mentions a x || mentions a y
662
+
| In_list (e, l) -> mentions a e || List.exists (mentions a) l
663
+
| In_select (e, _) -> mentions a e
664
+
| Scalar_select _ | Exists _ -> false
665
+
| Collate (e, _) -> mentions a e
666
+
| Func (_, args) -> List.exists (mentions a) args
667
+
| Distinct_agg (_, e) -> mentions a e
668
+
| Filter (x, p) -> mentions a x || mentions a p
669
+
| Ordered_agg (x, ob) ->
670
+
mentions a x || List.exists (fun (e, _) -> mentions a e) ob
671
+
| Window (x, w) ->
672
+
mentions a x
673
+
|| List.exists (mentions a) w.partition
674
+
|| List.exists (fun (e, _) -> mentions a e) w.order
675
+
| Cast (e, _) -> mentions a e
676
+
| Case (base, branches, els) ->
677
+
Option.fold ~none:false ~some:(mentions a) base
678
+
|| List.exists (fun (c, r) -> mentions a c || mentions a r) branches
679
+
|| Option.fold ~none:false ~some:(mentions a) els
680
+
681
+
(* Columns of the join's inner table [ialias] equated, in [on], to something
682
+
that does not reference the inner table -- the structural view used to
683
+
explain an index-driven join. *)
684
+
let join_eq_columns ialias on =
685
+
let rec go acc = function
686
+
| Binary (And, a, b) -> go (go acc a) b
687
+
| Binary (Eq, Col (Some q, c), e) when q = ialias && not (mentions ialias e)
688
+
->
689
+
c :: acc
690
+
| Binary (Eq, e, Col (Some q, c)) when q = ialias && not (mentions ialias e)
691
+
->
692
+
c :: acc
693
+
| _ -> acc
694
+
in
695
+
go [] on
696
+
697
+
(* The inner column -> outer expression map of a join's ON equalities: like
698
+
{!join_eq_columns} but keeping the other side of each equality, so a hash
699
+
probe key can be precomputed once and only evaluated per outer row. *)
700
+
let join_probe_map ialias on =
701
+
let rec go acc = function
702
+
| Binary (And, a, b) -> go (go acc a) b
703
+
| Binary (Eq, Col (Some q, c), e) when q = ialias && not (mentions ialias e)
704
+
->
705
+
(c, e) :: acc
706
+
| Binary (Eq, e, Col (Some q, c)) when q = ialias && not (mentions ialias e)
707
+
->
708
+
(c, e) :: acc
709
+
| _ -> acc
710
+
in
711
+
go [] on
712
+
713
+
(* Every table alias a join's ON clause references. A join can only run once the
714
+
relations it mentions are already in scope, so this bounds reordering. *)
715
+
let rec on_aliases = function
716
+
| Col (Some q, _) | Qualified_star q -> [ q ]
717
+
| Col (None, _) | Lit _ | Param _ | Star -> []
718
+
| Unop_not e | Is_null e | Is_not_null e | Cast (e, _) -> on_aliases e
719
+
| Binary (_, a, b) | Is (a, b) -> on_aliases a @ on_aliases b
720
+
| In_list (e, l) -> on_aliases e @ List.concat_map on_aliases l
721
+
| In_select (e, _) -> on_aliases e
722
+
| Scalar_select _ | Exists _ -> []
723
+
| Collate (e, _) -> on_aliases e
724
+
| Func (_, args) -> List.concat_map on_aliases args
725
+
| Distinct_agg (_, e) -> on_aliases e
726
+
| Filter (x, p) -> on_aliases x @ on_aliases p
727
+
| Ordered_agg (x, ob) ->
728
+
on_aliases x @ List.concat_map (fun (e, _) -> on_aliases e) ob
729
+
| Window (x, w) ->
730
+
on_aliases x
731
+
@ List.concat_map on_aliases w.partition
732
+
@ List.concat_map (fun (e, _) -> on_aliases e) w.order
733
+
| Case (b, brs, el) ->
734
+
Option.fold ~none:[] ~some:on_aliases b
735
+
@ List.concat_map (fun (c, r) -> on_aliases c @ on_aliases r) brs
736
+
@ Option.fold ~none:[] ~some:on_aliases el
737
+
738
+
let join_alias (j : join) = Option.value j.table.alias ~default:j.table.name
739
+
740
+
(* sqlite3 lets a [WHERE] or [ORDER BY] reference a select-list alias ([SELECT a
741
+
AS x ... WHERE x>1 ORDER BY x] resolves x to a). Substitute each such alias
742
+
with the expression it names, unless a real column of a scanned table shadows
743
+
it (a real column wins). Subqueries are not descended into -- they have their
744
+
own scope. An aggregate alias substituted into WHERE then raises, as sqlite3
745
+
does (an aggregate is not allowed in WHERE). *)
746
+
let resolve_where_aliases cat (s : select) =
747
+
match (s.where, s.order_by) with
748
+
| None, [] -> s
749
+
| _ ->
750
+
let table_cols (tr : table_ref) =
751
+
match tr.subquery with None -> cat.columns tr.name | Some _ -> []
752
+
in
753
+
let real_cols =
754
+
(match s.from with Table tr -> table_cols tr | _ -> [])
755
+
@ List.concat_map (fun (j : join) -> table_cols j.table) s.joins
756
+
in
757
+
let aliases =
758
+
List.filter_map
759
+
(fun (rc : result_col) ->
760
+
match rc.alias with
761
+
| Some a when not (List.mem a real_cols) -> Some (a, rc.expr)
762
+
| _ -> None)
763
+
s.cols
764
+
in
765
+
if aliases = [] then s
766
+
else
767
+
let rec sub e =
768
+
match e with
769
+
| Col (None, name) -> (
770
+
match List.assoc_opt name aliases with Some e' -> e' | None -> e)
771
+
| Binary (op, a, b) -> Binary (op, sub a, sub b)
772
+
| Unop_not a -> Unop_not (sub a)
773
+
| Is_null a -> Is_null (sub a)
774
+
| Is_not_null a -> Is_not_null (sub a)
775
+
| Is (a, b) -> Is (sub a, sub b)
776
+
| In_list (a, l) -> In_list (sub a, List.map sub l)
777
+
| Cast (a, t) -> Cast (sub a, t)
778
+
| Collate (a, c) -> Collate (sub a, c)
779
+
| Func (n, args) -> Func (n, List.map sub args)
780
+
| Case (b, brs, el) ->
781
+
Case
782
+
( Option.map sub b,
783
+
List.map (fun (c, r) -> (sub c, sub r)) brs,
784
+
Option.map sub el )
785
+
| Distinct_agg (n, a) -> Distinct_agg (n, sub a)
786
+
| Filter (a, b) -> Filter (sub a, sub b)
787
+
| Ordered_agg (a, ob) ->
788
+
Ordered_agg (sub a, List.map (fun (e, d) -> (sub e, d)) ob)
789
+
| Lit _ | Col _ | Param _ | Star | Qualified_star _ | In_select _
790
+
| Scalar_select _ | Exists _ | Window _ ->
791
+
e
792
+
in
793
+
{
794
+
s with
795
+
where = Option.map sub s.where;
796
+
order_by = List.map (fun (e, d) -> (sub e, d)) s.order_by;
797
+
}
798
+
799
+
(* Cost-based join ordering (Leis et al., VLDB 2015: join ordering dominates).
800
+
Inner joins commute, so reorder them cheapest-first by an exact-cardinality
801
+
cost model -- an index-covered ON is a lookup (cost 0), otherwise the inner
802
+
table's row count -- subject to each join's ON dependencies being in scope.
803
+
Outer joins are not reorderable, so a query containing one keeps FROM order. *)
804
+
let plan_joins cat from_alias joins =
805
+
if joins = [] || List.exists (fun j -> j.type_ <> Inner || j.natural) joins
806
+
then joins
807
+
else
808
+
let cost j =
809
+
let eq = join_eq_columns (join_alias j) j.on in
810
+
if eq <> [] && cat.index_for j.table.name eq <> None then 0
811
+
else List.length (cat.rows j.table.name)
812
+
in
813
+
let ready avail j =
814
+
List.for_all
815
+
(fun q -> q = join_alias j || List.mem q avail)
816
+
(on_aliases j.on)
817
+
in
818
+
let rec go avail remaining acc =
819
+
match remaining with
820
+
| [] -> List.rev acc
821
+
| _ ->
822
+
let candidates =
823
+
match List.filter (ready avail) remaining with
824
+
| [] -> remaining (* a cross/unsatisfiable join: do not stall *)
825
+
| r -> r
826
+
in
827
+
let best =
828
+
List.fold_left
829
+
(fun b j -> if cost j < cost b then j else b)
830
+
(List.hd candidates) (List.tl candidates)
831
+
in
832
+
go (join_alias best :: avail)
833
+
(List.filter (fun j -> j != best) remaining)
834
+
(best :: acc)
835
+
in
836
+
go [ from_alias ] joins []
837
+
838
+
(* The chosen access path for the [from] table: an index narrowing when one
839
+
covers the equalities, else a full scan. The narrowed rows are still passed
840
+
through the row filter, so the choice is a pure optimisation. *)
841
+
let from_access cat params (tr : table_ref) where =
842
+
let alias = Option.value tr.alias ~default:tr.name in
843
+
match collect_eqs params alias where with
844
+
| [] -> None
845
+
| eqs -> cat.index_scan tr.name eqs
846
+
847
+
(* The output column names of a select, for use as a derived table's columns:
848
+
the explicit alias, else the bare column name, else a positional name. A
849
+
[SELECT *] expands to every column in scope -- the FROM table plus each
850
+
joined table, recursing into a derived (subquery) operand. *)
851
+
let rec select_columns cat s =
852
+
let table_cols (tr : table_ref) =
853
+
match tr.subquery with
854
+
| Some q -> select_columns cat q
855
+
| None -> cat.columns tr.name
856
+
in
857
+
let star_cols () =
858
+
let from_cols =
859
+
match s.from with
860
+
| Unit -> []
861
+
| Table tr -> table_cols tr
862
+
| Select { fs_select; _ } -> select_columns cat fs_select
863
+
| Values (r :: _) -> List.mapi (fun j _ -> Fmt.str "column%d" (j + 1)) r
864
+
| Values [] -> []
865
+
| Table_function { tf_name; _ } -> table_function_columns tf_name
866
+
in
867
+
from_cols @ List.concat_map (fun (j : join) -> table_cols j.table) s.joins
868
+
in
869
+
List.concat
870
+
(List.mapi
871
+
(fun i (rc : result_col) ->
872
+
match rc.expr with
873
+
| Star -> star_cols ()
874
+
| Qualified_star q -> cat.columns q
875
+
| _ -> (
876
+
match rc.alias with
877
+
| Some a -> [ a ]
878
+
| None -> (
879
+
match rc.expr with
880
+
| Col (_, c) -> [ c ]
881
+
| _ -> [ Fmt.str "column%d" (i + 1) ])))
882
+
s.cols)
883
+
884
+
(* The output expressions of [s] in order, expanding [*]/[t.*] to a column
885
+
reference per underlying column. Used to resolve an ORDER BY ordinal to the
886
+
expression of that output column. *)
887
+
let output_exprs cat (s : select) =
888
+
let star () =
889
+
select_columns cat { s with cols = [ { expr = Star; alias = None } ] }
890
+
in
891
+
List.concat_map
892
+
(fun (rc : result_col) ->
893
+
match rc.expr with
894
+
| Star -> List.map (fun c -> Col (None, c)) (star ())
895
+
| Qualified_star q -> List.map (fun c -> Col (Some q, c)) (cat.columns q)
896
+
| e -> [ e ])
897
+
s.cols
898
+
899
+
(* sqlite3 lets ORDER BY and GROUP BY use a 1-based output-column ordinal
900
+
([ORDER BY 2] / [GROUP BY 2] use the second result column). Replace each
901
+
integer-literal key with the expression of that output column, so the normal
902
+
machinery uses it; an out-of-range or non-integer key is left as is. *)
903
+
let resolve_ordinals cat (s : select) =
904
+
if s.order_by = [] && s.group_by = [] then s
905
+
else
906
+
let outs = Array.of_list (output_exprs cat s) in
907
+
let n = Array.length outs in
908
+
(* A 1-based ordinal becomes its output expression; [ORDER BY k COLLATE c]
909
+
parses as a [Collate] around the ordinal, so look through it (the
910
+
collation stays, wrapping the resolved column). *)
911
+
let rec nth = function
912
+
| Lit (Int i) when i >= 1L && Int64.to_int i <= n ->
913
+
outs.(Int64.to_int i - 1)
914
+
| Collate (e, c) -> Collate (nth e, c)
915
+
| e -> e
916
+
in
917
+
(* An ORDER BY key may name an explicit output-column alias; the alias takes
918
+
precedence over an input column (sqlite3), so resolve it to that output
919
+
expression -- this is how [ORDER BY n] reaches an aggregate aliased [n]. *)
920
+
let alias_expr name =
921
+
List.find_map
922
+
(fun (rc : result_col) ->
923
+
match rc.alias with Some a when a = name -> Some rc.expr | _ -> None)
924
+
s.cols
925
+
in
926
+
let rec order_key = function
927
+
| Collate (e, c) -> Collate (order_key e, c)
928
+
| Col (None, name) as e -> (
929
+
match alias_expr name with Some x -> x | None -> nth e)
930
+
| e -> nth e
931
+
in
932
+
{
933
+
s with
934
+
order_by = List.map (fun (e, d) -> (order_key e, d)) s.order_by;
935
+
group_by = List.map nth s.group_by;
936
+
}
937
+
938
+
(* Apply each base-table column's declared COLLATE sequence to the comparisons of
939
+
[s]'s WHERE/ON/HAVING and to its ORDER BY keys, by wrapping the column in an
940
+
explicit [Collate] node -- which the existing collation machinery then honours.
941
+
sqlite3's rule: an explicit COLLATE on either operand wins; otherwise the left
942
+
operand's column collation, else the right's. Only bare columns of a scanned
943
+
base table carry a declared collation (a subquery/derived source has none). *)
944
+
let resolve_collations cat (s : select) =
945
+
let bases =
946
+
let of_ref (tr : table_ref) =
947
+
match tr.subquery with
948
+
| None -> [ (Option.value tr.alias ~default:tr.name, tr.name) ]
949
+
| Some _ -> []
950
+
in
951
+
(match s.from with Table tr -> of_ref tr | _ -> [])
952
+
@ List.concat_map (fun (j : join) -> of_ref j.table) s.joins
953
+
in
954
+
if bases = [] then s
955
+
else
956
+
let col_coll = function
957
+
| Col (Some q, name) -> (
958
+
match List.assoc_opt q bases with
959
+
| Some tbl -> cat.collation tbl name
960
+
| None -> None)
961
+
| Col (None, name) -> (
962
+
(* [cat.columns] raises for a non-base source (a CTE not yet bound on
963
+
this catalog); such a source has no declared collation anyway. *)
964
+
let cols_of tbl = try cat.columns tbl with Failure _ -> [] in
965
+
match
966
+
List.find_opt (fun (_, tbl) -> List.mem name (cols_of tbl)) bases
967
+
with
968
+
| Some (_, tbl) -> cat.collation tbl name
969
+
| None -> None)
970
+
| _ -> None
971
+
in
972
+
let explicit = function Collate _ -> true | _ -> false in
973
+
let is_col = function Col _ -> true | _ -> false in
974
+
(* A comparison's operands with a column's declared collation made explicit:
975
+
an explicit COLLATE wins; else the LEFT column's collation governs, else
976
+
the right's. Only a non-default sequence is wrapped (stays VM-compilable). *)
977
+
let cmp_operands a b =
978
+
if explicit a || explicit b then (a, b)
979
+
else if is_col a then
980
+
match col_coll a with Some c -> (Collate (a, c), b) | None -> (a, b)
981
+
else if is_col b then
982
+
match col_coll b with Some c -> (a, Collate (b, c)) | None -> (a, b)
983
+
else (a, b)
984
+
in
985
+
(* A left operand with its declared collation explicit (for [IN]/ORDER BY). *)
986
+
let lhs_coll e =
987
+
if explicit e then e
988
+
else match col_coll e with Some c -> Collate (e, c) | None -> e
989
+
in
990
+
let rec rw = function
991
+
| Binary (((And | Or) as op), a, b) -> Binary (op, rw a, rw b)
992
+
| Unop_not a -> Unop_not (rw a)
993
+
| Binary (((Eq | Neq | Lt | Le | Gt | Ge) as op), a, b) ->
994
+
let a, b = cmp_operands a b in
995
+
Binary (op, a, b)
996
+
(* [x IN ..] uses the left operand's collation, like [x = ..]. *)
997
+
| In_list (e, l) -> In_list (lhs_coll e, l)
998
+
| In_select (e, sub) -> In_select (lhs_coll e, sub)
999
+
| e -> e
1000
+
in
1001
+
let order_key (e, dir) = (lhs_coll e, dir) in
1002
+
{
1003
+
s with
1004
+
where = Option.map rw s.where;
1005
+
having = Option.map rw s.having;
1006
+
group_by = List.map lhs_coll s.group_by;
1007
+
order_by = List.map order_key s.order_by;
1008
+
joins = List.map (fun (j : join) -> { j with on = rw j.on }) s.joins;
1009
+
}
1010
+
1011
+
(* Does select [s] read from a table named [name] (directly, via a join, a
1012
+
FROM-subquery, or a compound arm)? Used to spot a self-referential CTE. *)
1013
+
let rec references_table name (s : select) =
1014
+
(match s.from with
1015
+
| Unit -> false
1016
+
| Table tr -> tr.name = name
1017
+
| Select { fs_select; _ } -> references_table name fs_select
1018
+
| Values _ | Table_function _ -> false)
1019
+
|| List.exists
1020
+
(fun (j : join) ->
1021
+
j.table.name = name
1022
+
||
1023
+
match j.table.subquery with
1024
+
| Some q -> references_table name q
1025
+
| None -> false)
1026
+
s.joins
1027
+
|| List.exists (fun (_, arm) -> references_table name arm) s.compound
1028
+
1029
+
(* Combine compound arms by their set operator. UNION/EXCEPT/INTERSECT yield
1030
+
distinct rows; UNION ALL keeps duplicates. *)
1031
+
let set_op op left right =
1032
+
match op with
1033
+
| Union_all -> left @ right
1034
+
| Union -> dedup (left @ right)
1035
+
| Except -> dedup (List.filter (fun r -> not (List.mem r right)) left)
1036
+
| Intersect -> dedup (List.filter (fun r -> List.mem r right) left)
1037
+
1038
+
(* ── Evaluation and SELECT execution ─────────────────────────── *)
1039
+
1040
+
(* Pick how to find the inner rows for a join: a full scan, an index lookup, or
1041
+
a hash table keyed on the equijoin columns. *)
1042
+
let join_strategy cat ialias env_of eq_cols (j : Ast.join) =
1043
+
if eq_cols = [] then `Scan
1044
+
else
1045
+
match cat.index_for (j.table : table_ref).name eq_cols with
1046
+
| Some _ -> `Index
1047
+
| None ->
1048
+
let tbl : (value list, value list) Hashtbl.t = Hashtbl.create 256 in
1049
+
List.iter
1050
+
(fun vals ->
1051
+
let row = [ env_of vals ] in
1052
+
let key = List.map (fun c -> lookup row (Some ialias) c) eq_cols in
1053
+
Hashtbl.add tbl key vals)
1054
+
(cat.rows j.table.name);
1055
+
`Hash tbl
1056
+
1057
+
(* Resolve each NATURAL join's implicit ON -- equality on the columns common to
1058
+
the declared-order left and the joined table -- and return, per join in
1059
+
declared order, a triple of: the resolved join, the common columns to drop
1060
+
from its frame (so [SELECT *] lists each common column once), and the left
1061
+
frame template (alias, columns) accumulated before it (used to NULL-pad the
1062
+
left of an unmatched right row in a RIGHT/FULL join). *)
1063
+
let resolve_natural cat base_frame joins =
1064
+
let _, acc =
1065
+
List.fold_left
1066
+
(fun (lframes, acc) (j : Ast.join) ->
1067
+
let ialias, icols = frag cat j.table in
1068
+
let entry =
1069
+
if (not j.natural) && j.using = [] then (j, [], lframes)
1070
+
else
1071
+
let owner c =
1072
+
List.find_map
1073
+
(fun (a, cs) -> if List.mem c cs then Some a else None)
1074
+
lframes
1075
+
in
1076
+
let common =
1077
+
if j.natural then List.filter (fun c -> owner c <> None) icols
1078
+
else j.using
1079
+
in
1080
+
let eqs =
1081
+
List.filter_map
1082
+
(fun c ->
1083
+
Option.map
1084
+
(fun a ->
1085
+
Binary (Eq, Col (Some a, c), Col (Some ialias, c)))
1086
+
(owner c))
1087
+
common
1088
+
in
1089
+
let on =
1090
+
match eqs with
1091
+
| [] -> Lit (Int 1L)
1092
+
| e :: r -> List.fold_left (fun acc x -> Binary (And, acc, x)) e r
1093
+
in
1094
+
({ j with on }, common, lframes)
1095
+
in
1096
+
(lframes @ [ (ialias, icols) ], acc @ [ entry ]))
1097
+
([ base_frame ], []) joins
1098
+
in
1099
+
acc
1100
+
1101
+
(* The distinct [Window] nodes appearing anywhere in [cols] (window functions do
1102
+
not nest, so a Window is not descended into). Pure syntax -- no executor
1103
+
dependencies, so it sits outside the evaluation rec group. *)
1104
+
let window_exprs cols =
1105
+
let acc = ref [] in
1106
+
let rec go e =
1107
+
match e with
1108
+
| Window _ -> if not (List.mem e !acc) then acc := !acc @ [ e ]
1109
+
| Binary (_, a, b) | Filter (a, b) | Is (a, b) ->
1110
+
go a;
1111
+
go b
1112
+
| Unop_not a
1113
+
| Is_null a
1114
+
| Is_not_null a
1115
+
| Cast (a, _)
1116
+
| Distinct_agg (_, a)
1117
+
| Collate (a, _) ->
1118
+
go a
1119
+
| In_list (a, l) ->
1120
+
go a;
1121
+
List.iter go l
1122
+
| Func (_, args) -> List.iter go args
1123
+
| Ordered_agg (a, ob) ->
1124
+
go a;
1125
+
List.iter (fun (e, _) -> go e) ob
1126
+
| Case (b, brs, el) ->
1127
+
Option.iter go b;
1128
+
List.iter
1129
+
(fun (c, r) ->
1130
+
go c;
1131
+
go r)
1132
+
brs;
1133
+
Option.iter go el
1134
+
| In_select _ | Scalar_select _ | Exists _ | Lit _ | Col _ | Param _ | Star
1135
+
| Qualified_star _ ->
1136
+
()
1137
+
in
1138
+
List.iter (fun (rc : Ast.result_col) -> go rc.expr) cols;
1139
+
!acc
1140
+
1141
+
(* Replace every [Window] node in [e] with the literal [lookup] gives for it. *)
1142
+
let rec subst_windows lookup e =
1143
+
let r = subst_windows lookup in
1144
+
match e with
1145
+
| Window _ -> Lit (lookup e)
1146
+
| Binary (op, a, b) -> Binary (op, r a, r b)
1147
+
| Is (a, b) -> Is (r a, r b)
1148
+
| Unop_not a -> Unop_not (r a)
1149
+
| Is_null a -> Is_null (r a)
1150
+
| Is_not_null a -> Is_not_null (r a)
1151
+
| In_list (a, l) -> In_list (r a, List.map r l)
1152
+
| Cast (a, t) -> Cast (r a, t)
1153
+
| Collate (a, c) -> Collate (r a, c)
1154
+
| Func (n, args) -> Func (n, List.map r args)
1155
+
| Case (b, brs, el) ->
1156
+
Case
1157
+
( Option.map r b,
1158
+
List.map (fun (c, x) -> (r c, r x)) brs,
1159
+
Option.map r el )
1160
+
| ( Lit _ | Col _ | Param _ | Star | Qualified_star _ | In_select _
1161
+
| Scalar_select _ | Exists _ | Distinct_agg _ | Filter _ | Ordered_agg _ )
1162
+
as e ->
1163
+
e
1164
+
1165
+
(* The frame [lo, hi] (ordered positions, clamped to the partition) for the row
1166
+
at [pos]: from the explicit ROWS/RANGE clause, else the default frame (whole
1167
+
partition with no ORDER BY, else UNBOUNDED PRECEDING to the current peer
1168
+
group). RANGE offsets are not value-based here; they fall back to the peer
1169
+
group, which agrees with RANGE for distinct order keys. [evcur] evaluates a
1170
+
bound offset against the current row. *)
1171
+
let window_frame ~pos ~k ~peer_start ~peer_end ~evcur w =
1172
+
let off e = Int64.to_int (intify (evcur e)) in
1173
+
let lo, hi =
1174
+
match w.frame with
1175
+
| None -> (0, if w.order = [] then k - 1 else peer_end.(pos))
1176
+
| Some f ->
1177
+
let rows = f.rows in
1178
+
let resolve at_start = function
1179
+
| Unbounded_preceding -> 0
1180
+
| Unbounded_following -> k - 1
1181
+
| Current_row ->
1182
+
if rows then pos
1183
+
else if at_start then peer_start.(pos)
1184
+
else peer_end.(pos)
1185
+
| Preceding e -> if rows then pos - off e else peer_start.(pos)
1186
+
| Following e -> if rows then pos + off e else peer_end.(pos)
1187
+
in
1188
+
(resolve true f.start, resolve false f.end_)
1189
+
in
1190
+
(max 0 lo, min (k - 1) hi)
1191
+
1192
+
(* Wrap [cat] so [name] resolves to the given materialised [cols]/[rows] (no
1193
+
index), shadowing any real table -- the mechanism behind CTEs and derived
1194
+
tables in JOIN position. *)
1195
+
let bind_relation cat name cols rows =
1196
+
{
1197
+
columns = (fun n -> if n = name then cols else cat.columns n);
1198
+
rows = (fun n -> if n = name then rows else cat.rows n);
1199
+
rows_rowid =
1200
+
(fun n ->
1201
+
if n = name then List.map (fun r -> (None, r)) rows
1202
+
else cat.rows_rowid n);
1203
+
index_scan = (fun n eqs -> if n = name then None else cat.index_scan n eqs);
1204
+
index_for = (fun n cs -> if n = name then None else cat.index_for n cs);
1205
+
collation = (fun n c -> if n = name then None else cat.collation n c);
1206
+
}
1207
+
1208
+
let is_col_node = function Col _ -> true | _ -> false
1209
+
1210
+
let subquery_column ?(scope = []) cat params s =
1211
+
!cat_subquery_runner cat scope s params
1212
+
|> List.map (function v :: _ -> v | [] -> Null)
1213
+
1214
+
let rec eval cat params env = function
1215
+
| Lit v -> v
1216
+
| Param i -> if i < Array.length params then params.(i) else Null
1217
+
| Col (q, n) -> lookup env q n
1218
+
| Star | Qualified_star _ -> failwith "'*' is only valid as a select item"
1219
+
| Unop_not e -> not_value (eval cat params env e)
1220
+
| Binary
1221
+
( ((And | Or | Like | Glob | Concat | Json_get | Json_get_text) as op),
1222
+
a,
1223
+
b ) ->
1224
+
binop_value op (eval cat params env a) (eval cat params env b)
1225
+
| Binary
1226
+
( ((Add | Sub | Mul | Div | Mod | Bit_and | Bit_or | Shl | Shr) as op),
1227
+
a,
1228
+
b ) ->
1229
+
arith op (eval cat params env a) (eval cat params env b)
1230
+
| Binary (op, a, b) ->
1231
+
let coll =
1232
+
match explicit_collation a with
1233
+
| Some _ as c -> c
1234
+
| None -> explicit_collation b
1235
+
in
1236
+
let va = eval cat params env a and vb = eval cat params env b in
1237
+
compare_with_affinity ?coll ~a_col:(is_col_node a) ~b_col:(is_col_node b)
1238
+
op va vb
1239
+
| Collate (e, _) -> eval cat params env e
1240
+
| Is_null e -> bool (eval cat params env e = Null)
1241
+
| Is_not_null e -> bool (eval cat params env e <> Null)
1242
+
| Is (a, b) -> is_value (eval cat params env a) (eval cat params env b)
1243
+
| In_list (e, l) ->
1244
+
let v = eval cat params env e in
1245
+
let cands = List.map (eval cat params env) l in
1246
+
(* The membership test uses the left operand's collation (a declared
1247
+
COLLATE made explicit by [resolve_collations]) and its affinity: a
1248
+
numeric column coerces a well-formed text candidate ([c0 IN ('2.0625')]
1249
+
matches) while a literal left keeps its value ([5 IN ('5')] mismatches).
1250
+
[bare] sees through a declared-collation wrapper to the column for the
1251
+
affinity rule, but not through a [BINARY] one -- that is unary plus,
1252
+
which strips affinity. *)
1253
+
let coll = explicit_collation e in
1254
+
let bare =
1255
+
match e with Collate (inner, c) when c <> "BINARY" -> inner | _ -> e
1256
+
in
1257
+
in_list_value ?coll ~e_col:(is_col_node bare) v cands
1258
+
| In_select (e, s) ->
1259
+
(* The subquery sees the current row as its outer scope, so a correlated
1260
+
[IN (SELECT ... WHERE inner.x = outer.y)] resolves [outer.y]. *)
1261
+
let scope = bindings_of_frames env in
1262
+
in_eval (eval cat params env e) (subquery_column ~scope cat params s)
1263
+
| Scalar_select s -> (
1264
+
(* A scalar subquery yields the first column of its first row (NULL if it
1265
+
returns none). Correlated via the same outer [env] scope. *)
1266
+
match !cat_subquery_runner cat (bindings_of_frames env) s params with
1267
+
| (v :: _) :: _ -> v
1268
+
| [] :: _ | [] -> Null)
1269
+
| Exists s ->
1270
+
bool
1271
+
(match !cat_subquery_runner cat (bindings_of_frames env) s params with
1272
+
| _ :: _ -> true
1273
+
| [] -> false)
1274
+
(* Aggregates are computed by {!aggregate} over the whole group; reaching one
1275
+
here means it was used as a scalar (in WHERE, ON, or ORDER BY). *)
1276
+
| Func (name, args) when is_agg name args ->
1277
+
Fmt.failwith
1278
+
"%s() is an aggregate function and is only valid as a select item, not \
1279
+
in WHERE, ON, or ORDER BY"
1280
+
name
1281
+
| Distinct_agg (name, _) ->
1282
+
Fmt.failwith
1283
+
"%s() is an aggregate function and is only valid as a select item, not \
1284
+
in WHERE, ON, or ORDER BY"
1285
+
name
1286
+
| Filter _ | Ordered_agg _ ->
1287
+
failwith
1288
+
"an aggregate FILTER/ORDER BY is only valid as a select item, not in \
1289
+
WHERE, ON, or ORDER BY"
1290
+
| Window _ ->
1291
+
failwith
1292
+
"a window function is only valid in the select list, not in WHERE, ON, \
1293
+
or GROUP BY"
1294
+
(* iif(C, T, F) is sugar for CASE and short-circuits, so it is evaluated
1295
+
before its branches rather than as an ordinary (eager-argument) function. *)
1296
+
| Func ("iif", [ c; t; f ]) ->
1297
+
if tri_of (eval cat params env c) = T then eval cat params env t
1298
+
else eval cat params env f
1299
+
| Func (name, args) -> apply name (List.map (eval cat params env) args)
1300
+
| Cast (e, ty) -> cast ty (eval cat params env e)
1301
+
(* CASE: the base (simple form) is evaluated once and matched with [=]
1302
+
semantics, so a NULL base matches no WHEN -- including WHEN NULL. First
1303
+
match wins; no match and no ELSE is NULL. *)
1304
+
| Case (base, branches, els) ->
1305
+
let bv = Option.map (eval cat params env) base in
1306
+
let hit cond =
1307
+
match bv with
1308
+
| Some b -> compare_op Eq b (eval cat params env cond) = Int 1L
1309
+
| None -> tri_of (eval cat params env cond) = T
1310
+
in
1311
+
let rec go = function
1312
+
| (c, r) :: rest -> if hit c then eval cat params env r else go rest
1313
+
| [] -> (
1314
+
match els with Some e -> eval cat params env e | None -> Null)
1315
+
in
1316
+
go branches
1317
+
1318
+
(* Inner-table equalities [col = e] in a join's ON clause where [e], evaluated
1319
+
against the current outer row, gives a concrete value -- the bindings that
1320
+
drive an index-nested-loop join. *)
1321
+
let join_eqs cat params env ialias on =
1322
+
let rec go acc = function
1323
+
| Binary (And, a, b) -> go (go acc a) b
1324
+
| Binary (Eq, Col (Some q, c), e) when q = ialias && not (mentions ialias e)
1325
+
->
1326
+
(c, eval cat params env e) :: acc
1327
+
| Binary (Eq, e, Col (Some q, c)) when q = ialias && not (mentions ialias e)
1328
+
->
1329
+
(c, eval cat params env e) :: acc
1330
+
| _ -> acc
1331
+
in
1332
+
go [] on
1333
+
1334
+
(* RIGHT/FULL OUTER: the inner table's unmatched rows must also survive, so the
1335
+
left stream is materialised and every inner row is scanned for any match.
1336
+
FULL additionally keeps unmatched left rows (NULL inner), like LEFT. The
1337
+
emission order is not specified by SQL; callers that care add ORDER BY. *)
1338
+
let right_full_join cat params (j : Ast.join) envs ~env_of ~trim ~null_frame
1339
+
~left_template =
1340
+
let lefts = envs in
1341
+
let inners = Array.of_list (cat.rows j.table.name) in
1342
+
let hit = Array.make (Array.length inners) false in
1343
+
let null_left =
1344
+
match lefts with
1345
+
| e :: _ -> List.map null_pad_frame e
1346
+
| [] ->
1347
+
List.map
1348
+
(fun (a, cs) -> Pos (a, cs, List.map (fun _ -> Null) cs, None))
1349
+
left_template
1350
+
in
1351
+
let out = ref [] in
1352
+
List.iter
1353
+
(fun env ->
1354
+
let any = ref false in
1355
+
Array.iteri
1356
+
(fun k vals ->
1357
+
match tri_of (eval cat params (env @ [ env_of vals ]) j.on) with
1358
+
| T ->
1359
+
any := true;
1360
+
hit.(k) <- true;
1361
+
out := (env @ [ trim (env_of vals) ]) :: !out
1362
+
| F | U -> ())
1363
+
inners;
1364
+
if (not !any) && j.type_ = Full then out := (env @ [ null_frame ]) :: !out)
1365
+
lefts;
1366
+
Array.iteri
1367
+
(fun k vals ->
1368
+
if not hit.(k) then out := (null_left @ [ trim (env_of vals) ]) :: !out)
1369
+
inners;
1370
+
List.rev !out
1371
+
1372
+
(* Add one joined table to the running row stream, picking the access strategy
1373
+
once for the whole join (not per outer row):
1374
+
- index-nested-loop when a unique index covers the ON equi-columns;
1375
+
- hash join when the ON has equi-columns but no index: build a hash table on
1376
+
the inner relation keyed by those columns once, then probe per outer row
1377
+
(O(inner + outer) instead of the O(inner x outer) nested-loop);
1378
+
- plain nested-loop scan otherwise (no equi-column, e.g. a cross join).
1379
+
The full ON predicate is always re-checked, so the strategy only narrows
1380
+
candidates and NULL keys (which never equi-match) fall out. *)
1381
+
let join_with ?(drop = []) ?(left_template = []) cat params (j : Ast.join) envs
1382
+
=
1383
+
let ialias, icols = frag cat j.table in
1384
+
let env_of vals = Pos (ialias, icols, vals, None) in
1385
+
(* A NATURAL join lists each common column once: the ON is evaluated on the
1386
+
full inner frame, but [drop]ped columns are removed from the frame stored
1387
+
in the row (they survive on the left and are equal there). With nothing to
1388
+
drop (the common non-NATURAL case) this is the identity, avoiding a per-row
1389
+
copy of the frame. *)
1390
+
let trim = if drop = [] then Fun.id else trim_frame drop in
1391
+
(* A LEFT JOIN keeps an outer row that matched nothing, with the inner table's
1392
+
columns all NULL. *)
1393
+
let null_frame =
1394
+
trim (Pos (ialias, icols, List.map (fun _ -> Null) icols, None))
1395
+
in
1396
+
let eq_cols = join_eq_columns ialias j.on in
1397
+
let strategy = join_strategy cat ialias env_of eq_cols j in
1398
+
(* The hash probe key as expressions over the outer row, resolved once (in
1399
+
[eq_cols] order) so each outer row only evaluates them -- no per-row
1400
+
[(col,value)] list rebuilt and re-looked-up. *)
1401
+
let probe_exprs =
1402
+
match strategy with
1403
+
| `Hash _ ->
1404
+
let m = join_probe_map ialias j.on in
1405
+
List.map (fun c -> List.assoc c m) eq_cols
1406
+
| _ -> []
1407
+
in
1408
+
let candidates env =
1409
+
match strategy with
1410
+
| `Scan -> cat.rows j.table.name
1411
+
| `Index -> (
1412
+
match
1413
+
cat.index_scan j.table.name (join_eqs cat params env ialias j.on)
1414
+
with
1415
+
| Some (_, rows) -> rows
1416
+
| None -> cat.rows j.table.name)
1417
+
| `Hash tbl ->
1418
+
let key = List.map (eval cat params env) probe_exprs in
1419
+
Hashtbl.find_all tbl key
1420
+
in
1421
+
let matched env =
1422
+
List.filter_map
1423
+
(fun vals ->
1424
+
(* Build the inner frame once and reuse it for both the ON test and the
1425
+
emitted row. *)
1426
+
let frame = env_of vals in
1427
+
match tri_of (eval cat params (env @ [ frame ]) j.on) with
1428
+
| T -> Some (env @ [ trim frame ])
1429
+
| F | U -> None)
1430
+
(candidates env)
1431
+
in
1432
+
match j.type_ with
1433
+
| Inner -> List.concat_map matched envs
1434
+
| Left ->
1435
+
List.concat_map
1436
+
(fun env ->
1437
+
match matched env with [] -> [ env @ [ null_frame ] ] | rows -> rows)
1438
+
envs
1439
+
| Right | Full ->
1440
+
right_full_join cat params j envs ~env_of ~trim ~null_frame ~left_template
1441
+
1442
+
let project cat params (s : Ast.select) env =
1443
+
(* A star-free select list (the common case) maps one value per item -- no
1444
+
per-item singleton list and no [concat_map] to flatten. Only [*] and [t.*],
1445
+
which expand to a whole frame, need the general path. *)
1446
+
let is_star (rc : Ast.result_col) =
1447
+
match rc.expr with Star | Qualified_star _ -> true | _ -> false
1448
+
in
1449
+
if List.exists is_star s.cols then
1450
+
List.concat_map
1451
+
(fun (rc : Ast.result_col) ->
1452
+
match rc.expr with
1453
+
| Star -> List.concat_map frame_values env
1454
+
| Qualified_star q -> (
1455
+
match aliased_ci (String.uppercase_ascii q) env with
1456
+
| Some f -> frame_values f
1457
+
| None -> Fmt.failwith "no such table: %s" q)
1458
+
| e -> [ eval cat params env e ])
1459
+
s.cols
1460
+
else
1461
+
List.map (fun (rc : Ast.result_col) -> eval cat params env rc.expr) s.cols
1462
+
1463
+
(* Fold one aggregate call over the group [envs]. With [distinct], the non-NULL
1464
+
argument values are deduplicated (preserving first-seen order) before the
1465
+
fold -- [count(DISTINCT x)], [sum(DISTINCT x)], etc. *)
1466
+
let agg_call ?(distinct = false) cat params envs name args =
1467
+
let arg1 = function [ a ] -> a | _ -> Star in
1468
+
let dedup vs = if distinct then distinct_values vs else vs in
1469
+
let agg_vals arg =
1470
+
dedup
1471
+
(List.filter_map
1472
+
(fun env ->
1473
+
match eval cat params env arg with Null -> None | v -> Some v)
1474
+
envs)
1475
+
in
1476
+
match (name, args) with
1477
+
| "count", args -> (
1478
+
match arg1 args with
1479
+
| Star -> Int (Int64.of_int (List.length envs))
1480
+
| a -> Int (Int64.of_int (List.length (agg_vals a))))
1481
+
| ("group_concat" | "string_agg"), args -> (
1482
+
(* group_concat(X [, sep]) / string_agg(X, sep): non-NULL X values joined
1483
+
by sep (default ","); NULL over an empty group. *)
1484
+
let arg, sep =
1485
+
match args with
1486
+
| [ a ] -> (a, ",")
1487
+
| a :: s :: _ ->
1488
+
( a,
1489
+
match envs with
1490
+
| env :: _ -> text_of_value (eval cat params env s)
1491
+
| [] -> "," )
1492
+
| [] -> (Star, ",")
1493
+
in
1494
+
match agg_vals arg with
1495
+
| [] -> Null
1496
+
| vals -> Text (String.concat sep (List.map text_of_value vals)))
1497
+
| _ -> numeric_agg name (agg_vals (arg1 args))
1498
+
1499
+
(* Evaluate one expression over a group [envs] with aggregate semantics: every
1500
+
aggregate call (even nested in a larger expression, e.g. [sum(x) > 5]) is
1501
+
folded over the group and substituted by its value; the rest is then read
1502
+
from an arbitrary row of the group. Used for select-list columns and HAVING. *)
1503
+
let agg_value ?(empty = []) ?rep cat params envs e =
1504
+
(* FILTER (WHERE p) restricts the group rows; ORDER BY sorts them (only
1505
+
order-sensitive aggregates like group_concat observe the order). *)
1506
+
let filtered p envs =
1507
+
List.filter (fun env -> tri_of (eval cat params env p) = T) envs
1508
+
in
1509
+
let sorted ob envs =
1510
+
let rec cmp a b = function
1511
+
| [] -> 0
1512
+
| (e, dir) :: rest ->
1513
+
let c = compare_values (eval cat params a e) (eval cat params b e) in
1514
+
let c = match dir with Asc -> c | Desc -> -c in
1515
+
if c <> 0 then c else cmp a b rest
1516
+
in
1517
+
List.stable_sort (fun a b -> cmp a b ob) envs
1518
+
in
1519
+
(* Compute an aggregate expression's value over [envs], peeling FILTER/ORDER
1520
+
BY decorations down to the core Func / Distinct_agg call. *)
1521
+
let rec agg_core envs = function
1522
+
| Func (name, args) -> agg_call ~distinct:false cat params envs name args
1523
+
| Distinct_agg (name, arg) ->
1524
+
agg_call ~distinct:true cat params envs name [ arg ]
1525
+
| Filter (inner, p) -> agg_core (filtered p envs) inner
1526
+
| Ordered_agg (inner, ob) -> agg_core (sorted ob envs) inner
1527
+
| _ -> Null
1528
+
in
1529
+
let rec subst e =
1530
+
match e with
1531
+
| e when is_agg_expr e -> Lit (agg_core envs e)
1532
+
| Unop_not a -> Unop_not (subst a)
1533
+
| Binary (op, a, b) -> Binary (op, subst a, subst b)
1534
+
| Is (a, b) -> Is (subst a, subst b)
1535
+
| Is_null a -> Is_null (subst a)
1536
+
| Is_not_null a -> Is_not_null (subst a)
1537
+
| In_list (a, l) -> In_list (subst a, List.map subst l)
1538
+
| Cast (a, ty) -> Cast (subst a, ty)
1539
+
| Collate (a, c) -> Collate (subst a, c)
1540
+
| Case (base, branches, els) ->
1541
+
Case
1542
+
( Option.map subst base,
1543
+
List.map (fun (c, r) -> (subst c, subst r)) branches,
1544
+
Option.map subst els )
1545
+
(* Recurse into a non-aggregate function's args for a nested aggregate. *)
1546
+
| Func (n, args) -> Func (n, List.map subst args)
1547
+
| (Lit _ | Col _ | Param _ | Star | Qualified_star _ | In_select _) as e ->
1548
+
e
1549
+
| (Scalar_select _ | Exists _) as e -> e
1550
+
| (Distinct_agg _ | Filter _ | Ordered_agg _ | Window _) as e -> e
1551
+
in
1552
+
let e = subst e in
1553
+
(* Bare columns: from [rep] (the min/max row), else an arbitrary or empty row. *)
1554
+
let row =
1555
+
match rep with
1556
+
| Some r -> r
1557
+
| None -> ( match envs with e :: _ -> e | [] -> empty)
1558
+
in
1559
+
eval cat params row e
1560
+
1561
+
let aggregate ?(empty = []) ?rep cat params (s : Ast.select) envs =
1562
+
(* [*] in a grouped/aggregated select expands to the columns of the group's
1563
+
representative row (the min/max row when one is chosen, else an arbitrary
1564
+
member), just as a bare column does. *)
1565
+
let rep_row () =
1566
+
match rep with
1567
+
| Some r -> r
1568
+
| None -> ( match envs with e :: _ -> e | [] -> empty)
1569
+
in
1570
+
let has_star =
1571
+
List.exists
1572
+
(fun (rc : Ast.result_col) ->
1573
+
match rc.expr with Star | Qualified_star _ -> true | _ -> false)
1574
+
s.cols
1575
+
in
1576
+
if not has_star then
1577
+
List.map
1578
+
(fun (rc : Ast.result_col) ->
1579
+
agg_value ~empty ?rep cat params envs rc.expr)
1580
+
s.cols
1581
+
else
1582
+
List.concat_map
1583
+
(fun (rc : Ast.result_col) ->
1584
+
match rc.expr with
1585
+
| Star -> List.concat_map frame_values (rep_row ())
1586
+
| Qualified_star q -> (
1587
+
match aliased_ci (String.uppercase_ascii q) (rep_row ()) with
1588
+
| Some f -> frame_values f
1589
+
| None -> Fmt.failwith "no such table: %s" q)
1590
+
| e -> [ agg_value ~empty ?rep cat params envs e ])
1591
+
s.cols
1592
+
1593
+
(* The representative row for bare (non-aggregate) columns: sqlite3 takes them
1594
+
from the row achieving a lone [min()]/[max()] in the select list (NULLs are
1595
+
ignored, as by the aggregate). [None] when there is no such aggregate, so the
1596
+
caller uses an arbitrary row. *)
1597
+
let minmax_rep cat params (s : select) envs =
1598
+
let target =
1599
+
List.find_map
1600
+
(fun (rc : Ast.result_col) ->
1601
+
match rc.expr with
1602
+
| Func ("min", [ a ]) -> Some (`Min, a)
1603
+
| Func ("max", [ a ]) -> Some (`Max, a)
1604
+
| _ -> None)
1605
+
s.cols
1606
+
in
1607
+
match (target, envs) with
1608
+
| None, _ | _, [] -> None
1609
+
| Some (dir, arg), e0 :: rest ->
1610
+
let better cur env =
1611
+
let cv = eval cat params cur arg and ev = eval cat params env arg in
1612
+
if ev = Null then false
1613
+
else if cv = Null then true
1614
+
else
1615
+
let c = compare_values ev cv in
1616
+
match dir with `Min -> c < 0 | `Max -> c > 0
1617
+
in
1618
+
Some
1619
+
(List.fold_left
1620
+
(fun best env -> if better best env then env else best)
1621
+
e0 rest)
1622
+
1623
+
let order_cmp cat params order_by e1 e2 =
1624
+
let rec cmp = function
1625
+
| [] -> 0
1626
+
| (oe, dir) :: rest ->
1627
+
let va = eval cat params e1 oe and vb = eval cat params e2 oe in
1628
+
let c =
1629
+
match explicit_collation oe with
1630
+
| Some name -> compare_values_coll name va vb
1631
+
| None -> compare_values va vb
1632
+
in
1633
+
let c = match dir with Asc -> c | Desc -> -c in
1634
+
if c <> 0 then c else cmp rest
1635
+
in
1636
+
cmp order_by
1637
+
1638
+
let order cat params s envs =
1639
+
if s.order_by = [] then envs
1640
+
else List.stable_sort (order_cmp cat params s.order_by) envs
1641
+
1642
+
(* Partition rows into groups by the GROUP BY key tuple, keeping the groups in
1643
+
first-appearance order; each group is the list of its rows. *)
1644
+
let group_envs cat params keys envs =
1645
+
(* Two rows fall in the same group when their key values are equal under the
1646
+
key's collation: a NOCASE GROUP BY key folds case. [resolve_collations] has
1647
+
already made a column's declared collation explicit, so a non-default
1648
+
sequence shows up as a [Collate] wrapper. *)
1649
+
let group_key env =
1650
+
List.map
1651
+
(fun e ->
1652
+
match (explicit_collation e, eval cat params env e) with
1653
+
| Some c, Text s -> collation_key c (Text s)
1654
+
| _, v -> v)
1655
+
keys
1656
+
in
1657
+
let tbl = Hashtbl.create 16 in
1658
+
let seen = ref [] in
1659
+
List.iter
1660
+
(fun env ->
1661
+
let k = group_key env in
1662
+
match Hashtbl.find_opt tbl k with
1663
+
| Some r -> r := env :: !r
1664
+
| None ->
1665
+
Hashtbl.add tbl k (ref [ env ]);
1666
+
seen := k :: !seen)
1667
+
envs;
1668
+
List.rev_map (fun k -> List.rev !(Hashtbl.find tbl k)) !seen
1669
+
1670
+
(* One row's window value: ranking from its position, navigation/aggregate over
1671
+
the frame [lo, hi] (ordered positions). [at i e] evaluates [e] at the i-th
1672
+
ordered row. *)
1673
+
let window_value cat params ~name ~args ~distinct ~envs_a ~oa ~peer_start ~k
1674
+
~dense ~pos ~lo ~hi =
1675
+
let at i e = eval cat params envs_a.(oa.(i)) e in
1676
+
let evcur e = eval cat params envs_a.(oa.(pos)) e in
1677
+
match name with
1678
+
| "row_number" -> Int (Int64.of_int (pos + 1))
1679
+
| "rank" -> Int (Int64.of_int (peer_start.(pos) + 1))
1680
+
| "dense_rank" -> Int (Int64.of_int dense)
1681
+
| "first_value" -> if lo <= hi then at lo (List.hd args) else Null
1682
+
| "last_value" -> if lo <= hi then at hi (List.hd args) else Null
1683
+
| "lag" | "lead" ->
1684
+
let off =
1685
+
match List.nth_opt args 1 with
1686
+
| Some o -> Int64.to_int (intify (evcur o))
1687
+
| None -> 1
1688
+
in
1689
+
let dflt =
1690
+
match List.nth_opt args 2 with Some d -> evcur d | None -> Null
1691
+
in
1692
+
let t = if name = "lag" then pos - off else pos + off in
1693
+
if t >= 0 && t < k then at t (List.hd args) else dflt
1694
+
| "nth_value" ->
1695
+
let nn = Int64.to_int (intify (evcur (List.nth args 1))) in
1696
+
let t = lo + (nn - 1) in
1697
+
if nn >= 1 && t <= hi then at t (List.hd args) else Null
1698
+
| "ntile" ->
1699
+
let nb = max 1 (Int64.to_int (intify (evcur (List.hd args)))) in
1700
+
let base = k / nb and rem = k mod nb in
1701
+
let big = rem * (base + 1) in
1702
+
let b =
1703
+
if pos < big then pos / (base + 1) else rem + ((pos - big) / base)
1704
+
in
1705
+
Int (Int64.of_int (b + 1))
1706
+
| _ ->
1707
+
let frame =
1708
+
if lo > hi then []
1709
+
else List.init (hi - lo + 1) (fun r -> envs_a.(oa.(lo + r)))
1710
+
in
1711
+
agg_call ~distinct cat params frame name args
1712
+
1713
+
(* Compute one partition's window values into [arr]: order [idxs] by the
1714
+
window's ORDER BY, find peer-group bounds (peers share a rank and a frame),
1715
+
and write each row's value (ranking by position, aggregate over its frame). *)
1716
+
let fill_window_partition cat params ~name ~args ~distinct w envs_a arr idxs =
1717
+
let oa =
1718
+
Array.of_list
1719
+
(List.stable_sort
1720
+
(fun i j -> order_cmp cat params w.order envs_a.(i) envs_a.(j))
1721
+
idxs)
1722
+
in
1723
+
let k = Array.length oa in
1724
+
let peer_start = Array.make k 0 and peer_end = Array.make k 0 in
1725
+
let p = ref 0 in
1726
+
while !p < k do
1727
+
let q = ref !p in
1728
+
while
1729
+
!q + 1 < k
1730
+
&& order_cmp cat params w.order envs_a.(oa.(!p)) envs_a.(oa.(!q + 1)) = 0
1731
+
do
1732
+
incr q
1733
+
done;
1734
+
for r = !p to !q do
1735
+
peer_start.(r) <- !p;
1736
+
peer_end.(r) <- !q
1737
+
done;
1738
+
p := !q + 1
1739
+
done;
1740
+
let dense = ref 0 and prev_start = ref (-1) in
1741
+
for pos = 0 to k - 1 do
1742
+
if peer_start.(pos) <> !prev_start then begin
1743
+
incr dense;
1744
+
prev_start := peer_start.(pos)
1745
+
end;
1746
+
let evcur e = eval cat params envs_a.(oa.(pos)) e in
1747
+
let lo, hi = window_frame ~pos ~k ~peer_start ~peer_end ~evcur w in
1748
+
arr.(oa.(pos)) <-
1749
+
window_value cat params ~name ~args ~distinct ~envs_a ~oa ~peer_start ~k
1750
+
~dense:!dense ~pos ~lo ~hi
1751
+
done
1752
+
1753
+
(* Evaluate the window function [Window (f, w)] over [envs], returning a value
1754
+
per env (aligned to [envs] order). Rows are partitioned by [w.partition],
1755
+
ordered within each partition by [w.order]; ranking functions use the
1756
+
position, aggregates use the default frame (the whole partition with no
1757
+
ORDER BY, else running through the current row's peer group). *)
1758
+
let eval_window cat params we envs =
1759
+
let fexpr, w = match we with Window (f, w) -> (f, w) | _ -> assert false in
1760
+
let name, args, distinct =
1761
+
match fexpr with
1762
+
| Func (n, a) -> (n, a, false)
1763
+
| Distinct_agg (n, a) -> (n, [ a ], true)
1764
+
| _ -> failwith "window: not a function call"
1765
+
in
1766
+
let envs_a = Array.of_list envs in
1767
+
let n = Array.length envs_a in
1768
+
let arr = Array.make n Null in
1769
+
(* partition the row indices by the partition-key tuple *)
1770
+
let tbl = Hashtbl.create 16 and keys = ref [] in
1771
+
Array.iteri
1772
+
(fun i env ->
1773
+
let k = List.map (eval cat params env) w.partition in
1774
+
match Hashtbl.find_opt tbl k with
1775
+
| Some r -> r := i :: !r
1776
+
| None ->
1777
+
Hashtbl.add tbl k (ref [ i ]);
1778
+
keys := k :: !keys)
1779
+
envs_a;
1780
+
let parts = List.rev_map (fun k -> List.rev !(Hashtbl.find tbl k)) !keys in
1781
+
List.iter
1782
+
(fun idxs ->
1783
+
fill_window_partition cat params ~name ~args ~distinct w envs_a arr idxs)
1784
+
parts;
1785
+
arr
1786
+
1787
+
(* Project [envs] when the select list has window functions: compute each window
1788
+
value per env, then project, substituting the windows. The outer ORDER BY
1789
+
sorts after the windows are computed (their frames are independent of it). *)
1790
+
let window_project ~ordered cat params (s : Ast.select) envs =
1791
+
let wins =
1792
+
List.map
1793
+
(fun we -> (we, eval_window cat params we envs))
1794
+
(window_exprs s.cols)
1795
+
in
1796
+
let indexed = List.mapi (fun i env -> (i, env)) envs in
1797
+
let indexed =
1798
+
if ordered then
1799
+
List.stable_sort
1800
+
(fun (_, e1) (_, e2) -> order_cmp cat params s.order_by e1 e2)
1801
+
indexed
1802
+
else indexed
1803
+
in
1804
+
List.map
1805
+
(fun (i, env) ->
1806
+
let lookup we = (List.assoc we wins).(i) in
1807
+
List.concat_map
1808
+
(fun (rc : Ast.result_col) ->
1809
+
match rc.expr with
1810
+
| Star -> List.concat_map frame_values env
1811
+
| Qualified_star q -> (
1812
+
match aliased_ci (String.uppercase_ascii q) env with
1813
+
| Some f -> frame_values f
1814
+
| None -> Fmt.failwith "no such table: %s" q)
1815
+
| e -> [ eval cat params env (subst_windows lookup e) ])
1816
+
s.cols)
1817
+
indexed
1818
+
1819
+
(* Run one SELECT/VALUES core to output rows: combine, filter, group/aggregate
1820
+
or project, distinct. [~order] applies the core's own ORDER BY (true for a
1821
+
plain select; false for a compound's cores, whose ordering is the
1822
+
compound-wide ORDER BY applied to the combined rows). *)
1823
+
(* Turn the WHERE-filtered row environments [envs] into output rows: a GROUP BY
1824
+
folds each group's aggregates (ordering the groups when [ordered]); an
1825
+
aggregate select list or HAVING with no GROUP BY is one implicit group; a
1826
+
window select projects through {!window_project}; otherwise it is an ordinary
1827
+
sort-and-project. Shared by {!exec_core} (which scans the table) and
1828
+
{!aggregate_scan} (which is handed already-scanned rows). *)
1829
+
let core_rows ~ordered cat params s envs =
1830
+
(* The all-NULL schema env for an empty implicit group (an empty table with no
1831
+
GROUP BY), so a bare column in HAVING/the select list reads as NULL. *)
1832
+
let empty = schema_env cat s in
1833
+
(* HAVING keeps a group only when its (aggregate) predicate is true; a NULL
1834
+
result is untrue and drops the group. *)
1835
+
let keep_group g =
1836
+
match s.having with
1837
+
| None -> true
1838
+
| Some h -> tri_of (agg_value ~empty cat params g h) = T
1839
+
in
1840
+
if s.group_by <> [] then
1841
+
let groups = group_envs cat params s.group_by envs in
1842
+
let groups =
1843
+
if not ordered then groups
1844
+
(* a compound arm: combine_compound re-orders, so leave first-seen *)
1845
+
else
1846
+
(* sqlite3 emits GROUP BY result rows in the group key's ascending order
1847
+
when there is no ORDER BY; an explicit ORDER BY overrides it. *)
1848
+
let keys =
1849
+
if s.order_by <> [] then s.order_by
1850
+
else List.map (fun e -> (e, Asc)) s.group_by
1851
+
in
1852
+
List.stable_sort
1853
+
(fun g1 g2 -> order_cmp cat params keys (List.hd g1) (List.hd g2))
1854
+
groups
1855
+
in
1856
+
List.filter_map
1857
+
(fun g ->
1858
+
let rep = minmax_rep cat params s g in
1859
+
if keep_group g then Some (aggregate ?rep cat params s g) else None)
1860
+
groups
1861
+
else if List.exists is_aggregate s.cols || s.having <> None then
1862
+
(* No GROUP BY but an aggregate select list or a HAVING clause: the whole
1863
+
input is one implicit group (lang_select.html). *)
1864
+
let rep = minmax_rep cat params s envs in
1865
+
if keep_group envs then [ aggregate ~empty ?rep cat params s envs ] else []
1866
+
else if window_exprs s.cols <> [] then
1867
+
window_project ~ordered cat params s envs
1868
+
else
1869
+
let envs = if ordered then order cat params s envs else envs in
1870
+
List.map (project cat params s) envs
1871
+
1872
+
(* ORDER BY over a compound's output rows: a bare integer is an ordinal (1-based
1873
+
output column), a bare name is an output column, anything else is evaluated
1874
+
against the row keyed by the output column names. *)
1875
+
let compound_order cat params names order_by rows =
1876
+
if order_by = [] then rows
1877
+
else
1878
+
let nth row i = Option.value (List.nth_opt row i) ~default:Null in
1879
+
let col_index name =
1880
+
let rec go i = function
1881
+
| [] -> None
1882
+
| x :: _ when x = name -> Some i
1883
+
| _ :: r -> go (i + 1) r
1884
+
in
1885
+
go 0 names
1886
+
in
1887
+
(* [ORDER BY k COLLATE c] wraps the ordinal in [Collate]; the collation is
1888
+
read by [cmp] below, so here just look through it to the key itself. *)
1889
+
let rec key row oe =
1890
+
match oe with
1891
+
| Lit (Int n) -> nth row (Int64.to_int n - 1)
1892
+
| Col (_, name) -> (
1893
+
match col_index name with Some i -> nth row i | None -> Null)
1894
+
| Collate (e, _) -> key row e
1895
+
| _ -> eval cat params [ Pos ("", names, row, None) ] oe
1896
+
in
1897
+
List.stable_sort
1898
+
(fun r1 r2 ->
1899
+
let rec cmp = function
1900
+
| [] -> 0
1901
+
| (oe, dir) :: rest ->
1902
+
let c =
1903
+
match explicit_collation oe with
1904
+
| Some name -> compare_values_coll name (key r1 oe) (key r2 oe)
1905
+
| None -> compare_values (key r1 oe) (key r2 oe)
1906
+
in
1907
+
let c = match dir with Asc -> c | Desc -> -c in
1908
+
if c <> 0 then c else cmp rest
1909
+
in
1910
+
cmp order_by)
1911
+
rows
1912
+
1913
+
let apply_limit cat params s rows =
1914
+
(* OFFSET first, then LIMIT. A negative/NULL offset skips nothing; a negative
1915
+
LIMIT is unbounded; LIMIT 0 yields no rows (lang_select.html). *)
1916
+
(* An offset/limit beyond the row count (up to int64 max) must not overflow
1917
+
[Int64.to_int]; compare against the length first. *)
1918
+
let count = Int64.of_int (List.length rows) in
1919
+
let rows =
1920
+
match s.offset with
1921
+
| None -> rows
1922
+
| Some e -> (
1923
+
match eval cat params [] e with
1924
+
| Int n when n >= count -> []
1925
+
| Int n when n > 0L -> drop (Int64.to_int n) rows
1926
+
| _ -> rows)
1927
+
in
1928
+
match s.limit with
1929
+
| None -> rows
1930
+
| Some e -> (
1931
+
match eval cat params [] e with
1932
+
| Int n when n < 0L -> rows
1933
+
| Int n when n >= Int64.of_int (List.length rows) -> rows
1934
+
| Int n -> take (Int64.to_int n) rows
1935
+
| Null -> rows
1936
+
| _ -> failwith "LIMIT must be an integer")
1937
+
1938
+
(* Materialise each join operand that is a subquery [(q) alias] under its alias,
1939
+
so the join machinery sees it as an ordinary named relation. *)
1940
+
let rec bind_join_subqueries ?(scope = []) cat params joins =
1941
+
List.fold_left
1942
+
(fun cat (j : Ast.join) ->
1943
+
match j.table.subquery with
1944
+
| None -> cat
1945
+
| Some sub ->
1946
+
let cols = select_columns cat sub in
1947
+
let rows = exec_select ~scope cat sub params in
1948
+
bind_relation cat j.table.name cols rows)
1949
+
cat joins
1950
+
1951
+
and combine ?(scope = []) cat params s : env list =
1952
+
let cat = bind_join_subqueries ~scope cat params s.joins in
1953
+
let no_rowid = List.map (fun r -> (None, r)) in
1954
+
let alias, cols, from_rows =
1955
+
match s.from with
1956
+
| Unit -> ("", [], [ (None, []) ])
1957
+
| Table tr ->
1958
+
let alias, cols = frag cat tr in
1959
+
(* A full scan carries each row's rowid (for the implicit rowid column);
1960
+
an index-narrowed scan drops it, so rowid stays unresolvable there. *)
1961
+
let rows =
1962
+
match from_access cat params tr s.where with
1963
+
| Some (_, rows) -> no_rowid rows
1964
+
| None -> cat.rows_rowid tr.name
1965
+
in
1966
+
(alias, cols, rows)
1967
+
| Select { fs_select; fs_alias } ->
1968
+
let alias = Option.value fs_alias ~default:"" in
1969
+
let cols = select_columns cat fs_select in
1970
+
(alias, cols, no_rowid (exec_select ~scope cat fs_select params))
1971
+
| Values tuples ->
1972
+
let n = match tuples with r :: _ -> List.length r | [] -> 0 in
1973
+
let cols = List.init n (fun i -> Fmt.str "column%d" (i + 1)) in
1974
+
let env = frames_of_scope scope in
1975
+
("", cols, no_rowid (List.map (List.map (eval cat params env)) tuples))
1976
+
| Table_function { tf_name; tf_args; tf_alias } ->
1977
+
let alias = Option.value tf_alias ~default:tf_name in
1978
+
let env = frames_of_scope scope in
1979
+
let cols, rows =
1980
+
table_function tf_name (List.map (eval cat params env) tf_args)
1981
+
in
1982
+
(alias, cols, no_rowid rows)
1983
+
in
1984
+
let base =
1985
+
List.map (fun (rid, vals) -> [ Pos (alias, cols, vals, rid) ]) from_rows
1986
+
in
1987
+
let resolved = resolve_natural cat (alias, cols) s.joins in
1988
+
let info_of j =
1989
+
match List.find_opt (fun (j', _, _) -> j' == j) resolved with
1990
+
| Some (_, d, lt) -> (d, lt)
1991
+
| None -> ([], [])
1992
+
in
1993
+
let joined =
1994
+
List.fold_left
1995
+
(fun envs j ->
1996
+
let drop, left_template = info_of j in
1997
+
join_with cat params ~drop ~left_template j envs)
1998
+
base
1999
+
(plan_joins cat alias (List.map (fun (j, _, _) -> j) resolved))
2000
+
in
2001
+
(* The outer [scope] sits at the tail: inner tables shadow it for unqualified
2002
+
names, but a qualified [outer.col] / [OLD.col] / [NEW.col] still resolves. *)
2003
+
if scope = [] then joined
2004
+
else
2005
+
let tail = frames_of_scope scope in
2006
+
List.map (fun env -> env @ tail) joined
2007
+
2008
+
(* Bind each WITH table expression as a row source, materialized once (the
2009
+
state-of-the-art choice when a CTE is read more than once, as our nested-loop
2010
+
joins do). Later CTEs see the earlier ones. *)
2011
+
and materialize_ctes cat params ctes =
2012
+
let bind = bind_relation in
2013
+
List.fold_left
2014
+
(fun cat (c : cte) ->
2015
+
let cols =
2016
+
match c.columns with [] -> select_columns cat c.query | cs -> cs
2017
+
in
2018
+
let rows =
2019
+
if references_table c.name c.query then
2020
+
run_recursive cat c.name cols params c.query
2021
+
else exec_select cat c.query params
2022
+
in
2023
+
bind cat c.name cols rows)
2024
+
cat ctes
2025
+
2026
+
(* Recursive CTE by semi-naive (delta) evaluation -- the SQLite / differential
2027
+
algorithm: seed with the non-recursive arm; each round runs the recursive
2028
+
arm(s) over only the previous round's new rows ([working]), so work is the
2029
+
delta, not the whole accumulated relation. UNION dedups new rows against the
2030
+
full result; UNION ALL keeps them. [cat] already binds [name] (to be
2031
+
rebound per round). A row cap guards against a non-terminating recursion. *)
2032
+
and run_recursive cat name cols params query =
2033
+
let op = match query.compound with (op, _) :: _ -> op | [] -> Union_all in
2034
+
let dedup_union = op = Union in
2035
+
let strip s = { s with compound = []; order_by = []; limit = None } in
2036
+
let initial = strip query in
2037
+
let arms = List.map (fun (_, arm) -> strip arm) query.compound in
2038
+
let rebind rows = bind_relation cat name cols rows in
2039
+
let seed = exec_core ~ordered:false (rebind []) params initial in
2040
+
let rec loop result working =
2041
+
if working = [] then result
2042
+
else
2043
+
let cat' = rebind working in
2044
+
let delta =
2045
+
List.concat_map
2046
+
(fun arm -> exec_core ~ordered:false cat' params arm)
2047
+
arms
2048
+
in
2049
+
let delta =
2050
+
if dedup_union then
2051
+
dedup (List.filter (fun r -> not (List.mem r result)) delta)
2052
+
else delta
2053
+
in
2054
+
if delta = [] then result
2055
+
else if List.length result + List.length delta > 1_000_000 then
2056
+
failwith "recursive CTE exceeded 1,000,000 rows"
2057
+
else loop (result @ delta) delta
2058
+
in
2059
+
loop seed seed
2060
+
2061
+
and exec_core ~ordered ?(scope = []) cat params s =
2062
+
let s = resolve_ordinals cat s in
2063
+
let s = resolve_collations cat s in
2064
+
let s = resolve_where_aliases cat s in
2065
+
let envs = combine ~scope cat params s in
2066
+
let envs =
2067
+
match s.where with
2068
+
| None -> envs
2069
+
| Some w -> List.filter (fun env -> tri_of (eval cat params env w) = T) envs
2070
+
in
2071
+
let rows = core_rows ~ordered cat params s envs in
2072
+
if s.distinct then distinct_dedup s.cols rows else rows
2073
+
2074
+
and exec_select ?(scope = []) cat s params =
2075
+
let cat = if s.ctes = [] then cat else materialize_ctes cat params s.ctes in
2076
+
let rows =
2077
+
if s.compound = [] then exec_core ~ordered:true ~scope cat params s
2078
+
else
2079
+
let names = select_columns cat s in
2080
+
let combined =
2081
+
List.fold_left
2082
+
(fun acc (op, arm) ->
2083
+
set_op op acc (exec_core ~ordered:false ~scope cat params arm))
2084
+
(exec_core ~ordered:false ~scope cat params s)
2085
+
s.compound
2086
+
in
2087
+
compound_order cat params names s.order_by combined
2088
+
in
2089
+
apply_limit cat params s rows
2090
+
2091
+
(* Does any expression reference the implicit [rowid] pseudo-column? A subquery
2092
+
or window expression returns [true] conservatively (the caller then keeps such
2093
+
a select on the tree-walker rather than the rowid-free VM scan). *)
2094
+
(* Whether [e] references a [rowid] column. A subquery / [EXISTS] reads as [true]
2095
+
(its scan is separate). A [Window] is opaque by default (the plain aggregate
2096
+
path cannot scan it); with [~through_window], it descends into the window's
2097
+
function, partition, and order keys -- the window node itself is what the
2098
+
window post-pass compiles, not a rowid reference, but a rowid inside its
2099
+
scanned components still matters. *)
2100
+
let rec expr_references_rowid ?(through_window = false) e =
2101
+
let r = expr_references_rowid ~through_window in
2102
+
match e with
2103
+
| Col (_, name) -> is_rowid_name name
2104
+
| Lit _ | Param _ | Star | Qualified_star _ -> false
2105
+
| Unop_not e
2106
+
| Is_null e
2107
+
| Is_not_null e
2108
+
| Cast (e, _)
2109
+
| Collate (e, _)
2110
+
| Distinct_agg (_, e) ->
2111
+
r e
2112
+
| Binary (_, a, b) | Is (a, b) | Filter (a, b) -> r a || r b
2113
+
| In_list (e, l) -> r e || List.exists r l
2114
+
| Func (_, args) -> List.exists r args
2115
+
| Ordered_agg (a, ob) -> r a || List.exists (fun (e, _) -> r e) ob
2116
+
| Case (base, brs, els) ->
2117
+
Option.fold ~none:false ~some:r base
2118
+
|| List.exists (fun (c, x) -> r c || r x) brs
2119
+
|| Option.fold ~none:false ~some:r els
2120
+
| Window (f, w) ->
2121
+
through_window
2122
+
&& (r f || List.exists r w.partition
2123
+
|| List.exists (fun (oe, _) -> r oe) w.order)
2124
+
| In_select _ | Scalar_select _ | Exists _ -> true
2125
+
2126
+
(* Whether [s] is an aggregate/GROUP BY select that {!aggregate_scan} can run from
2127
+
rowid-free scanned rows: it groups or aggregates or has HAVING, uses no window
2128
+
function, and references no [rowid]. *)
2129
+
let aggregate_compilable (s : select) =
2130
+
(s.group_by <> [] || s.having <> None || List.exists is_aggregate s.cols)
2131
+
&& window_exprs s.cols = []
2132
+
&& not
2133
+
(List.exists
2134
+
(fun (rc : Ast.result_col) -> expr_references_rowid rc.expr)
2135
+
s.cols
2136
+
|| (match s.having with
2137
+
| Some h -> expr_references_rowid h
2138
+
| None -> false)
2139
+
|| List.exists expr_references_rowid s.group_by
2140
+
|| List.exists (fun (e, _) -> expr_references_rowid e) s.order_by)
2141
+
2142
+
(* A select with a window function over a [rowid]-free projection: like an
2143
+
aggregate, it scans its (filtered, joined) source rows then post-processes them
2144
+
({!window_project}, reached through {!aggregate_scan}). Lets the register VM run
2145
+
the scan instead of falling back wholesale. *)
2146
+
let window_compilable (s : select) =
2147
+
let rowid = expr_references_rowid ~through_window:true in
2148
+
window_exprs s.cols <> []
2149
+
&& not
2150
+
(List.exists (fun (rc : Ast.result_col) -> rowid rc.expr) s.cols
2151
+
|| List.exists (fun (e, _) -> rowid e) s.order_by)
2152
+
2153
+
(* Run an aggregate/GROUP BY [s] from its already-scanned source [rows] and reuse
2154
+
{!core_rows} for the grouping/aggregation/HAVING and ORDER BY, then dedup
2155
+
(DISTINCT) and apply OFFSET/LIMIT. [segments] names the join's tables in FROM
2156
+
order as [(alias, cols)]; each scanned row is the concatenation of its tables'
2157
+
columns in that order, so it is sliced back into one [Pos] binding per table
2158
+
-- a single-table aggregate is just a one-element [segments]. Lets the
2159
+
register VM do the (possibly joined) scan and reuse this aggregation. *)
2160
+
let aggregate_scan cat params (s : select) segments rows =
2161
+
let bind vals =
2162
+
let env, _ =
2163
+
List.fold_left
2164
+
(fun (acc, rest) (alias, cols) ->
2165
+
let n = List.length cols in
2166
+
(Pos (alias, cols, take n rest, None) :: acc, drop n rest))
2167
+
([], vals) segments
2168
+
in
2169
+
List.rev env
2170
+
in
2171
+
let envs = List.map bind rows in
2172
+
let rows = core_rows ~ordered:true cat params s envs in
2173
+
let rows = if s.distinct then dedup rows else rows in
2174
+
apply_limit cat params s rows
2175
+
2176
+
(* The default subquery runner: the tree-walker over the enclosing-row [cat]. The
2177
+
engine overrides it with a catalog-VM runner reading the same [cat]. *)
2178
+
let () =
2179
+
cat_subquery_runner :=
2180
+
fun cat scope s params -> exec_select ~scope cat s params
2181
+
2182
+
(* Combine the already-computed arm rows of a compound [s] -- [base_rows] for the
2183
+
leading arm and [(op, rows)] for each following arm -- exactly as the compound
2184
+
branch of {!exec_select} does: fold the set operators, order by [s.order_by]
2185
+
over the output columns, then apply OFFSET/LIMIT. Lets a caller compute each
2186
+
arm however it likes (e.g. through the register VM) and reuse this orchestration. *)
2187
+
let combine_compound cat params (s : select) base_rows compound_rows =
2188
+
let combined =
2189
+
List.fold_left
2190
+
(fun acc (op, rows) -> set_op op acc rows)
2191
+
base_rows compound_rows
2192
+
in
2193
+
let ordered =
2194
+
compound_order cat params (select_columns cat s) s.order_by combined
2195
+
in
2196
+
apply_limit cat params s ordered
2197
+
2198
+
(* Each FROM source of [s] as (alias, its column names) -- the column scope a
2199
+
subquery body resolves against. A name that does not resolve (e.g. a CTE absent
2200
+
from the base catalog) contributes no columns, so a subquery using it reads as
2201
+
correlated and is left for the tree-walker rather than wrongly hoisted. *)
2202
+
let from_scope cat (s : select) : (string * string list) list =
2203
+
let cols_of name = try cat.columns name with Failure _ -> [] in
2204
+
let alias_or_name (tr : table_ref) =
2205
+
match tr.alias with Some a -> a | None -> tr.name
2206
+
in
2207
+
let of_ref (tr : table_ref) =
2208
+
match tr.subquery with
2209
+
| Some q -> (alias_or_name tr, select_columns cat q)
2210
+
| None -> (alias_or_name tr, cols_of tr.name)
2211
+
in
2212
+
let leading =
2213
+
match s.from with
2214
+
| Table tr -> [ of_ref tr ]
2215
+
| Select { fs_select; fs_alias } ->
2216
+
[ (Option.value fs_alias ~default:"", select_columns cat fs_select) ]
2217
+
| Values tuples ->
2218
+
let n = match tuples with r :: _ -> List.length r | [] -> 0 in
2219
+
[ ("", List.init n (fun i -> Fmt.str "column%d" (i + 1))) ]
2220
+
| Unit | Table_function _ -> []
2221
+
in
2222
+
leading @ List.map (fun (j : join) -> of_ref j.table) s.joins
2223
+
2224
+
(* Whether [s], read as a subquery under the column scope [bound] (alias -> its
2225
+
columns), references a FREE column -- one bound by neither [bound] nor [s]'s own
2226
+
FROM. A free column makes the subquery CORRELATED to an enclosing query, so it
2227
+
cannot be materialised on its own. A nested subquery extends the scope, so it is
2228
+
checked under [scope]. Conservative: a qualified column whose alias is unknown,
2229
+
or an unqualified column in no in-scope table, counts as free. *)
2230
+
let rec correlated cat bound (s : select) =
2231
+
let scope = bound @ from_scope cat s in
2232
+
let col_free = function
2233
+
| Col (Some q, _) -> not (List.mem_assoc q scope)
2234
+
| Col (None, c) ->
2235
+
not (List.exists (fun (_, cols) -> List.mem c cols) scope)
2236
+
| _ -> false
2237
+
in
2238
+
let rec free e =
2239
+
match e with
2240
+
| Col _ -> col_free e
2241
+
| Lit _ | Param _ | Star | Qualified_star _ -> false
2242
+
| Unop_not x
2243
+
| Is_null x
2244
+
| Is_not_null x
2245
+
| Cast (x, _)
2246
+
| Collate (x, _)
2247
+
| Distinct_agg (_, x) ->
2248
+
free x
2249
+
| Binary (_, a, b) | Is (a, b) | Filter (a, b) -> free a || free b
2250
+
| In_list (x, l) -> free x || List.exists free l
2251
+
| Func (_, args) -> List.exists free args
2252
+
| Ordered_agg (x, ob) -> free x || List.exists (fun (e, _) -> free e) ob
2253
+
| Window (x, w) ->
2254
+
free x
2255
+
|| List.exists free w.partition
2256
+
|| List.exists (fun (e, _) -> free e) w.order
2257
+
| Case (base, branches, els) ->
2258
+
Option.fold ~none:false ~some:free base
2259
+
|| List.exists (fun (c, r) -> free c || free r) branches
2260
+
|| Option.fold ~none:false ~some:free els
2261
+
| Scalar_select sub | Exists sub -> correlated cat scope sub
2262
+
| In_select (x, sub) -> free x || correlated cat scope sub
2263
+
in
2264
+
List.exists (fun (rc : result_col) -> free rc.expr) s.cols
2265
+
|| Option.fold ~none:false ~some:free s.where
2266
+
|| Option.fold ~none:false ~some:free s.having
2267
+
|| List.exists free s.group_by
2268
+
|| List.exists (fun (e, _) -> free e) s.order_by
2269
+
|| List.exists (fun (j : join) -> free j.on) s.joins
2270
+
|| List.exists (fun (_, arm) -> correlated cat bound arm) s.compound
2271
+
2272
+
exception Subst_hard
2273
+
(** Raised by {!subst_expr} on a node the simple substituter does not descend
2274
+
into (a nested subquery or a window), so the caller falls back. *)
2275
+
2276
+
(* Rebuild [e], applying [replace qual name e] to each column reference and
2277
+
recursing structurally everywhere else. A nested subquery / window raises
2278
+
{!Subst_hard}. *)
2279
+
let rec subst_expr ~replace e =
2280
+
let go = subst_expr ~replace in
2281
+
match e with
2282
+
| Col (qual, name) -> replace qual name e
2283
+
| Scalar_select _ | In_select _ | Exists _ | Window _ -> raise Subst_hard
2284
+
| Lit _ | Param _ | Star | Qualified_star _ -> e
2285
+
| Unop_not a -> Unop_not (go a)
2286
+
| Binary (op, a, b) -> Binary (op, go a, go b)
2287
+
| Is (a, b) -> Is (go a, go b)
2288
+
| Is_null a -> Is_null (go a)
2289
+
| Is_not_null a -> Is_not_null (go a)
2290
+
| In_list (a, l) -> In_list (go a, List.map go l)
2291
+
| Func (n, args) -> Func (n, List.map go args)
2292
+
| Distinct_agg (n, a) -> Distinct_agg (n, go a)
2293
+
| Filter (a, b) -> Filter (go a, go b)
2294
+
| Ordered_agg (a, ob) ->
2295
+
Ordered_agg (go a, List.map (fun (e, d) -> (go e, d)) ob)
2296
+
| Cast (a, t) -> Cast (go a, t)
2297
+
| Collate (a, c) -> Collate (go a, c)
2298
+
| Case (b, br, el) ->
2299
+
Case
2300
+
( Option.map go b,
2301
+
List.map (fun (c, r) -> (go c, go r)) br,
2302
+
Option.map go el )
2303
+
2304
+
(* Substitute each FREE column of subquery [s] -- a column bound by neither [s]'s
2305
+
own FROM (which shadows the outer query) nor a deeper scope -- with its value
2306
+
from [scope] (the enclosing row), turning a correlated subquery into an
2307
+
uncorrelated one that can run on its own. [None] when [s] is too tangled for the
2308
+
simple rule (a FROM-subquery, a nested subquery, or a window), so the caller
2309
+
evaluates it under [~scope] on the tree-walker instead. *)
2310
+
let substitute_scope cat scope (s : select) : select option =
2311
+
let own = from_scope cat s in
2312
+
let own_aliases = List.map fst own in
2313
+
let own_cols = List.concat_map snd own in
2314
+
let bound qual name =
2315
+
match qual with
2316
+
| Some q -> List.mem q own_aliases
2317
+
| None -> List.mem name own_cols
2318
+
in
2319
+
(* Resolve a free column against [scope]. The alias matches case-insensitively
2320
+
(as the tree-walker's {!lookup} does, for the [OLD]/[NEW] pseudo-tables
2321
+
written in any case); the column name matches exactly, as {!frame_lookup}. *)
2322
+
let lookup qual name =
2323
+
let alias_eq q a =
2324
+
String.equal q a
2325
+
|| String.equal (String.uppercase_ascii q) (String.uppercase_ascii a)
2326
+
in
2327
+
let rec find = function
2328
+
| (alias, cols) :: rest -> (
2329
+
match qual with
2330
+
| Some q when not (alias_eq q alias) -> find rest
2331
+
| _ -> (
2332
+
match List.assoc_opt name cols with
2333
+
| Some v -> Some v
2334
+
| None -> find rest))
2335
+
| [] -> None
2336
+
in
2337
+
find scope
2338
+
in
2339
+
(* A free column must resolve to a scope value; one that does not (a deeper
2340
+
correlation than [scope] carries) makes the whole substitution [None], so the
2341
+
caller keeps the tree-walker, rather than leaving an unbound column that would
2342
+
fail when the substituted select runs without a scope. *)
2343
+
let replace qual name e =
2344
+
if bound qual name then e
2345
+
else
2346
+
match lookup qual name with Some v -> Lit v | None -> raise Subst_hard
2347
+
in
2348
+
let sub = subst_expr ~replace in
2349
+
let sub_col (rc : Ast.result_col) = { rc with expr = sub rc.expr } in
2350
+
(* A FROM/join subquery is left untouched, which is sound only when it is
2351
+
uncorrelated; a lateral one (referencing the outer scope) falls back. *)
2352
+
let from_subq_ok q = not (correlated cat [] q) in
2353
+
try
2354
+
(match s.from with
2355
+
| Select { fs_select; _ } when not (from_subq_ok fs_select) ->
2356
+
raise Subst_hard
2357
+
| _ -> ());
2358
+
List.iter
2359
+
(fun (j : join) ->
2360
+
match j.table.subquery with
2361
+
| Some q when not (from_subq_ok q) -> raise Subst_hard
2362
+
| Some _ | None -> ())
2363
+
s.joins;
2364
+
Some
2365
+
{
2366
+
s with
2367
+
cols = List.map sub_col s.cols;
2368
+
where = Option.map sub s.where;
2369
+
group_by = List.map sub s.group_by;
2370
+
having = Option.map sub s.having;
2371
+
order_by = List.map (fun (e, d) -> (sub e, d)) s.order_by;
2372
+
joins = List.map (fun (j : join) -> { j with on = sub j.on }) s.joins;
2373
+
}
2374
+
with Subst_hard -> None
2375
+
2376
+
(* Replace each uncorrelated scalar / [IN (SELECT ...)] / [EXISTS] subquery in
2377
+
[s]'s scalar-expression positions with its materialised value, so the register
2378
+
VM -- which has no subquery opcode -- sees a literal or IN-list instead and
2379
+
compiles the outer query. A correlated subquery is left untouched (the VM falls
2380
+
back for it). The subquery is evaluated with the outer [params] (a [?] indexes
2381
+
the same array) but no row scope, which is exactly its value when uncorrelated;
2382
+
safe to evaluate eagerly because {!eval} is itself eager on AND/OR. *)
2383
+
let hoist_subqueries ~run cat (s : select) : select =
2384
+
let first_col = function v :: _ -> v | [] -> Null in
2385
+
let scalar sub =
2386
+
match run sub with (v :: _) :: _ -> Lit v | _ -> Lit Null
2387
+
in
2388
+
let rec go e =
2389
+
match e with
2390
+
| Scalar_select sub when not (correlated cat [] sub) -> scalar sub
2391
+
| Exists sub when not (correlated cat [] sub) -> Lit (bool (run sub <> []))
2392
+
| In_select (x, sub) when not (correlated cat [] sub) ->
2393
+
In_list (go x, List.map (fun v -> Lit v) (List.map first_col (run sub)))
2394
+
| Lit _ | Param _ | Col _ | Star | Qualified_star _ | Scalar_select _
2395
+
| Exists _ ->
2396
+
e
2397
+
| In_select (x, sub) -> In_select (go x, sub)
2398
+
| Unop_not x -> Unop_not (go x)
2399
+
| Is_null x -> Is_null (go x)
2400
+
| Is_not_null x -> Is_not_null (go x)
2401
+
| Cast (x, t) -> Cast (go x, t)
2402
+
| Collate (x, c) -> Collate (go x, c)
2403
+
| Distinct_agg (n, x) -> Distinct_agg (n, go x)
2404
+
| Binary (op, a, b) -> Binary (op, go a, go b)
2405
+
| Is (a, b) -> Is (go a, go b)
2406
+
| Filter (a, b) -> Filter (go a, go b)
2407
+
| In_list (x, l) -> In_list (go x, List.map go l)
2408
+
| Func (n, args) -> Func (n, List.map go args)
2409
+
| Ordered_agg (x, ob) ->
2410
+
Ordered_agg (go x, List.map (fun (e, d) -> (go e, d)) ob)
2411
+
| Window (x, w) ->
2412
+
Window
2413
+
( go x,
2414
+
{
2415
+
w with
2416
+
partition = List.map go w.partition;
2417
+
order = List.map (fun (e, d) -> (go e, d)) w.order;
2418
+
} )
2419
+
| Case (base, br, els) ->
2420
+
Case
2421
+
( Option.map go base,
2422
+
List.map (fun (c, r) -> (go c, go r)) br,
2423
+
Option.map go els )
2424
+
in
2425
+
{
2426
+
s with
2427
+
cols =
2428
+
List.map (fun (rc : result_col) -> { rc with expr = go rc.expr }) s.cols;
2429
+
where = Option.map go s.where;
2430
+
group_by = List.map go s.group_by;
2431
+
having = Option.map go s.having;
2432
+
order_by = List.map (fun (e, d) -> (go e, d)) s.order_by;
2433
+
joins = List.map (fun (j : join) -> { j with on = go j.on }) s.joins;
2434
+
}
2435
+
2436
+
(* The join-row environments of a bare [FROM from joins] (no projection, no
2437
+
WHERE) -- each is a [binding list] usable as an outer [~scope]. This drives
2438
+
[UPDATE ... FROM], whose auxiliary tables are visible to SET and WHERE. *)
2439
+
let from_bindings ?(scope = []) cat params from joins =
2440
+
let s =
2441
+
{
2442
+
ctes = [];
2443
+
distinct = false;
2444
+
cols = [ { expr = Star; alias = None } ];
2445
+
from;
2446
+
joins;
2447
+
where = None;
2448
+
group_by = [];
2449
+
having = None;
2450
+
compound = [];
2451
+
order_by = [];
2452
+
limit = None;
2453
+
offset = None;
2454
+
}
2455
+
in
2456
+
List.map bindings_of_frames (combine ~scope cat params s)
2457
+
2458
+
(* The access path the executor takes, one line per table. Structural (no
2459
+
parameter values): the from table uses an index when one covers its
2460
+
equalities (the same columns {!from_access} narrows on, so EXPLAIN and run
2461
+
agree), and joins are nested-loop scans. *)
2462
+
let explain cat (s : Ast.select) =
2463
+
let line tbl = function
2464
+
| Some descr -> Fmt.str "SEARCH %s USING %s" tbl descr
2465
+
| None -> Fmt.str "SCAN %s" tbl
2466
+
in
2467
+
let from_alias =
2468
+
match s.from with
2469
+
| Unit -> ""
2470
+
| Table tr -> Option.value tr.alias ~default:tr.name
2471
+
| Select { fs_alias; _ } -> Option.value fs_alias ~default:""
2472
+
| Values _ -> ""
2473
+
| Table_function { tf_name; tf_alias; _ } ->
2474
+
Option.value tf_alias ~default:tf_name
2475
+
in
2476
+
let from_line =
2477
+
match s.from with
2478
+
| Unit -> "SCAN (constant)"
2479
+
| Table tr ->
2480
+
line tr.name (cat.index_for tr.name (eq_columns from_alias s.where))
2481
+
| Select _ -> "SCAN (subquery)"
2482
+
| Values _ -> "SCAN (values)"
2483
+
| Table_function { tf_name; _ } -> Fmt.str "SCAN (%s)" tf_name
2484
+
in
2485
+
let join_line (j : Ast.join) =
2486
+
line j.table.name
2487
+
(cat.index_for j.table.name (join_eq_columns (join_alias j) j.on))
2488
+
in
2489
+
(* Explain the same order the executor runs (cost-based for inner joins). *)
2490
+
String.concat "\n"
2491
+
(from_line :: List.map join_line (plan_joins cat from_alias s.joins))
2492
+
2493
+
(* ── Write-path evaluation ────────────────────────────────────── *)
2494
+
2495
+
(* Evaluate an expression with no row in scope -- for INSERT ... VALUES, whose
2496
+
tuples are constants and bound parameters. A column reference here raises
2497
+
(no table is in scope), which is the correct error. *)
2498
+
let eval_const ?(scope = []) cat params e =
2499
+
eval cat params (frames_of_scope scope) e
2500
+
2501
+
(* Does [vals] (a row of [table], aligned to [cols]) satisfy [where]? Used to
2502
+
pick the rows a DELETE removes. No WHERE matches every row. *)
2503
+
let row_matches ?(scope = []) ?rowid cat params table cols where vals =
2504
+
match where with
2505
+
| None -> true
2506
+
| Some w ->
2507
+
let env = Pos (table, cols, vals, rowid) :: frames_of_scope scope in
2508
+
tri_of (eval cat params env w) = T
2509
+
2510
+
(* Evaluate [e] against a single [table] row ([vals] aligned to [cols]) -- the
2511
+
right-hand side of an UPDATE ... SET assignment, which may read the row's
2512
+
current column values. *)
2513
+
let eval_in_row ?(scope = []) ?rowid cat params table cols vals e =
2514
+
eval cat params (Pos (table, cols, vals, rowid) :: frames_of_scope scope) e
2515
+
2516
+
(* Evaluate an UPSERT DO UPDATE expression: the conflicting row's current values
2517
+
are in scope under [table], and the would-be-inserted values under the
2518
+
[excluded] pseudo-table (both aligned to [cols]). *)
2519
+
let eval_upsert ?(scope = []) cat params ~table ~cols ~current ~excluded e =
2520
+
eval cat params
2521
+
(Pos (table, cols, current, None)
2522
+
:: Pos ("excluded", cols, excluded, None)
2523
+
:: frames_of_scope scope)
2524
+
e
2525
+
2526
+
(* Project a RETURNING column list over each affected [row] of [table] ([cols]
2527
+
are the table's column names, aligned to [row]). [*] expands to the whole
2528
+
row; other items are expressions over the row. *)
2529
+
let returning_rows cat params ~table ~cols returning rows =
2530
+
List.map
2531
+
(fun row ->
2532
+
let env = [ Pos (table, cols, row, None) ] in
2533
+
List.concat_map
2534
+
(fun (rc : Ast.result_col) ->
2535
+
match rc.expr with
2536
+
| Star | Qualified_star _ -> row
2537
+
| e -> [ eval cat params env e ])
2538
+
returning)
2539
+
rows
+263
lib/query.mli
+263
lib/query.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Storage-agnostic SQL query executor.
7
+
8
+
Operates over a {!catalog} that exposes a table's column names and rows, so
9
+
the evaluation logic (comparisons, [LIKE], joins, ordering) is independent
10
+
of the storage backend and can be tested in isolation. The catalog speaks
11
+
the engine core's {!Catalog.Value.t} -- so a storage adapter need not know
12
+
the SQL frontend's value type -- and the executor converts at that boundary.
13
+
*)
14
+
15
+
type catalog = {
16
+
columns : string -> string list;
17
+
(** Column names of a table, in declared order. *)
18
+
rows : string -> Catalog.Value.t list list;
19
+
(** Rows of a table, each aligned to {!columns}. *)
20
+
rows_rowid : string -> (int64 option * Catalog.Value.t list) list;
21
+
(** Each row paired with its rowid, or [None] for a row source without one
22
+
(a view, a derived table, [VALUES]) -- lets the executor resolve the
23
+
implicit [rowid]/[oid]/[_rowid_] column of a full table scan. *)
24
+
index_scan :
25
+
string ->
26
+
(string * Catalog.Value.t) list ->
27
+
(string * Catalog.Value.t list list) option;
28
+
(** [index_scan table eqs] returns [Some (index_name, rows)] when an index
29
+
on [table] serves the column-equality bindings [eqs], or [None] for a
30
+
full {!rows} scan. The rows are still re-filtered, so this is a pure
31
+
optimisation. *)
32
+
index_for : string -> string list -> string option;
33
+
(** [index_for table cols] names a unique index on [table] all of whose
34
+
columns are among [cols] -- the structural counterpart of
35
+
{!index_scan}, used by {!explain}. *)
36
+
collation : string -> string -> string option;
37
+
(** [collation table col] is [col]'s declared [COLLATE] sequence
38
+
(uppercase) on [table], or [None] for the default binary / a derived
39
+
source. *)
40
+
}
41
+
42
+
val of_catalog : Catalog.t -> catalog
43
+
(** [of_catalog cat] adapts a {!Catalog.t} to the SQL frontend's read/explain
44
+
view. Backends such as Irmin or Parquet can implement {!Catalog.Spi.S},
45
+
build a catalog handle, and pass it through this adapter before calling
46
+
{!exec_select}. *)
47
+
48
+
val number_params : Ast.stmt -> Ast.stmt
49
+
(** [number_params stmt] assigns each [?] placeholder its zero-based index in
50
+
left-to-right source order. *)
51
+
52
+
type binding = string * (string * Ast.value) list
53
+
(** One named row fragment, [(alias, [(column, value); ...])]. A [binding list]
54
+
passed as [?scope] is an outer environment placed at the tail of the row's
55
+
own bindings, so inner columns shadow it for unqualified names but a
56
+
qualified [alias.col] still resolves. Used for correlated subqueries (the
57
+
enclosing row) and for a trigger's [OLD]/[NEW] rows. *)
58
+
59
+
val exec_select :
60
+
?scope:binding list ->
61
+
catalog ->
62
+
Ast.select ->
63
+
Ast.value array ->
64
+
Ast.value list list
65
+
(** [exec_select cat select params] runs [select], substituting [params.(i)] for
66
+
the [i]-th placeholder. Returns the result rows in output order. [?scope] is
67
+
an outer environment (e.g. a trigger's OLD/NEW rows) visible to the query.
68
+
@raise Failure on unknown tables/columns or unsupported functions. *)
69
+
70
+
val set_cat_subquery_runner :
71
+
(catalog ->
72
+
(string * (string * Ast.value) list) list ->
73
+
Ast.select ->
74
+
Ast.value array ->
75
+
Ast.value list list) ->
76
+
unit
77
+
(** Install the runner [eval] uses for a scalar / [IN] / [EXISTS] subquery:
78
+
given the enclosing-row {!type-catalog}, the outer scope, the subquery, and
79
+
the params, it returns the subquery's rows. The default is {!exec_select}
80
+
(the tree-walker over that catalog); the engine installs one that runs the
81
+
subquery on the catalog VM -- reading the {e same} catalog, so a CTE or
82
+
derived table materialised into it is visible -- falling back to
83
+
{!exec_select} for a shape the VM cannot compile. *)
84
+
85
+
val from_bindings :
86
+
?scope:binding list ->
87
+
catalog ->
88
+
Ast.value array ->
89
+
Ast.from_clause ->
90
+
Ast.join list ->
91
+
binding list list
92
+
(** [from_bindings cat params from joins] is the join-row environments of a bare
93
+
[FROM from joins] (no projection, no WHERE), each a [binding list] usable as
94
+
an outer [~scope]. Drives [UPDATE ... FROM]. [?scope] adds outer bindings.
95
+
*)
96
+
97
+
val materialize_ctes : catalog -> Ast.value array -> Ast.cte list -> catalog
98
+
(** [materialize_ctes cat params ctes] runs each [WITH] table expression
99
+
(semi-naive evaluation for a recursive one) and binds its rows into [cat]
100
+
under its name, returning the extended catalog. Lets a [WITH] on
101
+
[UPDATE]/[DELETE] put its CTEs in scope for the statement's subqueries. *)
102
+
103
+
val resolve_collations : catalog -> Ast.select -> Ast.select
104
+
(** Make each base-table column's declared [COLLATE] sequence explicit in [s]'s
105
+
comparisons and ORDER BY keys (wrapping the column in a [Collate] node by
106
+
sqlite3's left-operand rule), so the collation machinery honours it. The
107
+
tree-walker applies this itself; the register VM calls it so a compiled scan
108
+
over a collated column falls back rather than comparing binary. *)
109
+
110
+
val resolve_where_aliases : catalog -> Ast.select -> Ast.select
111
+
(** Substitute a select-list alias referenced in [s]'s WHERE or ORDER BY with
112
+
the aliased expression -- so [SELECT a AS x FROM t WHERE x > 1] resolves [x]
113
+
(an alias is only substituted when it does not name a real source column,
114
+
which shadows it, matching sqlite3). The tree-walker applies this itself;
115
+
the register VM calls it so a compiled scan resolves the alias too. *)
116
+
117
+
val substitute_scope :
118
+
catalog -> binding list -> Ast.select -> Ast.select option
119
+
(** [substitute_scope cat scope s] replaces each free (correlated) column of
120
+
subquery [s] -- one bound by neither its own FROM nor a deeper scope -- with
121
+
its value from [scope] (the enclosing row), turning a correlated subquery
122
+
into an uncorrelated one a caller can run on its own. [None] when [s] is too
123
+
tangled for the simple rule (a FROM-subquery, a nested subquery, or a
124
+
window), so the caller evaluates it under [~scope] on the tree-walker
125
+
instead. *)
126
+
127
+
val hoist_subqueries :
128
+
run:(Ast.select -> Ast.value list list) -> catalog -> Ast.select -> Ast.select
129
+
(** Replace each uncorrelated scalar / [IN (SELECT ...)] / [EXISTS] subquery in
130
+
[s]'s scalar-expression positions (select list, WHERE, GROUP BY, HAVING,
131
+
ORDER BY, join ON) with its materialised value -- a literal, or an [IN]
132
+
value list. A correlated subquery (one referencing an enclosing query's
133
+
columns) is left intact. [run] materialises an uncorrelated subquery to its
134
+
rows; the engine passes a runner that executes it on the catalog VM. The
135
+
register VM has no subquery opcode, so it calls this to compile the outer
136
+
query of an uncorrelated subquery rather than fall back. Sound because an
137
+
uncorrelated subquery is constant. *)
138
+
139
+
val resolve_ordinals : catalog -> Ast.select -> Ast.select
140
+
(** Rewrite [s]'s ORDER BY and GROUP BY so a 1-based output-column ordinal
141
+
([ORDER BY 2] / [GROUP BY 2]) becomes the expression of that output column.
142
+
The tree-walker applies this itself; the register VM calls it so a compiled
143
+
ORDER BY/GROUP BY ordinal works too. *)
144
+
145
+
val select_columns : catalog -> Ast.select -> string list
146
+
(** [select_columns cat s] is the output column names of [s]: each item's alias,
147
+
else a bare column's name, else [columnN]; [*] expands the source table's
148
+
columns. Used to name the columns of a [CREATE TABLE ... AS] target. *)
149
+
150
+
val aggregate_compilable : Ast.select -> bool
151
+
(** Whether [s] is an aggregate/GROUP BY select that {!aggregate_scan} can run
152
+
from rowid-free scanned rows: it groups or aggregates or has HAVING, uses no
153
+
window function, and references no [rowid]. *)
154
+
155
+
val window_compilable : Ast.select -> bool
156
+
(** Whether [s] has a window function over a [rowid]-free projection, so its
157
+
(filtered, joined) source rows can be scanned by the register VM and then
158
+
post-processed by {!aggregate_scan} (which reaches {!window_project}). *)
159
+
160
+
val aggregate_scan :
161
+
catalog ->
162
+
Ast.value array ->
163
+
Ast.select ->
164
+
(string * string list) list ->
165
+
Ast.value list list ->
166
+
Ast.value list list
167
+
(** [aggregate_scan cat params s segments rows] runs an aggregate/GROUP BY [s]
168
+
from its already-scanned source [rows]: it builds the row environments and
169
+
reuses the grouping, aggregation, HAVING, ORDER BY, DISTINCT, and
170
+
OFFSET/LIMIT of {!exec_select}. [segments] is the join's tables in FROM
171
+
order as [(alias, cols)]; each row is the concatenation of those tables'
172
+
columns in that order and is sliced back into one binding per table (a
173
+
single-table aggregate is a one-element [segments]). Lets the register VM do
174
+
the scan and reuse this aggregation. *)
175
+
176
+
val combine_compound :
177
+
catalog ->
178
+
Ast.value array ->
179
+
Ast.select ->
180
+
Ast.value list list ->
181
+
(Ast.set_op * Ast.value list list) list ->
182
+
Ast.value list list
183
+
(** [combine_compound cat params s base_rows compound_rows] combines a compound
184
+
select's already-computed arm rows -- [base_rows] for the leading arm,
185
+
[(op, rows)] per following arm -- as {!exec_select} does: fold the set
186
+
operators, apply [s]'s ORDER BY over the output columns, then OFFSET/LIMIT.
187
+
Lets a caller produce each arm's rows itself (e.g. via the register VM) and
188
+
reuse this orchestration. *)
189
+
190
+
val explain : catalog -> Ast.select -> string
191
+
(** [explain cat select] describes the access path the executor takes, one line
192
+
per table ([SCAN t] or [SEARCH t USING INDEX i]). Structural -- it uses the
193
+
same index decision as {!exec_select}, independent of parameter values. *)
194
+
195
+
val is_agg : string -> Ast.expr list -> bool
196
+
(** [is_agg name args] is whether [name] (with that argument count) is an
197
+
aggregate -- [count]/[sum]/[avg]/..., or [min]/[max] with at most one
198
+
argument. An aggregate is folded over a group, not applied per row. *)
199
+
200
+
val eval_const :
201
+
?scope:binding list -> catalog -> Ast.value array -> Ast.expr -> Ast.value
202
+
(** [eval_const cat params e] evaluates [e] with no table row in scope, for
203
+
[INSERT ... VALUES] tuples. A column reference raises [Failure] unless it
204
+
resolves in [?scope] (a trigger's OLD/NEW rows). *)
205
+
206
+
val row_matches :
207
+
?scope:binding list ->
208
+
?rowid:int64 ->
209
+
catalog ->
210
+
Ast.value array ->
211
+
string ->
212
+
string list ->
213
+
Ast.expr option ->
214
+
Ast.value list ->
215
+
bool
216
+
(** [row_matches cat params table cols where vals] is whether the row [vals] of
217
+
[table] (aligned to [cols]) satisfies [where]. [None] matches every row.
218
+
Used to select the rows a [DELETE] removes. [?scope] adds outer bindings;
219
+
[?rowid] is the row's rowid, so [where] may reference the implicit rowid
220
+
column. *)
221
+
222
+
val eval_in_row :
223
+
?scope:binding list ->
224
+
?rowid:int64 ->
225
+
catalog ->
226
+
Ast.value array ->
227
+
string ->
228
+
string list ->
229
+
Ast.value list ->
230
+
Ast.expr ->
231
+
Ast.value
232
+
(** [eval_in_row cat params table cols vals e] evaluates [e] against the single
233
+
[table] row [vals] (aligned to [cols]) -- the right-hand side of an
234
+
[UPDATE ... SET] assignment, which may reference the row's columns. [?scope]
235
+
adds outer bindings (a trigger's OLD/NEW rows); [?rowid] is the row's rowid,
236
+
so [e] may reference the implicit rowid column. *)
237
+
238
+
val eval_upsert :
239
+
?scope:binding list ->
240
+
catalog ->
241
+
Ast.value array ->
242
+
table:string ->
243
+
cols:string list ->
244
+
current:Ast.value list ->
245
+
excluded:Ast.value list ->
246
+
Ast.expr ->
247
+
Ast.value
248
+
(** [eval_upsert cat params ~table ~cols ~current ~excluded e] evaluates an
249
+
[UPSERT] [DO UPDATE] expression with the conflicting row's [current] values
250
+
in scope under [table] and the would-be-inserted [excluded] values under the
251
+
[excluded] pseudo-table (both aligned to [cols]). *)
252
+
253
+
val returning_rows :
254
+
catalog ->
255
+
Ast.value array ->
256
+
table:string ->
257
+
cols:string list ->
258
+
Ast.result_col list ->
259
+
Ast.value list list ->
260
+
Ast.value list list
261
+
(** [returning_rows cat params ~table ~cols returning rows] projects a
262
+
[RETURNING] column list over each affected [row] of [table] ([cols] are the
263
+
table's column names, aligned to [row]); [*] expands to the whole row. *)
+227
lib/render.ml
+227
lib/render.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(* SQL renderer: an interpreter of the query AST that emits SQL text. It is the
7
+
inverse of {!Lexer.parse_statements} -- the output re-parses to the same
8
+
query and runs unchanged through the sqlite3 CLI -- and the sibling of
9
+
{!Query} (the executor): one AST, two interpretations (render and run).
10
+
11
+
Sub-expressions are fully parenthesised, so the output is unambiguous and
12
+
re-parseable without depending on operator precedence. *)
13
+
14
+
open Ast
15
+
16
+
let pp_comma ppf () = Fmt.string ppf ", "
17
+
18
+
let is_plain name =
19
+
name <> ""
20
+
&& (match name.[0] with 'a' .. 'z' | 'A' .. 'Z' | '_' -> true | _ -> false)
21
+
&& String.for_all
22
+
(function
23
+
| 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' -> true | _ -> false)
24
+
name
25
+
26
+
(* Bare when plain, double-quoted (with internal quotes doubled) otherwise,
27
+
matching SQLite's quoted-identifier syntax. *)
28
+
let pp_ident ppf name =
29
+
if is_plain name then Fmt.string ppf name
30
+
else
31
+
Fmt.pf ppf "\"%s\"" (String.concat "\"\"" (String.split_on_char '"' name))
32
+
33
+
let pp_string ppf s =
34
+
Fmt.pf ppf "'%s'" (String.concat "''" (String.split_on_char '\'' s))
35
+
36
+
let pp_hex ppf s = String.iter (fun c -> Fmt.pf ppf "%02x" (Char.code c)) s
37
+
38
+
(* %.17g round-trips a double; force a '.' so the lexer reads it back as a
39
+
float rather than an integer. *)
40
+
let pp_float ppf f =
41
+
let s = Fmt.str "%.17g" f in
42
+
if
43
+
String.exists
44
+
(function '.' | 'e' | 'E' | 'n' | 'i' -> true | _ -> false)
45
+
s
46
+
then Fmt.string ppf s
47
+
else Fmt.pf ppf "%s.0" s
48
+
49
+
let pp_value ppf = function
50
+
| Null -> Fmt.string ppf "NULL"
51
+
| Int i -> Fmt.pf ppf "%Ld" i
52
+
| Float f -> pp_float ppf f
53
+
| Text s -> pp_string ppf s
54
+
| Blob s -> Fmt.pf ppf "x'%a'" pp_hex s
55
+
56
+
let pp_binop ppf op =
57
+
Fmt.string ppf
58
+
(match op with
59
+
| Eq -> "="
60
+
| Neq -> "<>"
61
+
| Lt -> "<"
62
+
| Le -> "<="
63
+
| Gt -> ">"
64
+
| Ge -> ">="
65
+
| And -> "AND"
66
+
| Or -> "OR"
67
+
| Like -> "LIKE"
68
+
| Glob -> "GLOB"
69
+
| Add -> "+"
70
+
| Sub -> "-"
71
+
| Mul -> "*"
72
+
| Div -> "/"
73
+
| Mod -> "%"
74
+
| Bit_and -> "&"
75
+
| Bit_or -> "|"
76
+
| Shl -> "<<"
77
+
| Shr -> ">>"
78
+
| Concat -> "||"
79
+
| Json_get -> "->"
80
+
| Json_get_text -> "->>")
81
+
82
+
let pp_table_ref ppf (tr : table_ref) =
83
+
match tr.alias with
84
+
| None -> pp_ident ppf tr.name
85
+
| Some a -> Fmt.pf ppf "%a %a" pp_ident tr.name pp_ident a
86
+
87
+
let pp_set_op ppf = function
88
+
| Union -> Fmt.string ppf " UNION "
89
+
| Union_all -> Fmt.string ppf " UNION ALL "
90
+
| Except -> Fmt.string ppf " EXCEPT "
91
+
| Intersect -> Fmt.string ppf " INTERSECT "
92
+
93
+
let rec pp_expr ppf = function
94
+
| Lit v -> pp_value ppf v
95
+
| Param _ -> Fmt.char ppf '?'
96
+
| Col (None, n) -> pp_ident ppf n
97
+
| Col (Some t, n) -> Fmt.pf ppf "%a.%a" pp_ident t pp_ident n
98
+
| Star -> Fmt.char ppf '*'
99
+
| Qualified_star q -> Fmt.pf ppf "%a.*" pp_ident q
100
+
| Unop_not e -> Fmt.pf ppf "(NOT %a)" pp_expr e
101
+
| Binary (op, a, b) -> Fmt.pf ppf "(%a %a %a)" pp_expr a pp_binop op pp_expr b
102
+
| Is_null e -> Fmt.pf ppf "(%a IS NULL)" pp_expr e
103
+
| Is_not_null e -> Fmt.pf ppf "(%a IS NOT NULL)" pp_expr e
104
+
| Is (a, b) -> Fmt.pf ppf "(%a IS %a)" pp_expr a pp_expr b
105
+
| In_list (e, l) ->
106
+
Fmt.pf ppf "(%a IN (%a))" pp_expr e (Fmt.list ~sep:pp_comma pp_expr) l
107
+
| In_select (e, s) -> Fmt.pf ppf "(%a IN (%a))" pp_expr e pp_select s
108
+
| Scalar_select s -> Fmt.pf ppf "(%a)" pp_select s
109
+
| Exists s -> Fmt.pf ppf "(EXISTS (%a))" pp_select s
110
+
| Collate (e, c) -> Fmt.pf ppf "(%a COLLATE %s)" pp_expr e c
111
+
| Func (name, [ Star ]) -> Fmt.pf ppf "%a(*)" pp_ident name
112
+
| Func (name, args) ->
113
+
Fmt.pf ppf "%a(%a)" pp_ident name (Fmt.list ~sep:pp_comma pp_expr) args
114
+
| Distinct_agg (name, e) ->
115
+
Fmt.pf ppf "%a(DISTINCT %a)" pp_ident name pp_expr e
116
+
| Filter (a, p) -> Fmt.pf ppf "%a FILTER (WHERE %a)" pp_expr a pp_expr p
117
+
| Ordered_agg (Func (name, args), ob) ->
118
+
Fmt.pf ppf "%a(%a ORDER BY %a)" pp_ident name
119
+
(Fmt.list ~sep:pp_comma pp_expr)
120
+
args
121
+
(Fmt.list ~sep:pp_comma pp_order)
122
+
ob
123
+
| Ordered_agg (a, ob) ->
124
+
Fmt.pf ppf "%a ORDER BY %a" pp_expr a (Fmt.list ~sep:pp_comma pp_order) ob
125
+
| Window (a, w) ->
126
+
Fmt.pf ppf "%a OVER (" pp_expr a;
127
+
(match w.partition with
128
+
| [] -> ()
129
+
| l -> Fmt.pf ppf "PARTITION BY %a" (Fmt.list ~sep:pp_comma pp_expr) l);
130
+
(match w.order with
131
+
| [] -> ()
132
+
| l ->
133
+
if w.partition <> [] then Fmt.string ppf " ";
134
+
Fmt.pf ppf "ORDER BY %a" (Fmt.list ~sep:pp_comma pp_order) l);
135
+
Fmt.char ppf ')'
136
+
| Cast (e, ty) -> Fmt.pf ppf "CAST(%a AS %s)" pp_expr e ty
137
+
| Case (base, branches, els) ->
138
+
Fmt.pf ppf "(CASE";
139
+
(match base with None -> () | Some b -> Fmt.pf ppf " %a" pp_expr b);
140
+
List.iter
141
+
(fun (c, r) -> Fmt.pf ppf " WHEN %a THEN %a" pp_expr c pp_expr r)
142
+
branches;
143
+
(match els with None -> () | Some e -> Fmt.pf ppf " ELSE %a" pp_expr e);
144
+
Fmt.pf ppf " END)"
145
+
146
+
and pp_result_col ppf (rc : result_col) =
147
+
match rc.alias with
148
+
| None -> pp_expr ppf rc.expr
149
+
| Some a -> Fmt.pf ppf "%a AS %a" pp_expr rc.expr pp_ident a
150
+
151
+
and pp_order ppf (e, dir) =
152
+
Fmt.pf ppf "%a%s" pp_expr e (match dir with Asc -> "" | Desc -> " DESC")
153
+
154
+
and pp_join ppf j =
155
+
let kw =
156
+
match j.type_ with
157
+
| Inner -> "JOIN"
158
+
| Left -> "LEFT JOIN"
159
+
| Right -> "RIGHT JOIN"
160
+
| Full -> "FULL OUTER JOIN"
161
+
in
162
+
if j.natural then Fmt.pf ppf " NATURAL %s %a" kw pp_table_ref j.table
163
+
else if j.using <> [] then
164
+
Fmt.pf ppf " %s %a USING (%a)" kw pp_table_ref j.table
165
+
(Fmt.list ~sep:pp_comma pp_ident)
166
+
j.using
167
+
else Fmt.pf ppf " %s %a ON %a" kw pp_table_ref j.table pp_expr j.on
168
+
169
+
and pp_from ppf : Ast.from_clause -> unit = function
170
+
| Unit -> ()
171
+
| Table tr -> pp_table_ref ppf tr
172
+
| Select { fs_select; fs_alias } -> (
173
+
match fs_alias with
174
+
| None -> Fmt.pf ppf "(%a)" pp_select fs_select
175
+
| Some a -> Fmt.pf ppf "(%a) %a" pp_select fs_select pp_ident a)
176
+
| Values rows ->
177
+
let pp_tuple ppf t =
178
+
Fmt.pf ppf "(%a)" (Fmt.list ~sep:pp_comma pp_expr) t
179
+
in
180
+
Fmt.pf ppf "(VALUES %a)" (Fmt.list ~sep:pp_comma pp_tuple) rows
181
+
| Table_function { tf_name; tf_args; tf_alias } ->
182
+
Fmt.pf ppf "%a(%a)" pp_ident tf_name
183
+
(Fmt.list ~sep:pp_comma pp_expr)
184
+
tf_args;
185
+
Option.iter (fun a -> Fmt.pf ppf " %a" pp_ident a) tf_alias
186
+
187
+
and pp_cte ppf (c : Ast.cte) =
188
+
match c.columns with
189
+
| [] -> Fmt.pf ppf "%a AS (%a)" pp_ident c.name pp_select c.query
190
+
| cols ->
191
+
Fmt.pf ppf "%a (%a) AS (%a)" pp_ident c.name
192
+
(Fmt.list ~sep:pp_comma pp_ident)
193
+
cols pp_select c.query
194
+
195
+
(* A core: SELECT cols / FROM / WHERE / GROUP BY, no WITH / compound / ORDER BY /
196
+
LIMIT (those wrap the whole compound). *)
197
+
and pp_core ppf s =
198
+
Fmt.pf ppf "SELECT %s%a"
199
+
(if s.distinct then "DISTINCT " else "")
200
+
(Fmt.list ~sep:pp_comma pp_result_col)
201
+
s.cols;
202
+
(match s.from with Unit -> () | f -> Fmt.pf ppf " FROM %a" pp_from f);
203
+
Fmt.pf ppf "%a" (Fmt.list ~sep:Fmt.nop pp_join) s.joins;
204
+
(match s.where with None -> () | Some w -> Fmt.pf ppf " WHERE %a" pp_expr w);
205
+
(match s.group_by with
206
+
| [] -> ()
207
+
| l -> Fmt.pf ppf " GROUP BY %a" (Fmt.list ~sep:pp_comma pp_expr) l);
208
+
match s.having with None -> () | Some h -> Fmt.pf ppf " HAVING %a" pp_expr h
209
+
210
+
and pp_select ppf s =
211
+
(match s.ctes with
212
+
| [] -> ()
213
+
| l -> Fmt.pf ppf "WITH %a " (Fmt.list ~sep:pp_comma pp_cte) l);
214
+
pp_core ppf s;
215
+
List.iter
216
+
(fun (op, arm) ->
217
+
pp_set_op ppf op;
218
+
pp_core ppf arm)
219
+
s.compound;
220
+
(match s.order_by with
221
+
| [] -> ()
222
+
| l -> Fmt.pf ppf " ORDER BY %a" (Fmt.list ~sep:pp_comma pp_order) l);
223
+
(match s.limit with None -> () | Some n -> Fmt.pf ppf " LIMIT %a" pp_expr n);
224
+
match s.offset with None -> () | Some o -> Fmt.pf ppf " OFFSET %a" pp_expr o
225
+
226
+
let expr e = Fmt.str "%a" pp_expr e
227
+
let select s = Fmt.str "%a" pp_select s
+20
lib/render.mli
+20
lib/render.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2025 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** Render the query AST back to SQL text — the inverse of the parser and the
7
+
sibling of the executor. The output re-parses to the same query and runs
8
+
unchanged through the sqlite3 CLI. *)
9
+
10
+
val pp_expr : Ast.expr Fmt.t
11
+
(** Render an expression, fully parenthesised. *)
12
+
13
+
val pp_select : Ast.select Fmt.t
14
+
(** [pp_select] is the pretty-printer for a [SELECT] statement. *)
15
+
16
+
val expr : Ast.expr -> string
17
+
(** [expr e] is {!pp_expr} as a string. *)
18
+
19
+
val select : Ast.select -> string
20
+
(** [select s] is {!pp_select} as a string. *)
+88
lib/value_op.ml
+88
lib/value_op.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2026 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(* SQLite's value-level binary operators keyed by the AST's {!Ast.binop}: the
7
+
comparison value (with column affinity), the opcode-free operators
8
+
(AND/OR/LIKE/GLOB/||/JSON), and [IN (list)] membership. Built on the
9
+
AST-free {!Value_ops} and the function layer {!Func}; shared by the
10
+
tree-walker and the register VM so an operator's value agrees in both. *)
11
+
12
+
open Ast
13
+
open Value_ops
14
+
15
+
(* A comparison's value: NULL if either operand is NULL, else 1/0 for the
16
+
ordering under the optional collation. *)
17
+
let compare_op ?coll op a b =
18
+
if a = Null || b = Null then Null
19
+
else
20
+
let c =
21
+
match coll with
22
+
| Some name -> compare_values_coll name a b
23
+
| None -> compare_values a b
24
+
in
25
+
match op with
26
+
| Eq -> bool (c = 0)
27
+
| Neq -> bool (c <> 0)
28
+
| Lt -> bool (c < 0)
29
+
| Le -> bool (c <= 0)
30
+
| Gt -> bool (c > 0)
31
+
| Ge -> bool (c >= 0)
32
+
| And | Or | Like | Glob | Add | Sub | Mul | Div | Mod | Bit_and | Bit_or
33
+
| Shl | Shr | Concat | Json_get | Json_get_text ->
34
+
assert false
35
+
36
+
(* [v IN (candidates)] as a three-valued membership: an empty set is always
37
+
false (so [NOT IN ()] is always true, even for a NULL left operand); else a
38
+
NULL left operand is NULL; else 1 if any candidate compares equal, NULL if
39
+
none match but a NULL candidate is present, 0 otherwise. *)
40
+
let in_eval ?coll v candidates =
41
+
if candidates = [] then Int 0L
42
+
else if v = Null then Null
43
+
else
44
+
let cmp = List.map (fun x -> compare_op ?coll Eq v x) candidates in
45
+
if List.exists (fun r -> r = Int 1L) cmp then Int 1L
46
+
else if List.exists (fun r -> r = Null) cmp then Null
47
+
else Int 0L
48
+
49
+
(* A comparison's value with SQLite's column affinity: a numeric-valued column
50
+
coerces a well-formed text operand to a number ([c = '5'] matches when [c] is
51
+
numeric), while two literals get no affinity. [a_col]/[b_col] mark whether
52
+
each operand is a column. *)
53
+
let compare_with_affinity ?coll ~a_col ~b_col op va vb =
54
+
let va, vb =
55
+
match (a_col, va, b_col, vb) with
56
+
| true, (Int _ | Float _), _, (Text _ | Blob _) -> (va, num_coerce vb)
57
+
| _, (Text _ | Blob _), true, (Int _ | Float _) -> (num_coerce va, vb)
58
+
| _ -> (va, vb)
59
+
in
60
+
compare_op ?coll op va vb
61
+
62
+
(* The value of a binary operator with no per-element opcode and no affinity:
63
+
the three-valued AND/OR (both operands evaluated -- SQLite's AND/OR are pure
64
+
3VL, not short-circuit), LIKE/GLOB pattern tests, [||] concatenation, and the
65
+
JSON [->]/[->>] accessors. Arithmetic and comparison are handled elsewhere. *)
66
+
let binop_value op va vb =
67
+
match op with
68
+
| And -> value_of_tri (tri_and (tri_of va) (tri_of vb))
69
+
| Or -> value_of_tri (tri_or (tri_of va) (tri_of vb))
70
+
| Like -> like_op va vb
71
+
| Glob -> glob_op va vb
72
+
| Concat -> concat_op va vb
73
+
| Json_get -> Func.json_arrow ~as_text:false va vb
74
+
| Json_get_text -> Func.json_arrow ~as_text:true va vb
75
+
| Eq | Neq | Lt | Le | Gt | Ge | Add | Sub | Mul | Div | Mod | Bit_and
76
+
| Bit_or | Shl | Shr ->
77
+
assert false
78
+
79
+
(* The value of [v IN (cands)] with SQLite's affinity: a numeric left column
80
+
([e_col] with a numeric [v]) coerces each text candidate to a number, then
81
+
the three-valued {!in_eval} decides membership. *)
82
+
let in_list_value ?coll ~e_col v cands =
83
+
let cands =
84
+
match (e_col, v) with
85
+
| true, (Int _ | Float _) -> List.map num_coerce cands
86
+
| _ -> cands
87
+
in
88
+
in_eval ?coll v cands
+46
lib/value_op.mli
+46
lib/value_op.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2026 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** SQLite's value-level binary operators, keyed by the AST's {!Ast.binop}.
7
+
8
+
The comparison value (with column affinity and collation), the opcode-free
9
+
operators (AND/OR/LIKE/GLOB/[||]/JSON), and [IN (list)] membership, over
10
+
{!Value_ops} and {!Func}. Shared by the tree-walker and the register VM so
11
+
an operator's value agrees in both. *)
12
+
13
+
val compare_op :
14
+
?coll:string -> Ast.binop -> Ast.value -> Ast.value -> Ast.value
15
+
(** [compare_op op a b] is a comparison's value: NULL if either operand is NULL,
16
+
else [1]/[0] for the ordering under the optional collation [coll]. *)
17
+
18
+
val in_eval : ?coll:string -> Ast.value -> Ast.value list -> Ast.value
19
+
(** [in_eval v candidates] is [v IN (candidates)] as a three-valued membership:
20
+
an empty set is [0] (so [NOT IN ()] is [1]); a NULL [v] over a non-empty set
21
+
is NULL; else [1] on a match, NULL if none match but a NULL candidate is
22
+
present, [0] otherwise. *)
23
+
24
+
val compare_with_affinity :
25
+
?coll:string ->
26
+
a_col:bool ->
27
+
b_col:bool ->
28
+
Ast.binop ->
29
+
Ast.value ->
30
+
Ast.value ->
31
+
Ast.value
32
+
(** [compare_with_affinity ~a_col ~b_col op a b] is the comparison value
33
+
applying SQLite's column affinity: a numeric column coerces a well-formed
34
+
text operand to a number ([c = '5'] matches a numeric [c]), two literals get
35
+
no affinity. [a_col]/[b_col] mark whether each operand is a column. *)
36
+
37
+
val binop_value : Ast.binop -> Ast.value -> Ast.value -> Ast.value
38
+
(** [binop_value op a b] is the value of an opcode-free binary operator: the
39
+
three-valued AND/OR, LIKE/GLOB, [||] concatenation, and the JSON accessors.
40
+
Arithmetic and comparison operators do not reach here. *)
41
+
42
+
val in_list_value :
43
+
?coll:string -> e_col:bool -> Ast.value -> Ast.value list -> Ast.value
44
+
(** [in_list_value ~e_col v cands] is [v IN (cands)] with affinity: a numeric
45
+
left column [e_col] coerces each text candidate to a number, then {!in_eval}
46
+
decides membership. *)
+423
lib/value_ops.ml
+423
lib/value_ops.ml
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2026 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
open Catalog.Value
7
+
8
+
let type_rank = function
9
+
| Null -> 0
10
+
| Int _ | Float _ -> 1
11
+
| Text _ -> 2
12
+
| Blob _ -> 3
13
+
14
+
let float_of_value = function
15
+
| Int i -> Int64.to_float i
16
+
| Float f -> f
17
+
| _ -> invalid_arg "float_of_value"
18
+
19
+
(* Exact order of an int64 [i] against a float [r] without the precision loss of
20
+
widening [i] to a double (sqlite3IntFloatCompare): a float of magnitude >= 2^63
21
+
is outside int64 range and decides by sign; otherwise compare against the
22
+
truncated float, breaking a tie by [i] rendered back as a double. So
23
+
[9223372036854775807] sorts below the double [9223372036854775808.0] rather
24
+
than rounding up to equal it. *)
25
+
let int_float_compare i r =
26
+
let two63 = 0x1p63 in
27
+
if Float.is_nan r then 1
28
+
else if r >= two63 then -1
29
+
else if r < -.two63 then 1
30
+
else
31
+
let y = Int64.of_float r in
32
+
let c = Int64.compare i y in
33
+
if c <> 0 then c else Float.compare (Int64.to_float i) r
34
+
35
+
let compare_values a b =
36
+
match (a, b) with
37
+
| Null, Null -> 0
38
+
| Int x, Int y -> Int64.compare x y
39
+
| Int x, Float y -> int_float_compare x y
40
+
| Float x, Int y -> -int_float_compare y x
41
+
| Float x, Float y -> Float.compare x y
42
+
| Text x, Text y -> String.compare x y
43
+
| Blob x, Blob y -> String.compare x y
44
+
| _ -> Int.compare (type_rank a) (type_rank b)
45
+
46
+
(* The canonical bytes a collation compares by: BINARY is the string itself,
47
+
NOCASE folds ASCII case, RTRIM drops trailing spaces. Two texts collate equal
48
+
exactly when their keys are byte-equal, so it also drives a collation-aware
49
+
DISTINCT. An unknown name is an error, as in sqlite3. *)
50
+
let collate_key name s =
51
+
match name with
52
+
| "BINARY" -> s
53
+
| "NOCASE" -> String.lowercase_ascii s
54
+
| "RTRIM" ->
55
+
let n = ref (String.length s) in
56
+
while !n > 0 && s.[!n - 1] = ' ' do
57
+
decr n
58
+
done;
59
+
String.sub s 0 !n
60
+
| _ -> Fmt.failwith "no such collating sequence: %s" name
61
+
62
+
let collate_text name x y =
63
+
String.compare (collate_key name x) (collate_key name y)
64
+
65
+
(* [compare_values] with a named collation applied to a text/text comparison.
66
+
The collation is irrelevant to non-text operands, which compare as usual. *)
67
+
let compare_values_coll name a b =
68
+
match (a, b) with
69
+
| Text x, Text y -> collate_text name x y
70
+
| _ -> compare_values a b
71
+
72
+
(* A value's canonical form under collation [name]: text is mapped so two values
73
+
equal under the collation share a form (and order by it), anything else is
74
+
unchanged. Lets a caller bucket / dedup by a collated key with plain equality.
75
+
An unknown collation raises [Not_found] so the caller can fall back. *)
76
+
let collation_key name v =
77
+
match v with
78
+
| Text s -> (
79
+
try Text (collate_key name s) with Failure _ -> raise Not_found)
80
+
| _ -> v
81
+
82
+
(* Render a float as the sqlite3 CLI does: a whole value with one decimal
83
+
("2.0"), otherwise C [%.15g] (15 significant digits, the precision sqlite3
84
+
prints), forcing a decimal point so it reads back as a real. *)
85
+
let text_of_float f =
86
+
if Float.is_nan f then "NULL"
87
+
else if f = Float.infinity then "Inf"
88
+
else if f = Float.neg_infinity then "-Inf"
89
+
else if Float.is_integer f && Float.abs f < 1e15 then Fmt.str "%.1f" f
90
+
else
91
+
let s = Fmt.str "%.15g" f in
92
+
if String.exists (function '.' | 'e' | 'E' -> true | _ -> false) s then s
93
+
else s ^ ".0"
94
+
95
+
let text_of_value = function
96
+
| Text s | Blob s -> s
97
+
| Int i -> Int64.to_string i
98
+
| Float f -> text_of_float f
99
+
| Null -> ""
100
+
101
+
(* Three-valued logic for WHERE/AND/OR/NOT/HAVING: a value's truth is unknown
102
+
([U]) for NULL, true/false for a non-zero/zero number, and a text/blob is
103
+
coerced by its leading numeric prefix (so ['abc'] and [''] are false, ['5x']
104
+
is true) -- the same coercion as numeric affinity, as sqlite3's [if] test. *)
105
+
type tri = T | F | U
106
+
107
+
let tri_of v =
108
+
match v with
109
+
| Null -> U
110
+
| Int 0L -> F
111
+
| Int _ -> T
112
+
| Float f -> if f = 0. then F else T
113
+
| Text _ | Blob _ -> (
114
+
match leading_number (text_of_value v) with
115
+
| Int 0L | Float 0. -> F
116
+
| _ -> T)
117
+
118
+
let value_of_tri = function T -> Int 1L | F -> Int 0L | U -> Null
119
+
let tri_and a b = match (a, b) with F, _ | _, F -> F | T, T -> T | _ -> U
120
+
let tri_or a b = match (a, b) with T, _ | _, T -> T | F, F -> F | _ -> U
121
+
let tri_not = function T -> F | F -> T | U -> U
122
+
let not_value v = value_of_tri (tri_not (tri_of v))
123
+
let bool v = if v then Int 1L else Int 0L
124
+
125
+
(* SQLite's NULL-safe equality [a IS b]: two NULLs are equal, a NULL and a
126
+
non-NULL are not, else an ordinary value comparison (no affinity). Always 1 or
127
+
0, never NULL. *)
128
+
let is_value va vb =
129
+
bool
130
+
(match (va, vb) with
131
+
| Null, Null -> true
132
+
| Null, _ | _, Null -> false
133
+
| _ -> compare_values va vb = 0)
134
+
135
+
(* SUM/AVG/MIN/MAX/TOTAL over [vals], the non-NULL argument values of a group
136
+
(lang_aggfunc.html): SUM is integer when every value is, AVG and TOTAL are
137
+
real; SUM/MIN/MAX over no values is NULL, TOTAL is 0.0. *)
138
+
let numeric_agg name vals =
139
+
(* SUM over all-integer values stays an integer, but -- unlike [+], which
140
+
promotes on overflow -- sqlite3 raises "integer overflow" if the int64 sum
141
+
overflows (TOTAL and a mixed/real SUM accumulate as float and never do). *)
142
+
let sum_int () =
143
+
let add a v =
144
+
let x = match v with Int i -> i | _ -> 0L in
145
+
let r = Int64.add a x in
146
+
if a >= 0L = (x >= 0L) && r >= 0L <> (a >= 0L) then
147
+
failwith "integer overflow"
148
+
else r
149
+
in
150
+
Int (List.fold_left add 0L vals)
151
+
in
152
+
let sum_float () =
153
+
List.fold_left (fun a v -> a +. float_of_value v) 0. vals
154
+
in
155
+
let all_int = List.for_all (function Int _ -> true | _ -> false) vals in
156
+
let extreme keep = function
157
+
| [] -> Null
158
+
| v :: vs ->
159
+
List.fold_left
160
+
(fun a x -> if keep (compare_values x a) then x else a)
161
+
v vs
162
+
in
163
+
match name with
164
+
| "sum" ->
165
+
if vals = [] then Null
166
+
else if all_int then sum_int ()
167
+
else Float (sum_float ())
168
+
| "total" -> Float (sum_float ())
169
+
| "avg" ->
170
+
if vals = [] then Null
171
+
else Float (sum_float () /. float_of_int (List.length vals))
172
+
| "min" -> extreme (fun c -> c < 0) vals
173
+
| "max" -> extreme (fun c -> c > 0) vals
174
+
| _ -> Fmt.failwith "unknown aggregate %s()" name
175
+
176
+
(* The distinct values of [vs], by {!compare_values} equality, keeping the first
177
+
occurrence -- a [DISTINCT] aggregate's argument values. *)
178
+
let distinct_values vs =
179
+
let seen = ref [] in
180
+
List.filter
181
+
(fun v ->
182
+
if List.exists (fun u -> compare_values u v = 0) !seen then false
183
+
else (
184
+
seen := v :: !seen;
185
+
true))
186
+
vs
187
+
188
+
(* Whether [s] contains the substring [sub]. *)
189
+
let contains_sub s sub = Re.execp Re.(compile (str sub)) s
190
+
191
+
(* A declared type name's storage affinity (datatype3.html sec.3.1): a name
192
+
containing INT is INTEGER, CHAR/CLOB/TEXT is TEXT, BLOB or "" is BLOB,
193
+
REAL/FLOA/DOUB is REAL, anything else NUMERIC. *)
194
+
let affinity_of_type ty =
195
+
let u = String.uppercase_ascii ty in
196
+
if contains_sub u "INT" then `Integer
197
+
else if
198
+
contains_sub u "CHAR" || contains_sub u "CLOB" || contains_sub u "TEXT"
199
+
then `Text
200
+
else if contains_sub u "BLOB" || ty = "" then `Blob
201
+
else if
202
+
contains_sub u "REAL" || contains_sub u "FLOA" || contains_sub u "DOUB"
203
+
then `Real
204
+
else `Numeric
205
+
206
+
(* Apply a column's storage affinity to a value being written (datatype3 sec.3):
207
+
NUMERIC/INTEGER read a well-formed numeric TEXT as an integer (or real when it
208
+
is fractional or too big for int64), TEXT renders a number as text, REAL
209
+
coerces a number to float; a BLOB, NULL, and non-numeric text are unchanged.
210
+
[ty] is the column's declared type text ([""] = no affinity). *)
211
+
let apply_affinity ty v =
212
+
let numify s =
213
+
let s = String.trim s in
214
+
match Int64.of_string_opt s with
215
+
| Some i -> Int i
216
+
| None -> (
217
+
match float_of_string_opt s with Some f -> Float f | None -> v)
218
+
in
219
+
match (affinity_of_type ty, v) with
220
+
| _, Null -> v
221
+
| `Blob, _ -> v
222
+
| `Text, (Int _ | Float _) -> Text (text_of_value v)
223
+
| `Text, _ -> v
224
+
| (`Numeric | `Integer), Text s -> numify s
225
+
| (`Numeric | `Integer), _ -> v
226
+
| `Real, Text s -> (
227
+
match float_of_string_opt (String.trim s) with
228
+
| Some f -> Float f
229
+
| None -> v)
230
+
| `Real, Int i -> Float (Int64.to_float i)
231
+
| `Real, _ -> v
232
+
233
+
(* Leading numeric prefix of [s] as a float, 0. if none -- SQLite's
234
+
text-to-number cast parses a prefix (after optional whitespace) and ignores
235
+
trailing junk, exactly like C's [strtod], which [Scanf]'s [%f] mirrors. *)
236
+
let numeric_prefix s =
237
+
try Scanf.sscanf s " %f" Fun.id
238
+
with Scanf.Scan_failure _ | End_of_file -> 0.
239
+
240
+
(* Leading INTEGER prefix of [s] (optional sign then digits), 0 if none --
241
+
CAST(text AS INTEGER) reads only the integer part, stopping at the first
242
+
non-digit, so [CAST('123e+5' AS INTEGER)] is 123, not 12300000 (which is the
243
+
REAL/NUMERIC reading). Overflow saturates rather than wrapping. *)
244
+
let integer_prefix s =
245
+
let s = String.trim s in
246
+
let n = String.length s in
247
+
let i = ref 0 in
248
+
if !i < n && (s.[!i] = '+' || s.[!i] = '-') then incr i;
249
+
let digits_start = !i in
250
+
while !i < n && s.[!i] >= '0' && s.[!i] <= '9' do
251
+
incr i
252
+
done;
253
+
if !i = digits_start then 0L
254
+
else
255
+
match Int64.of_string_opt (String.sub s 0 !i) with
256
+
| Some x -> x
257
+
| None -> if s.[0] = '-' then Int64.min_int else Int64.max_int
258
+
259
+
(* CAST(v AS ty) per the target affinity (lang_expr.html#castexpr). NULL is
260
+
preserved; text/blob to a numeric type parses a leading numeric prefix. *)
261
+
let cast ty v =
262
+
match (affinity_of_type ty, v) with
263
+
| _, Null -> Null
264
+
| `Text, _ -> Text (text_of_value v)
265
+
| `Blob, Blob _ -> v
266
+
| `Blob, _ -> Blob (text_of_value v)
267
+
| `Integer, Int _ -> v
268
+
| `Integer, Float f -> Int (Int64.of_float f)
269
+
| `Integer, _ -> Int (integer_prefix (text_of_value v))
270
+
| `Real, Int i -> Float (Int64.to_float i)
271
+
| `Real, Float _ -> v
272
+
| `Real, _ -> Float (numeric_prefix (text_of_value v))
273
+
| `Numeric, (Int _ | Float _) -> v
274
+
| `Numeric, _ ->
275
+
let s = text_of_value v in
276
+
let f = numeric_prefix s in
277
+
(* sqlite3's NUMERIC affinity collapses an integral value to INTEGER:
278
+
integer-syntax text up to the int64 range, but float-syntax text (with a
279
+
'.' or exponent) only within +/-2^51, the lossless float<->int window of
280
+
sqlite3RealSameAsInt. A non-integral or larger value stays REAL. *)
281
+
let float_syntax =
282
+
String.exists (function '.' | 'e' | 'E' -> true | _ -> false) s
283
+
in
284
+
let limit = if float_syntax then 0x1p51 else 9.2e18 in
285
+
if Float.is_integer f && Float.abs f < limit then Int (Int64.of_float f)
286
+
else Float f
287
+
288
+
(* Whether [v] reads as a real rather than an integer -- a float, or text that
289
+
spells a real but not an integer. *)
290
+
let is_real = function
291
+
| Float _ -> true
292
+
| Text s -> (
293
+
let s = String.trim s in
294
+
match Int64.of_string_opt s with
295
+
| Some _ -> false
296
+
| None -> float_of_string_opt s <> None)
297
+
| _ -> false
298
+
299
+
(* Numeric affinity: integers and reals pass through; text becomes the integer
300
+
or real it spells (an integer if it has no fractional/exponent part), or 0 if
301
+
it is not numeric -- matching how sqlite3 coerces an operand in arithmetic. *)
302
+
let numeric_affinity v =
303
+
match v with
304
+
| Int _ | Float _ -> v
305
+
| _ -> (
306
+
match leading_number (text_of_value v) with
307
+
| Int n -> Int n
308
+
| Float f -> Float f
309
+
| _ -> Int 0L)
310
+
311
+
(* Comparison-affinity coercion: convert a text/blob to a number only when it is
312
+
a well-formed numeric literal, otherwise leave it unchanged. Unlike
313
+
{!numeric_affinity} (arithmetic, where non-numeric text is 0), a non-numeric
314
+
string stays text so it does not spuriously equal a number. *)
315
+
let num_coerce v =
316
+
match v with
317
+
| Text s | Blob s -> (
318
+
let s = String.trim s in
319
+
match Int64.of_string_opt s with
320
+
| Some i -> Int i
321
+
| None -> (
322
+
match float_of_string_opt s with Some f -> Float f | None -> v))
323
+
| _ -> v
324
+
325
+
(* [v] as an int64 -- SQLite's integer coercion of a value (a float truncates,
326
+
text reads its leading number, anything non-numeric is 0). *)
327
+
let intify = function
328
+
| Int i -> i
329
+
| Float f -> Int64.of_float f
330
+
| v -> (
331
+
match leading_number (text_of_value v) with
332
+
| Int n -> n
333
+
| Float f -> Int64.of_float f
334
+
| _ -> 0L)
335
+
336
+
(* SQL [LIKE]: [%] matches any run, [_] any single character, ASCII
337
+
case-insensitive; [~escape] makes a character match the next one literally. *)
338
+
let like_match ?escape pattern str =
339
+
let p = String.lowercase_ascii pattern in
340
+
let s = String.lowercase_ascii str in
341
+
let esc = Option.map Char.lowercase_ascii escape in
342
+
let pl = String.length p and sl = String.length s in
343
+
let rec go pi si =
344
+
if pi = pl then si = sl
345
+
else if Some p.[pi] = esc && pi + 1 < pl then
346
+
si < sl && s.[si] = p.[pi + 1] && go (pi + 2) (si + 1)
347
+
else
348
+
match p.[pi] with
349
+
| '%' -> go (pi + 1) si || (si < sl && go pi (si + 1))
350
+
| '_' -> si < sl && go (pi + 1) (si + 1)
351
+
| c -> si < sl && s.[si] = c && go (pi + 1) (si + 1)
352
+
in
353
+
go 0 0
354
+
355
+
(* GLOB: case-sensitive Unix-style wildcards. [*] matches any run, [?] one
356
+
character, and [[..]] a character class (ranges with [-], negation with a
357
+
leading [^]). *)
358
+
let glob_match pattern str =
359
+
let pl = String.length pattern and sl = String.length str in
360
+
let class_match neg cstart cend c =
361
+
let rec scan k =
362
+
if k >= cend then false
363
+
else if k + 2 < cend && pattern.[k + 1] = '-' then
364
+
if c >= pattern.[k] && c <= pattern.[k + 2] then true else scan (k + 3)
365
+
else if pattern.[k] = c then true
366
+
else scan (k + 1)
367
+
in
368
+
let m = scan cstart in
369
+
if neg then not m else m
370
+
in
371
+
let bracket pi =
372
+
let neg = pi + 1 < pl && pattern.[pi + 1] = '^' in
373
+
let cstart = if neg then pi + 2 else pi + 1 in
374
+
let j =
375
+
ref (if cstart < pl && pattern.[cstart] = ']' then cstart + 1 else cstart)
376
+
in
377
+
while !j < pl && pattern.[!j] <> ']' do
378
+
incr j
379
+
done;
380
+
if !j >= pl then `Literal else `Class (neg, cstart, !j)
381
+
in
382
+
let rec go pi si =
383
+
if pi = pl then si = sl
384
+
else
385
+
match pattern.[pi] with
386
+
| '*' -> go (pi + 1) si || (si < sl && go pi (si + 1))
387
+
| '?' -> si < sl && go (pi + 1) (si + 1)
388
+
| '[' -> (
389
+
match bracket pi with
390
+
| `Literal -> si < sl && str.[si] = '[' && go (pi + 1) (si + 1)
391
+
| `Class (neg, cstart, close) ->
392
+
si < sl
393
+
&& class_match neg cstart close str.[si]
394
+
&& go (close + 1) (si + 1))
395
+
| c -> si < sl && str.[si] = c && go (pi + 1) (si + 1)
396
+
in
397
+
go 0 0
398
+
399
+
(* [a LIKE b]: NULL if either operand is NULL, else the LIKE match as 1/0;
400
+
[~escape] is the optional single-character ESCAPE. *)
401
+
let like_op ?escape a b =
402
+
match (a, b) with
403
+
| Null, _ | _, Null -> Null
404
+
| _ -> (
405
+
match escape with
406
+
| Some e when text_of_value e = "" ->
407
+
failwith "ESCAPE expression must be a single character"
408
+
| Some e ->
409
+
let ec = (text_of_value e).[0] in
410
+
bool (like_match ~escape:ec (text_of_value b) (text_of_value a))
411
+
| None -> bool (like_match (text_of_value b) (text_of_value a)))
412
+
413
+
(* [a GLOB b]: NULL if either operand is NULL, else the GLOB match as 1/0. *)
414
+
let glob_op a b =
415
+
match (a, b) with
416
+
| Null, _ | _, Null -> Null
417
+
| _ -> bool (glob_match (text_of_value b) (text_of_value a))
418
+
419
+
(* [a || b]: NULL if either operand is NULL, else the text forms concatenated. *)
420
+
let concat_op a b =
421
+
match (a, b) with
422
+
| Null, _ | _, Null -> Null
423
+
| _ -> Text (text_of_value a ^ text_of_value b)
+134
lib/value_ops.mli
+134
lib/value_ops.mli
···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2026 Thomas Gazagnaire. All rights reserved.
3
+
SPDX-License-Identifier: MIT
4
+
---------------------------------------------------------------------------*)
5
+
6
+
(** SQLite's value-level semantics, shared by the tree-walker and the
7
+
register-VM paths: storage-class comparison order, collated comparison, text
8
+
conversion, and the aggregate folds. A pure layer over {!Catalog.Value.t}
9
+
with no dependency on the AST or the evaluator, so every executor folds and
10
+
orders values the same way. *)
11
+
12
+
val compare_values : Catalog.Value.t -> Catalog.Value.t -> int
13
+
(** [compare_values a b] orders two values by SQLite's storage-class rule (NULL
14
+
< number < text < blob; numbers compared exactly across int/real). *)
15
+
16
+
val compare_values_coll : string -> Catalog.Value.t -> Catalog.Value.t -> int
17
+
(** [compare_values_coll name a b] orders under collation [name] (BINARY /
18
+
NOCASE / RTRIM) for a text/text comparison, else by {!compare_values}. *)
19
+
20
+
val collation_key : string -> Catalog.Value.t -> Catalog.Value.t
21
+
(** [collation_key name v] is [v]'s canonical form under collation [name]: two
22
+
text values equal under the collation share a form (so a caller can bucket /
23
+
dedup by it with plain equality), anything else unchanged.
24
+
@raise Not_found on an unknown collation. *)
25
+
26
+
val float_of_value : Catalog.Value.t -> float
27
+
(** [float_of_value v] is the [REAL] value of a numeric [v] ([Int]/[Float]).
28
+
@raise Invalid_argument on a non-numeric value. *)
29
+
30
+
val text_of_value : Catalog.Value.t -> string
31
+
(** [text_of_value v] is SQLite's text conversion of [v] (the [CAST(v AS TEXT)]
32
+
rendering: a float carries a decimal point, NULL is the empty string). *)
33
+
34
+
type tri =
35
+
| T
36
+
| F
37
+
| U (** A three-valued truth: true, false, or unknown (NULL). *)
38
+
39
+
val tri_of : Catalog.Value.t -> tri
40
+
(** [tri_of v] is [v]'s truth: unknown for NULL, true/false for a non-zero/zero
41
+
number, a text/blob coerced by its leading numeric prefix. *)
42
+
43
+
val value_of_tri : tri -> Catalog.Value.t
44
+
(** [value_of_tri t] is [1] for true, [0] for false, NULL for unknown. *)
45
+
46
+
val tri_and : tri -> tri -> tri
47
+
(** Three-valued [AND]: false dominates, unknown is contagious otherwise. *)
48
+
49
+
val tri_or : tri -> tri -> tri
50
+
(** Three-valued [OR]: true dominates, unknown is contagious otherwise. *)
51
+
52
+
val tri_not : tri -> tri
53
+
(** Three-valued [NOT]: true and false flip, unknown stays. *)
54
+
55
+
val not_value : Catalog.Value.t -> Catalog.Value.t
56
+
(** [not_value v] is the three-valued logical [NOT] of [v] as a [1]/[0]/NULL. *)
57
+
58
+
val bool : bool -> Catalog.Value.t
59
+
(** [bool b] is [1] for [true], [0] for [false]. *)
60
+
61
+
val is_value : Catalog.Value.t -> Catalog.Value.t -> Catalog.Value.t
62
+
(** [is_value a b] is SQLite's NULL-safe equality [a IS b] as [1]/[0] (never
63
+
NULL): two NULLs are equal, a NULL and a non-NULL are not, else an ordinary
64
+
value comparison. *)
65
+
66
+
val numeric_agg : string -> Catalog.Value.t list -> Catalog.Value.t
67
+
(** [numeric_agg name vals] folds the non-NULL aggregate values [vals] for one
68
+
of [sum]/[total]/[avg]/[min]/[max]: SUM stays integer when every value is
69
+
(raising ["integer overflow"] on int64 overflow), AVG/TOTAL are real;
70
+
[min]/[max] use {!compare_values}; an empty [vals] is NULL ([total] is 0.0).
71
+
@raise Invalid_argument via {!float_of_value} on a non-numeric [sum]/[avg].
72
+
*)
73
+
74
+
val affinity_of_type : string -> [ `Blob | `Integer | `Numeric | `Real | `Text ]
75
+
(** [affinity_of_type ty] is the storage affinity of a declared type name
76
+
(datatype3.html sec.3.1): a name containing [INT] is [`Integer], CHAR/CLOB/
77
+
TEXT is [`Text], BLOB or [""] is [`Blob], REAL/FLOA/DOUB is [`Real], else
78
+
[`Numeric]. *)
79
+
80
+
val apply_affinity : string -> Catalog.Value.t -> Catalog.Value.t
81
+
(** [apply_affinity ty v] applies the column affinity of declared type [ty] to a
82
+
value being written: NUMERIC/INTEGER read well-formed numeric text as a
83
+
number, TEXT renders a number as text, REAL coerces a number to float; a
84
+
BLOB, NULL, and non-numeric text are unchanged. *)
85
+
86
+
val cast : string -> Catalog.Value.t -> Catalog.Value.t
87
+
(** [cast ty v] is [CAST(v AS ty)] by the target affinity
88
+
(lang_expr.html#castexpr): NULL is preserved; text/blob to a numeric type
89
+
parses a leading numeric prefix. *)
90
+
91
+
val is_real : Catalog.Value.t -> bool
92
+
(** [is_real v] is whether [v] reads as a real rather than an integer: a float,
93
+
or text that spells a real but not an integer. *)
94
+
95
+
val numeric_affinity : Catalog.Value.t -> Catalog.Value.t
96
+
(** [numeric_affinity v] is the arithmetic coercion: a number passes through,
97
+
text becomes the integer or real it spells, or [0] if it is not numeric. *)
98
+
99
+
val num_coerce : Catalog.Value.t -> Catalog.Value.t
100
+
(** [num_coerce v] is the comparison-affinity coercion: a text/blob becomes a
101
+
number only when it is a well-formed numeric literal, else it is unchanged
102
+
(so a non-numeric string does not spuriously equal a number). *)
103
+
104
+
val intify : Catalog.Value.t -> int64
105
+
(** [intify v] is SQLite's integer coercion of a value: a float truncates, text
106
+
reads its leading number, anything non-numeric is [0]. *)
107
+
108
+
val like_match : ?escape:char -> string -> string -> bool
109
+
(** [like_match pattern s] is SQL [LIKE] (ASCII case-insensitive): [%] matches
110
+
any run, [_] any single character; [~escape] makes its character match the
111
+
next one literally. *)
112
+
113
+
val glob_match : string -> string -> bool
114
+
(** [glob_match pattern s] is SQL [GLOB] (case-sensitive Unix wildcards): [*]
115
+
any run, [?] one character, [[..]] a character class. *)
116
+
117
+
val like_op :
118
+
?escape:Catalog.Value.t ->
119
+
Catalog.Value.t ->
120
+
Catalog.Value.t ->
121
+
Catalog.Value.t
122
+
(** [like_op a b] is [a LIKE b] as [1]/[0]/NULL; [~escape] is the optional
123
+
single-character ESCAPE value. *)
124
+
125
+
val glob_op : Catalog.Value.t -> Catalog.Value.t -> Catalog.Value.t
126
+
(** [glob_op a b] is [a GLOB b] as [1]/[0]/NULL. *)
127
+
128
+
val concat_op : Catalog.Value.t -> Catalog.Value.t -> Catalog.Value.t
129
+
(** [concat_op a b] is [a || b]: NULL if either is NULL, else the text forms
130
+
concatenated. *)
131
+
132
+
val distinct_values : Catalog.Value.t list -> Catalog.Value.t list
133
+
(** [distinct_values vs] keeps the first occurrence of each value by
134
+
{!compare_values} equality -- a [DISTINCT] aggregate's argument values. *)
+41
sql.opam
+41
sql.opam
···
1
+
# This file is generated by dune, edit dune-project instead
2
+
opam-version: "2.0"
3
+
synopsis: "SQL frontend over the catalog engine"
4
+
description:
5
+
"A SQL parser, AST, renderer, value semantics, and executor over the storage-agnostic catalog engine."
6
+
maintainer: ["Thomas Gazagnaire"]
7
+
authors: ["Thomas Gazagnaire"]
8
+
license: "MIT"
9
+
tags: ["org:blacksun" "storage"]
10
+
homepage: "https://tangled.org/gazagnaire.org/ocaml-sql"
11
+
bug-reports: "https://tangled.org/gazagnaire.org/ocaml-sql/issues"
12
+
depends: [
13
+
"dune" {>= "3.21"}
14
+
"ocaml" {>= "5.1"}
15
+
"catalog"
16
+
"fmt" {>= "0.9"}
17
+
"re"
18
+
"uutf" {>= "1.0"}
19
+
"ohex"
20
+
"nox-json"
21
+
"menhir" {build}
22
+
"alcotest" {with-test}
23
+
"mdx" {with-test}
24
+
"odoc" {with-doc}
25
+
]
26
+
build: [
27
+
["dune" "subst"] {dev}
28
+
[
29
+
"dune"
30
+
"build"
31
+
"-p"
32
+
name
33
+
"-j"
34
+
jobs
35
+
"@install"
36
+
"@runtest" {with-test}
37
+
"@doc" {with-doc}
38
+
]
39
+
]
40
+
dev-repo: "git+https://tangled.org/gazagnaire.org/ocaml-sql"
41
+
x-maintenance-intent: ["(latest)"]
+1
test/test.ml
+1
test/test.ml
···
1
+
let () = Alcotest.run "sql" [ Test_func.suite ]
+121
test/test_func.ml
+121
test/test_func.ml
···
1
+
module V = Catalog.Value
2
+
module Func = Sql.Func
3
+
4
+
let value = Alcotest.testable V.pp V.equal
5
+
let vint n = V.Int (Int64.of_int n)
6
+
let apply name args = Func.apply name args
7
+
8
+
let text = function
9
+
| V.Text s -> s
10
+
| v -> Alcotest.failf "expected text, got %a" V.pp v
11
+
12
+
let test_text_edges () =
13
+
Alcotest.check value "length counts UTF-8 scalar values" (vint 3)
14
+
(apply "length" [ V.Text "a\195\169b" ]);
15
+
Alcotest.check value "octet_length counts bytes" (vint 4)
16
+
(apply "octet_length" [ V.Text "a\195\169b" ]);
17
+
Alcotest.check value "substr is one-based" (V.Text "ell")
18
+
(apply "substr" [ V.Text "hello"; vint 2; vint 3 ]);
19
+
Alcotest.check value "negative length clamps to empty" (V.Text "")
20
+
(apply "substr" [ V.Text "hello"; vint 5; vint (-3) ])
21
+
22
+
let test_json_edges () =
23
+
Alcotest.check value "json_extract indexes array" (vint 20)
24
+
(apply "json_extract" [ V.Text "{\"a\":[10,20]}"; V.Text "$.a[1]" ]);
25
+
Alcotest.check value "json ->> returns SQL text" (V.Text "v")
26
+
(Func.json_arrow ~as_text:true (V.Text "{\"k\":\"v\"}") (V.Text "$.k"));
27
+
Alcotest.check value "missing json path is NULL" V.Null
28
+
(apply "json_extract" [ V.Text "{\"a\":1}"; V.Text "$.missing" ]);
29
+
Alcotest.check_raises "malformed json is rejected" (Failure "malformed JSON")
30
+
(fun () -> ignore (apply "json_extract" [ V.Text "{"; V.Text "$" ]))
31
+
32
+
let test_table_function_edges () =
33
+
Alcotest.(check (list string))
34
+
"generate_series column" [ "value" ]
35
+
(Func.table_function_columns "generate_series");
36
+
let _cols, rows =
37
+
Func.table_function "generate_series" [ vint 3; vint 1; vint (-1) ]
38
+
in
39
+
Alcotest.check
40
+
(Alcotest.list (Alcotest.list value))
41
+
"descending generate_series"
42
+
[ [ vint 3 ]; [ vint 2 ]; [ vint 1 ] ]
43
+
rows;
44
+
Alcotest.check_raises "zero step rejected"
45
+
(Failure "generate_series: step must be non-zero") (fun () ->
46
+
ignore (Func.table_function "generate_series" [ vint 1; vint 3; vint 0 ]));
47
+
Alcotest.check_raises "oversized series is rejected"
48
+
(Failure "generate_series: range too large to materialise") (fun () ->
49
+
ignore (Func.table_function "generate_series" [ vint 0; vint 10_000_000 ]));
50
+
Alcotest.check_raises "non-integer series arg is rejected"
51
+
(Failure "generate_series: integer arguments expected") (fun () ->
52
+
ignore (Func.table_function "generate_series" [ V.Text "1"; vint 3 ]))
53
+
54
+
let test_cve_format_edges () =
55
+
(* CVE-2022-35737-style: hostile printf width/precision must be bounded
56
+
before any allocation is attempted. *)
57
+
let padded = text (apply "printf" [ V.Text "%*s"; vint 4096; V.Text "x" ]) in
58
+
Alcotest.(check int) "bounded star width length" 4096 (String.length padded);
59
+
Alcotest.(check string)
60
+
"bounded star width right edge" "x" (String.sub padded 4095 1);
61
+
let left = text (apply "printf" [ V.Text "%*s"; vint (-16); V.Text "x" ]) in
62
+
Alcotest.(check int) "negative star width length" 16 (String.length left);
63
+
Alcotest.(check string)
64
+
"negative star width left-justifies" "x" (String.sub left 0 1);
65
+
Alcotest.(check string)
66
+
"star precision clips text" "abc"
67
+
(text (apply "printf" [ V.Text "%.*s"; vint 3; V.Text "abcdef" ]));
68
+
Alcotest.(check string)
69
+
"negative star precision is ignored" "abcdef"
70
+
(text (apply "printf" [ V.Text "%.*s"; vint (-1); V.Text "abcdef" ]));
71
+
Alcotest.check_raises "oversized star width rejected"
72
+
(Failure "format: width or precision too large") (fun () ->
73
+
ignore (apply "printf" [ V.Text "%*s"; V.Int Int64.max_int; V.Text "x" ]));
74
+
Alcotest.check_raises "oversized literal width rejected"
75
+
(Failure "format: width or precision too large") (fun () ->
76
+
ignore (apply "printf" [ V.Text "%1000001s"; V.Text "x" ]));
77
+
Alcotest.check_raises "oversized literal precision rejected"
78
+
(Failure "format: width or precision too large") (fun () ->
79
+
ignore (apply "printf" [ V.Text "%.1000001s"; V.Text "x" ]))
80
+
81
+
let test_binary_and_unicode_edges () =
82
+
Alcotest.check value "unhex decodes mixed-case hex" (V.Blob "\000\015\255")
83
+
(apply "unhex" [ V.Text "000Fff" ]);
84
+
Alcotest.check value "unhex rejects odd-length input" V.Null
85
+
(apply "unhex" [ V.Text "123" ]);
86
+
Alcotest.check value "unhex rejects non-hex input" V.Null
87
+
(apply "unhex" [ V.Text "00xz" ]);
88
+
Alcotest.check value "negative zeroblob clamps to empty blob" (V.Blob "")
89
+
(apply "zeroblob" [ vint (-3) ]);
90
+
Alcotest.check value "zeroblob materialises zero bytes"
91
+
(V.Blob "\000\000\000")
92
+
(apply "zeroblob" [ vint 3 ]);
93
+
Alcotest.check value "char invalid codepoint uses replacement character"
94
+
(V.Text "\239\191\189")
95
+
(apply "char" [ V.Int 0x110000L ]);
96
+
Alcotest.check value "unicode malformed UTF-8 uses replacement codepoint"
97
+
(vint 0xfffd)
98
+
(apply "unicode" [ V.Text "\255" ]);
99
+
Alcotest.check value "unicode empty text is NULL" V.Null
100
+
(apply "unicode" [ V.Text "" ])
101
+
102
+
let test_unknown_and_overflow () =
103
+
Alcotest.check_raises "unknown scalar rejected"
104
+
(Failure "unknown function no_such_function()") (fun () ->
105
+
ignore (apply "no_such_function" [ vint 1 ]));
106
+
Alcotest.check_raises "int64 min abs overflow rejected"
107
+
(Failure "integer overflow") (fun () ->
108
+
ignore (apply "abs" [ V.Int Int64.min_int ]))
109
+
110
+
let suite =
111
+
( "func",
112
+
[
113
+
Alcotest.test_case "text edge cases" `Quick test_text_edges;
114
+
Alcotest.test_case "json edge cases" `Quick test_json_edges;
115
+
Alcotest.test_case "table-function edge cases" `Quick
116
+
test_table_function_edges;
117
+
Alcotest.test_case "CVE-style format edges" `Quick test_cve_format_edges;
118
+
Alcotest.test_case "binary and unicode edges" `Quick
119
+
test_binary_and_unicode_edges;
120
+
Alcotest.test_case "unknown and overflow" `Quick test_unknown_and_overflow;
121
+
] )