lib/syntax.ml

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