From 2e7801d8b5e053bb27d0a58d4688d0265d0795e5 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Wed, 27 Sep 2023 12:51:06 +0200
Subject: [PATCH 01/58] Pull changes from upsteam 4.14+index

---
 upstream/ocaml_414/base-rev.txt               |   2 +-
 upstream/ocaml_414/file_formats/cmt_format.ml | 340 +++++++++++++++++-
 .../ocaml_414/file_formats/cmt_format.mli     |  20 +-
 upstream/ocaml_414/typing/cmt2annot.ml        |   2 +-
 upstream/ocaml_414/typing/env.ml              |  14 +-
 upstream/ocaml_414/typing/env.mli             |  10 +-
 upstream/ocaml_414/typing/includemod.ml       |  14 +
 upstream/ocaml_414/typing/parmatch.ml         |  37 +-
 upstream/ocaml_414/typing/patterns.ml         |  18 +-
 upstream/ocaml_414/typing/patterns.mli        |   4 +-
 upstream/ocaml_414/typing/printpat.ml         |   4 +-
 upstream/ocaml_414/typing/printtyped.ml       |   4 +-
 upstream/ocaml_414/typing/rec_check.ml        |   6 +-
 upstream/ocaml_414/typing/shape.ml            | 237 +++++++++---
 upstream/ocaml_414/typing/shape.mli           |  85 ++++-
 upstream/ocaml_414/typing/tast_iterator.ml    |   6 +-
 upstream/ocaml_414/typing/tast_mapper.ml      |   2 +-
 upstream/ocaml_414/typing/typeclass.ml        |   2 +-
 upstream/ocaml_414/typing/typecore.ml         |  52 +--
 upstream/ocaml_414/typing/typecore.mli        |   1 +
 upstream/ocaml_414/typing/typedecl.ml         | 134 ++++---
 upstream/ocaml_414/typing/typedecl.mli        |   8 +-
 upstream/ocaml_414/typing/typedtree.ml        |  44 ++-
 upstream/ocaml_414/typing/typedtree.mli       |  18 +-
 upstream/ocaml_414/typing/typemod.ml          | 130 +++----
 upstream/ocaml_414/typing/typemod.mli         |   2 +
 upstream/ocaml_414/typing/untypeast.ml        |  13 +-
 upstream/ocaml_414/utils/clflags.ml           |   1 +
 upstream/ocaml_414/utils/clflags.mli          |   1 +
 29 files changed, 918 insertions(+), 293 deletions(-)

diff --git a/upstream/ocaml_414/base-rev.txt b/upstream/ocaml_414/base-rev.txt
index 32276392e2..40609893af 100644
--- a/upstream/ocaml_414/base-rev.txt
+++ b/upstream/ocaml_414/base-rev.txt
@@ -1 +1 @@
-87efa5e6681dd0fc6547ef4669883bf15c871588
+407fdf73d15aaea435af38400f115717194874c1
diff --git a/upstream/ocaml_414/file_formats/cmt_format.ml b/upstream/ocaml_414/file_formats/cmt_format.ml
index a493780e5a..88b1d26b23 100644
--- a/upstream/ocaml_414/file_formats/cmt_format.ml
+++ b/upstream/ocaml_414/file_formats/cmt_format.ml
@@ -36,14 +36,29 @@ type binary_annots =
   | Partial_interface of binary_part array
 
 and binary_part =
-| Partial_structure of structure
-| Partial_structure_item of structure_item
-| Partial_expression of expression
-| Partial_pattern : 'k pattern_category * 'k general_pattern -> binary_part
-| Partial_class_expr of class_expr
-| Partial_signature of signature
-| Partial_signature_item of signature_item
-| Partial_module_type of module_type
+  | Partial_structure of structure
+  | Partial_structure_item of structure_item
+  | Partial_expression of expression
+  | Partial_pattern : 'k pattern_category * 'k general_pattern -> binary_part
+  | Partial_class_expr of class_expr
+  | Partial_signature of signature
+  | Partial_signature_item of signature_item
+  | Partial_module_type of module_type
+
+type item_declaration =
+  | Class_declaration of class_declaration
+  | Class_description of class_description
+  | Class_type_declaration of class_type_declaration
+  | Constructor_declaration of constructor_declaration
+  | Extension_constructor of extension_constructor
+  | Label_declaration of label_declaration
+  | Module_binding of module_binding
+  | Module_declaration of module_declaration
+  | Module_substitution of module_substitution
+  | Module_type_declaration of module_type_declaration
+  | Type_declaration of type_declaration
+  | Value_binding of value_binding
+  | Value_description of value_description
 
 type cmt_infos = {
   cmt_modname : string;
@@ -60,21 +75,123 @@ type cmt_infos = {
   cmt_imports : (string * Digest.t option) list;
   cmt_interface_digest : Digest.t option;
   cmt_use_summaries : bool;
-  cmt_uid_to_loc : Location.t Shape.Uid.Tbl.t;
+  cmt_uid_to_decl : item_declaration Shape.Uid.Tbl.t;
   cmt_impl_shape : Shape.t option; (* None for mli *)
+  cmt_ident_occurrences :
+    (Longident.t Location.loc * Shape.reduction_result) list
 }
 
 type error =
     Not_a_typedtree of string
 
+let iter_on_parts (it : Tast_iterator.iterator) = function
+  | Partial_structure s -> it.structure it s
+  | Partial_structure_item s -> it.structure_item it s
+  | Partial_expression e -> it.expr it e
+  | Partial_pattern (_category, p) -> it.pat it p
+  | Partial_class_expr ce -> it.class_expr it ce
+  | Partial_signature s -> it.signature it s
+  | Partial_signature_item s -> it.signature_item it s
+  | Partial_module_type s -> it.module_type it s
+
+let iter_on_annots (it : Tast_iterator.iterator) = function
+  | Implementation s -> it.structure it s
+  | Interface s -> it.signature it s
+  | Packed _ -> ()
+  | Partial_implementation array -> Array.iter (iter_on_parts it) array
+  | Partial_interface array -> Array.iter (iter_on_parts it) array
+
+module Local_reduce = Shape.Make_reduce(struct
+    type env = Env.t
+    let fuel = 10
+
+    let read_unit_shape ~unit_name:_ = None
+
+    let find_shape env id =
+      let namespace = Shape.Sig_component_kind.Module in
+      Env.shape_of_path ~namespace env (Pident id)
+  end)
+
+let iter_on_declarations ~(f: Shape.Uid.t -> item_declaration -> unit) =
+  let f_lbl_decls ldecls =
+    List.iter (fun ({ ld_uid; _ } as ld) ->
+      f ld_uid (Label_declaration ld)) ldecls
+  in
+  Tast_iterator.{ default_iterator with
+
+  value_bindings = (fun sub ((_, vbs) as bindings) ->
+    let bound_idents = let_filter_bound vbs in
+    List.iter (fun (vb, uid) -> f uid (Value_binding vb)) bound_idents;
+    default_iterator.value_bindings sub bindings);
+
+  module_binding = (fun sub mb ->
+    f mb.mb_uid (Module_binding mb);
+    default_iterator.module_binding sub mb);
+
+  module_declaration = (fun sub md ->
+    f md.md_uid (Module_declaration md);
+    default_iterator.module_declaration sub md);
+
+  module_type_declaration = (fun sub mtd ->
+    f mtd.mtd_uid (Module_type_declaration mtd);
+    default_iterator.module_type_declaration sub mtd);
+
+  module_substitution = (fun sub ms ->
+    f ms.ms_uid (Module_substitution ms);
+    default_iterator.module_substitution sub ms);
+
+  value_description = (fun sub vd ->
+    f vd.val_val.val_uid (Value_description vd);
+    default_iterator.value_description sub vd);
+
+  type_declaration = (fun sub td ->
+    (* compiler-generated "row_names" share the uid of their corresponding
+       class declaration, so we ignore them to prevent duplication *)
+    if not (Btype.is_row_name (Ident.name td.typ_id)) then begin
+      f td.typ_type.type_uid (Type_declaration td);
+      (* We also register records labels and constructors *)
+      let f_lbl_decls ldecls =
+        List.iter (fun ({ ld_uid; _ } as ld) ->
+          f ld_uid (Label_declaration ld)) ldecls
+      in
+      match td.typ_kind with
+      | Ttype_variant constrs ->
+          List.iter (fun ({ cd_uid; cd_args; _ } as cd) ->
+            f cd_uid (Constructor_declaration cd);
+            match cd_args with
+            | Cstr_record ldecls -> f_lbl_decls ldecls
+            | Cstr_tuple _ -> ()) constrs
+      | Ttype_record labels -> f_lbl_decls labels
+      | _ -> ()
+    end;
+    default_iterator.type_declaration sub td);
+
+  extension_constructor = (fun sub ec ->
+    f ec.ext_type.ext_uid (Extension_constructor ec);
+    begin match ec.ext_kind with
+    | Text_decl (_, Cstr_record lbls,_) -> f_lbl_decls lbls
+    | _ -> () end;
+    default_iterator.extension_constructor sub ec);
+
+  class_declaration = (fun sub cd ->
+    f cd.ci_decl.cty_uid (Class_declaration cd);
+    default_iterator.class_declaration sub cd);
+
+  class_type_declaration = (fun sub ctd ->
+    f ctd.ci_decl.cty_uid (Class_type_declaration ctd);
+    default_iterator.class_type_declaration sub ctd);
+
+  class_description =(fun sub cd ->
+    f cd.ci_decl.cty_uid (Class_description cd);
+    default_iterator.class_description sub cd);
+}
+
 let need_to_clear_env =
   try ignore (Sys.getenv "OCAML_BINANNOT_WITHENV"); false
   with Not_found -> true
 
 let keep_only_summary = Env.keep_only_summary
 
-open Tast_mapper
-
 let cenv =
   {Tast_mapper.default with env = fun _sub env -> keep_only_summary env}
 
@@ -103,6 +220,194 @@ let clear_env binary_annots =
 
   else binary_annots
 
+let iter_on_usages ~index =
+  let f ~namespace env path lid =
+    let not_ghost { Location.loc = { loc_ghost; _ }; _ } = not loc_ghost in
+    if not_ghost lid then
+      match Env.shape_of_path ~namespace env path with
+      | exception Not_found -> ()
+      | path_shape ->
+        let result = Local_reduce.reduce_for_uid env path_shape in
+        index := (lid, result) :: !index
+  in
+  let path_in_type typ name =
+    match Types.get_desc typ with
+    | Tconstr (type_path, _, _) ->
+      Some (Path.Pdot (type_path,  name))
+    | _ -> None
+  in
+  let add_constructor_description env lid =
+    function
+    | { Types.cstr_tag = Cstr_extension (path, _); _ } ->
+        f ~namespace:Extension_constructor env path lid
+    | { Types.cstr_uid = Predef _; _ } -> ()
+    | { Types.cstr_res; cstr_name; _ } ->
+        let path = path_in_type cstr_res cstr_name in
+        Option.iter (fun path -> f ~namespace:Constructor env path lid) path
+  in
+  let add_label env lid { Types.lbl_name; lbl_res; _ } =
+    let path = path_in_type lbl_res lbl_name in
+    Option.iter (fun path -> f ~namespace:Label env path lid) path
+  in
+  let with_constraint ~env (_path, _lid, with_constraint) =
+    match with_constraint with
+    | Twith_module (path', lid') | Twith_modsubst (path', lid') ->
+        f ~namespace:Module env path' lid'
+    | _ -> ()
+  in
+  Tast_iterator.{ default_iterator with
+
+  expr = (fun sub ({ exp_desc; exp_env; _ } as e) ->
+      (match exp_desc with
+      | Texp_ident (path, lid, _) ->
+          f ~namespace:Value exp_env path lid
+      | Texp_construct (lid, constr_desc, _) ->
+          add_constructor_description exp_env lid constr_desc
+      | Texp_field (_, lid, label_desc)
+      | Texp_setfield (_, lid, label_desc, _) ->
+          add_label exp_env lid label_desc
+      | Texp_new (path, lid, _) ->
+          f ~namespace:Class exp_env path lid
+      | Texp_record { fields; _ } ->
+        Array.iter (fun (label_descr, record_label_definition) ->
+          match record_label_definition with
+          | Overridden (
+              { Location.txt; loc},
+              {exp_loc; _})
+              when not exp_loc.loc_ghost
+                && loc.loc_start = exp_loc.loc_start
+                && loc.loc_end = exp_loc.loc_end ->
+            (* In the presence of punning we want to index the label
+                even if it is ghosted *)
+            let lid = { Location.txt; loc = {loc with loc_ghost = false} } in
+            add_label exp_env lid label_descr
+          | Overridden (lid, _) -> add_label exp_env lid label_descr
+          | Kept _ -> ()) fields
+      | _ -> ());
+      default_iterator.expr sub e);
+
+  typ =
+    (fun sub ({ ctyp_desc; ctyp_env; _ } as ct) ->
+      (match ctyp_desc with
+      | Ttyp_constr (path, lid, _ctyps) ->
+          f ~namespace:Type ctyp_env path lid
+      | Ttyp_package {pack_path; pack_txt} ->
+          f ~namespace:Module_type ctyp_env pack_path pack_txt
+      | _ -> ());
+      default_iterator.typ sub ct);
+
+  pat =
+    (fun (type a) sub
+      ({ pat_desc; pat_extra; pat_env; _ } as pat : a general_pattern) ->
+      (match pat_desc with
+      | Tpat_construct (lid, constr_desc, _, _) ->
+          add_constructor_description pat_env lid constr_desc
+      | Tpat_record (fields, _) ->
+        List.iter (fun (lid, label_descr, pat) ->
+          let lid =
+            let open Location in
+            (* In the presence of punning we want to index the label
+               even if it is ghosted *)
+            if (not pat.pat_loc.loc_ghost
+              && lid.loc.loc_start = pat.pat_loc.loc_start
+              && lid.loc.loc_end = pat.pat_loc.loc_end)
+            then {lid with loc = {lid.loc with loc_ghost = false}}
+            else lid
+          in
+          add_label pat_env lid label_descr)
+        fields
+      | _ -> ());
+      List.iter  (fun (pat_extra, _, _) ->
+        match pat_extra with
+        | Tpat_open (path, lid, _) ->
+            f ~namespace:Module pat_env path lid
+        | Tpat_type (path, lid) ->
+            f ~namespace:Type pat_env path lid
+        | _ -> ())
+        pat_extra;
+      default_iterator.pat sub pat);
+
+  binding_op = (fun sub ({bop_op_path; bop_op_name; bop_exp; _} as bop) ->
+    let lid = { bop_op_name with txt = Longident.Lident bop_op_name.txt } in
+    f ~namespace:Value bop_exp.exp_env bop_op_path lid;
+    default_iterator.binding_op sub bop);
+
+  module_expr =
+    (fun sub ({ mod_desc; mod_env; _ } as me) ->
+      (match mod_desc with
+      | Tmod_ident (path, lid) -> f ~namespace:Module mod_env path lid
+      | _ -> ());
+      default_iterator.module_expr sub me);
+
+  open_description =
+    (fun sub ({ open_expr = (path, lid); open_env; _ } as od)  ->
+      f ~namespace:Module open_env path lid;
+      default_iterator.open_description sub od);
+
+  module_type =
+    (fun sub ({ mty_desc; mty_env; _ } as mty)  ->
+      (match mty_desc with
+      | Tmty_ident (path, lid) ->
+          f ~namespace:Module_type mty_env path lid
+      | Tmty_with (_mty, l) ->
+          List.iter (with_constraint ~env:mty_env) l
+      | Tmty_alias (path, lid) ->
+          f ~namespace:Module mty_env path lid
+      | _ -> ());
+      default_iterator.module_type sub mty);
+
+  class_expr =
+    (fun sub ({ cl_desc; cl_env; _} as ce) ->
+      (match cl_desc with
+      | Tcl_ident (path, lid, _) -> f ~namespace:Class cl_env path lid
+      | _ -> ());
+      default_iterator.class_expr sub ce);
+
+  class_type =
+    (fun sub ({ cltyp_desc; cltyp_env; _} as ct) ->
+      (match cltyp_desc with
+      | Tcty_constr (path, lid, _) -> f ~namespace:Class_type cltyp_env path lid
+      | _ -> ());
+      default_iterator.class_type sub ct);
+
+  signature_item =
+    (fun sub ({ sig_desc; sig_env; _ } as sig_item) ->
+      (match sig_desc with
+      | Tsig_exception {
+          tyexn_constructor = { ext_kind = Text_rebind (path, lid)}} ->
+          f ~namespace:Extension_constructor sig_env path lid
+      | Tsig_modsubst { ms_manifest; ms_txt } ->
+          f ~namespace:Module sig_env ms_manifest ms_txt
+      | Tsig_typext { tyext_path; tyext_txt } ->
+          f ~namespace:Type sig_env tyext_path tyext_txt
+      | _ -> ());
+      default_iterator.signature_item sub sig_item);
+
+  structure_item =
+    (fun sub ({ str_desc; str_env; _ } as str_item) ->
+      (match str_desc with
+      | Tstr_exception {
+          tyexn_constructor = { ext_kind = Text_rebind (path, lid)}} ->
+          f ~namespace:Extension_constructor str_env path lid
+      | Tstr_typext { tyext_path; tyext_txt } ->
+          f ~namespace:Type str_env tyext_path tyext_txt
+      | _ -> ());
+      default_iterator.structure_item sub str_item)
+}
+
+let index_declarations binary_annots =
+  let index : item_declaration Types.Uid.Tbl.t = Types.Uid.Tbl.create 16 in
+  let f uid fragment = Types.Uid.Tbl.add index uid fragment in
+  iter_on_annots (iter_on_declarations ~f) binary_annots;
+  index
+
+let index_usages binary_annots =
+  let index : (Longident.t Location.loc * Shape.reduction_result) list ref =
+    ref []
+  in
+  iter_on_annots (iter_on_usages ~index) binary_annots;
+  !index
+
 exception Error of error
 
 let input_cmt ic = (input_value ic : cmt_infos)
@@ -174,10 +479,18 @@ let save_cmt filename modname binary_annots sourcefile initial_env cmi shape =
            | None -> None
            | Some cmi -> Some (output_cmi temp_file_name oc cmi)
          in
+         let cmt_ident_occurrences =
+          if !Clflags.store_usage_index then
+            index_usages binary_annots
+          else
+            []
+         in
+         let cmt_annots = clear_env binary_annots in
+         let cmt_uid_to_decl = index_declarations cmt_annots in
          let source_digest = Option.map Digest.file sourcefile in
          let cmt = {
            cmt_modname = modname;
-           cmt_annots = clear_env binary_annots;
+           cmt_annots;
            cmt_value_dependencies = !value_deps;
            cmt_comments = Lexer.comments ();
            cmt_args = Sys.argv;
@@ -190,8 +503,9 @@ let save_cmt filename modname binary_annots sourcefile initial_env cmi shape =
            cmt_imports = List.sort compare (Env.imports ());
            cmt_interface_digest = this_crc;
            cmt_use_summaries = need_to_clear_env;
-           cmt_uid_to_loc = Env.get_uid_to_loc_tbl ();
+           cmt_uid_to_decl;
            cmt_impl_shape = shape;
+           cmt_ident_occurrences;
          } in
          output_cmt oc cmt)
   end;
diff --git a/upstream/ocaml_414/file_formats/cmt_format.mli b/upstream/ocaml_414/file_formats/cmt_format.mli
index 43e09f1236..653dfcc75c 100644
--- a/upstream/ocaml_414/file_formats/cmt_format.mli
+++ b/upstream/ocaml_414/file_formats/cmt_format.mli
@@ -50,6 +50,21 @@ and binary_part =
   | Partial_signature_item of signature_item
   | Partial_module_type of module_type
 
+type item_declaration =
+  | Class_declaration of class_declaration
+  | Class_description of class_description
+  | Class_type_declaration of class_type_declaration
+  | Constructor_declaration of constructor_declaration
+  | Extension_constructor of extension_constructor
+  | Label_declaration of label_declaration
+  | Module_binding of module_binding
+  | Module_declaration of module_declaration
+  | Module_substitution of module_substitution
+  | Module_type_declaration of module_type_declaration
+  | Type_declaration of type_declaration
+  | Value_binding of value_binding
+  | Value_description of value_description
+
 type cmt_infos = {
   cmt_modname : modname;
   cmt_annots : binary_annots;
@@ -65,8 +80,10 @@ type cmt_infos = {
   cmt_imports : crcs;
   cmt_interface_digest : Digest.t option;
   cmt_use_summaries : bool;
-  cmt_uid_to_loc : Location.t Shape.Uid.Tbl.t;
+  cmt_uid_to_decl : item_declaration Shape.Uid.Tbl.t;
   cmt_impl_shape : Shape.t option; (* None for mli *)
+  cmt_ident_occurrences :
+    (Longident.t Location.loc * Shape.reduction_result) list
 }
 
 type error =
@@ -112,7 +129,6 @@ val set_saved_types : binary_part list -> unit
 val record_value_dependency:
   Types.value_description -> Types.value_description -> unit
 
-
 (*
 
   val is_magic_number : string -> bool
diff --git a/upstream/ocaml_414/typing/cmt2annot.ml b/upstream/ocaml_414/typing/cmt2annot.ml
index 40ee752e80..219c6023b2 100644
--- a/upstream/ocaml_414/typing/cmt2annot.ml
+++ b/upstream/ocaml_414/typing/cmt2annot.ml
@@ -23,7 +23,7 @@ let variables_iterator scope =
   let super = default_iterator in
   let pat sub (type k) (p : k general_pattern) =
     begin match p.pat_desc with
-    | Tpat_var (id, _) | Tpat_alias (_, id, _) ->
+    | Tpat_var (id, _, _) | Tpat_alias (_, id, _, _) ->
         Stypes.record (Stypes.An_ident (p.pat_loc,
                                         Ident.name id,
                                         Annot.Idef scope))
diff --git a/upstream/ocaml_414/typing/env.ml b/upstream/ocaml_414/typing/env.ml
index 6e324888da..95e53ce1b8 100644
--- a/upstream/ocaml_414/typing/env.ml
+++ b/upstream/ocaml_414/typing/env.ml
@@ -40,13 +40,6 @@ let value_declarations  : unit usage_tbl ref = s_table Types.Uid.Tbl.create 16
 let type_declarations   : unit usage_tbl ref = s_table Types.Uid.Tbl.create 16
 let module_declarations : unit usage_tbl ref = s_table Types.Uid.Tbl.create 16
 
-let uid_to_loc : Location.t Types.Uid.Tbl.t ref =
-  s_table Types.Uid.Tbl.create 16
-
-let register_uid uid loc = Types.Uid.Tbl.add !uid_to_loc uid loc
-
-let get_uid_to_loc_tbl () = !uid_to_loc
-
 type constructor_usage = Positive | Pattern | Exported_private | Exported
 type constructor_usages =
   {
@@ -941,7 +934,6 @@ let reset_declaration_caches () =
   Types.Uid.Tbl.clear !module_declarations;
   Types.Uid.Tbl.clear !used_constructors;
   Types.Uid.Tbl.clear !used_labels;
-  Types.Uid.Tbl.clear !uid_to_loc;
   ()
 
 let reset_cache () =
@@ -1258,6 +1250,10 @@ let find_shape env (ns : Shape.Sig_component_kind.t) id =
   match ns with
   | Type ->
       (IdTbl.find_same id env.types).tda_shape
+  | Constructor ->
+      Shape.leaf ((TycompTbl.find_same id env.constrs).cda_description.cstr_uid)
+  | Label ->
+      Shape.leaf ((TycompTbl.find_same id env.labels).lbl_uid)
   | Extension_constructor ->
       (TycompTbl.find_same id env.constrs).cda_shape
   | Value ->
@@ -2339,8 +2335,6 @@ let enter_signature_and_shape ~scope ~parent_shape mod_shape sg env =
   enter_signature_and_shape ~scope ~parent_shape (Some mod_shape) sg env
 
 let add_value = add_value ?shape:None
-let add_type = add_type ?shape:None
-let add_extension = add_extension ?shape:None
 let add_class = add_class ?shape:None
 let add_cltype = add_cltype ?shape:None
 let add_modtype = add_modtype ?shape:None
diff --git a/upstream/ocaml_414/typing/env.mli b/upstream/ocaml_414/typing/env.mli
index 49040b83cb..9c2bcac374 100644
--- a/upstream/ocaml_414/typing/env.mli
+++ b/upstream/ocaml_414/typing/env.mli
@@ -18,10 +18,6 @@
 open Types
 open Misc
 
-val register_uid : Uid.t -> Location.t -> unit
-
-val get_uid_to_loc_tbl : unit -> Location.t Types.Uid.Tbl.t
-
 type value_unbound_reason =
   | Val_unbound_instance_variable
   | Val_unbound_self
@@ -284,9 +280,11 @@ 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:
+  check:bool -> ?shape:Shape.t -> Ident.t -> type_declaration -> t -> t
 val add_extension:
-  check:bool -> rebind:bool -> Ident.t -> extension_constructor -> t -> t
+  check:bool -> ?shape:Shape.t -> rebind:bool -> Ident.t ->
+  extension_constructor -> t -> t
 val add_module: ?arg:bool -> ?shape:Shape.t ->
   Ident.t -> module_presence -> module_type -> t -> t
 val add_module_lazy: update_summary:bool ->
diff --git a/upstream/ocaml_414/typing/includemod.ml b/upstream/ocaml_414/typing/includemod.ml
index b2bf46a367..b81c448183 100644
--- a/upstream/ocaml_414/typing/includemod.ml
+++ b/upstream/ocaml_414/typing/includemod.ml
@@ -738,7 +738,21 @@ and signature_components  ~in_eq ~loc old_env ~mark env subst
               type_declarations ~loc ~old_env env ~mark subst id1 tydec1 tydec2
             in
             let item = mark_error_as_unrecoverable item in
+            (* Right now we don't filter hidden constructors / labels from the
+            shape. *)
             let shape_map = Shape.Map.add_type_proj shape_map id1 orig_shape in
+            let shape_map =
+              match tydec1.type_kind with
+              | Type_variant (cstrs, _) ->
+                  List.fold_left (fun shape_map { cd_id; _ } ->
+                    Shape.Map.add_type_proj shape_map cd_id orig_shape)
+                    shape_map cstrs
+              | Type_record (labels, _) ->
+                  List.fold_left (fun shape_map { ld_id; _ } ->
+                    Shape.Map.add_label_proj shape_map ld_id orig_shape)
+                    shape_map labels
+              | _ -> shape_map
+            in
             id1, item, shape_map, false
         | Sig_typext(id1, ext1, _, _), Sig_typext(_id2, ext2, _, _) ->
             let item =
diff --git a/upstream/ocaml_414/typing/parmatch.ml b/upstream/ocaml_414/typing/parmatch.ml
index 2b48d63d54..0af42d4926 100644
--- a/upstream/ocaml_414/typing/parmatch.ml
+++ b/upstream/ocaml_414/typing/parmatch.ml
@@ -37,7 +37,8 @@ let omega_list = Patterns.omega_list
 
 let extra_pat =
   make_pat
-    (Tpat_var (Ident.create_local "+", mknoloc "+"))
+    (Tpat_var (Ident.create_local "+", mknoloc "+",
+      Uid.internal_not_actually_unique))
     Ctype.none Env.empty
 
 
@@ -283,8 +284,8 @@ module Compat
   | ((Tpat_any|Tpat_var _),_)
   | (_,(Tpat_any|Tpat_var _)) -> true
 (* Structural induction *)
-  | Tpat_alias (p,_,_),_      -> compat p q
-  | _,Tpat_alias (q,_,_)      -> compat p q
+  | Tpat_alias (p,_,_,_),_      -> compat p q
+  | _,Tpat_alias (q,_,_,_)      -> compat p q
   | Tpat_or (p1,p2,_),_ ->
       (compat p1 q || compat p2 q)
   | _,Tpat_or (q1,q2,_) ->
@@ -921,7 +922,8 @@ let build_other ext env =
           (* let c = {c with cstr_name = "*extension*"} in *) (* PR#7330 *)
           make_pat
             (Tpat_var (Ident.create_local "*extension*",
-                       {txt="*extension*"; loc = d.pat_loc}))
+                       {txt="*extension*"; loc = d.pat_loc},
+                       Uid.internal_not_actually_unique))
             Ctype.none Env.empty
       | Construct _ ->
           begin match ext with
@@ -1051,7 +1053,7 @@ let build_other ext env =
 let rec has_instance p = match p.pat_desc with
   | Tpat_variant (l,_,r) when is_absent l r -> false
   | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_,None,_) -> true
-  | Tpat_alias (p,_,_) | Tpat_variant (_,Some p,_) -> has_instance p
+  | Tpat_alias (p,_,_,_) | Tpat_variant (_,Some p,_) -> has_instance p
   | Tpat_or (p1,p2,_) -> has_instance p1 || has_instance p2
   | Tpat_construct (_,_,ps,_) | Tpat_tuple ps | Tpat_array ps ->
       has_instances ps
@@ -1505,7 +1507,7 @@ let is_var_column rs =
 (* Standard or-args for left-to-right matching *)
 let rec or_args p = match p.pat_desc with
 | Tpat_or (p1,p2,_) -> p1,p2
-| Tpat_alias (p,_,_)  -> or_args p
+| Tpat_alias (p,_,_,_)  -> or_args p
 | _                 -> assert false
 
 (* Just remove current column *)
@@ -1685,8 +1687,8 @@ and every_both pss qs q1 q2 =
 let rec le_pat p q =
   match (p.pat_desc, q.pat_desc) with
   | (Tpat_var _|Tpat_any),_ -> true
-  | Tpat_alias(p,_,_), _ -> le_pat p q
-  | _, Tpat_alias(q,_,_) -> le_pat p q
+  | Tpat_alias(p,_,_,_), _ -> le_pat p q
+  | _, Tpat_alias(q,_,_,_) -> le_pat p q
   | Tpat_constant(c1), Tpat_constant(c2) -> const_compare c1 c2 = 0
   | Tpat_construct(_,c1,ps,_), Tpat_construct(_,c2,qs,_) ->
       Types.equal_tag c1.cstr_tag c2.cstr_tag && le_pats ps qs
@@ -1725,8 +1727,8 @@ let get_mins le ps =
 *)
 
 let rec lub p q = match p.pat_desc,q.pat_desc with
-| Tpat_alias (p,_,_),_      -> lub p q
-| _,Tpat_alias (q,_,_)      -> lub p q
+| Tpat_alias (p,_,_,_),_      -> lub p q
+| _,Tpat_alias (q,_,_,_)      -> lub p q
 | (Tpat_any|Tpat_var _),_ -> q
 | _,(Tpat_any|Tpat_var _) -> p
 | Tpat_or (p1,p2,_),_     -> orlub p1 p2 q
@@ -1861,14 +1863,14 @@ module Conv = struct
       match pat.pat_desc with
         Tpat_or (pa,pb,_) ->
           mkpat (Ppat_or (loop pa, loop pb))
-      | Tpat_var (_, ({txt="*extension*"} as nm)) -> (* PR#7330 *)
+      | Tpat_var (_, ({txt="*extension*"} as nm), _) -> (* PR#7330 *)
           mkpat (Ppat_var nm)
       | Tpat_any
       | Tpat_var _ ->
           mkpat Ppat_any
       | Tpat_constant c ->
           mkpat (Ppat_constant (Untypeast.constant c))
-      | Tpat_alias (p,_,_) -> loop p
+      | Tpat_alias (p,_,_,_) -> loop p
       | Tpat_tuple lst ->
           mkpat (Ppat_tuple (List.map loop lst))
       | Tpat_construct (cstr_lid, cstr, lst, _) ->
@@ -1909,7 +1911,7 @@ end
 let contains_extension pat =
   exists_pattern
     (function
-     | {pat_desc=Tpat_var (_, {txt="*extension*"})} -> true
+     | {pat_desc=Tpat_var (_, {txt="*extension*"}, _)} -> true
      | _ -> false)
     pat
 
@@ -2021,7 +2023,8 @@ let rec collect_paths_from_pat r p = match p.pat_desc with
     List.fold_left
       (fun r (_, _, p) -> collect_paths_from_pat r p)
       r lps
-| Tpat_variant (_, Some p, _) | Tpat_alias (p,_,_) -> collect_paths_from_pat r p
+| Tpat_variant (_, Some p, _) | Tpat_alias (p,_,_,_) ->
+    collect_paths_from_pat r p
 | Tpat_or (p1,p2,_) ->
     collect_paths_from_pat (collect_paths_from_pat r p1) p2
 | Tpat_lazy p
@@ -2155,7 +2158,7 @@ let inactive ~partial pat =
           end
         | Tpat_tuple ps | Tpat_construct (_, _, ps, _) ->
             List.for_all (fun p -> loop p) ps
-        | Tpat_alias (p,_,_) | Tpat_variant (_, Some p, _) ->
+        | Tpat_alias (p,_,_,_) | Tpat_variant (_, Some p, _) ->
             loop p
         | Tpat_record (ldps,_) ->
             List.for_all
@@ -2274,9 +2277,9 @@ type amb_row = { row : pattern list ; varsets : Ident.Set.t list; }
 let simplify_head_amb_pat head_bound_variables varsets ~add_column p ps k =
   let rec simpl head_bound_variables varsets p ps k =
     match (Patterns.General.view p).pat_desc with
-    | `Alias (p,x,_) ->
+    | `Alias (p,x,_,_) ->
       simpl (Ident.Set.add x head_bound_variables) varsets p ps k
-    | `Var (x, _) ->
+    | `Var (x,_,_) ->
       simpl (Ident.Set.add x head_bound_variables) varsets Patterns.omega ps k
     | `Or (p1,p2,_) ->
       simpl head_bound_variables varsets p1 ps
diff --git a/upstream/ocaml_414/typing/patterns.ml b/upstream/ocaml_414/typing/patterns.ml
index 55f9d4ff43..456f8dff33 100644
--- a/upstream/ocaml_414/typing/patterns.ml
+++ b/upstream/ocaml_414/typing/patterns.ml
@@ -79,18 +79,18 @@ end
 module General = struct
   type view = [
     | Half_simple.view
-    | `Var of Ident.t * string loc
-    | `Alias of pattern * Ident.t * string loc
+    | `Var of Ident.t * string loc * Uid.t
+    | `Alias of pattern * Ident.t * string loc * Uid.t
   ]
   type pattern = view pattern_data
 
   let view_desc = function
     | Tpat_any ->
        `Any
-    | Tpat_var (id, str) ->
-       `Var (id, str)
-    | Tpat_alias (p, id, str) ->
-       `Alias (p, id, str)
+    | Tpat_var (id, str, uid) ->
+       `Var (id, str, uid)
+    | Tpat_alias (p, id, str, uid) ->
+       `Alias (p, id, str, uid)
     | Tpat_constant cst ->
        `Constant cst
     | Tpat_tuple ps ->
@@ -110,8 +110,8 @@ module General = struct
 
   let erase_desc = function
     | `Any -> Tpat_any
-    | `Var (id, str) -> Tpat_var (id, str)
-    | `Alias (p, id, str) -> Tpat_alias (p, id, str)
+    | `Var (id, str, uid) -> Tpat_var (id, str, uid)
+    | `Alias (p, id, str, uid) -> Tpat_alias (p, id, str, uid)
     | `Constant cst -> Tpat_constant cst
     | `Tuple ps -> Tpat_tuple ps
     | `Construct (cstr, cst_descr, args) ->
@@ -129,7 +129,7 @@ module General = struct
 
   let rec strip_vars (p : pattern) : Half_simple.pattern =
     match p.pat_desc with
-    | `Alias (p, _, _) -> strip_vars (view p)
+    | `Alias (p, _, _, _) -> strip_vars (view p)
     | `Var _ -> { p with pat_desc = `Any }
     | #Half_simple.view as view -> { p with pat_desc = view }
 end
diff --git a/upstream/ocaml_414/typing/patterns.mli b/upstream/ocaml_414/typing/patterns.mli
index 66dd2d05a4..2ad645b0d0 100644
--- a/upstream/ocaml_414/typing/patterns.mli
+++ b/upstream/ocaml_414/typing/patterns.mli
@@ -65,8 +65,8 @@ end
 module General : sig
   type view = [
     | Half_simple.view
-    | `Var of Ident.t * string loc
-    | `Alias of pattern * Ident.t * string loc
+    | `Var of Ident.t * string loc * Uid.t
+    | `Alias of pattern * Ident.t * string loc * Uid.t
   ]
   type pattern = view pattern_data
 
diff --git a/upstream/ocaml_414/typing/printpat.ml b/upstream/ocaml_414/typing/printpat.ml
index 64094b63ec..e90fd8eeb1 100644
--- a/upstream/ocaml_414/typing/printpat.ml
+++ b/upstream/ocaml_414/typing/printpat.ml
@@ -52,7 +52,7 @@ let rec pretty_val : type k . _ -> k general_pattern -> _ = fun ppf v ->
     | [] ->
   match v.pat_desc with
   | Tpat_any -> fprintf ppf "_"
-  | Tpat_var (x,_) -> fprintf ppf "%s" (Ident.name x)
+  | Tpat_var (x,_,_) -> fprintf ppf "%s" (Ident.name x)
   | Tpat_constant c -> fprintf ppf "%s" (pretty_const c)
   | Tpat_tuple vs ->
       fprintf ppf "@[(%a)@]" (pretty_vals ",") vs
@@ -98,7 +98,7 @@ let rec pretty_val : type k . _ -> k general_pattern -> _ = fun ppf v ->
       fprintf ppf "@[[| %a |]@]" (pretty_vals " ;") vs
   | Tpat_lazy v ->
       fprintf ppf "@[<2>lazy@ %a@]" pretty_arg v
-  | Tpat_alias (v, x,_) ->
+  | Tpat_alias (v, x,_,_) ->
       fprintf ppf "@[(%a@ as %a)@]" pretty_val v Ident.print x
   | Tpat_value v ->
       fprintf ppf "%a" pretty_val (v :> pattern)
diff --git a/upstream/ocaml_414/typing/printtyped.ml b/upstream/ocaml_414/typing/printtyped.ml
index b925123aa9..fea441ebd1 100644
--- a/upstream/ocaml_414/typing/printtyped.ml
+++ b/upstream/ocaml_414/typing/printtyped.ml
@@ -242,8 +242,8 @@ and pattern : type k . _ -> _ -> k general_pattern -> unit = fun i ppf x ->
   end;
   match x.pat_desc with
   | Tpat_any -> line i ppf "Tpat_any\n";
-  | Tpat_var (s,_) -> line i ppf "Tpat_var \"%a\"\n" fmt_ident s;
-  | Tpat_alias (p, s,_) ->
+  | Tpat_var (s,_,_) -> line i ppf "Tpat_var \"%a\"\n" fmt_ident s;
+  | Tpat_alias (p, s,_,_) ->
       line i ppf "Tpat_alias \"%a\"\n" fmt_ident s;
       pattern i ppf p;
   | Tpat_constant (c) -> line i ppf "Tpat_constant %a\n" fmt_constant c;
diff --git a/upstream/ocaml_414/typing/rec_check.ml b/upstream/ocaml_414/typing/rec_check.ml
index 1980b82d02..fda80675b5 100644
--- a/upstream/ocaml_414/typing/rec_check.ml
+++ b/upstream/ocaml_414/typing/rec_check.ml
@@ -220,7 +220,7 @@ let classify_expression : Typedtree.expression -> sd =
     let old_env = env in
     let add_value_binding env vb =
       match vb.vb_pat.pat_desc with
-      | Tpat_var (id, _loc) ->
+      | Tpat_var (id, _loc, _uid) ->
           let size = classify_expression old_env vb.vb_expr in
           Ident.add id size env
       | _ ->
@@ -1187,8 +1187,8 @@ and pattern : type k . k general_pattern -> Env.t -> mode = fun pat env ->
 and is_destructuring_pattern : type k . k general_pattern -> bool =
   fun pat -> match pat.pat_desc with
     | Tpat_any -> false
-    | Tpat_var (_, _) -> false
-    | Tpat_alias (pat, _, _) -> is_destructuring_pattern pat
+    | Tpat_var (_, _, _) -> false
+    | Tpat_alias (pat, _, _, _) -> is_destructuring_pattern pat
     | Tpat_constant _ -> true
     | Tpat_tuple _ -> true
     | Tpat_construct _ -> true
diff --git a/upstream/ocaml_414/typing/shape.ml b/upstream/ocaml_414/typing/shape.ml
index f82e5343fa..1b5af183ed 100644
--- a/upstream/ocaml_414/typing/shape.ml
+++ b/upstream/ocaml_414/typing/shape.ml
@@ -67,6 +67,8 @@ module Sig_component_kind = struct
   type t =
     | Value
     | Type
+    | Constructor
+    | Label
     | Module
     | Module_type
     | Extension_constructor
@@ -76,6 +78,8 @@ module Sig_component_kind = struct
   let to_string = function
     | Value -> "value"
     | Type -> "type"
+    | Constructor -> "constructor"
+    | Label -> "label"
     | Module -> "module"
     | Module_type -> "module type"
     | Extension_constructor -> "extension constructor"
@@ -87,6 +91,8 @@ module Sig_component_kind = struct
     | Extension_constructor ->
         false
     | Type
+    | Constructor
+    | Label
     | Module
     | Module_type
     | Class
@@ -99,10 +105,15 @@ module Item = struct
     type t = string * Sig_component_kind.t
     let compare = compare
 
+    let name (name, _) = name
+    let kind (_, kind) = kind
+
     let make str ns = str, ns
 
     let value id = Ident.name id, Sig_component_kind.Value
     let type_ id = Ident.name id, Sig_component_kind.Type
+    let constr id = Ident.name id, Sig_component_kind.Constructor
+    let label id = Ident.name id, Sig_component_kind.Label
     let module_ id = Ident.name id, Sig_component_kind.Module
     let module_type id = Ident.name id, Sig_component_kind.Module_type
     let extension_constructor id =
@@ -124,17 +135,19 @@ module Item = struct
 end
 
 type var = Ident.t
-type t = { uid: Uid.t option; desc: desc }
+type t = { uid: Uid.t option; desc: desc; approximated: bool }
 and desc =
   | Var of var
   | Abs of var * t
   | App of t * t
   | Struct of t Item.Map.t
+  | Alias of t
   | Leaf
   | Proj of t * Item.t
   | Comp_unit of string
+  | Error of string
 
-let print fmt =
+let print fmt t =
   let print_uid_opt =
     Format.pp_print_option (fun fmt -> Format.fprintf fmt "<%a>" Uid.print)
   in
@@ -171,49 +184,83 @@ let print fmt =
                 aux t
             )
         in
-        Format.fprintf fmt "{@[<v>%a@,%a@]}" print_uid_opt uid print_map map
+        if Item.Map.is_empty map then
+          Format.fprintf fmt "@[<hv>{%a}@]" print_uid_opt uid
+        else
+          Format.fprintf fmt "{@[<v>%a@,%a@]}" print_uid_opt uid print_map map
+    | Alias t ->
+        Format.fprintf fmt "Alias@[(@[<v>%a@,%a@])@]" print_uid_opt uid aux t
+    | Error s ->
+        Format.fprintf fmt "Error %s" s
   in
-  Format.fprintf fmt"@[%a@]@;" aux
+  if t.approximated then
+    Format.fprintf fmt "@[(approx)@ %a@]@;" aux t
+  else
+    Format.fprintf fmt "@[%a@]@;" aux t
 
 let fresh_var ?(name="shape-var") uid =
   let var = Ident.create_local name in
-  var, { uid = Some uid; desc = Var var }
+  var, { uid = Some uid; desc = Var var; approximated = false }
 
 let for_unnamed_functor_param = Ident.create_local "()"
 
 let var uid id =
-  { uid = Some uid; desc = Var id }
+  { uid = Some uid; desc = Var id; approximated = false }
 
 let abs ?uid var body =
-  { uid; desc = Abs (var, body) }
+  { uid; desc = Abs (var, body); approximated = false }
 
 let str ?uid map =
-  { uid; desc = Struct map }
+  { uid; desc = Struct map; approximated = false }
+
+let alias ?uid t =
+  { uid; desc = Alias t; approximated = false}
 
 let leaf uid =
-  { uid = Some uid; desc = Leaf }
+  { uid = Some uid; desc = Leaf; approximated = false }
+
+let approx t = { t with approximated = true}
 
 let proj ?uid t item =
   match t.desc with
   | Leaf ->
       (* When stuck projecting in a leaf we propagate the leaf
         as a best effort *)
-      t
+      approx t
   | Struct map ->
       begin try Item.Map.find item map
-      with Not_found -> t (* ill-typed program *)
+      with Not_found -> approx t (* ill-typed program *)
       end
   | _ ->
-      { uid; desc = Proj (t, item) }
+     { uid; desc = Proj (t, item); approximated = false }
 
 let app ?uid f ~arg =
-      { uid; desc = App (f, arg) }
+  { uid; desc = App (f, arg); approximated = false }
 
 let decompose_abs t =
   match t.desc with
   | Abs (x, t) -> Some (x, t)
   | _ -> None
 
+type reduction_result =
+  | Resolved of Uid.t
+  | Unresolved of t
+  | Approximated of Uid.t option
+  | Missing_uid
+
+let print_reduction_result fmt result =
+  match result with
+  | Resolved uid ->
+      Format.fprintf fmt "@[Resolved: %a@]@;" Uid.print uid
+  | Unresolved shape ->
+      Format.fprintf fmt "@[Unresolved: %a@]@;" print shape
+  | Approximated (Some uid) ->
+      Format.fprintf fmt "@[Approximated: %a@]@;" Uid.print uid
+  | Approximated None ->
+      Format.fprintf fmt "@[Approximated: No uid@]@;"
+  | Missing_uid ->
+      Format.fprintf fmt "@[Missing uid@]@;"
+
 module Make_reduce(Params : sig
   type env
   val fuel : int
@@ -223,16 +270,18 @@ end) = struct
   (* We implement a strong call-by-need reduction, following an
      evaluator from Nathanaelle Courant. *)
 
-  type nf = { uid: Uid.t option; desc: nf_desc }
+  type nf = { uid: Uid.t option; desc: nf_desc; approximated: bool }
   and nf_desc =
     | NVar of var
     | NApp of nf * nf
     | NAbs of local_env * var * t * delayed_nf
     | NStruct of delayed_nf Item.Map.t
+    | NAlias of nf
     | NProj of nf * Item.t
     | NLeaf
     | NComp_unit of string
-    | NoFuelLeft of desc
+    | NError of string
+
   (* A type of normal forms for strong call-by-need evaluation.
      The normal form of an abstraction
        Abs(x, t)
@@ -251,7 +300,8 @@ end) = struct
      by calling the normalization function as usual, but duplicate
      computations are precisely avoided by memoization.
    *)
-  and delayed_nf = Thunk of local_env * t
+  and thunk = { local_env : local_env; shape: t }
+  and delayed_nf = Thunk of thunk
 
   and local_env = delayed_nf option Ident.Map.t
   (* When reducing in the body of an abstraction [Abs(x, body)], we
@@ -272,11 +322,15 @@ end) = struct
         Hashtbl.replace memo_table memo_key res;
         res
 
+  let rec strip_head_aliases nf = match nf.desc with
+    | NAlias nf -> strip_head_aliases nf
+    | _ -> nf
+
   type env = {
     fuel: int ref;
     global_env: Params.env;
     local_env: local_env;
-    reduce_memo_table: (local_env * t, nf) Hashtbl.t;
+    reduce_memo_table: (thunk, nf) Hashtbl.t;
     read_back_memo_table: (nf, t) Hashtbl.t;
   }
 
@@ -284,8 +338,11 @@ end) = struct
     { env with local_env = Ident.Map.add var shape env.local_env }
 
   let rec reduce_ env t =
-    let memo_key = (env.local_env, t) in
-    in_memo_table env.reduce_memo_table memo_key (reduce__ env) t
+    let local_env = env.local_env in
+    let memo_key = { local_env; shape = t } in
+    in_memo_table
+      env.reduce_memo_table memo_key
+      (reduce__ env) t
   (* Memoization is absolutely essential for performance on this
      problem, because the normal forms we build can in some real-world
      cases contain an exponential amount of redundancy. Memoization
@@ -324,13 +381,20 @@ end) = struct
      same hash.
 *)
 
-  and reduce__ ({fuel; global_env; local_env; _} as env) (t : t) =
-    let reduce env t = reduce_ env t in
-    let delay_reduce env t = Thunk (env.local_env, t) in
-    let force (Thunk (local_env, t)) =
+  and reduce__
+    ({fuel; global_env; local_env; _} as env) (t : t) =
+    let reduce env t =
+      reduce_ env t
+    in
+    let delay_reduce { local_env; _ } t =
+      Thunk { local_env; shape = t }
+    in
+    let force (Thunk { local_env; shape = t }) =
       reduce { env with local_env } t in
-    let return desc : nf = { uid = t.uid; desc } in
-    if !fuel < 0 then return (NoFuelLeft t.desc)
+    let return ?(approximated = t.approximated) desc : nf =
+      { uid = t.uid; desc; approximated }
+    in
+    if !fuel < 0 then return ~approximated:true (NError "NoFuelLeft")
     else
       match t.desc with
       | Comp_unit unit_name ->
@@ -339,19 +403,18 @@ end) = struct
           | None -> return (NComp_unit unit_name)
           end
       | App(f, arg) ->
-          let f = reduce env f in
+          let f = reduce env f |> strip_head_aliases in
           begin match f.desc with
           | NAbs(clos_env, var, body, _body_nf) ->
               let arg = delay_reduce env arg in
               let env = bind { env with local_env = clos_env } var (Some arg) in
-              reduce env body
-              |> improve_uid t.uid
+              { (reduce env body) with uid = t.uid }
           | _ ->
               let arg = reduce env arg in
               return (NApp(f, arg))
           end
       | Proj(str, item) ->
-          let str = reduce env str in
+          let str = reduce env str |> strip_head_aliases in
           let nored () = return (NProj(str, item)) in
           begin match str.desc with
           | NStruct (items) ->
@@ -392,8 +455,10 @@ end) = struct
       | Struct m ->
           let mnf = Item.Map.map (delay_reduce env) m in
           return (NStruct mnf)
+      | Alias t -> return (NAlias (reduce env t))
+      | Error s -> return ~approximated:true (NError s)
 
-  let rec read_back env (nf : nf) : t =
+  and read_back env (nf : nf) : t =
     in_memo_table env.read_back_memo_table nf (read_back_ env) nf
   (* The [nf] normal form we receive may contain a lot of internal
      sharing due to the use of memoization in the evaluator. We have
@@ -401,11 +466,13 @@ end) = struct
      over the term as a tree. *)
 
   and read_back_ env (nf : nf) : t =
-    { uid = nf.uid; desc = read_back_desc env nf.desc }
+    { uid = nf.uid ;
+      desc = read_back_desc env nf.desc;
+      approximated = nf.approximated }
 
   and read_back_desc env desc =
     let read_back nf = read_back env nf in
-    let read_back_force (Thunk (local_env, t)) =
+    let read_back_force (Thunk { local_env; shape = t }) =
       read_back (reduce_ { env with local_env } t) in
     match desc with
     | NVar v ->
@@ -416,28 +483,69 @@ end) = struct
         Abs(x, read_back_force nf)
     | NStruct nstr ->
         Struct (Item.Map.map read_back_force nstr)
+    | NAlias nf -> Alias (read_back nf)
     | NProj (nf, item) ->
         Proj (read_back nf, item)
     | NLeaf -> Leaf
     | NComp_unit s -> Comp_unit s
-    | NoFuelLeft t -> t
+    | NError s -> Error s
+
+  (* Sharing the memo tables is safe at the level of a compilation unit since
+    idents should be unique *)
+  let reduce_memo_table = Local_store.s_table Hashtbl.create 42
+  let read_back_memo_table = Local_store.s_table Hashtbl.create 42
 
   let reduce global_env t =
     let fuel = ref Params.fuel in
-    let reduce_memo_table = Hashtbl.create 42 in
-    let read_back_memo_table = Hashtbl.create 42 in
     let local_env = Ident.Map.empty in
     let env = {
       fuel;
       global_env;
-      reduce_memo_table;
-      read_back_memo_table;
+      reduce_memo_table = !reduce_memo_table;
+      read_back_memo_table = !read_back_memo_table;
       local_env;
     } in
     reduce_ env t |> read_back env
+
+  let rec is_stuck_on_comp_unit (nf : nf) =
+    match nf.desc with
+    | NVar _ ->
+        (* This should not happen if we only reduce closed terms *)
+        false
+    | NApp (nf, _) | NProj (nf, _) | NAlias nf -> is_stuck_on_comp_unit nf
+    | NStruct _ | NAbs _ -> false
+    | NComp_unit _ -> true
+    | NError _ -> false
+    | NLeaf -> false
+
+  let reduce_for_uid global_env t =
+    let fuel = ref Params.fuel in
+    let local_env = Ident.Map.empty in
+    let env = {
+      fuel;
+      global_env;
+      reduce_memo_table = !reduce_memo_table;
+      read_back_memo_table = !read_back_memo_table;
+      local_env;
+    } in
+    let nf = reduce_ env t in
+    if is_stuck_on_comp_unit nf then
+      Unresolved (read_back env nf)
+    else match nf with
+      | { uid = Some uid; approximated = false; _ } ->
+          Resolved uid
+      | { uid; approximated = true; _ } ->
+          Approximated uid
+      | { uid = None; approximated = false; _ } ->
+          (* A missing Uid after a complete reduction means the Uid was first
+             missing in the shape which is a code error. Having the
+             [Missing_uid] reported will allow Merlin (or another tool working
+             with the index) to ask users to report the issue if it does happen.
+          *)
+          Missing_uid
 end
 
-module Local_reduce =
+module Toplevel_local_reduce =
   (* Note: this definition with [type env = unit] is only suitable for
      reduction of toplevel shapes -- shapes of compilation units,
      where free variables are only Comp_unit names. If we wanted to
@@ -450,24 +558,45 @@ module Local_reduce =
     let find_shape _env _id = raise Not_found
   end)
 
-let local_reduce shape =
-  Local_reduce.reduce () shape
+let toplevel_local_reduce shape =
+  Toplevel_local_reduce.reduce () shape
 
-let dummy_mod = { uid = None; desc = Struct Item.Map.empty }
+let dummy_mod =
+  { uid = None; desc = Struct Item.Map.empty; approximated = false }
 
-let of_path ~find_shape ~namespace =
+let of_path ~find_shape ~namespace path =
   let rec aux : Sig_component_kind.t -> Path.t -> t = fun ns -> function
     | Pident id -> find_shape ns id
-    | Pdot (path, name) -> proj (aux Module path) (name, ns)
+    | Pdot (path, name) ->
+      (* We need to handle the following cases:
+        Path of constructor:
+          M.t.C
+        Path of label:
+          M.t.lbl
+        Path on label of inline record:
+          M.t.C.lbl *)
+      let is_capitalized name = String.capitalize_ascii name = name in
+      let is_label namespace = namespace = Sig_component_kind.Label in
+      let namespace : Sig_component_kind.t =
+        match path with
+        | Pident id when is_capitalized (Ident.name id) ->
+            if is_label ns then Constructor else Module
+        | Pident _ -> Type
+        | Pdot (_, name)  when is_capitalized name ->
+            if is_label ns then Constructor else Module
+        | Pdot _ -> Type
+        | Papply _ -> Module
+      in
+      proj (aux namespace path) (name, ns)
     | Papply (p1, p2) -> app (aux Module p1) ~arg:(aux Module p2)
   in
-  aux namespace
+  aux namespace path
 
 let for_persistent_unit s =
   { uid = Some (Uid.of_compilation_unit_id (Ident.create_persistent s));
-    desc = Comp_unit s }
+    desc = Comp_unit s; approximated = false }
 
-let leaf_for_unpack = { uid = None; desc = Leaf }
+let leaf_for_unpack = { uid = None; desc = Leaf; approximated = false }
 
 let set_uid_if_none t uid =
   match t.uid with
@@ -487,11 +616,21 @@ module Map = struct
     let item = Item.value id in
     Item.Map.add item (proj shape item) t
 
-  let add_type t id uid = Item.Map.add (Item.type_ id) (leaf uid) t
+  let add_type t id shape = Item.Map.add (Item.type_ id) shape t
   let add_type_proj t id shape =
     let item = Item.type_ id in
     Item.Map.add item (proj shape item) t
 
+  let add_constr t id shape = Item.Map.add (Item.constr id) shape t
+  let add_constr_proj t id shape =
+    let item = Item.constr id in
+    Item.Map.add item (proj shape item) t
+
+  let add_label t id uid = Item.Map.add (Item.label id) (leaf uid) t
+  let add_label_proj t id shape =
+    let item = Item.label id in
+    Item.Map.add item (proj shape item) t
+
   let add_module t id shape = Item.Map.add (Item.module_ id) shape t
   let add_module_proj t id shape =
     let item = Item.module_ id in
@@ -503,8 +642,8 @@ module Map = struct
     let item = Item.module_type id in
     Item.Map.add item (proj shape item) t
 
-  let add_extcons t id uid =
-    Item.Map.add (Item.extension_constructor id) (leaf uid) t
+  let add_extcons t id shape =
+    Item.Map.add (Item.extension_constructor id) shape t
   let add_extcons_proj t id shape =
     let item = Item.extension_constructor id in
     Item.Map.add item (proj shape item) t
diff --git a/upstream/ocaml_414/typing/shape.mli b/upstream/ocaml_414/typing/shape.mli
index 8a5aaca4fb..5d2434680b 100644
--- a/upstream/ocaml_414/typing/shape.mli
+++ b/upstream/ocaml_414/typing/shape.mli
@@ -2,7 +2,7 @@
 (*                                                                        *)
 (*                                 OCaml                                  *)
 (*                                                                        *)
-(*                Ulysse Gérard, Thomas Refis, Tarides                    *)
+(*                Ulysse Gérard, Thomas Refis, N G Tarides                *)
 (*                                                                        *)
 (*   Copyright 2021 Institut National de Recherche en Informatique et     *)
 (*     en Automatique.                                                    *)
@@ -13,6 +13,42 @@
 (*                                                                        *)
 (**************************************************************************)
 
+(** Shapes are an abstract representation of modules' implementations which
+    allow the tracking of definitions through functor applications and other
+    module-level operations.
+
+    The Shape of a compilation unit is elaborated during typing, partially
+    reduced (without loading external shapes) and written to the [cmt] file.
+
+    External tools can retrieve the definition of any value (or type, or module,
+    etc) by following this procedure:
+
+    - Build the Shape corresponding to the value's path:
+      [let shape = Env.shape_of_path ~namespace env path]
+
+    - Instantiate the [Make_reduce] functor with a way to load shapes from
+      external units and to looks for shapes in the environment (usually using
+      [Env.shape_of_path]).
+
+    - Completely reduce the shape:
+      [let shape = My_reduce.(weak_)reduce env shape]
+
+    - The [Uid.t] stored in the reduced shape should be the one of the
+      definition. However, if the [approximate] field of the reduced shape is
+      [true] then the [Uid.t] will not correspond to the definition, but to the
+      closest parent module's uid. This happens when Shape reduction gets stuck,
+      for example when hitting first-class modules.
+
+    - The location of the definition can be easily found with the
+      [cmt_format.cmt_uid_to_decl] talbe of the corresponding compilation unit.
+
+  See:
+  - {{: https://icfp22.sigplan.org/details/mlfamilyworkshop-2022-papers/10/Module-Shapes-for-Modern-Tooling }
+    the design document}
+  - {{: https://www.lix.polytechnique.fr/Labo/Gabriel.Scherer/research/shapes/2022-ml-workshop-shapes-talk.pdf }
+    a talk about the reduction strategy
+*)
+
 module Uid : sig
   type t = private
     | Compilation_unit of string
@@ -36,6 +72,8 @@ module Sig_component_kind : sig
   type t =
     | Value
     | Type
+    | Constructor
+    | Label
     | Module
     | Module_type
     | Extension_constructor
@@ -48,32 +86,49 @@ module Sig_component_kind : sig
   val can_appear_in_types : t -> bool
 end
 
+(** Shape's items are elements of a structure modeling module components. *)
 module Item : sig
-  type t
+  type t = string * Sig_component_kind.t
+  val name : t -> string
+  val kind : t -> Sig_component_kind.t
 
   val make : string -> Sig_component_kind.t -> t
 
   val value : Ident.t -> t
   val type_ : Ident.t -> t
+  val constr : Ident.t -> t
+  val label : Ident.t -> t
   val module_ : Ident.t -> t
   val module_type : Ident.t -> t
   val extension_constructor : Ident.t -> t
   val class_ : Ident.t -> t
   val class_type : Ident.t -> t
 
+  val print : Format.formatter -> t -> unit
+
   module Map : Map.S with type key = t
 end
 
 type var = Ident.t
-type t = { uid: Uid.t option; desc: desc }
+type t = { uid: Uid.t option; desc: desc; approximated: bool }
 and desc =
   | Var of var
   | Abs of var * t
   | App of t * t
   | Struct of t Item.Map.t
+  | Alias of t
   | Leaf
   | Proj of t * Item.t
   | Comp_unit of string
+  | Error of string
+
+type reduction_result =
+  | Resolved of Uid.t
+  | Unresolved of t
+  | Approximated of Uid.t option
+  | Missing_uid
+
+val print_reduction_result : Format.formatter -> reduction_result -> unit
 
 val print : Format.formatter -> t -> unit
 
@@ -86,6 +141,7 @@ val var : Uid.t -> Ident.t -> t
 val abs : ?uid:Uid.t -> var -> t -> t
 val app : ?uid:Uid.t -> t -> arg:t -> t
 val str : ?uid:Uid.t -> t Item.Map.t -> t
+val alias : ?uid:Uid.t -> t -> t
 val proj : ?uid:Uid.t -> t -> Item.t -> t
 val leaf : Uid.t -> t
 
@@ -105,16 +161,22 @@ module Map : sig
   val add_value : t -> Ident.t -> Uid.t -> t
   val add_value_proj : t -> Ident.t -> shape -> t
 
-  val add_type : t -> Ident.t -> Uid.t -> t
+  val add_type : t -> Ident.t -> shape -> t
   val add_type_proj : t -> Ident.t -> shape -> t
 
+  val add_constr : t -> Ident.t -> shape -> t
+  val add_constr_proj : t -> Ident.t -> shape -> t
+
+  val add_label : t -> Ident.t -> Uid.t -> t
+  val add_label_proj : t -> Ident.t -> shape -> t
+
   val add_module : t -> Ident.t -> shape -> t
   val add_module_proj : t -> Ident.t -> shape -> t
 
   val add_module_type : t -> Ident.t -> Uid.t -> t
   val add_module_type_proj : t -> Ident.t -> shape -> t
 
-  val add_extcons : t -> Ident.t -> Uid.t -> t
+  val add_extcons : t -> Ident.t -> shape -> t
   val add_extcons_proj : t -> Ident.t -> shape -> t
 
   val add_class : t -> Ident.t -> Uid.t -> t
@@ -126,6 +188,10 @@ end
 
 val dummy_mod : t
 
+(** This function returns the shape corresponding to a given path. It requires a
+    callback to find shapes in the environment. It is generally more useful to
+    rely directly on the [Env.shape_of_path] function to get the shape
+    associated with a given path. *)
 val of_path :
   find_shape:(Sig_component_kind.t -> Ident.t -> t) ->
   namespace:Sig_component_kind.t -> Path.t -> t
@@ -152,6 +218,13 @@ module Make_reduce(Context : sig
     val find_shape : env -> Ident.t -> t
   end) : sig
   val reduce : Context.env -> t -> t
+
+  (** Perform weak reduction and return the head's uid if any. If reduction was
+    incomplete the partially reduced shape is returned. *)
+  val reduce_for_uid : Context.env -> t -> reduction_result
 end
 
-val local_reduce : t -> t
+(** [toplevel_local_reduce] is only suitable to reduce toplevel shapes (shapes
+  of compilation units). Use the [Make_reduce] functor for other cases that
+  require access to the environment.*)
+val toplevel_local_reduce : t -> t
diff --git a/upstream/ocaml_414/typing/tast_iterator.ml b/upstream/ocaml_414/typing/tast_iterator.ml
index a700c0d91b..5f5be93c5c 100644
--- a/upstream/ocaml_414/typing/tast_iterator.ml
+++ b/upstream/ocaml_414/typing/tast_iterator.ml
@@ -170,7 +170,7 @@ let pat
   | Tpat_variant (_, po, _) -> Option.iter (sub.pat sub) po
   | Tpat_record (l, _) -> List.iter (fun (_, _, i) -> sub.pat sub i) l
   | Tpat_array l -> List.iter (sub.pat sub) l
-  | Tpat_alias (p, _, _) -> sub.pat sub p
+  | Tpat_alias (p, _, _, _) -> sub.pat sub p
   | Tpat_lazy p -> sub.pat sub p
   | Tpat_value p -> sub.pat sub (p :> pattern)
   | Tpat_exception p -> sub.pat sub p
@@ -316,8 +316,8 @@ let with_constraint sub = function
   | Twith_typesubst decl -> sub.type_declaration sub decl
   | Twith_module    _    -> ()
   | Twith_modsubst  _    -> ()
-  | Twith_modtype   _    -> ()
-  | Twith_modtypesubst _ -> ()
+  | Twith_modtype  decl  -> sub.module_type sub decl
+  | Twith_modtypesubst decl -> sub.module_type sub decl
 
 
 let open_description sub {open_env; _} = sub.env sub open_env
diff --git a/upstream/ocaml_414/typing/tast_mapper.ml b/upstream/ocaml_414/typing/tast_mapper.ml
index 9eb7f64e88..fd861f0522 100644
--- a/upstream/ocaml_414/typing/tast_mapper.ml
+++ b/upstream/ocaml_414/typing/tast_mapper.ml
@@ -219,7 +219,7 @@ let pat
     | Tpat_record (l, closed) ->
         Tpat_record (List.map (tuple3 id id (sub.pat sub)) l, closed)
     | Tpat_array l -> Tpat_array (List.map (sub.pat sub) l)
-    | Tpat_alias (p, id, s) -> Tpat_alias (sub.pat sub p, id, s)
+    | Tpat_alias (p, id, s, uid) -> Tpat_alias (sub.pat sub p, id, s, uid)
     | Tpat_lazy p -> Tpat_lazy (sub.pat sub p)
     | Tpat_value p ->
        (as_computation_pattern (sub.pat sub (p :> pattern))).pat_desc
diff --git a/upstream/ocaml_414/typing/typeclass.ml b/upstream/ocaml_414/typing/typeclass.ml
index 79d464fa7d..02754243b6 100644
--- a/upstream/ocaml_414/typing/typeclass.ml
+++ b/upstream/ocaml_414/typing/typeclass.ml
@@ -1305,7 +1305,7 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl =
         Typecore.type_let In_class_def val_env rec_flag sdefs in
       let (vals, met_env) =
         List.fold_right
-          (fun (id, _id_loc, _typ) (vals, met_env) ->
+          (fun (id, _id_loc, _typ, _uid) (vals, met_env) ->
              let path = Pident id in
              (* do not mark the value as used *)
              let vd = Env.find_value path val_env in
diff --git a/upstream/ocaml_414/typing/typecore.ml b/upstream/ocaml_414/typing/typecore.ml
index e043e237c5..f9d433fa8e 100644
--- a/upstream/ocaml_414/typing/typecore.ml
+++ b/upstream/ocaml_414/typing/typecore.ml
@@ -438,6 +438,7 @@ type pattern_variable =
     pv_loc: Location.t;
     pv_as_var: bool;
     pv_attributes: attributes;
+    pv_uid : Uid.t;
   }
 
 type module_variable =
@@ -471,19 +472,21 @@ let enter_variable ?(is_module=false) ?(is_as_variable=false) loc name ty
       !pattern_variables
   then raise(Error(loc, Env.empty, Multiply_bound_variable name.txt));
   let id = Ident.create_local name.txt in
+  let pv_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in
   pattern_variables :=
     {pv_id = id;
      pv_type = ty;
      pv_loc = loc;
      pv_as_var = is_as_variable;
-     pv_attributes = attrs} :: !pattern_variables;
+     pv_attributes = attrs;
+     pv_uid} :: !pattern_variables;
   if is_module then begin
     (* Note: unpack patterns enter a variable of the same name *)
     if not !allow_modules then
       raise (Error (loc, Env.empty, Modules_not_allowed));
     module_variables := (name, loc) :: !module_variables
   end;
-  id
+  id, pv_uid
 
 let sort_pattern_variables vs =
   List.sort
@@ -549,7 +552,7 @@ let rec build_as_type ~refine (env : Env.t ref) p =
 and build_as_type_aux ~refine (env : Env.t ref) p =
   let build_as_type = build_as_type ~refine in
   match p.pat_desc with
-    Tpat_alias(p1,_, _) -> build_as_type env p1
+    Tpat_alias(p1,_, _, _) -> build_as_type env p1
   | Tpat_tuple pl ->
       let tyl = List.map (build_as_type env) pl in
       newty (Ttuple tyl)
@@ -1661,14 +1664,14 @@ and type_pat_aux
       end
   | Ppat_var name ->
       let ty = instance expected_ty in
-      let id = (* PR#7330 *)
+      let id, uid = (* PR#7330 *)
         if name.txt = "*extension*" then
-          Ident.create_local name.txt
+          Ident.create_local name.txt, Uid.internal_not_actually_unique
         else
           enter_variable loc name ty sp.ppat_attributes
       in
       rvp k {
-        pat_desc = Tpat_var (id, name);
+        pat_desc = Tpat_var (id, name, uid);
         pat_loc = loc; pat_extra=[];
         pat_type = ty;
         pat_attributes = sp.ppat_attributes;
@@ -1687,9 +1690,9 @@ and type_pat_aux
             pat_env = !env }
       | Some s ->
           let v = { name with txt = s } in
-          let id = enter_variable loc v t ~is_module:true sp.ppat_attributes in
+          let id, uid = enter_variable loc v t ~is_module:true sp.ppat_attributes in
           rvp k {
-            pat_desc = Tpat_var (id, v);
+            pat_desc = Tpat_var (id, v, uid);
             pat_loc = sp.ppat_loc;
             pat_extra=[Tpat_unpack, loc, sp.ppat_attributes];
             pat_type = t;
@@ -1703,8 +1706,8 @@ and type_pat_aux
       assert construction_not_used_in_counterexamples;
       let cty, ty, ty' =
         solve_Ppat_poly_constraint ~refine env lloc sty expected_ty in
-      let id = enter_variable lloc name ty' attrs in
-      rvp k { pat_desc = Tpat_var (id, name);
+      let id, uid = enter_variable lloc name ty' attrs in
+      rvp k { pat_desc = Tpat_var (id, name, uid);
               pat_loc = lloc;
               pat_extra = [Tpat_constraint cty, loc, sp.ppat_attributes];
               pat_type = ty;
@@ -1714,11 +1717,11 @@ and type_pat_aux
       assert construction_not_used_in_counterexamples;
       type_pat Value sq expected_ty (fun q ->
         let ty_var = solve_Ppat_alias ~refine env q in
-        let id =
+        let id, uid =
           enter_variable ~is_as_variable:true loc name ty_var sp.ppat_attributes
         in
         rvp k {
-          pat_desc = Tpat_alias(q, id, name);
+          pat_desc = Tpat_alias(q, id, name, uid);
           pat_loc = loc; pat_extra=[];
           pat_type = q.pat_type;
           pat_attributes = sp.ppat_attributes;
@@ -2037,12 +2040,12 @@ and type_pat_aux
         let extra = (Tpat_constraint cty, loc, sp.ppat_attributes) in
         let p : k general_pattern =
           match category, (p : k general_pattern) with
-          | Value, {pat_desc = Tpat_var (id,s); _} ->
+          | Value, {pat_desc = Tpat_var (id,s,uid); _} ->
             {p with
               pat_type = ty;
               pat_desc =
                 Tpat_alias
-                  ({p with pat_desc = Tpat_any; pat_attributes = []}, id,s);
+                  ({p with pat_desc = Tpat_any; pat_attributes = []}, id,s,uid);
               pat_extra = [extra];
             }
           | _, p ->
@@ -2133,12 +2136,12 @@ let iter_pattern_variables_type f : pattern_variable list -> unit =
 
 let add_pattern_variables ?check ?check_as env pv =
   List.fold_right
-    (fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes} env ->
+    (fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes; pv_uid} env ->
        let check = if pv_as_var then check_as else check in
        Env.add_value ?check pv_id
          {val_type = pv_type; val_kind = Val_reg; Types.val_loc = pv_loc;
           val_attributes = pv_attributes;
-          val_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+          val_uid = pv_uid;
          } env
     )
     pv env
@@ -2756,8 +2759,8 @@ let rec name_pattern default = function
     [] -> Ident.create_local default
   | p :: rem ->
     match p.pat_desc with
-      Tpat_var (id, _) -> id
-    | Tpat_alias(_, id, _) -> id
+      Tpat_var (id, _, _) -> id
+    | Tpat_alias(_, id, _, _) -> id
     | _ -> name_pattern default rem
 
 let name_cases default lst =
@@ -3680,10 +3683,12 @@ and type_expect_
         | _ -> Mp_present
       in
       let scope = create_scope () in
+      let md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in
       let md =
         { md_type = modl.mod_type; md_attributes = []; md_loc = name.loc;
-          md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); }
+          md_uid; }
       in
+      let md_shape = Shape.set_uid_if_none md_shape md_uid in
       let (id, new_env) =
         match name.txt with
         | None -> None, env
@@ -3709,7 +3714,7 @@ and type_expect_
         exp_attributes = sexp.pexp_attributes;
         exp_env = env }
   | Pexp_letexception(cd, sbody) ->
-      let (cd, newenv) = Typedecl.transl_exception env cd in
+      let (cd, newenv, _shape) = Typedecl.transl_exception env cd in
       let body = type_expect newenv sbody ty_expected_explained in
       re {
         exp_desc = Texp_letexception(cd, body);
@@ -4470,7 +4475,10 @@ and type_argument ?explanation ?recarg env sarg ty_expected' ty_expected =
           }
         in
         let exp_env = Env.add_value id desc env in
-        {pat_desc = Tpat_var (id, mknoloc name); pat_type = ty;pat_extra=[];
+        {pat_desc =
+          Tpat_var (id, mknoloc name, desc.val_uid);
+         pat_type = ty;
+         pat_extra=[];
          pat_attributes = [];
          pat_loc = Location.none; pat_env = env},
         {exp_type = ty; exp_loc = Location.none; exp_env = exp_env;
@@ -5330,7 +5338,7 @@ and type_let
     List.iter
       (fun {vb_pat=pat} -> match pat.pat_desc with
            Tpat_var _ -> ()
-         | Tpat_alias ({pat_desc=Tpat_any}, _, _) -> ()
+         | Tpat_alias ({pat_desc=Tpat_any}, _, _, _) -> ()
          | _ -> raise(Error(pat.pat_loc, env, Illegal_letrec_pat)))
       l;
   List.iter (function
diff --git a/upstream/ocaml_414/typing/typecore.mli b/upstream/ocaml_414/typing/typecore.mli
index 2f56bb49f0..97c949d15d 100644
--- a/upstream/ocaml_414/typing/typecore.mli
+++ b/upstream/ocaml_414/typing/typecore.mli
@@ -56,6 +56,7 @@ type pattern_variable =
     pv_loc: Location.t;
     pv_as_var: bool;
     pv_attributes: Typedtree.attributes;
+    pv_uid : Uid.t;
   }
 
 val mk_expected:
diff --git a/upstream/ocaml_414/typing/typedecl.ml b/upstream/ocaml_414/typing/typedecl.ml
index d00c0fc450..8f0f8c5b9f 100644
--- a/upstream/ocaml_414/typing/typedecl.ml
+++ b/upstream/ocaml_414/typing/typedecl.ml
@@ -82,9 +82,9 @@ 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 ~check ?shape id decl env =
   Builtin_attributes.warning_scope ~ppwarning:false decl.type_attributes
-    (fun () -> Env.add_type ~check id decl env)
+    (fun () -> Env.add_type ~check ?shape id decl env)
 
 let enter_type rec_flag env sdecl (id, uid) =
   let needed =
@@ -222,7 +222,9 @@ let transl_labels env univars closed lbls =
          let arg = Ast_helper.Typ.force_poly arg in
          let cty = transl_simple_type env ?univars closed arg in
          {ld_id = Ident.create_local name.txt;
-          ld_name = name; ld_mutable = mut;
+          ld_name = name;
+          ld_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+          ld_mutable = mut;
           ld_type = cty; ld_loc = loc; ld_attributes = attrs}
       )
   in
@@ -237,7 +239,7 @@ let transl_labels env univars closed lbls =
           ld_type = ty;
           ld_loc = ld.ld_loc;
           ld_attributes = ld.ld_attributes;
-          ld_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+          ld_uid = ld.ld_uid;
          }
       )
       lbls in
@@ -307,6 +309,27 @@ let make_constructor env loc type_path type_params svars sargs sret_type =
       widen z;
       targs, Some tret_type, args, Some ret_type
 
+
+let shape_map_labels =
+  List.fold_left (fun map { ld_id; ld_uid; _} ->
+    Shape.Map.add_label map ld_id ld_uid)
+    Shape.Map.empty
+
+let shape_map_cstrs =
+  List.fold_left (fun map { cd_id; cd_uid; cd_args; _ } ->
+    let cstr_shape_map =
+      let label_decls =
+        match cd_args with
+        | Cstr_tuple _ -> []
+        | Cstr_record ldecls -> ldecls
+      in
+      shape_map_labels label_decls
+    in
+    Shape.Map.add_constr map cd_id
+      @@ Shape.str ~uid:cd_uid cstr_shape_map)
+    (Shape.Map.empty)
+
+
 let transl_declaration env sdecl (id, uid) =
   (* Bind type parameters *)
   reset_type_variables();
@@ -393,6 +416,7 @@ let transl_declaration env sdecl (id, uid) =
           let tcstr =
             { cd_id = name;
               cd_name = scstr.pcd_name;
+              cd_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
               cd_vars = scstr.pcd_vars;
               cd_args = targs;
               cd_res = tret_type;
@@ -405,7 +429,7 @@ let transl_declaration env sdecl (id, uid) =
               cd_res = ret_type;
               cd_loc = scstr.pcd_loc;
               cd_attributes = scstr.pcd_attributes;
-              cd_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) }
+              cd_uid = tcstr.cd_uid }
           in
             tcstr, cstr
         in
@@ -470,18 +494,29 @@ let transl_declaration env sdecl (id, uid) =
       in
       set_private_row env sdecl.ptype_loc p decl
     end;
-    {
-      typ_id = id;
-      typ_name = sdecl.ptype_name;
-      typ_params = tparams;
-      typ_type = decl;
-      typ_cstrs = cstrs;
-      typ_loc = sdecl.ptype_loc;
-      typ_manifest = tman;
-      typ_kind = tkind;
-      typ_private = sdecl.ptype_private;
-      typ_attributes = sdecl.ptype_attributes;
-    }
+    let decl =
+      {
+        typ_id = id;
+        typ_name = sdecl.ptype_name;
+        typ_params = tparams;
+        typ_type = decl;
+        typ_cstrs = cstrs;
+        typ_loc = sdecl.ptype_loc;
+        typ_manifest = tman;
+        typ_kind = tkind;
+        typ_private = sdecl.ptype_private;
+        typ_attributes = sdecl.ptype_attributes;
+      }
+    in
+    let typ_shape =
+      let map = match decl.typ_kind with
+        | Ttype_variant cstrs -> shape_map_cstrs cstrs
+        | Ttype_record labels -> shape_map_labels labels
+        | _ -> Shape.Map.empty
+      in
+      Shape.str ~uid:decl.typ_type.type_uid map
+    in
+    decl, typ_shape
 
 (* Generalize a type declaration *)
 
@@ -841,10 +876,11 @@ 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)
-    decls env
+let add_types_to_env decls shapes env =
+  List.fold_right2
+    (fun (id, decl) shape env ->
+      add_type ~check:true ~shape id decl env)
+    decls shapes env
 
 (* Translate a set of type declarations, mutually recursive or not *)
 let transl_type_decl env rec_flag sdecl_list =
@@ -910,13 +946,16 @@ let transl_type_decl env rec_flag sdecl_list =
   in
   let tdecls =
     List.map2 transl_declaration sdecl_list (List.map ids_slots ids_list) in
-  let decls =
-    List.map (fun tdecl -> (tdecl.typ_id, tdecl.typ_type)) tdecls in
+  let decls, shapes =
+    List.map (fun (tdecl, tshape) -> (tdecl.typ_id, tdecl.typ_type), tshape)
+      tdecls
+    |> List.split
+  in
   current_slot := None;
   (* Check for duplicates *)
   check_duplicates sdecl_list;
   (* Build the final env. *)
-  let new_env = add_types_to_env decls env in
+  let new_env = add_types_to_env decls shapes env in
   (* Update stubs *)
   begin match rec_flag with
     | Asttypes.Nonrecursive -> ()
@@ -943,11 +982,12 @@ let transl_type_decl env rec_flag sdecl_list =
     check_well_founded_decl new_env (List.assoc id id_loc_list) (Path.Pident id)
       decl to_check)
     decls;
-  List.iter
-    (check_abbrev_recursion ~orig_env:env new_env id_loc_list to_check) tdecls;
+  List.iter (fun (decl, _shape) ->
+    check_abbrev_recursion ~orig_env:env new_env id_loc_list to_check decl)
+    tdecls;
   (* Check that all type variables are closed *)
   List.iter2
-    (fun sdecl tdecl ->
+    (fun sdecl (tdecl, _shape) ->
       let decl = tdecl.typ_type in
        match Ctype.closed_type_decl decl with
          Some ty -> raise(Error(sdecl.ptype_loc, Unbound_type_var(ty,decl)))
@@ -972,18 +1012,18 @@ let transl_type_decl env rec_flag sdecl_list =
         raise (Error (loc, Separability err))
   in
   (* Compute the final environment with variance and immediacy *)
-  let final_env = add_types_to_env decls env in
+  let final_env = add_types_to_env decls shapes env in
   (* Check re-exportation *)
   List.iter2 (check_abbrev final_env) sdecl_list decls;
   (* Keep original declaration *)
   let final_decls =
     List.map2
-      (fun tdecl (_id2, decl) ->
+      (fun (tdecl, _shape) (_id2, decl) ->
         { tdecl with typ_type = decl }
       ) tdecls decls
   in
   (* Done *)
-  (final_decls, final_env)
+  (final_decls, final_env, shapes)
 
 (* Translating type extensions *)
 
@@ -1092,12 +1132,22 @@ let transl_extension_constructor ~scope env type_path type_params
       ext_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
     }
   in
+  let ext_cstrs =
     { ext_id = id;
       ext_name = sext.pext_name;
       ext_type = ext;
       ext_kind = kind;
       Typedtree.ext_loc = sext.pext_loc;
       Typedtree.ext_attributes = sext.pext_attributes; }
+  in
+  let shape =
+    let map =  match ext_cstrs.ext_kind with
+    | Text_decl (_, Cstr_record lbls, _) -> shape_map_labels lbls
+    | _ -> Shape.Map.empty
+    in
+    Shape.str ~uid:ext_cstrs.ext_type.ext_uid map
+ in
+  ext_cstrs, shape
 
 let transl_extension_constructor ~scope env type_path type_params
     typext_params priv sext =
@@ -1174,13 +1224,13 @@ let transl_type_extension extend env loc styext =
   (* Generalize types *)
   List.iter Ctype.generalize type_params;
   List.iter
-    (fun ext ->
+    (fun (ext, _shape) ->
        Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args;
        Option.iter Ctype.generalize ext.ext_type.ext_ret_type)
     constructors;
   (* Check that all type variables are closed *)
   List.iter
-    (fun ext ->
+    (fun (ext, _shape) ->
        match Ctype.closed_extension_constructor ext.ext_type with
          Some ty ->
            raise(Error(ext.ext_loc, Unbound_type_var_ext(ty, ext.ext_type)))
@@ -1188,7 +1238,7 @@ let transl_type_extension extend env loc styext =
     constructors;
   (* Check variances are correct *)
   List.iter
-    (fun ext->
+    (fun (ext, _shape) ->
        (* Note that [loc] here is distinct from [type_decl.type_loc], which
           makes the [loc] parameter to this function useful. [loc] is the
           location of the extension, while [type_decl] points to the original
@@ -1201,11 +1251,13 @@ let transl_type_extension extend env loc styext =
   (* Add extension constructors to the environment *)
   let newenv =
     List.fold_left
-      (fun env ext ->
+      (fun env (ext, shape) ->
          let rebind = is_rebind ext in
-         Env.add_extension ~check:true ~rebind ext.ext_id ext.ext_type env)
+         Env.add_extension ~check:true ~shape ~rebind
+           ext.ext_id ext.ext_type env)
       env constructors
   in
+  let constructors, shapes = List.split constructors in
   let tyext =
     { tyext_path = type_path;
       tyext_txt = styext.ptyext_path;
@@ -1215,7 +1267,7 @@ let transl_type_extension extend env loc styext =
       tyext_loc = styext.ptyext_loc;
       tyext_attributes = styext.ptyext_attributes; }
   in
-    (tyext, newenv)
+    (tyext, newenv, shapes)
 
 let transl_type_extension extend env loc styext =
   Builtin_attributes.warning_scope styext.ptyext_attributes
@@ -1225,7 +1277,7 @@ let transl_exception env sext =
   let scope = Ctype.create_scope () in
   reset_type_variables();
   Ctype.begin_def();
-  let ext =
+  let ext, shape =
     transl_extension_constructor ~scope env
       Predef.path_exn [] [] Asttypes.Public sext
   in
@@ -1241,13 +1293,13 @@ let transl_exception env sext =
   end;
   let rebind = is_rebind ext in
   let newenv =
-    Env.add_extension ~check:true ~rebind ext.ext_id ext.ext_type env
+    Env.add_extension ~check:true ~shape ~rebind ext.ext_id ext.ext_type env
   in
-  ext, newenv
+  ext, newenv, shape
 
 let transl_type_exception env t =
   Builtin_attributes.check_no_alert t.ptyexn_attributes;
-  let contructor, newenv =
+  let contructor, newenv, shape =
     Builtin_attributes.warning_scope t.ptyexn_attributes
       (fun () ->
          transl_exception env t.ptyexn_constructor
@@ -1255,7 +1307,7 @@ let transl_type_exception env t =
   in
   {tyexn_constructor = contructor;
    tyexn_loc = t.ptyexn_loc;
-   tyexn_attributes = t.ptyexn_attributes}, newenv
+   tyexn_attributes = t.ptyexn_attributes}, newenv, shape
 
 
 type native_repr_attribute =
diff --git a/upstream/ocaml_414/typing/typedecl.mli b/upstream/ocaml_414/typing/typedecl.mli
index 0fb68edf42..cc4cf3fc80 100644
--- a/upstream/ocaml_414/typing/typedecl.mli
+++ b/upstream/ocaml_414/typing/typedecl.mli
@@ -20,19 +20,19 @@ open Format
 
 val transl_type_decl:
     Env.t -> Asttypes.rec_flag -> Parsetree.type_declaration list ->
-    Typedtree.type_declaration list * Env.t
+    Typedtree.type_declaration list * Env.t * Shape.t list
 
 val transl_exception:
     Env.t -> Parsetree.extension_constructor ->
-    Typedtree.extension_constructor * Env.t
+    Typedtree.extension_constructor * Env.t * Shape.t
 
 val transl_type_exception:
     Env.t ->
-    Parsetree.type_exception -> Typedtree.type_exception * Env.t
+    Parsetree.type_exception -> Typedtree.type_exception * Env.t * Shape.t
 
 val transl_type_extension:
     bool -> Env.t -> Location.t -> Parsetree.type_extension ->
-    Typedtree.type_extension * Env.t
+    Typedtree.type_extension * Env.t * Shape.t list
 
 val transl_value_decl:
     Env.t -> Location.t ->
diff --git a/upstream/ocaml_414/typing/typedtree.ml b/upstream/ocaml_414/typing/typedtree.ml
index 9194a59c18..d16f063e76 100644
--- a/upstream/ocaml_414/typing/typedtree.ml
+++ b/upstream/ocaml_414/typing/typedtree.ml
@@ -18,6 +18,8 @@
 open Asttypes
 open Types
 
+module Uid = Shape.Uid
+
 (* Value expressions for the core language *)
 
 type partial = Partial | Total
@@ -53,9 +55,9 @@ and pat_extra =
 and 'k pattern_desc =
   (* value patterns *)
   | Tpat_any : value pattern_desc
-  | Tpat_var : Ident.t * string loc -> value pattern_desc
+  | Tpat_var : Ident.t * string loc * Uid.t -> value pattern_desc
   | Tpat_alias :
-      value general_pattern * Ident.t * string loc -> value pattern_desc
+      value general_pattern * Ident.t * string loc * Uid.t -> value pattern_desc
   | Tpat_constant : constant -> value pattern_desc
   | Tpat_tuple : value general_pattern list -> value pattern_desc
   | Tpat_construct :
@@ -288,6 +290,7 @@ and module_binding =
     {
      mb_id: Ident.t option;
      mb_name: string option loc;
+     mb_uid: Uid.t;
      mb_presence: module_presence;
      mb_expr: module_expr;
      mb_attributes: attribute list;
@@ -367,6 +370,7 @@ and module_declaration =
     {
      md_id: Ident.t option;
      md_name: string option loc;
+     md_uid: Uid.t;
      md_presence: module_presence;
      md_type: module_type;
      md_attributes: attribute list;
@@ -377,6 +381,7 @@ and module_substitution =
     {
      ms_id: Ident.t;
      ms_name: string loc;
+     ms_uid: Uid.t;
      ms_manifest: Path.t;
      ms_txt: Longident.t loc;
      ms_attributes: attributes;
@@ -387,6 +392,7 @@ and module_type_declaration =
     {
      mtd_id: Ident.t;
      mtd_name: string loc;
+     mtd_uid: Uid.t;
      mtd_type: module_type option;
      mtd_attributes: attribute list;
      mtd_loc: Location.t;
@@ -509,6 +515,7 @@ and label_declaration =
     {
      ld_id: Ident.t;
      ld_name: string loc;
+     ld_uid: Uid.t;
      ld_mutable: mutable_flag;
      ld_type: core_type;
      ld_loc: Location.t;
@@ -519,6 +526,7 @@ and constructor_declaration =
     {
      cd_id: Ident.t;
      cd_name: string loc;
+     cd_uid: Uid.t;
      cd_vars: string loc list;
      cd_args: constructor_arguments;
      cd_res: core_type option;
@@ -672,7 +680,7 @@ type pattern_action =
 let shallow_iter_pattern_desc
   : type k . pattern_action -> k pattern_desc -> unit
   = fun f -> function
-  | Tpat_alias(p, _, _) -> f.f p
+  | Tpat_alias(p, _, _, _) -> f.f p
   | Tpat_tuple patl -> List.iter f.f patl
   | Tpat_construct(_, _, patl, _) -> List.iter f.f patl
   | Tpat_variant(_, pat, _) -> Option.iter f.f pat
@@ -692,8 +700,8 @@ type pattern_transformation =
 let shallow_map_pattern_desc
   : type k . pattern_transformation -> k pattern_desc -> k pattern_desc
   = fun f d -> match d with
-  | Tpat_alias (p1, id, s) ->
-      Tpat_alias (f.f p1, id, s)
+  | Tpat_alias (p1, id, s, uid) ->
+      Tpat_alias (f.f p1, id, s, uid)
   | Tpat_tuple pats ->
       Tpat_tuple (List.map f.f pats)
   | Tpat_record (lpats, closed) ->
@@ -754,11 +762,11 @@ let rec iter_bound_idents
   : type k . _ -> k general_pattern -> _
   = fun f pat ->
   match pat.pat_desc with
-  | Tpat_var (id,s) ->
-     f (id,s,pat.pat_type)
-  | Tpat_alias(p, id, s) ->
+  | Tpat_var (id, s, uid) ->
+     f (id,s,pat.pat_type, uid)
+  | Tpat_alias(p, id, s, uid) ->
       iter_bound_idents f p;
-      f (id,s,pat.pat_type)
+      f (id,s,pat.pat_type, uid)
   | Tpat_or(p1, _, _) ->
       (* Invariant : both arguments bind the same variables *)
       iter_bound_idents f p1
@@ -774,7 +782,7 @@ let rev_pat_bound_idents_full pat =
   !idents_full
 
 let rev_only_idents idents_full =
-  List.rev_map (fun (id,_,_) -> id) idents_full
+  List.rev_map (fun (id,_,_,_) -> id) idents_full
 
 let pat_bound_idents_full pat =
   List.rev (rev_pat_bound_idents_full pat)
@@ -792,19 +800,27 @@ let let_bound_idents_full bindings =
 let let_bound_idents pat =
   rev_only_idents (rev_let_bound_idents_full pat)
 
+let let_filter_bound bindings =
+  let decls = ref [] in
+  let add vb (_,_,_,uid) =
+    decls := (vb, uid) :: !decls
+  in
+  List.iter (fun vb -> iter_bound_idents (add vb) vb.vb_pat) bindings;
+  !decls
+
 let alpha_var env id = List.assoc id env
 
 let rec alpha_pat
   : type k . _ -> k general_pattern -> k general_pattern
   = fun env p -> match p.pat_desc with
-  | Tpat_var (id, s) -> (* note the ``Not_found'' case *)
+  | Tpat_var (id, s, uid) -> (* note the ``Not_found'' case *)
       {p with pat_desc =
-       try Tpat_var (alpha_var env id, s) with
+       try Tpat_var (alpha_var env id, s, uid) with
        | Not_found -> Tpat_any}
-  | Tpat_alias (p1, id, s) ->
+  | Tpat_alias (p1, id, s, uid) ->
       let new_p =  alpha_pat env p1 in
       begin try
-        {p with pat_desc = Tpat_alias (new_p, alpha_var env id, s)}
+        {p with pat_desc = Tpat_alias (new_p, alpha_var env id, s, uid)}
       with
       | Not_found -> new_p
       end
diff --git a/upstream/ocaml_414/typing/typedtree.mli b/upstream/ocaml_414/typing/typedtree.mli
index f5460d1ea2..377daa87cb 100644
--- a/upstream/ocaml_414/typing/typedtree.mli
+++ b/upstream/ocaml_414/typing/typedtree.mli
@@ -22,6 +22,7 @@
 *)
 
 open Asttypes
+module Uid = Shape.Uid
 
 (* Value expressions for the core language *)
 
@@ -75,10 +76,10 @@ and 'k pattern_desc =
   (* value patterns *)
   | Tpat_any : value pattern_desc
         (** _ *)
-  | Tpat_var : Ident.t * string loc -> value pattern_desc
+  | Tpat_var : Ident.t * string loc * Uid.t -> value pattern_desc
         (** x *)
   | Tpat_alias :
-      value general_pattern * Ident.t * string loc -> value pattern_desc
+      value general_pattern * Ident.t * string loc * Uid.t -> value pattern_desc
         (** P as a *)
   | Tpat_constant : constant -> value pattern_desc
         (** 1, 'a', "true", 1.0, 1l, 1L, 1n *)
@@ -429,6 +430,7 @@ and module_binding =
     {
      mb_id: Ident.t option;
      mb_name: string option loc;
+     mb_uid: Uid.t;
      mb_presence: Types.module_presence;
      mb_expr: module_expr;
      mb_attributes: attributes;
@@ -507,6 +509,7 @@ and module_declaration =
     {
      md_id: Ident.t option;
      md_name: string option loc;
+     md_uid: Uid.t;
      md_presence: Types.module_presence;
      md_type: module_type;
      md_attributes: attributes;
@@ -517,6 +520,7 @@ and module_substitution =
     {
      ms_id: Ident.t;
      ms_name: string loc;
+     ms_uid: Uid.t;
      ms_manifest: Path.t;
      ms_txt: Longident.t loc;
      ms_attributes: attributes;
@@ -527,6 +531,7 @@ and module_type_declaration =
     {
      mtd_id: Ident.t;
      mtd_name: string loc;
+     mtd_uid: Uid.t;
      mtd_type: module_type option;
      mtd_attributes: attributes;
      mtd_loc: Location.t;
@@ -651,6 +656,7 @@ and label_declaration =
     {
      ld_id: Ident.t;
      ld_name: string loc;
+     ld_uid: Uid.t;
      ld_mutable: mutable_flag;
      ld_type: core_type;
      ld_loc: Location.t;
@@ -661,6 +667,7 @@ and constructor_declaration =
     {
      cd_id: Ident.t;
      cd_name: string loc;
+     cd_uid: Uid.t;
      cd_vars: string loc list;
      cd_args: constructor_arguments;
      cd_res: core_type option;
@@ -808,7 +815,9 @@ val exists_pattern: (pattern -> bool) -> pattern -> bool
 
 val let_bound_idents: value_binding list -> Ident.t list
 val let_bound_idents_full:
-    value_binding list -> (Ident.t * string loc * Types.type_expr) list
+    value_binding list ->
+    (Ident.t * string loc * Types.type_expr * Types.Uid.t) list
+val let_filter_bound: value_binding list ->  (value_binding * Uid.t) list
 
 (** Alpha conversion of patterns *)
 val alpha_pat:
@@ -819,7 +828,8 @@ val mkloc: 'a -> Location.t -> 'a Asttypes.loc
 
 val pat_bound_idents: 'k general_pattern -> Ident.t list
 val pat_bound_idents_full:
-  'k general_pattern -> (Ident.t * string loc * Types.type_expr) list
+  'k general_pattern ->
+  (Ident.t * string loc * Types.type_expr * Types.Uid.t) list
 
 (** Splits an or pattern into its value (left) and exception (right) parts. *)
 val split_pattern:
diff --git a/upstream/ocaml_414/typing/typemod.ml b/upstream/ocaml_414/typing/typemod.ml
index b575de2909..b6bc5914c3 100644
--- a/upstream/ocaml_414/typing/typemod.ml
+++ b/upstream/ocaml_414/typing/typemod.ml
@@ -1042,7 +1042,7 @@ end = struct
     let open Sig_component_kind in
     match component with
     | Value -> names.values
-    | Type -> names.types
+    | Type | Label | Constructor -> names.types
     | Module -> names.modules
     | Module_type -> names.modtypes
     | Extension_constructor -> names.typexts
@@ -1378,19 +1378,16 @@ and transl_signature env sg =
               Typedecl.transl_value_decl env item.psig_loc sdesc
             in
             Signature_names.check_value names tdesc.val_loc tdesc.val_id;
-            Env.register_uid tdesc.val_val.val_uid tdesc.val_loc;
             let (trem,rem, final_env) = transl_sig newenv srem in
             mksig (Tsig_value tdesc) env loc :: trem,
             Sig_value(tdesc.val_id, tdesc.val_val, Exported) :: rem,
               final_env
         | Psig_type (rec_flag, sdecls) ->
-            let (decls, newenv) =
+            let (decls, newenv, _) =
               Typedecl.transl_type_decl env rec_flag sdecls
             in
             List.iter (fun td ->
               Signature_names.check_type names td.typ_loc td.typ_id;
-              if not (Btype.is_row_name (Ident.name td.typ_id)) then
-                Env.register_uid td.typ_type.type_uid td.typ_loc
             ) decls;
             let (trem, rem, final_env) = transl_sig newenv srem in
             let sg =
@@ -1402,7 +1399,7 @@ and transl_signature env sg =
             sg,
             final_env
         | Psig_typesubst sdecls ->
-            let (decls, newenv) =
+            let (decls, newenv, _) =
               Typedecl.transl_type_decl env Nonrecursive sdecls
             in
             List.iter (fun td ->
@@ -1422,8 +1419,7 @@ and transl_signature env sg =
                   in
                   Some (`Substituted_away subst)
               in
-              Signature_names.check_type ?info names td.typ_loc td.typ_id;
-              Env.register_uid td.typ_type.type_uid td.typ_loc
+              Signature_names.check_type ?info names td.typ_loc td.typ_id
             ) decls;
             let (trem, rem, final_env) = transl_sig newenv srem in
             let sg = rem
@@ -1432,13 +1428,12 @@ and transl_signature env sg =
             sg,
             final_env
         | Psig_typext styext ->
-            let (tyext, newenv) =
+            let (tyext, newenv, _shapes) =
               Typedecl.transl_type_extension false env item.psig_loc styext
             in
             let constructors = tyext.tyext_constructors in
             List.iter (fun ext ->
-              Signature_names.check_typext names ext.ext_loc ext.ext_id;
-              Env.register_uid ext.ext_type.ext_uid ext.ext_loc
+              Signature_names.check_typext names ext.ext_loc ext.ext_id
             ) constructors;
             let (trem, rem, final_env) = transl_sig newenv srem in
               mksig (Tsig_typext tyext) env loc :: trem,
@@ -1447,13 +1442,10 @@ and transl_signature env sg =
               ) constructors rem,
               final_env
         | Psig_exception sext ->
-            let (ext, newenv) = Typedecl.transl_type_exception env sext in
+            let (ext, newenv, _s) = Typedecl.transl_type_exception env sext in
             let constructor = ext.tyexn_constructor in
             Signature_names.check_typext names constructor.ext_loc
               constructor.ext_id;
-            Env.register_uid
-              constructor.ext_type.ext_uid
-              constructor.ext_loc;
             let (trem, rem, final_env) = transl_sig newenv srem in
             mksig (Tsig_exception ext) env loc :: trem,
             Sig_typext(constructor.ext_id,
@@ -1489,11 +1481,10 @@ and transl_signature env sg =
                 Signature_names.check_module names pmd.pmd_name.loc id;
                 Some id, newenv
             in
-            Env.register_uid md.md_uid md.md_loc;
             let (trem, rem, final_env) = transl_sig newenv srem in
             mksig (Tsig_module {md_id=id; md_name=pmd.pmd_name;
-                                md_presence=pres; md_type=tmty;
-                                md_loc=pmd.pmd_loc;
+                                md_uid=md.md_uid; md_presence=pres;
+                                md_type=tmty; md_loc=pmd.pmd_loc;
                                 md_attributes=pmd.pmd_attributes})
               env loc :: trem,
             (match id with
@@ -1529,9 +1520,8 @@ and transl_signature env sg =
               `Substituted_away (Subst.add_module id path Subst.identity)
             in
             Signature_names.check_module ~info names pms.pms_name.loc id;
-            Env.register_uid md.md_uid md.md_loc;
             let (trem, rem, final_env) = transl_sig newenv srem in
-            mksig (Tsig_modsubst {ms_id=id; ms_name=pms.pms_name;
+            mksig (Tsig_modsubst {ms_id=id; ms_name=pms.pms_name; ms_uid=md.md_uid;
                                   ms_manifest=path; ms_txt=pms.pms_manifest;
                                   ms_loc=pms.pms_loc;
                                   ms_attributes=pms.pms_attributes})
@@ -1548,9 +1538,8 @@ and transl_signature env sg =
                 | Some id -> Some (id, md, uid)
               ) tdecls
             in
-            List.iter (fun (id, md, uid) ->
+            List.iter (fun (id, md, _uid) ->
               Signature_names.check_module names md.md_loc id;
-              Env.register_uid uid md.md_loc
             ) decls;
             let (trem, rem, final_env) = transl_sig newenv srem in
             mksig (Tsig_recmodule (List.map (fun (md, _, _) -> md) tdecls))
@@ -1565,15 +1554,16 @@ and transl_signature env sg =
               decls rem,
             final_env
         | Psig_modtype pmtd ->
-            let newenv, mtd, decl = transl_modtype_decl env pmtd in
+            let newenv, mtd, (decl : modtype_declaration) =
+              transl_modtype_decl env pmtd
+            in
             Signature_names.check_modtype names pmtd.pmtd_loc mtd.mtd_id;
-            Env.register_uid decl.mtd_uid mtd.mtd_loc;
             let (trem, rem, final_env) = transl_sig newenv srem in
             mksig (Tsig_modtype mtd) env loc :: trem,
             Sig_modtype (mtd.mtd_id, decl, Exported) :: rem,
             final_env
         | Psig_modtypesubst pmtd ->
-            let newenv, mtd, decl = transl_modtype_decl env pmtd in
+            let newenv, mtd, _decl = transl_modtype_decl env pmtd in
             let info =
               let mty = match mtd.mtd_type with
                 | Some tmty -> tmty.mty_type
@@ -1587,7 +1577,6 @@ and transl_signature env sg =
               | _ -> `Unpackable_modtype_substituted_away (mtd.mtd_id,subst)
             in
             Signature_names.check_modtype ~info names pmtd.pmtd_loc mtd.mtd_id;
-            Env.register_uid decl.mtd_uid mtd.mtd_loc;
             let (trem, rem, final_env) = transl_sig newenv srem in
             mksig (Tsig_modtypesubst mtd) env loc :: trem,
             rem,
@@ -1630,7 +1619,6 @@ and transl_signature env sg =
               Signature_names.check_class names loc cls.cls_id;
               Signature_names.check_class_type names loc cls.cls_ty_id;
               Signature_names.check_type names loc cls.cls_typesharp_id;
-              Env.register_uid cls.cls_decl.cty_uid cls.cls_decl.cty_loc;
             ) classes;
             let (trem, rem, final_env) = transl_sig newenv srem in
             let sg =
@@ -1658,9 +1646,6 @@ and transl_signature env sg =
               Signature_names.check_class_type names loc decl.clsty_ty_id;
               Signature_names.check_type names loc decl.clsty_obj_id;
               Signature_names.check_type names loc decl.clsty_typesharp_id;
-              Env.register_uid
-                decl.clsty_ty_decl.clty_uid
-                decl.clsty_ty_decl.clty_loc;
             ) classes;
             let (trem,rem, final_env) = transl_sig newenv srem in
             let sg =
@@ -1726,6 +1711,7 @@ and transl_modtype_decl_aux env
     {
      mtd_id=id;
      mtd_name=pmtd_name;
+     mtd_uid=decl.mtd_uid;
      mtd_type=tmty;
      mtd_attributes=pmtd_attributes;
      mtd_loc=pmtd_loc;
@@ -1808,11 +1794,11 @@ and transl_recmodule_modtypes env sdecls =
     List.map2 (fun pmd (id_shape, id_loc, md, mty) ->
       let tmd =
         {md_id=Option.map fst id_shape; md_name=id_loc; md_type=mty;
-         md_presence=Mp_present;
+         md_uid=md.Types.md_uid; md_presence=Mp_present;
          md_loc=pmd.pmd_loc;
          md_attributes=pmd.pmd_attributes}
       in
-      tmd, md.md_uid, Option.map snd id_shape
+      tmd, md.Types.md_uid, Option.map snd id_shape
     ) sdecls dcl2
   in
   (dcl2, env2)
@@ -1999,6 +1985,7 @@ let check_recmodule_inclusion env bindings =
           {
             mb_id = id;
             mb_name = name;
+            mb_uid = uid;
             mb_presence = Mp_present;
             mb_expr = modl';
             mb_attributes = attrs;
@@ -2464,10 +2451,9 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr =
            will be marked as being used during the signature inclusion test. *)
         let items, shape_map =
           List.fold_left
-            (fun (acc, shape_map) (id, { Asttypes.loc; _ }, _typ)->
+            (fun (acc, shape_map) (id, { Asttypes.loc; _ }, _typ, _uid)->
               Signature_names.check_value names loc id;
               let vd =  Env.find_value (Pident id) newenv in
-              Env.register_uid vd.val_uid vd.val_loc;
               Sig_value(id, vd, Exported) :: acc,
               Shape.Map.add_value shape_map id vd.val_uid
             )
@@ -2481,13 +2467,14 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr =
     | Pstr_primitive sdesc ->
         let (desc, newenv) = Typedecl.transl_value_decl env loc sdesc in
         Signature_names.check_value names desc.val_loc desc.val_id;
-        Env.register_uid desc.val_val.val_uid desc.val_val.val_loc;
         Tstr_primitive desc,
         [Sig_value(desc.val_id, desc.val_val, Exported)],
         Shape.Map.add_value shape_map desc.val_id desc.val_val.val_uid,
         newenv
     | Pstr_type (rec_flag, sdecls) ->
-        let (decls, newenv) = Typedecl.transl_type_decl env rec_flag sdecls in
+        let (decls, newenv, shapes) =
+          Typedecl.transl_type_decl env rec_flag sdecls
+        in
         List.iter
           Signature_names.(fun td -> check_type names td.typ_loc td.typ_id)
           decls;
@@ -2495,32 +2482,26 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr =
           (fun rs info -> Sig_type(info.typ_id, info.typ_type, rs, Exported))
           decls []
         in
-        let shape_map = List.fold_left
-          (fun shape_map -> function
-            | Sig_type (id, vd, _, _) ->
-              if not (Btype.is_row_name (Ident.name id)) then begin
-                Env.register_uid vd.type_uid vd.type_loc;
-                Shape.Map.add_type shape_map id vd.type_uid
-              end else shape_map
-            | _ -> assert false
-          )
+        let shape_map = List.fold_left2
+          (fun map { typ_id; _} shape ->
+            Shape.Map.add_type map typ_id shape)
           shape_map
-          items
+          decls
+          shapes
         in
         Tstr_type (rec_flag, decls),
         items,
         shape_map,
         enrich_type_decls anchor decls env newenv
     | Pstr_typext styext ->
-        let (tyext, newenv) =
+        let (tyext, newenv, shapes) =
           Typedecl.transl_type_extension true env loc styext
         in
         let constructors = tyext.tyext_constructors in
-        let shape_map = List.fold_left (fun shape_map ext ->
+        let shape_map = List.fold_left2 (fun shape_map ext shape ->
             Signature_names.check_typext names ext.ext_loc ext.ext_id;
-            Env.register_uid ext.ext_type.ext_uid ext.ext_loc;
-            Shape.Map.add_extcons shape_map ext.ext_id ext.ext_type.ext_uid
-          ) shape_map constructors
+            Shape.Map.add_extcons shape_map ext.ext_id shape
+          ) shape_map constructors shapes
         in
         (Tstr_typext tyext,
          map_ext
@@ -2529,13 +2510,10 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr =
         shape_map,
          newenv)
     | Pstr_exception sext ->
-        let (ext, newenv) = Typedecl.transl_type_exception env sext in
+        let (ext, newenv, shape) = Typedecl.transl_type_exception env sext in
         let constructor = ext.tyexn_constructor in
         Signature_names.check_typext names constructor.ext_loc
           constructor.ext_id;
-        Env.register_uid
-          constructor.ext_type.ext_uid
-          constructor.ext_loc;
         Tstr_exception ext,
         [Sig_typext(constructor.ext_id,
                     constructor.ext_type,
@@ -2543,7 +2521,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr =
                     Exported)],
         Shape.Map.add_extcons shape_map
           constructor.ext_id
-          constructor.ext_type.ext_uid,
+          shape,
         newenv
     | Pstr_module {pmb_name = name; pmb_expr = smodl; pmb_attributes = attrs;
                    pmb_loc;
@@ -2570,8 +2548,11 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr =
             md_uid;
           }
         in
-        let md_shape = Shape.set_uid_if_none md_shape md_uid in
-        Env.register_uid md_uid pmb_loc;
+        let md_shape =
+          match modl.mod_type with
+          | Mty_alias _path -> Shape.alias ~uid:md_uid md_shape
+          | _ -> Shape.set_uid_if_none md_shape md_uid
+        in
         (*prerr_endline (Ident.unique_toplevel_name id);*)
         Mtype.lower_nongen outer_scope md.md_type;
         let id, newenv, sg =
@@ -2594,8 +2575,9 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr =
           | Some id -> Shape.Map.add_module shape_map id md_shape
           | None -> shape_map
         in
-        Tstr_module {mb_id=id; mb_name=name; mb_expr=modl;
-                     mb_presence=pres; mb_attributes=attrs;  mb_loc=pmb_loc; },
+        Tstr_module {mb_id=id; mb_name=name; mb_uid = md.md_uid;
+                     mb_expr=modl; mb_presence=pres; mb_attributes=attrs;
+                     mb_loc=pmb_loc; },
         sg,
         shape_map,
         newenv
@@ -2668,8 +2650,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr =
           ) bindings2
         in
         let shape_map =
-          List.fold_left (fun map (id, mb, uid, shape) ->
-            Env.register_uid uid mb.mb_loc;
+          List.fold_left (fun map (id, _mb, _uid, shape) ->
             Shape.Map.add_module map id shape
           ) shape_map mbs
         in
@@ -2688,7 +2669,6 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr =
         (* check that it is non-abstract *)
         let newenv, mtd, decl = transl_modtype_decl env pmtd in
         Signature_names.check_modtype names pmtd.pmtd_loc mtd.mtd_id;
-        Env.register_uid decl.mtd_uid decl.mtd_loc;
         let id = mtd.mtd_id in
         let map = Shape.Map.add_module_type shape_map id decl.mtd_uid in
         Tstr_modtype mtd, [Sig_modtype (id, decl, Exported)], map, newenv
@@ -2706,12 +2686,13 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr =
             Signature_names.check_class_type names loc cls.cls_ty_id;
             Signature_names.check_type names loc cls.cls_obj_id;
             Signature_names.check_type names loc cls.cls_typesharp_id;
-            Env.register_uid cls.cls_decl.cty_uid loc;
-            let map f id acc = f acc id cls.cls_decl.cty_uid in
+            let uid = cls.cls_decl.cty_uid in
+            let map f id acc = f acc id uid in
+            let map_t f id acc = f acc id (Shape.str ~uid Shape.Map.empty) in
             map Shape.Map.add_class cls.cls_id acc
             |> map Shape.Map.add_class_type cls.cls_ty_id
-            |> map Shape.Map.add_type cls.cls_obj_id
-            |> map Shape.Map.add_type cls.cls_typesharp_id
+            |> map_t Shape.Map.add_type cls.cls_obj_id
+            |> map_t Shape.Map.add_type cls.cls_typesharp_id
           ) shape_map classes
         in
         Tstr_class
@@ -2737,11 +2718,12 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr =
             Signature_names.check_class_type names loc decl.clsty_ty_id;
             Signature_names.check_type names loc decl.clsty_obj_id;
             Signature_names.check_type names loc decl.clsty_typesharp_id;
-            Env.register_uid decl.clsty_ty_decl.clty_uid loc;
-            let map f id acc = f acc id decl.clsty_ty_decl.clty_uid in
+            let uid = decl.clsty_ty_decl.clty_uid in
+            let map_t f id acc = f acc id (Shape.str ~uid Shape.Map.empty) in
+            let map f id acc = f acc id uid in
             map Shape.Map.add_class_type decl.clsty_ty_id acc
-            |> map Shape.Map.add_type decl.clsty_obj_id
-            |> map Shape.Map.add_type decl.clsty_typesharp_id
+            |> map_t Shape.Map.add_type decl.clsty_obj_id
+            |> map_t Shape.Map.add_type decl.clsty_typesharp_id
           ) shape_map classes
         in
         Tstr_class_type
@@ -3005,7 +2987,7 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
       let simple_sg = Signature_names.simplify finalenv names sg in
       if !Clflags.print_types then begin
         Typecore.force_delayed_checks ();
-        let shape = Shape.local_reduce shape in
+        let shape = Shape.toplevel_local_reduce shape in
         Printtyp.wrap_printing_env ~error:false initial_env
           (fun () -> fprintf std_formatter "%a@."
               (Printtyp.printed_signature sourcefile) simple_sg
@@ -3035,7 +3017,7 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
           (* It is important to run these checks after the inclusion test above,
              so that value declarations which are not used internally but
              exported are not reported as being unused. *)
-          let shape = Shape.local_reduce shape in
+          let shape = Shape.toplevel_local_reduce shape in
           let annots = Cmt_format.Implementation str in
           Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename
             annots (Some sourcefile) initial_env None (Some shape);
@@ -3059,7 +3041,7 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
              the value being exported. We can still capture unused
              declarations like "let x = true;; let x = 1;;", because in this
              case, the inferred signature contains only the last declaration. *)
-          let shape = Shape.local_reduce shape in
+          let shape = Shape.toplevel_local_reduce shape in
           if not !Clflags.dont_write_files then begin
             let alerts = Builtin_attributes.alerts_of_str ast in
             let cmi =
diff --git a/upstream/ocaml_414/typing/typemod.mli b/upstream/ocaml_414/typing/typemod.mli
index 30ed1c7174..473e9b853f 100644
--- a/upstream/ocaml_414/typing/typemod.mli
+++ b/upstream/ocaml_414/typing/typemod.mli
@@ -76,6 +76,8 @@ module Sig_component_kind : sig
   type t =
     | Value
     | Type
+    | Constructor
+    | Label
     | Module
     | Module_type
     | Extension_constructor
diff --git a/upstream/ocaml_414/typing/untypeast.ml b/upstream/ocaml_414/typing/untypeast.ml
index 84af674ad2..5145f79c8a 100644
--- a/upstream/ocaml_414/typing/untypeast.ml
+++ b/upstream/ocaml_414/typing/untypeast.ml
@@ -298,7 +298,8 @@ let pattern : type k . _ -> k T.general_pattern -> _ = fun sub pat ->
   match pat with
       { pat_extra=[Tpat_unpack, loc, _attrs]; pat_desc = Tpat_any; _ } ->
         Ppat_unpack { txt = None; loc  }
-    | { pat_extra=[Tpat_unpack, _, _attrs]; pat_desc = Tpat_var (_,name); _ } ->
+    | { pat_extra=[Tpat_unpack, _, _attrs];
+        pat_desc = Tpat_var (_,name, _); _ } ->
         Ppat_unpack { name with txt = Some name.txt }
     | { pat_extra=[Tpat_type (_path, lid), _, _attrs]; _ } ->
         Ppat_type (map_loc sub lid)
@@ -308,7 +309,7 @@ let pattern : type k . _ -> k T.general_pattern -> _ = fun sub pat ->
     | _ ->
     match pat.pat_desc with
       Tpat_any -> Ppat_any
-    | Tpat_var (id, name) ->
+    | Tpat_var (id, name, _) ->
         begin
           match (Ident.name id).[0] with
             'A'..'Z' ->
@@ -321,11 +322,11 @@ let pattern : type k . _ -> k T.general_pattern -> _ = fun sub pat ->
        The compiler transforms (x:t) into (_ as x : t).
        This avoids transforming a warning 27 into a 26.
      *)
-    | Tpat_alias ({pat_desc = Tpat_any; pat_loc}, _id, name)
+    | Tpat_alias ({pat_desc = Tpat_any; pat_loc}, _id, name, _)
          when pat_loc = pat.pat_loc ->
        Ppat_var name
 
-    | Tpat_alias (pat, _id, name) ->
+    | Tpat_alias (pat, _id, name, _) ->
         Ppat_alias (sub.pat sub pat, name)
     | Tpat_constant cst -> Ppat_constant (constant cst)
     | Tpat_tuple list ->
@@ -782,7 +783,7 @@ let core_type sub ct =
 
 let class_structure sub cs =
   let rec remove_self = function
-    | { pat_desc = Tpat_alias (p, id, _s) }
+    | { pat_desc = Tpat_alias (p, id, _s, _) }
       when string_is_prefix "selfpat-" (Ident.name id) ->
         remove_self p
     | p -> p
@@ -812,7 +813,7 @@ let object_field sub {of_loc; of_desc; of_attributes;} =
   Of.mk ~loc ~attrs desc
 
 and is_self_pat = function
-  | { pat_desc = Tpat_alias(_pat, id, _) } ->
+  | { pat_desc = Tpat_alias(_pat, id, _, _) } ->
       string_is_prefix "self-" (Ident.name id)
   | _ -> false
 
diff --git a/upstream/ocaml_414/utils/clflags.ml b/upstream/ocaml_414/utils/clflags.ml
index 83bd357f15..9b776cfa99 100644
--- a/upstream/ocaml_414/utils/clflags.ml
+++ b/upstream/ocaml_414/utils/clflags.ml
@@ -68,6 +68,7 @@ and all_ppx = ref ([] : string list)        (* -ppx *)
 let absname = ref false                 (* -absname *)
 let annotations = ref false             (* -annot *)
 let binary_annotations = ref false      (* -bin-annot *)
+let store_usage_index = ref false       (* -store-usage-index *)
 and use_threads = ref false             (* -thread *)
 and noassert = ref false                (* -noassert *)
 and verbose = ref false                 (* -verbose *)
diff --git a/upstream/ocaml_414/utils/clflags.mli b/upstream/ocaml_414/utils/clflags.mli
index 8cab8f15ac..1ee8ffa344 100644
--- a/upstream/ocaml_414/utils/clflags.mli
+++ b/upstream/ocaml_414/utils/clflags.mli
@@ -98,6 +98,7 @@ val all_ppx : string list ref
 val absname : bool ref
 val annotations : bool ref
 val binary_annotations : bool ref
+val store_usage_index : bool ref
 val use_threads : bool ref
 val noassert : bool ref
 val verbose : bool ref

From 548e8cb41adaa43d83e9dd5610b83dede34a8b1b Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Wed, 27 Sep 2023 12:53:55 +0200
Subject: [PATCH 02/58] Update vendored compiler to 414+index. Locate is
 broken.

---
 src/analysis/context.ml                  |   4 +-
 src/analysis/destruct.ml                 |  15 +-
 src/analysis/locate.ml                   |   4 +-
 src/analysis/outline.ml                  |   2 +-
 src/ocaml/merlin_specific/browse_raw.ml  |   8 +-
 src/ocaml/merlin_specific/tast_helper.ml |   4 +-
 src/ocaml/typing/cmt_format.ml           | 324 ++++++++++++++++++++++-
 src/ocaml/typing/cmt_format.mli          |  20 +-
 src/ocaml/typing/env.ml                  |  22 +-
 src/ocaml/typing/env.mli                 |  13 +-
 src/ocaml/typing/includemod.ml           |  14 +
 src/ocaml/typing/parmatch.ml             |  37 +--
 src/ocaml/typing/patterns.ml             |  18 +-
 src/ocaml/typing/patterns.mli            |   4 +-
 src/ocaml/typing/printpat.ml             |   4 +-
 src/ocaml/typing/printtyped.ml           |   4 +-
 src/ocaml/typing/rec_check.ml            |   6 +-
 src/ocaml/typing/shape.ml                | 254 ++++++++++++------
 src/ocaml/typing/shape.mli               |  85 +++++-
 src/ocaml/typing/tast_iterator.ml        |   6 +-
 src/ocaml/typing/tast_mapper.ml          |   2 +-
 src/ocaml/typing/typeclass.ml            |   2 +-
 src/ocaml/typing/typecore.ml             |  52 ++--
 src/ocaml/typing/typecore.mli            |   1 +
 src/ocaml/typing/typedecl.ml             | 138 ++++++----
 src/ocaml/typing/typedecl.mli            |   8 +-
 src/ocaml/typing/typedtree.ml            |  44 ++-
 src/ocaml/typing/typedtree.mli           |  19 +-
 src/ocaml/typing/typemod.ml              | 137 +++++-----
 src/ocaml/typing/typemod.mli             |   2 +
 src/ocaml/typing/untypeast.ml            |  13 +-
 src/ocaml/utils/clflags.ml               |   1 +
 src/ocaml/utils/clflags.mli              |   1 +
 33 files changed, 923 insertions(+), 345 deletions(-)

diff --git a/src/analysis/context.ml b/src/analysis/context.ml
index 30806301c0..35abbb070c 100644
--- a/src/analysis/context.ml
+++ b/src/analysis/context.ml
@@ -78,9 +78,9 @@ let inspect_pattern (type a) ~cursor ~lid (p : a Typedtree.general_pattern) =
                   (Printtyped.pattern 0) p);
   match p.pat_desc with
   | Tpat_any when Longident.last lid = "_" -> None
-  | Tpat_var (_, str_loc) when (Longident.last lid) = str_loc.txt ->
+  | Tpat_var (_, str_loc, _) when (Longident.last lid) = str_loc.txt ->
     None
-  | Tpat_alias (_, _, str_loc)
+  | Tpat_alias (_, _, str_loc, _)
     when (Longident.last lid) = str_loc.txt ->
     (* Assumption: if [Browse.enclosing] stopped on this node and not on the
       subpattern, then it must mean that the cursor is on the alias. *)
diff --git a/src/analysis/destruct.ml b/src/analysis/destruct.ml
index e30f456384..568296743f 100644
--- a/src/analysis/destruct.ml
+++ b/src/analysis/destruct.ml
@@ -301,7 +301,7 @@ let rec destructible patt =
   let open Typedtree in
   match patt.pat_desc with
   | Tpat_any | Tpat_var _ -> true
-  | Tpat_alias (p, _, _)  -> destructible p
+  | Tpat_alias (p, _, _, _)  -> destructible p
   | _ -> false
 
 
@@ -335,8 +335,8 @@ let rec subst_patt initial ~by patt =
   | Tpat_any
   | Tpat_var _
   | Tpat_constant _ -> patt
-  | Tpat_alias (p,x,y) ->
-    { patt with pat_desc = Tpat_alias (f p, x, y) }
+  | Tpat_alias (p,x,y, uid) ->
+    { patt with pat_desc = Tpat_alias (f p, x, y, uid) }
   | Tpat_tuple lst ->
     { patt with pat_desc = Tpat_tuple (List.map lst ~f) }
   | Tpat_construct (lid, cd, lst, lco) ->
@@ -362,8 +362,8 @@ let rec rm_sub patt sub =
   | Tpat_any
   | Tpat_var _
   | Tpat_constant _ -> patt
-  | Tpat_alias (p,x,y) ->
-    { patt with pat_desc = Tpat_alias (f p, x, y)  }
+  | Tpat_alias (p,x,y,uid) ->
+    { patt with pat_desc = Tpat_alias (f p, x, y, uid)  }
   | Tpat_tuple lst ->
     { patt with pat_desc = Tpat_tuple (List.map lst ~f) }
   | Tpat_construct (lid, cd, lst, lco) ->
@@ -388,7 +388,8 @@ let rec qualify_constructors ~unmangling_tables f pat  =
   let qualify_constructors = qualify_constructors ~unmangling_tables in
   let pat_desc =
     match pat.pat_desc with
-    | Tpat_alias (p, id, loc) -> Tpat_alias (qualify_constructors f p, id, loc)
+    | Tpat_alias (p, id, loc, uid) ->
+      Tpat_alias (qualify_constructors f p, id, loc, uid)
     | Tpat_tuple ps -> Tpat_tuple (List.map ps ~f:(qualify_constructors f))
     | Tpat_record (labels, closed) ->
       let labels =
@@ -461,7 +462,7 @@ let find_branch patterns sub =
       | Tpat_var _
       | Tpat_constant _
       | Tpat_variant (_, None, _) -> false
-      | Tpat_alias (p,_,_)
+      | Tpat_alias (p,_,_,_)
       | Tpat_variant (_, Some p, _)
       | Tpat_lazy p ->
         is_sub_patt p ~sub
diff --git a/src/analysis/locate.ml b/src/analysis/locate.ml
index 44236c0df5..c6f5e71c77 100644
--- a/src/analysis/locate.ml
+++ b/src/analysis/locate.ml
@@ -864,8 +864,8 @@ let find_doc_attributes_in_typedtree ~config ~comp_unit uid =
           let rec aux pat =
             let open Typedtree in
             match pat.pat_desc with
-            | Tpat_var (id, _) -> f id
-            | Tpat_alias (pat, _, _)
+            | Tpat_var (id, _, _) -> f id
+            | Tpat_alias (pat, _, _, _)
             | Tpat_variant (_, Some pat, _)
             | Tpat_lazy pat
             | Tpat_or (pat, _, _) ->
diff --git a/src/analysis/outline.ml b/src/analysis/outline.ml
index ed179236ca..54a64a0e71 100644
--- a/src/analysis/outline.ml
+++ b/src/analysis/outline.ml
@@ -36,7 +36,7 @@ open Browse_raw
 open Browse_tree
 
 let id_of_patt = function
-  | { pat_desc = Tpat_var (id, _) ; _ } -> Some id
+  | { pat_desc = Tpat_var (id, _, _) ; _ } -> Some id
   | _ -> None
 
 let mk ?(children=[]) ~location ~deprecated outline_kind outline_type id =
diff --git a/src/ocaml/merlin_specific/browse_raw.ml b/src/ocaml/merlin_specific/browse_raw.ml
index 88caa4bed6..49ea56c4ec 100644
--- a/src/ocaml/merlin_specific/browse_raw.ml
+++ b/src/ocaml/merlin_specific/browse_raw.ml
@@ -299,7 +299,7 @@ let of_pat_record_field obj loc lbl =
 let of_pattern_desc (type k) (desc : k pattern_desc) =
   match desc with
   | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_,None,_) -> id_fold
-  | Tpat_alias (p,_,_) | Tpat_variant (_,Some p,_) | Tpat_lazy p
+  | Tpat_alias (p,_,_,_) | Tpat_variant (_,Some p,_) | Tpat_lazy p
   | Tpat_exception p -> of_pattern p
   | Tpat_value p -> of_pattern (p :> value general_pattern)
   | Tpat_tuple ps | Tpat_construct (_,_,ps,None) | Tpat_array ps ->
@@ -368,7 +368,7 @@ let of_expression_desc loc = function
   | Texp_letmodule (mb_id, mb_name, mb_presence, mb_expr, e) ->
     let mb =
       {mb_id;mb_name;mb_expr;mb_loc=Location.none;mb_attributes=[]
-      ; mb_presence }
+      ; mb_presence; mb_uid=Shape.Uid.internal_not_actually_unique }
     in
     app (Module_binding mb) ** of_expression e
   | Texp_letexception (ec,e) ->
@@ -778,9 +778,9 @@ let pattern_paths (type k) { Typedtree. pat_desc; pat_extra; _ } =
     match (pat_desc : k pattern_desc) with
     | Tpat_construct (lid_loc,{Types. cstr_name; cstr_res; _},_,_) ->
       fake_path lid_loc cstr_res cstr_name
-    | Tpat_var (id, {Location. loc; txt}) ->
+    | Tpat_var (id, {Location. loc; txt}, _) ->
       [mkloc (Path.Pident id) loc, Some (Longident.Lident txt)]
-    | Tpat_alias (_,id,loc) ->
+    | Tpat_alias (_,id,loc, _) ->
       [reloc (Path.Pident id) loc, Some (Longident.Lident loc.txt)]
     | _ -> []
   in
diff --git a/src/ocaml/merlin_specific/tast_helper.ml b/src/ocaml/merlin_specific/tast_helper.ml
index 1664fa1586..2ae85d8e58 100644
--- a/src/ocaml/merlin_specific/tast_helper.ml
+++ b/src/ocaml/merlin_specific/tast_helper.ml
@@ -14,7 +14,7 @@ module Pat = struct
       | None -> str.Asttypes.loc
       | Some loc -> loc
     in
-    let pat_desc = Tpat_var (Ident.create_local str.Asttypes.txt, str) in
+    let pat_desc = Tpat_var (Ident.create_local str.Asttypes.txt, str, Uid.internal_not_actually_unique) in
     { pat_desc; pat_loc; pat_extra; pat_attributes; pat_type; pat_env }
 
   let record ?(loc=Location.none) pat_env pat_type lst closed_flag =
@@ -25,7 +25,7 @@ module Pat = struct
     let pat_desc = Tpat_tuple lst in
     { pat_desc; pat_loc = loc; pat_extra; pat_attributes; pat_type; pat_env }
 
-  let construct ?(loc=Location.none) 
+  let construct ?(loc=Location.none)
     pat_env pat_type lid cstr_desc args locs_coretype =
     let pat_desc = Tpat_construct (lid, cstr_desc, args, locs_coretype) in
     { pat_desc; pat_loc = loc; pat_extra; pat_attributes; pat_type; pat_env }
diff --git a/src/ocaml/typing/cmt_format.ml b/src/ocaml/typing/cmt_format.ml
index 49a629879f..c7e5c00468 100644
--- a/src/ocaml/typing/cmt_format.ml
+++ b/src/ocaml/typing/cmt_format.ml
@@ -61,6 +61,21 @@ and binary_part =
   | Partial_signature_item of signature_item
   | Partial_module_type of module_type
 
+type item_declaration =
+  | Class_declaration of class_declaration
+  | Class_description of class_description
+  | Class_type_declaration of class_type_declaration
+  | Constructor_declaration of constructor_declaration
+  | Extension_constructor of extension_constructor
+  | Label_declaration of label_declaration
+  | Module_binding of module_binding
+  | Module_declaration of module_declaration
+  | Module_substitution of module_substitution
+  | Module_type_declaration of module_type_declaration
+  | Type_declaration of type_declaration
+  | Value_binding of value_binding
+  | Value_description of value_description
+
 type cmt_infos = {
   cmt_modname : string;
   cmt_annots : binary_annots;
@@ -76,21 +91,123 @@ type cmt_infos = {
   cmt_imports : (string * Digest.t option) list;
   cmt_interface_digest : Digest.t option;
   cmt_use_summaries : bool;
-  cmt_uid_to_loc : Location.t Shape.Uid.Tbl.t;
+  cmt_uid_to_decl : item_declaration Shape.Uid.Tbl.t;
   cmt_impl_shape : Shape.t option; (* None for mli *)
+  cmt_ident_occurrences :
+    (Longident.t Location.loc * Shape.reduction_result) list
 }
 
 type error =
     Not_a_typedtree of string
 
+let iter_on_parts (it : Tast_iterator.iterator) = function
+  | Partial_structure s -> it.structure it s
+  | Partial_structure_item s -> it.structure_item it s
+  | Partial_expression e -> it.expr it e
+  | Partial_pattern (_category, p) -> it.pat it p
+  | Partial_class_expr ce -> it.class_expr it ce
+  | Partial_signature s -> it.signature it s
+  | Partial_signature_item s -> it.signature_item it s
+  | Partial_module_type s -> it.module_type it s
+
+let iter_on_annots (it : Tast_iterator.iterator) = function
+  | Implementation s -> it.structure it s
+  | Interface s -> it.signature it s
+  | Packed _ -> ()
+  | Partial_implementation array -> Array.iter (iter_on_parts it) array
+  | Partial_interface array -> Array.iter (iter_on_parts it) array
+
+module Local_reduce = Shape.Make_reduce(struct
+    type env = Env.t
+    let fuel = 10
+
+    let read_unit_shape ~unit_name:_ = None
+
+    let find_shape env id =
+      let namespace = Shape.Sig_component_kind.Module in
+      Env.shape_of_path ~namespace env (Pident id)
+  end)
+
+let iter_on_declarations ~(f: Shape.Uid.t -> item_declaration -> unit) =
+  let f_lbl_decls ldecls =
+    List.iter ~f:(fun ({ ld_uid; _ } as ld) ->
+      f ld_uid (Label_declaration ld)) ldecls
+  in
+  Tast_iterator.{ default_iterator with
+
+  value_bindings = (fun sub ((_, vbs) as bindings) ->
+    let bound_idents = let_filter_bound vbs in
+    List.iter ~f:(fun (vb, uid) -> f uid (Value_binding vb)) bound_idents;
+    default_iterator.value_bindings sub bindings);
+
+  module_binding = (fun sub mb ->
+    f mb.mb_uid (Module_binding mb);
+    default_iterator.module_binding sub mb);
+
+  module_declaration = (fun sub md ->
+    f md.md_uid (Module_declaration md);
+    default_iterator.module_declaration sub md);
+
+  module_type_declaration = (fun sub mtd ->
+    f mtd.mtd_uid (Module_type_declaration mtd);
+    default_iterator.module_type_declaration sub mtd);
+
+  module_substitution = (fun sub ms ->
+    f ms.ms_uid (Module_substitution ms);
+    default_iterator.module_substitution sub ms);
+
+  value_description = (fun sub vd ->
+    f vd.val_val.val_uid (Value_description vd);
+    default_iterator.value_description sub vd);
+
+  type_declaration = (fun sub td ->
+    (* compiler-generated "row_names" share the uid of their corresponding
+       class declaration, so we ignore them to prevent duplication *)
+    if not (Btype.is_row_name (Ident.name td.typ_id)) then begin
+      f td.typ_type.type_uid (Type_declaration td);
+      (* We also register records labels and constructors *)
+      let f_lbl_decls ldecls =
+        List.iter ~f:(fun ({ ld_uid; _ } as ld) ->
+          f ld_uid (Label_declaration ld)) ldecls
+      in
+      match td.typ_kind with
+      | Ttype_variant constrs ->
+          List.iter ~f:(fun ({ cd_uid; cd_args; _ } as cd) ->
+            f cd_uid (Constructor_declaration cd);
+            match cd_args with
+            | Cstr_record ldecls -> f_lbl_decls ldecls
+            | Cstr_tuple _ -> ()) constrs
+      | Ttype_record labels -> f_lbl_decls labels
+      | _ -> ()
+    end;
+    default_iterator.type_declaration sub td);
+
+  extension_constructor = (fun sub ec ->
+    f ec.ext_type.ext_uid (Extension_constructor ec);
+    begin match ec.ext_kind with
+    | Text_decl (_, Cstr_record lbls,_) -> f_lbl_decls lbls
+    | _ -> () end;
+    default_iterator.extension_constructor sub ec);
+
+  class_declaration = (fun sub cd ->
+    f cd.ci_decl.cty_uid (Class_declaration cd);
+    default_iterator.class_declaration sub cd);
+
+  class_type_declaration = (fun sub ctd ->
+    f ctd.ci_decl.cty_uid (Class_type_declaration ctd);
+    default_iterator.class_type_declaration sub ctd);
+
+  class_description =(fun sub cd ->
+    f cd.ci_decl.cty_uid (Class_description cd);
+    default_iterator.class_description sub cd);
+}
+
 let need_to_clear_env =
   try ignore (Sys.getenv "OCAML_BINANNOT_WITHENV"); false
   with Not_found -> true
 
 let keep_only_summary = Env.keep_only_summary
 
-open Tast_mapper
-
 let cenv =
   {Tast_mapper.default with env = fun _sub env -> keep_only_summary env}
 
@@ -119,6 +236,194 @@ let clear_env binary_annots =
 
   else binary_annots
 
+let iter_on_usages ~index =
+  let f ~namespace env path lid =
+    let not_ghost { Location.loc = { loc_ghost; _ }; _ } = not loc_ghost in
+    if not_ghost lid then
+      match Env.shape_of_path ~namespace env path with
+      | exception Not_found -> ()
+      | path_shape ->
+        let result = Local_reduce.reduce_for_uid env path_shape in
+        index := (lid, result) :: !index
+  in
+  let path_in_type typ name =
+    match Types.get_desc typ with
+    | Tconstr (type_path, _, _) ->
+      Some (Path.Pdot (type_path,  name))
+    | _ -> None
+  in
+  let add_constructor_description env lid =
+    function
+    | { Types.cstr_tag = Cstr_extension (path, _); _ } ->
+        f ~namespace:Extension_constructor env path lid
+    | { Types.cstr_uid = Predef _; _ } -> ()
+    | { Types.cstr_res; cstr_name; _ } ->
+        let path = path_in_type cstr_res cstr_name in
+        Option.iter ~f:(fun path -> f ~namespace:Constructor env path lid) path
+  in
+  let add_label env lid { Types.lbl_name; lbl_res; _ } =
+    let path = path_in_type lbl_res lbl_name in
+    Option.iter ~f:(fun path -> f ~namespace:Label env path lid) path
+  in
+  let with_constraint ~env (_path, _lid, with_constraint) =
+    match with_constraint with
+    | Twith_module (path', lid') | Twith_modsubst (path', lid') ->
+        f ~namespace:Module env path' lid'
+    | _ -> ()
+  in
+  Tast_iterator.{ default_iterator with
+
+  expr = (fun sub ({ exp_desc; exp_env; _ } as e) ->
+      (match exp_desc with
+      | Texp_ident (path, lid, _) ->
+          f ~namespace:Value exp_env path lid
+      | Texp_construct (lid, constr_desc, _) ->
+          add_constructor_description exp_env lid constr_desc
+      | Texp_field (_, lid, label_desc)
+      | Texp_setfield (_, lid, label_desc, _) ->
+          add_label exp_env lid label_desc
+      | Texp_new (path, lid, _) ->
+          f ~namespace:Class exp_env path lid
+      | Texp_record { fields; _ } ->
+        Array.iter (fun (label_descr, record_label_definition) ->
+          match record_label_definition with
+          | Overridden (
+              { Location.txt; loc},
+              {exp_loc; _})
+              when not exp_loc.loc_ghost
+                && loc.loc_start = exp_loc.loc_start
+                && loc.loc_end = exp_loc.loc_end ->
+            (* In the presence of punning we want to index the label
+                even if it is ghosted *)
+            let lid = { Location.txt; loc = {loc with loc_ghost = false} } in
+            add_label exp_env lid label_descr
+          | Overridden (lid, _) -> add_label exp_env lid label_descr
+          | Kept _ -> ()) fields
+      | _ -> ());
+      default_iterator.expr sub e);
+
+  typ =
+    (fun sub ({ ctyp_desc; ctyp_env; _ } as ct) ->
+      (match ctyp_desc with
+      | Ttyp_constr (path, lid, _ctyps) ->
+          f ~namespace:Type ctyp_env path lid
+      | Ttyp_package {pack_path; pack_txt} ->
+          f ~namespace:Module_type ctyp_env pack_path pack_txt
+      | _ -> ());
+      default_iterator.typ sub ct);
+
+  pat =
+    (fun (type a) sub
+      ({ pat_desc; pat_extra; pat_env; _ } as pat : a general_pattern) ->
+      (match pat_desc with
+      | Tpat_construct (lid, constr_desc, _, _) ->
+          add_constructor_description pat_env lid constr_desc
+      | Tpat_record (fields, _) ->
+        List.iter ~f:(fun (lid, label_descr, pat) ->
+          let lid =
+            let open Location in
+            (* In the presence of punning we want to index the label
+               even if it is ghosted *)
+            if (not pat.pat_loc.loc_ghost
+              && lid.loc.loc_start = pat.pat_loc.loc_start
+              && lid.loc.loc_end = pat.pat_loc.loc_end)
+            then {lid with loc = {lid.loc with loc_ghost = false}}
+            else lid
+          in
+          add_label pat_env lid label_descr)
+        fields
+      | _ -> ());
+      List.iter ~f:(fun (pat_extra, _, _) ->
+        match pat_extra with
+        | Tpat_open (path, lid, _) ->
+            f ~namespace:Module pat_env path lid
+        | Tpat_type (path, lid) ->
+            f ~namespace:Type pat_env path lid
+        | _ -> ())
+        pat_extra;
+      default_iterator.pat sub pat);
+
+  binding_op = (fun sub ({bop_op_path; bop_op_name; bop_exp; _} as bop) ->
+    let lid = { bop_op_name with txt = Longident.Lident bop_op_name.txt } in
+    f ~namespace:Value bop_exp.exp_env bop_op_path lid;
+    default_iterator.binding_op sub bop);
+
+  module_expr =
+    (fun sub ({ mod_desc; mod_env; _ } as me) ->
+      (match mod_desc with
+      | Tmod_ident (path, lid) -> f ~namespace:Module mod_env path lid
+      | _ -> ());
+      default_iterator.module_expr sub me);
+
+  open_description =
+    (fun sub ({ open_expr = (path, lid); open_env; _ } as od)  ->
+      f ~namespace:Module open_env path lid;
+      default_iterator.open_description sub od);
+
+  module_type =
+    (fun sub ({ mty_desc; mty_env; _ } as mty)  ->
+      (match mty_desc with
+      | Tmty_ident (path, lid) ->
+          f ~namespace:Module_type mty_env path lid
+      | Tmty_with (_mty, l) ->
+          List.iter ~f:(with_constraint ~env:mty_env) l
+      | Tmty_alias (path, lid) ->
+          f ~namespace:Module mty_env path lid
+      | _ -> ());
+      default_iterator.module_type sub mty);
+
+  class_expr =
+    (fun sub ({ cl_desc; cl_env; _} as ce) ->
+      (match cl_desc with
+      | Tcl_ident (path, lid, _) -> f ~namespace:Class cl_env path lid
+      | _ -> ());
+      default_iterator.class_expr sub ce);
+
+  class_type =
+    (fun sub ({ cltyp_desc; cltyp_env; _} as ct) ->
+      (match cltyp_desc with
+      | Tcty_constr (path, lid, _) -> f ~namespace:Class_type cltyp_env path lid
+      | _ -> ());
+      default_iterator.class_type sub ct);
+
+  signature_item =
+    (fun sub ({ sig_desc; sig_env; _ } as sig_item) ->
+      (match sig_desc with
+      | Tsig_exception {
+          tyexn_constructor = { ext_kind = Text_rebind (path, lid)}} ->
+          f ~namespace:Extension_constructor sig_env path lid
+      | Tsig_modsubst { ms_manifest; ms_txt } ->
+          f ~namespace:Module sig_env ms_manifest ms_txt
+      | Tsig_typext { tyext_path; tyext_txt } ->
+          f ~namespace:Type sig_env tyext_path tyext_txt
+      | _ -> ());
+      default_iterator.signature_item sub sig_item);
+
+  structure_item =
+    (fun sub ({ str_desc; str_env; _ } as str_item) ->
+      (match str_desc with
+      | Tstr_exception {
+          tyexn_constructor = { ext_kind = Text_rebind (path, lid)}} ->
+          f ~namespace:Extension_constructor str_env path lid
+      | Tstr_typext { tyext_path; tyext_txt } ->
+          f ~namespace:Type str_env tyext_path tyext_txt
+      | _ -> ());
+      default_iterator.structure_item sub str_item)
+}
+
+let index_declarations binary_annots =
+  let index : item_declaration Types.Uid.Tbl.t = Types.Uid.Tbl.create 16 in
+  let f uid fragment = Types.Uid.Tbl.add index uid fragment in
+  iter_on_annots (iter_on_declarations ~f) binary_annots;
+  index
+
+let index_usages binary_annots =
+  let index : (Longident.t Location.loc * Shape.reduction_result) list ref =
+    ref []
+  in
+  iter_on_annots (iter_on_usages ~index) binary_annots;
+  !index
+
 exception Error of error
 
 let input_cmt ic = (input_value ic : cmt_infos)
@@ -192,10 +497,18 @@ let save_cmt filename modname binary_annots sourcefile initial_env cmi shape =
            | None -> None
            | Some cmi -> Some (output_cmi temp_file_name oc cmi)
          in
+         let cmt_ident_occurrences =
+          if !Clflags.store_usage_index then
+            index_usages binary_annots
+          else
+            []
+         in
+         let cmt_annots = clear_env binary_annots in
+         let cmt_uid_to_decl = index_declarations cmt_annots in
          let source_digest = Option.map ~f:Digest.file sourcefile in
          let cmt = {
            cmt_modname = modname;
-           cmt_annots = clear_env binary_annots;
+           cmt_annots;
            cmt_value_dependencies = !value_deps;
            cmt_comments = [];
            cmt_args = Sys.argv;
@@ -208,8 +521,9 @@ let save_cmt filename modname binary_annots sourcefile initial_env cmi shape =
            cmt_imports = List.sort ~cmp:compare (Env.imports ());
            cmt_interface_digest = this_crc;
            cmt_use_summaries = need_to_clear_env;
-           cmt_uid_to_loc = Env.get_uid_to_loc_tbl ();
+           cmt_uid_to_decl;
            cmt_impl_shape = shape;
+           cmt_ident_occurrences;
          } in
          output_cmt oc cmt)
   end;
diff --git a/src/ocaml/typing/cmt_format.mli b/src/ocaml/typing/cmt_format.mli
index 43e09f1236..653dfcc75c 100644
--- a/src/ocaml/typing/cmt_format.mli
+++ b/src/ocaml/typing/cmt_format.mli
@@ -50,6 +50,21 @@ and binary_part =
   | Partial_signature_item of signature_item
   | Partial_module_type of module_type
 
+type item_declaration =
+  | Class_declaration of class_declaration
+  | Class_description of class_description
+  | Class_type_declaration of class_type_declaration
+  | Constructor_declaration of constructor_declaration
+  | Extension_constructor of extension_constructor
+  | Label_declaration of label_declaration
+  | Module_binding of module_binding
+  | Module_declaration of module_declaration
+  | Module_substitution of module_substitution
+  | Module_type_declaration of module_type_declaration
+  | Type_declaration of type_declaration
+  | Value_binding of value_binding
+  | Value_description of value_description
+
 type cmt_infos = {
   cmt_modname : modname;
   cmt_annots : binary_annots;
@@ -65,8 +80,10 @@ type cmt_infos = {
   cmt_imports : crcs;
   cmt_interface_digest : Digest.t option;
   cmt_use_summaries : bool;
-  cmt_uid_to_loc : Location.t Shape.Uid.Tbl.t;
+  cmt_uid_to_decl : item_declaration Shape.Uid.Tbl.t;
   cmt_impl_shape : Shape.t option; (* None for mli *)
+  cmt_ident_occurrences :
+    (Longident.t Location.loc * Shape.reduction_result) list
 }
 
 type error =
@@ -112,7 +129,6 @@ val set_saved_types : binary_part list -> unit
 val record_value_dependency:
   Types.value_description -> Types.value_description -> unit
 
-
 (*
 
   val is_magic_number : string -> bool
diff --git a/src/ocaml/typing/env.ml b/src/ocaml/typing/env.ml
index 823da2ad43..98e8f962ac 100644
--- a/src/ocaml/typing/env.ml
+++ b/src/ocaml/typing/env.ml
@@ -40,13 +40,6 @@ let value_declarations  : unit usage_tbl ref = s_table Types.Uid.Tbl.create 16
 let type_declarations   : unit usage_tbl ref = s_table Types.Uid.Tbl.create 16
 let module_declarations : unit usage_tbl ref = s_table Types.Uid.Tbl.create 16
 
-let uid_to_loc : Location.t Types.Uid.Tbl.t ref =
-  s_table Types.Uid.Tbl.create 16
-
-let register_uid uid loc = Types.Uid.Tbl.add !uid_to_loc uid loc
-
-let get_uid_to_loc_tbl () = !uid_to_loc
-
 type constructor_usage = Positive | Pattern | Exported_private | Exported
 type constructor_usages =
   {
@@ -995,7 +988,6 @@ let reset_declaration_caches () =
   Types.Uid.Tbl.clear !module_declarations;
   Types.Uid.Tbl.clear !used_constructors;
   Types.Uid.Tbl.clear !used_labels;
-  Types.Uid.Tbl.clear !uid_to_loc;
   ()
 
 let reset_cache () =
@@ -1312,6 +1304,10 @@ let find_shape env (ns : Shape.Sig_component_kind.t) id =
   match ns with
   | Type ->
       (IdTbl.find_same id env.types).tda_shape
+  | Constructor ->
+      Shape.leaf ((TycompTbl.find_same id env.constrs).cda_description.cstr_uid)
+  | Label ->
+      Shape.leaf ((TycompTbl.find_same id env.labels).lbl_uid)
   | Extension_constructor ->
       (TycompTbl.find_same id env.constrs).cda_shape
   | Value ->
@@ -2453,8 +2449,6 @@ let enter_signature_and_shape ~scope ~parent_shape mod_shape sg env =
   enter_signature_and_shape ~scope ~parent_shape (Some mod_shape) sg env
 
 let add_value = add_value ?shape:None
-let add_type = add_type ?shape:None
-let add_extension = add_extension ?shape:None
 let add_class = add_class ?shape:None
 let add_cltype = add_cltype ?shape:None
 let add_modtype = add_modtype ?shape:None
@@ -2709,11 +2703,11 @@ let (initial_safe_string, initial_unsafe_string) =
     (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_long_path ~check ?shape id info env =
+  add_type ~check ?shape ~predef:false ~long_path:true id info env
 
-let add_type ~check id info env =
-  add_type ~check ~predef:false ~long_path:false id info env
+let add_type ~check ?shape id info env =
+  add_type ~check ?shape ~predef:false ~long_path:false id info env
 
 (* Tracking usage *)
 
diff --git a/src/ocaml/typing/env.mli b/src/ocaml/typing/env.mli
index 03ae201cd7..3f2acb48c0 100644
--- a/src/ocaml/typing/env.mli
+++ b/src/ocaml/typing/env.mli
@@ -18,10 +18,6 @@
 open Types
 open Misc
 
-val register_uid : Uid.t -> Location.t -> unit
-
-val get_uid_to_loc_tbl : unit -> Location.t Types.Uid.Tbl.t
-
 type value_unbound_reason =
   | Val_unbound_instance_variable
   | Val_unbound_self
@@ -284,10 +280,13 @@ 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_type:
+  check:bool -> ?shape:Shape.t -> Ident.t -> type_declaration -> t -> t
+val add_type_long_path: check:bool -> ?shape:Shape.t -> Ident.t ->
+  type_declaration -> t -> t
 val add_extension:
-  check:bool -> rebind:bool -> Ident.t -> extension_constructor -> t -> t
+  check:bool -> ?shape:Shape.t -> rebind:bool -> Ident.t ->
+  extension_constructor -> t -> t
 val add_module: ?arg:bool -> ?shape:Shape.t ->
   Ident.t -> module_presence -> module_type -> t -> t
 val add_module_lazy: update_summary:bool ->
diff --git a/src/ocaml/typing/includemod.ml b/src/ocaml/typing/includemod.ml
index 27491f609f..0a52dfc7e5 100644
--- a/src/ocaml/typing/includemod.ml
+++ b/src/ocaml/typing/includemod.ml
@@ -741,7 +741,21 @@ and signature_components  ~in_eq ~loc old_env ~mark env subst
               type_declarations ~loc ~old_env env ~mark subst id1 tydec1 tydec2
             in
             let item = mark_error_as_unrecoverable item in
+            (* Right now we don't filter hidden constructors / labels from the
+            shape. *)
             let shape_map = Shape.Map.add_type_proj shape_map id1 orig_shape in
+            let shape_map =
+              match tydec1.type_kind with
+              | Type_variant (cstrs, _) ->
+                  List.fold_left (fun shape_map { cd_id; _ } ->
+                    Shape.Map.add_type_proj shape_map cd_id orig_shape)
+                    shape_map cstrs
+              | Type_record (labels, _) ->
+                  List.fold_left (fun shape_map { ld_id; _ } ->
+                    Shape.Map.add_label_proj shape_map ld_id orig_shape)
+                    shape_map labels
+              | _ -> shape_map
+            in
             id1, item, shape_map, false
         | Sig_typext(id1, ext1, _, _), Sig_typext(_id2, ext2, _, _) ->
             let item =
diff --git a/src/ocaml/typing/parmatch.ml b/src/ocaml/typing/parmatch.ml
index e8ca641410..67ba445454 100644
--- a/src/ocaml/typing/parmatch.ml
+++ b/src/ocaml/typing/parmatch.ml
@@ -37,7 +37,8 @@ let omega_list = Patterns.omega_list
 
 let extra_pat =
   make_pat
-    (Tpat_var (Ident.create_local "+", mknoloc "+"))
+    (Tpat_var (Ident.create_local "+", mknoloc "+",
+      Uid.internal_not_actually_unique))
     Ctype.none Env.empty
 
 
@@ -283,8 +284,8 @@ module Compat
   | ((Tpat_any|Tpat_var _),_)
   | (_,(Tpat_any|Tpat_var _)) -> true
 (* Structural induction *)
-  | Tpat_alias (p,_,_),_      -> compat p q
-  | _,Tpat_alias (q,_,_)      -> compat p q
+  | Tpat_alias (p,_,_,_),_      -> compat p q
+  | _,Tpat_alias (q,_,_,_)      -> compat p q
   | Tpat_or (p1,p2,_),_ ->
       (compat p1 q || compat p2 q)
   | _,Tpat_or (q1,q2,_) ->
@@ -921,7 +922,8 @@ let build_other ext env =
           (* let c = {c with cstr_name = "*extension*"} in *) (* PR#7330 *)
           make_pat
             (Tpat_var (Ident.create_local "*extension*",
-                       {txt="*extension*"; loc = d.pat_loc}))
+                       {txt="*extension*"; loc = d.pat_loc},
+                       Uid.internal_not_actually_unique))
             Ctype.none Env.empty
       | Construct _ ->
           begin match ext with
@@ -1051,7 +1053,7 @@ let build_other ext env =
 let rec has_instance p = match p.pat_desc with
   | Tpat_variant (l,_,r) when is_absent l r -> false
   | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_,None,_) -> true
-  | Tpat_alias (p,_,_) | Tpat_variant (_,Some p,_) -> has_instance p
+  | Tpat_alias (p,_,_,_) | Tpat_variant (_,Some p,_) -> has_instance p
   | Tpat_or (p1,p2,_) -> has_instance p1 || has_instance p2
   | Tpat_construct (_,_,ps,_) | Tpat_tuple ps | Tpat_array ps ->
       has_instances ps
@@ -1505,7 +1507,7 @@ let is_var_column rs =
 (* Standard or-args for left-to-right matching *)
 let rec or_args p = match p.pat_desc with
 | Tpat_or (p1,p2,_) -> p1,p2
-| Tpat_alias (p,_,_)  -> or_args p
+| Tpat_alias (p,_,_,_)  -> or_args p
 | _                 -> assert false
 
 (* Just remove current column *)
@@ -1685,8 +1687,8 @@ and every_both pss qs q1 q2 =
 let rec le_pat p q =
   match (p.pat_desc, q.pat_desc) with
   | (Tpat_var _|Tpat_any),_ -> true
-  | Tpat_alias(p,_,_), _ -> le_pat p q
-  | _, Tpat_alias(q,_,_) -> le_pat p q
+  | Tpat_alias(p,_,_,_), _ -> le_pat p q
+  | _, Tpat_alias(q,_,_,_) -> le_pat p q
   | Tpat_constant(c1), Tpat_constant(c2) -> const_compare c1 c2 = 0
   | Tpat_construct(_,c1,ps,_), Tpat_construct(_,c2,qs,_) ->
       Types.equal_tag c1.cstr_tag c2.cstr_tag && le_pats ps qs
@@ -1725,8 +1727,8 @@ let get_mins le ps =
 *)
 
 let rec lub p q = match p.pat_desc,q.pat_desc with
-| Tpat_alias (p,_,_),_      -> lub p q
-| _,Tpat_alias (q,_,_)      -> lub p q
+| Tpat_alias (p,_,_,_),_      -> lub p q
+| _,Tpat_alias (q,_,_,_)      -> lub p q
 | (Tpat_any|Tpat_var _),_ -> q
 | _,(Tpat_any|Tpat_var _) -> p
 | Tpat_or (p1,p2,_),_     -> orlub p1 p2 q
@@ -1861,14 +1863,14 @@ module Conv = struct
       match pat.pat_desc with
         Tpat_or (pa,pb,_) ->
           mkpat (Ppat_or (loop pa, loop pb))
-      | Tpat_var (_, ({txt="*extension*"} as nm)) -> (* PR#7330 *)
+      | Tpat_var (_, ({txt="*extension*"} as nm), _) -> (* PR#7330 *)
           mkpat (Ppat_var nm)
       | Tpat_any
       | Tpat_var _ ->
           mkpat Ppat_any
       | Tpat_constant c ->
           mkpat (Ppat_constant (Untypeast.constant c))
-      | Tpat_alias (p,_,_) -> loop p
+      | Tpat_alias (p,_,_,_) -> loop p
       | Tpat_tuple lst ->
           mkpat (Ppat_tuple (List.map loop lst))
       | Tpat_construct (cstr_lid, cstr, lst, _) ->
@@ -1909,7 +1911,7 @@ end
 let contains_extension pat =
   exists_pattern
     (function
-     | {pat_desc=Tpat_var (_, {txt="*extension*"})} -> true
+     | {pat_desc=Tpat_var (_, {txt="*extension*"}, _)} -> true
      | _ -> false)
     pat
 
@@ -2021,7 +2023,8 @@ let rec collect_paths_from_pat r p = match p.pat_desc with
     List.fold_left
       (fun r (_, _, p) -> collect_paths_from_pat r p)
       r lps
-| Tpat_variant (_, Some p, _) | Tpat_alias (p,_,_) -> collect_paths_from_pat r p
+| Tpat_variant (_, Some p, _) | Tpat_alias (p,_,_,_) ->
+    collect_paths_from_pat r p
 | Tpat_or (p1,p2,_) ->
     collect_paths_from_pat (collect_paths_from_pat r p1) p2
 | Tpat_lazy p
@@ -2155,7 +2158,7 @@ let inactive ~partial pat =
           end
         | Tpat_tuple ps | Tpat_construct (_, _, ps, _) ->
             List.for_all (fun p -> loop p) ps
-        | Tpat_alias (p,_,_) | Tpat_variant (_, Some p, _) ->
+        | Tpat_alias (p,_,_,_) | Tpat_variant (_, Some p, _) ->
             loop p
         | Tpat_record (ldps,_) ->
             List.for_all
@@ -2274,9 +2277,9 @@ type amb_row = { row : pattern list ; varsets : Ident.Set.t list; }
 let simplify_head_amb_pat head_bound_variables varsets ~add_column p ps k =
   let rec simpl head_bound_variables varsets p ps k =
     match (Patterns.General.view p).pat_desc with
-    | `Alias (p,x,_) ->
+    | `Alias (p,x,_,_) ->
       simpl (Ident.Set.add x head_bound_variables) varsets p ps k
-    | `Var (x, _) ->
+    | `Var (x,_,_) ->
       simpl (Ident.Set.add x head_bound_variables) varsets Patterns.omega ps k
     | `Or (p1,p2,_) ->
       simpl head_bound_variables varsets p1 ps
diff --git a/src/ocaml/typing/patterns.ml b/src/ocaml/typing/patterns.ml
index 55f9d4ff43..456f8dff33 100644
--- a/src/ocaml/typing/patterns.ml
+++ b/src/ocaml/typing/patterns.ml
@@ -79,18 +79,18 @@ end
 module General = struct
   type view = [
     | Half_simple.view
-    | `Var of Ident.t * string loc
-    | `Alias of pattern * Ident.t * string loc
+    | `Var of Ident.t * string loc * Uid.t
+    | `Alias of pattern * Ident.t * string loc * Uid.t
   ]
   type pattern = view pattern_data
 
   let view_desc = function
     | Tpat_any ->
        `Any
-    | Tpat_var (id, str) ->
-       `Var (id, str)
-    | Tpat_alias (p, id, str) ->
-       `Alias (p, id, str)
+    | Tpat_var (id, str, uid) ->
+       `Var (id, str, uid)
+    | Tpat_alias (p, id, str, uid) ->
+       `Alias (p, id, str, uid)
     | Tpat_constant cst ->
        `Constant cst
     | Tpat_tuple ps ->
@@ -110,8 +110,8 @@ module General = struct
 
   let erase_desc = function
     | `Any -> Tpat_any
-    | `Var (id, str) -> Tpat_var (id, str)
-    | `Alias (p, id, str) -> Tpat_alias (p, id, str)
+    | `Var (id, str, uid) -> Tpat_var (id, str, uid)
+    | `Alias (p, id, str, uid) -> Tpat_alias (p, id, str, uid)
     | `Constant cst -> Tpat_constant cst
     | `Tuple ps -> Tpat_tuple ps
     | `Construct (cstr, cst_descr, args) ->
@@ -129,7 +129,7 @@ module General = struct
 
   let rec strip_vars (p : pattern) : Half_simple.pattern =
     match p.pat_desc with
-    | `Alias (p, _, _) -> strip_vars (view p)
+    | `Alias (p, _, _, _) -> strip_vars (view p)
     | `Var _ -> { p with pat_desc = `Any }
     | #Half_simple.view as view -> { p with pat_desc = view }
 end
diff --git a/src/ocaml/typing/patterns.mli b/src/ocaml/typing/patterns.mli
index 66dd2d05a4..2ad645b0d0 100644
--- a/src/ocaml/typing/patterns.mli
+++ b/src/ocaml/typing/patterns.mli
@@ -65,8 +65,8 @@ end
 module General : sig
   type view = [
     | Half_simple.view
-    | `Var of Ident.t * string loc
-    | `Alias of pattern * Ident.t * string loc
+    | `Var of Ident.t * string loc * Uid.t
+    | `Alias of pattern * Ident.t * string loc * Uid.t
   ]
   type pattern = view pattern_data
 
diff --git a/src/ocaml/typing/printpat.ml b/src/ocaml/typing/printpat.ml
index 64094b63ec..e90fd8eeb1 100644
--- a/src/ocaml/typing/printpat.ml
+++ b/src/ocaml/typing/printpat.ml
@@ -52,7 +52,7 @@ let rec pretty_val : type k . _ -> k general_pattern -> _ = fun ppf v ->
     | [] ->
   match v.pat_desc with
   | Tpat_any -> fprintf ppf "_"
-  | Tpat_var (x,_) -> fprintf ppf "%s" (Ident.name x)
+  | Tpat_var (x,_,_) -> fprintf ppf "%s" (Ident.name x)
   | Tpat_constant c -> fprintf ppf "%s" (pretty_const c)
   | Tpat_tuple vs ->
       fprintf ppf "@[(%a)@]" (pretty_vals ",") vs
@@ -98,7 +98,7 @@ let rec pretty_val : type k . _ -> k general_pattern -> _ = fun ppf v ->
       fprintf ppf "@[[| %a |]@]" (pretty_vals " ;") vs
   | Tpat_lazy v ->
       fprintf ppf "@[<2>lazy@ %a@]" pretty_arg v
-  | Tpat_alias (v, x,_) ->
+  | Tpat_alias (v, x,_,_) ->
       fprintf ppf "@[(%a@ as %a)@]" pretty_val v Ident.print x
   | Tpat_value v ->
       fprintf ppf "%a" pretty_val (v :> pattern)
diff --git a/src/ocaml/typing/printtyped.ml b/src/ocaml/typing/printtyped.ml
index c3480379d2..2430b903db 100644
--- a/src/ocaml/typing/printtyped.ml
+++ b/src/ocaml/typing/printtyped.ml
@@ -242,8 +242,8 @@ and pattern : type k . _ -> _ -> k general_pattern -> unit = fun i ppf x ->
   end;
   match x.pat_desc with
   | Tpat_any -> line i ppf "Tpat_any\n";
-  | Tpat_var (s,_) -> line i ppf "Tpat_var \"%a\"\n" fmt_ident s;
-  | Tpat_alias (p, s,_) ->
+  | Tpat_var (s,_,_) -> line i ppf "Tpat_var \"%a\"\n" fmt_ident s;
+  | Tpat_alias (p, s,_,_) ->
       line i ppf "Tpat_alias \"%a\"\n" fmt_ident s;
       pattern i ppf p;
   | Tpat_constant (c) -> line i ppf "Tpat_constant %a\n" fmt_constant c;
diff --git a/src/ocaml/typing/rec_check.ml b/src/ocaml/typing/rec_check.ml
index 99802cbf51..4210771820 100644
--- a/src/ocaml/typing/rec_check.ml
+++ b/src/ocaml/typing/rec_check.ml
@@ -221,7 +221,7 @@ let classify_expression : Typedtree.expression -> sd =
     let old_env = env in
     let add_value_binding env vb =
       match vb.vb_pat.pat_desc with
-      | Tpat_var (id, _loc) ->
+      | Tpat_var (id, _loc, _uid) ->
           let size = classify_expression old_env vb.vb_expr in
           Ident.add id size env
       | _ ->
@@ -1197,8 +1197,8 @@ and pattern : type k . k general_pattern -> Env.t -> mode = fun pat env ->
 and is_destructuring_pattern : type k . k general_pattern -> bool =
   fun pat -> match pat.pat_desc with
     | Tpat_any -> false
-    | Tpat_var (_, _) -> false
-    | Tpat_alias (pat, _, _) -> is_destructuring_pattern pat
+    | Tpat_var (_, _, _) -> false
+    | Tpat_alias (pat, _, _, _) -> is_destructuring_pattern pat
     | Tpat_constant _ -> true
     | Tpat_tuple _ -> true
     | Tpat_construct _ -> true
diff --git a/src/ocaml/typing/shape.ml b/src/ocaml/typing/shape.ml
index 8bd04f4dd5..6de30689ec 100644
--- a/src/ocaml/typing/shape.ml
+++ b/src/ocaml/typing/shape.ml
@@ -67,6 +67,8 @@ module Sig_component_kind = struct
   type t =
     | Value
     | Type
+    | Constructor
+    | Label
     | Module
     | Module_type
     | Extension_constructor
@@ -76,6 +78,8 @@ module Sig_component_kind = struct
   let to_string = function
     | Value -> "value"
     | Type -> "type"
+    | Constructor -> "constructor"
+    | Label -> "label"
     | Module -> "module"
     | Module_type -> "module type"
     | Extension_constructor -> "extension constructor"
@@ -87,6 +91,8 @@ module Sig_component_kind = struct
     | Extension_constructor ->
         false
     | Type
+    | Constructor
+    | Label
     | Module
     | Module_type
     | Class
@@ -99,10 +105,15 @@ module Item = struct
     type t = string * Sig_component_kind.t
     let compare = compare
 
+    let name (name, _) = name
+    let kind (_, kind) = kind
+
     let make str ns = str, ns
 
     let value id = Ident.name id, Sig_component_kind.Value
     let type_ id = Ident.name id, Sig_component_kind.Type
+    let constr id = Ident.name id, Sig_component_kind.Constructor
+    let label id = Ident.name id, Sig_component_kind.Label
     let module_ id = Ident.name id, Sig_component_kind.Module
     let module_type id = Ident.name id, Sig_component_kind.Module_type
     let extension_constructor id =
@@ -124,17 +135,19 @@ module Item = struct
 end
 
 type var = Ident.t
-type t = { uid: Uid.t option; desc: desc }
+type t = { uid: Uid.t option; desc: desc; approximated: bool }
 and desc =
   | Var of var
   | Abs of var * t
   | App of t * t
   | Struct of t Item.Map.t
+  | Alias of t
   | Leaf
   | Proj of t * Item.t
   | Comp_unit of string
+  | Error of string
 
-let print fmt =
+let print fmt t =
   let print_uid_opt =
     Format.pp_print_option (fun fmt -> Format.fprintf fmt "<%a>" Uid.print)
   in
@@ -171,49 +184,83 @@ let print fmt =
                 aux t
             )
         in
-        Format.fprintf fmt "{@[<v>%a@,%a@]}" print_uid_opt uid print_map map
+        if Item.Map.is_empty map then
+          Format.fprintf fmt "@[<hv>{%a}@]" print_uid_opt uid
+        else
+          Format.fprintf fmt "{@[<v>%a@,%a@]}" print_uid_opt uid print_map map
+    | Alias t ->
+        Format.fprintf fmt "Alias@[(@[<v>%a@,%a@])@]" print_uid_opt uid aux t
+    | Error s ->
+        Format.fprintf fmt "Error %s" s
   in
-  Format.fprintf fmt"@[%a@]@;" aux
+  if t.approximated then
+    Format.fprintf fmt "@[(approx)@ %a@]@;" aux t
+  else
+    Format.fprintf fmt "@[%a@]@;" aux t
 
 let fresh_var ?(name="shape-var") uid =
   let var = Ident.create_local name in
-  var, { uid = Some uid; desc = Var var }
+  var, { uid = Some uid; desc = Var var; approximated = false }
 
 let for_unnamed_functor_param = Ident.create_local "()"
 
 let var uid id =
-  { uid = Some uid; desc = Var id }
+  { uid = Some uid; desc = Var id; approximated = false }
 
 let abs ?uid var body =
-  { uid; desc = Abs (var, body) }
+  { uid; desc = Abs (var, body); approximated = false }
 
 let str ?uid map =
-  { uid; desc = Struct map }
+  { uid; desc = Struct map; approximated = false }
+
+let alias ?uid t =
+  { uid; desc = Alias t; approximated = false}
 
 let leaf uid =
-  { uid = Some uid; desc = Leaf }
+  { uid = Some uid; desc = Leaf; approximated = false }
+
+let approx t = { t with approximated = true}
 
 let proj ?uid t item =
   match t.desc with
   | Leaf ->
       (* When stuck projecting in a leaf we propagate the leaf
         as a best effort *)
-      t
+      approx t
   | Struct map ->
       begin try Item.Map.find item map
-      with Not_found -> t (* ill-typed program *)
+      with Not_found -> approx t (* ill-typed program *)
       end
   | _ ->
-      { uid; desc = Proj (t, item) }
+     { uid; desc = Proj (t, item); approximated = false }
 
 let app ?uid f ~arg =
-      { uid; desc = App (f, arg) }
+  { uid; desc = App (f, arg); approximated = false }
 
 let decompose_abs t =
   match t.desc with
   | Abs (x, t) -> Some (x, t)
   | _ -> None
 
+type reduction_result =
+  | Resolved of Uid.t
+  | Unresolved of t
+  | Approximated of Uid.t option
+  | Missing_uid
+
+let print_reduction_result fmt result =
+  match result with
+  | Resolved uid ->
+      Format.fprintf fmt "@[Resolved: %a@]@;" Uid.print uid
+  | Unresolved shape ->
+      Format.fprintf fmt "@[Unresolved: %a@]@;" print shape
+  | Approximated (Some uid) ->
+      Format.fprintf fmt "@[Approximated: %a@]@;" Uid.print uid
+  | Approximated None ->
+      Format.fprintf fmt "@[Approximated: No uid@]@;"
+  | Missing_uid ->
+      Format.fprintf fmt "@[Missing uid@]@;"
+
 module Make_reduce(Params : sig
   type env
   val fuel : int
@@ -223,16 +270,17 @@ end) = struct
   (* We implement a strong call-by-need reduction, following an
      evaluator from Nathanaelle Courant. *)
 
-  type nf = { uid: Uid.t option; desc: nf_desc }
+  type nf = { uid: Uid.t option; desc: nf_desc; approximated: bool }
   and nf_desc =
     | NVar of var
     | NApp of nf * nf
     | NAbs of local_env * var * t * delayed_nf
     | NStruct of delayed_nf Item.Map.t
+    | NAlias of nf
     | NProj of nf * Item.t
     | NLeaf
     | NComp_unit of string
-    | NoFuelLeft of desc
+    | NError of string
   (* A type of normal forms for strong call-by-need evaluation.
      The normal form of an abstraction
        Abs(x, t)
@@ -251,7 +299,8 @@ end) = struct
      by calling the normalization function as usual, but duplicate
      computations are precisely avoided by memoization.
    *)
-  and delayed_nf = Thunk of local_env * t
+  and thunk = { local_env : local_env; shape: t }
+  and delayed_nf = Thunk of thunk
 
   and local_env = delayed_nf option Ident.Map.t
   (* When reducing in the body of an abstraction [Abs(x, body)], we
@@ -272,11 +321,15 @@ end) = struct
         Hashtbl.replace memo_table memo_key res;
         res
 
+  let rec strip_head_aliases nf = match nf.desc with
+    | NAlias nf -> strip_head_aliases nf
+    | _ -> nf
+
   type env = {
     fuel: int ref;
     global_env: Params.env;
     local_env: local_env;
-    reduce_memo_table: (local_env * t, nf) Hashtbl.t;
+    reduce_memo_table: (thunk, nf) Hashtbl.t;
     read_back_memo_table: (nf, t) Hashtbl.t;
   }
 
@@ -284,8 +337,11 @@ end) = struct
     { env with local_env = Ident.Map.add var shape env.local_env }
 
   let rec reduce_ env t =
-    let memo_key = (env.local_env, t) in
-    in_memo_table env.reduce_memo_table memo_key (reduce__ env) t
+    let local_env = env.local_env in
+    let memo_key = { local_env; shape = t } in
+    in_memo_table
+      env.reduce_memo_table memo_key
+      (reduce__ env) t
   (* Memoization is absolutely essential for performance on this
      problem, because the normal forms we build can in some real-world
      cases contain an exponential amount of redundancy. Memoization
@@ -324,13 +380,20 @@ end) = struct
      same hash.
 *)
 
-  and reduce__ ({fuel; global_env; local_env; _} as env) (t : t) =
-    let reduce env t = reduce_ env t in
-    let delay_reduce env t = Thunk (env.local_env, t) in
-    let force (Thunk (local_env, t)) =
+  and reduce__
+    ({fuel; global_env; local_env; _} as env) (t : t) =
+    let reduce env t =
+      reduce_ env t
+    in
+    let delay_reduce { local_env; _ } t =
+      Thunk { local_env; shape = t }
+    in
+    let force (Thunk { local_env; shape = t }) =
       reduce { env with local_env } t in
-    let return desc : nf = { uid = t.uid; desc } in
-    if !fuel < 0 then return (NoFuelLeft t.desc)
+    let return ?(approximated = t.approximated) desc : nf =
+      { uid = t.uid; desc; approximated }
+    in
+    if !fuel < 0 then return ~approximated:true (NError "NoFuelLeft")
     else
       match t.desc with
       | Comp_unit unit_name ->
@@ -339,19 +402,18 @@ end) = struct
           | None -> return (NComp_unit unit_name)
           end
       | App(f, arg) ->
-          let f = reduce env f in
+          let f = reduce env f |> strip_head_aliases in
           begin match f.desc with
           | NAbs(clos_env, var, body, _body_nf) ->
               let arg = delay_reduce env arg in
               let env = bind { env with local_env = clos_env } var (Some arg) in
-              reduce env body
-              |> improve_uid t.uid
+              { (reduce env body) with uid = t.uid }
           | _ ->
               let arg = reduce env arg in
               return (NApp(f, arg))
           end
       | Proj(str, item) ->
-          let str = reduce env str in
+          let str = reduce env str |> strip_head_aliases in
           let nored () = return (NProj(str, item)) in
           begin match str.desc with
           | NStruct (items) ->
@@ -392,8 +454,10 @@ end) = struct
       | Struct m ->
           let mnf = Item.Map.map (delay_reduce env) m in
           return (NStruct mnf)
+      | Alias t -> return (NAlias (reduce env t))
+      | Error s -> return ~approximated:true (NError s)
 
-  let rec read_back env (nf : nf) : t =
+  and read_back env (nf : nf) : t =
     in_memo_table env.read_back_memo_table nf (read_back_ env) nf
   (* The [nf] normal form we receive may contain a lot of internal
      sharing due to the use of memoization in the evaluator. We have
@@ -401,11 +465,13 @@ end) = struct
      over the term as a tree. *)
 
   and read_back_ env (nf : nf) : t =
-    { uid = nf.uid; desc = read_back_desc env nf.desc }
+    { uid = nf.uid;
+      desc = read_back_desc env nf.desc;
+      approximated = nf.approximated }
 
   and read_back_desc env desc =
     let read_back nf = read_back env nf in
-    let read_back_force (Thunk (local_env, t)) =
+    let read_back_force (Thunk { local_env; shape = t }) =
       read_back (reduce_ { env with local_env } t) in
     match desc with
     | NVar v ->
@@ -416,44 +482,20 @@ end) = struct
         Abs(x, read_back_force nf)
     | NStruct nstr ->
         Struct (Item.Map.map read_back_force nstr)
+    | NAlias nf -> Alias (read_back nf)
     | NProj (nf, item) ->
         Proj (read_back nf, item)
     | NLeaf -> Leaf
     | NComp_unit s -> Comp_unit s
-    | NoFuelLeft t -> t
-
-  (* When in Merlin we don't need to perform full shape reduction since we are
-     only interested by uid's stored at the "top-level" of the shape once the
-     projections have been done. *)
-  let weak_read_back env (nf : nf) : t =
-    let cache = Hashtbl.create 42 in
-    let rec weak_read_back env nf =
-      let memo_key = (env.local_env, nf) in
-      in_memo_table cache memo_key (weak_read_back_ env) nf
-    and weak_read_back_ env nf : t =
-      { uid = nf.uid; desc = weak_read_back_desc env nf.desc }
-    and weak_read_back_desc env desc : desc =
-      let weak_read_back_no_force (Thunk (_local_env, t)) = t in
-      match desc with
-      | NVar v ->
-          Var v
-      | NApp (nft, nfu) ->
-          App(weak_read_back env nft, weak_read_back env nfu)
-      | NAbs (_env, x, _t, nf) ->
-          Abs(x, weak_read_back_no_force nf)
-      | NStruct nstr ->
-          Struct (Item.Map.map weak_read_back_no_force nstr)
-      | NProj (nf, item) ->
-          Proj (read_back env nf, item)
-      | NLeaf -> Leaf
-      | NComp_unit s -> Comp_unit s
-      | NoFuelLeft t -> t
-    in weak_read_back env nf
+    | NError s -> Error s
+
+  (* Sharing the memo tables is safe at the level of a compilation unit since
+    idents should be unique *)
+  let reduce_memo_table = Hashtbl.create 42
+  let read_back_memo_table = Hashtbl.create 42
 
   let reduce global_env t =
     let fuel = ref Params.fuel in
-    let reduce_memo_table = Hashtbl.create 42 in
-    let read_back_memo_table = Hashtbl.create 42 in
     let local_env = Ident.Map.empty in
     let env = {
       fuel;
@@ -464,10 +506,19 @@ end) = struct
     } in
     reduce_ env t |> read_back env
 
-  let weak_reduce global_env t =
+  let rec is_stuck_on_comp_unit (nf : nf) =
+    match nf.desc with
+    | NVar _ ->
+      (* This should not happen if we only reduce closed terms *)
+      false
+    | NApp (nf, _) | NProj (nf, _) | NAlias nf -> is_stuck_on_comp_unit nf
+    | NStruct _ | NAbs _ -> false
+    | NComp_unit _ -> true
+    | NError _ -> false
+    | NLeaf -> false
+
+  let reduce_for_uid global_env t =
     let fuel = ref Params.fuel in
-    let reduce_memo_table = Hashtbl.create 42 in
-    let read_back_memo_table = Hashtbl.create 42 in
     let local_env = Ident.Map.empty in
     let env = {
       fuel;
@@ -476,10 +527,24 @@ end) = struct
       read_back_memo_table;
       local_env;
     } in
-    reduce_ env t |> weak_read_back env
+    let nf = reduce_ env t in
+    if is_stuck_on_comp_unit nf then
+      Unresolved (read_back env nf)
+    else match nf with
+      | { uid = Some uid; approximated = false; _ } ->
+          Resolved uid
+      | { uid; approximated = true; _ } ->
+          Approximated uid
+      | { uid = None; approximated = false; _ } ->
+          (* A missing Uid after a complete reduction means the Uid was first
+             missing in the shape which is a code error. Having the
+             [Missing_uid] reported will allow Merlin (or another tool working
+             with the index) to ask users to report the issue if it does happen.
+          *)
+          Missing_uid
 end
 
-module Local_reduce =
+module Toplevel_local_reduce =
   (* Note: this definition with [type env = unit] is only suitable for
      reduction of toplevel shapes -- shapes of compilation units,
      where free variables are only Comp_unit names. If we wanted to
@@ -492,24 +557,45 @@ module Local_reduce =
     let find_shape _env _id = raise Not_found
   end)
 
-let local_reduce shape =
-  Local_reduce.reduce () shape
+let toplevel_local_reduce shape =
+  Toplevel_local_reduce.reduce () shape
 
-let dummy_mod = { uid = None; desc = Struct Item.Map.empty }
+let dummy_mod =
+  { uid = None; desc = Struct Item.Map.empty; approximated = false }
 
-let of_path ~find_shape ~namespace =
+let of_path ~find_shape ~namespace path =
   let rec aux : Sig_component_kind.t -> Path.t -> t = fun ns -> function
     | Pident id -> find_shape ns id
-    | Pdot (path, name) -> proj (aux Module path) (name, ns)
+    | Pdot (path, name) ->
+      (* We need to handle the following cases:
+        Path of constructor:
+          M.t.C
+        Path of label:
+          M.t.lbl
+        Path on label of inline record:
+          M.t.C.lbl *)
+      let is_capitalized name = String.capitalize_ascii name = name in
+      let is_label namespace = namespace = Sig_component_kind.Label in
+      let namespace : Sig_component_kind.t =
+        match path with
+        | Pident id when is_capitalized (Ident.name id) ->
+            if is_label ns then Constructor else Module
+        | Pident _ -> Type
+        | Pdot (_, name)  when is_capitalized name ->
+            if is_label ns then Constructor else Module
+        | Pdot _ -> Type
+        | Papply _ -> Module
+      in
+      proj (aux namespace path) (name, ns)
     | Papply (p1, p2) -> app (aux Module p1) ~arg:(aux Module p2)
   in
-  aux namespace
+  aux namespace path
 
 let for_persistent_unit s =
   { uid = Some (Uid.of_compilation_unit_id (Ident.create_persistent s));
-    desc = Comp_unit s }
+    desc = Comp_unit s; approximated = false }
 
-let leaf_for_unpack = { uid = None; desc = Leaf }
+let leaf_for_unpack = { uid = None; desc = Leaf; approximated = false }
 
 let set_uid_if_none t uid =
   match t.uid with
@@ -529,11 +615,21 @@ module Map = struct
     let item = Item.value id in
     Item.Map.add item (proj shape item) t
 
-  let add_type t id uid = Item.Map.add (Item.type_ id) (leaf uid) t
+  let add_type t id shape = Item.Map.add (Item.type_ id) shape t
   let add_type_proj t id shape =
     let item = Item.type_ id in
     Item.Map.add item (proj shape item) t
 
+  let add_constr t id shape = Item.Map.add (Item.constr id) shape t
+  let add_constr_proj t id shape =
+    let item = Item.constr id in
+    Item.Map.add item (proj shape item) t
+
+  let add_label t id uid = Item.Map.add (Item.label id) (leaf uid) t
+  let add_label_proj t id shape =
+    let item = Item.label id in
+    Item.Map.add item (proj shape item) t
+
   let add_module t id shape = Item.Map.add (Item.module_ id) shape t
   let add_module_proj t id shape =
     let item = Item.module_ id in
@@ -545,8 +641,8 @@ module Map = struct
     let item = Item.module_type id in
     Item.Map.add item (proj shape item) t
 
-  let add_extcons t id uid =
-    Item.Map.add (Item.extension_constructor id) (leaf uid) t
+  let add_extcons t id shape =
+    Item.Map.add (Item.extension_constructor id) shape t
   let add_extcons_proj t id shape =
     let item = Item.extension_constructor id in
     Item.Map.add item (proj shape item) t
diff --git a/src/ocaml/typing/shape.mli b/src/ocaml/typing/shape.mli
index 9740a3ad2d..8d1d4b3342 100644
--- a/src/ocaml/typing/shape.mli
+++ b/src/ocaml/typing/shape.mli
@@ -13,6 +13,42 @@
 (*                                                                        *)
 (**************************************************************************)
 
+(** Shapes are an abstract representation of modules' implementations which
+    allow the tracking of definitions through functor applications and other
+    module-level operations.
+
+    The Shape of a compilation unit is elaborated during typing, partially
+    reduced (without loading external shapes) and written to the [cmt] file.
+
+    External tools can retrieve the definition of any value (or type, or module,
+    etc) by following this procedure:
+
+    - Build the Shape corresponding to the value's path:
+      [let shape = Env.shape_of_path ~namespace env path]
+
+    - Instantiate the [Make_reduce] functor with a way to load shapes from
+      external units and to looks for shapes in the environment (usually using
+      [Env.shape_of_path]).
+
+    - Completely reduce the shape:
+      [let shape = My_reduce.(weak_)reduce env shape]
+
+    - The [Uid.t] stored in the reduced shape should be the one of the
+      definition. However, if the [approximate] field of the reduced shape is
+      [true] then the [Uid.t] will not correspond to the definition, but to the
+      closest parent module's uid. This happens when Shape reduction gets stuck,
+      for example when hitting first-class modules.
+
+    - The location of the definition can be easily found with the
+      [cmt_format.cmt_uid_to_decl] talbe of the corresponding compilation unit.
+
+  See:
+  - {{: https://icfp22.sigplan.org/details/mlfamilyworkshop-2022-papers/10/Module-Shapes-for-Modern-Tooling }
+    the design document}
+  - {{: https://www.lix.polytechnique.fr/Labo/Gabriel.Scherer/research/shapes/2022-ml-workshop-shapes-talk.pdf }
+    a talk about the reduction strategy
+*)
+
 module Uid : sig
   type t = private
     | Compilation_unit of string
@@ -36,6 +72,8 @@ module Sig_component_kind : sig
   type t =
     | Value
     | Type
+    | Constructor
+    | Label
     | Module
     | Module_type
     | Extension_constructor
@@ -48,32 +86,49 @@ module Sig_component_kind : sig
   val can_appear_in_types : t -> bool
 end
 
+(** Shape's items are elements of a structure modeling module components. *)
 module Item : sig
-  type t
+  type t = string * Sig_component_kind.t
+  val name : t -> string
+  val kind : t -> Sig_component_kind.t
 
   val make : string -> Sig_component_kind.t -> t
 
   val value : Ident.t -> t
   val type_ : Ident.t -> t
+  val constr : Ident.t -> t
+  val label : Ident.t -> t
   val module_ : Ident.t -> t
   val module_type : Ident.t -> t
   val extension_constructor : Ident.t -> t
   val class_ : Ident.t -> t
   val class_type : Ident.t -> t
 
+  val print : Format.formatter -> t -> unit
+
   module Map : Map.S with type key = t
 end
 
 type var = Ident.t
-type t = { uid: Uid.t option; desc: desc }
+type t = { uid: Uid.t option; desc: desc; approximated: bool }
 and desc =
   | Var of var
   | Abs of var * t
   | App of t * t
   | Struct of t Item.Map.t
+  | Alias of t
   | Leaf
   | Proj of t * Item.t
   | Comp_unit of string
+  | Error of string
+
+type reduction_result =
+  | Resolved of Uid.t
+  | Unresolved of t
+  | Approximated of Uid.t option
+  | Missing_uid
+
+val print_reduction_result : Format.formatter -> reduction_result -> unit
 
 val print : Format.formatter -> t -> unit
 
@@ -86,6 +141,7 @@ val var : Uid.t -> Ident.t -> t
 val abs : ?uid:Uid.t -> var -> t -> t
 val app : ?uid:Uid.t -> t -> arg:t -> t
 val str : ?uid:Uid.t -> t Item.Map.t -> t
+val alias : ?uid:Uid.t -> t -> t
 val proj : ?uid:Uid.t -> t -> Item.t -> t
 val leaf : Uid.t -> t
 
@@ -105,16 +161,22 @@ module Map : sig
   val add_value : t -> Ident.t -> Uid.t -> t
   val add_value_proj : t -> Ident.t -> shape -> t
 
-  val add_type : t -> Ident.t -> Uid.t -> t
+  val add_type : t -> Ident.t -> shape -> t
   val add_type_proj : t -> Ident.t -> shape -> t
 
+  val add_constr : t -> Ident.t -> shape -> t
+  val add_constr_proj : t -> Ident.t -> shape -> t
+
+  val add_label : t -> Ident.t -> Uid.t -> t
+  val add_label_proj : t -> Ident.t -> shape -> t
+
   val add_module : t -> Ident.t -> shape -> t
   val add_module_proj : t -> Ident.t -> shape -> t
 
   val add_module_type : t -> Ident.t -> Uid.t -> t
   val add_module_type_proj : t -> Ident.t -> shape -> t
 
-  val add_extcons : t -> Ident.t -> Uid.t -> t
+  val add_extcons : t -> Ident.t -> shape -> t
   val add_extcons_proj : t -> Ident.t -> shape -> t
 
   val add_class : t -> Ident.t -> Uid.t -> t
@@ -126,6 +188,10 @@ end
 
 val dummy_mod : t
 
+(** This function returns the shape corresponding to a given path. It requires a
+    callback to find shapes in the environment. It is generally more useful to
+    rely directly on the [Env.shape_of_path] function to get the shape
+    associated with a given path. *)
 val of_path :
   find_shape:(Sig_component_kind.t -> Ident.t -> t) ->
   namespace:Sig_component_kind.t -> Path.t -> t
@@ -152,7 +218,14 @@ module Make_reduce(Context : sig
     val find_shape : env -> Ident.t -> t
   end) : sig
   val reduce : Context.env -> t -> t
-  val weak_reduce : Context.env -> t -> t
+
+  (** Perform weak reduction and return the head's uid if any. If reduction was
+    incomplete the partially reduced shape is returned. *)
+  val reduce_for_uid : Context.env -> t -> reduction_result
 end
 
-val local_reduce : t -> t
+(** [toplevel_local_reduce] is only suitable to reduce toplevel shapes (shapes
+  of compilation units). Use the [Make_reduce] functor for other cases that
+  require access to the environment.*)
+val toplevel_local_reduce : t -> t
+
diff --git a/src/ocaml/typing/tast_iterator.ml b/src/ocaml/typing/tast_iterator.ml
index 98bc77dfb5..7e2e3a1978 100644
--- a/src/ocaml/typing/tast_iterator.ml
+++ b/src/ocaml/typing/tast_iterator.ml
@@ -170,7 +170,7 @@ let pat
   | Tpat_variant (_, po, _) -> Option.iter (sub.pat sub) po
   | Tpat_record (l, _) -> List.iter (fun (_, _, i) -> sub.pat sub i) l
   | Tpat_array l -> List.iter (sub.pat sub) l
-  | Tpat_alias (p, _, _) -> sub.pat sub p
+  | Tpat_alias (p, _, _, _) -> sub.pat sub p
   | Tpat_lazy p -> sub.pat sub p
   | Tpat_value p -> sub.pat sub (p :> pattern)
   | Tpat_exception p -> sub.pat sub p
@@ -318,8 +318,8 @@ let with_constraint sub = function
   | Twith_typesubst decl -> sub.type_declaration sub decl
   | Twith_module    _    -> ()
   | Twith_modsubst  _    -> ()
-  | Twith_modtype   _    -> ()
-  | Twith_modtypesubst _ -> ()
+  | Twith_modtype  decl  -> sub.module_type sub decl
+  | Twith_modtypesubst decl -> sub.module_type sub decl
 
 
 let open_description sub {open_env; _} = sub.env sub open_env
diff --git a/src/ocaml/typing/tast_mapper.ml b/src/ocaml/typing/tast_mapper.ml
index fe7268676e..a2700b7cba 100644
--- a/src/ocaml/typing/tast_mapper.ml
+++ b/src/ocaml/typing/tast_mapper.ml
@@ -219,7 +219,7 @@ let pat
     | Tpat_record (l, closed) ->
         Tpat_record (List.map (tuple3 id id (sub.pat sub)) l, closed)
     | Tpat_array l -> Tpat_array (List.map (sub.pat sub) l)
-    | Tpat_alias (p, id, s) -> Tpat_alias (sub.pat sub p, id, s)
+    | Tpat_alias (p, id, s, uid) -> Tpat_alias (sub.pat sub p, id, s, uid)
     | Tpat_lazy p -> Tpat_lazy (sub.pat sub p)
     | Tpat_value p ->
        (as_computation_pattern (sub.pat sub (p :> pattern))).pat_desc
diff --git a/src/ocaml/typing/typeclass.ml b/src/ocaml/typing/typeclass.ml
index 28f0645780..d951a00002 100644
--- a/src/ocaml/typing/typeclass.ml
+++ b/src/ocaml/typing/typeclass.ml
@@ -1305,7 +1305,7 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl =
         Typecore.type_let In_class_def val_env rec_flag sdefs in
       let (vals, met_env) =
         List.fold_right
-          (fun (id, _id_loc, _typ) (vals, met_env) ->
+          (fun (id, _id_loc, _typ, _uid) (vals, met_env) ->
              let path = Pident id in
              (* do not mark the value as used *)
              let vd = Env.find_value path val_env in
diff --git a/src/ocaml/typing/typecore.ml b/src/ocaml/typing/typecore.ml
index f83421683b..77b91e24de 100644
--- a/src/ocaml/typing/typecore.ml
+++ b/src/ocaml/typing/typecore.ml
@@ -537,6 +537,7 @@ type pattern_variable =
     pv_loc: Location.t;
     pv_as_var: bool;
     pv_attributes: attributes;
+    pv_uid : Uid.t;
   }
 
 type module_variable =
@@ -570,19 +571,21 @@ let enter_variable ?(is_module=false) ?(is_as_variable=false) loc name ty
       !pattern_variables
   then raise(error(loc, Env.empty, Multiply_bound_variable name.txt));
   let id = Ident.create_local name.txt in
+  let pv_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in
   pattern_variables :=
     {pv_id = id;
      pv_type = ty;
      pv_loc = loc;
      pv_as_var = is_as_variable;
-     pv_attributes = attrs} :: !pattern_variables;
+     pv_attributes = attrs;
+     pv_uid} :: !pattern_variables;
   if is_module then begin
     (* Note: unpack patterns enter a variable of the same name *)
     if not !allow_modules then
       raise (error (loc, Env.empty, Modules_not_allowed));
     module_variables := (name, loc) :: !module_variables
   end;
-  id
+  id, pv_uid
 
 let sort_pattern_variables vs =
   List.sort
@@ -648,7 +651,7 @@ let rec build_as_type ~refine (env : Env.t ref) p =
 and build_as_type_aux ~refine (env : Env.t ref) p =
   let build_as_type = build_as_type ~refine in
   match p.pat_desc with
-    Tpat_alias(p1,_, _) -> build_as_type env p1
+    Tpat_alias(p1,_, _, _) -> build_as_type env p1
   | Tpat_tuple pl ->
       let tyl = List.map (build_as_type env) pl in
       newty (Ttuple tyl)
@@ -1783,14 +1786,14 @@ and type_pat_aux
       end
   | Ppat_var name ->
       let ty = instance expected_ty in
-      let id = (* PR#7330 *)
+      let id, uid = (* PR#7330 *)
         if name.txt = "*extension*" then
-          Ident.create_local name.txt
+          Ident.create_local name.txt, Uid.internal_not_actually_unique
         else
           enter_variable loc name ty sp.ppat_attributes
       in
       rvp k {
-        pat_desc = Tpat_var (id, name);
+        pat_desc = Tpat_var (id, name, uid);
         pat_loc = loc; pat_extra=[];
         pat_type = ty;
         pat_attributes = sp.ppat_attributes;
@@ -1809,9 +1812,9 @@ and type_pat_aux
             pat_env = !env }
       | Some s ->
           let v = { name with txt = s } in
-          let id = enter_variable loc v t ~is_module:true sp.ppat_attributes in
+          let id, uid = enter_variable loc v t ~is_module:true sp.ppat_attributes in
           rvp k {
-            pat_desc = Tpat_var (id, v);
+            pat_desc = Tpat_var (id, v, uid);
             pat_loc = sp.ppat_loc;
             pat_extra=[Tpat_unpack, loc, sp.ppat_attributes];
             pat_type = t;
@@ -1825,8 +1828,8 @@ and type_pat_aux
       assert construction_not_used_in_counterexamples;
       let cty, ty, ty' =
         solve_Ppat_poly_constraint ~refine env lloc sty expected_ty in
-      let id = enter_variable lloc name ty' attrs in
-      rvp k { pat_desc = Tpat_var (id, name);
+      let id, uid = enter_variable lloc name ty' attrs in
+      rvp k { pat_desc = Tpat_var (id, name, uid);
               pat_loc = lloc;
               pat_extra = [Tpat_constraint cty, loc, sp.ppat_attributes];
               pat_type = ty;
@@ -1836,11 +1839,11 @@ and type_pat_aux
       assert construction_not_used_in_counterexamples;
       type_pat Value sq expected_ty (fun q ->
         let ty_var = solve_Ppat_alias ~refine env q in
-        let id =
+        let id, uid =
           enter_variable ~is_as_variable:true loc name ty_var sp.ppat_attributes
         in
         rvp k {
-          pat_desc = Tpat_alias(q, id, name);
+          pat_desc = Tpat_alias(q, id, name, uid);
           pat_loc = loc; pat_extra=[];
           pat_type = q.pat_type;
           pat_attributes = sp.ppat_attributes;
@@ -2159,12 +2162,12 @@ and type_pat_aux
         let extra = (Tpat_constraint cty, loc, sp.ppat_attributes) in
         let p : k general_pattern =
           match category, (p : k general_pattern) with
-          | Value, {pat_desc = Tpat_var (id,s); _} ->
+          | Value, {pat_desc = Tpat_var (id,s,uid); _} ->
             {p with
               pat_type = ty;
               pat_desc =
                 Tpat_alias
-                  ({p with pat_desc = Tpat_any; pat_attributes = []}, id,s);
+                  ({p with pat_desc = Tpat_any; pat_attributes = []}, id,s,uid);
               pat_extra = [extra];
             }
           | _, p ->
@@ -2256,12 +2259,12 @@ let iter_pattern_variables_type f : pattern_variable list -> unit =
 
 let add_pattern_variables ?check ?check_as env pv =
   List.fold_right
-    (fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes} env ->
+    (fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes; pv_uid} env ->
        let check = if pv_as_var then check_as else check in
        Env.add_value ?check pv_id
          {val_type = pv_type; val_kind = Val_reg; Types.val_loc = pv_loc;
           val_attributes = pv_attributes;
-          val_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+          val_uid = pv_uid;
          } env
     )
     pv env
@@ -2885,8 +2888,8 @@ let rec name_pattern default = function
     [] -> Ident.create_local default
   | p :: rem ->
     match p.pat_desc with
-      Tpat_var (id, _) -> id
-    | Tpat_alias(_, id, _) -> id
+      Tpat_var (id, _, _) -> id
+    | Tpat_alias(_, id, _, _) -> id
     | _ -> name_pattern default rem
 
 let name_cases default lst =
@@ -3873,10 +3876,12 @@ and type_expect_
         | _ -> Mp_present
       in
       let scope = create_scope () in
+      let md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in
       let md =
         { md_type = modl.mod_type; md_attributes = []; md_loc = name.loc;
-          md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); }
+          md_uid; }
       in
+      let md_shape = Shape.set_uid_if_none md_shape md_uid in
       let (id, new_env) =
         match name.txt with
         | None -> None, env
@@ -3902,7 +3907,7 @@ and type_expect_
         exp_attributes = sexp.pexp_attributes;
         exp_env = env }
   | Pexp_letexception(cd, sbody) ->
-      let (cd, newenv) = Typedecl.transl_exception env cd in
+      let (cd, newenv, _shape) = Typedecl.transl_exception env cd in
       let body = type_expect newenv sbody ty_expected_explained in
       re {
         exp_desc = Texp_letexception(cd, body);
@@ -4701,7 +4706,10 @@ and type_argument ?explanation ?recarg env sarg ty_expected' ty_expected =
           }
         in
         let exp_env = Env.add_value id desc env in
-        {pat_desc = Tpat_var (id, mknoloc name); pat_type = ty;pat_extra=[];
+        {pat_desc =
+          Tpat_var (id, mknoloc name, desc.val_uid);
+         pat_type = ty;
+         pat_extra=[];
          pat_attributes = [];
          pat_loc = Location.none; pat_env = env},
         {exp_type = ty; exp_loc = Location.none; exp_env = exp_env;
@@ -5574,7 +5582,7 @@ and type_let
     List.iter
       (fun {vb_pat=pat} -> match pat.pat_desc with
            Tpat_var _ -> ()
-         | Tpat_alias ({pat_desc=Tpat_any}, _, _) -> ()
+         | Tpat_alias ({pat_desc=Tpat_any}, _, _, _) -> ()
          | _ -> raise(error(pat.pat_loc, env, Illegal_letrec_pat)))
       l;
   List.iter (function
diff --git a/src/ocaml/typing/typecore.mli b/src/ocaml/typing/typecore.mli
index 73772b47ac..2c162e714b 100644
--- a/src/ocaml/typing/typecore.mli
+++ b/src/ocaml/typing/typecore.mli
@@ -56,6 +56,7 @@ type pattern_variable =
     pv_loc: Location.t;
     pv_as_var: bool;
     pv_attributes: Typedtree.attributes;
+    pv_uid : Uid.t;
   }
 
 val mk_expected:
diff --git a/src/ocaml/typing/typedecl.ml b/src/ocaml/typing/typedecl.ml
index 502418335f..f7582b7801 100644
--- a/src/ocaml/typing/typedecl.ml
+++ b/src/ocaml/typing/typedecl.ml
@@ -82,12 +82,12 @@ let get_unboxed_from_attributes sdecl =
 
 (* Enter all declared types in the environment as abstract types *)
 
-let add_type ~long_path ~check id decl env =
+let add_type ~long_path ~check ?shape id decl env =
   Builtin_attributes.warning_scope ~ppwarning:false decl.type_attributes
     (fun () ->
        match long_path with
-       | true -> Env.add_type_long_path ~check id decl env
-       | false -> Env.add_type ~check id decl env)
+       | true -> Env.add_type_long_path ~check ?shape id decl env
+       | false -> Env.add_type ~check ?shape id decl env)
 
 let enter_type rec_flag env sdecl (id, uid) =
   let needed =
@@ -225,7 +225,9 @@ let transl_labels env univars closed lbls =
          let arg = Ast_helper.Typ.force_poly arg in
          let cty = transl_simple_type env ?univars closed arg in
          {ld_id = Ident.create_local name.txt;
-          ld_name = name; ld_mutable = mut;
+          ld_name = name;
+          ld_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+          ld_mutable = mut;
           ld_type = cty; ld_loc = loc; ld_attributes = attrs}
       )
   in
@@ -235,14 +237,12 @@ let transl_labels env univars closed lbls =
       (fun ld ->
          let ty = ld.ld_type.ctyp_type in
          let ty = match get_desc ty with Tpoly(t,[]) -> t | _ -> ty in
-         let ld_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in
-         Env.register_uid ld_uid ld.ld_loc;
          {Types.ld_id = ld.ld_id;
           ld_mutable = ld.ld_mutable;
           ld_type = ty;
           ld_loc = ld.ld_loc;
           ld_attributes = ld.ld_attributes;
-          ld_uid;
+          ld_uid = ld.ld_uid;
          }
       )
       lbls in
@@ -312,6 +312,25 @@ let make_constructor env loc type_path type_params svars sargs sret_type =
       widen z;
       targs, Some tret_type, args, Some ret_type
 
+let shape_map_labels =
+  List.fold_left (fun map { ld_id; ld_uid; _} ->
+    Shape.Map.add_label map ld_id ld_uid)
+    Shape.Map.empty
+
+let shape_map_cstrs =
+  List.fold_left (fun map { cd_id; cd_uid; cd_args; _ } ->
+    let cstr_shape_map =
+      let label_decls =
+        match cd_args with
+        | Cstr_tuple _ -> []
+        | Cstr_record ldecls -> ldecls
+      in
+      shape_map_labels label_decls
+    in
+    Shape.Map.add_constr map cd_id
+      @@ Shape.str ~uid:cd_uid cstr_shape_map)
+    (Shape.Map.empty)
+
 let transl_declaration env sdecl (id, uid) =
   (* Bind type parameters *)
   reset_type_variables();
@@ -398,6 +417,7 @@ let transl_declaration env sdecl (id, uid) =
           let tcstr =
             { cd_id = name;
               cd_name = scstr.pcd_name;
+              cd_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
               cd_vars = scstr.pcd_vars;
               cd_args = targs;
               cd_res = tret_type;
@@ -405,14 +425,12 @@ let transl_declaration env sdecl (id, uid) =
               cd_attributes = scstr.pcd_attributes }
           in
           let cstr =
-            let cd_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in
-            Env.register_uid cd_uid scstr.pcd_loc;
             { Types.cd_id = name;
               cd_args = args;
               cd_res = ret_type;
               cd_loc = scstr.pcd_loc;
               cd_attributes = scstr.pcd_attributes;
-              cd_uid; }
+              cd_uid = tcstr.cd_uid; }
           in
             tcstr, cstr
         in
@@ -477,18 +495,29 @@ let transl_declaration env sdecl (id, uid) =
       in
       set_private_row env sdecl.ptype_loc p decl
     end;
-    {
-      typ_id = id;
-      typ_name = sdecl.ptype_name;
-      typ_params = tparams;
-      typ_type = decl;
-      typ_cstrs = cstrs;
-      typ_loc = sdecl.ptype_loc;
-      typ_manifest = tman;
-      typ_kind = tkind;
-      typ_private = sdecl.ptype_private;
-      typ_attributes = sdecl.ptype_attributes;
-    }
+    let decl =
+      {
+        typ_id = id;
+        typ_name = sdecl.ptype_name;
+        typ_params = tparams;
+        typ_type = decl;
+        typ_cstrs = cstrs;
+        typ_loc = sdecl.ptype_loc;
+        typ_manifest = tman;
+        typ_kind = tkind;
+        typ_private = sdecl.ptype_private;
+        typ_attributes = sdecl.ptype_attributes;
+      }
+    in
+    let typ_shape =
+      let map = match decl.typ_kind with
+        | Ttype_variant cstrs -> shape_map_cstrs cstrs
+        | Ttype_record labels -> shape_map_labels labels
+        | _ -> Shape.Map.empty
+      in
+      Shape.str ~uid:decl.typ_type.type_uid map
+    in
+    decl, typ_shape
 
 (* Generalize a type declaration *)
 
@@ -848,10 +877,11 @@ let check_redefined_unit (td: Parsetree.type_declaration) =
   | _ ->
       ()
 
-let add_types_to_env decls env =
-  List.fold_right
-    (fun (id, decl) env -> add_type ~long_path:false ~check:true id decl env)
-    decls env
+let add_types_to_env decls shapes env =
+  List.fold_right2
+    (fun (id, decl) shape env ->
+      add_type ~long_path:false ~check:true ~shape id decl env)
+    decls shapes env
 
 (* Translate a set of type declarations, mutually recursive or not *)
 let transl_type_decl env rec_flag sdecl_list =
@@ -917,13 +947,16 @@ let transl_type_decl env rec_flag sdecl_list =
   in
   let tdecls =
     List.map2 transl_declaration sdecl_list (List.map ids_slots ids_list) in
-  let decls =
-    List.map (fun tdecl -> (tdecl.typ_id, tdecl.typ_type)) tdecls in
+  let decls, shapes =
+    List.map (fun (tdecl, tshape) -> (tdecl.typ_id, tdecl.typ_type), tshape)
+      tdecls
+    |> List.split
+  in
   current_slot := None;
   (* Check for duplicates *)
   check_duplicates sdecl_list;
   (* Build the final env. *)
-  let new_env = add_types_to_env decls env in
+  let new_env = add_types_to_env decls shapes env in
   (* Update stubs *)
   begin match rec_flag with
     | Asttypes.Nonrecursive -> ()
@@ -950,11 +983,12 @@ let transl_type_decl env rec_flag sdecl_list =
     check_well_founded_decl new_env (List.assoc id id_loc_list) (Path.Pident id)
       decl to_check)
     decls;
-  List.iter
-    (check_abbrev_recursion ~orig_env:env new_env id_loc_list to_check) tdecls;
+  List.iter (fun (decl, _shape) ->
+    check_abbrev_recursion ~orig_env:env new_env id_loc_list to_check decl)
+    tdecls;
   (* Check that all type variables are closed *)
   List.iter2
-    (fun sdecl tdecl ->
+    (fun sdecl (tdecl, _shape) ->
       let decl = tdecl.typ_type in
        match Ctype.closed_type_decl decl with
          Some ty ->
@@ -981,18 +1015,18 @@ let transl_type_decl env rec_flag sdecl_list =
         raise (Error (loc, Separability err))
   in
   (* Compute the final environment with variance and immediacy *)
-  let final_env = add_types_to_env decls env in
+  let final_env = add_types_to_env decls shapes env in
   (* Check re-exportation *)
   List.iter2 (check_abbrev final_env) sdecl_list decls;
   (* Keep original declaration *)
   let final_decls =
     List.map2
-      (fun tdecl (_id2, decl) ->
+      (fun (tdecl, _shape) (_id2, decl) ->
         { tdecl with typ_type = decl }
       ) tdecls decls
   in
   (* Done *)
-  (final_decls, final_env)
+  (final_decls, final_env, shapes)
 
 (* Translating type extensions *)
 
@@ -1101,12 +1135,22 @@ let transl_extension_constructor ~scope env type_path type_params
       ext_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
     }
   in
+  let ext_cstrs =
     { ext_id = id;
       ext_name = sext.pext_name;
       ext_type = ext;
       ext_kind = kind;
       Typedtree.ext_loc = sext.pext_loc;
       Typedtree.ext_attributes = sext.pext_attributes; }
+  in
+  let shape =
+    let map =  match ext_cstrs.ext_kind with
+    | Text_decl (_, Cstr_record lbls, _) -> shape_map_labels lbls
+    | _ -> Shape.Map.empty
+    in
+    Shape.str ~uid:ext_cstrs.ext_type.ext_uid map
+ in
+  ext_cstrs, shape
 
 let transl_extension_constructor ~scope env type_path type_params
     typext_params priv sext =
@@ -1183,13 +1227,13 @@ let transl_type_extension extend env loc styext =
   (* Generalize types *)
   List.iter Ctype.generalize type_params;
   List.iter
-    (fun ext ->
+    (fun (ext, _shape) ->
        Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args;
        Option.iter Ctype.generalize ext.ext_type.ext_ret_type)
     constructors;
   (* Check that all type variables are closed *)
   List.iter
-    (fun ext ->
+    (fun (ext, _shape) ->
        match Ctype.closed_extension_constructor ext.ext_type with
          Some ty ->
            raise(Error(ext.ext_loc, Unbound_type_var_ext(ty, ext.ext_type)))
@@ -1197,7 +1241,7 @@ let transl_type_extension extend env loc styext =
     constructors;
   (* Check variances are correct *)
   List.iter
-    (fun ext->
+    (fun (ext, _shape) ->
        (* Note that [loc] here is distinct from [type_decl.type_loc], which
           makes the [loc] parameter to this function useful. [loc] is the
           location of the extension, while [type_decl] points to the original
@@ -1210,11 +1254,13 @@ let transl_type_extension extend env loc styext =
   (* Add extension constructors to the environment *)
   let newenv =
     List.fold_left
-      (fun env ext ->
+      (fun env (ext, shape) ->
          let rebind = is_rebind ext in
-         Env.add_extension ~check:true ~rebind ext.ext_id ext.ext_type env)
+         Env.add_extension ~check:true ~shape ~rebind
+          ext.ext_id ext.ext_type env)
       env constructors
   in
+  let constructors, shapes = List.split constructors in
   let tyext =
     { tyext_path = type_path;
       tyext_txt = styext.ptyext_path;
@@ -1224,7 +1270,7 @@ let transl_type_extension extend env loc styext =
       tyext_loc = styext.ptyext_loc;
       tyext_attributes = styext.ptyext_attributes; }
   in
-    (tyext, newenv)
+    (tyext, newenv, shapes)
 
 let transl_type_extension extend env loc styext =
   Builtin_attributes.warning_scope styext.ptyext_attributes
@@ -1234,7 +1280,7 @@ let transl_exception env sext =
   let scope = Ctype.create_scope () in
   reset_type_variables();
   Ctype.begin_def();
-  let ext =
+  let ext, shape =
     transl_extension_constructor ~scope env
       Predef.path_exn [] [] Asttypes.Public sext
   in
@@ -1250,13 +1296,13 @@ let transl_exception env sext =
   end;
   let rebind = is_rebind ext in
   let newenv =
-    Env.add_extension ~check:true ~rebind ext.ext_id ext.ext_type env
+    Env.add_extension ~check:true ~shape ~rebind ext.ext_id ext.ext_type env
   in
-  ext, newenv
+  ext, newenv, shape
 
 let transl_type_exception env t =
   Builtin_attributes.check_no_alert t.ptyexn_attributes;
-  let contructor, newenv =
+  let contructor, newenv, shape =
     Builtin_attributes.warning_scope t.ptyexn_attributes
       (fun () ->
          transl_exception env t.ptyexn_constructor
@@ -1264,7 +1310,7 @@ let transl_type_exception env t =
   in
   {tyexn_constructor = contructor;
    tyexn_loc = t.ptyexn_loc;
-   tyexn_attributes = t.ptyexn_attributes}, newenv
+   tyexn_attributes = t.ptyexn_attributes}, newenv, shape
 
 
 type native_repr_attribute =
diff --git a/src/ocaml/typing/typedecl.mli b/src/ocaml/typing/typedecl.mli
index 0fb68edf42..cc4cf3fc80 100644
--- a/src/ocaml/typing/typedecl.mli
+++ b/src/ocaml/typing/typedecl.mli
@@ -20,19 +20,19 @@ open Format
 
 val transl_type_decl:
     Env.t -> Asttypes.rec_flag -> Parsetree.type_declaration list ->
-    Typedtree.type_declaration list * Env.t
+    Typedtree.type_declaration list * Env.t * Shape.t list
 
 val transl_exception:
     Env.t -> Parsetree.extension_constructor ->
-    Typedtree.extension_constructor * Env.t
+    Typedtree.extension_constructor * Env.t * Shape.t
 
 val transl_type_exception:
     Env.t ->
-    Parsetree.type_exception -> Typedtree.type_exception * Env.t
+    Parsetree.type_exception -> Typedtree.type_exception * Env.t * Shape.t
 
 val transl_type_extension:
     bool -> Env.t -> Location.t -> Parsetree.type_extension ->
-    Typedtree.type_extension * Env.t
+    Typedtree.type_extension * Env.t * Shape.t list
 
 val transl_value_decl:
     Env.t -> Location.t ->
diff --git a/src/ocaml/typing/typedtree.ml b/src/ocaml/typing/typedtree.ml
index 19c3e15e83..6090907043 100644
--- a/src/ocaml/typing/typedtree.ml
+++ b/src/ocaml/typing/typedtree.ml
@@ -18,6 +18,8 @@
 open Asttypes
 open Types
 
+module Uid = Shape.Uid
+
 (* Value expressions for the core language *)
 
 type partial = Partial | Total
@@ -53,9 +55,9 @@ and pat_extra =
 and 'k pattern_desc =
   (* value patterns *)
   | Tpat_any : value pattern_desc
-  | Tpat_var : Ident.t * string loc -> value pattern_desc
+  | Tpat_var : Ident.t * string loc * Uid.t -> value pattern_desc
   | Tpat_alias :
-      value general_pattern * Ident.t * string loc -> value pattern_desc
+      value general_pattern * Ident.t * string loc * Uid.t -> value pattern_desc
   | Tpat_constant : constant -> value pattern_desc
   | Tpat_tuple : value general_pattern list -> value pattern_desc
   | Tpat_construct :
@@ -291,6 +293,7 @@ and module_binding =
     {
      mb_id: Ident.t option;
      mb_name: string option loc;
+     mb_uid: Uid.t;
      mb_presence: module_presence;
      mb_expr: module_expr;
      mb_attributes: attribute list;
@@ -370,6 +373,7 @@ and module_declaration =
     {
      md_id: Ident.t option;
      md_name: string option loc;
+     md_uid: Uid.t;
      md_presence: module_presence;
      md_type: module_type;
      md_attributes: attribute list;
@@ -380,6 +384,7 @@ and module_substitution =
     {
      ms_id: Ident.t;
      ms_name: string loc;
+     ms_uid: Uid.t;
      ms_manifest: Path.t;
      ms_txt: Longident.t loc;
      ms_attributes: attributes;
@@ -390,6 +395,7 @@ and module_type_declaration =
     {
      mtd_id: Ident.t;
      mtd_name: string loc;
+     mtd_uid: Uid.t;
      mtd_type: module_type option;
      mtd_attributes: attribute list;
      mtd_loc: Location.t;
@@ -512,6 +518,7 @@ and label_declaration =
     {
      ld_id: Ident.t;
      ld_name: string loc;
+     ld_uid: Uid.t;
      ld_mutable: mutable_flag;
      ld_type: core_type;
      ld_loc: Location.t;
@@ -522,6 +529,7 @@ and constructor_declaration =
     {
      cd_id: Ident.t;
      cd_name: string loc;
+     cd_uid: Uid.t;
      cd_vars: string loc list;
      cd_args: constructor_arguments;
      cd_res: core_type option;
@@ -675,7 +683,7 @@ type pattern_action =
 let shallow_iter_pattern_desc
   : type k . pattern_action -> k pattern_desc -> unit
   = fun f -> function
-  | Tpat_alias(p, _, _) -> f.f p
+  | Tpat_alias(p, _, _, _) -> f.f p
   | Tpat_tuple patl -> List.iter f.f patl
   | Tpat_construct(_, _, patl, _) -> List.iter f.f patl
   | Tpat_variant(_, pat, _) -> Option.iter f.f pat
@@ -695,8 +703,8 @@ type pattern_transformation =
 let shallow_map_pattern_desc
   : type k . pattern_transformation -> k pattern_desc -> k pattern_desc
   = fun f d -> match d with
-  | Tpat_alias (p1, id, s) ->
-      Tpat_alias (f.f p1, id, s)
+  | Tpat_alias (p1, id, s, uid) ->
+      Tpat_alias (f.f p1, id, s, uid)
   | Tpat_tuple pats ->
       Tpat_tuple (List.map f.f pats)
   | Tpat_record (lpats, closed) ->
@@ -757,11 +765,11 @@ let rec iter_bound_idents
   : type k . _ -> k general_pattern -> _
   = fun f pat ->
   match pat.pat_desc with
-  | Tpat_var (id,s) ->
-     f (id,s,pat.pat_type)
-  | Tpat_alias(p, id, s) ->
+  | Tpat_var (id, s, uid) ->
+     f (id,s,pat.pat_type, uid)
+  | Tpat_alias(p, id, s, uid) ->
       iter_bound_idents f p;
-      f (id,s,pat.pat_type)
+      f (id,s,pat.pat_type, uid)
   | Tpat_or(p1, _, _) ->
       (* Invariant : both arguments bind the same variables *)
       iter_bound_idents f p1
@@ -777,7 +785,7 @@ let rev_pat_bound_idents_full pat =
   !idents_full
 
 let rev_only_idents idents_full =
-  List.rev_map (fun (id,_,_) -> id) idents_full
+  List.rev_map (fun (id,_,_,_) -> id) idents_full
 
 let pat_bound_idents_full pat =
   List.rev (rev_pat_bound_idents_full pat)
@@ -796,19 +804,27 @@ let let_bound_idents_full bindings =
 let let_bound_idents pat =
   rev_only_idents (rev_let_bound_idents_full pat)
 
+let let_filter_bound bindings =
+  let decls = ref [] in
+  let add vb (_,_,_,uid) =
+    decls := (vb, uid) :: !decls
+  in
+  List.iter (fun vb -> iter_bound_idents (add vb) vb.vb_pat) bindings;
+  !decls
+
 let alpha_var env id = List.assoc id env
 
 let rec alpha_pat
   : type k . _ -> k general_pattern -> k general_pattern
   = fun env p -> match p.pat_desc with
-  | Tpat_var (id, s) -> (* note the ``Not_found'' case *)
+  | Tpat_var (id, s, uid) -> (* note the ``Not_found'' case *)
       {p with pat_desc =
-       try Tpat_var (alpha_var env id, s) with
+       try Tpat_var (alpha_var env id, s, uid) with
        | Not_found -> Tpat_any}
-  | Tpat_alias (p1, id, s) ->
+  | Tpat_alias (p1, id, s, uid) ->
       let new_p : k general_pattern =  alpha_pat env p1 in
       begin try
-        {p with pat_desc = Tpat_alias (new_p, alpha_var env id, s)}
+        {p with pat_desc = Tpat_alias (new_p, alpha_var env id, s, uid)}
       with
       | Not_found -> new_p
       end
diff --git a/src/ocaml/typing/typedtree.mli b/src/ocaml/typing/typedtree.mli
index fffc5186e4..5793afdd54 100644
--- a/src/ocaml/typing/typedtree.mli
+++ b/src/ocaml/typing/typedtree.mli
@@ -22,6 +22,7 @@
 *)
 
 open Asttypes
+module Uid = Shape.Uid
 
 (* Value expressions for the core language *)
 
@@ -75,10 +76,10 @@ and 'k pattern_desc =
   (* value patterns *)
   | Tpat_any : value pattern_desc
         (** _ *)
-  | Tpat_var : Ident.t * string loc -> value pattern_desc
+  | Tpat_var : Ident.t * string loc * Uid.t -> value pattern_desc
         (** x *)
   | Tpat_alias :
-      value general_pattern * Ident.t * string loc -> value pattern_desc
+      value general_pattern * Ident.t * string loc * Uid.t -> value pattern_desc
         (** P as a *)
   | Tpat_constant : constant -> value pattern_desc
         (** 1, 'a', "true", 1.0, 1l, 1L, 1n *)
@@ -437,6 +438,7 @@ and module_binding =
     {
      mb_id: Ident.t option;
      mb_name: string option loc;
+     mb_uid: Uid.t;
      mb_presence: Types.module_presence;
      mb_expr: module_expr;
      mb_attributes: attributes;
@@ -515,6 +517,7 @@ and module_declaration =
     {
      md_id: Ident.t option;
      md_name: string option loc;
+     md_uid: Uid.t;
      md_presence: Types.module_presence;
      md_type: module_type;
      md_attributes: attributes;
@@ -525,6 +528,7 @@ and module_substitution =
     {
      ms_id: Ident.t;
      ms_name: string loc;
+     ms_uid: Uid.t;
      ms_manifest: Path.t;
      ms_txt: Longident.t loc;
      ms_attributes: attributes;
@@ -535,6 +539,7 @@ and module_type_declaration =
     {
      mtd_id: Ident.t;
      mtd_name: string loc;
+     mtd_uid: Uid.t;
      mtd_type: module_type option;
      mtd_attributes: attributes;
      mtd_loc: Location.t;
@@ -659,6 +664,7 @@ and label_declaration =
     {
      ld_id: Ident.t;
      ld_name: string loc;
+     ld_uid: Uid.t;
      ld_mutable: mutable_flag;
      ld_type: core_type;
      ld_loc: Location.t;
@@ -669,6 +675,7 @@ and constructor_declaration =
     {
      cd_id: Ident.t;
      cd_name: string loc;
+     cd_uid: Uid.t;
      cd_vars: string loc list;
      cd_args: constructor_arguments;
      cd_res: core_type option;
@@ -816,7 +823,10 @@ val exists_pattern: (pattern -> bool) -> pattern -> bool
 
 val let_bound_idents: value_binding list -> Ident.t list
 val let_bound_idents_full:
-    value_binding list -> (Ident.t * string loc * Types.type_expr) list
+    value_binding list ->
+    (Ident.t * string loc * Types.type_expr * Types.Uid.t) list
+val let_filter_bound: value_binding list ->  (value_binding * Uid.t) list
+
 
 (** Alpha conversion of patterns *)
 val alpha_pat:
@@ -827,7 +837,8 @@ val mkloc: 'a -> Location.t -> 'a Asttypes.loc
 
 val pat_bound_idents: 'k general_pattern -> Ident.t list
 val pat_bound_idents_full:
-  'k general_pattern -> (Ident.t * string loc * Types.type_expr) list
+  'k general_pattern ->
+  (Ident.t * string loc * Types.type_expr * Types.Uid.t) list
 
 (** Splits an or pattern into its value (left) and exception (right) parts. *)
 val split_pattern:
diff --git a/src/ocaml/typing/typemod.ml b/src/ocaml/typing/typemod.ml
index 7020d7d3c1..8727c9e956 100644
--- a/src/ocaml/typing/typemod.ml
+++ b/src/ocaml/typing/typemod.ml
@@ -1051,7 +1051,7 @@ end = struct
     let open Sig_component_kind in
     match component with
     | Value -> names.values
-    | Type -> names.types
+    | Type | Label | Constructor -> names.types
     | Module -> names.modules
     | Module_type -> names.modtypes
     | Extension_constructor -> names.typexts
@@ -1388,7 +1388,6 @@ and transl_signature ?(keep_warnings = false) env sg =
               Typedecl.transl_value_decl env item.psig_loc sdesc
             in
             Signature_names.check_value names tdesc.val_loc tdesc.val_id;
-            Env.register_uid tdesc.val_val.val_uid tdesc.val_loc;
             res
           with
           | (tdesc, newenv) ->
@@ -1402,17 +1401,15 @@ and transl_signature ?(keep_warnings = false) env sg =
           end
         | Psig_type (rec_flag, sdecls) ->
           begin match
-            let (decls, _) as res =
+            let (decls, _, _) as res =
               Typedecl.transl_type_decl env rec_flag sdecls
             in
             List.iter (fun td ->
               Signature_names.check_type names td.typ_loc td.typ_id;
-              if not (Btype.is_row_name (Ident.name td.typ_id)) then
-                Env.register_uid td.typ_type.type_uid td.typ_loc
             ) decls;
             res
           with
-          | (decls, newenv) ->
+          | (decls, newenv, _) ->
             let newenv = Env.update_short_paths newenv in
             let (trem, rem, final_env) = transl_sig newenv srem in
             let sg =
@@ -1437,7 +1434,7 @@ and transl_signature ?(keep_warnings = false) env sg =
                    once we have nice error messages there. *)
                 raise (Error (td.ptype_loc, env, Invalid_type_subst_rhs))
             ) sdecls;
-            let (decls, _) as res =
+            let (decls, _, _) as res =
               Typedecl.transl_type_decl env Nonrecursive sdecls
             in
             List.iter (fun td ->
@@ -1453,12 +1450,11 @@ and transl_signature ?(keep_warnings = false) env sg =
                   in
                   Some (`Substituted_away subst)
               in
-              Signature_names.check_type ?info names td.typ_loc td.typ_id;
-              Env.register_uid td.typ_type.type_uid td.typ_loc
+              Signature_names.check_type ?info names td.typ_loc td.typ_id
             ) decls;
             res
           with
-          | (decls, newenv) ->
+          | (decls, newenv, _) ->
             let (trem, rem, final_env) = transl_sig newenv srem in
             let sg = rem
             in
@@ -1471,17 +1467,16 @@ and transl_signature ?(keep_warnings = false) env sg =
           end
         | Psig_typext styext ->
           begin match
-            let (tyext, _) as res =
+            let (tyext, _, _) as res =
               Typedecl.transl_type_extension false env item.psig_loc styext
             in
             let constructors = tyext.tyext_constructors in
             List.iter (fun ext ->
-              Signature_names.check_typext names ext.ext_loc ext.ext_id;
-              Env.register_uid ext.ext_type.ext_uid ext.ext_loc
+              Signature_names.check_typext names ext.ext_loc ext.ext_id
             ) constructors;
             res, constructors
           with
-          | (tyext, newenv), constructors ->
+          | (tyext, newenv, _), constructors ->
             let (trem, rem, final_env) = transl_sig newenv srem in
               mksig (Tsig_typext tyext) env loc :: trem,
               map_ext (fun es ext ->
@@ -1494,16 +1489,13 @@ and transl_signature ?(keep_warnings = false) env sg =
           end
         | Psig_exception sext ->
           begin match
-            let (ext, _) as res = Typedecl.transl_type_exception env sext in
+            let (ext, _, _) as res = Typedecl.transl_type_exception env sext in
             let constructor = ext.tyexn_constructor in
             Signature_names.check_typext names constructor.ext_loc
               constructor.ext_id;
-            Env.register_uid
-              constructor.ext_type.ext_uid
-              constructor.ext_loc;
             res, constructor
           with
-          | (ext, newenv), constructor ->
+          | (ext, newenv, _), constructor ->
             let (trem, rem, final_env) = transl_sig newenv srem in
             mksig (Tsig_exception ext) env loc :: trem,
             Sig_typext(constructor.ext_id,
@@ -1517,6 +1509,7 @@ and transl_signature ?(keep_warnings = false) env sg =
           end
         | Psig_module pmd ->
           let scope = Ctype.create_scope () in
+          let md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in
           begin match
             let tmty =
               Builtin_attributes.warning_scope pmd.pmd_attributes
@@ -1534,7 +1527,7 @@ and transl_signature ?(keep_warnings = false) env sg =
                 md_type=tmty.mty_type;
                 md_attributes=pmd.pmd_attributes;
                 md_loc=pmd.pmd_loc;
-                md_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+                md_uid;
               }
               in
               let id, newenv =
@@ -1542,15 +1535,14 @@ and transl_signature ?(keep_warnings = false) env sg =
               in
               let newenv = Env.update_short_paths newenv in
               Signature_names.check_module names pmd.pmd_name.loc id;
-              Env.register_uid md.md_uid md.md_loc;
               let sig_item = Sig_module(id, pres, md, Trec_not, Exported) in
               Some id, pres, newenv, Some sig_item, tmty
           with
           | (id, pres, newenv, sig_item, tmty) ->
             let (trem, rem, final_env) = transl_sig newenv srem in
             mksig (Tsig_module {md_id=id; md_name=pmd.pmd_name;
-                                md_presence=pres; md_type=tmty;
-                                md_loc=pmd.pmd_loc;
+                                md_uid; md_presence=pres;
+                                md_type=tmty; md_loc=pmd.pmd_loc;
                                 md_attributes=pmd.pmd_attributes})
               env loc :: trem,
             (match sig_item with None -> rem | Some i -> i :: rem),
@@ -1589,8 +1581,7 @@ and transl_signature ?(keep_warnings = false) env sg =
               `Substituted_away (Subst.add_module id path Subst.identity)
             in
             Signature_names.check_module ~info names pms.pms_name.loc id;
-            Env.register_uid md.md_uid md.md_loc;
-            (newenv, Tsig_modsubst {ms_id=id; ms_name=pms.pms_name;
+            (newenv, Tsig_modsubst {ms_id=id; ms_name=pms.pms_name; ms_uid=md.md_uid;
                                     ms_manifest=path; ms_txt=pms.pms_manifest;
                                     ms_loc=pms.pms_loc;
                                     ms_attributes=pms.pms_attributes})
@@ -1613,9 +1604,8 @@ and transl_signature ?(keep_warnings = false) env sg =
                 | Some id -> Some (id, md, uid)
               ) tdecls
             in
-            List.iter (fun (id, md, uid) ->
+            List.iter (fun (id, md, _uid) ->
               Signature_names.check_module names md.md_loc id;
-              Env.register_uid uid md.md_loc
             ) decls;
             (tdecls, decls, newenv)
           with
@@ -1640,7 +1630,6 @@ and transl_signature ?(keep_warnings = false) env sg =
           begin match transl_modtype_decl env pmtd with
           | newenv, mtd, decl ->
             Signature_names.check_modtype names pmtd.pmtd_loc mtd.mtd_id;
-            Env.register_uid decl.mtd_uid mtd.mtd_loc;
             let (trem, rem, final_env) = transl_sig newenv srem in
             mksig (Tsig_modtype mtd) env loc :: trem,
             Sig_modtype (mtd.mtd_id, decl, Exported) :: rem,
@@ -1651,7 +1640,7 @@ and transl_signature ?(keep_warnings = false) env sg =
           end
         | Psig_modtypesubst pmtd ->
           begin match transl_modtype_decl env pmtd with
-          | newenv, mtd, decl ->
+          | newenv, mtd, _decl ->
             let info =
               let mty = match mtd.mtd_type with
                 | Some tmty -> tmty.mty_type
@@ -1665,7 +1654,6 @@ and transl_signature ?(keep_warnings = false) env sg =
               | _ -> `Unpackable_modtype_substituted_away (mtd.mtd_id,subst)
             in
             Signature_names.check_modtype ~info names pmtd.pmtd_loc mtd.mtd_id;
-            Env.register_uid decl.mtd_uid mtd.mtd_loc;
             let (trem, rem, final_env) = transl_sig newenv srem in
             mksig (Tsig_modtypesubst mtd) env loc :: trem,
             rem,
@@ -1726,7 +1714,6 @@ and transl_signature ?(keep_warnings = false) env sg =
               Signature_names.check_class names loc cls.cls_id;
               Signature_names.check_class_type names loc cls.cls_ty_id;
               Signature_names.check_type names loc cls.cls_typesharp_id;
-              Env.register_uid cls.cls_decl.cty_uid cls.cls_decl.cty_loc;
             ) classes;
             res
           with
@@ -1762,9 +1749,6 @@ and transl_signature ?(keep_warnings = false) env sg =
               Signature_names.check_class_type names loc decl.clsty_ty_id;
               Signature_names.check_type names loc decl.clsty_obj_id;
               Signature_names.check_type names loc decl.clsty_typesharp_id;
-              Env.register_uid
-                decl.clsty_ty_decl.clty_uid
-                decl.clsty_ty_decl.clty_loc;
             ) classes;
             res
           with
@@ -1834,6 +1818,7 @@ and transl_modtype_decl_aux env
     {
      mtd_id=id;
      mtd_name=pmtd_name;
+     mtd_uid=decl.mtd_uid;
      mtd_type=tmty;
      mtd_attributes=pmtd_attributes;
      mtd_loc=pmtd_loc;
@@ -1916,11 +1901,11 @@ and transl_recmodule_modtypes env sdecls =
     List.map2 (fun pmd (id_shape, id_loc, md, mty) ->
       let tmd =
         {md_id=Option.map fst id_shape; md_name=id_loc; md_type=mty;
-         md_presence=Mp_present;
+         md_uid=md.Types.md_uid; md_presence=Mp_present;
          md_loc=pmd.pmd_loc;
          md_attributes=pmd.pmd_attributes}
       in
-      tmd, md.md_uid, Option.map snd id_shape
+      tmd, md.Types.md_uid, Option.map snd id_shape
     ) sdecls dcl2
   in
   (dcl2, env2)
@@ -2110,6 +2095,7 @@ let check_recmodule_inclusion env bindings =
           {
             mb_id = id;
             mb_name = name;
+            mb_uid = uid;
             mb_presence = Mp_present;
             mb_expr = modl';
             mb_attributes = attrs;
@@ -2626,10 +2612,9 @@ and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body ancho
            will be marked as being used during the signature inclusion test. *)
         let items, shape_map =
           List.fold_left
-            (fun (acc, shape_map) (id, { Asttypes.loc; _ }, _typ)->
+            (fun (acc, shape_map) (id, { Asttypes.loc; _ }, _typ, _uid)->
               Signature_names.check_value names loc id;
               let vd =  Env.find_value (Pident id) newenv in
-              Env.register_uid vd.val_uid vd.val_loc;
               Sig_value(id, vd, Exported) :: acc,
               Shape.Map.add_value shape_map id vd.val_uid
             )
@@ -2643,13 +2628,14 @@ and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body ancho
     | Pstr_primitive sdesc ->
         let (desc, newenv) = Typedecl.transl_value_decl env loc sdesc in
         Signature_names.check_value names desc.val_loc desc.val_id;
-        Env.register_uid desc.val_val.val_uid desc.val_val.val_loc;
         Tstr_primitive desc,
         [Sig_value(desc.val_id, desc.val_val, Exported)],
         Shape.Map.add_value shape_map desc.val_id desc.val_val.val_uid,
         newenv
     | Pstr_type (rec_flag, sdecls) ->
-        let (decls, newenv) = Typedecl.transl_type_decl env rec_flag sdecls in
+        let (decls, newenv, shapes) =
+          Typedecl.transl_type_decl env rec_flag sdecls
+        in
         let newenv = Env.update_short_paths newenv in
         List.iter
           Signature_names.(fun td -> check_type names td.typ_loc td.typ_id)
@@ -2658,32 +2644,26 @@ and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body ancho
           (fun rs info -> Sig_type(info.typ_id, info.typ_type, rs, Exported))
           decls []
         in
-        let shape_map = List.fold_left
-          (fun shape_map -> function
-            | Sig_type (id, vd, _, _) ->
-              if not (Btype.is_row_name (Ident.name id)) then begin
-                Env.register_uid vd.type_uid vd.type_loc;
-                Shape.Map.add_type shape_map id vd.type_uid
-              end else shape_map
-            | _ -> assert false
-          )
+        let shape_map = List.fold_left2
+          (fun map { typ_id; _} shape ->
+            Shape.Map.add_type map typ_id shape)
           shape_map
-          items
+          decls
+          shapes
         in
         Tstr_type (rec_flag, decls),
         items,
         shape_map,
         enrich_type_decls anchor decls env newenv
     | Pstr_typext styext ->
-        let (tyext, newenv) =
+        let (tyext, newenv, shapes) =
           Typedecl.transl_type_extension true env loc styext
         in
         let constructors = tyext.tyext_constructors in
-        let shape_map = List.fold_left (fun shape_map ext ->
+        let shape_map = List.fold_left2 (fun shape_map ext shape ->
             Signature_names.check_typext names ext.ext_loc ext.ext_id;
-            Env.register_uid ext.ext_type.ext_uid ext.ext_loc;
-            Shape.Map.add_extcons shape_map ext.ext_id ext.ext_type.ext_uid
-          ) shape_map constructors
+            Shape.Map.add_extcons shape_map ext.ext_id shape
+          ) shape_map constructors shapes
         in
         (Tstr_typext tyext,
          map_ext
@@ -2692,13 +2672,10 @@ and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body ancho
         shape_map,
          newenv)
     | Pstr_exception sext ->
-        let (ext, newenv) = Typedecl.transl_type_exception env sext in
+        let (ext, newenv, shape) = Typedecl.transl_type_exception env sext in
         let constructor = ext.tyexn_constructor in
         Signature_names.check_typext names constructor.ext_loc
           constructor.ext_id;
-        Env.register_uid
-          constructor.ext_type.ext_uid
-          constructor.ext_loc;
         Tstr_exception ext,
         [Sig_typext(constructor.ext_id,
                     constructor.ext_type,
@@ -2706,7 +2683,7 @@ and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body ancho
                     Exported)],
         Shape.Map.add_extcons shape_map
           constructor.ext_id
-          constructor.ext_type.ext_uid,
+          shape,
         newenv
     | Pstr_module {pmb_name = name; pmb_expr = smodl; pmb_attributes = attrs;
                    pmb_loc;
@@ -2733,8 +2710,11 @@ and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body ancho
             md_uid;
           }
         in
-        let md_shape = Shape.set_uid_if_none md_shape md_uid in
-        Env.register_uid md_uid pmb_loc;
+        let md_shape =
+          match modl.mod_type with
+          | Mty_alias _path -> Shape.alias ~uid:md_uid md_shape
+          | _ -> Shape.set_uid_if_none md_shape md_uid
+        in
         (*prerr_endline (Ident.unique_toplevel_name id);*)
         Mtype.lower_nongen outer_scope md.md_type;
         let id, newenv, sg =
@@ -2758,8 +2738,9 @@ and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body ancho
           | Some id -> Shape.Map.add_module shape_map id md_shape
           | None -> shape_map
         in
-        Tstr_module {mb_id=id; mb_name=name; mb_expr=modl;
-                     mb_presence=pres; mb_attributes=attrs;  mb_loc=pmb_loc; },
+        Tstr_module {mb_id=id; mb_name=name; mb_uid = md.md_uid;
+                     mb_expr=modl; mb_presence=pres; mb_attributes=attrs;
+                     mb_loc=pmb_loc; },
         sg,
         shape_map,
         newenv
@@ -2834,8 +2815,7 @@ and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body ancho
           ) bindings2
         in
         let shape_map =
-          List.fold_left (fun map (id, mb, uid, shape) ->
-            Env.register_uid uid mb.mb_loc;
+          List.fold_left (fun map (id, _mb, _uid, shape) ->
             Shape.Map.add_module map id shape
           ) shape_map mbs
         in
@@ -2855,7 +2835,6 @@ and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body ancho
         let newenv, mtd, decl = transl_modtype_decl env pmtd in
         let newenv = Env.update_short_paths newenv in
         Signature_names.check_modtype names pmtd.pmtd_loc mtd.mtd_id;
-        Env.register_uid decl.mtd_uid decl.mtd_loc;
         let id = mtd.mtd_id in
         let map = Shape.Map.add_module_type shape_map id decl.mtd_uid in
         Tstr_modtype mtd, [Sig_modtype (id, decl, Exported)], map, newenv
@@ -2875,12 +2854,13 @@ and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body ancho
             Signature_names.check_class_type names loc cls.cls_ty_id;
             Signature_names.check_type names loc cls.cls_obj_id;
             Signature_names.check_type names loc cls.cls_typesharp_id;
-            Env.register_uid cls.cls_decl.cty_uid loc;
-            let map f id acc = f acc id cls.cls_decl.cty_uid in
+            let uid = cls.cls_decl.cty_uid in
+            let map f id acc = f acc id uid in
+            let map_t f id acc = f acc id (Shape.str ~uid Shape.Map.empty) in
             map Shape.Map.add_class cls.cls_id acc
             |> map Shape.Map.add_class_type cls.cls_ty_id
-            |> map Shape.Map.add_type cls.cls_obj_id
-            |> map Shape.Map.add_type cls.cls_typesharp_id
+            |> map_t Shape.Map.add_type cls.cls_obj_id
+            |> map_t Shape.Map.add_type cls.cls_typesharp_id
           ) shape_map classes
         in
         Tstr_class
@@ -2907,11 +2887,12 @@ and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body ancho
             Signature_names.check_class_type names loc decl.clsty_ty_id;
             Signature_names.check_type names loc decl.clsty_obj_id;
             Signature_names.check_type names loc decl.clsty_typesharp_id;
-            Env.register_uid decl.clsty_ty_decl.clty_uid loc;
-            let map f id acc = f acc id decl.clsty_ty_decl.clty_uid in
+            let uid = decl.clsty_ty_decl.clty_uid in
+            let map_t f id acc = f acc id (Shape.str ~uid Shape.Map.empty) in
+            let map f id acc = f acc id uid in
             map Shape.Map.add_class_type decl.clsty_ty_id acc
-            |> map Shape.Map.add_type decl.clsty_obj_id
-            |> map Shape.Map.add_type decl.clsty_typesharp_id
+            |> map_t Shape.Map.add_type decl.clsty_obj_id
+            |> map_t Shape.Map.add_type decl.clsty_typesharp_id
           ) shape_map classes
         in
         Tstr_class_type
@@ -3185,7 +3166,7 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
       let simple_sg = Signature_names.simplify finalenv names sg in
       if !Clflags.print_types then begin
         Typecore.force_delayed_checks ();
-        let shape = Shape.local_reduce shape in
+        let shape = Shape.toplevel_local_reduce shape in
         Printtyp.wrap_printing_env ~error:false initial_env
           (fun () -> fprintf std_formatter "%a@."
               (Printtyp.printed_signature sourcefile) simple_sg
@@ -3214,7 +3195,7 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
           (* It is important to run these checks after the inclusion test above,
              so that value declarations which are not used internally but
              exported are not reported as being unused. *)
-          let shape = Shape.local_reduce shape in
+          let shape = Shape.toplevel_local_reduce shape in
           let annots = Cmt_format.Implementation str in
           Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename
             annots (Some sourcefile) initial_env None (Some shape);
@@ -3237,7 +3218,7 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
              the value being exported. We can still capture unused
              declarations like "let x = true;; let x = 1;;", because in this
              case, the inferred signature contains only the last declaration. *)
-          let shape = Shape.local_reduce shape in
+          let shape = Shape.toplevel_local_reduce shape in
           if not !Clflags.dont_write_files then begin
             let alerts = Builtin_attributes.alerts_of_str ast in
             let cmi =
diff --git a/src/ocaml/typing/typemod.mli b/src/ocaml/typing/typemod.mli
index 6f4075882b..46705e7609 100644
--- a/src/ocaml/typing/typemod.mli
+++ b/src/ocaml/typing/typemod.mli
@@ -76,6 +76,8 @@ module Sig_component_kind : sig
   type t =
     | Value
     | Type
+    | Constructor
+    | Label
     | Module
     | Module_type
     | Extension_constructor
diff --git a/src/ocaml/typing/untypeast.ml b/src/ocaml/typing/untypeast.ml
index a3fbeaf9d1..642758d10d 100644
--- a/src/ocaml/typing/untypeast.ml
+++ b/src/ocaml/typing/untypeast.ml
@@ -298,7 +298,8 @@ let pattern : type k . _ -> k T.general_pattern -> _ = fun sub pat ->
   match pat with
       { pat_extra=[Tpat_unpack, loc, _attrs]; pat_desc = Tpat_any; _ } ->
         Ppat_unpack { txt = None; loc  }
-    | { pat_extra=[Tpat_unpack, _, _attrs]; pat_desc = Tpat_var (_,name); _ } ->
+    | { pat_extra=[Tpat_unpack, _, _attrs];
+        pat_desc = Tpat_var (_,name, _); _ } ->
         Ppat_unpack { name with txt = Some name.txt }
     | { pat_extra=[Tpat_type (_path, lid), _, _attrs]; _ } ->
         Ppat_type (map_loc sub lid)
@@ -308,7 +309,7 @@ let pattern : type k . _ -> k T.general_pattern -> _ = fun sub pat ->
     | _ ->
     match pat.pat_desc with
       Tpat_any -> Ppat_any
-    | Tpat_var (id, name) ->
+    | Tpat_var (id, name, _) ->
         begin
           match (Ident.name id).[0] with
             'A'..'Z' ->
@@ -321,11 +322,11 @@ let pattern : type k . _ -> k T.general_pattern -> _ = fun sub pat ->
        The compiler transforms (x:t) into (_ as x : t).
        This avoids transforming a warning 27 into a 26.
      *)
-    | Tpat_alias ({pat_desc = Tpat_any; pat_loc}, _id, name)
+    | Tpat_alias ({pat_desc = Tpat_any; pat_loc}, _id, name, _)
          when pat_loc = pat.pat_loc ->
        Ppat_var name
 
-    | Tpat_alias (pat, _id, name) ->
+    | Tpat_alias (pat, _id, name, _) ->
         Ppat_alias (sub.pat sub pat, name)
     | Tpat_constant cst -> Ppat_constant (constant cst)
     | Tpat_tuple list ->
@@ -789,7 +790,7 @@ let core_type sub ct =
 
 let class_structure sub cs =
   let rec remove_self = function
-    | { pat_desc = Tpat_alias (p, id, _s) }
+    | { pat_desc = Tpat_alias (p, id, _s, _) }
       when string_is_prefix "selfpat-" (Ident.name id) ->
         remove_self p
     | p -> p
@@ -819,7 +820,7 @@ let object_field sub {of_loc; of_desc; of_attributes;} =
   Of.mk ~loc ~attrs desc
 
 and is_self_pat = function
-  | { pat_desc = Tpat_alias(_pat, id, _) } ->
+  | { pat_desc = Tpat_alias(_pat, id, _, _) } ->
       string_is_prefix "self-" (Ident.name id)
   | _ -> false
 
diff --git a/src/ocaml/utils/clflags.ml b/src/ocaml/utils/clflags.ml
index 2c4bd6631e..ab73106101 100644
--- a/src/ocaml/utils/clflags.ml
+++ b/src/ocaml/utils/clflags.ml
@@ -25,6 +25,7 @@ let open_modules        = ref []
 
 let annotations         = ref false
 let binary_annotations  = ref true
+let store_usage_index   = ref true
 let print_types         = ref false
 let native_code         = ref false
 let error_size          = ref 500
diff --git a/src/ocaml/utils/clflags.mli b/src/ocaml/utils/clflags.mli
index e06b7a4c6b..f26746c1ea 100644
--- a/src/ocaml/utils/clflags.mli
+++ b/src/ocaml/utils/clflags.mli
@@ -23,6 +23,7 @@ val open_modules         : string list ref
     Ignored by merlin but kept for compatibility with upstream code. *)
 val annotations          : bool ref
 val binary_annotations   : bool ref
+val store_usage_index    : bool ref
 val print_types          : bool ref
 val native_code          : bool ref
 val dont_write_files     : bool ref

From 8b99e2487d9027a00bc2b9b0ed2fd656d44942f3 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Fri, 29 Sep 2023 14:03:28 +0200
Subject: [PATCH 03/58] Use new iterator to perform locate and occurrences

- enable or disable aliases traversal
- mark approximated results as such
- improve constr / labels cases + traverse aliases
---
 src/analysis/ast_iterators.ml                 |  58 ++++
 src/analysis/completion.mli                   |   2 +-
 src/analysis/index_format.ml                  | 107 +++++++
 src/analysis/locate.ml                        | 270 +++++++++++-------
 src/analysis/locate.mli                       |  37 ++-
 src/analysis/misc_utils.ml                    |  25 ++
 src/analysis/misc_utils.mli                   |   3 +
 src/analysis/namespace.ml                     |  24 ++
 src/analysis/namespace.mli                    |  14 +
 src/analysis/namespaced_path.ml               | 133 ---------
 src/analysis/namespaced_path.mli              |  49 ----
 src/analysis/occurrences.ml                   | 170 +++++++++++
 src/frontend/query_commands.ml                |  93 +++---
 src/ocaml/typing/cmt_format.mli               |   8 +
 src/ocaml/typing/shape.ml                     |  13 +-
 src/ocaml/typing/shape.mli                    |   6 +-
 src/ocaml/typing/typecore.ml                  |   6 +-
 src/utils/std.ml                              |   4 +-
 tests/test-dirs/document/issue1513.t          |   8 +-
 tests/test-dirs/environment_on_open.t/run.t   |   2 +-
 tests/test-dirs/locate-type.t/run.t           |   6 +-
 .../locate/context-detection/cd-field.t/run.t |   6 +-
 .../cd-from_a_pattern.t/run.t                 |   2 +-
 .../locate/context-detection/cd-label.t/run.t |   6 +-
 .../locate/context-detection/cd-test.t/run.t  |  18 +-
 .../locate/functors/f-all_local.t/run.t       |   4 +-
 .../functors/f-from_application.t/run.t       |   6 +-
 .../locate/functors/f-generative.t/run.t      |   2 +-
 .../functors/f-missed_shadowing.t/run.t       |   2 +-
 .../functors/f-nested_applications.t/run.t    |  10 +-
 .../test-dirs/locate/functors/f-test-ml-mli.t |   4 +-
 tests/test-dirs/locate/includes.t/run.t       |   4 +-
 tests/test-dirs/locate/issue1199.t            |   2 +-
 tests/test-dirs/locate/issue1424.t            |   2 +-
 tests/test-dirs/locate/issue1667.t            |   6 +-
 tests/test-dirs/locate/issue802.t/run.t       |   6 +-
 tests/test-dirs/locate/issue845.t/run.t       |   4 +-
 tests/test-dirs/locate/l-413-features.t       |   4 +-
 tests/test-dirs/locate/local-build-scheme.t   |   2 +-
 tests/test-dirs/locate/local-locate.t         |  17 ++
 tests/test-dirs/locate/locate-constrs.t       |   4 +-
 tests/test-dirs/locate/module-aliases.t/run.t |   8 +-
 tests/test-dirs/locate/module-decl-aliases.t  |   8 +-
 .../locate/non-local/ignore-kept-locs.t/run.t |  13 +-
 .../locate/non-local/preference.t/run.t       |   6 +-
 .../reconstruct-identifier/off_by_one.t/run.t |   2 +-
 tests/test-dirs/locate/sig-substs.t/run.t     |   4 +-
 tests/test-dirs/locate/without-implem.t       |   2 +-
 tests/test-dirs/occurrences/issue1404.t       |   2 +-
 49 files changed, 748 insertions(+), 446 deletions(-)
 create mode 100644 src/analysis/ast_iterators.ml
 create mode 100644 src/analysis/index_format.ml
 create mode 100644 src/analysis/namespace.ml
 create mode 100644 src/analysis/namespace.mli
 delete mode 100644 src/analysis/namespaced_path.ml
 delete mode 100644 src/analysis/namespaced_path.mli
 create mode 100644 src/analysis/occurrences.ml
 create mode 100644 tests/test-dirs/locate/local-locate.t

diff --git a/src/analysis/ast_iterators.ml b/src/analysis/ast_iterators.ml
new file mode 100644
index 0000000000..dd2d0a3fc6
--- /dev/null
+++ b/src/analysis/ast_iterators.ml
@@ -0,0 +1,58 @@
+open Std
+open Typedtree
+
+let {Logger. log} = Logger.for_section "iterators"
+
+(* The compiler contains an iterator that aims to gather definitions but
+ignores local values like let-in expressions and local type definition. To
+provide occurrences in the active buffer we extend the compiler's iterator with
+these cases. *)
+let iter_on_defs ~uid_to_locs_tbl =
+  let log = log ~title:"iter_on_defs" in
+  let register_uid uid fragment =
+    let loc = Misc_utils.loc_of_decl ~uid fragment in
+    Option.iter loc ~f:(fun loc ->
+      Types.Uid.Tbl.add uid_to_locs_tbl uid loc)
+  in
+  let iter_decl = Cmt_format.iter_on_declarations ~f:register_uid in
+  let register_uid uid loc =
+    Types.Uid.Tbl.add uid_to_locs_tbl uid loc
+  in
+  { iter_decl with
+    expr = (fun sub ({ exp_extra; exp_env; _ } as expr) ->
+      List.iter exp_extra ~f:(fun (exp_extra, _loc, _attr) ->
+        match exp_extra with
+        | Texp_newtype' (typ_id, typ_name) ->
+          log "Found definition %s (%a)\n%!" typ_name.txt
+            Logger.fmt (fun fmt -> Location.print_loc fmt typ_name.loc);
+          let decl = Env.find_type (Path.Pident typ_id) exp_env in
+          register_uid decl.type_uid typ_name;
+          ()
+        | _ -> ());
+      iter_decl.expr sub expr);
+  }
+
+let build_uid_to_locs_tbl ~(local_defs : Mtyper.typedtree) () =
+  let uid_to_locs_tbl : string Location.loc Types.Uid.Tbl.t =
+    Types.Uid.Tbl.create 64
+  in
+  let iter = iter_on_defs ~uid_to_locs_tbl in
+  begin match local_defs with
+  | `Interface sign ->
+    iter.signature iter sign
+  | `Implementation str ->
+    iter.structure iter str end;
+  uid_to_locs_tbl
+
+let index_usages  ~(local_defs : Mtyper.typedtree) () =
+  let index = ref [] in
+  begin match local_defs with
+  | `Interface signature ->
+    let iter = Cmt_format.iter_on_usages ~index in
+    iter.signature iter signature
+  | `Implementation structure ->
+    let iter = Cmt_format.iter_on_usages ~index in
+    iter.structure iter structure end;
+  !index
+
+
diff --git a/src/analysis/completion.mli b/src/analysis/completion.mli
index 8cc348526d..74e68e6971 100644
--- a/src/analysis/completion.mli
+++ b/src/analysis/completion.mli
@@ -52,7 +52,7 @@ val map_entry : ('a -> 'b) ->
 
 val branch_complete
   :  Mconfig.t
-  -> ?get_doc:([> `Completion_entry of Namespaced_path.Namespace.t
+  -> ?get_doc:([> `Completion_entry of Namespace.t
                 * Path.t * Location.t ] -> [> `Found of string ])
   -> ?target_type:Types.type_expr
   -> ?kinds:Compl.kind list
diff --git a/src/analysis/index_format.ml b/src/analysis/index_format.ml
new file mode 100644
index 0000000000..45502fa4ff
--- /dev/null
+++ b/src/analysis/index_format.ml
@@ -0,0 +1,107 @@
+module Lid : Set.OrderedType with type t = Longident.t Location.loc = struct
+  type t = Longident.t Location.loc
+
+  let compare_pos (p1 : Lexing.position) (p2 : Lexing.position) =
+    match String.compare p1.pos_fname p2.pos_fname with
+    | 0 -> Int.compare p1.pos_cnum p2.pos_cnum
+    | n -> n
+
+  let compare (t1 : t) (t2 : t) =
+    (* TODO CHECK...*)
+    match compare_pos t1.loc.loc_start t2.loc.loc_start with
+    | 0 -> compare_pos t1.loc.loc_end t2.loc.loc_end
+    | n -> n
+end
+
+module LidSet = Set.Make (Lid)
+
+(** [add tbl uid locs] adds a binding of [uid] to the locations [locs]. If this key is
+    already present the locations are merged. *)
+let add tbl uid locs =
+  try
+    let locations = Hashtbl.find tbl uid in
+    Hashtbl.replace tbl uid (LidSet.union locs locations)
+  with Not_found -> Hashtbl.add tbl uid locs
+
+type payload = {
+  defs : (Shape.Uid.t, LidSet.t) Hashtbl.t;
+  partials : (Shape.t, LidSet.t) Hashtbl.t;
+  unreduced : (Shape.t * Longident.t Location.loc) list;
+  load_path : string list;
+  cu_shape : (string, Shape.t) Hashtbl.t;
+}
+
+type file_format = V1 of payload
+
+let pp_partials (fmt : Format.formatter)
+    (partials : (Shape.t, LidSet.t) Hashtbl.t) =
+  Format.fprintf fmt "{@[";
+  Hashtbl.iter
+    (fun shape locs ->
+      Format.fprintf fmt "@[<hov 2>shape: %a; locs:@ @[<v>%a@]@]@;" Shape.print
+        shape
+        (Format.pp_print_list
+           ~pp_sep:(fun fmt () -> Format.fprintf fmt ";@;")
+           (fun fmt { Location.txt; loc } ->
+             Format.fprintf fmt "%S: %a"
+               (try Longident.flatten txt |> String.concat "." with _ -> "<?>")
+               Location.print_loc loc))
+        (LidSet.elements locs))
+    partials;
+  Format.fprintf fmt "@]}"
+
+let pp_unreduced (fmt : Format.formatter)
+    (unreduced : (Shape.t * Longident.t Location.loc) list) =
+  Format.fprintf fmt "{@[";
+  List.iter
+    (fun (shape, { Location.txt; loc }) ->
+      Format.fprintf fmt "@[<hov 2>shape: %a; locs:@ @[<v>%s: %a@]@]@;"
+        Shape.print shape
+        (try Longident.flatten txt |> String.concat "." with _ -> "<?>")
+        Location.print_loc loc)
+    unreduced;
+  Format.fprintf fmt "@]}"
+
+let pp_payload (fmt : Format.formatter) pl =
+  Format.fprintf fmt "%i uids:@ {@[" (Hashtbl.length pl.defs);
+  Hashtbl.iter
+    (fun uid locs ->
+      Format.fprintf fmt "@[<hov 2>uid: %a; locs:@ @[<v>%a@]@]@;"
+        Shape.Uid.print uid
+        (Format.pp_print_list
+           ~pp_sep:(fun fmt () -> Format.fprintf fmt ";@;")
+           (fun fmt { Location.txt; loc } ->
+             Format.fprintf fmt "%S: %a"
+               (try Longident.flatten txt |> String.concat "." with _ -> "<?>")
+               Location.print_loc loc))
+        (LidSet.elements locs))
+    pl.defs;
+  Format.fprintf fmt "@]},@ ";
+  Format.fprintf fmt "%i partial shapes:@ @[%a@],@ "
+    (Hashtbl.length pl.partials)
+    pp_partials pl.partials;
+  Format.fprintf fmt "%i unreduced shapes:@ @[%a@]@ " (List.length pl.unreduced)
+    pp_unreduced pl.unreduced;
+  Format.fprintf fmt "and shapes for CUS %s.@ "
+    (String.concat ";@," (Hashtbl.to_seq_keys pl.cu_shape |> List.of_seq))
+
+let pp (fmt : Format.formatter) ff =
+  match ff with V1 tbl -> Format.fprintf fmt "V1@,%a" pp_payload tbl
+
+let ext = "uideps"
+
+let write ~file tbl =
+  let oc = open_out_bin file in
+  Marshal.to_channel oc (V1 tbl) [];
+  close_out oc
+
+let read ~file =
+  let ic = open_in_bin file in
+  try
+    let payload =
+      match Marshal.from_channel ic with V1 payload -> payload
+      (* TODO is that "safe" ? We probably want some magic number *)
+    in
+    close_in ic;
+    payload
+  with e -> raise e (* todo *)
diff --git a/src/analysis/locate.ml b/src/analysis/locate.ml
index c6f5e71c77..7ee1b34eca 100644
--- a/src/analysis/locate.ml
+++ b/src/analysis/locate.ml
@@ -31,6 +31,20 @@ open Std
 let last_location = ref Location.none
 
 let {Logger. log} = Logger.for_section "locate"
+
+type config = {
+  mconfig: Mconfig.t;
+  ml_or_mli: [ `ML | `MLI ];
+  traverse_aliases: bool;
+}
+
+type result = {
+  uid: Shape.Uid.t option;
+  file: string option;
+  location: Location.t;
+  approximated: bool;
+}
+
 module File : sig
   type t = private
     | ML   of string
@@ -297,13 +311,12 @@ let move_to filename cmt_infos =
   in
   File_switching.move_to ~digest filename
 
-
-let load_cmt ~config comp_unit ml_or_mli =
-  Preferences.set ml_or_mli;
+let load_cmt ~config comp_unit =
+  Preferences.set config.ml_or_mli;
   let file =
     Preferences.build comp_unit
   in
-  match Utils.find_file ~config ~with_fallback:true file with
+  match Utils.find_file ~config:config.mconfig ~with_fallback:true file with
   | Some path ->
       let cmt_infos = (Cmt_cache.read path).cmt_infos in
       let source_file = cmt_infos.cmt_sourcefile in
@@ -339,7 +352,9 @@ let scrape_alias ~env ~fallback_uid ~namespace path =
   in
   non_alias_declaration_uid ~fallback_uid path
 
-let uid_of_path ~config ~env ~ml_or_mli ~decl_uid path namespace =
+type 'a approx = { t : 'a; approximated : bool }
+
+let uid_of_path ~config ~env ~decl_uid path namespace =
   let module Shape_reduce =
     Shape.Make_reduce (struct
       type env = Env.t
@@ -348,7 +363,7 @@ let uid_of_path ~config ~env ~ml_or_mli ~decl_uid path namespace =
 
       let read_unit_shape ~unit_name =
           log ~title:"read_unit_shape" "inspecting %s" unit_name;
-          match load_cmt ~config unit_name `ML with
+          match load_cmt ~config:({config with ml_or_mli = `ML}) unit_name with
           | Ok (filename, cmt_infos) ->
             move_to filename cmt_infos;
             log ~title:"read_unit_shape" "shapes loaded for %s" unit_name;
@@ -361,85 +376,118 @@ let uid_of_path ~config ~env ~ml_or_mli ~decl_uid path namespace =
         ~namespace:Shape.Sig_component_kind.Module env (Pident id)
     end)
   in
-  let unalias fallback_uid =
-    let uid = scrape_alias ~fallback_uid ~env ~namespace path in
-    log ~title:"uid_of_path" "Unaliasing uid: %a -> %a"
-      Logger.fmt (fun fmt -> Shape.Uid.print fmt fallback_uid)
-      Logger.fmt (fun fmt -> Shape.Uid.print fmt uid);
-    uid
+  let unalias ~config fallback_uid =
+    if not config.traverse_aliases then fallback_uid else
+    let uid = scrape_alias ~fallback_uid ~env ~namespace path in begin
+      log ~title:"uid_of_path" "Unaliased uid: %a -> %a"
+        Logger.fmt (fun fmt -> Shape.Uid.print fmt fallback_uid)
+        Logger.fmt (fun fmt -> Shape.Uid.print fmt uid);
+      uid
+    end
   in
-  match ml_or_mli with
-  | `MLI -> unalias decl_uid
+  match config.ml_or_mli with
+  | `MLI ->
+    let uid = unalias ~config decl_uid in
+    log ~title:"uid_of_path" "Declaration uid: %a"
+      Logger.fmt (fun fmt -> Shape.Uid.print fmt decl_uid);
+    { t = Some uid; approximated = false }
   | `ML ->
     let shape = Env.shape_of_path ~namespace env path in
     log ~title:"shape_of_path" "initial: %a"
       Logger.fmt (fun fmt -> Shape.print fmt shape);
-    let r = Shape_reduce.weak_reduce env shape in
+    let reduced = Shape_reduce.reduce_for_uid
+      ~keep_aliases:(not config.traverse_aliases) env shape
+    in
     log ~title:"shape_of_path" "reduced: %a"
-      Logger.fmt (fun fmt -> Shape.print fmt r);
-    match r.uid with
-    | Some uid -> uid
-    | None ->
-      log ~title:"shape_of_path" "No uid found; fallbacking to declaration uid";
-      unalias decl_uid
+      Logger.fmt (fun fmt -> Shape.print_reduction_result fmt reduced);
+    begin match reduced with
+    | Resolved uid -> { t = Some uid; approximated = false }
+    | Approximated None ->
+        let uid = unalias ~config decl_uid in
+        log ~title:"shape_of_path" "Falling back to the declaration uid: %a"
+          Logger.fmt (fun fmt -> Shape.Uid.print fmt uid);
+        { t = Some uid; approximated = true }
+    | Approximated t ->
+      { t; approximated = true }
+    | Unresolved { uid; desc = Comp_unit _; approximated } -> { t = uid; approximated }
+    | _ -> { t = None; approximated = false }
+    end
 
-let from_uid ~config ~ml_or_mli uid loc path =
+let from_uid ~config ~local_defs uid loc path =
+  let title = "from_uid" in
   let loc_of_comp_unit comp_unit =
-    match load_cmt ~config comp_unit ml_or_mli with
+    match load_cmt ~config comp_unit with
     | Ok (pos_fname, _cmt) ->
       let pos = Std.Lexing.make_pos ~pos_fname (1, 0) in
       let loc = { Location.loc_start=pos; loc_end=pos; loc_ghost=true } in
       Some loc
     | _ -> None
   in
-  let title = "from_uid" in
-  match uid with
-  | Shape.Uid.Item { comp_unit; _ } ->
+  let loc_of_decl ~uid decl =
+    match Misc_utils.loc_of_decl ~uid decl  with
+    | Some loc ->
+      log ~title "Found location: %a"
+        Logger.fmt (fun fmt -> Location.print_loc fmt loc.loc);
+      Some (uid, loc.loc)
+    | None ->
+      (* Check: this should never happen *)
+      log ~title "The declaration has no location. \
+        Fallbacking to the node's location: %a"
+        Logger.fmt (fun fmt -> Location.print_loc fmt loc);
+      Some (uid, loc)
+  in
+  let approximated = uid.approximated in
+  match uid.t with
+  | Some (Shape.Uid.Item { comp_unit; _ } as uid) ->
     let locopt =
       let log_and_return msg = log ~title msg; None in
-      let uid_to_loc_tbl =
-        if Env.get_unit_name () = comp_unit then begin
-          log ~title "We look for %a in the current compilation unit."
-            Logger.fmt (fun fmt -> Shape.Uid.print fmt uid);
-          Some (Env.get_uid_to_loc_tbl ())
-        end else begin
-          log ~title "Loading the cmt for unit %S" comp_unit;
-          match load_cmt ~config comp_unit ml_or_mli with
-          | Ok (_pos_fname, cmt) -> Some cmt.cmt_uid_to_loc
-          | Error () -> log_and_return "Failed to load the cmt file."
-        end
-      in
-      Option.bind uid_to_loc_tbl ~f:(fun tbl ->
+      if Env.get_unit_name () = comp_unit then begin
+        log ~title "We look for %a in the current compilation unit."
+          Logger.fmt (fun fmt -> Shape.Uid.print fmt uid);
         log ~title "Looking for %a in the uid_to_loc table"
           Logger.fmt (fun fmt -> Shape.Uid.print fmt uid);
+        let tbl = Ast_iterators.build_uid_to_locs_tbl ~local_defs () in
         match Shape.Uid.Tbl.find_opt tbl uid with
-        | Some loc ->
-          log ~title "Found location: %a"
-            Logger.fmt (fun fmt -> Location.print_loc fmt loc);
+        | Some { Location.loc; _ } -> Some (uid, loc)
+        | None ->
+          log ~title
+            "Uid not found in the local table.\
+            Fallbacking to the node's location: %a"
+          Logger.fmt (fun fmt -> Location.print_loc fmt loc);
           Some (uid, loc)
-        | None -> log_and_return  "Uid not found in the table.")
+      end else begin
+        log ~title "Loading the shapes for unit %S" comp_unit;
+        match load_cmt ~config comp_unit with
+        | Ok (_pos_fname, cmt) ->
+          log ~title "Shapes successfully loaded, looking for %a"
+            Logger.fmt (fun fmt -> Shape.Uid.print fmt uid);
+          begin match Shape.Uid.Tbl.find_opt cmt.cmt_uid_to_decl uid with
+            | Some decl -> loc_of_decl ~uid decl
+            | None ->
+              log ~title "Uid not found in the cmt table. \
+                Fallbacking to the node's location: %a"
+                Logger.fmt (fun fmt -> Location.print_loc fmt loc);
+              Some (uid, loc)
+          end
+        | _ -> log_and_return  "Failed to load the shapes"
+      end
     in
     begin match locopt with
-    | Some (uid, loc) -> `Found (Some uid, loc)
-    | None ->
-      log ~title "Fallbacking to lookup location: %a"
-        Logger.fmt (fun fmt -> Location.print_loc fmt loc);
-      `Found (Some uid, loc)
+    | Some (uid, loc) -> `Found (Some uid, loc, approximated)
+    | None -> `Not_found (Path.name path, None)
     end
-  | Compilation_unit comp_unit ->
+  | Some (Compilation_unit comp_unit as uid) ->
     begin
       log ~title "Got the uid of a compilation unit: %a"
         Logger.fmt (fun fmt -> Shape.Uid.print fmt uid);
       match loc_of_comp_unit comp_unit with
-      | Some loc -> `Found (Some uid, loc)
+      | Some loc -> `Found (Some uid, loc, approximated)
       | _ -> log ~title "Failed to load the CU's cmt";
         `Not_found (Path.name path, None)
     end
-  | Predef _ | Internal -> assert false
-
-let locate ~config ~env ~ml_or_mli decl_uid loc path ns =
-  let uid = uid_of_path ~config ~env ~ml_or_mli ~decl_uid path ns in
-  from_uid ~config ~ml_or_mli uid loc path
+  | Some (Predef _ | Internal) -> `Builtin
+  | None -> log ~title "No UID found, fallbacking to lookup location.";
+      `Found (None, loc, true)
 
 let path_and_loc_of_cstr desc _ =
   let open Types in
@@ -483,7 +531,7 @@ let find_source ~config loc =
   in
   let dir = Filename.dirname initial_path in
   let dir =
-    match Mconfig.(config.query.directory) with
+    match config.Mconfig.query.directory with
     | "" -> dir
     | cwd -> Misc.canonicalize_filename ~cwd dir
   in
@@ -492,7 +540,9 @@ let find_source ~config loc =
     log ~title:"find_source" "failed to find %S in source path (fallback = %b)"
        filename with_fallback ;
     log ~title:"find_source" "looking for %S in %S" (File.name file) dir ;
-    begin match Utils.find_file_with_path ~config ~with_fallback file [dir] with
+    begin match
+      Utils.find_file_with_path ~config ~with_fallback file [dir]
+    with
     | Some source -> Found source
     | None ->
       log ~title:"find_source" "Trying to find %S in %S directly" fname dir;
@@ -585,8 +635,8 @@ let find_source ~config loc path =
       | _ -> failure
       | exception _ -> failure
   in
-  match result with
-  | Found src -> `Found (Some src, loc.Location.loc_start)
+  match (result : find_source_result) with
+  | Found src -> `Found (Some src, loc)
   | Not_found f -> File.explain_not_found path f
   | Multiple_matches lst ->
     let matches = String.concat lst ~sep:", " in
@@ -595,10 +645,11 @@ let find_source ~config loc path =
                merlin doesn't know which is the right one: %s"
         matches)
 
+type namespace = Namespace.t
 module Namespace = struct
   type under_type = [ `Constr | `Labels ]
 
-  type t = (* TODO: share with [Namespaced_path.Namespace.t] *)
+  type t = (* TODO: share with [Namespace.t] *)
     [ `Type | `Mod | `Modtype | `Vals | under_type ]
 
   type inferred =
@@ -622,7 +673,7 @@ module Env_lookup : sig
 
   val loc
     : Path.t
-    -> Namespaced_path.Namespace.t
+    -> namespace
     -> Env.t
     -> (Location.t * Shape.Uid.t * Shape.Sig_component_kind.t) option
 
@@ -630,11 +681,12 @@ module Env_lookup : sig
      : Namespace.inferred list
     -> Longident.t
     -> Env.t
-    -> (Path.t * Shape.Sig_component_kind.t * Shape.Uid.t * Location.t) option
+    -> (Path.t * Shape.Sig_component_kind.t * Shape.Uid.t * Location.t)
+        option
 
 end = struct
 
-  let loc path (namespace : Namespaced_path.Namespace.t) env =
+  let loc path (namespace : namespace) env =
     try
       Some (
         match namespace with
@@ -678,40 +730,47 @@ end = struct
             log ~title:"lookup"
               "got constructor, fetching path and loc in type namespace";
             let path, loc = path_and_loc_of_cstr cd env in
-            (* TODO: Use [`Constr] here instead of [`Type] *)
-            raise (Found (path, Type, cd.cstr_uid,loc))
+            log ~title:"lookup" "found path: %a"
+              Logger.fmt (fun fmt -> Path.print fmt path);
+            let path = Path.Pdot (path, cd.cstr_name)
+            in
+            raise (Found (path, Constructor, cd.cstr_uid, loc))
           | `Constr ->
             log ~title:"lookup" "lookup in constructor namespace" ;
             let cd = Env.find_constructor_by_name ident env in
             let path, loc = path_and_loc_of_cstr cd env in
+            let path = Path.Pdot (path, cd.cstr_name) in
             (* TODO: Use [`Constr] here instead of [`Type] *)
-            raise (Found (path, Type,cd.cstr_uid, loc))
+            raise (Found (path, Constructor,cd.cstr_uid, loc))
           | `Mod ->
             log ~title:"lookup" "lookup in module namespace" ;
             let path, md = Env.find_module_by_name ident env in
             raise (Found (path, Module, md.md_uid, md.Types.md_loc))
           | `Modtype ->
-            log ~title:"lookup" "lookup in module type namespace" ;
             let path, mtd = Env.find_modtype_by_name ident env in
-            raise (Found (path, Module_type, mtd.mtd_uid, mtd.Types.mtd_loc))
+            raise
+              (Found (path, Module_type, mtd.mtd_uid, mtd.Types.mtd_loc))
           | `Type ->
             log ~title:"lookup" "lookup in type namespace" ;
             let path, typ_decl = Env.find_type_by_name ident env in
             raise (
-              Found (path, Type, typ_decl.type_uid, typ_decl.Types.type_loc)
+              Found
+                (path, Type, typ_decl.type_uid, typ_decl.Types.type_loc)
             )
           | `Vals ->
             log ~title:"lookup" "lookup in value namespace" ;
             let path, val_desc = Env.find_value_by_name ident env in
             raise (
-              Found (path, Value, val_desc.val_uid, val_desc.Types.val_loc)
+              Found
+                (path, Value, val_desc.val_uid, val_desc.Types.val_loc)
             )
           | `This_label lbl ->
             log ~title:"lookup"
               "got label, fetching path and loc in type namespace";
             let path, loc = path_and_loc_from_label lbl env in
-            (* TODO: Use [`Labels] here instead of [`Type] *)
-            raise (Found (path, Type, lbl.lbl_uid, loc))
+            let path = Path.Pdot (path, lbl.lbl_name)
+            in
+            raise (Found (path, Label, lbl.lbl_uid, loc))
           | `Labels ->
             log ~title:"lookup" "lookup in label namespace" ;
             let lbl = Env.find_label_by_name ident env in
@@ -722,15 +781,16 @@ end = struct
       ) ;
       log ~title:"lookup" "   ... not in the environment" ;
       None
-    with Found ((path, namespace, decl_uid, _loc) as x) ->
-      log ~title:"env_lookup" "found: '%a' in namespace %s with uid %a"
+    with Found ((path, namespace, decl_uid, loc) as x) ->
+      log ~title:"env_lookup" "found: '%a' in namespace %s with decl_uid %a\nat loc %a"
         Logger.fmt (fun fmt -> Path.print fmt path)
         (Shape.Sig_component_kind.to_string namespace)
-        Logger.fmt (fun fmt -> Shape.Uid.print fmt decl_uid);
+        Logger.fmt (fun fmt -> Shape.Uid.print fmt decl_uid)
+        Logger.fmt (fun fmt -> Location.print_loc fmt loc);
       Some x
 end
 
-let uid_from_longident ~config ~env nss ml_or_mli ident =
+let uid_from_longident ~config ~env nss ident =
   let str_ident =
     try String.concat ~sep:"." (Longident.flatten ident)
     with _-> "Not a flat longident"
@@ -741,28 +801,30 @@ let uid_from_longident ~config ~env nss ml_or_mli ident =
     if Utils.is_builtin_path path then
       `Builtin
     else
-      let uid = uid_of_path ~config ~env ~ml_or_mli ~decl_uid path namespace in
+      let uid = uid_of_path ~config ~env ~decl_uid path namespace in
       `Uid (uid, loc, path)
 
-let from_longident ~config ~env nss ml_or_mli ident =
-  match uid_from_longident ~config ~env nss ml_or_mli ident with
-  | `Uid (uid, loc, path) -> from_uid ~config ~ml_or_mli uid loc path
+let from_longident ~config ~env ~local_defs nss ident =
+  match uid_from_longident ~config ~env nss ident with
+  | `Uid (uid, loc, path) ->
+    from_uid ~config ~local_defs uid loc path
   | (`Builtin | `Not_in_env _) as v -> v
 
-let from_path ~config ~env ~namespace ml_or_mli path =
+let from_path ~config ~env ~local_defs ~namespace path =
   File_switching.reset ();
   if Utils.is_builtin_path path then
     `Builtin
   else
     match Env_lookup.loc path namespace env with
     | None -> `Not_in_env (Path.name path)
-    | Some (loc, uid, namespace) ->
-      match locate ~config ~env ~ml_or_mli uid loc path namespace with
-      | `Not_found _
+    | Some (loc, decl_uid, namespace) ->
+      let uid = uid_of_path ~config ~env ~decl_uid path namespace in
+      match from_uid ~config ~local_defs uid loc path with
+      | `Not_found _ | `Builtin
       | `File_not_found _ as err -> err
-      | `Found (uid, loc) ->
-        match find_source ~config loc (Path.name path) with
-        | `Found (file, loc) -> `Found (uid, file, loc)
+      | `Found (uid, loc, approximated) ->
+        match find_source ~config:config.mconfig loc (Path.name path) with
+        | `Found (file, location) -> `Found { uid; file; location; approximated }
         | `File_not_found _ as otherwise -> otherwise
 
 let infer_namespace ?namespaces ~pos lid browse is_label =
@@ -793,7 +855,7 @@ let infer_namespace ?namespaces ~pos lid browse is_label =
         "dropping inferred context, it is not precise enough";
       `Ok [ `Labels ]
 
-let from_string ~config ~env ~local_defs ~pos ?namespaces switch path =
+let from_string ~config ~env ~local_defs ~pos ?namespaces path =
   File_switching.reset ();
   let browse = Mbrowse.of_typedtree local_defs in
   let lid = Type_utils.parse_longident path in
@@ -804,13 +866,13 @@ let from_string ~config ~env ~local_defs ~pos ?namespaces switch path =
     | `Ok nss ->
       log ~title:"from_string"
         "looking for the source of '%s' (prioritizing %s files)"
-        path (match switch with `ML -> ".ml" | `MLI -> ".mli");
-      match from_longident ~config ~env nss switch ident with
+        path (match config.ml_or_mli with `ML -> ".ml" | `MLI -> ".mli");
+      match from_longident ~config ~env ~local_defs nss ident with
       | `File_not_found _ | `Not_found _ | `Not_in_env _ as err -> err
       | `Builtin -> `Builtin path
-      | `Found (uid, loc) ->
-        match find_source ~config loc path with
-        | `Found (file, loc) -> `Found (uid, file, loc)
+      | `Found (uid, loc, approximated) ->
+        match find_source ~config:config.mconfig loc path with
+        | `Found (file, location) -> `Found { uid; file; location; approximated }
         | `File_not_found _ as otherwise -> otherwise
   in
   Option.value_map ~f:from_lid ~default:(`Not_found (path, None)) lid
@@ -890,7 +952,7 @@ let find_doc_attributes_in_typedtree ~config ~comp_unit uid =
   in
   let typedtree =
     log ~title:"doc_from_uid" "Loading the cmt for unit %S" comp_unit;
-    match load_cmt ~config comp_unit `MLI with
+    match load_cmt ~config:({config with ml_or_mli = `MLI}) comp_unit with
     | Ok (_, cmt_infos) ->
       log ~title:"doc_from_uid" "Cmt loaded, itering on the typedtree";
       begin match cmt_infos.cmt_annots with
@@ -989,32 +1051,30 @@ let doc_from_comment_list ~local_defs ~buffer_comments loc =
   | None, _     -> `No_documentation
   | Some doc, _ -> `Found doc
 
-let get_doc ~config ~env ~local_defs ~comments ~pos =
+let get_doc ~config:mconfig ~env ~local_defs ~comments ~pos =
   File_switching.reset ();
   fun path ->
   let_ref last_location Location.none @@ fun () ->
+  let config = { mconfig; ml_or_mli = `MLI; traverse_aliases = true; } in
   let doc_from_uid_result =
     match path with
     | `Completion_entry (namespace, path, _loc) ->
       log ~title:"get_doc" "completion: looking for the doc of '%a'"
         Logger.fmt (fun fmt -> Path.print fmt path) ;
-      let from_path = from_path ~config ~env ~namespace `MLI path in
+
+      let from_path =
+        from_path ~config ~env ~local_defs ~namespace path
+      in
       begin match from_path with
-      | `Found (uid, _, pos) ->
-        let loc : Location.t =
-          { loc_start = pos; loc_end = pos; loc_ghost = true }
-        in
+      | `Found { uid; location = loc; _ } ->
         doc_from_uid ~config ~loc uid
       | (`Builtin |`Not_in_env _|`File_not_found _|`Not_found _)
         as otherwise -> otherwise
       end
     | `User_input path ->
       log ~title:"get_doc" "looking for the doc of '%s'" path;
-      begin match from_string ~config ~env ~local_defs ~pos `MLI path with
-      | `Found (uid, _, pos) ->
-        let loc : Location.t =
-          { loc_start = pos; loc_end = pos; loc_ghost = true }
-        in
+      begin match from_string ~config ~env ~local_defs ~pos path with
+      | `Found { uid; location = loc; _ } ->
         doc_from_uid ~config ~loc uid
       | `At_origin ->
         `Found_loc { Location.loc_start = pos; loc_end = pos; loc_ghost = true }
diff --git a/src/analysis/locate.mli b/src/analysis/locate.mli
index 581d75c294..cc02ee5b4d 100644
--- a/src/analysis/locate.mli
+++ b/src/analysis/locate.mli
@@ -28,32 +28,52 @@
 
 val log : 'a Logger.printf
 
+type namespace = Namespace.t
 module Namespace : sig
   type t = [ `Type | `Mod | `Modtype | `Vals | `Constr | `Labels ]
 end
 
+type config = {
+  mconfig: Mconfig.t;
+  ml_or_mli: [ `ML | `MLI ];
+  traverse_aliases: bool;
+}
+
+type result = {
+  uid: Shape.Uid.t option;
+  file: string option;
+  location: Location.t;
+  approximated: bool;
+}
+
+val find_source
+  : config: Mconfig.t
+  -> Warnings.loc
+  -> string
+  -> [> `File_not_found of string
+      | `Found of string option * Location.t ]
+
 val from_path
-  : config:Mconfig.t
+  : config:config
   -> env:Env.t
-  -> namespace:Namespaced_path.Namespace.t
-  -> [ `ML | `MLI ]
+  -> local_defs:Mtyper.typedtree
+  -> namespace:namespace
   -> Path.t
   -> [> `File_not_found of string
-     | `Found of Shape.Uid.t option * string option * Lexing.position
+     | `Found of result
      | `Builtin
      | `Not_in_env of string
      | `Not_found of string * string option ]
 
 val from_string
-  :  config:Mconfig.t
+  :  config:config
   -> env:Env.t
   -> local_defs:Mtyper.typedtree
   -> pos:Lexing.position
   -> ?namespaces:Namespace.t list
-  -> [ `ML | `MLI ]
   -> string
   -> [> `File_not_found of string
-      | `Found of Shape.Uid.t option * string option * Lexing.position
+      | `Found of result
       | `Builtin of string
       | `Missing_labels_namespace
       | `Not_found of string * string option
@@ -67,8 +87,7 @@ val get_doc
   -> comments:(string * Location.t) list
   -> pos:Lexing.position
   -> [ `User_input of string
-     | `Completion_entry of
-        Namespaced_path.Namespace.t * Path.t * Location.t ]
+     | `Completion_entry of namespace * Path.t * Location.t ]
   -> [> `File_not_found of string
       | `Found of string
       | `Builtin of string
diff --git a/src/analysis/misc_utils.ml b/src/analysis/misc_utils.ml
index b5ac18dedd..0d27982109 100644
--- a/src/analysis/misc_utils.ml
+++ b/src/analysis/misc_utils.ml
@@ -57,3 +57,28 @@ let parenthesize_name name =
     else
       "(" ^ name ^ ")"
   )
+
+let loc_of_decl ~uid =
+  let of_option name =
+    match name.Location.txt with
+    | Some txt -> Some { name with txt }
+    | None -> None
+  in
+  let of_value_binding vb =
+    let bound_idents = Typedtree.let_bound_idents_full [vb] in
+    ListLabels.find_map ~f:(fun (_, loc, _, uid') -> if uid = uid' then Some loc else None) bound_idents
+  in
+  function
+  | Cmt_format.Class_declaration cd -> Some cd.ci_id_name
+  | Class_description cd -> Some cd.ci_id_name
+  | Class_type_declaration ctd -> Some ctd.ci_id_name
+  | Extension_constructor ec -> Some ec.ext_name
+  | Module_binding mb -> of_option mb.mb_name
+  | Module_declaration md -> of_option md.md_name
+  | Module_type_declaration mtd -> Some mtd.mtd_name
+  | Module_substitution msd -> Some msd.ms_name;
+  | Type_declaration td -> Some td.typ_name
+  | Constructor_declaration cd -> Some cd.cd_name
+  | Label_declaration ld -> Some ld.ld_name
+  | Value_description vd -> Some vd.val_name
+  | Value_binding vb -> of_value_binding vb
diff --git a/src/analysis/misc_utils.mli b/src/analysis/misc_utils.mli
index 06a02a5db1..02dfd1b7a8 100644
--- a/src/analysis/misc_utils.mli
+++ b/src/analysis/misc_utils.mli
@@ -22,3 +22,6 @@ end
 
 (* Add parenthesis to qualified operators *)
 val parenthesize_name : string -> string
+
+(** Extracts the loc from cmt's cmt_uid_to_decl tables *)
+val loc_of_decl : uid:Shape.Uid.t -> Cmt_format.item_declaration -> string Location.loc option
diff --git a/src/analysis/namespace.ml b/src/analysis/namespace.ml
new file mode 100644
index 0000000000..13e214dd0f
--- /dev/null
+++ b/src/analysis/namespace.ml
@@ -0,0 +1,24 @@
+open! Std
+
+type t = [
+  | `Vals
+  | `Type
+  | `Constr
+  | `Mod
+  | `Modtype
+  | `Functor
+  | `Labels
+  | `Unknown
+  | `Apply
+]
+
+let to_string = function
+  | `Mod -> "(module) "
+  | `Functor -> "(functor)"
+  | `Labels -> "(label) "
+  | `Constr -> "(constructor) "
+  | `Type -> "(type) "
+  | `Vals -> "(value) "
+  | `Modtype -> "(module type) "
+  | `Unknown -> "(unknown)"
+  | `Apply -> "(functor application)"
diff --git a/src/analysis/namespace.mli b/src/analysis/namespace.mli
new file mode 100644
index 0000000000..794593a029
--- /dev/null
+++ b/src/analysis/namespace.mli
@@ -0,0 +1,14 @@
+type t = [
+  | `Vals
+  | `Type
+  | `Constr
+  | `Mod
+  | `Modtype
+  | `Functor
+  | `Labels
+  | `Unknown
+  | `Apply
+]
+
+val to_string : t -> string
+
diff --git a/src/analysis/namespaced_path.ml b/src/analysis/namespaced_path.ml
deleted file mode 100644
index 2ade36f4c7..0000000000
--- a/src/analysis/namespaced_path.ml
+++ /dev/null
@@ -1,133 +0,0 @@
-open Std
-
-module Namespace = struct
-  type t = [
-    | `Vals
-    | `Type
-    | `Constr
-    | `Mod
-    | `Modtype
-    | `Functor
-    | `Labels
-    | `Unknown
-    | `Apply
-  ]
-
-  let to_tag_string = function
-    | `Mod -> ""
-    | `Functor -> "[functor]"
-    | `Labels -> "[label]"
-    | `Constr -> "[cstr]"
-    | `Type -> "[type]"
-    | `Vals -> "[val]"
-    | `Modtype -> "[Mty]"
-    | `Unknown -> "[?]"
-    | `Apply -> "[functor application]"
-
-  let to_string = function
-    | `Mod -> "(module) "
-    | `Functor -> "(functor)"
-    | `Labels -> "(label) "
-    | `Constr -> "(constructor) "
-    | `Type -> "(type) "
-    | `Vals -> "(value) "
-    | `Modtype -> "(module type) "
-    | `Unknown -> "(unknown)"
-    | `Apply -> "(functor application)"
-end
-
-module Id = struct
-  type t =
-    | Id of Ident.t
-    | String of string
-
-  let name = function
-    | Id id -> Ident.name id
-    | String s -> s
-
-  let unique_name = function
-    | Id id -> Ident.unique_toplevel_name id
-    | String s -> s
-
-  let equal mi1 mi2 =
-    match mi1, mi2 with
-    | Id i1, Id i2 -> Ident.equal i1 i2
-    | Id i, String s
-    | String s, Id i -> (Ident.name i) = s
-    | String s1, String s2 -> s1 = s2
-end
-
-type t = elt list
-and elt =
-  | Ident of Id.t * Namespace.t
-  | Applied_to of t
-
-let rec to_string ~name = function
-  | []
-  | Applied_to _ :: _ -> invalid_arg "Namespaced_path.to_string"
-  | Ident (id, ns) :: rest ->
-    List.fold_left rest ~init:(name id ^ Namespace.to_tag_string ns) ~f:(
-      fun acc elt ->
-        match elt with
-        | Ident (id, ns) ->
-          Printf.sprintf "%s.%s%s" acc (name id) (Namespace.to_tag_string ns)
-        | Applied_to arg ->
-          Printf.sprintf "%s(%s)" acc (to_string ~name arg)
-    )
-
-let to_unique_string l = to_string ~name:Id.unique_name l
-let to_string l = to_string ~name:Id.name l
-
-let of_path ~namespace p =
-  let rec aux namespace acc p =
-    let open Path in
-    match p with
-    | Pident id -> Ident (Id.Id id, namespace) :: acc
-    | Pdot (p, s) -> aux `Mod (Ident (Id.String s, namespace) :: acc) p
-    | Papply (p1, p2) ->
-      let acc =
-        Applied_to (aux `Mod [] p2) :: acc
-      in
-      aux `Mod acc p1
-  in
-  aux namespace [] p
-
-let head_exn = function
-  | [] -> invalid_arg "head"
-  | x :: _ -> x
-
-let head x =
-  try Some (head_exn x)
-  with Invalid_argument _ -> None
-
-let peal_head_exn = function
-  | [] -> invalid_arg "peal_head_exn"
-  | _head :: rest -> rest
-
-let peal_head p =
-  try Some (peal_head_exn p)
-  with Invalid_argument _ -> None
-
-let rec equal p1 p2 = List.equal ~eq:equal_elt p1 p2
-and equal_elt elt1 elt2 =
-  match elt1, elt2 with
-  | Ident (i1, ns1), Ident (i2, ns2) -> Id.equal i1 i2 && ns1 = ns2
-  | Applied_to p1, Applied_to p2 -> equal p1 p2
-  | _, _ -> false
-
-let rewrite_head ~new_prefix p = new_prefix @ p
-
-let strip_stamps =
-  List.map ~f:(function
-    | Ident (Id i, ns) -> Ident (String (Ident.name i), ns)
-    | elt -> elt
-  )
-
-let empty = []
-
-let rec subst_prefix ~old_prefix ~new_prefix p =
-  match old_prefix, p with
-  | [], _ -> Some (new_prefix @ p)
-  | op1 :: ops, elt1 :: p when equal_elt op1 elt1 ->
-    subst_prefix ~old_prefix:ops ~new_prefix p
-  | _ -> None
diff --git a/src/analysis/namespaced_path.mli b/src/analysis/namespaced_path.mli
deleted file mode 100644
index 4e4a75cec2..0000000000
--- a/src/analysis/namespaced_path.mli
+++ /dev/null
@@ -1,49 +0,0 @@
-module Namespace : sig
-  type t = [
-    | `Vals
-    | `Type
-    | `Constr
-    | `Mod
-    | `Modtype
-    | `Functor
-    | `Labels
-    | `Unknown
-    | `Apply
-  ]
-
-  val to_string : t -> string
-end
-
-module Id : sig
-  type t = private
-    | Id of Ident.t
-    | String of string
-
-  val name : t -> string
-end
-
-type t (* = private elt list *)
-and elt = private
-  | Ident of Id.t * Namespace.t
-  | Applied_to of t
-
-val to_string : t -> string
-val to_unique_string : t -> string
-
-val head : t -> elt option
-val head_exn : t -> elt
-
-val peal_head : t -> t option
-val peal_head_exn : t -> t
-
-val equal : t -> t -> bool
-
-val rewrite_head : new_prefix:t -> t -> t
-
-val strip_stamps : t -> t
-
-val of_path : namespace:Namespace.t -> Path.t -> t
-
-val empty : t
-
-val subst_prefix : old_prefix:t -> new_prefix:t -> t -> t option
diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml
new file mode 100644
index 0000000000..b84d4b94f8
--- /dev/null
+++ b/src/analysis/occurrences.ml
@@ -0,0 +1,170 @@
+open Std
+module LidSet = Index_format.LidSet
+
+let {Logger. log} = Logger.for_section "occurrences"
+
+let index_buffer ~env ~local_defs () =
+  let defs = Hashtbl.create 64 in
+  let index = Ast_iterators.index_usages ~(local_defs : Mtyper.typedtree) () in
+  let module Shape_reduce =
+    Shape.Make_reduce (struct
+      type env = Env.t
+
+      let fuel = 10
+
+      let read_unit_shape ~unit_name =
+          log ~title:"read_unit_shape" "inspecting %s" unit_name;
+          let cmt = Format.sprintf "%s.cmt" unit_name in
+          match Cmt_format.read (Load_path.find_uncap cmt) with
+          | _, Some cmt_infos ->
+            log ~title:"read_unit_shape" "shapes loaded for %s" unit_name;
+            cmt_infos.cmt_impl_shape
+          | exception _ | _ ->
+            log ~title:"read_unit_shape" "failed to find %s" unit_name;
+            None
+
+      let find_shape env id = Env.shape_of_path
+        ~namespace:Shape.Sig_component_kind.Module env (Pident id)
+    end)
+  in
+  List.iter index ~f:(fun (lid, item) ->
+    match item with
+    | Shape.Approximated _ | Missing_uid -> ()
+    | Resolved uid ->
+        Index_format.(add defs uid (LidSet.singleton lid))
+    | Unresolved shape ->
+      (* Format.eprintf "Reducing %a\n%!" Shape.print shape; *)
+      match Shape_reduce.reduce env shape with
+        | { Shape.desc = Leaf | Struct _; uid = Some uid; approximated = _ } ->
+          (* Format.eprintf "Reduced %a\n%!" Shape.print s; *)
+            Index_format.add defs uid (LidSet.singleton lid)
+        | _ -> ());
+  defs
+
+let load_external_index ~index_file =
+  let uideps = Index_format.read ~file:index_file in
+  uideps
+
+let merge_tbl ~into tbl = Hashtbl.iter (Index_format.add into) tbl
+
+(* A longident can have the form: A.B.x Right now we are only interested in
+   values, but we will eventually want to index all occurrences of modules in
+   such longidents. However there is an issue with that: we only have the
+   location of the complete longident which might span multiple lines. This is
+   enough to get the last component since it will always be on the last line,
+   but will prevent us to find the location of previous components. *)
+let last_loc (loc : Location.t) lid =
+  if lid = Longident.Lident "*unknown*" then loc
+  else
+    let last_size = Longident.last lid |> String.length in
+    { loc with
+      loc_start = { loc.loc_end with
+        pos_cnum = loc.loc_end.pos_cnum - last_size;
+      }
+    }
+
+let uid_and_loc_of_node env node =
+  let open Browse_raw in
+  log ~title:"occurrences" "Looking for uid of node %s"
+    @@ string_of_node node;
+  match node with
+  | Module_binding_name { mb_id = Some ident; mb_name; _ } ->
+    let md = Env.find_module (Pident ident) env in
+    Some (md.md_uid, mb_name.loc)
+  | Pattern { pat_desc =
+      Tpat_var (_, name, uid) | Tpat_alias (_, _, name, uid); _ } ->
+      Some (uid, name.loc)
+  | Type_declaration { typ_type; typ_name; _ } ->
+      Some (typ_type.type_uid, typ_name.loc)
+  | Value_description { val_val; val_name; _ } ->
+      Some (val_val.val_uid, val_name.loc)
+  | _ -> None
+
+let loc_of_local_def ~local_defs uid =
+  (* WIP *)
+  (* todo: cache or specialize ? *)
+  let uid_to_locs_tbl : string Location.loc Types.Uid.Tbl.t =
+    Types.Uid.Tbl.create 64
+  in
+  match local_defs with
+  | `Interface _ -> failwith "not implemented"
+  | `Implementation str ->
+    let iter = Ast_iterators.iter_on_defs ~uid_to_locs_tbl in
+    iter.structure iter str;
+    (* todo: optimize, the iterator could be more flexible *)
+    (* we could check equality and raise with the result as soon that it arrive *)
+    Shape.Uid.Tbl.find uid_to_locs_tbl uid
+
+let locs_of ~config ~scope ~env ~local_defs ~pos ~node:_ path =
+  log ~title:"occurrences" "Looking for occurences of %s (pos: %s)"
+    path
+    (Lexing.print_position () pos);
+  let locate_result =
+    Locate.from_string
+    ~config:{ mconfig = config; traverse_aliases=false; ml_or_mli = `ML}
+    ~env ~local_defs ~pos path
+  in
+  let def =
+    match locate_result with
+    | `At_origin ->
+      log ~title:"locs_of" "Cursor is on definition / declaration";
+      (* We are on  a definition / declaration so we look for the node's uid  *)
+      (* todo: refactor *)
+      let browse = Mbrowse.of_typedtree local_defs in
+      let node = Mbrowse.enclosing pos [browse] in
+      let env, node = Mbrowse.leaf_node node in
+      uid_and_loc_of_node env node
+    | `Found { uid = Some uid; location; approximated = false; _ } ->
+        log ~title:"locs_of" "Found definition uid using locate: %a "
+          Logger.fmt (fun fmt -> Shape.Uid.print fmt uid);
+        Some (uid, location)
+    | _ ->
+      log ~title:"locs_of" "Locate failed to find a definition.";
+      None
+  in
+  match def with
+  | Some (uid, loc) ->
+    log ~title:"locs_of" "Definition has uid %a (%a)"
+      Logger.fmt (fun fmt -> Shape.Uid.print fmt uid)
+      Logger.fmt (fun fmt -> Location.print_loc fmt loc);
+    (* Todo: use magic number instead and don't use the lib *)
+    let index_file = None (* todo *) in
+    log ~title:"locs_of" "Indexing current buffer";
+    let index = index_buffer ~env ~local_defs () in
+    if scope = `Project then begin
+      match index_file with
+      | None -> log ~title:"locs_of" "No external index specified"
+      | Some index_file ->
+        log ~title:"locs_of" "Using external index: %S" index_file;
+        let external_uideps = load_external_index ~index_file in
+        merge_tbl ~into:index external_uideps.defs
+    end;
+    (* TODO ignore externally indexed locs from the current buffer *)
+    let locs = match Hashtbl.find_opt index uid with
+      | Some locs ->
+        LidSet.elements locs
+        |> List.filter_map ~f:(fun lid ->
+          let loc = last_loc lid.Location.loc lid.txt in
+          let fname = loc.Location.loc_start.Lexing.pos_fname in
+          if Filename.is_relative fname then begin
+            match Locate.find_source ~config loc fname with
+            | `Found (Some file, _) -> Some { loc with loc_start =
+                { loc.loc_start with pos_fname = file}}
+            | `Found (None, _) -> Some { loc with loc_start =
+                { loc.loc_start with pos_fname = ""}}
+            | `File_not_found msg ->
+              log ~title:"occurrences" "%s" msg;
+              None
+            | _ -> None
+          end else Some loc)
+      | None -> log ~title:"locs_of" "No locs found in index."; []
+    in
+    (* We only prepend the location of the definition if it's int he scope of
+       the query *)
+    let loc_in_unit (loc : Location.t) =
+      let by = Env.get_unit_name () |> String.lowercase_ascii in
+      String.is_prefixed ~by (loc.loc_start.pos_fname |> String.lowercase_ascii)
+    in
+    if scope = `Project || loc_in_unit loc then Ok (loc::locs)
+    else Ok locs
+  | None -> Error "nouid"
diff --git a/src/frontend/query_commands.ml b/src/frontend/query_commands.ml
index 7894247861..1107b92e90 100644
--- a/src/frontend/query_commands.ml
+++ b/src/frontend/query_commands.ml
@@ -362,7 +362,8 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a =
 
   | Locate_type pos ->
     let typer = Mpipeline.typer_result pipeline in
-    let structures = Mbrowse.of_typedtree (Mtyper.get_typedtree typer) in
+    let local_defs = Mtyper.get_typedtree typer in
+    let structures = Mbrowse.of_typedtree local_defs in
     let pos = Mpipeline.get_lexing_pos pipeline pos in
     let node =
       match Mbrowse.enclosing pos [structures] with
@@ -388,15 +389,22 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a =
       | None -> `Invalid_context
       | Some (env, path) ->
         Locate.log ~title:"debug" "found type: %s" (Path.name path);
+        let config = Locate.{
+            mconfig = Mpipeline.final_config pipeline;
+            ml_or_mli = `MLI;
+            traverse_aliases = true
+          }
+        in
         match Locate.from_path
+                ~config
                 ~env
-                ~config:(Mpipeline.final_config pipeline)
-                ~namespace:`Type `MLI
+                ~local_defs
+                ~namespace:`Type
                 path with
         | `Builtin -> `Builtin (Path.name path)
         | `Not_in_env _ as s -> s
         | `Not_found _ as s -> s
-        | `Found (_uid, file, pos) -> `Found (file, pos)
+        | `Found { file; location; _ } -> `Found (file, location.loc_start)
         | `File_not_found _ as s -> s
     end
 
@@ -520,15 +528,17 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a =
         path
     in
     if path = "" then `Invalid_context else
-    begin match
-      Locate.from_string
-        ~config:(Mpipeline.final_config pipeline)
-        ~env ~local_defs ~pos ml_or_mli path
-    with
-    | `Found (_, file, pos) ->
+    let config = Locate.{
+        mconfig = Mpipeline.final_config pipeline;
+        ml_or_mli;
+        traverse_aliases = true
+      }
+    in
+    begin match Locate.from_string ~config ~env ~local_defs ~pos path with
+    | `Found { file; location; _ } ->
       Locate.log ~title:"result"
         "found: %s" (Option.value ~default:"<local buffer>" file);
-      `Found (file, pos)
+      `Found (file, location.loc_start)
     | `Missing_labels_namespace ->
       (* Can't happen because we haven't passed a namespace as input. *)
       assert false
@@ -782,58 +792,23 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a =
     let config = Mpipeline.final_config pipeline in
     Mconfig.(config.merlin.source_path)
 
-  | Occurrences (`Ident_at pos, _scope) ->
+  | Occurrences (`Ident_at pos, scope) ->
+    let config = Mpipeline.final_config pipeline in
     let typer = Mpipeline.typer_result pipeline in
-    let str = Mbrowse.of_typedtree (Mtyper.get_typedtree typer) in
+    let local_defs = Mtyper.get_typedtree typer in
     let pos = Mpipeline.get_lexing_pos pipeline pos in
-    let enclosing = Mbrowse.enclosing pos [str] in
-    let curr_node =
-      let is_wildcard_pat = function
-        | Browse_raw.Pattern {pat_desc = Typedtree.Tpat_any; _} -> true
-        | _ -> false
-      in
-      List.find_some enclosing ~f:(fun (_, node) ->
-        (* it doesn't make sense to find occurrences of a wildcard pattern *)
-        not (is_wildcard_pat node))
-      |> Option.map ~f:(fun (env, node) -> Browse_tree.of_node ~env node)
-      |> Option.value ~default:Browse_tree.dummy
-    in
-    let str = Browse_tree.of_browse str in
-    let get_loc {Location.txt = _; loc} = loc in
-    let ident_occurrence () =
-      let paths = Browse_raw.node_paths curr_node.Browse_tree.t_node in
-      let under_cursor p = Location_aux.compare_pos pos (get_loc p) = 0 in
-      Logger.log ~section:"occurrences" ~title:"Occurrences paths" "%a"
-        Logger.json (fun () ->
-            let dump_path ({Location.txt; loc} as p) =
-              let ppf, to_string = Format.to_string () in
-              Printtyp.path ppf txt;
-              `Assoc [
-                "start", Lexing.json_of_position loc.Location.loc_start;
-                "end", Lexing.json_of_position loc.Location.loc_end;
-                "under_cursor", `Bool (under_cursor p);
-                "path", `String (to_string ())
-              ]
-            in
-            `List (List.map ~f:dump_path paths));
-      match List.filter paths ~f:under_cursor with
-      | [] -> []
-      | (path :: _) ->
-        let path = path.Location.txt in
-        let ts = Browse_tree.all_occurrences path str in
-        let loc (_t,paths) = List.map ~f:get_loc paths in
-        List.concat_map ~f:loc ts
-
-    in
-    let constructor_occurrence d =
-      let ts = Browse_tree.all_constructor_occurrences (curr_node,d) str in
-      List.map ~f:get_loc ts
-
+    let env, node = Mbrowse.leaf_node (Mtyper.node_at typer pos) in
+    let path =
+      let path = reconstruct_identifier pipeline pos None in
+      let path = Mreader_lexer.identifier_suffix path in
+      let path = List.map ~f:(fun {Location. txt; _} -> txt) path in
+      let path = String.concat ~sep:"." path in
+      Locate.log ~title:"reconstructed identifier" "%s" path;
+      path
     in
     let locs =
-      match Browse_raw.node_is_constructor curr_node.Browse_tree.t_node with
-      | Some d -> constructor_occurrence d.Location.txt
-      | None -> ident_occurrence ()
+      Occurrences.locs_of ~config ~scope ~env ~local_defs ~node ~pos path
+      |> Result.value ~default:[]
     in
     let loc_start l = l.Location.loc_start in
     let cmp l1 l2 = Lexing.compare_pos (loc_start l1) (loc_start l2) in
diff --git a/src/ocaml/typing/cmt_format.mli b/src/ocaml/typing/cmt_format.mli
index 653dfcc75c..9e4c0c45ac 100644
--- a/src/ocaml/typing/cmt_format.mli
+++ b/src/ocaml/typing/cmt_format.mli
@@ -140,3 +140,11 @@ val record_value_dependency:
   val read_signature : 'a -> string -> Types.signature * 'b list * 'c list
 
 *)
+
+val iter_on_declarations :
+  f:(Types.Uid.t -> item_declaration -> unit)
+  -> Tast_iterator.iterator
+
+val iter_on_usages :
+  index:(Longident.t Location.loc * Shape.reduction_result) list ref
+  -> Tast_iterator.iterator
diff --git a/src/ocaml/typing/shape.ml b/src/ocaml/typing/shape.ml
index 6de30689ec..46b820b467 100644
--- a/src/ocaml/typing/shape.ml
+++ b/src/ocaml/typing/shape.ml
@@ -327,6 +327,7 @@ end) = struct
 
   type env = {
     fuel: int ref;
+    keep_aliases: bool;
     global_env: Params.env;
     local_env: local_env;
     reduce_memo_table: (thunk, nf) Hashtbl.t;
@@ -454,7 +455,11 @@ end) = struct
       | Struct m ->
           let mnf = Item.Map.map (delay_reduce env) m in
           return (NStruct mnf)
-      | Alias t -> return (NAlias (reduce env t))
+      | Alias t ->
+        let nf = reduce env t in
+        if env.keep_aliases then
+          return (NAlias nf)
+        else nf
       | Error s -> return ~approximated:true (NError s)
 
   and read_back env (nf : nf) : t =
@@ -494,11 +499,12 @@ end) = struct
   let reduce_memo_table = Hashtbl.create 42
   let read_back_memo_table = Hashtbl.create 42
 
-  let reduce global_env t =
+  let reduce ?(keep_aliases = true) global_env t =
     let fuel = ref Params.fuel in
     let local_env = Ident.Map.empty in
     let env = {
       fuel;
+      keep_aliases;
       global_env;
       reduce_memo_table;
       read_back_memo_table;
@@ -517,11 +523,12 @@ end) = struct
     | NError _ -> false
     | NLeaf -> false
 
-  let reduce_for_uid global_env t =
+  let reduce_for_uid ?(keep_aliases = true) global_env t =
     let fuel = ref Params.fuel in
     let local_env = Ident.Map.empty in
     let env = {
       fuel;
+      keep_aliases;
       global_env;
       reduce_memo_table;
       read_back_memo_table;
diff --git a/src/ocaml/typing/shape.mli b/src/ocaml/typing/shape.mli
index 8d1d4b3342..f6bafecd6a 100644
--- a/src/ocaml/typing/shape.mli
+++ b/src/ocaml/typing/shape.mli
@@ -217,11 +217,13 @@ module Make_reduce(Context : sig
 
     val find_shape : env -> Ident.t -> t
   end) : sig
-  val reduce : Context.env -> t -> t
+  val reduce :
+    ?keep_aliases:bool -> Context.env -> t -> t
 
   (** Perform weak reduction and return the head's uid if any. If reduction was
     incomplete the partially reduced shape is returned. *)
-  val reduce_for_uid : Context.env -> t -> reduction_result
+  val reduce_for_uid :
+    ?keep_aliases:bool -> Context.env -> t -> reduction_result
 end
 
 (** [toplevel_local_reduce] is only suitable to reduce toplevel shapes (shapes
diff --git a/src/ocaml/typing/typecore.ml b/src/ocaml/typing/typecore.ml
index 77b91e24de..2bedac3cf9 100644
--- a/src/ocaml/typing/typecore.ml
+++ b/src/ocaml/typing/typecore.ml
@@ -2167,7 +2167,11 @@ and type_pat_aux
               pat_type = ty;
               pat_desc =
                 Tpat_alias
-                  ({p with pat_desc = Tpat_any; pat_attributes = []}, id,s,uid);
+                  ({p with
+                    pat_desc = Tpat_any;
+                    pat_attributes = (* Merlin should ignore these nodes *)
+                      [Ast_helper.Attr.mk (mknoloc "merlin.hide") (PStr [])];
+                    pat_loc = { p.pat_loc with loc_ghost = true }}, id,s,uid);
               pat_extra = [extra];
             }
           | _, p ->
diff --git a/src/utils/std.ml b/src/utils/std.ml
index 0031c04b04..cfcdcc509a 100644
--- a/src/utils/std.ml
+++ b/src/utils/std.ml
@@ -343,9 +343,7 @@ module Option = struct
 end
 
 module Result = struct
-  type ('a, 'e) t = ('a, 'e) result =
-  | Ok of 'a
-  | Error of 'e
+  include Result
 
   let map ~f r = Result.map f r
   let bind ~f r = Result.bind r f
diff --git a/tests/test-dirs/document/issue1513.t b/tests/test-dirs/document/issue1513.t
index 245bfed984..50fdeca695 100644
--- a/tests/test-dirs/document/issue1513.t
+++ b/tests/test-dirs/document/issue1513.t
@@ -16,12 +16,10 @@ Merlin should show comments for a type's constructor from another module:
 
   $ $OCAMLC -c -bin-annot naux.ml
 
-FIXME: We should not rely on "fallbacking". This requires a compiler change.
+We should not rely on "fallbacking". This requires a compiler change.
   $ $MERLIN single document -position 1:13 \
-  > -log-file - -log-section locate \
-  > -filename main.ml <main.ml 2>&1 | 
-  > grep "Uid not found in the table."
-  Uid not found in the table.
+  > -filename main.ml <main.ml | tr '\n' ' ' | jq '.value'
+  "A Comment"
 
 FIXME: expected "B Comment"
   $ $MERLIN single document -position 2:13 \
diff --git a/tests/test-dirs/environment_on_open.t/run.t b/tests/test-dirs/environment_on_open.t/run.t
index f8f1705c4b..dc7374de48 100644
--- a/tests/test-dirs/environment_on_open.t/run.t
+++ b/tests/test-dirs/environment_on_open.t/run.t
@@ -6,7 +6,7 @@
       "file": "$TESTCASE_ROOT/environment_on_open.ml",
       "pos": {
         "line": 1,
-        "col": 0
+        "col": 7
       }
     },
     "notifications": []
diff --git a/tests/test-dirs/locate-type.t/run.t b/tests/test-dirs/locate-type.t/run.t
index f25f2f42db..d1a59aa638 100644
--- a/tests/test-dirs/locate-type.t/run.t
+++ b/tests/test-dirs/locate-type.t/run.t
@@ -7,7 +7,7 @@
       "file": "$TESTCASE_ROOT/a.ml",
       "pos": {
         "line": 2,
-        "col": 2
+        "col": 7
       }
     },
     "notifications": []
@@ -20,7 +20,7 @@
       "file": "$TESTCASE_ROOT/a.ml",
       "pos": {
         "line": 2,
-        "col": 2
+        "col": 7
       }
     },
     "notifications": []
@@ -33,7 +33,7 @@
       "file": "$TESTCASE_ROOT/b.ml",
       "pos": {
         "line": 1,
-        "col": 0
+        "col": 5
       }
     },
     "notifications": []
diff --git a/tests/test-dirs/locate/context-detection/cd-field.t/run.t b/tests/test-dirs/locate/context-detection/cd-field.t/run.t
index 20ae655177..372cdfa77e 100644
--- a/tests/test-dirs/locate/context-detection/cd-field.t/run.t
+++ b/tests/test-dirs/locate/context-detection/cd-field.t/run.t
@@ -6,7 +6,7 @@
       "file": "$TESTCASE_ROOT/field.ml",
       "pos": {
         "line": 1,
-        "col": 0
+        "col": 5
       }
     },
     "notifications": []
@@ -19,7 +19,7 @@
       "file": "$TESTCASE_ROOT/field.ml",
       "pos": {
         "line": 1,
-        "col": 0
+        "col": 5
       }
     },
     "notifications": []
@@ -34,7 +34,7 @@ the field bar rather than the identifier.
       "file": "$TESTCASE_ROOT/field.ml",
       "pos": {
         "line": 10,
-        "col": 2
+        "col": 7
       }
     },
     "notifications": []
diff --git a/tests/test-dirs/locate/context-detection/cd-from_a_pattern.t/run.t b/tests/test-dirs/locate/context-detection/cd-from_a_pattern.t/run.t
index 882936ce67..278e4921a7 100644
--- a/tests/test-dirs/locate/context-detection/cd-from_a_pattern.t/run.t
+++ b/tests/test-dirs/locate/context-detection/cd-from_a_pattern.t/run.t
@@ -31,7 +31,7 @@ We call locate from the broken pattern:
       "file": "$TESTCASE_ROOT/from_a_pattern.ml",
       "pos": {
         "line": 1,
-        "col": 0
+        "col": 7
       }
     },
     "notifications": []
diff --git a/tests/test-dirs/locate/context-detection/cd-label.t/run.t b/tests/test-dirs/locate/context-detection/cd-label.t/run.t
index 91844c2cd5..689444bf45 100644
--- a/tests/test-dirs/locate/context-detection/cd-label.t/run.t
+++ b/tests/test-dirs/locate/context-detection/cd-label.t/run.t
@@ -49,7 +49,7 @@ We could expect 2:12 or at least 2:4
     "file": "$TESTCASE_ROOT/record.ml",
     "pos": {
       "line": 1,
-      "col": 0
+      "col": 5
     }
   }
 
@@ -60,14 +60,12 @@ We could expect 2:12 or at least 2:4
 
   $ $OCAMLC -c -bin-annot record.ml
 
-FIXME: Merlin looks for the Uid of the label in Record's `uid_to_loc` table but
-doesn't find it. We need a compiler fix for this, see #1505.
   $ $MERLIN single locate -look-for mli -position 2:24 \
   > -filename ./other_module.ml < ./other_module.ml | jq '.value'
   {
     "file": "$TESTCASE_ROOT/record.ml",
     "pos": {
       "line": 1,
-      "col": 0
+      "col": 11
     }
   }
diff --git a/tests/test-dirs/locate/context-detection/cd-test.t/run.t b/tests/test-dirs/locate/context-detection/cd-test.t/run.t
index 34e4cce900..b3882f95eb 100644
--- a/tests/test-dirs/locate/context-detection/cd-test.t/run.t
+++ b/tests/test-dirs/locate/context-detection/cd-test.t/run.t
@@ -7,7 +7,7 @@ Trying them all:
       "file": "$TESTCASE_ROOT/test.ml",
       "pos": {
         "line": 1,
-        "col": 0
+        "col": 5
       }
     },
     "notifications": []
@@ -20,7 +20,7 @@ Trying them all:
       "file": "$TESTCASE_ROOT/test.ml",
       "pos": {
         "line": 3,
-        "col": 0
+        "col": 12
       }
     },
     "notifications": []
@@ -33,7 +33,7 @@ Trying them all:
       "file": "$TESTCASE_ROOT/test.ml",
       "pos": {
         "line": 7,
-        "col": 0
+        "col": 12
       }
     },
     "notifications": []
@@ -61,7 +61,7 @@ FIXME this should say "Already at definition point" (we're defining the label):
       "file": "$TESTCASE_ROOT/test.ml",
       "pos": {
         "line": 1,
-        "col": 0
+        "col": 5
       }
     },
     "notifications": []
@@ -96,7 +96,7 @@ FIXME we failed to parse/reconstruct the ident, that's interesting
       "file": "$TESTCASE_ROOT/test.ml",
       "pos": {
         "line": 1,
-        "col": 0
+        "col": 5
       }
     },
     "notifications": []
@@ -109,7 +109,7 @@ FIXME we failed to parse/reconstruct the ident, that's interesting
       "file": "$TESTCASE_ROOT/test.ml",
       "pos": {
         "line": 1,
-        "col": 0
+        "col": 5
       }
     },
     "notifications": []
@@ -122,7 +122,7 @@ FIXME we failed to parse/reconstruct the ident, that's interesting
       "file": "$TESTCASE_ROOT/test.ml",
       "pos": {
         "line": 11,
-        "col": 0
+        "col": 10
       }
     },
     "notifications": []
@@ -151,7 +151,7 @@ FIXME this should jump to line 11:
       "file": "$TESTCASE_ROOT/test.ml",
       "pos": {
         "line": 13,
-        "col": 0
+        "col": 5
       }
     },
     "notifications": []
@@ -177,7 +177,7 @@ FIXME this should jump to line 11:
       "file": "$TESTCASE_ROOT/test.ml",
       "pos": {
         "line": 13,
-        "col": 0
+        "col": 5
       }
     },
     "notifications": []
diff --git a/tests/test-dirs/locate/functors/f-all_local.t/run.t b/tests/test-dirs/locate/functors/f-all_local.t/run.t
index 1cb47dc635..33ad905cac 100644
--- a/tests/test-dirs/locate/functors/f-all_local.t/run.t
+++ b/tests/test-dirs/locate/functors/f-all_local.t/run.t
@@ -7,7 +7,7 @@ Check that we can jump locally inside the functor:
       "file": "$TESTCASE_ROOT/all_local.ml",
       "pos": {
         "line": 12,
-        "col": 2
+        "col": 7
       }
     },
     "notifications": []
@@ -53,7 +53,7 @@ Check the argument is substituted for the parameter
       "file": "$TESTCASE_ROOT/all_local.ml",
       "pos": {
         "line": 6,
-        "col": 2
+        "col": 7
       }
     },
     "notifications": []
diff --git a/tests/test-dirs/locate/functors/f-from_application.t/run.t b/tests/test-dirs/locate/functors/f-from_application.t/run.t
index 37624dbcb5..c28cb0493e 100644
--- a/tests/test-dirs/locate/functors/f-from_application.t/run.t
+++ b/tests/test-dirs/locate/functors/f-from_application.t/run.t
@@ -8,7 +8,7 @@ FIXME: we confuse the module for the constructor and jump to the wrong place
       "file": "$TESTCASE_ROOT/from_application.ml",
       "pos": {
         "line": 5,
-        "col": 0
+        "col": 7
       }
     },
     "notifications": []
@@ -23,7 +23,7 @@ Jump from inside the functor application to inside the functor application:
       "file": "$TESTCASE_ROOT/from_application.ml",
       "pos": {
         "line": 14,
-        "col": 4
+        "col": 9
       }
     },
     "notifications": []
@@ -38,7 +38,7 @@ Jump from inside the functor application to the outer scope:
       "file": "$TESTCASE_ROOT/from_application.ml",
       "pos": {
         "line": 9,
-        "col": 0
+        "col": 5
       }
     },
     "notifications": []
diff --git a/tests/test-dirs/locate/functors/f-generative.t/run.t b/tests/test-dirs/locate/functors/f-generative.t/run.t
index 28de85ca5d..e8d473b0a4 100644
--- a/tests/test-dirs/locate/functors/f-generative.t/run.t
+++ b/tests/test-dirs/locate/functors/f-generative.t/run.t
@@ -7,7 +7,7 @@ Check that we handle generative functors properly:
       "file": "$TESTCASE_ROOT/generative.ml",
       "pos": {
         "line": 3,
-        "col": 2
+        "col": 6
       }
     },
     "notifications": []
diff --git a/tests/test-dirs/locate/functors/f-missed_shadowing.t/run.t b/tests/test-dirs/locate/functors/f-missed_shadowing.t/run.t
index 99b22601c9..40f8de69df 100644
--- a/tests/test-dirs/locate/functors/f-missed_shadowing.t/run.t
+++ b/tests/test-dirs/locate/functors/f-missed_shadowing.t/run.t
@@ -22,7 +22,7 @@ Reproduce bug described (and fixed) in commit e558d203334fd06f7653a6388b46dba895
       "file": "$TESTCASE_ROOT/missed_shadowing.ml",
       "pos": {
         "line": 7,
-        "col": 0
+        "col": 12
       }
     },
     "notifications": []
diff --git a/tests/test-dirs/locate/functors/f-nested_applications.t/run.t b/tests/test-dirs/locate/functors/f-nested_applications.t/run.t
index 0d933368c3..3977c4d0ca 100644
--- a/tests/test-dirs/locate/functors/f-nested_applications.t/run.t
+++ b/tests/test-dirs/locate/functors/f-nested_applications.t/run.t
@@ -7,7 +7,7 @@
       "file": "$TESTCASE_ROOT/nested_applications.ml",
       "pos": {
         "line": 10,
-        "col": 2
+        "col": 7
       }
     },
     "notifications": []
@@ -21,7 +21,7 @@
       "file": "$TESTCASE_ROOT/nested_applications.ml",
       "pos": {
         "line": 10,
-        "col": 2
+        "col": 7
       }
     },
     "notifications": []
@@ -35,7 +35,7 @@
       "file": "$TESTCASE_ROOT/nested_applications.ml",
       "pos": {
         "line": 10,
-        "col": 2
+        "col": 7
       }
     },
     "notifications": []
@@ -49,7 +49,7 @@
       "file": "$TESTCASE_ROOT/nested_applications.ml",
       "pos": {
         "line": 10,
-        "col": 2
+        "col": 7
       }
     },
     "notifications": []
@@ -63,7 +63,7 @@
       "file": "$TESTCASE_ROOT/nested_applications.ml",
       "pos": {
         "line": 10,
-        "col": 2
+        "col": 7
       }
     },
     "notifications": []
diff --git a/tests/test-dirs/locate/functors/f-test-ml-mli.t b/tests/test-dirs/locate/functors/f-test-ml-mli.t
index 35d27170b3..bffd012ce7 100644
--- a/tests/test-dirs/locate/functors/f-test-ml-mli.t
+++ b/tests/test-dirs/locate/functors/f-test-ml-mli.t
@@ -34,7 +34,7 @@ Should jump to mySet.ml:
     "file": "$TESTCASE_ROOT/mySet.ml",
     "pos": {
       "line": 2,
-      "col": 2
+      "col": 7
     }
   }
 
@@ -45,6 +45,6 @@ Should jump to mySet.mli:
     "file": "$TESTCASE_ROOT/mySet.mli",
     "pos": {
       "line": 2,
-      "col": 2
+      "col": 7
     }
   }
diff --git a/tests/test-dirs/locate/includes.t/run.t b/tests/test-dirs/locate/includes.t/run.t
index 6ffd20e5a9..e55c9ea2b8 100644
--- a/tests/test-dirs/locate/includes.t/run.t
+++ b/tests/test-dirs/locate/includes.t/run.t
@@ -13,7 +13,7 @@ thing.
       "file": "$TESTCASE_ROOT/foo.ml",
       "pos": {
         "line": 1,
-        "col": 0
+        "col": 8
       }
     },
     "notifications": []
@@ -29,7 +29,7 @@ the structure, but the stamp will have changed:
       "file": "$TESTCASE_ROOT/foo.ml",
       "pos": {
         "line": 1,
-        "col": 0
+        "col": 8
       }
     },
     "notifications": []
diff --git a/tests/test-dirs/locate/issue1199.t b/tests/test-dirs/locate/issue1199.t
index 86bc6b1738..2f0f3ccb33 100644
--- a/tests/test-dirs/locate/issue1199.t
+++ b/tests/test-dirs/locate/issue1199.t
@@ -30,7 +30,7 @@ straight to the functor.
       "file": "$TESTCASE_ROOT/func.ml",
       "pos": {
         "line": 5,
-        "col": 0
+        "col": 7
       }
     },
     "notifications": []
diff --git a/tests/test-dirs/locate/issue1424.t b/tests/test-dirs/locate/issue1424.t
index 874a14ab09..6fdad78cd9 100644
--- a/tests/test-dirs/locate/issue1424.t
+++ b/tests/test-dirs/locate/issue1424.t
@@ -27,7 +27,7 @@ Jump to interface:
     "file": "$TESTCASE_ROOT/test2.mli",
     "pos": {
       "line": 1,
-      "col": 0
+      "col": 4
     }
   }
 
diff --git a/tests/test-dirs/locate/issue1667.t b/tests/test-dirs/locate/issue1667.t
index 4484427162..1c5a51053e 100644
--- a/tests/test-dirs/locate/issue1667.t
+++ b/tests/test-dirs/locate/issue1667.t
@@ -14,14 +14,14 @@
   > -filename ./main.ml < ./main.ml | jq '.value.pos'
   {
     "line": 2,
-    "col": 2
+    "col": 14
   }
 
   $ $MERLIN single locate -look-for ml -position 7:13 \
   > -filename ./main.ml < ./main.ml | jq '.value.pos'
   {
     "line": 2,
-    "col": 2
+    "col": 14
   }
 
 
@@ -29,5 +29,5 @@
   > -filename ./main.ml < ./main.ml | jq '.value.pos'
   {
     "line": 2,
-    "col": 2
+    "col": 14
   }
diff --git a/tests/test-dirs/locate/issue802.t/run.t b/tests/test-dirs/locate/issue802.t/run.t
index 73505e98d8..1cea359c03 100644
--- a/tests/test-dirs/locate/issue802.t/run.t
+++ b/tests/test-dirs/locate/issue802.t/run.t
@@ -15,7 +15,7 @@ Test jumping from a normal constructor:
       "file": "$TESTCASE_ROOT/error.ml",
       "pos": {
         "line": 1,
-        "col": 0
+        "col": 5
       }
     },
     "notifications": []
@@ -30,7 +30,7 @@ From an exception:
       "file": "$TESTCASE_ROOT/error.ml",
       "pos": {
         "line": 3,
-        "col": 0
+        "col": 10
       }
     },
     "notifications": []
@@ -60,7 +60,7 @@ And from the extensible type name itself:
       "file": "$TESTCASE_ROOT/error.ml",
       "pos": {
         "line": 5,
-        "col": 0
+        "col": 5
       }
     },
     "notifications": []
diff --git a/tests/test-dirs/locate/issue845.t/run.t b/tests/test-dirs/locate/issue845.t/run.t
index 3dafe6f83b..5dcc18ec66 100644
--- a/tests/test-dirs/locate/issue845.t/run.t
+++ b/tests/test-dirs/locate/issue845.t/run.t
@@ -22,7 +22,7 @@ FIXME: this jumps to the .mli...
       "file": "$TESTCASE_ROOT/local_map.ml",
       "pos": {
         "line": 1,
-        "col": 0
+        "col": 7
       }
     },
     "notifications": []
@@ -39,7 +39,7 @@ Test jumping to intf:
       "file": "$TESTCASE_ROOT/local_map.mli",
       "pos": {
         "line": 1,
-        "col": 0
+        "col": 7
       }
     },
     "notifications": []
diff --git a/tests/test-dirs/locate/l-413-features.t b/tests/test-dirs/locate/l-413-features.t
index 95682571fc..7de71cff21 100644
--- a/tests/test-dirs/locate/l-413-features.t
+++ b/tests/test-dirs/locate/l-413-features.t
@@ -58,7 +58,7 @@ Module types substitutions
       "file": "$TESTCASE_ROOT/mtsubst.ml",
       "pos": {
         "line": 5,
-        "col": 19
+        "col": 31
       }
     },
     "notifications": []
@@ -86,7 +86,7 @@ Module types substitutions
       "file": "$TESTCASE_ROOT/mtsubst.ml",
       "pos": {
         "line": 5,
-        "col": 19
+        "col": 31
       }
     },
     "notifications": []
diff --git a/tests/test-dirs/locate/local-build-scheme.t b/tests/test-dirs/locate/local-build-scheme.t
index eae49fc8fe..a444f64b4c 100644
--- a/tests/test-dirs/locate/local-build-scheme.t
+++ b/tests/test-dirs/locate/local-build-scheme.t
@@ -42,7 +42,7 @@
     "file": "experimental",
     "pos": {
       "line": 1,
-      "col": 20
+      "col": 24
     }
   }
 
diff --git a/tests/test-dirs/locate/local-locate.t b/tests/test-dirs/locate/local-locate.t
new file mode 100644
index 0000000000..eeb3ae8033
--- /dev/null
+++ b/tests/test-dirs/locate/local-locate.t
@@ -0,0 +1,17 @@
+  $ cat >main.ml <<EOF
+  > let _ = let x = 42 in x
+  > EOF
+
+  $ $MERLIN single locate -look-for ml -position 1:22 \
+  > -filename main.ml <main.ml | jq '.value.pos'
+  {
+    "line": 1,
+    "col": 12
+  }
+
+  $ $MERLIN single locate -look-for mli -position 1:22 \
+  > -filename main.ml <main.ml | jq '.value.pos'
+  {
+    "line": 1,
+    "col": 12
+  }
diff --git a/tests/test-dirs/locate/locate-constrs.t b/tests/test-dirs/locate/locate-constrs.t
index 6df036bc09..c2fcddb70d 100644
--- a/tests/test-dirs/locate/locate-constrs.t
+++ b/tests/test-dirs/locate/locate-constrs.t
@@ -25,7 +25,7 @@ We could expect 1:9
     "file": "$TESTCASE_ROOT/constr.ml",
     "pos": {
       "line": 1,
-      "col": 0
+      "col": 5
     }
   }
 
@@ -42,7 +42,7 @@ With the declaration in another compilation unit:
     "file": "$TESTCASE_ROOT/constr.ml",
     "pos": {
       "line": 1,
-      "col": 18
+      "col": 21
     }
   }
 
diff --git a/tests/test-dirs/locate/module-aliases.t/run.t b/tests/test-dirs/locate/module-aliases.t/run.t
index 5eac85a908..8b1d56a598 100644
--- a/tests/test-dirs/locate/module-aliases.t/run.t
+++ b/tests/test-dirs/locate/module-aliases.t/run.t
@@ -49,7 +49,7 @@ Jump to the declaration of an element of an alisaed module `A.|f`:
     "file": "$TESTCASE_ROOT/anothermod.mli",
     "pos": {
       "line": 3,
-      "col": 0
+      "col": 4
     }
   }
 
@@ -128,7 +128,7 @@ Jump from to another module value decl `Anothermod.|a`:
     "file": "$TESTCASE_ROOT/anothermod.mli",
     "pos": {
       "line": 2,
-      "col": 0
+      "col": 5
     }
   }
 
@@ -139,7 +139,7 @@ Jump from to another module value def `Anothermod.|a`:
     "file": "$TESTCASE_ROOT/anothermod.ml",
     "pos": {
       "line": 2,
-      "col": 0
+      "col": 5
     }
   }
 
@@ -151,7 +151,7 @@ Jump to the declaration of an element of an alisaed module `A.|f`:
     "file": "$TESTCASE_ROOT/anothermod.mli",
     "pos": {
       "line": 3,
-      "col": 0
+      "col": 4
     }
   }
 
diff --git a/tests/test-dirs/locate/module-decl-aliases.t b/tests/test-dirs/locate/module-decl-aliases.t
index 0d297716e1..c1b66ff728 100644
--- a/tests/test-dirs/locate/module-decl-aliases.t
+++ b/tests/test-dirs/locate/module-decl-aliases.t
@@ -25,7 +25,7 @@
     "file": "$TESTCASE_ROOT/main.ml",
     "pos": {
       "line": 6,
-      "col": 2
+      "col": 9
     }
   }
 
@@ -35,7 +35,7 @@
     "file": "$TESTCASE_ROOT/main.ml",
     "pos": {
       "line": 2,
-      "col": 2
+      "col": 9
     }
   }
   $ $MERLIN single locate -look-for ml -position 2:10 \
@@ -44,7 +44,7 @@
     "file": "$TESTCASE_ROOT/main.ml",
     "pos": {
       "line": 6,
-      "col": 2
+      "col": 9
     }
   }
 
@@ -54,6 +54,6 @@
     "file": "$TESTCASE_ROOT/main.ml",
     "pos": {
       "line": 2,
-      "col": 2
+      "col": 9
     }
   }
diff --git a/tests/test-dirs/locate/non-local/ignore-kept-locs.t/run.t b/tests/test-dirs/locate/non-local/ignore-kept-locs.t/run.t
index 3a0fc89d37..218681b389 100644
--- a/tests/test-dirs/locate/non-local/ignore-kept-locs.t/run.t
+++ b/tests/test-dirs/locate/non-local/ignore-kept-locs.t/run.t
@@ -20,8 +20,8 @@ available:
   }
 
   $ grep -A1 from_uid log | grep -v from_uid | sed '/^--$/d'
-  Loading the cmt for unit "A"
-  Looking for A.0 in the uid_to_loc table
+  Loading the shapes for unit "A"
+  Shapes successfully loaded, looking for A.0
   Found location: File "a.ml", line 1, characters 4-9
 
   $ rm log
@@ -41,8 +41,8 @@ available:
   }
 
   $ grep -A1 from_uid log | grep -v from_uid | sed '/^--$/d'
-  Loading the cmt for unit "A"
-  Looking for A.0 in the uid_to_loc table
+  Loading the shapes for unit "A"
+  Shapes successfully loaded, looking for A.0
   Found location: File "a.ml", line 1, characters 4-9
 
   $ rm log
@@ -66,9 +66,6 @@ In the absence of cmt though, fallbacking to the cmi loc makes sense:
   }
 
   $ grep -A1 from_uid log | grep -v from_uid
-  Loading the cmt for unit "A"
-  --
-  Failed to load the cmt file.
-  Fallbacking to lookup location: File "a.ml", line 1, characters 4-9
+  No UID found, fallbacking to lookup location.
 
   $ rm log
diff --git a/tests/test-dirs/locate/non-local/preference.t/run.t b/tests/test-dirs/locate/non-local/preference.t/run.t
index 181bcda82d..404f51bf20 100644
--- a/tests/test-dirs/locate/non-local/preference.t/run.t
+++ b/tests/test-dirs/locate/non-local/preference.t/run.t
@@ -51,7 +51,7 @@ Test that Locate.locate and Locate.from_path do their job properly:
       "file": "$TESTCASE_ROOT/a.mli",
       "pos": {
         "line": 3,
-        "col": 0
+        "col": 4
       }
     },
     "notifications": []
@@ -64,7 +64,7 @@ Test that Locate.locate and Locate.from_path do their job properly:
       "file": "$TESTCASE_ROOT/a.mli",
       "pos": {
         "line": 3,
-        "col": 0
+        "col": 4
       }
     },
     "notifications": []
@@ -77,7 +77,7 @@ Test that Locate.locate and Locate.from_path do their job properly:
       "file": "$TESTCASE_ROOT/a.mli",
       "pos": {
         "line": 3,
-        "col": 0
+        "col": 4
       }
     },
     "notifications": []
diff --git a/tests/test-dirs/locate/reconstruct-identifier/off_by_one.t/run.t b/tests/test-dirs/locate/reconstruct-identifier/off_by_one.t/run.t
index c73c509066..c1bc158677 100644
--- a/tests/test-dirs/locate/reconstruct-identifier/off_by_one.t/run.t
+++ b/tests/test-dirs/locate/reconstruct-identifier/off_by_one.t/run.t
@@ -7,7 +7,7 @@ Regression test for #624
       "file": "$TESTCASE_ROOT/off_by_one.ml",
       "pos": {
         "line": 1,
-        "col": 0
+        "col": 7
       }
     },
     "notifications": []
diff --git a/tests/test-dirs/locate/sig-substs.t/run.t b/tests/test-dirs/locate/sig-substs.t/run.t
index 292826a7f4..086533403f 100644
--- a/tests/test-dirs/locate/sig-substs.t/run.t
+++ b/tests/test-dirs/locate/sig-substs.t/run.t
@@ -9,7 +9,7 @@ when both are present in the buffer (the struct will always be preferred).
       "file": "$TESTCASE_ROOT/basic.ml",
       "pos": {
         "line": 8,
-        "col": 2
+        "col": 9
       }
     },
     "notifications": []
@@ -23,7 +23,7 @@ TODO SHAPES: it could be more precise by answering 8:21
       "file": "$TESTCASE_ROOT/basic.ml",
       "pos": {
         "line": 8,
-        "col": 2
+        "col": 9
       }
     },
     "notifications": []
diff --git a/tests/test-dirs/locate/without-implem.t b/tests/test-dirs/locate/without-implem.t
index 7b5c06db64..44f5b0b153 100644
--- a/tests/test-dirs/locate/without-implem.t
+++ b/tests/test-dirs/locate/without-implem.t
@@ -40,7 +40,7 @@
       "file": "$TESTCASE_ROOT/noimpl.mli",
       "pos": {
         "line": 1,
-        "col": 0
+        "col": 5
       }
     },
     "notifications": []
diff --git a/tests/test-dirs/occurrences/issue1404.t b/tests/test-dirs/occurrences/issue1404.t
index 10098869e8..85b8b52c8e 100644
--- a/tests/test-dirs/occurrences/issue1404.t
+++ b/tests/test-dirs/occurrences/issue1404.t
@@ -84,6 +84,6 @@ locate position 2:1 returns the definition of [(+)]
     "file": "lib/ocaml/stdlib.mli",
     "pos": {
       "line": 347,
-      "col": 0
+      "col": 9
     }
   }

From 02be33cd52891ad693c42f222be26817891f397a Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Mon, 9 Oct 2023 16:32:00 +0200
Subject: [PATCH 04/58] tests: (rebase: move after changes) promote improved
 tests

---
 .../locate/context-detection/cd-field.t/run.t |  4 +-
 .../locate/context-detection/cd-label.t/run.t |  2 +-
 .../locate/context-detection/cd-test.t/run.t  |  8 +-
 tests/test-dirs/locate/issue802.t/run.t       |  2 +-
 .../locate/locate-constrs-decl-def.t          | 80 +++++++++++++++++++
 tests/test-dirs/locate/locate-constrs.t       |  3 +-
 tests/test-dirs/occurrences/ext-variant.t     |  2 -
 tests/test-dirs/occurrences/issue1398.t/run.t | 68 +++++++++++++++-
 tests/test-dirs/occurrences/issue1404.t       | 10 +--
 tests/test-dirs/occurrences/issue1410.t       | 41 +---------
 tests/test-dirs/occurrences/issue827.t/run.t  |  4 +-
 tests/test-dirs/typing-recovery.t             |  4 +-
 12 files changed, 166 insertions(+), 62 deletions(-)
 create mode 100644 tests/test-dirs/locate/locate-constrs-decl-def.t

diff --git a/tests/test-dirs/locate/context-detection/cd-field.t/run.t b/tests/test-dirs/locate/context-detection/cd-field.t/run.t
index 372cdfa77e..583bf436b7 100644
--- a/tests/test-dirs/locate/context-detection/cd-field.t/run.t
+++ b/tests/test-dirs/locate/context-detection/cd-field.t/run.t
@@ -6,7 +6,7 @@
       "file": "$TESTCASE_ROOT/field.ml",
       "pos": {
         "line": 1,
-        "col": 5
+        "col": 11
       }
     },
     "notifications": []
@@ -19,7 +19,7 @@
       "file": "$TESTCASE_ROOT/field.ml",
       "pos": {
         "line": 1,
-        "col": 5
+        "col": 11
       }
     },
     "notifications": []
diff --git a/tests/test-dirs/locate/context-detection/cd-label.t/run.t b/tests/test-dirs/locate/context-detection/cd-label.t/run.t
index 689444bf45..f7e5338d7e 100644
--- a/tests/test-dirs/locate/context-detection/cd-label.t/run.t
+++ b/tests/test-dirs/locate/context-detection/cd-label.t/run.t
@@ -49,7 +49,7 @@ We could expect 2:12 or at least 2:4
     "file": "$TESTCASE_ROOT/record.ml",
     "pos": {
       "line": 1,
-      "col": 5
+      "col": 11
     }
   }
 
diff --git a/tests/test-dirs/locate/context-detection/cd-test.t/run.t b/tests/test-dirs/locate/context-detection/cd-test.t/run.t
index b3882f95eb..1dd96f14a8 100644
--- a/tests/test-dirs/locate/context-detection/cd-test.t/run.t
+++ b/tests/test-dirs/locate/context-detection/cd-test.t/run.t
@@ -7,7 +7,7 @@ Trying them all:
       "file": "$TESTCASE_ROOT/test.ml",
       "pos": {
         "line": 1,
-        "col": 5
+        "col": 9
       }
     },
     "notifications": []
@@ -109,7 +109,7 @@ FIXME we failed to parse/reconstruct the ident, that's interesting
       "file": "$TESTCASE_ROOT/test.ml",
       "pos": {
         "line": 1,
-        "col": 5
+        "col": 9
       }
     },
     "notifications": []
@@ -151,7 +151,7 @@ FIXME this should jump to line 11:
       "file": "$TESTCASE_ROOT/test.ml",
       "pos": {
         "line": 13,
-        "col": 5
+        "col": 11
       }
     },
     "notifications": []
@@ -177,7 +177,7 @@ FIXME this should jump to line 11:
       "file": "$TESTCASE_ROOT/test.ml",
       "pos": {
         "line": 13,
-        "col": 5
+        "col": 11
       }
     },
     "notifications": []
diff --git a/tests/test-dirs/locate/issue802.t/run.t b/tests/test-dirs/locate/issue802.t/run.t
index 1cea359c03..9f32717e42 100644
--- a/tests/test-dirs/locate/issue802.t/run.t
+++ b/tests/test-dirs/locate/issue802.t/run.t
@@ -15,7 +15,7 @@ Test jumping from a normal constructor:
       "file": "$TESTCASE_ROOT/error.ml",
       "pos": {
         "line": 1,
-        "col": 5
+        "col": 9
       }
     },
     "notifications": []
diff --git a/tests/test-dirs/locate/locate-constrs-decl-def.t b/tests/test-dirs/locate/locate-constrs-decl-def.t
new file mode 100644
index 0000000000..d39a3790e5
--- /dev/null
+++ b/tests/test-dirs/locate/locate-constrs-decl-def.t
@@ -0,0 +1,80 @@
+/**
+* VARIANTS
+**/
+
+  $ cat >constr.mli <<EOF
+  > type t = A of int |  B
+  > EOF
+
+  $ cat >constr.ml <<EOF
+  > type u = C of int
+  > type t = A of int |  B
+  > let foo : t = A 42
+  > EOF
+
+  $ cat >main.ml <<EOF
+  > let foo : Constr.t = Constr.A 42
+  > EOF
+
+  $ $OCAMLC -c -bin-annot -store-usage-index constr.mli constr.ml
+
+  $ $MERLIN single locate -look-for mli -position 1:28 \
+  > -filename ./main.ml < ./main.ml | jq '.value'
+  {
+    "file": "$TESTCASE_ROOT/constr.mli",
+    "pos": {
+      "line": 1,
+      "col": 9
+    }
+  }
+
+  $ $MERLIN single locate -look-for ml -position 1:28 \
+  > -filename ./main.ml < ./main.ml | jq '.value'
+  {
+    "file": "$TESTCASE_ROOT/constr.ml",
+    "pos": {
+      "line": 2,
+      "col": 9
+    }
+  }
+
+  $ cat >main.ml <<EOF
+  > module Constr : sig
+  >   type t = A of int |  B
+  >   type u = { label_a : int }
+  > end = struct
+  >   type u = { label_a : int }
+  >   type t = A of int |  B
+  > end
+  > let foo : Constr.t = Constr.A 42
+  > let bar : Constr.u = { Constr.label_a = 42 }
+  > EOF
+
+  $ $MERLIN single locate -look-for mli -position 8:28 \
+  > -filename ./main.ml < ./main.ml | jq '.value.pos'
+  {
+    "line": 2,
+    "col": 11
+  }
+
+  $ $MERLIN single locate -look-for ml -position 8:28 \
+  > -filename ./main.ml < ./main.ml | jq '.value.pos'
+  {
+    "line": 6,
+    "col": 11
+  }
+
+
+  $ $MERLIN single locate -look-for mli -position 9:30 \
+  > -filename ./main.ml < ./main.ml | jq '.value.pos'
+  {
+    "line": 3,
+    "col": 13
+  }
+
+  $ $MERLIN single locate -look-for ml -position 9:30 \
+  > -filename ./main.ml < ./main.ml | jq '.value.pos'
+  {
+    "line": 5,
+    "col": 13
+  }
diff --git a/tests/test-dirs/locate/locate-constrs.t b/tests/test-dirs/locate/locate-constrs.t
index c2fcddb70d..06024a93b6 100644
--- a/tests/test-dirs/locate/locate-constrs.t
+++ b/tests/test-dirs/locate/locate-constrs.t
@@ -17,7 +17,6 @@
     }
   }
 
-FIXME: this is not a very satisfying answer. 
 We could expect 1:9
   $ $MERLIN single locate  -look-for ml -position 2:14 \
   > -filename ./constr.ml < ./constr.ml | jq '.value'
@@ -25,7 +24,7 @@ We could expect 1:9
     "file": "$TESTCASE_ROOT/constr.ml",
     "pos": {
       "line": 1,
-      "col": 5
+      "col": 9
     }
   }
 
diff --git a/tests/test-dirs/occurrences/ext-variant.t b/tests/test-dirs/occurrences/ext-variant.t
index 0ca6ff38e6..0130c31c9f 100644
--- a/tests/test-dirs/occurrences/ext-variant.t
+++ b/tests/test-dirs/occurrences/ext-variant.t
@@ -44,9 +44,7 @@ See issue #1185 on vscode-ocaml-platform
   > | _ -> 0
   > EOF
 
-FIXME: we can do better than that
   $ $MERLIN single occurrences -identifier-at 5:2 \
-  > -log-file - -log-section occurrences \
   > -filename main.ml <main.ml | jq '.value'
   [
     {
diff --git a/tests/test-dirs/occurrences/issue1398.t/run.t b/tests/test-dirs/occurrences/issue1398.t/run.t
index 069c4becb2..5bb9740d7d 100644
--- a/tests/test-dirs/occurrences/issue1398.t/run.t
+++ b/tests/test-dirs/occurrences/issue1398.t/run.t
@@ -78,22 +78,82 @@ Test finding occurrences of and-based binding operator, from reified syntax:
     "notifications": []
   }
 
-FIXME -- this doesn't find anything right now
 Test finding occurrences of let-based binding operator, from operator syntax:
 
   $ $MERLIN single occurrences -identifier-at 4:0 ./issue1398.ml < ./issue1398.ml
   {
     "class": "return",
-    "value": [],
+    "value": [
+      {
+        "start": {
+          "line": 1,
+          "col": 4
+        },
+        "end": {
+          "line": 1,
+          "col": 11
+        }
+      },
+      {
+        "start": {
+          "line": 3,
+          "col": 12
+        },
+        "end": {
+          "line": 3,
+          "col": 17
+        }
+      },
+      {
+        "start": {
+          "line": 4,
+          "col": 0
+        },
+        "end": {
+          "line": 4,
+          "col": 5
+        }
+      }
+    ],
     "notifications": []
   }
 
-FIXME -- this doesn't find anything right now
 Test finding occurrences of and-based binding operator, from operator syntax:
 
   $ $MERLIN single occurrences -identifier-at 4:12 ./issue1398.ml < ./issue1398.ml
   {
     "class": "return",
-    "value": [],
+    "value": [
+      {
+        "start": {
+          "line": 2,
+          "col": 4
+        },
+        "end": {
+          "line": 2,
+          "col": 11
+        }
+      },
+      {
+        "start": {
+          "line": 3,
+          "col": 21
+        },
+        "end": {
+          "line": 3,
+          "col": 26
+        }
+      },
+      {
+        "start": {
+          "line": 4,
+          "col": 12
+        },
+        "end": {
+          "line": 4,
+          "col": 17
+        }
+      }
+    ],
     "notifications": []
   }
diff --git a/tests/test-dirs/occurrences/issue1404.t b/tests/test-dirs/occurrences/issue1404.t
index 85b8b52c8e..a881b54d13 100644
--- a/tests/test-dirs/occurrences/issue1404.t
+++ b/tests/test-dirs/occurrences/issue1404.t
@@ -30,7 +30,7 @@ occurrences identifier-at 2:0 returns the occurrences of [x]
     }
   ]
 
-FIXME occurrences identifier-at 2:1 returns the occurrences of [x] (should be [+])
+Occurrences identifier-at 2:1 returns the occurrences [+]
   $ $MERLIN single occurrences -identifier-at 2:1 -filename opt.ml <<EOF | \
   > jq '.value'
   > let x = 3 and y = 4 + 2 in
@@ -40,21 +40,21 @@ FIXME occurrences identifier-at 2:1 returns the occurrences of [x] (should be [+
     {
       "start": {
         "line": 1,
-        "col": 4
+        "col": 20
       },
       "end": {
         "line": 1,
-        "col": 5
+        "col": 21
       }
     },
     {
       "start": {
         "line": 2,
-        "col": 0
+        "col": 1
       },
       "end": {
         "line": 2,
-        "col": 1
+        "col": 2
       }
     }
   ]
diff --git a/tests/test-dirs/occurrences/issue1410.t b/tests/test-dirs/occurrences/issue1410.t
index 27922260d4..14948be952 100644
--- a/tests/test-dirs/occurrences/issue1410.t
+++ b/tests/test-dirs/occurrences/issue1410.t
@@ -1,35 +1,11 @@
-FIXME
-
-First result is incorrect when in the body of a function with an optional argument
-
+FIXME: No result is returned, we could expect the one occurrence of None.
   $ $MERLIN single occurrences -identifier-at 3:3 -filename opt.ml <<EOF | \
   > jq '.value'
   > (* test case *)
   > let f ?(x=1) () = 2 ;;
   > None
   > EOF
-  [
-    {
-      "start": {
-        "line": 0,
-        "col": -1
-      },
-      "end": {
-        "line": 0,
-        "col": -1
-      }
-    },
-    {
-      "start": {
-        "line": 3,
-        "col": 0
-      },
-      "end": {
-        "line": 3,
-        "col": 4
-      }
-    }
-  ]
+  []
 
   $ $MERLIN single occurrences -identifier-at 3:3 -filename opt.ml <<EOF | \
   > jq '.value'
@@ -37,15 +13,4 @@ First result is incorrect when in the body of a function with an optional argume
   > let f () = 2 ;;
   > None
   > EOF
-  [
-    {
-      "start": {
-        "line": 3,
-        "col": 0
-      },
-      "end": {
-        "line": 3,
-        "col": 4
-      }
-    }
-  ]
+  []
diff --git a/tests/test-dirs/occurrences/issue827.t/run.t b/tests/test-dirs/occurrences/issue827.t/run.t
index 922bd797c8..f521cec891 100644
--- a/tests/test-dirs/occurrences/issue827.t/run.t
+++ b/tests/test-dirs/occurrences/issue827.t/run.t
@@ -17,7 +17,7 @@ Reproduction case:
       {
         "start": {
           "line": 4,
-          "col": 8
+          "col": 10
         },
         "end": {
           "line": 4,
@@ -76,7 +76,7 @@ work:
       {
         "start": {
           "line": 4,
-          "col": 8
+          "col": 10
         },
         "end": {
           "line": 4,
diff --git a/tests/test-dirs/typing-recovery.t b/tests/test-dirs/typing-recovery.t
index 088abcc73e..eabb5adfcd 100644
--- a/tests/test-dirs/typing-recovery.t
+++ b/tests/test-dirs/typing-recovery.t
@@ -106,7 +106,9 @@
                       Ttyp_constr \"t/273\"
                       []
                   Tpat_alias \"x/278\"
-                  pattern (test.ml[2,15+7]..test.ml[2,15+8])
+                  pattern (test.ml[2,15+7]..test.ml[2,15+8]) ghost
+                    attribute \"merlin.hide\"
+                      []
                     Tpat_any
                 expression (test.ml[3,31+2]..test.ml[6,69+12])
                   Texp_match

From c584de4708b051075ea262d3a490a52fe52d2aba Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Wed, 25 Oct 2023 16:29:51 +0200
Subject: [PATCH 05/58] config: accept INDEX_FILE directive

---
 src/dot-merlin/dot_merlin_reader.ml      | 10 ++++++++++
 src/dot-protocol/merlin_dot_protocol.ml  |  3 +++
 src/dot-protocol/merlin_dot_protocol.mli |  1 +
 src/kernel/mconfig.ml                    |  4 ++++
 src/kernel/mconfig.mli                   |  3 ++-
 src/kernel/mconfig_dot.ml                |  9 +++++++--
 src/kernel/mconfig_dot.mli               |  1 +
 7 files changed, 28 insertions(+), 3 deletions(-)

diff --git a/src/dot-merlin/dot_merlin_reader.ml b/src/dot-merlin/dot_merlin_reader.ml
index e3a1aaba00..0883f92163 100644
--- a/src/dot-merlin/dot_merlin_reader.ml
+++ b/src/dot-merlin/dot_merlin_reader.ml
@@ -305,6 +305,7 @@ type config = {
   pass_forward : Merlin_dot_protocol.Directive.no_processing_required list;
   to_canonicalize : (string * Merlin_dot_protocol.Directive.include_path) list;
   stdlib : string option;
+  index_file : string option;
   packages_to_load : string list;
   findlib : string option;
   findlib_path : string list;
@@ -315,6 +316,7 @@ let empty_config = {
   pass_forward      = [];
   to_canonicalize   = [];
   stdlib            = None;
+  index_file        = None;
   packages_to_load  = [];
   findlib           = None;
   findlib_path      = [];
@@ -339,6 +341,14 @@ let prepend_config ~cwd ~cfg =
         log ~title:"conflicting paths for stdlib" "%s\n%s" p canon_path
       end;
       { cfg with stdlib = Some canon_path }
+    | `INDEX_FILE path ->
+      let canon_path = canonicalize_filename ~cwd path in
+      begin match cfg.index_file with
+      | None -> ()
+      | Some p ->
+        log ~title:"conflicting paths for index file" "%s\n%s" p canon_path
+      end;
+      { cfg with index_file = Some canon_path }
     | `FINDLIB path ->
       let canon_path = canonicalize_filename ~cwd path in
       begin match cfg.stdlib with
diff --git a/src/dot-protocol/merlin_dot_protocol.ml b/src/dot-protocol/merlin_dot_protocol.ml
index 97648d9317..04f258729e 100644
--- a/src/dot-protocol/merlin_dot_protocol.ml
+++ b/src/dot-protocol/merlin_dot_protocol.ml
@@ -37,6 +37,7 @@ module Directive = struct
     [ `EXT of string list
     | `FLG of string list
     | `STDLIB of string
+    | `INDEX_FILE of string
     | `SUFFIX of string
     | `READER of string list
     | `EXCLUDE_QUERY_DIR
@@ -85,6 +86,7 @@ module Sexp = struct
         | "CMI" -> `CMI value
         | "CMT" -> `CMT value
         | "STDLIB" -> `STDLIB value
+        | "INDEX_FILE" -> `INDEX_FILE value
         | "SUFFIX" -> `SUFFIX value
         | "ERROR" -> `ERROR_MSG value
         | "FLG" ->
@@ -117,6 +119,7 @@ module Sexp = struct
         | `EXT ss -> ("EXT", [ List (atoms_of_strings ss) ])
         | `FLG ss -> ("FLG", [ List (atoms_of_strings ss) ])
         | `STDLIB s -> ("STDLIB", single s)
+        | `INDEX_FILE s -> ("INDEX_FILE", single s)
         | `SUFFIX s -> ("SUFFIX", single s)
         | `READER ss -> ("READER", [ List (atoms_of_strings ss) ])
         | `EXCLUDE_QUERY_DIR -> ("EXCLUDE_QUERY_DIR", [])
diff --git a/src/dot-protocol/merlin_dot_protocol.mli b/src/dot-protocol/merlin_dot_protocol.mli
index c238b813ae..ccb36e4bf0 100644
--- a/src/dot-protocol/merlin_dot_protocol.mli
+++ b/src/dot-protocol/merlin_dot_protocol.mli
@@ -49,6 +49,7 @@ module Directive : sig
     [ `EXT of string list
     | `FLG of string list
     | `STDLIB of string
+    | `INDEX_FILE of string
     | `SUFFIX of string
     | `READER of string list
     | `EXCLUDE_QUERY_DIR
diff --git a/src/kernel/mconfig.ml b/src/kernel/mconfig.ml
index 93ef775227..886d750aa8 100644
--- a/src/kernel/mconfig.ml
+++ b/src/kernel/mconfig.ml
@@ -77,6 +77,7 @@ type merlin = {
   extensions  : string list;
   suffixes    : (string * string) list;
   stdlib      : string option;
+  index_file  : string option;
   reader      : string list;
   protocol    : [`Json | `Sexp];
   log_file    : string option;
@@ -115,6 +116,7 @@ let dump_merlin x =
         ]) x.suffixes
     );
     "stdlib"       , Json.option Json.string x.stdlib;
+    "index_file"   , Json.option Json.string x.index_file;
     "reader"       , `List (List.map ~f:Json.string x.reader);
     "protocol"     , (match x.protocol with
         | `Json -> `String "json"
@@ -251,6 +253,7 @@ let get_external_config path t =
       extensions = dot.extensions @ merlin.extensions;
       suffixes = dot.suffixes @ merlin.suffixes;
       stdlib = (if dot.stdlib = None then merlin.stdlib else dot.stdlib);
+      index_file = dot.index_file;
       reader =
         if dot.reader = []
         then merlin.reader
@@ -623,6 +626,7 @@ let initial = {
     extensions  = [];
     suffixes    = [(".ml", ".mli"); (".re", ".rei")];
     stdlib      = None;
+    index_file  = None;
     reader      = [];
     protocol    = `Json;
     log_file    = None;
diff --git a/src/kernel/mconfig.mli b/src/kernel/mconfig.mli
index e219f4b4fe..4343bef9f2 100644
--- a/src/kernel/mconfig.mli
+++ b/src/kernel/mconfig.mli
@@ -35,6 +35,7 @@ type merlin = {
   extensions  : string list;
   suffixes    : (string * string) list;
   stdlib      : string option;
+  index_file  : string option;
   reader      : string list;
   protocol    : [`Json | `Sexp];
   log_file    : string option;
@@ -57,7 +58,7 @@ val dump_merlin : merlin -> json
 
 (** {1 Some flags affecting queries} *)
 
-module Verbosity : sig 
+module Verbosity : sig
   type t = Smart | Lvl of int
 
   (** the default value for verbosity, i.e., [Lvl 0] *)
diff --git a/src/kernel/mconfig_dot.ml b/src/kernel/mconfig_dot.ml
index 13ad8eba99..3a7de973e6 100644
--- a/src/kernel/mconfig_dot.ml
+++ b/src/kernel/mconfig_dot.ml
@@ -41,6 +41,7 @@ type config = {
   extensions   : string list;
   suffixes     : (string * string) list;
   stdlib       : string option;
+  index_file   : string option;
   reader       : string list;
   exclude_query_dir : bool;
   use_ppx_cache : bool;
@@ -55,6 +56,7 @@ let empty_config = {
   suffixes     = [];
   flags        = [];
   stdlib       = None;
+  index_file   = None;
   reader       = [];
   exclude_query_dir = false;
   use_ppx_cache = false;
@@ -246,6 +248,8 @@ let prepend_config ~dir:cwd configurator (directives : directive list) config =
       {config with flags = flags :: config.flags}, errors
     | `STDLIB path ->
       {config with stdlib = Some path}, errors
+    | `INDEX_FILE path ->
+      {config with index_file = Some path}, errors
     | `READER reader ->
       {config with reader}, errors
     | `EXCLUDE_QUERY_DIR ->
@@ -273,8 +277,9 @@ let postprocess_config config =
     extensions   = clean config.extensions;
     suffixes     = clean config.suffixes;
     flags        = clean config.flags;
-    stdlib      = config.stdlib;
-    reader      = config.reader;
+    stdlib       = config.stdlib;
+    index_file   = config.index_file;
+    reader       = config.reader;
     exclude_query_dir = config.exclude_query_dir;
     use_ppx_cache = config.use_ppx_cache;
   }
diff --git a/src/kernel/mconfig_dot.mli b/src/kernel/mconfig_dot.mli
index 7e1ad9a1e3..18c8f90219 100644
--- a/src/kernel/mconfig_dot.mli
+++ b/src/kernel/mconfig_dot.mli
@@ -37,6 +37,7 @@ type config = {
   extensions   : string list;
   suffixes     : (string * string) list;
   stdlib       : string option;
+  index_file   : string option;
   reader       : string list;
   exclude_query_dir : bool;
   use_ppx_cache : bool;

From c75480748c69f5c5a223ecf4d09a420a4be8b0dd Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Wed, 25 Oct 2023 16:44:17 +0200
Subject: [PATCH 06/58] occurrences: handle project wide queries

---
 src/analysis/context.ml                       |  2 +
 src/analysis/index_format.ml                  | 82 ++++++++---------
 src/analysis/occurrences.ml                   | 38 +++++---
 .../occurrences/fields-in-patterns.t          | 37 ++++++++
 .../occurrences/project-wide/simple.t         | 91 +++++++++++++++++++
 5 files changed, 193 insertions(+), 57 deletions(-)
 create mode 100644 tests/test-dirs/occurrences/fields-in-patterns.t
 create mode 100644 tests/test-dirs/occurrences/project-wide/simple.t

diff --git a/src/analysis/context.ml b/src/analysis/context.ml
index 35abbb070c..66e51c87ef 100644
--- a/src/analysis/context.ml
+++ b/src/analysis/context.ml
@@ -141,6 +141,8 @@ let inspect_browse_tree ~cursor lid browse : t option =
     | Pattern p -> inspect_pattern ~cursor ~lid p
     | Value_description _
     | Type_declaration _
+    | Constructor_declaration _
+    | Label_declaration _
     | Extension_constructor _
     | Module_binding_name _
     | Module_declaration_name _ ->
diff --git a/src/analysis/index_format.ml b/src/analysis/index_format.ml
index 45502fa4ff..643289db5b 100644
--- a/src/analysis/index_format.ml
+++ b/src/analysis/index_format.ml
@@ -1,3 +1,6 @@
+
+exception Not_an_index of string
+
 module Lid : Set.OrderedType with type t = Longident.t Location.loc = struct
   type t = Longident.t Location.loc
 
@@ -23,23 +26,20 @@ let add tbl uid locs =
     Hashtbl.replace tbl uid (LidSet.union locs locations)
   with Not_found -> Hashtbl.add tbl uid locs
 
-type payload = {
+type index = {
   defs : (Shape.Uid.t, LidSet.t) Hashtbl.t;
-  partials : (Shape.t, LidSet.t) Hashtbl.t;
-  unreduced : (Shape.t * Longident.t Location.loc) list;
+  approximated : (Shape.Uid.t, LidSet.t) Hashtbl.t;
   load_path : string list;
   cu_shape : (string, Shape.t) Hashtbl.t;
 }
 
-type file_format = V1 of payload
-
 let pp_partials (fmt : Format.formatter)
-    (partials : (Shape.t, LidSet.t) Hashtbl.t) =
+    (partials : (Shape.Uid.t, LidSet.t) Hashtbl.t) =
   Format.fprintf fmt "{@[";
   Hashtbl.iter
-    (fun shape locs ->
-      Format.fprintf fmt "@[<hov 2>shape: %a; locs:@ @[<v>%a@]@]@;" Shape.print
-        shape
+    (fun uid locs ->
+      Format.fprintf fmt "@[<hov 2>uid: %a; locs:@ @[<v>%a@]@]@;"
+        Shape.Uid.print uid
         (Format.pp_print_list
            ~pp_sep:(fun fmt () -> Format.fprintf fmt ";@;")
            (fun fmt { Location.txt; loc } ->
@@ -50,19 +50,7 @@ let pp_partials (fmt : Format.formatter)
     partials;
   Format.fprintf fmt "@]}"
 
-let pp_unreduced (fmt : Format.formatter)
-    (unreduced : (Shape.t * Longident.t Location.loc) list) =
-  Format.fprintf fmt "{@[";
-  List.iter
-    (fun (shape, { Location.txt; loc }) ->
-      Format.fprintf fmt "@[<hov 2>shape: %a; locs:@ @[<v>%s: %a@]@]@;"
-        Shape.print shape
-        (try Longident.flatten txt |> String.concat "." with _ -> "<?>")
-        Location.print_loc loc)
-    unreduced;
-  Format.fprintf fmt "@]}"
-
-let pp_payload (fmt : Format.formatter) pl =
+let pp (fmt : Format.formatter) pl =
   Format.fprintf fmt "%i uids:@ {@[" (Hashtbl.length pl.defs);
   Hashtbl.iter
     (fun uid locs ->
@@ -77,31 +65,41 @@ let pp_payload (fmt : Format.formatter) pl =
         (LidSet.elements locs))
     pl.defs;
   Format.fprintf fmt "@]},@ ";
-  Format.fprintf fmt "%i partial shapes:@ @[%a@],@ "
-    (Hashtbl.length pl.partials)
-    pp_partials pl.partials;
-  Format.fprintf fmt "%i unreduced shapes:@ @[%a@]@ " (List.length pl.unreduced)
-    pp_unreduced pl.unreduced;
+  Format.fprintf fmt "%i approx shapes:@ @[%a@],@ "
+    (Hashtbl.length pl.approximated)
+    pp_partials pl.approximated;
   Format.fprintf fmt "and shapes for CUS %s.@ "
     (String.concat ";@," (Hashtbl.to_seq_keys pl.cu_shape |> List.of_seq))
 
-let pp (fmt : Format.formatter) ff =
-  match ff with V1 tbl -> Format.fprintf fmt "V1@,%a" pp_payload tbl
-
 let ext = "uideps"
 
-let write ~file tbl =
-  let oc = open_out_bin file in
-  Marshal.to_channel oc (V1 tbl) [];
-  close_out oc
+(* [magic_number] Must be the same lenght as cmt's magic numbers *)
+let magic_number = "Merl2023I001"
+
+let write ~file index =
+  Merlin_utils.Misc.output_to_file_via_temporary ~mode:[ Open_binary ] file
+    (fun _temp_file_name oc ->
+      output_string oc magic_number;
+      output_value oc (index : index))
+
+type file_content = Cmt of Cmt_format.cmt_infos | Index of index | Unknown
 
 let read ~file =
   let ic = open_in_bin file in
-  try
-    let payload =
-      match Marshal.from_channel ic with V1 payload -> payload
-      (* TODO is that "safe" ? We probably want some magic number *)
-    in
-    close_in ic;
-    payload
-  with e -> raise e (* todo *)
+  Merlin_utils.Misc.try_finally
+    ~always:(fun () -> close_in ic)
+    (fun () ->
+      let file_magic_number = ref (Cmt_format.read_magic_number ic) in
+      let cmi_magic_number = Ocaml_utils.Config.cmi_magic_number in
+      let cmt_magic_number = Ocaml_utils.Config.cmt_magic_number in
+      (if String.equal !file_magic_number cmi_magic_number then
+         let _ = Cmi_format.input_cmi ic in
+         file_magic_number := Cmt_format.read_magic_number ic);
+      if String.equal !file_magic_number cmt_magic_number then
+        Cmt (input_value ic : Cmt_format.cmt_infos)
+      else if String.equal !file_magic_number magic_number then
+        Index (input_value ic : index)
+      else Unknown)
+
+let read_exn ~file =
+  match read ~file with Index index -> index | _ -> raise (Not_an_index file)
diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml
index b84d4b94f8..b4d35ba48d 100644
--- a/src/analysis/occurrences.ml
+++ b/src/analysis/occurrences.ml
@@ -41,10 +41,6 @@ let index_buffer ~env ~local_defs () =
         | _ -> ());
   defs
 
-let load_external_index ~index_file =
-  let uideps = Index_format.read ~file:index_file in
-  uideps
-
 let merge_tbl ~into tbl = Hashtbl.iter (Index_format.add into) tbl
 
 (* A longident can have the form: A.B.x Right now we are only interested in
@@ -76,6 +72,10 @@ let uid_and_loc_of_node env node =
       Some (uid, name.loc)
   | Type_declaration { typ_type; typ_name; _ } ->
       Some (typ_type.type_uid, typ_name.loc)
+  | Label_declaration { ld_uid; ld_loc ; _ } ->
+      Some (ld_uid, ld_loc)
+  | Constructor_declaration { cd_uid; cd_loc ; _ } ->
+      Some (cd_uid, cd_loc)
   | Value_description { val_val; val_name; _ } ->
       Some (val_val.val_uid, val_name.loc)
   | _ -> None
@@ -122,21 +122,22 @@ let locs_of ~config ~scope ~env ~local_defs ~pos ~node:_ path =
       log ~title:"locs_of" "Locate failed to find a definition.";
       None
   in
+  let current_buffer_path =
+    Filename.concat config.query.directory config.query.filename
+  in
   match def with
-  | Some (uid, loc) ->
+  | Some (uid, def_loc) ->
     log ~title:"locs_of" "Definition has uid %a (%a)"
       Logger.fmt (fun fmt -> Shape.Uid.print fmt uid)
-      Logger.fmt (fun fmt -> Location.print_loc fmt loc);
-    (* Todo: use magic number instead and don't use the lib *)
-    let index_file = None (* todo *) in
+      Logger.fmt (fun fmt -> Location.print_loc fmt def_loc);
     log ~title:"locs_of" "Indexing current buffer";
     let index = index_buffer ~env ~local_defs () in
     if scope = `Project then begin
-      match index_file with
+      match config.merlin.index_file with
       | None -> log ~title:"locs_of" "No external index specified"
-      | Some index_file ->
-        log ~title:"locs_of" "Using external index: %S" index_file;
-        let external_uideps = load_external_index ~index_file in
+      | Some file ->
+        log ~title:"locs_of" "Using external index: %S" file;
+        let external_uideps = Index_format.read_exn ~file in
         merge_tbl ~into:index external_uideps.defs
     end;
     (* TODO ignore externally indexed locs from the current buffer *)
@@ -146,7 +147,11 @@ let locs_of ~config ~scope ~env ~local_defs ~pos ~node:_ path =
         |> List.filter_map ~f:(fun lid ->
           let loc = last_loc lid.Location.loc lid.txt in
           let fname = loc.Location.loc_start.Lexing.pos_fname in
-          if Filename.is_relative fname then begin
+          if String.equal fname current_buffer_path then
+            (* ignore locs coming from the external index for the buffer *)
+            (* maybe filter before *)
+            None
+          else if Filename.is_relative fname then begin
             match Locate.find_source ~config loc fname with
             | `Found (Some file, _) -> Some { loc with loc_start =
                 { loc.loc_start with pos_fname = file}}
@@ -165,6 +170,9 @@ let locs_of ~config ~scope ~env ~local_defs ~pos ~node:_ path =
       let by = Env.get_unit_name () |> String.lowercase_ascii in
       String.is_prefixed ~by (loc.loc_start.pos_fname |> String.lowercase_ascii)
     in
-    if scope = `Project || loc_in_unit loc then Ok (loc::locs)
-    else Ok locs
+    if loc_in_unit def_loc then
+      let def_loc = {def_loc with
+        loc_start = {def_loc.loc_start with pos_fname = current_buffer_path }} in
+      Ok (def_loc::locs)
+      else Ok locs
   | None -> Error "nouid"
diff --git a/tests/test-dirs/occurrences/fields-in-patterns.t b/tests/test-dirs/occurrences/fields-in-patterns.t
new file mode 100644
index 0000000000..50e6b2d492
--- /dev/null
+++ b/tests/test-dirs/occurrences/fields-in-patterns.t
@@ -0,0 +1,37 @@
+  $ cat >main.ml <<EOF
+  > type t = { lbl_a : int }
+  > let f (x : t) = match x with
+  >   | { lbl_a } -> ignore lbl_a
+  > EOF
+ 
+
+  $ $MERLIN single occurrences -identifier-at 3:8 -scope project \
+  > -filename main.ml <main.ml 
+  {
+    "class": "return",
+    "value": [
+      {
+        "file": "$TESTCASE_ROOT/main.ml",
+        "start": {
+          "line": 3,
+          "col": 6
+        },
+        "end": {
+          "line": 3,
+          "col": 11
+        }
+      },
+      {
+        "file": "$TESTCASE_ROOT/main.ml",
+        "start": {
+          "line": 3,
+          "col": 24
+        },
+        "end": {
+          "line": 3,
+          "col": 29
+        }
+      }
+    ],
+    "notifications": []
+  }
diff --git a/tests/test-dirs/occurrences/project-wide/simple.t b/tests/test-dirs/occurrences/project-wide/simple.t
new file mode 100644
index 0000000000..6d2c47d163
--- /dev/null
+++ b/tests/test-dirs/occurrences/project-wide/simple.t
@@ -0,0 +1,91 @@
+  $ cat >dune-workspace <<'EOF'
+  > (lang dune 3.11)
+  > (workspace_indexation enabled)
+  > EOF
+
+  $ cat >dune-project <<'EOF'
+  > (lang dune 3.11)
+  > EOF
+
+  $ mkdir lib
+  $ cat >lib/lib.ml <<'EOF'
+  > let x = 42
+  > let y = x
+  > EOF
+
+  $ cat >lib/dune <<'EOF'
+  > (library
+  >  (name lib))
+  > EOF
+
+  $ mkdir exe
+  $ cat >exe/main.ml <<'EOF'
+  > print_int Lib.x
+  > EOF
+
+  $ cat >exe/dune <<'EOF'
+  > (library
+  >  (name main)
+  >  (libraries lib))
+  > EOF
+
+  $ dune build @all
+  ld: warning: -undefined suppress is deprecated
+  ld: warning: -undefined suppress is deprecated
+  ld: warning: -undefined suppress is deprecated
+  ld: warning: -undefined suppress is deprecated
+
+  $ ocaml-index dump _build/default/project.ocaml-index
+  3 uids:
+  {uid: Lib.1; locs:
+     "y": File "$TESTCASE_ROOT/lib/lib.ml", line 2, characters 4-5
+   uid: Stdlib.313; locs:
+     "print_int": File "$TESTCASE_ROOT/exe/main.ml", line 1, characters 0-9
+   uid: Lib.0; locs:
+     "Lib.x": File "$TESTCASE_ROOT/exe/main.ml", line 1, characters 10-15;
+     "x": File "$TESTCASE_ROOT/lib/lib.ml", line 1, characters 4-5;
+     "x": File "$TESTCASE_ROOT/lib/lib.ml", line 2, characters 8-9
+   }, 0 approx shapes: {}, and shapes for CUS .
+
+Occurrences of Lib.x
+  $ $MERLIN single occurrences -scope project -identifier-at 1:15 \
+  > -filename exe/main.ml <exe/main.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "file": "$TESTCASE_ROOT/lib/lib.ml",
+        "start": {
+          "line": 1,
+          "col": 4
+        },
+        "end": {
+          "line": 1,
+          "col": 5
+        }
+      },
+      {
+        "file": "$TESTCASE_ROOT/exe/main.ml",
+        "start": {
+          "line": 1,
+          "col": 14
+        },
+        "end": {
+          "line": 1,
+          "col": 15
+        }
+      },
+      {
+        "file": "$TESTCASE_ROOT/lib/lib.ml",
+        "start": {
+          "line": 2,
+          "col": 8
+        },
+        "end": {
+          "line": 2,
+          "col": 9
+        }
+      }
+    ],
+    "notifications": []
+  }

From 461aabb95fa9967b07e5a17091abbda59aab9c06 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Tue, 14 Nov 2023 14:08:18 +0100
Subject: [PATCH 07/58] tests: new and improved tests

---
 .../config/dot-merlin-reader/quoting.t        |   1 +
 .../locate/in-implicit-trans-dep.t/run.t      |  14 +-
 .../locate/locate-constrs-decl-def.t          |  24 ++-
 .../test-dirs/occurrences/constrs-decl-def.t  | 189 ++++++++++++++++++
 tests/test-dirs/occurrences/issue1398.t/run.t |   4 +-
 .../occurrences/project-wide/simple.t         |   4 -
 6 files changed, 225 insertions(+), 11 deletions(-)
 create mode 100644 tests/test-dirs/occurrences/constrs-decl-def.t

diff --git a/tests/test-dirs/config/dot-merlin-reader/quoting.t b/tests/test-dirs/config/dot-merlin-reader/quoting.t
index b9ae8c7eee..ca81bb5323 100644
--- a/tests/test-dirs/config/dot-merlin-reader/quoting.t
+++ b/tests/test-dirs/config/dot-merlin-reader/quoting.t
@@ -51,6 +51,7 @@
       }
     ],
     "stdlib": null,
+    "index_file": null,
     "reader": [],
     "protocol": "json",
     "log_file": null,
diff --git a/tests/test-dirs/locate/in-implicit-trans-dep.t/run.t b/tests/test-dirs/locate/in-implicit-trans-dep.t/run.t
index d844c52eb1..7427839f88 100644
--- a/tests/test-dirs/locate/in-implicit-trans-dep.t/run.t
+++ b/tests/test-dirs/locate/in-implicit-trans-dep.t/run.t
@@ -1,12 +1,18 @@
   $ dune build @check
 
-FIXME: When the deifinition is in one of the implicit transitive dependencies
-Merlin does not found the file in the source path provided by Dune. One possible
-fix would be for Dune to provide additional source path for "externatl" deps.
+When the definition is in one of the implicit transitive dependencies
+Merlin does not find the file in the source path provided by Dune. One possible
+fix would be for Dune to provide additional source path for "external" deps.
   $ $MERLIN single locate -look-for ml -position 1:15 \
   > -filename bin/main.ml <bin/main.ml
   {
     "class": "return",
-    "value": "'Lib1.t' seems to originate from 'Lib2' whose ML file could not be found",
+    "value": {
+      "file": "$TESTCASE_ROOT/src/lib2/lib2.ml",
+      "pos": {
+        "line": 1,
+        "col": 5
+      }
+    },
     "notifications": []
   }
diff --git a/tests/test-dirs/locate/locate-constrs-decl-def.t b/tests/test-dirs/locate/locate-constrs-decl-def.t
index d39a3790e5..8ec3fbaaa1 100644
--- a/tests/test-dirs/locate/locate-constrs-decl-def.t
+++ b/tests/test-dirs/locate/locate-constrs-decl-def.t
@@ -4,16 +4,18 @@
 
   $ cat >constr.mli <<EOF
   > type t = A of int |  B
+  > type u = { label_a : int }
   > EOF
 
   $ cat >constr.ml <<EOF
-  > type u = C of int
+  > type u = { label_a : int }
   > type t = A of int |  B
   > let foo : t = A 42
   > EOF
 
   $ cat >main.ml <<EOF
   > let foo : Constr.t = Constr.A 42
+  > let bar : Constr.u = { Constr.label_a = 42 }
   > EOF
 
   $ $OCAMLC -c -bin-annot -store-usage-index constr.mli constr.ml
@@ -38,6 +40,26 @@
     }
   }
 
+  $ $MERLIN single locate -look-for mli -position 2:30 \
+  > -filename ./main.ml < ./main.ml | jq '.value'
+  {
+    "file": "$TESTCASE_ROOT/constr.mli",
+    "pos": {
+      "line": 2,
+      "col": 11
+    }
+  }
+
+  $ $MERLIN single locate -look-for ml -position 2:30 \
+  > -filename ./main.ml < ./main.ml | jq '.value'
+  {
+    "file": "$TESTCASE_ROOT/constr.ml",
+    "pos": {
+      "line": 1,
+      "col": 11
+    }
+  }
+
   $ cat >main.ml <<EOF
   > module Constr : sig
   >   type t = A of int |  B
diff --git a/tests/test-dirs/occurrences/constrs-decl-def.t b/tests/test-dirs/occurrences/constrs-decl-def.t
new file mode 100644
index 0000000000..06a0343b53
--- /dev/null
+++ b/tests/test-dirs/occurrences/constrs-decl-def.t
@@ -0,0 +1,189 @@
+  $ cat >main.ml <<'EOF'
+  > module M : sig
+  >   type t = A of { label_a : int }
+  > end = struct
+  >   type t = A of { label_a : int }
+  >   let _ = A { label_a = 1 }
+  > end
+  > 
+  > let _ = M.A { label_a = 1 }
+  > 
+  > open M
+  > 
+  > let _ = A { label_a = 1 }
+  > EOF
+
+Constructor declaration:
+  $ $MERLIN single locate -look-for mli -position 12:8 \
+  > -filename main.ml <main.ml | jq '.value.pos'
+  {
+    "line": 2,
+    "col": 11
+  }
+
+Constructor definition:
+  $ $MERLIN single locate -look-for ml -position 12:8 \
+  > -filename main.ml <main.ml | jq '.value.pos'
+  {
+    "line": 4,
+    "col": 11
+  }
+
+Label declaration:
+  $ $MERLIN single locate -look-for mli -position 12:13 \
+  > -filename main.ml <main.ml | jq '.value.pos'
+  {
+    "line": 2,
+    "col": 18
+  }
+
+Label definition:
+  $ $MERLIN single locate -look-for ml -position 12:13 \
+  > -filename main.ml <main.ml | jq '.value.pos'
+  {
+    "line": 4,
+    "col": 18
+  }
+
+Constructor occurrences:
+  $ $MERLIN single occurrences -identifier-at 12:8 \
+  > -filename main.ml <main.ml | grep line | uniq
+          "line": 4,
+          "line": 5,
+          "line": 8,
+          "line": 12,
+
+Label occurrences:
+  $ $MERLIN single occurrences -identifier-at 12:13 \
+  > -filename main.ml <main.ml | jq '.value'
+  [
+    {
+      "start": {
+        "line": 4,
+        "col": 18
+      },
+      "end": {
+        "line": 4,
+        "col": 25
+      }
+    },
+    {
+      "start": {
+        "line": 5,
+        "col": 14
+      },
+      "end": {
+        "line": 5,
+        "col": 21
+      }
+    },
+    {
+      "start": {
+        "line": 8,
+        "col": 14
+      },
+      "end": {
+        "line": 8,
+        "col": 21
+      }
+    },
+    {
+      "start": {
+        "line": 12,
+        "col": 12
+      },
+      "end": {
+        "line": 12,
+        "col": 19
+      }
+    }
+  ]
+
+  $ cat >main.ml <<'EOF'
+  > type t = { a : int; b : float }
+  > let _ = { a = 4; b = 2.0 }
+  > let a = 4
+  > let r = { a; b = 2.0 }
+  > let _ = { r with b = 2.0 }
+  > let { a; b } = r
+  > EOF
+
+  $ $MERLIN single occurrences -identifier-at 6:15 \
+  > -filename main.ml <main.ml | jq '.value'
+  [
+    {
+      "start": {
+        "line": 4,
+        "col": 4
+      },
+      "end": {
+        "line": 4,
+        "col": 5
+      }
+    },
+    {
+      "start": {
+        "line": 5,
+        "col": 10
+      },
+      "end": {
+        "line": 5,
+        "col": 11
+      }
+    },
+    {
+      "start": {
+        "line": 6,
+        "col": 15
+      },
+      "end": {
+        "line": 6,
+        "col": 16
+      }
+    }
+  ]
+
+  $ $MERLIN single occurrences -identifier-at 2:10 \
+  > -filename main.ml <main.ml | jq '.value'
+  [
+    {
+      "start": {
+        "line": 1,
+        "col": 11
+      },
+      "end": {
+        "line": 1,
+        "col": 12
+      }
+    },
+    {
+      "start": {
+        "line": 2,
+        "col": 10
+      },
+      "end": {
+        "line": 2,
+        "col": 11
+      }
+    },
+    {
+      "start": {
+        "line": 4,
+        "col": 10
+      },
+      "end": {
+        "line": 4,
+        "col": 11
+      }
+    },
+    {
+      "start": {
+        "line": 6,
+        "col": 6
+      },
+      "end": {
+        "line": 6,
+        "col": 7
+      }
+    }
+  ]
diff --git a/tests/test-dirs/occurrences/issue1398.t/run.t b/tests/test-dirs/occurrences/issue1398.t/run.t
index 5bb9740d7d..93541666b7 100644
--- a/tests/test-dirs/occurrences/issue1398.t/run.t
+++ b/tests/test-dirs/occurrences/issue1398.t/run.t
@@ -17,7 +17,7 @@ Test finding occurrences of let-based binding operator, from reified syntax:
       {
         "start": {
           "line": 3,
-          "col": 10
+          "col": 12
         },
         "end": {
           "line": 3,
@@ -57,7 +57,7 @@ Test finding occurrences of and-based binding operator, from reified syntax:
       {
         "start": {
           "line": 3,
-          "col": 19
+          "col": 21
         },
         "end": {
           "line": 3,
diff --git a/tests/test-dirs/occurrences/project-wide/simple.t b/tests/test-dirs/occurrences/project-wide/simple.t
index 6d2c47d163..c212c89d84 100644
--- a/tests/test-dirs/occurrences/project-wide/simple.t
+++ b/tests/test-dirs/occurrences/project-wide/simple.t
@@ -30,10 +30,6 @@
   > EOF
 
   $ dune build @all
-  ld: warning: -undefined suppress is deprecated
-  ld: warning: -undefined suppress is deprecated
-  ld: warning: -undefined suppress is deprecated
-  ld: warning: -undefined suppress is deprecated
 
   $ ocaml-index dump _build/default/project.ocaml-index
   3 uids:

From 5396ff0d2d41cfe0df0fc66c0523b14a37dc225e Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Wed, 15 Nov 2023 18:43:42 +0100
Subject: [PATCH 08/58] Locate refactor

---
 src/analysis/locate.ml | 426 +++++++++++++++++++++--------------------
 1 file changed, 221 insertions(+), 205 deletions(-)

diff --git a/src/analysis/locate.ml b/src/analysis/locate.ml
index 7ee1b34eca..b197d4c8ed 100644
--- a/src/analysis/locate.ml
+++ b/src/analysis/locate.ml
@@ -352,9 +352,182 @@ let scrape_alias ~env ~fallback_uid ~namespace path =
   in
   non_alias_declaration_uid ~fallback_uid path
 
-type 'a approx = { t : 'a; approximated : bool }
+type namespace = Namespace.t
+module Namespace = struct
+  type under_type = [ `Constr | `Labels ]
+
+  type t = (* TODO: share with [Namespace.t] *)
+    [ `Type | `Mod | `Modtype | `Vals | under_type ]
+
+  type inferred =
+    [ t
+    | `This_label of Types.label_description
+    | `This_cstr of Types.constructor_description ]
+
+  let from_context : Context.t -> inferred list = function
+    | Type          -> [ `Type ; `Mod ; `Modtype ; `Constr ; `Labels ; `Vals ]
+    | Module_type   -> [ `Modtype ; `Mod ; `Type ; `Constr ; `Labels ; `Vals ]
+    | Expr | Constant ->
+      [ `Vals ; `Mod ; `Modtype ; `Constr ; `Labels ; `Type ]
+    | Patt          -> [ `Mod ; `Modtype ; `Type ; `Constr ; `Labels ; `Vals ]
+    | Unknown       -> [ `Vals ; `Type ; `Constr ; `Mod ; `Modtype ; `Labels ]
+    | Label lbl     -> [ `This_label lbl ]
+    | Module_path   -> [ `Mod ]
+    | Constructor (c, _) -> [ `This_cstr c ]
+end
+
+module Env_lookup : sig
+
+  type declaration = {
+    uid: Shape.Uid.t;
+    loc: Location.t;
+    namespace: Shape.Sig_component_kind.t
+  }
+
+  val loc
+    : Path.t
+    -> namespace
+    -> Env.t
+    -> declaration option
+
+  val in_namespaces
+     : Namespace.inferred list
+    -> Longident.t
+    -> Env.t
+    -> (Path.t * declaration) option
 
-let uid_of_path ~config ~env ~decl_uid path namespace =
+end = struct
+
+  type declaration = {
+    uid: Shape.Uid.t;
+    loc: Location.t;
+    namespace: Shape.Sig_component_kind.t
+  }
+
+  let loc path (namespace : namespace) env =
+    try
+      let loc, uid, namespace =
+        match namespace with
+        | `Unknown
+        | `Apply
+        | `Vals ->
+          let vd = Env.find_value path env in
+          vd.val_loc, vd.val_uid, Shape.Sig_component_kind.Value
+        | `Constr
+        | `Labels
+        | `Type ->
+          let td = Env.find_type path env in
+          td.type_loc, td.type_uid, Shape.Sig_component_kind.Type
+        | `Functor
+        | `Mod ->
+          let md = Env.find_module path env in
+          md.md_loc, md.md_uid, Shape.Sig_component_kind.Module
+        | `Modtype ->
+          let mtd = Env.find_modtype path env in
+          mtd.mtd_loc, mtd.mtd_uid, Shape.Sig_component_kind.Module_type
+      in
+      Some { uid; loc; namespace }
+    with
+      Not_found -> None
+
+  exception Found of
+    (Path.t * Shape.Sig_component_kind.t * Shape.Uid.t * Location.t)
+
+  let path_and_loc_of_cstr desc _ =
+    let open Types in
+    match desc.cstr_tag with
+    | Cstr_extension (path, _) -> path, desc.cstr_loc
+    | _ ->
+      match get_desc desc.cstr_res with
+      | Tconstr (path, _, _) -> path, desc.cstr_loc
+      | _ -> assert false
+
+  let path_and_loc_from_label desc env =
+    let open Types in
+    match get_desc desc.lbl_res with
+    | Tconstr (path, _, _) ->
+      let typ_decl = Env.find_type path env in
+      path, typ_decl.Types.type_loc
+    | _ -> assert false
+
+  let in_namespaces (nss : Namespace.inferred list) ident env =
+    let open Shape.Sig_component_kind in
+    try
+      List.iter nss ~f:(fun namespace ->
+        try
+          match namespace with
+          | `This_cstr ({ Types.cstr_tag = Cstr_extension _; _ } as cd) ->
+            log ~title:"lookup"
+              "got extension constructor";
+            let path, loc = path_and_loc_of_cstr cd env in
+            (* TODO: Use [`Constr] here instead of [`Type] *)
+            raise (Found (path, Extension_constructor, cd.cstr_uid, loc))
+          | `This_cstr cd ->
+            log ~title:"lookup"
+              "got constructor, fetching path and loc in type namespace";
+            let path, loc = path_and_loc_of_cstr cd env in
+            log ~title:"lookup" "found path: %a"
+              Logger.fmt (fun fmt -> Path.print fmt path);
+            let path = Path.Pdot (path, cd.cstr_name)
+            in
+            raise (Found (path, Constructor, cd.cstr_uid, loc))
+          | `Constr ->
+            log ~title:"lookup" "lookup in constructor namespace" ;
+            let cd = Env.find_constructor_by_name ident env in
+            let path, loc = path_and_loc_of_cstr cd env in
+            let path = Path.Pdot (path, cd.cstr_name) in
+            (* TODO: Use [`Constr] here instead of [`Type] *)
+            raise (Found (path, Constructor,cd.cstr_uid, loc))
+          | `Mod ->
+            log ~title:"lookup" "lookup in module namespace" ;
+            let path, md = Env.find_module_by_name ident env in
+            raise (Found (path, Module, md.md_uid, md.Types.md_loc))
+          | `Modtype ->
+            let path, mtd = Env.find_modtype_by_name ident env in
+            raise
+              (Found (path, Module_type, mtd.mtd_uid, mtd.Types.mtd_loc))
+          | `Type ->
+            log ~title:"lookup" "lookup in type namespace" ;
+            let path, typ_decl = Env.find_type_by_name ident env in
+            raise (
+              Found
+                (path, Type, typ_decl.type_uid, typ_decl.Types.type_loc)
+            )
+          | `Vals ->
+            log ~title:"lookup" "lookup in value namespace" ;
+            let path, val_desc = Env.find_value_by_name ident env in
+            raise (
+              Found
+                (path, Value, val_desc.val_uid, val_desc.Types.val_loc)
+            )
+          | `This_label lbl ->
+            log ~title:"lookup"
+              "got label, fetching path and loc in type namespace";
+            let path, loc = path_and_loc_from_label lbl env in
+            let path = Path.Pdot (path, lbl.lbl_name)
+            in
+            raise (Found (path, Label, lbl.lbl_uid, loc))
+          | `Labels ->
+            log ~title:"lookup" "lookup in label namespace" ;
+            let lbl = Env.find_label_by_name ident env in
+            let path, loc = path_and_loc_from_label lbl env in
+            (* TODO: Use [`Labels] here instead of [`Type] *)
+            raise (Found (path, Type, lbl.lbl_uid, loc))
+        with Not_found -> ()
+      ) ;
+      log ~title:"lookup" "   ... not in the environment" ;
+      None
+    with Found (path, namespace, decl_uid, loc) ->
+      log ~title:"env_lookup" "found: '%a' in namespace %s with decl_uid %a\nat loc %a"
+        Logger.fmt (fun fmt -> Path.print fmt path)
+        (Shape.Sig_component_kind.to_string namespace)
+        Logger.fmt (fun fmt -> Shape.Uid.print fmt decl_uid)
+        Logger.fmt (fun fmt -> Location.print_loc fmt loc);
+      Some (path, { uid = decl_uid; loc; namespace })
+end
+
+let uid_of_path ~config ~env ~(decl : Env_lookup.declaration) path =
+  let namespace = decl.namespace in
   let module Shape_reduce =
     Shape.Make_reduce (struct
       type env = Env.t
@@ -387,33 +560,23 @@ let uid_of_path ~config ~env ~decl_uid path namespace =
   in
   match config.ml_or_mli with
   | `MLI ->
-    let uid = unalias ~config decl_uid in
+    let uid = unalias ~config decl.uid in
     log ~title:"uid_of_path" "Declaration uid: %a"
-      Logger.fmt (fun fmt -> Shape.Uid.print fmt decl_uid);
-    { t = Some uid; approximated = false }
+      Logger.fmt (Fun.flip Shape.Uid.print decl.uid);
+    Shape.Resolved uid
   | `ML ->
     let shape = Env.shape_of_path ~namespace env path in
     log ~title:"shape_of_path" "initial: %a"
-      Logger.fmt (fun fmt -> Shape.print fmt shape);
+      Logger.fmt (Fun.flip Shape.print shape);
     let reduced = Shape_reduce.reduce_for_uid
       ~keep_aliases:(not config.traverse_aliases) env shape
     in
     log ~title:"shape_of_path" "reduced: %a"
       Logger.fmt (fun fmt -> Shape.print_reduction_result fmt reduced);
-    begin match reduced with
-    | Resolved uid -> { t = Some uid; approximated = false }
-    | Approximated None ->
-        let uid = unalias ~config decl_uid in
-        log ~title:"shape_of_path" "Falling back to the declaration uid: %a"
-          Logger.fmt (fun fmt -> Shape.Uid.print fmt uid);
-        { t = Some uid; approximated = true }
-    | Approximated t ->
-      { t; approximated = true }
-    | Unresolved { uid; desc = Comp_unit _; approximated } -> { t = uid; approximated }
-    | _ -> { t = None; approximated = false }
-    end
+    reduced
 
-let from_uid ~config ~local_defs uid loc path =
+let from_reduction_result
+  ~config ~local_defs ~(decl : Env_lookup.declaration) shape_result path =
   let title = "from_uid" in
   let loc_of_comp_unit comp_unit =
     match load_cmt ~config comp_unit with
@@ -423,8 +586,8 @@ let from_uid ~config ~local_defs uid loc path =
       Some loc
     | _ -> None
   in
-  let loc_of_decl ~uid decl =
-    match Misc_utils.loc_of_decl ~uid decl  with
+  let loc_of_decl ~uid def =
+    match Misc_utils.loc_of_decl ~uid def  with
     | Some loc ->
       log ~title "Found location: %a"
         Logger.fmt (fun fmt -> Location.print_loc fmt loc.loc);
@@ -433,12 +596,23 @@ let from_uid ~config ~local_defs uid loc path =
       (* Check: this should never happen *)
       log ~title "The declaration has no location. \
         Fallbacking to the node's location: %a"
-        Logger.fmt (fun fmt -> Location.print_loc fmt loc);
-      Some (uid, loc)
+        Logger.fmt (fun fmt -> Location.print_loc fmt decl.loc);
+      Some (uid, decl.loc)
+  in
+  let uid, approximated =
+    match shape_result with
+    | Shape.Resolved uid -> uid, false
+    | Unresolved { uid = Some uid; desc = Comp_unit _; approximated } ->
+        uid, approximated
+    (* | Unresolved { uid = Some uid; approximated; _ } ->
+        uid, approximated *)
+    | Unresolved _ | Approximated _ | Missing_uid ->
+        log ~title "No definition uid, fallbacking to the declaration uid: %a"
+          Logger.fmt (Fun.flip Shape.Uid.print decl.uid);
+        decl.uid, true
   in
-  let approximated = uid.approximated in
-  match uid.t with
-  | Some (Shape.Uid.Item { comp_unit; _ } as uid) ->
+  match uid with
+  | Shape.Uid.Item { comp_unit; _ } ->
     let locopt =
       let log_and_return msg = log ~title msg; None in
       if Env.get_unit_name () = comp_unit then begin
@@ -453,10 +627,10 @@ let from_uid ~config ~local_defs uid loc path =
           log ~title
             "Uid not found in the local table.\
             Fallbacking to the node's location: %a"
-          Logger.fmt (fun fmt -> Location.print_loc fmt loc);
-          Some (uid, loc)
+          Logger.fmt (fun fmt -> Location.print_loc fmt decl.loc);
+          Some (uid, decl.loc)
       end else begin
-        log ~title "Loading the shapes for unit %S" comp_unit;
+        log ~title "Loading the cmt file for unit %S" comp_unit;
         match load_cmt ~config comp_unit with
         | Ok (_pos_fname, cmt) ->
           log ~title "Shapes successfully loaded, looking for %a"
@@ -466,17 +640,21 @@ let from_uid ~config ~local_defs uid loc path =
             | None ->
               log ~title "Uid not found in the cmt table. \
                 Fallbacking to the node's location: %a"
-                Logger.fmt (fun fmt -> Location.print_loc fmt loc);
-              Some (uid, loc)
+                Logger.fmt (fun fmt -> Location.print_loc fmt decl.loc);
+              Some (uid, decl.loc)
           end
-        | _ -> log_and_return  "Failed to load the shapes"
+        | _ -> log_and_return "Failed to load the shapes"
       end
     in
     begin match locopt with
     | Some (uid, loc) -> `Found (Some uid, loc, approximated)
-    | None -> `Not_found (Path.name path, None)
+    | None ->
+      log ~title "Uid not found in the cmt table. \
+        Fallbacking to the node's location: %a"
+      Logger.fmt (fun fmt -> Location.print_loc fmt decl.loc);
+      `Found (Some uid, decl.loc, true)
     end
-  | Some (Compilation_unit comp_unit as uid) ->
+  | Compilation_unit comp_unit ->
     begin
       log ~title "Got the uid of a compilation unit: %a"
         Logger.fmt (fun fmt -> Shape.Uid.print fmt uid);
@@ -485,26 +663,7 @@ let from_uid ~config ~local_defs uid loc path =
       | _ -> log ~title "Failed to load the CU's cmt";
         `Not_found (Path.name path, None)
     end
-  | Some (Predef _ | Internal) -> `Builtin
-  | None -> log ~title "No UID found, fallbacking to lookup location.";
-      `Found (None, loc, true)
-
-let path_and_loc_of_cstr desc _ =
-  let open Types in
-  match desc.cstr_tag with
-  | Cstr_extension (path, _) -> path, desc.cstr_loc
-  | _ ->
-    match get_desc desc.cstr_res with
-    | Tconstr (path, _, _) -> path, desc.cstr_loc
-    | _ -> assert false
-
-let path_and_loc_from_label desc env =
-  let open Types in
-  match get_desc desc.lbl_res with
-  | Tconstr (path, _, _) ->
-    let typ_decl = Env.find_type path env in
-    path, typ_decl.Types.type_loc
-  | _ -> assert false
+  | Predef _ | Internal -> `Builtin
 
 type find_source_result =
   | Found of string
@@ -645,150 +804,7 @@ let find_source ~config loc path =
                merlin doesn't know which is the right one: %s"
         matches)
 
-type namespace = Namespace.t
-module Namespace = struct
-  type under_type = [ `Constr | `Labels ]
-
-  type t = (* TODO: share with [Namespace.t] *)
-    [ `Type | `Mod | `Modtype | `Vals | under_type ]
-
-  type inferred =
-    [ t
-    | `This_label of Types.label_description
-    | `This_cstr of Types.constructor_description ]
-
-  let from_context : Context.t -> inferred list = function
-    | Type          -> [ `Type ; `Mod ; `Modtype ; `Constr ; `Labels ; `Vals ]
-    | Module_type   -> [ `Modtype ; `Mod ; `Type ; `Constr ; `Labels ; `Vals ]
-    | Expr | Constant ->
-      [ `Vals ; `Mod ; `Modtype ; `Constr ; `Labels ; `Type ]
-    | Patt          -> [ `Mod ; `Modtype ; `Type ; `Constr ; `Labels ; `Vals ]
-    | Unknown       -> [ `Vals ; `Type ; `Constr ; `Mod ; `Modtype ; `Labels ]
-    | Label lbl     -> [ `This_label lbl ]
-    | Module_path   -> [ `Mod ]
-    | Constructor (c, _) -> [ `This_cstr c ]
-end
-
-module Env_lookup : sig
-
-  val loc
-    : Path.t
-    -> namespace
-    -> Env.t
-    -> (Location.t * Shape.Uid.t * Shape.Sig_component_kind.t) option
-
-  val in_namespaces
-     : Namespace.inferred list
-    -> Longident.t
-    -> Env.t
-    -> (Path.t * Shape.Sig_component_kind.t * Shape.Uid.t * Location.t)
-        option
-
-end = struct
-
-  let loc path (namespace : namespace) env =
-    try
-      Some (
-        match namespace with
-        | `Unknown
-        | `Apply
-        | `Vals ->
-          let vd = Env.find_value path env in
-          vd.val_loc, vd.val_uid, Shape.Sig_component_kind.Value
-        | `Constr
-        | `Labels
-        | `Type ->
-          let td = Env.find_type path env in
-          td.type_loc, td.type_uid, Shape.Sig_component_kind.Type
-        | `Functor
-        | `Mod ->
-          let md = Env.find_module path env in
-          md.md_loc, md.md_uid, Shape.Sig_component_kind.Module
-        | `Modtype ->
-          let mtd = Env.find_modtype path env in
-          mtd.mtd_loc, mtd.mtd_uid, Shape.Sig_component_kind.Module_type
-      )
-    with
-      Not_found -> None
-
-  exception Found of
-    (Path.t * Shape.Sig_component_kind.t * Shape.Uid.t * Location.t)
 
-  let in_namespaces (nss : Namespace.inferred list) ident env =
-    let open Shape.Sig_component_kind in
-    try
-      List.iter nss ~f:(fun namespace ->
-        try
-          match namespace with
-          | `This_cstr ({ Types.cstr_tag = Cstr_extension _; _ } as cd) ->
-            log ~title:"lookup"
-              "got extension constructor";
-            let path, loc = path_and_loc_of_cstr cd env in
-            (* TODO: Use [`Constr] here instead of [`Type] *)
-            raise (Found (path, Extension_constructor, cd.cstr_uid, loc))
-          | `This_cstr cd ->
-            log ~title:"lookup"
-              "got constructor, fetching path and loc in type namespace";
-            let path, loc = path_and_loc_of_cstr cd env in
-            log ~title:"lookup" "found path: %a"
-              Logger.fmt (fun fmt -> Path.print fmt path);
-            let path = Path.Pdot (path, cd.cstr_name)
-            in
-            raise (Found (path, Constructor, cd.cstr_uid, loc))
-          | `Constr ->
-            log ~title:"lookup" "lookup in constructor namespace" ;
-            let cd = Env.find_constructor_by_name ident env in
-            let path, loc = path_and_loc_of_cstr cd env in
-            let path = Path.Pdot (path, cd.cstr_name) in
-            (* TODO: Use [`Constr] here instead of [`Type] *)
-            raise (Found (path, Constructor,cd.cstr_uid, loc))
-          | `Mod ->
-            log ~title:"lookup" "lookup in module namespace" ;
-            let path, md = Env.find_module_by_name ident env in
-            raise (Found (path, Module, md.md_uid, md.Types.md_loc))
-          | `Modtype ->
-            let path, mtd = Env.find_modtype_by_name ident env in
-            raise
-              (Found (path, Module_type, mtd.mtd_uid, mtd.Types.mtd_loc))
-          | `Type ->
-            log ~title:"lookup" "lookup in type namespace" ;
-            let path, typ_decl = Env.find_type_by_name ident env in
-            raise (
-              Found
-                (path, Type, typ_decl.type_uid, typ_decl.Types.type_loc)
-            )
-          | `Vals ->
-            log ~title:"lookup" "lookup in value namespace" ;
-            let path, val_desc = Env.find_value_by_name ident env in
-            raise (
-              Found
-                (path, Value, val_desc.val_uid, val_desc.Types.val_loc)
-            )
-          | `This_label lbl ->
-            log ~title:"lookup"
-              "got label, fetching path and loc in type namespace";
-            let path, loc = path_and_loc_from_label lbl env in
-            let path = Path.Pdot (path, lbl.lbl_name)
-            in
-            raise (Found (path, Label, lbl.lbl_uid, loc))
-          | `Labels ->
-            log ~title:"lookup" "lookup in label namespace" ;
-            let lbl = Env.find_label_by_name ident env in
-            let path, loc = path_and_loc_from_label lbl env in
-            (* TODO: Use [`Labels] here instead of [`Type] *)
-            raise (Found (path, Type, lbl.lbl_uid, loc))
-        with Not_found -> ()
-      ) ;
-      log ~title:"lookup" "   ... not in the environment" ;
-      None
-    with Found ((path, namespace, decl_uid, loc) as x) ->
-      log ~title:"env_lookup" "found: '%a' in namespace %s with decl_uid %a\nat loc %a"
-        Logger.fmt (fun fmt -> Path.print fmt path)
-        (Shape.Sig_component_kind.to_string namespace)
-        Logger.fmt (fun fmt -> Shape.Uid.print fmt decl_uid)
-        Logger.fmt (fun fmt -> Location.print_loc fmt loc);
-      Some x
-end
 
 let uid_from_longident ~config ~env nss ident =
   let str_ident =
@@ -797,17 +813,17 @@ let uid_from_longident ~config ~env nss ident =
   in
   match Env_lookup.in_namespaces nss ident env with
   | None -> `Not_in_env str_ident
-  | Some (path, namespace, decl_uid, loc) ->
+  | Some (path, decl) ->
     if Utils.is_builtin_path path then
       `Builtin
     else
-      let uid = uid_of_path ~config ~env ~decl_uid path namespace in
-      `Uid (uid, loc, path)
+      let shape_result = uid_of_path ~config ~env ~decl path in
+      `Uid (shape_result, path, decl)
 
 let from_longident ~config ~env ~local_defs nss ident =
   match uid_from_longident ~config ~env nss ident with
-  | `Uid (uid, loc, path) ->
-    from_uid ~config ~local_defs uid loc path
+  | `Uid (shape_result, path, decl) ->
+    from_reduction_result ~config ~local_defs ~decl shape_result path
   | (`Builtin | `Not_in_env _) as v -> v
 
 let from_path ~config ~env ~local_defs ~namespace path =
@@ -817,9 +833,9 @@ let from_path ~config ~env ~local_defs ~namespace path =
   else
     match Env_lookup.loc path namespace env with
     | None -> `Not_in_env (Path.name path)
-    | Some (loc, decl_uid, namespace) ->
-      let uid = uid_of_path ~config ~env ~decl_uid path namespace in
-      match from_uid ~config ~local_defs uid loc path with
+    | Some decl ->
+      let res = uid_of_path ~config ~env ~decl path in
+      match from_reduction_result ~config ~local_defs ~decl res path with
       | `Not_found _ | `Builtin
       | `File_not_found _ as err -> err
       | `Found (uid, loc, approximated) ->

From 92fe41d7efd84478758b7fa05d5f6df443914416 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Wed, 15 Nov 2023 18:45:05 +0100
Subject: [PATCH 09/58] tests: Promote valid changes

---
 .../test-dirs/locate/context-detection/cd-test.t/run.t | 10 ++--------
 tests/test-dirs/locate/functors/f-all_local.t/run.t    |  2 +-
 tests/test-dirs/locate/issue1424.t                     |  2 +-
 .../locate/non-local/ignore-kept-locs.t/run.t          | 10 +++++++---
 tests/test-dirs/locate/sig-substs.t/run.t              |  3 +--
 tests/test-dirs/locate/without-implem.t                |  6 +++++-
 tests/test-dirs/occurrences/issue827.t/run.t           |  2 +-
 7 files changed, 18 insertions(+), 17 deletions(-)

diff --git a/tests/test-dirs/locate/context-detection/cd-test.t/run.t b/tests/test-dirs/locate/context-detection/cd-test.t/run.t
index 1dd96f14a8..3e01314838 100644
--- a/tests/test-dirs/locate/context-detection/cd-test.t/run.t
+++ b/tests/test-dirs/locate/context-detection/cd-test.t/run.t
@@ -39,18 +39,12 @@ Trying them all:
     "notifications": []
   }
 
-FIXME this should say "Already at definition point" (we're defining the label):
+This should say "Already at definition point" (we're defining the label):
 
   $ $MERLIN single locate -look-for ml -position 13:12 -filename ./test.ml < ./test.ml
   {
     "class": "return",
-    "value": {
-      "file": "$TESTCASE_ROOT/test.ml",
-      "pos": {
-        "line": 5,
-        "col": 4
-      }
-    },
+    "value": "Already at definition point",
     "notifications": []
   }
 
diff --git a/tests/test-dirs/locate/functors/f-all_local.t/run.t b/tests/test-dirs/locate/functors/f-all_local.t/run.t
index 33ad905cac..835e9981c5 100644
--- a/tests/test-dirs/locate/functors/f-all_local.t/run.t
+++ b/tests/test-dirs/locate/functors/f-all_local.t/run.t
@@ -38,7 +38,7 @@ Check that we can jump from inside the functor to the (sig of the) parameter:
       "file": "$TESTCASE_ROOT/all_local.ml",
       "pos": {
         "line": 2,
-        "col": 2
+        "col": 7
       }
     },
     "notifications": []
diff --git a/tests/test-dirs/locate/issue1424.t b/tests/test-dirs/locate/issue1424.t
index 6fdad78cd9..23b3d039c1 100644
--- a/tests/test-dirs/locate/issue1424.t
+++ b/tests/test-dirs/locate/issue1424.t
@@ -39,6 +39,6 @@ FIXME: it should jump to the ml file
     "file": "$TESTCASE_ROOT/test2.mli",
     "pos": {
       "line": 1,
-      "col": 0
+      "col": 4
     }
   }
diff --git a/tests/test-dirs/locate/non-local/ignore-kept-locs.t/run.t b/tests/test-dirs/locate/non-local/ignore-kept-locs.t/run.t
index 218681b389..9c8b42ac1d 100644
--- a/tests/test-dirs/locate/non-local/ignore-kept-locs.t/run.t
+++ b/tests/test-dirs/locate/non-local/ignore-kept-locs.t/run.t
@@ -20,7 +20,7 @@ available:
   }
 
   $ grep -A1 from_uid log | grep -v from_uid | sed '/^--$/d'
-  Loading the shapes for unit "A"
+  Loading the cmt file for unit "A"
   Shapes successfully loaded, looking for A.0
   Found location: File "a.ml", line 1, characters 4-9
 
@@ -41,7 +41,7 @@ available:
   }
 
   $ grep -A1 from_uid log | grep -v from_uid | sed '/^--$/d'
-  Loading the shapes for unit "A"
+  Loading the cmt file for unit "A"
   Shapes successfully loaded, looking for A.0
   Found location: File "a.ml", line 1, characters 4-9
 
@@ -66,6 +66,10 @@ In the absence of cmt though, fallbacking to the cmi loc makes sense:
   }
 
   $ grep -A1 from_uid log | grep -v from_uid
-  No UID found, fallbacking to lookup location.
+  No definition uid, fallbacking to the declaration uid: A.0
+  Loading the cmt file for unit "A"
+  --
+  Failed to load the shapes
+  Uid not found in the cmt table. Fallbacking to the node's location: File "a.ml", line 1, characters 4-9
 
   $ rm log
diff --git a/tests/test-dirs/locate/sig-substs.t/run.t b/tests/test-dirs/locate/sig-substs.t/run.t
index 086533403f..882968144e 100644
--- a/tests/test-dirs/locate/sig-substs.t/run.t
+++ b/tests/test-dirs/locate/sig-substs.t/run.t
@@ -15,7 +15,6 @@ when both are present in the buffer (the struct will always be preferred).
     "notifications": []
   }
 
-TODO SHAPES: it could be more precise by answering 8:21
   $ $MERLIN single locate -look-for ml -position 10:13 -filename ./basic.ml < ./basic.ml
   {
     "class": "return",
@@ -23,7 +22,7 @@ TODO SHAPES: it could be more precise by answering 8:21
       "file": "$TESTCASE_ROOT/basic.ml",
       "pos": {
         "line": 8,
-        "col": 9
+        "col": 25
       }
     },
     "notifications": []
diff --git a/tests/test-dirs/locate/without-implem.t b/tests/test-dirs/locate/without-implem.t
index 44f5b0b153..3028f0f892 100644
--- a/tests/test-dirs/locate/without-implem.t
+++ b/tests/test-dirs/locate/without-implem.t
@@ -18,6 +18,7 @@
 
   $ dune build ./main.exe 2> /dev/null
 
+Definition of t
   $ $MERLIN single locate -look-for ml -position 1:16 \
   > -filename main.ml <main.ml
   {
@@ -26,12 +27,13 @@
       "file": "$TESTCASE_ROOT/noimpl.mli",
       "pos": {
         "line": 1,
-        "col": 0
+        "col": 5
       }
     },
     "notifications": []
   }
 
+Declaration of t
   $ $MERLIN single locate -look-for mli -position 1:16 \
   > -filename main.ml <main.ml
   {
@@ -46,6 +48,7 @@
     "notifications": []
   }
 
+Definition of module Noimpl
   $ $MERLIN single locate -look-for ml -position 1:13 \
   > -filename main.ml <main.ml
   {
@@ -60,6 +63,7 @@
     "notifications": []
   }
 
+Declaration of module Noimpl
   $ $MERLIN single locate -look-for mli -position 1:13 \
   > -filename main.ml <main.ml
   {
diff --git a/tests/test-dirs/occurrences/issue827.t/run.t b/tests/test-dirs/occurrences/issue827.t/run.t
index f521cec891..43d1bab64f 100644
--- a/tests/test-dirs/occurrences/issue827.t/run.t
+++ b/tests/test-dirs/occurrences/issue827.t/run.t
@@ -35,7 +35,7 @@ Reproduction case:
       {
         "start": {
           "line": 2,
-          "col": 18
+          "col": 16
         },
         "end": {
           "line": 2,

From 7e897f0a3d4828897ec9ee8b085c07827e322d4a Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Thu, 16 Nov 2023 13:30:10 +0100
Subject: [PATCH 10/58] More locate refactor

---
 src/analysis/locate.ml         | 55 ++++++++++++++++++----------------
 src/analysis/locate.mli        |  4 ++-
 src/frontend/query_commands.ml |  2 +-
 3 files changed, 33 insertions(+), 28 deletions(-)

diff --git a/src/analysis/locate.ml b/src/analysis/locate.ml
index b197d4c8ed..40d946f37f 100644
--- a/src/analysis/locate.ml
+++ b/src/analysis/locate.ml
@@ -40,6 +40,8 @@ type config = {
 
 type result = {
   uid: Shape.Uid.t option;
+  reduction_result: Shape.reduction_result;
+  decl_uid: Shape.Uid.t;
   file: string option;
   location: Location.t;
   approximated: bool;
@@ -604,9 +606,7 @@ let from_reduction_result
     | Shape.Resolved uid -> uid, false
     | Unresolved { uid = Some uid; desc = Comp_unit _; approximated } ->
         uid, approximated
-    (* | Unresolved { uid = Some uid; approximated; _ } ->
-        uid, approximated *)
-    | Unresolved _ | Approximated _ | Missing_uid ->
+    | Approximated _ | Unresolved _ | Missing_uid ->
         log ~title "No definition uid, fallbacking to the declaration uid: %a"
           Logger.fmt (Fun.flip Shape.Uid.print decl.uid);
         decl.uid, true
@@ -663,7 +663,8 @@ let from_reduction_result
       | _ -> log ~title "Failed to load the CU's cmt";
         `Not_found (Path.name path, None)
     end
-  | Predef _ | Internal -> `Builtin
+  | Predef s -> `Builtin s
+  | Internal -> `Builtin "<internal>"
 
 type find_source_result =
   | Found of string
@@ -815,33 +816,42 @@ let uid_from_longident ~config ~env nss ident =
   | None -> `Not_in_env str_ident
   | Some (path, decl) ->
     if Utils.is_builtin_path path then
-      `Builtin
+      `Builtin (Path.name path)
     else
       let shape_result = uid_of_path ~config ~env ~decl path in
       `Uid (shape_result, path, decl)
 
+
+let from_shape_or_decl ~config ~local_defs ~decl shape_result path =
+  match from_reduction_result ~config ~local_defs ~decl shape_result path with
+  | `Not_found _ | `Builtin _
+  | `File_not_found _ as err -> err
+  | `Found (uid, loc, approximated) ->
+  match find_source ~config:config.mconfig loc (Path.name path) with
+  | `Found (file, location) ->
+    `Found {
+      uid;
+      reduction_result = shape_result;
+      decl_uid = decl.uid;
+      file; location; approximated }
+  | `File_not_found _ as otherwise -> otherwise
+
 let from_longident ~config ~env ~local_defs nss ident =
   match uid_from_longident ~config ~env nss ident with
   | `Uid (shape_result, path, decl) ->
-    from_reduction_result ~config ~local_defs ~decl shape_result path
-  | (`Builtin | `Not_in_env _) as v -> v
+    from_shape_or_decl ~config ~local_defs ~decl shape_result path
+  | (`Builtin _ | `Not_in_env _) as v -> v
 
 let from_path ~config ~env ~local_defs ~namespace path =
   File_switching.reset ();
   if Utils.is_builtin_path path then
-    `Builtin
+    `Builtin (Path.name path)
   else
     match Env_lookup.loc path namespace env with
     | None -> `Not_in_env (Path.name path)
     | Some decl ->
       let res = uid_of_path ~config ~env ~decl path in
-      match from_reduction_result ~config ~local_defs ~decl res path with
-      | `Not_found _ | `Builtin
-      | `File_not_found _ as err -> err
-      | `Found (uid, loc, approximated) ->
-        match find_source ~config:config.mconfig loc (Path.name path) with
-        | `Found (file, location) -> `Found { uid; file; location; approximated }
-        | `File_not_found _ as otherwise -> otherwise
+      from_shape_or_decl ~config ~local_defs ~decl res path
 
 let infer_namespace ?namespaces ~pos lid browse is_label =
   match namespaces with
@@ -883,13 +893,7 @@ let from_string ~config ~env ~local_defs ~pos ?namespaces path =
       log ~title:"from_string"
         "looking for the source of '%s' (prioritizing %s files)"
         path (match config.ml_or_mli with `ML -> ".ml" | `MLI -> ".mli");
-      match from_longident ~config ~env ~local_defs nss ident with
-      | `File_not_found _ | `Not_found _ | `Not_in_env _ as err -> err
-      | `Builtin -> `Builtin path
-      | `Found (uid, loc, approximated) ->
-        match find_source ~config:config.mconfig loc path with
-        | `Found (file, location) -> `Found { uid; file; location; approximated }
-        | `File_not_found _ as otherwise -> otherwise
+      from_longident ~config ~env ~local_defs nss ident
   in
   Option.value_map ~f:from_lid ~default:(`Not_found (path, None)) lid
 
@@ -1084,7 +1088,7 @@ let get_doc ~config:mconfig ~env ~local_defs ~comments ~pos =
       begin match from_path with
       | `Found { uid; location = loc; _ } ->
         doc_from_uid ~config ~loc uid
-      | (`Builtin |`Not_in_env _|`File_not_found _|`Not_found _)
+      | (`Builtin _ |`Not_in_env _|`File_not_found _|`Not_found _)
         as otherwise -> otherwise
       end
     | `User_input path ->
@@ -1095,8 +1099,7 @@ let get_doc ~config:mconfig ~env ~local_defs ~comments ~pos =
       | `At_origin ->
         `Found_loc { Location.loc_start = pos; loc_end = pos; loc_ghost = true }
       | `Missing_labels_namespace -> `No_documentation
-      | `Builtin _ -> `Builtin
-      | (`Not_in_env _ | `Not_found _ |`File_not_found _ )
+      | (`Builtin _ | `Not_in_env _ | `Not_found _ |`File_not_found _ )
         as otherwise -> otherwise
       end
   in
@@ -1104,7 +1107,7 @@ let get_doc ~config:mconfig ~env ~local_defs ~comments ~pos =
   | `Found_doc doc -> `Found doc
   | `Found_loc loc ->
       doc_from_comment_list ~local_defs ~buffer_comments:comments loc
-  | `Builtin ->
+  | `Builtin _ ->
     begin match path with
     | `User_input path -> `Builtin path
     | `Completion_entry (_, path, _) -> `Builtin (Path.name path)
diff --git a/src/analysis/locate.mli b/src/analysis/locate.mli
index cc02ee5b4d..ec2baa193e 100644
--- a/src/analysis/locate.mli
+++ b/src/analysis/locate.mli
@@ -41,6 +41,8 @@ type config = {
 
 type result = {
   uid: Shape.Uid.t option;
+  reduction_result: Shape.reduction_result;
+  decl_uid: Shape.Uid.t;
   file: string option;
   location: Location.t;
   approximated: bool;
@@ -61,7 +63,7 @@ val from_path
   -> Path.t
   -> [> `File_not_found of string
      | `Found of result
-     | `Builtin
+     | `Builtin of string
      | `Not_in_env of string
      | `Not_found of string * string option ]
 
diff --git a/src/frontend/query_commands.ml b/src/frontend/query_commands.ml
index 1107b92e90..5cfe940978 100644
--- a/src/frontend/query_commands.ml
+++ b/src/frontend/query_commands.ml
@@ -401,7 +401,7 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a =
                 ~local_defs
                 ~namespace:`Type
                 path with
-        | `Builtin -> `Builtin (Path.name path)
+        | `Builtin s -> `Builtin s
         | `Not_in_env _ as s -> s
         | `Not_found _ as s -> s
         | `Found { file; location; _ } -> `Found (file, location.loc_start)

From f9eb9efd04710ac7fb7ae19b3b5f3392f64c08c3 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Thu, 16 Nov 2023 14:54:38 +0100
Subject: [PATCH 11/58] locate: more refactor

---
 src/analysis/locate.ml         | 25 ++++++++++++-------------
 src/analysis/locate.mli        |  4 ++--
 src/frontend/query_commands.ml |  6 +++---
 3 files changed, 17 insertions(+), 18 deletions(-)

diff --git a/src/analysis/locate.ml b/src/analysis/locate.ml
index 40d946f37f..b9623eacd3 100644
--- a/src/analysis/locate.ml
+++ b/src/analysis/locate.ml
@@ -42,7 +42,7 @@ type result = {
   uid: Shape.Uid.t option;
   reduction_result: Shape.reduction_result;
   decl_uid: Shape.Uid.t;
-  file: string option;
+  file: string;
   location: Location.t;
   approximated: bool;
 }
@@ -796,7 +796,7 @@ let find_source ~config loc path =
       | exception _ -> failure
   in
   match (result : find_source_result) with
-  | Found src -> `Found (Some src, loc)
+  | Found src -> `Found (src, loc)
   | Not_found f -> File.explain_not_found path f
   | Multiple_matches lst ->
     let matches = String.concat lst ~sep:", " in
@@ -805,8 +805,6 @@ let find_source ~config loc path =
                merlin doesn't know which is the right one: %s"
         matches)
 
-
-
 let uid_from_longident ~config ~env nss ident =
   let str_ident =
     try String.concat ~sep:"." (Longident.flatten ident)
@@ -821,20 +819,21 @@ let uid_from_longident ~config ~env nss ident =
       let shape_result = uid_of_path ~config ~env ~decl path in
       `Uid (shape_result, path, decl)
 
-
 let from_shape_or_decl ~config ~local_defs ~decl shape_result path =
   match from_reduction_result ~config ~local_defs ~decl shape_result path with
   | `Not_found _ | `Builtin _
   | `File_not_found _ as err -> err
   | `Found (uid, loc, approximated) ->
-  match find_source ~config:config.mconfig loc (Path.name path) with
-  | `Found (file, location) ->
-    `Found {
-      uid;
-      reduction_result = shape_result;
-      decl_uid = decl.uid;
-      file; location; approximated }
-  | `File_not_found _ as otherwise -> otherwise
+    match find_source ~config:config.mconfig loc (Path.name path) with
+    | `Found (file, location) ->
+      log ~title:"find_source" "Found file: %s (%a)" file
+        Logger.fmt (Fun.flip Location.print_loc location);
+      `Found {
+        uid;
+        reduction_result = shape_result;
+        decl_uid = decl.uid;
+        file; location; approximated }
+    | `File_not_found _ as otherwise -> otherwise
 
 let from_longident ~config ~env ~local_defs nss ident =
   match uid_from_longident ~config ~env nss ident with
diff --git a/src/analysis/locate.mli b/src/analysis/locate.mli
index ec2baa193e..cae940ebab 100644
--- a/src/analysis/locate.mli
+++ b/src/analysis/locate.mli
@@ -43,7 +43,7 @@ type result = {
   uid: Shape.Uid.t option;
   reduction_result: Shape.reduction_result;
   decl_uid: Shape.Uid.t;
-  file: string option;
+  file: string;
   location: Location.t;
   approximated: bool;
 }
@@ -53,7 +53,7 @@ val find_source
   -> Warnings.loc
   -> string
   -> [> `File_not_found of string
-      | `Found of string option * Location.t ]
+      | `Found of string * Location.t ]
 
 val from_path
   : config:config
diff --git a/src/frontend/query_commands.ml b/src/frontend/query_commands.ml
index 5cfe940978..f4ed7d4865 100644
--- a/src/frontend/query_commands.ml
+++ b/src/frontend/query_commands.ml
@@ -404,7 +404,7 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a =
         | `Builtin s -> `Builtin s
         | `Not_in_env _ as s -> s
         | `Not_found _ as s -> s
-        | `Found { file; location; _ } -> `Found (file, location.loc_start)
+        | `Found { file; location; _ } -> `Found (Some file, location.loc_start)
         | `File_not_found _ as s -> s
     end
 
@@ -537,8 +537,8 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a =
     begin match Locate.from_string ~config ~env ~local_defs ~pos path with
     | `Found { file; location; _ } ->
       Locate.log ~title:"result"
-        "found: %s" (Option.value ~default:"<local buffer>" file);
-      `Found (file, location.loc_start)
+        "found: %s"  file;
+      `Found (Some file, location.loc_start)
     | `Missing_labels_namespace ->
       (* Can't happen because we haven't passed a namespace as input. *)
       assert false

From c6009df1eb34699cbd4f8d28733c59d38b1344ab Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Thu, 16 Nov 2023 14:54:57 +0100
Subject: [PATCH 12/58] occurrences: refactor iterator

---
 src/analysis/ast_iterators.ml   | 13 ++++-------
 src/analysis/occurrences.ml     | 39 ++++++++++++++++++---------------
 src/ocaml/typing/cmt_format.ml  | 25 +++++++++++----------
 src/ocaml/typing/cmt_format.mli |  7 +++++-
 4 files changed, 44 insertions(+), 40 deletions(-)

diff --git a/src/analysis/ast_iterators.ml b/src/analysis/ast_iterators.ml
index dd2d0a3fc6..c91f1adc05 100644
--- a/src/analysis/ast_iterators.ml
+++ b/src/analysis/ast_iterators.ml
@@ -44,15 +44,10 @@ let build_uid_to_locs_tbl ~(local_defs : Mtyper.typedtree) () =
     iter.structure iter str end;
   uid_to_locs_tbl
 
-let index_usages  ~(local_defs : Mtyper.typedtree) () =
-  let index = ref [] in
+let iter_on_usages ~f (local_defs : Mtyper.typedtree) =
+  let iter = Cmt_format.iter_on_usages ~f () in
   begin match local_defs with
-  | `Interface signature ->
-    let iter = Cmt_format.iter_on_usages ~index in
-    iter.signature iter signature
-  | `Implementation structure ->
-    let iter = Cmt_format.iter_on_usages ~index in
-    iter.structure iter structure end;
-  !index
+  | `Interface signature -> iter.signature iter signature
+  | `Implementation structure -> iter.structure iter structure end
 
 
diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml
index b4d35ba48d..ec37315730 100644
--- a/src/analysis/occurrences.ml
+++ b/src/analysis/occurrences.ml
@@ -3,9 +3,8 @@ module LidSet = Index_format.LidSet
 
 let {Logger. log} = Logger.for_section "occurrences"
 
-let index_buffer ~env ~local_defs () =
+let index_buffer ~local_defs () =
   let defs = Hashtbl.create 64 in
-  let index = Ast_iterators.index_usages ~(local_defs : Mtyper.typedtree) () in
   let module Shape_reduce =
     Shape.Make_reduce (struct
       type env = Env.t
@@ -27,18 +26,20 @@ let index_buffer ~env ~local_defs () =
         ~namespace:Shape.Sig_component_kind.Module env (Pident id)
     end)
   in
-  List.iter index ~f:(fun (lid, item) ->
-    match item with
-    | Shape.Approximated _ | Missing_uid -> ()
-    | Resolved uid ->
-        Index_format.(add defs uid (LidSet.singleton lid))
-    | Unresolved shape ->
-      (* Format.eprintf "Reducing %a\n%!" Shape.print shape; *)
-      match Shape_reduce.reduce env shape with
-        | { Shape.desc = Leaf | Struct _; uid = Some uid; approximated = _ } ->
-          (* Format.eprintf "Reduced %a\n%!" Shape.print s; *)
-            Index_format.add defs uid (LidSet.singleton lid)
-        | _ -> ());
+  let f ~namespace env path lid  =
+    let not_ghost { Location.loc = { loc_ghost; _ }; _ } = not loc_ghost in
+    if not_ghost lid then
+      match Env.shape_of_path ~namespace env path with
+      | exception Not_found -> ()
+      | path_shape ->
+        begin match Shape_reduce.reduce_for_uid env path_shape with
+        | Shape.Approximated _ | Missing_uid -> ()
+        | Resolved uid ->
+            Index_format.(add defs uid (LidSet.singleton lid))
+            | Unresolved _ -> ()
+        end
+  in
+  Ast_iterators.iter_on_usages ~f local_defs;
   defs
 
 let merge_tbl ~into tbl = Hashtbl.iter (Index_format.add into) tbl
@@ -118,6 +119,10 @@ let locs_of ~config ~scope ~env ~local_defs ~pos ~node:_ path =
         log ~title:"locs_of" "Found definition uid using locate: %a "
           Logger.fmt (fun fmt -> Shape.Uid.print fmt uid);
         Some (uid, location)
+    | `Found { uid = Some uid; location; approximated = true; _ } ->
+        log ~title:"locs_of" "Approx: %a "
+          Logger.fmt (fun fmt -> Shape.Uid.print fmt uid);
+        Some (uid, location)
     | _ ->
       log ~title:"locs_of" "Locate failed to find a definition.";
       None
@@ -131,7 +136,7 @@ let locs_of ~config ~scope ~env ~local_defs ~pos ~node:_ path =
       Logger.fmt (fun fmt -> Shape.Uid.print fmt uid)
       Logger.fmt (fun fmt -> Location.print_loc fmt def_loc);
     log ~title:"locs_of" "Indexing current buffer";
-    let index = index_buffer ~env ~local_defs () in
+    let index = index_buffer ~local_defs () in
     if scope = `Project then begin
       match config.merlin.index_file with
       | None -> log ~title:"locs_of" "No external index specified"
@@ -153,10 +158,8 @@ let locs_of ~config ~scope ~env ~local_defs ~pos ~node:_ path =
             None
           else if Filename.is_relative fname then begin
             match Locate.find_source ~config loc fname with
-            | `Found (Some file, _) -> Some { loc with loc_start =
+            | `Found (file, _) -> Some { loc with loc_start =
                 { loc.loc_start with pos_fname = file}}
-            | `Found (None, _) -> Some { loc with loc_start =
-                { loc.loc_start with pos_fname = ""}}
             | `File_not_found msg ->
               log ~title:"occurrences" "%s" msg;
               None
diff --git a/src/ocaml/typing/cmt_format.ml b/src/ocaml/typing/cmt_format.ml
index c7e5c00468..7f5d9c8331 100644
--- a/src/ocaml/typing/cmt_format.ml
+++ b/src/ocaml/typing/cmt_format.ml
@@ -236,16 +236,7 @@ let clear_env binary_annots =
 
   else binary_annots
 
-let iter_on_usages ~index =
-  let f ~namespace env path lid =
-    let not_ghost { Location.loc = { loc_ghost; _ }; _ } = not loc_ghost in
-    if not_ghost lid then
-      match Env.shape_of_path ~namespace env path with
-      | exception Not_found -> ()
-      | path_shape ->
-        let result = Local_reduce.reduce_for_uid env path_shape in
-        index := (lid, result) :: !index
-  in
+let iter_on_usages ~f () =
   let path_in_type typ name =
     match Types.get_desc typ with
     | Tconstr (type_path, _, _) ->
@@ -255,7 +246,8 @@ let iter_on_usages ~index =
   let add_constructor_description env lid =
     function
     | { Types.cstr_tag = Cstr_extension (path, _); _ } ->
-        f ~namespace:Extension_constructor env path lid
+        let namespace : Shape.Sig_component_kind.t = Extension_constructor in
+        f ~namespace env path lid
     | { Types.cstr_uid = Predef _; _ } -> ()
     | { Types.cstr_res; cstr_name; _ } ->
         let path = path_in_type cstr_res cstr_name in
@@ -421,7 +413,16 @@ let index_usages binary_annots =
   let index : (Longident.t Location.loc * Shape.reduction_result) list ref =
     ref []
   in
-  iter_on_annots (iter_on_usages ~index) binary_annots;
+  let f ~namespace env path lid  =
+    let not_ghost { Location.loc = { loc_ghost; _ }; _ } = not loc_ghost in
+    if not_ghost lid then
+      match Env.shape_of_path ~namespace env path with
+      | exception Not_found -> ()
+      | path_shape ->
+        let result = Local_reduce.reduce_for_uid env path_shape in
+        index := (lid, result) :: !index
+  in
+  iter_on_annots (iter_on_usages ~f ()) binary_annots;
   !index
 
 exception Error of error
diff --git a/src/ocaml/typing/cmt_format.mli b/src/ocaml/typing/cmt_format.mli
index 9e4c0c45ac..1fdc59600e 100644
--- a/src/ocaml/typing/cmt_format.mli
+++ b/src/ocaml/typing/cmt_format.mli
@@ -146,5 +146,10 @@ val iter_on_declarations :
   -> Tast_iterator.iterator
 
 val iter_on_usages :
-  index:(Longident.t Location.loc * Shape.reduction_result) list ref
+  f:(namespace:Shape.Sig_component_kind.t ->
+    Env.t ->
+    Path.t ->
+    Longident.t Location.loc ->
+    unit)
+  -> unit
   -> Tast_iterator.iterator

From 9189fe91e795b04c6c560e0f7b231c89e23b0e1f Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Thu, 16 Nov 2023 15:19:26 +0100
Subject: [PATCH 13/58] locate: refactor: extract env_lookup

---
 src/analysis/completion.mli |   2 +-
 src/analysis/env_lookup.ml  | 175 +++++++++++++++++++++++++++++++++++
 src/analysis/env_lookup.mli |  47 ++++++++++
 src/analysis/locate.ml      | 178 +-----------------------------------
 src/analysis/locate.mli     |  11 +--
 src/analysis/namespace.ml   |  24 -----
 src/analysis/namespace.mli  |  14 ---
 7 files changed, 228 insertions(+), 223 deletions(-)
 create mode 100644 src/analysis/env_lookup.ml
 create mode 100644 src/analysis/env_lookup.mli
 delete mode 100644 src/analysis/namespace.ml
 delete mode 100644 src/analysis/namespace.mli

diff --git a/src/analysis/completion.mli b/src/analysis/completion.mli
index 74e68e6971..7d379295d3 100644
--- a/src/analysis/completion.mli
+++ b/src/analysis/completion.mli
@@ -52,7 +52,7 @@ val map_entry : ('a -> 'b) ->
 
 val branch_complete
   :  Mconfig.t
-  -> ?get_doc:([> `Completion_entry of Namespace.t
+  -> ?get_doc:([> `Completion_entry of Env_lookup.Namespace.t
                 * Path.t * Location.t ] -> [> `Found of string ])
   -> ?target_type:Types.type_expr
   -> ?kinds:Compl.kind list
diff --git a/src/analysis/env_lookup.ml b/src/analysis/env_lookup.ml
new file mode 100644
index 0000000000..fa48c31a70
--- /dev/null
+++ b/src/analysis/env_lookup.ml
@@ -0,0 +1,175 @@
+open! Std
+let {Logger. log} = Logger.for_section "env-lookup"
+
+module Namespace = struct
+  type t = [
+    | `Vals
+    | `Type
+    | `Constr
+    | `Mod
+    | `Modtype
+    | `Functor
+    | `Labels
+    | `Unknown
+    | `Apply
+  ]
+
+  let to_string = function
+    | `Vals -> "(value) "
+    | `Type -> "(type) "
+    | `Constr -> "(constructor) "
+    | `Mod -> "(module) "
+    | `Modtype -> "(module type) "
+    | `Functor -> "(functor)"
+    | `Labels -> "(label) "
+    | `Unknown -> "(unknown)"
+    | `Apply -> "(functor application)"
+
+  type under_type = [ `Constr | `Labels ]
+
+  type inferred_basic = (* TODO: share with [Namespace.t] *)
+    [ `Type | `Mod | `Modtype | `Vals | under_type ]
+
+  type inferred =
+    [ inferred_basic
+    | `This_label of Types.label_description
+    | `This_cstr of Types.constructor_description ]
+
+  let from_context : Context.t -> inferred list = function
+    | Type          -> [ `Type ; `Mod ; `Modtype ; `Constr ; `Labels ; `Vals ]
+    | Module_type   -> [ `Modtype ; `Mod ; `Type ; `Constr ; `Labels ; `Vals ]
+    | Expr | Constant ->
+      [ `Vals ; `Mod ; `Modtype ; `Constr ; `Labels ; `Type ]
+    | Patt          -> [ `Mod ; `Modtype ; `Type ; `Constr ; `Labels ; `Vals ]
+    | Unknown       -> [ `Vals ; `Type ; `Constr ; `Mod ; `Modtype ; `Labels ]
+    | Label lbl     -> [ `This_label lbl ]
+    | Module_path   -> [ `Mod ]
+    | Constructor (c, _) -> [ `This_cstr c ]
+end
+
+type declaration = {
+  uid: Shape.Uid.t;
+  loc: Location.t;
+  namespace: Shape.Sig_component_kind.t
+}
+
+let loc path (namespace : Namespace.t) env =
+  try
+    let loc, uid, namespace =
+      match namespace with
+      | `Unknown
+      | `Apply
+      | `Vals ->
+        let vd = Env.find_value path env in
+        vd.val_loc, vd.val_uid, Shape.Sig_component_kind.Value
+      | `Constr
+      | `Labels
+      | `Type ->
+        let td = Env.find_type path env in
+        td.type_loc, td.type_uid, Shape.Sig_component_kind.Type
+      | `Functor
+      | `Mod ->
+        let md = Env.find_module path env in
+        md.md_loc, md.md_uid, Shape.Sig_component_kind.Module
+      | `Modtype ->
+        let mtd = Env.find_modtype path env in
+        mtd.mtd_loc, mtd.mtd_uid, Shape.Sig_component_kind.Module_type
+    in
+    Some { uid; loc; namespace }
+  with
+    Not_found -> None
+
+exception Found of
+  (Path.t * Shape.Sig_component_kind.t * Shape.Uid.t * Location.t)
+
+let path_and_loc_of_cstr desc _ =
+  let open Types in
+  match desc.cstr_tag with
+  | Cstr_extension (path, _) -> path, desc.cstr_loc
+  | _ ->
+    match get_desc desc.cstr_res with
+    | Tconstr (path, _, _) -> path, desc.cstr_loc
+    | _ -> assert false
+
+let path_and_loc_from_label desc env =
+  let open Types in
+  match get_desc desc.lbl_res with
+  | Tconstr (path, _, _) ->
+    let typ_decl = Env.find_type path env in
+    path, typ_decl.Types.type_loc
+  | _ -> assert false
+
+let in_namespaces (nss : Namespace.inferred list) ident env =
+  let open Shape.Sig_component_kind in
+  try
+    List.iter nss ~f:(fun namespace ->
+      try
+        match namespace with
+        | `This_cstr ({ Types.cstr_tag = Cstr_extension _; _ } as cd) ->
+          log ~title:"lookup"
+            "got extension constructor";
+          let path, loc = path_and_loc_of_cstr cd env in
+          (* TODO: Use [`Constr] here instead of [`Type] *)
+          raise (Found (path, Extension_constructor, cd.cstr_uid, loc))
+        | `This_cstr cd ->
+          log ~title:"lookup"
+            "got constructor, fetching path and loc in type namespace";
+          let path, loc = path_and_loc_of_cstr cd env in
+          log ~title:"lookup" "found path: %a"
+            Logger.fmt (fun fmt -> Path.print fmt path);
+          let path = Path.Pdot (path, cd.cstr_name)
+          in
+          raise (Found (path, Constructor, cd.cstr_uid, loc))
+        | `Constr ->
+          log ~title:"lookup" "lookup in constructor namespace" ;
+          let cd = Env.find_constructor_by_name ident env in
+          let path, loc = path_and_loc_of_cstr cd env in
+          let path = Path.Pdot (path, cd.cstr_name) in
+          (* TODO: Use [`Constr] here instead of [`Type] *)
+          raise (Found (path, Constructor,cd.cstr_uid, loc))
+        | `Mod ->
+          log ~title:"lookup" "lookup in module namespace" ;
+          let path, md = Env.find_module_by_name ident env in
+          raise (Found (path, Module, md.md_uid, md.Types.md_loc))
+        | `Modtype ->
+          let path, mtd = Env.find_modtype_by_name ident env in
+          raise
+            (Found (path, Module_type, mtd.mtd_uid, mtd.Types.mtd_loc))
+        | `Type ->
+          log ~title:"lookup" "lookup in type namespace" ;
+          let path, typ_decl = Env.find_type_by_name ident env in
+          raise (
+            Found
+              (path, Type, typ_decl.type_uid, typ_decl.Types.type_loc)
+          )
+        | `Vals ->
+          log ~title:"lookup" "lookup in value namespace" ;
+          let path, val_desc = Env.find_value_by_name ident env in
+          raise (
+            Found
+              (path, Value, val_desc.val_uid, val_desc.Types.val_loc)
+          )
+        | `This_label lbl ->
+          log ~title:"lookup"
+            "got label, fetching path and loc in type namespace";
+          let path, loc = path_and_loc_from_label lbl env in
+          let path = Path.Pdot (path, lbl.lbl_name)
+          in
+          raise (Found (path, Label, lbl.lbl_uid, loc))
+        | `Labels ->
+          log ~title:"lookup" "lookup in label namespace" ;
+          let lbl = Env.find_label_by_name ident env in
+          let path, loc = path_and_loc_from_label lbl env in
+          (* TODO: Use [`Labels] here instead of [`Type] *)
+          raise (Found (path, Type, lbl.lbl_uid, loc))
+      with Not_found -> ()
+    ) ;
+    log ~title:"lookup" "   ... not in the environment" ;
+    None
+  with Found (path, namespace, decl_uid, loc) ->
+    log ~title:"env_lookup" "found: '%a' in namespace %s with decl_uid %a\nat loc %a"
+      Logger.fmt (fun fmt -> Path.print fmt path)
+      (Shape.Sig_component_kind.to_string namespace)
+      Logger.fmt (fun fmt -> Shape.Uid.print fmt decl_uid)
+      Logger.fmt (fun fmt -> Location.print_loc fmt loc);
+    Some (path, { uid = decl_uid; loc; namespace })
diff --git a/src/analysis/env_lookup.mli b/src/analysis/env_lookup.mli
new file mode 100644
index 0000000000..9cc25d7bdd
--- /dev/null
+++ b/src/analysis/env_lookup.mli
@@ -0,0 +1,47 @@
+module Namespace : sig
+  type t =
+      [ `Apply
+      | `Constr
+      | `Functor
+      | `Labels
+      | `Mod
+      | `Modtype
+      | `Type
+      | `Unknown
+      | `Vals ]
+
+  val to_string : t -> string
+
+  type under_type = [ `Constr | `Labels ]
+  type inferred_basic =
+      [ `Constr | `Labels | `Mod | `Modtype | `Type | `Vals ]
+  type inferred =
+      [ `Constr
+      | `Labels
+      | `Mod
+      | `Modtype
+      | `This_cstr of Types.constructor_description
+      | `This_label of Types.label_description
+      | `Type
+      | `Vals ]
+
+  val from_context : Context.t -> inferred list
+end
+
+type declaration = {
+  uid: Shape.Uid.t;
+  loc: Location.t;
+  namespace: Shape.Sig_component_kind.t
+}
+
+val loc
+  : Path.t
+  -> Namespace.t
+  -> Env.t
+  -> declaration option
+
+val in_namespaces
+   : Namespace.inferred list
+  -> Longident.t
+  -> Env.t
+  -> (Path.t * declaration) option
diff --git a/src/analysis/locate.ml b/src/analysis/locate.ml
index b9623eacd3..fe67a822f6 100644
--- a/src/analysis/locate.ml
+++ b/src/analysis/locate.ml
@@ -354,180 +354,6 @@ let scrape_alias ~env ~fallback_uid ~namespace path =
   in
   non_alias_declaration_uid ~fallback_uid path
 
-type namespace = Namespace.t
-module Namespace = struct
-  type under_type = [ `Constr | `Labels ]
-
-  type t = (* TODO: share with [Namespace.t] *)
-    [ `Type | `Mod | `Modtype | `Vals | under_type ]
-
-  type inferred =
-    [ t
-    | `This_label of Types.label_description
-    | `This_cstr of Types.constructor_description ]
-
-  let from_context : Context.t -> inferred list = function
-    | Type          -> [ `Type ; `Mod ; `Modtype ; `Constr ; `Labels ; `Vals ]
-    | Module_type   -> [ `Modtype ; `Mod ; `Type ; `Constr ; `Labels ; `Vals ]
-    | Expr | Constant ->
-      [ `Vals ; `Mod ; `Modtype ; `Constr ; `Labels ; `Type ]
-    | Patt          -> [ `Mod ; `Modtype ; `Type ; `Constr ; `Labels ; `Vals ]
-    | Unknown       -> [ `Vals ; `Type ; `Constr ; `Mod ; `Modtype ; `Labels ]
-    | Label lbl     -> [ `This_label lbl ]
-    | Module_path   -> [ `Mod ]
-    | Constructor (c, _) -> [ `This_cstr c ]
-end
-
-module Env_lookup : sig
-
-  type declaration = {
-    uid: Shape.Uid.t;
-    loc: Location.t;
-    namespace: Shape.Sig_component_kind.t
-  }
-
-  val loc
-    : Path.t
-    -> namespace
-    -> Env.t
-    -> declaration option
-
-  val in_namespaces
-     : Namespace.inferred list
-    -> Longident.t
-    -> Env.t
-    -> (Path.t * declaration) option
-
-end = struct
-
-  type declaration = {
-    uid: Shape.Uid.t;
-    loc: Location.t;
-    namespace: Shape.Sig_component_kind.t
-  }
-
-  let loc path (namespace : namespace) env =
-    try
-      let loc, uid, namespace =
-        match namespace with
-        | `Unknown
-        | `Apply
-        | `Vals ->
-          let vd = Env.find_value path env in
-          vd.val_loc, vd.val_uid, Shape.Sig_component_kind.Value
-        | `Constr
-        | `Labels
-        | `Type ->
-          let td = Env.find_type path env in
-          td.type_loc, td.type_uid, Shape.Sig_component_kind.Type
-        | `Functor
-        | `Mod ->
-          let md = Env.find_module path env in
-          md.md_loc, md.md_uid, Shape.Sig_component_kind.Module
-        | `Modtype ->
-          let mtd = Env.find_modtype path env in
-          mtd.mtd_loc, mtd.mtd_uid, Shape.Sig_component_kind.Module_type
-      in
-      Some { uid; loc; namespace }
-    with
-      Not_found -> None
-
-  exception Found of
-    (Path.t * Shape.Sig_component_kind.t * Shape.Uid.t * Location.t)
-
-  let path_and_loc_of_cstr desc _ =
-    let open Types in
-    match desc.cstr_tag with
-    | Cstr_extension (path, _) -> path, desc.cstr_loc
-    | _ ->
-      match get_desc desc.cstr_res with
-      | Tconstr (path, _, _) -> path, desc.cstr_loc
-      | _ -> assert false
-
-  let path_and_loc_from_label desc env =
-    let open Types in
-    match get_desc desc.lbl_res with
-    | Tconstr (path, _, _) ->
-      let typ_decl = Env.find_type path env in
-      path, typ_decl.Types.type_loc
-    | _ -> assert false
-
-  let in_namespaces (nss : Namespace.inferred list) ident env =
-    let open Shape.Sig_component_kind in
-    try
-      List.iter nss ~f:(fun namespace ->
-        try
-          match namespace with
-          | `This_cstr ({ Types.cstr_tag = Cstr_extension _; _ } as cd) ->
-            log ~title:"lookup"
-              "got extension constructor";
-            let path, loc = path_and_loc_of_cstr cd env in
-            (* TODO: Use [`Constr] here instead of [`Type] *)
-            raise (Found (path, Extension_constructor, cd.cstr_uid, loc))
-          | `This_cstr cd ->
-            log ~title:"lookup"
-              "got constructor, fetching path and loc in type namespace";
-            let path, loc = path_and_loc_of_cstr cd env in
-            log ~title:"lookup" "found path: %a"
-              Logger.fmt (fun fmt -> Path.print fmt path);
-            let path = Path.Pdot (path, cd.cstr_name)
-            in
-            raise (Found (path, Constructor, cd.cstr_uid, loc))
-          | `Constr ->
-            log ~title:"lookup" "lookup in constructor namespace" ;
-            let cd = Env.find_constructor_by_name ident env in
-            let path, loc = path_and_loc_of_cstr cd env in
-            let path = Path.Pdot (path, cd.cstr_name) in
-            (* TODO: Use [`Constr] here instead of [`Type] *)
-            raise (Found (path, Constructor,cd.cstr_uid, loc))
-          | `Mod ->
-            log ~title:"lookup" "lookup in module namespace" ;
-            let path, md = Env.find_module_by_name ident env in
-            raise (Found (path, Module, md.md_uid, md.Types.md_loc))
-          | `Modtype ->
-            let path, mtd = Env.find_modtype_by_name ident env in
-            raise
-              (Found (path, Module_type, mtd.mtd_uid, mtd.Types.mtd_loc))
-          | `Type ->
-            log ~title:"lookup" "lookup in type namespace" ;
-            let path, typ_decl = Env.find_type_by_name ident env in
-            raise (
-              Found
-                (path, Type, typ_decl.type_uid, typ_decl.Types.type_loc)
-            )
-          | `Vals ->
-            log ~title:"lookup" "lookup in value namespace" ;
-            let path, val_desc = Env.find_value_by_name ident env in
-            raise (
-              Found
-                (path, Value, val_desc.val_uid, val_desc.Types.val_loc)
-            )
-          | `This_label lbl ->
-            log ~title:"lookup"
-              "got label, fetching path and loc in type namespace";
-            let path, loc = path_and_loc_from_label lbl env in
-            let path = Path.Pdot (path, lbl.lbl_name)
-            in
-            raise (Found (path, Label, lbl.lbl_uid, loc))
-          | `Labels ->
-            log ~title:"lookup" "lookup in label namespace" ;
-            let lbl = Env.find_label_by_name ident env in
-            let path, loc = path_and_loc_from_label lbl env in
-            (* TODO: Use [`Labels] here instead of [`Type] *)
-            raise (Found (path, Type, lbl.lbl_uid, loc))
-        with Not_found -> ()
-      ) ;
-      log ~title:"lookup" "   ... not in the environment" ;
-      None
-    with Found (path, namespace, decl_uid, loc) ->
-      log ~title:"env_lookup" "found: '%a' in namespace %s with decl_uid %a\nat loc %a"
-        Logger.fmt (fun fmt -> Path.print fmt path)
-        (Shape.Sig_component_kind.to_string namespace)
-        Logger.fmt (fun fmt -> Shape.Uid.print fmt decl_uid)
-        Logger.fmt (fun fmt -> Location.print_loc fmt loc);
-      Some (path, { uid = decl_uid; loc; namespace })
-end
-
 let uid_of_path ~config ~env ~(decl : Env_lookup.declaration) path =
   let namespace = decl.namespace in
   let module Shape_reduce =
@@ -856,7 +682,7 @@ let infer_namespace ?namespaces ~pos lid browse is_label =
   match namespaces with
   | Some nss ->
     if not is_label
-    then `Ok (nss :> Namespace.inferred list)
+    then `Ok (nss :> Env_lookup.Namespace.inferred list)
     else if List.mem `Labels ~set:nss then (
       log ~title:"from_string" "restricting namespaces to labels";
       `Ok [ `Labels ]
@@ -874,7 +700,7 @@ let infer_namespace ?namespaces ~pos lid browse is_label =
     | Some ctxt, false ->
       log ~title:"from_string"
         "inferred context: %s" (Context.to_string ctxt);
-      `Ok (Namespace.from_context ctxt)
+      `Ok (Env_lookup.Namespace.from_context ctxt)
     | _, true ->
       log ~title:"from_string"
         "dropping inferred context, it is not precise enough";
diff --git a/src/analysis/locate.mli b/src/analysis/locate.mli
index cae940ebab..2cd4928611 100644
--- a/src/analysis/locate.mli
+++ b/src/analysis/locate.mli
@@ -28,11 +28,6 @@
 
 val log : 'a Logger.printf
 
-type namespace = Namespace.t
-module Namespace : sig
-  type t = [ `Type | `Mod | `Modtype | `Vals | `Constr | `Labels ]
-end
-
 type config = {
   mconfig: Mconfig.t;
   ml_or_mli: [ `ML | `MLI ];
@@ -59,7 +54,7 @@ val from_path
   : config:config
   -> env:Env.t
   -> local_defs:Mtyper.typedtree
-  -> namespace:namespace
+  -> namespace:Env_lookup.Namespace.t
   -> Path.t
   -> [> `File_not_found of string
      | `Found of result
@@ -72,7 +67,7 @@ val from_string
   -> env:Env.t
   -> local_defs:Mtyper.typedtree
   -> pos:Lexing.position
-  -> ?namespaces:Namespace.t list
+  -> ?namespaces:Env_lookup.Namespace.inferred_basic list
   -> string
   -> [> `File_not_found of string
       | `Found of result
@@ -89,7 +84,7 @@ val get_doc
   -> comments:(string * Location.t) list
   -> pos:Lexing.position
   -> [ `User_input of string
-     | `Completion_entry of namespace * Path.t * Location.t ]
+     | `Completion_entry of Env_lookup.Namespace.t * Path.t * Location.t ]
   -> [> `File_not_found of string
       | `Found of string
       | `Builtin of string
diff --git a/src/analysis/namespace.ml b/src/analysis/namespace.ml
deleted file mode 100644
index 13e214dd0f..0000000000
--- a/src/analysis/namespace.ml
+++ /dev/null
@@ -1,24 +0,0 @@
-open! Std
-
-type t = [
-  | `Vals
-  | `Type
-  | `Constr
-  | `Mod
-  | `Modtype
-  | `Functor
-  | `Labels
-  | `Unknown
-  | `Apply
-]
-
-let to_string = function
-  | `Mod -> "(module) "
-  | `Functor -> "(functor)"
-  | `Labels -> "(label) "
-  | `Constr -> "(constructor) "
-  | `Type -> "(type) "
-  | `Vals -> "(value) "
-  | `Modtype -> "(module type) "
-  | `Unknown -> "(unknown)"
-  | `Apply -> "(functor application)"
diff --git a/src/analysis/namespace.mli b/src/analysis/namespace.mli
deleted file mode 100644
index 794593a029..0000000000
--- a/src/analysis/namespace.mli
+++ /dev/null
@@ -1,14 +0,0 @@
-type t = [
-  | `Vals
-  | `Type
-  | `Constr
-  | `Mod
-  | `Modtype
-  | `Functor
-  | `Labels
-  | `Unknown
-  | `Apply
-]
-
-val to_string : t -> string
-

From 9bcc245657782c610657971f00038098b9c3d2e9 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Thu, 16 Nov 2023 15:55:00 +0100
Subject: [PATCH 14/58] namespace: refactor: use kinds from compiler

---
 src/analysis/completion.ml     |  4 +--
 src/analysis/completion.mli    |  2 +-
 src/analysis/env_lookup.ml     | 53 ++++++++++++----------------------
 src/analysis/env_lookup.mli    | 13 ++-------
 src/frontend/query_commands.ml |  2 +-
 5 files changed, 24 insertions(+), 50 deletions(-)

diff --git a/src/analysis/completion.ml b/src/analysis/completion.ml
index f8d713250b..76c42049c1 100644
--- a/src/analysis/completion.ml
+++ b/src/analysis/completion.ml
@@ -219,8 +219,8 @@ let make_candidate ~get_doc ~attrs ~exact ~prefix_path name ?loc ?path ty =
       | Some p, Some loc ->
         let namespace = (* FIXME: that's just terrible *)
           match kind with
-          | `Value -> `Vals
-          | `Type -> `Type
+          | `Value -> Shape.Sig_component_kind.Value
+          | `Type -> Type
           | _ -> assert false
         in
         begin match get_doc (`Completion_entry (namespace, p, loc)) with
diff --git a/src/analysis/completion.mli b/src/analysis/completion.mli
index 7d379295d3..e5098a68a1 100644
--- a/src/analysis/completion.mli
+++ b/src/analysis/completion.mli
@@ -52,7 +52,7 @@ val map_entry : ('a -> 'b) ->
 
 val branch_complete
   :  Mconfig.t
-  -> ?get_doc:([> `Completion_entry of Env_lookup.Namespace.t
+  -> ?get_doc:([> `Completion_entry of Shape.Sig_component_kind.t
                 * Path.t * Location.t ] -> [> `Found of string ])
   -> ?target_type:Types.type_expr
   -> ?kinds:Compl.kind list
diff --git a/src/analysis/env_lookup.ml b/src/analysis/env_lookup.ml
index fa48c31a70..6d780ae162 100644
--- a/src/analysis/env_lookup.ml
+++ b/src/analysis/env_lookup.ml
@@ -2,28 +2,9 @@ open! Std
 let {Logger. log} = Logger.for_section "env-lookup"
 
 module Namespace = struct
-  type t = [
-    | `Vals
-    | `Type
-    | `Constr
-    | `Mod
-    | `Modtype
-    | `Functor
-    | `Labels
-    | `Unknown
-    | `Apply
-  ]
+  type t = Shape.Sig_component_kind.t
 
-  let to_string = function
-    | `Vals -> "(value) "
-    | `Type -> "(type) "
-    | `Constr -> "(constructor) "
-    | `Mod -> "(module) "
-    | `Modtype -> "(module type) "
-    | `Functor -> "(functor)"
-    | `Labels -> "(label) "
-    | `Unknown -> "(unknown)"
-    | `Apply -> "(functor application)"
+  let to_string = Shape.Sig_component_kind.to_string
 
   type under_type = [ `Constr | `Labels ]
 
@@ -55,25 +36,27 @@ type declaration = {
 
 let loc path (namespace : Namespace.t) env =
   try
-    let loc, uid, namespace =
+    let loc, uid, (namespace : Namespace.t) =
       match namespace with
-      | `Unknown
-      | `Apply
-      | `Vals ->
+      | Value ->
         let vd = Env.find_value path env in
-        vd.val_loc, vd.val_uid, Shape.Sig_component_kind.Value
-      | `Constr
-      | `Labels
-      | `Type ->
+        vd.val_loc, vd.val_uid, Value
+      | (Type | Extension_constructor | Constructor | Label) ->
         let td = Env.find_type path env in
-        td.type_loc, td.type_uid, Shape.Sig_component_kind.Type
-      | `Functor
-      | `Mod ->
+        td.type_loc, td.type_uid, Type
+      | Module ->
         let md = Env.find_module path env in
-        md.md_loc, md.md_uid, Shape.Sig_component_kind.Module
-      | `Modtype ->
+        md.md_loc, md.md_uid, Module
+      | Module_type ->
         let mtd = Env.find_modtype path env in
-        mtd.mtd_loc, mtd.mtd_uid, Shape.Sig_component_kind.Module_type
+        mtd.mtd_loc, mtd.mtd_uid, Module_type
+      | Class ->
+        let cty = Env.find_class path env in
+        cty.cty_loc, cty.cty_uid, Class
+      | Class_type ->
+        let clty = Env.find_cltype path env in
+        clty.clty_loc, clty.clty_uid, Class
+
     in
     Some { uid; loc; namespace }
   with
diff --git a/src/analysis/env_lookup.mli b/src/analysis/env_lookup.mli
index 9cc25d7bdd..665fd8caf8 100644
--- a/src/analysis/env_lookup.mli
+++ b/src/analysis/env_lookup.mli
@@ -1,14 +1,5 @@
 module Namespace : sig
-  type t =
-      [ `Apply
-      | `Constr
-      | `Functor
-      | `Labels
-      | `Mod
-      | `Modtype
-      | `Type
-      | `Unknown
-      | `Vals ]
+  type t = Shape.Sig_component_kind.t
 
   val to_string : t -> string
 
@@ -31,7 +22,7 @@ end
 type declaration = {
   uid: Shape.Uid.t;
   loc: Location.t;
-  namespace: Shape.Sig_component_kind.t
+  namespace: Namespace.t
 }
 
 val loc
diff --git a/src/frontend/query_commands.ml b/src/frontend/query_commands.ml
index f4ed7d4865..b22543e845 100644
--- a/src/frontend/query_commands.ml
+++ b/src/frontend/query_commands.ml
@@ -399,7 +399,7 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a =
                 ~config
                 ~env
                 ~local_defs
-                ~namespace:`Type
+                ~namespace:Type
                 path with
         | `Builtin s -> `Builtin s
         | `Not_in_env _ as s -> s

From 636bc328fcae45bbae8ba01ebe90d53c95258708 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Thu, 16 Nov 2023 16:02:50 +0100
Subject: [PATCH 15/58] occurrences: index declarations when def not found

---
 src/analysis/occurrences.ml | 13 +++++++++++--
 1 file changed, 11 insertions(+), 2 deletions(-)

diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml
index ec37315730..32bedfde55 100644
--- a/src/analysis/occurrences.ml
+++ b/src/analysis/occurrences.ml
@@ -35,8 +35,17 @@ let index_buffer ~local_defs () =
         begin match Shape_reduce.reduce_for_uid env path_shape with
         | Shape.Approximated _ | Missing_uid -> ()
         | Resolved uid ->
-            Index_format.(add defs uid (LidSet.singleton lid))
-            | Unresolved _ -> ()
+          Index_format.(add defs uid (LidSet.singleton lid))
+        | Unresolved s ->
+          log ~title:"index_buffer" "Could not resolve shape %a"
+            Logger.fmt (Fun.flip Shape.print s);
+          begin match Env_lookup.loc path namespace env with
+          | None -> log ~title:"index_buffer" "Declaration not found"
+          | Some decl ->
+            log ~title:"index_buffer" "Found the declaration: %a"
+              Logger.fmt (Fun.flip Location.print_loc decl.loc);
+            Index_format.(add defs decl.uid (LidSet.singleton lid))
+          end
         end
   in
   Ast_iterators.iter_on_usages ~f local_defs;

From f6dcfa6e16748ac05dc1bb5e1030dccea841b9d3 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Thu, 16 Nov 2023 17:47:50 +0100
Subject: [PATCH 16/58] locate: refactor

---
 src/analysis/env_lookup.ml  |  2 +-
 src/analysis/env_lookup.mli |  6 +++---
 src/analysis/locate.ml      | 39 ++++++++++++++-----------------------
 3 files changed, 19 insertions(+), 28 deletions(-)

diff --git a/src/analysis/env_lookup.ml b/src/analysis/env_lookup.ml
index 6d780ae162..fa64a807fc 100644
--- a/src/analysis/env_lookup.ml
+++ b/src/analysis/env_lookup.ml
@@ -28,7 +28,7 @@ module Namespace = struct
     | Constructor (c, _) -> [ `This_cstr c ]
 end
 
-type declaration = {
+type item = {
   uid: Shape.Uid.t;
   loc: Location.t;
   namespace: Shape.Sig_component_kind.t
diff --git a/src/analysis/env_lookup.mli b/src/analysis/env_lookup.mli
index 665fd8caf8..e09a5907a2 100644
--- a/src/analysis/env_lookup.mli
+++ b/src/analysis/env_lookup.mli
@@ -19,7 +19,7 @@ module Namespace : sig
   val from_context : Context.t -> inferred list
 end
 
-type declaration = {
+type item = {
   uid: Shape.Uid.t;
   loc: Location.t;
   namespace: Namespace.t
@@ -29,10 +29,10 @@ val loc
   : Path.t
   -> Namespace.t
   -> Env.t
-  -> declaration option
+  -> item option
 
 val in_namespaces
    : Namespace.inferred list
   -> Longident.t
   -> Env.t
-  -> (Path.t * declaration) option
+  -> (Path.t * item) option
diff --git a/src/analysis/locate.ml b/src/analysis/locate.ml
index fe67a822f6..aace53c591 100644
--- a/src/analysis/locate.ml
+++ b/src/analysis/locate.ml
@@ -354,7 +354,7 @@ let scrape_alias ~env ~fallback_uid ~namespace path =
   in
   non_alias_declaration_uid ~fallback_uid path
 
-let uid_of_path ~config ~env ~(decl : Env_lookup.declaration) path =
+let uid_of_path ~config ~env ~(decl : Env_lookup.item) path =
   let namespace = decl.namespace in
   let module Shape_reduce =
     Shape.Make_reduce (struct
@@ -404,7 +404,7 @@ let uid_of_path ~config ~env ~(decl : Env_lookup.declaration) path =
     reduced
 
 let from_reduction_result
-  ~config ~local_defs ~(decl : Env_lookup.declaration) shape_result path =
+  ~config ~local_defs ~(decl : Env_lookup.item) shape_result path =
   let title = "from_uid" in
   let loc_of_comp_unit comp_unit =
     match load_cmt ~config comp_unit with
@@ -631,21 +631,8 @@ let find_source ~config loc path =
                merlin doesn't know which is the right one: %s"
         matches)
 
-let uid_from_longident ~config ~env nss ident =
-  let str_ident =
-    try String.concat ~sep:"." (Longident.flatten ident)
-    with _-> "Not a flat longident"
-  in
-  match Env_lookup.in_namespaces nss ident env with
-  | None -> `Not_in_env str_ident
-  | Some (path, decl) ->
-    if Utils.is_builtin_path path then
-      `Builtin (Path.name path)
-    else
-      let shape_result = uid_of_path ~config ~env ~decl path in
-      `Uid (shape_result, path, decl)
-
-let from_shape_or_decl ~config ~local_defs ~decl shape_result path =
+let from_path ~config ~env ~local_defs ~decl path =
+  let shape_result = uid_of_path ~config ~env ~decl path in
   match from_reduction_result ~config ~local_defs ~decl shape_result path with
   | `Not_found _ | `Builtin _
   | `File_not_found _ as err -> err
@@ -662,10 +649,16 @@ let from_shape_or_decl ~config ~local_defs ~decl shape_result path =
     | `File_not_found _ as otherwise -> otherwise
 
 let from_longident ~config ~env ~local_defs nss ident =
-  match uid_from_longident ~config ~env nss ident with
-  | `Uid (shape_result, path, decl) ->
-    from_shape_or_decl ~config ~local_defs ~decl shape_result path
-  | (`Builtin _ | `Not_in_env _) as v -> v
+  let str_ident =
+    try String.concat ~sep:"." (Longident.flatten ident)
+    with _-> "Not a flat longident"
+  in
+  match Env_lookup.in_namespaces nss ident env with
+  | None -> `Not_in_env str_ident
+  | Some (path, decl) ->
+    if Utils.is_builtin_path path then
+      `Builtin (Path.name path)
+    else from_path ~config ~env ~local_defs ~decl path
 
 let from_path ~config ~env ~local_defs ~namespace path =
   File_switching.reset ();
@@ -674,9 +667,7 @@ let from_path ~config ~env ~local_defs ~namespace path =
   else
     match Env_lookup.loc path namespace env with
     | None -> `Not_in_env (Path.name path)
-    | Some decl ->
-      let res = uid_of_path ~config ~env ~decl path in
-      from_shape_or_decl ~config ~local_defs ~decl res path
+    | Some decl -> from_path ~config ~env ~local_defs ~decl path
 
 let infer_namespace ?namespaces ~pos lid browse is_label =
   match namespaces with

From 027405a33e5b78c974dc9a9f4eba2aa24f2da00b Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Fri, 17 Nov 2023 12:52:25 +0100
Subject: [PATCH 17/58] Locate: refactmore

---
 src/analysis/locate.ml  | 274 ++++++++++++++++++----------------------
 src/analysis/locate.mli |   3 +-
 2 files changed, 127 insertions(+), 150 deletions(-)

diff --git a/src/analysis/locate.ml b/src/analysis/locate.ml
index aace53c591..8780fa7a79 100644
--- a/src/analysis/locate.ml
+++ b/src/analysis/locate.ml
@@ -39,8 +39,7 @@ type config = {
 }
 
 type result = {
-  uid: Shape.Uid.t option;
-  reduction_result: Shape.reduction_result;
+  uid: Shape.Uid.t;
   decl_uid: Shape.Uid.t;
   file: string;
   location: Location.t;
@@ -354,144 +353,6 @@ let scrape_alias ~env ~fallback_uid ~namespace path =
   in
   non_alias_declaration_uid ~fallback_uid path
 
-let uid_of_path ~config ~env ~(decl : Env_lookup.item) path =
-  let namespace = decl.namespace in
-  let module Shape_reduce =
-    Shape.Make_reduce (struct
-      type env = Env.t
-
-      let fuel = 10
-
-      let read_unit_shape ~unit_name =
-          log ~title:"read_unit_shape" "inspecting %s" unit_name;
-          match load_cmt ~config:({config with ml_or_mli = `ML}) unit_name with
-          | Ok (filename, cmt_infos) ->
-            move_to filename cmt_infos;
-            log ~title:"read_unit_shape" "shapes loaded for %s" unit_name;
-            cmt_infos.cmt_impl_shape
-          | Error () ->
-            log ~title:"read_unit_shape" "failed to find %s" unit_name;
-            None
-
-      let find_shape env id = Env.shape_of_path
-        ~namespace:Shape.Sig_component_kind.Module env (Pident id)
-    end)
-  in
-  let unalias ~config fallback_uid =
-    if not config.traverse_aliases then fallback_uid else
-    let uid = scrape_alias ~fallback_uid ~env ~namespace path in begin
-      log ~title:"uid_of_path" "Unaliased uid: %a -> %a"
-        Logger.fmt (fun fmt -> Shape.Uid.print fmt fallback_uid)
-        Logger.fmt (fun fmt -> Shape.Uid.print fmt uid);
-      uid
-    end
-  in
-  match config.ml_or_mli with
-  | `MLI ->
-    let uid = unalias ~config decl.uid in
-    log ~title:"uid_of_path" "Declaration uid: %a"
-      Logger.fmt (Fun.flip Shape.Uid.print decl.uid);
-    Shape.Resolved uid
-  | `ML ->
-    let shape = Env.shape_of_path ~namespace env path in
-    log ~title:"shape_of_path" "initial: %a"
-      Logger.fmt (Fun.flip Shape.print shape);
-    let reduced = Shape_reduce.reduce_for_uid
-      ~keep_aliases:(not config.traverse_aliases) env shape
-    in
-    log ~title:"shape_of_path" "reduced: %a"
-      Logger.fmt (fun fmt -> Shape.print_reduction_result fmt reduced);
-    reduced
-
-let from_reduction_result
-  ~config ~local_defs ~(decl : Env_lookup.item) shape_result path =
-  let title = "from_uid" in
-  let loc_of_comp_unit comp_unit =
-    match load_cmt ~config comp_unit with
-    | Ok (pos_fname, _cmt) ->
-      let pos = Std.Lexing.make_pos ~pos_fname (1, 0) in
-      let loc = { Location.loc_start=pos; loc_end=pos; loc_ghost=true } in
-      Some loc
-    | _ -> None
-  in
-  let loc_of_decl ~uid def =
-    match Misc_utils.loc_of_decl ~uid def  with
-    | Some loc ->
-      log ~title "Found location: %a"
-        Logger.fmt (fun fmt -> Location.print_loc fmt loc.loc);
-      Some (uid, loc.loc)
-    | None ->
-      (* Check: this should never happen *)
-      log ~title "The declaration has no location. \
-        Fallbacking to the node's location: %a"
-        Logger.fmt (fun fmt -> Location.print_loc fmt decl.loc);
-      Some (uid, decl.loc)
-  in
-  let uid, approximated =
-    match shape_result with
-    | Shape.Resolved uid -> uid, false
-    | Unresolved { uid = Some uid; desc = Comp_unit _; approximated } ->
-        uid, approximated
-    | Approximated _ | Unresolved _ | Missing_uid ->
-        log ~title "No definition uid, fallbacking to the declaration uid: %a"
-          Logger.fmt (Fun.flip Shape.Uid.print decl.uid);
-        decl.uid, true
-  in
-  match uid with
-  | Shape.Uid.Item { comp_unit; _ } ->
-    let locopt =
-      let log_and_return msg = log ~title msg; None in
-      if Env.get_unit_name () = comp_unit then begin
-        log ~title "We look for %a in the current compilation unit."
-          Logger.fmt (fun fmt -> Shape.Uid.print fmt uid);
-        log ~title "Looking for %a in the uid_to_loc table"
-          Logger.fmt (fun fmt -> Shape.Uid.print fmt uid);
-        let tbl = Ast_iterators.build_uid_to_locs_tbl ~local_defs () in
-        match Shape.Uid.Tbl.find_opt tbl uid with
-        | Some { Location.loc; _ } -> Some (uid, loc)
-        | None ->
-          log ~title
-            "Uid not found in the local table.\
-            Fallbacking to the node's location: %a"
-          Logger.fmt (fun fmt -> Location.print_loc fmt decl.loc);
-          Some (uid, decl.loc)
-      end else begin
-        log ~title "Loading the cmt file for unit %S" comp_unit;
-        match load_cmt ~config comp_unit with
-        | Ok (_pos_fname, cmt) ->
-          log ~title "Shapes successfully loaded, looking for %a"
-            Logger.fmt (fun fmt -> Shape.Uid.print fmt uid);
-          begin match Shape.Uid.Tbl.find_opt cmt.cmt_uid_to_decl uid with
-            | Some decl -> loc_of_decl ~uid decl
-            | None ->
-              log ~title "Uid not found in the cmt table. \
-                Fallbacking to the node's location: %a"
-                Logger.fmt (fun fmt -> Location.print_loc fmt decl.loc);
-              Some (uid, decl.loc)
-          end
-        | _ -> log_and_return "Failed to load the shapes"
-      end
-    in
-    begin match locopt with
-    | Some (uid, loc) -> `Found (Some uid, loc, approximated)
-    | None ->
-      log ~title "Uid not found in the cmt table. \
-        Fallbacking to the node's location: %a"
-      Logger.fmt (fun fmt -> Location.print_loc fmt decl.loc);
-      `Found (Some uid, decl.loc, true)
-    end
-  | Compilation_unit comp_unit ->
-    begin
-      log ~title "Got the uid of a compilation unit: %a"
-        Logger.fmt (fun fmt -> Shape.Uid.print fmt uid);
-      match loc_of_comp_unit comp_unit with
-      | Some loc -> `Found (Some uid, loc, approximated)
-      | _ -> log ~title "Failed to load the CU's cmt";
-        `Not_found (Path.name path, None)
-    end
-  | Predef s -> `Builtin s
-  | Internal -> `Builtin "<internal>"
-
 type find_source_result =
   | Found of string
   | Not_found of File.t
@@ -631,19 +492,136 @@ let find_source ~config loc path =
                merlin doesn't know which is the right one: %s"
         matches)
 
+(** [find_loc_of_uid] uid's location are given by tables stored int he cmt files
+  for external compilation units or computed by Merlin for the current buffer.
+  This function lookups a uid's location in the appropriate table. *)
+let find_loc_of_uid ~config ~local_defs uid comp_unit =
+  let title = "find_loc_of_uid" in
+  let loc_of_decl ~uid def =
+    match Misc_utils.loc_of_decl ~uid def  with
+    | Some loc ->
+      log ~title "Found location: %a"
+        Logger.fmt (fun fmt -> Location.print_loc fmt loc.loc);
+      `Some (uid, loc.loc)
+    | None -> log ~title "The declaration has no location."; `None
+  in
+  if Env.get_unit_name () = comp_unit then begin
+    log ~title "We look for %a in the current compilation unit."
+      Logger.fmt (fun fmt -> Shape.Uid.print fmt uid);
+    log ~title "Looking for %a in the uid_to_loc table"
+      Logger.fmt (fun fmt -> Shape.Uid.print fmt uid);
+    let tbl = Ast_iterators.build_uid_to_locs_tbl ~local_defs () in
+    match Shape.Uid.Tbl.find_opt tbl uid with
+    | Some { Location.loc; _ } -> `Some (uid, loc)
+    | None -> log ~title "Uid not found in the local table."; `None
+  end else begin
+    log ~title "Loading the cmt file for unit %S" comp_unit;
+    match load_cmt ~config comp_unit with
+    | Ok (_pos_fname, cmt) ->
+      log ~title "Shapes successfully loaded, looking for %a"
+        Logger.fmt (fun fmt -> Shape.Uid.print fmt uid);
+      begin match Shape.Uid.Tbl.find_opt cmt.cmt_uid_to_decl uid with
+        | Some decl -> loc_of_decl ~uid decl
+        | None -> log ~title "Uid not found in the cmt's table."; `None
+      end
+    | _ -> log ~title "Failed to load the cmt file"; `None
+  end
+
+let find_loc_of_comp_unit ~config uid comp_unit =
+  let title = "find_loc_of_comp_unit" in
+  log ~title "Got the uid of a compilation unit: %s" comp_unit;
+  match load_cmt ~config comp_unit with
+  | Ok (pos_fname, _cmt) ->
+    let pos = Std.Lexing.make_pos ~pos_fname (1, 0) in
+    let loc = { Location.loc_start=pos; loc_end=pos; loc_ghost=true } in
+    `Some (uid, loc)
+    | _ -> log ~title "Failed to load the CU's cmt"; `None
+
+let find_definition_uid ~config ~env ~(decl : Env_lookup.item) path =
+  let namespace = decl.namespace in
+  let module Shape_reduce =
+    Shape.Make_reduce (struct
+      type env = Env.t
+
+      let fuel = 10
+
+      let read_unit_shape ~unit_name =
+          log ~title:"read_unit_shape" "inspecting %s" unit_name;
+          match load_cmt ~config:({config with ml_or_mli = `ML}) unit_name with
+          | Ok (filename, cmt_infos) ->
+            move_to filename cmt_infos;
+            log ~title:"read_unit_shape" "shapes loaded for %s" unit_name;
+            cmt_infos.cmt_impl_shape
+          | Error () ->
+            log ~title:"read_unit_shape" "failed to find %s" unit_name;
+            None
+
+      let find_shape env id = Env.shape_of_path
+        ~namespace:Shape.Sig_component_kind.Module env (Pident id)
+    end)
+  in
+  let shape = Env.shape_of_path ~namespace env path in
+  log ~title:"shape_of_path" "initial: %a"
+    Logger.fmt (Fun.flip Shape.print shape);
+  let reduced = Shape_reduce.reduce_for_uid
+    ~keep_aliases:(not config.traverse_aliases) env shape
+  in
+  log ~title:"shape_of_path" "reduced: %a"
+    Logger.fmt (fun fmt -> Shape.print_reduction_result fmt reduced);
+  reduced
+
+(** This is the main function here *)
 let from_path ~config ~env ~local_defs ~decl path =
-  let shape_result = uid_of_path ~config ~env ~decl path in
-  match from_reduction_result ~config ~local_defs ~decl shape_result path with
-  | `Not_found _ | `Builtin _
-  | `File_not_found _ as err -> err
-  | `Found (uid, loc, approximated) ->
+  let title = "from_path" in
+  let unalias (decl : Env_lookup.item) =
+    if not config.traverse_aliases then decl.uid else
+    let namespace = decl.namespace in
+    let uid = scrape_alias ~fallback_uid:decl.uid ~env ~namespace path in
+    if uid <> decl.uid then
+      log ~title:"uid_of_path" "Unaliased declaration uid: %a -> %a"
+        Logger.fmt (Fun.flip Shape.Uid.print decl.uid)
+        Logger.fmt (Fun.flip Shape.Uid.print uid);
+    uid
+  in
+  (* Step 1:  Path => Uid *)
+  let decl : Env_lookup.item = { decl with uid = (unalias decl) } in
+  let uid, approximated = match config.ml_or_mli with
+    | `MLI -> decl.uid, false
+    | `ML ->
+      match find_definition_uid ~config ~env ~decl path with
+      | Shape.Resolved uid -> uid, false
+      | Unresolved { uid = Some uid; desc = Comp_unit _; approximated } ->
+          uid, approximated
+      | Approximated _ | Unresolved _ | Missing_uid ->
+          log ~title "No definition uid, falling back to the declaration uid: %a"
+            Logger.fmt (Fun.flip Shape.Uid.print decl.uid);
+          decl.uid, true
+  in
+  (* Step 2:  Uid => Location *)
+  let loc = match uid with
+    | Predef s -> `Builtin s
+    | Internal -> `Builtin "<internal>"
+    | Item {comp_unit; _} -> find_loc_of_uid ~config ~local_defs uid comp_unit
+    | Compilation_unit comp_unit -> find_loc_of_comp_unit ~config uid comp_unit
+  in
+  let loc = match loc with
+    | `None ->
+      log ~title "Falling back to the declaration's location: %a"
+        Logger.fmt (Fun.flip Location.print_loc decl.loc);
+      `Some (decl.uid, decl.loc)
+    | other -> other
+  in
+  (* Step 3:  Location => Source *)
+  match loc with
+  | `None -> assert false
+  | `Builtin _ as err -> err
+  | `Some (uid, loc) ->
     match find_source ~config:config.mconfig loc (Path.name path) with
     | `Found (file, location) ->
       log ~title:"find_source" "Found file: %s (%a)" file
         Logger.fmt (Fun.flip Location.print_loc location);
       `Found {
         uid;
-        reduction_result = shape_result;
         decl_uid = decl.uid;
         file; location; approximated }
     | `File_not_found _ as otherwise -> otherwise
@@ -830,8 +808,8 @@ let find_doc_attributes_in_typedtree ~config ~comp_unit uid =
 
 let doc_from_uid ~config ~loc uid =
   begin match uid with
-  | Some (Shape.Uid.Item { comp_unit; _ } as uid)
-  | Some (Shape.Uid.Compilation_unit comp_unit as uid)
+  | Shape.Uid.Item { comp_unit; _ }
+  | Shape.Uid.Compilation_unit comp_unit
       when Env.get_unit_name () <> comp_unit ->
         log ~title:"get_doc" "the doc (%a) you're looking for is in another
           compilation unit (%s)"
diff --git a/src/analysis/locate.mli b/src/analysis/locate.mli
index 2cd4928611..5ad25b880f 100644
--- a/src/analysis/locate.mli
+++ b/src/analysis/locate.mli
@@ -35,8 +35,7 @@ type config = {
 }
 
 type result = {
-  uid: Shape.Uid.t option;
-  reduction_result: Shape.reduction_result;
+  uid: Shape.Uid.t;
   decl_uid: Shape.Uid.t;
   file: string;
   location: Location.t;

From 8f1ee55da3cd86f37eb550a1adc13b6e39560e47 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Fri, 17 Nov 2023 12:58:59 +0100
Subject: [PATCH 18/58] test: promote ok test change

---
 .../locate/non-local/ignore-kept-locs.t/run.t     | 15 +++++++++------
 1 file changed, 9 insertions(+), 6 deletions(-)

diff --git a/tests/test-dirs/locate/non-local/ignore-kept-locs.t/run.t b/tests/test-dirs/locate/non-local/ignore-kept-locs.t/run.t
index 9c8b42ac1d..b0ffbc5283 100644
--- a/tests/test-dirs/locate/non-local/ignore-kept-locs.t/run.t
+++ b/tests/test-dirs/locate/non-local/ignore-kept-locs.t/run.t
@@ -19,7 +19,8 @@ available:
     "notifications": []
   }
 
-  $ grep -A1 from_uid log | grep -v from_uid | sed '/^--$/d'
+  $ grep -A1 -e from_path -e find_loc_of_uid log | 
+  > grep -v -e from_path -e find_loc_of_uid | sed '/^--$/d'
   Loading the cmt file for unit "A"
   Shapes successfully loaded, looking for A.0
   Found location: File "a.ml", line 1, characters 4-9
@@ -40,7 +41,8 @@ available:
     "notifications": []
   }
 
-  $ grep -A1 from_uid log | grep -v from_uid | sed '/^--$/d'
+  $ grep -A1 -e from_path -e find_loc_of_uid log | 
+  > grep -v -e from_path -e find_loc_of_uid | sed '/^--$/d'
   Loading the cmt file for unit "A"
   Shapes successfully loaded, looking for A.0
   Found location: File "a.ml", line 1, characters 4-9
@@ -65,11 +67,12 @@ In the absence of cmt though, fallbacking to the cmi loc makes sense:
     "notifications": []
   }
 
-  $ grep -A1 from_uid log | grep -v from_uid
-  No definition uid, fallbacking to the declaration uid: A.0
+  $ grep -A1 -e from_path -e find_loc_of_uid log | 
+  > grep -v -e from_path -e find_loc_of_uid
+  No definition uid, falling back to the declaration uid: A.0
   Loading the cmt file for unit "A"
   --
-  Failed to load the shapes
-  Uid not found in the cmt table. Fallbacking to the node's location: File "a.ml", line 1, characters 4-9
+  Failed to load the cmt file
+  Falling back to the declaration's location: File "a.ml", line 1, characters 4-9
 
   $ rm log

From 2341f1505d317d5f7a8fbcc158c0581bebcf1ae5 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Fri, 17 Nov 2023 13:42:52 +0100
Subject: [PATCH 19/58] Locate, return builtin uids

---
 src/analysis/locate.ml         | 22 ++++++----------------
 src/analysis/locate.mli        |  4 ++--
 src/frontend/query_commands.ml |  7 +++++--
 3 files changed, 13 insertions(+), 20 deletions(-)

diff --git a/src/analysis/locate.ml b/src/analysis/locate.ml
index 8780fa7a79..b8883d0f94 100644
--- a/src/analysis/locate.ml
+++ b/src/analysis/locate.ml
@@ -209,10 +209,6 @@ end
 
 
 module Utils = struct
-  let is_builtin_path = function
-    | Path.Pident id -> Ident.is_predef id
-    | _ -> false
-
   (* Reuse the code of [Misc.find_in_path_uncap] but returns all the files
      matching, instead of the first one. This is only used when looking for ml
      files, not cmts. Indeed for cmts we know that the load path will only ever
@@ -599,8 +595,8 @@ let from_path ~config ~env ~local_defs ~decl path =
   in
   (* Step 2:  Uid => Location *)
   let loc = match uid with
-    | Predef s -> `Builtin s
-    | Internal -> `Builtin "<internal>"
+    | Predef s -> `Builtin (uid, s)
+    | Internal -> `Builtin (uid, "<internal>")
     | Item {comp_unit; _} -> find_loc_of_uid ~config ~local_defs uid comp_unit
     | Compilation_unit comp_unit -> find_loc_of_comp_unit ~config uid comp_unit
   in
@@ -633,19 +629,13 @@ let from_longident ~config ~env ~local_defs nss ident =
   in
   match Env_lookup.in_namespaces nss ident env with
   | None -> `Not_in_env str_ident
-  | Some (path, decl) ->
-    if Utils.is_builtin_path path then
-      `Builtin (Path.name path)
-    else from_path ~config ~env ~local_defs ~decl path
+  | Some (path, decl) -> from_path ~config ~env ~local_defs ~decl path
 
 let from_path ~config ~env ~local_defs ~namespace path =
   File_switching.reset ();
-  if Utils.is_builtin_path path then
-    `Builtin (Path.name path)
-  else
-    match Env_lookup.loc path namespace env with
-    | None -> `Not_in_env (Path.name path)
-    | Some decl -> from_path ~config ~env ~local_defs ~decl path
+  match Env_lookup.loc path namespace env with
+  | None -> `Not_in_env (Path.name path)
+  | Some decl -> from_path ~config ~env ~local_defs ~decl path
 
 let infer_namespace ?namespaces ~pos lid browse is_label =
   match namespaces with
diff --git a/src/analysis/locate.mli b/src/analysis/locate.mli
index 5ad25b880f..54b51dd1e1 100644
--- a/src/analysis/locate.mli
+++ b/src/analysis/locate.mli
@@ -57,7 +57,7 @@ val from_path
   -> Path.t
   -> [> `File_not_found of string
      | `Found of result
-     | `Builtin of string
+     | `Builtin of Shape.Uid.t * string
      | `Not_in_env of string
      | `Not_found of string * string option ]
 
@@ -70,7 +70,7 @@ val from_string
   -> string
   -> [> `File_not_found of string
       | `Found of result
-      | `Builtin of string
+      | `Builtin of Shape.Uid.t * string
       | `Missing_labels_namespace
       | `Not_found of string * string option
       | `Not_in_env of string
diff --git a/src/frontend/query_commands.ml b/src/frontend/query_commands.ml
index b22543e845..fb8873714f 100644
--- a/src/frontend/query_commands.ml
+++ b/src/frontend/query_commands.ml
@@ -401,7 +401,7 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a =
                 ~local_defs
                 ~namespace:Type
                 path with
-        | `Builtin s -> `Builtin s
+        | `Builtin (_, s) -> `Builtin s
         | `Not_in_env _ as s -> s
         | `Not_found _ as s -> s
         | `Found { file; location; _ } -> `Found (Some file, location.loc_start)
@@ -542,7 +542,10 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a =
     | `Missing_labels_namespace ->
       (* Can't happen because we haven't passed a namespace as input. *)
       assert false
-    | (`Not_found _|`At_origin |`Not_in_env _|`File_not_found _|`Builtin _) as
+    | `Builtin (_, s) ->
+      Locate.log ~title:"result" "found builtin %s" s;
+      `Builtin s
+    | (`Not_found _|`At_origin |`Not_in_env _|`File_not_found _) as
       otherwise ->
       Locate.log ~title:"result" "not found";
       otherwise

From 2597a5d9bdd1fed186268e844990af6f938aa8b8 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Fri, 17 Nov 2023 13:43:36 +0100
Subject: [PATCH 20/58] occurrences: show predefs in local buffer

---
 src/analysis/occurrences.ml    | 5 +++--
 src/ocaml/typing/cmt_format.ml | 1 -
 2 files changed, 3 insertions(+), 3 deletions(-)

diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml
index 32bedfde55..1c5af84efa 100644
--- a/src/analysis/occurrences.ml
+++ b/src/analysis/occurrences.ml
@@ -124,14 +124,15 @@ let locs_of ~config ~scope ~env ~local_defs ~pos ~node:_ path =
       let node = Mbrowse.enclosing pos [browse] in
       let env, node = Mbrowse.leaf_node node in
       uid_and_loc_of_node env node
-    | `Found { uid = Some uid; location; approximated = false; _ } ->
+    | `Found { uid; location; approximated = false; _ } ->
         log ~title:"locs_of" "Found definition uid using locate: %a "
           Logger.fmt (fun fmt -> Shape.Uid.print fmt uid);
         Some (uid, location)
-    | `Found { uid = Some uid; location; approximated = true; _ } ->
+    | `Found { uid; location; approximated = true; _ } ->
         log ~title:"locs_of" "Approx: %a "
           Logger.fmt (fun fmt -> Shape.Uid.print fmt uid);
         Some (uid, location)
+    | `Builtin (uid, s) -> log ~title:"locs_of" "Locate found a builtin: %s" s; Some (uid, Location.none)
     | _ ->
       log ~title:"locs_of" "Locate failed to find a definition.";
       None
diff --git a/src/ocaml/typing/cmt_format.ml b/src/ocaml/typing/cmt_format.ml
index 7f5d9c8331..1daf02f139 100644
--- a/src/ocaml/typing/cmt_format.ml
+++ b/src/ocaml/typing/cmt_format.ml
@@ -248,7 +248,6 @@ let iter_on_usages ~f () =
     | { Types.cstr_tag = Cstr_extension (path, _); _ } ->
         let namespace : Shape.Sig_component_kind.t = Extension_constructor in
         f ~namespace env path lid
-    | { Types.cstr_uid = Predef _; _ } -> ()
     | { Types.cstr_res; cstr_name; _ } ->
         let path = path_in_type cstr_res cstr_name in
         Option.iter ~f:(fun path -> f ~namespace:Constructor env path lid) path

From d3360b7c4583ebca42a5b883b210cea8567c8002 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Fri, 17 Nov 2023 14:31:49 +0100
Subject: [PATCH 21/58] index: to upstream: correct predef paths

---
 src/ocaml/typing/cmt_format.ml | 3 +++
 1 file changed, 3 insertions(+)

diff --git a/src/ocaml/typing/cmt_format.ml b/src/ocaml/typing/cmt_format.ml
index 1daf02f139..c6b28a5724 100644
--- a/src/ocaml/typing/cmt_format.ml
+++ b/src/ocaml/typing/cmt_format.ml
@@ -248,6 +248,9 @@ let iter_on_usages ~f () =
     | { Types.cstr_tag = Cstr_extension (path, _); _ } ->
         let namespace : Shape.Sig_component_kind.t = Extension_constructor in
         f ~namespace env path lid
+    | { Types.cstr_uid = Predef name; _} ->
+        let id = List.assoc name Predef.builtin_idents in
+        f ~namespace:Constructor env (Pident id) lid
     | { Types.cstr_res; cstr_name; _ } ->
         let path = path_in_type cstr_res cstr_name in
         Option.iter ~f:(fun path -> f ~namespace:Constructor env path lid) path

From 07e65a1f5b2257e05cfdf367577e5e1d411a814c Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Fri, 17 Nov 2023 14:55:38 +0100
Subject: [PATCH 22/58] reconstruct identifier: handle ()

---
 src/ocaml/preprocess/lexer_ident.mll | 1 +
 1 file changed, 1 insertion(+)

diff --git a/src/ocaml/preprocess/lexer_ident.mll b/src/ocaml/preprocess/lexer_ident.mll
index e9690dbd27..fd448d141c 100644
--- a/src/ocaml/preprocess/lexer_ident.mll
+++ b/src/ocaml/preprocess/lexer_ident.mll
@@ -91,6 +91,7 @@ rule token = parse
     { UIDENT ident }
   | "`"  { BACKQUOTE }
   | "'"  { QUOTE }
+  | "()" { LIDENT "()"}
   | "("  { LPAREN }
   | ")"  { RPAREN }
   | "."  { DOT }

From 451fa84119f6f89b4b6cc40c8eab963e7121a9db Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Fri, 17 Nov 2023 14:56:08 +0100
Subject: [PATCH 23/58] New and improved tests

---
 tests/test-dirs/occurrences/issue1410.t  |  28 ++++-
 tests/test-dirs/occurrences/no-ml.t      |  54 +++++++++
 tests/test-dirs/occurrences/only-local.t | 146 +++++++++++++++++++++++
 3 files changed, 225 insertions(+), 3 deletions(-)
 create mode 100644 tests/test-dirs/occurrences/no-ml.t
 create mode 100644 tests/test-dirs/occurrences/only-local.t

diff --git a/tests/test-dirs/occurrences/issue1410.t b/tests/test-dirs/occurrences/issue1410.t
index 14948be952..65e4e27ad5 100644
--- a/tests/test-dirs/occurrences/issue1410.t
+++ b/tests/test-dirs/occurrences/issue1410.t
@@ -1,11 +1,22 @@
-FIXME: No result is returned, we could expect the one occurrence of None.
+No result is returned, we could expect the one occurrence of None.
   $ $MERLIN single occurrences -identifier-at 3:3 -filename opt.ml <<EOF | \
   > jq '.value'
   > (* test case *)
   > let f ?(x=1) () = 2 ;;
   > None
   > EOF
-  []
+  [
+    {
+      "start": {
+        "line": 3,
+        "col": 0
+      },
+      "end": {
+        "line": 3,
+        "col": 4
+      }
+    }
+  ]
 
   $ $MERLIN single occurrences -identifier-at 3:3 -filename opt.ml <<EOF | \
   > jq '.value'
@@ -13,4 +24,15 @@ FIXME: No result is returned, we could expect the one occurrence of None.
   > let f () = 2 ;;
   > None
   > EOF
-  []
+  [
+    {
+      "start": {
+        "line": 3,
+        "col": 0
+      },
+      "end": {
+        "line": 3,
+        "col": 4
+      }
+    }
+  ]
diff --git a/tests/test-dirs/occurrences/no-ml.t b/tests/test-dirs/occurrences/no-ml.t
new file mode 100644
index 0000000000..f133ca2ea0
--- /dev/null
+++ b/tests/test-dirs/occurrences/no-ml.t
@@ -0,0 +1,54 @@
+  $ cat >oui_ml.ml <<'EOF'
+  > type t = int
+  > EOF
+
+  $ cat >no_ml.mli <<'EOF'
+  > include module type of Oui_ml
+  > EOF
+
+  $ cat >main.ml <<'EOF'
+  > let (x : No_ml.t) = 42
+  > open No_ml
+  > let (y : t) = 43
+  > EOF
+
+  $ $OCAMLC -bin-annot -c oui_ml.ml no_ml.mli
+
+  $ $MERLIN single occurrences -scope project -identifier-at 1:15 \
+  > -filename main.ml <main.ml | jq '.value'
+  [
+    {
+      "file": "$TESTCASE_ROOT/main.ml",
+      "start": {
+        "line": 1,
+        "col": 15
+      },
+      "end": {
+        "line": 1,
+        "col": 16
+      }
+    },
+    {
+      "file": "$TESTCASE_ROOT/main.ml",
+      "start": {
+        "line": 3,
+        "col": 9
+      },
+      "end": {
+        "line": 3,
+        "col": 10
+      }
+    }
+  ]
+
+
+
+  $ $MERLIN single locate -look-for ml -position 1:15 \
+  > -filename main.ml <main.ml | jq '.value'
+  {
+    "file": "$TESTCASE_ROOT/oui_ml.ml",
+    "pos": {
+      "line": 1,
+      "col": 5
+    }
+  }
diff --git a/tests/test-dirs/occurrences/only-local.t b/tests/test-dirs/occurrences/only-local.t
new file mode 100644
index 0000000000..1beae3d3af
--- /dev/null
+++ b/tests/test-dirs/occurrences/only-local.t
@@ -0,0 +1,146 @@
+Some occurrences are only available locally an dnot part of the global index
+
+  $ cat >local.ml <<'EOF'
+  > type t = int
+  > let x : int = 42
+  > EOF
+
+Predef:
+  $ $MERLIN single occurrences -identifier-at 2:9 \
+  > -filename local.ml <local.ml | jq '.value'
+  [
+    {
+      "start": {
+        "line": 1,
+        "col": 9
+      },
+      "end": {
+        "line": 1,
+        "col": 12
+      }
+    },
+    {
+      "start": {
+        "line": 2,
+        "col": 8
+      },
+      "end": {
+        "line": 2,
+        "col": 11
+      }
+    }
+  ]
+
+
+Predef constructors:
+  $ cat >local.ml <<'EOF'
+  > let _ = None
+  > let None = None
+  > EOF
+
+  $ $MERLIN single occurrences -identifier-at 1:10 \
+  > -filename local.ml <local.ml | jq '.value'
+  [
+    {
+      "start": {
+        "line": 1,
+        "col": 8
+      },
+      "end": {
+        "line": 1,
+        "col": 12
+      }
+    },
+    {
+      "start": {
+        "line": 2,
+        "col": 4
+      },
+      "end": {
+        "line": 2,
+        "col": 8
+      }
+    },
+    {
+      "start": {
+        "line": 2,
+        "col": 11
+      },
+      "end": {
+        "line": 2,
+        "col": 15
+      }
+    }
+  ]
+
+true / false
+  $ cat >local.ml <<'EOF'
+  > let _ = true
+  > let _ = true
+  > EOF
+
+  $ $MERLIN single occurrences -identifier-at 1:10 \
+  > -filename local.ml <local.ml | jq '.value'
+  [
+    {
+      "start": {
+        "line": 1,
+        "col": 8
+      },
+      "end": {
+        "line": 1,
+        "col": 12
+      }
+    },
+    {
+      "start": {
+        "line": 2,
+        "col": 8
+      },
+      "end": {
+        "line": 2,
+        "col": 12
+      }
+    }
+  ]
+
+unit
+  $ cat >local.ml <<'EOF'
+  > let _ = ()
+  > let f () = ()
+  > EOF
+
+  $ $MERLIN single occurrences -identifier-at 1:9 \
+  > -filename local.ml <local.ml | jq '.value'
+  [
+    {
+      "start": {
+        "line": 1,
+        "col": 8
+      },
+      "end": {
+        "line": 1,
+        "col": 10
+      }
+    },
+    {
+      "start": {
+        "line": 2,
+        "col": 6
+      },
+      "end": {
+        "line": 2,
+        "col": 8
+      }
+    },
+    {
+      "start": {
+        "line": 2,
+        "col": 11
+      },
+      "end": {
+        "line": 2,
+        "col": 13
+      }
+    }
+  ]

From 1e0dc6e6cd123a02119f244e83bf95d0a6109836 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Tue, 21 Nov 2023 16:03:50 +0100
Subject: [PATCH 24/58] test: illustrate issue with wrapping

---
 .../test-dirs/occurrences/occ-and-wrapping.t  | 118 ++++++++++++++++++
 1 file changed, 118 insertions(+)
 create mode 100644 tests/test-dirs/occurrences/occ-and-wrapping.t

diff --git a/tests/test-dirs/occurrences/occ-and-wrapping.t b/tests/test-dirs/occurrences/occ-and-wrapping.t
new file mode 100644
index 0000000000..9abb82a1f9
--- /dev/null
+++ b/tests/test-dirs/occurrences/occ-and-wrapping.t
@@ -0,0 +1,118 @@
+  $ cat >dune-workspace <<'EOF'
+  > (lang dune 3.11)
+  > (workspace_indexation enabled)
+  > EOF
+
+  $ cat >dune-project <<'EOF'
+  > (lang dune 3.11)
+  > EOF
+ 
+  $ mkdir lib
+
+  $ cat >lib/wrapped_module.ml <<'EOF'
+  > let x = 42
+  > let f () = x
+  > EOF
+
+  $ cat >lib/dune <<'EOF'
+  > (library 
+  >  (name lib))
+  > EOF
+
+  $ cat >main.ml <<'EOF'
+  > open Lib
+  > let () = print_int Wrapped_module.x
+  > EOF
+
+  $ cat >dune <<'EOF'
+  > (executable
+  >  (name main)
+  >  (libraries lib))
+  > EOF
+
+  $ dune build @uideps @all
+
+  $ ocaml-index dump _build/default/project.ocaml-index
+  6 uids:
+  {uid: Lib__Wrapped_module; locs:
+     "Lib__Wrapped_module": File "$TESTCASE_ROOT/lib/lib.ml-gen", line 4, characters 24-43
+   uid: Stdlib.313; locs:
+     "print_int": File "$TESTCASE_ROOT/main.ml", line 2, characters 9-18
+   uid: Lib.0; locs:
+     "Wrapped_module": File "$TESTCASE_ROOT/lib/lib.ml-gen", line 4, characters 7-21
+   uid: Lib__Wrapped_module.0; locs:
+     "x": File "$TESTCASE_ROOT/lib/wrapped_module.ml", line 1, characters 4-5;
+     "x": File "$TESTCASE_ROOT/lib/wrapped_module.ml", line 2, characters 11-12;
+     "Wrapped_module.x": File "$TESTCASE_ROOT/main.ml", line 2, characters 19-35
+   uid: Lib; locs:
+     "Lib": File "$TESTCASE_ROOT/main.ml", line 1, characters 5-8
+   uid: Lib__Wrapped_module.1; locs:
+     "f": File "$TESTCASE_ROOT/lib/wrapped_module.ml", line 2, characters 4-5
+   }, 0 approx shapes: {}, and shapes for CUS .
+
+  $ $MERLIN single occurrences -scope project -identifier-at 2:34 \
+  > -filename main.ml <main.ml | jq '.value'
+  [
+    {
+      "file": "$TESTCASE_ROOT/lib/wrapped_module.ml",
+      "start": {
+        "line": 1,
+        "col": 4
+      },
+      "end": {
+        "line": 1,
+        "col": 5
+      }
+    },
+    {
+      "file": "$TESTCASE_ROOT/lib/wrapped_module.ml",
+      "start": {
+        "line": 2,
+        "col": 11
+      },
+      "end": {
+        "line": 2,
+        "col": 12
+      }
+    },
+    {
+      "file": "$TESTCASE_ROOT/main.ml",
+      "start": {
+        "line": 2,
+        "col": 34
+      },
+      "end": {
+        "line": 2,
+        "col": 35
+      }
+    }
+  ]
+
+FIXME: These are only the local occurrences. This is due to Merlin identifing
+the uid as part of `Wrapped_module` instead of `Lib__wrapped_module`.
+  $ $MERLIN single occurrences -scope project -identifier-at 2:11 \
+  > -filename lib/wrapped_module.ml <lib/wrapped_module.ml | jq '.value'
+  [
+    {
+      "file": "$TESTCASE_ROOT/lib/wrapped_module.ml",
+      "start": {
+        "line": 1,
+        "col": 4
+      },
+      "end": {
+        "line": 1,
+        "col": 5
+      }
+    },
+    {
+      "file": "$TESTCASE_ROOT/lib/wrapped_module.ml",
+      "start": {
+        "line": 2,
+        "col": 11
+      },
+      "end": {
+        "line": 2,
+        "col": 12
+      }
+    }
+  ]

From 26fd7e5849f277fb8c3f75495cd10215fa618235 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Wed, 22 Nov 2023 11:10:33 +0100
Subject: [PATCH 25/58] New `UNIT_NAME` configuration directive

---
 src/dot-merlin/dot_merlin_reader.ml               | 15 ++++++++-------
 src/dot-protocol/merlin_dot_protocol.ml           |  3 +++
 src/dot-protocol/merlin_dot_protocol.mli          |  1 +
 src/kernel/mconfig.ml                             |  9 ++++++++-
 src/kernel/mconfig.mli                            |  1 +
 src/kernel/mconfig_dot.ml                         |  5 +++++
 src/kernel/mconfig_dot.mli                        |  1 +
 .../test-dirs/config/dot-merlin-reader/quoting.t  |  1 +
 8 files changed, 28 insertions(+), 8 deletions(-)

diff --git a/src/dot-merlin/dot_merlin_reader.ml b/src/dot-merlin/dot_merlin_reader.ml
index 0883f92163..3ac4df2077 100644
--- a/src/dot-merlin/dot_merlin_reader.ml
+++ b/src/dot-merlin/dot_merlin_reader.ml
@@ -90,6 +90,10 @@ module Cache = File_cache.Make (struct
             recurse := true
           else if String.is_prefixed ~by:". " line then
             includes := String.trim (String.drop 2 line) :: !includes
+          else if String.is_prefixed ~by:"INDEX_FILE " line then
+            tell (`INDEX_FILE (String.drop 11 line))
+          else if String.is_prefixed ~by:"UNIT_NAME " line then
+            tell (`UNIT_NAME (String.drop 10 line))
           else if String.is_prefixed ~by:"STDLIB " line then
             tell (`STDLIB (String.drop 7 line))
           else if String.is_prefixed ~by:"FINDLIB " line then
@@ -306,6 +310,7 @@ type config = {
   to_canonicalize : (string * Merlin_dot_protocol.Directive.include_path) list;
   stdlib : string option;
   index_file : string option;
+  unit_name : string option;
   packages_to_load : string list;
   findlib : string option;
   findlib_path : string list;
@@ -317,6 +322,7 @@ let empty_config = {
   to_canonicalize   = [];
   stdlib            = None;
   index_file        = None;
+  unit_name         = None;
   packages_to_load  = [];
   findlib           = None;
   findlib_path      = [];
@@ -328,7 +334,7 @@ let prepend_config ~cwd ~cfg =
     match d with
     | `B _ | `S _ | `CMI _ | `CMT _  as directive ->
       { cfg with to_canonicalize = (cwd, directive) :: cfg.to_canonicalize }
-    | `EXT _ | `SUFFIX _ | `FLG _ | `READER _
+    | `EXT _ | `SUFFIX _ | `FLG _ | `READER _ | `UNIT_NAME _
     | (`EXCLUDE_QUERY_DIR | `USE_PPX_CACHE | `UNKNOWN_TAG _) as directive ->
       { cfg with pass_forward = directive :: cfg.pass_forward }
     | `PKG ps ->
@@ -343,12 +349,7 @@ let prepend_config ~cwd ~cfg =
       { cfg with stdlib = Some canon_path }
     | `INDEX_FILE path ->
       let canon_path = canonicalize_filename ~cwd path in
-      begin match cfg.index_file with
-      | None -> ()
-      | Some p ->
-        log ~title:"conflicting paths for index file" "%s\n%s" p canon_path
-      end;
-      { cfg with index_file = Some canon_path }
+      { cfg with pass_forward = `INDEX_FILE canon_path :: cfg.pass_forward }
     | `FINDLIB path ->
       let canon_path = canonicalize_filename ~cwd path in
       begin match cfg.stdlib with
diff --git a/src/dot-protocol/merlin_dot_protocol.ml b/src/dot-protocol/merlin_dot_protocol.ml
index 04f258729e..ed6466a40c 100644
--- a/src/dot-protocol/merlin_dot_protocol.ml
+++ b/src/dot-protocol/merlin_dot_protocol.ml
@@ -38,6 +38,7 @@ module Directive = struct
     | `FLG of string list
     | `STDLIB of string
     | `INDEX_FILE of string
+    | `UNIT_NAME of string
     | `SUFFIX of string
     | `READER of string list
     | `EXCLUDE_QUERY_DIR
@@ -87,6 +88,7 @@ module Sexp = struct
         | "CMT" -> `CMT value
         | "STDLIB" -> `STDLIB value
         | "INDEX_FILE" -> `INDEX_FILE value
+        | "UNIT_NAME" -> `UNIT_NAME value
         | "SUFFIX" -> `SUFFIX value
         | "ERROR" -> `ERROR_MSG value
         | "FLG" ->
@@ -120,6 +122,7 @@ module Sexp = struct
         | `FLG ss -> ("FLG", [ List (atoms_of_strings ss) ])
         | `STDLIB s -> ("STDLIB", single s)
         | `INDEX_FILE s -> ("INDEX_FILE", single s)
+        | `UNIT_NAME s -> ("UNIT_NAME", single s)
         | `SUFFIX s -> ("SUFFIX", single s)
         | `READER ss -> ("READER", [ List (atoms_of_strings ss) ])
         | `EXCLUDE_QUERY_DIR -> ("EXCLUDE_QUERY_DIR", [])
diff --git a/src/dot-protocol/merlin_dot_protocol.mli b/src/dot-protocol/merlin_dot_protocol.mli
index ccb36e4bf0..ffb744380b 100644
--- a/src/dot-protocol/merlin_dot_protocol.mli
+++ b/src/dot-protocol/merlin_dot_protocol.mli
@@ -50,6 +50,7 @@ module Directive : sig
     | `FLG of string list
     | `STDLIB of string
     | `INDEX_FILE of string
+    | `UNIT_NAME of string
     | `SUFFIX of string
     | `READER of string list
     | `EXCLUDE_QUERY_DIR
diff --git a/src/kernel/mconfig.ml b/src/kernel/mconfig.ml
index 886d750aa8..996e383227 100644
--- a/src/kernel/mconfig.ml
+++ b/src/kernel/mconfig.ml
@@ -78,6 +78,7 @@ type merlin = {
   suffixes    : (string * string) list;
   stdlib      : string option;
   index_file  : string option;
+  unit_name   : string option;
   reader      : string list;
   protocol    : [`Json | `Sexp];
   log_file    : string option;
@@ -117,6 +118,7 @@ let dump_merlin x =
     );
     "stdlib"       , Json.option Json.string x.stdlib;
     "index_file"   , Json.option Json.string x.index_file;
+    "unit_name"    , Json.option Json.string x.unit_name;
     "reader"       , `List (List.map ~f:Json.string x.reader);
     "protocol"     , (match x.protocol with
         | `Json -> `String "json"
@@ -254,6 +256,7 @@ let get_external_config path t =
       suffixes = dot.suffixes @ merlin.suffixes;
       stdlib = (if dot.stdlib = None then merlin.stdlib else dot.stdlib);
       index_file = dot.index_file;
+      unit_name = dot.unit_name;
       reader =
         if dot.reader = []
         then merlin.reader
@@ -627,6 +630,7 @@ let initial = {
     suffixes    = [(".ml", ".mli"); (".re", ".rei")];
     stdlib      = None;
     index_file  = None;
+    unit_name   = None;
     reader      = [];
     protocol    = `Json;
     log_file    = None;
@@ -799,4 +803,7 @@ let global_modules ?(include_current=false) config = (
 
 let filename t = t.query.filename
 
-let unitname t = Misc.unitname t.query.filename
+let unitname t =
+  match t.merlin.unit_name with
+  | None -> Misc.unitname t.query.filename
+  | Some unit_name -> String.capitalize_ascii unit_name
diff --git a/src/kernel/mconfig.mli b/src/kernel/mconfig.mli
index 4343bef9f2..22f65d6479 100644
--- a/src/kernel/mconfig.mli
+++ b/src/kernel/mconfig.mli
@@ -36,6 +36,7 @@ type merlin = {
   suffixes    : (string * string) list;
   stdlib      : string option;
   index_file  : string option;
+  unit_name   : string option;
   reader      : string list;
   protocol    : [`Json | `Sexp];
   log_file    : string option;
diff --git a/src/kernel/mconfig_dot.ml b/src/kernel/mconfig_dot.ml
index 3a7de973e6..6e3df99352 100644
--- a/src/kernel/mconfig_dot.ml
+++ b/src/kernel/mconfig_dot.ml
@@ -42,6 +42,7 @@ type config = {
   suffixes     : (string * string) list;
   stdlib       : string option;
   index_file   : string option;
+  unit_name    : string option;
   reader       : string list;
   exclude_query_dir : bool;
   use_ppx_cache : bool;
@@ -57,6 +58,7 @@ let empty_config = {
   flags        = [];
   stdlib       = None;
   index_file   = None;
+  unit_name    = None;
   reader       = [];
   exclude_query_dir = false;
   use_ppx_cache = false;
@@ -250,6 +252,8 @@ let prepend_config ~dir:cwd configurator (directives : directive list) config =
       {config with stdlib = Some path}, errors
     | `INDEX_FILE path ->
       {config with index_file = Some path}, errors
+    | `UNIT_NAME unit_name ->
+      {config with unit_name = Some unit_name}, errors
     | `READER reader ->
       {config with reader}, errors
     | `EXCLUDE_QUERY_DIR ->
@@ -279,6 +283,7 @@ let postprocess_config config =
     flags        = clean config.flags;
     stdlib       = config.stdlib;
     index_file   = config.index_file;
+    unit_name    = config.unit_name;
     reader       = config.reader;
     exclude_query_dir = config.exclude_query_dir;
     use_ppx_cache = config.use_ppx_cache;
diff --git a/src/kernel/mconfig_dot.mli b/src/kernel/mconfig_dot.mli
index 18c8f90219..aa9fc4c7d9 100644
--- a/src/kernel/mconfig_dot.mli
+++ b/src/kernel/mconfig_dot.mli
@@ -38,6 +38,7 @@ type config = {
   suffixes     : (string * string) list;
   stdlib       : string option;
   index_file   : string option;
+  unit_name    : string option;
   reader       : string list;
   exclude_query_dir : bool;
   use_ppx_cache : bool;
diff --git a/tests/test-dirs/config/dot-merlin-reader/quoting.t b/tests/test-dirs/config/dot-merlin-reader/quoting.t
index ca81bb5323..f1c485a8d9 100644
--- a/tests/test-dirs/config/dot-merlin-reader/quoting.t
+++ b/tests/test-dirs/config/dot-merlin-reader/quoting.t
@@ -52,6 +52,7 @@
     ],
     "stdlib": null,
     "index_file": null,
+    "unit_name": null,
     "reader": [],
     "protocol": "json",
     "log_file": null,

From 2e618e1b5780f4a5db24a448a07a18e9cae4986f Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Wed, 22 Nov 2023 11:10:39 +0100
Subject: [PATCH 26/58] occurrences: use new UNIT_NAME to fix issue with
 wrapping

---
 src/analysis/occurrences.ml                   | 31 ++++++++++++-------
 .../test-dirs/occurrences/occ-and-wrapping.t  | 21 ++++++++++---
 2 files changed, 36 insertions(+), 16 deletions(-)

diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml
index 1c5af84efa..d8f1d89a9b 100644
--- a/src/analysis/occurrences.ml
+++ b/src/analysis/occurrences.ml
@@ -4,6 +4,7 @@ module LidSet = Index_format.LidSet
 let {Logger. log} = Logger.for_section "occurrences"
 
 let index_buffer ~local_defs () =
+  let {Logger. log} = Logger.for_section "index" in
   let defs = Hashtbl.create 64 in
   let module Shape_reduce =
     Shape.Make_reduce (struct
@@ -105,6 +106,11 @@ let loc_of_local_def ~local_defs uid =
     (* we could check equality and raise with the result as soon that it arrive *)
     Shape.Uid.Tbl.find uid_to_locs_tbl uid
 
+let comp_unit_of_uid = function
+  | Shape.Uid.Compilation_unit comp_unit
+  | Item { comp_unit; _ } -> Some comp_unit
+  | Internal | Predef _ -> None
+
 let locs_of ~config ~scope ~env ~local_defs ~pos ~node:_ path =
   log ~title:"occurrences" "Looking for occurences of %s (pos: %s)"
     path
@@ -141,9 +147,9 @@ let locs_of ~config ~scope ~env ~local_defs ~pos ~node:_ path =
     Filename.concat config.query.directory config.query.filename
   in
   match def with
-  | Some (uid, def_loc) ->
+  | Some (def_uid, def_loc) ->
     log ~title:"locs_of" "Definition has uid %a (%a)"
-      Logger.fmt (fun fmt -> Shape.Uid.print fmt uid)
+      Logger.fmt (fun fmt -> Shape.Uid.print fmt def_uid)
       Logger.fmt (fun fmt -> Location.print_loc fmt def_loc);
     log ~title:"locs_of" "Indexing current buffer";
     let index = index_buffer ~local_defs () in
@@ -156,11 +162,14 @@ let locs_of ~config ~scope ~env ~local_defs ~pos ~node:_ path =
         merge_tbl ~into:index external_uideps.defs
     end;
     (* TODO ignore externally indexed locs from the current buffer *)
-    let locs = match Hashtbl.find_opt index uid with
+    let locs = match Hashtbl.find_opt index def_uid with
       | Some locs ->
+        log ~title:"occurrences" "Found %i locs" (LidSet.cardinal locs);
         LidSet.elements locs
-        |> List.filter_map ~f:(fun lid ->
-          let loc = last_loc lid.Location.loc lid.txt in
+        |> List.filter_map ~f:(fun {Location.txt; loc} ->
+          log ~title:"occurrences" "Found occ: %s %a"
+            (Longident.head txt) Logger.fmt (Fun.flip Location.print_loc loc);
+          let loc = last_loc loc txt in
           let fname = loc.Location.loc_start.Lexing.pos_fname in
           if String.equal fname current_buffer_path then
             (* ignore locs coming from the external index for the buffer *)
@@ -177,13 +186,13 @@ let locs_of ~config ~scope ~env ~local_defs ~pos ~node:_ path =
           end else Some loc)
       | None -> log ~title:"locs_of" "No locs found in index."; []
     in
-    (* We only prepend the location of the definition if it's int he scope of
-       the query *)
-    let loc_in_unit (loc : Location.t) =
-      let by = Env.get_unit_name () |> String.lowercase_ascii in
-      String.is_prefixed ~by (loc.loc_start.pos_fname |> String.lowercase_ascii)
+    (* We only prepend the loc of the definition for the current buffer *)
+    let uid_in_current_unit =
+      let uid_comp_unit = comp_unit_of_uid def_uid in
+      Option.value_map ~default:false uid_comp_unit
+        ~f:(String.equal @@ Env.get_unit_name ())
     in
-    if loc_in_unit def_loc then
+    if uid_in_current_unit then
       let def_loc = {def_loc with
         loc_start = {def_loc.loc_start with pos_fname = current_buffer_path }} in
       Ok (def_loc::locs)
diff --git a/tests/test-dirs/occurrences/occ-and-wrapping.t b/tests/test-dirs/occurrences/occ-and-wrapping.t
index 9abb82a1f9..efe2dc2f9f 100644
--- a/tests/test-dirs/occurrences/occ-and-wrapping.t
+++ b/tests/test-dirs/occurrences/occ-and-wrapping.t
@@ -21,7 +21,7 @@
 
   $ cat >main.ml <<'EOF'
   > open Lib
-  > let () = print_int Wrapped_module.x
+  > let _y = print_int Wrapped_module.x
   > EOF
 
   $ cat >dune <<'EOF'
@@ -30,12 +30,14 @@
   >  (libraries lib))
   > EOF
 
-  $ dune build @uideps @all
+  $ dune build @uideps @all 
 
   $ ocaml-index dump _build/default/project.ocaml-index
-  6 uids:
+  7 uids:
   {uid: Lib__Wrapped_module; locs:
      "Lib__Wrapped_module": File "$TESTCASE_ROOT/lib/lib.ml-gen", line 4, characters 24-43
+   uid: Dune__exe__Main.0; locs:
+     "_y": File "$TESTCASE_ROOT/main.ml", line 2, characters 4-6
    uid: Stdlib.313; locs:
      "print_int": File "$TESTCASE_ROOT/main.ml", line 2, characters 9-18
    uid: Lib.0; locs:
@@ -88,8 +90,6 @@
     }
   ]
 
-FIXME: These are only the local occurrences. This is due to Merlin identifing
-the uid as part of `Wrapped_module` instead of `Lib__wrapped_module`.
   $ $MERLIN single occurrences -scope project -identifier-at 2:11 \
   > -filename lib/wrapped_module.ml <lib/wrapped_module.ml | jq '.value'
   [
@@ -114,5 +114,16 @@ the uid as part of `Wrapped_module` instead of `Lib__wrapped_module`.
         "line": 2,
         "col": 12
       }
+    },
+    {
+      "file": "$TESTCASE_ROOT/main.ml",
+      "start": {
+        "line": 2,
+        "col": 34
+      },
+      "end": {
+        "line": 2,
+        "col": 35
+      }
     }
   ]

From 08c06dcfd74659d5705909a88db87dacc742c05e Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Wed, 22 Nov 2023 16:58:35 +0100
Subject: [PATCH 27/58] shapes: dependent keep_alias

---
 src/analysis/locate.ml     |  7 ++++++-
 src/ocaml/typing/shape.ml  | 12 ++++++------
 src/ocaml/typing/shape.mli |  4 ++--
 3 files changed, 14 insertions(+), 9 deletions(-)

diff --git a/src/analysis/locate.ml b/src/analysis/locate.ml
index b8883d0f94..95b1ce1b99 100644
--- a/src/analysis/locate.ml
+++ b/src/analysis/locate.ml
@@ -559,8 +559,13 @@ let find_definition_uid ~config ~env ~(decl : Env_lookup.item) path =
   let shape = Env.shape_of_path ~namespace env path in
   log ~title:"shape_of_path" "initial: %a"
     Logger.fmt (Fun.flip Shape.print shape);
+  let keep_aliases =
+    if config.traverse_aliases
+    then (fun _ -> false)
+    else (fun _ -> true)
+  in
   let reduced = Shape_reduce.reduce_for_uid
-    ~keep_aliases:(not config.traverse_aliases) env shape
+    ~keep_aliases env shape
   in
   log ~title:"shape_of_path" "reduced: %a"
     Logger.fmt (fun fmt -> Shape.print_reduction_result fmt reduced);
diff --git a/src/ocaml/typing/shape.ml b/src/ocaml/typing/shape.ml
index 46b820b467..0307eb2b1b 100644
--- a/src/ocaml/typing/shape.ml
+++ b/src/ocaml/typing/shape.ml
@@ -327,7 +327,7 @@ end) = struct
 
   type env = {
     fuel: int ref;
-    keep_aliases: bool;
+    keep_aliases: t -> bool;
     global_env: Params.env;
     local_env: local_env;
     reduce_memo_table: (thunk, nf) Hashtbl.t;
@@ -455,9 +455,9 @@ end) = struct
       | Struct m ->
           let mnf = Item.Map.map (delay_reduce env) m in
           return (NStruct mnf)
-      | Alias t ->
-        let nf = reduce env t in
-        if env.keep_aliases then
+      | Alias aliased_t ->
+        let nf = reduce env aliased_t in
+        if env.keep_aliases t then
           return (NAlias nf)
         else nf
       | Error s -> return ~approximated:true (NError s)
@@ -499,7 +499,7 @@ end) = struct
   let reduce_memo_table = Hashtbl.create 42
   let read_back_memo_table = Hashtbl.create 42
 
-  let reduce ?(keep_aliases = true) global_env t =
+  let reduce ?(keep_aliases = fun _ -> true) global_env t =
     let fuel = ref Params.fuel in
     let local_env = Ident.Map.empty in
     let env = {
@@ -523,7 +523,7 @@ end) = struct
     | NError _ -> false
     | NLeaf -> false
 
-  let reduce_for_uid ?(keep_aliases = true) global_env t =
+  let reduce_for_uid ?(keep_aliases = fun _ -> true) global_env t =
     let fuel = ref Params.fuel in
     let local_env = Ident.Map.empty in
     let env = {
diff --git a/src/ocaml/typing/shape.mli b/src/ocaml/typing/shape.mli
index f6bafecd6a..18cd20331a 100644
--- a/src/ocaml/typing/shape.mli
+++ b/src/ocaml/typing/shape.mli
@@ -218,12 +218,12 @@ module Make_reduce(Context : sig
     val find_shape : env -> Ident.t -> t
   end) : sig
   val reduce :
-    ?keep_aliases:bool -> Context.env -> t -> t
+    ?keep_aliases:(t -> bool) -> Context.env -> t -> t
 
   (** Perform weak reduction and return the head's uid if any. If reduction was
     incomplete the partially reduced shape is returned. *)
   val reduce_for_uid :
-    ?keep_aliases:bool -> Context.env -> t -> reduction_result
+    ?keep_aliases:(t -> bool) -> Context.env -> t -> reduction_result
 end
 
 (** [toplevel_local_reduce] is only suitable to reduce toplevel shapes (shapes

From d3011c474b4fcca29927136de4a3cfb42d5d1018 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Thu, 23 Nov 2023 15:50:04 +0100
Subject: [PATCH 28/58] Reduce log verbosity when looking for a file

---
 src/utils/misc.ml | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/src/utils/misc.ml b/src/utils/misc.ml
index 1c1c2f4093..3b5de7927e 100644
--- a/src/utils/misc.ml
+++ b/src/utils/misc.ml
@@ -271,9 +271,9 @@ let find_in_path_uncap ?(fallback="") path name =
         then Some (Filename.concat dirname uname)
         else if exact_file_exists ~dirname ~basename:name
         then Some (Filename.concat dirname name)
-        else 
-          let () = Logger.log 
-            ~section:"locate" 
+        else
+          let () = Logger.log
+            ~section:"find-file"
             ~title:"find_in_path_uncap"
             "Failed to load %s/%s" dirname name
           in

From 2e87e3af8d017111ab589c0615b73dec715c07ec Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Fri, 24 Nov 2023 16:31:54 +0100
Subject: [PATCH 29/58] Locate: traverse wrapping aliases

---
 src/analysis/locate.ml | 18 ++++++++++++++----
 1 file changed, 14 insertions(+), 4 deletions(-)

diff --git a/src/analysis/locate.ml b/src/analysis/locate.ml
index 95b1ce1b99..303e312033 100644
--- a/src/analysis/locate.ml
+++ b/src/analysis/locate.ml
@@ -308,12 +308,12 @@ let move_to filename cmt_infos =
   in
   File_switching.move_to ~digest filename
 
-let load_cmt ~config comp_unit =
+let load_cmt ~config ?(with_fallback = true) comp_unit =
   Preferences.set config.ml_or_mli;
   let file =
     Preferences.build comp_unit
   in
-  match Utils.find_file ~config:config.mconfig ~with_fallback:true file with
+  match Utils.find_file ~config:config.mconfig ~with_fallback file with
   | Some path ->
       let cmt_infos = (Cmt_cache.read path).cmt_infos in
       let source_file = cmt_infos.cmt_sourcefile in
@@ -543,7 +543,10 @@ let find_definition_uid ~config ~env ~(decl : Env_lookup.item) path =
 
       let read_unit_shape ~unit_name =
           log ~title:"read_unit_shape" "inspecting %s" unit_name;
-          match load_cmt ~config:({config with ml_or_mli = `ML}) unit_name with
+          match
+            load_cmt ~config:({config with ml_or_mli = `ML})
+                     ~with_fallback:false unit_name
+          with
           | Ok (filename, cmt_infos) ->
             move_to filename cmt_infos;
             log ~title:"read_unit_shape" "shapes loaded for %s" unit_name;
@@ -562,7 +565,14 @@ let find_definition_uid ~config ~env ~(decl : Env_lookup.item) path =
   let keep_aliases =
     if config.traverse_aliases
     then (fun _ -> false)
-    else (fun _ -> true)
+    else (function
+    | Shape. { uid = Some (Item { comp_unit; _ });
+               desc = Alias { desc = Comp_unit alias_cu; _ };
+               _ }
+      when let by = comp_unit ^ "__" in
+        Merlin_utils.Std.String.is_prefixed ~by alias_cu ->
+      false
+    | _ -> true)
   in
   let reduced = Shape_reduce.reduce_for_uid
     ~keep_aliases env shape

From ac9a769e91588aa906dcfe81acb855ec94b59e5f Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Fri, 24 Nov 2023 16:32:52 +0100
Subject: [PATCH 30/58] Index: fix issue with constr / label paths

---
 src/analysis/occurrences.ml | 20 ++++++++++++++++++--
 1 file changed, 18 insertions(+), 2 deletions(-)

diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml
index d8f1d89a9b..03464152dc 100644
--- a/src/analysis/occurrences.ml
+++ b/src/analysis/occurrences.ml
@@ -3,6 +3,22 @@ module LidSet = Index_format.LidSet
 
 let {Logger. log} = Logger.for_section "occurrences"
 
+let decl_of_path_or_lid env namespace path lid =
+  match (namespace : Shape.Sig_component_kind.t) with
+  | Constructor ->
+    begin match Env.find_constructor_by_name lid env with
+    | exception Not_found -> None
+    | {cstr_uid; cstr_loc; _ } ->
+      Some { Env_lookup.uid = cstr_uid; loc = cstr_loc; namespace }
+    end
+  | Label ->
+    begin match Env.find_label_by_name lid env with
+    | exception Not_found -> None
+    | {lbl_uid; lbl_loc; _ } ->
+      Some { Env_lookup.uid = lbl_uid; loc = lbl_loc; namespace }
+    end
+  | _ -> Env_lookup.loc path namespace env
+
 let index_buffer ~local_defs () =
   let {Logger. log} = Logger.for_section "index" in
   let defs = Hashtbl.create 64 in
@@ -40,8 +56,8 @@ let index_buffer ~local_defs () =
         | Unresolved s ->
           log ~title:"index_buffer" "Could not resolve shape %a"
             Logger.fmt (Fun.flip Shape.print s);
-          begin match Env_lookup.loc path namespace env with
-          | None -> log ~title:"index_buffer" "Declaration not found"
+          begin match decl_of_path_or_lid env namespace path lid.txt with
+          | exception _ |  None -> log ~title:"index_buffer" "Declaration not found"
           | Some decl ->
             log ~title:"index_buffer" "Found the declaration: %a"
               Logger.fmt (Fun.flip Location.print_loc decl.loc);

From f029e1cf69300ccd7cbc49a66ea5fe092f6f02dc Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Fri, 24 Nov 2023 16:33:04 +0100
Subject: [PATCH 31/58] Add a test for constr / label not found issue

---
 tests/test-dirs/occurrences/constr-issue.t | 60 ++++++++++++++++++++++
 1 file changed, 60 insertions(+)
 create mode 100644 tests/test-dirs/occurrences/constr-issue.t

diff --git a/tests/test-dirs/occurrences/constr-issue.t b/tests/test-dirs/occurrences/constr-issue.t
new file mode 100644
index 0000000000..1ee83a1fd1
--- /dev/null
+++ b/tests/test-dirs/occurrences/constr-issue.t
@@ -0,0 +1,60 @@
+  $ cat >main.ml <main.ml <<'EOF'
+  > let f = function
+  >   | Unix.WEXITED n -> n
+  >   | _ -> 0
+  > EOF
+
+  $ $MERLIN single occurrences -identifier-at 2:17 -filename main.ml <main.ml | jq '.value'
+  [
+    {
+      "start": {
+        "line": 2,
+        "col": 17
+      },
+      "end": {
+        "line": 2,
+        "col": 18
+      }
+    },
+    {
+      "start": {
+        "line": 2,
+        "col": 22
+      },
+      "end": {
+        "line": 2,
+        "col": 23
+      }
+    }
+  ]
+
+  $ cat >main.ml <main.ml <<'EOF'
+  > let f = function
+  >   | { Unix.st_ino = n; _ } when true -> n
+  >   | { Unix.st_ino = n; _ } -> n
+  >   | _ -> 0
+  > EOF
+
+  $ $MERLIN single occurrences -identifier-at 2:14 -filename main.ml <main.ml | jq '.value'
+  [
+    {
+      "start": {
+        "line": 2,
+        "col": 11
+      },
+      "end": {
+        "line": 2,
+        "col": 17
+      }
+    },
+    {
+      "start": {
+        "line": 3,
+        "col": 11
+      },
+      "end": {
+        "line": 3,
+        "col": 17
+      }
+    }
+  ]

From 57d8b47f49b18ca265b082a1d55bdf6611d4d875 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Mon, 27 Nov 2023 19:14:48 +0100
Subject: [PATCH 32/58] test: show that uid counters are not restored correctly

---
 src/analysis/occurrences.ml                |  6 +++-
 tests/test-dirs/server-tests/stable-uids.t | 37 ++++++++++++++++++++++
 2 files changed, 42 insertions(+), 1 deletion(-)
 create mode 100644 tests/test-dirs/server-tests/stable-uids.t

diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml
index 03464152dc..e0deb05781 100644
--- a/src/analysis/occurrences.ml
+++ b/src/analysis/occurrences.ml
@@ -43,7 +43,7 @@ let index_buffer ~local_defs () =
         ~namespace:Shape.Sig_component_kind.Module env (Pident id)
     end)
   in
-  let f ~namespace env path lid  =
+  let f ~namespace env path (lid : Longident.t Location.loc)  =
     let not_ghost { Location.loc = { loc_ghost; _ }; _ } = not loc_ghost in
     if not_ghost lid then
       match Env.shape_of_path ~namespace env path with
@@ -52,6 +52,10 @@ let index_buffer ~local_defs () =
         begin match Shape_reduce.reduce_for_uid env path_shape with
         | Shape.Approximated _ | Missing_uid -> ()
         | Resolved uid ->
+          log ~title:"index_buffer" "Found %s (%a) wiht uid %a"
+            (Longident.head lid.txt)
+            Logger.fmt (Fun.flip Location.print_loc lid.loc)
+            Logger.fmt (Fun.flip Shape.Uid.print uid);
           Index_format.(add defs uid (LidSet.singleton lid))
         | Unresolved s ->
           log ~title:"index_buffer" "Could not resolve shape %a"
diff --git a/tests/test-dirs/server-tests/stable-uids.t b/tests/test-dirs/server-tests/stable-uids.t
new file mode 100644
index 0000000000..0255b3d790
--- /dev/null
+++ b/tests/test-dirs/server-tests/stable-uids.t
@@ -0,0 +1,37 @@
+  $ cat >main.ml <<'EOF'
+  > let x' = 1
+  > let x = 41
+  > let f x = x
+  > let y = f x
+  > EOF
+
+  $ $MERLIN server occurrences -scope local -identifier-at 3:10 \
+  > -log-file log_1 -log-section index \
+  > -filename main.ml <main.ml >/dev/null 
+
+  $ cat >main.ml <<'EOF'
+  > let x' = 1
+  > let x = 42
+  > let f x = x 
+  > let y = f x
+  > EOF
+
+  $ $MERLIN server occurrences -scope local -identifier-at 3:10 \
+  > -log-file log_2 -log-section index \
+  > -filename main.ml <main.ml >/dev/null
+
+FIXME: The uids should be the same on both queries !
+  $ cat log_1 | grep Found | cat >log_1g
+  $ cat log_2 | grep Found | cat >log_2g
+  $ diff log_1g log_2g
+  1,3c1,3
+  < Found x (File "main.ml", line 3, characters 10-11) wiht uid Main.3
+  < Found f (File "main.ml", line 4, characters 8-9) wiht uid Main.2
+  < Found x (File "main.ml", line 4, characters 10-11) wiht uid Main.1
+  ---
+  > Found x (File "main.ml", line 3, characters 10-11) wiht uid Main.7
+  > Found f (File "main.ml", line 4, characters 8-9) wiht uid Main.6
+  > Found x (File "main.ml", line 4, characters 10-11) wiht uid Main.5
+  [1]
+
+  $ $MERLIN server stop-server

From 93e971039b42f97ea008d2b36239eeebff99d13a Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Mon, 27 Nov 2023 19:16:06 +0100
Subject: [PATCH 33/58] Reset uid counter when restoring the typer's state

---
 src/kernel/mtyper.ml                       | 54 +++++++++++++++-------
 src/ocaml/typing/shape.ml                  |  5 +-
 src/ocaml/typing/shape.mli                 |  2 +
 tests/test-dirs/server-tests/stable-uids.t |  9 ----
 4 files changed, 43 insertions(+), 27 deletions(-)

diff --git a/src/kernel/mtyper.ml b/src/kernel/mtyper.ml
index 034cb10c7d..2bcbc2b306 100644
--- a/src/kernel/mtyper.ml
+++ b/src/kernel/mtyper.ml
@@ -8,6 +8,7 @@ type ('p,'t) item = {
   typedtree_items: 't list * Types.signature_item list;
   part_snapshot  : Types.snapshot;
   part_stamp     : int;
+  part_uid       : int;
   part_env       : Env.t;
   part_errors    : exn list;
   part_checks    : Typecore.delayed_check list;
@@ -28,15 +29,16 @@ let fresh_env config =
   let env0 = Extension.register Mconfig.(config.merlin.extensions) env0 in
   let snap0 = Btype.snapshot () in
   let stamp0 = Ident.get_currentstamp () in
-  (env0, snap0, stamp0)
+  let uid0 = Shape.Uid.get_current_stamp () in
+  (env0, snap0, stamp0, uid0)
 
 let get_cache config =
   match !cache with
-  | Some (env0, snap0, stamp0, items, _) when Types.is_valid snap0 ->
-    env0, snap0, stamp0, Some items
+  | Some (env0, snap0, stamp0, uid0, items, _) when Types.is_valid snap0 ->
+    env0, snap0, stamp0, uid0, Some items
   | Some _ | None ->
-    let env0, snap0, stamp0 = fresh_env config in
-    env0, snap0, stamp0, None
+    let env0, snap0, stamp0, uid0 = fresh_env config in
+    env0, snap0, stamp0, uid0, None
 
 let return_and_cache status =
   cache := Some status;
@@ -47,6 +49,7 @@ type result = {
   initial_env : Env.t;
   initial_snapshot : Types.snapshot;
   initial_stamp : int;
+  initial_uid : int;
   typedtree : [
     | `Interface of
         (Parsetree.signature_item, Typedtree.signature_item) item list
@@ -87,6 +90,7 @@ let rec type_structure caught env = function
       parsetree_item; typedtree_items; part_env;
       part_snapshot = Btype.snapshot ();
       part_stamp    = Ident.get_currentstamp ();
+      part_uid      = Shape.Uid.get_current_stamp ();
       part_errors   = !caught;
       part_checks   = !Typecore.delayed_checks;
       part_warnings = Warnings.backup ();
@@ -102,6 +106,7 @@ let rec type_signature caught env = function
       parsetree_item; typedtree_items = (sig_items, sig_type); part_env;
       part_snapshot = Btype.snapshot ();
       part_stamp    = Ident.get_currentstamp ();
+      part_uid      = Shape.Uid.get_current_stamp ();
       part_errors   = !caught;
       part_checks   = !Typecore.delayed_checks;
       part_warnings = Warnings.backup ();
@@ -110,46 +115,50 @@ let rec type_signature caught env = function
   | [] -> []
 
 let type_implementation config caught parsetree =
-  let env0, snap0, stamp0, prefix = get_cache config in
+  let env0, snap0, stamp0, uid0, prefix = get_cache config in
   let prefix, parsetree, cache_stat =
     match prefix with
     | Some (`Implementation items) -> compatible_prefix items parsetree
     | Some (`Interface _) | None -> ([], parsetree, Miss)
   in
-  let env', snap', stamp', warn' = match prefix with
-    | [] -> (env0, snap0, stamp0, Warnings.backup ())
+  let env', snap', stamp', uid', warn' = match prefix with
+    | [] -> (env0, snap0, stamp0, uid0, Warnings.backup ())
     | x :: _ ->
       caught := x.part_errors;
       Typecore.delayed_checks := x.part_checks;
-      (x.part_env, x.part_snapshot, x.part_stamp, x.part_warnings)
+      (x.part_env, x.part_snapshot, x.part_stamp, x.part_uid, x.part_warnings)
   in
   Btype.backtrack snap';
   Warnings.restore warn';
   Env.cleanup_functor_caches ~stamp:stamp';
+  Shape.Uid.restore_stamp uid';
   let suffix = type_structure caught env' parsetree in
   return_and_cache
-    (env0, snap0, stamp0, `Implementation (List.rev_append prefix suffix), cache_stat)
+    (env0, snap0, stamp0, uid0, `Implementation (List.rev_append prefix suffix),
+     cache_stat)
 
 let type_interface config caught parsetree =
-  let env0, snap0, stamp0, prefix = get_cache config in
+  let env0, snap0, stamp0, uid0, prefix = get_cache config in
   let prefix, parsetree, cache_stat =
     match prefix with
     | Some (`Interface items) -> compatible_prefix items parsetree
     | Some (`Implementation _) | None -> ([], parsetree, Miss)
   in
-  let env', snap', stamp', warn' = match prefix with
-    | [] -> (env0, snap0, stamp0, Warnings.backup ())
+  let env', snap', stamp', uid', warn' = match prefix with
+    | [] -> (env0, snap0, stamp0, uid0, Warnings.backup ())
     | x :: _ ->
       caught := x.part_errors;
       Typecore.delayed_checks := x.part_checks;
-      (x.part_env, x.part_snapshot, x.part_stamp, x.part_warnings)
+      (x.part_env, x.part_snapshot, x.part_stamp, x.part_uid, x.part_warnings)
   in
   Btype.backtrack snap';
   Warnings.restore warn';
   Env.cleanup_functor_caches ~stamp:stamp';
+  Shape.Uid.restore_stamp uid';
   let suffix = type_signature caught env' parsetree in
   return_and_cache
-    (env0, snap0, stamp0, `Interface (List.rev_append prefix suffix), cache_stat)
+    (env0, snap0, stamp0, uid0, `Interface (List.rev_append prefix suffix),
+     cache_stat)
 
 let run config parsetree =
   if not (Env.check_state_consistency ()) then (
@@ -164,12 +173,23 @@ let run config parsetree =
   let caught = ref [] in
   Msupport.catch_errors Mconfig.(config.ocaml.warnings) caught @@ fun () ->
   Typecore.reset_delayed_checks ();
-  let initial_env, initial_snapshot, initial_stamp, typedtree, cache_stat = match parsetree with
+  let
+    initial_env, initial_snapshot, initial_stamp, initial_uid, typedtree, cache_stat
+  =
+    match parsetree with
     | `Implementation parsetree -> type_implementation config caught parsetree
     | `Interface parsetree -> type_interface config caught parsetree
   in
   Typecore.reset_delayed_checks ();
-  { config; initial_env; initial_snapshot; initial_stamp; typedtree; cache_stat }
+  {
+    config;
+    initial_env;
+    initial_snapshot;
+    initial_uid;
+    initial_stamp;
+    typedtree;
+    cache_stat;
+  }
 
 let get_env ?pos:_ t =
   Option.value ~default:t.initial_env (
diff --git a/src/ocaml/typing/shape.ml b/src/ocaml/typing/shape.ml
index 0307eb2b1b..d3f85e971c 100644
--- a/src/ocaml/typing/shape.ml
+++ b/src/ocaml/typing/shape.ml
@@ -38,10 +38,13 @@ module Uid = struct
       print fmt t
   end)
 
-  let id = ref (-1)
+  let id = Local_store.s_ref (-1)
 
   let reinit () = id := (-1)
 
+  let get_current_stamp () = !id
+  let restore_stamp i = id := i
+
   let mk  ~current_unit =
       incr id;
       Item { comp_unit = current_unit; id = !id }
diff --git a/src/ocaml/typing/shape.mli b/src/ocaml/typing/shape.mli
index 18cd20331a..45e98170f9 100644
--- a/src/ocaml/typing/shape.mli
+++ b/src/ocaml/typing/shape.mli
@@ -57,6 +57,8 @@ module Uid : sig
     | Predef of string
 
   val reinit : unit -> unit
+  val get_current_stamp : unit -> int
+  val restore_stamp : int -> unit
 
   val mk : current_unit:string -> t
   val of_compilation_unit_id : Ident.t -> t
diff --git a/tests/test-dirs/server-tests/stable-uids.t b/tests/test-dirs/server-tests/stable-uids.t
index 0255b3d790..bd767563f6 100644
--- a/tests/test-dirs/server-tests/stable-uids.t
+++ b/tests/test-dirs/server-tests/stable-uids.t
@@ -24,14 +24,5 @@ FIXME: The uids should be the same on both queries !
   $ cat log_1 | grep Found | cat >log_1g
   $ cat log_2 | grep Found | cat >log_2g
   $ diff log_1g log_2g
-  1,3c1,3
-  < Found x (File "main.ml", line 3, characters 10-11) wiht uid Main.3
-  < Found f (File "main.ml", line 4, characters 8-9) wiht uid Main.2
-  < Found x (File "main.ml", line 4, characters 10-11) wiht uid Main.1
-  ---
-  > Found x (File "main.ml", line 3, characters 10-11) wiht uid Main.7
-  > Found f (File "main.ml", line 4, characters 8-9) wiht uid Main.6
-  > Found x (File "main.ml", line 4, characters 10-11) wiht uid Main.5
-  [1]
 
   $ $MERLIN server stop-server

From a99ff3ca81b44bd86d33652b92adba42ce83277b Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Wed, 29 Nov 2023 11:52:04 +0100
Subject: [PATCH 34/58] Create mli for index format and add stats

---
 src/analysis/index_format.ml  |  5 ++++-
 src/analysis/index_format.mli | 30 ++++++++++++++++++++++++++++++
 2 files changed, 34 insertions(+), 1 deletion(-)
 create mode 100644 src/analysis/index_format.mli

diff --git a/src/analysis/index_format.ml b/src/analysis/index_format.ml
index 643289db5b..b63a0e857d 100644
--- a/src/analysis/index_format.ml
+++ b/src/analysis/index_format.ml
@@ -18,6 +18,8 @@ end
 
 module LidSet = Set.Make (Lid)
 
+module Stats = Map.Make (String)
+
 (** [add tbl uid locs] adds a binding of [uid] to the locations [locs]. If this key is
     already present the locations are merged. *)
 let add tbl uid locs =
@@ -31,6 +33,7 @@ type index = {
   approximated : (Shape.Uid.t, LidSet.t) Hashtbl.t;
   load_path : string list;
   cu_shape : (string, Shape.t) Hashtbl.t;
+  stats : float Stats.t;
 }
 
 let pp_partials (fmt : Format.formatter)
@@ -71,7 +74,7 @@ let pp (fmt : Format.formatter) pl =
   Format.fprintf fmt "and shapes for CUS %s.@ "
     (String.concat ";@," (Hashtbl.to_seq_keys pl.cu_shape |> List.of_seq))
 
-let ext = "uideps"
+let ext = "ocaml-index"
 
 (* [magic_number] Must be the same lenght as cmt's magic numbers *)
 let magic_number = "Merl2023I001"
diff --git a/src/analysis/index_format.mli b/src/analysis/index_format.mli
new file mode 100644
index 0000000000..ac440cb85c
--- /dev/null
+++ b/src/analysis/index_format.mli
@@ -0,0 +1,30 @@
+exception Not_an_index of string
+
+module Lid : Set.OrderedType with type t = Longident.t Location.loc
+module LidSet : Set.S with type elt = Longident.t Location.loc
+
+val add : ('a, LidSet.t) Hashtbl.t -> 'a -> LidSet.t -> unit
+
+module Stats : Map.S with type key = String.t
+
+type index = {
+  defs : (Shape.Uid.t, LidSet.t) Hashtbl.t;
+  approximated : (Shape.Uid.t, LidSet.t) Hashtbl.t;
+  load_path : string list;
+  cu_shape : (string, Shape.t) Hashtbl.t;
+  stats : float Stats.t;
+}
+
+type file_content = Cmt of Cmt_format.cmt_infos | Index of index | Unknown
+
+val pp : Format.formatter -> index -> unit
+
+val ext : string
+val magic_number : string
+
+val write : file:string -> index -> unit
+val read : file:string -> file_content
+
+(** [read_exn] raises [Not_an_index] if the file does not have the correct magic
+  nulmber. *)
+val read_exn : file:string -> index

From 372cc6b43f9cd936d879891df5bc036ad427ba66 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Wed, 29 Nov 2023 12:16:09 +0100
Subject: [PATCH 35/58] Improve location sort function

---
 src/analysis/index_format.ml | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/src/analysis/index_format.ml b/src/analysis/index_format.ml
index b63a0e857d..ce108c9155 100644
--- a/src/analysis/index_format.ml
+++ b/src/analysis/index_format.ml
@@ -5,7 +5,8 @@ module Lid : Set.OrderedType with type t = Longident.t Location.loc = struct
   type t = Longident.t Location.loc
 
   let compare_pos (p1 : Lexing.position) (p2 : Lexing.position) =
-    match String.compare p1.pos_fname p2.pos_fname with
+    let p1f, p2f = Filename.(basename p1.pos_fname, basename p2.pos_fname) in
+    match String.compare p1f p2f with
     | 0 -> Int.compare p1.pos_cnum p2.pos_cnum
     | n -> n
 

From 12220ca59bdf586992484dbcb98526e4c15e0a82 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Wed, 29 Nov 2023 18:43:28 +0100
Subject: [PATCH 36/58] Do not use external index if it might be out-of-sync

---
 src/analysis/occurrences.ml                   | 58 ++++++++++++++-----
 .../occurrences/project-wide/simple.t         | 33 ++++++++++-
 2 files changed, 76 insertions(+), 15 deletions(-)

diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml
index e0deb05781..20066b8a4a 100644
--- a/src/analysis/occurrences.ml
+++ b/src/analysis/occurrences.ml
@@ -131,6 +131,19 @@ let comp_unit_of_uid = function
   | Item { comp_unit; _ } -> Some comp_unit
   | Internal | Predef _ -> None
 
+let check Index_format.{ stats; _ } file =
+  let open Index_format in
+  match Stats.find_opt file stats with
+  | None -> log ~title:"stat_check" "No mtime found for file %S." file; true
+  | Some mtime ->
+    try
+      let equal = Float.equal (Unix.stat file).st_mtime mtime in
+      log ~title:"stat_check"
+        "File %s has been modified since the index was built." file;
+      equal
+    with Unix.Unix_error _ -> false
+
+
 let locs_of ~config ~scope ~env ~local_defs ~pos ~node:_ path =
   log ~title:"occurrences" "Looking for occurences of %s (pos: %s)"
     path
@@ -172,18 +185,38 @@ let locs_of ~config ~scope ~env ~local_defs ~pos ~node:_ path =
       Logger.fmt (fun fmt -> Shape.Uid.print fmt def_uid)
       Logger.fmt (fun fmt -> Location.print_loc fmt def_loc);
     log ~title:"locs_of" "Indexing current buffer";
-    let index = index_buffer ~local_defs () in
-    if scope = `Project then begin
-      match config.merlin.index_file with
-      | None -> log ~title:"locs_of" "No external index specified"
-      | Some file ->
-        log ~title:"locs_of" "Using external index: %S" file;
-        let external_uideps = Index_format.read_exn ~file in
-        merge_tbl ~into:index external_uideps.defs
-    end;
-    (* TODO ignore externally indexed locs from the current buffer *)
-    let locs = match Hashtbl.find_opt index def_uid with
-      | Some locs ->
+    let buffer_index = index_buffer ~local_defs () in
+    let buffer_locs = Hashtbl.find_opt buffer_index def_uid in
+    let external_locs, desync =
+      if scope = `Buffer then None, false else begin
+      let exception File_changed in
+      let open Option.Infix in
+      try
+        let locs = config.merlin.index_file  >>= fun file ->
+          let external_index = Index_format.read_exn ~file in
+          Hashtbl.find_opt external_index.defs def_uid
+          >>| fun locs -> LidSet.filter (fun {loc; _} ->
+            (* We ignore external results that concern the current buffer *)
+            let fname = loc.Location.loc_start.Lexing.pos_fname in
+            (* We ignore external results if the index is not up-to-date *)
+            (* We could return partial results from up-to-date file *)
+            if String.equal fname current_buffer_path then false
+            else begin
+              if not (check external_index fname) then raise File_changed;
+              true
+            end) locs
+          in
+          locs, false
+      with File_changed -> None, true
+      end
+    in
+    if desync then log ~title:"locs_of" "External index might be out-of-sync.";
+    let locs = match buffer_locs, external_locs with
+      | None, None -> LidSet.empty
+      | Some locs, None | None, Some locs -> locs
+      | Some b_locs, Some e_locs -> LidSet.union b_locs e_locs
+    in
+    let locs =
         log ~title:"occurrences" "Found %i locs" (LidSet.cardinal locs);
         LidSet.elements locs
         |> List.filter_map ~f:(fun {Location.txt; loc} ->
@@ -204,7 +237,6 @@ let locs_of ~config ~scope ~env ~local_defs ~pos ~node:_ path =
               None
             | _ -> None
           end else Some loc)
-      | None -> log ~title:"locs_of" "No locs found in index."; []
     in
     (* We only prepend the loc of the definition for the current buffer *)
     let uid_in_current_unit =
diff --git a/tests/test-dirs/occurrences/project-wide/simple.t b/tests/test-dirs/occurrences/project-wide/simple.t
index c212c89d84..9cc03f11f9 100644
--- a/tests/test-dirs/occurrences/project-wide/simple.t
+++ b/tests/test-dirs/occurrences/project-wide/simple.t
@@ -38,9 +38,9 @@
    uid: Stdlib.313; locs:
      "print_int": File "$TESTCASE_ROOT/exe/main.ml", line 1, characters 0-9
    uid: Lib.0; locs:
-     "Lib.x": File "$TESTCASE_ROOT/exe/main.ml", line 1, characters 10-15;
      "x": File "$TESTCASE_ROOT/lib/lib.ml", line 1, characters 4-5;
-     "x": File "$TESTCASE_ROOT/lib/lib.ml", line 2, characters 8-9
+     "x": File "$TESTCASE_ROOT/lib/lib.ml", line 2, characters 8-9;
+     "Lib.x": File "$TESTCASE_ROOT/exe/main.ml", line 1, characters 10-15
    }, 0 approx shapes: {}, and shapes for CUS .
 
 Occurrences of Lib.x
@@ -85,3 +85,32 @@ Occurrences of Lib.x
     ],
     "notifications": []
   }
+
+
+  $ sleep 1 # Make sure that the time will change
+  $ touch lib/lib.ml
+
+  $ $MERLIN single occurrences -scope project -identifier-at 1:15 \
+  > -log-file log -log-section occurrences \
+  > -filename exe/main.ml <exe/main.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "file": "$TESTCASE_ROOT/exe/main.ml",
+        "start": {
+          "line": 1,
+          "col": 14
+        },
+        "end": {
+          "line": 1,
+          "col": 15
+        }
+      }
+    ],
+    "notifications": []
+  }
+
+  $ cat log | grep index
+  File $TESTCASE_ROOT/lib/lib.ml has been modified since the index was built.
+  External index might be out-of-sync.

From 91898bddaa65f94b7b3b5e1cf2c37a17f277132a Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Wed, 29 Nov 2023 18:44:09 +0100
Subject: [PATCH 37/58] Remove todo

---
 src/analysis/index_format.ml | 1 -
 1 file changed, 1 deletion(-)

diff --git a/src/analysis/index_format.ml b/src/analysis/index_format.ml
index ce108c9155..be47991df0 100644
--- a/src/analysis/index_format.ml
+++ b/src/analysis/index_format.ml
@@ -11,7 +11,6 @@ module Lid : Set.OrderedType with type t = Longident.t Location.loc = struct
     | n -> n
 
   let compare (t1 : t) (t2 : t) =
-    (* TODO CHECK...*)
     match compare_pos t1.loc.loc_start t2.loc.loc_start with
     | 0 -> compare_pos t1.loc.loc_end t2.loc.loc_end
     | n -> n

From 00163b329d4c3411cd1296905df0405b64402887 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Wed, 29 Nov 2023 18:56:07 +0100
Subject: [PATCH 38/58] wip: forward desync information

---
 src/analysis/occurrences.ml            | 8 ++++----
 src/frontend/ocamlmerlin/query_json.ml | 2 +-
 src/frontend/query_commands.ml         | 6 +++---
 src/frontend/query_protocol.ml         | 2 +-
 4 files changed, 9 insertions(+), 9 deletions(-)

diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml
index 20066b8a4a..d89082d43b 100644
--- a/src/analysis/occurrences.ml
+++ b/src/analysis/occurrences.ml
@@ -239,14 +239,14 @@ let locs_of ~config ~scope ~env ~local_defs ~pos ~node:_ path =
           end else Some loc)
     in
     (* We only prepend the loc of the definition for the current buffer *)
-    let uid_in_current_unit =
+    let def_uid_is_in_current_unit =
       let uid_comp_unit = comp_unit_of_uid def_uid in
       Option.value_map ~default:false uid_comp_unit
         ~f:(String.equal @@ Env.get_unit_name ())
     in
-    if uid_in_current_unit then
+    if def_uid_is_in_current_unit then
       let def_loc = {def_loc with
         loc_start = {def_loc.loc_start with pos_fname = current_buffer_path }} in
-      Ok (def_loc::locs)
-      else Ok locs
+      Ok ((def_loc::locs), desync)
+      else Ok (locs, desync)
   | None -> Error "nouid"
diff --git a/src/frontend/ocamlmerlin/query_json.ml b/src/frontend/ocamlmerlin/query_json.ml
index 3332370642..3b97d1f6df 100644
--- a/src/frontend/ocamlmerlin/query_json.ml
+++ b/src/frontend/ocamlmerlin/query_json.ml
@@ -422,7 +422,7 @@ let json_of_response (type a) (query : a t) (response : a) : json =
   | Findlib_list, strs -> `List (List.map ~f:Json.string strs)
   | Extension_list _, strs -> `List (List.map ~f:Json.string strs)
   | Path_list _, strs -> `List (List.map ~f:Json.string strs)
-  | Occurrences (_, scope), locations ->
+  | Occurrences (_, scope), (locations, _desync) ->
     let with_file = scope = `Project in
     `List (List.map locations
              ~f:(fun loc -> with_location ~with_file loc []))
diff --git a/src/frontend/query_commands.ml b/src/frontend/query_commands.ml
index fb8873714f..91d0dae284 100644
--- a/src/frontend/query_commands.ml
+++ b/src/frontend/query_commands.ml
@@ -809,13 +809,13 @@ let dispatch pipeline (type a) : a Query_protocol.t -> a =
       Locate.log ~title:"reconstructed identifier" "%s" path;
       path
     in
-    let locs =
+    let locs, desync =
       Occurrences.locs_of ~config ~scope ~env ~local_defs ~node ~pos path
-      |> Result.value ~default:[]
+      |> Result.value ~default:([], false)
     in
     let loc_start l = l.Location.loc_start in
     let cmp l1 l2 = Lexing.compare_pos (loc_start l1) (loc_start l2) in
-    List.sort ~cmp locs
+    (List.sort ~cmp locs), desync
 
   | Version ->
     Printf.sprintf "The Merlin toolkit version %s, for Ocaml %s\n"
diff --git a/src/frontend/query_protocol.ml b/src/frontend/query_protocol.ml
index 38552f486f..ad2296f840 100644
--- a/src/frontend/query_protocol.ml
+++ b/src/frontend/query_protocol.ml
@@ -195,6 +195,6 @@ type _ t =
     -> string list t
   | Occurrences(* *)
     : [`Ident_at of Msource.position] * [`Project | `Buffer]
-    -> Location.t list t
+    -> (Location.t list * bool) t
   | Version
     : string t

From 1e8badbe34861793996f292ef2d583b5c7c44ecc Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Tue, 19 Dec 2023 15:29:40 +0100
Subject: [PATCH 39/58] Pull latest changes from upstream

4.14.2+index
---
 upstream/ocaml_414/base-rev.txt               |   2 +-
 upstream/ocaml_414/file_formats/cmt_format.ml | 176 +++------
 .../ocaml_414/file_formats/cmt_format.mli     |  17 +-
 upstream/ocaml_414/typing/shape.ml            | 323 +---------------
 upstream/ocaml_414/typing/shape.mli           |  54 +--
 upstream/ocaml_414/typing/shape_reduce.ml     | 350 ++++++++++++++++++
 upstream/ocaml_414/typing/shape_reduce.mli    |  57 +++
 upstream/ocaml_414/typing/tast_iterator.ml    |  42 ++-
 upstream/ocaml_414/typing/tast_iterator.mli   |   1 +
 upstream/ocaml_414/typing/typeclass.ml        |   2 +-
 upstream/ocaml_414/typing/typedecl.ml         |  11 +-
 upstream/ocaml_414/typing/typedtree.ml        |  21 +-
 upstream/ocaml_414/typing/typedtree.mli       |  18 +-
 upstream/ocaml_414/typing/typemod.ml          |  33 +-
 upstream/ocaml_414/utils/clflags.ml           |   2 +-
 upstream/ocaml_414/utils/clflags.mli          |   2 +-
 16 files changed, 569 insertions(+), 542 deletions(-)
 create mode 100644 upstream/ocaml_414/typing/shape_reduce.ml
 create mode 100644 upstream/ocaml_414/typing/shape_reduce.mli

diff --git a/upstream/ocaml_414/base-rev.txt b/upstream/ocaml_414/base-rev.txt
index 40609893af..705276ab3b 100644
--- a/upstream/ocaml_414/base-rev.txt
+++ b/upstream/ocaml_414/base-rev.txt
@@ -1 +1 @@
-407fdf73d15aaea435af38400f115717194874c1
+d118cdf64b1e4be9e8f5969f485f43c7bc675352
diff --git a/upstream/ocaml_414/file_formats/cmt_format.ml b/upstream/ocaml_414/file_formats/cmt_format.ml
index 88b1d26b23..9927f7abd9 100644
--- a/upstream/ocaml_414/file_formats/cmt_format.ml
+++ b/upstream/ocaml_414/file_formats/cmt_format.ml
@@ -45,21 +45,6 @@ and binary_part =
   | Partial_signature_item of signature_item
   | Partial_module_type of module_type
 
-type item_declaration =
-  | Class_declaration of class_declaration
-  | Class_description of class_description
-  | Class_type_declaration of class_type_declaration
-  | Constructor_declaration of constructor_declaration
-  | Extension_constructor of extension_constructor
-  | Label_declaration of label_declaration
-  | Module_binding of module_binding
-  | Module_declaration of module_declaration
-  | Module_substitution of module_substitution
-  | Module_type_declaration of module_type_declaration
-  | Type_declaration of type_declaration
-  | Value_binding of value_binding
-  | Value_description of value_description
-
 type cmt_infos = {
   cmt_modname : string;
   cmt_annots : binary_annots;
@@ -78,7 +63,7 @@ type cmt_infos = {
   cmt_uid_to_decl : item_declaration Shape.Uid.Tbl.t;
   cmt_impl_shape : Shape.t option; (* None for mli *)
   cmt_ident_occurrences :
-    (Longident.t Location.loc * Shape.reduction_result) list
+    (Longident.t Location.loc * Shape_reduce.result) list
 }
 
 type error =
@@ -101,89 +86,28 @@ let iter_on_annots (it : Tast_iterator.iterator) = function
   | Partial_implementation array -> Array.iter (iter_on_parts it) array
   | Partial_interface array -> Array.iter (iter_on_parts it) array
 
-module Local_reduce = Shape.Make_reduce(struct
-    type env = Env.t
-    let fuel = 10
-
-    let read_unit_shape ~unit_name:_ = None
-
-    let find_shape env id =
-      let namespace = Shape.Sig_component_kind.Module in
-      Env.shape_of_path ~namespace env (Pident id)
-  end)
-
-let iter_on_declarations ~(f: Shape.Uid.t -> item_declaration -> unit) =
-  let f_lbl_decls ldecls =
-    List.iter (fun ({ ld_uid; _ } as ld) ->
-      f ld_uid (Label_declaration ld)) ldecls
-  in
-  Tast_iterator.{ default_iterator with
-
-  value_bindings = (fun sub ((_, vbs) as bindings) ->
-    let bound_idents = let_filter_bound vbs in
-    List.iter (fun (vb, uid) -> f uid (Value_binding vb)) bound_idents;
-    default_iterator.value_bindings sub bindings);
-
-  module_binding = (fun sub mb ->
-    f mb.mb_uid (Module_binding mb);
-    default_iterator.module_binding sub mb);
-
-  module_declaration = (fun sub md ->
-    f md.md_uid (Module_declaration md);
-    default_iterator.module_declaration sub md);
-
-  module_type_declaration = (fun sub mtd ->
-    f mtd.mtd_uid (Module_type_declaration mtd);
-    default_iterator.module_type_declaration sub mtd);
-
-  module_substitution = (fun sub ms ->
-    f ms.ms_uid (Module_substitution ms);
-    default_iterator.module_substitution sub ms);
-
-  value_description = (fun sub vd ->
-    f vd.val_val.val_uid (Value_description vd);
-    default_iterator.value_description sub vd);
-
-  type_declaration = (fun sub td ->
-    (* compiler-generated "row_names" share the uid of their corresponding
-       class declaration, so we ignore them to prevent duplication *)
-    if not (Btype.is_row_name (Ident.name td.typ_id)) then begin
-      f td.typ_type.type_uid (Type_declaration td);
-      (* We also register records labels and constructors *)
-      let f_lbl_decls ldecls =
-        List.iter (fun ({ ld_uid; _ } as ld) ->
-          f ld_uid (Label_declaration ld)) ldecls
-      in
-      match td.typ_kind with
-      | Ttype_variant constrs ->
-          List.iter (fun ({ cd_uid; cd_args; _ } as cd) ->
-            f cd_uid (Constructor_declaration cd);
-            match cd_args with
-            | Cstr_record ldecls -> f_lbl_decls ldecls
-            | Cstr_tuple _ -> ()) constrs
-      | Ttype_record labels -> f_lbl_decls labels
-      | _ -> ()
-    end;
-    default_iterator.type_declaration sub td);
-
-  extension_constructor = (fun sub ec ->
-    f ec.ext_type.ext_uid (Extension_constructor ec);
-    begin match ec.ext_kind with
-    | Text_decl (_, Cstr_record lbls,_) -> f_lbl_decls lbls
-    | _ -> () end;
-    default_iterator.extension_constructor sub ec);
-
-  class_declaration = (fun sub cd ->
-    f cd.ci_decl.cty_uid (Class_declaration cd);
-    default_iterator.class_declaration sub cd);
-
-  class_type_declaration = (fun sub ctd ->
-    f ctd.ci_decl.cty_uid (Class_type_declaration ctd);
-    default_iterator.class_type_declaration sub ctd);
-
-  class_description =(fun sub cd ->
-    f cd.ci_decl.cty_uid (Class_description cd);
-    default_iterator.class_description sub cd);
+let iter_on_declaration f decl =
+  match decl with
+  | Value vd -> f vd.val_val.val_uid decl;
+  | Value_binding vb ->
+      let bound_idents = let_bound_idents_full [vb] in
+      List.iter (fun (_, _, _, uid) -> f uid decl) bound_idents
+  | Type td ->
+      if not (Btype.is_row_name (Ident.name td.typ_id)) then
+        f td.typ_type.type_uid (Type td)
+  | Constructor cd -> f cd.cd_uid decl
+  | Extension_constructor ec -> f ec.ext_type.ext_uid decl;
+  | Label ld -> f ld.ld_uid decl
+  | Module md -> f md.md_uid decl
+  | Module_type mtd -> f mtd.mtd_uid decl
+  | Module_substitution ms -> f ms.ms_uid decl
+  | Module_binding mb -> f mb.mb_uid decl
+  | Class cd -> f cd.ci_decl.cty_uid decl
+  | Class_type ct -> f ct.ci_decl.cty_uid decl
+
+let iter_on_declarations ~(f: Shape.Uid.t -> item_declaration -> unit) = {
+  Tast_iterator.default_iterator with
+  item_declaration = (fun _sub decl -> iter_on_declaration f decl);
 }
 
 let need_to_clear_env =
@@ -220,16 +144,12 @@ let clear_env binary_annots =
 
   else binary_annots
 
-let iter_on_usages ~index =
-  let f ~namespace env path lid =
-    let not_ghost { Location.loc = { loc_ghost; _ }; _ } = not loc_ghost in
-    if not_ghost lid then
-      match Env.shape_of_path ~namespace env path with
-      | exception Not_found -> ()
-      | path_shape ->
-        let result = Local_reduce.reduce_for_uid env path_shape in
-        index := (lid, result) :: !index
-  in
+(* Every typedtree node with a located longident corresponding to user-facing
+   syntax should be indexed. *)
+let iter_on_occurrences
+  ~(f : namespace:Shape.Sig_component_kind.t ->
+        Env.t -> Path.t -> Longident.t Location.loc ->
+        unit) =
   let path_in_type typ name =
     match Types.get_desc typ with
     | Tconstr (type_path, _, _) ->
@@ -240,7 +160,6 @@ let iter_on_usages ~index =
     function
     | { Types.cstr_tag = Cstr_extension (path, _); _ } ->
         f ~namespace:Extension_constructor env path lid
-    | { Types.cstr_uid = Predef _; _ } -> ()
     | { Types.cstr_res; cstr_name; _ } ->
         let path = path_in_type cstr_res cstr_name in
         Option.iter (fun path -> f ~namespace:Constructor env path lid) path
@@ -283,6 +202,12 @@ let iter_on_usages ~index =
             add_label exp_env lid label_descr
           | Overridden (lid, _) -> add_label exp_env lid label_descr
           | Kept _ -> ()) fields
+      | Texp_instvar  (_self_path, path, name) ->
+          let lid = { name with txt = Longident.Lident name.txt } in
+          f ~namespace:Value exp_env path lid
+      | Texp_setinstvar  (_self_path, path, name, _) ->
+          let lid = { name with txt = Longident.Lident name.txt } in
+          f ~namespace:Value exp_env path lid
       | _ -> ());
       default_iterator.expr sub e);
 
@@ -293,7 +218,10 @@ let iter_on_usages ~index =
           f ~namespace:Type ctyp_env path lid
       | Ttyp_package {pack_path; pack_txt} ->
           f ~namespace:Module_type ctyp_env pack_path pack_txt
-      | _ -> ());
+      | Ttyp_class (path, lid, _typs) ->
+          (* Deprecated syntax to extend a polymorphic variant *)
+          f ~namespace:Type ctyp_env path lid
+      |  _ -> ());
       default_iterator.typ sub ct);
 
   pat =
@@ -323,7 +251,7 @@ let iter_on_usages ~index =
             f ~namespace:Module pat_env path lid
         | Tpat_type (path, lid) ->
             f ~namespace:Type pat_env path lid
-        | _ -> ())
+        | Tpat_constraint _ | Tpat_unpack -> ())
         pat_extra;
       default_iterator.pat sub pat);
 
@@ -360,7 +288,7 @@ let iter_on_usages ~index =
     (fun sub ({ cl_desc; cl_env; _} as ce) ->
       (match cl_desc with
       | Tcl_ident (path, lid, _) -> f ~namespace:Class cl_env path lid
-      | _ -> ());
+      |  _ -> ());
       default_iterator.class_expr sub ce);
 
   class_type =
@@ -391,7 +319,7 @@ let iter_on_usages ~index =
           f ~namespace:Extension_constructor str_env path lid
       | Tstr_typext { tyext_path; tyext_txt } ->
           f ~namespace:Type str_env tyext_path tyext_txt
-      | _ -> ());
+      |  _ -> ());
       default_iterator.structure_item sub str_item)
 }
 
@@ -401,11 +329,21 @@ let index_declarations binary_annots =
   iter_on_annots (iter_on_declarations ~f) binary_annots;
   index
 
-let index_usages binary_annots =
-  let index : (Longident.t Location.loc * Shape.reduction_result) list ref =
+let index_occurrences binary_annots =
+  let index : (Longident.t Location.loc * Shape_reduce.result) list ref =
     ref []
   in
-  iter_on_annots (iter_on_usages ~index) binary_annots;
+  let f ~namespace env path lid =
+    let not_ghost { Location.loc = { loc_ghost; _ }; _ } = not loc_ghost in
+    if not_ghost lid then
+      match Env.shape_of_path ~namespace env path with
+      | exception Not_found -> ()
+      | { uid = Some (Predef _); _ } -> ()
+      | path_shape ->
+        let result = Shape_reduce.local_reduce_for_uid env path_shape in
+        index := (lid, result) :: !index
+  in
+  iter_on_annots (iter_on_occurrences ~f) binary_annots;
   !index
 
 exception Error of error
@@ -480,8 +418,8 @@ let save_cmt filename modname binary_annots sourcefile initial_env cmi shape =
            | Some cmi -> Some (output_cmi temp_file_name oc cmi)
          in
          let cmt_ident_occurrences =
-          if !Clflags.store_usage_index then
-            index_usages binary_annots
+          if !Clflags.store_occurrences then
+            index_occurrences binary_annots
           else
             []
          in
diff --git a/upstream/ocaml_414/file_formats/cmt_format.mli b/upstream/ocaml_414/file_formats/cmt_format.mli
index 653dfcc75c..e2dd81a49d 100644
--- a/upstream/ocaml_414/file_formats/cmt_format.mli
+++ b/upstream/ocaml_414/file_formats/cmt_format.mli
@@ -50,21 +50,6 @@ and binary_part =
   | Partial_signature_item of signature_item
   | Partial_module_type of module_type
 
-type item_declaration =
-  | Class_declaration of class_declaration
-  | Class_description of class_description
-  | Class_type_declaration of class_type_declaration
-  | Constructor_declaration of constructor_declaration
-  | Extension_constructor of extension_constructor
-  | Label_declaration of label_declaration
-  | Module_binding of module_binding
-  | Module_declaration of module_declaration
-  | Module_substitution of module_substitution
-  | Module_type_declaration of module_type_declaration
-  | Type_declaration of type_declaration
-  | Value_binding of value_binding
-  | Value_description of value_description
-
 type cmt_infos = {
   cmt_modname : modname;
   cmt_annots : binary_annots;
@@ -83,7 +68,7 @@ type cmt_infos = {
   cmt_uid_to_decl : item_declaration Shape.Uid.Tbl.t;
   cmt_impl_shape : Shape.t option; (* None for mli *)
   cmt_ident_occurrences :
-    (Longident.t Location.loc * Shape.reduction_result) list
+    (Longident.t Location.loc * Shape_reduce.result) list
 }
 
 type error =
diff --git a/upstream/ocaml_414/typing/shape.ml b/upstream/ocaml_414/typing/shape.ml
index 1b5af183ed..d11a835d32 100644
--- a/upstream/ocaml_414/typing/shape.ml
+++ b/upstream/ocaml_414/typing/shape.ml
@@ -198,6 +198,10 @@ let print fmt t =
   else
     Format.fprintf fmt "@[%a@]@;" aux t
 
+let rec strip_head_aliases = function
+  | { desc = Alias t; _ } -> strip_head_aliases t
+  | t -> t
+
 let fresh_var ?(name="shape-var") uid =
   let var = Ident.create_local name in
   var, { uid = Some uid; desc = Var var; approximated = false }
@@ -242,325 +246,6 @@ let decompose_abs t =
   | Abs (x, t) -> Some (x, t)
   | _ -> None
 
-type reduction_result =
-  | Resolved of Uid.t
-  | Unresolved of t
-  | Approximated of Uid.t option
-  | Missing_uid
-
-let print_reduction_result fmt result =
-  match result with
-  | Resolved uid ->
-      Format.fprintf fmt "@[Resolved: %a@]@;" Uid.print uid
-  | Unresolved shape ->
-      Format.fprintf fmt "@[Unresolved: %a@]@;" print shape
-  | Approximated (Some uid) ->
-      Format.fprintf fmt "@[Approximated: %a@]@;" Uid.print uid
-  | Approximated None ->
-      Format.fprintf fmt "@[Approximated: No uid@]@;"
-  | Missing_uid ->
-      Format.fprintf fmt "@[Missing uid@]@;"
-
-module Make_reduce(Params : sig
-  type env
-  val fuel : int
-  val read_unit_shape : unit_name:string -> t option
-  val find_shape : env -> Ident.t -> t
-end) = struct
-  (* We implement a strong call-by-need reduction, following an
-     evaluator from Nathanaelle Courant. *)
-
-  type nf = { uid: Uid.t option; desc: nf_desc; approximated: bool }
-  and nf_desc =
-    | NVar of var
-    | NApp of nf * nf
-    | NAbs of local_env * var * t * delayed_nf
-    | NStruct of delayed_nf Item.Map.t
-    | NAlias of nf
-    | NProj of nf * Item.t
-    | NLeaf
-    | NComp_unit of string
-    | NError of string
-
-  (* A type of normal forms for strong call-by-need evaluation.
-     The normal form of an abstraction
-       Abs(x, t)
-     is a closure
-       NAbs(env, x, t, dnf)
-     when [env] is the local environment, and [dnf] is a delayed
-     normal form of [t].
-
-     A "delayed normal form" is morally equivalent to (nf Lazy.t), but
-     we use a different representation that is compatible with
-     memoization (lazy values are not hashable/comparable by default
-     comparison functions): we represent a delayed normal form as
-     just a not-yet-computed pair [local_env * t] of a term in a
-     local environment -- we could also see this as a term under
-     an explicit substitution. This delayed thunked is "forced"
-     by calling the normalization function as usual, but duplicate
-     computations are precisely avoided by memoization.
-   *)
-  and thunk = { local_env : local_env; shape: t }
-  and delayed_nf = Thunk of thunk
-
-  and local_env = delayed_nf option Ident.Map.t
-  (* When reducing in the body of an abstraction [Abs(x, body)], we
-     bind [x] to [None] in the environment. [Some v] is used for
-     actual substitutions, for example in [App(Abs(x, body), t)], when
-     [v] is a thunk that will evaluate to the normal form of [t]. *)
-
-  let improve_uid uid (nf : nf) =
-    match nf.uid with
-    | Some _ -> nf
-    | None -> { nf with uid }
-
-  let in_memo_table memo_table memo_key f arg =
-    match Hashtbl.find memo_table memo_key with
-    | res -> res
-    | exception Not_found ->
-        let res = f arg in
-        Hashtbl.replace memo_table memo_key res;
-        res
-
-  let rec strip_head_aliases nf = match nf.desc with
-    | NAlias nf -> strip_head_aliases nf
-    | _ -> nf
-
-  type env = {
-    fuel: int ref;
-    global_env: Params.env;
-    local_env: local_env;
-    reduce_memo_table: (thunk, nf) Hashtbl.t;
-    read_back_memo_table: (nf, t) Hashtbl.t;
-  }
-
-  let bind env var shape =
-    { env with local_env = Ident.Map.add var shape env.local_env }
-
-  let rec reduce_ env t =
-    let local_env = env.local_env in
-    let memo_key = { local_env; shape = t } in
-    in_memo_table
-      env.reduce_memo_table memo_key
-      (reduce__ env) t
-  (* Memoization is absolutely essential for performance on this
-     problem, because the normal forms we build can in some real-world
-     cases contain an exponential amount of redundancy. Memoization
-     can avoid the repeated evaluation of identical subterms,
-     providing a large speedup, but even more importantly it
-     implicitly shares the memory of the repeated results, providing
-     much smaller normal forms (that blow up again if printed back
-     as trees). A functor-heavy file from Irmin has its shape normal
-     form decrease from 100Mio to 2.5Mio when memoization is enabled.
-
-     Note: the local environment is part of the memoization key, while
-     it is defined using a type Ident.Map.t of non-canonical balanced
-     trees: two maps could have exactly the same items, but be
-     balanced differently and therefore hash differently, reducing
-     the effectivenss of memoization.
-     This could in theory happen, say, with the two programs
-       (fun x -> fun y -> ...)
-     and
-       (fun y -> fun x -> ...)
-     having "the same" local environments, with additions done in
-     a different order, giving non-structurally-equal trees. Should we
-     define our own hash functions to provide robust hashing on
-     environments?
-
-     We believe that the answer is "no": this problem does not occur
-     in practice. We can assume that identifiers are unique on valid
-     typedtree fragments (identifier "stamps" distinguish
-     binding positions); in particular the two program fragments above
-     in fact bind *distinct* identifiers x (with different stamps) and
-     different identifiers y, so the environments are distinct. If two
-     environments are structurally the same, they must correspond to
-     the evaluation evnrionments of two sub-terms that are under
-     exactly the same scope of binders. So the two environments were
-     obtained by the same term traversal, adding binders in the same
-     order, giving the same balanced trees: the environments have the
-     same hash.
-*)
-
-  and reduce__
-    ({fuel; global_env; local_env; _} as env) (t : t) =
-    let reduce env t =
-      reduce_ env t
-    in
-    let delay_reduce { local_env; _ } t =
-      Thunk { local_env; shape = t }
-    in
-    let force (Thunk { local_env; shape = t }) =
-      reduce { env with local_env } t in
-    let return ?(approximated = t.approximated) desc : nf =
-      { uid = t.uid; desc; approximated }
-    in
-    if !fuel < 0 then return ~approximated:true (NError "NoFuelLeft")
-    else
-      match t.desc with
-      | Comp_unit unit_name ->
-          begin match Params.read_unit_shape ~unit_name with
-          | Some t -> reduce env t
-          | None -> return (NComp_unit unit_name)
-          end
-      | App(f, arg) ->
-          let f = reduce env f |> strip_head_aliases in
-          begin match f.desc with
-          | NAbs(clos_env, var, body, _body_nf) ->
-              let arg = delay_reduce env arg in
-              let env = bind { env with local_env = clos_env } var (Some arg) in
-              { (reduce env body) with uid = t.uid }
-          | _ ->
-              let arg = reduce env arg in
-              return (NApp(f, arg))
-          end
-      | Proj(str, item) ->
-          let str = reduce env str |> strip_head_aliases in
-          let nored () = return (NProj(str, item)) in
-          begin match str.desc with
-          | NStruct (items) ->
-              begin match Item.Map.find item items with
-              | exception Not_found -> nored ()
-              | nf ->
-                  force nf
-                  |> improve_uid t.uid
-              end
-          | _ ->
-              nored ()
-          end
-      | Abs(var, body) ->
-          let body_nf = delay_reduce (bind env var None) body in
-          return (NAbs(local_env, var, body, body_nf))
-      | Var id ->
-          begin match Ident.Map.find id local_env with
-          (* Note: instead of binding abstraction-bound variables to
-             [None], we could unify it with the [Some v] case by
-             binding the bound variable [x] to [NVar x].
-
-             One reason to distinguish the situations is that we can
-             provide a different [Uid.t] location; for bound
-             variables, we use the [Uid.t] of the bound occurrence
-             (not the binding site), whereas for bound values we use
-             their binding-time [Uid.t]. *)
-          | None -> return (NVar id)
-          | Some def -> force def
-          | exception Not_found ->
-          match Params.find_shape global_env id with
-          | exception Not_found -> return (NVar id)
-          | res when res = t -> return (NVar id)
-          | res ->
-              decr fuel;
-              reduce env res
-          end
-      | Leaf -> return NLeaf
-      | Struct m ->
-          let mnf = Item.Map.map (delay_reduce env) m in
-          return (NStruct mnf)
-      | Alias t -> return (NAlias (reduce env t))
-      | Error s -> return ~approximated:true (NError s)
-
-  and read_back env (nf : nf) : t =
-    in_memo_table env.read_back_memo_table nf (read_back_ env) nf
-  (* The [nf] normal form we receive may contain a lot of internal
-     sharing due to the use of memoization in the evaluator. We have
-     to memoize here again, otherwise the sharing is lost by mapping
-     over the term as a tree. *)
-
-  and read_back_ env (nf : nf) : t =
-    { uid = nf.uid ;
-      desc = read_back_desc env nf.desc;
-      approximated = nf.approximated }
-
-  and read_back_desc env desc =
-    let read_back nf = read_back env nf in
-    let read_back_force (Thunk { local_env; shape = t }) =
-      read_back (reduce_ { env with local_env } t) in
-    match desc with
-    | NVar v ->
-        Var v
-    | NApp (nft, nfu) ->
-        App(read_back nft, read_back nfu)
-    | NAbs (_env, x, _t, nf) ->
-        Abs(x, read_back_force nf)
-    | NStruct nstr ->
-        Struct (Item.Map.map read_back_force nstr)
-    | NAlias nf -> Alias (read_back nf)
-    | NProj (nf, item) ->
-        Proj (read_back nf, item)
-    | NLeaf -> Leaf
-    | NComp_unit s -> Comp_unit s
-    | NError s -> Error s
-
-  (* Sharing the memo tables is safe at the level of a compilation unit since
-    idents should be unique *)
-  let reduce_memo_table = Local_store.s_table Hashtbl.create 42
-  let read_back_memo_table = Local_store.s_table Hashtbl.create 42
-
-  let reduce global_env t =
-    let fuel = ref Params.fuel in
-    let local_env = Ident.Map.empty in
-    let env = {
-      fuel;
-      global_env;
-      reduce_memo_table = !reduce_memo_table;
-      read_back_memo_table = !read_back_memo_table;
-      local_env;
-    } in
-    reduce_ env t |> read_back env
-
-  let rec is_stuck_on_comp_unit (nf : nf) =
-    match nf.desc with
-    | NVar _ ->
-        (* This should not happen if we only reduce closed terms *)
-        false
-    | NApp (nf, _) | NProj (nf, _) | NAlias nf -> is_stuck_on_comp_unit nf
-    | NStruct _ | NAbs _ -> false
-    | NComp_unit _ -> true
-    | NError _ -> false
-    | NLeaf -> false
-
-  let reduce_for_uid global_env t =
-    let fuel = ref Params.fuel in
-    let local_env = Ident.Map.empty in
-    let env = {
-      fuel;
-      global_env;
-      reduce_memo_table = !reduce_memo_table;
-      read_back_memo_table = !read_back_memo_table;
-      local_env;
-    } in
-    let nf = reduce_ env t in
-    if is_stuck_on_comp_unit nf then
-      Unresolved (read_back env nf)
-    else match nf with
-      | { uid = Some uid; approximated = false; _ } ->
-          Resolved uid
-      | { uid; approximated = true; _ } ->
-          Approximated uid
-      | { uid = None; approximated = false; _ } ->
-          (* A missing Uid after a complete reduction means the Uid was first
-             missing in the shape which is a code error. Having the
-             [Missing_uid] reported will allow Merlin (or another tool working
-             with the index) to ask users to report the issue if it does happen.
-          *)
-          Missing_uid
-end
-
-module Toplevel_local_reduce =
-  (* Note: this definition with [type env = unit] is only suitable for
-     reduction of toplevel shapes -- shapes of compilation units,
-     where free variables are only Comp_unit names. If we wanted to
-     reduce shapes inside module signatures, we would need to take
-     a typing environment as parameter. *)
-  Make_reduce(struct
-    type env = unit
-    let fuel = 10
-    let read_unit_shape ~unit_name:_ = None
-    let find_shape _env _id = raise Not_found
-  end)
-
-let toplevel_local_reduce shape =
-  Toplevel_local_reduce.reduce () shape
-
 let dummy_mod =
   { uid = None; desc = Struct Item.Map.empty; approximated = false }
 
diff --git a/upstream/ocaml_414/typing/shape.mli b/upstream/ocaml_414/typing/shape.mli
index 5d2434680b..3d686ab185 100644
--- a/upstream/ocaml_414/typing/shape.mli
+++ b/upstream/ocaml_414/typing/shape.mli
@@ -26,7 +26,7 @@
     - Build the Shape corresponding to the value's path:
       [let shape = Env.shape_of_path ~namespace env path]
 
-    - Instantiate the [Make_reduce] functor with a way to load shapes from
+    - Instantiate the [Shape_reduce.Make] functor with a way to load shapes from
       external units and to looks for shapes in the environment (usually using
       [Env.shape_of_path]).
 
@@ -40,7 +40,7 @@
       for example when hitting first-class modules.
 
     - The location of the definition can be easily found with the
-      [cmt_format.cmt_uid_to_decl] talbe of the corresponding compilation unit.
+      [cmt_format.cmt_uid_to_decl] table of the corresponding compilation unit.
 
   See:
   - {{: https://icfp22.sigplan.org/details/mlfamilyworkshop-2022-papers/10/Module-Shapes-for-Modern-Tooling }
@@ -49,6 +49,12 @@
     a talk about the reduction strategy
 *)
 
+(** A [Uid.t] is associated with every declaration in signatures and
+    implementations, they uniquely identify bindings in the program.
+    When associated with these bindings' locations they are useful to
+    external tools when trying to jump to the declaration of
+    definitions of identifiers. They are stored to that effect in the
+    [uid_to_decl] table of cmt files. *)
 module Uid : sig
   type t = private
     | Compilation_unit of string
@@ -86,7 +92,8 @@ module Sig_component_kind : sig
   val can_appear_in_types : t -> bool
 end
 
-(** Shape's items are elements of a structure modeling module components. *)
+(** Shape's items are elements of a structure. These structures models module
+    components and nested types' constructors and labels *)
 module Item : sig
   type t = string * Sig_component_kind.t
   val name : t -> string
@@ -122,16 +129,10 @@ and desc =
   | Comp_unit of string
   | Error of string
 
-type reduction_result =
-  | Resolved of Uid.t
-  | Unresolved of t
-  | Approximated of Uid.t option
-  | Missing_uid
-
-val print_reduction_result : Format.formatter -> reduction_result -> unit
-
 val print : Format.formatter -> t -> unit
 
+val strip_head_aliases : t -> t
+
 (* Smart constructors *)
 
 val for_unnamed_functor_param : var
@@ -197,34 +198,3 @@ val of_path :
   namespace:Sig_component_kind.t -> Path.t -> t
 
 val set_uid_if_none : t -> Uid.t -> t
-
-(** The [Make_reduce] functor is used to generate a reduction function for
-    shapes.
-
-    It is parametrized by:
-    - an environment and a function to find shapes by path in that environment
-    - a function to load the shape of an external compilation unit
-    - some fuel, which is used to bound recursion when dealing with recursive
-      shapes introduced by recursive modules. (FTR: merlin currently uses a
-      fuel of 10, which seems to be enough for most practical examples)
-*)
-module Make_reduce(Context : sig
-    type env
-
-    val fuel : int
-
-    val read_unit_shape : unit_name:string -> t option
-
-    val find_shape : env -> Ident.t -> t
-  end) : sig
-  val reduce : Context.env -> t -> t
-
-  (** Perform weak reduction and return the head's uid if any. If reduction was
-    incomplete the partially reduced shape is returned. *)
-  val reduce_for_uid : Context.env -> t -> reduction_result
-end
-
-(** [toplevel_local_reduce] is only suitable to reduce toplevel shapes (shapes
-  of compilation units). Use the [Make_reduce] functor for other cases that
-  require access to the environment.*)
-val toplevel_local_reduce : t -> t
diff --git a/upstream/ocaml_414/typing/shape_reduce.ml b/upstream/ocaml_414/typing/shape_reduce.ml
new file mode 100644
index 0000000000..0b6e7916ec
--- /dev/null
+++ b/upstream/ocaml_414/typing/shape_reduce.ml
@@ -0,0 +1,350 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                Ulysse Gérard, Thomas Refis, Tarides                    *)
+(*                                                                        *)
+(*   Copyright 2021 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Shape
+
+type result =
+  | Resolved of Uid.t
+  | Resolved_alias of Uid.t list
+  | Unresolved of t
+  | Approximated of Uid.t option
+  | Internal_error_missing_uid
+
+let print_result fmt result =
+  match result with
+  | Resolved uid ->
+      Format.fprintf fmt "@[Resolved: %a@]@;" Uid.print uid
+  | Resolved_alias uids ->
+      Format.fprintf fmt "@[Resolved_alias: %a@]@;"
+        Format.(pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt "@ -> ")
+        Uid.print) uids
+  | Unresolved shape ->
+      Format.fprintf fmt "@[Unresolved: %a@]@;" print shape
+  | Approximated (Some uid) ->
+      Format.fprintf fmt "@[Approximated: %a@]@;" Uid.print uid
+  | Approximated None ->
+      Format.fprintf fmt "@[Approximated: No uid@]@;"
+  | Internal_error_missing_uid ->
+      Format.fprintf fmt "@[Missing uid@]@;"
+
+
+let find_shape env id =
+  let namespace = Shape.Sig_component_kind.Module in
+  Env.shape_of_path ~namespace env (Pident id)
+
+module Make(Params : sig
+  val fuel : int
+  val read_unit_shape : unit_name:string -> t option
+end) = struct
+  (* We implement a strong call-by-need reduction, following an
+     evaluator from Nathanaelle Courant. *)
+
+  type nf = { uid: Uid.t option; desc: nf_desc; approximated: bool }
+  and nf_desc =
+    | NVar of var
+    | NApp of nf * nf
+    | NAbs of local_env * var * t * delayed_nf
+    | NStruct of delayed_nf Item.Map.t
+    | NAlias of delayed_nf
+    | NProj of nf * Item.t
+    | NLeaf
+    | NComp_unit of string
+    | NError of string
+
+  (* A type of normal forms for strong call-by-need evaluation.
+     The normal form of an abstraction
+       Abs(x, t)
+     is a closure
+       NAbs(env, x, t, dnf)
+     when [env] is the local environment, and [dnf] is a delayed
+     normal form of [t].
+
+     A "delayed normal form" is morally equivalent to (nf Lazy.t), but
+     we use a different representation that is compatible with
+     memoization (lazy values are not hashable/comparable by default
+     comparison functions): we represent a delayed normal form as
+     just a not-yet-computed pair [local_env * t] of a term in a
+     local environment -- we could also see this as a term under
+     an explicit substitution. This delayed thunked is "forced"
+     by calling the normalization function as usual, but duplicate
+     computations are precisely avoided by memoization.
+   *)
+  and delayed_nf = Thunk of local_env * t
+
+  and local_env = delayed_nf option Ident.Map.t
+  (* When reducing in the body of an abstraction [Abs(x, body)], we
+     bind [x] to [None] in the environment. [Some v] is used for
+     actual substitutions, for example in [App(Abs(x, body), t)], when
+     [v] is a thunk that will evaluate to the normal form of [t]. *)
+
+  let approx_nf nf = { nf with approximated = true }
+
+  let in_memo_table memo_table memo_key f arg =
+    match Hashtbl.find memo_table memo_key with
+    | res -> res
+    | exception Not_found ->
+        let res = f arg in
+        Hashtbl.replace memo_table memo_key res;
+        res
+
+  type env = {
+    fuel: int ref;
+    global_env: Env.t;
+    local_env: local_env;
+    reduce_memo_table: (local_env * t, nf) Hashtbl.t;
+    read_back_memo_table: (nf, t) Hashtbl.t;
+  }
+
+  let bind env var shape =
+    { env with local_env = Ident.Map.add var shape env.local_env }
+
+  let rec reduce_ env t =
+    let local_env = env.local_env in
+    let memo_key = (local_env, t) in
+    in_memo_table env.reduce_memo_table memo_key (reduce__ env) t
+  (* Memoization is absolutely essential for performance on this
+     problem, because the normal forms we build can in some real-world
+     cases contain an exponential amount of redundancy. Memoization
+     can avoid the repeated evaluation of identical subterms,
+     providing a large speedup, but even more importantly it
+     implicitly shares the memory of the repeated results, providing
+     much smaller normal forms (that blow up again if printed back
+     as trees). A functor-heavy file from Irmin has its shape normal
+     form decrease from 100Mio to 2.5Mio when memoization is enabled.
+
+     Note: the local environment is part of the memoization key, while
+     it is defined using a type Ident.Map.t of non-canonical balanced
+     trees: two maps could have exactly the same items, but be
+     balanced differently and therefore hash differently, reducing
+     the effectivenss of memoization.
+     This could in theory happen, say, with the two programs
+       (fun x -> fun y -> ...)
+     and
+       (fun y -> fun x -> ...)
+     having "the same" local environments, with additions done in
+     a different order, giving non-structurally-equal trees. Should we
+     define our own hash functions to provide robust hashing on
+     environments?
+
+     We believe that the answer is "no": this problem does not occur
+     in practice. We can assume that identifiers are unique on valid
+     typedtree fragments (identifier "stamps" distinguish
+     binding positions); in particular the two program fragments above
+     in fact bind *distinct* identifiers x (with different stamps) and
+     different identifiers y, so the environments are distinct. If two
+     environments are structurally the same, they must correspond to
+     the evaluation evnrionments of two sub-terms that are under
+     exactly the same scope of binders. So the two environments were
+     obtained by the same term traversal, adding binders in the same
+     order, giving the same balanced trees: the environments have the
+     same hash.
+*)
+
+  and reduce__
+    ({fuel; global_env; local_env; _} as env) (t : t) =
+    let reduce env t = reduce_ env t in
+    let delay_reduce env t = Thunk (env.local_env, t) in
+    let force (Thunk (local_env, t)) = reduce { env with local_env } t in
+    let return desc = { uid = t.uid; desc; approximated = t.approximated } in
+    let rec force_aliases nf = match nf.desc with
+      | NAlias delayed_nf ->
+          let nf = force delayed_nf in
+          force_aliases nf
+      | _ -> nf
+    in
+    let reset_uid_if_new_binding t' =
+      match t.uid with
+      | None -> t'
+      | Some _ as uid -> { t' with uid }
+    in
+    if !fuel < 0 then approx_nf (return (NError "NoFuelLeft"))
+    else
+      match t.desc with
+      | Comp_unit unit_name ->
+          begin match Params.read_unit_shape ~unit_name with
+          | Some t -> reduce env t
+          | None -> return (NComp_unit unit_name)
+          end
+      | App(f, arg) ->
+          let f = reduce env f |> force_aliases in
+          begin match f.desc with
+          | NAbs(clos_env, var, body, _body_nf) ->
+              let arg = delay_reduce env arg in
+              let env = bind { env with local_env = clos_env } var (Some arg) in
+              reduce env body |> reset_uid_if_new_binding
+          | _ ->
+              let arg = reduce env arg in
+              return (NApp(f, arg))
+          end
+      | Proj(str, item) ->
+          let str = reduce env str |> force_aliases in
+          let nored () = return (NProj(str, item)) in
+          begin match str.desc with
+          | NStruct (items) ->
+              begin match Item.Map.find item items with
+              | exception Not_found -> nored ()
+              | nf -> force nf |> reset_uid_if_new_binding
+              end
+          | _ ->
+              nored ()
+          end
+      | Abs(var, body) ->
+          let body_nf = delay_reduce (bind env var None) body in
+          return (NAbs(local_env, var, body, body_nf))
+      | Var id ->
+          begin match Ident.Map.find id local_env with
+          (* Note: instead of binding abstraction-bound variables to
+             [None], we could unify it with the [Some v] case by
+             binding the bound variable [x] to [NVar x].
+
+             One reason to distinguish the situations is that we can
+             provide a different [Uid.t] location; for bound
+             variables, we use the [Uid.t] of the bound occurrence
+             (not the binding site), whereas for bound values we use
+             their binding-time [Uid.t]. *)
+          | None -> return (NVar id)
+          | Some def ->
+              begin match force def with
+              | { uid = Some _; _  } as nf -> nf
+                  (* This var already has a binding uid *)
+              | { uid = None; _ } as nf -> { nf with uid = t.uid }
+                  (* Set the var's binding uid *)
+              end
+          | exception Not_found ->
+          match find_shape global_env id with
+          | exception Not_found -> return (NVar id)
+          | res when res = t -> return (NVar id)
+          | res ->
+              decr fuel;
+              reduce env res
+          end
+      | Leaf -> return NLeaf
+      | Struct m ->
+          let mnf = Item.Map.map (delay_reduce env) m in
+          return (NStruct mnf)
+      | Alias t -> return (NAlias (delay_reduce env t))
+      | Error s -> approx_nf (return (NError s))
+
+  and read_back env (nf : nf) : t =
+    in_memo_table env.read_back_memo_table nf (read_back_ env) nf
+  (* The [nf] normal form we receive may contain a lot of internal
+     sharing due to the use of memoization in the evaluator. We have
+     to memoize here again, otherwise the sharing is lost by mapping
+     over the term as a tree. *)
+
+  and read_back_ env (nf : nf) : t =
+    { uid = nf.uid ;
+      desc = read_back_desc env nf.desc;
+      approximated = nf.approximated }
+
+  and read_back_desc env desc =
+    let read_back nf = read_back env nf in
+    let read_back_force (Thunk (local_env, t)) =
+      read_back (reduce_ { env with local_env } t) in
+    match desc with
+    | NVar v ->
+        Var v
+    | NApp (nft, nfu) ->
+        App(read_back nft, read_back nfu)
+    | NAbs (_env, x, _t, nf) ->
+        Abs(x, read_back_force nf)
+    | NStruct nstr ->
+        Struct (Item.Map.map read_back_force nstr)
+    | NAlias nf -> Alias (read_back_force nf)
+    | NProj (nf, item) ->
+        Proj (read_back nf, item)
+    | NLeaf -> Leaf
+    | NComp_unit s -> Comp_unit s
+    | NError s -> Error s
+
+  (* Sharing the memo tables is safe at the level of a compilation unit since
+    idents should be unique *)
+  let reduce_memo_table = Local_store.s_table Hashtbl.create 42
+  let read_back_memo_table = Local_store.s_table Hashtbl.create 42
+
+  let reduce global_env t =
+    let fuel = ref Params.fuel in
+    let local_env = Ident.Map.empty in
+    let env = {
+      fuel;
+      global_env;
+      reduce_memo_table = !reduce_memo_table;
+      read_back_memo_table = !read_back_memo_table;
+      local_env;
+    } in
+    reduce_ env t |> read_back env
+
+  let rec is_stuck_on_comp_unit (nf : nf) =
+    match nf.desc with
+    | NVar _ ->
+        (* This should not happen if we only reduce closed terms *)
+        false
+    | NApp (nf, _) | NProj (nf, _) -> is_stuck_on_comp_unit nf
+    | NStruct _ | NAbs _ -> false
+    | NAlias _ -> false
+    | NComp_unit _ -> true
+    | NError _ -> false
+    | NLeaf -> false
+
+  let get_aliases_uids (t : t) =
+    let rec aux acc (t : t) = match t with
+      | { uid = Some uid; desc = Alias t; _ } -> aux (uid::acc) t
+      | { uid = Some uid; _ } -> Resolved_alias (List.rev (uid::acc))
+      | _ -> Internal_error_missing_uid
+    in
+    aux [] t
+
+  let reduce_for_uid global_env t =
+    let fuel = ref Params.fuel in
+    let local_env = Ident.Map.empty in
+    let env = {
+      fuel;
+      global_env;
+      reduce_memo_table = !reduce_memo_table;
+      read_back_memo_table = !read_back_memo_table;
+      local_env;
+    } in
+    let nf = reduce_ env t in
+    if is_stuck_on_comp_unit nf then
+      Unresolved (read_back env nf)
+    else match nf with
+      | { desc = NAlias _; approximated = false; _ } ->
+          get_aliases_uids (read_back env nf)
+      | { uid = Some uid; approximated = false; _ } ->
+          Resolved uid
+      | { uid; approximated = true; _ } ->
+          Approximated uid
+      | { uid = None; approximated = false; _ } ->
+          (* A missing Uid after a complete reduction means the Uid was first
+             missing in the shape which is a code error. Having the
+             [Missing_uid] reported will allow Merlin (or another tool working
+             with the index) to ask users to report the issue if it does happen.
+          *)
+          Internal_error_missing_uid
+end
+
+module Local_reduce =
+  (* Note: this definition with [type env = unit] is only suitable for
+     reduction of toplevel shapes -- shapes of compilation units,
+     where free variables are only Comp_unit names. If we wanted to
+     reduce shapes inside module signatures, we would need to take
+     a typing environment as parameter. *)
+  Make(struct
+    let fuel = 10
+    let read_unit_shape ~unit_name:_ = None
+  end)
+
+let local_reduce = Local_reduce.reduce
+let local_reduce_for_uid = Local_reduce.reduce_for_uid
diff --git a/upstream/ocaml_414/typing/shape_reduce.mli b/upstream/ocaml_414/typing/shape_reduce.mli
new file mode 100644
index 0000000000..6156207ad6
--- /dev/null
+++ b/upstream/ocaml_414/typing/shape_reduce.mli
@@ -0,0 +1,57 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                Ulysse Gérard, Thomas Refis, Tarides                    *)
+(*                                                                        *)
+(*   Copyright 2021 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Shape
+
+(** The result of reducing a shape and looking for its uid *)
+type result =
+  | Resolved of Uid.t (** Shape reduction succeeded and a uid was found *)
+  | Resolved_alias of Uid.t list (** Reduction led to an alias chain *)
+  | Unresolved of t (** Result still contains [Comp_unit] terms *)
+  | Approximated of Uid.t option
+    (** Reduction failed: it can arrive with first-clsss modules for example *)
+  | Internal_error_missing_uid
+    (** Reduction succeeded but no uid was found, this should never happen *)
+
+val print_result : Format.formatter -> result -> unit
+
+(** The [Make] functor is used to generate a reduction function for
+    shapes.
+
+    It is parametrized by:
+    - a function to load the shape of an external compilation unit
+    - some fuel, which is used to bound recursion when dealing with recursive
+      shapes introduced by recursive modules. (FTR: merlin currently uses a
+      fuel of 10, which seems to be enough for most practical examples)
+*)
+module Make(_ : sig
+    val fuel : int
+
+    val read_unit_shape : unit_name:string -> t option
+  end) : sig
+  val reduce : Env.t -> t -> t
+
+  (** Perform weak reduction and return the head's uid if any. If reduction was
+    incomplete the partially reduced shape is returned. *)
+  val reduce_for_uid : Env.t -> t -> result
+end
+
+(** [local_reduce] will not reduce shapes that require loading external
+  compilation units. *)
+val local_reduce : Env.t -> t -> t
+
+(** [local_reduce_for_uid] will not reduce shapes that require loading external
+  compilation units. *)
+val local_reduce_for_uid : Env.t -> t -> result
diff --git a/upstream/ocaml_414/typing/tast_iterator.ml b/upstream/ocaml_414/typing/tast_iterator.ml
index 5f5be93c5c..506036afcf 100644
--- a/upstream/ocaml_414/typing/tast_iterator.ml
+++ b/upstream/ocaml_414/typing/tast_iterator.ml
@@ -59,6 +59,7 @@ type iterator =
     value_bindings: iterator -> (rec_flag * value_binding list) -> unit;
     value_description: iterator -> value_description -> unit;
     with_constraint: iterator -> with_constraint -> unit;
+    item_declaration: iterator -> item_declaration -> unit;
   }
 
 let structure sub {str_items; str_final_env; _} =
@@ -69,19 +70,25 @@ let class_infos sub f x =
   List.iter (fun (ct, _) -> sub.typ sub ct) x.ci_params;
   f x.ci_expr
 
-let module_type_declaration sub {mtd_type; _} =
+let module_type_declaration sub ({mtd_type; _} as x) =
+  sub.item_declaration sub (Module_type x);
   Option.iter (sub.module_type sub) mtd_type
 
-let module_declaration sub {md_type; _} =
+let module_declaration sub ({md_type; _} as md) =
+  sub.item_declaration sub (Module md);
   sub.module_type sub md_type
-let module_substitution _ _ = ()
+
+let module_substitution sub ms =
+  sub.item_declaration sub (Module_substitution ms)
 
 let include_infos f {incl_mod; _} = f incl_mod
 
 let class_type_declaration sub x =
+  sub.item_declaration sub (Class_type x);
   class_infos sub (sub.class_type sub) x
 
 let class_declaration sub x =
+  sub.item_declaration sub (Class x);
   class_infos sub (sub.class_expr sub) x
 
 let structure_item sub {str_desc; str_env; _} =
@@ -104,15 +111,20 @@ let structure_item sub {str_desc; str_env; _} =
   | Tstr_open od -> sub.open_declaration sub od
   | Tstr_attribute _ -> ()
 
-let value_description sub x = sub.typ sub x.val_desc
+let value_description sub x =
+  sub.item_declaration sub (Value x);
+  sub.typ sub x.val_desc
 
-let label_decl sub {ld_type; _} = sub.typ sub ld_type
+let label_decl sub ({ld_type; _} as ld) =
+  sub.item_declaration sub (Label ld);
+  sub.typ sub ld_type
 
 let constructor_args sub = function
   | Cstr_tuple l -> List.iter (sub.typ sub) l
   | Cstr_record l -> List.iter (label_decl sub) l
 
-let constructor_decl sub {cd_args; cd_res; _} =
+let constructor_decl sub ({cd_args; cd_res; _} as x) =
+  sub.item_declaration sub (Constructor x);
   constructor_args sub cd_args;
   Option.iter (sub.typ sub) cd_res
 
@@ -122,7 +134,9 @@ let type_kind sub = function
   | Ttype_record list -> List.iter (label_decl sub) list
   | Ttype_open -> ()
 
-let type_declaration sub {typ_cstrs; typ_kind; typ_manifest; typ_params; _} =
+let type_declaration
+  sub ({typ_cstrs; typ_kind; typ_manifest; typ_params; _} as x) =
+  sub.item_declaration sub (Type x);
   List.iter
     (fun (c1, c2, _) ->
       sub.typ sub c1;
@@ -141,7 +155,8 @@ let type_extension sub {tyext_constructors; tyext_params; _} =
 let type_exception sub {tyexn_constructor; _} =
   sub.extension_constructor sub tyexn_constructor
 
-let extension_constructor sub {ext_kind; _} =
+let extension_constructor sub ({ext_kind; _} as ec) =
+  sub.item_declaration sub (Extension_constructor ec);
   match ext_kind with
   | Text_decl (_, ctl, cto) ->
       constructor_args sub ctl;
@@ -291,6 +306,7 @@ let signature_item sub {sig_desc; sig_env; _} =
   | Tsig_attribute _ -> ()
 
 let class_description sub x =
+  sub.item_declaration sub (Class_type x);
   class_infos sub (sub.class_type sub) x
 
 let functor_parameter sub = function
@@ -360,7 +376,9 @@ let module_expr sub {mod_desc; mod_env; _} =
       sub.module_coercion sub c
   | Tmod_unpack (exp, _) -> sub.expr sub exp
 
-let module_binding sub {mb_expr; _} = sub.module_expr sub mb_expr
+let module_binding sub ({mb_expr; _} as mb) =
+  sub.item_declaration sub (Module_binding mb);
+  sub.module_expr sub mb_expr
 
 let class_expr sub {cl_desc; cl_env; _} =
   sub.env sub cl_env;
@@ -463,12 +481,15 @@ let case sub {c_lhs; c_guard; c_rhs} =
   Option.iter (sub.expr sub) c_guard;
   sub.expr sub c_rhs
 
-let value_binding sub {vb_pat; vb_expr; _} =
+let value_binding sub ({vb_pat; vb_expr; _} as vb) =
+  sub.item_declaration sub (Value_binding vb);
   sub.pat sub vb_pat;
   sub.expr sub vb_expr
 
 let env _sub _ = ()
 
+let item_declaration _sub _ = ()
+
 let default_iterator =
   {
     binding_op;
@@ -512,4 +533,5 @@ let default_iterator =
     value_bindings;
     value_description;
     with_constraint;
+    item_declaration;
   }
diff --git a/upstream/ocaml_414/typing/tast_iterator.mli b/upstream/ocaml_414/typing/tast_iterator.mli
index e126128edf..5e6d3b6c72 100644
--- a/upstream/ocaml_414/typing/tast_iterator.mli
+++ b/upstream/ocaml_414/typing/tast_iterator.mli
@@ -63,6 +63,7 @@ type iterator =
     value_bindings: iterator -> (rec_flag * value_binding list) -> unit;
     value_description: iterator -> value_description -> unit;
     with_constraint: iterator -> with_constraint -> unit;
+    item_declaration: iterator -> item_declaration -> unit;
   }
 
 val default_iterator: iterator
diff --git a/upstream/ocaml_414/typing/typeclass.ml b/upstream/ocaml_414/typing/typeclass.ml
index 02754243b6..51a76f5eb0 100644
--- a/upstream/ocaml_414/typing/typeclass.ml
+++ b/upstream/ocaml_414/typing/typeclass.ml
@@ -1952,7 +1952,7 @@ let approx_class_declarations env sdecls =
 
 open Format
 
-let non_virtual_string_of_kind = function
+let non_virtual_string_of_kind : kind -> string = function
   | Object -> "object"
   | Class -> "non-virtual class"
   | Class_type -> "non-virtual class type"
diff --git a/upstream/ocaml_414/typing/typedecl.ml b/upstream/ocaml_414/typing/typedecl.ml
index 8f0f8c5b9f..25728a8d61 100644
--- a/upstream/ocaml_414/typing/typedecl.ml
+++ b/upstream/ocaml_414/typing/typedecl.ml
@@ -509,12 +509,15 @@ let transl_declaration env sdecl (id, uid) =
       }
     in
     let typ_shape =
+      let uid = decl.typ_type.type_uid in
       let map = match decl.typ_kind with
-        | Ttype_variant cstrs -> shape_map_cstrs cstrs
-        | Ttype_record labels -> shape_map_labels labels
-        | _ -> Shape.Map.empty
+        | Ttype_variant cstrs -> Some (shape_map_cstrs cstrs)
+        | Ttype_record labels -> Some (shape_map_labels labels)
+        | Ttype_abstract | Ttype_open -> None
       in
-      Shape.str ~uid:decl.typ_type.type_uid map
+      Option.map (Shape.str ~uid) map
+      (* Abstract types are just leafs *)
+      |> Option.value ~default:(Shape.leaf uid)
     in
     decl, typ_shape
 
diff --git a/upstream/ocaml_414/typing/typedtree.ml b/upstream/ocaml_414/typing/typedtree.ml
index d16f063e76..56b35f6e77 100644
--- a/upstream/ocaml_414/typing/typedtree.ml
+++ b/upstream/ocaml_414/typing/typedtree.ml
@@ -635,6 +635,19 @@ type implementation = {
   shape: Shape.t;
 }
 
+type item_declaration =
+  | Value of value_description
+  | Value_binding of value_binding
+  | Type of type_declaration
+  | Constructor of constructor_declaration
+  | Extension_constructor of extension_constructor
+  | Label of label_declaration
+  | Module of module_declaration
+  | Module_substitution of module_substitution
+  | Module_binding of module_binding
+  | Module_type of module_type_declaration
+  | Class of class_declaration
+  | Class_type of class_type_declaration
 
 (* Auxiliary functions over the a.s.t. *)
 
@@ -800,14 +813,6 @@ let let_bound_idents_full bindings =
 let let_bound_idents pat =
   rev_only_idents (rev_let_bound_idents_full pat)
 
-let let_filter_bound bindings =
-  let decls = ref [] in
-  let add vb (_,_,_,uid) =
-    decls := (vb, uid) :: !decls
-  in
-  List.iter (fun vb -> iter_bound_idents (add vb) vb.vb_pat) bindings;
-  !decls
-
 let alpha_var env id = List.assoc id env
 
 let rec alpha_pat
diff --git a/upstream/ocaml_414/typing/typedtree.mli b/upstream/ocaml_414/typing/typedtree.mli
index 377daa87cb..d085194d83 100644
--- a/upstream/ocaml_414/typing/typedtree.mli
+++ b/upstream/ocaml_414/typing/typedtree.mli
@@ -785,6 +785,23 @@ type implementation = {
     structure.
 *)
 
+type item_declaration =
+  | Value of value_description
+  | Value_binding of value_binding
+  | Type of type_declaration
+  | Constructor of constructor_declaration
+  | Extension_constructor of extension_constructor
+  | Label of label_declaration
+  | Module of module_declaration
+  | Module_substitution of module_substitution
+  | Module_binding of module_binding
+  | Module_type of module_type_declaration
+  | Class of class_declaration
+  | Class_type of class_type_declaration
+(** [item_declaration] groups together items that correspond to the syntactic
+    category of "declarations" which include types, values, modules, etc.
+    declarations in signatures and their definitions in implementations. *)
+
 (* Auxiliary functions over the a.s.t. *)
 
 (** [as_computation_pattern p] is a computation pattern with description
@@ -817,7 +834,6 @@ val let_bound_idents: value_binding list -> Ident.t list
 val let_bound_idents_full:
     value_binding list ->
     (Ident.t * string loc * Types.type_expr * Types.Uid.t) list
-val let_filter_bound: value_binding list ->  (value_binding * Uid.t) list
 
 (** Alpha conversion of patterns *)
 val alpha_pat:
diff --git a/upstream/ocaml_414/typing/typemod.ml b/upstream/ocaml_414/typing/typemod.ml
index b6bc5914c3..9648d04526 100644
--- a/upstream/ocaml_414/typing/typemod.ml
+++ b/upstream/ocaml_414/typing/typemod.ml
@@ -2129,6 +2129,7 @@ and type_module_aux ~alias sttn funct_body anchor env smod =
       let shape =
         Env.shape_of_path ~namespace:Shape.Sig_component_kind.Module env path
       in
+      let shape = if alias && aliasable then Shape.alias shape else shape in
       let md =
         if alias && aliasable then
           (Env.add_required_global (Path.head path); md)
@@ -2548,11 +2549,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr =
             md_uid;
           }
         in
-        let md_shape =
-          match modl.mod_type with
-          | Mty_alias _path -> Shape.alias ~uid:md_uid md_shape
-          | _ -> Shape.set_uid_if_none md_shape md_uid
-        in
+        let md_shape = Shape.set_uid_if_none md_shape md_uid in
         (*prerr_endline (Ident.unique_toplevel_name id);*)
         Mtype.lower_nongen outer_scope md.md_type;
         let id, newenv, sg =
@@ -2687,12 +2684,11 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr =
             Signature_names.check_type names loc cls.cls_obj_id;
             Signature_names.check_type names loc cls.cls_typesharp_id;
             let uid = cls.cls_decl.cty_uid in
-            let map f id acc = f acc id uid in
-            let map_t f id acc = f acc id (Shape.str ~uid Shape.Map.empty) in
-            map Shape.Map.add_class cls.cls_id acc
-            |> map Shape.Map.add_class_type cls.cls_ty_id
-            |> map_t Shape.Map.add_type cls.cls_obj_id
-            |> map_t Shape.Map.add_type cls.cls_typesharp_id
+            let map f id v acc = f acc id v in
+            map Shape.Map.add_class cls.cls_id uid acc
+            |> map Shape.Map.add_class_type cls.cls_ty_id uid
+            |> map Shape.Map.add_type cls.cls_obj_id (Shape.leaf uid)
+            |> map Shape.Map.add_type cls.cls_typesharp_id (Shape.leaf uid)
           ) shape_map classes
         in
         Tstr_class
@@ -2719,11 +2715,10 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr =
             Signature_names.check_type names loc decl.clsty_obj_id;
             Signature_names.check_type names loc decl.clsty_typesharp_id;
             let uid = decl.clsty_ty_decl.clty_uid in
-            let map_t f id acc = f acc id (Shape.str ~uid Shape.Map.empty) in
-            let map f id acc = f acc id uid in
-            map Shape.Map.add_class_type decl.clsty_ty_id acc
-            |> map_t Shape.Map.add_type decl.clsty_obj_id
-            |> map_t Shape.Map.add_type decl.clsty_typesharp_id
+            let map f id v acc = f acc id v in
+            map Shape.Map.add_class_type decl.clsty_ty_id uid acc
+            |> map Shape.Map.add_type decl.clsty_obj_id (Shape.leaf uid)
+            |> map Shape.Map.add_type decl.clsty_typesharp_id (Shape.leaf uid)
           ) shape_map classes
         in
         Tstr_class_type
@@ -2987,7 +2982,7 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
       let simple_sg = Signature_names.simplify finalenv names sg in
       if !Clflags.print_types then begin
         Typecore.force_delayed_checks ();
-        let shape = Shape.toplevel_local_reduce shape in
+        let shape = Shape_reduce.local_reduce Env.empty shape in
         Printtyp.wrap_printing_env ~error:false initial_env
           (fun () -> fprintf std_formatter "%a@."
               (Printtyp.printed_signature sourcefile) simple_sg
@@ -3017,7 +3012,7 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
           (* It is important to run these checks after the inclusion test above,
              so that value declarations which are not used internally but
              exported are not reported as being unused. *)
-          let shape = Shape.toplevel_local_reduce shape in
+          let shape = Shape_reduce.local_reduce Env.empty shape in
           let annots = Cmt_format.Implementation str in
           Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename
             annots (Some sourcefile) initial_env None (Some shape);
@@ -3041,7 +3036,7 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
              the value being exported. We can still capture unused
              declarations like "let x = true;; let x = 1;;", because in this
              case, the inferred signature contains only the last declaration. *)
-          let shape = Shape.toplevel_local_reduce shape in
+          let shape = Shape_reduce.local_reduce Env.empty shape in
           if not !Clflags.dont_write_files then begin
             let alerts = Builtin_attributes.alerts_of_str ast in
             let cmi =
diff --git a/upstream/ocaml_414/utils/clflags.ml b/upstream/ocaml_414/utils/clflags.ml
index 9b776cfa99..9e4511aa0c 100644
--- a/upstream/ocaml_414/utils/clflags.ml
+++ b/upstream/ocaml_414/utils/clflags.ml
@@ -68,7 +68,7 @@ and all_ppx = ref ([] : string list)        (* -ppx *)
 let absname = ref false                 (* -absname *)
 let annotations = ref false             (* -annot *)
 let binary_annotations = ref false      (* -bin-annot *)
-let store_usage_index = ref false       (* -store-usage-index *)
+let store_occurrences = ref false       (* -bin-annot-occurrences *)
 and use_threads = ref false             (* -thread *)
 and noassert = ref false                (* -noassert *)
 and verbose = ref false                 (* -verbose *)
diff --git a/upstream/ocaml_414/utils/clflags.mli b/upstream/ocaml_414/utils/clflags.mli
index 1ee8ffa344..822d00c65a 100644
--- a/upstream/ocaml_414/utils/clflags.mli
+++ b/upstream/ocaml_414/utils/clflags.mli
@@ -98,7 +98,7 @@ val all_ppx : string list ref
 val absname : bool ref
 val annotations : bool ref
 val binary_annotations : bool ref
-val store_usage_index : bool ref
+val store_occurrences : bool ref
 val use_threads : bool ref
 val noassert : bool ref
 val verbose : bool ref

From f3a7490bd15cf24584da06641ff509214f9eae3f Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Tue, 19 Dec 2023 16:19:44 +0100
Subject: [PATCH 40/58] Import small fix from upstream

---
 upstream/ocaml_414/base-rev.txt               | 2 +-
 upstream/ocaml_414/file_formats/cmt_format.ml | 3 +++
 2 files changed, 4 insertions(+), 1 deletion(-)

diff --git a/upstream/ocaml_414/base-rev.txt b/upstream/ocaml_414/base-rev.txt
index 705276ab3b..18dfb3f240 100644
--- a/upstream/ocaml_414/base-rev.txt
+++ b/upstream/ocaml_414/base-rev.txt
@@ -1 +1 @@
-d118cdf64b1e4be9e8f5969f485f43c7bc675352
+12b1d5914b9ed5abdeb05a1a4896004ea9509208
diff --git a/upstream/ocaml_414/file_formats/cmt_format.ml b/upstream/ocaml_414/file_formats/cmt_format.ml
index 9927f7abd9..9955577bf5 100644
--- a/upstream/ocaml_414/file_formats/cmt_format.ml
+++ b/upstream/ocaml_414/file_formats/cmt_format.ml
@@ -160,6 +160,9 @@ let iter_on_occurrences
     function
     | { Types.cstr_tag = Cstr_extension (path, _); _ } ->
         f ~namespace:Extension_constructor env path lid
+    | { Types.cstr_uid = Predef name; _} ->
+        let id = List.assoc name Predef.builtin_idents in
+        f ~namespace:Constructor env (Pident id) lid
     | { Types.cstr_res; cstr_name; _ } ->
         let path = path_in_type cstr_res cstr_name in
         Option.iter (fun path -> f ~namespace:Constructor env path lid) path

From 7c338347322a7031f8d4ad8b7fe2a042eede5359 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Wed, 20 Dec 2023 13:35:12 +0100
Subject: [PATCH 41/58] Adapt typer and analysis to upstream changes

---
 src/analysis/ast_iterators.ml                 |   2 +-
 src/analysis/locate.ml                        |  33 +-
 src/analysis/locate.mli                       |   2 +
 src/analysis/misc_utils.ml                    |  23 +-
 src/analysis/misc_utils.mli                   |   3 +-
 src/analysis/occurrences.ml                   |  17 +-
 src/ocaml/typing/cmt_format.ml                | 163 +++-----
 src/ocaml/typing/cmt_format.mli               |  20 +-
 src/ocaml/typing/shape.ml                     | 329 +---------------
 src/ocaml/typing/shape.mli                    |  57 +--
 src/ocaml/typing/shape_reduce.ml              | 350 ++++++++++++++++++
 src/ocaml/typing/shape_reduce.mli             |  57 +++
 src/ocaml/typing/tast_iterator.ml             |  42 ++-
 src/ocaml/typing/tast_iterator.mli            |   1 +
 src/ocaml/typing/typeclass.ml                 |   2 +-
 src/ocaml/typing/typedecl.ml                  |  11 +-
 src/ocaml/typing/typedtree.ml                 |  21 +-
 src/ocaml/typing/typedtree.mli                |  18 +-
 src/ocaml/typing/typemod.ml                   |  33 +-
 src/ocaml/utils/clflags.ml                    |   2 +-
 src/ocaml/utils/clflags.mli                   |   2 +-
 tests/test-dirs/locate/issue1424.t            |   5 +-
 .../locate/locate-constrs-decl-def.t          |   2 +-
 .../locate/non-local/ignore-kept-locs.t/run.t |   1 -
 .../test-dirs/occurrences/occ-and-wrapping.t  |   6 +-
 25 files changed, 615 insertions(+), 587 deletions(-)
 create mode 100644 src/ocaml/typing/shape_reduce.ml
 create mode 100644 src/ocaml/typing/shape_reduce.mli

diff --git a/src/analysis/ast_iterators.ml b/src/analysis/ast_iterators.ml
index c91f1adc05..a0cb5ce0e0 100644
--- a/src/analysis/ast_iterators.ml
+++ b/src/analysis/ast_iterators.ml
@@ -45,7 +45,7 @@ let build_uid_to_locs_tbl ~(local_defs : Mtyper.typedtree) () =
   uid_to_locs_tbl
 
 let iter_on_usages ~f (local_defs : Mtyper.typedtree) =
-  let iter = Cmt_format.iter_on_usages ~f () in
+  let iter = Cmt_format.iter_on_occurrences ~f in
   begin match local_defs with
   | `Interface signature -> iter.signature iter signature
   | `Implementation structure -> iter.structure iter structure end
diff --git a/src/analysis/locate.ml b/src/analysis/locate.ml
index 303e312033..be9b542d35 100644
--- a/src/analysis/locate.ml
+++ b/src/analysis/locate.ml
@@ -535,10 +535,7 @@ let find_loc_of_comp_unit ~config uid comp_unit =
 
 let find_definition_uid ~config ~env ~(decl : Env_lookup.item) path =
   let namespace = decl.namespace in
-  let module Shape_reduce =
-    Shape.Make_reduce (struct
-      type env = Env.t
-
+  let module Reduce = Shape_reduce.Make (struct
       let fuel = 10
 
       let read_unit_shape ~unit_name =
@@ -554,15 +551,12 @@ let find_definition_uid ~config ~env ~(decl : Env_lookup.item) path =
           | Error () ->
             log ~title:"read_unit_shape" "failed to find %s" unit_name;
             None
-
-      let find_shape env id = Env.shape_of_path
-        ~namespace:Shape.Sig_component_kind.Module env (Pident id)
     end)
   in
   let shape = Env.shape_of_path ~namespace env path in
   log ~title:"shape_of_path" "initial: %a"
     Logger.fmt (Fun.flip Shape.print shape);
-  let keep_aliases =
+  let _keep_aliases =
     if config.traverse_aliases
     then (fun _ -> false)
     else (function
@@ -574,13 +568,24 @@ let find_definition_uid ~config ~env ~(decl : Env_lookup.item) path =
       false
     | _ -> true)
   in
-  let reduced = Shape_reduce.reduce_for_uid
-    ~keep_aliases env shape
+  let reduced = Reduce.reduce_for_uid env shape
   in
   log ~title:"shape_of_path" "reduced: %a"
-    Logger.fmt (fun fmt -> Shape.print_reduction_result fmt reduced);
+    Logger.fmt (fun fmt -> Shape_reduce.print_result fmt reduced);
   reduced
 
+let rec uid_of_aliases ~traverse_aliases = function
+  | [] -> assert false
+  | [ def ] -> def
+  | (Shape.Uid.Item { comp_unit; _ })
+    :: (((Compilation_unit comp_unit') :: _) as tl)
+    when let by = comp_unit ^ "__" in String.is_prefixed ~by comp_unit' ->
+      (* Always traverse dune-wrapper aliases *)
+      uid_of_aliases ~traverse_aliases tl
+  | [ alias; def ] -> if traverse_aliases then def else alias
+  | _alias :: tl when traverse_aliases -> uid_of_aliases ~traverse_aliases tl
+  | alias :: _tl -> alias
+
 (** This is the main function here *)
 let from_path ~config ~env ~local_defs ~decl path =
   let title = "from_path" in
@@ -599,11 +604,13 @@ let from_path ~config ~env ~local_defs ~decl path =
   let uid, approximated = match config.ml_or_mli with
     | `MLI -> decl.uid, false
     | `ML ->
+      let traverse_aliases = config.traverse_aliases in
       match find_definition_uid ~config ~env ~decl path with
-      | Shape.Resolved uid -> uid, false
+      | Resolved uid -> uid, false
+      | Resolved_alias aliases -> uid_of_aliases ~traverse_aliases aliases, false
       | Unresolved { uid = Some uid; desc = Comp_unit _; approximated } ->
           uid, approximated
-      | Approximated _ | Unresolved _ | Missing_uid ->
+      | Approximated _ | Unresolved _ | Internal_error_missing_uid ->
           log ~title "No definition uid, falling back to the declaration uid: %a"
             Logger.fmt (Fun.flip Shape.Uid.print decl.uid);
           decl.uid, true
diff --git a/src/analysis/locate.mli b/src/analysis/locate.mli
index 54b51dd1e1..2fb5b8f3ec 100644
--- a/src/analysis/locate.mli
+++ b/src/analysis/locate.mli
@@ -42,6 +42,8 @@ type result = {
   approximated: bool;
 }
 
+val uid_of_aliases : traverse_aliases:bool -> Shape.Uid.t list -> Shape.Uid.t
+
 val find_source
   : config: Mconfig.t
   -> Warnings.loc
diff --git a/src/analysis/misc_utils.ml b/src/analysis/misc_utils.ml
index 0d27982109..78e23d77b1 100644
--- a/src/analysis/misc_utils.ml
+++ b/src/analysis/misc_utils.ml
@@ -69,16 +69,15 @@ let loc_of_decl ~uid =
     ListLabels.find_map ~f:(fun (_, loc, _, uid') -> if uid = uid' then Some loc else None) bound_idents
   in
   function
-  | Cmt_format.Class_declaration cd -> Some cd.ci_id_name
-  | Class_description cd -> Some cd.ci_id_name
-  | Class_type_declaration ctd -> Some ctd.ci_id_name
-  | Extension_constructor ec -> Some ec.ext_name
-  | Module_binding mb -> of_option mb.mb_name
-  | Module_declaration md -> of_option md.md_name
-  | Module_type_declaration mtd -> Some mtd.mtd_name
-  | Module_substitution msd -> Some msd.ms_name;
-  | Type_declaration td -> Some td.typ_name
-  | Constructor_declaration cd -> Some cd.cd_name
-  | Label_declaration ld -> Some ld.ld_name
-  | Value_description vd -> Some vd.val_name
+  | Typedtree.Value vd -> Some vd.val_name
   | Value_binding vb -> of_value_binding vb
+  | Type td -> Some td.typ_name
+  | Constructor cd -> Some cd.cd_name
+  | Label ld -> Some ld.ld_name
+  | Module md -> of_option md.md_name
+  | Module_type mtd -> Some mtd.mtd_name
+  | Module_substitution msd -> Some msd.ms_name;
+  | Module_binding mb -> of_option mb.mb_name
+  | Class cd -> Some cd.ci_id_name
+  | Class_type ctd -> Some ctd.ci_id_name
+  | Extension_constructor ec -> Some ec.ext_name
diff --git a/src/analysis/misc_utils.mli b/src/analysis/misc_utils.mli
index 02dfd1b7a8..1df3e86826 100644
--- a/src/analysis/misc_utils.mli
+++ b/src/analysis/misc_utils.mli
@@ -24,4 +24,5 @@ end
 val parenthesize_name : string -> string
 
 (** Extracts the loc from cmt's cmt_uid_to_decl tables *)
-val loc_of_decl : uid:Shape.Uid.t -> Cmt_format.item_declaration -> string Location.loc option
+val loc_of_decl :
+  uid:Shape.Uid.t -> Typedtree.item_declaration -> string Location.loc option
diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml
index d89082d43b..f1be6f38a2 100644
--- a/src/analysis/occurrences.ml
+++ b/src/analysis/occurrences.ml
@@ -23,9 +23,7 @@ let index_buffer ~local_defs () =
   let {Logger. log} = Logger.for_section "index" in
   let defs = Hashtbl.create 64 in
   let module Shape_reduce =
-    Shape.Make_reduce (struct
-      type env = Env.t
-
+    Shape_reduce.Make (struct
       let fuel = 10
 
       let read_unit_shape ~unit_name =
@@ -38,19 +36,24 @@ let index_buffer ~local_defs () =
           | exception _ | _ ->
             log ~title:"read_unit_shape" "failed to find %s" unit_name;
             None
-
-      let find_shape env id = Env.shape_of_path
-        ~namespace:Shape.Sig_component_kind.Module env (Pident id)
     end)
   in
   let f ~namespace env path (lid : Longident.t Location.loc)  =
+    log ~title:"index_buffer" "pouet %a" Logger.fmt (Fun.flip Path.print path);
     let not_ghost { Location.loc = { loc_ghost; _ }; _ } = not loc_ghost in
     if not_ghost lid then
       match Env.shape_of_path ~namespace env path with
       | exception Not_found -> ()
       | path_shape ->
+
+    log ~title:"index_buffer" "pouet SOP %a"
+      Logger.fmt (Fun.flip Shape.print path_shape);
         begin match Shape_reduce.reduce_for_uid env path_shape with
-        | Shape.Approximated _ | Missing_uid -> ()
+        | Ocaml_typing.Shape_reduce.Approximated _
+        | Internal_error_missing_uid -> ()
+        | Resolved_alias l ->
+            let uid = Locate.uid_of_aliases ~traverse_aliases:false l in
+            Index_format.(add defs uid (LidSet.singleton lid))
         | Resolved uid ->
           log ~title:"index_buffer" "Found %s (%a) wiht uid %a"
             (Longident.head lid.txt)
diff --git a/src/ocaml/typing/cmt_format.ml b/src/ocaml/typing/cmt_format.ml
index c6b28a5724..5dacc789fc 100644
--- a/src/ocaml/typing/cmt_format.ml
+++ b/src/ocaml/typing/cmt_format.ml
@@ -61,21 +61,6 @@ and binary_part =
   | Partial_signature_item of signature_item
   | Partial_module_type of module_type
 
-type item_declaration =
-  | Class_declaration of class_declaration
-  | Class_description of class_description
-  | Class_type_declaration of class_type_declaration
-  | Constructor_declaration of constructor_declaration
-  | Extension_constructor of extension_constructor
-  | Label_declaration of label_declaration
-  | Module_binding of module_binding
-  | Module_declaration of module_declaration
-  | Module_substitution of module_substitution
-  | Module_type_declaration of module_type_declaration
-  | Type_declaration of type_declaration
-  | Value_binding of value_binding
-  | Value_description of value_description
-
 type cmt_infos = {
   cmt_modname : string;
   cmt_annots : binary_annots;
@@ -94,8 +79,8 @@ type cmt_infos = {
   cmt_uid_to_decl : item_declaration Shape.Uid.Tbl.t;
   cmt_impl_shape : Shape.t option; (* None for mli *)
   cmt_ident_occurrences :
-    (Longident.t Location.loc * Shape.reduction_result) list
-}
+    (Longident.t Location.loc * Shape_reduce.result) list
+  }
 
 type error =
     Not_a_typedtree of string
@@ -117,89 +102,28 @@ let iter_on_annots (it : Tast_iterator.iterator) = function
   | Partial_implementation array -> Array.iter (iter_on_parts it) array
   | Partial_interface array -> Array.iter (iter_on_parts it) array
 
-module Local_reduce = Shape.Make_reduce(struct
-    type env = Env.t
-    let fuel = 10
-
-    let read_unit_shape ~unit_name:_ = None
-
-    let find_shape env id =
-      let namespace = Shape.Sig_component_kind.Module in
-      Env.shape_of_path ~namespace env (Pident id)
-  end)
-
-let iter_on_declarations ~(f: Shape.Uid.t -> item_declaration -> unit) =
-  let f_lbl_decls ldecls =
-    List.iter ~f:(fun ({ ld_uid; _ } as ld) ->
-      f ld_uid (Label_declaration ld)) ldecls
-  in
-  Tast_iterator.{ default_iterator with
-
-  value_bindings = (fun sub ((_, vbs) as bindings) ->
-    let bound_idents = let_filter_bound vbs in
-    List.iter ~f:(fun (vb, uid) -> f uid (Value_binding vb)) bound_idents;
-    default_iterator.value_bindings sub bindings);
-
-  module_binding = (fun sub mb ->
-    f mb.mb_uid (Module_binding mb);
-    default_iterator.module_binding sub mb);
-
-  module_declaration = (fun sub md ->
-    f md.md_uid (Module_declaration md);
-    default_iterator.module_declaration sub md);
-
-  module_type_declaration = (fun sub mtd ->
-    f mtd.mtd_uid (Module_type_declaration mtd);
-    default_iterator.module_type_declaration sub mtd);
-
-  module_substitution = (fun sub ms ->
-    f ms.ms_uid (Module_substitution ms);
-    default_iterator.module_substitution sub ms);
-
-  value_description = (fun sub vd ->
-    f vd.val_val.val_uid (Value_description vd);
-    default_iterator.value_description sub vd);
-
-  type_declaration = (fun sub td ->
-    (* compiler-generated "row_names" share the uid of their corresponding
-       class declaration, so we ignore them to prevent duplication *)
-    if not (Btype.is_row_name (Ident.name td.typ_id)) then begin
-      f td.typ_type.type_uid (Type_declaration td);
-      (* We also register records labels and constructors *)
-      let f_lbl_decls ldecls =
-        List.iter ~f:(fun ({ ld_uid; _ } as ld) ->
-          f ld_uid (Label_declaration ld)) ldecls
-      in
-      match td.typ_kind with
-      | Ttype_variant constrs ->
-          List.iter ~f:(fun ({ cd_uid; cd_args; _ } as cd) ->
-            f cd_uid (Constructor_declaration cd);
-            match cd_args with
-            | Cstr_record ldecls -> f_lbl_decls ldecls
-            | Cstr_tuple _ -> ()) constrs
-      | Ttype_record labels -> f_lbl_decls labels
-      | _ -> ()
-    end;
-    default_iterator.type_declaration sub td);
-
-  extension_constructor = (fun sub ec ->
-    f ec.ext_type.ext_uid (Extension_constructor ec);
-    begin match ec.ext_kind with
-    | Text_decl (_, Cstr_record lbls,_) -> f_lbl_decls lbls
-    | _ -> () end;
-    default_iterator.extension_constructor sub ec);
-
-  class_declaration = (fun sub cd ->
-    f cd.ci_decl.cty_uid (Class_declaration cd);
-    default_iterator.class_declaration sub cd);
-
-  class_type_declaration = (fun sub ctd ->
-    f ctd.ci_decl.cty_uid (Class_type_declaration ctd);
-    default_iterator.class_type_declaration sub ctd);
-
-  class_description =(fun sub cd ->
-    f cd.ci_decl.cty_uid (Class_description cd);
-    default_iterator.class_description sub cd);
+let iter_on_declaration f decl =
+  match decl with
+  | Value vd -> f vd.val_val.val_uid decl;
+  | Value_binding vb ->
+      let bound_idents = let_bound_idents_full [vb] in
+      List.iter ~f:(fun (_, _, _, uid) -> f uid decl) bound_idents
+  | Type td ->
+      if not (Btype.is_row_name (Ident.name td.typ_id)) then
+        f td.typ_type.type_uid (Type td)
+  | Constructor cd -> f cd.cd_uid decl
+  | Extension_constructor ec -> f ec.ext_type.ext_uid decl;
+  | Label ld -> f ld.ld_uid decl
+  | Module md -> f md.md_uid decl
+  | Module_type mtd -> f mtd.mtd_uid decl
+  | Module_substitution ms -> f ms.ms_uid decl
+  | Module_binding mb -> f mb.mb_uid decl
+  | Class cd -> f cd.ci_decl.cty_uid decl
+  | Class_type ct -> f ct.ci_decl.cty_uid decl
+
+let iter_on_declarations ~(f: Shape.Uid.t -> item_declaration -> unit) = {
+  Tast_iterator.default_iterator with
+  item_declaration = (fun _sub decl -> iter_on_declaration f decl);
 }
 
 let need_to_clear_env =
@@ -236,7 +160,12 @@ let clear_env binary_annots =
 
   else binary_annots
 
-let iter_on_usages ~f () =
+(* Every typedtree node with a located longident corresponding to user-facing
+   syntax should be indexed. *)
+let iter_on_occurrences
+  ~(f : namespace:Shape.Sig_component_kind.t ->
+        Env.t -> Path.t -> Longident.t Location.loc ->
+        unit) =
   let path_in_type typ name =
     match Types.get_desc typ with
     | Tconstr (type_path, _, _) ->
@@ -293,6 +222,12 @@ let iter_on_usages ~f () =
             add_label exp_env lid label_descr
           | Overridden (lid, _) -> add_label exp_env lid label_descr
           | Kept _ -> ()) fields
+      | Texp_instvar  (_self_path, path, name) ->
+          let lid = { name with txt = Longident.Lident name.txt } in
+          f ~namespace:Value exp_env path lid
+      | Texp_setinstvar  (_self_path, path, name, _) ->
+          let lid = { name with txt = Longident.Lident name.txt } in
+          f ~namespace:Value exp_env path lid
       | _ -> ());
       default_iterator.expr sub e);
 
@@ -303,7 +238,10 @@ let iter_on_usages ~f () =
           f ~namespace:Type ctyp_env path lid
       | Ttyp_package {pack_path; pack_txt} ->
           f ~namespace:Module_type ctyp_env pack_path pack_txt
-      | _ -> ());
+      | Ttyp_class (path, lid, _typs) ->
+          (* Deprecated syntax to extend a polymorphic variant *)
+          f ~namespace:Type ctyp_env path lid
+      |  _ -> ());
       default_iterator.typ sub ct);
 
   pat =
@@ -333,7 +271,7 @@ let iter_on_usages ~f () =
             f ~namespace:Module pat_env path lid
         | Tpat_type (path, lid) ->
             f ~namespace:Type pat_env path lid
-        | _ -> ())
+        | Tpat_constraint _ | Tpat_unpack -> ())
         pat_extra;
       default_iterator.pat sub pat);
 
@@ -370,7 +308,7 @@ let iter_on_usages ~f () =
     (fun sub ({ cl_desc; cl_env; _} as ce) ->
       (match cl_desc with
       | Tcl_ident (path, lid, _) -> f ~namespace:Class cl_env path lid
-      | _ -> ());
+      |  _ -> ());
       default_iterator.class_expr sub ce);
 
   class_type =
@@ -401,7 +339,7 @@ let iter_on_usages ~f () =
           f ~namespace:Extension_constructor str_env path lid
       | Tstr_typext { tyext_path; tyext_txt } ->
           f ~namespace:Type str_env tyext_path tyext_txt
-      | _ -> ());
+      |  _ -> ());
       default_iterator.structure_item sub str_item)
 }
 
@@ -411,22 +349,23 @@ let index_declarations binary_annots =
   iter_on_annots (iter_on_declarations ~f) binary_annots;
   index
 
-let index_usages binary_annots =
-  let index : (Longident.t Location.loc * Shape.reduction_result) list ref =
+let index_occurrences binary_annots =
+  let index : (Longident.t Location.loc * Shape_reduce.result) list ref =
     ref []
   in
-  let f ~namespace env path lid  =
+  let f ~namespace env path lid =
     let not_ghost { Location.loc = { loc_ghost; _ }; _ } = not loc_ghost in
     if not_ghost lid then
       match Env.shape_of_path ~namespace env path with
       | exception Not_found -> ()
       | path_shape ->
-        let result = Local_reduce.reduce_for_uid env path_shape in
+        let result = Shape_reduce.local_reduce_for_uid env path_shape in
         index := (lid, result) :: !index
   in
-  iter_on_annots (iter_on_usages ~f ()) binary_annots;
+  iter_on_annots (iter_on_occurrences ~f) binary_annots;
   !index
 
+
 exception Error of error
 
 let input_cmt ic = (input_value ic : cmt_infos)
@@ -501,8 +440,8 @@ let save_cmt filename modname binary_annots sourcefile initial_env cmi shape =
            | Some cmi -> Some (output_cmi temp_file_name oc cmi)
          in
          let cmt_ident_occurrences =
-          if !Clflags.store_usage_index then
-            index_usages binary_annots
+          if !Clflags.store_occurrences then
+            index_occurrences binary_annots
           else
             []
          in
diff --git a/src/ocaml/typing/cmt_format.mli b/src/ocaml/typing/cmt_format.mli
index 1fdc59600e..7764b0d469 100644
--- a/src/ocaml/typing/cmt_format.mli
+++ b/src/ocaml/typing/cmt_format.mli
@@ -50,21 +50,6 @@ and binary_part =
   | Partial_signature_item of signature_item
   | Partial_module_type of module_type
 
-type item_declaration =
-  | Class_declaration of class_declaration
-  | Class_description of class_description
-  | Class_type_declaration of class_type_declaration
-  | Constructor_declaration of constructor_declaration
-  | Extension_constructor of extension_constructor
-  | Label_declaration of label_declaration
-  | Module_binding of module_binding
-  | Module_declaration of module_declaration
-  | Module_substitution of module_substitution
-  | Module_type_declaration of module_type_declaration
-  | Type_declaration of type_declaration
-  | Value_binding of value_binding
-  | Value_description of value_description
-
 type cmt_infos = {
   cmt_modname : modname;
   cmt_annots : binary_annots;
@@ -83,7 +68,7 @@ type cmt_infos = {
   cmt_uid_to_decl : item_declaration Shape.Uid.Tbl.t;
   cmt_impl_shape : Shape.t option; (* None for mli *)
   cmt_ident_occurrences :
-    (Longident.t Location.loc * Shape.reduction_result) list
+    (Longident.t Location.loc * Shape_reduce.result) list
 }
 
 type error =
@@ -145,11 +130,10 @@ val iter_on_declarations :
   f:(Types.Uid.t -> item_declaration -> unit)
   -> Tast_iterator.iterator
 
-val iter_on_usages :
+val iter_on_occurrences :
   f:(namespace:Shape.Sig_component_kind.t ->
     Env.t ->
     Path.t ->
     Longident.t Location.loc ->
     unit)
-  -> unit
   -> Tast_iterator.iterator
diff --git a/src/ocaml/typing/shape.ml b/src/ocaml/typing/shape.ml
index d3f85e971c..6248d83ff1 100644
--- a/src/ocaml/typing/shape.ml
+++ b/src/ocaml/typing/shape.ml
@@ -201,6 +201,10 @@ let print fmt t =
   else
     Format.fprintf fmt "@[%a@]@;" aux t
 
+let rec strip_head_aliases = function
+  | { desc = Alias t; _ } -> strip_head_aliases t
+  | t -> t
+
 let fresh_var ?(name="shape-var") uid =
   let var = Ident.create_local name in
   var, { uid = Some uid; desc = Var var; approximated = false }
@@ -245,331 +249,6 @@ let decompose_abs t =
   | Abs (x, t) -> Some (x, t)
   | _ -> None
 
-type reduction_result =
-  | Resolved of Uid.t
-  | Unresolved of t
-  | Approximated of Uid.t option
-  | Missing_uid
-
-let print_reduction_result fmt result =
-  match result with
-  | Resolved uid ->
-      Format.fprintf fmt "@[Resolved: %a@]@;" Uid.print uid
-  | Unresolved shape ->
-      Format.fprintf fmt "@[Unresolved: %a@]@;" print shape
-  | Approximated (Some uid) ->
-      Format.fprintf fmt "@[Approximated: %a@]@;" Uid.print uid
-  | Approximated None ->
-      Format.fprintf fmt "@[Approximated: No uid@]@;"
-  | Missing_uid ->
-      Format.fprintf fmt "@[Missing uid@]@;"
-
-module Make_reduce(Params : sig
-  type env
-  val fuel : int
-  val read_unit_shape : unit_name:string -> t option
-  val find_shape : env -> Ident.t -> t
-end) = struct
-  (* We implement a strong call-by-need reduction, following an
-     evaluator from Nathanaelle Courant. *)
-
-  type nf = { uid: Uid.t option; desc: nf_desc; approximated: bool }
-  and nf_desc =
-    | NVar of var
-    | NApp of nf * nf
-    | NAbs of local_env * var * t * delayed_nf
-    | NStruct of delayed_nf Item.Map.t
-    | NAlias of nf
-    | NProj of nf * Item.t
-    | NLeaf
-    | NComp_unit of string
-    | NError of string
-  (* A type of normal forms for strong call-by-need evaluation.
-     The normal form of an abstraction
-       Abs(x, t)
-     is a closure
-       NAbs(env, x, t, dnf)
-     when [env] is the local environment, and [dnf] is a delayed
-     normal form of [t].
-
-     A "delayed normal form" is morally equivalent to (nf Lazy.t), but
-     we use a different representation that is compatible with
-     memoization (lazy values are not hashable/comparable by default
-     comparison functions): we represent a delayed normal form as
-     just a not-yet-computed pair [local_env * t] of a term in a
-     local environment -- we could also see this as a term under
-     an explicit substitution. This delayed thunked is "forced"
-     by calling the normalization function as usual, but duplicate
-     computations are precisely avoided by memoization.
-   *)
-  and thunk = { local_env : local_env; shape: t }
-  and delayed_nf = Thunk of thunk
-
-  and local_env = delayed_nf option Ident.Map.t
-  (* When reducing in the body of an abstraction [Abs(x, body)], we
-     bind [x] to [None] in the environment. [Some v] is used for
-     actual substitutions, for example in [App(Abs(x, body), t)], when
-     [v] is a thunk that will evaluate to the normal form of [t]. *)
-
-  let improve_uid uid (nf : nf) =
-    match nf.uid with
-    | Some _ -> nf
-    | None -> { nf with uid }
-
-  let in_memo_table memo_table memo_key f arg =
-    match Hashtbl.find memo_table memo_key with
-    | res -> res
-    | exception Not_found ->
-        let res = f arg in
-        Hashtbl.replace memo_table memo_key res;
-        res
-
-  let rec strip_head_aliases nf = match nf.desc with
-    | NAlias nf -> strip_head_aliases nf
-    | _ -> nf
-
-  type env = {
-    fuel: int ref;
-    keep_aliases: t -> bool;
-    global_env: Params.env;
-    local_env: local_env;
-    reduce_memo_table: (thunk, nf) Hashtbl.t;
-    read_back_memo_table: (nf, t) Hashtbl.t;
-  }
-
-  let bind env var shape =
-    { env with local_env = Ident.Map.add var shape env.local_env }
-
-  let rec reduce_ env t =
-    let local_env = env.local_env in
-    let memo_key = { local_env; shape = t } in
-    in_memo_table
-      env.reduce_memo_table memo_key
-      (reduce__ env) t
-  (* Memoization is absolutely essential for performance on this
-     problem, because the normal forms we build can in some real-world
-     cases contain an exponential amount of redundancy. Memoization
-     can avoid the repeated evaluation of identical subterms,
-     providing a large speedup, but even more importantly it
-     implicitly shares the memory of the repeated results, providing
-     much smaller normal forms (that blow up again if printed back
-     as trees). A functor-heavy file from Irmin has its shape normal
-     form decrease from 100Mio to 2.5Mio when memoization is enabled.
-
-     Note: the local environment is part of the memoization key, while
-     it is defined using a type Ident.Map.t of non-canonical balanced
-     trees: two maps could have exactly the same items, but be
-     balanced differently and therefore hash differently, reducing
-     the effectivenss of memoization.
-     This could in theory happen, say, with the two programs
-       (fun x -> fun y -> ...)
-     and
-       (fun y -> fun x -> ...)
-     having "the same" local environments, with additions done in
-     a different order, giving non-structurally-equal trees. Should we
-     define our own hash functions to provide robust hashing on
-     environments?
-
-     We believe that the answer is "no": this problem does not occur
-     in practice. We can assume that identifiers are unique on valid
-     typedtree fragments (identifier "stamps" distinguish
-     binding positions); in particular the two program fragments above
-     in fact bind *distinct* identifiers x (with different stamps) and
-     different identifiers y, so the environments are distinct. If two
-     environments are structurally the same, they must correspond to
-     the evaluation evnrionments of two sub-terms that are under
-     exactly the same scope of binders. So the two environments were
-     obtained by the same term traversal, adding binders in the same
-     order, giving the same balanced trees: the environments have the
-     same hash.
-*)
-
-  and reduce__
-    ({fuel; global_env; local_env; _} as env) (t : t) =
-    let reduce env t =
-      reduce_ env t
-    in
-    let delay_reduce { local_env; _ } t =
-      Thunk { local_env; shape = t }
-    in
-    let force (Thunk { local_env; shape = t }) =
-      reduce { env with local_env } t in
-    let return ?(approximated = t.approximated) desc : nf =
-      { uid = t.uid; desc; approximated }
-    in
-    if !fuel < 0 then return ~approximated:true (NError "NoFuelLeft")
-    else
-      match t.desc with
-      | Comp_unit unit_name ->
-          begin match Params.read_unit_shape ~unit_name with
-          | Some t -> reduce env t
-          | None -> return (NComp_unit unit_name)
-          end
-      | App(f, arg) ->
-          let f = reduce env f |> strip_head_aliases in
-          begin match f.desc with
-          | NAbs(clos_env, var, body, _body_nf) ->
-              let arg = delay_reduce env arg in
-              let env = bind { env with local_env = clos_env } var (Some arg) in
-              { (reduce env body) with uid = t.uid }
-          | _ ->
-              let arg = reduce env arg in
-              return (NApp(f, arg))
-          end
-      | Proj(str, item) ->
-          let str = reduce env str |> strip_head_aliases in
-          let nored () = return (NProj(str, item)) in
-          begin match str.desc with
-          | NStruct (items) ->
-              begin match Item.Map.find item items with
-              | exception Not_found -> nored ()
-              | nf ->
-                  force nf
-                  |> improve_uid t.uid
-              end
-          | _ ->
-              nored ()
-          end
-      | Abs(var, body) ->
-          let body_nf = delay_reduce (bind env var None) body in
-          return (NAbs(local_env, var, body, body_nf))
-      | Var id ->
-          begin match Ident.Map.find id local_env with
-          (* Note: instead of binding abstraction-bound variables to
-             [None], we could unify it with the [Some v] case by
-             binding the bound variable [x] to [NVar x].
-
-             One reason to distinguish the situations is that we can
-             provide a different [Uid.t] location; for bound
-             variables, we use the [Uid.t] of the bound occurrence
-             (not the binding site), whereas for bound values we use
-             their binding-time [Uid.t]. *)
-          | None -> return (NVar id)
-          | Some def -> force def
-          | exception Not_found ->
-          match Params.find_shape global_env id with
-          | exception Not_found -> return (NVar id)
-          | res when res = t -> return (NVar id)
-          | res ->
-              decr fuel;
-              reduce env res
-          end
-      | Leaf -> return NLeaf
-      | Struct m ->
-          let mnf = Item.Map.map (delay_reduce env) m in
-          return (NStruct mnf)
-      | Alias aliased_t ->
-        let nf = reduce env aliased_t in
-        if env.keep_aliases t then
-          return (NAlias nf)
-        else nf
-      | Error s -> return ~approximated:true (NError s)
-
-  and read_back env (nf : nf) : t =
-    in_memo_table env.read_back_memo_table nf (read_back_ env) nf
-  (* The [nf] normal form we receive may contain a lot of internal
-     sharing due to the use of memoization in the evaluator. We have
-     to memoize here again, otherwise the sharing is lost by mapping
-     over the term as a tree. *)
-
-  and read_back_ env (nf : nf) : t =
-    { uid = nf.uid;
-      desc = read_back_desc env nf.desc;
-      approximated = nf.approximated }
-
-  and read_back_desc env desc =
-    let read_back nf = read_back env nf in
-    let read_back_force (Thunk { local_env; shape = t }) =
-      read_back (reduce_ { env with local_env } t) in
-    match desc with
-    | NVar v ->
-        Var v
-    | NApp (nft, nfu) ->
-        App(read_back nft, read_back nfu)
-    | NAbs (_env, x, _t, nf) ->
-        Abs(x, read_back_force nf)
-    | NStruct nstr ->
-        Struct (Item.Map.map read_back_force nstr)
-    | NAlias nf -> Alias (read_back nf)
-    | NProj (nf, item) ->
-        Proj (read_back nf, item)
-    | NLeaf -> Leaf
-    | NComp_unit s -> Comp_unit s
-    | NError s -> Error s
-
-  (* Sharing the memo tables is safe at the level of a compilation unit since
-    idents should be unique *)
-  let reduce_memo_table = Hashtbl.create 42
-  let read_back_memo_table = Hashtbl.create 42
-
-  let reduce ?(keep_aliases = fun _ -> true) global_env t =
-    let fuel = ref Params.fuel in
-    let local_env = Ident.Map.empty in
-    let env = {
-      fuel;
-      keep_aliases;
-      global_env;
-      reduce_memo_table;
-      read_back_memo_table;
-      local_env;
-    } in
-    reduce_ env t |> read_back env
-
-  let rec is_stuck_on_comp_unit (nf : nf) =
-    match nf.desc with
-    | NVar _ ->
-      (* This should not happen if we only reduce closed terms *)
-      false
-    | NApp (nf, _) | NProj (nf, _) | NAlias nf -> is_stuck_on_comp_unit nf
-    | NStruct _ | NAbs _ -> false
-    | NComp_unit _ -> true
-    | NError _ -> false
-    | NLeaf -> false
-
-  let reduce_for_uid ?(keep_aliases = fun _ -> true) global_env t =
-    let fuel = ref Params.fuel in
-    let local_env = Ident.Map.empty in
-    let env = {
-      fuel;
-      keep_aliases;
-      global_env;
-      reduce_memo_table;
-      read_back_memo_table;
-      local_env;
-    } in
-    let nf = reduce_ env t in
-    if is_stuck_on_comp_unit nf then
-      Unresolved (read_back env nf)
-    else match nf with
-      | { uid = Some uid; approximated = false; _ } ->
-          Resolved uid
-      | { uid; approximated = true; _ } ->
-          Approximated uid
-      | { uid = None; approximated = false; _ } ->
-          (* A missing Uid after a complete reduction means the Uid was first
-             missing in the shape which is a code error. Having the
-             [Missing_uid] reported will allow Merlin (or another tool working
-             with the index) to ask users to report the issue if it does happen.
-          *)
-          Missing_uid
-end
-
-module Toplevel_local_reduce =
-  (* Note: this definition with [type env = unit] is only suitable for
-     reduction of toplevel shapes -- shapes of compilation units,
-     where free variables are only Comp_unit names. If we wanted to
-     reduce shapes inside module signatures, we would need to take
-     a typing environment as parameter. *)
-  Make_reduce(struct
-    type env = unit
-    let fuel = 10
-    let read_unit_shape ~unit_name:_ = None
-    let find_shape _env _id = raise Not_found
-  end)
-
-let toplevel_local_reduce shape =
-  Toplevel_local_reduce.reduce () shape
-
 let dummy_mod =
   { uid = None; desc = Struct Item.Map.empty; approximated = false }
 
diff --git a/src/ocaml/typing/shape.mli b/src/ocaml/typing/shape.mli
index 45e98170f9..31f9176a47 100644
--- a/src/ocaml/typing/shape.mli
+++ b/src/ocaml/typing/shape.mli
@@ -26,7 +26,7 @@
     - Build the Shape corresponding to the value's path:
       [let shape = Env.shape_of_path ~namespace env path]
 
-    - Instantiate the [Make_reduce] functor with a way to load shapes from
+    - Instantiate the [Shape_reduce.Make] functor with a way to load shapes from
       external units and to looks for shapes in the environment (usually using
       [Env.shape_of_path]).
 
@@ -40,7 +40,7 @@
       for example when hitting first-class modules.
 
     - The location of the definition can be easily found with the
-      [cmt_format.cmt_uid_to_decl] talbe of the corresponding compilation unit.
+      [cmt_format.cmt_uid_to_decl] table of the corresponding compilation unit.
 
   See:
   - {{: https://icfp22.sigplan.org/details/mlfamilyworkshop-2022-papers/10/Module-Shapes-for-Modern-Tooling }
@@ -49,6 +49,12 @@
     a talk about the reduction strategy
 *)
 
+(** A [Uid.t] is associated with every declaration in signatures and
+    implementations, they uniquely identify bindings in the program.
+    When associated with these bindings' locations they are useful to
+    external tools when trying to jump to the declaration of
+    definitions of identifiers. They are stored to that effect in the
+    [uid_to_decl] table of cmt files. *)
 module Uid : sig
   type t = private
     | Compilation_unit of string
@@ -88,7 +94,8 @@ module Sig_component_kind : sig
   val can_appear_in_types : t -> bool
 end
 
-(** Shape's items are elements of a structure modeling module components. *)
+(** Shape's items are elements of a structure. These structures models module
+    components and nested types' constructors and labels *)
 module Item : sig
   type t = string * Sig_component_kind.t
   val name : t -> string
@@ -124,16 +131,10 @@ and desc =
   | Comp_unit of string
   | Error of string
 
-type reduction_result =
-  | Resolved of Uid.t
-  | Unresolved of t
-  | Approximated of Uid.t option
-  | Missing_uid
-
-val print_reduction_result : Format.formatter -> reduction_result -> unit
-
 val print : Format.formatter -> t -> unit
 
+val strip_head_aliases : t -> t
+
 (* Smart constructors *)
 
 val for_unnamed_functor_param : var
@@ -199,37 +200,3 @@ val of_path :
   namespace:Sig_component_kind.t -> Path.t -> t
 
 val set_uid_if_none : t -> Uid.t -> t
-
-(** The [Make_reduce] functor is used to generate a reduction function for
-    shapes.
-
-    It is parametrized by:
-    - an environment and a function to find shapes by path in that environment
-    - a function to load the shape of an external compilation unit
-    - some fuel, which is used to bound recursion when dealing with recursive
-      shapes introduced by recursive modules. (FTR: merlin currently uses a
-      fuel of 10, which seems to be enough for most practical examples)
-*)
-module Make_reduce(Context : sig
-    type env
-
-    val fuel : int
-
-    val read_unit_shape : unit_name:string -> t option
-
-    val find_shape : env -> Ident.t -> t
-  end) : sig
-  val reduce :
-    ?keep_aliases:(t -> bool) -> Context.env -> t -> t
-
-  (** Perform weak reduction and return the head's uid if any. If reduction was
-    incomplete the partially reduced shape is returned. *)
-  val reduce_for_uid :
-    ?keep_aliases:(t -> bool) -> Context.env -> t -> reduction_result
-end
-
-(** [toplevel_local_reduce] is only suitable to reduce toplevel shapes (shapes
-  of compilation units). Use the [Make_reduce] functor for other cases that
-  require access to the environment.*)
-val toplevel_local_reduce : t -> t
-
diff --git a/src/ocaml/typing/shape_reduce.ml b/src/ocaml/typing/shape_reduce.ml
new file mode 100644
index 0000000000..fd18b81f27
--- /dev/null
+++ b/src/ocaml/typing/shape_reduce.ml
@@ -0,0 +1,350 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                Ulysse Gérard, Thomas Refis, Tarides                    *)
+(*                                                                        *)
+(*   Copyright 2021 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Shape
+
+type result =
+  | Resolved of Uid.t
+  | Resolved_alias of Uid.t list
+  | Unresolved of t
+  | Approximated of Uid.t option
+  | Internal_error_missing_uid
+
+let print_result fmt result =
+  match result with
+  | Resolved uid ->
+      Format.fprintf fmt "@[Resolved: %a@]@;" Uid.print uid
+  | Resolved_alias uids ->
+      Format.fprintf fmt "@[Resolved_alias: %a@]@;"
+        Format.(pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt "@ -> ")
+        Uid.print) uids
+  | Unresolved shape ->
+      Format.fprintf fmt "@[Unresolved: %a@]@;" print shape
+  | Approximated (Some uid) ->
+      Format.fprintf fmt "@[Approximated: %a@]@;" Uid.print uid
+  | Approximated None ->
+      Format.fprintf fmt "@[Approximated: No uid@]@;"
+  | Internal_error_missing_uid ->
+      Format.fprintf fmt "@[Missing uid@]@;"
+
+
+let find_shape env id =
+  let namespace = Shape.Sig_component_kind.Module in
+  Env.shape_of_path ~namespace env (Pident id)
+
+module Make(Params : sig
+  val fuel : int
+  val read_unit_shape : unit_name:string -> t option
+end) = struct
+  (* We implement a strong call-by-need reduction, following an
+     evaluator from Nathanaelle Courant. *)
+
+  type nf = { uid: Uid.t option; desc: nf_desc; approximated: bool }
+  and nf_desc =
+    | NVar of var
+    | NApp of nf * nf
+    | NAbs of local_env * var * t * delayed_nf
+    | NStruct of delayed_nf Item.Map.t
+    | NAlias of delayed_nf
+    | NProj of nf * Item.t
+    | NLeaf
+    | NComp_unit of string
+    | NError of string
+
+  (* A type of normal forms for strong call-by-need evaluation.
+     The normal form of an abstraction
+       Abs(x, t)
+     is a closure
+       NAbs(env, x, t, dnf)
+     when [env] is the local environment, and [dnf] is a delayed
+     normal form of [t].
+
+     A "delayed normal form" is morally equivalent to (nf Lazy.t), but
+     we use a different representation that is compatible with
+     memoization (lazy values are not hashable/comparable by default
+     comparison functions): we represent a delayed normal form as
+     just a not-yet-computed pair [local_env * t] of a term in a
+     local environment -- we could also see this as a term under
+     an explicit substitution. This delayed thunked is "forced"
+     by calling the normalization function as usual, but duplicate
+     computations are precisely avoided by memoization.
+   *)
+  and delayed_nf = Thunk of local_env * t
+
+  and local_env = delayed_nf option Ident.Map.t
+  (* When reducing in the body of an abstraction [Abs(x, body)], we
+     bind [x] to [None] in the environment. [Some v] is used for
+     actual substitutions, for example in [App(Abs(x, body), t)], when
+     [v] is a thunk that will evaluate to the normal form of [t]. *)
+
+  let approx_nf nf = { nf with approximated = true }
+
+  let in_memo_table memo_table memo_key f arg =
+    match Hashtbl.find memo_table memo_key with
+    | res -> res
+    | exception Not_found ->
+        let res = f arg in
+        Hashtbl.replace memo_table memo_key res;
+        res
+
+  type env = {
+    fuel: int ref;
+    global_env: Env.t;
+    local_env: local_env;
+    reduce_memo_table: (local_env * t, nf) Hashtbl.t;
+    read_back_memo_table: (nf, t) Hashtbl.t;
+  }
+
+  let bind env var shape =
+    { env with local_env = Ident.Map.add var shape env.local_env }
+
+  let rec reduce_ env t =
+    let local_env = env.local_env in
+    let memo_key = (local_env, t) in
+    in_memo_table env.reduce_memo_table memo_key (reduce__ env) t
+  (* Memoization is absolutely essential for performance on this
+     problem, because the normal forms we build can in some real-world
+     cases contain an exponential amount of redundancy. Memoization
+     can avoid the repeated evaluation of identical subterms,
+     providing a large speedup, but even more importantly it
+     implicitly shares the memory of the repeated results, providing
+     much smaller normal forms (that blow up again if printed back
+     as trees). A functor-heavy file from Irmin has its shape normal
+     form decrease from 100Mio to 2.5Mio when memoization is enabled.
+
+     Note: the local environment is part of the memoization key, while
+     it is defined using a type Ident.Map.t of non-canonical balanced
+     trees: two maps could have exactly the same items, but be
+     balanced differently and therefore hash differently, reducing
+     the effectivenss of memoization.
+     This could in theory happen, say, with the two programs
+       (fun x -> fun y -> ...)
+     and
+       (fun y -> fun x -> ...)
+     having "the same" local environments, with additions done in
+     a different order, giving non-structurally-equal trees. Should we
+     define our own hash functions to provide robust hashing on
+     environments?
+
+     We believe that the answer is "no": this problem does not occur
+     in practice. We can assume that identifiers are unique on valid
+     typedtree fragments (identifier "stamps" distinguish
+     binding positions); in particular the two program fragments above
+     in fact bind *distinct* identifiers x (with different stamps) and
+     different identifiers y, so the environments are distinct. If two
+     environments are structurally the same, they must correspond to
+     the evaluation evnrionments of two sub-terms that are under
+     exactly the same scope of binders. So the two environments were
+     obtained by the same term traversal, adding binders in the same
+     order, giving the same balanced trees: the environments have the
+     same hash.
+*)
+
+  and reduce__
+    ({fuel; global_env; local_env; _} as env) (t : t) =
+    let reduce env t = reduce_ env t in
+    let delay_reduce env t = Thunk (env.local_env, t) in
+    let force (Thunk (local_env, t)) = reduce { env with local_env } t in
+    let return desc = { uid = t.uid; desc; approximated = t.approximated } in
+    let rec force_aliases nf = match nf.desc with
+      | NAlias delayed_nf ->
+          let nf = force delayed_nf in
+          force_aliases nf
+      | _ -> nf
+    in
+    let reset_uid_if_new_binding t' =
+      match t.uid with
+      | None -> t'
+      | Some _ as uid -> { t' with uid }
+    in
+    if !fuel < 0 then approx_nf (return (NError "NoFuelLeft"))
+    else
+      match t.desc with
+      | Comp_unit unit_name ->
+          begin match Params.read_unit_shape ~unit_name with
+          | Some t -> reduce env t
+          | None -> return (NComp_unit unit_name)
+          end
+      | App(f, arg) ->
+          let f = reduce env f |> force_aliases in
+          begin match f.desc with
+          | NAbs(clos_env, var, body, _body_nf) ->
+              let arg = delay_reduce env arg in
+              let env = bind { env with local_env = clos_env } var (Some arg) in
+              reduce env body |> reset_uid_if_new_binding
+          | _ ->
+              let arg = reduce env arg in
+              return (NApp(f, arg))
+          end
+      | Proj(str, item) ->
+          let str = reduce env str |> force_aliases in
+          let nored () = return (NProj(str, item)) in
+          begin match str.desc with
+          | NStruct (items) ->
+              begin match Item.Map.find item items with
+              | exception Not_found -> nored ()
+              | nf -> force nf |> reset_uid_if_new_binding
+              end
+          | _ ->
+              nored ()
+          end
+      | Abs(var, body) ->
+          let body_nf = delay_reduce (bind env var None) body in
+          return (NAbs(local_env, var, body, body_nf))
+      | Var id ->
+          begin match Ident.Map.find id local_env with
+          (* Note: instead of binding abstraction-bound variables to
+             [None], we could unify it with the [Some v] case by
+             binding the bound variable [x] to [NVar x].
+
+             One reason to distinguish the situations is that we can
+             provide a different [Uid.t] location; for bound
+             variables, we use the [Uid.t] of the bound occurrence
+             (not the binding site), whereas for bound values we use
+             their binding-time [Uid.t]. *)
+          | None -> return (NVar id)
+          | Some def ->
+              begin match force def with
+              | { uid = Some _; _  } as nf -> nf
+                  (* This var already has a binding uid *)
+              | { uid = None; _ } as nf -> { nf with uid = t.uid }
+                  (* Set the var's binding uid *)
+              end
+          | exception Not_found ->
+          match find_shape global_env id with
+          | exception Not_found -> return (NVar id)
+          | res when res = t -> return (NVar id)
+          | res ->
+              decr fuel;
+              reduce env res
+          end
+      | Leaf -> return NLeaf
+      | Struct m ->
+          let mnf = Item.Map.map (delay_reduce env) m in
+          return (NStruct mnf)
+      | Alias t -> return (NAlias (delay_reduce env t))
+      | Error s -> approx_nf (return (NError s))
+
+  and read_back env (nf : nf) : t =
+    in_memo_table env.read_back_memo_table nf (read_back_ env) nf
+  (* The [nf] normal form we receive may contain a lot of internal
+     sharing due to the use of memoization in the evaluator. We have
+     to memoize here again, otherwise the sharing is lost by mapping
+     over the term as a tree. *)
+
+  and read_back_ env (nf : nf) : t =
+    { uid = nf.uid ;
+      desc = read_back_desc env nf.desc;
+      approximated = nf.approximated }
+
+  and read_back_desc env desc =
+    let read_back nf = read_back env nf in
+    let read_back_force (Thunk (local_env, t)) =
+      read_back (reduce_ { env with local_env } t) in
+    match desc with
+    | NVar v ->
+        Var v
+    | NApp (nft, nfu) ->
+        App(read_back nft, read_back nfu)
+    | NAbs (_env, x, _t, nf) ->
+        Abs(x, read_back_force nf)
+    | NStruct nstr ->
+        Struct (Item.Map.map read_back_force nstr)
+    | NAlias nf -> Alias (read_back_force nf)
+    | NProj (nf, item) ->
+        Proj (read_back nf, item)
+    | NLeaf -> Leaf
+    | NComp_unit s -> Comp_unit s
+    | NError s -> Error s
+
+  (* Sharing the memo tables is safe at the level of a compilation unit since
+    idents should be unique *)
+  let reduce_memo_table = Hashtbl.create 42
+  let read_back_memo_table = Hashtbl.create 42
+
+  let reduce global_env t =
+    let fuel = ref Params.fuel in
+    let local_env = Ident.Map.empty in
+    let env = {
+      fuel;
+      global_env;
+      reduce_memo_table;
+      read_back_memo_table;
+      local_env;
+    } in
+    reduce_ env t |> read_back env
+
+  let rec is_stuck_on_comp_unit (nf : nf) =
+    match nf.desc with
+    | NVar _ ->
+        (* This should not happen if we only reduce closed terms *)
+        false
+    | NApp (nf, _) | NProj (nf, _) -> is_stuck_on_comp_unit nf
+    | NStruct _ | NAbs _ -> false
+    | NAlias _ -> false
+    | NComp_unit _ -> true
+    | NError _ -> false
+    | NLeaf -> false
+
+  let get_aliases_uids (t : t) =
+    let rec aux acc (t : t) = match t with
+      | { uid = Some uid; desc = Alias t; _ } -> aux (uid::acc) t
+      | { uid = Some uid; _ } -> Resolved_alias (List.rev (uid::acc))
+      | _ -> Internal_error_missing_uid
+    in
+    aux [] t
+
+  let reduce_for_uid global_env t =
+    let fuel = ref Params.fuel in
+    let local_env = Ident.Map.empty in
+    let env = {
+      fuel;
+      global_env;
+      reduce_memo_table;
+      read_back_memo_table;
+      local_env;
+    } in
+    let nf = reduce_ env t in
+    if is_stuck_on_comp_unit nf then
+      Unresolved (read_back env nf)
+    else match nf with
+      | { desc = NAlias _; approximated = false; _ } ->
+          get_aliases_uids (read_back env nf)
+      | { uid = Some uid; approximated = false; _ } ->
+          Resolved uid
+      | { uid; approximated = true; _ } ->
+          Approximated uid
+      | { uid = None; approximated = false; _ } ->
+          (* A missing Uid after a complete reduction means the Uid was first
+             missing in the shape which is a code error. Having the
+             [Missing_uid] reported will allow Merlin (or another tool working
+             with the index) to ask users to report the issue if it does happen.
+          *)
+          Internal_error_missing_uid
+end
+
+module Local_reduce =
+  (* Note: this definition with [type env = unit] is only suitable for
+     reduction of toplevel shapes -- shapes of compilation units,
+     where free variables are only Comp_unit names. If we wanted to
+     reduce shapes inside module signatures, we would need to take
+     a typing environment as parameter. *)
+  Make(struct
+    let fuel = 10
+    let read_unit_shape ~unit_name:_ = None
+  end)
+
+let local_reduce = Local_reduce.reduce
+let local_reduce_for_uid = Local_reduce.reduce_for_uid
diff --git a/src/ocaml/typing/shape_reduce.mli b/src/ocaml/typing/shape_reduce.mli
new file mode 100644
index 0000000000..6156207ad6
--- /dev/null
+++ b/src/ocaml/typing/shape_reduce.mli
@@ -0,0 +1,57 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                Ulysse Gérard, Thomas Refis, Tarides                    *)
+(*                                                                        *)
+(*   Copyright 2021 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+open Shape
+
+(** The result of reducing a shape and looking for its uid *)
+type result =
+  | Resolved of Uid.t (** Shape reduction succeeded and a uid was found *)
+  | Resolved_alias of Uid.t list (** Reduction led to an alias chain *)
+  | Unresolved of t (** Result still contains [Comp_unit] terms *)
+  | Approximated of Uid.t option
+    (** Reduction failed: it can arrive with first-clsss modules for example *)
+  | Internal_error_missing_uid
+    (** Reduction succeeded but no uid was found, this should never happen *)
+
+val print_result : Format.formatter -> result -> unit
+
+(** The [Make] functor is used to generate a reduction function for
+    shapes.
+
+    It is parametrized by:
+    - a function to load the shape of an external compilation unit
+    - some fuel, which is used to bound recursion when dealing with recursive
+      shapes introduced by recursive modules. (FTR: merlin currently uses a
+      fuel of 10, which seems to be enough for most practical examples)
+*)
+module Make(_ : sig
+    val fuel : int
+
+    val read_unit_shape : unit_name:string -> t option
+  end) : sig
+  val reduce : Env.t -> t -> t
+
+  (** Perform weak reduction and return the head's uid if any. If reduction was
+    incomplete the partially reduced shape is returned. *)
+  val reduce_for_uid : Env.t -> t -> result
+end
+
+(** [local_reduce] will not reduce shapes that require loading external
+  compilation units. *)
+val local_reduce : Env.t -> t -> t
+
+(** [local_reduce_for_uid] will not reduce shapes that require loading external
+  compilation units. *)
+val local_reduce_for_uid : Env.t -> t -> result
diff --git a/src/ocaml/typing/tast_iterator.ml b/src/ocaml/typing/tast_iterator.ml
index 7e2e3a1978..3ac8513008 100644
--- a/src/ocaml/typing/tast_iterator.ml
+++ b/src/ocaml/typing/tast_iterator.ml
@@ -59,6 +59,7 @@ type iterator =
     value_bindings: iterator -> (rec_flag * value_binding list) -> unit;
     value_description: iterator -> value_description -> unit;
     with_constraint: iterator -> with_constraint -> unit;
+    item_declaration: iterator -> item_declaration -> unit;
   }
 
 let structure sub {str_items; str_final_env; _} =
@@ -69,19 +70,25 @@ let class_infos sub f x =
   List.iter (fun (ct, _) -> sub.typ sub ct) x.ci_params;
   f x.ci_expr
 
-let module_type_declaration sub {mtd_type; _} =
+let module_type_declaration sub ({mtd_type; _} as x) =
+  sub.item_declaration sub (Module_type x);
   Option.iter (sub.module_type sub) mtd_type
 
-let module_declaration sub {md_type; _} =
+let module_declaration sub ({md_type; _} as md) =
+  sub.item_declaration sub (Module md);
   sub.module_type sub md_type
-let module_substitution _ _ = ()
+
+let module_substitution sub ms =
+  sub.item_declaration sub (Module_substitution ms)
 
 let include_infos f {incl_mod; _} = f incl_mod
 
 let class_type_declaration sub x =
+  sub.item_declaration sub (Class_type x);
   class_infos sub (sub.class_type sub) x
 
 let class_declaration sub x =
+  sub.item_declaration sub (Class x);
   class_infos sub (sub.class_expr sub) x
 
 let structure_item sub {str_desc; str_env; _} =
@@ -104,15 +111,20 @@ let structure_item sub {str_desc; str_env; _} =
   | Tstr_open od -> sub.open_declaration sub od
   | Tstr_attribute _ -> ()
 
-let value_description sub x = sub.typ sub x.val_desc
+let value_description sub x =
+  sub.item_declaration sub (Value x);
+  sub.typ sub x.val_desc
 
-let label_decl sub {ld_type; _} = sub.typ sub ld_type
+let label_decl sub ({ld_type; _} as ld) =
+  sub.item_declaration sub (Label ld);
+  sub.typ sub ld_type
 
 let constructor_args sub = function
   | Cstr_tuple l -> List.iter (sub.typ sub) l
   | Cstr_record l -> List.iter (label_decl sub) l
 
-let constructor_decl sub {cd_args; cd_res; _} =
+let constructor_decl sub ({cd_args; cd_res; _} as x) =
+  sub.item_declaration sub (Constructor x);
   constructor_args sub cd_args;
   Option.iter (sub.typ sub) cd_res
 
@@ -122,7 +134,9 @@ let type_kind sub = function
   | Ttype_record list -> List.iter (label_decl sub) list
   | Ttype_open -> ()
 
-let type_declaration sub {typ_cstrs; typ_kind; typ_manifest; typ_params; _} =
+let type_declaration
+  sub ({typ_cstrs; typ_kind; typ_manifest; typ_params; _} as x) =
+  sub.item_declaration sub (Type x);
   List.iter
     (fun (c1, c2, _) ->
       sub.typ sub c1;
@@ -141,7 +155,8 @@ let type_extension sub {tyext_constructors; tyext_params; _} =
 let type_exception sub {tyexn_constructor; _} =
   sub.extension_constructor sub tyexn_constructor
 
-let extension_constructor sub {ext_kind; _} =
+let extension_constructor sub ({ext_kind; _} as ec) =
+  sub.item_declaration sub (Extension_constructor ec);
   match ext_kind with
   | Text_decl (_, ctl, cto) ->
       constructor_args sub ctl;
@@ -293,6 +308,7 @@ let signature_item sub {sig_desc; sig_env; _} =
   | Tsig_attribute _ -> ()
 
 let class_description sub x =
+  sub.item_declaration sub (Class_type x);
   class_infos sub (sub.class_type sub) x
 
 let functor_parameter sub = function
@@ -362,7 +378,9 @@ let module_expr sub {mod_desc; mod_env; _} =
       sub.module_coercion sub c
   | Tmod_unpack (exp, _) -> sub.expr sub exp
 
-let module_binding sub {mb_expr; _} = sub.module_expr sub mb_expr
+let module_binding sub ({mb_expr; _} as mb) =
+  sub.item_declaration sub (Module_binding mb);
+  sub.module_expr sub mb_expr
 
 let class_expr sub {cl_desc; cl_env; _} =
   sub.env sub cl_env;
@@ -465,12 +483,15 @@ let case sub {c_lhs; c_guard; c_rhs} =
   Option.iter (sub.expr sub) c_guard;
   sub.expr sub c_rhs
 
-let value_binding sub {vb_pat; vb_expr; _} =
+let value_binding sub ({vb_pat; vb_expr; _} as vb) =
+  sub.item_declaration sub (Value_binding vb);
   sub.pat sub vb_pat;
   sub.expr sub vb_expr
 
 let env _sub _ = ()
 
+let item_declaration _sub _ = ()
+
 let default_iterator =
   {
     binding_op;
@@ -514,4 +535,5 @@ let default_iterator =
     value_bindings;
     value_description;
     with_constraint;
+    item_declaration;
   }
diff --git a/src/ocaml/typing/tast_iterator.mli b/src/ocaml/typing/tast_iterator.mli
index e126128edf..5e6d3b6c72 100644
--- a/src/ocaml/typing/tast_iterator.mli
+++ b/src/ocaml/typing/tast_iterator.mli
@@ -63,6 +63,7 @@ type iterator =
     value_bindings: iterator -> (rec_flag * value_binding list) -> unit;
     value_description: iterator -> value_description -> unit;
     with_constraint: iterator -> with_constraint -> unit;
+    item_declaration: iterator -> item_declaration -> unit;
   }
 
 val default_iterator: iterator
diff --git a/src/ocaml/typing/typeclass.ml b/src/ocaml/typing/typeclass.ml
index d951a00002..787f82c2dd 100644
--- a/src/ocaml/typing/typeclass.ml
+++ b/src/ocaml/typing/typeclass.ml
@@ -1952,7 +1952,7 @@ let approx_class_declarations env sdecls =
 
 open Format
 
-let non_virtual_string_of_kind = function
+let non_virtual_string_of_kind : kind -> string = function
   | Object -> "object"
   | Class -> "non-virtual class"
   | Class_type -> "non-virtual class type"
diff --git a/src/ocaml/typing/typedecl.ml b/src/ocaml/typing/typedecl.ml
index f7582b7801..504637a427 100644
--- a/src/ocaml/typing/typedecl.ml
+++ b/src/ocaml/typing/typedecl.ml
@@ -510,12 +510,15 @@ let transl_declaration env sdecl (id, uid) =
       }
     in
     let typ_shape =
+      let uid = decl.typ_type.type_uid in
       let map = match decl.typ_kind with
-        | Ttype_variant cstrs -> shape_map_cstrs cstrs
-        | Ttype_record labels -> shape_map_labels labels
-        | _ -> Shape.Map.empty
+        | Ttype_variant cstrs -> Some (shape_map_cstrs cstrs)
+        | Ttype_record labels -> Some (shape_map_labels labels)
+        | Ttype_abstract | Ttype_open -> None
       in
-      Shape.str ~uid:decl.typ_type.type_uid map
+      Option.map (Shape.str ~uid) map
+      (* Abstract types are just leafs *)
+      |> Option.value ~default:(Shape.leaf uid)
     in
     decl, typ_shape
 
diff --git a/src/ocaml/typing/typedtree.ml b/src/ocaml/typing/typedtree.ml
index 6090907043..2c270b0f61 100644
--- a/src/ocaml/typing/typedtree.ml
+++ b/src/ocaml/typing/typedtree.ml
@@ -638,6 +638,19 @@ type implementation = {
   shape: Shape.t;
 }
 
+type item_declaration =
+  | Value of value_description
+  | Value_binding of value_binding
+  | Type of type_declaration
+  | Constructor of constructor_declaration
+  | Extension_constructor of extension_constructor
+  | Label of label_declaration
+  | Module of module_declaration
+  | Module_substitution of module_substitution
+  | Module_binding of module_binding
+  | Module_type of module_type_declaration
+  | Class of class_declaration
+  | Class_type of class_type_declaration
 
 (* Auxiliary functions over the a.s.t. *)
 
@@ -804,14 +817,6 @@ let let_bound_idents_full bindings =
 let let_bound_idents pat =
   rev_only_idents (rev_let_bound_idents_full pat)
 
-let let_filter_bound bindings =
-  let decls = ref [] in
-  let add vb (_,_,_,uid) =
-    decls := (vb, uid) :: !decls
-  in
-  List.iter (fun vb -> iter_bound_idents (add vb) vb.vb_pat) bindings;
-  !decls
-
 let alpha_var env id = List.assoc id env
 
 let rec alpha_pat
diff --git a/src/ocaml/typing/typedtree.mli b/src/ocaml/typing/typedtree.mli
index 5793afdd54..e6e1324fd8 100644
--- a/src/ocaml/typing/typedtree.mli
+++ b/src/ocaml/typing/typedtree.mli
@@ -793,6 +793,23 @@ type implementation = {
     structure.
 *)
 
+type item_declaration =
+| Value of value_description
+| Value_binding of value_binding
+| Type of type_declaration
+| Constructor of constructor_declaration
+| Extension_constructor of extension_constructor
+| Label of label_declaration
+| Module of module_declaration
+| Module_substitution of module_substitution
+| Module_binding of module_binding
+| Module_type of module_type_declaration
+| Class of class_declaration
+| Class_type of class_type_declaration
+(** [item_declaration] groups together items that correspond to the syntactic
+  category of "declarations" which include types, values, modules, etc.
+  declarations in signatures and their definitions in implementations. *)
+
 (* Auxiliary functions over the a.s.t. *)
 
 (** [as_computation_pattern p] is a computation pattern with description
@@ -825,7 +842,6 @@ val let_bound_idents: value_binding list -> Ident.t list
 val let_bound_idents_full:
     value_binding list ->
     (Ident.t * string loc * Types.type_expr * Types.Uid.t) list
-val let_filter_bound: value_binding list ->  (value_binding * Uid.t) list
 
 
 (** Alpha conversion of patterns *)
diff --git a/src/ocaml/typing/typemod.ml b/src/ocaml/typing/typemod.ml
index 8727c9e956..612edf380e 100644
--- a/src/ocaml/typing/typemod.ml
+++ b/src/ocaml/typing/typemod.ml
@@ -2259,6 +2259,7 @@ and type_module_aux ~alias sttn funct_body anchor env smod =
       let shape =
         Env.shape_of_path ~namespace:Shape.Sig_component_kind.Module env path
       in
+      let shape = if alias && aliasable then Shape.alias shape else shape in
       let md =
         if alias && aliasable then
           (Env.add_required_global (Path.head path); md)
@@ -2710,11 +2711,7 @@ and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body ancho
             md_uid;
           }
         in
-        let md_shape =
-          match modl.mod_type with
-          | Mty_alias _path -> Shape.alias ~uid:md_uid md_shape
-          | _ -> Shape.set_uid_if_none md_shape md_uid
-        in
+        let md_shape = Shape.set_uid_if_none md_shape md_uid in
         (*prerr_endline (Ident.unique_toplevel_name id);*)
         Mtype.lower_nongen outer_scope md.md_type;
         let id, newenv, sg =
@@ -2855,12 +2852,11 @@ and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body ancho
             Signature_names.check_type names loc cls.cls_obj_id;
             Signature_names.check_type names loc cls.cls_typesharp_id;
             let uid = cls.cls_decl.cty_uid in
-            let map f id acc = f acc id uid in
-            let map_t f id acc = f acc id (Shape.str ~uid Shape.Map.empty) in
-            map Shape.Map.add_class cls.cls_id acc
-            |> map Shape.Map.add_class_type cls.cls_ty_id
-            |> map_t Shape.Map.add_type cls.cls_obj_id
-            |> map_t Shape.Map.add_type cls.cls_typesharp_id
+            let map f id v acc = f acc id v in
+            map Shape.Map.add_class cls.cls_id uid acc
+            |> map Shape.Map.add_class_type cls.cls_ty_id uid
+            |> map Shape.Map.add_type cls.cls_obj_id (Shape.leaf uid)
+            |> map Shape.Map.add_type cls.cls_typesharp_id (Shape.leaf uid)
           ) shape_map classes
         in
         Tstr_class
@@ -2888,11 +2884,10 @@ and type_structure ?(toplevel = false) ?(keep_warnings = false) funct_body ancho
             Signature_names.check_type names loc decl.clsty_obj_id;
             Signature_names.check_type names loc decl.clsty_typesharp_id;
             let uid = decl.clsty_ty_decl.clty_uid in
-            let map_t f id acc = f acc id (Shape.str ~uid Shape.Map.empty) in
-            let map f id acc = f acc id uid in
-            map Shape.Map.add_class_type decl.clsty_ty_id acc
-            |> map_t Shape.Map.add_type decl.clsty_obj_id
-            |> map_t Shape.Map.add_type decl.clsty_typesharp_id
+            let map f id v acc = f acc id v in
+            map Shape.Map.add_class_type decl.clsty_ty_id uid acc
+            |> map Shape.Map.add_type decl.clsty_obj_id (Shape.leaf uid)
+            |> map Shape.Map.add_type decl.clsty_typesharp_id (Shape.leaf uid)
           ) shape_map classes
         in
         Tstr_class_type
@@ -3166,7 +3161,7 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
       let simple_sg = Signature_names.simplify finalenv names sg in
       if !Clflags.print_types then begin
         Typecore.force_delayed_checks ();
-        let shape = Shape.toplevel_local_reduce shape in
+        let shape = Shape_reduce.local_reduce Env.empty shape in
         Printtyp.wrap_printing_env ~error:false initial_env
           (fun () -> fprintf std_formatter "%a@."
               (Printtyp.printed_signature sourcefile) simple_sg
@@ -3195,7 +3190,7 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
           (* It is important to run these checks after the inclusion test above,
              so that value declarations which are not used internally but
              exported are not reported as being unused. *)
-          let shape = Shape.toplevel_local_reduce shape in
+          let shape = Shape_reduce.local_reduce Env.empty shape in
           let annots = Cmt_format.Implementation str in
           Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename
             annots (Some sourcefile) initial_env None (Some shape);
@@ -3218,7 +3213,7 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
              the value being exported. We can still capture unused
              declarations like "let x = true;; let x = 1;;", because in this
              case, the inferred signature contains only the last declaration. *)
-          let shape = Shape.toplevel_local_reduce shape in
+          let shape = Shape_reduce.local_reduce Env.empty shape in
           if not !Clflags.dont_write_files then begin
             let alerts = Builtin_attributes.alerts_of_str ast in
             let cmi =
diff --git a/src/ocaml/utils/clflags.ml b/src/ocaml/utils/clflags.ml
index ab73106101..ed727351d0 100644
--- a/src/ocaml/utils/clflags.ml
+++ b/src/ocaml/utils/clflags.ml
@@ -25,7 +25,7 @@ let open_modules        = ref []
 
 let annotations         = ref false
 let binary_annotations  = ref true
-let store_usage_index   = ref true
+let store_occurrences   = ref true
 let print_types         = ref false
 let native_code         = ref false
 let error_size          = ref 500
diff --git a/src/ocaml/utils/clflags.mli b/src/ocaml/utils/clflags.mli
index f26746c1ea..de4666e087 100644
--- a/src/ocaml/utils/clflags.mli
+++ b/src/ocaml/utils/clflags.mli
@@ -23,7 +23,7 @@ val open_modules         : string list ref
     Ignored by merlin but kept for compatibility with upstream code. *)
 val annotations          : bool ref
 val binary_annotations   : bool ref
-val store_usage_index    : bool ref
+val store_occurrences    : bool ref
 val print_types          : bool ref
 val native_code          : bool ref
 val dont_write_files     : bool ref
diff --git a/tests/test-dirs/locate/issue1424.t b/tests/test-dirs/locate/issue1424.t
index 23b3d039c1..8b76a45332 100644
--- a/tests/test-dirs/locate/issue1424.t
+++ b/tests/test-dirs/locate/issue1424.t
@@ -18,7 +18,7 @@
   > val foo : int
   > EOF
 
-  $ dune build
+  $ dune build @check
 
 Jump to interface:
   $ $MERLIN single locate -look-for mli -position 1:16 \
@@ -32,11 +32,10 @@ Jump to interface:
   }
 
 Jump to definition:
-FIXME: it should jump to the ml file
   $ $MERLIN single locate -look-for ml -position 1:16 \
   > -filename test.ml <test.ml | jq '.value'
   {
-    "file": "$TESTCASE_ROOT/test2.mli",
+    "file": "$TESTCASE_ROOT/test2.ml",
     "pos": {
       "line": 1,
       "col": 4
diff --git a/tests/test-dirs/locate/locate-constrs-decl-def.t b/tests/test-dirs/locate/locate-constrs-decl-def.t
index 8ec3fbaaa1..00dd7b9730 100644
--- a/tests/test-dirs/locate/locate-constrs-decl-def.t
+++ b/tests/test-dirs/locate/locate-constrs-decl-def.t
@@ -18,7 +18,7 @@
   > let bar : Constr.u = { Constr.label_a = 42 }
   > EOF
 
-  $ $OCAMLC -c -bin-annot -store-usage-index constr.mli constr.ml
+  $ $OCAMLC -c -bin-annot -bin-annot-occurrences constr.mli constr.ml
 
   $ $MERLIN single locate -look-for mli -position 1:28 \
   > -filename ./main.ml < ./main.ml | jq '.value'
diff --git a/tests/test-dirs/locate/non-local/ignore-kept-locs.t/run.t b/tests/test-dirs/locate/non-local/ignore-kept-locs.t/run.t
index b0ffbc5283..2f257adbfa 100644
--- a/tests/test-dirs/locate/non-local/ignore-kept-locs.t/run.t
+++ b/tests/test-dirs/locate/non-local/ignore-kept-locs.t/run.t
@@ -71,7 +71,6 @@ In the absence of cmt though, fallbacking to the cmi loc makes sense:
   > grep -v -e from_path -e find_loc_of_uid
   No definition uid, falling back to the declaration uid: A.0
   Loading the cmt file for unit "A"
-  --
   Failed to load the cmt file
   Falling back to the declaration's location: File "a.ml", line 1, characters 4-9
 
diff --git a/tests/test-dirs/occurrences/occ-and-wrapping.t b/tests/test-dirs/occurrences/occ-and-wrapping.t
index efe2dc2f9f..db142bc091 100644
--- a/tests/test-dirs/occurrences/occ-and-wrapping.t
+++ b/tests/test-dirs/occurrences/occ-and-wrapping.t
@@ -30,7 +30,7 @@
   >  (libraries lib))
   > EOF
 
-  $ dune build @uideps @all 
+  $ dune build @ocaml-index @all 
 
   $ ocaml-index dump _build/default/project.ocaml-index
   7 uids:
@@ -43,9 +43,9 @@
    uid: Lib.0; locs:
      "Wrapped_module": File "$TESTCASE_ROOT/lib/lib.ml-gen", line 4, characters 7-21
    uid: Lib__Wrapped_module.0; locs:
+     "Wrapped_module.x": File "$TESTCASE_ROOT/main.ml", line 2, characters 19-35;
      "x": File "$TESTCASE_ROOT/lib/wrapped_module.ml", line 1, characters 4-5;
-     "x": File "$TESTCASE_ROOT/lib/wrapped_module.ml", line 2, characters 11-12;
-     "Wrapped_module.x": File "$TESTCASE_ROOT/main.ml", line 2, characters 19-35
+     "x": File "$TESTCASE_ROOT/lib/wrapped_module.ml", line 2, characters 11-12
    uid: Lib; locs:
      "Lib": File "$TESTCASE_ROOT/main.ml", line 1, characters 5-8
    uid: Lib__Wrapped_module.1; locs:

From 714a91e95d09bf786283e99103158739ec7d4d9d Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Wed, 20 Dec 2023 13:43:35 +0100
Subject: [PATCH 42/58] tests: add more locate/occurrences tests

---
 tests/test-dirs/locate/f-alias.t          |  44 ++++++
 tests/test-dirs/locate/f-def-alias.t      |  26 ++++
 tests/test-dirs/occurrences/cross-files.t | 155 ++++++++++++++++++++++
 3 files changed, 225 insertions(+)
 create mode 100644 tests/test-dirs/locate/f-alias.t
 create mode 100644 tests/test-dirs/locate/f-def-alias.t
 create mode 100644 tests/test-dirs/occurrences/cross-files.t

diff --git a/tests/test-dirs/locate/f-alias.t b/tests/test-dirs/locate/f-alias.t
new file mode 100644
index 0000000000..8cc301cd0d
--- /dev/null
+++ b/tests/test-dirs/locate/f-alias.t
@@ -0,0 +1,44 @@
+  $ cat >main.ml <<'EOF'
+  > module Id(X : sig end) = X
+  > module F (X :sig end ) : 
+  > sig module M : sig end end = 
+  > struct module M = X end
+  > module N = struct end
+  > module Z = F(Id(N))
+  > 
+  > include Z.M
+  > EOF
+
+  $ $MERLIN single locate -look-for ml -position 8:11 \
+  > -filename main.ml <main.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/main.ml",
+      "pos": {
+        "line": 5,
+        "col": 7
+      }
+    },
+    "notifications": []
+  }
+
+  $ cat >main.ml <<'EOF'
+  > module M = struct end
+  > module N = M
+  > module O = N
+  > EOF
+
+  $ $MERLIN single locate -look-for ml -position 3:11 \
+  > -filename main.ml <main.ml
+  {
+    "class": "return",
+    "value": {
+      "file": "$TESTCASE_ROOT/main.ml",
+      "pos": {
+        "line": 1,
+        "col": 7
+      }
+    },
+    "notifications": []
+  }
diff --git a/tests/test-dirs/locate/f-def-alias.t b/tests/test-dirs/locate/f-def-alias.t
new file mode 100644
index 0000000000..757a9d3d38
--- /dev/null
+++ b/tests/test-dirs/locate/f-def-alias.t
@@ -0,0 +1,26 @@
+  $ cat >main.ml <<'EOF'
+  > module M : sig
+  >   module F (X : sig end) : sig end
+  > end = struct
+  >   module F (X : sig end) = X
+  > end
+  > module X = struct end
+  > module N = M.F (X)
+  > 
+  > include N
+  > EOF
+
+  $ $MERLIN single locate -look-for ml -position 9:8 \
+  > -filename ./main.ml < ./main.ml | jq '.value'
+  {
+    "file": "$TESTCASE_ROOT/main.ml",
+    "pos": {
+      "line": 7,
+      "col": 7
+    }
+  }
+
+  $ $MERLIN single occurrences -identifier-at 9:8 \
+  > -filename ./main.ml < ./main.ml | jq '.value' | grep line | uniq
+        "line": 7,
+        "line": 9,
diff --git a/tests/test-dirs/occurrences/cross-files.t b/tests/test-dirs/occurrences/cross-files.t
new file mode 100644
index 0000000000..4e1b55f0a9
--- /dev/null
+++ b/tests/test-dirs/occurrences/cross-files.t
@@ -0,0 +1,155 @@
+  $ cat >lib.ml <<'EOF'
+  > let something_fun () = print_string "fun";;
+  > let g = something_fun
+  > EOF
+
+  $ cat >main.ml <<'EOF'
+  > let () = Lib.something_fun ()
+  > EOF
+
+  $ $OCAMLC -c -bin-annot -bin-annot-occurrences - lib.ml main.ml
+  $ ocaml-index aggregate lib.cmt main.cmt -o project.index
+
+  $ cat >.merlin <<'EOF'
+  > INDEX_FILE project.index
+  > B .
+  > EOF
+
+FIXME: remove duplicates
+  $ $MERLIN single occurrences -scope project -identifier-at 1:16 \
+  > -filename main.ml <main.ml | jq '.value'
+  [
+    {
+      "file": "$TESTCASE_ROOT/lib.ml",
+      "start": {
+        "line": 1,
+        "col": 4
+      },
+      "end": {
+        "line": 1,
+        "col": 17
+      }
+    },
+    {
+      "file": "$TESTCASE_ROOT/main.ml",
+      "start": {
+        "line": 1,
+        "col": 13
+      },
+      "end": {
+        "line": 1,
+        "col": 26
+      }
+    },
+    {
+      "file": "$TESTCASE_ROOT/lib.ml",
+      "start": {
+        "line": 2,
+        "col": 8
+      },
+      "end": {
+        "line": 2,
+        "col": 21
+      }
+    }
+  ]
+
+FIXME: remove duplicates
+  $ $MERLIN single occurrences -scope project -identifier-at 2:15 \
+  > -filename lib.ml <lib.ml | jq '.value'
+  [
+    {
+      "file": "$TESTCASE_ROOT/lib.ml",
+      "start": {
+        "line": 1,
+        "col": 4
+      },
+      "end": {
+        "line": 1,
+        "col": 17
+      }
+    },
+    {
+      "file": "$TESTCASE_ROOT/lib.ml",
+      "start": {
+        "line": 1,
+        "col": 4
+      },
+      "end": {
+        "line": 1,
+        "col": 17
+      }
+    },
+    {
+      "file": "$TESTCASE_ROOT/main.ml",
+      "start": {
+        "line": 1,
+        "col": 13
+      },
+      "end": {
+        "line": 1,
+        "col": 26
+      }
+    },
+    {
+      "file": "$TESTCASE_ROOT/lib.ml",
+      "start": {
+        "line": 2,
+        "col": 8
+      },
+      "end": {
+        "line": 2,
+        "col": 21
+      }
+    }
+  ]
+
+FIXME: remove duplicates
+  $ $MERLIN single occurrences -scope project -identifier-at 1:10 \
+  > -filename lib.ml <lib.ml | jq '.value'
+  [
+    {
+      "file": "$TESTCASE_ROOT/lib.ml",
+      "start": {
+        "line": 1,
+        "col": 4
+      },
+      "end": {
+        "line": 1,
+        "col": 17
+      }
+    },
+    {
+      "file": "$TESTCASE_ROOT/lib.ml",
+      "start": {
+        "line": 1,
+        "col": 4
+      },
+      "end": {
+        "line": 1,
+        "col": 17
+      }
+    },
+    {
+      "file": "$TESTCASE_ROOT/main.ml",
+      "start": {
+        "line": 1,
+        "col": 13
+      },
+      "end": {
+        "line": 1,
+        "col": 26
+      }
+    },
+    {
+      "file": "$TESTCASE_ROOT/lib.ml",
+      "start": {
+        "line": 2,
+        "col": 8
+      },
+      "end": {
+        "line": 2,
+        "col": 21
+      }
+    }
+  ]

From e3b0a00ebb5b8705975b405fe33d163f7d59c7ec Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Thu, 21 Dec 2023 11:22:52 +0100
Subject: [PATCH 43/58] uid reset: correctly prune usage tables

This commit take advantage of the Stamped_hashtable datastructure introduced in 147f0c3
---
 src/kernel/mtyper.ml                          |   2 +
 src/ocaml/typing/env.ml                       | 122 +++++++++++-------
 src/ocaml/typing/env.mli                      |   1 +
 src/ocaml/typing/shape.ml                     |   4 +
 src/ocaml/typing/shape.mli                    |   1 +
 src/utils/stamped_hashtable.ml                |   8 ++
 src/utils/stamped_hashtable.mli               |   7 +
 .../server-tests/warnings/backtrack.t         |  40 ++++++
 8 files changed, 140 insertions(+), 45 deletions(-)

diff --git a/src/kernel/mtyper.ml b/src/kernel/mtyper.ml
index 2bcbc2b306..593fa7335b 100644
--- a/src/kernel/mtyper.ml
+++ b/src/kernel/mtyper.ml
@@ -131,6 +131,7 @@ let type_implementation config caught parsetree =
   Btype.backtrack snap';
   Warnings.restore warn';
   Env.cleanup_functor_caches ~stamp:stamp';
+  Env.cleanup_usage_tables ~stamp:uid';
   Shape.Uid.restore_stamp uid';
   let suffix = type_structure caught env' parsetree in
   return_and_cache
@@ -154,6 +155,7 @@ let type_interface config caught parsetree =
   Btype.backtrack snap';
   Warnings.restore warn';
   Env.cleanup_functor_caches ~stamp:stamp';
+  Env.cleanup_usage_tables ~stamp:uid';
   Shape.Uid.restore_stamp uid';
   let suffix = type_signature caught env' parsetree in
   return_and_cache
diff --git a/src/ocaml/typing/env.ml b/src/ocaml/typing/env.ml
index 98e8f962ac..997213e2f8 100644
--- a/src/ocaml/typing/env.ml
+++ b/src/ocaml/typing/env.ml
@@ -28,7 +28,7 @@ module String = Misc.String
 
 let add_delayed_check_forward = ref (fun _ -> assert false)
 
-type 'a usage_tbl = ('a -> unit) Types.Uid.Tbl.t
+type 'a usage_tbl = (Uid.t, ('a -> unit)) Stamped_hashtable.t
 (** This table is used to track usage of value declarations.
     A declaration is identified by its uid.
     The callback attached to a declaration is called whenever the value (or
@@ -36,9 +36,30 @@ type 'a usage_tbl = ('a -> unit) Types.Uid.Tbl.t
     (inclusion test between signatures, cf Includemod.value_descriptions, ...).
 *)
 
-let value_declarations  : unit usage_tbl ref = s_table Types.Uid.Tbl.create 16
-let type_declarations   : unit usage_tbl ref = s_table Types.Uid.Tbl.create 16
-let module_declarations : unit usage_tbl ref = s_table Types.Uid.Tbl.create 16
+let local_stamped n : Stamped_hashtable.changelog * ('a usage_tbl) =
+  let changelog = Stamped_hashtable.create_changelog () in
+  changelog, Stamped_hashtable.create changelog n
+
+let stamped_value_declarations = s_table local_stamped 32
+let value_declarations_changelog, value_declarations = !stamped_value_declarations
+
+let stamped_type_declarations = s_table local_stamped 32
+let type_declarations_changelog, type_declarations = !stamped_type_declarations
+
+let stamped_module_declarations = s_table local_stamped 32
+let module_declarations_changelog, module_declarations = !stamped_module_declarations
+
+(* let prune_usage_tables ~stamp =
+  (* We remove *)
+  let prune tbl =
+    Types.Uid.Tbl.filter_map_inplace
+      (fun uid value ->
+        if Shape.Uid.is_more_recent ~stamp uid then None else Some value)
+      tbl
+  in
+  prune !value_declarations;
+  prune !type_declarations;
+  prune !module_declarations *)
 
 type constructor_usage = Positive | Pattern | Exported_private | Exported
 type constructor_usages =
@@ -74,8 +95,8 @@ let constructor_usage_complaint ~rebind priv cu
       | false, false, true -> Some Only_exported_private
     end
 
-let used_constructors : constructor_usage usage_tbl ref =
-  s_table Types.Uid.Tbl.create 16
+let stamped_used_constructors = s_table local_stamped 32
+let used_constructors_changelog, used_constructors = !stamped_used_constructors
 
 type label_usage =
     Projection | Mutation | Construct | Exported_private | Exported
@@ -124,8 +145,8 @@ let label_usage_complaint priv mut lu
       | true, false, _ -> Some Not_mutated
     end
 
-let used_labels : label_usage usage_tbl ref =
-  s_table Types.Uid.Tbl.create 16
+let stamped_used_labels = s_table local_stamped 32
+let used_labels_changelog, used_labels = !stamped_used_labels
 
 (** Map indexed by the name of module components. *)
 module NameMap = String.Map
@@ -492,7 +513,7 @@ let in_signature_flag = 0x01
 let stamped_changelog =
   s_table Stamped_hashtable.create_changelog ()
 
-let stamped_add table path value =
+let stamped_path_add table path value =
   let rec path_stamp = function
     | Pident id -> Ident.stamp id
     | Pdot (t, _) -> path_stamp t
@@ -502,11 +523,15 @@ let stamped_add table path value =
   let stamp = if stamp = 0 then None else Some stamp in
   Stamped_hashtable.add table ?stamp path value
 
-let stamped_mem table path =
-  Stamped_hashtable.mem table path
+let stamped_uid_add table uid value =
+  let stamp = Types.Uid.stamp_of_uid uid in
+  Stamped_hashtable.add table ?stamp uid value
 
-let stamped_find table path =
-  Stamped_hashtable.find table path
+let stamped_mem table value =
+  Stamped_hashtable.mem table value
+
+let stamped_find table value =
+  Stamped_hashtable.find table value
 
 let stamped_create n =
   Stamped_hashtable.create !stamped_changelog n
@@ -983,11 +1008,11 @@ let register_import_as_opaque modname =
   Persistent_env.register_import_as_opaque !persistent_env modname
 
 let reset_declaration_caches () =
-  Types.Uid.Tbl.clear !value_declarations;
-  Types.Uid.Tbl.clear !type_declarations;
-  Types.Uid.Tbl.clear !module_declarations;
-  Types.Uid.Tbl.clear !used_constructors;
-  Types.Uid.Tbl.clear !used_labels;
+  Stamped_hashtable.clear value_declarations;
+  Stamped_hashtable.clear type_declarations;
+  Stamped_hashtable.clear module_declarations;
+  Stamped_hashtable.clear used_constructors;
+  Stamped_hashtable.clear used_labels;
   ()
 
 let reset_cache () =
@@ -1034,7 +1059,7 @@ let modtype_of_functor_appl fcomp p1 p2 =
           in
           Subst.modtype (Rescope scope) subst mty
         in
-        stamped_add fcomp.fcomp_subst_cache p2 mty;
+        stamped_path_add fcomp.fcomp_subst_cache p2 mty;
         mty
 
 let check_functor_appl
@@ -1983,9 +2008,9 @@ and check_usage loc id uid warn tbl =
      Warnings.is_active (warn "")
   then begin
     let name = Ident.name id in
-    if Types.Uid.Tbl.mem tbl uid then ()
+    if stamped_mem tbl uid then ()
     else let used = ref false in
-    Types.Uid.Tbl.add tbl uid (fun () -> used := true);
+      stamped_uid_add tbl uid (fun () -> used := true);
     if not (name = "" || name.[0] = '_' || name.[0] = '#')
     then
       !add_delayed_check_forward
@@ -2005,7 +2030,7 @@ and check_value_name name loc =
 and store_value ?check id addr decl shape env =
   check_value_name (Ident.name id) decl.val_loc;
   Option.iter
-    (fun f -> check_usage decl.val_loc id decl.val_uid f !value_declarations)
+    (fun f -> check_usage decl.val_loc id decl.val_uid f value_declarations)
     check;
   let vda =
     { vda_description = decl;
@@ -2025,9 +2050,9 @@ and store_constructor ~check type_decl type_id cstr_id cstr env =
     let loc = cstr.cstr_loc in
     let k = cstr.cstr_uid in
     let priv = type_decl.type_private in
-    if not (Types.Uid.Tbl.mem !used_constructors k) then begin
+    if not (stamped_mem used_constructors k) then begin
       let used = constructor_usages () in
-      Types.Uid.Tbl.add !used_constructors k
+      stamped_uid_add used_constructors k
         (add_constructor_usage used);
       if not (ty_name = "" || ty_name.[0] = '_')
       then
@@ -2058,9 +2083,9 @@ and store_label ~check type_decl type_id lbl_id lbl env =
     let loc = lbl.lbl_loc in
     let mut = lbl.lbl_mut in
     let k = lbl.lbl_uid in
-    if not (Types.Uid.Tbl.mem !used_labels k) then
+    if not (stamped_mem used_labels k) then
       let used = label_usages () in
-      Types.Uid.Tbl.add !used_labels k
+      stamped_uid_add used_labels k
         (add_label_usage used);
       if not (ty_name = "" || ty_name.[0] = '_' || name.[0] = '_')
       then !add_delayed_check_forward
@@ -2081,7 +2106,7 @@ and store_type ~check ~long_path ~predef id info shape env =
   if check then
     check_usage loc id info.type_uid
       (fun s -> Warnings.Unused_type_declaration s)
-      !type_declarations;
+      type_declarations;
   let descrs, env =
     let path = Pident id in
     match info.type_kind with
@@ -2151,9 +2176,9 @@ and store_extension ~check ~rebind id addr ext shape env =
     let is_exception = Path.same ext.ext_type_path Predef.path_exn in
     let name = cstr.cstr_name in
     let k = cstr.cstr_uid in
-    if not (Types.Uid.Tbl.mem !used_constructors k) then begin
+    if not (stamped_mem used_constructors k) then begin
       let used = constructor_usages () in
-      Types.Uid.Tbl.add !used_constructors k
+      stamped_uid_add used_constructors k
         (add_constructor_usage used);
       !add_delayed_check_forward
          (fun () ->
@@ -2175,7 +2200,7 @@ and store_module ?(update_summary=true) ~check
   let open Subst.Lazy in
   let loc = md.mdl_loc in
   Option.iter
-    (fun f -> check_usage loc id md.mdl_uid f !module_declarations) check;
+    (fun f -> check_usage loc id md.mdl_uid f module_declarations) check;
   let alerts = Builtin_attributes.alerts_of_attrs md.mdl_attributes in
   let comps =
     components_of_module ~alerts ~uid:md.mdl_uid
@@ -2257,7 +2282,7 @@ let components_of_functor_appl ~loc ~f_path ~f_comp ~arg env =
         (*???*)
         env Subst.identity p addr (Subst.Lazy.of_modtype mty) shape
     in
-    stamped_add f_comp.fcomp_cache arg comps;
+    stamped_path_add f_comp.fcomp_cache arg comps;
     comps
 
 (* Define forward functions *)
@@ -2712,19 +2737,19 @@ let add_type ~check ?shape id info env =
 (* Tracking usage *)
 
 let mark_module_used uid =
-  match Types.Uid.Tbl.find !module_declarations uid with
+  match Stamped_hashtable.find module_declarations uid with
   | mark -> mark ()
   | exception Not_found -> ()
 
 let mark_modtype_used _uid = ()
 
 let mark_value_used uid =
-  match Types.Uid.Tbl.find !value_declarations uid with
+  match Stamped_hashtable.find value_declarations uid with
   | mark -> mark ()
   | exception Not_found -> ()
 
 let mark_type_used uid =
-  match Types.Uid.Tbl.find !type_declarations uid with
+  match Stamped_hashtable.find type_declarations uid with
   | mark -> mark ()
   | exception Not_found -> ()
 
@@ -2734,24 +2759,24 @@ let mark_type_path_used env path =
   | exception Not_found -> ()
 
 let mark_constructor_used usage cd =
-  match Types.Uid.Tbl.find !used_constructors cd.cd_uid with
+  match stamped_find used_constructors cd.cd_uid with
   | mark -> mark usage
   | exception Not_found -> ()
 
 let mark_extension_used usage ext =
-  match Types.Uid.Tbl.find !used_constructors ext.ext_uid with
+  match stamped_find used_constructors ext.ext_uid with
   | mark -> mark usage
   | exception Not_found -> ()
 
 let mark_label_used usage ld =
-  match Types.Uid.Tbl.find !used_labels ld.ld_uid with
+  match stamped_find used_labels ld.ld_uid with
   | mark -> mark usage
   | exception Not_found -> ()
 
 let mark_constructor_description_used usage env cstr =
   let ty_path = Btype.cstr_type_path cstr in
   mark_type_path_used env ty_path;
-  match Types.Uid.Tbl.find !used_constructors cstr.cstr_uid with
+  match stamped_find used_constructors cstr.cstr_uid with
   | mark -> mark usage
   | exception Not_found -> ()
 
@@ -2762,30 +2787,30 @@ let mark_label_description_used usage env lbl =
     | _ -> assert false
   in
   mark_type_path_used env ty_path;
-  match Types.Uid.Tbl.find !used_labels lbl.lbl_uid with
+  match stamped_find used_labels lbl.lbl_uid with
   | mark -> mark usage
   | exception Not_found -> ()
 
 let mark_class_used uid =
-  match Types.Uid.Tbl.find !type_declarations uid with
+  match stamped_find type_declarations uid with
   | mark -> mark ()
   | exception Not_found -> ()
 
 let mark_cltype_used uid =
-  match Types.Uid.Tbl.find !type_declarations uid with
+  match stamped_find type_declarations uid with
   | mark -> mark ()
   | exception Not_found -> ()
 
 let set_value_used_callback vd callback =
-  Types.Uid.Tbl.add !value_declarations vd.val_uid callback
+  stamped_uid_add value_declarations vd.val_uid callback
 
 let set_type_used_callback td callback =
   if Uid.for_actual_declaration td.type_uid then
     let old =
-      try Types.Uid.Tbl.find !type_declarations td.type_uid
+      try stamped_find type_declarations td.type_uid
       with Not_found -> ignore
     in
-    Types.Uid.Tbl.replace !type_declarations td.type_uid
+    Stamped_hashtable.replace type_declarations td.type_uid
       (fun () -> callback old)
 
 (* Lookup by name *)
@@ -4008,7 +4033,7 @@ and short_paths_functor_components_desc env mpath comp path =
             Subst.modtype (Rescope (Path.scope (Papply (mpath, path))))
               subst f.fcomp_res
           in
-          stamped_add f.fcomp_subst_cache path mty;
+          stamped_path_add f.fcomp_subst_cache path mty;
           mty
       in
       let loc = Location.(in_file !input_name) in
@@ -4118,3 +4143,10 @@ let short_paths env =
 
 let cleanup_functor_caches ~stamp =
   Stamped_hashtable.backtrack !stamped_changelog ~stamp
+
+let cleanup_usage_tables ~stamp =
+  Stamped_hashtable.backtrack value_declarations_changelog ~stamp;
+  Stamped_hashtable.backtrack type_declarations_changelog ~stamp;
+  Stamped_hashtable.backtrack module_declarations_changelog ~stamp;
+  Stamped_hashtable.backtrack used_constructors_changelog ~stamp;
+  Stamped_hashtable.backtrack used_labels_changelog ~stamp
diff --git a/src/ocaml/typing/env.mli b/src/ocaml/typing/env.mli
index 3f2acb48c0..1b9191f468 100644
--- a/src/ocaml/typing/env.mli
+++ b/src/ocaml/typing/env.mli
@@ -533,3 +533,4 @@ val with_cmis : (unit -> 'a) -> 'a
 
 val add_merlin_extension_module: Ident.t -> module_type -> t -> t
 val cleanup_functor_caches : stamp:int -> unit
+val cleanup_usage_tables : stamp:int -> unit
diff --git a/src/ocaml/typing/shape.ml b/src/ocaml/typing/shape.ml
index 6248d83ff1..c22b9a356f 100644
--- a/src/ocaml/typing/shape.ml
+++ b/src/ocaml/typing/shape.ml
@@ -45,6 +45,10 @@ module Uid = struct
   let get_current_stamp () = !id
   let restore_stamp i = id := i
 
+  let stamp_of_uid = function
+    | Item { id; _ } -> Some id
+    | _ -> None
+
   let mk  ~current_unit =
       incr id;
       Item { comp_unit = current_unit; id = !id }
diff --git a/src/ocaml/typing/shape.mli b/src/ocaml/typing/shape.mli
index 31f9176a47..ed6c84692a 100644
--- a/src/ocaml/typing/shape.mli
+++ b/src/ocaml/typing/shape.mli
@@ -65,6 +65,7 @@ module Uid : sig
   val reinit : unit -> unit
   val get_current_stamp : unit -> int
   val restore_stamp : int -> unit
+  val stamp_of_uid : t -> int option
 
   val mk : current_unit:string -> t
   val of_compilation_unit_id : Ident.t -> t
diff --git a/src/utils/stamped_hashtable.ml b/src/utils/stamped_hashtable.ml
index d5dd9aad03..d741531fcd 100644
--- a/src/utils/stamped_hashtable.ml
+++ b/src/utils/stamped_hashtable.ml
@@ -42,12 +42,20 @@ let add {table; changelog} ?stamp key value =
   | Some stamp ->
     changelog.recent <- Cell {stamp; key; table} :: changelog.recent
 
+let replace t k v =
+  Hashtbl.replace t.table k v
+
 let mem t a =
   Hashtbl.mem t.table a
 
 let find t a =
   Hashtbl.find t.table a
 
+let clear t =
+  Hashtbl.clear t.table;
+  t.changelog.recent <- [];
+  t.changelog.sorted <- []
+
 (* Implementation of backtracking *)
 
 (* Helper to sort by decreasing stamps *)
diff --git a/src/utils/stamped_hashtable.mli b/src/utils/stamped_hashtable.mli
index 40c3386333..78fcd8b3e8 100644
--- a/src/utils/stamped_hashtable.mli
+++ b/src/utils/stamped_hashtable.mli
@@ -34,9 +34,16 @@ val mem : ('a, 'b) t -> 'a -> bool
 val find : ('a, 'b) t -> 'a -> 'b
 (** See [Hashtbl.find]. *)
 
+val clear : ('a, 'b) t -> unit
+(** Clear the table and empty the changelog. See [Hashtbl.clear]. *)
+
 val create_changelog : unit -> changelog
 (** Create a new change log. *)
 
 (* [backtrack changelog ~stamp] remove all items added to tables logging to
    [changelog] with a stamp strictly greater than [stamp] *)
 val backtrack : changelog -> stamp:int -> unit
+
+val replace : ('a, 'b) t -> 'a -> 'b -> unit
+(** This operation is unsafe in general. Only replacements that does not imply
+    re-stamping are safe. *)
diff --git a/tests/test-dirs/server-tests/warnings/backtrack.t b/tests/test-dirs/server-tests/warnings/backtrack.t
index 99d27a20fa..65003eb30f 100644
--- a/tests/test-dirs/server-tests/warnings/backtrack.t
+++ b/tests/test-dirs/server-tests/warnings/backtrack.t
@@ -78,4 +78,44 @@ environment in different queries, some warnings will be reported only once.
     "notifications": []
   }
 
+
+  $ $MERLIN server errors -filename backtrack.ml -w +A <<EOF
+  > let f x = ()
+  > let g y = ()
+  > EOF
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 1,
+          "col": 6
+        },
+        "end": {
+          "line": 1,
+          "col": 7
+        },
+        "type": "warning",
+        "sub": [],
+        "valid": true,
+        "message": "Warning 27: unused variable x."
+      },
+      {
+        "start": {
+          "line": 2,
+          "col": 6
+        },
+        "end": {
+          "line": 2,
+          "col": 7
+        },
+        "type": "warning",
+        "sub": [],
+        "valid": true,
+        "message": "Warning 27: unused variable y."
+      }
+    ],
+    "notifications": []
+  }
+
   $ $MERLIN server stop-server

From 5fc8a1ba3a9876fdbc2c677afbb934f51c23b458 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Thu, 21 Dec 2023 15:12:18 +0100
Subject: [PATCH 44/58] tests: missing occurrences in type constraints

---
 .../type-enclosing/te-413-features.t          | 83 +++----------------
 1 file changed, 13 insertions(+), 70 deletions(-)

diff --git a/tests/test-dirs/type-enclosing/te-413-features.t b/tests/test-dirs/type-enclosing/te-413-features.t
index da5ab50a03..06a9e7313d 100644
--- a/tests/test-dirs/type-enclosing/te-413-features.t
+++ b/tests/test-dirs/type-enclosing/te-413-features.t
@@ -108,48 +108,19 @@ Module types substitutions
     }
   ]
 
-  $ $MERLIN single occurrences -identifier-at 6:19 \
+FIXME: we are missing occurrences
+  $ $MERLIN single occurrences -identifier-at 7:20 \
   > -filename mtsubst.ml < mtsubst.ml |
   > tr '\n' ' ' |  jq '.value'
   [
     {
       "start": {
-        "line": 2,
-        "col": 14
+        "line": 5,
+        "col": 31
       },
       "end": {
-        "line": 2,
-        "col": 15
-      }
-    },
-    {
-      "start": {
-        "line": 3,
-        "col": 12
-      },
-      "end": {
-        "line": 3,
-        "col": 13
-      }
-    },
-    {
-      "start": {
-        "line": 3,
-        "col": 17
-      },
-      "end": {
-        "line": 3,
-        "col": 18
-      }
-    },
-    {
-      "start": {
-        "line": 6,
-        "col": 19
-      },
-      "end": {
-        "line": 6,
-        "col": 20
+        "line": 5,
+        "col": 32
       }
     }
   ]
@@ -196,48 +167,20 @@ Module types substitutions
     }
   ]
 
-  $ $MERLIN single occurrences -identifier-at 6:19 \
+FIXME: we are missing occurrences
+  $ $MERLIN single occurrences -identifier-at 7:20 \
   > -filename mtsubst.ml < mtsubst.ml |
   > tr '\n' ' ' |  jq '.value'
   [
     {
       "start": {
-        "line": 2,
-        "col": 14
+        "line": 5,
+        "col": 31
       },
       "end": {
-        "line": 2,
-        "col": 15
-      }
-    },
-    {
-      "start": {
-        "line": 3,
-        "col": 12
-      },
-      "end": {
-        "line": 3,
-        "col": 13
-      }
-    },
-    {
-      "start": {
-        "line": 3,
-        "col": 17
-      },
-      "end": {
-        "line": 3,
-        "col": 18
-      }
-    },
-    {
-      "start": {
-        "line": 6,
-        "col": 19
-      },
-      "end": {
-        "line": 6,
-        "col": 20
+        "line": 5,
+        "col": 32
       }
     }
   ]
+

From 1632e4de10462282c31bffb2bf84b657b24387fa Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Fri, 22 Dec 2023 17:50:51 +0100
Subject: [PATCH 45/58] occ: Improve definition handling

They are not stored in the index anymore
---
 src/analysis/occurrences.ml                   | 33 ++++++++++++-------
 tests/test-dirs/occurrences/cross-files.t     | 24 --------------
 tests/test-dirs/occurrences/no-ml.t           | 11 +++++++
 .../test-dirs/occurrences/occ-and-wrapping.t  |  9 +----
 .../occurrences/project-wide/simple.t         | 18 +++++++---
 5 files changed, 47 insertions(+), 48 deletions(-)

diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml
index f1be6f38a2..afc1249432 100644
--- a/src/analysis/occurrences.ml
+++ b/src/analysis/occurrences.ml
@@ -146,6 +146,11 @@ let check Index_format.{ stats; _ } file =
       equal
     with Unix.Unix_error _ -> false
 
+let set_fname ~file (loc : Location.t) =
+  let pos_fname = file in
+  { loc with
+      loc_start = { loc.loc_start with pos_fname };
+      loc_end   = { loc.loc_end with pos_fname }}
 
 let locs_of ~config ~scope ~env ~local_defs ~pos ~node:_ path =
   log ~title:"occurrences" "Looking for occurences of %s (pos: %s)"
@@ -233,23 +238,29 @@ let locs_of ~config ~scope ~env ~local_defs ~pos ~node:_ path =
             None
           else if Filename.is_relative fname then begin
             match Locate.find_source ~config loc fname with
-            | `Found (file, _) -> Some { loc with loc_start =
-                { loc.loc_start with pos_fname = file}}
+            | `Found (file, _) -> Some (set_fname ~file loc)
             | `File_not_found msg ->
-              log ~title:"occurrences" "%s" msg;
-              None
-            | _ -> None
+                log ~title:"occurrences" "%s" msg;
+                None
           end else Some loc)
     in
-    (* We only prepend the loc of the definition for the current buffer *)
     let def_uid_is_in_current_unit =
       let uid_comp_unit = comp_unit_of_uid def_uid in
       Option.value_map ~default:false uid_comp_unit
         ~f:(String.equal @@ Env.get_unit_name ())
     in
-    if def_uid_is_in_current_unit then
-      let def_loc = {def_loc with
-        loc_start = {def_loc.loc_start with pos_fname = current_buffer_path }} in
-      Ok ((def_loc::locs), desync)
-      else Ok (locs, desync)
+    let def_loc =
+      if def_uid_is_in_current_unit
+      then set_fname ~file:current_buffer_path def_loc
+      else match
+       Locate.find_source ~config def_loc def_loc.loc_start.pos_fname
+      with
+      | `Found (file, _) -> set_fname ~file def_loc
+      | `File_not_found msg ->
+          log ~title:"occurrences" "%s" msg;
+          { def_loc with loc_ghost = true }
+    in
+    if not def_loc.loc_ghost && (def_uid_is_in_current_unit || scope = `Project)
+    then Ok (def_loc::locs, desync)
+    else Ok (locs, desync)
   | None -> Error "nouid"
diff --git a/tests/test-dirs/occurrences/cross-files.t b/tests/test-dirs/occurrences/cross-files.t
index 4e1b55f0a9..461ac93145 100644
--- a/tests/test-dirs/occurrences/cross-files.t
+++ b/tests/test-dirs/occurrences/cross-files.t
@@ -54,21 +54,9 @@ FIXME: remove duplicates
     }
   ]
 
-FIXME: remove duplicates
   $ $MERLIN single occurrences -scope project -identifier-at 2:15 \
   > -filename lib.ml <lib.ml | jq '.value'
   [
-    {
-      "file": "$TESTCASE_ROOT/lib.ml",
-      "start": {
-        "line": 1,
-        "col": 4
-      },
-      "end": {
-        "line": 1,
-        "col": 17
-      }
-    },
     {
       "file": "$TESTCASE_ROOT/lib.ml",
       "start": {
@@ -104,21 +92,9 @@ FIXME: remove duplicates
     }
   ]
 
-FIXME: remove duplicates
   $ $MERLIN single occurrences -scope project -identifier-at 1:10 \
   > -filename lib.ml <lib.ml | jq '.value'
   [
-    {
-      "file": "$TESTCASE_ROOT/lib.ml",
-      "start": {
-        "line": 1,
-        "col": 4
-      },
-      "end": {
-        "line": 1,
-        "col": 17
-      }
-    },
     {
       "file": "$TESTCASE_ROOT/lib.ml",
       "start": {
diff --git a/tests/test-dirs/occurrences/no-ml.t b/tests/test-dirs/occurrences/no-ml.t
index f133ca2ea0..1bd00e1c26 100644
--- a/tests/test-dirs/occurrences/no-ml.t
+++ b/tests/test-dirs/occurrences/no-ml.t
@@ -17,6 +17,17 @@
   $ $MERLIN single occurrences -scope project -identifier-at 1:15 \
   > -filename main.ml <main.ml | jq '.value'
   [
+    {
+      "file": "$TESTCASE_ROOT/oui_ml.ml",
+      "start": {
+        "line": 1,
+        "col": 5
+      },
+      "end": {
+        "line": 1,
+        "col": 6
+      }
+    },
     {
       "file": "$TESTCASE_ROOT/main.ml",
       "start": {
diff --git a/tests/test-dirs/occurrences/occ-and-wrapping.t b/tests/test-dirs/occurrences/occ-and-wrapping.t
index db142bc091..ce0379e57a 100644
--- a/tests/test-dirs/occurrences/occ-and-wrapping.t
+++ b/tests/test-dirs/occurrences/occ-and-wrapping.t
@@ -33,23 +33,16 @@
   $ dune build @ocaml-index @all 
 
   $ ocaml-index dump _build/default/project.ocaml-index
-  7 uids:
+  4 uids:
   {uid: Lib__Wrapped_module; locs:
      "Lib__Wrapped_module": File "$TESTCASE_ROOT/lib/lib.ml-gen", line 4, characters 24-43
-   uid: Dune__exe__Main.0; locs:
-     "_y": File "$TESTCASE_ROOT/main.ml", line 2, characters 4-6
    uid: Stdlib.313; locs:
      "print_int": File "$TESTCASE_ROOT/main.ml", line 2, characters 9-18
-   uid: Lib.0; locs:
-     "Wrapped_module": File "$TESTCASE_ROOT/lib/lib.ml-gen", line 4, characters 7-21
    uid: Lib__Wrapped_module.0; locs:
      "Wrapped_module.x": File "$TESTCASE_ROOT/main.ml", line 2, characters 19-35;
-     "x": File "$TESTCASE_ROOT/lib/wrapped_module.ml", line 1, characters 4-5;
      "x": File "$TESTCASE_ROOT/lib/wrapped_module.ml", line 2, characters 11-12
    uid: Lib; locs:
      "Lib": File "$TESTCASE_ROOT/main.ml", line 1, characters 5-8
-   uid: Lib__Wrapped_module.1; locs:
-     "f": File "$TESTCASE_ROOT/lib/wrapped_module.ml", line 2, characters 4-5
    }, 0 approx shapes: {}, and shapes for CUS .
 
   $ $MERLIN single occurrences -scope project -identifier-at 2:34 \
diff --git a/tests/test-dirs/occurrences/project-wide/simple.t b/tests/test-dirs/occurrences/project-wide/simple.t
index 9cc03f11f9..fd159d1ac4 100644
--- a/tests/test-dirs/occurrences/project-wide/simple.t
+++ b/tests/test-dirs/occurrences/project-wide/simple.t
@@ -32,13 +32,10 @@
   $ dune build @all
 
   $ ocaml-index dump _build/default/project.ocaml-index
-  3 uids:
-  {uid: Lib.1; locs:
-     "y": File "$TESTCASE_ROOT/lib/lib.ml", line 2, characters 4-5
-   uid: Stdlib.313; locs:
+  2 uids:
+  {uid: Stdlib.313; locs:
      "print_int": File "$TESTCASE_ROOT/exe/main.ml", line 1, characters 0-9
    uid: Lib.0; locs:
-     "x": File "$TESTCASE_ROOT/lib/lib.ml", line 1, characters 4-5;
      "x": File "$TESTCASE_ROOT/lib/lib.ml", line 2, characters 8-9;
      "Lib.x": File "$TESTCASE_ROOT/exe/main.ml", line 1, characters 10-15
    }, 0 approx shapes: {}, and shapes for CUS .
@@ -96,6 +93,17 @@ Occurrences of Lib.x
   {
     "class": "return",
     "value": [
+      {
+        "file": "$TESTCASE_ROOT/lib/lib.ml",
+        "start": {
+          "line": 1,
+          "col": 4
+        },
+        "end": {
+          "line": 1,
+          "col": 5
+        }
+      },
       {
         "file": "$TESTCASE_ROOT/exe/main.ml",
         "start": {

From a58679804d07efa78b2b8ef8dc99f3cef14693cb Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Tue, 2 Jan 2024 15:19:50 +0100
Subject: [PATCH 46/58] test: show issue with definition outside of workspace

---
 .../occurrences/def-outside-workspace.t       | 47 +++++++++++++++++++
 1 file changed, 47 insertions(+)
 create mode 100644 tests/test-dirs/occurrences/def-outside-workspace.t

diff --git a/tests/test-dirs/occurrences/def-outside-workspace.t b/tests/test-dirs/occurrences/def-outside-workspace.t
new file mode 100644
index 0000000000..f614bcbaab
--- /dev/null
+++ b/tests/test-dirs/occurrences/def-outside-workspace.t
@@ -0,0 +1,47 @@
+  $ cat >main.ml <<'EOF'
+  > let _ = Bytes.create 0
+  > let _ = Bytes.create 0
+  > EOF
+
+FIXME: we shouldn't return the definition when it's not in the current workspace
+  $ $MERLIN single occurrences -scope project -identifier-at 2:17 \
+  > -filename main.ml <main.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "file": "$TESTCASE_ROOT/main.ml",
+        "start": {
+          "line": 1,
+          "col": 14
+        },
+        "end": {
+          "line": 1,
+          "col": 20
+        }
+      },
+      {
+        "file": "$TESTCASE_ROOT/main.ml",
+        "start": {
+          "line": 2,
+          "col": 14
+        },
+        "end": {
+          "line": 2,
+          "col": 20
+        }
+      },
+      {
+        "file": "lib/ocaml/bytes.ml",
+        "start": {
+          "line": 28,
+          "col": 9
+        },
+        "end": {
+          "line": 28,
+          "col": 15
+        }
+      }
+    ],
+    "notifications": []
+  }

From bacaa50102683ca3bfac356a319b687b8db7dd51 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Tue, 2 Jan 2024 16:26:54 +0100
Subject: [PATCH 47/58] occ: consider the def is in the index

---
 src/analysis/occurrences.ml                    | 10 ++--------
 tests/test-dirs/occurrences/cross-files.t      |  2 +-
 .../occurrences/def-outside-workspace.t        | 13 +------------
 tests/test-dirs/occurrences/no-ml.t            |  7 ++++++-
 tests/test-dirs/occurrences/occ-and-wrapping.t |  9 ++++++++-
 .../occurrences/project-wide/simple.t          | 18 +++++-------------
 6 files changed, 23 insertions(+), 36 deletions(-)

diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml
index afc1249432..56db4bdc4f 100644
--- a/src/analysis/occurrences.ml
+++ b/src/analysis/occurrences.ml
@@ -200,7 +200,7 @@ let locs_of ~config ~scope ~env ~local_defs ~pos ~node:_ path =
       let exception File_changed in
       let open Option.Infix in
       try
-        let locs = config.merlin.index_file  >>= fun file ->
+        let locs = config.merlin.index_file >>= fun file ->
           let external_index = Index_format.read_exn ~file in
           Hashtbl.find_opt external_index.defs def_uid
           >>| fun locs -> LidSet.filter (fun {loc; _} ->
@@ -252,13 +252,7 @@ let locs_of ~config ~scope ~env ~local_defs ~pos ~node:_ path =
     let def_loc =
       if def_uid_is_in_current_unit
       then set_fname ~file:current_buffer_path def_loc
-      else match
-       Locate.find_source ~config def_loc def_loc.loc_start.pos_fname
-      with
-      | `Found (file, _) -> set_fname ~file def_loc
-      | `File_not_found msg ->
-          log ~title:"occurrences" "%s" msg;
-          { def_loc with loc_ghost = true }
+      else { def_loc with loc_ghost = true }
     in
     if not def_loc.loc_ghost && (def_uid_is_in_current_unit || scope = `Project)
     then Ok (def_loc::locs, desync)
diff --git a/tests/test-dirs/occurrences/cross-files.t b/tests/test-dirs/occurrences/cross-files.t
index 461ac93145..dd873a52c3 100644
--- a/tests/test-dirs/occurrences/cross-files.t
+++ b/tests/test-dirs/occurrences/cross-files.t
@@ -8,7 +8,7 @@
   > EOF
 
   $ $OCAMLC -c -bin-annot -bin-annot-occurrences - lib.ml main.ml
-  $ ocaml-index aggregate lib.cmt main.cmt -o project.index
+  $ ocaml-index aggregate --root ${PWD} lib.cmt main.cmt -o project.index
 
   $ cat >.merlin <<'EOF'
   > INDEX_FILE project.index
diff --git a/tests/test-dirs/occurrences/def-outside-workspace.t b/tests/test-dirs/occurrences/def-outside-workspace.t
index f614bcbaab..ce8bdb6397 100644
--- a/tests/test-dirs/occurrences/def-outside-workspace.t
+++ b/tests/test-dirs/occurrences/def-outside-workspace.t
@@ -3,7 +3,7 @@
   > let _ = Bytes.create 0
   > EOF
 
-FIXME: we shouldn't return the definition when it's not in the current workspace
+We shouldn't return the definition when it's not in the current workspace
   $ $MERLIN single occurrences -scope project -identifier-at 2:17 \
   > -filename main.ml <main.ml
   {
@@ -30,17 +30,6 @@ FIXME: we shouldn't return the definition when it's not in the current workspace
           "line": 2,
           "col": 20
         }
-      },
-      {
-        "file": "lib/ocaml/bytes.ml",
-        "start": {
-          "line": 28,
-          "col": 9
-        },
-        "end": {
-          "line": 28,
-          "col": 15
-        }
       }
     ],
     "notifications": []
diff --git a/tests/test-dirs/occurrences/no-ml.t b/tests/test-dirs/occurrences/no-ml.t
index 1bd00e1c26..a229f95443 100644
--- a/tests/test-dirs/occurrences/no-ml.t
+++ b/tests/test-dirs/occurrences/no-ml.t
@@ -12,7 +12,12 @@
   > let (y : t) = 43
   > EOF
 
-  $ $OCAMLC -bin-annot -c oui_ml.ml no_ml.mli
+  $ $OCAMLC -bin-annot -bin-annot-occurrences -c oui_ml.ml no_ml.mli main.ml
+  $ ocaml-index aggregate oui_ml.cmt no_ml.cmti main.cmt -o project.index
+
+  $ cat >.merlin <<'EOF'
+  > INDEX_FILE project.index
+  > EOF
 
   $ $MERLIN single occurrences -scope project -identifier-at 1:15 \
   > -filename main.ml <main.ml | jq '.value'
diff --git a/tests/test-dirs/occurrences/occ-and-wrapping.t b/tests/test-dirs/occurrences/occ-and-wrapping.t
index ce0379e57a..db142bc091 100644
--- a/tests/test-dirs/occurrences/occ-and-wrapping.t
+++ b/tests/test-dirs/occurrences/occ-and-wrapping.t
@@ -33,16 +33,23 @@
   $ dune build @ocaml-index @all 
 
   $ ocaml-index dump _build/default/project.ocaml-index
-  4 uids:
+  7 uids:
   {uid: Lib__Wrapped_module; locs:
      "Lib__Wrapped_module": File "$TESTCASE_ROOT/lib/lib.ml-gen", line 4, characters 24-43
+   uid: Dune__exe__Main.0; locs:
+     "_y": File "$TESTCASE_ROOT/main.ml", line 2, characters 4-6
    uid: Stdlib.313; locs:
      "print_int": File "$TESTCASE_ROOT/main.ml", line 2, characters 9-18
+   uid: Lib.0; locs:
+     "Wrapped_module": File "$TESTCASE_ROOT/lib/lib.ml-gen", line 4, characters 7-21
    uid: Lib__Wrapped_module.0; locs:
      "Wrapped_module.x": File "$TESTCASE_ROOT/main.ml", line 2, characters 19-35;
+     "x": File "$TESTCASE_ROOT/lib/wrapped_module.ml", line 1, characters 4-5;
      "x": File "$TESTCASE_ROOT/lib/wrapped_module.ml", line 2, characters 11-12
    uid: Lib; locs:
      "Lib": File "$TESTCASE_ROOT/main.ml", line 1, characters 5-8
+   uid: Lib__Wrapped_module.1; locs:
+     "f": File "$TESTCASE_ROOT/lib/wrapped_module.ml", line 2, characters 4-5
    }, 0 approx shapes: {}, and shapes for CUS .
 
   $ $MERLIN single occurrences -scope project -identifier-at 2:34 \
diff --git a/tests/test-dirs/occurrences/project-wide/simple.t b/tests/test-dirs/occurrences/project-wide/simple.t
index fd159d1ac4..9cc03f11f9 100644
--- a/tests/test-dirs/occurrences/project-wide/simple.t
+++ b/tests/test-dirs/occurrences/project-wide/simple.t
@@ -32,10 +32,13 @@
   $ dune build @all
 
   $ ocaml-index dump _build/default/project.ocaml-index
-  2 uids:
-  {uid: Stdlib.313; locs:
+  3 uids:
+  {uid: Lib.1; locs:
+     "y": File "$TESTCASE_ROOT/lib/lib.ml", line 2, characters 4-5
+   uid: Stdlib.313; locs:
      "print_int": File "$TESTCASE_ROOT/exe/main.ml", line 1, characters 0-9
    uid: Lib.0; locs:
+     "x": File "$TESTCASE_ROOT/lib/lib.ml", line 1, characters 4-5;
      "x": File "$TESTCASE_ROOT/lib/lib.ml", line 2, characters 8-9;
      "Lib.x": File "$TESTCASE_ROOT/exe/main.ml", line 1, characters 10-15
    }, 0 approx shapes: {}, and shapes for CUS .
@@ -93,17 +96,6 @@ Occurrences of Lib.x
   {
     "class": "return",
     "value": [
-      {
-        "file": "$TESTCASE_ROOT/lib/lib.ml",
-        "start": {
-          "line": 1,
-          "col": 4
-        },
-        "end": {
-          "line": 1,
-          "col": 5
-        }
-      },
       {
         "file": "$TESTCASE_ROOT/exe/main.ml",
         "start": {

From a9023557a423d4f7d8338308948b7b737ee40c7a Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Wed, 3 Jan 2024 13:07:39 +0100
Subject: [PATCH 48/58] test: show issue when def is not reachable

---
 tests/test-dirs/occurrences/without-def.t | 13 +++++++++++++
 1 file changed, 13 insertions(+)
 create mode 100644 tests/test-dirs/occurrences/without-def.t

diff --git a/tests/test-dirs/occurrences/without-def.t b/tests/test-dirs/occurrences/without-def.t
new file mode 100644
index 0000000000..bb46b6ab5d
--- /dev/null
+++ b/tests/test-dirs/occurrences/without-def.t
@@ -0,0 +1,13 @@
+Sometimes it's not possible to get the definition of an ident, we still want to
+display local occurrences based on the declarations uid for that.
+
+  $ cat >local.ml <<'EOF'
+  > let _x : bool = Filename.is_relative "/" 
+  > let _y : bool = Filename.is_relative "/" 
+  > let _z : string = Filename.basename "/" 
+  > EOF
+
+FIXME: there are two occurrences of Filename.is_relative
+  $ $MERLIN single occurrences -identifier-at 1:30 \
+  > -filename local.ml <local.ml | jq '.value'
+  []

From 92d10b82a20b5eeee14f7c5af865d2e63ddf2c07 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Wed, 3 Jan 2024 13:08:29 +0100
Subject: [PATCH 49/58] occ: fix handling of usages without definition

---
 src/analysis/occurrences.ml               | 39 +++++++++++++----------
 tests/test-dirs/occurrences/without-def.t | 25 +++++++++++++--
 2 files changed, 45 insertions(+), 19 deletions(-)

diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml
index 56db4bdc4f..4bb526c9de 100644
--- a/src/analysis/occurrences.ml
+++ b/src/analysis/occurrences.ml
@@ -39,17 +39,24 @@ let index_buffer ~local_defs () =
     end)
   in
   let f ~namespace env path (lid : Longident.t Location.loc)  =
-    log ~title:"index_buffer" "pouet %a" Logger.fmt (Fun.flip Path.print path);
+    log ~title:"index_buffer" "Path: %a" Logger.fmt (Fun.flip Path.print path);
     let not_ghost { Location.loc = { loc_ghost; _ }; _ } = not loc_ghost in
-    if not_ghost lid then
+    let index_decl () =
+      begin match decl_of_path_or_lid env namespace path lid.txt with
+      | exception _ |  None -> log ~title:"index_buffer" "Declaration not found"
+      | Some decl ->
+        log ~title:"index_buffer" "Found declaration: %a"
+          Logger.fmt (Fun.flip Location.print_loc decl.loc);
+        Index_format.(add defs decl.uid (LidSet.singleton lid))
+      end
+    in
+     if not_ghost lid then
       match Env.shape_of_path ~namespace env path with
       | exception Not_found -> ()
       | path_shape ->
-
-    log ~title:"index_buffer" "pouet SOP %a"
-      Logger.fmt (Fun.flip Shape.print path_shape);
+        log ~title:"index_buffer" "Shape of path: %a"
+          Logger.fmt (Fun.flip Shape.print path_shape);
         begin match Shape_reduce.reduce_for_uid env path_shape with
-        | Ocaml_typing.Shape_reduce.Approximated _
         | Internal_error_missing_uid -> ()
         | Resolved_alias l ->
             let uid = Locate.uid_of_aliases ~traverse_aliases:false l in
@@ -60,16 +67,14 @@ let index_buffer ~local_defs () =
             Logger.fmt (Fun.flip Location.print_loc lid.loc)
             Logger.fmt (Fun.flip Shape.Uid.print uid);
           Index_format.(add defs uid (LidSet.singleton lid))
+        | Approximated s  ->
+          log ~title:"index_buffer" "Shape is approximative, found uid: %a"
+            Logger.fmt (Fun.flip (Format.pp_print_option Shape.Uid.print) s);
+          index_decl ()
         | Unresolved s ->
-          log ~title:"index_buffer" "Could not resolve shape %a"
+          log ~title:"index_buffer" "Shape unresolved, stuck on: %a"
             Logger.fmt (Fun.flip Shape.print s);
-          begin match decl_of_path_or_lid env namespace path lid.txt with
-          | exception _ |  None -> log ~title:"index_buffer" "Declaration not found"
-          | Some decl ->
-            log ~title:"index_buffer" "Found the declaration: %a"
-              Logger.fmt (Fun.flip Location.print_loc decl.loc);
-            Index_format.(add defs decl.uid (LidSet.singleton lid))
-          end
+          index_decl ()
         end
   in
   Ast_iterators.iter_on_usages ~f local_defs;
@@ -175,10 +180,10 @@ let locs_of ~config ~scope ~env ~local_defs ~pos ~node:_ path =
         log ~title:"locs_of" "Found definition uid using locate: %a "
           Logger.fmt (fun fmt -> Shape.Uid.print fmt uid);
         Some (uid, location)
-    | `Found { uid; location; approximated = true; _ } ->
+    | `Found { decl_uid; location; approximated = true; _ } ->
         log ~title:"locs_of" "Approx: %a "
-          Logger.fmt (fun fmt -> Shape.Uid.print fmt uid);
-        Some (uid, location)
+          Logger.fmt (fun fmt -> Shape.Uid.print fmt decl_uid);
+        Some (decl_uid, location)
     | `Builtin (uid, s) -> log ~title:"locs_of" "Locate found a builtin: %s" s; Some (uid, Location.none)
     | _ ->
       log ~title:"locs_of" "Locate failed to find a definition.";
diff --git a/tests/test-dirs/occurrences/without-def.t b/tests/test-dirs/occurrences/without-def.t
index bb46b6ab5d..37436e6bbc 100644
--- a/tests/test-dirs/occurrences/without-def.t
+++ b/tests/test-dirs/occurrences/without-def.t
@@ -7,7 +7,28 @@ display local occurrences based on the declarations uid for that.
   > let _z : string = Filename.basename "/" 
   > EOF
 
-FIXME: there are two occurrences of Filename.is_relative
+There are two occurrences of Filename.is_relative
   $ $MERLIN single occurrences -identifier-at 1:30 \
   > -filename local.ml <local.ml | jq '.value'
-  []
+  [
+    {
+      "start": {
+        "line": 1,
+        "col": 25
+      },
+      "end": {
+        "line": 1,
+        "col": 36
+      }
+    },
+    {
+      "start": {
+        "line": 2,
+        "col": 25
+      },
+      "end": {
+        "line": 2,
+        "col": 36
+      }
+    }
+  ]

From 41b88a0c9c45f67e2db3976a19c51dbd6871c237 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Wed, 3 Jan 2024 13:22:56 +0100
Subject: [PATCH 50/58] Add test showing missing param occurrences

---
 tests/test-dirs/occurrences/func-param.t | 26 ++++++++++++++++++++++++
 1 file changed, 26 insertions(+)
 create mode 100644 tests/test-dirs/occurrences/func-param.t

diff --git a/tests/test-dirs/occurrences/func-param.t b/tests/test-dirs/occurrences/func-param.t
new file mode 100644
index 0000000000..24439198ef
--- /dev/null
+++ b/tests/test-dirs/occurrences/func-param.t
@@ -0,0 +1,26 @@
+
+  $ cat >main.ml <<'EOF'
+  > module Client (P : sig
+  >     val url : string
+  >   end) =
+  >   struct
+  >     let url = P.url
+  >     let url2 = P.url
+  >   end
+  > EOF
+
+FIXME: there are two occurrences of P.url
+  $ $MERLIN single occurrences -identifier-at 6:17 \
+  > -filename main.ml <main.ml | jq '.value'
+  [
+    {
+      "start": {
+        "line": 2,
+        "col": 8
+      },
+      "end": {
+        "line": 2,
+        "col": 11
+      }
+    }
+  ]

From 601d1a93e1dff879e553e36304dfc7fd1e004e82 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Wed, 3 Jan 2024 13:30:41 +0100
Subject: [PATCH 51/58] occ: improve local functor param answers

---
 src/analysis/occurrences.ml                   |  4 +-
 tests/test-dirs/occurrences/func-param.t      | 22 ++++++++-
 .../type-enclosing/te-413-features.t          | 46 ++++++++++++++++++-
 3 files changed, 68 insertions(+), 4 deletions(-)

diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml
index 4bb526c9de..5345690c60 100644
--- a/src/analysis/occurrences.ml
+++ b/src/analysis/occurrences.ml
@@ -57,7 +57,9 @@ let index_buffer ~local_defs () =
         log ~title:"index_buffer" "Shape of path: %a"
           Logger.fmt (Fun.flip Shape.print path_shape);
         begin match Shape_reduce.reduce_for_uid env path_shape with
-        | Internal_error_missing_uid -> ()
+        | Internal_error_missing_uid ->
+          log ~title:"index_buffer" "Reduction failed: mssing uid";
+          index_decl ()
         | Resolved_alias l ->
             let uid = Locate.uid_of_aliases ~traverse_aliases:false l in
             Index_format.(add defs uid (LidSet.singleton lid))
diff --git a/tests/test-dirs/occurrences/func-param.t b/tests/test-dirs/occurrences/func-param.t
index 24439198ef..7007f7fa1e 100644
--- a/tests/test-dirs/occurrences/func-param.t
+++ b/tests/test-dirs/occurrences/func-param.t
@@ -9,7 +9,7 @@
   >   end
   > EOF
 
-FIXME: there are two occurrences of P.url
+There are two usages of P.url
   $ $MERLIN single occurrences -identifier-at 6:17 \
   > -filename main.ml <main.ml | jq '.value'
   [
@@ -22,5 +22,25 @@ FIXME: there are two occurrences of P.url
         "line": 2,
         "col": 11
       }
+    },
+    {
+      "start": {
+        "line": 5,
+        "col": 16
+      },
+      "end": {
+        "line": 5,
+        "col": 19
+      }
+    },
+    {
+      "start": {
+        "line": 6,
+        "col": 17
+      },
+      "end": {
+        "line": 6,
+        "col": 20
+      }
     }
   ]
diff --git a/tests/test-dirs/type-enclosing/te-413-features.t b/tests/test-dirs/type-enclosing/te-413-features.t
index 06a9e7313d..860985c129 100644
--- a/tests/test-dirs/type-enclosing/te-413-features.t
+++ b/tests/test-dirs/type-enclosing/te-413-features.t
@@ -78,6 +78,7 @@ Module types substitutions
   > end
   > EOF
 
+1.
   $ $MERLIN single type-enclosing -position 6:25 \
   > -filename mtsubst.ml < mtsubst.ml |
   > tr '\n' ' ' |  jq '.value[0:2]'
@@ -108,7 +109,7 @@ Module types substitutions
     }
   ]
 
-FIXME: we are missing occurrences
+2.
   $ $MERLIN single occurrences -identifier-at 7:20 \
   > -filename mtsubst.ml < mtsubst.ml |
   > tr '\n' ' ' |  jq '.value'
@@ -122,6 +123,26 @@ FIXME: we are missing occurrences
         "line": 5,
         "col": 32
       }
+    },
+    {
+      "start": {
+        "line": 6,
+        "col": 25
+      },
+      "end": {
+        "line": 6,
+        "col": 26
+      }
+    },
+    {
+      "start": {
+        "line": 7,
+        "col": 20
+      },
+      "end": {
+        "line": 7,
+        "col": 21
+      }
     }
   ]
 
@@ -137,6 +158,7 @@ FIXME: we are missing occurrences
   > end
   > EOF
 
+3.
   $ $MERLIN single type-enclosing -position 6:26 \
   > -filename mtsubst.ml < mtsubst.ml |
   > tr '\n' ' ' |  jq '.value[0:2]'
@@ -167,7 +189,7 @@ FIXME: we are missing occurrences
     }
   ]
 
-FIXME: we are missing occurrences
+4.
   $ $MERLIN single occurrences -identifier-at 7:20 \
   > -filename mtsubst.ml < mtsubst.ml |
   > tr '\n' ' ' |  jq '.value'
@@ -181,6 +203,26 @@ FIXME: we are missing occurrences
         "line": 5,
         "col": 32
       }
+    },
+    {
+      "start": {
+        "line": 6,
+        "col": 26
+      },
+      "end": {
+        "line": 6,
+        "col": 27
+      }
+    },
+    {
+      "start": {
+        "line": 7,
+        "col": 20
+      },
+      "end": {
+        "line": 7,
+        "col": 21
+      }
     }
   ]
 

From f9c024d11a127a8cd452c92ecf4313b09809be3b Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Wed, 3 Jan 2024 13:45:00 +0100
Subject: [PATCH 52/58] occ: restrict search to buffer when locate failed

---
 src/analysis/occurrences.ml         | 28 +++++++++++++---------------
 tests/test-dirs/occurrences/no-ml.t | 11 -----------
 2 files changed, 13 insertions(+), 26 deletions(-)

diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml
index 5345690c60..6fface81d1 100644
--- a/src/analysis/occurrences.ml
+++ b/src/analysis/occurrences.ml
@@ -168,7 +168,9 @@ let locs_of ~config ~scope ~env ~local_defs ~pos ~node:_ path =
     ~config:{ mconfig = config; traverse_aliases=false; ml_or_mli = `ML}
     ~env ~local_defs ~pos path
   in
-  let def =
+  (* When we fail to find an exact definition we restrict the scope to the local
+     buffer *)
+  let def, scope =
     match locate_result with
     | `At_origin ->
       log ~title:"locs_of" "Cursor is on definition / declaration";
@@ -177,19 +179,21 @@ let locs_of ~config ~scope ~env ~local_defs ~pos ~node:_ path =
       let browse = Mbrowse.of_typedtree local_defs in
       let node = Mbrowse.enclosing pos [browse] in
       let env, node = Mbrowse.leaf_node node in
-      uid_and_loc_of_node env node
+      uid_and_loc_of_node env node, scope
     | `Found { uid; location; approximated = false; _ } ->
         log ~title:"locs_of" "Found definition uid using locate: %a "
           Logger.fmt (fun fmt -> Shape.Uid.print fmt uid);
-        Some (uid, location)
+        Some (uid, location), scope
     | `Found { decl_uid; location; approximated = true; _ } ->
         log ~title:"locs_of" "Approx: %a "
           Logger.fmt (fun fmt -> Shape.Uid.print fmt decl_uid);
-        Some (decl_uid, location)
-    | `Builtin (uid, s) -> log ~title:"locs_of" "Locate found a builtin: %s" s; Some (uid, Location.none)
+        Some (decl_uid, location), `Buffer
+    | `Builtin (uid, s) ->
+        log ~title:"locs_of" "Locate found a builtin: %s" s;
+        Some (uid, Location.none), scope
     | _ ->
-      log ~title:"locs_of" "Locate failed to find a definition.";
-      None
+        log ~title:"locs_of" "Locate failed to find a definition.";
+        None, `Buffer
   in
   let current_buffer_path =
     Filename.concat config.query.directory config.query.filename
@@ -256,12 +260,6 @@ let locs_of ~config ~scope ~env ~local_defs ~pos ~node:_ path =
       Option.value_map ~default:false uid_comp_unit
         ~f:(String.equal @@ Env.get_unit_name ())
     in
-    let def_loc =
-      if def_uid_is_in_current_unit
-      then set_fname ~file:current_buffer_path def_loc
-      else { def_loc with loc_ghost = true }
-    in
-    if not def_loc.loc_ghost && (def_uid_is_in_current_unit || scope = `Project)
-    then Ok (def_loc::locs, desync)
-    else Ok (locs, desync)
+    if not def_uid_is_in_current_unit then Ok (locs, desync)
+    else Ok (set_fname ~file:current_buffer_path def_loc :: locs, desync)
   | None -> Error "nouid"
diff --git a/tests/test-dirs/occurrences/no-ml.t b/tests/test-dirs/occurrences/no-ml.t
index a229f95443..42d8deb5e6 100644
--- a/tests/test-dirs/occurrences/no-ml.t
+++ b/tests/test-dirs/occurrences/no-ml.t
@@ -22,17 +22,6 @@
   $ $MERLIN single occurrences -scope project -identifier-at 1:15 \
   > -filename main.ml <main.ml | jq '.value'
   [
-    {
-      "file": "$TESTCASE_ROOT/oui_ml.ml",
-      "start": {
-        "line": 1,
-        "col": 5
-      },
-      "end": {
-        "line": 1,
-        "col": 6
-      }
-    },
     {
       "file": "$TESTCASE_ROOT/main.ml",
       "start": {

From 69dcc552569f8c681dbf8dd6ae42344872403c8f Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Wed, 3 Jan 2024 16:48:53 +0100
Subject: [PATCH 53/58] occ: fix local-buffer paths

---
 src/analysis/occurrences.ml | 23 ++++++++++-------------
 1 file changed, 10 insertions(+), 13 deletions(-)

diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml
index 6fface81d1..e5fafd6abc 100644
--- a/src/analysis/occurrences.ml
+++ b/src/analysis/occurrences.ml
@@ -3,6 +3,12 @@ module LidSet = Index_format.LidSet
 
 let {Logger. log} = Logger.for_section "occurrences"
 
+let set_fname ~file (loc : Location.t) =
+  let pos_fname = file in
+  { loc with
+      loc_start = { loc.loc_start with pos_fname };
+      loc_end   = { loc.loc_end with pos_fname }}
+
 let decl_of_path_or_lid env namespace path lid =
   match (namespace : Shape.Sig_component_kind.t) with
   | Constructor ->
@@ -19,7 +25,7 @@ let decl_of_path_or_lid env namespace path lid =
     end
   | _ -> Env_lookup.loc path namespace env
 
-let index_buffer ~local_defs () =
+let index_buffer ~current_buffer_path ~local_defs () =
   let {Logger. log} = Logger.for_section "index" in
   let defs = Hashtbl.create 64 in
   let module Shape_reduce =
@@ -41,6 +47,7 @@ let index_buffer ~local_defs () =
   let f ~namespace env path (lid : Longident.t Location.loc)  =
     log ~title:"index_buffer" "Path: %a" Logger.fmt (Fun.flip Path.print path);
     let not_ghost { Location.loc = { loc_ghost; _ }; _ } = not loc_ghost in
+    let lid = { lid with loc = set_fname ~file:current_buffer_path lid.loc } in
     let index_decl () =
       begin match decl_of_path_or_lid env namespace path lid.txt with
       | exception _ |  None -> log ~title:"index_buffer" "Declaration not found"
@@ -153,12 +160,6 @@ let check Index_format.{ stats; _ } file =
       equal
     with Unix.Unix_error _ -> false
 
-let set_fname ~file (loc : Location.t) =
-  let pos_fname = file in
-  { loc with
-      loc_start = { loc.loc_start with pos_fname };
-      loc_end   = { loc.loc_end with pos_fname }}
-
 let locs_of ~config ~scope ~env ~local_defs ~pos ~node:_ path =
   log ~title:"occurrences" "Looking for occurences of %s (pos: %s)"
     path
@@ -204,7 +205,7 @@ let locs_of ~config ~scope ~env ~local_defs ~pos ~node:_ path =
       Logger.fmt (fun fmt -> Shape.Uid.print fmt def_uid)
       Logger.fmt (fun fmt -> Location.print_loc fmt def_loc);
     log ~title:"locs_of" "Indexing current buffer";
-    let buffer_index = index_buffer ~local_defs () in
+    let buffer_index = index_buffer ~current_buffer_path ~local_defs () in
     let buffer_locs = Hashtbl.find_opt buffer_index def_uid in
     let external_locs, desync =
       if scope = `Buffer then None, false else begin
@@ -243,11 +244,7 @@ let locs_of ~config ~scope ~env ~local_defs ~pos ~node:_ path =
             (Longident.head txt) Logger.fmt (Fun.flip Location.print_loc loc);
           let loc = last_loc loc txt in
           let fname = loc.Location.loc_start.Lexing.pos_fname in
-          if String.equal fname current_buffer_path then
-            (* ignore locs coming from the external index for the buffer *)
-            (* maybe filter before *)
-            None
-          else if Filename.is_relative fname then begin
+          if Filename.is_relative fname then begin
             match Locate.find_source ~config loc fname with
             | `Found (file, _) -> Some (set_fname ~file loc)
             | `File_not_found msg ->

From 5d74c464878ea0143a870d3d91c947ed3a9b1615 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Fri, 5 Jan 2024 15:16:24 +0100
Subject: [PATCH 54/58] index: rely on size when mtime differ

---
 src/analysis/index_format.ml  | 3 ++-
 src/analysis/index_format.mli | 3 ++-
 src/analysis/occurrences.ml   | 8 ++++++--
 3 files changed, 10 insertions(+), 4 deletions(-)

diff --git a/src/analysis/index_format.ml b/src/analysis/index_format.ml
index be47991df0..092b0de707 100644
--- a/src/analysis/index_format.ml
+++ b/src/analysis/index_format.ml
@@ -28,12 +28,13 @@ let add tbl uid locs =
     Hashtbl.replace tbl uid (LidSet.union locs locations)
   with Not_found -> Hashtbl.add tbl uid locs
 
+type stat = { mtime : float; size : int }
 type index = {
   defs : (Shape.Uid.t, LidSet.t) Hashtbl.t;
   approximated : (Shape.Uid.t, LidSet.t) Hashtbl.t;
   load_path : string list;
   cu_shape : (string, Shape.t) Hashtbl.t;
-  stats : float Stats.t;
+  stats : stat Stats.t;
 }
 
 let pp_partials (fmt : Format.formatter)
diff --git a/src/analysis/index_format.mli b/src/analysis/index_format.mli
index ac440cb85c..4f18a36608 100644
--- a/src/analysis/index_format.mli
+++ b/src/analysis/index_format.mli
@@ -7,12 +7,13 @@ val add : ('a, LidSet.t) Hashtbl.t -> 'a -> LidSet.t -> unit
 
 module Stats : Map.S with type key = String.t
 
+type stat = { mtime : float; size : int }
 type index = {
   defs : (Shape.Uid.t, LidSet.t) Hashtbl.t;
   approximated : (Shape.Uid.t, LidSet.t) Hashtbl.t;
   load_path : string list;
   cu_shape : (string, Shape.t) Hashtbl.t;
-  stats : float Stats.t;
+  stats : stat Stats.t;
 }
 
 type file_content = Cmt of Cmt_format.cmt_infos | Index of index | Unknown
diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml
index e5fafd6abc..100f535a25 100644
--- a/src/analysis/occurrences.ml
+++ b/src/analysis/occurrences.ml
@@ -152,9 +152,13 @@ let check Index_format.{ stats; _ } file =
   let open Index_format in
   match Stats.find_opt file stats with
   | None -> log ~title:"stat_check" "No mtime found for file %S." file; true
-  | Some mtime ->
+  | Some { mtime; size } ->
     try
-      let equal = Float.equal (Unix.stat file).st_mtime mtime in
+      let stats = Unix.stat file in
+      let equal =
+        Float.equal stats.st_mtime mtime
+        || Int.equal stats.st_size size
+      in
       log ~title:"stat_check"
         "File %s has been modified since the index was built." file;
       equal

From f45caa68e2f40433efa69f0d7455fb084b0892ad Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Fri, 5 Jan 2024 15:31:41 +0100
Subject: [PATCH 55/58] index: rely on size only to check status

---
 src/analysis/index_format.ml  | 2 +-
 src/analysis/index_format.mli | 2 +-
 src/analysis/occurrences.ml   | 7 ++++---
 3 files changed, 6 insertions(+), 5 deletions(-)

diff --git a/src/analysis/index_format.ml b/src/analysis/index_format.ml
index 092b0de707..c4a19e8148 100644
--- a/src/analysis/index_format.ml
+++ b/src/analysis/index_format.ml
@@ -28,7 +28,7 @@ let add tbl uid locs =
     Hashtbl.replace tbl uid (LidSet.union locs locations)
   with Not_found -> Hashtbl.add tbl uid locs
 
-type stat = { mtime : float; size : int }
+type stat = { mtime : float; size : int; source_digest: string option }
 type index = {
   defs : (Shape.Uid.t, LidSet.t) Hashtbl.t;
   approximated : (Shape.Uid.t, LidSet.t) Hashtbl.t;
diff --git a/src/analysis/index_format.mli b/src/analysis/index_format.mli
index 4f18a36608..4d68269c75 100644
--- a/src/analysis/index_format.mli
+++ b/src/analysis/index_format.mli
@@ -7,7 +7,7 @@ val add : ('a, LidSet.t) Hashtbl.t -> 'a -> LidSet.t -> unit
 
 module Stats : Map.S with type key = String.t
 
-type stat = { mtime : float; size : int }
+type stat = { mtime : float; size : int; source_digest: string option }
 type index = {
   defs : (Shape.Uid.t, LidSet.t) Hashtbl.t;
   approximated : (Shape.Uid.t, LidSet.t) Hashtbl.t;
diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml
index 100f535a25..58d022cf5a 100644
--- a/src/analysis/occurrences.ml
+++ b/src/analysis/occurrences.ml
@@ -152,12 +152,13 @@ let check Index_format.{ stats; _ } file =
   let open Index_format in
   match Stats.find_opt file stats with
   | None -> log ~title:"stat_check" "No mtime found for file %S." file; true
-  | Some { mtime; size } ->
+  | Some { size; _ } ->
     try
       let stats = Unix.stat file in
       let equal =
-        Float.equal stats.st_mtime mtime
-        || Int.equal stats.st_size size
+        (* This is fast but approximative. A better option would be to check
+           [mtime] and then [source_digest] if the times differ. *)
+         Int.equal stats.st_size size
       in
       log ~title:"stat_check"
         "File %s has been modified since the index was built." file;

From 9066c676149062b9fa1388ee8f564ee88fa8f9d8 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Mon, 8 Jan 2024 10:08:40 +0100
Subject: [PATCH 56/58] tests: fix index changed test

---
 tests/test-dirs/occurrences/project-wide/simple.t | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/tests/test-dirs/occurrences/project-wide/simple.t b/tests/test-dirs/occurrences/project-wide/simple.t
index 9cc03f11f9..4b39b99973 100644
--- a/tests/test-dirs/occurrences/project-wide/simple.t
+++ b/tests/test-dirs/occurrences/project-wide/simple.t
@@ -88,7 +88,7 @@ Occurrences of Lib.x
 
 
   $ sleep 1 # Make sure that the time will change
-  $ touch lib/lib.ml
+  $ echo " (* *)" >> lib/lib.ml
 
   $ $MERLIN single occurrences -scope project -identifier-at 1:15 \
   > -log-file log -log-section occurrences \

From 217fdca0f4becf208ff143afde84e5a737616118 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Tue, 16 Jan 2024 14:13:19 +0100
Subject: [PATCH 57/58] occ: index module in path when scope is local

---
 src/analysis/occurrences.ml                   | 28 ++++++++-
 tests/test-dirs/occurrences/modules-in-path.t | 62 +++++++++++++++++++
 2 files changed, 87 insertions(+), 3 deletions(-)
 create mode 100644 tests/test-dirs/occurrences/modules-in-path.t

diff --git a/src/analysis/occurrences.ml b/src/analysis/occurrences.ml
index 58d022cf5a..ad73e6077b 100644
--- a/src/analysis/occurrences.ml
+++ b/src/analysis/occurrences.ml
@@ -25,7 +25,7 @@ let decl_of_path_or_lid env namespace path lid =
     end
   | _ -> Env_lookup.loc path namespace env
 
-let index_buffer ~current_buffer_path ~local_defs () =
+let index_buffer ~scope ~current_buffer_path ~local_defs () =
   let {Logger. log} = Logger.for_section "index" in
   let defs = Hashtbl.create 64 in
   let module Shape_reduce =
@@ -65,7 +65,7 @@ let index_buffer ~current_buffer_path ~local_defs () =
           Logger.fmt (Fun.flip Shape.print path_shape);
         begin match Shape_reduce.reduce_for_uid env path_shape with
         | Internal_error_missing_uid ->
-          log ~title:"index_buffer" "Reduction failed: mssing uid";
+          log ~title:"index_buffer" "Reduction failed: missing uid";
           index_decl ()
         | Resolved_alias l ->
             let uid = Locate.uid_of_aliases ~traverse_aliases:false l in
@@ -86,6 +86,26 @@ let index_buffer ~current_buffer_path ~local_defs () =
           index_decl ()
         end
   in
+  let f ~namespace env path (lid : Longident.t Location.loc)  =
+    (* The compiler lacks sufficient location information to precisely hihglight
+       modules in paths. This function hacks around that issue when looking for
+       occurrences in the current buffer only. *)
+    let rec iter_on_path ~namespace path ({Location.txt; loc} as lid) =
+      let () = f ~namespace env path lid in
+      if scope = `Buffer then
+      match path, txt with
+      | Pdot (path, _), Ldot (lid, s) ->
+        let length_with_dot = String.length s + 1 in
+        let lid =
+          { Location.txt = lid; loc = { loc with loc_end = {loc.loc_end with
+            pos_cnum = loc.loc_end.pos_cnum - length_with_dot}} }
+        in
+        iter_on_path ~namespace:Module path lid
+      | Papply _, _ -> ()
+      | _, _ -> ()
+    in
+    iter_on_path ~namespace path lid
+  in
   Ast_iterators.iter_on_usages ~f local_defs;
   defs
 
@@ -210,7 +230,9 @@ let locs_of ~config ~scope ~env ~local_defs ~pos ~node:_ path =
       Logger.fmt (fun fmt -> Shape.Uid.print fmt def_uid)
       Logger.fmt (fun fmt -> Location.print_loc fmt def_loc);
     log ~title:"locs_of" "Indexing current buffer";
-    let buffer_index = index_buffer ~current_buffer_path ~local_defs () in
+    let buffer_index =
+      index_buffer ~scope ~current_buffer_path ~local_defs ()
+    in
     let buffer_locs = Hashtbl.find_opt buffer_index def_uid in
     let external_locs, desync =
       if scope = `Buffer then None, false else begin
diff --git a/tests/test-dirs/occurrences/modules-in-path.t b/tests/test-dirs/occurrences/modules-in-path.t
new file mode 100644
index 0000000000..4a61393e86
--- /dev/null
+++ b/tests/test-dirs/occurrences/modules-in-path.t
@@ -0,0 +1,62 @@
+  $ cat >main.ml <<'EOF'
+  > module N = struct module M = struct let x = 42 end end
+  > let () = print_int N.M.x
+  > EOF
+
+  $ $MERLIN single occurrences -identifier-at 1:25 \
+  > -filename main.ml <main.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 1,
+          "col": 25
+        },
+        "end": {
+          "line": 1,
+          "col": 26
+        }
+      },
+      {
+        "start": {
+          "line": 2,
+          "col": 21
+        },
+        "end": {
+          "line": 2,
+          "col": 22
+        }
+      }
+    ],
+    "notifications": []
+  }
+
+  $ $MERLIN single occurrences -identifier-at 1:7 \
+  > -filename main.ml <main.ml
+  {
+    "class": "return",
+    "value": [
+      {
+        "start": {
+          "line": 1,
+          "col": 7
+        },
+        "end": {
+          "line": 1,
+          "col": 8
+        }
+      },
+      {
+        "start": {
+          "line": 2,
+          "col": 19
+        },
+        "end": {
+          "line": 2,
+          "col": 20
+        }
+      }
+    ],
+    "notifications": []
+  }

From 3f991d175d12b2b658e9a3637ea3dc3fcd7ef696 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ulysse=20G=C3=A9rard?= <thevoodoos@gmail.com>
Date: Tue, 16 Jan 2024 14:41:28 +0100
Subject: [PATCH 58/58] test: illustrate shortcomings of Merlin when lid have
 spaces or commentaries in them

---
 tests/test-dirs/occurrences/modules-in-path.t | 41 +++++++++++++++++++
 1 file changed, 41 insertions(+)

diff --git a/tests/test-dirs/occurrences/modules-in-path.t b/tests/test-dirs/occurrences/modules-in-path.t
index 4a61393e86..95f9c56ee0 100644
--- a/tests/test-dirs/occurrences/modules-in-path.t
+++ b/tests/test-dirs/occurrences/modules-in-path.t
@@ -1,8 +1,11 @@
   $ cat >main.ml <<'EOF'
   > module N = struct module M = struct let x = 42 end end
   > let () = print_int N.M.x
+  > let () = print_int N.M.(*comment*)x
   > EOF
 
+FIXME: longident with spaces will be highlighted incorrectly
+
   $ $MERLIN single occurrences -identifier-at 1:25 \
   > -filename main.ml <main.ml
   {
@@ -27,6 +30,16 @@
           "line": 2,
           "col": 22
         }
+      },
+      {
+        "start": {
+          "line": 3,
+          "col": 32
+        },
+        "end": {
+          "line": 3,
+          "col": 33
+        }
       }
     ],
     "notifications": []
@@ -56,7 +69,35 @@
           "line": 2,
           "col": 20
         }
+      },
+      {
+        "start": {
+          "line": 3,
+          "col": 30
+        },
+        "end": {
+          "line": 3,
+          "col": 31
+        }
       }
     ],
     "notifications": []
   }
+
+
+FIXME: reconstruct identifier does not handle correctly longidents with comments
+between components.
+  $ $MERLIN single occurrences -identifier-at 3:34 \
+  > -log-file - -log-section locate \
+  > -filename main.ml <main.ml
+  # 0.01 locate - reconstructed identifier
+  x
+  # 0.01 locate - from_string
+  inferred context: expression
+  # 0.01 locate - from_string
+  looking for the source of 'x' (prioritizing .ml files)
+  {
+    "class": "return",
+    "value": [],
+    "notifications": []
+  }