1 (** SQL syntax and RA *)
7 type env
= { tables
: Tables.table list
; }
9 let empty_env = { tables
= [] }
11 let collect f l
= List.flatten
(List.map f l
)
14 let schema_as_params = List.map
(fun attr
-> (Some attr
.name
,(0,0)), Some attr
.domain
)
16 let values_or_all table names
=
17 let schema = Tables.get_schema table
in
19 | Some names
-> Schema.project names
schema
22 let list_filter_map = ExtList.List.filter_map
24 let show_expr_q e
= Show.show
<expr_q
> (e
)
30 | `Func
(_
,l
) -> List.fold_left
loop acc l
35 let test_all_grouping columns
=
37 (* grouping function of zero or single parameter *)
38 | Expr
(Fun
(func
,args
),_
) when Type.is_grouping func
&& List.length args
<= 1 -> true
41 List.for_all
test columns
43 let cross = List.fold_left
Schema.cross []
45 (* all columns from tables, without duplicates *)
46 (* FIXME check type of duplicates *)
47 let all_columns = Schema.make_unique $
cross
48 let all_tbl_columns = all_columns $
List.map snd
50 let split_column_assignments tables l
=
53 let all = all_tbl_columns tables
in
54 List.iter
(fun ((cname
,tname
as col
),expr
) ->
58 | Some name
-> Tables.get_from tables name
|> snd
61 (* hint expression to unify with the column type *)
62 let typ = (Schema.find
schema cname
).domain
in
63 exprs := (Fun
(Type.(Ret Any
), [Value
typ;expr
])) :: !exprs) l
;
64 (List.rev
!cols, List.rev
!exprs)
66 (** replace every Column with Value of corresponding type *)
67 let rec resolve_columns tables joined_schema expr
=
69 eprintf "\nRESOLVE COLUMNS\n%s\n%!" (expr_to_string expr);
70 Tables.print stderr tables;
71 Sql.Schema.print joined_schema;
73 let schema_of_table name
= name
|> Tables.get_from tables
|> snd
in
77 | Column
(name
,table
) ->
78 let attr = Schema.find
(Option.map_default
schema_of_table joined_schema table
) name
in
82 `Func
(r
,List.map
each l
)
83 | Select
(select
,single
) ->
84 let as_params = List.map
(fun x
-> `Param x
) in
85 let (schema,p
,_
) = eval_select_full
{tables
} select
in
86 match schema,single
with
87 | [ {domain
;_
} ], true -> `Func
(Type.Ret domain
, as_params p
)
88 | s
, true -> raise
(Schema.Error
(s
, "only one column allowed for SELECT operator in this expression"))
89 | _
-> fail
"not implemented: multi-column select in expression"
93 (** assign types to parameters where possible *)
94 and assign_types expr
=
95 let rec typeof e
= (* FIXME simplify *)
98 | `Param
(_
,t
) -> e
, t
99 | `Func
(func
,params
) ->
100 let (params
,types
) = params
|> List.map
typeof |> List.split
in
102 sprintf
"%s applied to (%s)"
103 (Type.string_of_func func
)
104 (String.concat
", " @@ List.map
Type.to_string types
)
106 let (ret
,inferred_params
) = match func
, types
with
107 | Type.Agg
, [typ] -> typ, types
108 | Type.Group
(ret
,false), [_
]
109 | Type.Group
(ret
,true), _
-> ret
, types
110 | (Type.Agg
| Type.Group _
), _
-> fail
"cannot use this grouping function with %d parameters" (List.length types
)
111 | Type.Func
(ret
,args
), _
when List.length args
= List.length types
112 && List.fold_left
(&&) true (List.map2
Type.matches args types
) -> ret
, args
114 fail
"types do not match : %s" (show ())
115 | Type.Ret
Type.Any
, _
-> (* lame - make a best guest, return type same as for parameters *)
116 begin match List.filter
((<>) Type.Any
) types
with
117 | [] -> Type.Any
, types
118 | h
::tl
when List.for_all
((=) h
) tl
-> h
, List.map
(fun _
-> h
) types
119 | _
-> Type.Any
, types
121 | Type.Ret ret
, _
-> ret
, types
(* ignoring arguments FIXME *)
122 | Type.Poly ret
, _
->
123 match List.filter
((<>) Type.Any
) types
with
125 | h
::tl
when List.for_all
((=) h
) tl
-> ret
, List.map
(fun _
-> h
) types
126 | _
-> fail
"all parameters should have same type : %s" (show ())
128 let assign inferred x
=
130 | `Param
(n
,Type.Any
) -> `Param
(n
, inferred
)
133 `Func
(func
,(List.map2
assign inferred_params params
)), ret
137 and resolve_types tables joined_schema expr
=
138 let expr = resolve_columns tables joined_schema
expr in
143 eprintfn
"resolve_types failed with %s at:" (Printexc.to_string exn
);
144 eprintfn
"%s" (show_expr_q expr);
147 and infer_schema columns tables joined_schema
=
148 (* let all = tables |> List.map snd |> List.flatten in *)
149 let schema name
= name
|> Tables.get_from tables
|> snd
in
150 let resolve1 = function
151 | All
-> joined_schema
152 | AllOf t
-> schema t
156 | Column
(name
,Some t
) -> Schema.find
(schema t
) name
157 | Column
(name
,None
) -> Schema.find joined_schema name
158 | _
-> attr "" (resolve_types tables joined_schema e
|> snd
)
160 let col = Option.map_default
(fun n
-> {col with name
= n
}) col name
in
163 collect resolve1 columns
165 and test_all_const columns
=
166 let rec is_const = function
167 | Fun
(_
,args
) -> List.for_all
is_const args
168 | Select _
-> false (* FIXME ? *)
173 | Expr
(e
,_
) -> is_const e
176 List.for_all
test columns
178 and get_params tables joined_schema e
=
179 e
|> resolve_types tables joined_schema
|> fst
|> get_params_q
183 let e = Sub [Value Type.Text; Param (Next,None); Sub []; Param (Named "ds", Some Type.Int);] in
184 e |> get_params |> to_string |> print_endline
187 and params_of_columns tables j_s
=
188 let get tables j_s
= function
189 | All
| AllOf
_ -> []
190 | Expr
(e,_) -> get_params tables j_s
e
192 collect (get tables j_s
)
194 and get_params_opt tables j_s
= function
195 | Some x
-> get_params tables j_s x
198 and get_params_l tables j_s l
= collect (get_params tables j_s
) l
200 and do_join env
(tables
,params
,schema) ((table1
,params1
),kind
) =
201 let (_,schema1
) = table1
in
202 let tables = tables @ [table1
] in
203 let schema = match kind
with
206 | `Default
-> Schema.cross schema schema1
207 | `Natural
-> Schema.natural
schema schema1
208 | `Using l
-> Schema.join_using l
schema schema1
210 let p = match kind
with
211 | `Cross
| `Default
| `Natural
| `Using
_ -> []
212 | `Search
e -> get_params env
.tables schema e
214 tables,params
@ params1
@ p , schema
216 and join env
((t0
,p0
),joins
) =
217 let all_tables = List.fold_left
(fun acc
((table
,_),_) -> table
::acc
) [t0
] joins
in
218 let env = {tables = env.tables @ all_tables} in
219 let (tables,params
,joined_schema
) = List.fold_left
(do_join
env) ([t0
],p0
,snd t0
) joins
in
220 (* let joined_schema = tables |> List.map snd |> List.flatten in *)
221 (tables,params
,joined_schema)
223 and params_of_assigns
tables ss
=
224 let (_,exprs) = split_column_assignments tables ss
in
225 get_params_l
tables (cross (List.map snd
tables)) exprs
227 and params_of_order o final_schema
tables =
228 get_params_l
tables (final_schema
:: (List.map snd
tables) |> all_columns) o
230 and ensure_simple_expr
= function
231 | Value x
-> `Value x
232 | Param x
-> `Param x
233 | Column
_ -> failwith
"Not a simple expression"
234 | Fun
(func
,_) when Type.is_grouping func
-> failwith
"Grouping function not allowed in simple expression"
235 | Fun
(x
,l
) -> `Func
(x
,List.map ensure_simple_expr l
) (* FIXME *)
236 | Select
_ -> failwith
"not implemented : ensure_simple_expr for SELECT"
238 and eval_select
env { columns
; from
; where
; group
; having
; } =
239 let (tbls
,p2
,joined_schema) =
241 | Some
(t
,l
) -> join
env (resolve_source
env t
, List.map
(fun (x
,k
) -> resolve_source
env x
, k
) l
)
244 let tbls = env.tables @ tbls in
245 let singlerow = group
= [] && test_all_grouping columns
in
246 let singlerow2 = where
= None
&& group
= [] && test_all_const columns
in
247 let p1 = params_of_columns
tbls joined_schema columns
in
248 let p3 = get_params_opt
tbls joined_schema where
in
249 let p4 = get_params_l
tbls joined_schema group
in
250 let p5 = get_params_opt
tbls joined_schema having
in
251 let cardinality = if singlerow then `One
else
252 if singlerow2 then `Zero_one
else `Nat
in
253 (infer_schema columns
tbls joined_schema, p1 @ p2
@ p3 @ p4 @ p5, tbls, cardinality)
255 and resolve_source
env (x
,alias
) =
256 let src = match x
with
257 | `Select select
-> let (s
,p,_,_) = eval_select
env select
in ("",s
), p
258 | `Table s
-> Tables.get s
, []
261 | Some name
-> let ((_,s
),p) = src in ((name
,s
),p)
264 and eval_select_full
env (select
,other
,order
,limit
) =
265 let (s1
,p1,tbls,cardinality) = eval_select
env select
in
266 let (s2l
,p2l
) = List.split
(List.map
(fun (s
,p,_,_) -> s
,p) @@ List.map
(eval_select
env) other
) in
268 eprintf
"cardinality=%s other=%u\n%!"
269 (Stmt.cardinality_to_string
cardinality)
271 let cardinality = if other
= [] then cardinality else `Nat
in
272 (* ignoring tables in compound statements - they cannot be used in ORDER BY *)
273 let final_schema = List.fold_left
Schema.compound s1 s2l
in
274 let p3 = params_of_order order
final_schema tbls in
275 let (p4,limit1
) = match limit
with | Some x
-> x
| None
-> [],false in
276 (* Schema.check_unique schema; *)
278 if limit1
&& cardinality = `Nat
then `Zero_one
280 final_schema,(p1@(List.flatten p2l
)@p3@p4), Stmt.Select
cardinality
283 let update_tables tables ss w
=
284 let (tables,params
) = List.split
tables in
285 let p1 = params_of_assigns
tables ss
in
286 let p2 = get_params_opt
tables (all_tbl_columns tables) w
in
287 (List.flatten params
) @ p1 @ p2
289 let eval (stmt
:Sql.stmt
) =
292 | Create
(name
,`Schema
schema) ->
293 Tables.add
(name
,schema);
295 | Create
(name
,`Select select
) ->
296 let (schema,params
,_) = eval_select_full
empty_env select
in
297 Tables.add
(name
,schema);
298 ([],params
,Create name
)
299 | Alter
(name
,actions
) ->
301 | `Add
(col,pos
) -> Tables.alter_add name
col pos
302 | `Drop
col -> Tables.alter_drop name
col
303 | `Change
(oldcol
,col,pos
) -> Tables.alter_change name oldcol
col pos
304 | `None
-> ()) actions
;
309 | CreateIndex
(name
,table
,cols) ->
310 Sql.Schema.project
cols (Tables.get_schema table
) |> ignore
; (* just check *)
311 [],[],CreateIndex name
312 | Insert
(table
,`Values
(names
, values
)) ->
313 let expect = values_or_all table names
in
314 let params, inferred
= match values
with
315 | None
-> [], Some
(Values
, expect)
317 let vl = List.length values
in
318 let cl = List.length
expect in
320 fail
"Expected %u expressions in VALUES list, %u provided" cl vl;
321 let assigns = List.combine
(List.map
(fun a
-> a
.name
, None
) expect) values
in
322 params_of_assigns
[Tables.get table
] assigns, None
324 [], params, Insert
(inferred
,table
)
325 | Insert
(table
,`Select
(names
, select
)) ->
326 let (schema,params,_) = eval_select_full
empty_env select
in
327 let expect = values_or_all table names
in
328 ignore
(Schema.compound
expect schema); (* test equal types *)
329 [], params, Insert
(None
,table
)
330 | Insert
(table
, `Set ss
) ->
331 let (params,inferred
) = match ss
with
332 | None
-> [], Some
(Assign
, Tables.get_schema table
)
333 | Some ss
-> params_of_assigns
[Tables.get table
] ss
, None
335 [], params, Insert
(inferred
,table
)
336 | Delete
(table
, where
) ->
337 let t = Tables.get table
in
338 let p = get_params_opt
[t] (snd
t) where
in
342 | Column
_ -> [] (* this is not column but some db-specific identifier *)
343 | _ -> get_params_q (ensure_simple_expr
e)
346 | Update
(table
,ss
,w
,o
,lim
) ->
347 let params = update_tables [Tables.get table
,[]] ss w
in
348 let p3 = params_of_order o
[] [Tables.get table
] in
349 [], params @ p3 @ lim
, Update
(Some table
)
350 | UpdateMulti
(tables,ss
,w
) ->
351 let tables = List.map
(resolve_source
empty_env) tables in
352 let params = update_tables tables ss w
in
353 [], params, Update None
354 | Select select
-> eval_select_full
empty_env select