diff options
| -rw-r--r-- | Changes | 6 | ||||
| -rw-r--r-- | testsuite/tests/typing-warnings/records.ml | 20 | ||||
| -rw-r--r-- | testsuite/tests/typing-warnings/records.ml.principal.reference | 28 | ||||
| -rw-r--r-- | testsuite/tests/typing-warnings/records.ml.reference | 22 | ||||
| -rw-r--r-- | typing/typecore.ml | 17 |
5 files changed, 87 insertions, 6 deletions
@@ -6,6 +6,11 @@ Next version: Other libraries: * Labltk: removed from the distribution, now available as a third-party library +Type system: +* Keep typing of pattern cases independent in principal mode + (i.e. information from previous cases is no longer used when typing + patterns; cf. PR6235' in typing-warnings/records.ml) + Language features: - Attributes and extension nodes @@ -53,6 +58,7 @@ Bug fixes: - PR#6173: Typing error message is worse that before - PR#6174: OCaml compiler loops on an example using GADTs (non -rectypes) - PR#6216: inlining of GADT matches generates invalid assembly +- PR#6235: Issue with type information flowing through a variant pattern OCaml 4.01.0: diff --git a/testsuite/tests/typing-warnings/records.ml b/testsuite/tests/typing-warnings/records.ml index 61a21cebb6..59a45549d0 100644 --- a/testsuite/tests/typing-warnings/records.ml +++ b/testsuite/tests/typing-warnings/records.ml @@ -158,3 +158,23 @@ module Shadow2 = struct open M (* this open shadows label 'x' *) let y = {x = ""} end;; + +(* PR#6235 *) + +module P6235 = struct + type t = { loc : string; } + type v = { loc : string; x : int; } + type u = [ `Key of t ] + let f (u : u) = match u with `Key {loc} -> loc +end;; + +(* Remove interaction between branches *) + +module P6235' = struct + type t = { loc : string; } + type v = { loc : string; x : int; } + type u = [ `Key of t ] + let f = function + | (_ : u) when false -> "" + |`Key {loc} -> loc +end;; diff --git a/testsuite/tests/typing-warnings/records.ml.principal.reference b/testsuite/tests/typing-warnings/records.ml.principal.reference index 322f31e71f..c208dee25d 100644 --- a/testsuite/tests/typing-warnings/records.ml.principal.reference +++ b/testsuite/tests/typing-warnings/records.ml.principal.reference @@ -270,4 +270,32 @@ module Shadow2 : module M : sig type s = { x : string; } end val y : M.s end +# Characters 167-170: + let f (u : u) = match u with `Key {loc} -> loc + ^^^ +Warning 42: this use of loc required disambiguation. +module P6235 : + sig + type t = { loc : string; } + type v = { loc : string; x : int; } + type u = [ `Key of t ] + val f : u -> string + end +# Characters 219-224: + |`Key {loc} -> loc + ^^^^^ +Warning 41: these field labels belong to several types: v t +The first one was selected. Please disambiguate if this is wrong. +Characters 219-224: + |`Key {loc} -> loc + ^^^^^ +Warning 9: the following labels are not bound in this record pattern: +x +Either bind these labels explicitly or add '; _' to the pattern. +Characters 214-224: + |`Key {loc} -> loc + ^^^^^^^^^^ +Error: This pattern matches values of type [? `Key of v ] + but a pattern was expected which matches values of type u + Types for tag `Key are incompatible # diff --git a/testsuite/tests/typing-warnings/records.ml.reference b/testsuite/tests/typing-warnings/records.ml.reference index 4dde3848a0..2853439c65 100644 --- a/testsuite/tests/typing-warnings/records.ml.reference +++ b/testsuite/tests/typing-warnings/records.ml.reference @@ -265,4 +265,26 @@ module Shadow2 : module M : sig type s = { x : string; } end val y : M.s end +# Characters 167-170: + let f (u : u) = match u with `Key {loc} -> loc + ^^^ +Warning 42: this use of loc required disambiguation. +module P6235 : + sig + type t = { loc : string; } + type v = { loc : string; x : int; } + type u = [ `Key of t ] + val f : u -> string + end +# Characters 220-223: + |`Key {loc} -> loc + ^^^ +Warning 42: this use of loc required disambiguation. +module P6235' : + sig + type t = { loc : string; } + type v = { loc : string; x : int; } + type u = [ `Key of t ] + val f : u -> string + end # diff --git a/typing/typecore.ml b/typing/typecore.ml index edbf555047..644b2ae110 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -1050,16 +1050,21 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = pat_attributes = sp.ppat_attributes; pat_env = !env } | Ppat_variant(l, sarg) -> - let arg = may_map (fun p -> type_pat p (newvar())) sarg in - let arg_type = match arg with None -> [] | Some arg -> [arg.pat_type] in + let arg_type = match sarg with None -> [] | Some _ -> [newvar()] in let row = { row_fields = - [l, Reither(arg = None, arg_type, true, ref None)]; + [l, Reither(sarg = None, arg_type, true, ref None)]; row_bound = (); row_closed = false; row_more = newvar (); row_fixed = false; row_name = None } in unify_pat_types loc !env (newty (Tvariant row)) expected_ty; + let arg = + (* PR#6235: propagate type information *) + match sarg, arg_type with + Some p, [ty] -> Some (type_pat p ty) + | _ -> None + in rp { pat_desc = Tpat_variant(l, arg, ref {row with row_more = newvar()}); pat_loc = loc; pat_extra=[]; @@ -3325,11 +3330,12 @@ and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist : Typedt { pat with pat_type = instance env pat.pat_type } end else pat in - unify_pat env pat ty_arg'; (pat, (ext_env, unpacks))) caselist in - (* Check for polymorphic variants to close *) + (* Unify cases (delayed to keep it order-free) *) let patl = List.map fst pat_env_list in + List.iter (fun pat -> unify_pat env pat ty_arg') patl; + (* Check for polymorphic variants to close *) if List.exists has_variants patl then begin Parmatch.pressure_variants env patl; List.iter (iter_pattern finalize_variant) patl @@ -3337,7 +3343,6 @@ and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist : Typedt (* `Contaminating' unifications start here *) List.iter (fun f -> f()) !pattern_force; (* Post-processing and generalization *) - let patl = List.map fst pat_env_list in List.iter (iter_pattern (fun {pat_type=t} -> unify_var env t (newvar()))) patl; List.iter (fun pat -> unify_pat env pat (instance env ty_arg)) patl; |