Remove expansion from "unexpanded" module type of

src/document/generator.ml

@@ -1371,11 +1371,13 @@ module Make (Syntax : SYNTAX) = struct
         match t with
         | Path { p_expansion = None; _ }
         | TypeOf { t_expansion = None; _ }
-        | With { w_expansion = None; _ } ->
+        | With { w_expansion = None; _ }
+        | Strengthen { s_expansion = None; _ } ->
             None
         | Path { p_expansion = Some e; _ }
         | TypeOf { t_expansion = Some e; _ }
-        | With { w_expansion = Some e; _ } ->
+        | With { w_expansion = Some e; _ }
+        | Strengthen { s_expansion = Some e; _ } ->
             Some e
         | Signature sg -> Some (Signature sg)
         | Functor (f_parameter, e) -> (
@@ -1511,10 +1513,13 @@ module Make (Syntax : SYNTAX) = struct
     and umty_hidden : Odoc_model.Lang.ModuleType.U.expr -> bool = function
       | Path p -> Paths.Path.(is_hidden (p :> t))
       | With (_, expr) -> umty_hidden expr
-      | TypeOf { t_desc = ModPath m; _ }
-      | TypeOf { t_desc = StructInclude m; _ } ->
+      | Functor _ -> false
+      | TypeOf (ModPath m) | TypeOf (StructInclude m) ->
           Paths.Path.(is_hidden (m :> t))
       | Signature _ -> false
+      | Project (_, expr) -> umty_hidden expr
+      | Strengthen (p, expr) ->
+          umty_hidden expr || Paths.Path.(is_hidden (p :> t))
 
     and mty_hidden : Odoc_model.Lang.ModuleType.expr -> bool = function
       | Path { p_path = mty_path; _ } -> Paths.Path.(is_hidden (mty_path :> t))
@@ -1548,19 +1553,28 @@ module Make (Syntax : SYNTAX) = struct
       function
       | Path _ -> false
       | Signature _ -> true
+      | Functor (_, expr) -> is_elidable_with_u expr
       | With (_, expr) -> is_elidable_with_u expr
       | TypeOf _ -> false
+      | Project _ | Strengthen _ ->
+          (* Currently these are only produced in cases where the module type would
+             previously have been replaced by its expansion, which would have been
+             a signature *)
+          true
 
     and umty : Odoc_model.Lang.ModuleType.U.expr -> text =
      fun m ->
-      match m with
-      | Path p -> Link.from_path (p :> Paths.Path.t)
-      | Signature _ ->
-          Syntax.Mod.open_tag ++ O.txt " ... " ++ Syntax.Mod.close_tag
-      | With (_, expr) when is_elidable_with_u expr ->
-          Syntax.Mod.open_tag ++ O.txt " ... " ++ Syntax.Mod.close_tag
-      | With (subs, expr) -> mty_with subs expr
-      | TypeOf { t_desc; _ } -> mty_typeof t_desc
+      if is_elidable_with_u m then
+        Syntax.Mod.open_tag ++ O.txt " ... " ++ Syntax.Mod.close_tag
+      else
+        match m with
+        | Path p -> Link.from_path (p :> Paths.Path.t)
+        | Signature _ | Project _ | Strengthen _ ->
+            (* impossible since [is_elidable_with_u m] was false *)
+            assert false
+        | With (subs, expr) -> mty_with subs expr
+        | Functor _ -> (* shouldn't happen *) O.txt "<unexpanded functor>"
+        | TypeOf t -> mty_typeof t
 
     and mty : Odoc_model.Lang.ModuleType.expr -> text =
      fun m ->
@@ -1600,6 +1614,7 @@ module Make (Syntax : SYNTAX) = struct
         | TypeOf { t_desc; _ } -> mty_typeof t_desc
         | Signature _ ->
             Syntax.Mod.open_tag ++ O.txt " ... " ++ Syntax.Mod.close_tag
+        | Strengthen _ -> O.txt "unexpanded strengthening"
 
     and mty_in_decl :
         Paths.Identifier.Signature.t -> Odoc_model.Lang.ModuleType.expr -> text
@@ -1634,6 +1649,9 @@ module Make (Syntax : SYNTAX) = struct
                    ++ O.cut ++ mty arg.expr ++ O.txt ")"
           in
           O.sp ++ text_arg ++ mty_in_decl base expr
+      | Strengthen _ ->
+          (* TODO *)
+          unresolved [ inline (Text "<strengthening>") ]
 
     (* TODO : Centralize the list juggling for type parameters *)
     and type_expr_in_subst td typath =

src/document/targets.ml

@@ -49,7 +49,8 @@ and module_type_expr (t : Odoc_model.Lang.ModuleType.expr) =
       sub @ module_type_expr e
   | Path { p_expansion = e_opt; _ }
   | With { w_expansion = e_opt; _ }
-  | TypeOf { t_expansion = e_opt; _ } ->
+  | TypeOf { t_expansion = e_opt; _ }
+  | Strengthen { s_expansion = e_opt; _ } ->
       opt_expansion e_opt
 
 and module_ (t : Odoc_model.Lang.Module.t) =

src/loader/cmt.ml

@@ -548,19 +548,15 @@ and read_include env parent incl =
   let decl_modty =
     match unwrap_module_expr_desc incl.incl_mod.mod_desc with
     | Tmod_ident(p, _) ->
-      Some (ModuleType.U.TypeOf {t_desc = ModuleType.StructInclude (Env.Path.read_module env p); t_expansion=None })
+      ModuleType.U.TypeOf (ModuleType.StructInclude (Env.Path.read_module env p))
     | _ ->
       let mty = read_module_expr env parent container incl.incl_mod in
       umty_of_mty mty
   in
   let content, shadowed = Cmi.read_signature_noenv env parent (Odoc_model.Compat.signature incl.incl_type) in
   let expansion = { content; shadowed; } in
-  match decl_modty with
-  | Some m ->
-    let decl = ModuleType m in
-    [Include {parent; doc; decl; expansion; status; strengthened=None; loc }]
-  | _ ->
-    content.items
+  let decl = ModuleType decl_modty in
+  [Include {parent; doc; decl; expansion; status; strengthened=None; loc }]
 
 and read_open env parent o =
   let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in

src/loader/cmti.ml

@@ -553,11 +553,8 @@ and read_module_type env parent label_parent mty =
     | Tmty_with(body, subs) -> (
       let body = read_module_type env parent label_parent body in
       let subs = List.map (read_with_constraint env parent label_parent) subs in
-      match Odoc_model.Lang.umty_of_mty body with
-      | Some w_expr ->
-          With {w_substitutions=subs; w_expansion=None; w_expr }
-      | None ->
-        failwith "error")
+      let w_expr = Odoc_model.Lang.umty_of_mty body in
+      With {w_substitutions=subs; w_expansion=None; w_expr })
     | Tmty_typeof mexpr ->
         let decl =
           match mexpr.mod_desc with
@@ -757,12 +754,8 @@ and read_include env parent incl =
   let expr = read_module_type env parent container incl.incl_mod in
   let umty = Odoc_model.Lang.umty_of_mty expr in 
   let expansion = { content; shadowed; } in
-  match umty with
-  | Some uexpr ->
-    let decl = Include.ModuleType uexpr in
-    [Include {parent; doc; decl; expansion; status; strengthened=None; loc }]
-  | _ ->
-    content.items
+  let decl = Include.ModuleType umty in
+  [Include {parent; doc; decl; expansion; status; strengthened=None; loc }]
 
 and read_open env parent o =
   let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in

src/model/lang.ml

@@ -81,19 +81,15 @@ and ModuleType : sig
     | Signature of Signature.t
     | Functor of FunctorParameter.t * simple_expansion
 
-  type typeof_t = {
-    t_desc : type_of_desc;
-    t_expansion : simple_expansion option;
-  }
-
   module U : sig
     type expr =
       | Path of Path.ModuleType.t
       | Signature of Signature.t
+      | Functor of FunctorParameter.t * expr
       | With of substitution list * expr
-      | TypeOf of typeof_t
-
-    (* Nb. this may have an expansion! *)
+      | TypeOf of type_of_desc
+      | Project of Projection.t * expr
+      | Strengthen of Path.Module.t * expr
   end
 
   type path_t = {
@@ -107,12 +103,24 @@ and ModuleType : sig
     w_expr : U.expr;
   }
 
+  type typeof_t = {
+    t_desc : type_of_desc;
+    t_expansion : simple_expansion option;
+  }
+
+  type strengthen_t = {
+    s_path : Path.Module.t;
+    s_expansion : simple_expansion option;
+    s_expr : U.expr;
+  }
+
   type expr =
     | Path of path_t
     | Signature of Signature.t
     | Functor of FunctorParameter.t * expr
     | With of with_t
     | TypeOf of typeof_t
+    | Strengthen of strengthen_t
 
   type t = {
     id : Identifier.ModuleType.t;
@@ -520,12 +528,13 @@ module rec SourceTree : sig
 end =
   SourceTree
 
-let umty_of_mty : ModuleType.expr -> ModuleType.U.expr option = function
-  | Signature sg -> Some (Signature sg)
-  | Path { p_path; _ } -> Some (Path p_path)
-  | Functor _ -> None
-  | TypeOf t -> Some (TypeOf t)
-  | With { w_substitutions; w_expr; _ } -> Some (With (w_substitutions, w_expr))
+let rec umty_of_mty : ModuleType.expr -> ModuleType.U.expr = function
+  | Signature sg -> Signature sg
+  | Path { p_path; _ } -> Path p_path
+  | Functor (p, e) -> Functor (p, umty_of_mty e)
+  | TypeOf t -> TypeOf t.t_desc
+  | With { w_substitutions; w_expr; _ } -> With (w_substitutions, w_expr)
+  | Strengthen { s_path; s_expr; _ } -> Strengthen (s_path, s_expr)
 
 (** Query the top-comment of a signature. This is [s.doc] most of the time with
     an exception for signature starting with an inline includes. *)

src/model/paths.ml

@@ -688,6 +688,10 @@ module Path = struct
   let is_hidden = is_path_hidden
 end
 
+module Projection = struct
+  type t = Paths_types.Path.projection
+end
+
 module Fragment = struct
   module Resolved = struct
     type t = Paths_types.Resolved_fragment.any

src/model/paths.mli

@@ -366,6 +366,11 @@ module rec Path : sig
   val is_hidden : t -> bool
 end
 
+(** Suffixes of module paths *)
+module Projection : sig
+  type t = Paths_types.Path.projection
+end
+
 (** OCaml path fragments for specifying module substitutions *)
 module Fragment : sig
   module Resolved : sig

src/model/paths_types.ml

@@ -327,6 +327,10 @@ module rec Path : sig
     | `Dot of module_ * string
     | `Apply of module_ * module_ ]
   (** @canonical Odoc_model.Paths.Path.t *)
+
+  type projection =
+    [ `Here | `Dot of projection * string | `Apply of projection * module_ ]
+  (** @canonical Odoc_model.Paths.Projection.t *)
 end =
   Path
 

src/model_desc/lang_desc.ml

@@ -143,6 +143,15 @@ and moduletype_typeof_t =
       F ("t_expansion", (fun t -> t.t_expansion), Option simple_expansion);
     ]
 
+and moduletype_strengthen_t =
+  let open Lang.ModuleType in
+  Record
+    [
+      F ("s_path", (fun t -> (t.s_path :> Paths.Path.t)), path);
+      F ("s_expr", (fun t -> t.s_expr), moduletype_u_expr);
+      F ("s_expansion", (fun t -> t.s_expansion), Option simple_expansion);
+    ]
+
 and moduletype_expr =
   let open Lang.ModuleType in
   Variant
@@ -152,20 +161,30 @@ and moduletype_expr =
     | Functor (x1, x2) ->
         C ("Functor", (x1, x2), Pair (functorparameter_t, moduletype_expr))
     | With t -> C ("With", t, moduletype_with_t)
-    | TypeOf x -> C ("TypeOf", x, moduletype_typeof_t))
+    | TypeOf x -> C ("TypeOf", x, moduletype_typeof_t)
+    | Strengthen x -> C ("Strengthen", x, moduletype_strengthen_t))
 
 and moduletype_u_expr =
   let open Lang.ModuleType.U in
   Variant
     (function
     | Path x -> C ("Path", (x :> Paths.Path.t), path)
     | Signature x -> C ("Signature", x, signature_t)
+    | Functor (x1, x2) ->
+        C ("Functor", (x1, x2), Pair (functorparameter_t, moduletype_u_expr))
     | With (t, e) ->
         C
           ( "With",
             (t, e),
             Pair (List moduletype_substitution, moduletype_u_expr) )
-    | TypeOf x -> C ("TypeOf", x, moduletype_typeof_t))
+    | TypeOf x -> C ("TypeOf", x, moduletype_type_of_desc)
+    | Project (x1, x2) ->
+        C ("Project", (x1, x2), Pair (projection, moduletype_u_expr))
+    | Strengthen (x1, x2) ->
+        C
+          ( "Strengthen",
+            ((x1 :> Paths.Path.t), x2),
+            Pair (path, moduletype_u_expr) ))
 
 and moduletype_t =
   let open Lang.ModuleType in

src/model_desc/paths_desc.ml

@@ -392,6 +392,14 @@ module General_paths = struct
               ((x1 :> rr), x2),
               Pair (resolved_reference, Names.valuename) ))
 
+  let rec projection : Paths.Projection.t t =
+    Variant
+      (function
+      | `Here -> C0 "`Here"
+      | `Dot (proj, s) -> C ("`Dot", (proj, s), Pair (projection, string))
+      | `Apply (proj, m) ->
+          C ("`Apply", (proj, (m :> p)), Pair (projection, path)))
+
   let resolved_fragment_root : Paths.Fragment.Resolved.root t =
     Variant
       (function
@@ -458,6 +466,8 @@ let resolved_path : [< Paths.Path.Resolved.t ] Type_desc.t =
 let path : [< Paths.Path.t ] Type_desc.t =
   Indirect ((fun n -> (n :> General_paths.p)), General_paths.path)
 
+let projection = General_paths.projection
+
 let resolved_fragment =
   Indirect ((fun n -> (n :> General_paths.rf)), General_paths.resolved_fragment)
 

src/model_desc/paths_desc.mli

@@ -10,6 +10,8 @@ val resolved_path : [< Path.Resolved.t ] Type_desc.t
 
 val path : [< Path.t ] Type_desc.t
 
+val projection : Projection.t Type_desc.t
+
 val resolved_fragment : [< Fragment.Resolved.t ] Type_desc.t
 
 val fragment : [< Fragment.t ] Type_desc.t