Alias more when strengthening

src/loader/cmt.ml

@@ -526,7 +526,7 @@ and read_include env parent incl =
   | Some m when not (contains_signature m) ->
     let decl = ModuleType m in
     let expansion = { content; shadowed; } in
-    [Include {parent; doc; decl; expansion; status }]
+    [Include {parent; doc; decl; expansion; status; strengthened=None }]
   | Some (ModuleType.U.Signature { items; _ }) ->
     items
   | _ ->

src/loader/cmti.ml

@@ -692,7 +692,7 @@ and read_include env parent incl =
   | Some uexpr when not (contains_signature uexpr) ->
     let decl = Include.ModuleType uexpr in
     let expansion = { content; shadowed; } in
-    [Include {parent; doc; decl; expansion; status }]
+    [Include {parent; doc; decl; expansion; status; strengthened=None }]
   | Some ModuleType.U.Signature { items; _ } when is_inlinable items ->
     items
   | _ ->

src/model/lang.ml

@@ -168,6 +168,7 @@ and Include : sig
 
   type t = {
     parent : Identifier.Signature.t;
+    strengthened : Path.Module.t option;
     doc : Comment.docs;
     status : [ `Inline | `Closed | `Open | `Default ];
     decl : decl;

src/xref2/compile.ml

@@ -329,7 +329,14 @@ and include_ : Env.t -> Include.t -> Include.t =
         i.expansion
     | Ok sg ->
         let map = { Lang_of.empty with shadowed = i.expansion.shadowed } in
-        let e = Lang_of.(simple_expansion map i.parent (Signature sg)) in
+        let sg' =
+          match i.strengthened with
+          | Some p ->
+              let cp = Component.Of_Lang.(module_path empty p) in
+              Strengthen.signature cp sg
+          | None -> sg
+        in
+        let e = Lang_of.(simple_expansion map i.parent (Signature sg')) in
 
         let expansion_sg =
           match e with

src/xref2/component.ml

@@ -326,6 +326,7 @@ and Include : sig
 
   type t = {
     parent : Odoc_model.Paths.Identifier.Signature.t;
+    strengthened : Cpath.module_ option;
     doc : CComment.docs;
     status : [ `Default | `Inline | `Closed | `Open ];
     shadowed : Odoc_model.Lang.Include.shadowed;
@@ -2119,6 +2120,7 @@ module Of_Lang = struct
       shadowed = i.expansion.shadowed;
       expansion_ = apply_sig_map ident_map i.expansion.content;
       status = i.status;
+      strengthened = option module_path ident_map i.strengthened;
       decl;
     }
 

src/xref2/component.mli

@@ -304,6 +304,7 @@ and Include : sig
 
   type t = {
     parent : Odoc_model.Paths.Identifier.Signature.t;
+    strengthened : Cpath.module_ option;
     doc : CComment.docs;
     status : [ `Default | `Inline | `Closed | `Open ];
     shadowed : Odoc_model.Lang.Include.shadowed;

src/xref2/lang_of.ml

@@ -599,6 +599,7 @@ and include_ parent map i =
             i.expansion_;
       };
     status = i.status;
+    strengthened = Opt.map (Path.module_ map) i.strengthened;
   }
 
 and open_ parent map o =

src/xref2/strengthen.ml

@@ -20,21 +20,30 @@ open Delayed
 let rec signature :
     Cpath.module_ -> ?canonical:Cpath.module_ -> Signature.t -> Signature.t =
  fun prefix ?canonical sg ->
+  let sg', strengthened_modules = sig_items prefix ?canonical sg in
+  (* Format.eprintf "Invalidating modules: %a\n%!" (Format.pp_print_list Ident.fmt) strengthened_modules; *)
+  let substs =
+    List.fold_left
+      (fun s mid -> Subst.path_invalidate_module (mid :> Ident.path_module) s)
+      Subst.identity strengthened_modules
+  in
+  Subst.signature substs sg'
+
+and sig_items prefix ?canonical sg =
   let open Signature in
-  let items, strengthened_modules =
+  let items, ids =
     List.fold_left
       (fun (items, s) item ->
         match item with
-        | Module (id, r, m) -> (
+        | Module (id, r, m) ->
             let name = Ident.Name.module_ id in
             let canonical =
               match canonical with
               | Some p -> Some (`Dot (p, name))
               | None -> None
             in
-            match module_ ?canonical (`Dot (prefix, name)) (get m) with
-            | None -> (item :: items, s)
-            | Some m' -> (Module (id, r, put (fun () -> m')) :: items, id :: s))
+            let m' = module_ ?canonical (`Dot (prefix, name)) (get m) in
+            (Module (id, r, put (fun () -> m')) :: items, id :: s)
         | ModuleType (id, mt) ->
             ( ModuleType
                 ( id,
@@ -52,29 +61,22 @@ let rec signature :
                       type_decl (`Dot (prefix, Ident.Name.type_ id)) (get t)) )
               :: items,
               s )
+        | Include i ->
+            let i', strengthened = include_ prefix i in
+            (Include i' :: items, strengthened @ s)
         | Exception _ | TypExt _ | Value _ | External _ | Class _ | ClassType _
-        | Include _ | ModuleSubstitution _ | TypeSubstitution _ | Comment _
-        | Open _ ->
+        | ModuleSubstitution _ | TypeSubstitution _ | Comment _ | Open _ ->
             (item :: items, s))
       ([], []) sg.items
   in
-  (* Format.eprintf "Invalidating modules: %a\n%!" (Format.pp_print_list Ident.fmt) strengthened_modules; *)
-  let substs =
-    List.fold_left
-      (fun s mid -> Subst.path_invalidate_module (mid :> Ident.path_module) s)
-      Subst.identity strengthened_modules
-  in
-  Subst.signature substs { sg with items = List.rev items }
+  ({ sg with items = List.rev items }, ids)
 
 and module_ :
     ?canonical:Cpath.module_ ->
     Cpath.module_ ->
     Component.Module.t ->
-    Component.Module.t option =
- fun ?canonical prefix m ->
-  match m.type_ with
-  | Alias _ -> None
-  | ModuleType _ -> Some { m with canonical; type_ = Alias (prefix, None) }
+    Component.Module.t =
+ fun ?canonical prefix m -> { m with canonical; type_ = Alias (prefix, None) }
 
 (* nuke the expansion as this could otherwise lead to inconsistencies - e.g. 'AlreadyASig' *)
 and module_type :
@@ -113,3 +115,8 @@ and type_decl : Cpath.type_ -> TypeDecl.t -> TypeDecl.t =
     }
   in
   { t with equation }
+
+and include_ : Cpath.module_ -> Include.t -> Include.t * Ident.module_ list =
+ fun path i ->
+  let expansion_, strengthened = sig_items path i.expansion_ in
+  ({ i with expansion_; strengthened = Some path }, strengthened)

src/xref2/subst.ml

@@ -724,6 +724,7 @@ and include_ s i =
   {
     i with
     decl = include_decl s i.decl;
+    strengthened = option_ module_path s i.strengthened;
     expansion_ = apply_sig_map_sg s i.expansion_;
   }
 

src/xref2/tools.ml

@@ -147,48 +147,6 @@ let prefix_signature (path, sg) =
   in
   { sg with items }
 
-let simplify_resolved_module_path :
-    Env.t -> Cpath.Resolved.module_ -> Cpath.Resolved.module_ =
- fun env cpath ->
-  let path = Lang_of.(Path.resolved_module empty cpath) in
-  let id = Odoc_model.Paths.Path.Resolved.Module.identifier path in
-  let rec check_ident id =
-    match Env.(lookup_by_id s_module) id env with
-    | Some _ -> `Identifier id
-    | None -> (
-        match id with
-        | `Module ((#Odoc_model.Paths.Identifier.Module.t as parent), name) ->
-            `Module (`Module (check_ident parent), name)
-        | _ -> failwith "Bad canonical path")
-  in
-  check_ident id
-
-let simplify_resolved_module_type_path :
-    Env.t -> Cpath.Resolved.module_type -> Cpath.Resolved.module_type =
- fun env cpath ->
-  let path = Lang_of.(Path.resolved_module_type empty cpath) in
-  let id = Odoc_model.Paths.Path.Resolved.ModuleType.identifier path in
-  match Env.(lookup_by_id s_module_type) id env with
-  | Some _ -> `Identifier id
-  | None -> (
-      match cpath with
-      | `ModuleType (`Module m, p) ->
-          `ModuleType (`Module (simplify_resolved_module_path env m), p)
-      | _ -> cpath)
-
-let simplify_resolved_type_path :
-    Env.t -> Cpath.Resolved.type_ -> Cpath.Resolved.type_ =
- fun env cpath ->
-  let path = Lang_of.(Path.resolved_type empty cpath) in
-  let id = Odoc_model.Paths.Path.Resolved.Type.identifier path in
-  match Env.(lookup_by_id s_type) id env with
-  | Some _ -> `Identifier id
-  | None -> (
-      match cpath with
-      | `Type (`Module m, p) ->
-          `Type (`Module (simplify_resolved_module_path env m), p)
-      | _ -> cpath)
-
 open Errors.Tools_error
 
 type resolve_module_result =
@@ -937,24 +895,94 @@ and reresolve_module : Env.t -> Cpath.Resolved.module_ -> Cpath.Resolved.module_
       `Hidden p'
   | `Canonical (p, `Resolved p2) ->
       `Canonical (reresolve_module env p, `Resolved (reresolve_module env p2))
-  | `Canonical (p, p2) -> (
-      match
-        resolve_module ~mark_substituted:true ~add_canonical:false env p2
-      with
-      | Ok (`Alias (_, p2'), _) ->
-          `Canonical
-            ( reresolve_module env p,
-              `Resolved (simplify_resolved_module_path env p2') )
-      | Ok (p2', _) ->
-          (* See, e.g. Base.Sexp for an example of where the canonical path might not be
-             a simple alias *)
-          `Canonical
-            ( reresolve_module env p,
-              `Resolved (simplify_resolved_module_path env p2') )
-      | Error _ -> `Canonical (reresolve_module env p, p2)
-      | exception _ -> `Canonical (reresolve_module env p, p2))
+  | `Canonical (p, p2) ->
+      `Canonical (reresolve_module env p, handle_canonical_module env p2)
   | `OpaqueModule m -> `OpaqueModule (reresolve_module env m)
 
+and handle_canonical_module env p2 =
+  let resolve p =
+    match resolve_module ~mark_substituted:true ~add_canonical:false env p with
+    | Ok (p, _) -> Some p
+    | Error _ -> None
+  in
+  let rec get_cpath = function
+    | `Root _ as p -> resolve p
+    | `Dot (p, n) -> (
+        match get_cpath p with
+        | None -> None
+        | Some parent -> (
+            let fallback = `Dot (`Resolved parent, n) in
+            match parent with
+            | `Identifier pid -> (
+                let p' =
+                  `Identifier
+                    ( `Module
+                        ( (pid :> Odoc_model.Paths.Identifier.Signature.t),
+                          Odoc_model.Names.ModuleName.make_std n ),
+                      false )
+                in
+                match resolve p' with None -> resolve fallback | x -> x)
+            | _ -> resolve fallback))
+    | _ -> None
+  in
+  match get_cpath p2 with Some p -> `Resolved p | None -> p2
+
+and handle_canonical_module_type env p2 =
+  let resolve p =
+    match
+      resolve_module_type ~mark_substituted:true ~add_canonical:false env p
+    with
+    | Ok (p, _) -> `Resolved p
+    | Error _ -> p2
+  in
+  match p2 with
+  | `Dot (p, n) -> (
+      match handle_canonical_module env p with
+      | `Resolved r as p' -> (
+          let fallback = `Dot (p', n) in
+          match r with
+          | `Identifier pid -> (
+              let p' =
+                `Identifier
+                  ( `ModuleType
+                      ( (pid :> Odoc_model.Paths.Identifier.Signature.t),
+                        Odoc_model.Names.ModuleTypeName.make_std n ),
+                    false )
+              in
+              match resolve p' with
+              | `Resolved _ as x -> x
+              | _ -> resolve fallback)
+          | _ -> resolve fallback)
+      | _ -> p2)
+  | _ -> p2
+
+and handle_canonical_type env p2 =
+  let resolve p =
+    match resolve_type ~add_canonical:false env p with
+    | Ok (p, _) -> `Resolved p
+    | Error _ -> p2
+  in
+  match p2 with
+  | `Dot (p, n) -> (
+      match handle_canonical_module env p with
+      | `Resolved r as p' -> (
+          let fallback = `Dot (p', n) in
+          match r with
+          | `Identifier pid -> (
+              let p' =
+                `Identifier
+                  ( `Type
+                      ( (pid :> Odoc_model.Paths.Identifier.Signature.t),
+                        Odoc_model.Names.TypeName.make_std n ),
+                    false )
+              in
+              match resolve p' with
+              | `Resolved _ as x -> x
+              | _ -> resolve fallback)
+          | _ -> resolve fallback)
+      | _ -> p2)
+  | _ -> p2
+
 and reresolve_module_type :
     Env.t -> Cpath.Resolved.module_type -> Cpath.Resolved.module_type =
  fun env path ->
@@ -965,16 +993,9 @@ and reresolve_module_type :
   | `CanonicalModuleType (p1, `Resolved p2) ->
       `CanonicalModuleType
         (reresolve_module_type env p1, `Resolved (reresolve_module_type env p2))
-  | `CanonicalModuleType (p1, p2) -> (
-      match
-        resolve_module_type ~mark_substituted:true ~add_canonical:false env p2
-      with
-      | Ok (p2', _) ->
-          `CanonicalModuleType
-            ( reresolve_module_type env p1,
-              `Resolved (simplify_resolved_module_type_path env p2') )
-      | Error _ -> `CanonicalModuleType (reresolve_module_type env p1, p2)
-      | exception _ -> `CanonicalModuleType (reresolve_module_type env p1, p2))
+  | `CanonicalModuleType (p1, p2) ->
+      `CanonicalModuleType
+        (reresolve_module_type env p1, handle_canonical_module_type env p2)
   | `SubstT (p1, p2) ->
       `SubstT (reresolve_module_type env p1, reresolve_module_type env p2)
   | `OpaqueModuleType m -> `OpaqueModuleType (reresolve_module_type env m)
@@ -985,14 +1006,8 @@ and reresolve_type : Env.t -> Cpath.Resolved.type_ -> Cpath.Resolved.type_ =
     match path with
     | `Identifier _ | `Local _ -> path
     | `Substituted s -> `Substituted (reresolve_type env s)
-    | `CanonicalType (p1, p2) -> (
-        match resolve_type ~add_canonical:false env p2 with
-        | Ok (p, _) ->
-            `CanonicalType
-              ( reresolve_type env p1,
-                `Resolved (simplify_resolved_type_path env p) )
-        | Error _ -> `CanonicalType (reresolve_type env p1, p2)
-        | exception _ -> `CanonicalType (reresolve_type env p1, p2))
+    | `CanonicalType (p1, p2) ->
+        `CanonicalType (reresolve_type env p1, handle_canonical_type env p2)
     | `Type (p, n) -> `Type (reresolve_parent env p, n)
     | `Class (p, n) -> `Class (reresolve_parent env p, n)
     | `ClassType (p, n) -> `ClassType (reresolve_parent env p, n)
@@ -1278,7 +1293,9 @@ and fragmap :
                       compiled = false;
                     }
                 in
-                Ok (Component.Signature.Include { i with decl; expansion_ })
+                Ok
+                  (Component.Signature.Include
+                     { i with decl; expansion_; strengthened = None })
               else Ok item
             in
             component >>= fun c ->