From 93fff347385ee55f1dde44a6f1882ac7eae2059f Mon Sep 17 00:00:00 2001 From: Gleb Patsiia Date: Tue, 20 Jan 2026 10:13:25 +0000 Subject: [PATCH 1/2] implement dynamic select feature --- impl/ocaml/sqlgg_traits.ml | 16 + lib/sql.ml | 4 +- lib/syntax.ml | 151 ++++- lib/syntax.mli | 10 +- src/gen.ml | 50 +- src/gen_caml.ml | 454 ++++++++++++-- src/gen_csharp.ml | 19 +- src/gen_cxx.ml | 5 +- src/gen_java.ml | 10 +- src/gen_xml.ml | 13 +- src/main.ml | 10 +- src/test.ml | 45 +- test/cram/dune | 1 + test/cram/dynamic_select.t | 206 +++++++ test/cram/test.t | 572 ++++++++++++++++++ .../dynamic_select.sql | 54 ++ .../test_build_dynamic_select/product_id.ml | 5 + .../test_build_dynamic_select/test_run.ml | 398 ++++++++++++ 18 files changed, 1894 insertions(+), 129 deletions(-) create mode 100644 test/cram/dynamic_select.t create mode 100644 test/cram/test_build_dynamic_select/dynamic_select.sql create mode 100644 test/cram/test_build_dynamic_select/product_id.ml create mode 100644 test/cram/test_build_dynamic_select/test_run.ml diff --git a/impl/ocaml/sqlgg_traits.ml b/impl/ocaml/sqlgg_traits.ml index 31bf1336..7b2c4439 100644 --- a/impl/ocaml/sqlgg_traits.ml +++ b/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 diff --git a/lib/sql.ml b/lib/sql.ml index f85be226..de802561 100644 --- a/lib/sql.ml +++ b/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] diff --git a/lib/syntax.ml b/lib/syntax.ml index 6f5da39b..ce02704a 100644 --- a/lib/syntax.ml +++ b/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,7 +62,12 @@ 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 = []; @@ -68,7 +75,8 @@ let empty_env = { query_has_grouping = 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,12 @@ 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 -> + (* For DynamicSelect, get params from each branch separately *) + [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 +843,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 +864,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 +1002,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 +1018,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,8 +1104,12 @@ 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 @@ -1079,6 +1117,11 @@ and resolve_source env (x, alias) = 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 +1143,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 +1183,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 +1204,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 +1370,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 +1476,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 +1539,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 +1577,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 +1591,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; diff --git a/lib/syntax.mli b/lib/syntax.mli index 634e9b34..d599b46f 100644 --- a/lib/syntax.mli +++ b/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 diff --git a/src/gen.ml b/src/gen.ml index 5b157b96..ab421edf 100644 --- a/src/gen.ml +++ b/src/gen.ml @@ -8,7 +8,7 @@ open Stmt type subst_mode = | Named | Unnamed | Oracle | PostgreSQL -type stmt = { schema : Sql.Schema.t; vars : Sql.var list; kind : kind; props : Props.t; } +type stmt = { schema : Sql.attr Syntax.schema_column list; vars : Sql.var list; kind : kind; props : Props.t; } (** defines substitution function for parameter literals *) let params_mode = ref None @@ -117,23 +117,7 @@ let substitute_vars s vars subst_param = in loop s acc i2 parami tl | Choice (name,ctors) :: tl -> - let dyn = ctors |> List.map begin function - | Sql.Simple (ctor,args) -> - let (c1,c2) = ctor.pos in - assert ((c2 = 0 && c1 = 1) || c2 > c1); - assert (c1 > i); - let sql = - match args with - | None -> [Static ""] - | Some l -> - let (acc,last) = loop s [] c1 0 l in - List.rev (Static (String.slice ~first:last ~last:c2 s) :: acc) - in - { ctor; sql; args; is_poly=true } - | Verbatim (n,v) -> - { ctor = { label = Some n; pos = (0,0) }; args=Some []; sql=[Static v]; is_poly=true } - end - in + let dyn = process_ctors ~is_poly:true s i ctors in let (i1,i2) = name.pos in assert (i2 > i1); assert (i1 > i); @@ -188,6 +172,30 @@ let substitute_vars s vars subst_param = let raw_processed = loop_and_squash shared_sql shared_vars in let processed_shared = [Static "("] @ raw_processed @ [Static ")"] in loop s (List.rev processed_shared @ Static (String.slice ~first:i ~last:i1 s) :: acc) i2 parami tl + | DynamicSelect (name,ctors) :: tl -> + let dyn = process_ctors ~is_poly:false s i ctors in + let (i1,i2) = name.pos in + assert (i2 > i1); + assert (i1 > i); + let acc = Dynamic (name, dyn) :: Static (String.slice ~first:i ~last:i1 s) :: acc in + loop s acc i2 parami tl + and process_ctors ~is_poly s i ctors = + ctors |> List.map begin function + | Sql.Simple (ctor, args) -> + let (c1, c2) = ctor.pos in + assert ((c2 = 0 && c1 = 1) || c2 > c1); + assert (c1 > i); + let sql = + match args with + | None -> [Static ""] + | Some l -> + let (acc, last) = loop s [] c1 0 l in + List.rev (Static (String.slice ~first:last ~last:c2 s) :: acc) + in + { ctor; sql; args; is_poly } + | Verbatim (n, v) -> + { ctor = { label = Some n; pos = (0,0) }; args = Some []; sql = [Static v]; is_poly } + end and loop_and_squash sql vars = let acc, last = loop sql [] 0 0 vars in let acc = List.rev (Static (String.slice ~first:last sql) :: acc) in @@ -266,7 +274,8 @@ let rec find_param_ids l = | OptionActionChoice (id, _, _, _) -> [id] | ChoiceIn { param; vars; _ } -> find_param_ids vars @ [param] | SharedVarsGroup (vars, _) -> find_param_ids vars - | TupleList (id, _) -> [ id ]) + | TupleList (id, _) -> [ id ] + | DynamicSelect (id, _) -> [ id ]) l let names_of_vars l = @@ -284,7 +293,8 @@ let rec params_only l = | ChoiceIn { vars; _ } -> params_only vars | OptionActionChoice _ | Choice _ -> fail "dynamic choices not supported for this host language" - | TupleList _ -> []) + | TupleList _ -> [] + | DynamicSelect _ -> fail "dynamic selects not supported for this host language (params_only)") l let rec inparams_only l = diff --git a/src/gen_caml.ml b/src/gen_caml.ml index 6ebddf0b..cead456e 100644 --- a/src/gen_caml.ml +++ b/src/gen_caml.ml @@ -127,6 +127,26 @@ let enum_name = Printf.sprintf "Enum_%d" let get_enum_name ctors = ctors |> enum_get_hash |> Hashtbl.find enums_hash_tbl |> fst |> enum_name +(* DynamicSelect support *) + +let field_name_of_param_id (p : Sql.param_id) = + match p.label with Some s -> String.capitalize_ascii s | None -> "Field" + +(* Generate pattern for match case on ctor *) +let ctor_pattern = function + | Sql.Simple (param_id, args) -> + let field_name = field_name_of_param_id param_id in + (match args with Some (_ :: _) -> field_name ^ " _" | _ -> field_name) + | Sql.Verbatim (n, _) -> String.capitalize_ascii n + +type dynamic_info = { + param_id: Sql.param_id; + module_name: string; + param_name: string; + ctors: Sql.ctor list; + schema_fields: (Sql.param_id * Sql.attr) list; +} + module L = struct open Type @@ -168,40 +188,49 @@ module L = struct let as_api_type = as_lang_type end -let get_column index attr = - let nullable_suffix = if is_attr_nullable attr then "_nullable" else "" in +let nullable_suffix attr = if is_attr_nullable attr then "_nullable" else "" + +(* Format T.get_column call with given row variable and index expression *) +let format_get_column ~row ~idx attr = + let null_suffix = nullable_suffix attr in let format_t_get_column type_name = - sprintf "(T.get_column_%s%s stmt %u)" type_name nullable_suffix index + sprintf "T.get_column_%s%s %s %s" type_name null_suffix row idx in - let format_column_expr attr = - match Sql.Meta.find_opt attr.meta "module" with - | Some m -> - let runtime_repr_name = L.as_runtime_repr_name attr.domain in - let inner_get_column_expr = format_t_get_column runtime_repr_name in - let get_column = "get_column" in - let get_column_name = get_column |> Sql.Meta.find_opt attr.meta |> Option.default get_column in - sprintf "(%s.%s%s %s)" m get_column_name nullable_suffix inner_get_column_expr - | None -> - begin match attr.domain with - | { t = Union { ctors; _ }; _ } -> - sprintf "(%s.get_column%s stmt %u)" (get_enum_name ctors) nullable_suffix index - | _ -> - let lang_type_name = L.as_lang_type attr.domain in - format_t_get_column lang_type_name - end - in - format_column_expr attr + match Sql.Meta.find_opt attr.meta "module" with + | Some m -> + let runtime_repr_name = L.as_runtime_repr_name attr.domain in + let inner_get_column_expr = sprintf "(T.get_column_%s%s %s %s)" runtime_repr_name null_suffix row idx in + let get_column = "get_column" in + let get_column_name = get_column |> Sql.Meta.find_opt attr.meta |> Option.default get_column in + sprintf "%s.%s%s %s" m get_column_name null_suffix inner_get_column_expr + | None -> + begin match attr.domain with + | { t = Union { ctors; _ }; _ } -> + sprintf "%s.get_column%s %s %s" (get_enum_name ctors) null_suffix row idx + | _ -> + format_t_get_column (L.as_lang_type attr.domain) + end + +let get_column index attr = + sprintf "(%s)" (format_get_column ~row:"stmt" ~idx:(string_of_int index) attr) module T = Translate(L) (* open L *) open T +let schema_to_attrs schema = + List.filter_map (function + | Syntax.Attr attr -> Some attr + | Syntax.Dynamic _ -> None + ) schema + let output_schema_binder_labeled _ schema = + let attrs = schema_to_attrs schema in let name = "invoke_callback" in output "let %s stmt =" name; - let args = Name.idents ~prefix:"r" (List.map (fun a -> a.name) schema) in - let values = List.mapi get_column schema in + let args = Name.idents ~prefix:"r" (List.map (fun a -> a.Sql.name) attrs) in + let values = List.mapi get_column attrs in indented (fun () -> output "callback"; indented (fun () -> List.iter2 (output "~%s:%s") args values)); @@ -209,10 +238,11 @@ let output_schema_binder_labeled _ schema = name let output_select1_cb _ schema = + let attrs = schema_to_attrs schema in let name = "get_row" in output "let %s stmt =" name; indented (fun () -> - List.mapi get_column schema |> String.concat ", " |> indent_endline); + List.mapi get_column attrs |> String.concat ", " |> indent_endline); output "in"; name @@ -236,12 +266,11 @@ let is_callback stmt = | _, Stmt.Select (`Zero_one | `One) -> false | _ -> true -let list_separate f l = - let a = ref [] in - let b = ref [] in - List.iter (fun x -> match f x with `Left x -> tuck a x | `Right x -> tuck b x) l; - List.rev !a, List.rev !b - +let should_generate_for_style style stmt = + match style with + | `List | `Fold -> is_callback stmt + | `Single -> (match stmt.kind, stmt.schema with | Stmt.Select (`One | `Zero_one), _ :: _ -> true | _ -> false) + | `Direct -> true let make_variant_name i name ~is_poly = let prefix = if is_poly then "`" else "" in @@ -272,11 +301,14 @@ let match_variant_pattern i name args ~is_poly = ((seen_wildcards, seen_names, all_wc), Some "_") | TupleList ({ label = Some s; _ }, _) | Choice ({ label = Some s; _ }, _) + | DynamicSelect ({ label = Some s; _ }, _) | OptionActionChoice ({ label = Some s; _ }, _, _, _) | ChoiceIn { param = { label = Some s; _ }; _ } -> if List.mem s seen_names then ((seen_wildcards, seen_names, false), None) else ((seen_wildcards, s :: seen_names, false), Some s) + | DynamicSelect ({ label = None; _ }, _) -> + ((seen_wildcards, seen_names, all_wc), Some "_") ) ([], [], true) arg_list in let patterns = List.filter_map identity patterns in @@ -359,7 +391,7 @@ let set_var index var = | Some name -> Hashtbl.add seen name (); true | None -> true) | ChoiceIn _ | OptionActionChoice _ - | SharedVarsGroup _ | Choice _ -> true + | SharedVarsGroup _ | Choice _ | DynamicSelect _ -> true in if use_var then let pattern = match aux index var with @@ -433,6 +465,9 @@ let set_var index var = execute_generators all_generators; output "end;" ) + | DynamicSelect _ -> + (* DynamicSelect params are handled separately in generate_stmt_with_dynamic *) + None in Option.may (fun g -> g ()) (aux index var) @@ -446,6 +481,7 @@ let rec eval_count_params vars = | SharedVarsGroup (vars, _) -> `SharedVarsGroup vars | OptionActionChoice (param_id, vars, _, _) -> `OptionActionChoice (param_id, vars) | Choice (name, c) -> `Choice (name, c) + | DynamicSelect _ -> `Static false (* handled separately in generate_stmt_with_dynamic *) in let rec group_vars (static, choices, bool_choices, choices_in) = function | [] -> (List.rev static, List.rev choices, List.rev bool_choices, List.rev choices_in) @@ -523,7 +559,9 @@ let rec exclude_in_vars l = | TupleList _ -> None | ChoiceIn t -> Some (ChoiceIn { t with vars = exclude_in_vars t.vars }) | Choice (param_id, ctors) -> - Some (Choice (param_id, List.map exclude_in_vars_in_constructors ctors))) + Some (Choice (param_id, List.map exclude_in_vars_in_constructors ctors)) + | DynamicSelect (param_id, ctors) -> + Some (DynamicSelect (param_id, List.map exclude_in_vars_in_constructors ctors))) l and exclude_in_vars_in_constructors = function @@ -649,17 +687,263 @@ let make_sql l = Buffer.add_string b ")"; Buffer.contents b -let generate_stmt style index stmt = +(* Generate stmt with multiple dynamic selects *) +let generate_stmt_with_dynamic style index stmt dynamic_infos = + if not (should_generate_for_style style stmt) then () else let name = choose_name stmt.props stmt.kind index |> String.uncapitalize_ascii in let subst = Props.get_all stmt.props "subst" in let inputs = (subst @ names_of_vars stmt.vars) |> List.map (fun v -> sprintf "~%s" v) |> inline_values in - let should_generate = + let needs_callback_param = match style with + | `List | `Fold -> true + | `Single -> is_callback stmt + | `Direct -> is_callback stmt + in + let needs_acc_param = style = `Fold in + let all_inputs = inputs ^ (if needs_callback_param then " callback" else "") ^ (if needs_acc_param then " acc" else "") in + + output "let %s db %s =" name all_inputs; + inc_indent (); + + let sql_pieces = get_sql stmt in + + (* Generate helpers for each dynamic select *) + List.iter (fun di -> + output "let rec params_count_%s : type a. a %s.t -> int = function" di.param_name di.module_name; + inc_indent (); + List.iter (fun ctor -> + match ctor with + | Sql.Simple (param_id, args) -> + let field_name = field_name_of_param_id param_id in + let arg_count = match args with Some l -> List.length l | None -> 0 in + if arg_count = 0 then + output "| %s.V %s -> 0" di.module_name field_name + else + output "| %s.V (%s _) -> %d" di.module_name field_name arg_count + | Sql.Verbatim (n, _) -> + output "| %s.V %s -> 0" di.module_name (String.capitalize_ascii n) + ) di.ctors; + output "| Return _ -> 0"; + output "| Map (t, _) -> params_count_%s t" di.param_name; + output "| Both (a, b) -> params_count_%s a + params_count_%s b" di.param_name di.param_name; + dec_indent (); + output "in"; + + output "let field_set_%s : type a. a %s.field -> T.params -> unit = function" di.param_name di.module_name; + inc_indent (); + List.iter (fun ctor -> + match ctor with + | Sql.Simple (param_id, args) -> + let field_name = field_name_of_param_id param_id in + let param_types = Option.default [] args |> List.filter_map (function Sql.Single (p, _) -> Some p.typ | _ -> None) in + begin match param_types with + | [] -> + output "| %s -> fun _p -> ()" field_name + | [t] -> + output "| %s x -> fun p -> T.set_param_%s p x" field_name (L.as_lang_type t) + | types -> + let vars = List.mapi (fun i _ -> sprintf "x%d" i) types in + let pattern = sprintf "(%s)" (String.concat ", " vars) in + let sets = List.map2 (fun v t -> sprintf "T.set_param_%s p %s" (L.as_lang_type t) v) vars types in + output "| %s %s -> fun p -> %s" field_name pattern (String.concat "; " sets) + end + | Sql.Verbatim (n, _) -> + output "| %s -> fun _p -> ()" (String.capitalize_ascii n) + ) di.ctors; + dec_indent (); + output "in"; + + output "let rec set_%s : type a. a %s.t -> T.params -> unit = function" di.param_name di.module_name; + inc_indent (); + output "| %s.V f -> fun p -> field_set_%s f p" di.module_name di.param_name; + output "| Return _ -> fun _p -> ()"; + output "| Map (t, _) -> fun p -> set_%s t p" di.param_name; + output "| Both (a, b) -> fun p -> set_%s a p; set_%s b p" di.param_name di.param_name; + dec_indent (); + output "in"; + + output "let field_to_column_%s : type a. a %s.field -> string = function" di.param_name di.module_name; + inc_indent (); + let field_sqls = List.find_map (function + | Gen.Dynamic (pid, ctors) when pid = di.param_id -> + Some (List.map (fun c -> c.Gen.ctor, c.Gen.sql) ctors) + | _ -> None + ) sql_pieces |> Option.default [] in + List.iter2 (fun ctor (_, sql) -> + let body = match ctor with Sql.Verbatim (_, v) -> quote v | _ -> make_sql sql in + output "| %s -> %s" (ctor_pattern ctor) body + ) di.ctors field_sqls; + dec_indent (); + output "in"; + + output "let rec to_a_field_list_%s : type a. a %s.t -> %s.a_field list = function" di.param_name di.module_name di.module_name; + inc_indent (); + output "| %s.V f -> [Any_field f]" di.module_name; + output "| Return _ -> []"; + output "| Map (t, _) -> to_a_field_list_%s t" di.param_name; + output "| Both (a, b) -> to_a_field_list_%s a @ to_a_field_list_%s b" di.param_name di.param_name; + dec_indent (); + output "in"; + + output "let field_read_%s : type a. a %s.field -> T.row -> int -> a = function" di.param_name di.module_name; + inc_indent (); + List.iter2 (fun ctor (_, attr) -> + output "| %s -> fun row idx -> %s" (ctor_pattern ctor) (format_get_column ~row:"row" ~idx:"idx" attr) + ) di.ctors di.schema_fields; + dec_indent (); + output "in"; + + output "let rec read_%s : type a. a %s.t -> T.row -> int -> a * int = function" di.param_name di.module_name; + inc_indent (); + output "| %s.V f -> fun row idx -> (field_read_%s f row idx, idx + 1)" di.module_name di.param_name; + output "| Return x -> fun _row idx -> (x, idx)"; + output "| Map (t, f) -> fun row idx -> let (v, idx') = read_%s t row idx in (f v, idx')" di.param_name; + output "| Both (a, b) -> fun row idx -> let (va, i1) = read_%s a row idx in let (vb, i2) = read_%s b row i1 in ((va, vb), i2)" di.param_name di.param_name; + dec_indent (); + output "in" + ) dynamic_infos; + + (* Generate set_params *) + let other_vars = List.filter (function Sql.DynamicSelect _ -> false | _ -> true) stmt.vars in + let static_count = eval_count_params other_vars in + let dynamic_counts = dynamic_infos |> List.map (fun di -> + sprintf "params_count_%s %s" di.param_name di.param_name + ) |> String.concat " + " in + + output "let set_params stmt ="; + inc_indent (); + output "let p = T.start_params stmt (%s + %s) in" static_count dynamic_counts; + List.iter (fun di -> + output "set_%s %s p;" di.param_name di.param_name + ) dynamic_infos; + List.iteri set_var other_vars; + output "T.finish_params p"; + dec_indent (); + output "in"; + + let find_di_by_pid pid = List.find (fun di -> di.param_id = pid) dynamic_infos in + + let rec build_parts acc pending_comma = function + | [] -> List.rev acc + | Gen.Static s :: rest -> + let s_trimmed = String.trim s in + let ends_with_comma = String.length s_trimmed > 0 && s_trimmed.[String.length s_trimmed - 1] = ',' in + if ends_with_comma then + let s_no_comma = String.sub s_trimmed 0 (String.length s_trimmed - 1) in + build_parts (if s_no_comma = "" then acc else quote s_no_comma :: acc) true rest + else + build_parts (quote s :: acc) false rest + | Gen.Dynamic (pid, _) :: rest -> + let di = find_di_by_pid pid in + let fields_expr = sprintf "(%s |> to_a_field_list_%s |> List.map (fun (%s.Any_field f) -> field_to_column_%s f))" + di.param_name di.param_name di.module_name di.param_name in + let dyn_expr = + if pending_comma then + sprintf "(match %s with [] -> \"\" | l -> \", \" ^ String.concat \", \" l)" fields_expr + else + sprintf "(String.concat \", \" %s)" fields_expr + in + build_parts (dyn_expr :: acc) false rest + | _ :: rest -> build_parts acc pending_comma rest + in + let sql_parts = build_parts [] false sql_pieces in + let sql_expr = String.concat " ^ " sql_parts in + + if style = `Fold then output "let r_acc = ref acc in"; + if style = `List then output "let r_acc = ref [] in"; + + let func = select_func_of_kind stmt.kind in + + (* Split schema into segments by Dynamic *) + let rec split_schema_multi acc current = function + | [] -> List.rev ((List.rev current, None) :: acc) + | Syntax.Dynamic (pid, _) :: rest -> + let di = find_di_by_pid pid in + split_schema_multi (((List.rev current), Some di.param_name) :: acc) [] rest + | Syntax.Attr a :: rest -> + split_schema_multi acc (a :: current) rest + in + let schema_segments = split_schema_multi [] [] stmt.schema in + + (* Build callback body with chained reads *) + (* For Fold/List styles, we always need callback pattern. For Direct/Single, check is_callback *) + let needs_callback = match style with + | `Fold | `List -> true + | `Direct | `Single -> is_callback stmt + in + let build_callback_body () = + let buf = Buffer.create 256 in + let static_idx = ref 0 in + let current_idx_expr = ref None in (* None means use static_idx, Some s means use that expression *) + let reads = ref [] in + let attr_counter = ref 0 in + + List.iter (fun (attrs, dyn_opt) -> + (* Read static attrs in this segment *) + List.iteri (fun i attr -> + let col_idx_expr = match !current_idx_expr with + | None -> string_of_int !static_idx + | Some base_var -> + if i = 0 then base_var + else sprintf "(%s + %d)" base_var i + in + let value_expr = sprintf "(%s)" (format_get_column ~row:"row" ~idx:col_idx_expr attr) in + if needs_callback then + reads := sprintf "~%s:%s" (name_of attr !attr_counter) value_expr :: !reads + else + reads := value_expr :: !reads; + incr static_idx; + incr attr_counter + ) attrs; + + (* Read dynamic part if present *) + match dyn_opt with + | Some param_name -> + let read_var = sprintf "__sqlgg_r_%s" param_name in + let next_idx_var = sprintf "__sqlgg_idx_after_%s" param_name in + let start_idx = match !current_idx_expr with + | None -> string_of_int !static_idx + | Some base_var -> sprintf "(%s + %d)" base_var (List.length attrs) + in + Buffer.add_string buf (sprintf "let (%s, %s) = read_%s %s row %s in " + read_var next_idx_var param_name param_name start_idx); + if needs_callback then + reads := sprintf "~%s:%s" param_name read_var :: !reads + else + reads := read_var :: !reads; + current_idx_expr := Some next_idx_var + | None -> () + ) schema_segments; + + let params = List.rev !reads in + if needs_callback then + Buffer.add_string buf (sprintf "callback\n %s" (String.concat "\n " params)) + else + Buffer.add_string buf (sprintf "(%s)" (String.concat ", " params)); + Buffer.contents buf + in + + let callback_body = build_callback_body () in + + let (bind_start, bind_end, full_callback) = match style with - | `List | `Fold -> is_callback stmt - | `Single -> (match stmt.kind, stmt.schema with | Stmt.Select (`One | `Zero_one), _ :: _ -> true | _ -> false) - | `Direct -> true + | `Fold -> "IO.(>>=) (", ")", sprintf "(fun row -> r_acc := (%s !r_acc))" callback_body + | `List -> "IO.(>>=) (", ")", sprintf "(fun row -> r_acc := (%s) :: !r_acc)" callback_body + | `Direct | `Single -> "", "", sprintf "(fun row -> %s)" callback_body in - if should_generate then begin + + output "%sT.%s db" bind_start func; + output " (%s)" sql_expr; + output " set_params %s%s" full_callback bind_end; + if style = `Fold then output "(fun () -> IO.return !r_acc)"; + if style = `List then output "(fun () -> IO.return (List.rev !r_acc))"; + dec_indent (); + empty_line () + +let generate_stmt style index stmt = + let name = choose_name stmt.props stmt.kind index |> String.uncapitalize_ascii in + let subst = Props.get_all stmt.props "subst" in + let inputs = (subst @ names_of_vars stmt.vars) |> List.map (fun v -> sprintf "~%s" v) |> inline_values in + if should_generate_for_style style stmt then begin let needs_callback_param = match style with | `List | `Single -> true | _ -> is_callback stmt in let needs_acc_param = style = `Fold in let all_inputs = inputs ^ (if needs_callback_param then " callback" else "") ^ (if needs_acc_param then " acc" else "") in @@ -750,10 +1034,21 @@ let generate_enum_modules stmts = let meta_has_module m = Sql.Meta.mem m "module" in let schemas_to_enums schemas = - List.filter_map (fun { domain; meta; _ } -> + List.filter_map (fun ({ domain; meta; _ } : Sql.attr) -> if meta_has_module meta then None else get_enum domain ) schemas in + + let schema_columns_to_enums schema_cols = + List.concat_map (function + | Syntax.Attr attr -> + if meta_has_module attr.meta then [] else get_enum attr.domain |> option_list + | Syntax.Dynamic (_, fields) -> + List.concat_map (fun (_, attr) -> + if meta_has_module attr.meta then [] else get_enum attr.domain |> option_list + ) fields + ) schema_cols + in let rec vars_to_enums vars = let enum_opt typ = typ |> get_enum |> option_list in @@ -764,7 +1059,8 @@ let generate_enum_modules stmts = | SharedVarsGroup (vars, _) | OptionActionChoice (_, vars, _, _) | ChoiceIn { vars; _ } -> vars_to_enums vars - | Choice (_, ctor_list) -> + | Choice (_, ctor_list) + | DynamicSelect (_, ctor_list) -> List.concat_map ( function | Simple (_, vars) -> Option.map vars_to_enums vars |> option_list |> List.concat | Verbatim _ -> [] @@ -797,7 +1093,7 @@ let generate_enum_modules stmts = in indented (fun () -> - let result = schemas_to_enums schemas @ vars_to_enums vars in + let result = schema_columns_to_enums schemas @ vars_to_enums vars in let (_: int * unit list) = List.fold_left_map begin fun acc enum -> let hash = enum_get_hash enum in if Hashtbl.mem enums_hash_tbl hash then acc, () @@ -809,6 +1105,77 @@ let generate_enum_modules stmts = () ) +(* Extract all DynamicSelect infos from stmt *) +let get_all_dynamic_select_infos index stmt = + let query_name = Gen.choose_name stmt.Gen.props stmt.Gen.kind index in + let ds_from_vars = stmt.Gen.vars |> List.filter_map (function Sql.DynamicSelect (param_id, ctors) -> Some (param_id, ctors) | _ -> None) in + let ds_from_schema = stmt.Gen.schema |> List.filter_map (function Syntax.Dynamic (param_id, fields) -> Some (param_id, fields) | _ -> None) in + List.mapi (fun i ((param_id, ctors), (_, schema_fields)) -> + let param_name = Gen.make_param_name i param_id in + let module_name = sprintf "%s_%s" (String.capitalize_ascii query_name) param_name in + { param_id; module_name; param_name; ctors; schema_fields } + ) (List.combine ds_from_vars ds_from_schema) + +(* Generate DynamicSelect GADT modules for all stmts that need them *) +let generate_dynamic_select_modules stmts = + List.iteri (fun index stmt -> + get_all_dynamic_select_infos index stmt |> List.iter (fun di -> + let module_name = di.module_name in + let fields = List.map2 (fun ctor (_field_param_id, attr) -> + match ctor with + | Sql.Simple (ctor_param_id, args) -> + let param_types = Option.default [] args |> List.filter_map (function Sql.Single (p, _) -> Some p.typ | _ -> None) in + let param_name = match ctor_param_id.Sql.label with Some s -> String.lowercase_ascii s | None -> "v" in + (field_name_of_param_id ctor_param_id, param_name, param_types, attr) + | Sql.Verbatim (name, _) -> + (String.capitalize_ascii name, String.lowercase_ascii name, [], attr) + ) di.ctors di.schema_fields in + + output "module %s = struct" module_name; + inc_indent (); + + output "type _ field ="; + inc_indent (); + List.iter (fun (field_name, _param_name, param_types, attr) -> + let result_type = attr.Sql.domain in + let result_type_str = L.as_lang_type result_type in + let is_nullable = result_type.Sql.Type.nullability = Sql.Type.Nullable in + let result_full = match Sql.Meta.find_opt attr.Sql.meta "module" with + | Some m -> if is_nullable then sprintf "%s.t option" m else sprintf "%s.t" m + | None -> if is_nullable then sprintf "T.Types.%s.t option" result_type_str else sprintf "T.Types.%s.t" result_type_str + in + match param_types with + | [] -> output "| %s : %s field" field_name result_full + | [t] -> output "| %s : T.Types.%s.t -> %s field" field_name (L.as_lang_type t) result_full + | types -> + let tuple = types |> List.map (fun t -> sprintf "T.Types.%s.t" (L.as_lang_type t)) |> String.concat " * " in + output "| %s : (%s) -> %s field" field_name tuple result_full + ) fields; + dec_indent (); + empty_line (); + + output "include Sqlgg_traits.Dynamic(struct type nonrec 'a t = 'a field end)"; + empty_line (); + + List.iter (fun (field_name, param_name, param_types, _attr) -> + match param_types with + | [] -> output "let %s = V %s" (String.lowercase_ascii field_name) field_name + | _ -> output "let %s %s = V (%s %s)" (String.lowercase_ascii field_name) param_name field_name param_name + ) fields; + + dec_indent (); + output "end"; + empty_line () + ) + ) stmts + +(* Wrapper to generate stmt with or without DynamicSelect *) +let generate_stmt_wrapper style index stmt = + let dynamic_infos = get_all_dynamic_select_infos index stmt in + match dynamic_infos with + | [] -> generate_stmt style index stmt + | _ -> generate_stmt_with_dynamic style index stmt dynamic_infos + let generate ~gen_io name stmts = (* let types = @@ -825,8 +1192,9 @@ let generate ~gen_io name stmts = inc_indent (); output "module IO = %s" io; generate_enum_modules stmts; + generate_dynamic_select_modules stmts; empty_line (); - List.iteri (generate_stmt `Direct) stmts; + List.iteri (generate_stmt_wrapper `Direct) stmts; let has_fold = List.exists is_callback stmts in let has_list = has_fold in let has_single = List.exists (fun stmt -> @@ -843,7 +1211,7 @@ let generate ~gen_io name stmts = if i > 0 then output ""; output "module %s = struct" name; inc_indent (); - List.iteri (generate_stmt style) stmts; + List.iteri (generate_stmt_wrapper style) stmts; dec_indent (); output "end (* module %s *)" name ); diff --git a/src/gen_csharp.ml b/src/gen_csharp.ml index 0a0f2a4e..bac39dc1 100644 --- a/src/gen_csharp.ml +++ b/src/gen_csharp.ml @@ -8,6 +8,12 @@ open Prelude open Gen open Sql +let schema_to_attrs schema = + List.filter_map (function + | Syntax.Attr attr -> Some attr + | Syntax.Dynamic _ -> None + ) schema + module G = Gen_cxx module J = Gen_java module Values = G.Values @@ -96,9 +102,10 @@ let start () = () let func_execute index stmt = let params = params_only stmt.vars in let values = G.Values.inject @@ values_of_params params in - let schema_binder_name = output_schema_binder index stmt.schema in + let schema = schema_to_attrs stmt.schema in + let schema_binder_name = output_schema_binder index schema in let is_select = Option.is_some schema_binder_name in - let doc = if is_select then ["result", schema_to_string stmt.schema] else [] in + let doc = if is_select then ["result", schema_to_string schema] else [] in comment_xml "execute query" doc; let func_name = if is_select then "execute_reader" else "execute" in let result = "public " ^ if is_select then "IEnumerable" else "int" in @@ -129,7 +136,7 @@ let func_execute index stmt = let result = match schema_binder_name with None -> [] | Some name -> ["result",name] in let all_params = values @ result in G.func "public int" "execute" all_params (fun () -> - let args = List.mapi (fun index attr -> get_column attr index) stmt.schema in + let args = List.mapi (fun index attr -> get_column attr index) schema in output "int count = 0;"; output "foreach (var reader in execute_reader(%s))" (Values.inline values); G.open_curly (); @@ -139,7 +146,7 @@ let func_execute index stmt = output "return count;" ); empty_line (); - match stmt.schema with + match schema with | [attr] -> let t = as_lang_type attr.domain in G.func ("public IEnumerable<" ^ t ^ ">") "rows" values (fun () -> @@ -154,10 +161,10 @@ let func_execute index stmt = output "public readonly %s %s;" (as_lang_type attr.domain) (name_of attr index) - ) stmt.schema; + ) schema; empty_line (); G.func "public" "row" ["reader","IDataReader"] (fun () -> - List.iteri (fun i attr -> output "%s = %s;" (name_of attr i) (get_column attr i)) stmt.schema; + List.iteri (fun i attr -> output "%s = %s;" (name_of attr i) (get_column attr i)) schema; ); end_class "row"; G.func "public IEnumerable" "rows" values (fun () -> diff --git a/src/gen_cxx.ml b/src/gen_cxx.ml index 14f365a5..8e326f3b 100644 --- a/src/gen_cxx.ml +++ b/src/gen_cxx.ml @@ -168,7 +168,10 @@ let make_stmt index stmt = let params = params_only stmt.vars in struct_params name ["stmt","typename Traits::statement"] (fun () -> func "" name ["db","typename Traits::connection"] ~tail:(sprintf ": stmt(db,SQLGG_STR(%s))" sql) identity; - let schema_binder_name = output_schema_binder index stmt.schema in + let schema = List.concat_map (function + | Syntax.Attr attr -> [attr] + | Syntax.Dynamic _ -> failwith "Dynamic columns not supported in cxx") stmt.Gen.schema in + let schema_binder_name = output_schema_binder index schema in let params_binder_name = output_params_binder index params in (* if (Option.is_some schema_binder_name) then output_schema_data index stmt.schema; *) out_public (); diff --git a/src/gen_java.ml b/src/gen_java.ml index 4c271ba8..670efc52 100644 --- a/src/gen_java.ml +++ b/src/gen_java.ml @@ -105,7 +105,10 @@ let generate_code index stmt = let sql = quote (get_sql_string_only stmt) in output "PreparedStatement pstmt_%s;" name; empty_line (); - let schema_binder_name = output_schema_binder name index stmt.schema in + let schema = List.concat_map (function + | Syntax.Attr attr -> [attr] + | Syntax.Dynamic _ -> failwith "Dynamic columns not supported in cxx") stmt.Gen.schema in + let schema_binder_name = output_schema_binder name index schema in let result = match schema_binder_name with None -> [] | Some name -> ["result",name] in let all_params = values @ result in G.func "public int" name all_params ~tail:"throws SQLException" (fun () -> @@ -116,7 +119,10 @@ let generate_code index stmt = | None -> output "return pstmt_%s.executeUpdate();" name | Some _ -> output "ResultSet res = pstmt_%s.executeQuery();" name; - let args = List.mapi (fun index attr -> get_column attr index) stmt.schema in + let schema = List.concat_map (function + | Syntax.Attr attr -> [attr] + | Syntax.Dynamic _ -> failwith "Dynamic columns not supported in cxx") stmt.Gen.schema in + let args = List.mapi (fun index attr -> get_column attr index) schema in let args = String.concat "," args in output "int count = 0;"; output "while (res.next())"; diff --git a/src/gen_xml.ml b/src/gen_xml.ml index beab8c49..e6365ee9 100644 --- a/src/gen_xml.ml +++ b/src/gen_xml.ml @@ -8,6 +8,12 @@ open Prelude open Stmt open Gen +let schema_to_attrs schema = + List.filter_map (function + | Syntax.Attr attr -> Some attr + | Syntax.Dynamic _ -> None + ) schema + type xml = | Node of (string * (string * string) list * xml list) | Comment of string @@ -58,7 +64,7 @@ let value ?(inparam=false) v = Node ("value", attrs, []) let tuplelist_value_of_param = function - | Sql.Single _ | SingleIn _ | Choice _ | ChoiceIn _ | OptionActionChoice _ | SharedVarsGroup _ -> None + | Sql.Single _ | SingleIn _ | Choice _ | ChoiceIn _ | OptionActionChoice _ | SharedVarsGroup _ | DynamicSelect _ -> None | TupleList ({ label = None; _ }, _) -> failwith "empty label in tuple subst" | TupleList ({ label = Some name; _ }, kind) -> let schema = match kind with @@ -103,7 +109,8 @@ let rec params_only l = | SingleIn _ -> [] | SharedVarsGroup (vars, _) | ChoiceIn { vars; _ } -> params_only vars - | Choice (_,choices) -> + | Choice (_,choices) + | DynamicSelect (_, choices) -> choices |> List.map (function Sql.Verbatim _ | Simple (_,None) -> [] | Simple (_name,Some vars) -> params_only vars) (* TODO prefix names *) |> List.concat @@ -118,7 +125,7 @@ let generate_code (x,_) index stmt = @ (params_to_values @@ params_only stmt.vars) @ (inparams_to_values @@ inparams_only stmt.vars)) in - let output = Node ("out",[],schema_to_values stmt.schema) in + let output = Node ("out",[],schema_to_values (schema_to_attrs stmt.schema)) in let sql = get_sql_string stmt in let attrs = match stmt.kind with diff --git a/src/main.ml b/src/main.ml index 964a4fd8..a69a5f83 100644 --- a/src/main.ml +++ b/src/main.ml @@ -13,6 +13,10 @@ let () = Printexc.(register_printer begin function | _ -> None end) +let set_dynamic_select_prop props = match Props.get props "dynamic_select" with + | Some s -> String.lowercase_ascii s = "true" + | None -> false + (** Handle parsing error and format a helpful error message *) let handle_parsing_error sql exn (line, cnum, tok, tail) = let extra = match exn with @@ -79,7 +83,10 @@ let check_dialect sql dialect_features = (show_feature ds.feature) (show !selected) (position_info ds) (feature_to_string ds.feature)) let get_statement_error stmt sql = - if not (Sql.Schema.is_unique stmt.Gen.schema) then + let schema = List.concat_map (function + | Syntax.Attr attr -> [attr] + | Syntax.Dynamic (_, l) -> List.map snd l) stmt.Gen.schema in + if not (Sql.Schema.is_unique schema) then Printf.eprintf "Warning: this SQL statement will produce rowset with duplicate column names:\n%s\n" sql; match stmt.kind with | Insert (Some _, _) when !Gen.params_mode = None -> @@ -89,6 +96,7 @@ let get_statement_error stmt sql = let parse_one' (sql, props) = if Sqlgg_config.debug1 () then Printf.eprintf "------\n%s\n%!" sql; + Syntax.Config.dynamic_select := set_dynamic_select_prop props; let (sql, schema, vars, kind, dialect_features) = Syntax.parse sql in check_dialect sql dialect_features; begin match kind, !Gen.params_mode with diff --git a/src/test.ml b/src/test.ml index f5819641..6758320c 100644 --- a/src/test.ml +++ b/src/test.ml @@ -6,6 +6,12 @@ open Sql (* open Sql.Type *) open Stmt +let schema_to_attrs schema = + List.filter_map (function + | Syntax.Attr attr -> Some attr + | Syntax.Dynamic _ -> None + ) schema + let cmp_param p1 p2 = p1.id.label = p2.id.label && Type.equal p1.typ p2.typ && p1.id.pos = (0,0) && snd p2.id.pos > fst p2.id.pos let cmp_params p1 p2 = @@ -50,14 +56,15 @@ let assert_params_with_meta stmt meta = | ChoiceIn _ | SharedVarsGroup _ | OptionActionChoice _ | Choice _ | TupleList _ -> assert false + | DynamicSelect _ -> failwith "dynamic selects not supported for this host language" ) stmt.Gen.vars) let do_test ?kind sql schema params = let stmt = parse sql in - assert_equal ~msg:"schema" ~printer:Sql.Schema.to_string schema stmt.schema; + assert_equal ~msg:"schema" ~printer:Sql.Schema.to_string schema (schema_to_attrs stmt.schema); assert_equal ~msg:"params" ~cmp:cmp_params ~printer:Sql.show_params params - (List.map (function Single (p, _) -> p | SharedVarsGroup _ | OptionActionChoice _ | SingleIn _ | Choice _ | ChoiceIn _ | TupleList _ -> assert false) stmt.vars); + (List.map (function Single (p, _) -> p | SharedVarsGroup _ | OptionActionChoice _ | SingleIn _ | Choice _ | ChoiceIn _ | TupleList _ -> assert false | DynamicSelect _ -> failwith "dynamic selects not supported for this host language") stmt.vars); match kind with | Some k -> assert_equal ~msg:"kind" ~printer:[%derive.show: Stmt.kind] k stmt.kind @@ -71,7 +78,7 @@ let tt sql ?kind schema params = let tt_schema_only sql ?kind schema = let test () = let stmt = parse sql in - assert_equal ~msg:"schema" ~printer:Sql.Schema.to_string schema stmt.schema; + assert_equal ~msg:"schema" ~printer:Sql.Schema.to_string schema (schema_to_attrs stmt.schema); match kind with | Some k -> assert_equal ~msg:"kind" ~printer:[%derive.show: Stmt.kind] k stmt.kind | None -> () @@ -478,7 +485,7 @@ let test_in_clause_with_tuple_sets () = SELECT a FROM test17 WHERE (a, b, c) IN @abc |} in - assert_equal ~msg:"schema" ~printer:Sql.Schema.to_string [attr' ~nullability:Nullable "a" Int] stmt.schema; + assert_equal ~msg:"schema" ~printer:Sql.Schema.to_string [attr' ~nullability:Nullable "a" Int] (schema_to_attrs stmt.schema); () let test_agg_nullable = [ @@ -1041,22 +1048,22 @@ let test_enum_literal () = do_test "CREATE TABLE test36 (status enum('active','pending','deleted') NOT NULL DEFAULT 'pending')" [] []; let stmt = parse {|INSERT INTO test36 VALUES('pending')|} in - assert_equal ~msg:"schema" ~printer:Sql.Schema.to_string [] stmt.schema; + assert_equal ~msg:"schema" ~printer:Sql.Schema.to_string [] (schema_to_attrs stmt.schema); let stmt2 = parse {|INSERT INTO test36 VALUES('active')|} in - assert_equal ~msg:"schema" ~printer:Sql.Schema.to_string [] stmt2.schema; + assert_equal ~msg:"schema" ~printer:Sql.Schema.to_string [] (schema_to_attrs stmt2.schema); let stmt3 = parse {|INSERT INTO test36 VALUES('deleted')|} in - assert_equal ~msg:"schema" ~printer:Sql.Schema.to_string [] stmt3.schema; + assert_equal ~msg:"schema" ~printer:Sql.Schema.to_string [] (schema_to_attrs stmt3.schema); let stmt4 = parse {|SELECT * FROM test36 WHERE status = 'active'|} in assert_equal ~msg:"schema" ~printer:Sql.Schema.to_string [attr' ~extra:[NotNull; WithDefault] "status" (Type.(Union { ctors = (Enum_kind.Ctors.of_list ["active"; "pending"; "deleted"] ); is_closed = true }))] - stmt4.schema; + (schema_to_attrs stmt4.schema); let stmt5 = parse {|UPDATE test36 SET status = 'deleted' WHERE status = 'pending'|} in - assert_equal ~msg:"schema" ~printer:Sql.Schema.to_string [] stmt5.schema; + assert_equal ~msg:"schema" ~printer:Sql.Schema.to_string [] (schema_to_attrs stmt5.schema); let stmt6 = parse {| SELECT * FROM test36 @@ -1066,13 +1073,13 @@ let test_enum_literal () = assert_equal ~msg:"schema" ~printer:Sql.Schema.to_string [attr' ~extra:[NotNull; WithDefault] "status" (Type.(Union { ctors = (Enum_kind.Ctors.of_list ["active"; "pending"; "deleted"]); is_closed = true }))] - stmt6.schema; + (schema_to_attrs stmt6.schema); ignore @@ wrong {|INSERT INTO test36 VALUES('deleteddd')|} ; ignore @@ wrong {|INSERT INTO test36 VALUES((IF(TRUE, 'a', 'b')))|} ; let stmt7 = parse {|INSERT INTO test36 VALUES((IF(TRUE, 'pending', 'active')))|} in - assert_equal ~msg:"schema" ~printer:Sql.Schema.to_string [] stmt7.schema; + assert_equal ~msg:"schema" ~printer:Sql.Schema.to_string [] (schema_to_attrs stmt7.schema); ignore @@ wrong {|INSERT INTO test36 VALUES((IF(TRUE, 'pending', 'b')))|}; ignore @@ wrong {|INSERT INTO test36 VALUES(CONCAT(''))|}; @@ -1082,7 +1089,7 @@ let test_enum_literal () = let stmt8 = parse {|SELECT CONCAT(status, 'test') AS named FROM test36 WHERE status = 'active'|} in assert_equal ~msg:"schema" ~printer:Sql.Schema.to_string [attr' ~extra:[] "named" Text] - stmt8.schema + (schema_to_attrs stmt8.schema) let test_add_with_window_function = [ (* Most aggregate functions also can be used as window functions *) @@ -1351,7 +1358,7 @@ let test_type_mapping_params _ = ~msg:"schema" ~printer:Sql.Schema.to_string [attr' ~extra:[PrimaryKey] ~meta:["module", "HelloWorld"] "id" Int] - stmt.schema; + (schema_to_attrs stmt.schema); assert_params_with_meta stmt [(named "id" Int, ["module", "HelloWorld"])]; (* test in subqery *) @@ -1360,7 +1367,7 @@ let test_type_mapping_params _ = ~msg:"schema" ~printer:Sql.Schema.to_string [attr' ~extra:[PrimaryKey] ~meta:["module", "HelloWorld"] "id" Int] - stmt.schema; + (schema_to_attrs stmt.schema); assert_params_with_meta stmt [(named "id" Int, ["module", "HelloWorld"])]; let stmt = parse {|SELECT id FROM test39 WHERE txt = (SELECT txt FROM test39 WHERE id = @id OR (txt = @txt OR TRUE) )|} in @@ -1370,7 +1377,7 @@ let test_type_mapping_params _ = [ attr' ~extra:[PrimaryKey] ~meta:["module", "HelloWorld"] "id" Int; ] - stmt.schema; + (schema_to_attrs stmt.schema); assert_params_with_meta stmt [(named "id" Int, ["module", "HelloWorld"]); (named "txt" Text, [])]; do_test {| @@ -1393,7 +1400,7 @@ let test_type_mapping_params _ = attr' ~extra:[PrimaryKey] ~meta:["module", "HelloWorld"] "id" Int; attr' ~extra:[NotNull] ~meta:["module", "Txt_module_name"] "txt2" Text; ] - stmt.schema; + (schema_to_attrs stmt.schema); assert_params_with_meta stmt [ (named "id" Int, ["module", "HelloWorld"]); (named "txt2" Text, ["module", "Txt_module_name"]) @@ -1411,7 +1418,7 @@ let test_type_mapping_params _ = attr' ~extra:[PrimaryKey] ~meta:["module", "HelloWorld"] "id" Int; attr' ~extra:[NotNull] ~meta:["module", "Txt_module_name"] "txt2" Text; ] - stmt.schema; + (schema_to_attrs stmt.schema); assert_params_with_meta stmt [ (named "txt2" Text, ["module", "Txt_module_name"]) ]; @@ -1457,7 +1464,7 @@ let test_type_mapping_params _ = [ attr' "booo" Bool; ] - stmt.schema; + (schema_to_attrs stmt.schema); (* not only in WHERE expr *) assert_params_with_meta stmt [ @@ -1534,7 +1541,7 @@ let test_type_mapping_params _ = attr' ~extra:[] ~meta:["module", "Module3"] "d" (Decimal { precision = Some 10; scale = Some 2; }); attr' "e" Int; ] - stmt.schema; + (schema_to_attrs stmt.schema); assert_params_with_meta stmt [ (named "param_1" Datetime, []); diff --git a/test/cram/dune b/test/cram/dune index e14eae43..2c716781 100644 --- a/test/cram/dune +++ b/test/cram/dune @@ -5,6 +5,7 @@ (glob_files *.compare.ml) (source_tree test_build_json_functions) (source_tree test_build_enum_literals) + (source_tree test_build_dynamic_select) (glob_files print_ocaml_impl.ml) (glob_files test_cached_prepared_stmts.ml) (glob_files print_impl.ml) diff --git a/test/cram/dynamic_select.t b/test/cram/dynamic_select.t new file mode 100644 index 00000000..3855bfb2 --- /dev/null +++ b/test/cram/dynamic_select.t @@ -0,0 +1,206 @@ +Test DynamicSelect with applicative combinators generates proper SQL: + $ cd test_build_dynamic_select + $ cat dynamic_select.sql | sqlgg -no-header -gen caml_io -params unnamed -gen caml -dialect mysql - > output.ml + $ cp ../print_ocaml_impl.ml . + $ ocamlfind ocamlc -package sqlgg.traits,yojson -I . -c print_ocaml_impl.ml + $ ocamlfind ocamlc -package sqlgg.traits,yojson -I . -c product_id.ml + $ ocamlfind ocamlc -package sqlgg.traits,sqlgg -I . -c output.ml + $ ocamlfind ocamlc -package sqlgg.traits,yojson -I . -c test_run.ml + $ ocamlfind ocamlc -package sqlgg.traits,yojson -I . -linkpkg -o test_run.exe print_ocaml_impl.cmo product_id.cmo output.cmo test_run.ml + $ ./test_run.exe + Dynamic Select Query Generation Tests + ================================================== + === Starting Dynamic Select Tests === + + --- Test Group 1: Basic select_one_maybe --- + [TEST 1.1] Single field: Name + [MOCK SELECT_ONE_MAYBE] Connection type: [> `RO ] + [SQL] SELECT id, name FROM products WHERE id = 1 + [MOCK] Returning one row + [MOCK] get_column_Text_nullable[1] = Some "Widget" + [MOCK] get_column_Int[0] = 1 + [TEST 1.1] Completed + + [TEST 1.2] Single field: Price + [MOCK SELECT_ONE_MAYBE] Connection type: [> `RO ] + [SQL] SELECT id, price FROM products WHERE id = 2 + [MOCK] Returning one row + [MOCK] get_column_Decimal_nullable[1] = Some 99.990000 + [MOCK] get_column_Int[0] = 1 + [TEST 1.2] Completed + + [TEST 1.3] Combined fields: Name and Price using let+/and+ + [MOCK SELECT_ONE_MAYBE] Connection type: [> `RO ] + [SQL] SELECT id, name , price FROM products WHERE id = 3 + [MOCK] Returning one row + [MOCK] get_column_Text_nullable[1] = Some "Gadget" + [MOCK] get_column_Decimal_nullable[2] = Some 149.990000 + [MOCK] get_column_Int[0] = 1 + [TEST 1.3] Completed + + [TEST 1.4] Three fields: Name, Price, Category + [MOCK SELECT_ONE_MAYBE] Connection type: [> `RO ] + [SQL] SELECT id, name , price , category FROM products WHERE id = 4 + [MOCK] Returning one row + [MOCK] get_column_Text_nullable[1] = Some "Phone" + [MOCK] get_column_Decimal_nullable[2] = Some 599.990000 + [MOCK] get_column_Text_nullable[3] = Some "Electronics" + [MOCK] get_column_Int[0] = 1 + [TEST 1.4] Completed + + [TEST 1.5] Mapped field: Price with transformation + [MOCK SELECT_ONE_MAYBE] Connection type: [> `RO ] + [SQL] SELECT id, price FROM products WHERE id = 5 + [MOCK] Returning one row + [MOCK] get_column_Decimal_nullable[1] = Some 100.000000 + [MOCK] get_column_Int[0] = 1 + [TEST 1.5] Completed + + [TEST 1.6] Return constructor (constant value) + [MOCK SELECT_ONE_MAYBE] Connection type: [> `RO ] + [SQL] SELECT id FROM products WHERE id = 6 + [MOCK] Returning one row + [MOCK] get_column_Int[0] = 1 + [TEST 1.6] Completed + + --- Test Group 2: Select with callback --- + [TEST 2.1] List with single field: Name + [MOCK SELECT] Connection type: [> `RO ] + [SQL] SELECT id, name FROM products WHERE stock > 10 + [MOCK] Returning 2 rows + Row 0: col0=1 col1=Widget + [MOCK] get_column_Text_nullable[1] = Some "Widget" + [MOCK] get_column_Int[0] = 1 + Row: id=1, col=Widget + Row 1: col0=2 col1=Gadget + [MOCK] get_column_Text_nullable[1] = Some "Gadget" + [MOCK] get_column_Int[0] = 2 + Row: id=2, col=Gadget + [TEST 2.1] Completed + + [TEST 2.2] List with combined fields: Name and Price + [MOCK SELECT] Connection type: [> `RO ] + [SQL] SELECT id, name , price FROM products WHERE stock > 5 + [MOCK] Returning 2 rows + Row 0: col0=1 col1=Widget col2=19.99 + [MOCK] get_column_Text_nullable[1] = Some "Widget" + [MOCK] get_column_Decimal_nullable[2] = Some 19.990000 + [MOCK] get_column_Int[0] = 1 + Row: id=1, name=Widget, price=19.99 + Row 1: col0=2 col1=Gadget col2=29.99 + [MOCK] get_column_Text_nullable[1] = Some "Gadget" + [MOCK] get_column_Decimal_nullable[2] = Some 29.990000 + [MOCK] get_column_Int[0] = 2 + Row: id=2, name=Gadget, price=29.99 + [TEST 2.2] Completed + + --- Test Group 3: Multiple dynamic selects --- + [TEST 3.1] Two dynamic selects: x=A(name), y=C(price) + [MOCK SELECT_ONE_MAYBE] Connection type: [> `RO ] + [SQL] SELECT name , price FROM products WHERE id = 1 + [MOCK] Returning one row + [MOCK] get_column_Text_nullable[0] = Some "Widget" + [MOCK] get_column_Decimal_nullable[1] = Some 99.990000 + [TEST 3.1] Completed + + [TEST 3.2] Two dynamic selects with combinators + [MOCK SELECT_ONE_MAYBE] Connection type: [> `RO ] + [SQL] SELECT name , category , price , stock FROM products WHERE id = 2 + [MOCK] Returning one row + [MOCK] get_column_Text_nullable[0] = Some "Widget" + [MOCK] get_column_Text_nullable[1] = Some "Electronics" + [MOCK] get_column_Decimal_nullable[2] = Some 99.990000 + [MOCK] get_column_Int_nullable[3] = Some 50 + [TEST 3.2] Completed + + --- Test Group 4: Verbatim branches --- + [TEST 4.1] Verbatim branch: Default + [MOCK SELECT_ONE_MAYBE] Connection type: [> `RO ] + [SQL] SELECT id, 'N/A' FROM products WHERE id = 1 + [MOCK] Returning one row + [MOCK] get_column_Text[1] = "N/A" + [MOCK] get_column_Int[0] = 1 + [TEST 4.1] Completed + + [TEST 4.2] Regular branch after Verbatim: Name + [MOCK SELECT_ONE_MAYBE] Connection type: [> `RO ] + [SQL] SELECT id, name FROM products WHERE id = 2 + [MOCK] Returning one row + [MOCK] get_column_Text_nullable[1] = Some "Widget" + [MOCK] get_column_Int[0] = 1 + [TEST 4.2] Completed + + --- Test Group 5: Parameter in branch --- + [TEST 5.1] Static branch (no param) + [MOCK SELECT_ONE_MAYBE] Connection type: [> `RO ] + [SQL] SELECT id, name FROM products WHERE id = 1 + [MOCK] Returning one row + [MOCK] get_column_Text_nullable[1] = Some "Widget" + [MOCK] get_column_Int[0] = 1 + [TEST 5.1] Completed + + [TEST 5.2] Dynamic branch (with param) + [MOCK SELECT_ONE_MAYBE] Connection type: [> `RO ] + [SQL] SELECT id, 'Custom Value' FROM products WHERE id = 2 + [MOCK] Returning one row + [MOCK] get_column_Text[1] = "Custom Value" + [MOCK] get_column_Int[0] = 1 + [TEST 5.2] Completed + + --- Test Group 6: Dynamic at first position --- + [TEST 6.1] Dynamic select at first position + [MOCK SELECT_ONE_MAYBE] Connection type: [> `RO ] + [SQL] SELECT name , id, stock FROM products WHERE id = 1 + [MOCK] Returning one row + [MOCK] get_column_Text_nullable[0] = Some "Widget" + [MOCK] get_column_Int_nullable[2] = Some 100 + [MOCK] get_column_Int[1] = 1 + [TEST 6.1] Completed + + [TEST 6.2] Dynamic select at first position with combinator + [MOCK SELECT_ONE_MAYBE] Connection type: [> `RO ] + [SQL] SELECT name , price , id, stock FROM products WHERE id = 2 + [MOCK] Returning one row + [MOCK] get_column_Text_nullable[0] = Some "Widget" + [MOCK] get_column_Decimal_nullable[1] = Some 99.990000 + [MOCK] get_column_Int_nullable[3] = Some 100 + [MOCK] get_column_Int[2] = 1 + [TEST 6.2] Completed + + --- Test Group 7: select_one --- + [TEST 7.1] select_one with single field + [MOCK SELECT_ONE_MAYBE] Connection type: [> `RO ] + [SQL] SELECT name FROM products WHERE id = 1 LIMIT 1 + [MOCK] Returning one row + [MOCK] get_column_Text_nullable[0] = Some "Widget" + [TEST 7.1] Completed + + [TEST 7.2] select_one with combined fields + [MOCK SELECT_ONE_MAYBE] Connection type: [> `RO ] + [SQL] SELECT name , price FROM products WHERE id = 2 LIMIT 1 + [MOCK] Returning one row + [MOCK] get_column_Text_nullable[0] = Some "Widget" + [MOCK] get_column_Decimal_nullable[1] = Some 99.990000 + [TEST 7.2] Completed + + --- Test Group 8: module-wrapped column --- + [TEST 8.1] Module-wrapped column: Id + [MOCK SELECT_ONE_MAYBE] Connection type: [> `RO ] + [SQL] SELECT id FROM products_wrapped WHERE id = 1 + [MOCK] Returning one row + [MOCK] get_column_Int[0] = 42 + [TEST 8.1] Completed + + [TEST 8.2] Module-wrapped: regular column Name + [MOCK SELECT_ONE_MAYBE] Connection type: [> `RO ] + [SQL] SELECT name FROM products_wrapped WHERE id = 2 + [MOCK] Returning one row + [MOCK] get_column_Text_nullable[0] = Some "Widget" + [TEST 8.2] Completed + + === All Dynamic Select Tests Passed === + + ================================================== + All tests executed successfully! + $ cd .. + diff --git a/test/cram/test.t b/test/cram/test.t index f540c2b3..fe0eebd4 100644 --- a/test/cram/test.t +++ b/test/cram/test.t @@ -3517,3 +3517,575 @@ Test IS NOT NULL type refinement with IS NULL: end (* module List *) end (* module Sqlgg *) + +Test DynamicSelect with dynamic_select flag: + $ sqlgg -gen caml -no-header -dialect=mysql - <<'EOF' 2>&1 + > CREATE TABLE accounts (id INT PRIMARY KEY, balance DECIMAL(10,2)); + > -- [sqlgg] dynamic_select=true + > -- @select_ids2 + > SELECT id, balance, @x { A { @t + 1 } | B { (SELECT 6 + @seven LIMIT 1) } } FROM accounts WHERE id > @t; + > EOF + module Sqlgg (T : Sqlgg_traits.M) = struct + + module IO = Sqlgg_io.Blocking + module Select_ids2_x = struct + type _ field = + | A : T.Types.Int.t -> T.Types.Int.t field + | B : T.Types.Int.t -> T.Types.Int.t option field + + include Sqlgg_traits.Dynamic(struct type nonrec 'a t = 'a field end) + + let a a = V (A a) + let b b = V (B b) + end + + + let create_accounts db = + T.execute db ("CREATE TABLE accounts (id INT PRIMARY KEY, balance DECIMAL(10,2))") T.no_params + + let select_ids2 db ~x ~t callback = + let rec params_count_x : type a. a Select_ids2_x.t -> int = function + | Select_ids2_x.V (A _) -> 1 + | Select_ids2_x.V (B _) -> 1 + | Return _ -> 0 + | Map (t, _) -> params_count_x t + | Both (a, b) -> params_count_x a + params_count_x b + in + let field_set_x : type a. a Select_ids2_x.field -> T.params -> unit = function + | A x -> fun p -> T.set_param_Int p x + | B x -> fun p -> T.set_param_Int p x + in + let rec set_x : type a. a Select_ids2_x.t -> T.params -> unit = function + | Select_ids2_x.V f -> fun p -> field_set_x f p + | Return _ -> fun _p -> () + | Map (t, _) -> fun p -> set_x t p + | Both (a, b) -> fun p -> set_x a p; set_x b p + in + let field_to_column_x : type a. a Select_ids2_x.field -> string = function + | A _ -> (" " ^ "?" ^ " + 1 ") + | B _ -> (" (SELECT 6 + " ^ "?" ^ " LIMIT 1) ") + in + let rec to_a_field_list_x : type a. a Select_ids2_x.t -> Select_ids2_x.a_field list = function + | Select_ids2_x.V f -> [Any_field f] + | Return _ -> [] + | Map (t, _) -> to_a_field_list_x t + | Both (a, b) -> to_a_field_list_x a @ to_a_field_list_x b + in + let field_read_x : type a. a Select_ids2_x.field -> T.row -> int -> a = function + | A _ -> fun row idx -> T.get_column_Int row idx + | B _ -> fun row idx -> T.get_column_Int_nullable row idx + in + let rec read_x : type a. a Select_ids2_x.t -> T.row -> int -> a * int = function + | Select_ids2_x.V f -> fun row idx -> (field_read_x f row idx, idx + 1) + | Return x -> fun _row idx -> (x, idx) + | Map (t, f) -> fun row idx -> let (v, idx') = read_x t row idx in (f v, idx') + | Both (a, b) -> fun row idx -> let (va, i1) = read_x a row idx in let (vb, i2) = read_x b row i1 in ((va, vb), i2) + in + let set_params stmt = + let p = T.start_params stmt (1 + params_count_x x) in + set_x x p; + T.set_param_Int p t; + T.finish_params p + in + T.select db + ("SELECT id, balance" ^ (match (x |> to_a_field_list_x |> List.map (fun (Select_ids2_x.Any_field f) -> field_to_column_x f)) with [] -> "" | l -> ", " ^ String.concat ", " l) ^ " FROM accounts WHERE id > ?") + set_params (fun row -> let (__sqlgg_r_x, __sqlgg_idx_after_x) = read_x x row 2 in callback + ~id:(T.get_column_Int row 0) + ~balance:(T.get_column_Decimal_nullable row 1) + ~x:__sqlgg_r_x) + + module Fold = struct + let select_ids2 db ~x ~t callback acc = + let rec params_count_x : type a. a Select_ids2_x.t -> int = function + | Select_ids2_x.V (A _) -> 1 + | Select_ids2_x.V (B _) -> 1 + | Return _ -> 0 + | Map (t, _) -> params_count_x t + | Both (a, b) -> params_count_x a + params_count_x b + in + let field_set_x : type a. a Select_ids2_x.field -> T.params -> unit = function + | A x -> fun p -> T.set_param_Int p x + | B x -> fun p -> T.set_param_Int p x + in + let rec set_x : type a. a Select_ids2_x.t -> T.params -> unit = function + | Select_ids2_x.V f -> fun p -> field_set_x f p + | Return _ -> fun _p -> () + | Map (t, _) -> fun p -> set_x t p + | Both (a, b) -> fun p -> set_x a p; set_x b p + in + let field_to_column_x : type a. a Select_ids2_x.field -> string = function + | A _ -> (" " ^ "?" ^ " + 1 ") + | B _ -> (" (SELECT 6 + " ^ "?" ^ " LIMIT 1) ") + in + let rec to_a_field_list_x : type a. a Select_ids2_x.t -> Select_ids2_x.a_field list = function + | Select_ids2_x.V f -> [Any_field f] + | Return _ -> [] + | Map (t, _) -> to_a_field_list_x t + | Both (a, b) -> to_a_field_list_x a @ to_a_field_list_x b + in + let field_read_x : type a. a Select_ids2_x.field -> T.row -> int -> a = function + | A _ -> fun row idx -> T.get_column_Int row idx + | B _ -> fun row idx -> T.get_column_Int_nullable row idx + in + let rec read_x : type a. a Select_ids2_x.t -> T.row -> int -> a * int = function + | Select_ids2_x.V f -> fun row idx -> (field_read_x f row idx, idx + 1) + | Return x -> fun _row idx -> (x, idx) + | Map (t, f) -> fun row idx -> let (v, idx') = read_x t row idx in (f v, idx') + | Both (a, b) -> fun row idx -> let (va, i1) = read_x a row idx in let (vb, i2) = read_x b row i1 in ((va, vb), i2) + in + let set_params stmt = + let p = T.start_params stmt (1 + params_count_x x) in + set_x x p; + T.set_param_Int p t; + T.finish_params p + in + let r_acc = ref acc in + IO.(>>=) (T.select db + ("SELECT id, balance" ^ (match (x |> to_a_field_list_x |> List.map (fun (Select_ids2_x.Any_field f) -> field_to_column_x f)) with [] -> "" | l -> ", " ^ String.concat ", " l) ^ " FROM accounts WHERE id > ?") + set_params (fun row -> r_acc := (let (__sqlgg_r_x, __sqlgg_idx_after_x) = read_x x row 2 in callback + ~id:(T.get_column_Int row 0) + ~balance:(T.get_column_Decimal_nullable row 1) + ~x:__sqlgg_r_x !r_acc))) + (fun () -> IO.return !r_acc) + + end (* module Fold *) + + module List = struct + let select_ids2 db ~x ~t callback = + let rec params_count_x : type a. a Select_ids2_x.t -> int = function + | Select_ids2_x.V (A _) -> 1 + | Select_ids2_x.V (B _) -> 1 + | Return _ -> 0 + | Map (t, _) -> params_count_x t + | Both (a, b) -> params_count_x a + params_count_x b + in + let field_set_x : type a. a Select_ids2_x.field -> T.params -> unit = function + | A x -> fun p -> T.set_param_Int p x + | B x -> fun p -> T.set_param_Int p x + in + let rec set_x : type a. a Select_ids2_x.t -> T.params -> unit = function + | Select_ids2_x.V f -> fun p -> field_set_x f p + | Return _ -> fun _p -> () + | Map (t, _) -> fun p -> set_x t p + | Both (a, b) -> fun p -> set_x a p; set_x b p + in + let field_to_column_x : type a. a Select_ids2_x.field -> string = function + | A _ -> (" " ^ "?" ^ " + 1 ") + | B _ -> (" (SELECT 6 + " ^ "?" ^ " LIMIT 1) ") + in + let rec to_a_field_list_x : type a. a Select_ids2_x.t -> Select_ids2_x.a_field list = function + | Select_ids2_x.V f -> [Any_field f] + | Return _ -> [] + | Map (t, _) -> to_a_field_list_x t + | Both (a, b) -> to_a_field_list_x a @ to_a_field_list_x b + in + let field_read_x : type a. a Select_ids2_x.field -> T.row -> int -> a = function + | A _ -> fun row idx -> T.get_column_Int row idx + | B _ -> fun row idx -> T.get_column_Int_nullable row idx + in + let rec read_x : type a. a Select_ids2_x.t -> T.row -> int -> a * int = function + | Select_ids2_x.V f -> fun row idx -> (field_read_x f row idx, idx + 1) + | Return x -> fun _row idx -> (x, idx) + | Map (t, f) -> fun row idx -> let (v, idx') = read_x t row idx in (f v, idx') + | Both (a, b) -> fun row idx -> let (va, i1) = read_x a row idx in let (vb, i2) = read_x b row i1 in ((va, vb), i2) + in + let set_params stmt = + let p = T.start_params stmt (1 + params_count_x x) in + set_x x p; + T.set_param_Int p t; + T.finish_params p + in + let r_acc = ref [] in + IO.(>>=) (T.select db + ("SELECT id, balance" ^ (match (x |> to_a_field_list_x |> List.map (fun (Select_ids2_x.Any_field f) -> field_to_column_x f)) with [] -> "" | l -> ", " ^ String.concat ", " l) ^ " FROM accounts WHERE id > ?") + set_params (fun row -> r_acc := (let (__sqlgg_r_x, __sqlgg_idx_after_x) = read_x x row 2 in callback + ~id:(T.get_column_Int row 0) + ~balance:(T.get_column_Decimal_nullable row 1) + ~x:__sqlgg_r_x) :: !r_acc)) + (fun () -> IO.return (List.rev !r_acc)) + + end (* module List *) + end (* module Sqlgg *) + +Test DynamicSelect with two dynamic columns: + $ sqlgg -gen caml -no-header -dialect=mysql - <<'EOF' 2>&1 | head -80 + > CREATE TABLE items (id INT, name TEXT, price DECIMAL(10,2)); + > -- [sqlgg] dynamic_select=true + > -- @multi_dynamic + > SELECT id, @x { A { name } | B { 'default' } }, price, @y { C { price * 2 } | D { @factor :: Text } } FROM items; + > EOF + module Sqlgg (T : Sqlgg_traits.M) = struct + + module IO = Sqlgg_io.Blocking + module Multi_dynamic_x = struct + type _ field = + | A : T.Types.Text.t option field + | B : T.Types.Text.t field + + include Sqlgg_traits.Dynamic(struct type nonrec 'a t = 'a field end) + + let a = V A + let b = V B + end + + module Multi_dynamic_y = struct + type _ field = + | C : T.Types.Decimal.t option field + | D : T.Types.Text.t -> T.Types.Text.t field + + include Sqlgg_traits.Dynamic(struct type nonrec 'a t = 'a field end) + + let c = V C + let d d = V (D d) + end + + + let create_items db = + T.execute db ("CREATE TABLE items (id INT, name TEXT, price DECIMAL(10,2))") T.no_params + + let multi_dynamic db ~x ~y callback = + let rec params_count_x : type a. a Multi_dynamic_x.t -> int = function + | Multi_dynamic_x.V A -> 0 + | Multi_dynamic_x.V B -> 0 + | Return _ -> 0 + | Map (t, _) -> params_count_x t + | Both (a, b) -> params_count_x a + params_count_x b + in + let field_set_x : type a. a Multi_dynamic_x.field -> T.params -> unit = function + | A -> fun _p -> () + | B -> fun _p -> () + in + let rec set_x : type a. a Multi_dynamic_x.t -> T.params -> unit = function + | Multi_dynamic_x.V f -> fun p -> field_set_x f p + | Return _ -> fun _p -> () + | Map (t, _) -> fun p -> set_x t p + | Both (a, b) -> fun p -> set_x a p; set_x b p + in + let field_to_column_x : type a. a Multi_dynamic_x.field -> string = function + | A -> (" name ") + | B -> (" 'default' ") + in + let rec to_a_field_list_x : type a. a Multi_dynamic_x.t -> Multi_dynamic_x.a_field list = function + | Multi_dynamic_x.V f -> [Any_field f] + | Return _ -> [] + | Map (t, _) -> to_a_field_list_x t + | Both (a, b) -> to_a_field_list_x a @ to_a_field_list_x b + in + let field_read_x : type a. a Multi_dynamic_x.field -> T.row -> int -> a = function + | A -> fun row idx -> T.get_column_Text_nullable row idx + | B -> fun row idx -> T.get_column_Text row idx + in + let rec read_x : type a. a Multi_dynamic_x.t -> T.row -> int -> a * int = function + | Multi_dynamic_x.V f -> fun row idx -> (field_read_x f row idx, idx + 1) + | Return x -> fun _row idx -> (x, idx) + | Map (t, f) -> fun row idx -> let (v, idx') = read_x t row idx in (f v, idx') + | Both (a, b) -> fun row idx -> let (va, i1) = read_x a row idx in let (vb, i2) = read_x b row i1 in ((va, vb), i2) + in + let rec params_count_y : type a. a Multi_dynamic_y.t -> int = function + | Multi_dynamic_y.V C -> 0 + | Multi_dynamic_y.V (D _) -> 1 + | Return _ -> 0 + | Map (t, _) -> params_count_y t + | Both (a, b) -> params_count_y a + params_count_y b + in + let field_set_y : type a. a Multi_dynamic_y.field -> T.params -> unit = function + | C -> fun _p -> () + | D x -> fun p -> T.set_param_Text p x + in + let rec set_y : type a. a Multi_dynamic_y.t -> T.params -> unit = function + | Multi_dynamic_y.V f -> fun p -> field_set_y f p + +Test DynamicSelect with Verbatim branches: + $ sqlgg -gen caml -no-header -dialect=mysql - <<'EOF' 2>&1 | head -50 + > CREATE TABLE users (id INT, status TEXT); + > -- [sqlgg] dynamic_select=true + > -- @with_verbatim + > SELECT id, @col { active { 'active' } | inactive { 'inactive' } | custom { status } } FROM users; + > EOF + module Sqlgg (T : Sqlgg_traits.M) = struct + + module IO = Sqlgg_io.Blocking + module With_verbatim_col = struct + type _ field = + | Active : T.Types.Text.t field + | Inactive : T.Types.Text.t field + | Custom : T.Types.Text.t option field + + include Sqlgg_traits.Dynamic(struct type nonrec 'a t = 'a field end) + + let active = V Active + let inactive = V Inactive + let custom = V Custom + end + + + let create_users db = + T.execute db ("CREATE TABLE users (id INT, status TEXT)") T.no_params + + let with_verbatim db ~col callback = + let rec params_count_col : type a. a With_verbatim_col.t -> int = function + | With_verbatim_col.V Active -> 0 + | With_verbatim_col.V Inactive -> 0 + | With_verbatim_col.V Custom -> 0 + | Return _ -> 0 + | Map (t, _) -> params_count_col t + | Both (a, b) -> params_count_col a + params_count_col b + in + let field_set_col : type a. a With_verbatim_col.field -> T.params -> unit = function + | Active -> fun _p -> () + | Inactive -> fun _p -> () + | Custom -> fun _p -> () + in + let rec set_col : type a. a With_verbatim_col.t -> T.params -> unit = function + | With_verbatim_col.V f -> fun p -> field_set_col f p + | Return _ -> fun _p -> () + | Map (t, _) -> fun p -> set_col t p + | Both (a, b) -> fun p -> set_col a p; set_col b p + in + let field_to_column_col : type a. a With_verbatim_col.field -> string = function + | Active -> (" 'active' ") + | Inactive -> (" 'inactive' ") + | Custom -> (" status ") + in + let rec to_a_field_list_col : type a. a With_verbatim_col.t -> With_verbatim_col.a_field list = function + | With_verbatim_col.V f -> [Any_field f] + | Return _ -> [] + | Map (t, _) -> to_a_field_list_col t + | Both (a, b) -> to_a_field_list_col a @ to_a_field_list_col b + +Test DynamicSelect at beginning of SELECT: + $ sqlgg -gen caml -no-header -dialect=mysql - <<'EOF' 2>&1 | head -40 + > CREATE TABLE data (a INT, b TEXT); + > -- [sqlgg] dynamic_select=true + > -- @first_col + > SELECT @x { X { a } | Y { b } }, a, b FROM data; + > EOF + module Sqlgg (T : Sqlgg_traits.M) = struct + + module IO = Sqlgg_io.Blocking + module First_col_x = struct + type _ field = + | X : T.Types.Int.t option field + | Y : T.Types.Text.t option field + + include Sqlgg_traits.Dynamic(struct type nonrec 'a t = 'a field end) + + let x = V X + let y = V Y + end + + + let create_data db = + T.execute db ("CREATE TABLE data (a INT, b TEXT)") T.no_params + + let first_col db ~x callback = + let rec params_count_x : type a. a First_col_x.t -> int = function + | First_col_x.V X -> 0 + | First_col_x.V Y -> 0 + | Return _ -> 0 + | Map (t, _) -> params_count_x t + | Both (a, b) -> params_count_x a + params_count_x b + in + let field_set_x : type a. a First_col_x.field -> T.params -> unit = function + | X -> fun _p -> () + | Y -> fun _p -> () + in + let rec set_x : type a. a First_col_x.t -> T.params -> unit = function + | First_col_x.V f -> fun p -> field_set_x f p + | Return _ -> fun _p -> () + | Map (t, _) -> fun p -> set_x t p + | Both (a, b) -> fun p -> set_x a p; set_x b p + in + let field_to_column_x : type a. a First_col_x.field -> string = function + | X -> (" a ") + | Y -> (" b ") + in + +Test DynamicSelect disabled in subquery (fallback to Choice): + $ sqlgg -gen caml -no-header -dialect=mysql - <<'EOF' 2>&1 | head -20 + > CREATE TABLE t1 (id INT); + > -- [sqlgg] dynamic_select=true + > -- @with_subquery + > SELECT id, (SELECT @x { A { 1 } | B { 2 } } LIMIT 1) as sub FROM t1; + > EOF + module Sqlgg (T : Sqlgg_traits.M) = struct + + module IO = Sqlgg_io.Blocking + + let create_t1 db = + T.execute db ("CREATE TABLE t1 (id INT)") T.no_params + + let with_subquery db ~x callback = + let invoke_callback stmt = + callback + ~id:(T.get_column_Int_nullable stmt 0) + ~sub:(T.get_column_Int_nullable stmt 1) + in + let set_params stmt = + let p = T.start_params stmt (0 + (match x with `A -> 0 | `B -> 0)) in + T.finish_params p + in + T.select db ("SELECT id, (SELECT " ^ (match x with `A -> " 1 " | `B -> " 2 ") ^ " LIMIT 1) as sub FROM t1") set_params invoke_callback + + module Fold = struct + +Test DynamicSelect with module annotation: + $ sqlgg -gen caml -no-header -dialect=mysql - <<'EOF' 2>&1 | head -70 + > CREATE TABLE wrapped ( + > -- [sqlgg] module=Product_id + > id INT PRIMARY KEY, + > name TEXT, + > price DECIMAL(10,2) + > ); + > -- [sqlgg] dynamic_select=true + > -- @with_module + > SELECT @col { Id { id } | Name { name } } FROM wrapped WHERE id = @id; + > EOF + module Sqlgg (T : Sqlgg_traits.M) = struct + + module IO = Sqlgg_io.Blocking + module With_module_col = struct + type _ field = + | Id : Product_id.t field + | Name : T.Types.Text.t option field + + include Sqlgg_traits.Dynamic(struct type nonrec 'a t = 'a field end) + + let id = V Id + let name = V Name + end + + + let create_wrapped db = + T.execute db ("CREATE TABLE wrapped (\n\ + id INT PRIMARY KEY,\n\ + name TEXT,\n\ + price DECIMAL(10,2)\n\ + )") T.no_params + + let with_module db ~col ~id = + let rec params_count_col : type a. a With_module_col.t -> int = function + | With_module_col.V Id -> 0 + | With_module_col.V Name -> 0 + | Return _ -> 0 + | Map (t, _) -> params_count_col t + | Both (a, b) -> params_count_col a + params_count_col b + in + let field_set_col : type a. a With_module_col.field -> T.params -> unit = function + | Id -> fun _p -> () + | Name -> fun _p -> () + in + let rec set_col : type a. a With_module_col.t -> T.params -> unit = function + | With_module_col.V f -> fun p -> field_set_col f p + | Return _ -> fun _p -> () + | Map (t, _) -> fun p -> set_col t p + | Both (a, b) -> fun p -> set_col a p; set_col b p + in + let field_to_column_col : type a. a With_module_col.field -> string = function + | Id -> (" id ") + | Name -> (" name ") + in + let rec to_a_field_list_col : type a. a With_module_col.t -> With_module_col.a_field list = function + | With_module_col.V f -> [Any_field f] + | Return _ -> [] + | Map (t, _) -> to_a_field_list_col t + | Both (a, b) -> to_a_field_list_col a @ to_a_field_list_col b + in + let field_read_col : type a. a With_module_col.field -> T.row -> int -> a = function + | Id -> fun row idx -> Product_id.get_column (T.get_column_int64 row idx) + | Name -> fun row idx -> T.get_column_Text_nullable row idx + in + let rec read_col : type a. a With_module_col.t -> T.row -> int -> a * int = function + | With_module_col.V f -> fun row idx -> (field_read_col f row idx, idx + 1) + | Return x -> fun _row idx -> (x, idx) + | Map (t, f) -> fun row idx -> let (v, idx') = read_col t row idx in (f v, idx') + | Both (a, b) -> fun row idx -> let (va, i1) = read_col a row idx in let (vb, i2) = read_col b row i1 in ((va, vb), i2) + in + let set_params stmt = + let p = T.start_params stmt (1 + params_count_col col) in + set_col col p; + T.set_param_int64 p (Product_id.set_param id); + T.finish_params p + in + T.select_one_maybe db + ("SELECT " ^ (String.concat ", " (col |> to_a_field_list_col |> List.map (fun (With_module_col.Any_field f) -> field_to_column_col f))) ^ " FROM wrapped WHERE id = ?") + set_params (fun row -> let (__sqlgg_r_col, __sqlgg_idx_after_col) = read_col col row 0 in (__sqlgg_r_col)) + + +Test DynamicSelect with LIMIT 1 (select_one): + $ sqlgg -gen caml -no-header -dialect=mysql - <<'EOF' 2>&1 | head -70 + > CREATE TABLE products (id INT PRIMARY KEY, name TEXT, price DECIMAL(10,2)); + > -- [sqlgg] dynamic_select=true + > -- @select_one_product + > SELECT @col { Name { name } | Price { price } } FROM products WHERE id = @id LIMIT 1; + > EOF + module Sqlgg (T : Sqlgg_traits.M) = struct + + module IO = Sqlgg_io.Blocking + module Select_one_product_col = struct + type _ field = + | Name : T.Types.Text.t option field + | Price : T.Types.Decimal.t option field + + include Sqlgg_traits.Dynamic(struct type nonrec 'a t = 'a field end) + + let name = V Name + let price = V Price + end + + + let create_products db = + T.execute db ("CREATE TABLE products (id INT PRIMARY KEY, name TEXT, price DECIMAL(10,2))") T.no_params + + let select_one_product db ~col ~id = + let rec params_count_col : type a. a Select_one_product_col.t -> int = function + | Select_one_product_col.V Name -> 0 + | Select_one_product_col.V Price -> 0 + | Return _ -> 0 + | Map (t, _) -> params_count_col t + | Both (a, b) -> params_count_col a + params_count_col b + in + let field_set_col : type a. a Select_one_product_col.field -> T.params -> unit = function + | Name -> fun _p -> () + | Price -> fun _p -> () + in + let rec set_col : type a. a Select_one_product_col.t -> T.params -> unit = function + | Select_one_product_col.V f -> fun p -> field_set_col f p + | Return _ -> fun _p -> () + | Map (t, _) -> fun p -> set_col t p + | Both (a, b) -> fun p -> set_col a p; set_col b p + in + let field_to_column_col : type a. a Select_one_product_col.field -> string = function + | Name -> (" name ") + | Price -> (" price ") + in + let rec to_a_field_list_col : type a. a Select_one_product_col.t -> Select_one_product_col.a_field list = function + | Select_one_product_col.V f -> [Any_field f] + | Return _ -> [] + | Map (t, _) -> to_a_field_list_col t + | Both (a, b) -> to_a_field_list_col a @ to_a_field_list_col b + in + let field_read_col : type a. a Select_one_product_col.field -> T.row -> int -> a = function + | Name -> fun row idx -> T.get_column_Text_nullable row idx + | Price -> fun row idx -> T.get_column_Decimal_nullable row idx + in + let rec read_col : type a. a Select_one_product_col.t -> T.row -> int -> a * int = function + | Select_one_product_col.V f -> fun row idx -> (field_read_col f row idx, idx + 1) + | Return x -> fun _row idx -> (x, idx) + | Map (t, f) -> fun row idx -> let (v, idx') = read_col t row idx in (f v, idx') + | Both (a, b) -> fun row idx -> let (va, i1) = read_col a row idx in let (vb, i2) = read_col b row i1 in ((va, vb), i2) + in + let set_params stmt = + let p = T.start_params stmt (1 + params_count_col col) in + set_col col p; + T.set_param_Int p id; + T.finish_params p + in + T.select_one_maybe db + ("SELECT " ^ (String.concat ", " (col |> to_a_field_list_col |> List.map (fun (Select_one_product_col.Any_field f) -> field_to_column_col f))) ^ " FROM products WHERE id = ? LIMIT 1") + set_params (fun row -> let (__sqlgg_r_col, __sqlgg_idx_after_col) = read_col col row 0 in (__sqlgg_r_col)) + + module Single = struct + let select_one_product db ~col ~id = + let rec params_count_col : type a. a Select_one_product_col.t -> int = function + | Select_one_product_col.V Name -> 0 diff --git a/test/cram/test_build_dynamic_select/dynamic_select.sql b/test/cram/test_build_dynamic_select/dynamic_select.sql new file mode 100644 index 00000000..6606f72b --- /dev/null +++ b/test/cram/test_build_dynamic_select/dynamic_select.sql @@ -0,0 +1,54 @@ +CREATE TABLE products ( + id INT PRIMARY KEY, + name TEXT, + price DECIMAL(10,2), + category TEXT, + stock INT +); + +-- Test 1: Basic dynamic select with select_one_maybe +-- [sqlgg] dynamic_select=true +-- @select_product +SELECT id, @col { Name { name } | Price { price } | Category { category } } FROM products WHERE id = @id; + +-- Test 2: Dynamic select with callback (multiple rows) +-- [sqlgg] dynamic_select=true +-- @list_products +SELECT id, @col { Name { name } | Price { price } } FROM products WHERE stock > @min_stock; + +-- Test 3: Multiple dynamic selects in one query +-- [sqlgg] dynamic_select=true +-- @multi_dynamic +SELECT @x { A { name } | B { category } }, @y { C { price } | D { stock } } FROM products WHERE id = @id; + +-- Test 4: Dynamic select with Verbatim branches +-- [sqlgg] dynamic_select=true +-- @with_verbatim +SELECT id, @col { Name { name } | Default { 'N/A' } | Price { price } } FROM products WHERE id = @id; + +-- Test 5: Dynamic select with parameter in branch +-- [sqlgg] dynamic_select=true +-- @with_param +SELECT id, @col { Static { name } | Dynamic { @custom_value :: Text } } FROM products WHERE id = @id; + +-- Test 6: Dynamic select at the start of SELECT list +-- [sqlgg] dynamic_select=true +-- @first_position +SELECT @col { Name { name } | Price { price } }, id, stock FROM products WHERE id = @id; + +-- Test 7: select_one (guaranteed single row) +-- [sqlgg] dynamic_select=true +-- @select_one_product +SELECT @col { Name { name } | Price { price } } FROM products WHERE id = @id LIMIT 1; + +-- Test 8: Dynamic select with module-wrapped column +CREATE TABLE products_wrapped ( + -- [sqlgg] module=Product_id + id INT PRIMARY KEY, + name TEXT, + price DECIMAL(10,2) +); + +-- [sqlgg] dynamic_select=true +-- @with_module +SELECT @col { Id { id } | Name { name } | Price { price } } FROM products_wrapped WHERE id = @id; diff --git a/test/cram/test_build_dynamic_select/product_id.ml b/test/cram/test_build_dynamic_select/product_id.ml new file mode 100644 index 00000000..28dcee7f --- /dev/null +++ b/test/cram/test_build_dynamic_select/product_id.ml @@ -0,0 +1,5 @@ +type t = int64 + +let get_column (x : int64) : t = x +let get_column_nullable (x : int64 option) : t option = x +let set_param (x : t) : int64 = x diff --git a/test/cram/test_build_dynamic_select/test_run.ml b/test/cram/test_build_dynamic_select/test_run.ml new file mode 100644 index 00000000..6a3c2dd8 --- /dev/null +++ b/test/cram/test_build_dynamic_select/test_run.ml @@ -0,0 +1,398 @@ +(* test_run.ml - Test dynamic select query generation *) + +open Printf + +module M (T: Sqlgg_traits.M with + type Types.Int.t = int64 and + type Types.Text.t = string and + type Types.Decimal.t = float) = struct + + module Sql = Output.Sqlgg(T) + + (* === Test 1: Basic select_one_maybe === *) + module Test1 = struct + open Sql.Select_product_col + + let single_field_name connection = + printf "[TEST 1.1] Single field: Name\n"; + Print_ocaml_impl.clear_mock_responses (); + Print_ocaml_impl.setup_select_one_response (Some ( + Print_ocaml_impl.make_mock_row [Print_ocaml_impl.mock_int 1L; Print_ocaml_impl.mock_text "Widget"] + )); + let _ = Sql.select_product connection ~col:name ~id:1L in + printf "[TEST 1.1] Completed\n\n" + + let single_field_price connection = + printf "[TEST 1.2] Single field: Price\n"; + Print_ocaml_impl.clear_mock_responses (); + Print_ocaml_impl.setup_select_one_response (Some ( + Print_ocaml_impl.make_mock_row [Print_ocaml_impl.mock_int 1L; Print_ocaml_impl.mock_float 99.99] + )); + let _ = Sql.select_product connection ~col:price ~id:2L in + printf "[TEST 1.2] Completed\n\n" + + let combined_name_and_price connection = + printf "[TEST 1.3] Combined fields: Name and Price using let+/and+\n"; + Print_ocaml_impl.clear_mock_responses (); + Print_ocaml_impl.setup_select_one_response (Some ( + Print_ocaml_impl.make_mock_row [ + Print_ocaml_impl.mock_int 1L; + Print_ocaml_impl.mock_text "Gadget"; + Print_ocaml_impl.mock_float 149.99 + ] + )); + let combined = + let+ n = name + and+ p = price in + (n, p) + in + let _ = Sql.select_product connection ~col:combined ~id:3L in + printf "[TEST 1.3] Completed\n\n" + + let three_fields connection = + printf "[TEST 1.4] Three fields: Name, Price, Category\n"; + Print_ocaml_impl.clear_mock_responses (); + Print_ocaml_impl.setup_select_one_response (Some ( + Print_ocaml_impl.make_mock_row [ + Print_ocaml_impl.mock_int 1L; + Print_ocaml_impl.mock_text "Phone"; + Print_ocaml_impl.mock_float 599.99; + Print_ocaml_impl.mock_text "Electronics" + ] + )); + let all_three = + let+ n = name + and+ p = price + and+ c = category in + (n, p, c) + in + let _ = Sql.select_product connection ~col:all_three ~id:4L in + printf "[TEST 1.4] Completed\n\n" + + let mapped_field connection = + printf "[TEST 1.5] Mapped field: Price with transformation\n"; + Print_ocaml_impl.clear_mock_responses (); + Print_ocaml_impl.setup_select_one_response (Some ( + Print_ocaml_impl.make_mock_row [Print_ocaml_impl.mock_int 1L; Print_ocaml_impl.mock_float 100.0] + )); + let doubled_price = + let+ p = price in + Option.map (fun x -> x *. 2.0) p + in + let _ = Sql.select_product connection ~col:doubled_price ~id:5L in + printf "[TEST 1.5] Completed\n\n" + + let with_return connection = + printf "[TEST 1.6] Return constructor (constant value)\n"; + Print_ocaml_impl.clear_mock_responses (); + Print_ocaml_impl.setup_select_one_response (Some ( + Print_ocaml_impl.make_mock_row [Print_ocaml_impl.mock_int 1L] + )); + let constant = return "constant_value" in + let _ = Sql.select_product connection ~col:constant ~id:6L in + printf "[TEST 1.6] Completed\n\n" + + let run connection = + single_field_name connection; + single_field_price connection; + combined_name_and_price connection; + three_fields connection; + mapped_field connection; + with_return connection + end + + (* === Test 2: select with callback (multiple rows) === *) + module Test2 = struct + open Sql.List_products_col + + let single_field connection = + printf "[TEST 2.1] List with single field: Name\n"; + Print_ocaml_impl.clear_mock_responses (); + Print_ocaml_impl.setup_select_response [ + Print_ocaml_impl.make_mock_row [Print_ocaml_impl.mock_int 1L; Print_ocaml_impl.mock_text "Widget"]; + Print_ocaml_impl.make_mock_row [Print_ocaml_impl.mock_int 2L; Print_ocaml_impl.mock_text "Gadget"]; + ]; + Sql.list_products connection ~col:name ~min_stock:10L (fun ~id ~col -> + printf " Row: id=%Ld, col=%s\n" id (match col with Some s -> s | None -> "NULL") + ); + printf "[TEST 2.1] Completed\n\n" + + let combined_fields connection = + printf "[TEST 2.2] List with combined fields: Name and Price\n"; + Print_ocaml_impl.clear_mock_responses (); + Print_ocaml_impl.setup_select_response [ + Print_ocaml_impl.make_mock_row [Print_ocaml_impl.mock_int 1L; Print_ocaml_impl.mock_text "Widget"; Print_ocaml_impl.mock_float 19.99]; + Print_ocaml_impl.make_mock_row [Print_ocaml_impl.mock_int 2L; Print_ocaml_impl.mock_text "Gadget"; Print_ocaml_impl.mock_float 29.99]; + ]; + let combined = + let+ n = name + and+ p = price in + (n, p) + in + Sql.list_products connection ~col:combined ~min_stock:5L (fun ~id ~col -> + let (n, p) = col in + printf " Row: id=%Ld, name=%s, price=%s\n" id + (match n with Some s -> s | None -> "NULL") + (match p with Some f -> sprintf "%.2f" f | None -> "NULL") + ); + printf "[TEST 2.2] Completed\n\n" + + let run connection = + single_field connection; + combined_fields connection + end + + (* === Test 3: Multiple dynamic selects === *) + module Test3 = struct + open Sql + + let two_dynamic_selects connection = + printf "[TEST 3.1] Two dynamic selects: x=A(name), y=C(price)\n"; + Print_ocaml_impl.clear_mock_responses (); + Print_ocaml_impl.setup_select_one_response (Some ( + Print_ocaml_impl.make_mock_row [ + Print_ocaml_impl.mock_text "Widget"; + Print_ocaml_impl.mock_float 99.99 + ] + )); + let _ = Sql.multi_dynamic connection + ~x:Multi_dynamic_x.a + ~y:Multi_dynamic_y.c + ~id:1L in + printf "[TEST 3.1] Completed\n\n" + + let combined_both connection = + printf "[TEST 3.2] Two dynamic selects with combinators\n"; + Print_ocaml_impl.clear_mock_responses (); + Print_ocaml_impl.setup_select_one_response (Some ( + Print_ocaml_impl.make_mock_row [ + Print_ocaml_impl.mock_text "Widget"; + Print_ocaml_impl.mock_text "Electronics"; + Print_ocaml_impl.mock_float 99.99; + Print_ocaml_impl.mock_int 50L + ] + )); + let x_combined = + let open Multi_dynamic_x in + let+ n = a + and+ c = b in + (n, c) + in + let y_combined = + let open Multi_dynamic_y in + let+ p = c + and+ s = d in + (p, s) + in + let _ = Sql.multi_dynamic connection ~x:x_combined ~y:y_combined ~id:2L in + printf "[TEST 3.2] Completed\n\n" + + let run connection = + two_dynamic_selects connection; + combined_both connection + end + + (* === Test 4: Verbatim branches === *) + module Test4 = struct + open Sql.With_verbatim_col + + let verbatim_branch connection = + printf "[TEST 4.1] Verbatim branch: Default\n"; + Print_ocaml_impl.clear_mock_responses (); + Print_ocaml_impl.setup_select_one_response (Some ( + Print_ocaml_impl.make_mock_row [Print_ocaml_impl.mock_int 1L; Print_ocaml_impl.mock_text "N/A"] + )); + let _ = Sql.with_verbatim connection ~col:default ~id:1L in + printf "[TEST 4.1] Completed\n\n" + + let regular_branch connection = + printf "[TEST 4.2] Regular branch after Verbatim: Name\n"; + Print_ocaml_impl.clear_mock_responses (); + Print_ocaml_impl.setup_select_one_response (Some ( + Print_ocaml_impl.make_mock_row [Print_ocaml_impl.mock_int 1L; Print_ocaml_impl.mock_text "Widget"] + )); + let _ = Sql.with_verbatim connection ~col:name ~id:2L in + printf "[TEST 4.2] Completed\n\n" + + let run connection = + verbatim_branch connection; + regular_branch connection + end + + (* === Test 5: Parameter in branch === *) + module Test5 = struct + open Sql.With_param_col + + let static_branch connection = + printf "[TEST 5.1] Static branch (no param)\n"; + Print_ocaml_impl.clear_mock_responses (); + Print_ocaml_impl.setup_select_one_response (Some ( + Print_ocaml_impl.make_mock_row [Print_ocaml_impl.mock_int 1L; Print_ocaml_impl.mock_text "Widget"] + )); + let _ = Sql.with_param connection ~col:static ~id:1L in + printf "[TEST 5.1] Completed\n\n" + + let dynamic_branch connection = + printf "[TEST 5.2] Dynamic branch (with param)\n"; + Print_ocaml_impl.clear_mock_responses (); + Print_ocaml_impl.setup_select_one_response (Some ( + Print_ocaml_impl.make_mock_row [Print_ocaml_impl.mock_int 1L; Print_ocaml_impl.mock_text "Custom Value"] + )); + let _ = Sql.with_param connection ~col:(dynamic "Custom Value") ~id:2L in + printf "[TEST 5.2] Completed\n\n" + + let run connection = + static_branch connection; + dynamic_branch connection + end + + (* === Test 6: Dynamic at first position === *) + module Test6 = struct + open Sql.First_position_col + + let first_position connection = + printf "[TEST 6.1] Dynamic select at first position\n"; + Print_ocaml_impl.clear_mock_responses (); + Print_ocaml_impl.setup_select_one_response (Some ( + Print_ocaml_impl.make_mock_row [ + Print_ocaml_impl.mock_text "Widget"; + Print_ocaml_impl.mock_int 1L; + Print_ocaml_impl.mock_int 100L + ] + )); + let _ = Sql.first_position connection ~col:name ~id:1L in + printf "[TEST 6.1] Completed\n\n" + + let first_combined connection = + printf "[TEST 6.2] Dynamic select at first position with combinator\n"; + Print_ocaml_impl.clear_mock_responses (); + Print_ocaml_impl.setup_select_one_response (Some ( + Print_ocaml_impl.make_mock_row [ + Print_ocaml_impl.mock_text "Widget"; + Print_ocaml_impl.mock_float 99.99; + Print_ocaml_impl.mock_int 1L; + Print_ocaml_impl.mock_int 100L + ] + )); + let combined = + let+ n = name + and+ p = price in + (n, p) + in + let _ = Sql.first_position connection ~col:combined ~id:2L in + printf "[TEST 6.2] Completed\n\n" + + let run connection = + first_position connection; + first_combined connection + end + + (* === Test 7: select_one (guaranteed row) === *) + module Test7 = struct + open Sql.Select_one_product_col + + let select_one_single connection = + printf "[TEST 7.1] select_one with single field\n"; + Print_ocaml_impl.clear_mock_responses (); + Print_ocaml_impl.setup_select_one_response (Some ( + Print_ocaml_impl.make_mock_row [Print_ocaml_impl.mock_text "Widget"] + )); + let _ = Sql.select_one_product connection ~col:name ~id:1L in + printf "[TEST 7.1] Completed\n\n" + + let select_one_combined connection = + printf "[TEST 7.2] select_one with combined fields\n"; + Print_ocaml_impl.clear_mock_responses (); + Print_ocaml_impl.setup_select_one_response (Some ( + Print_ocaml_impl.make_mock_row [ + Print_ocaml_impl.mock_text "Widget"; + Print_ocaml_impl.mock_float 99.99 + ] + )); + let combined = + let+ n = name + and+ p = price in + (n, p) + in + let _ = Sql.select_one_product connection ~col:combined ~id:2L in + printf "[TEST 7.2] Completed\n\n" + + let run connection = + select_one_single connection; + select_one_combined connection + end + + (* === Test 8: module-wrapped column === *) + module Test8 = struct + open Sql.With_module_col + + let with_module_id connection = + printf "[TEST 8.1] Module-wrapped column: Id\n"; + Print_ocaml_impl.clear_mock_responses (); + Print_ocaml_impl.setup_select_one_response (Some ( + Print_ocaml_impl.make_mock_row [Print_ocaml_impl.mock_int 42L] + )); + let _ = Sql.with_module connection ~col:id ~id:1L in + printf "[TEST 8.1] Completed\n\n" + + let with_module_name connection = + printf "[TEST 8.2] Module-wrapped: regular column Name\n"; + Print_ocaml_impl.clear_mock_responses (); + Print_ocaml_impl.setup_select_one_response (Some ( + Print_ocaml_impl.make_mock_row [Print_ocaml_impl.mock_text "Widget"] + )); + let _ = Sql.with_module connection ~col:name ~id:2L in + printf "[TEST 8.2] Completed\n\n" + + let run connection = + with_module_id connection; + with_module_name connection + end + + let run_all_tests connection = + printf "=== Starting Dynamic Select Tests ===\n\n"; + + try + printf "--- Test Group 1: Basic select_one_maybe ---\n"; + Test1.run connection; + + printf "--- Test Group 2: Select with callback ---\n"; + Test2.run connection; + + printf "--- Test Group 3: Multiple dynamic selects ---\n"; + Test3.run connection; + + printf "--- Test Group 4: Verbatim branches ---\n"; + Test4.run connection; + + printf "--- Test Group 5: Parameter in branch ---\n"; + Test5.run connection; + + printf "--- Test Group 6: Dynamic at first position ---\n"; + Test6.run connection; + + printf "--- Test Group 7: select_one ---\n"; + Test7.run connection; + + printf "--- Test Group 8: module-wrapped column ---\n"; + Test8.run connection; + + printf "=== All Dynamic Select Tests Passed ===\n" + with + | exn -> + printf "\n=== Test Failed with Exception: %s ===\n" (Printexc.to_string exn); + raise exn +end + +module Test = M(Print_ocaml_impl) + +let () = + let con = () in + + printf "Dynamic Select Query Generation Tests\n"; + printf "%s\n" (String.make 50 '='); + + Test.run_all_tests con; + + printf "\n%s\n" (String.make 50 '='); + printf "All tests executed successfully!\n" From ec6cfa4d5a0f30b05bf61da1033cf56a5ab6c472 Mon Sep 17 00:00:00 2001 From: Gleb Patsiia Date: Wed, 21 Jan 2026 20:14:29 +0000 Subject: [PATCH 2/2] wip --- lib/syntax.ml | 1 - src/gen_caml.ml | 217 ++++++++++++++++++++++-------------------------- 2 files changed, 99 insertions(+), 119 deletions(-) diff --git a/lib/syntax.ml b/lib/syntax.ml index ce02704a..27e2e7ce 100644 --- a/lib/syntax.ml +++ b/lib/syntax.ml @@ -809,7 +809,6 @@ and get_params_of_columns env = let get = function | All | AllOf _ -> [] | Expr (Choices (p, choices), _) when not env.is_subquery && !Config.dynamic_select -> - (* For DynamicSelect, get params from each branch separately *) [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)] diff --git a/src/gen_caml.ml b/src/gen_caml.ml index cead456e..5387ffe8 100644 --- a/src/gen_caml.ml +++ b/src/gen_caml.ml @@ -127,12 +127,9 @@ let enum_name = Printf.sprintf "Enum_%d" let get_enum_name ctors = ctors |> enum_get_hash |> Hashtbl.find enums_hash_tbl |> fst |> enum_name -(* DynamicSelect support *) - let field_name_of_param_id (p : Sql.param_id) = match p.label with Some s -> String.capitalize_ascii s | None -> "Field" -(* Generate pattern for match case on ctor *) let ctor_pattern = function | Sql.Simple (param_id, args) -> let field_name = field_name_of_param_id param_id in @@ -190,7 +187,6 @@ end let nullable_suffix attr = if is_attr_nullable attr then "_nullable" else "" -(* Format T.get_column call with given row variable and index expression *) let format_get_column ~row ~idx attr = let null_suffix = nullable_suffix attr in let format_t_get_column type_name = @@ -225,6 +221,8 @@ let schema_to_attrs schema = | Syntax.Dynamic _ -> None ) schema +let format_labeled_param name value = sprintf "~%s:%s" name value + let output_schema_binder_labeled _ schema = let attrs = schema_to_attrs schema in let name = "invoke_callback" in @@ -233,7 +231,7 @@ let output_schema_binder_labeled _ schema = let values = List.mapi get_column attrs in indented (fun () -> output "callback"; - indented (fun () -> List.iter2 (output "~%s:%s") args values)); + indented (fun () -> List.iter2 (fun arg value -> output "%s" (format_labeled_param arg value)) args values)); output "in"; name @@ -272,6 +270,36 @@ let should_generate_for_style style stmt = | `Single -> (match stmt.kind, stmt.schema with | Stmt.Select (`One | `Zero_one), _ :: _ -> true | _ -> false) | `Direct -> true +let gen_func_signature ~single_needs_callback style stmt index = + let name = choose_name stmt.props stmt.kind index |> String.uncapitalize_ascii in + let subst = Props.get_all stmt.props "subst" in + let inputs = (subst @ names_of_vars stmt.vars) |> List.map (fun v -> sprintf "~%s" v) |> inline_values in + let needs_callback_param = match style with + | `List | `Fold -> true + | `Single -> single_needs_callback + | `Direct -> is_callback stmt + in + let needs_acc_param = style = `Fold in + let all_inputs = inputs ^ (if needs_callback_param then " callback" else "") ^ (if needs_acc_param then " acc" else "") in + output "let %s db %s =" name all_inputs; + inc_indent (); + subst + +let output_r_acc_init = function + | `Fold -> output "let r_acc = ref acc in" + | `List -> output "let r_acc = ref [] in" + | `Direct | `Single -> () + +let output_r_acc_return = function + | `Fold -> output "(fun () -> IO.return !r_acc)" + | `List -> output "(fun () -> IO.return (List.rev !r_acc))" + | `Direct | `Single -> () + +let complete_func style = + output_r_acc_return style; + dec_indent (); + empty_line () + let make_variant_name i name ~is_poly = let prefix = if is_poly then "`" else "" in prefix ^ match name with @@ -465,9 +493,7 @@ let set_var index var = execute_generators all_generators; output "end;" ) - | DynamicSelect _ -> - (* DynamicSelect params are handled separately in generate_stmt_with_dynamic *) - None + | DynamicSelect _ -> None in Option.may (fun g -> g ()) (aux index var) @@ -687,22 +713,17 @@ let make_sql l = Buffer.add_string b ")"; Buffer.contents b -(* Generate stmt with multiple dynamic selects *) +type callback_build_state = { + bindings: string list; + reads: string list; + static_idx: int; + attr_n: int; + idx_expr: string option; +} + let generate_stmt_with_dynamic style index stmt dynamic_infos = if not (should_generate_for_style style stmt) then () else - let name = choose_name stmt.props stmt.kind index |> String.uncapitalize_ascii in - let subst = Props.get_all stmt.props "subst" in - let inputs = (subst @ names_of_vars stmt.vars) |> List.map (fun v -> sprintf "~%s" v) |> inline_values in - let needs_callback_param = match style with - | `List | `Fold -> true - | `Single -> is_callback stmt - | `Direct -> is_callback stmt - in - let needs_acc_param = style = `Fold in - let all_inputs = inputs ^ (if needs_callback_param then " callback" else "") ^ (if needs_acc_param then " acc" else "") in - - output "let %s db %s =" name all_inputs; - inc_indent (); + let _subst = gen_func_signature ~single_needs_callback:(is_callback stmt) style stmt index in let sql_pieces = get_sql stmt in @@ -802,7 +823,6 @@ let generate_stmt_with_dynamic style index stmt dynamic_infos = output "in" ) dynamic_infos; - (* Generate set_params *) let other_vars = List.filter (function Sql.DynamicSelect _ -> false | _ -> true) stmt.vars in let static_count = eval_count_params other_vars in let dynamic_counts = dynamic_infos |> List.map (fun di -> @@ -848,12 +868,8 @@ let generate_stmt_with_dynamic style index stmt dynamic_infos = let sql_parts = build_parts [] false sql_pieces in let sql_expr = String.concat " ^ " sql_parts in - if style = `Fold then output "let r_acc = ref acc in"; - if style = `List then output "let r_acc = ref [] in"; - - let func = select_func_of_kind stmt.kind in + output_r_acc_init style; - (* Split schema into segments by Dynamic *) let rec split_schema_multi acc current = function | [] -> List.rev ((List.rev current, None) :: acc) | Syntax.Dynamic (pid, _) :: rest -> @@ -864,62 +880,45 @@ let generate_stmt_with_dynamic style index stmt dynamic_infos = in let schema_segments = split_schema_multi [] [] stmt.schema in - (* Build callback body with chained reads *) - (* For Fold/List styles, we always need callback pattern. For Direct/Single, check is_callback *) let needs_callback = match style with | `Fold | `List -> true | `Direct | `Single -> is_callback stmt in + let format_param = if needs_callback then format_labeled_param else (fun _ v -> v) in + let format_result params = + if needs_callback then sprintf "callback\n %s" (String.concat "\n " params) + else sprintf "(%s)" (String.concat ", " params) + in let build_callback_body () = - let buf = Buffer.create 256 in - let static_idx = ref 0 in - let current_idx_expr = ref None in (* None means use static_idx, Some s means use that expression *) - let reads = ref [] in - let attr_counter = ref 0 in - - List.iter (fun (attrs, dyn_opt) -> - (* Read static attrs in this segment *) - List.iteri (fun i attr -> - let col_idx_expr = match !current_idx_expr with - | None -> string_of_int !static_idx - | Some base_var -> - if i = 0 then base_var - else sprintf "(%s + %d)" base_var i - in - let value_expr = sprintf "(%s)" (format_get_column ~row:"row" ~idx:col_idx_expr attr) in - if needs_callback then - reads := sprintf "~%s:%s" (name_of attr !attr_counter) value_expr :: !reads - else - reads := value_expr :: !reads; - incr static_idx; - incr attr_counter - ) attrs; - - (* Read dynamic part if present *) - match dyn_opt with - | Some param_name -> - let read_var = sprintf "__sqlgg_r_%s" param_name in - let next_idx_var = sprintf "__sqlgg_idx_after_%s" param_name in - let start_idx = match !current_idx_expr with - | None -> string_of_int !static_idx - | Some base_var -> sprintf "(%s + %d)" base_var (List.length attrs) - in - Buffer.add_string buf (sprintf "let (%s, %s) = read_%s %s row %s in " - read_var next_idx_var param_name param_name start_idx); - if needs_callback then - reads := sprintf "~%s:%s" param_name read_var :: !reads - else - reads := read_var :: !reads; - current_idx_expr := Some next_idx_var - | None -> () - ) schema_segments; - - let params = List.rev !reads in - if needs_callback then - Buffer.add_string buf (sprintf "callback\n %s" (String.concat "\n " params)) - else - Buffer.add_string buf (sprintf "(%s)" (String.concat ", " params)); - Buffer.contents buf + let col_idx_at ~base ~offset = match base with + | None -> string_of_int offset + | Some var when offset = 0 -> var + | Some var -> sprintf "(%s + %d)" var offset + in + let process_attrs st attrs = + List.fold_left (fun (st, i) attr -> + let col_idx = col_idx_at ~base:st.idx_expr ~offset:(st.static_idx + i) in + let value = sprintf "(%s)" (format_get_column ~row:"row" ~idx:col_idx attr) in + let param = format_param (name_of attr st.attr_n) value in + ({ st with reads = param :: st.reads; attr_n = st.attr_n + 1 }, i + 1) + ) (st, 0) attrs |> fst + in + let process_dynamic st param_name = + let read_var = sprintf "__sqlgg_r_%s" param_name in + let next_var = sprintf "__sqlgg_idx_after_%s" param_name in + let start = col_idx_at ~base:st.idx_expr ~offset:st.static_idx in + let binding = sprintf "let (%s, %s) = read_%s %s row %s in " read_var next_var param_name param_name start in + { bindings = binding :: st.bindings; + reads = format_param param_name read_var :: st.reads; + static_idx = st.static_idx; attr_n = st.attr_n + 1; idx_expr = Some next_var } + in + let process_segment st (attrs, dyn_opt) = + let st = { (process_attrs st attrs) with static_idx = st.static_idx + List.length attrs } in + match dyn_opt with None -> st | Some name -> process_dynamic st name + in + let init = { bindings = []; reads = []; static_idx = 0; attr_n = 0; idx_expr = None } in + let final = List.fold_left process_segment init schema_segments in + String.concat "" (List.rev final.bindings) ^ format_result (List.rev final.reads) in let callback_body = build_callback_body () in @@ -931,24 +930,14 @@ let generate_stmt_with_dynamic style index stmt dynamic_infos = | `Direct | `Single -> "", "", sprintf "(fun row -> %s)" callback_body in - output "%sT.%s db" bind_start func; + output "%sT.%s db" bind_start (select_func_of_kind stmt.kind); output " (%s)" sql_expr; output " set_params %s%s" full_callback bind_end; - if style = `Fold then output "(fun () -> IO.return !r_acc)"; - if style = `List then output "(fun () -> IO.return (List.rev !r_acc))"; - dec_indent (); - empty_line () + complete_func style let generate_stmt style index stmt = - let name = choose_name stmt.props stmt.kind index |> String.uncapitalize_ascii in - let subst = Props.get_all stmt.props "subst" in - let inputs = (subst @ names_of_vars stmt.vars) |> List.map (fun v -> sprintf "~%s" v) |> inline_values in - if should_generate_for_style style stmt then begin - let needs_callback_param = match style with | `List | `Single -> true | _ -> is_callback stmt in - let needs_acc_param = style = `Fold in - let all_inputs = inputs ^ (if needs_callback_param then " callback" else "") ^ (if needs_acc_param then " acc" else "") in - output "let %s db %s =" name all_inputs; - inc_indent (); + if not (should_generate_for_style style stmt) then () else + let subst = gen_func_signature ~single_needs_callback:true style stmt index in let sql = make_sql @@ get_sql stmt in let sql = match subst with | [] -> sql @@ -966,19 +955,18 @@ let generate_stmt style index stmt = output "in"; "__sqlgg_sql" in - let (func,callback) = - match style with - | `Single -> - (match stmt.schema with - | [] -> ("execute", "") - | _ -> - let func = select_func_of_kind stmt.kind in - (func, output_schema_binder_labeled index stmt.schema)) - | _ -> output_schema_binder index stmt.schema stmt.kind + let (func, callback) = + match stmt.schema with + | [] -> "execute", "" + | _ -> + let func = select_func_of_kind stmt.kind in + match style, stmt.kind with + | `Single, _ -> func, output_schema_binder_labeled index stmt.schema + | _, Stmt.Select (`Zero_one | `One) -> func, output_select1_cb index stmt.schema + | _ -> func, output_schema_binder_labeled index stmt.schema in let params_binder_name = output_params_binder index stmt.vars in - if style = `Fold then output "let r_acc = ref acc in"; - if style = `List then output "let r_acc = ref [] in"; + output_r_acc_init style; let (bind, callback) = match style with | `Fold -> "IO.(>>=) (", sprintf "(fun x -> r_acc := %s x !r_acc))" callback @@ -1002,11 +990,7 @@ let generate_stmt style index stmt = | Some label -> sprintf {|( match %s with [] -> IO.return { T.affected_rows = 0L; insert_id = None } | _ :: _ -> %s)|} label exec in output "%s%s" bind exec; - if style = `Fold then output "(fun () -> IO.return !r_acc)"; - if style = `List then output "(fun () -> IO.return (List.rev !r_acc))"; - dec_indent (); - empty_line () - end + complete_func style let sanitize_to_variant_name s = let normalized = @@ -1039,14 +1023,14 @@ let generate_enum_modules stmts = ) schemas in + let schema_columns_to_enums schema_cols = + let attr_enum attr = + if meta_has_module attr.meta then [] else option_list (get_enum attr.domain) + in List.concat_map (function - | Syntax.Attr attr -> - if meta_has_module attr.meta then [] else get_enum attr.domain |> option_list - | Syntax.Dynamic (_, fields) -> - List.concat_map (fun (_, attr) -> - if meta_has_module attr.meta then [] else get_enum attr.domain |> option_list - ) fields + | Syntax.Attr attr -> attr_enum attr + | Syntax.Dynamic (_, fields) -> List.concat_map (fun (_, attr) -> attr_enum attr) fields ) schema_cols in @@ -1105,7 +1089,6 @@ let generate_enum_modules stmts = () ) -(* Extract all DynamicSelect infos from stmt *) let get_all_dynamic_select_infos index stmt = let query_name = Gen.choose_name stmt.Gen.props stmt.Gen.kind index in let ds_from_vars = stmt.Gen.vars |> List.filter_map (function Sql.DynamicSelect (param_id, ctors) -> Some (param_id, ctors) | _ -> None) in @@ -1116,7 +1099,6 @@ let get_all_dynamic_select_infos index stmt = { param_id; module_name; param_name; ctors; schema_fields } ) (List.combine ds_from_vars ds_from_schema) -(* Generate DynamicSelect GADT modules for all stmts that need them *) let generate_dynamic_select_modules stmts = List.iteri (fun index stmt -> get_all_dynamic_select_infos index stmt |> List.iter (fun di -> @@ -1169,7 +1151,6 @@ let generate_dynamic_select_modules stmts = ) ) stmts -(* Wrapper to generate stmt with or without DynamicSelect *) let generate_stmt_wrapper style index stmt = let dynamic_infos = get_all_dynamic_select_infos index stmt in match dynamic_infos with