lib/syntax.ml

   1 (** SQL syntax and RA *)
   2
   3 open Printf
   4 open Prelude
   5 open Sql
   6
   7 type env = { tables : Tables.table list; }
   8
   9 let empty_env = { tables = [] }
  10
  11 let collect f l = List.flatten (List.map f l)
  12
  13 (* FIXME *)
  14 let schema_as_params = List.map (fun attr -> (Some attr.name,(0,0)), Some attr.domain)
  15
  16 let values_or_all table names =
  17   let schema = Tables.get_schema table in
  18   match names with
  19   | Some names -> Schema.project names schema
  20   | None -> schema
  21
  22 let list_filter_map = ExtList.List.filter_map
  23
  24 let show_expr_q e = Show.show<expr_q> (e)
  25
  26 let get_params_q e =
  27   let rec loop acc e =
  28     match e with
  29     | `Param p -> p::acc
  30     | `Func (_,l) -> List.fold_left loop acc l
  31     | `Value _ -> acc
  32   in
  33   loop [] e |> List.rev
  34
  35 let test_all_grouping columns =
  36   let test = function
  37   (* grouping function of zero or single parameter *)
  38   | Expr (Fun (func,args),_) when Type.is_grouping func && List.length args <= 1 -> true
  39   | _ -> false
  40   in
  41   List.for_all test columns
  42
  43 let cross = List.fold_left Schema.cross []
  44
  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
  49
  50 let split_column_assignments tables l =
  51   let cols = ref [] in
  52   let exprs = ref [] in
  53   let all = all_tbl_columns tables in
  54   List.iter (fun ((cname,tname as col),expr) ->
  55     cols := col :: !cols;
  56     let schema =
  57       match tname with
  58       | Some name -> Tables.get_from tables name |> snd
  59       | None -> all
  60     in
  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)
  65
  66 (** replace every Column with Value of corresponding type *)
  67 let rec resolve_columns tables joined_schema expr =
  68 (*
  69   eprintf "\nRESOLVE COLUMNS\n%s\n%!" (expr_to_string expr);
  70   Tables.print stderr tables;
  71   Sql.Schema.print joined_schema;
  72 *)
  73   let schema_of_table name = name |> Tables.get_from tables |> snd in
  74   let rec each e =
  75     match e with
  76     | Value x -> `Value x
  77     | Column (name,table) ->
  78       let attr = Schema.find (Option.map_default schema_of_table joined_schema table) name in
  79       `Value attr.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 = (* FIXME simplify *)
  96     match e with
  97     | `Value t -> e, t
  98     | `Param (_,t) -> e, t
  99     | `Func (func,params) ->
 100         let (params,types) = params |> List.map typeof |> List.split in
 101         let show () =
 102           sprintf "%s applied to (%s)"
 103             (Type.string_of_func func)
 104             (String.concat ", " @@ List.map Type.to_string types)
 105         in
 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
 113         | Type.Func _, _ ->
 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
 120           end
 121         | Type.Ret ret, _ -> ret, types (* ignoring arguments FIXME *)
 122         | Type.Poly ret, _ ->
 123           match List.filter ((<>) Type.Any) types with
 124           | [] -> ret, types
 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 ())
 127         in
 128         let assign inferred x =
 129           match x with
 130           | `Param (n,Type.Any) -> `Param (n, inferred)
 131           | x -> x
 132         in
 133         `Func (func,(List.map2 assign inferred_params params)), ret
 134   in
 135   typeof expr
 136
 137 and resolve_types tables joined_schema expr =
 138   let expr = resolve_columns tables joined_schema expr in
 139   try
 140     assign_types expr
 141   with
 142     exn ->
 143       eprintfn "resolve_types failed with %s at:" (Printexc.to_string exn);
 144       eprintfn "%s" (show_expr_q expr);
 145       raise exn
 146
 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
 153     | Expr (e,name) ->
 154       let col = begin
 155       match e with
 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)
 159       end in
 160       let col = Option.map_default (fun n -> {col with name = n}) col name in
 161       [ col ]
 162   in
 163   collect resolve1 columns
 164
 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 ? *)
 169   | Column _ -> false
 170   | _ -> true
 171   in
 172   let test = function
 173   | Expr (e,_) -> is_const e
 174   | _ -> false
 175   in
 176   List.for_all test columns
 177
 178 and get_params tables joined_schema e =
 179   e |> resolve_types tables joined_schema |> fst |> get_params_q
 180
 181 (*
 182 let _ =
 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
 185 *)
 186
 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
 191   in
 192   collect (get tables j_s)
 193
 194 and get_params_opt tables j_s = function
 195   | Some x -> get_params tables j_s x
 196   | None -> []
 197
 198 and get_params_l tables j_s l = collect (get_params tables j_s) l
 199
 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
 204   | `Cross
 205   | `Search _
 206   | `Default -> Schema.cross schema schema1
 207   | `Natural -> Schema.natural schema schema1
 208   | `Using l -> Schema.join_using l schema schema1
 209   in
 210   let p = match kind with
 211   | `Cross | `Default | `Natural | `Using _ -> []
 212   | `Search e -> get_params env.tables schema e
 213   in
 214   tables,params @ params1 @ p , schema
 215
 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)
 222
 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
 226
 227 and params_of_order o final_schema tables =
 228   get_params_l tables (final_schema :: (List.map snd tables) |> all_columns) o
 229
 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"
 237
 238 and eval_select env { columns; from; where; group; having; } =
 239   let (tbls,p2,joined_schema) =
 240     match from with
 241     | Some (t,l) -> join env (resolve_source env t, List.map (fun (x,k) -> resolve_source env x, k) l)
 242     | None -> [], [], []
 243   in
 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)
 254
 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, []
 259   in
 260   match alias with
 261   | Some name -> let ((_,s),p) = src in ((name,s),p)
 262   | None -> src
 263
 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
 267   if false then
 268     eprintf "cardinality=%s other=%u\n%!"
 269             (Stmt.cardinality_to_string cardinality)
 270             (List.length other);
 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; *)
 277   let cardinality =
 278     if limit1 && cardinality = `Nat then `Zero_one
 279                                     else cardinality in
 280   final_schema,(p1@(List.flatten p2l)@p3@p4), Stmt.Select cardinality
 281
 282
 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
 288
 289 let eval (stmt:Sql.stmt) =
 290   let open Stmt in
 291   match stmt with
 292   | Create (name,`Schema schema) ->
 293       Tables.add (name,schema);
 294       ([],[],Create name)
 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) ->
 300       List.iter (function
 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;
 305       ([],[],Alter name)
 306   | Drop name ->
 307       Tables.drop name;
 308       ([],[],Drop name)
 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)
 316     | Some values ->
 317       let vl = List.length values in
 318       let cl = List.length expect in
 319       if vl <> cl then
 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
 323     in
 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
 334     in
 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
 339     [], p, Delete table
 340   | Set (_name, e) ->
 341     let p = match e with
 342       | Column _ -> [] (* this is not column but some db-specific identifier *)
 343       | _ -> get_params_q (ensure_simple_expr e)
 344     in
 345     [], p, Other
 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