From 78bf1b7a9203dd4d5bcee84725f39a0f1af6ca26 Mon Sep 17 00:00:00 2001 From: ygrek Date: Fri, 24 Nov 2023 18:22:52 -0500 Subject: [PATCH] track nullability (generic) ref #5 #76 --- TODO | 1 + lib/sql.ml | 164 +++++++++++++++++++++++++--------------- lib/sql_parser.mly | 62 ++++++++------- lib/syntax.ml | 92 +++++++++++++--------- src/gen.ml | 4 +- src/gen_caml.ml | 8 +- src/gen_csharp.ml | 5 +- src/gen_cxx.ml | 2 +- src/gen_java.ml | 5 +- src/gen_xml.ml | 2 +- src/test.ml | 13 ++-- test/null.sql | 27 ++++++- test/out/inargument.xml | 4 +- test/out/misc.xml | 6 +- test/out/multidel.xml | 16 ++-- test/out/null.xml | 41 ++++++++-- test/out/subquery.xml | 2 +- 17 files changed, 288 insertions(+), 166 deletions(-) diff --git a/TODO b/TODO index a82779f..dfdc3c6 100644 --- a/TODO +++ b/TODO @@ -1,3 +1,4 @@ +* WHERE IS NOT NULL influence type * native-type annotations in queries * allow to parametrize SQL syntax itself (ORDER BY ASC|DESC) : unsafe/enumeration/option params * ocaml ppx syntax extension for inline sql diff --git a/lib/sql.ml b/lib/sql.ml index 8b8660a..3724604 100644 --- a/lib/sql.ml +++ b/lib/sql.ml @@ -6,7 +6,7 @@ open Prelude module Type = struct - type t = + type kind = | Unit of [`Interval] | Int | Text @@ -16,19 +16,37 @@ struct | Datetime | Decimal | Any - [@@deriving show {with_path=false}] + [@@deriving eq, show{with_path=false}] - let to_string = show + type nullability = + | Nullable (** can be NULL *) + | Strict (** cannot be NULL *) + | Depends (** unknown, to be determined *) + [@@deriving eq, show{with_path=false}] - let matches x y = - match x,y with - | Any, _ | _, Any -> true - | _ -> x = y + type t = { t : kind; nullability : nullability; }[@@deriving eq, show{with_path=false}] + + let nullability nullability = fun t -> { t; nullability } + let strict = nullability Strict + let depends = nullability Depends + let nullable = nullability Nullable + + let (=) : t -> t -> bool = equal + + let show { t; nullability; } = show_kind t ^ (match nullability with Nullable -> "?" | Depends -> "??" | Strict -> "") + let _ = pp + let pp pf t = Format.pp_print_string pf (show t) - let is_unit = function Unit _ -> true | _ -> false + let type_name t = show_kind t.t - let order x y = - if x = y then + let is_any { t; nullability = _ } = equal_kind t Any + + let matches x y = is_any x || is_any y || x = y + + let is_unit = function { t = Unit _; _ } -> true | _ -> false + + let order_kind x y = + if equal_kind x y then `Equal else match x,y with @@ -41,28 +59,50 @@ struct | Text, Datetime | Datetime, Text -> `Order (Datetime,Text) | _ -> `No - let common_type f x y = - match order x y with - | `Equal -> Some x - | `Order p -> Some (f p) - | `No -> None - - let common_supertype = common_type snd - let common_subtype = common_type fst - let common_type x y = Option.is_some @@ common_subtype x y + let order_nullability x y = + match x,y with + | Depends, Depends -> `Equal Depends + | Nullable, Nullable -> `Equal Nullable + | Strict, Strict -> `Equal Strict + | Depends, n + | n, Depends -> `Equal n (* Order ? *) + | Strict, Nullable -> `Strict_Nullable + | Nullable, Strict -> `Nullable_Strict + + let common_nullability = List.fold_left (fun acc t -> + match acc, t.nullability with + | _, Nullable + | Nullable, _ -> Nullable + | _, Strict + | Strict, _ -> Strict + | Depends, Depends -> Depends + ) Depends + + let common_nullability l = match common_nullability l with Depends -> Strict | n -> n + let undepend t nullability = if equal_nullability t.nullability Depends then { t with nullability } else t + + let common_type x y = + match order_nullability x.nullability y.nullability, order_kind x.t y.t with + | _, `No -> None + | `Equal nullability, `Order (t,_) -> Some {t; nullability} + | `Equal _nullability, `Equal -> Some x + | (`Nullable_Strict|`Strict_Nullable), `Equal -> Some (nullable x.t) + | (`Nullable_Strict|`Strict_Nullable), `Order (sub,_) -> Some (nullable sub) + + let has_common_type x y = Option.is_some @@ common_type x y type tyvar = Typ of t | Var of int - let string_of_tyvar = function Typ t -> to_string t | Var i -> sprintf "'%c" (Char.chr @@ Char.code 'a' + i) + let string_of_tyvar = function Typ t -> show t | Var i -> sprintf "'%c" (Char.chr @@ Char.code 'a' + i) type func = | Group of t (* _ -> t *) | Agg (* 'a -> 'a *) | Multi of tyvar * tyvar (* 'a -> ... -> 'a -> 'b *) - | Ret of t (* _ -> t *) (* TODO eliminate *) + | Ret of kind (* _ -> t *) (* TODO eliminate *) | F of tyvar * tyvar list let monomorphic ret args = F (Typ ret, List.map (fun t -> Typ t) args) - let fixed = monomorphic + let fixed ret args = monomorphic (depends ret) (List.map depends args) let identity = F (Var 0, [Var 0]) @@ -70,8 +110,8 @@ struct let open Format in function | Agg -> fprintf pp "|'a| -> 'a" - | Group ret -> fprintf pp "|_| -> %s" (to_string ret) - | Ret ret -> fprintf pp "_ -> %s" (to_string ret) + | Group ret -> fprintf pp "|_| -> %s" (show ret) + | Ret ret -> fprintf pp "_ -> %s" (show_kind ret) | F (ret, args) -> fprintf pp "%s -> %s" (String.concat " -> " @@ List.map string_of_tyvar args) (string_of_tyvar ret) | Multi (ret, each_arg) -> fprintf pp "{ %s }+ -> %s" (string_of_tyvar each_arg) (string_of_tyvar ret) @@ -155,7 +195,7 @@ struct let sub l a = List.filter (fun x -> not (List.mem x a)) l - let to_string v = v |> List.map (fun attr -> sprintf "%s %s" (Type.to_string attr.domain) attr.name) |> + let to_string v = v |> List.map (fun attr -> sprintf "%s %s" (Type.show attr.domain) attr.name) |> String.concat ", " |> sprintf "[%s]" let names t = t |> List.map (fun attr -> attr.name) |> String.concat "," |> sprintf "[%s]" @@ -176,14 +216,13 @@ struct common @ sub t1 common @ sub t2 common let check_types t1 t2 = - List.iter2 (fun a1 a2 -> - match a1.domain, a2.domain with - | Type.Any, _ - | _, Type.Any -> () - | x, y when x = y -> () - | _ -> raise (Error (t1, sprintf "Atributes do not match : %s of type %s and %s of type %s" - a1.name (Type.to_string a1.domain) - a2.name (Type.to_string a2.domain)))) t1 t2 + List.iter2 begin fun a1 a2 -> + match Type.matches a1.domain a2.domain with + | true -> () + | false -> raise (Error (t1, sprintf "Atributes do not match : %s of type %s and %s of type %s" + a1.name (Type.show a1.domain) + a2.name (Type.show a2.domain))) + end t1 t2 let check_types t1 t2 = try check_types t1 t2 with @@ -231,7 +270,7 @@ type table = table_name * schema [@@deriving show] let print_table out (name,schema) = IO.write_line out (show_table_name name); schema |> List.iter begin fun {name;domain;extra} -> - IO.printf out "%10s %s %s\n" (Type.to_string domain) name (Constraints.show extra) + IO.printf out "%10s %s %s\n" (Type.show domain) name (Constraints.show extra) end; IO.write_line out "" @@ -335,7 +374,7 @@ type stmt = | Update of table_name * assignments * expr option * order * param list (* where, order, limit *) | UpdateMulti of source list * assignments * expr option | Select of select_full -| CreateRoutine of string * Type.t option * (string * Type.t * expr option) list +| CreateRoutine of string * Type.kind option * (string * Type.kind * expr option) list (* open Schema @@ -375,7 +414,7 @@ let exclude narg name = add_ (Some narg) None name let add_multi typ name = add_ None (Some typ) name let add narg typ name = add_ (Some narg) (Some typ) name -let sponge = Type.(Multi (Typ Any, Typ Any)) +let sponge = let open Type in let any = depends Any in Multi (Typ any, Typ any) let lookup name narg = let name = String.lowercase_ascii name in @@ -402,33 +441,38 @@ let () = let open Type in let open Function in let (||>) x f = List.iter f x in - "count" |> add 0 (Group Int); (* count( * ) - asterisk is treated as no parameters in parser *) - "count" |> add 1 (Group Int); - "avg" |> add 1 (Group Float); + let int = strict Int in + let float = strict Float in + let text = strict Text in + let datetime = strict Datetime in + "count" |> add 0 (Group int); (* count( * ) - asterisk is treated as no parameters in parser *) + "count" |> add 1 (Group int); + "avg" |> add 1 (Group float); ["max";"min";"sum"] ||> add 1 Agg; ["max";"min"] ||> multi_polymorphic; (* sqlite3 *) - ["lower";"upper";"unhex";"md5";"sha";"sha1";"sha2"] ||> monomorphic Text [Text]; - "hex" |> monomorphic Text [Int]; - "length" |> monomorphic Int [Text]; - ["random"] ||> monomorphic Int []; - "floor" |> monomorphic Int [Float]; - ["nullif";"ifnull"] ||> add 2 (F (Var 0, [Var 0; Var 0])); + ["lower";"upper";"unhex";"md5";"sha";"sha1";"sha2"] ||> monomorphic text [text]; + "hex" |> monomorphic text [int]; + "length" |> monomorphic int [text]; + ["random"] ||> monomorphic int []; + "floor" |> monomorphic int [float]; + "nullif" |> add 2 (F (Var 0 (* TODO nullable *), [Var 0; Var 0])); + "ifnull" |> add 2 (F (Var 0, [Var 1; Var 0])); ["least";"greatest";"coalesce"] ||> multi_polymorphic; "strftime" |> exclude 1; (* requires at least 2 arguments *) - ["concat";"concat_ws";"strftime"] ||> multi ~ret:(Typ Text) (Typ Text); - "date" |> monomorphic Datetime [Datetime]; - "time" |> monomorphic Text [Datetime]; - "julianday" |> multi ~ret:(Typ Float) (Typ Text); - "from_unixtime" |> monomorphic Datetime [Int]; - "from_unixtime" |> monomorphic Text [Int;Text]; - ["pow"; "power"] ||> monomorphic Float [Float;Int]; - "unix_timestamp" |> monomorphic Int []; - "unix_timestamp" |> monomorphic Int [Datetime]; - ["timestampdiff";"timestampadd"] ||> monomorphic Int [Unit `Interval;Datetime;Datetime]; + ["concat";"concat_ws";"strftime"] ||> multi ~ret:(Typ text) (Typ text); + "date" |> monomorphic datetime [datetime]; + "time" |> monomorphic text [datetime]; + "julianday" |> multi ~ret:(Typ float) (Typ text); + "from_unixtime" |> monomorphic datetime [int]; + "from_unixtime" |> monomorphic text [int;text]; + ["pow"; "power"] ||> monomorphic float [float;int]; + "unix_timestamp" |> monomorphic int []; + "unix_timestamp" |> monomorphic int [datetime]; + ["timestampdiff";"timestampadd"] ||> monomorphic int [strict @@ Unit `Interval;datetime;datetime]; "any_value" |> add 1 (F (Var 0,[Var 0])); (* 'a -> 'a but not aggregate *) - "substring" |> monomorphic Text [Text; Int]; - "substring" |> monomorphic Text [Text; Int; Int]; - "substring_index" |> monomorphic Text [Text; Text; Int]; - "last_insert_id" |> monomorphic Int []; - "last_insert_id" |> monomorphic Int [Int]; + "substring" |> monomorphic text [text; int]; + "substring" |> monomorphic text [text; int; int]; + "substring_index" |> monomorphic text [text; text; int]; + "last_insert_id" |> monomorphic int []; + "last_insert_id" |> monomorphic int [int]; () diff --git a/lib/sql_parser.mly b/lib/sql_parser.mly index 41a14bf..9bb7647 100644 --- a/lib/sql_parser.mly +++ b/lib/sql_parser.mly @@ -13,8 +13,8 @@ let make_limit l = let param = function | _, `Const _ -> None - | x, `Param { label=None; pos } -> Some (new_param { label = Some (match x with `Limit -> "limit" | `Offset -> "offset"); pos } Int) - | _, `Param id -> Some (new_param id Int) + | x, `Param { label=None; pos } -> Some (new_param { label = Some (match x with `Limit -> "limit" | `Offset -> "offset"); pos } (strict Int)) + | _, `Param id -> Some (new_param id (strict Int)) in List.filter_map param l, List.mem (`Limit,`Const 1) l @@ -297,7 +297,12 @@ alter_pos: AFTER col=IDENT { `After col } | { `Default } drop_behavior: CASCADE | RESTRICT { } -column_def: name=IDENT t=sql_type? extra=column_def_extra* { make_attribute name (Option.default Int t) (Constraints.of_list @@ List.filter_map identity extra) } +column_def: name=IDENT t=sql_type? extra=column_def_extra* + { + let extra = Constraints.of_list @@ List.filter_map identity extra in + let t = { t = Option.default Int t; nullability = if Constraints.mem Null extra then Nullable else Strict } in + make_attribute name t extra + } column_def1: c=column_def { `Attr c } | pair(CONSTRAINT,IDENT?)? l=table_constraint_1 index_options { `Constraint l } @@ -332,7 +337,7 @@ column_def_extra: PRIMARY? KEY { Some PrimaryKey } | AUTOINCREMENT { Some Autoincrement } | on_conflict { None } | CHECK LPAREN expr RPAREN { None } - | DEFAULT e=default_value { if e = Value Any then Some Null else None } (* FIXME check type with column *) + | DEFAULT e=default_value { match e with Value { t = Any; nullability = _ } -> Some Null | _ -> None } (* FIXME check type with column *) | COLLATE IDENT { None } | pair(GENERATED,ALWAYS)? AS LPAREN expr RPAREN either(VIRTUAL,STORED)? { None } (* FIXME params and typing ignored *) @@ -360,7 +365,7 @@ expr: | e1=expr NUM_DIV_OP e2=expr %prec PLUS { Fun ((Ret Float),[e1;e2]) } | e1=expr DIV e2=expr %prec PLUS { Fun ((Ret Int),[e1;e2]) } | e1=expr boolean_bin_op e2=expr %prec AND { Fun ((fixed Bool [Bool;Bool]),[e1;e2]) } - | e1=expr comparison_op anyall? e2=expr %prec EQUAL { poly Bool [e1;e2] } + | e1=expr comparison_op anyall? e2=expr %prec EQUAL { poly (depends Bool) [e1;e2] } | e1=expr CONCAT_OP e2=expr { Fun ((fixed Text [Text;Text]),[e1;e2]) } | e=like_expr esc=escape? { @@ -376,16 +381,16 @@ expr: | VALUES LPAREN n=IDENT RPAREN { Inserted n } | v=literal_value | v=datetime_value { v } | v=interval_unit { v } - | e1=expr mnot(IN) l=sequence(expr) { poly Bool (e1::l) } - | e1=expr mnot(IN) LPAREN select=select_stmt RPAREN { poly Bool [e1; SelectExpr (select, `AsValue)] } + | e1=expr mnot(IN) l=sequence(expr) { poly (depends Bool) (e1::l) } + | e1=expr mnot(IN) LPAREN select=select_stmt RPAREN { poly (depends Bool) [e1; SelectExpr (select, `AsValue)] } | e1=expr IN table=table_name { Tables.check table; e1 } | e1=expr k=in_or_not_in p=PARAM { - let e = poly Bool [ e1; Inparam (new_param p Any) ] in + let e = poly (depends Bool) [ e1; Inparam (new_param p (depends Any)) ] in InChoice ({ label = p.label; pos = ($startofs, $endofs) }, k, e ) } | LPAREN select=select_stmt RPAREN { SelectExpr (select, `AsValue) } - | p=PARAM { Param (new_param p Any) } + | p=PARAM { Param (new_param p (depends Any)) } | p=PARAM parser_state_ident LCURLY l=choices c2=RCURLY { let { label; pos=(p1,_p2) } = p in Choices ({ label; pos = (p1,c2+1)},l) } | SUBSTRING LPAREN s=expr FROM p=expr FOR n=expr RPAREN | SUBSTRING LPAREN s=expr COMMA p=expr COMMA n=expr RPAREN { Fun (Function.lookup "substring" 3, [s;p;n]) } @@ -397,22 +402,22 @@ expr: | CONVERT LPAREN e=expr COMMA t=sql_type RPAREN | CAST LPAREN e=expr AS t=sql_type RPAREN { Fun (Ret t, [e]) } | f=IDENT LPAREN p=func_params RPAREN { Fun (Function.lookup f (List.length p), p) } - | e=expr IS NOT? NULL { Fun (Ret Bool, [e]) } - | e1=expr IS NOT? distinct_from? e2=expr { poly Bool [e1;e2] } - | e=expr mnot(BETWEEN) a=expr AND b=expr { poly Bool [e;a;b] } - | mnot(EXISTS) LPAREN select=select_stmt RPAREN { Fun (F (Typ Bool, [Typ Any]),[SelectExpr (select,`Exists)]) } + | e=expr IS NOT? NULL { poly (strict Bool) [e] } + | e1=expr IS NOT? distinct_from? e2=expr { poly (strict Bool) [e1;e2] } + | e=expr mnot(BETWEEN) a=expr AND b=expr { poly (depends Bool) [e;a;b] } + | mnot(EXISTS) LPAREN select=select_stmt RPAREN { Fun (F (Typ (strict Bool), [Typ (depends Any)]),[SelectExpr (select,`Exists)]) } | CASE e1=expr? branches=nonempty_list(case_branch) e2=preceded(ELSE,expr)? END (* FIXME typing *) { let t_args = match e1 with - | None -> (List.flatten @@ List.map (fun _ -> [Typ Bool; Var 1]) branches) + | None -> (List.flatten @@ List.map (fun _ -> [Typ (depends Bool); Var 1]) branches) | Some _ -> [Var 0] @ (List.flatten @@ List.map (fun _ -> [Var 0; Var 1]) branches) in let t_args = t_args @ maybe (fun _ -> Var 1) e2 in let v_args = option_to_list e1 @ List.flatten branches @ option_to_list e2 in Fun (F (Var 1, t_args), v_args) } - | IF LPAREN e1=expr COMMA e2=expr COMMA e3=expr RPAREN { Fun (F (Var 0, [Typ Bool;Var 0;Var 0]), [e1;e2;e3]) } + | IF LPAREN e1=expr COMMA e2=expr COMMA e3=expr RPAREN { Fun (F (Var 0, [Typ (depends Bool);Var 0;Var 0]), [e1;e2;e3]) } | e=window_function OVER window_spec { e } (* https://dev.mysql.com/doc/refman/8.0/en/window-functions-usage.html *) @@ -443,24 +448,27 @@ choice_body: c1=LCURLY e=expr c2=RCURLY { (c1,Some e,c2) } choice: parser_state_normal label=IDENT? e=choice_body? { let (c1,e,c2) = Option.default (0,None,0) e in ({ label; pos = (c1+1,c2) },e) } choices: separated_nonempty_list(pair(parser_state_ident,NUM_BIT_OR),choice) { $1 } -datetime_value: | DATETIME_FUNC | DATETIME_FUNC LPAREN INTEGER? RPAREN { Value Datetime } +datetime_value: | DATETIME_FUNC | DATETIME_FUNC LPAREN INTEGER? RPAREN { Value (strict Datetime) } -literal_value: - | TEXT collate? { Value Text } - | BLOB collate? { Value Blob } - | INTEGER { Value Int } - | FLOAT { Value Float } +strict_value: + | TEXT collate? { Text } + | BLOB collate? { Blob } + | INTEGER { Int } + | FLOAT { Float } | TRUE - | FALSE { Value Bool } + | FALSE { Bool } | DATE TEXT | TIME TEXT - | TIMESTAMP TEXT { Value Datetime } - | NULL { Value Any } (* he he *) + | TIMESTAMP TEXT { Datetime } + +literal_value: + | strict_value { Value (strict $1) } + | NULL { Value (nullable Any) } (* he he *) single_literal_value: | literal_value { $1 } - | MINUS INTEGER { Value Int } - | MINUS FLOAT { Value Float } + | MINUS INTEGER { Value (strict Int) } + | MINUS FLOAT { Value (strict Float) } expr_list: l=commas(expr) { l } func_params: DISTINCT? l=expr_list { l } @@ -479,7 +487,7 @@ interval_unit: MICROSECOND | SECOND | MINUTE | HOUR | DAY | WEEK | MONTH | QUART | SECOND_MICROSECOND | MINUTE_MICROSECOND | MINUTE_SECOND | HOUR_MICROSECOND | HOUR_SECOND | HOUR_MINUTE | DAY_MICROSECOND | DAY_SECOND | DAY_MINUTE | DAY_HOUR - | YEAR_MONTH { Value (Unit `Interval) } + | YEAR_MONTH { Value (strict (Unit `Interval)) } sql_type_flavor: T_INTEGER UNSIGNED? ZEROFILL? { Int } | T_DECIMAL { Decimal } diff --git a/lib/syntax.ml b/lib/syntax.ml index d74efd9..ccfce64 100644 --- a/lib/syntax.ml +++ b/lib/syntax.ml @@ -144,8 +144,7 @@ let rec resolve_columns env expr = let (schema,p,_) = eval_select_full env select in (* represet nested selects as functions with sql parameters as function arguments, some hack *) match schema, usage with - | [ {domain;_} ], `AsValue -> - ResFun (Type.Ret domain, as_params p) + | [ {domain;_} ], `AsValue -> ResFun (Type.Ret domain.t, as_params p) (* use nullable *) | s, `AsValue -> raise (Schema.Error (s, "only one column allowed for SELECT operator in this expression")) | _, `Exists -> ResFun (Type.Ret Any, as_params p) in @@ -154,7 +153,7 @@ let rec resolve_columns env expr = (** assign types to parameters where possible *) and assign_types expr = let option_split = function None -> None, None | Some (x,y) -> Some x, Some y in - let rec typeof (e:res_expr) = (* FIXME simplify *) + let rec typeof_ (e:res_expr) = (* FIXME simplify *) match e with | ResValue t -> e, `Ok t | ResParam p -> e, `Ok p.typ @@ -165,7 +164,7 @@ and assign_types expr = let t = match List.map get_or_failwith @@ List.filter_map identity t with | [] -> assert false - | t::ts -> List.fold_left (fun acc t -> match acc with None -> None | Some prev -> Type.common_subtype prev t) (Some t) ts + | t::ts -> List.fold_left (fun acc t -> match acc with None -> None | Some prev -> Type.common_type prev t) (Some t) ts in let t = match t with None -> `Error "no common subtype for all choice branches" | Some t -> `Ok t in ResChoices (n, List.map2 (fun (n,_) e -> n,e) l e), t @@ -173,11 +172,12 @@ and assign_types expr = let open Type in let (params,types) = params |> List.map typeof |> List.split in let types = List.map get_or_failwith types in - let show () = + let show_func () = sprintf "%s applied to (%s)" (string_of_func func) - (String.concat ", " @@ List.map to_string types) + (String.concat ", " @@ List.map show types) in + if !debug then eprintfn "func %s" (show_func ()); let func = match func with | Multi (ret,each_arg) -> F (ret, List.map (fun _ -> each_arg) types) @@ -188,55 +188,69 @@ and assign_types expr = | Agg, [typ] | Group typ, _ -> typ, types | Agg, _ -> fail "cannot use this grouping function with %d parameters" (List.length types) - | F (_, args), _ when List.length args <> List.length types -> fail "wrong number of arguments : %s" (show ()) + | F (_, args), _ when List.length args <> List.length types -> fail "wrong number of arguments : %s" (show_func ()) | F (ret, args), _ -> let typevar = Hashtbl.create 10 in - let l = List.map2 begin fun arg typ -> + List.iter2 begin fun arg typ -> match arg with - | Typ arg -> common_type arg typ + | Typ arg -> + begin match common_type arg typ with + | None -> fail "types %s and %s do not match in %s" (show arg) (show typ) (show_func ()) + | Some _ -> () + end | Var i -> - let arg = + let var = match Hashtbl.find typevar i with - | exception Not_found -> Hashtbl.replace typevar i typ; typ + | exception Not_found -> typ | t -> t in - (* prefer more precise type *) - if arg = Type.Any then Hashtbl.replace typevar i typ; - common_type arg typ - end args types - in + match common_type var typ with + | Some t -> + if !debug then Type.(eprintfn "common_type %s %s = %s" (show var) (show typ) (show t)); + Hashtbl.replace typevar i t + | None -> fail "types %s and %s for %s do not match in %s" (show var) (show typ) (string_of_tyvar arg) (show_func ()); + end args types; + if !debug then typevar |> Hashtbl.iter (fun i typ -> eprintfn "%s : %s" (string_of_tyvar (Var i)) (show typ)); let convert = function Typ t -> t | Var i -> Hashtbl.find typevar i in - if List.fold_left (&&) true l then - convert ret, List.map convert args - else - fail "types do not match : %s" (show ()) + let args = List.map convert args in + let nullable = common_nullability args in + let ret = convert ret in + undepend ret nullable, args | Ret Any, _ -> (* lame *) - begin match List.filter ((<>) Any) types with - | [] -> Any, types - (* make a best guess, return type same as for parameters when all of single type *) - | h::tl when List.for_all (matches h) tl -> h, List.map (fun _ -> h) types - (* "expand" to floats, when all parameters numeric and above rule didn't match *) - | l when List.for_all (function Int | Float -> true | _ -> false) l -> Float, List.map (function Any -> Float | x -> x) types - | _ -> Any, types - end - | Ret ret, _ -> ret, types (* ignoring arguments FIXME *) + let (t, types) = + match List.filter (not $ is_any) types with + | [] -> Any, types + (* make a best guess, return type same as for parameters when all of single type *) + | h::tl when List.for_all (matches h) tl -> h.t, List.map (fun _ -> h) types + (* "expand" to floats, when all parameters numeric and above rule didn't match *) + | l when List.for_all (function { t = Int | Float; nullability = _ } -> true | _ -> false) l -> + Float, List.map (fun x -> if is_any x then { x with t = Float } else x) types + | _ -> Any, types + and nullability = common_nullability types + in + { t; nullability }, types + | Ret ret, _ -> + let nullability = common_nullability types in + { t = ret; nullability; }, types (* ignoring arguments FIXME *) in let assign inferred x = match x with - | ResParam { id; typ = Any; attr; } -> ResParam (new_param ?attr id inferred) - | ResInparam { id; typ = Any; attr; } -> ResInparam (new_param ?attr id inferred) + | ResParam { id; typ; attr; } when is_any typ -> ResParam (new_param ?attr id inferred) + | ResInparam { id; typ; attr; } when is_any typ -> ResInparam (new_param ?attr id inferred) | x -> x in ResFun (func,(List.map2 assign inferred_params params)), `Ok ret + and typeof expr = + let r = typeof_ expr in + if !debug then eprintfn "%s is typeof %s" (Type.show @@ get_or_failwith @@ snd r) (show_res_expr @@ fst r); + r in typeof expr and resolve_types env expr = let expr = resolve_columns env expr in try - let (expr',t as r) = assign_types expr in - if !debug then eprintf "resolved types %s : %s\n%!" (show_res_expr expr') (Type.to_string @@ get_or_failwith t); - r + assign_types expr with exn -> eprintfn "resolve_types failed with %s at:" (Printexc.to_string exn); @@ -528,7 +542,7 @@ let unify_params l = match Hashtbl.find h name with | exception _ -> Hashtbl.add h name t | t' -> - match Sql.Type.common_subtype t t' with + match Type.common_type t t' with | Some x -> Hashtbl.replace h name x | None -> fail "incompatible types for parameter %S : %s and %s" name (Type.show t) (Type.show t') in @@ -540,8 +554,12 @@ let unify_params l = | TupleList _ -> () in let rec map = function - | Single { id; typ; attr } -> Single (new_param id ?attr (match id.label with None -> typ | Some name -> try Hashtbl.find h name with _ -> assert false)) - | SingleIn { id; typ; attr } -> SingleIn (new_param id ?attr (match id.label with None -> typ | Some name -> try Hashtbl.find h name with _ -> assert false)) + | Single { id; typ; attr } -> + let typ = match id.label with None -> typ | Some name -> try Hashtbl.find h name with _ -> assert false in + Single (new_param id ?attr (Type.undepend typ Strict)) (* if no other clues - input parameters are strict *) + | SingleIn { id; typ; attr } -> + let typ = match id.label with None -> typ | Some name -> try Hashtbl.find h name with _ -> assert false in + SingleIn (new_param id ?attr (Type.undepend typ Strict)) (* if no other clues - input parameters are strict *) | ChoiceIn t -> ChoiceIn { t with vars = List.map map t.vars } | Choice (p, l) -> Choice (p, List.map (function Simple (n,l) -> Simple (n, Option.map (List.map map) l) | Verbatim _ as v -> v) l) | TupleList _ as x -> x diff --git a/src/gen.ml b/src/gen.ml index 68f2d21..5f4e5e8 100644 --- a/src/gen.ml +++ b/src/gen.ml @@ -196,10 +196,10 @@ type value = { vname : string; vtyp : string; nullable : bool; } module Translate(T : LangTypes) = struct let show_param_type p = T.as_api_type p.Sql.typ -let schema_to_values = List.mapi (fun i attr -> { vname = name_of attr i; vtyp = T.as_lang_type attr.Sql.domain; nullable = is_attr_nullable attr }) +let schema_to_values = List.mapi (fun i attr -> { vname = name_of attr i; vtyp = T.as_lang_type attr.Sql.domain; nullable = is_attr_nullable attr || attr.domain.nullability = Nullable }) (* let schema_to_string = G.Values.to_string $ schema_to_values *) let all_params_to_values l = - l |> List.mapi (fun i p -> { vname = show_param_name p i; vtyp = T.as_lang_type p.typ; nullable = is_param_nullable p; }) + l |> List.mapi (fun i p -> { vname = show_param_name p i; vtyp = T.as_lang_type p.typ; nullable = is_param_nullable p || p.typ.nullability = Nullable; }) |> List.unique ~cmp:(fun v1 v2 -> String.equal v1.vname v2.vname) (* rev unique rev -- to preserve ordering with respect to first occurrences *) let values_of_params = List.rev $ List.unique ~cmp:(=) $ List.rev $ all_params_to_values diff --git a/src/gen_caml.ml b/src/gen_caml.ml index e06ffe6..ca1ab5d 100644 --- a/src/gen_caml.ml +++ b/src/gen_caml.ml @@ -120,9 +120,11 @@ let comment () fmt = Printf.kprintf (indent_endline $ make_comment) fmt let empty_line () = print_newline () module L = struct + open Type + let as_lang_type = function - | Type.Blob -> Type.to_string Type.Text - | t -> Type.to_string t + | { t = Blob; nullability } -> type_name { t = Text; nullability } + | t -> type_name t let as_api_type = as_lang_type end @@ -319,8 +321,6 @@ let output_params_binder index vars = | [] -> "T.no_params" | vars -> output_params_binder index vars -let prepend prefix = function s -> prefix ^ s - let in_var_module _label typ = Sql.Type.to_string typ let gen_in_substitution var = diff --git a/src/gen_csharp.ml b/src/gen_csharp.ml index d2c8484..043d312 100644 --- a/src/gen_csharp.ml +++ b/src/gen_csharp.ml @@ -32,8 +32,9 @@ let quote = J.quote module L = struct -let as_api_type = function - | Type.Int -> "Int64" +let as_api_type t = + match t.Type.t with + | Int -> "Int64" | Text -> "String" | Float -> "Float" | Blob -> "String" diff --git a/src/gen_cxx.ml b/src/gen_cxx.ml index 92f1fb6..08928c2 100644 --- a/src/gen_cxx.ml +++ b/src/gen_cxx.ml @@ -41,7 +41,7 @@ let out_public () = dec_indent(); output "public:"; inc_indent() let out_private () = dec_indent(); output "private:"; inc_indent() module L = struct - let as_api_type = Type.to_string + let as_api_type = Type.type_name let as_lang_type t = "typename Traits::" ^ (as_api_type t) end diff --git a/src/gen_java.ml b/src/gen_java.ml index 7ed946f..0601920 100644 --- a/src/gen_java.ml +++ b/src/gen_java.ml @@ -32,8 +32,9 @@ let (start_intf,end_intf) = start_ "public static interface" module L = struct -let as_lang_type = function - | Type.Int -> "int" +let as_lang_type t = + match t.Type.t with + | Int -> "int" | Text -> "String" | Any -> "String" | Float -> "float" diff --git a/src/gen_xml.ml b/src/gen_xml.ml index b99f6fa..b942372 100644 --- a/src/gen_xml.ml +++ b/src/gen_xml.ml @@ -61,7 +61,7 @@ let tuplelist_value_of_param = function | Sql.Single _ | SingleIn _ | Choice _ | ChoiceIn _ -> None | TupleList ({ label = None; _ }, _) -> failwith "empty label in tuple subst" | TupleList ({ label = Some name; _ }, schema) -> - let typ = "list(" ^ String.concat ", " (List.map (fun { Sql.domain; _ } -> Sql.Type.to_string domain) schema) ^ ")" in + let typ = "list(" ^ String.concat ", " (List.map (fun { Sql.domain; _ } -> Sql.Type.type_name domain) schema) ^ ")" in let attrs = ["name", name; "type", typ] in Some (Node ("value", attrs, [])) diff --git a/src/test.ml b/src/test.ml index f803f15..65f8b5b 100644 --- a/src/test.ml +++ b/src/test.ml @@ -2,16 +2,13 @@ open Printf open OUnit open Sqlgg open Sql -open Sql.Type +(* open Sql.Type *) open Stmt -let named s t = new_param { label = Some s; pos = (0,0) } t -let param t = new_param { label = None; pos = (0,0) } t - let cmp_params p1 p2 = try List.for_all2 (fun p1 p2 -> - p1.id.label = p2.id.label && p1.typ = p2.typ && p1.id.pos = (0,0) && snd p2.id.pos > fst p2.id.pos) + 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) p1 p2 with _ -> false @@ -38,9 +35,11 @@ let tt sql ?kind schema params = let wrong sql = sql >:: (fun () -> ("Expected error in : " ^ sql) @? (try ignore (Main.parse_one' (sql,[])); false with _ -> true)) -let attr ?(extra=[]) n d = make_attribute n d (Constraints.of_list extra) +let attr ?(extra=[]) n d = make_attribute n (Type.strict d) (Constraints.of_list extra) +let named s t = new_param { label = Some s; pos = (0,0) } (Type.strict t) +let param t = new_param { label = None; pos = (0,0) } (Type.strict t) -let test = [ +let test = Type.[ tt "CREATE TABLE test (id INT, str TEXT, name TEXT)" [] []; tt "SELECT str FROM test WHERE id=?" [attr "str" Text] diff --git a/test/null.sql b/test/null.sql index 266f5a2..ef07d57 100644 --- a/test/null.sql +++ b/test/null.sql @@ -6,6 +6,7 @@ CREATE TABLE IF NOT EXISTS `test` ( ); -- issue #45 +-- BUG/misfeature picks nullable for @maybe, while it could be strict -- @insert1 INSERT INTO `test` SET `nullable` = CASE @maybe WHEN 0 THEN NULL ELSE @maybe END @@ -26,17 +27,39 @@ INSERT INTO test VALUES; -- @list_nullable SELECT `id`, `nullable` FROM test; --- @case_todo +-- @case_BUG +-- out expected int nullable, not any +-- in could be strict SELECT CASE @x WHEN 0 THEN NULL ELSE @x END; --- @select_nullif +-- @select_nullif_BUG SELECT NULLIF(@maybe, 0); +-- BUG? IFNULL should make first param nullable? -- @select_ifnull SELECT IFNULL(@maybe, 0); +-- @select_ifnull_int +SELECT IFNULL(nullable_int, 0) FROM test; + -- @select_plus SELECT id + IFNULL(nullable_int, 0) FROM test; +-- @select_plus_null +SELECT id + NULL FROM test; + +-- @select_plus_nullable_BUG +SELECT id + nullable_int FROM test; + -- @select_func SELECT nullable, floor(unix_timestamp(nullable)/3600) FROM test; + +-- @get_max +SELECT + max(nullable), + IF(max(nullable) IS NULL, NULL, max(nullable)) +FROM + test +WHERE + id = @id +LIMIT 1; diff --git a/test/out/inargument.xml b/test/out/inargument.xml index 5b2f08a..828974e 100644 --- a/test/out/inargument.xml +++ b/test/out/inargument.xml @@ -30,7 +30,7 @@ - + @@ -50,7 +50,7 @@ - + diff --git a/test/out/misc.xml b/test/out/misc.xml index 8c2580e..7d88966 100644 --- a/test/out/misc.xml +++ b/test/out/misc.xml @@ -170,9 +170,9 @@ - - - + + + diff --git a/test/out/multidel.xml b/test/out/multidel.xml index d7416db..ef69698 100644 --- a/test/out/multidel.xml +++ b/test/out/multidel.xml @@ -11,7 +11,7 @@ - + @@ -24,45 +24,45 @@ - + - + - + - + - + - + - + diff --git a/test/out/null.xml b/test/out/null.xml index a5d8894..921d12b 100644 --- a/test/out/null.xml +++ b/test/out/null.xml @@ -7,7 +7,7 @@ - + @@ -21,7 +21,7 @@ - + @@ -46,15 +46,15 @@ - + - + - + - + @@ -64,18 +64,36 @@ - + + + + + + + + + + + + + + + + + + + @@ -83,6 +101,15 @@ + + + + + + + + + diff --git a/test/out/subquery.xml b/test/out/subquery.xml index 6416592..9650a64 100644 --- a/test/out/subquery.xml +++ b/test/out/subquery.xml @@ -21,7 +21,7 @@ - +