From 3386811444bdc2da53dcb9329371a38336194292 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Thu, 29 Oct 2026 18:08:24 +0000 Subject: [PATCH] Pass the origin of a synthesized match as an argument, not an attribute MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Why: The type checker rewrites a `let` destructuring a GADT constructor, and an optional parameter's default, into a match, and marked that match with the string attributes `#let_gadt_pattern` and `#optional_arg_default` so that it gets function-style diagnostics rather than a switch's (#9126). Both are made and read inside typecore and nothing after typing reads them. `type_expect` now takes `?match_context` and `type_let` takes `?optional_default`; only `let.unwrap`, which comes from the parsed `let?`, stays an attribute. The GADT rewrite also required the binding to have no attributes, so a doc comment or `@warning` in front of it was an error; its attributes now go on the case pattern, and `@warning` on a pattern now covers that pattern's unused variables. Typedtree modified (let destructuring a GADT constructor): Example: type rec any = Any('a, 'a => string): any let get = value => { let Any(x, f) = value f(x) } Before (typed): expression attribute "#let_gadt_pattern" [] Texp_match expression Texp_ident "value/1004" [ pattern Tpat_construct "Any" … After (typed): expression Texp_match expression Texp_ident "value/1004" [ pattern Tpat_construct "Any" … Diagnostic removed (attribute in front of a GADT let): Example: type rec any = Any('a, 'a => string): any let get = value => { /** Destructures the existential. */ let Any(x, f) = value f(x) } Before (diagnostic): This pattern introduces an existential type from a GADT constructor, which is not allowed here. Match on it inside a switch instead. After (diagnostic): compiles Diagnostic removed (unused variable of a pattern with @warning): Example: let silenced = o => switch o { | @warning("-27") Some(x) => 1 | None => 0 } Before (diagnostic): Warning number 27 unused variable x. After (diagnostic): no warning Review: Why not a typed origin field on `Texp_match`, as #9126 suggests? Nothing after typing reads the origin; the field would change the typed tree for no consumer. Review: Does `@warning("-8")` on a GADT let cover a non-exhaustive pattern? No: the exhaustiveness check runs for the whole match, outside the case pattern's warning scope, as for a switch case. Fixes: #9126 Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01Kbf3gHnoR8Goys4AMxET4q Signed-off-by: Christoph Knittel --- changes/gadt-let-attributes.fix.md | 1 + compiler/ml/typecore.ml | 97 +++++++++++-------- .../pattern_warning_scope.res.expected | 16 +++ .../fixtures/pattern_warning_scope.res | 23 +++++ tests/tests/src/gadt_test.mjs | 64 ++++++------ tests/tests/src/gadt_test.res | 9 ++ 6 files changed, 143 insertions(+), 67 deletions(-) create mode 100644 changes/gadt-let-attributes.fix.md create mode 100644 tests/build_tests/super_errors/expected/pattern_warning_scope.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/pattern_warning_scope.res diff --git a/changes/gadt-let-attributes.fix.md b/changes/gadt-let-attributes.fix.md new file mode 100644 index 0000000000..075cd40a7e --- /dev/null +++ b/changes/gadt-let-attributes.fix.md @@ -0,0 +1 @@ +- Accept an attribute or doc comment in front of a `let` that destructures a GADT constructor, and let `@warning` on a pattern cover that pattern's unused variables. diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index da87c06dc8..c3658e2585 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -1961,10 +1961,15 @@ let type_pattern ~lev env spat expected_ty = reset_pattern true; let new_env = ref env in let pat = type_pat ~allow_existentials:true ~lev new_env spat expected_ty in + (* The unused-variable checks are set up here, after [type_pat] has left + the pattern's warning scope: enter it again so that [@warning] on the + pattern covers its variables. *) let new_env, unpacks = - add_pattern_variables !new_env - ~check:(fun s -> Warnings.Unused_var_strict s) - ~check_as:(fun s -> Warnings.Unused_var s) + Builtin_attributes.warning_scope ~ppwarning:false spat.ppat_attributes + (fun () -> + add_pattern_variables !new_env + ~check:(fun s -> Warnings.Unused_var_strict s) + ~check_as:(fun s -> Warnings.Unused_var s)) in (pat, new_env, get_ref (pattern_force_ref ()), unpacks) @@ -2544,7 +2549,8 @@ let rec type_exp ?deprecated_context ~context ?recarg env sexp = In the principal case, [type_expected'] may be at generic_level. *) -and type_expect ~context ?deprecated_context ?recarg env sexp ty_expected = +and type_expect ~context ?deprecated_context ?recarg ?match_context env sexp + ty_expected = (* Special errors for braced identifiers passed to records *) let context = match sexp.pexp_desc with @@ -2555,14 +2561,19 @@ and type_expect ~context ?deprecated_context ?recarg env sexp ty_expected = let previous_saved_types = Cmt_format.get_saved_types () in let exp = Builtin_attributes.warning_scope sexp.pexp_attributes (fun () -> - type_expect_ ?deprecated_context ~context ?recarg env sexp ty_expected) + type_expect_ ?deprecated_context ~context ?recarg ?match_context env + sexp ty_expected) in Cmt_format.set_saved_types (Cmt_format.Partial_expression exp :: previous_saved_types); exp -and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp - ty_expected = +(* [match_context] is set where the type checker itself rewrites source into + a match, and says what that match stands for in the source: it decides the + wording of the match's diagnostics, which would otherwise speak of a + switch. *) +and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) + ?(match_context : [`Function] option) env sexp ty_expected = let loc = sexp.pexp_loc in (* Record the expression type before unifying it with the expected type *) let rue exp = @@ -2636,16 +2647,28 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp } | Pexp_let ( Nonrecursive, - [{pvb_pat = spat; pvb_expr = sval; pvb_attributes = []}], + [ + { + pvb_pat = spat; + pvb_expr = sval; + pvb_constraint = None; + pvb_attributes; + }; + ], sbody ) when contains_gadt env spat -> - (* TODO: allow non-empty attributes? *) - type_expect ~context:None env + (* A let destructuring a GADT constructor is typed as a one-case match, + whose case can bind the constructor's existential types. The rest of + the block is that case's body, so the match gets function-style + diagnostics rather than a switch's. The binding's attributes go on the + case pattern, where they scope over the pattern's warnings. *) + let spat = + {spat with ppat_attributes = pvb_attributes @ spat.ppat_attributes} + in + type_expect ~context:None ~match_context:`Function env { sexp with pexp_desc = Pexp_match (sval, [Ast_helper.Exp.case spat sbody]); - pexp_attributes = - (mknoloc "#let_gadt_pattern", PStr []) :: sexp.pexp_attributes; } ty_expected | Pexp_let (rec_flag, spat_sexp_list, sbody) -> @@ -2829,19 +2852,15 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp (* Note: val_caselist = [] and exn_caselist = [], i.e. a fully empty pattern matching can be generated by Camlp4 with its revised syntax. Let's accept it for backward compatibility. *) - let has_attr name = - Ext_list.exists sexp.pexp_attributes (fun ({txt}, _) -> txt = name) - in let call_context = - (* Optional-default lowering synthesizes a match expression, but from the - user's point of view this is still part of a function definition. A - [let] destructuring a GADT constructor is typed as a one-case match, - whose body is the rest of the block. Use function-style diagnostics - for both instead of reporting a phantom switch. *) - if has_attr "let.unwrap" then `LetUnwrap - else if has_attr "#optional_arg_default" || has_attr "#let_gadt_pattern" - then `Function - else `Switch + match match_context with + | Some (`Function as context) -> context + | None -> + if + Ext_list.exists sexp.pexp_attributes (fun ({txt}, _) -> + txt = "let.unwrap") + then `LetUnwrap + else `Switch in let val_cases, partial = type_cases ~call_context env arg.exp_type ty_expected true loc @@ -3905,7 +3924,6 @@ and type_function ~async loc attrs env ty_expected_ in let smatch = Exp.match_ ~loc:sloc - ~attrs:[(mknoloc "#optional_arg_default", PStr [])] (Exp.ident ~loc (mknoloc (Longident.Lident opt_name))) scases in @@ -4058,7 +4076,8 @@ and type_function ~async loc attrs env ty_expected_ | Some vb -> let let_env = ext_env in let pat_exp_list, ext_env, let_unpacks = - type_let ~context:None ext_env Nonrecursive [vb] true + type_let ~context:None ~optional_default:true ext_env Nonrecursive + [vb] true in (* The pattern binds the option carrier under an unspellable name ([*opt_