Upstream looping patch for short-path (#1645)

from voodoos/short-paths-loop

CHANGES.md

@@ -8,6 +8,8 @@ unreleased
       warning 42 (disambiguated name) is active.
     - Correctly invalidate PPX cache when pipeline ran partially (#1650,
       fixes #1647)
+    - Prevent `short-path` from looping in some cases related to recursive type
+      definitions (#1645)
   + editor modes
     - emacs: call merlin-client-logger with "interrupted" if the
       merlin binary itself is interrupted, not just the parsing of the

src/ocaml/typing/env.ml

@@ -1712,8 +1712,8 @@ let prefix_idents root prefixing_sub sg =
 
 (* Short path additions *)
 
-let short_paths_type predef id decl old =
-  if not predef && !Clflags.real_paths then old
+let short_paths_type ~long_path predef id decl old =
+  if long_path || (not predef && !Clflags.real_paths) then old
   else Type(id, decl) :: old
 
 let short_paths_type_open path decls old =
@@ -2080,7 +2080,7 @@ and store_label ~check type_decl type_id lbl_id lbl env =
     labels = TycompTbl.add lbl_id lbl env.labels;
   }
 
-and store_type ~check ~predef id info shape env =
+and store_type ~check ~long_path ~predef id info shape env =
   let loc = info.type_loc in
   if check then
     check_usage loc id info.type_uid
@@ -2117,7 +2117,7 @@ and store_type ~check ~predef id info shape env =
     types = IdTbl.add id tda env.types;
     summary = Env_type(env.summary, id, info);
     short_paths_additions =
-      short_paths_type predef id info env.short_paths_additions; }
+      short_paths_type ~long_path predef id info env.short_paths_additions; }
 
 and store_type_infos ~tda_shape id info env =
   (* Simplified version of store_type that doesn't compute and store
@@ -2136,7 +2136,7 @@ and store_type_infos ~tda_shape id info env =
     types = IdTbl.add id tda env.types;
     summary = Env_type(env.summary, id, info);
     short_paths_additions =
-      short_paths_type false id info env.short_paths_additions; }
+      short_paths_type ~long_path:false false id info env.short_paths_additions; }
 
 and store_extension ~check ~rebind id addr ext shape env =
   let loc = ext.ext_loc in
@@ -2360,7 +2360,7 @@ let enter_value ?check name desc env =
 
 let enter_type ~scope name info env =
   let id = Ident.create_scoped ~scope name in
-  let env = store_type ~check:true ~predef:false
+  let env = store_type ~check:true ~predef:false ~long_path:false
     id info (Shape.leaf info.type_uid) env
   in
   (id, env)
@@ -2412,7 +2412,8 @@ let add_item (map, mod_shape) comp env =
       map, add_value ?shape id decl env
   | Sig_type(id, decl, _, _) ->
       let map, shape = proj_shape (Shape.Item.type_ id) in
-      map, add_type ~check:false ~predef:false ?shape id decl env
+      map,
+      add_type ~long_path:false ~check:false ~predef:false ?shape id decl env
   | Sig_typext(id, ext, _, _) ->
       let map, shape = proj_shape (Shape.Item.extension_constructor id) in
       map, add_extension ~check:false ?shape ~rebind:false id ext env
@@ -2704,12 +2705,15 @@ let save_signature_with_imports ~alerts sg modname filename imports =
 (* Make the initial environment *)
 let (initial_safe_string, initial_unsafe_string) =
   Predef.build_initial_env
-    (add_type ~check:false ~predef:true)
+    (add_type ~check:false ~predef:true ~long_path:false)
     (add_extension ~check:false ~rebind:false)
     empty
 
+let add_type_long_path ~check id info env =
+  add_type ~check ~predef:false ~long_path:true id info env
+
 let add_type ~check id info env =
-  add_type ~check ~predef:false id info env
+  add_type ~check ~predef:false ~long_path:false id info env
 
 (* Tracking usage *)
 

src/ocaml/typing/env.mli

@@ -285,6 +285,7 @@ val make_copy_of_types: t -> (t -> t)
 val add_value:
     ?check:(string -> Warnings.t) -> Ident.t -> value_description -> t -> t
 val add_type: check:bool -> Ident.t -> type_declaration -> t -> t
+val add_type_long_path: check:bool -> Ident.t -> type_declaration -> t -> t
 val add_extension:
   check:bool -> rebind:bool -> Ident.t -> extension_constructor -> t -> t
 val add_module: ?arg:bool -> ?shape:Shape.t ->

src/ocaml/typing/typedecl.ml

@@ -82,9 +82,12 @@ let get_unboxed_from_attributes sdecl =
 
 (* Enter all declared types in the environment as abstract types *)
 
-let add_type ~check id decl env =
+let add_type ~long_path ~check id decl env =
   Builtin_attributes.warning_scope ~ppwarning:false decl.type_attributes
-    (fun () -> Env.add_type ~check id decl env)
+    (fun () ->
+       match long_path with
+       | true -> Env.add_type_long_path ~check id decl env
+       | false -> Env.add_type ~check id decl env)
 
 let enter_type rec_flag env sdecl (id, uid) =
   let needed =
@@ -122,7 +125,7 @@ let enter_type rec_flag env sdecl (id, uid) =
       type_uid = uid;
     }
   in
-  add_type ~check:true id decl env
+  add_type ~long_path:true ~check:true id decl env
 
 let update_type temp_env env id loc =
   let path = Path.Pident id in
@@ -847,7 +850,7 @@ let check_redefined_unit (td: Parsetree.type_declaration) =
 
 let add_types_to_env decls env =
   List.fold_right
-    (fun (id, decl) env -> add_type ~check:true id decl env)
+    (fun (id, decl) env -> add_type ~long_path:false ~check:true id decl env)
     decls env
 
 (* Translate a set of type declarations, mutually recursive or not *)

tests/test-dirs/sp-normalization.t

@@ -0,0 +1,56 @@
+  $ cat >test.ml <<'EOF'
+  > module Id = struct
+  >   type 'a t = 'a
+  > end
+  > 
+  > module Unit = struct
+  >   type t = unit
+  > end
+  > 
+  > type 'a t =
+  >   | Id of 'a t Id.t
+  >   | Unit of Unit.t
+  > EOF
+
+This query should not hang indefinitely
+  $ $MERLIN single type-enclosing -position 11:17 -short-paths \
+  > -filename test.ml < test.ml |
+  > jq '.value'
+  [
+    {
+      "start": {
+        "line": 11,
+        "col": 12
+      },
+      "end": {
+        "line": 11,
+        "col": 18
+      },
+      "type": "type t = unit",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 11,
+        "col": 12
+      },
+      "end": {
+        "line": 11,
+        "col": 18
+      },
+      "type": "unit",
+      "tail": "no"
+    },
+    {
+      "start": {
+        "line": 9,
+        "col": 0
+      },
+      "end": {
+        "line": 11,
+        "col": 18
+      },
+      "type": "type 'a t = Id of 'a t | Unit of unit",
+      "tail": "no"
+    }
+  ]