Support for "with module type" constraints

src/document/generator.ml

@@ -165,11 +165,16 @@ module Make (Syntax : SYNTAX) = struct
         | `Subst (_, rr) -> render_resolved_fragment (rr :> t)
         | `SubstAlias (_, rr) -> render_resolved_fragment (rr :> t)
         | `Module (`Root _, s) -> ModuleName.to_string s
+        | `Module_type (`Root _, s) -> ModuleTypeName.to_string s
         | `Type (`Root _, s) -> TypeName.to_string s
         | `Class (`Root _, s) -> ClassName.to_string s
         | `ClassType (`Root _, s) -> ClassTypeName.to_string s
         | `Module (rr, s) ->
             dot (render_resolved_fragment (rr :> t)) (ModuleName.to_string s)
+        | `Module_type (rr, s) ->
+            dot
+              (render_resolved_fragment (rr :> t))
+              (ModuleTypeName.to_string s)
         | `Type (rr, s) ->
             dot (render_resolved_fragment (rr :> t)) (TypeName.to_string s)
         | `Class (rr, s) ->
@@ -1094,6 +1099,12 @@ module Make (Syntax : SYNTAX) = struct
       | `Module (_, name) when ModuleName.is_internal name -> true
       | _ -> false
 
+    let internal_module_type_substitution t =
+      let open Lang.ModuleTypeSubstitution in
+      match t.id with
+      | `ModuleType (_, name) when ModuleTypeName.is_internal name -> true
+      | _ -> false
+
     let rec signature (s : Lang.Signature.t) =
       let rec loop l acc_items =
         match l with
@@ -1107,6 +1118,10 @@ module Make (Syntax : SYNTAX) = struct
             | ModuleType m when internal_module_type m -> loop rest acc_items
             | ModuleSubstitution m when internal_module_substitution m ->
                 loop rest acc_items
+            | ModuleTypeSubstitution m when internal_module_type_substitution m
+              ->
+                loop rest acc_items
+            | ModuleTypeSubstitution m -> continue @@ module_type_substitution m
             | Module (_, m) -> continue @@ module_ m
             | ModuleType m -> continue @@ module_type m
             | Class (_, c) -> continue @@ class_ c
@@ -1186,6 +1201,24 @@ module Make (Syntax : SYNTAX) = struct
       let doc = Comment.to_ir t.doc in
       Item.Declaration { attr; anchor; doc; content }
 
+    and module_type_substitution (t : Odoc_model.Lang.ModuleTypeSubstitution.t)
+        =
+      let modname = Paths.Identifier.name t.id in
+      let modname, expansion_doc, mty =
+        module_type_manifest ~subst:true modname t.id t.doc (Some t.manifest)
+      in
+      let content =
+        O.documentedSrc
+          (O.keyword "module" ++ O.txt " " ++ O.keyword "type" ++ O.txt " ")
+        @ modname @ mty
+        @ O.documentedSrc
+            (if Syntax.Mod.close_tag_semicolon then O.txt ";" else O.noop)
+      in
+      let attr = [ "module-type" ] in
+      let anchor = path_to_id t.id in
+      let doc = Comment.synopsis ~decl_doc:t.doc ~expansion_doc in
+      Item.Declaration { attr; anchor; doc; content }
+
     and simple_expansion :
         Odoc_model.Lang.ModuleType.simple_expansion ->
         Comment.Comment.docs * Item.t list =
@@ -1327,31 +1360,37 @@ module Make (Syntax : SYNTAX) = struct
       | Alias (mod_path, _) -> Link.from_path (mod_path :> Paths.Path.t)
       | ModuleType mt -> mty mt
 
-    and module_type (t : Odoc_model.Lang.ModuleType.t) =
-      let modname = Paths.Identifier.name t.id in
+    and module_type_manifest ~subst modname id doc manifest =
       let expansion =
-        match t.expr with
+        match manifest with
         | None -> None
         | Some e -> expansion_of_module_type_expr e
       in
       let modname, expansion, expansion_doc =
         match expansion with
         | None -> (O.documentedSrc @@ O.txt modname, None, None)
         | Some (expansion_doc, items) ->
-            let url = Url.Path.from_identifier t.id in
+            let url = Url.Path.from_identifier id in
             let link = path url [ inline @@ Text modname ] in
             let page =
-              make_expansion_page modname `Mty url [ t.doc; expansion_doc ]
-                items
+              make_expansion_page modname `Mty url [ doc; expansion_doc ] items
             in
             (O.documentedSrc link, Some page, Some expansion_doc)
       in
       let summary =
-        match t.expr with
+        match manifest with
         | None -> O.noop
-        | Some expr -> O.txt " = " ++ mty expr
+        | Some expr -> (if subst then O.txt " := " else O.txt " = ") ++ mty expr
+      in
+      ( modname,
+        expansion_doc,
+        attach_expansion (" = ", "sig", "end") expansion summary )
+
+    and module_type (t : Odoc_model.Lang.ModuleType.t) =
+      let modname = Paths.Identifier.name t.id in
+      let modname, expansion_doc, mty =
+        module_type_manifest ~subst:false modname t.id t.doc t.expr
       in
-      let mty = attach_expansion (" = ", "sig", "end") expansion summary in
       let content =
         O.documentedSrc
           (O.keyword "module" ++ O.txt " " ++ O.keyword "type" ++ O.txt " ")
@@ -1491,6 +1530,10 @@ module Make (Syntax : SYNTAX) = struct
           O.keyword "module" ++ O.sp
           ++ Link.from_fragment (frag_mod :> Paths.Fragment.leaf)
           ++ O.sp ++ O.txt "= " ++ mdexpr md
+      | ModuleTypeEq (frag_mty, md) ->
+          O.keyword "module" ++ O.txt " " ++ O.keyword "type" ++ O.txt " "
+          ++ Link.from_fragment (frag_mty :> Paths.Fragment.leaf)
+          ++ O.txt " = " ++ mty md
       | TypeEq (frag_typ, td) ->
           O.keyword "type" ++ O.sp
           ++ type_expr_in_subst td (frag_typ :> Paths.Fragment.leaf)
@@ -1501,6 +1544,10 @@ module Make (Syntax : SYNTAX) = struct
           ++ Link.from_fragment (frag_mod :> Paths.Fragment.leaf)
           ++ O.sp ++ O.txt ":= "
           ++ Link.from_path (mod_path :> Paths.Path.t)
+      | ModuleTypeSubst (frag_mty, md) ->
+          O.keyword "module" ++ O.txt " " ++ O.keyword "type" ++ O.txt " "
+          ++ Link.from_fragment (frag_mty :> Paths.Fragment.leaf)
+          ++ O.txt " := " ++ mty md
       | TypeSubst (frag_typ, td) -> (
           O.keyword "type" ++ O.sp
           ++ type_expr_in_subst td (frag_typ :> Paths.Fragment.leaf)

src/document/targets.ml

@@ -18,8 +18,9 @@ and signature (t : Odoc_model.Lang.Signature.t) =
         | Module (_, md) -> add_items ~don't (module_ md :: acc) is
         | ModuleType mty -> add_items ~don't (module_type mty :: acc) is
         | Include incl -> add_items ~don't (include_ incl :: acc) is
-        | Open _ | ModuleSubstitution _ | TypeSubstitution _ | Type _ | TypExt _
-        | Exception _ | Value _ | External _ | Class _ | ClassType _
+        | Open _ | ModuleSubstitution _ | ModuleTypeSubstitution _
+        | TypeSubstitution _ | Type _ | TypExt _ | Exception _ | Value _
+        | External _ | Class _ | ClassType _
         | Comment (`Docs _) ->
             add_items ~don't acc is)
   in

src/loader/cmti.ml

@@ -451,7 +451,8 @@ let read_class_descriptions env parent clds =
   |> fst
   |> List.rev
 
-let rec read_with_constraint env parent (_, frag, constr) =
+let rec read_with_constraint env global_parent parent (_, frag, constr) =
+  let _ = global_parent in
   let open ModuleType in
     match constr with
     | Twith_type decl ->
@@ -470,9 +471,15 @@ let rec read_with_constraint env parent (_, frag, constr) =
         let frag = Env.Fragment.read_module frag.Location.txt in
         let p = Env.Path.read_module env p in
           ModuleSubst(frag, p)
-#if OCAML_VERSION >= (4,13,0)
-   | Twith_modtype _ -> failwith "with module type not yet implemented"
-   | Twith_modtypesubst _ -> failwith "with module type not yet implemented"
+ #if OCAML_VERSION >= (4,13,0)
+    | Twith_modtype mty ->
+        let frag = Env.Fragment.read_module_type frag.Location.txt in
+        let mty = read_module_type env global_parent parent mty in
+        ModuleTypeEq(frag, mty)
+    | Twith_modtypesubst mty ->
+        let frag = Env.Fragment.read_module_type frag.Location.txt in
+        let mty = read_module_type env global_parent parent mty in
+        ModuleTypeSubst(frag, mty)
 #endif
 
 and read_module_type env parent label_parent mty =
@@ -517,7 +524,7 @@ and read_module_type env parent label_parent mty =
 #endif
     | Tmty_with(body, subs) -> (
       let body = read_module_type env parent label_parent body in
-      let subs = List.map (read_with_constraint env label_parent) subs 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 }
@@ -686,7 +693,8 @@ and read_signature_item env parent item =
     | Tsig_modsubst mst ->
         [ModuleSubstitution (read_module_substitution env parent mst)]
 #if OCAML_VERSION >= (4,13,0)
-    | Tsig_modtypesubst _ -> failwith "local module type substitution not yet implemented"
+    | Tsig_modtypesubst mtst ->
+        [ModuleTypeSubstitution (read_module_type_substitution env parent mtst)]
 #endif
 
 
@@ -697,6 +705,21 @@ and read_module_substitution env parent ms =
   let doc, () = Doc_attr.attached Odoc_model.Semantics.Expect_none container ms.ms_attributes in
   let manifest = Env.Path.read_module env ms.ms_manifest in
   { id; doc; manifest }
+
+#if OCAML_VERSION >= (4,13,0)
+and read_module_type_substitution env parent mtd =
+  let open ModuleTypeSubstitution in
+  let id = Env.find_module_type env mtd.mtd_id in
+  let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
+  let doc, () = Doc_attr.attached Odoc_model.Semantics.Expect_none container mtd.mtd_attributes in
+  let expr = match opt_map (read_module_type env (id :> Identifier.Signature.t) container) mtd.mtd_type with
+    | None -> assert false
+    | Some x -> x
+  in
+  {id; doc; manifest=expr;}
+#endif
+
+
 #endif
 
 and read_include env parent incl =

src/loader/ident_env.cppo.ml

@@ -596,6 +596,11 @@ module Fragment = struct
     | Longident.Ldot(p, s) -> `Dot((read_module p :> Paths.Fragment.Signature.t), s)
     | Longident.Lapply _ -> assert false
 
+  let read_module_type : Longident.t -> Paths.Fragment.ModuleType.t = function
+    | Longident.Lident s -> `Dot(`Root, s)
+    | Longident.Ldot(p, s) -> `Dot((read_module p :> Paths.Fragment.Signature.t), s)
+    | Longident.Lapply _ -> assert false
+
   let read_type = function
     | Longident.Lident s -> `Dot(`Root, s)
     | Longident.Ldot(p, s) -> `Dot((read_module p :> Paths.Fragment.Signature.t), s)

src/loader/ident_env.cppo.mli

@@ -63,5 +63,7 @@ val find_class_type_identifier : t -> Ident.t -> Paths.Identifier.ClassType.t
 module Fragment : sig
   val read_module : Longident.t -> Paths.Fragment.Module.t
 
+  val read_module_type : Longident.t -> Paths.Fragment.ModuleType.t
+
   val read_type : Longident.t -> Paths.Fragment.Type.t
 end

src/model/lang.ml

@@ -52,8 +52,10 @@ end =
 and ModuleType : sig
   type substitution =
     | ModuleEq of Fragment.Module.t * Module.Equation.t
+    | ModuleTypeEq of Fragment.ModuleType.t * ModuleType.expr
     | TypeEq of Fragment.Type.t * TypeDecl.Equation.t
     | ModuleSubst of Fragment.Module.t * Path.Module.t
+    | ModuleTypeSubst of Fragment.ModuleType.t * ModuleType.expr
     | TypeSubst of Fragment.Type.t * TypeDecl.Equation.t
 
   type type_of_desc =
@@ -115,6 +117,15 @@ and ModuleSubstitution : sig
 end =
   ModuleSubstitution
 
+and ModuleTypeSubstitution : sig
+  type t = {
+    id : Identifier.ModuleType.t;
+    doc : Comment.docs;
+    manifest : ModuleType.expr;
+  }
+end =
+  ModuleTypeSubstitution
+
 (** {3 Signatures} *)
 
 and Signature : sig
@@ -124,6 +135,7 @@ and Signature : sig
     | Module of recursive * Module.t
     | ModuleType of ModuleType.t
     | ModuleSubstitution of ModuleSubstitution.t
+    | ModuleTypeSubstitution of ModuleTypeSubstitution.t
     | Open of Open.t
     | Type of recursive * TypeDecl.t
     | TypeSubstitution of TypeDecl.t

src/model/paths.ml

@@ -735,6 +735,17 @@ module Fragment = struct
         | `OpaqueModule m -> split m
     end
 
+    module ModuleType = struct
+      type t = Paths_types.Resolved_fragment.module_type
+
+      let split : t -> string * t option = function
+        | `Module_type (m, name) -> (
+            match split_parent m with
+            | Base _ -> (ModuleTypeName.to_string name, None)
+            | Branch (base, m) ->
+                (ModuleName.to_string base, Some (`Module_type (m, name))))
+    end
+
     module Type = struct
       type t = Paths_types.Resolved_fragment.type_
 
@@ -765,6 +776,7 @@ module Fragment = struct
       | `SubstAlias (p, _) ->
           (Path.Resolved.Module.identifier p :> Identifier.t)
       | `Module (m, n) -> `Module (Signature.identifier m, n)
+      | `Module_type (m, n) -> `ModuleType (Signature.identifier m, n)
       | `Type (m, n) -> `Type (Signature.identifier m, n)
       | `Class (m, n) -> `Class (Signature.identifier m, n)
       | `ClassType (m, n) -> `ClassType (Signature.identifier m, n)
@@ -775,7 +787,11 @@ module Fragment = struct
       | `Root (`Module r) -> Path.is_resolved_hidden (r :> Path.Resolved.t)
       | `Subst (s, _) -> Path.is_resolved_hidden (s :> Path.Resolved.t)
       | `SubstAlias (s, _) -> Path.is_resolved_hidden (s :> Path.Resolved.t)
-      | `Module (m, _) | `Type (m, _) | `Class (m, _) | `ClassType (m, _) ->
+      | `Module (m, _)
+      | `Module_type (m, _)
+      | `Type (m, _)
+      | `Class (m, _)
+      | `ClassType (m, _) ->
           is_hidden (m :> t)
       | `OpaqueModule m -> is_hidden (m :> t)
   end
@@ -829,6 +845,21 @@ module Fragment = struct
               (ModuleName.to_string base, Some (`Dot (m, name))))
   end
 
+  module ModuleType = struct
+    type t = Paths_types.Fragment.module_type
+
+    let split : t -> string * t option = function
+      | `Resolved r ->
+          let base, m = Resolved.ModuleType.split r in
+          let m = match m with None -> None | Some m -> Some (`Resolved m) in
+          (base, m)
+      | `Dot (m, name) -> (
+          match split_parent m with
+          | Base _ -> (name, None)
+          | Branch (base, m) ->
+              (ModuleName.to_string base, Some (`Dot (m, name))))
+  end
+
   module Type = struct
     type t = Paths_types.Fragment.type_
 

src/model/paths.mli

@@ -502,6 +502,12 @@ module Fragment : sig
       val split : t -> string * t option
     end
 
+    module ModuleType : sig
+      type t = Paths_types.Resolved_fragment.module_type
+
+      val split : t -> string * t option
+    end
+
     module Type : sig
       type t = Paths_types.Resolved_fragment.type_
 
@@ -531,6 +537,12 @@ module Fragment : sig
     val split : t -> string * t option
   end
 
+  module ModuleType : sig
+    type t = Paths_types.Fragment.module_type
+
+    val split : t -> string * t option
+  end
+
   module Type : sig
     type t = Paths_types.Fragment.type_
 

src/model/paths_types.ml

@@ -266,6 +266,10 @@ module rec Fragment : sig
     [ `Resolved of Resolved_fragment.module_ | `Dot of signature * string ]
   (** @canonical Odoc_model.Paths.Fragment.Module.t *)
 
+  type module_type =
+    [ `Resolved of Resolved_fragment.module_type | `Dot of signature * string ]
+  (** @canonical Odoc_model.Paths.Fragment.ModuleType.t *)
+
   type type_ =
     [ `Resolved of Resolved_fragment.type_ | `Dot of signature * string ]
   (** @canonical Odoc_model.Paths.Fragment.Type.t *)
@@ -307,7 +311,10 @@ and Resolved_fragment : sig
     | `ClassType of signature * ClassTypeName.t ]
   (** @canonical Odoc_model.Paths.Fragment.Resolved.Type.t *)
 
-  type leaf = [ module_ | type_ ]
+  and module_type = [ `Module_type of signature * ModuleTypeName.t ]
+  (** @canonical Odoc_model.Paths.Fragment.Resolved.ModuleType.t *)
+
+  type leaf = [ module_ | module_type | type_ ]
   (** @canonical Odoc_model.Paths.Fragment.Resolved.leaf *)
 
   (* Absence of `Root here might make coersions annoying *)
@@ -316,6 +323,7 @@ and Resolved_fragment : sig
     | `Subst of Resolved_path.module_type * module_
     | `SubstAlias of Resolved_path.module_ * module_
     | `Module of signature * ModuleName.t
+    | `Module_type of signature * ModuleTypeName.t
     | `Type of signature * TypeName.t
     | `Class of signature * ClassName.t
     | `ClassType of signature * ClassTypeName.t