Pass the origin of a synthesized match as an argument, not an attribute (#9128)

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"
      [
        <case>
          pattern
            Tpat_construct "Any"
          …
After (typed):
    expression
      Texp_match
      expression
        Texp_ident "value/1004"
      [
        <case>
          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


Claude-Session: https://claude.ai/code/session_01Kbf3gHnoR8Goys4AMxET4q

Signed-off-by: Christoph Knittel <ck@cca.io>
Co-authored-by: Claude Opus 5.5 <noreply@anthropic.com>

Author: cknitt

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.

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_<label>*]), which typing needs so that user code can
@@ -4908,9 +4927,13 @@ and type_cases ~(call_context : [`LetUnwrap | `Switch | `Function | `Try]) env
 
 (* Typing of let bindings *)
 
+(* [optional_default] marks the let that binds an optional parameter's
+   default, which [type_function] synthesizes: its variables are parameters
+   from the user's point of view, so an unused one gets the strict (parameter)
+   warning, and its match on the option gets function-style diagnostics. *)
 and type_let ~context ?(check = fun s -> Warnings.Unused_var s)
-    ?(check_strict = fun s -> Warnings.Unused_var_strict s) env rec_flag
-    spat_sexp_list allow =
+    ?(check_strict = fun s -> Warnings.Unused_var_strict s)
+    ?(optional_default = false) env rec_flag spat_sexp_list allow =
   let spat_sexp_list =
     List.map
       (fun (vb : Parsetree.value_binding) ->
@@ -4926,17 +4949,7 @@ and type_let ~context ?(check = fun s -> Warnings.Unused_var s)
       spat_sexp_list
   in
   begin_def ();
-  let is_fake_let =
-    (* the synthetic let-declaration introduced for an optional parameter's
-       default: its variables are parameters from the user's point of view,
-       so an unused one gets the strict (parameter) warning *)
-    match spat_sexp_list with
-    | [{pvb_expr = {pexp_attributes}}] ->
-      Ext_list.exists pexp_attributes (fun ({txt}, _) ->
-          txt = "#optional_arg_default")
-    | _ -> false
-  in
-  let check = if is_fake_let then check_strict else check in
+  let check = if optional_default then check_strict else check in
 
   let spatl =
     List.map
@@ -5048,7 +5061,11 @@ and type_let ~context ?(check = fun s -> Warnings.Unused_var s)
         let type_expression expected =
           Builtin_attributes.warning_scope pvb_attributes (fun () ->
               match pvb_constraint with
-              | None -> type_expect ~context exp_env sexp expected
+              | None ->
+                let match_context =
+                  if optional_default then Some `Function else None
+                in
+                type_expect ~context ?match_context exp_env sexp expected
               | Some {pvc_newtypes; pvc_type} ->
                 let constrained =
                   Ast_helper.Exp.constraint_ ~loc:pvb_loc sexp pvc_type

tests/build_tests/super_errors/expected/pattern_warning_scope.res.expected

@@ -0,0 +1,16 @@
+
+  Warning number 27
+  /.../fixtures/pattern_warning_scope.res:21:10
+
+  19 │ let unsilenced = o =>
+  20 │   switch o {
+  21 │   | Some(y) => 1
+  22 │   | None => 0
+  23 │   }
+
+  unused variable y.
+
+Fix this by:
+- Deleting the variable if it's not used anymore.
+- Prepending the variable name with `_` (like `_y`) to ignore that the variable is unused.
+- Using the variable somewhere.

tests/build_tests/super_errors/fixtures/pattern_warning_scope.res

@@ -0,0 +1,23 @@
+type rec any = Any('a, 'a => string): any
+
+// `@warning` on a let destructuring a GADT and on a case pattern covers the
+// pattern's variables; only `unsilenced` is reported.
+let get = value => {
+  /** Destructures the existential. */
+  @warning("-27")
+  let Any(x, f) = value
+  ignore(f)
+  "s"
+}
+
+let silenced = o =>
+  switch o {
+  | @warning("-27") Some(x) => 1
+  | None => 0
+  }
+
+let unsilenced = o =>
+  switch o {
+  | Some(y) => 1
+  | None => 0
+  }