Fix 1913

CHANGES.md

@@ -11,6 +11,10 @@ unreleased
     - Fix issues with ident validation and Lid comparison for occurrences (#1924)
     - Handle class type in outline (#1932)
     - Handle locally defined value in outline (#1936)
+    - Fix a typer issue triggering assertions in the short-paths graph (#1935,
+      fixes #1913)
+    - Downstreamed a typer fix from 5.3.X that would trigger assertions linked
+      to scopes bit masks when backtracking the typer cache (#1935)
   + ocaml-index
     - Improve the granularity of index reading by segmenting the marshalization
       of the involved data-structures. (#1889)

src/ocaml/typing/env.ml

@@ -2393,9 +2393,9 @@ let enter_value ?check name desc env =
   let env = store_value ?check id addr desc (Shape.leaf desc.val_uid) env in
   (id, env)
 
-let enter_type ~scope name info env =
+let enter_type ?(long_path = false) ~scope name info env =
   let id = Ident.create_scoped ~scope name in
-  let env = store_type ~check:true ~predef:false ~long_path:false
+  let env = store_type ~check:true ~predef:false ~long_path
     id info (Shape.leaf info.type_uid) env
   in
   (id, env)

src/ocaml/typing/env.mli

@@ -359,7 +359,9 @@ val remove_last_open: Path.t -> t -> t option
 val enter_value:
     ?check:(string -> Warnings.t) ->
     string -> value_description -> t -> Ident.t * t
-val enter_type: scope:int -> string -> type_declaration -> t -> Ident.t * t
+val enter_type:
+  ?long_path:bool -> scope:int ->
+  string -> type_declaration -> t -> Ident.t * t
 val enter_extension:
   scope:int -> rebind:bool -> string ->
   extension_constructor -> t -> Ident.t * t

src/ocaml/typing/short_paths_graph.ml

@@ -14,6 +14,7 @@ module Ident = struct
   let global name =
     Ident.create_persistent name
 
+  let print_with_scope t = Ident.print_with_scope t
 end
 
 module Ident_map = Map.Make(Ident)
@@ -1153,36 +1154,39 @@ end = struct
       module_type_names = String_map.empty;
       module_names = String_map.empty; }
 
-  let previous_type t id =
+  let failwith_id msg id =
+    failwith (Format_doc.asprintf "%s: %a" msg Ident.print_with_scope id)
+
+  let previous_type _desc t id =
     match Ident_map.find id t.types with
     | exception Not_found -> None
     | prev ->
       match Type.declaration prev with
-      | None -> failwith "Graph.add: type already defined"
+      | None -> failwith_id "Graph.add: type already defined" id
       | Some _ as o -> o
 
   let previous_class_type t id =
     match Ident_map.find id t.class_types with
     | exception Not_found -> None
     | prev ->
       match Class_type.declaration prev with
-      | None -> failwith "Graph.add: class type already defined"
+      | None -> failwith_id "Graph.add: class type already defined" id
       | Some _ as o -> o
 
   let previous_module_type t id =
     match Ident_map.find id t.module_types with
     | exception Not_found -> None
     | prev ->
       match Module_type.declaration prev with
-      | None -> failwith "Graph.add: module type already defined"
+      | None -> failwith_id "Graph.add: module type already defined" id
       | Some _ as o -> o
 
   let previous_module t id =
     match Ident_map.find id t.modules with
     | exception Not_found -> None
     | prev ->
       match Module.declaration prev with
-      | None -> failwith "Graph.add: module already defined"
+      | None -> failwith_id "Graph.add: module already defined" id
       | Some _ as o -> o
 
   let add_name source id names =
@@ -1213,7 +1217,7 @@ end = struct
     let rec loop acc diff declarations = function
       | [] -> loop_declarations acc diff declarations
       | Component.Type(origin, id, desc, source, dpr) :: rest ->
-          let prev = previous_type acc id in
+          let prev = previous_type desc acc id in
           let typ = Type.base origin id (Some desc) dpr in
           let types = Ident_map.add id typ acc.types in
           let type_names = add_name source id acc.type_names in

src/ocaml/typing/typecore.ml

@@ -913,7 +913,8 @@ let solve_constructor_annotation
           new_local_type ~loc:name.loc Definition
             ~manifest_and_scope:(tv, Ident.lowest_scope) in
         let (id, new_env) =
-          Env.enter_type ~scope:expansion_scope name.txt decl !!penv in
+          (* These redundant types should not be added to the shortpath graph *)
+          Env.enter_type ~long_path:true ~scope:expansion_scope name.txt decl !!penv in
         Pattern_env.set_env penv new_env;
         ({name with txt = id}, (decl, tv)))
       name_list

src/ocaml/typing/types.ml

@@ -515,9 +515,7 @@ type changes =
   | Unchanged
   | Invalid
 
-open Local_store
-
-let trail = s_table ref Unchanged
+let trail = Local_store.s_table ref Unchanged
 
 let log_change ch =
   let r' = ref Unchanged in
@@ -641,7 +639,7 @@ module Transient_expr = struct
   let get_marks ty = ty.scope lsr 27
   let set_scope ty sc =
     if (sc land marks_mask <> 0) then
-      invalid_arg "Types.Transient_expr.set_scope";
+      invalid_arg(Format.sprintf "Types.Transient_expr.set_scope %i" sc);
     ty.scope <- (ty.scope land marks_mask) lor sc
   let try_mark_node mark ty =
     match mark with
@@ -815,7 +813,7 @@ let undo_change = function
 
 type snapshot = changes ref * int
 let last_snapshot = Local_store.s_ref 0
-let linked_variables = s_ref 0
+let linked_variables = Local_store.s_ref 0
 
 let log_type ty =
   if ty.id <= !last_snapshot then log_change (Ctype (ty, ty.desc))
@@ -864,7 +862,7 @@ let set_level ty level =
 (* TODO: introduce a guard and rename it to set_higher_scope? *)
 let set_scope ty scope =
   let ty = repr ty in
-  let prev_scope = ty.scope land marks_mask in
+  let prev_scope = ty.scope land scope_mask in
   if scope <> prev_scope then begin
     if ty.id <= !last_snapshot then log_change (Cscope (ty, prev_scope));
     Transient_expr.set_scope ty scope

tests/test-dirs/short-paths/double-trouble.t

@@ -0,0 +1,29 @@
+Found in issue #1913
+
+  $ cat >test.ml <<EOF
+  > type _ plus = | Zero : 'm plus |  Suc : 'm plus -> 'm plus
+  > type _ has_plus = Plus : 'm plus -> unit has_plus;;
+  > let (Plus (type mn3) (ed : mn3 plus) ) = Plus (Suc Zero) in ed + 2
+  > EOF
+
+  $ $MERLIN single errors -short-paths -filename test.ml < test.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 3,
+          "col": 60
+        },
+        "end": {
+          "line": 3,
+          "col": 62
+        },
+        "type": "typer",
+        "sub": [],
+        "valid": true,
+        "message": "The value ed has type mn3 plus but an expression was expected of type int"
+      }
+    ],
+    "notifications": []
+  }