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_