From cf3552cfe078f0ba23157dd5a52dfadb5266360d Mon Sep 17 00:00:00 2001 From: ygrek Date: Fri, 25 Sep 2020 16:46:31 -0400 Subject: [PATCH] track nullability (generic) ref #5 #76 TODO functions operating on NULLs specifically --- lib/sql.ml | 151 ++++++++++++++++++++++++++---------------- lib/sql_parser.mly | 62 +++++++++-------- lib/syntax.ml | 93 +++++++++++++++----------- 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/test.ml | 13 ++-- test/out/misc.xml | 6 +- test/out/multidel.xml | 16 ++--- test/out/null.xml | 8 +-- test/out/subquery.xml | 2 +- 13 files changed, 222 insertions(+), 153 deletions(-) diff --git a/lib/sql.ml b/lib/sql.ml index dbb7751..35b9827 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,33 @@ struct | Datetime | Decimal | Any - [@@deriving show {with_path=false}] + [@@deriving eq, show{with_path=false}] - let to_string = show + type nullable = Nullable | Strict | Depends [@@deriving eq, show{with_path=false}] - let matches x y = - match x,y with - | Any, _ | _, Any -> true - | _ -> x = y + type t = { t : kind; nullable : nullable; }[@@deriving eq, show{with_path=false}] + + let nullable nullable = fun t -> { t; nullable } + let strict = nullable Strict + let depends = nullable Depends + let nullable = nullable Nullable + + let (=) : t -> t -> bool = equal + + let show { t; nullable} = show_kind t ^ (match nullable 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; nullable = _ } = 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 @@ -39,28 +53,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_nullable 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_nullable = List.fold_left (fun acc t -> + match acc, t.nullable with + | _, Nullable + | Nullable, _ -> Nullable + | _, Strict + | Strict, _ -> Strict + | Depends, Depends -> Depends + ) Depends + + let common_nullable l = match common_nullable l with Depends -> Strict | n -> n + let undepend t nullable = if equal_nullable t.nullable Depends then { t with nullable } else t + + let common_type x y = + match order_nullable x.nullable y.nullable, order_kind x.t y.t with + | _, `No -> None + | `Equal nullable, `Order (t,_) -> Some {t; nullable} + | `Equal _nullable, `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]) @@ -68,8 +104,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) @@ -153,7 +189,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]" @@ -174,14 +210,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 @@ -229,7 +264,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 "" @@ -340,7 +375,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 @@ -379,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 name in @@ -406,30 +441,34 @@ 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"] ||> monomorphic Text [Text]; - "length" |> monomorphic Int [Text]; - ["random"] ||> monomorphic Int []; + ["lower";"upper"] ||> monomorphic text [text]; + "length" |> monomorphic int [text]; + ["random"] ||> monomorphic int []; ["nullif";"ifnull"] ||> add 2 (F (Var 0, [Var 0; Var 0])); ["least";"greatest";"coalesce"] ||> multi_polymorphic; "strftime" |> exclude 1; (* requires at least 2 arguments *) - ["concat";"strftime"] ||> multi ~ret:(Typ Text) (Typ Text); - ["date";"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";"strftime"] ||> multi ~ret:(Typ text) (Typ text); + ["date";"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 14191fd..b568d3a 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 @@ -288,7 +288,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; nullable = 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 } @@ -323,7 +328,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 when is_any t -> Some Null | _ -> None } (* FIXME check type with column *) | COLLATE IDENT { None } default_value: e=single_literal_value | e=datetime_value { e } (* sub expr ? *) @@ -350,7 +355,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? { @@ -366,16 +371,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]) } @@ -385,23 +390,23 @@ expr: | DEFAULT LPAREN a=attr_name RPAREN { Fun (Type.identity, [Column a]) } | CONVERT LPAREN e=expr USING IDENT RPAREN { 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 maybe f = function None -> [] | Some x -> [f x] in 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 = maybe Prelude.identity e1 @ List.flatten branches @ maybe Prelude.identity 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]) } | either(LAG,LEAD) LPAREN e=expr pair(COMMA, pair(MINUS?,INTEGER))? RPAREN OVER LPAREN (* [ PARTITION BY partition_expression ] *) order RPAREN (* TODO order parameters? *) { e } @@ -414,24 +419,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 } @@ -450,7 +458,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 0a08729..27e5d52 100644 --- a/lib/syntax.ml +++ b/lib/syntax.ml @@ -127,16 +127,16 @@ let rec resolve_columns env expr = p in let (schema,p,_) = eval_select_full env select in match schema, usage with - | [ {domain;_} ], `AsValue -> `Func (Type.Ret domain, as_params p) + | [ {domain;_} ], `AsValue -> `Func (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 -> `Func (Type.Ret Any, as_params p) + | _, `Exists -> `Func (Type.(Ret Any), as_params p) in each 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:expr_q) = (* FIXME simplify *) + let rec typeof_ (e:expr_q) = (* FIXME simplify *) match e with | `Value t -> e, `Ok t | `Param p -> e, `Ok p.typ @@ -147,7 +147,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 `Choice (n, List.map2 (fun (n,_) e -> n,e) l e), t @@ -155,11 +155,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) @@ -170,55 +171,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_nullable 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; nullable = _ } -> true | _ -> false) l -> + Float, List.map (fun x -> if is_any x then { x with t = Float } else x) types + | _ -> Any, types + and nullable = common_nullable types + in + { t; nullable }, types + | Ret ret, _ -> + let nullable = common_nullable types in + { t = ret; nullable; }, types (* ignoring arguments FIXME *) in let assign inferred x = match x with - | `Param { id; typ = Any; attr; } -> `Param (new_param ?attr id inferred) - | `Inparam { id; typ = Any; attr; } -> `Inparam (new_param ?attr id inferred) + | `Param { id; typ; attr; } when is_any typ -> `Param (new_param ?attr id inferred) + | `Inparam { id; typ; attr; } when is_any typ -> `Inparam (new_param ?attr id inferred) | x -> x in `Func (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_expr_q @@ 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_expr_q 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); @@ -504,7 +519,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 @@ -515,8 +530,12 @@ let unify_params l = | Choice (p,l) -> check_choice_name p; List.iter (function Simple (_,l) -> Option.may (List.iter traverse) l | Verbatim _ -> ()) l 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) in diff --git a/src/gen.ml b/src/gen.ml index 7c554ce..e79f4e7 100644 --- a/src/gen.ml +++ b/src/gen.ml @@ -189,10 +189,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.nullable = 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.nullable = 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 75478be..cd6323e 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; nullable } -> type_name { t = Text; nullable } + | t -> type_name t let as_api_type = as_lang_type end @@ -317,7 +319,7 @@ let output_params_binder index vars = let prepend prefix = function s -> prefix ^ s -let in_var_module _label typ = Sql.Type.to_string typ +let in_var_module _label typ = Sql.Type.type_name typ (* FIXME nullability *) let gen_in_substitution var = if Option.is_none var.id.label then failwith "empty label in IN param"; 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 f217f5b..01998f9 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/test.ml b/src/test.ml index 40f9154..89343f7 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/out/misc.xml b/test/out/misc.xml index c31e541..071b1cd 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 69f812c..0c5c1ee 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 f774df7..cf88ca0 100644 --- a/test/out/null.xml +++ b/test/out/null.xml @@ -7,7 +7,7 @@ - + @@ -21,7 +21,7 @@ - + @@ -47,10 +47,10 @@ - + - + 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 @@ - +