From 9b29b6bd5989019903df9c1f234d2eff9ae2e0d5 Mon Sep 17 00:00:00 2001
From: David Vulakh <33737747+dvulakh@users.noreply.github.com>
Date: Mon, 13 Jan 2025 11:59:02 -0500
Subject: [PATCH] Fix bug in variance & injectivity normalization (#96)

the mapper just didn't walk the location, so it was not being erased
in the normalization pass
---
 test/passing/dune.inc                 | 36 +++++++++++++++++++++++++++
 test/passing/tests/variance.ml        |  3 +++
 test/passing/tests/variance.ml.js-ref |  7 ++++++
 test/passing/tests/variance.ml.ref    |  5 ++++
 vendor/parser-extended/ast_mapper.ml  | 13 +++++++++-
 5 files changed, 63 insertions(+), 1 deletion(-)
 create mode 100644 test/passing/tests/variance.ml
 create mode 100644 test/passing/tests/variance.ml.js-ref
 create mode 100644 test/passing/tests/variance.ml.ref

diff --git a/test/passing/dune.inc b/test/passing/dune.inc
index 933de953be..f3a498f741 100644
--- a/test/passing/dune.inc
+++ b/test/passing/dune.inc
@@ -11906,6 +11906,42 @@
  (package ocamlformat)
  (action (diff tests/use_file.mlt.js-err use_file.mlt.js-stderr)))
 
+(rule
+ (deps tests/.ocamlformat )
+ (package ocamlformat)
+ (action
+  (with-stdout-to variance.ml.stdout
+   (with-stderr-to variance.ml.stderr
+     (run %{bin:ocamlformat} --margin-check %{dep:tests/variance.ml})))))
+
+(rule
+ (alias runtest)
+ (package ocamlformat)
+ (action (diff tests/variance.ml.ref variance.ml.stdout)))
+
+(rule
+ (alias runtest)
+ (package ocamlformat)
+ (action (diff tests/variance.ml.err variance.ml.stderr)))
+
+(rule
+ (deps tests/.ocamlformat )
+ (package ocamlformat)
+ (action
+  (with-stdout-to variance.ml.js-stdout
+   (with-stderr-to variance.ml.js-stderr
+     (run %{bin:ocamlformat} --profile=janestreet --enable-outside-detected-project --disable-conf-files %{dep:tests/variance.ml})))))
+
+(rule
+ (alias runtest)
+ (package ocamlformat)
+ (action (diff tests/variance.ml.js-ref variance.ml.js-stdout)))
+
+(rule
+ (alias runtest)
+ (package ocamlformat)
+ (action (diff tests/variance.ml.js-err variance.ml.js-stderr)))
+
 (rule
  (deps tests/.ocamlformat )
  (package ocamlformat)
diff --git a/test/passing/tests/variance.ml b/test/passing/tests/variance.ml
new file mode 100644
index 0000000000..182dea1870
--- /dev/null
+++ b/test/passing/tests/variance.ml
@@ -0,0 +1,3 @@
+(* Regression test for variance/injectivity markers tripping the roundtrip check *)
+ type !_ t
+let _ = fun (type a) -> (function _ -> ())
diff --git a/test/passing/tests/variance.ml.js-ref b/test/passing/tests/variance.ml.js-ref
new file mode 100644
index 0000000000..eca178bdcc
--- /dev/null
+++ b/test/passing/tests/variance.ml.js-ref
@@ -0,0 +1,7 @@
+(* Regression test for variance/injectivity markers tripping the roundtrip check *)
+type !_ t
+
+let _ =
+  fun (type a) -> function
+  | _ -> ()
+;;
diff --git a/test/passing/tests/variance.ml.ref b/test/passing/tests/variance.ml.ref
new file mode 100644
index 0000000000..7d58cc6ff2
--- /dev/null
+++ b/test/passing/tests/variance.ml.ref
@@ -0,0 +1,5 @@
+(* Regression test for variance/injectivity markers tripping the roundtrip
+   check *)
+type !_ t
+
+let _ = fun (type a) -> function _ -> ()
diff --git a/vendor/parser-extended/ast_mapper.ml b/vendor/parser-extended/ast_mapper.ml
index 7b747b3013..9008a855b4 100644
--- a/vendor/parser-extended/ast_mapper.ml
+++ b/vendor/parser-extended/ast_mapper.ml
@@ -74,6 +74,8 @@ type mapper = {
   typ: mapper -> core_type -> core_type;
   type_declaration: mapper -> type_declaration -> type_declaration;
   type_extension: mapper -> type_extension -> type_extension;
+  variance_and_injectivity: mapper -> Asttypes.variance_and_injectivity
+                            -> Asttypes.variance_and_injectivity;
   kind_abbreviation: mapper -> kind_abbreviation -> kind_abbreviation;
   type_exception: mapper -> type_exception -> type_exception;
   type_kind: mapper -> type_kind -> type_kind;
@@ -237,6 +239,8 @@ module T = struct
         constr_unboxed ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl)
     (* End Jane Street extension *)
 
+  let map_variance_and_injectivity sub = List.map (map_loc sub)
+
   let map_type_declaration sub
       {ptype_name; ptype_params; ptype_cstrs;
        ptype_kind;
@@ -248,9 +252,15 @@ module T = struct
       } =
     let loc = sub.location sub ptype_loc in
     let attrs = sub.attributes sub ptype_attributes in
+    let params =
+      List.map
+        (fun (ct, var_inj) ->
+          sub.typ sub ct, sub.variance_and_injectivity sub var_inj)
+        ptype_params
+    in
     Type.mk ~loc ~attrs (map_loc sub ptype_name)
       ?jkind:(ptype_jkind)
-      ~params:(List.map (map_fst (sub.typ sub)) ptype_params)
+      ~params
       ~priv:(Flag.map_private sub ptype_private)
       ~cstrs:(List.map
                 (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub))
@@ -849,6 +859,7 @@ let default_mapper =
     class_description =
       (fun this -> CE.class_infos this (this.class_type this));
     type_declaration = T.map_type_declaration;
+    variance_and_injectivity = T.map_variance_and_injectivity;
     type_kind = T.map_type_kind;
     typ = T.map;
     type_extension = T.map_type_extension;