Fix 1431

CHANGES.md

@@ -5,6 +5,7 @@
   (@jonludlam, #1427)
 - Fix #1429, which broke docs in packages including `merlin-lib` (@jonludlam,
   #1430)
+- Fix #1431, a regression introduced in v3.2.0 (#1433, @jonludlam)
 
 # 3.2.0
 

src/xref2/tools.ml

@@ -2356,25 +2356,32 @@ let apply_inner_substs env (sg : Component.Signature.t) : Component.Signature.t
   let rec inner (items : Component.Signature.item list) :
       Component.Signature.item list =
     match items with
-    | Component.Signature.TypeSubstitution (id, typedecl) :: rest -> (
+    | (Component.Signature.TypeSubstitution (id, typedecl) as orig) :: rest -> (
         let subst =
           Component.ModuleType.TypeSubst
             (`Dot (`Root, Ident.Name.type_ id), typedecl.equation)
         in
-        let rest =
+        let rest' = inner rest in
+        let inlined =
           Component.Signature.Type
             (id, Ordinary, Component.Delayed.put (fun () -> typedecl))
-          :: inner rest
+          :: rest'
         in
-        match fragmap env subst { sg with items = rest } with
+        match fragmap env subst { sg with items = inlined } with
         | Ok sg' -> sg'.items
-        | Error _ -> failwith "error")
-    | Component.Signature.ModuleSubstitution (id, modsubst) :: rest -> (
+        | Error e ->
+            Lookup_failures.report_internal
+              "apply_inner_substs: fragmap failed: %a" Errors.Tools_error.pp
+              (e :> Errors.Tools_error.any);
+            orig :: rest')
+    | (Component.Signature.ModuleSubstitution (id, modsubst) as orig) :: rest
+      -> (
         let subst =
           Component.ModuleType.ModuleSubst
             (`Dot (`Root, Ident.Name.module_ id), modsubst.manifest)
         in
-        let rest =
+        let rest' = inner rest in
+        let inlined =
           Component.Signature.Module
             ( id,
               Ordinary,
@@ -2386,17 +2393,23 @@ let apply_inner_substs env (sg : Component.Signature.t) : Component.Signature.t
                     canonical = None;
                     hidden = false;
                   }) )
-          :: inner rest
+          :: rest'
         in
-        match fragmap env subst { sg with items = rest } with
+        match fragmap env subst { sg with items = inlined } with
         | Ok sg' -> sg'.items
-        | Error _ -> failwith "error")
-    | Component.Signature.ModuleTypeSubstitution (id, modtypesubst) :: rest -> (
+        | Error e ->
+            Lookup_failures.report_internal
+              "apply_inner_substs: fragmap failed: %a" Errors.Tools_error.pp
+              (e :> Errors.Tools_error.any);
+            orig :: rest')
+    | (Component.Signature.ModuleTypeSubstitution (id, modtypesubst) as orig)
+      :: rest -> (
         let subst =
           Component.ModuleType.ModuleTypeSubst
             (`Dot (`Root, Ident.Name.module_type id), modtypesubst.manifest)
         in
-        let rest =
+        let rest' = inner rest in
+        let inlined =
           Component.Signature.ModuleType
             ( id,
               Component.Delayed.put (fun () ->
@@ -2406,11 +2419,15 @@ let apply_inner_substs env (sg : Component.Signature.t) : Component.Signature.t
                     expr = Some modtypesubst.manifest;
                     canonical = None;
                   }) )
-          :: inner rest
+          :: rest'
         in
-        match fragmap env subst { sg with items = rest } with
+        match fragmap env subst { sg with items = inlined } with
         | Ok sg' -> sg'.items
-        | Error _ -> failwith "error")
+        | Error e ->
+            Lookup_failures.report_internal
+              "apply_inner_substs: fragmap failed: %a" Errors.Tools_error.pp
+              (e :> Errors.Tools_error.any);
+            orig :: rest')
     | x :: rest -> x :: inner rest
     | [] -> []
   in

test/xref2/dune

@@ -43,6 +43,7 @@
   js_stack_overflow
   expansion
   github_issue_1066
+  github_issue_1431
   include_module_type_of_preamble)
  (enabled_if
   (>= %{ocaml_version} 4.08.0)))

test/xref2/github_issue_1431.t/legacy.mli

@@ -0,0 +1,13 @@
+(** A signature with a sibling module declaration and a destructive module
+    substitution whose manifest references that sibling.
+
+    When this signature is loaded as the expansion of [include module type of
+    Legacy] elsewhere, [Of_Lang] rewrites internal cross-references to local
+    idents — so the manifest of [Original_components] becomes a
+    [`Resolved (`Local _)] path. *)
+
+module Components : sig
+  type t
+end
+
+module Original_components := Components

test/xref2/github_issue_1431.t/run.t

@@ -0,0 +1,9 @@
+Repro of #1431. The unresolvable substitution is logged as a non-fatal
+internal warning rather than triggering an assertion failure.
+
+  $ ocamlc -bin-annot -c legacy.mli
+  $ ocamlc -bin-annot -c top.mli
+  $ odoc compile legacy.cmti
+  $ odoc compile -I . top.cmti
+  File "top.cmti":
+  Warning: apply_inner_substs: fragmap failed: Unresolved module path resolved(Components/2) (Local id found: Components/2)

test/xref2/github_issue_1431.t/top.mli

@@ -0,0 +1 @@
+include module type of Legacy