collect params of subqueries
[sqlgg.git] / lib / syntax.ml
blob8d253571f6d5cb896c0ce47ad1a8a9013cd7687e
1 (** SQL syntax and RA *)
3 open Printf
4 open ExtLib
5 open Prelude
6 open Sql
8 let debug = ref false
10 type env = {
11 tables : Tables.table list;
12 schema : Schema.t;
13 insert_schema : Schema.t;
16 (* expr with all name references resolved to values or "functions" *)
17 type res_expr =
18 | ResValue of Type.t (** literal value *)
19 | ResParam of param
20 | ResInparam of param
21 | ResChoices of param_id * res_expr choices
22 | ResInChoice of param_id * [`In | `NotIn] * res_expr
23 | ResFun of Type.func * res_expr list (** function kind (return type and flavor), arguments *)
24 [@@deriving show]
26 let empty_env = { tables = []; schema = []; insert_schema = []; }
28 let flat_map f l = List.flatten (List.map f l)
30 let schema_of tables name = snd @@ Tables.get_from tables name
32 let get_or_failwith = function `Error s -> failwith s | `Ok t -> t
34 let values_or_all table names =
35 let schema = Tables.get_schema table in
36 match names with
37 | Some names -> Schema.project names schema
38 | None -> schema
40 let rec get_params_of_res_expr (e:res_expr) =
41 let rec loop acc e =
42 match e with
43 | ResParam p -> Single p::acc
44 | ResInparam p -> SingleIn p::acc
45 | ResFun (_,l) -> List.fold_left loop acc l
46 | ResValue _ -> acc
47 | ResInChoice (param, kind, e) -> ChoiceIn { param; kind; vars = get_params_of_res_expr e } :: acc
48 | ResChoices (p,l) -> Choice (p, List.map (fun (n,e) -> Simple (n, Option.map get_params_of_res_expr e)) l) :: acc
50 loop [] e |> List.rev
52 let list_same l =
53 match l with
54 | [] -> None
55 | x::xs -> if List.for_all (fun y -> x = y) xs then Some x else None
57 let rec is_grouping = function
58 | Value _
59 | Param _
60 | Column _
61 | SelectExpr _
62 | Inparam _
63 | Inserted _ -> false
64 | Choices (p,l) ->
65 begin match list_same @@ List.map (fun (_,expr) -> Option.map_default is_grouping false expr) l with
66 | None -> failed ~at:p.pos "inconsistent grouping in choice branches"
67 | Some v -> v
68 end
69 | InChoice (_, _, e) -> is_grouping e
70 | Fun (func,args) ->
71 (* grouping function of zero or single parameter or function on grouping result *)
72 (Type.is_grouping func && List.length args <= 1) || List.exists is_grouping args
74 let exists_grouping columns =
75 List.exists (function Expr (e,_) -> is_grouping e | All | AllOf _ -> false) columns
77 let cross = List.fold_left Schema.cross []
79 (* all columns from tables, without duplicates *)
80 (* FIXME check type of duplicates *)
81 let all_columns = Schema.make_unique $ cross
82 let all_tbl_columns = all_columns $ List.map snd
84 let resolve_column tables schema {cname;tname} =
85 Schema.find (Option.map_default (schema_of tables) schema tname) cname
87 (* HACK hint expression to unify with the column type *)
88 let rec hint attr expr =
89 (* associate parameter with column *)
90 let expr = match expr with Param p -> Param { p with attr = Some attr } | e -> e in
91 (* go one level deep into choices *)
92 match expr with
93 | Choices (n,l) -> Choices (n, List.map (fun (n,e) -> n, Option.map (hint attr) e) l)
94 | _ -> Fun (F (Var 0, [Var 0; Var 0]), [Value attr.domain;expr])
96 let resolve_column_assignments tables l =
97 let all = all_tbl_columns tables in
98 l |> List.map begin fun (col,expr) ->
99 let attr = resolve_column tables all col in
100 hint attr expr
103 let get_columns_schema tables l =
104 let all = all_tbl_columns tables in
105 (* FIXME col_name *)
106 l |> List.map (fun col -> { (resolve_column tables all col) with name = col.cname })
108 let _print_env env =
109 eprintfn "env: ";
110 Sql.Schema.print env.schema;
111 Tables.print stderr env.tables
113 (** resolve each name reference (Column, Inserted, etc) into ResValue or ResFun of corresponding type *)
114 let rec resolve_columns env expr =
115 if !debug then
116 begin
117 eprintf "\nRESOLVE COLUMNS %s\n%!" (expr_to_string expr);
118 eprintf "schema: "; Sql.Schema.print env.schema;
119 Tables.print stderr env.tables;
120 end;
121 let rec each e =
122 match e with
123 | Value x -> ResValue x
124 | Column col -> ResValue (resolve_column env.tables env.schema col).domain
125 | Inserted name ->
126 let attr = try Schema.find env.insert_schema name with Schema.Error (_,s) -> fail "for inserted values : %s" s in
127 ResValue attr.domain
128 | Param x -> ResParam x
129 | Inparam x -> ResInparam x
130 | InChoice (n, k, x) -> ResInChoice (n, k, each x)
131 | Choices (n,l) -> ResChoices (n, List.map (fun (n,e) -> n, Option.map each e) l)
132 | Fun (r,l) ->
133 ResFun (r,List.map each l)
134 | SelectExpr (select, usage) ->
135 let rec params_of_var = function
136 | Single p -> [ResParam p]
137 | SingleIn p -> [ResParam p]
138 | ChoiceIn { vars; _ } -> as_params vars
139 | Choice (_,l) -> l |> flat_map (function Simple (_, vars) -> Option.map_default as_params [] vars | Verbatim _ -> [])
140 | TupleList (p, _) -> failed ~at:p.pos "FIXME TupleList in SELECT subquery"
141 and as_params p = flat_map params_of_var p in
142 let (schema,p,_) = eval_select_full env select in
143 (* represet nested selects as functions with sql parameters as function arguments, some hack *)
144 match schema, usage with
145 | [ {domain;_} ], `AsValue ->
146 ResFun (Type.Ret domain, as_params p)
147 | s, `AsValue -> raise (Schema.Error (s, "only one column allowed for SELECT operator in this expression"))
148 | _, `Exists -> ResFun (Type.Ret Any, as_params p)
150 each expr
152 (** assign types to parameters where possible *)
153 and assign_types expr =
154 let option_split = function None -> None, None | Some (x,y) -> Some x, Some y in
155 let rec typeof (e:res_expr) = (* FIXME simplify *)
156 match e with
157 | ResValue t -> e, `Ok t
158 | ResParam p -> e, `Ok p.typ
159 | ResInparam p -> e, `Ok p.typ
160 | ResInChoice (n, k, e) -> let e, t = typeof e in ResInChoice (n, k, e), t
161 | ResChoices (n,l) ->
162 let (e,t) = List.split @@ List.map (fun (_,e) -> option_split @@ Option.map typeof e) l in
163 let t =
164 match List.map get_or_failwith @@ List.filter_map identity t with
165 | [] -> assert false
166 | t::ts -> List.fold_left (fun acc t -> match acc with None -> None | Some prev -> Type.common_subtype prev t) (Some t) ts
168 let t = match t with None -> `Error "no common subtype for all choice branches" | Some t -> `Ok t in
169 ResChoices (n, List.map2 (fun (n,_) e -> n,e) l e), t
170 | ResFun (func,params) ->
171 let open Type in
172 let (params,types) = params |> List.map typeof |> List.split in
173 let types = List.map get_or_failwith types in
174 let show () =
175 sprintf "%s applied to (%s)"
176 (string_of_func func)
177 (String.concat ", " @@ List.map to_string types)
179 let func =
180 match func with
181 | Multi (ret,each_arg) -> F (ret, List.map (fun _ -> each_arg) types)
182 | x -> x
184 let (ret,inferred_params) = match func, types with
185 | Multi _, _ -> assert false (* rewritten into F above *)
186 | Agg, [typ]
187 | Group typ, _ -> typ, types
188 | Agg, _ -> fail "cannot use this grouping function with %d parameters" (List.length types)
189 | F (_, args), _ when List.length args <> List.length types -> fail "wrong number of arguments : %s" (show ())
190 | F (ret, args), _ ->
191 let typevar = Hashtbl.create 10 in
192 let l = List.map2 begin fun arg typ ->
193 match arg with
194 | Typ arg -> common_type arg typ
195 | Var i ->
196 let arg =
197 match Hashtbl.find typevar i with
198 | exception Not_found -> Hashtbl.replace typevar i typ; typ
199 | t -> t
201 (* prefer more precise type *)
202 if arg = Type.Any then Hashtbl.replace typevar i typ;
203 common_type arg typ
204 end args types
206 let convert = function Typ t -> t | Var i -> Hashtbl.find typevar i in
207 if List.fold_left (&&) true l then
208 convert ret, List.map convert args
209 else
210 fail "types do not match : %s" (show ())
211 | Ret Any, _ -> (* lame *)
212 begin match List.filter ((<>) Any) types with
213 | [] -> Any, types
214 (* make a best guess, return type same as for parameters when all of single type *)
215 | h::tl when List.for_all (matches h) tl -> h, List.map (fun _ -> h) types
216 (* "expand" to floats, when all parameters numeric and above rule didn't match *)
217 | l when List.for_all (function Int | Float -> true | _ -> false) l -> Float, List.map (function Any -> Float | x -> x) types
218 | _ -> Any, types
220 | Ret ret, _ -> ret, types (* ignoring arguments FIXME *)
222 let assign inferred x =
223 match x with
224 | ResParam { id; typ = Any; attr; } -> ResParam (new_param ?attr id inferred)
225 | ResInparam { id; typ = Any; attr; } -> ResInparam (new_param ?attr id inferred)
226 | x -> x
228 ResFun (func,(List.map2 assign inferred_params params)), `Ok ret
230 typeof expr
232 and resolve_types env expr =
233 let expr = resolve_columns env expr in
235 let (expr',t as r) = assign_types expr in
236 if !debug then eprintf "resolved types %s : %s\n%!" (show_res_expr expr') (Type.to_string @@ get_or_failwith t);
238 with
239 exn ->
240 eprintfn "resolve_types failed with %s at:" (Printexc.to_string exn);
241 eprintfn "%s" (show_res_expr expr);
242 raise exn
244 and infer_schema env columns =
245 (* let all = tables |> List.map snd |> List.flatten in *)
246 let resolve1 = function
247 | All -> env.schema
248 | AllOf t -> schema_of env.tables t
249 | Expr (e,name) ->
250 let col =
251 match e with
252 | Column col -> resolve_column env.tables env.schema col
253 | _ -> make_attribute "" (resolve_types env e |> snd |> get_or_failwith) Constraints.empty
255 let col = Option.map_default (fun n -> {col with name = n}) col name in
256 [ col ]
258 flat_map resolve1 columns
260 and get_params env e = e |> resolve_types env |> fst |> get_params_of_res_expr
263 let _ =
264 let e = Sub [Value Type.Text; Param (Next,None); Sub []; Param (Named "ds", Some Type.Int);] in
265 e |> get_params |> to_string |> print_endline
268 and get_params_of_columns env =
269 let get = function
270 | All | AllOf _ -> []
271 | Expr (e,_) -> get_params env e
273 flat_map get
275 and get_params_opt env = function
276 | Some x -> get_params env x
277 | None -> []
279 and get_params_l env l = flat_map (get_params env) l
281 and do_join (env,params) ((schema1,params1,_tables),kind) =
282 let schema = match kind with
283 | `Cross
284 | `Search _
285 | `Default -> Schema.cross env.schema schema1
286 | `Natural -> Schema.natural env.schema schema1
287 | `Using l -> Schema.join_using l env.schema schema1
289 let env = { env with schema } in
290 let p = match kind with
291 | `Cross | `Default | `Natural | `Using _ -> []
292 | `Search e -> get_params env e (* TODO should use final schema (same as tables)? *)
294 env, params @ params1 @ p
296 and join env ((schema,p0,ts0),joins) =
297 assert (env.schema = []);
298 let all_tables = List.flatten (ts0 :: List.map (fun ((_,_,ts),_) -> ts) joins) in
299 let env = { env with tables = env.tables @ all_tables; schema; } in
300 List.fold_left do_join (env, p0) joins
302 and params_of_assigns env ss =
303 let exprs = resolve_column_assignments env.tables ss in
304 get_params_l env exprs
306 and params_of_order order final_schema tables =
307 List.concat @@
308 List.map
309 (fun (order, direction) ->
310 let env = { tables; schema=(final_schema :: (List.map snd tables) |> all_columns); insert_schema = []; } in
311 let p1 = get_params_l env [ order ] in
312 let p2 =
313 match direction with
314 | None | Some `Fixed -> []
315 | Some (`Param p) -> [Choice (p,[Verbatim ("ASC","ASC");Verbatim ("DESC","DESC")])]
317 p1 @ p2)
318 order
320 and ensure_res_expr = function
321 | Value x -> ResValue x
322 | Param x -> ResParam x
323 | Inparam x -> ResInparam x
324 | Choices (p,_) -> failed ~at:p.pos "ensure_res_expr Choices TBD"
325 | InChoice (p,_,_) -> failed ~at:p.pos "ensure_res_expr InChoice TBD"
326 | Column _ | Inserted _ -> failwith "Not a simple expression"
327 | Fun (func,_) when Type.is_grouping func -> failwith "Grouping function not allowed in simple expression"
328 | Fun (x,l) -> ResFun (x,List.map ensure_res_expr l) (* FIXME *)
329 | SelectExpr _ -> failwith "not implemented : ensure_res_expr for SELECT"
331 and eval_nested env nested =
332 (* nested selects generate new fresh schema in scope, cannot refer to outer schema,
333 but can refer to attributes of tables through `tables` *)
334 let env = { env with schema = [] } in
335 match nested with
336 | Some (t,l) -> join env (resolve_source env t, List.map (fun (x,k) -> resolve_source env x, k) l)
337 | None -> env, []
339 and eval_select env { columns; from; where; group; having; } =
340 let (env,p2) = eval_nested env from in
341 let cardinality =
342 if from = None then (if where = None then `One else `Zero_one)
343 else if group = [] && exists_grouping columns then `One
344 else `Nat
346 let final_schema = infer_schema env columns in
347 (* use schema without aliases here *)
348 let p1 = get_params_of_columns env columns in
349 let env = Schema.{ env with schema = cross env.schema final_schema |> make_unique } in (* enrich schema in scope with aliases *)
350 let p3 = get_params_opt env where in
351 let p4 = get_params_l env group in
352 let p5 = get_params_opt env having in
353 (final_schema, p1 @ p2 @ p3 @ p4 @ p5, env.tables, cardinality)
355 (** @return final schema, params and tables that can be referenced by outside scope *)
356 and resolve_source env (x,alias) =
357 match x with
358 | `Select select ->
359 let (s,p,_) = eval_select_full env select in
360 s, p, (match alias with None -> [] | Some name -> [name,s])
361 | `Nested s ->
362 let (env,p) = eval_nested env (Some s) in
363 let s = infer_schema env [All] in
364 if alias <> None then failwith "No alias allowed on nested tables";
365 s, p, env.tables
366 | `Table s ->
367 let (name,s) = Tables.get s in
368 s, [], List.map (fun name -> name, s) (name :: option_list alias)
370 and eval_select_full env { select=(select,other); order; limit; } =
371 let (s1,p1,tbls,cardinality) = eval_select env select in
372 let (s2l,p2l) = List.split (List.map (fun (s,p,_,_) -> s,p) @@ List.map (eval_select env) other) in
373 if false then
374 eprintf "cardinality=%s other=%u\n%!"
375 (Stmt.cardinality_to_string cardinality)
376 (List.length other);
377 let cardinality = if other = [] then cardinality else `Nat in
378 (* ignoring tables in compound statements - they cannot be used in ORDER BY *)
379 let final_schema = List.fold_left Schema.compound s1 s2l in
380 let p3 = params_of_order order final_schema tbls in
381 let (p4,limit1) = match limit with Some (p,x) -> List.map (fun p -> Single p) p, x | None -> [],false in
382 (* Schema.check_unique schema; *)
383 let cardinality =
384 if limit1 && cardinality = `Nat then `Zero_one
385 else cardinality in
386 final_schema,(p1@(List.flatten p2l)@p3@p4 : var list), Stmt.Select cardinality
389 let update_tables sources ss w =
390 let schema = cross @@ (List.map (fun (s,_,_) -> s) sources) in
391 let p0 = List.flatten @@ List.map (fun (_,p,_) -> p) sources in
392 let tables = List.flatten @@ List.map (fun (_,_,ts) -> ts) sources in (* TODO assert equal duplicates if not unique *)
393 let env = { tables; schema; insert_schema=get_columns_schema tables (List.map fst ss); } in
394 let p1 = params_of_assigns env ss in
395 let p2 = get_params_opt env w in
396 p0 @ p1 @ p2
398 let annotate_select select types =
399 let (select1,compound) = select.select in
400 let rec loop acc cols types =
401 match cols, types with
402 | [], [] -> List.rev acc
403 | (All | AllOf _) :: _, _ -> failwith "Asterisk not supported"
404 | Expr (e,name) :: cols, t :: types -> loop (Expr (Fun (F (Typ t, [Typ t]), [e]), name) :: acc) cols types
405 | _, [] | [], _ -> failwith "Select cardinality doesn't match Insert"
407 { select with select = { select1 with columns = loop [] select1.columns types }, compound }
409 let eval (stmt:Sql.stmt) =
410 let open Stmt in
411 match stmt with
412 | Create (name,`Schema schema) ->
413 Tables.add (name,schema);
414 ([],[],Create name)
415 | Create (name,`Select select) ->
416 let (schema,params,_) = eval_select_full empty_env select in
417 Tables.add (name,schema);
418 ([],params,Create name)
419 | Alter (name,actions) ->
420 List.iter (function
421 | `Add (col,pos) -> Tables.alter_add name col pos
422 | `Drop col -> Tables.alter_drop name col
423 | `Change (oldcol,col,pos) -> Tables.alter_change name oldcol col pos
424 | `RenameColumn (oldcol,newcol) -> Tables.rename_column name oldcol newcol
425 | `RenameTable new_name -> Tables.rename name new_name
426 | `RenameIndex _ -> () (* indices are not tracked yet *)
427 | `None -> ()) actions;
428 ([],[],Alter [name])
429 | Rename l ->
430 List.iter (fun (o,n) -> Tables.rename o n) l;
431 ([], [], Alter (List.map fst l)) (* to have sensible target for gen_xml *)
432 | Drop name ->
433 Tables.drop name;
434 ([],[],Drop name)
435 | CreateIndex (name,table,cols) ->
436 Sql.Schema.project cols (Tables.get_schema table) |> ignore; (* just check *)
437 [],[],CreateIndex name
438 | Insert { target=table; action=`Values (names, values); on_duplicate; } ->
439 let expect = values_or_all table names in
440 let env = { tables = [Tables.get table]; schema = Tables.get_schema table; insert_schema = expect; } in
441 let params, inferred = match values with
442 | None -> [], Some (Values, expect)
443 | Some values ->
444 let vl = List.map List.length values in
445 let cl = List.length expect in
446 if List.exists (fun n -> n <> cl) vl then
447 fail "Expecting %u expressions in every VALUES tuple" cl;
448 let assigns = values |>
449 List.map begin fun tuple ->
450 (* pair up columns with inserted values *)
451 List.combine (List.map (fun a -> {cname=a.name; tname=None}) expect) tuple
452 (* resolve DEFAULTs *)
453 |> List.map (function (col,`Expr e) -> col, e | (col,`Default) -> col, Fun (Type.identity, [Column col]))
456 params_of_assigns env (List.concat assigns), None
458 let params2 = params_of_assigns env (Option.default [] on_duplicate) in
459 [], params @ params2, Insert (inferred,table)
460 | Insert { target=table; action=`Param (names, param_id); on_duplicate; } ->
461 let expect = values_or_all table names in
462 let env = { tables = [Tables.get table]; schema = Tables.get_schema table; insert_schema = expect; } in
463 let params = [ TupleList (param_id, expect) ] in
464 let params2 = params_of_assigns env (Option.default [] on_duplicate) in
465 [], params @ params2, Insert (None, table)
466 | Insert { target=table; action=`Select (names, select); on_duplicate; } ->
467 let expect = values_or_all table names in
468 let env = { tables = [Tables.get table]; schema = Tables.get_schema table; insert_schema = expect; } in
469 let select = annotate_select select (List.map (fun a -> a.domain) expect) in
470 let (schema,params,_) = eval_select_full env select in
471 ignore (Schema.compound expect schema); (* test equal types once more (not really needed) *)
472 let params2 = params_of_assigns env (Option.default [] on_duplicate) in
473 [], params @ params2, Insert (None,table)
474 | Insert { target=table; action=`Set ss; on_duplicate; } ->
475 let expect = values_or_all table (Option.map (List.map (function ({cname; tname=None},_) -> cname | _ -> assert false)) ss) in
476 let env = { tables = [Tables.get table]; schema = Tables.get_schema table; insert_schema = expect; } in
477 let (params,inferred) = match ss with
478 | None -> [], Some (Assign, Tables.get_schema table)
479 | Some ss -> params_of_assigns env ss, None
481 let params2 = params_of_assigns env (Option.default [] on_duplicate) in
482 [], params @ params2, Insert (inferred,table)
483 | Delete (table, where) ->
484 let t = Tables.get table in
485 let p = get_params_opt { tables=[t]; schema=snd t; insert_schema=[]; } where in
486 [], p, Delete [table]
487 | DeleteMulti (targets, tables, where) ->
488 (* use dummy columns to verify targets match the provided tables *)
489 let columns = List.map (fun tn -> AllOf tn) targets in
490 let select = ({ columns; from = Some tables; where; group = []; having = None }, []) in
491 let _attrs, params, _ = eval_select_full empty_env { select; order = []; limit = None } in
492 [], params, Delete targets
493 | Set (_name, e) ->
494 let p = match e with
495 | Column _ -> [] (* this is not column but some db-specific identifier *)
496 | _ -> get_params_of_res_expr (ensure_res_expr e)
498 [], p, Other
499 | Update (table,ss,w,o,lim) ->
500 let t = Tables.get table in
501 let params = update_tables [snd t,[],[t]] ss w in
502 let p3 = params_of_order o [] [t] in
503 [], params @ p3 @ (List.map (fun p -> Single p) lim), Update (Some table)
504 | UpdateMulti (tables,ss,w) ->
505 let sources = List.map (resolve_source empty_env) tables in
506 let params = update_tables sources ss w in
507 [], params, Update None
508 | Select select -> eval_select_full empty_env select
509 | CreateRoutine (name,_,_) ->
510 [], [], CreateRoutine name
512 (* FIXME unify each choice separately *)
513 let unify_params l =
514 let h = Hashtbl.create 10 in
515 let h_choices = Hashtbl.create 10 in
516 let check_choice_name p =
517 match p.label with
518 | None -> () (* unique *)
519 | Some n when Hashtbl.mem h_choices n -> failed ~at:p.pos "sharing choices not implemented"
520 | Some n -> Hashtbl.add h_choices n ()
522 let remember name t =
523 match name with
524 | None -> () (* anonymous ie non-shared *)
525 | Some name ->
526 match Hashtbl.find h name with
527 | exception _ -> Hashtbl.add h name t
528 | t' ->
529 match Sql.Type.common_subtype t t' with
530 | Some x -> Hashtbl.replace h name x
531 | None -> fail "incompatible types for parameter %S : %s and %s" name (Type.show t) (Type.show t')
533 let rec traverse = function
534 | Single { id; typ; attr=_ } -> remember id.label typ
535 | SingleIn { id; typ; _ } -> remember id.label typ
536 | ChoiceIn { vars; _ } -> List.iter traverse vars
537 | Choice (p,l) -> check_choice_name p; List.iter (function Simple (_,l) -> Option.may (List.iter traverse) l | Verbatim _ -> ()) l
538 | TupleList _ -> ()
540 let rec map = function
541 | Single { id; typ; attr } -> Single (new_param id ?attr (match id.label with None -> typ | Some name -> try Hashtbl.find h name with _ -> assert false))
542 | SingleIn { id; typ; attr } -> SingleIn (new_param id ?attr (match id.label with None -> typ | Some name -> try Hashtbl.find h name with _ -> assert false))
543 | ChoiceIn t -> ChoiceIn { t with vars = List.map map t.vars }
544 | Choice (p, l) -> Choice (p, List.map (function Simple (n,l) -> Simple (n, Option.map (List.map map) l) | Verbatim _ as v -> v) l)
545 | TupleList _ as x -> x
547 List.iter traverse l;
548 List.map map l
550 let is_alpha = function
551 | 'a'..'z' -> true
552 | 'A'..'Z' -> true
553 | _ -> false
555 let common_prefix = function
556 | [] -> 0
557 | x::_ as l ->
558 let rec loop i =
559 if String.length x <= i then i
560 else
561 if List.for_all (fun s -> i < String.length s && s.[i] = x.[i]) l then
562 loop (i+1)
563 else
566 let i = loop 0 in
567 (* do not allow empty names or starting not with alpha *)
568 if List.exists (fun s -> i = String.length s || not (is_alpha s.[i])) l then 0 else i
570 (* fill inferred sql for VALUES or SET *)
571 let complete_sql kind sql =
572 match kind with
573 | Stmt.Insert (Some (kind,schema), _) ->
574 let (pre,each,post) = match kind with
575 | Values -> "(", (fun _ -> ""), ")"
576 | Assign -> "", (fun name -> name ^" = "), ""
578 let module B = Buffer in
579 let b = B.create 100 in
580 B.add_string b sql;
581 B.add_string b " ";
582 B.add_string b pre;
583 let params = ref [] in
584 let first = common_prefix @@ List.map (fun attr -> attr.Sql.name) schema in
585 schema |> List.iter (fun attr ->
586 if !params <> [] then B.add_string b ",";
587 let attr_ref_prefix = each attr.Sql.name in
588 let attr_name = String.slice ~first attr.Sql.name in
589 let attr_ref = "@" ^ attr_name in
590 let pos_start = B.length b + String.length attr_ref_prefix in
591 let pos_end = pos_start + String.length attr_ref in
592 let param = Single (new_param ~attr {label=Some attr_name; pos=(pos_start,pos_end)} attr.domain) in
593 B.add_string b attr_ref_prefix;
594 B.add_string b attr_ref;
595 tuck params param;
597 B.add_string b post;
598 (B.contents b, List.rev !params)
599 | _ -> (sql,[])
601 let parse sql =
602 let (schema,p1,kind) = eval @@ Parser.parse_stmt sql in
603 let (sql,p2) = complete_sql kind sql in
604 (sql, schema, unify_params (p1 @ p2), kind)