lib/syntax.ml

   1 (** SQL syntax and RA *)
   2
   3 open Printf
   4 open ExtLib
   5 open Prelude
   6 open Sql
   7
   8 let debug = ref false
   9
  10 type env = {
  11   tables : Tables.table list;
  12   joined_schema : Schema.t;
  13   insert_schema : Schema.t;
  14 }
  15
  16 let empty_env = { tables = []; joined_schema = []; insert_schema = []; }
  17
  18 let collect f l = List.flatten (List.map f l)
  19
  20 (* FIXME *)
  21 let schema_as_params = List.map (fun attr -> (Some attr.name,(0,0)), Some attr.domain)
  22
  23 let schema_of tables name = snd @@ Tables.get_from tables name
  24
  25 let values_or_all table names =
  26   let schema = Tables.get_schema table in
  27   match names with
  28   | Some names -> Schema.project names schema
  29   | None -> schema
  30
  31 let list_filter_map = ExtList.List.filter_map
  32
  33 let get_params_q e =
  34   let rec loop acc e =
  35     match e with
  36     | `Param p -> p::acc
  37     | `Func (_,l) -> List.fold_left loop acc l
  38     | `Value _ -> acc
  39   in
  40   loop [] e |> List.rev
  41
  42 let rec is_singular = function
  43 | Value _
  44 | Param _ -> true
  45 | Column _ -> false
  46 | Fun (func,args) ->
  47   (* grouping function of zero or single parameter or function of all singular values *)
  48   (Type.is_grouping func && List.length args <= 1) || List.for_all is_singular args
  49 | Select _ -> false (* ? *)
  50 | Inserted _ -> false (* ? *)
  51
  52 let test_all_grouping columns =
  53   List.for_all (function Expr (e,_) -> is_singular e | All | AllOf _ -> false) columns
  54
  55 let cross = List.fold_left Schema.cross []
  56
  57 (* all columns from tables, without duplicates *)
  58 (* FIXME check type of duplicates *)
  59 let all_columns = Schema.make_unique $ cross
  60 let all_tbl_columns = all_columns $ List.map snd
  61
  62 let resolve_column tables joined_schema {cname;tname} =
  63   Schema.find (Option.map_default (schema_of tables) joined_schema tname) cname
  64
  65 let resolve_column_assignments tables l =
  66   let all = all_tbl_columns tables in
  67   l |> List.map begin fun (col,expr) ->
  68     (* hint expression to unify with the column type *)
  69     let typ = (resolve_column tables all col).domain in
  70     Fun (Type.(Ret Any), [Value typ;expr])
  71   end
  72
  73 let get_columns_schema tables l =
  74   let all = all_tbl_columns tables in
  75   (* FIXME col_name *)
  76   l |> List.map (fun col -> { name = col.cname; domain = (resolve_column tables all col).domain; })
  77
  78 (** replace each name reference (Column, Inserted, etc) with Value of corresponding type *)
  79 let rec resolve_columns env expr =
  80   if !debug then
  81   begin
  82     eprintf "\nRESOLVE COLUMNS %s\n%!" (expr_to_string expr);
  83     eprintf "schema: "; Sql.Schema.print env.joined_schema;
  84     Tables.print stderr env.tables;
  85   end;
  86   let rec each e =
  87     match e with
  88     | Value x -> `Value x
  89     | Column col -> `Value (resolve_column env.tables env.joined_schema col).domain
  90     | Inserted name ->
  91       let attr = try Schema.find env.insert_schema name with Schema.Error (_,s) -> fail "for inserted values : %s" s in
  92       `Value attr.domain
  93     | Param x -> `Param x
  94     | Fun (r,l) ->
  95       `Func (r,List.map each l)
  96     | Select (select,single) ->
  97       let as_params = List.map (fun x -> `Param x) in
  98       let (schema,p,_) = eval_select_full env select in
  99       match schema,single with
 100       | [ {domain;_} ], true -> `Func (Type.Ret domain, as_params p)
 101       | s, true -> raise (Schema.Error (s, "only one column allowed for SELECT operator in this expression"))
 102       | _ -> fail "not implemented: multi-column select in expression"
 103   in
 104   each expr
 105
 106 (** assign types to parameters where possible *)
 107 and assign_types expr =
 108   let rec typeof (e:expr_q) = (* FIXME simplify *)
 109     match e with
 110     | `Value t -> e, t
 111     | `Param (_,t) -> e, t
 112     | `Func (func,params) ->
 113         let open Type in
 114         let (params,types) = params |> List.map typeof |> List.split in
 115         let show () =
 116           sprintf "%s applied to (%s)"
 117             (string_of_func func)
 118             (String.concat ", " @@ List.map to_string types)
 119         in
 120         let (ret,inferred_params) = match func, types with
 121         | Agg, [typ] -> typ, types
 122         | Group (ret,false), [_]
 123         | Group (ret,true), _ -> ret, types
 124         | (Agg | Group _), _ -> fail "cannot use this grouping function with %d parameters" (List.length types)
 125         | F (_, args), _ when List.length args <> List.length types -> fail "types do not match : %s" (show ())
 126         | F (ret, args), _ ->
 127           let typevar = Hashtbl.create 10 in
 128           let l = List.map2 begin fun arg typ ->
 129             match arg with
 130             | Typ arg -> matches arg typ
 131             | Var i ->
 132               let arg =
 133                 match Hashtbl.find typevar i with
 134                 | exception Not_found -> Hashtbl.replace typevar i typ; typ
 135                 | t -> t
 136               in
 137               (* prefer more precise type *)
 138               if arg = Type.Any then Hashtbl.replace typevar i typ;
 139               matches arg typ
 140           end args types
 141           in
 142           let convert = function Typ t -> t | Var i -> Hashtbl.find typevar i in
 143           if List.fold_left (&&) true l then
 144             convert ret, List.map convert args
 145           else
 146             fail "types do not match : %s" (show ())
 147         | Ret Any, _ -> (* lame *)
 148           begin match List.filter ((<>) Any) types with
 149           | [] -> Any, types
 150           (* make a best guess, return type same as for parameters when all of single type *)
 151           | h::tl when List.for_all (matches h) tl -> h, List.map (fun _ -> h) types
 152           (* "expand" to floats, when all parameters numeric and above rule didn't match *)
 153           | l when List.for_all (function Int | Float -> true | _ -> false) l -> Float, List.map (function Any -> Float | x -> x) types
 154           | _ -> Any, types
 155           end
 156         | Ret ret, _ -> ret, types (* ignoring arguments FIXME *)
 157         | Poly ret, _ ->
 158           match List.filter ((<>) Any) types with
 159           | [] -> ret, types
 160           | h::tl when List.for_all (matches h) tl -> ret, List.map (fun _ -> h) types
 161           | _ -> fail "all parameters should have same type : %s" (show ())
 162         in
 163         let assign inferred x =
 164           match x with
 165           | `Param (n,Any) -> `Param (n, inferred)
 166           | x -> x
 167         in
 168         `Func (func,(List.map2 assign inferred_params params)), ret
 169   in
 170   typeof expr
 171
 172 and resolve_types env expr =
 173   let expr = resolve_columns env expr in
 174   try
 175     let (expr',t as r) = assign_types expr in
 176     if !debug then eprintf "resolved types %s : %s\n%!" (show_expr_q expr') (Type.to_string t);
 177     r
 178   with
 179     exn ->
 180       eprintfn "resolve_types failed with %s at:" (Printexc.to_string exn);
 181       eprintfn "%s" (show_expr_q expr);
 182       raise exn
 183
 184 and infer_schema env columns =
 185 (*   let all = tables |> List.map snd |> List.flatten in *)
 186   let resolve1 = function
 187     | All -> env.joined_schema
 188     | AllOf t -> schema_of env.tables t
 189     | Expr (e,name) ->
 190       let col =
 191         match e with
 192         | Column col -> resolve_column env.tables env.joined_schema col
 193         | _ -> attr "" (resolve_types env e |> snd)
 194       in
 195       let col = Option.map_default (fun n -> {col with name = n}) col name in
 196       [ col ]
 197   in
 198   collect resolve1 columns
 199
 200 and test_all_const columns =
 201   let rec is_const = function
 202   | Fun (_,args) -> List.for_all is_const args
 203   | Select _ -> false (* FIXME ? *)
 204   | Column _ -> false
 205   | _ -> true
 206   in
 207   let test = function
 208   | Expr (e,_) -> is_const e
 209   | _ -> false
 210   in
 211   List.for_all test columns
 212
 213 and get_params env e = e |> resolve_types env |> fst |> get_params_q
 214
 215 (*
 216 let _ =
 217   let e = Sub [Value Type.Text; Param (Next,None); Sub []; Param (Named "ds", Some Type.Int);] in
 218   e |> get_params |> to_string |> print_endline
 219 *)
 220
 221 and params_of_columns env =
 222   let get = function
 223   | All | AllOf _ -> []
 224   | Expr (e,_) -> get_params env e
 225   in
 226   collect get
 227
 228 and get_params_opt env = function
 229   | Some x -> get_params env x
 230   | None -> []
 231
 232 and get_params_l env l = collect (get_params env) l
 233
 234 and do_join (env,params) (((_, schema1),params1),kind) =
 235   let joined_schema = match kind with
 236   | `Cross
 237   | `Search _
 238   | `Default -> Schema.cross env.joined_schema schema1
 239   | `Natural -> Schema.natural env.joined_schema schema1
 240   | `Using l -> Schema.join_using l env.joined_schema schema1
 241   in
 242   let env = { env with joined_schema } in
 243   let p = match kind with
 244   | `Cross | `Default | `Natural | `Using _ -> []
 245   | `Search e -> get_params env e (* TODO should use final schema (same as tables)? *)
 246   in
 247   env, params @ params1 @ p
 248
 249 and join env ((t0,p0),joins) =
 250   assert (env.joined_schema = []);
 251   let all_tables = List.fold_left (fun acc ((table,_),_) -> table::acc) [t0] joins in
 252   let env = { env with tables = env.tables @ all_tables; joined_schema = snd t0 } in
 253   List.fold_left do_join (env, p0) joins
 254
 255 and params_of_assigns env ss =
 256   let exprs = resolve_column_assignments env.tables ss in
 257   get_params_l env exprs
 258
 259 and params_of_order o final_schema tables =
 260   get_params_l { tables; joined_schema=(final_schema :: (List.map snd tables) |> all_columns); insert_schema = []; } o
 261
 262 and ensure_simple_expr = function
 263   | Value x -> `Value x
 264   | Param x -> `Param x
 265   | Column _ | Inserted _ -> failwith "Not a simple expression"
 266   | Fun (func,_) when Type.is_grouping func -> failwith "Grouping function not allowed in simple expression"
 267   | Fun (x,l) -> `Func (x,List.map ensure_simple_expr l) (* FIXME *)
 268   | Select _ -> failwith "not implemented : ensure_simple_expr for SELECT"
 269
 270 and eval_select env { columns; from; where; group; having; } =
 271   (* nested selects generate new fresh schema in scope, cannot refer to outer schema,
 272     but can refer to attributes of tables through `tables` *)
 273   let env = { env with joined_schema = [] } in
 274   let (env,p2) =
 275     match from with
 276     | Some (t,l) -> join env (resolve_source env t, List.map (fun (x,k) -> resolve_source env x, k) l)
 277     | None -> env, []
 278   in
 279   let singlerow = group = [] && test_all_grouping columns in
 280   let singlerow2 = where = None && group = [] && test_all_const columns in
 281   let p1 = params_of_columns env columns in
 282   let p3 = get_params_opt env where in
 283   let p4 = get_params_l env group in
 284   let p5 = get_params_opt env having in
 285   let cardinality = if singlerow then `One else
 286                     if singlerow2 then `Zero_one else `Nat in
 287   (infer_schema env columns, p1 @ p2 @ p3 @ p4 @ p5, env.tables, cardinality)
 288
 289 and resolve_source env (x,alias) =
 290   let src = match x with
 291   | `Select select -> let (s,p,_,_) = eval_select env select in ("",s), p
 292   | `Table s -> Tables.get s, []
 293   in
 294   match alias with
 295   | Some name -> let ((_,s),p) = src in ((name,s),p)
 296   | None -> src
 297
 298 and eval_select_full env { select=(select,other); order; limit; } =
 299   let (s1,p1,tbls,cardinality) = eval_select env select in
 300   let (s2l,p2l) = List.split (List.map (fun (s,p,_,_) -> s,p) @@ List.map (eval_select env) other) in
 301   if false then
 302     eprintf "cardinality=%s other=%u\n%!"
 303             (Stmt.cardinality_to_string cardinality)
 304             (List.length other);
 305   let cardinality = if other = [] then cardinality else `Nat in
 306   (* ignoring tables in compound statements - they cannot be used in ORDER BY *)
 307   let final_schema = List.fold_left Schema.compound s1 s2l in
 308   let p3 = params_of_order order final_schema tbls in
 309   let (p4,limit1) = match limit with | Some x -> x | None -> [],false in
 310   (*                 Schema.check_unique schema; *)
 311   let cardinality =
 312     if limit1 && cardinality = `Nat then `Zero_one
 313                                     else cardinality in
 314   final_schema,(p1@(List.flatten p2l)@p3@p4), Stmt.Select cardinality
 315
 316
 317 let update_tables tables ss w =
 318   let (tables,params) = List.split tables in
 319   let env = { tables; joined_schema=cross @@ List.map snd tables; insert_schema=get_columns_schema tables (List.map fst ss); } in
 320   let p1 = params_of_assigns env ss in
 321   let p2 = get_params_opt env w in
 322   (List.flatten params) @ p1 @ p2
 323
 324 let annotate_select select types =
 325   let (select1,compound) = select.select in
 326   let rec loop acc cols types =
 327     match cols, types with
 328     | [], [] -> List.rev acc
 329     | (All | AllOf _) :: _, _ -> failwith "Asterisk not supported"
 330     | Expr (e,name) :: cols, t :: types -> loop (Expr (Fun (F (Typ t, [Typ t]), [e]), name) :: acc) cols types
 331     | _, [] | [], _ -> failwith "Select cardinality doesn't match Insert"
 332   in
 333   { select with select = { select1 with columns = loop [] select1.columns types }, compound }
 334
 335 let eval (stmt:Sql.stmt) =
 336   let open Stmt in
 337   match stmt with
 338   | Create (name,`Schema schema) ->
 339       Tables.add (name,schema);
 340       ([],[],Create name)
 341   | Create (name,`Select select) ->
 342       let (schema,params,_) = eval_select_full empty_env select in
 343       Tables.add (name,schema);
 344       ([],params,Create name)
 345   | Alter (name,actions) ->
 346       List.iter (function
 347       | `Add (col,pos) -> Tables.alter_add name col pos
 348       | `Drop col -> Tables.alter_drop name col
 349       | `Change (oldcol,col,pos) -> Tables.alter_change name oldcol col pos
 350       | `None -> ()) actions;
 351       ([],[],Alter name)
 352   | Drop name ->
 353       Tables.drop name;
 354       ([],[],Drop name)
 355   | CreateIndex (name,table,cols) ->
 356       Sql.Schema.project cols (Tables.get_schema table) |> ignore; (* just check *)
 357       [],[],CreateIndex name
 358   | Insert { target=table; action=`Values (names, values); on_duplicate; } ->
 359     let expect = values_or_all table names in
 360     let env = { tables = [Tables.get table]; joined_schema = expect; insert_schema = expect; } in
 361     let params, inferred = match values with
 362     | None -> [], Some (Values, expect)
 363     | Some values ->
 364       let vl = List.map List.length values in
 365       let cl = List.length expect in
 366       if List.exists (fun n -> n <> cl) vl then
 367         fail "Expecting %u expressions in every VALUES tuple" cl;
 368       let assigns = List.map (fun tuple -> List.combine (List.map (fun a -> {cname=a.name; tname=None}) expect) tuple) values in
 369       params_of_assigns env (List.concat assigns), None
 370     in
 371     let params2 = params_of_assigns env (Option.default [] on_duplicate) in
 372     [], params @ params2, Insert (inferred,table)
 373   | Insert { target=table; action=`Select (names, select); on_duplicate; } ->
 374     let expect = values_or_all table names in
 375     let env = { tables = [Tables.get table]; joined_schema = expect; insert_schema = expect; } in
 376     let select = annotate_select select (List.map (fun a -> a.domain) expect) in
 377     let (schema,params,_) = eval_select_full env select in
 378     ignore (Schema.compound expect schema); (* test equal types once more (not really needed) *)
 379     let params2 = params_of_assigns env (Option.default [] on_duplicate) in
 380     [], params @ params2, Insert (None,table)
 381   | Insert { target=table; action=`Set ss; on_duplicate; } ->
 382     let expect = values_or_all table (Option.map (List.map (function ({cname; tname=None},_) -> cname | _ -> assert false)) ss) in
 383     let env = { tables = [Tables.get table]; joined_schema = expect; insert_schema = expect; } in
 384     let (params,inferred) = match ss with
 385     | None -> [], Some (Assign, Tables.get_schema table)
 386     | Some ss -> params_of_assigns env ss, None
 387     in
 388     let params2 = params_of_assigns env (Option.default [] on_duplicate) in
 389     [], params @ params2, Insert (inferred,table)
 390   | Delete (table, where) ->
 391     let t = Tables.get table in
 392     let p = get_params_opt { tables=[t]; joined_schema=snd t; insert_schema=[]; } where in
 393     [], p, Delete table
 394   | Set (_name, e) ->
 395     let p = match e with
 396       | Column _ -> [] (* this is not column but some db-specific identifier *)
 397       | _ -> get_params_q (ensure_simple_expr e)
 398     in
 399     [], p, Other
 400   | Update (table,ss,w,o,lim) ->
 401     let params = update_tables [Tables.get table,[]] ss w in
 402     let p3 = params_of_order o [] [Tables.get table] in
 403     [], params @ p3 @ lim, Update (Some table)
 404   | UpdateMulti (tables,ss,w) ->
 405     let tables = List.map (resolve_source empty_env) tables in
 406     let params = update_tables tables ss w in
 407     [], params, Update None
 408   | Select select -> eval_select_full empty_env select
 409   | CreateRoutine _ ->
 410     [], [], Other
 411
 412 let unify_params l =
 413   let h = Hashtbl.create 10 in
 414   l |> List.iter begin fun ((name,_loc),t) ->
 415     match name with
 416     | None -> ()
 417     | Some name ->
 418     match Hashtbl.find h name with
 419     | exception _ -> Hashtbl.add h name t
 420     | t' ->
 421     match Sql.Type.common_subtype t t' with
 422     | Some x -> Hashtbl.replace h name x
 423     | None -> fail "incompatible types for parameter %S : %s and %s" name (Type.show t) (Type.show t')
 424   end;
 425   l |> List.map (function ((None,_),_ as x) -> x | ((Some name,_ as id),_) -> id, try Hashtbl.find h name with _ -> assert false)
 426
 427 let eval stmt =
 428   let (schema,p,kind) = eval stmt in
 429   (schema, unify_params p, kind)