Source file sql_builders.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
open Sql_internals
open Sql_types
(** operations *)
let null_workaround (v, t) =
if is_null_type t then null
else (v, t)
let check_atom_type ty atom_t =
ignore (unify ty (Non_nullable atom_t))
let fixed_op op a b return_t =
let input_t = unify (get_type a) (get_type b) in
let retype value =
let (v, _) = null_workaround value in
v, input_t in
null_workaround (Op ([retype a], op, [retype b]), return_t)
let op type_fun op a b =
let input_t = unify (get_type a) (get_type b) in
fixed_op op a b (type_fun input_t)
let cast expr expected_type =
let atom_type = match expected_type with
| Nullable None -> failwith "cast with polymorphic null"
| Nullable (Some ty) | Non_nullable ty -> ty in
(Cast (expr, atom_type), unify (get_type expr) expected_type)
(** values *)
let field row path checker =
ignore checker;
(Field (row, path),
get_sql_type (get_type row) path)
let default table field checker =
ignore checker;
match table.data with
| Selection _ | View_op _ -> invalid_arg "default"
| Table table -> List.assoc field table.defaults
let row name view =
( Row (name, view),
Non_nullable (TRecord {view with data = ()}) )
let tuple fields producer record_parser =
let record_t =
let field_typ (name, field) = (name, get_type field) in
{ data = ();
producer = unsafe_producer (fun tuple -> producer ~tuple);
record_parser = Sql_parsers.unsafe_record_parser record_parser;
descr = List.map field_typ fields } in
Tuple fields, Non_nullable (TRecord record_t)
let if_then_else p a b =
let t = unify (get_type a) (get_type b) in
Case ([(p, a)], b), t
let match_null matched null_case other_case_fun =
match get_type matched with
| Nullable None when false -> null_case
| _ ->
let other_case = other_case_fun matched in
let t = unify (get_type null_case) (get_type other_case) in
let is_null = Op ([matched], "IS NULL", []), Non_nullable TBool in
Case ([(is_null, null_case)], other_case), t
(** tables *)
let table descr producer record_parser name (obj_witness, defaults) =
ignore obj_witness;
{ descr = descr;
producer = unsafe_producer (fun row -> producer ~row);
record_parser = Sql_parsers.unsafe_record_parser record_parser;
data = Table { name = name; defaults = defaults } }
(** views *)
let view (select, select_type) ?order_by ?limit ?offset from where =
let order_tuple = List.sort (fun (x, _) (y, _) -> String.compare x y) in
let query =
{ select = (match select with
| Simple_select (Tuple tup, t) -> Simple_select (Tuple (order_tuple tup), t)
| Group_by ((Tuple tup, t), r) -> Group_by ((Tuple (order_tuple tup), t), r)
| _ -> select);
from = from;
where = where;
order_by = order_by;
limit = limit;
offset = offset } in
match select_type with
| Non_nullable (TRecord t) | Nullable (Some (TRecord t)) ->
{ t with data = Selection query }
| _ -> assert false
type order = Sql_internals.order = Asc | Desc
(** results *)
let simple_select row = Simple_select row, get_type row
let group group_part result_part =
Group_by (result_part, group_part), get_type result_part
(** queries *)
let get_table writable_view = match writable_view.data with
| Selection _ -> assert false
| View_op _ -> assert false
| Table data -> { writable_view with data = data }
let value value = Value value
let select view = Select view
let insert view inserted_view =
Insert (get_table view, inserted_view)
let delete view row from where =
Delete (get_table view, row, from, where)
let update view row set subtype_witness from where =
ignore subtype_witness;
Update (get_table view, row, set, from, where)