From f8bc8fdc546489702e99fe7d6b31cc6d53cc8a18 Mon Sep 17 00:00:00 2001
From: Nick Roberts <nroberts@janestreet.com>
Date: Wed, 19 Jun 2024 12:22:03 -0400
Subject: [PATCH] flambda-backend: Fix warning 34 (unused type declaration) for
 locally-abstract types (#2683)

* Regression test with bad output

* Fix
---
 .../tests/typing-warnings/unused_types.ml     | 63 +++++++++++++++++++
 typing/typecore.ml                            | 17 ++---
 2 files changed, 72 insertions(+), 8 deletions(-)

diff --git a/testsuite/tests/typing-warnings/unused_types.ml b/testsuite/tests/typing-warnings/unused_types.ml
index c000d27bb1c..8070be362fb 100644
--- a/testsuite/tests/typing-warnings/unused_types.ml
+++ b/testsuite/tests/typing-warnings/unused_types.ml
@@ -530,3 +530,66 @@ Warning 69 [unused-field]: unused record field b.
 
 module Unused_field_disable_one_warning : sig end
 |}]
+
+(* Locally abstract types *)
+
+let u (type unused) = ()
+[%%expect {|
+Line 1, characters 12-18:
+1 | let u (type unused) = ()
+                ^^^^^^
+Warning 34 [unused-type-declaration]: unused type unused.
+
+val u : unit = ()
+|}]
+
+let u = fun (type unused) -> ()
+[%%expect {|
+Line 1, characters 18-24:
+1 | let u = fun (type unused) -> ()
+                      ^^^^^^
+Warning 34 [unused-type-declaration]: unused type unused.
+
+val u : unit = ()
+|}]
+
+let f (type unused) x = x
+[%%expect {|
+Line 1, characters 12-18:
+1 | let f (type unused) x = x
+                ^^^^^^
+Warning 34 [unused-type-declaration]: unused type unused.
+
+val f : 'a -> 'a = <fun>
+|}]
+
+let f = fun (type unused) x -> x
+[%%expect {|
+Line 1, characters 18-24:
+1 | let f = fun (type unused) x -> x
+                      ^^^^^^
+Warning 34 [unused-type-declaration]: unused type unused.
+
+val f : 'a -> 'a = <fun>
+|}]
+
+let f (type used unused) (x : used) = x
+[%%expect {|
+Line 1, characters 17-23:
+1 | let f (type used unused) (x : used) = x
+                     ^^^^^^
+Warning 34 [unused-type-declaration]: unused type unused.
+
+val f : 'used -> 'used = <fun>
+|}]
+
+let f = fun (type used unused) (x : used) -> x
+
+[%%expect{|
+Line 1, characters 23-29:
+1 | let f = fun (type used unused) (x : used) -> x
+                           ^^^^^^
+Warning 34 [unused-type-declaration]: unused type unused.
+
+val f : 'used -> 'used = <fun>
+|}]
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 777b16ec324..1303ca9470f 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -6249,7 +6249,7 @@ and type_expect_
       in
       re { exp with exp_extra =
              (Texp_poly cty, loc, sexp.pexp_attributes) :: exp.exp_extra }
-  | Pexp_newtype({txt=name}, sbody) ->
+  | Pexp_newtype(name, sbody) ->
     type_newtype_expr ~loc ~env ~expected_mode ~rue ~attributes:sexp.pexp_attributes
       name None sbody
   | Pexp_pack m ->
@@ -6687,7 +6687,7 @@ and type_function
       (* Check everything else in the scope of (type a). *)
       let (params, body, newtypes, contains_gadt, fun_alloc_mode, ret_info),
           exp_type, jkind_annot =
-        type_newtype loc env newtype_var.txt jkind_annot (fun env ->
+        type_newtype env newtype_var jkind_annot (fun env ->
           let { function_ = exp_type, params, body;
                 newtypes; params_contain_gadt = contains_gadt;
                 fun_alloc_mode; ret_info;
@@ -8282,9 +8282,10 @@ and type_function_cases_expect
       by the user.
 *)
 and type_newtype
-  : type a. _ -> _ -> _ -> _ -> (Env.t -> a * type_expr)
+  : type a. _ -> _ -> _ -> (Env.t -> a * type_expr)
     -> a * type_expr * Jkind.annotation option =
-  fun loc env name jkind_annot_opt type_body  ->
+  fun env name jkind_annot_opt type_body  ->
+  let { txt = name; loc = name_loc } : _ Location.loc = name in
   let jkind, jkind_annot =
     Jkind.of_annotation_option_default ~context:(Newtype_declaration name)
       ~default:(Jkind.value ~why:Univar) jkind_annot_opt
@@ -8298,7 +8299,7 @@ and type_newtype
   (* Use [with_local_level] just for scoping *)
   with_local_level begin fun () ->
     (* Create a fake abstract type declaration for name. *)
-    let decl = new_local_type ~loc jkind ~jkind_annot in
+    let decl = new_local_type ~loc:name_loc jkind ~jkind_annot in
     let scope = create_scope () in
     let (id, new_env) = Env.enter_type ~scope name decl env in
 
@@ -8324,7 +8325,7 @@ and type_newtype
 and type_newtype_expr
     ~loc ~env ~expected_mode ~rue ~attributes name jkind_annot_opt sbody =
   let body, ety, jkind_annot =
-    type_newtype loc env name jkind_annot_opt (fun env ->
+    type_newtype env name jkind_annot_opt (fun env ->
       let expr = type_exp env expected_mode sbody in
       expr, expr.exp_type)
   in
@@ -8332,7 +8333,7 @@ and type_newtype_expr
      any new extra node in the typed AST. *)
   rue { body with exp_loc = loc; exp_type = ety;
         exp_extra =
-        (Texp_newtype (name, jkind_annot),
+        (Texp_newtype (name.txt, jkind_annot),
          loc, attributes) :: body.exp_extra }
 
 (* Typing of let bindings *)
@@ -9214,7 +9215,7 @@ and type_jkind_expr
       ~loc ~env ~expected_mode ~ty_expected:_ ~explanation:_ ~rue ~attributes
   : Jane_syntax.Layouts.expression -> _ = function
   | Lexp_constant x -> type_unboxed_constant ~loc ~env ~rue ~attributes x
-  | Lexp_newtype ({txt=name}, jkind_annot, sbody) ->
+  | Lexp_newtype (name, jkind_annot, sbody) ->
     type_newtype_expr ~loc ~env ~expected_mode ~rue ~attributes
       name (Some jkind_annot) sbody