9 type t
= | Int
| Text
| Blob
| Float
| Bool
| Datetime
| Any
10 [@@deriving show
{with_path
=false}]
16 | Any
, _
| _
, Any
-> true
24 | Any
, t
| t
, Any
-> `Order
(t
, Any
)
25 | Int
, Float
| Float
, Int
-> `Order
(Int
,Float
)
26 | Text
, Blob
| Blob
, Text
-> `Order
(Text
,Blob
)
27 | Int
, Datetime
| Datetime
, Int
-> `Order
(Int
,Datetime
)
30 let common_type f x y
=
33 | `Order p
-> Some
(f p
)
36 let common_supertype = common_type snd
37 let common_subtype = common_type fst
38 let common_type x y
= Option.is_some
@@ common_subtype x y
40 type tyvar
= Typ
of t
| Var
of int
41 let string_of_tyvar = function Typ t
-> to_string t
| Var i
-> sprintf
"'%c" (Char.chr
@@ Char.code 'a'
+ i
)
44 | Group
of t
(* _ -> t *)
46 | Poly
of t
(* 'a -> 'a -> t *) (* = F (Typ t, [Var 0; Var 0]) *)
47 | Multi
of tyvar
* tyvar
(* 'a -> ... -> 'a -> 'b *)
48 | Ret
of t
(* _ -> t *) (* TODO eliminate *)
49 | F
of tyvar
* tyvar list
51 let monomorphic ret args
= F
(Typ ret
, List.map
(fun t
-> Typ t
) args
)
52 let fixed = monomorphic
57 | Agg
-> fprintf pp
"|'a| -> 'a"
58 | Group ret
-> fprintf pp
"|_| -> %s" (to_string ret
)
59 | Poly ret
-> fprintf pp
"'a -> 'a -> %s" (to_string ret
)
60 | Ret ret
-> fprintf pp
"_ -> %s" (to_string ret
)
61 | F
(ret
, args
) -> fprintf pp
"%s -> %s" (String.concat
" -> " @@ List.map
string_of_tyvar args
) (string_of_tyvar ret
)
62 | Multi
(ret
, each_arg
) -> fprintf pp
"{ %s }+ -> %s" (string_of_tyvar each_arg
) (string_of_tyvar ret
)
64 let string_of_func = Format.asprintf
"%a" pp_func
66 let is_grouping = function
67 | Group _
| Agg
-> true
68 | Ret _
| Poly _
| F _
| Multi _
-> false
73 type conflict_algo
= | Ignore
| Replace
| Abort
| Fail
| Rollback
74 [@@deriving show
{with_path
=false}]
76 type t
= | PrimaryKey
| NotNull
| Unique
| Autoincrement
| OnConflict
of conflict_algo
77 [@@deriving show
{with_path
=false}]
80 type attr
= {name
: string; domain
: Type.t
;}
81 [@@deriving show
{with_path
=false}]
83 let attr n d
= {name
=n
;domain
=d
}
90 exception Error
of t
* string
92 (** FIXME attribute case sensitivity? *)
93 let by_name name
= function attr -> attr.name
= name
94 let find_by_name t name
= List.find_all
(by_name name
) t
97 match find_by_name t name
with
99 | [] -> raise
(Error
(t
,"missing attribute : " ^ name
))
100 | _
-> raise
(Error
(t
,"duplicate attribute : " ^ name
))
102 let make_unique = List.unique ~cmp
:(fun a1 a2
-> a1
.name
= a2
.name
&& a1
.name
<> "")
103 let is_unique t
= List.length
(make_unique t
) = List.length t
104 let check_unique t
= is_unique t
|| raise
(Error
(t
,"duplicate attributes"))
106 let project names t
= List.map
(find t
) names
108 let change_inplace t before after
=
109 List.map
(fun attr ->
110 match by_name before
attr with
114 let cross t1 t2
= t1
@ t2
116 (** [contains t attr] tests whether schema [t] contains attribute [attr] *)
117 let contains t
attr = find t
attr.name
= attr
119 let check_contains t
attr =
120 if not
(contains t
attr) then
121 raise
(Error
(t
,"type mismatch for attribute " ^
attr.name
))
123 let sub l a
= List.filter
(fun x
-> not
(List.mem x a
)) l
125 let to_string v
= v
|> List.map
(fun attr -> sprintf
"%s %s" (Type.to_string attr.domain
) attr.name
) |>
126 String.concat
", " |> sprintf
"[%s]"
127 let names t
= t
|> List.map
(fun attr -> attr.name
) |> String.concat
"," |> sprintf
"[%s]"
130 let (common
,t1only
) = List.partition
(fun x
-> List.mem x t2
) t1
in
131 if 0 = List.length common
then failwith
"natural'";
132 let t2only = sub t2 common
in
133 common
@ t1only
@ t2only
136 try natural_ t1 t2
with
137 | _
-> raise
(Error
(t1
,"no common attributes for natural join of " ^
138 (names t1
) ^
" and " ^
(names t2
)))
140 let join_using l t1 t2
=
141 let common = List.map
(find t1
) l
in
142 List.iter
(check_contains t2
) common;
143 common @ sub t1
common @ sub t2
common
145 let check_types t1 t2
=
146 List.iter2
(fun a1 a2
->
147 match a1
.domain
, a2
.domain
with
150 | x
, y
when x
= y
-> ()
151 | _
-> raise
(Error
(t1
, sprintf
"Atributes do not match : %s of type %s and %s of type %s"
152 a1
.name
(Type.to_string a1
.domain
)
153 a2
.name
(Type.to_string a2
.domain
)))) t1 t2
155 let check_types t1 t2
=
156 try check_types t1 t2
with
157 | List.Different_list_size _
-> raise
(Error
(t1
, (to_string t1
) ^
" differs in size to " ^
(to_string t2
)))
159 let compound t1 t2
= check_types t1 t2
; t1
162 match find_by_name t col
.name
with
167 | `Default
-> t
@ [col
]
170 let (i
,_
) = List.findi
(fun _
attr -> by_name name
attr) t
in
171 let (l1
,l2
) = List.split_nth
(i
+1) t
in
174 Not_found
-> raise
(Error
(t
,"Can't insert column " ^ col
.name ^
" after non-existing column " ^ name
))
176 | _
-> raise
(Error
(t
,"Already has column " ^ col
.name
))
180 List.remove_if
(by_name col
) t
182 let change t oldcol col pos
=
184 | `Default
-> change_inplace t oldcol col
185 | `First
| `After _
-> add (drop t oldcol
) col pos
188 let print x
= prerr_endline
(to_string x
)
192 type table
= string * Schema.t
[@@deriving show
]
193 type schema
= Schema.t
195 let print_table out
(name
,schema
) =
196 IO.write_line out name
;
197 schema
|> List.iter
(fun {name
=name
;domain
=domain
} ->
198 IO.printf out
"%10s %s\n" (Type.to_string domain
) name
);
201 (** optional name and start/end position in string *)
202 type param_id
= string option * (int * int) [@@deriving show
]
203 type param
= param_id
* Type.t
[@@deriving show
]
204 type params
= param list
[@@deriving show
]
206 let params_to_string = show_params
208 type alter_pos
= [ `After
of string | `Default
| `First
]
209 type alter_action
= [ `Add
of attr * alter_pos
| `Drop
of string | `Change
of string * attr * alter_pos
| `None
]
211 type select_result
= (schema
* param list
)
213 type int_or_param
= [`Const
of int | `Limit
of param
]
214 type limit_t
= [ `Limit
| `Offset
]
216 cname
: string; (** column name *)
217 tname
: string option; (** table name *)
219 and limit
= (param_id
* Type.t
) list
* bool
220 and source1
= [ `Select
of select
| `Table
of string ]
221 and source
= source1
* string option
222 and join_cond
= [ `Cross
| `Search
of expr
| `Default
| `Natural
| `Using
of string list
]
224 columns
: column list
;
225 from
: (source
* (source
* join_cond
) list
) option;
228 having
: expr
option;
231 select
: select
* select list
;
233 limit
: limit
option;
236 | Value
of Type.t
(** literal value *)
238 | Fun
of Type.func
* expr list
(** parameters *)
239 | Select
of select_full
* bool (* single *)
241 | Inserted
of string (** inserted value *)
245 | Expr
of expr
* string option (** name *)
246 [@@deriving show
{with_path
=false}]
248 type columns
= column list
[@@deriving show
]
250 type expr_q
= [ `Value
of Type.t
(** literal value *)
252 | `Func
of Type.func
* expr_q list
(** return type, grouping, parameters *)
256 let expr_to_string = show_expr
258 type assignments
= (col_name
* expr
) list
263 action
: [ `Set
of assignments
option
264 | `Values
of (string list
option * expr list list
option) (* column names * list of value tuples *)
265 | `Select
of (string list
option * select_full
) ];
266 on_duplicate
: assignments
option;
270 | Create
of string * [ `Schema
of schema
| `Select
of select_full
]
272 | Alter
of string * alter_action list
273 | CreateIndex
of string * string * string list
(* index name, table name, columns *)
274 | Insert
of insert_action
275 | Delete
of string * expr
option
276 | Set
of string * expr
277 | Update
of string * assignments
* expr
option * expr list
* param list
(* where, order, limit *)
278 | UpdateMulti
of source list
* assignments
* expr
option
279 | Select
of select_full
280 | CreateRoutine
of string * Type.t
option * (string * Type.t
* expr
option) list
285 let test = [{name="a";domain=Type.Int}; {name="b";domain=Type.Int}; {name="c";domain=Type.Text};];;
288 let () = print (project ["b";"c";"b"] test)
289 let () = print (project ["b";"d"] test)
290 let () = print (rename test "a" "new_a")
293 module Function
: sig
295 val lookup
: string -> int -> Type.func
297 val add : int -> Type.func
-> string -> unit
298 val monomorphic : Type.t
-> Type.t list
-> string -> unit
299 val multi
: ret
:Type.tyvar
-> Type.tyvar
-> string -> unit
300 val multi_polymorphic
: string -> unit
304 let h_fixed_arity = Hashtbl.create
10
305 let h_multi = Hashtbl.create
10
307 let add narg typ name
=
308 let name = String.lowercase
name in
309 if Hashtbl.mem
h_fixed_arity (name,narg
) then
310 fail
"Function %S of %d arguments already registered" name narg
312 Hashtbl.add h_fixed_arity (name,narg
) typ
314 let add_multi typ
name =
315 let name = String.lowercase
name in
316 if Hashtbl.mem
h_multi name then
317 fail
"Function %S already registered" name
319 Hashtbl.add h_multi name typ
321 let lookup name narg
=
322 let name = String.lowercase
name in
323 match Hashtbl.find h_fixed_arity (name,narg
) with
326 match Hashtbl.find h_multi name with
328 | exception _
-> fail
"Unknown function %S of %d arguments" name narg
330 let monomorphic ret args
name = add (List.length args
) Type.(monomorphic ret args
) name
331 let multi_polymorphic name = add_multi Type.(Multi
(Var
0, Var
0)) name
332 let multi ~ret args
name = add_multi Type.(Multi
(ret
, args
)) name
339 let (||>) x f
= List.iter f x
in
340 "count" |> add 0 (Group Int
); (* asterisk is treated as no parameters in parser *)
341 "avg" |> add 1 (Group Float
);
342 ["max";"min";"sum"] ||> add 1 Agg
;
343 ["max";"min"] ||> multi_polymorphic; (* sqlite3 *)
344 "strftime" |> monomorphic Text
[Text
;Text
];
345 ["lower";"upper"] ||> monomorphic Text
[Text
];
346 "length" |> monomorphic Int
[Text
];
347 ["random";"unix_timestamp"] ||> monomorphic Int
[];
348 ["nullif";"ifnull"] ||> add 2 (F
(Var
0, [Var
0; Var
0]));
349 ["least";"greatest";"coalesce"] ||> multi_polymorphic;
350 "concat" |> multi ~ret
:(Typ Text
) (Typ Text
);
351 "from_unixtime" |> monomorphic Datetime
[Int
];
352 "from_unixtime" |> monomorphic Text
[Int
;Text
];