Dynamic select 3

impl/ocaml/sqlgg_traits.ml

@@ -269,6 +269,22 @@ module type M_control_io = sig
 
 end
 
+module Dynamic (F : sig type _ t end) = struct
+  type a_field = Any_field : 'a F.t -> a_field
+
+  type _ t =
+    | V : 'a F.t -> 'a t
+    | Return : 'a -> 'a t
+    | Map : 'a t * ('a -> 'b) -> 'b t
+    | Both : 'a t * 'b t -> ('a * 'b) t
+
+  let return x = Return x
+  let map f t = Map (t, f)
+  let both a b = Both (a, b)
+  let (let+) t f = Map (t, f)
+  let (and+) a b = Both (a, b)
+end
+
 module type M_default_types = M with type Types.Bool.t = bool
   and type Types.Int.t = int64
   and type Types.Float.t = float

lib/sql.ml

@@ -317,7 +317,7 @@ module Meta = struct
   let get_is_non_nullifiable meta = Option.default "false" (find_opt meta "non_nullifiable") = "true" 
 end
 
-type attr = {name : string; domain : Type.t; extra : Constraints.t; meta: Meta.t }
+type attr = { name : string; domain : Type.t; extra : Constraints.t; meta: Meta.t }
   [@@deriving show {with_path=false}]
 
 let make_attribute name kind extra ~meta =
@@ -526,6 +526,8 @@ and var =
 (* It differs from Choice that in this case we should generate sql "TRUE", it doesn't seem reusable *)
 | OptionActionChoice of param_id * var list * (pos * pos) * option_actions_kind
 | SharedVarsGroup of vars * shared_query_ref_id
+| DynamicSelect of param_id * ctor list
+[@@deriving show]
 and tuple_list_kind = Insertion of schema | Where_in of (Type.t * Meta.t) list * in_or_not_in * pos | ValueRows of { types: Type.t list; values_start_pos: int; }
 [@@deriving show]
 and vars = var list [@@deriving show]

lib/syntax.ml

@@ -10,6 +10,7 @@ module Config = struct
   let debug = ref false
   (* If strict mode is not enabled, some dbs allow this. *)
   let allow_write_notnull_null = ref false
+  let dynamic_select = ref false
 end
 
 type env = {
@@ -28,6 +29,7 @@ type env = {
   (* Check if the current query is an UPDATE statement *)
   is_update: bool;
   insert_resolved_types: (string, Type.t) Hashtbl.t; (* for INSERT .. VALUES *)
+  is_subquery: bool;  (* whether we are inside a subquery *)
 }
 
 (* Merge global tables with ctes during resolving sources in SELECT .. FROM sources, JOIN *)
@@ -60,15 +62,21 @@ and case_branch = { when_: res_expr; then_: res_expr; } [@@deriving show]
 and res_fun = { kind: func ; parameters: res_expr list; is_over_clause: bool; } [@@deriving show]  
 
 and res_in_tuple_list = 
-  ResTyped of (Type.t * Meta.t) list | Res of (res_expr * Meta.t) list
+  ResTyped of (Type.t * Meta.t) list | Res of (res_expr * Meta.t) list [@@deriving show] 
+
+type 'a schema_column =
+  | Attr of 'a
+  | Dynamic of param_id * (param_id * 'a) list
+  [@@deriving show]
 
 let empty_env = { query_has_grouping = false; 
   tables = []; schema = []; 
   set_tyvar_strict = false; 
   ctes = [];
   is_order_by = false;
   is_update = false;
-  insert_resolved_types = Hashtbl.create 16
+  insert_resolved_types = Hashtbl.create 16;
+  is_subquery = false;
 }
 
 let flat_map f l = List.flatten (List.map f l)
@@ -408,9 +416,9 @@ let rec resolve_columns env expr =
       ResInTupleList {param_id; res_in_tuple_list = Res res_exprs; kind; pos }
     | Inparam (x, m) -> ResInparam (x, m)
     | InChoice (n, k, x) -> ResInChoice (n, k, each x)
-    | Choices (n,l) -> ResChoices (n, List.map (fun (n,e) -> n, Option.map each e) l)
+    | Choices (n, l) -> ResChoices (n, List.map (fun (n, e) -> n, Option.map each e) l)
     | Fun { kind; parameters; is_over_clause } ->
-      ResFun { kind; parameters = List.map each parameters; is_over_clause }  
+      ResFun { kind; parameters = List.map each parameters; is_over_clause }
     | Case { case; branches; else_ } ->
       let case = Option.map each case in
       let branches = List.map (fun { Sql.when_; then_ } -> { when_ = each when_; then_ = each then_ }) branches in
@@ -422,7 +430,12 @@ let rec resolve_columns env expr =
       end
     (* nested select *)
     | SelectExpr (select, usage) ->
-      let (schema,p,_) = eval_select_full env select in
+      let (schema, p, _) = eval_select_full { env with is_subquery = true } select in
+      let schema = List.map (function
+        | Attr a -> a
+        | Dynamic _ -> fail "nested select cannot have dynamic attributes"
+      ) schema
+      in
       let schema = Schema.Source.from_schema schema in
       (* represet nested selects as functions with sql parameters as function arguments, some hack *)
       match schema, usage with
@@ -754,20 +767,32 @@ and infer_schema ~not_null_keys env columns =
       col
   in
   let resolve1 = function
-    | All -> List.map refine_column env.schema
-    | AllOf t -> List.map refine_column (schema_of ~env t)
+    | All -> List.map (fun x -> Attr (refine_column x)) env.schema
+    | AllOf t -> List.map (fun x -> Attr (refine_column x)) (schema_of ~env t)
     | Expr (e,name) ->
+      let make_col expr =
+        let _, t = resolve_types env expr in
+        let col = {
+          Schema.Source.Attr.attr = unnamed_attribute ~meta:(propagate_meta ~env expr) (get_or_failwith t);
+          sources = []
+        } in 
+        let col = refine_column col in
+        Option.map_default (fun n -> {col with attr = { col.attr with name = n }}) col name
+      in
       let col =
         match e with
-        | Column col -> resolve_column ~env col
-        | e -> {
-          attr = unnamed_attribute ~meta:(propagate_meta ~env e) (resolve_types env e |> snd |> get_or_failwith);
-          sources = []
-        }
+        | Column col -> 
+          let col = resolve_column ~env col in
+          let col = refine_column col in
+          Attr (Option.map_default (fun n -> {col with attr = { col.attr with name = n }}) col name)
+        | Choices (p, choices) when not env.is_subquery && !Config.dynamic_select ->
+          let dynamic = choices |> List.filter_map (fun (choice_p, e_opt) -> 
+            Option.map (fun choice_e -> choice_p, make_col choice_e) e_opt
+          ) in 
+          Dynamic (p, dynamic)
+        | e -> Attr (make_col e)
       in
       (* Refine before applying alias, so we check against original column name *)
-      let col = refine_column col in
-      let col = Option.map_default (fun n -> {col with attr = { col.attr with name = n }}) col name in
       [ col ]
   in
   flat_map resolve1 columns
@@ -783,7 +808,11 @@ let _ =
 and get_params_of_columns env =
   let get = function
   | All | AllOf _ -> []
-  | Expr (e,_) -> get_params env e
+  | Expr (Choices (p, choices), _) when not env.is_subquery && !Config.dynamic_select ->
+    [DynamicSelect (p, List.map (fun (n, e) -> 
+      Simple (n, Option.map (fun e -> e |> resolve_types env |> fst |> get_params_of_res_expr env) e)
+    ) choices)]
+  | Expr (e, _) -> get_params env e
   in
   flat_map get
 
@@ -813,7 +842,7 @@ and params_of_assigns env ss =
   let exprs = resolve_column_assignments ~env ss in
   get_params_l env exprs
 
-and get_params_of_res_expr env (e:res_expr) =
+and get_params_of_res_expr env e =
   let rec loop acc e =
     match e with
     | ResSelect (_, p) -> (List.rev p) @ acc
@@ -834,7 +863,7 @@ and get_params_of_res_expr env (e:res_expr) =
     | ResInTupleList _
     | ResValue _ -> acc
     | ResInChoice (param, kind, e) -> ChoiceIn { param; kind; vars = get_params_of_res_expr env e } :: acc
-    | ResChoices (p,l) -> Choice (p, List.map (fun (n,e) -> Simple (n, Option.map (get_params_of_res_expr env) e)) l) :: acc
+    | ResChoices (p, l) -> Choice (p, List.map (fun (n, e) -> Simple (n, Option.map (get_params_of_res_expr env) e)) l) :: acc
   in
   loop [] e |> List.rev
 
@@ -972,10 +1001,14 @@ and eval_select env { columns; from; where; group; having; } =
   let not_null_keys_having = extract_not_null_column_keys env having in
   let not_null_keys = not_null_keys_where @ not_null_keys_having in
   let final_schema = infer_schema ~not_null_keys env columns in
+  let final_schema' = List.concat_map (function
+    | Attr attr -> [attr]
+    | Dynamic (_, l) -> List.map snd l
+  ) final_schema in
   (* use schema without aliases here *)
   let p1 = get_params_of_columns env columns in
-  let env, p3 = if Dialect.Semantic.is_where_aliases_dialect () then
-    let env = { env with schema = make_unique (Schema.Join.cross env.schema final_schema) } in
+  let env, p3 = if Dialect.Semantic.is_where_aliases_dialect () then 
+    let env = { env with schema = make_unique (Schema.Join.cross env.schema final_schema') } in
     env, get_params_opt { env with set_tyvar_strict = true; } where
   else
     let p3 = get_params_opt { env with set_tyvar_strict = true; 
@@ -984,7 +1017,7 @@ and eval_select env { columns; from; where; group; having; } =
     env, p3
   in
   (* ORDER BY, HAVING, GROUP BY allow have column without explicit referring to source if it's specified in SELECT *)
-  let env = { env with schema = update_schema_with_aliases env.schema final_schema } in
+  let env = { env with schema = update_schema_with_aliases env.schema final_schema' } in
   let satisfies_some_relevant_constraint table where env =
     let get_all_eql_checks expr = 
       let rec aux acc expr_list =
@@ -1070,15 +1103,24 @@ and resolve_source env (x, alias) =
   end in
   match x with
   | `Select select ->
-    let (s,p,_) = eval_select_full env select in
+    let (s,p,_) = eval_select_full { env with is_subquery = true } select in
     let tbl_alias = Option.map (fun { table_name; _ } -> table_name) alias in
+    let s = List.map (function
+      | Attr a -> a
+      | Dynamic _ -> failwith "nested select cannot have dynamic attributes"
+    ) s in
     let s = List.map (fun i -> { i with Schema.Source.Attr.sources = List.concat [option_list tbl_alias; i.Schema.Source.Attr.sources] }) s in
     let s, tables = resolve_schema_with_alias s in
     s, p, tables
   | `Nested from ->
     let (env,p) = eval_nested env (Some from) in
     let s = infer_schema ~not_null_keys:[] env [All] in
     if alias <> None then failwith "No alias allowed on nested tables";
+    let s = List.map (function 
+      | Attr attr -> attr
+       (* TODO: next step optimize it *)
+      | Dynamic _ -> failwith "Nested source cannot have dynamic columns"
+    ) s in
     s, p, env.tables
   | `Table s ->
     let (name,s) = Tables_with_derived.get ~env s in
@@ -1100,14 +1142,20 @@ and resolve_source env (x, alias) =
         let unions = List.map (fun exprs -> `Union, dummy_select exprs ) xs in
         let select = dummy_select exprs in
         let select_complete = { select = select, unions; order=row_order; limit=row_limit; } in
-        eval_select_full env { select_complete; cte = None }
+        let (s, p, v) = eval_select_full env { select_complete; cte = None } in 
+        let s = List.map (function 
+          | Attr attr -> attr 
+          | Dynamic _ -> failwith "VALUES cannot have dynamic columns"
+        ) s in
+        (s, p, v)
       | RowParam { id; types; values_start_pos } ->
-        List.map (fun t -> { attr = make_attribute' "" t; Schema.Source.Attr.sources = []}) 
-          types, [ TupleList (id, ValueRows { types; values_start_pos }) ], Stmt.Select `Nat
+        List.map (fun t -> { attr = make_attribute' "" t; Schema.Source.Attr.sources = []}) types, 
+          [ TupleList (id, ValueRows { types; values_start_pos }) ], Stmt.Select `Nat
     in
     let s, tables = resolve_schema_with_alias s in
     s, p, tables
 
+
 and eval_select_full env { select_complete; cte } =
   let ctes, p1 = Option.map_default eval_cte ([], []) cte in
   let env = { env with ctes = ctes @ env.ctes } in
@@ -1134,8 +1182,13 @@ and eval_cte { cte_items; is_recursive } =
           in
           let stmt = { stmt_ with select = select, other } in
           let s1, p1, env, cardinality = eval_select env (fst stmt.select) in
+          let s1' = List.map (function 
+            | Attr attr -> attr
+            (* TODO: next step is to support it for CTEs *)
+            | Dynamic _ -> failwith "Recursive CTEs cannot have dynamic columns"
+          ) s1 in
           (* UNIONed fields access by alias to itself cte *)
-          let s2 = Schema.compound (Option.map_default a1 s1 cte.cols) s1 in
+          let s2 = Schema.compound (Option.map_default a1 s1' cte.cols) s1' in
           let a2 = from_schema s2 in
           eval_compound ~env:{ env with ctes = (tbl_name, a2) :: env.ctes } (p1, s1, cardinality, stmt) 
         | CteSharedQuery _ -> failwith "Recursive CTEs with shared query currently are not supported"
@@ -1150,20 +1203,42 @@ and eval_cte { cte_items; is_recursive } =
           let s1, p1, kind = eval_select_full env stmt in
           s1, [SharedVarsGroup (p1, shared_query_name)], kind
       )
-    in  
+    in
+    let s1 = List.map (function 
+      | Attr attr -> attr
+        (* TODO: next step is to support it for CTEs *)
+      | Dynamic _ -> failwith "Recursive CTEs cannot have dynamic columns"
+    ) s1 in
     let s2 = Schema.compound (Option.map_default a1 s1 cte.cols) s1 in
     (tbl_name, from_schema s2) :: acc_ctes, acc_vars @ p1 end
   ([], []) cte_items  
 
-and eval_compound ~env result = 
+and eval_compound ~env result =
   let (p1, s1, cardinality, stmt) = result in
   let { select=(_select, other); order; limit; _; } = stmt in
   let other = List.map snd other in
   let (s2l, p2l) = List.split (List.map (fun (s,p,_,_) -> s,p) @@ List.map (eval_select env) other) in
   let cardinality = if other = [] then cardinality else `Nat in
   (* ignoring tables in compound statements - they cannot be used in ORDER BY *)
-  let final_schema = List.fold_left Schema.compound s1 s2l in
-  let p3 = params_of_order order final_schema env in
+  let final_schema = 
+    if other = [] then s1
+    else (
+      (* TODO: next step is to support it for UNIONS (but if it's possible to control it) *)
+      let unwrap_attr = function 
+        | Attr attr -> attr
+        | Dynamic _ -> failwith "Union/Except/Intersect doesn't support dynamic columns"
+      in
+      let s1' = List.map unwrap_attr s1 in
+      let s2l' = List.map (List.map unwrap_attr) s2l in
+      List.map (fun x -> Attr x) @@ List.fold_left Schema.compound s1' s2l'
+    )
+  in
+  let p3 = 
+    let schema = List.concat_map (function 
+      | Attr attr -> [attr]
+      | Dynamic (_, a) -> List.map snd a
+    ) final_schema in
+    params_of_order order schema env in
   let (p4,limit1) = match limit with Some (p,x) -> List.map (fun p -> Single (p, Meta.empty())) p, x | None -> [],false in
   (* Schema.check_unique schema; *)
   let cardinality =
@@ -1294,6 +1369,10 @@ let rec eval (stmt:Sql.stmt) =
       ([],[],Create name)
   | Create (name,`Select select) ->
       let (schema,params,_) = eval_select_full empty_env select in
+      let schema = List.map (function 
+        | Attr attr -> attr 
+        | Dynamic _ -> failwith "CREATE TABLE AS SELECT cannot have dynamic columns"
+      ) schema in
       Tables.add (name, from_schema schema);
       ([],params,Create name)
   | Alter (name,actions) ->
@@ -1396,6 +1475,10 @@ let rec eval (stmt:Sql.stmt) =
     let select_complete = annotate_select select.select_complete expect in
     let select = { select with select_complete } in
     let (schema,params,_) = eval_select_full env select in
+    let schema = List.map (function 
+      | Attr attr -> attr 
+      | Dynamic _ -> failwith "INSERT ... SELECT cannot have dynamic columns"
+    ) schema in
     ignore (Schema.compound
       ((List.map (fun attr -> {sources=[]; attr;})) expect)
       (List.map (fun {attr; _} -> {sources=[]; attr}) schema)); (* test equal types once more (not really needed) *)
@@ -1455,7 +1538,11 @@ let rec eval (stmt:Sql.stmt) =
     [], params @ p3 @ (List.map (fun p -> Single (p, Meta.empty())) lim), Update None
   | Select select -> 
     let (schema, a, b) = eval_select_full empty_env select in
-    from_schema schema , a ,b
+    let schema = List.map (function 
+      | Attr attr -> Attr attr.attr
+      | Dynamic (p, l) -> Dynamic (p, List.map (fun (p, attr) -> p, attr.attr) l)
+    ) schema in
+    schema, a ,b
   | CreateRoutine (name,_,_) ->
     [], [], CreateRoutine name
 
@@ -1489,7 +1576,7 @@ let unify_params l =
   | SharedVarsGroup (vars, _)
   | ChoiceIn { vars; _ } -> List.iter traverse vars
   | OptionActionChoice (_, l, _, _) -> List.iter traverse l
-  | Choice (p,l) -> check_choice_name ~sharing_disabled:true p; List.iter (function Simple (_,l) -> Option.may (List.iter traverse) l | Verbatim _ -> ()) l
+  | Choice (p,l) | DynamicSelect (p, l) -> check_choice_name ~sharing_disabled:true p; List.iter (function Simple (_,l) -> Option.may (List.iter traverse) l | Verbatim _ -> ()) l
   | TupleList _ -> ()
   in
   let rec map = function
@@ -1503,6 +1590,7 @@ let unify_params l =
   | SharedVarsGroup (vars, pos) -> SharedVarsGroup (List.map map vars, pos)
   | OptionActionChoice (p, l, pos, kind) -> OptionActionChoice (p, (List.map map l), pos, kind)
   | Choice (p, l) -> Choice (p, List.map (function Simple (n,l) -> Simple (n, Option.map (List.map map) l) | Verbatim _ as v -> v) l)
+  | DynamicSelect (p, l) -> DynamicSelect (p, List.map (function Simple (n,l) -> Simple (n, Option.map (List.map map) l) | Verbatim _ as v -> v) l)
   | TupleList _ as x -> x
   in
   List.iter traverse l;

lib/syntax.mli

@@ -1,9 +1,15 @@
+open Sql
 
 module Config: sig
   val debug : bool ref
   val allow_write_notnull_null : bool ref
+  val dynamic_select : bool ref
 end
 
-val parse : string -> string * Sql.Schema.t * Sql.var list * Stmt.kind * Dialect.dialect_support list
+type 'a schema_column =
+  | Attr of 'a
+  | Dynamic of param_id * (param_id * 'a) list
+  [@@deriving show]
 
-val eval_select: Sql.select_full -> Sql.Schema.t * Sql.vars * Stmt.kind
+val parse : string -> string * attr schema_column list * var list * Stmt.kind * Dialect.dialect_support list
+val eval_select: select_full -> attr schema_column list * var list * Stmt.kind