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