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) |> print_endline
  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 ((_,true),args,_),_) when 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.Any,false), [Value typ;expr], `None)) :: !exprs) l;
  64   (List.rev !cols, List.rev !exprs)
  65
  66
  67 (** replace every Column with Value of corresponding type *)
  68 let rec resolve_columns tables joined_schema expr =
  69 (*
  70   eprintf "\nRESOLVE COLUMNS\n%s\n%!" (expr_to_string expr);
  71   Tables.print stderr tables;
  72   Sql.Schema.print joined_schema;
  73 *)
  74   let schema_of_table name = name |> Tables.get_from tables |> snd in
  75   let rec each e =
  76     match e with
  77     | Value x -> `Value x
  78     | Column (name,table) ->
  79       let attr = Schema.find (Option.map_default schema_of_table joined_schema table) name in
  80       `Value attr.domain
  81     | Param x -> `Param x
  82     | Fun (r,l,select) ->
  83       let p = params_of_select {tables} select in
  84       `Func (r,p @ List.map each l)
  85   in
  86   each expr
  87
  88 (** assign types to parameters where possible *)
  89 and assign_types expr =
  90   let rec typeof e = (* FIXME simplify *)
  91     match e with
  92     | `Value t -> e, t
  93     | `Func ((ret,g),l) ->
  94 (** Assumption: sql functions/operators have type schema 'a -> ... -> 'a -> 'a -> 'b
  95     i.e. all parameters of some equal type *)
  96         let (l,t) = l |> List.map typeof |> List.split in
  97         let t = match List.filter ((<>) Type.Any) t with
  98         | [] -> Type.Any
  99         | h::t -> if List.for_all ((=) h) t then h else Type.Any
 100         in
 101         let assign = function
 102         | `Param (n,Type.Any) -> `Param (n,t)
 103         | x -> x
 104         in
 105         let ret = if Type.Any <> ret then ret else t in
 106         `Func ((ret,g),(List.map assign l)),ret
 107     | `Param (_,t) -> e, t
 108   in
 109   typeof expr
 110
 111 and resolve_types tables joined_schema expr =
 112   let expr = resolve_columns tables joined_schema expr in
 113   if false then show_expr_q expr;
 114   let (expr,_ as r) = assign_types expr in
 115   if false then print_newline @@ show_expr_q expr;
 116   r
 117
 118 and infer_schema columns tables joined_schema =
 119 (*   let all = tables |> List.map snd |> List.flatten in *)
 120   let schema name = name |> Tables.get_from tables |> snd in
 121   let resolve1 = function
 122     | All -> joined_schema
 123     | AllOf t -> schema t
 124     | Expr (e,name) ->
 125       let col = begin
 126       match e with
 127       | Column (name,Some t) -> Schema.find (schema t) name
 128       | Column (name,None) -> Schema.find joined_schema name
 129       | _ -> attr "" (resolve_types tables joined_schema e |> snd)
 130       end in
 131       let col = Option.map_default (fun n -> {col with name = n}) col name in
 132       [ col ]
 133   in
 134   collect resolve1 columns
 135
 136 and test_all_const columns =
 137   let rec is_const = function
 138   | Fun (_,args,`None) -> List.for_all is_const args
 139   | Fun (_,_,_) -> false (* FIXME ? *)
 140   | Column _ -> false
 141   | _ -> true
 142   in
 143   let test = function
 144   | Expr (e,_) -> is_const e
 145   | _ -> false
 146   in
 147   List.for_all test columns
 148
 149 and get_params tables joined_schema e =
 150   e |> resolve_types tables joined_schema |> fst |> get_params_q
 151
 152 (*
 153 let _ =
 154   let e = Sub [Value Type.Text; Param (Next,None); Sub []; Param (Named "ds", Some Type.Int);] in
 155   e |> get_params |> to_string |> print_endline
 156 *)
 157
 158 and params_of_columns tables j_s =
 159   let get tables j_s = function
 160   | All | AllOf _ -> []
 161   | Expr (e,_) -> get_params tables j_s e
 162   in
 163   collect (get tables j_s)
 164
 165 and get_params_opt tables j_s = function
 166   | Some x -> get_params tables j_s x
 167   | None -> []
 168
 169 and get_params_l tables j_s l = collect (get_params tables j_s) l
 170
 171 and do_join env (tables,params,schema) ((table1,params1),kind) =
 172   let (_,schema1) = table1 in
 173   let tables = tables @ [table1] in
 174   let schema = match kind with
 175   | `Cross
 176   | `Search _
 177   | `Default -> Schema.cross schema schema1
 178   | `Natural -> Schema.natural schema schema1
 179   | `Using l -> Schema.join_using l schema schema1
 180   in
 181   let p = match kind with
 182   | `Cross | `Default | `Natural | `Using _ -> []
 183   | `Search e -> get_params env.tables schema e
 184   in
 185   tables,params @ params1 @ p , schema
 186
 187 and join env ((t0,p0),joins) =
 188   let all_tables = List.fold_left (fun acc ((table,_),_) -> table::acc) [t0] joins in
 189   let env = {tables = env.tables @ all_tables} in
 190   let (tables,params,joined_schema) = List.fold_left (do_join env) ([t0],p0,snd t0) joins in
 191 (*   let joined_schema = tables |> List.map snd |> List.flatten in *)
 192   (tables,params,joined_schema)
 193
 194 and params_of_assigns tables ss =
 195   let (_,exprs) = split_column_assignments tables ss in
 196   get_params_l tables (cross (List.map snd tables)) exprs
 197
 198 and params_of_order o final_schema tables =
 199   get_params_l tables (final_schema :: (List.map snd tables) |> all_columns) o
 200
 201 and ensure_simple_expr = function
 202   | Value x -> `Value x
 203   | Param x -> `Param x
 204   | Column _ -> failwith "Not a simple expression"
 205   | Fun ((_,grouping),_,_) when grouping -> failwith "Grouping function not allowed in simple expression"
 206   | Fun (x,l,`None) -> `Func (x,List.map ensure_simple_expr l) (* FIXME *)
 207   | Fun (_,_,_) -> failwith "not implemented : ensure_simple_expr with SELECT"
 208
 209 and eval_select env { columns; from; where; group; having; } =
 210   let (tbls,p2,joined_schema) =
 211     match from with
 212     | Some (t,l) -> join env (resolve_source env t, List.map (fun (x,k) -> resolve_source env x, k) l)
 213     | None -> [], [], []
 214   in
 215   let tbls = env.tables @ tbls in
 216   let singlerow = group = [] && test_all_grouping columns in
 217   let singlerow2 = where = None && group = [] && test_all_const columns in
 218   let p1 = params_of_columns tbls joined_schema columns in
 219   let p3 = get_params_opt tbls joined_schema where in
 220   let p4 = get_params_l tbls joined_schema group in
 221   let p5 = get_params_opt tbls joined_schema having in
 222   let cardinality = if singlerow then `One else
 223                     if singlerow2 then `Zero_one else `Nat in
 224   (infer_schema columns tbls joined_schema, p1 @ p2 @ p3 @ p4 @ p5, tbls, cardinality)
 225
 226 and resolve_source env (x,alias) =
 227   let src = match x with
 228   | `Select select -> let (s,p,_,_) = eval_select env select in ("",s), p
 229   | `Table s -> Tables.get s, []
 230   in
 231   match alias with
 232   | Some name -> let ((_,s),p) = src in ((name,s),p)
 233   | None -> src
 234
 235 and eval_select_full env (select,other,order,limit) =
 236   let (s1,p1,tbls,cardinality) = eval_select env select in
 237   let (s2l,p2l) = List.split (List.map (fun (s,p,_,_) -> s,p) @@ List.map (eval_select env) other) in
 238   if false then
 239     eprintf "cardinality=%s other=%u\n%!"
 240             (Stmt.cardinality_to_string cardinality)
 241             (List.length other);
 242   let cardinality = if other = [] then cardinality else `Nat in
 243   (* ignoring tables in compound statements - they cannot be used in ORDER BY *)
 244   let final_schema = List.fold_left Schema.compound s1 s2l in
 245   let p3 = params_of_order order final_schema tbls in
 246   let (p4,limit1) = match limit with | Some x -> x | None -> [],false in
 247   (*                 Schema.check_unique schema; *)
 248   let cardinality =
 249     if limit1 && cardinality = `Nat then `Zero_one
 250                                     else cardinality in
 251   final_schema,(p1@(List.flatten p2l)@p3@p4), Stmt.Select cardinality
 252
 253 and params_of_select env s =
 254   let make = List.map (fun x -> `Param x) in
 255   match s with
 256   | `None -> []
 257   | `Select s -> let (_,p,_) = eval_select_full env s in make p
 258   | `Single select ->
 259     match eval_select_full env select with
 260     | [_],p,_ -> make p
 261     | s,_,_ -> raise (Schema.Error (s,"only one column allowed for SELECT operator in this expression"))
 262
 263
 264 let update_tables tables ss w =
 265   let (tables,params) = List.split tables in
 266   let p1 = params_of_assigns tables ss in
 267   let p2 = get_params_opt tables (all_tbl_columns tables) w in
 268   (List.flatten params) @ p1 @ p2
 269
 270 let eval (stmt:Sql.stmt) =
 271   let open Stmt in
 272   match stmt with
 273   | Create (name,`Schema schema) ->
 274       Tables.add (name,schema);
 275       ([],[],Create name)
 276   | Create (name,`Select select) ->
 277       let (schema,params,_) = eval_select_full empty_env select in
 278       Tables.add (name,schema);
 279       ([],params,Create name)
 280   | Alter (name,actions) ->
 281       List.iter (function
 282       | `Add (col,pos) -> Tables.alter_add name col pos
 283       | `Drop col -> Tables.alter_drop name col
 284       | `Change (oldcol,col,pos) -> Tables.alter_change name oldcol col pos
 285       | `None -> ()) actions;
 286       ([],[],Alter name)
 287   | Drop name ->
 288       Tables.drop name;
 289       ([],[],Drop name)
 290   | CreateIndex (name,table,cols) ->
 291       Sql.Schema.project cols (Tables.get_schema table) |> ignore; (* just check *)
 292       [],[],CreateIndex name
 293   | Insert (table,`Values (names, values)) ->
 294     let expect = values_or_all table names in
 295     let params, inferred = match values with
 296     | None -> [], Some (Values, expect)
 297     | Some values ->
 298       let vl = List.length values in
 299       let cl = List.length expect in
 300       if vl <> cl then
 301         failwith (sprintf "Expected %u expressions in VALUES list, %u provided" cl vl);
 302       let assigns = List.combine (List.map (fun a -> a.name, None) expect) values in
 303       params_of_assigns [Tables.get table] assigns, None
 304     in
 305     [], params, Insert (inferred,table)
 306   | Insert (table,`Select (names, select)) ->
 307     let (schema,params,_) = eval_select_full empty_env select in
 308     let expect = values_or_all table names in
 309     ignore (Schema.compound expect schema); (* test equal types *)
 310     [], params, Insert (None,table)
 311   | Insert (table, `Set ss) ->
 312     let (params,inferred) = match ss with
 313     | None -> [], Some (Assign, Tables.get_schema table)
 314     | Some ss -> params_of_assigns [Tables.get table] ss, None
 315     in
 316     [], params, Insert (inferred,table)
 317   | Delete (table, where) ->
 318     let t = Tables.get table in
 319     let p = get_params_opt [t] (snd t) where in
 320     [], p, Delete table
 321   | Set (_name, e) ->
 322     let p = match e with
 323       | Column _ -> [] (* this is not column but some db-specific identifier *)
 324       | _ -> get_params_q (ensure_simple_expr e)
 325     in
 326     [], p, Other
 327   | Update (table,ss,w,o,lim) ->
 328     let params = update_tables [Tables.get table,[]] ss w in
 329     let p3 = params_of_order o [] [Tables.get table] in
 330     [], params @ p3 @ lim, Update (Some table)
 331   | UpdateMulti (tables,ss,w) ->
 332     let tables = List.map (resolve_source empty_env) tables in
 333     let params = update_tables tables ss w in
 334     [], params, Update None
 335   | Select select -> eval_select_full empty_env select