Handle comments attached to class constraint and inherit

src/document/generator.ml

@@ -954,20 +954,27 @@ module Make (Syntax : SYNTAX) = struct
       let doc = Comment.to_ir t.doc in
       Item.Declaration { attr; anchor; doc; content }
 
-    let inherit_ cte =
+    let inherit_ (ih : Lang.ClassSignature.Inherit.t) =
+      let cte =
+        match ih.expr with
+        | Signature _ -> assert false (* Bold. *)
+        | cty -> cty
+      in
       let content =
         O.documentedSrc (O.keyword "inherit" ++ O.txt " " ++ class_type_expr cte)
       in
       let attr = [ "inherit" ] in
       let anchor = None in
-      let doc = [] in
+      let doc = Comment.to_ir ih.doc in
       Item.Declaration { attr; anchor; doc; content }
 
-    let constraint_ t1 t2 =
-      let content = O.documentedSrc (format_constraints [ (t1, t2) ]) in
+    let constraint_ (cst : Lang.ClassSignature.Constraint.t) =
+      let content =
+        O.documentedSrc (format_constraints [ (cst.left, cst.right) ])
+      in
       let attr = [] in
       let anchor = None in
-      let doc = [] in
+      let doc = Comment.to_ir cst.doc in
       Item.Declaration { attr; anchor; doc; content }
 
     let class_signature (c : Lang.ClassSignature.t) =
@@ -977,11 +984,10 @@ module Make (Syntax : SYNTAX) = struct
         | item :: rest -> (
             let continue item = loop rest (item :: acc_items) in
             match (item : Lang.ClassSignature.item) with
-            | Inherit (Signature _) -> assert false (* Bold. *)
             | Inherit cty -> continue @@ inherit_ cty
             | Method m -> continue @@ method_ m
             | InstanceVariable v -> continue @@ instance_variable v
-            | Constraint (t1, t2) -> continue @@ constraint_ t1 t2
+            | Constraint cst -> continue @@ constraint_ cst
             | Comment `Stop ->
                 let rest =
                   Utils.skip_until rest ~p:(function

src/loader/cmi.ml

@@ -691,6 +691,12 @@ let read_type_constraints env params =
        else acc)
     params []
 
+let read_class_constraints env params =
+  let open ClassSignature in
+  read_type_constraints env params
+  |> List.map (fun (left, right) ->
+         Constraint { Constraint.left; right; doc = [] })
+
 let read_type_declaration env parent id decl =
   let open TypeDecl in
   let id = Env.find_type_identifier env id in
@@ -810,12 +816,7 @@ let rec read_class_signature env parent params =
   | Cty_signature csig ->
       let open ClassSignature in
       let self = read_self_type csig.csig_self in
-      let constraints = read_type_constraints env params in
-      let constraints =
-        List.map
-          (fun (typ1, typ2) -> Constraint(typ1, typ2))
-          constraints
-      in
+      let constraints = read_class_constraints env params in
       let instance_variables =
         Vars.fold
           (fun name (mutable_, virtual_, typ) acc ->

src/loader/cmi.mli

@@ -51,6 +51,11 @@ val read_type_constraints : Ident_env.t -> Types.type_expr list ->
                             (Odoc_model.Lang.TypeExpr.t
                              * Odoc_model.Lang.TypeExpr.t) list
 
+val read_class_constraints :
+  Ident_env.t ->
+  Types.type_expr list ->
+  Odoc_model.Lang.ClassSignature.item list
+
 val read_class_signature : Ident_env.t ->
                            Paths.Identifier.ClassSignature.t ->
                            Types.type_expr list -> Types.class_type ->

src/loader/cmt.ml

@@ -124,10 +124,16 @@ let read_type_extension env parent tyext =
   in
     { parent; type_path; doc; type_params; private_; constructors; }
 
+(** Make a standalone comment out of a comment attached to an item that isn't
+    rendered. For example, [constraint] items are read separately and not
+    associated with their comment. *)
+let mk_class_comment = function
+  | [] -> None
+  | doc -> Some (ClassSignature.Comment (`Docs doc))
+
 let rec read_class_type_field env parent ctf =
   let open ClassSignature in
   let open Odoc_model.Names in
-
   let container = (parent : Identifier.ClassSignature.t :> Identifier.LabelParent.t) in
   let doc = Doc_attr.attached_no_tag container ctf.ctf_attributes in
   match ctf.ctf_desc with
@@ -145,9 +151,10 @@ let rec read_class_type_field env parent ctf =
       let virtual_ = (virtual_ = Virtual) in
       let type_ = read_core_type env typ in
         Some (Method {id; doc; private_; virtual_; type_})
-  | Tctf_constraint(_, _) -> None
+  | Tctf_constraint(_, _) -> mk_class_comment doc
   | Tctf_inherit cltyp ->
-      Some (Inherit (read_class_signature env parent [] cltyp))
+      let expr = read_class_signature env parent [] cltyp in
+      Some (Inherit {Inherit.expr; doc})
   | Tctf_attribute attr ->
       match Doc_attr.standalone container attr with
       | None -> None
@@ -165,14 +172,7 @@ and read_class_signature env parent params cltyp =
         let self =
           Cmi.read_self_type csig.csig_self.ctyp_type
         in
-        let constraints =
-          Cmi.read_type_constraints env params
-        in
-        let constraints =
-          List.map
-            (fun (typ1, typ2) -> Constraint(typ1, typ2))
-            constraints
-        in
+        let constraints = Cmi.read_class_constraints env params in
         let items =
           List.fold_left
             (fun rest item ->
@@ -242,10 +242,11 @@ let rec read_class_field env parent cf =
             false, Cmi.read_type_expr env expr.exp_type
       in
         Some (Method {id; doc; private_; virtual_; type_})
-  | Tcf_constraint(_, _) -> None
+  | Tcf_constraint(_, _) -> mk_class_comment doc
   | Tcf_inherit(_, cl, _, _, _) ->
-      Some (Inherit (read_class_structure env parent [] cl))
-  | Tcf_initializer _ -> None
+      let expr = read_class_structure env parent [] cl in
+      Some (Inherit {Inherit.expr; doc})
+  | Tcf_initializer _ -> mk_class_comment doc
   | Tcf_attribute attr ->
       match Doc_attr.standalone container attr with
       | None -> None
@@ -259,14 +260,7 @@ and read_class_structure env parent params cl =
     | Tcl_structure cstr ->
         let open ClassSignature in
         let self = Cmi.read_self_type cstr.cstr_self.pat_type in
-        let constraints =
-          Cmi.read_type_constraints env params
-        in
-        let constraints =
-          List.map
-            (fun (typ1, typ2) -> Constraint(typ1, typ2))
-            constraints
-        in
+        let constraints = Cmi.read_class_constraints env params in
         let items =
           List.fold_left
             (fun rest item ->

src/loader/cmti.ml

@@ -347,7 +347,6 @@ let read_exception env parent (ext : extension_constructor) =
 let rec read_class_type_field env parent ctf =
   let open ClassSignature in
   let open Odoc_model.Names in
-
   let container = (parent : Identifier.ClassSignature.t :> Identifier.LabelParent.t) in
   let doc = Doc_attr.attached_no_tag container ctf.ctf_attributes in
   match ctf.ctf_desc with
@@ -356,21 +355,22 @@ let rec read_class_type_field env parent ctf =
       let id = Identifier.Mk.instance_variable(parent, InstanceVariableName.make_std name) in
       let mutable_ = (mutable_ = Mutable) in
       let virtual_ = (virtual_ = Virtual) in
-    let type_ = read_core_type env container typ in
-        Some (InstanceVariable {id; doc; mutable_; virtual_; type_})
+      let type_ = read_core_type env container typ in
+      Some (InstanceVariable {id; doc; mutable_; virtual_; type_})
   | Tctf_method(name, private_, virtual_, typ) ->
       let open Method in
       let id = Identifier.Mk.method_(parent, MethodName.make_std name) in
       let private_ = (private_ = Private) in
       let virtual_ = (virtual_ = Virtual) in
-    let type_ = read_core_type env container typ in
-        Some (Method {id; doc; private_; virtual_; type_})
+      let type_ = read_core_type env container typ in
+      Some (Method {id; doc; private_; virtual_; type_})
   | Tctf_constraint(typ1, typ2) ->
-    let typ1 = read_core_type env container typ1 in
-    let typ2 = read_core_type env container typ2 in
-        Some (Constraint(typ1, typ2))
+      let left = read_core_type env container typ1 in
+      let right = read_core_type env container typ2 in
+      Some (Constraint {left; right; doc})
   | Tctf_inherit cltyp ->
-      Some (Inherit (read_class_signature env parent container cltyp))
+      let expr = read_class_signature env parent container cltyp in
+      Some (Inherit {expr; doc})
   | Tctf_attribute attr ->
       match Doc_attr.standalone container attr with
       | None -> None

src/model/lang.ml

@@ -335,11 +335,19 @@ end =
 (** {3 Class Signatures} *)
 
 and ClassSignature : sig
+  module Constraint : sig
+    type t = { left : TypeExpr.t; right : TypeExpr.t; doc : Comment.docs }
+  end
+
+  module Inherit : sig
+    type t = { expr : ClassType.expr; doc : Comment.docs }
+  end
+
   type item =
     | Method of Method.t
     | InstanceVariable of InstanceVariable.t
-    | Constraint of TypeExpr.t * TypeExpr.t
-    | Inherit of ClassType.expr
+    | Constraint of Constraint.t
+    | Inherit of Inherit.t
     | Comment of Comment.docs_or_stop
 
   type t = { self : TypeExpr.t option; items : item list; doc : Comment.docs }

src/model_desc/lang_desc.ml

@@ -470,9 +470,12 @@ and classsignature_item =
     (function
     | Method x -> C ("Method", x, method_t)
     | InstanceVariable x -> C ("InstanceVariable", x, instancevariable_t)
-    | Constraint (x1, x2) ->
-        C ("Constraint", (x1, x2), Pair (typeexpr_t, typeexpr_t))
-    | Inherit x -> C ("Inherit", x, classtype_expr)
+    | Constraint cst ->
+        C
+          ( "Constraint",
+            (cst.left, cst.right, cst.doc),
+            Triple (typeexpr_t, typeexpr_t, docs) )
+    | Inherit ih -> C ("Inherit", (ih.expr, ih.doc), Pair (classtype_expr, docs))
     | Comment x -> C ("Comment", x, docs_or_stop))
 
 and classsignature_t =

src/xref2/compile.ml

@@ -139,10 +139,8 @@ and class_signature env parent c =
   let map_item = function
     | Method m -> Method (method_ env parent m)
     | InstanceVariable i -> InstanceVariable (instance_variable env parent i)
-    | Constraint (t1, t2) ->
-        Constraint
-          (type_expression env container t1, type_expression env container t2)
-    | Inherit c -> Inherit (class_type_expr env parent c)
+    | Constraint cst -> Constraint (class_constraint env container cst)
+    | Inherit ih -> Inherit (inherit_ env parent ih)
     | Comment c -> Comment c
   in
   {
@@ -161,6 +159,18 @@ and instance_variable env parent i =
   let container = (parent :> Id.Parent.t) in
   { i with type_ = type_expression env container i.type_ }
 
+and class_constraint env parent cst =
+  let open ClassSignature.Constraint in
+  {
+    cst with
+    left = type_expression env parent cst.left;
+    right = type_expression env parent cst.right;
+  }
+
+and inherit_ env parent ih =
+  let open ClassSignature.Inherit in
+  { ih with expr = class_type_expr env parent ih.expr }
+
 and class_ env parent c =
   let open Class in
   let container = (parent :> Id.Parent.t) in

src/xref2/component.ml

@@ -378,11 +378,19 @@ end =
   ClassType
 
 and ClassSignature : sig
+  module Constraint : sig
+    type t = { left : TypeExpr.t; right : TypeExpr.t; doc : CComment.docs }
+  end
+
+  module Inherit : sig
+    type t = { expr : ClassType.expr; doc : CComment.docs }
+  end
+
   type item =
     | Method of Ident.method_ * Method.t
     | InstanceVariable of Ident.instance_variable * InstanceVariable.t
-    | Constraint of TypeExpr.t * TypeExpr.t
-    | Inherit of ClassType.expr
+    | Constraint of Constraint.t
+    | Inherit of Inherit.t
     | Comment of CComment.docs_or_stop
 
   type t = { self : TypeExpr.t option; items : item list; doc : CComment.docs }
@@ -602,10 +610,12 @@ module Fmt = struct
         | InstanceVariable (id, i) ->
             Format.fprintf ppf "@[<v 2>instance variable %a : %a@]@," Ident.fmt
               id instance_variable i
-        | Constraint (t1, t2) ->
-            Format.fprintf ppf "@[<v 2>constraint %a = %a@]@," type_expr t1
-              type_expr t2
-        | Inherit i -> Format.fprintf ppf "@[<v 2>inherit %a" class_type_expr i
+        | Constraint cst ->
+            Format.fprintf ppf "@[<v 2>constraint %a = %a@]@," type_expr
+              cst.Constraint.left type_expr cst.right
+        | Inherit i ->
+            Format.fprintf ppf "@[<v 2>inherit %a" class_type_expr
+              i.Inherit.expr
         | Comment _ -> ())
       sg.items
 
@@ -2223,10 +2233,8 @@ module Of_Lang = struct
               let id = Ident.Of_Identifier.instance_variable i.id in
               let i' = instance_variable ident_map i in
               ClassSignature.InstanceVariable (id, i')
-          | Constraint (t1, t2) ->
-              Constraint
-                (type_expression ident_map t1, type_expression ident_map t2)
-          | Inherit e -> Inherit (class_type_expr ident_map e)
+          | Constraint cst -> Constraint (class_constraint ident_map cst)
+          | Inherit e -> Inherit (inherit_ ident_map e)
           | Comment c -> Comment (docs_or_stop ident_map c))
         sg.items
     in
@@ -2253,6 +2261,19 @@ module Of_Lang = struct
       type_ = type_expression ident_map i.type_;
     }
 
+  and class_constraint ident_map cst =
+    {
+      ClassSignature.Constraint.doc = docs ident_map cst.doc;
+      left = type_expression ident_map cst.left;
+      right = type_expression ident_map cst.right;
+    }
+
+  and inherit_ ident_map ih =
+    {
+      ClassSignature.Inherit.doc = docs ident_map ih.doc;
+      expr = class_type_expr ident_map ih.expr;
+    }
+
   and module_substitution ident_map (t : Odoc_model.Lang.ModuleSubstitution.t) =
     {
       ModuleSubstitution.doc = docs ident_map t.doc;

src/xref2/component.mli

@@ -352,11 +352,19 @@ and ClassType : sig
 end
 
 and ClassSignature : sig
+  module Constraint : sig
+    type t = { left : TypeExpr.t; right : TypeExpr.t; doc : CComment.docs }
+  end
+
+  module Inherit : sig
+    type t = { expr : ClassType.expr; doc : CComment.docs }
+  end
+
   type item =
     | Method of Ident.method_ * Method.t
     | InstanceVariable of Ident.instance_variable * InstanceVariable.t
-    | Constraint of TypeExpr.t * TypeExpr.t
-    | Inherit of ClassType.expr
+    | Constraint of Constraint.t
+    | Inherit of Inherit.t
     | Comment of CComment.docs_or_stop
 
   type t = { self : TypeExpr.t option; items : item list; doc : CComment.docs }

src/xref2/find.ml

@@ -311,7 +311,7 @@ let any_in_type_in_sig sg name =
 
 let filter_in_class_signature cs f =
   let rec inner = function
-    | ClassSignature.Inherit ct_expr :: tl -> inner_inherit ct_expr @ inner tl
+    | ClassSignature.Inherit { expr; _ } :: tl -> inner_inherit expr @ inner tl
     | it :: tl -> (
         match f it with Some x -> x :: inner tl | None -> inner tl)
     | [] -> []