Merge pull request #1334 from voodoos/issue1322

Don't repeat environment entries in Typemod.check_type_decl (ocaml/ocaml#10382)

CHANGES.md

@@ -13,6 +13,7 @@ Mon Jul 26 11:12:21 PM CET 2021
     - ignore `-error-style` compiler flag (#1402, @nojb)
     - fix handling of record field expressions (#1375)
     - allow -pp to return an AST (#1394)
+    - fix merlin crashing due to short-paths (#1334, fixes #1322)
   + editor modes
     - update quick setup instructions for emacs (#1380, @ScriptDevil)
   + test suite

src/ocaml/typing/typemod.ml

@@ -246,21 +246,28 @@ let check_recmod_typedecls env decls =
 
 (* Merge one "with" constraint in a signature *)
 
-let rec add_rec_types env = function
-    Sig_type(id, decl, Trec_next, _) :: rem ->
-      add_rec_types (Env.add_type ~check:true id decl env) rem
-  | _ -> env
-
-let check_type_decl env loc id row_id newdecl decl rs rem =
-  let env = Env.add_type ~check:true id newdecl env in
-  let env =
+let check_type_decl env loc id row_id newdecl decl =
+  let fresh_id = Ident.rename id in
+  let path = Pident fresh_id in
+  let sub = Subst.add_type id path Subst.identity in
+  let fresh_row_id, sub =
     match row_id with
+    | None -> None, sub
+    | Some id ->
+      let fresh_row_id = Some (Ident.rename id) in
+      let sub = Subst.add_type id (Pident fresh_id) sub in
+      fresh_row_id, sub
+  in
+  let newdecl = Subst.type_declaration sub newdecl in
+  let decl = Subst.type_declaration sub decl in
+  let env = Env.add_type ~check:false fresh_id newdecl env in
+  let env =
+    match fresh_row_id with
     | None -> env
-    | Some id -> Env.add_type ~check:false id newdecl env
+    | Some fresh_row_id -> Env.add_type ~check:false fresh_row_id newdecl env
   in
-  let env = if rs = Trec_not then env else add_rec_types env rem in
-  Includemod.type_declarations ~mark:Mark_both ~loc env id newdecl decl;
-  Typedecl.check_coherence env loc (Path.Pident id) newdecl
+  Includemod.type_declarations ~mark:Mark_both ~loc env fresh_id newdecl decl;
+  Typedecl.check_coherence env loc path newdecl
 
 let update_rec_next rs rem =
   match rs with
@@ -515,7 +522,7 @@ let merge_constraint initial_env remove_aliases loc sg constr =
           Typedecl.transl_with_constraint id (Some(Pident id_row))
             ~sig_env ~sig_decl:decl ~outer_env:initial_env sdecl in
         let newdecl = tdecl.typ_type in
-        check_type_decl sig_env sdecl.ptype_loc id row_id newdecl decl rs rem;
+        check_type_decl sig_env sdecl.ptype_loc id row_id newdecl decl;
         let decl_row = {decl_row with type_params = newdecl.type_params} in
         let rs' = if rs = Trec_first then Trec_not else rs in
         (Pident id, lid, Twith_type tdecl),
@@ -529,7 +536,7 @@ let merge_constraint initial_env remove_aliases loc sg constr =
           Typedecl.transl_with_constraint id None
             ~sig_env ~sig_decl ~outer_env:initial_env sdecl in
         let newdecl = tdecl.typ_type and loc = sdecl.ptype_loc in
-        check_type_decl sig_env loc id row_id newdecl sig_decl rs rem;
+        check_type_decl sig_env loc id row_id newdecl sig_decl;
         begin match constr with
           Pwith_type _ ->
             (Pident id, lid, Twith_type tdecl),

tests/test-dirs/issue1322.t/.merlin

@@ -0,0 +1 @@
+FLG -short-paths

tests/test-dirs/issue1322.t/foo.ml

@@ -0,0 +1,7 @@
+module type Monad = sig
+  type 'a t
+end
+module type Monad_option =
+  Monad
+    with type 'a t = 'a option
+    constraint 'a = int

tests/test-dirs/issue1322.t/nasty.ml

@@ -0,0 +1,9 @@
+module type S = sig
+  type 'a t = 'a
+    constraint 'a = < m : r >
+  and r = (< m : r >) t
+end
+
+module type S = sig type 'a t = 'a constraint 'a = < m : r > and r = < m : r > t end
+
+module type T = S with type 'a t = 'b constraint 'a = < m : 'b >

tests/test-dirs/issue1322.t/run.t

@@ -0,0 +1,36 @@
+  $ $MERLIN single errors -filename foo.ml < foo.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 5,
+          "col": 2
+        },
+        "end": {
+          "line": 7,
+          "col": 23
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "In this `with' constraint, the new definition of t
+  does not match its original definition in the constrained signature:
+  Type declarations do not match:
+    type 'a t = 'a t constraint 'a = int
+  is not included in
+    type 'a t
+  Their constraints differ.
+  File \"foo.ml\", line 2, characters 2-11: Expected declaration
+  File \"foo.ml\", line 6, characters 9-54: Actual declaration"
+      }
+    ],
+    "notifications": []
+  }
+
+  $ $MERLIN single errors -filename nasty.ml < nasty.ml
+  {
+    "class": "return",
+    "value": [],
+    "notifications": []
+  }