Merge changes in Merlin

Author: voodoos

src/ocaml/typing/includemod.ml

@@ -452,21 +452,35 @@ and try_modtypes ~in_eq ~loc env ~mark subst mty1 mty2 orig_shape =
         functor_param ~in_eq ~loc env ~mark:(negate_mark mark)
           subst param1 param2
       in
-      (* Using a fresh variable with a placeholder uid here is fine: users will
-         never try to jump to the definition of that variable.
-         If they try to jump to the parameter from inside the functor, they will
-         use the variable shape that is stored in the local environment.  *)
-      let var, shape_var = Shape.fresh_var Uid.internal_not_actually_unique in
-      let cc_res =
-        let res_shape = Shape.app orig_shape ~arg:shape_var in
-        modtypes ~in_eq ~loc env ~mark subst res1 res2 res_shape
+      let var, res_shape =
+        match Shape.decompose_abs orig_shape with
+        | Some (var, res_shape) -> var, res_shape
+        | None ->
+            (* Using a fresh variable with a placeholder uid here is fine: users
+               will never try to jump to the definition of that variable.
+               If they try to jump to the parameter from inside the functor,
+               they will use the variable shape that is stored in the local
+               environment.  *)
+            let var, shape_var =
+              Shape.fresh_var Uid.internal_not_actually_unique
+            in
+            var, Shape.app orig_shape ~arg:shape_var
       in
+      let cc_res = modtypes ~in_eq ~loc env ~mark subst res1 res2 res_shape in
       begin match cc_arg, cc_res with
-      | Ok Tcoerce_none, Ok (Tcoerce_none, res_shape) ->
-          let final_shape = Shape.abs var res_shape in
+      | Ok Tcoerce_none, Ok (Tcoerce_none, final_res_shape) ->
+          let final_shape =
+            if final_res_shape == res_shape
+            then orig_shape
+            else Shape.abs var final_res_shape
+          in
           Ok (Tcoerce_none, final_shape)
-      | Ok cc_arg, Ok (cc_res, res_shape) ->
-          let final_shape = Shape.abs var res_shape in
+      | Ok cc_arg, Ok (cc_res, final_res_shape) ->
+          let final_shape =
+            if final_res_shape == res_shape
+            then orig_shape
+            else Shape.abs var final_res_shape
+          in
           Ok (Tcoerce_functor(cc_arg, cc_res), final_shape)
       | _, Error {Error.symptom = Error.Functor Error.Params res; _} ->
           let got_params, got_res = res.got in
@@ -562,33 +576,31 @@ and signatures  ~in_eq ~loc env ~mark subst sig1 sig2 mod_shape =
       ([], 0) sig1 in
   (* Build a table of the components of sig1, along with their positions.
      The table is indexed by kind and name of component *)
-  let rec build_component_table pos tbl = function
-      [] -> pos, tbl
-    | (Sig_value (_, _, Hidden)
-      |Sig_type (_, _, _, Hidden)
-      |Sig_typext (_, _, _, Hidden)
-      |Sig_module (_, _, _, _, Hidden)
-      |Sig_modtype (_, _, Hidden)
-      |Sig_class (_, _, _, Hidden)
-      |Sig_class_type (_, _, _, Hidden)
-      ) as item :: rem ->
-        let pos = if is_runtime_component item then pos + 1 else pos in
-        build_component_table pos tbl rem (* do not pair private items. *)
+  let rec build_component_table nb_exported pos tbl = function
+      [] -> nb_exported, pos, tbl
     | item :: rem ->
-        let (id, _loc, name) = item_ident_name item in
         let pos, nextpos =
           if is_runtime_component item then pos, pos + 1
           else -1, pos
         in
-        build_component_table nextpos
-                              (FieldMap.add name (id, item, pos) tbl) rem in
-  let len1, comps1 =
-    build_component_table 0 FieldMap.empty sig1 in
-  let len2 =
-    List.fold_left
-      (fun n i -> if is_runtime_component i then n + 1 else n)
-      0
-      sig2
+        match item_visibility item with
+        | Hidden ->
+            (* do not pair private items. *)
+            build_component_table nb_exported nextpos tbl rem
+        | Exported ->
+            let (id, _loc, name) = item_ident_name item in
+            build_component_table (nb_exported + 1) nextpos
+              (FieldMap.add name (id, item, pos) tbl) rem
+  in
+  let exported_len1, runtime_len1, comps1 =
+    build_component_table 0 0 FieldMap.empty sig1
+  in
+  let exported_len2, runtime_len2 =
+    List.fold_left (fun (el, rl) i ->
+      let el = match item_visibility i with Hidden -> el | Exported -> el + 1 in
+      let rl = if is_runtime_component i then rl + 1 else rl in
+      el, rl
+    ) (0, 0) sig2
   in
   (* Pair each component of sig2 with a component of sig1,
      identifying the names along the way.
@@ -597,15 +609,19 @@ and signatures  ~in_eq ~loc env ~mark subst sig1 sig2 mod_shape =
      and the coercion to be applied to it. *)
   let rec pair_components subst paired unpaired = function
       [] ->
-        let oks, shape_map, errors =
+        let oks, (shape_map, deep_modifications), errors =
           signature_components ~in_eq ~loc env ~mark new_env subst mod_shape
             Shape.Map.empty
             (List.rev paired)
         in
         begin match unpaired, errors, oks with
             | [], [], cc ->
-                let shape = Shape.str ?uid:mod_shape.Shape.uid shape_map in
-                if len1 = len2 then (* see PR#5098 *)
+                let shape =
+                  if not deep_modifications && exported_len1 = exported_len2
+                  then mod_shape
+                  else Shape.str ?uid:mod_shape.Shape.uid shape_map
+                in
+                if runtime_len1 = runtime_len2 then (* see PR#5098 *)
                   Ok (simplify_structure_coercion cc id_pos_list, shape)
                 else
                   Ok (Tcoerce_structure (cc, id_pos_list), shape)
@@ -655,8 +671,9 @@ and signatures  ~in_eq ~loc env ~mark subst sig1 sig2 mod_shape =
 and signature_components  ~in_eq ~loc old_env ~mark env subst
     orig_shape shape_map paired =
   match paired with
-  | [] -> [], shape_map, []
+  | [] -> [], (shape_map, false), []
   | (sigi1, sigi2, pos) :: rem ->
+      let shape_modified = ref false in
       let id, item, shape_map, present_at_runtime =
         match sigi1, sigi2 with
         | Sig_value(id1, valdecl1, _) ,Sig_value(_id2, valdecl2, _) ->
@@ -695,6 +712,7 @@ and signature_components  ~in_eq ~loc old_env ~mark env subst
               let item, shape_map =
                 match item with
                 | Ok (cc, shape) ->
+                    if shape != orig_shape then shape_modified := true;
                     let mod_shape = Shape.set_uid_if_none shape mty1.md_uid in
                     Ok cc, Shape.Map.add_module shape_map id1 mod_shape
                 | Error diff ->
@@ -741,10 +759,11 @@ and signature_components  ~in_eq ~loc old_env ~mark env subst
         | _ ->
             assert false
       in
-      let oks, final_map, errors =
+      let oks, (final_map, deep_modifications), errors =
         signature_components ~in_eq ~loc old_env ~mark env subst
           orig_shape shape_map rem
       in
+      let final_map = final_map, deep_modifications || !shape_modified in
       match item with
       | Ok x when present_at_runtime -> (pos,x) :: oks, final_map, errors
       | Ok _ -> oks, final_map, errors