Merge pull request #1988 from liam923/make-short-paths-lazier

Make short paths lazier

Author: voodoos

CHANGES.md

@@ -4,6 +4,8 @@ unreleased
   + merlin library
     - Fix completion not working for inlined records labels (#1978, fixes #1977)
     - Perform buffer indexing only if the query requires it (#1990 and #1991)
+    - Stop unnecessarily forcing substitutions when initializing short-paths graph (#1988)
+    
 
 merlin 5.6
 ==========

src/ocaml/typing/env.ml

@@ -662,11 +662,11 @@ and cltype_data =
 and short_paths_addition =
   | Type of Ident.t * type_declaration
   | Class_type of Ident.t * class_type_declaration
-  | Module_type of Ident.t * modtype_declaration
-  | Module of Ident.t * module_declaration * module_components
+  | Module_type of Ident.t * Subst.Lazy.modtype_declaration
+  | Module of Ident.t * Subst.Lazy.module_decl * module_components
   | Type_open of Path.t * type_data NameMap.t
   | Class_type_open of Path.t * class_type_declaration NameMap.t
-  | Module_type_open of Path.t * modtype_declaration NameMap.t
+  | Module_type_open of Path.t * Subst.Lazy.modtype_declaration NameMap.t
   | Module_open of Path.t * module_data NameMap.t
 
 let empty_structure =
@@ -1771,20 +1771,15 @@ let short_paths_class_type_open path decls old =
   else Class_type_open(path, decls) :: old
 
 let short_paths_module_type id decl old =
-  let decl = Subst.Lazy.force_modtype_decl decl in
   if !Clflags.real_paths then old
   else Module_type(id, decl) :: old
 
 let short_paths_module_type_open path decls old =
-  let decls = NameMap.map
-    (fun mtda -> Subst.Lazy.force_modtype_decl mtda.mtda_declaration)
-    decls
-  in
+  let decls = NameMap.map (fun mtda -> mtda.mtda_declaration) decls in
   if !Clflags.real_paths then old
   else Module_type_open(path, decls) :: old
 
 let short_paths_module id decl comps old =
-  let decl = Subst.Lazy.force_module_decl decl in
   if !Clflags.real_paths then old
   else Module(id, decl, comps) :: old
 
@@ -4036,13 +4031,13 @@ let short_paths_class_type_desc clty =
         | ns -> Subst(path, ns)
       end
 
-let short_paths_module_type_desc mty =
+let short_paths_module_type_desc (mty : Subst.Lazy.modtype option) =
   let open Short_paths.Desc.Module_type in
   match mty with
-  | None | Some Mty_for_hole -> Fresh
-  | Some (Mty_ident path) -> Alias path
-  | Some (Mty_signature _ | Mty_functor _) -> Fresh
-  | Some (Mty_alias _) -> assert false
+  | None | Some MtyL_for_hole -> Fresh
+  | Some (MtyL_ident path) -> Alias path
+  | Some (MtyL_signature _ | MtyL_functor _) -> Fresh
+  | Some (MtyL_alias _) -> assert false
 
 let deprecated_of_alerts alerts =
   if
@@ -4059,26 +4054,26 @@ let deprecated_of_alerts alerts =
 let deprecated_of_attributes attrs =
   deprecated_of_alerts (Builtin_attributes.alerts_of_attrs attrs)
 
-let rec short_paths_module_desc env mpath mty comp =
+let rec short_paths_module_desc env mpath (mty : Subst.Lazy.modtype) comp =
   let open Short_paths.Desc.Module in
   match mty with
-  | Mty_alias path -> Alias path
-  | Mty_ident path -> begin
-      match find_modtype_expansion path env with
+  | MtyL_alias path -> Alias path
+  | MtyL_ident path -> begin
+      match find_modtype_expansion_lazy path env with
       | exception Not_found -> Fresh (Signature (lazy []))
       | mty -> short_paths_module_desc env mpath mty comp
     end
-  | Mty_signature _ ->
+  | MtyL_signature _ ->
       let components =
         lazy (short_paths_module_components_desc env mpath comp)
       in
       Fresh (Signature components)
-  | Mty_functor _ ->
+  | MtyL_functor _ ->
       let apply path =
         short_paths_functor_components_desc env mpath comp path
       in
       Fresh (Functor apply)
-  | Mty_for_hole -> Fresh (Signature (lazy []))
+  | MtyL_for_hole -> Fresh (Signature (lazy []))
 
 and short_paths_module_components_desc env mpath comp =
   match get_components comp with
@@ -4103,19 +4098,17 @@ and short_paths_module_components_desc env mpath comp =
       in
       let comps =
         String.Map.fold (fun name mtda acc ->
-          let mtd = Subst.Lazy.force_modtype_decl mtda.mtda_declaration in
-          let desc = short_paths_module_type_desc mtd.mtd_type in
-          let depr = deprecated_of_attributes mtd.mtd_attributes in
+          let desc = short_paths_module_type_desc mtda.mtda_declaration.mtdl_type in
+          let depr = deprecated_of_attributes mtda.mtda_declaration.mtdl_attributes in
           let item = Short_paths.Desc.Module.Module_type(name, desc, depr) in
           item :: acc
         ) c.comp_modtypes comps
       in
       let comps =
         String.Map.fold (fun name { mda_declaration; mda_components; _ } acc ->
-          let mty = Subst.Lazy.force_module_decl mda_declaration in
           let mpath = Pdot(mpath, name) in
           let desc =
-            short_paths_module_desc env mpath mty.md_type mda_components
+            short_paths_module_desc env mpath mda_declaration.mdl_type mda_components
           in
           let depr = deprecated_of_alerts mda_components.alerts in
           let item = Short_paths.Desc.Module.Module(name, desc, depr) in
@@ -4145,6 +4138,7 @@ and short_paths_functor_components_desc env mpath comp path =
           stamped_path_add f.fcomp_subst_cache path mty;
           mty
       in
+      let mty = Subst.Lazy.of_modtype mty in
       let loc = Location.(in_file !input_name) in
       let comps =
         components_of_functor_appl ~loc ~f_comp:f env ~f_path:mpath ~arg:path
@@ -4167,14 +4161,12 @@ let short_paths_additions_desc env additions =
            let depr = deprecated_of_attributes clty.clty_attributes in
            Short_paths.Desc.Class_type(id, desc, source, depr) :: acc
        | Module_type(id, mtd) ->
-           let desc = short_paths_module_type_desc mtd.mtd_type in
+           let desc = short_paths_module_type_desc mtd.mtdl_type in
            let source = Short_paths.Desc.Local in
-           let depr = deprecated_of_attributes mtd.mtd_attributes in
+           let depr = deprecated_of_attributes mtd.mtdl_attributes in
            Short_paths.Desc.Module_type(id, desc, source, depr) :: acc
        | Module(id, md, comps) ->
-           let desc =
-             short_paths_module_desc env (Pident id) md.md_type comps
-           in
+           let desc = short_paths_module_desc env (Pident id) md.mdl_type comps in
            let source = Short_paths.Desc.Local in
            let depr = deprecated_of_alerts comps.alerts in
            Short_paths.Desc.Module(id, desc, source, depr) :: acc
@@ -4200,12 +4192,12 @@ let short_paths_additions_desc env additions =
              decls acc
        | Module_type_open(root, decls) ->
            String.Map.fold
-             (fun name mtd acc ->
+             (fun name (mtd : Subst.Lazy.modtype_declaration) acc ->
                 let id = Ident.create_local name in
                 let path = Pdot(root, name) in
                 let desc = Short_paths.Desc.Module_type.Alias path in
                 let source = Short_paths.Desc.Open in
-                let depr = deprecated_of_attributes mtd.mtd_attributes in
+                let depr = deprecated_of_attributes mtd.mtdl_attributes in
                 Short_paths.Desc.Module_type(id, desc, source, depr) :: acc)
              decls acc
        | Module_open(root, decls) ->

tests/test-dirs/function-recovery.t

@@ -10,7 +10,7 @@
     "value": "[
     structure_item (test.ml[1,0+0]..test.ml[3,104+28])
       Tstr_module (Present)
-      ERROR_locate_from_inside_function_literal_used_as_non_function/283
+      ERROR_locate_from_inside_function_literal_used_as_non_function/277
         module_expr (test.ml[1,0+72]..test.ml[3,104+28])
           Tmod_structure
           [
@@ -19,7 +19,7 @@
               [
                 <def>
                   pattern (test.ml[2,79+6]..test.ml[2,79+13])
-                    Tpat_var \"problem/280\"
+                    Tpat_var \"problem/274\"
                   expression (test.ml[2,79+16]..test.ml[2,79+24])
                     Texp_variant \"Problem\"
                     None
@@ -55,7 +55,7 @@
                                 constant (_none_[0,0+-1]..[0,0+-1]) ghost
                                   PConst_int (1,None)
                           ]
-                        Texp_ident \"*type-error*/281\"
+                        Texp_ident \"*type-error*/275\"
               ]
           ]
   ]
@@ -76,10 +76,10 @@
       [
         <def>
           pattern (type.ml[1,0+4]..type.ml[1,0+5])
-            Tpat_var \"f/280\"
+            Tpat_var \"f/274\"
           expression (type.ml[1,0+8]..type.ml[1,0+61])
             extra (type.ml[1,0+18]..type.ml[1,0+19])
-              Texp_newtype' \"t/282\"
+              Texp_newtype' \"t/276\"
             Texp_function
             [
               Nolabel
@@ -91,10 +91,10 @@
                       Ttyp_constr \"list/11!\"
                       [
                         core_type (type.ml[1,0+28]..type.ml[1,0+29])
-                          Ttyp_constr \"t/282\"
+                          Ttyp_constr \"t/276\"
                           []
                       ]
-                  Tpat_alias \"foo/283\"
+                  Tpat_alias \"foo/277\"
                   pattern (type.ml[1,0+22]..type.ml[1,0+25]) ghost
                     attribute \"merlin.hide\"
                       []
@@ -109,7 +109,7 @@
                       extra (type.ml[1,0+43]..type.ml[1,0+50])
                         Tpat_extra_constraint
                         core_type (type.ml[1,0+48]..type.ml[1,0+49])
-                          Ttyp_constr \"t/282\"
+                          Ttyp_constr \"t/276\"
                           []
                       Tpat_any
                     expression (type.ml[1,0+53]..type.ml[1,0+55])
@@ -124,7 +124,7 @@
                               constant (_none_[0,0+-1]..[0,0+-1]) ghost
                                 PConst_int (1,None)
                         ]
-                      Texp_ident \"*type-error*/284\"
+                      Texp_ident \"*type-error*/278\"
                 ]
                 expression (type.ml[1,0+59]..type.ml[1,0+61])
                   attribute \"merlin.loc\"
@@ -203,7 +203,7 @@
                     "ghost": false,
                     "attrs": [],
                     "kind": "pattern (test.ml[1,0+4]..test.ml[1,0+5])
-    Tpat_var \"f/280\"
+    Tpat_var \"f/274\"
   ",
                     "children": []
                   },
@@ -234,7 +234,7 @@
                         "ghost": false,
                         "attrs": [],
                         "kind": "pattern (test.ml[1,0+6]..test.ml[1,0+9])
-    Tpat_var \"x/282\"
+    Tpat_var \"x/276\"
   ",
                         "children": []
                       },
@@ -413,7 +413,7 @@
     Tpat_construct \"Some\"
     [
       pattern (test.ml[4,57+9]..test.ml[4,57+12])
-        Tpat_var \"_aa/283\"
+        Tpat_var \"_aa/277\"
     ]
     None
   ",
@@ -431,7 +431,7 @@
                                 "ghost": false,
                                 "attrs": [],
                                 "kind": "pattern (test.ml[4,57+9]..test.ml[4,57+12])
-    Tpat_var \"_aa/283\"
+    Tpat_var \"_aa/277\"
   ",
                                 "children": []
                               }

tests/test-dirs/server-tests/typer-cache/stamps.t/run.t

@@ -8,31 +8,31 @@ buffers, and different runs for the same buffer:
   $ echo "let f x = x" | \
   > $MERLIN server dump -what browse -filename test.ml | \
   > sed 's:\\n:\n:g' | grep Tpat_var
-    Tpat_var \"f/280\"
-    Tpat_var \"x/282\"
+    Tpat_var \"f/274\"
+    Tpat_var \"x/276\"
 
   $ echo "let f x = let () = () in x" | \
   > $MERLIN server dump -what browse -filename test.ml | \
   > sed 's:\\n:\n:g' | grep Tpat_var
-    Tpat_var \"f/283\"
-    Tpat_var \"x/285\"
+    Tpat_var \"f/277\"
+    Tpat_var \"x/279\"
 
   $ echo "let f x = x" | \
   > $MERLIN server dump -what browse -filename other_test.ml | \
   > sed 's:\\n:\n:g' | grep Tpat_var
-    Tpat_var \"f/280\"
-    Tpat_var \"x/282\"
+    Tpat_var \"f/274\"
+    Tpat_var \"x/276\"
 
   $ echo "let f x = let () = () in x" | \
   > $MERLIN server dump -what browse -filename test.ml | \
   > sed 's:\\n:\n:g' | grep Tpat_var
-    Tpat_var \"f/283\"
-    Tpat_var \"x/285\"
+    Tpat_var \"f/277\"
+    Tpat_var \"x/279\"
 
   $ echo "let f x = x" | \
   > $MERLIN server dump -what browse -filename test.ml | \
   > sed 's:\\n:\n:g' | grep Tpat_var
-    Tpat_var \"f/286\"
-    Tpat_var \"x/288\"
+    Tpat_var \"f/280\"
+    Tpat_var \"x/282\"
 
   $ $MERLIN server stop-server