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