move class_signature_pv from parent to label_parent

panglesd · EmileTrotignon · panglesd · commit be87d3a433ef · 2023-12-06T09:44:26.000+01:00
Indeed, `parent` is for constructor and fields: they can only have signature or
datatype as parent.

Signed-off-by: Paul-Elliot &lt;peada@free.fr&gt;
Co-authored-by: Emile Trotignon &lt;emile@tarides.com&gt;
diff --git a/src/model/paths.ml b/src/model/paths.ml
@@ -997,14 +997,14 @@ module Reference = struct
         as sg ->
           (parent_signature_identifier sg :> Identifier.Parent.t)
       | `Type _ as t -> (parent_type_identifier t :> Identifier.Parent.t)
-      | (`Class _ | `ClassType _) as c ->
-          (parent_class_signature_identifier c :> Identifier.Parent.t)
 
     and label_parent_identifier : label_parent -> Identifier.LabelParent.t =
       function
       | `Identifier id -> id
+      | (`Class _ | `ClassType _) as c ->
+          (parent_class_signature_identifier c :> Identifier.LabelParent.t)
       | ( `Hidden _ | `Alias _ | `AliasModuleType _ | `Module _ | `ModuleType _
-        | `Type _ | `Class _ | `ClassType _ ) as r ->
+        | `Type _ ) as r ->
           (parent_identifier r :> Identifier.LabelParent.t)
 
     and identifier : t -> Identifier.t = function
diff --git a/src/model/paths_types.ml b/src/model/paths_types.ml
@@ -81,13 +81,13 @@ module Identifier = struct
   and datatype = datatype_pv id
   (** @canonical Odoc_model.Paths.Identifier.DataType.t *)
 
-  type parent_pv = [ signature_pv | datatype_pv | class_signature_pv ]
+  type parent_pv = [ signature_pv | datatype_pv ]
   (** @canonical Odoc_model.Paths.Identifier.Parent.t_pv *)
 
   and parent = parent_pv id
   (** @canonical Odoc_model.Paths.Identifier.Parent.t *)
 
-  type label_parent_pv = [ parent_pv | page_pv ]
+  type label_parent_pv = [ parent_pv | page_pv | class_signature_pv ]
   (** @canonical Odoc_model.Paths.Identifier.LabelParent.t_pv *)
 
   and label_parent = label_parent_pv id
@@ -623,8 +623,6 @@ module rec Reference : sig
     | `Dot of label_parent * string
     | `Module of signature * ModuleName.t
     | `ModuleType of signature * ModuleTypeName.t
-    | `Class of signature * ClassName.t
-    | `ClassType of signature * ClassTypeName.t
     | `Type of signature * TypeName.t ]
   (** @canonical Odoc_model.Paths.Reference.Parent.t *)
 
@@ -813,8 +811,6 @@ and Resolved_reference : sig
     | `Module of signature * ModuleName.t
     | `Hidden of module_
     | `ModuleType of signature * ModuleTypeName.t
-    | `Class of signature * ClassName.t
-    | `ClassType of signature * ClassTypeName.t
     | `Type of signature * TypeName.t ]
   (** @canonical Odoc_model.Paths.Reference.Resolved.Parent.t *)
 
diff --git a/src/xref2/compile.ml b/src/xref2/compile.ml
@@ -103,22 +103,22 @@ and content env id =
 
 and value_ env parent t =
   let open Value in
-  let container = (parent :> Id.Parent.t) in
+  let container = (parent :> Id.LabelParent.t) in
   try { t with type_ = type_expression env container t.type_ }
   with _ ->
     Errors.report ~what:(`Value t.id) `Compile;
     t
 
 and exception_ env parent e =
   let open Exception in
-  let container = (parent :> Id.Parent.t) in
+  let container = (parent :> Id.LabelParent.t) in
   let res = Opt.map (type_expression env container) e.res in
   let args = type_decl_constructor_argument env container e.args in
   { e with res; args }
 
 and extension env parent t =
   let open Extension in
-  let container = (parent :> Id.Parent.t) in
+  let container = (parent :> Id.LabelParent.t) in
   let constructor c =
     let open Constructor in
     {
@@ -133,7 +133,7 @@ and extension env parent t =
 
 and class_type_expr env parent =
   let open ClassType in
-  let container = (parent :> Id.Parent.t) in
+  let container = (parent :> Id.LabelParent.t) in
   function
   | Constr (path, texps) ->
       Constr
@@ -169,7 +169,7 @@ and class_type env c =
 
 and class_signature env parent c =
   let open ClassSignature in
-  let container = (parent : Id.ClassSignature.t :> Id.Parent.t) in
+  let container = (parent : Id.ClassSignature.t :> Id.LabelParent.t) in
   let env = Env.open_class_signature c env in
   let map_item = function
     | Method m -> Method (method_ env parent m)
@@ -186,12 +186,12 @@ and class_signature env parent c =
 
 and method_ env parent m =
   let open Method in
-  let container = (parent :> Id.Parent.t) in
+  let container = (parent :> Id.LabelParent.t) in
   { m with type_ = type_expression env container m.type_ }
 
 and instance_variable env parent i =
   let open InstanceVariable in
-  let container = (parent :> Id.Parent.t) in
+  let container = (parent :> Id.LabelParent.t) in
   { i with type_ = type_expression env container i.type_ }
 
 and class_constraint env parent cst =
@@ -208,7 +208,7 @@ and inherit_ env parent ih =
 
 and class_ env parent c =
   let open Class in
-  let container = (parent :> Id.Parent.t) in
+  let container = (parent :> Id.LabelParent.t) in
   let expansion =
     match
       let open Utils.OptionMonad in
@@ -513,7 +513,7 @@ and module_type_expr_sub id ~fragment_root (sg_res, env, subs) lsub =
                   Errors.report ~what:(`With_type cfrag) `Compile;
                   (cfrag, frag)
             in
-            let eqn' = type_decl_equation env (id :> Id.Parent.t) eqn in
+            let eqn' = type_decl_equation env (id :> Id.LabelParent.t) eqn in
             let ceqn' = Component.Of_Lang.(type_equation (empty ()) eqn') in
             Tools.fragmap ~mark_substituted:true env
               (Component.ModuleType.TypeEq (cfrag', ceqn'))
@@ -556,7 +556,7 @@ and module_type_expr_sub id ~fragment_root (sg_res, env, subs) lsub =
                   Errors.report ~what:(`With_type cfrag) `Compile;
                   (cfrag, frag)
             in
-            let eqn' = type_decl_equation env (id :> Id.Parent.t) eqn in
+            let eqn' = type_decl_equation env (id :> Id.LabelParent.t) eqn in
             let ceqn' = Component.Of_Lang.(type_equation (empty ()) eqn') in
             Tools.fragmap ~mark_substituted:true env
               (Component.ModuleType.TypeSubst (cfrag', ceqn'))
@@ -739,7 +739,7 @@ and type_decl : Env.t -> TypeDecl.t -> TypeDecl.t =
   let open TypeDecl in
   let container =
     match t.id.iv with
-    | `Type (parent, _) -> (parent :> Id.Parent.t)
+    | `Type (parent, _) -> (parent :> Id.LabelParent.t)
     | `CoreType _ -> assert false
   in
   let equation = type_decl_equation env container t.equation in
@@ -749,7 +749,7 @@ and type_decl : Env.t -> TypeDecl.t -> TypeDecl.t =
   { t with equation; representation }
 
 and type_decl_equation :
-    Env.t -> Id.Parent.t -> TypeDecl.Equation.t -> TypeDecl.Equation.t =
+    Env.t -> Id.LabelParent.t -> TypeDecl.Equation.t -> TypeDecl.Equation.t =
  fun env parent t ->
   let open TypeDecl.Equation in
   let manifest = Opt.map (type_expression env parent) t.manifest in
@@ -763,7 +763,7 @@ and type_decl_equation :
 
 and type_decl_representation :
     Env.t ->
-    Id.Parent.t ->
+    Id.LabelParent.t ->
     TypeDecl.Representation.t ->
     TypeDecl.Representation.t =
  fun env parent r ->
@@ -784,7 +784,10 @@ and type_decl_constructor_argument env parent c =
   | Record fs -> Record (List.map (type_decl_field env parent) fs)
 
 and type_decl_constructor :
-    Env.t -> Id.Parent.t -> TypeDecl.Constructor.t -> TypeDecl.Constructor.t =
+    Env.t ->
+    Id.LabelParent.t ->
+    TypeDecl.Constructor.t ->
+    TypeDecl.Constructor.t =
  fun env parent c ->
   let open TypeDecl.Constructor in
   let args = type_decl_constructor_argument env parent c.args in
@@ -853,7 +856,7 @@ and type_expression_package env parent p =
               }))
   | Error _ -> { p with path = Lang_of.(Path.module_type (empty ()) cp) }
 
-and type_expression : Env.t -> Id.Parent.t -> _ -> _ =
+and type_expression : Env.t -> Id.LabelParent.t -> _ -> _ =
  fun env parent texpr ->
   let open TypeExpr in
   match texpr with
diff --git a/src/xref2/ident.ml b/src/xref2/ident.ml
@@ -16,10 +16,13 @@ type class_signature =
 
 type datatype = [ `LType of TypeName.t * int ]
 
-type parent = [ signature | datatype | class_signature ]
+type parent = [ signature | datatype ]
 
 type label_parent =
-  [ parent | `LPage of PageName.t * int | `LLeafPage of PageName.t * int ]
+  [ parent
+  | `LPage of PageName.t * int
+  | `LLeafPage of PageName.t * int
+  | class_signature ]
 
 type module_ =
   [ `LRoot of ModuleName.t * int
@@ -143,11 +146,12 @@ module Of_Identifier = struct
     match p with
     | { iv = #Signature.t_pv; _ } as s -> (signature s :> parent)
     | { iv = #DataType.t_pv; _ } as s -> (datatype s :> parent)
-    | { iv = #ClassSignature.t_pv; _ } as s -> (class_signature s :> parent)
 
   let label_parent : LabelParent.t -> label_parent =
    fun p ->
     match p with
+    | { iv = #ClassSignature.t_pv; _ } as s ->
+        (class_signature s :> label_parent)
     | { iv = #Parent.t_pv; _ } as s -> (parent s :> label_parent)
     | { iv = `Page (_, n); _ } -> `LPage (n, fresh_int ())
     | { iv = `LeafPage (_, n); _ } -> `LLeafPage (n, fresh_int ())
diff --git a/src/xref2/lang_of.ml b/src/xref2/lang_of.ml
@@ -513,15 +513,15 @@ and class_decl map parent c =
   | Arrow (lbl, t, d) ->
       Arrow
         ( lbl,
-          type_expr map (parent :> Identifier.Parent.t) t,
+          type_expr map (parent :> Identifier.LabelParent.t) t,
           class_decl map parent d )
 
 and class_type_expr map parent c =
   match c with
   | Component.ClassType.Constr (p, ts) ->
       Constr
         ( Path.class_type map p,
-          List.rev_map (type_expr map (parent :> Identifier.Parent.t)) ts
+          List.rev_map (type_expr map (parent :> Identifier.LabelParent.t)) ts
           |> List.rev )
   | Signature s -> Signature (class_signature map parent s)
 
@@ -548,7 +548,7 @@ and class_type map parent id c =
 
 and class_signature map parent sg =
   let open Component.ClassSignature in
-  let pparent = (parent :> Identifier.Parent.t) in
+  let pparent = (parent :> Identifier.LabelParent.t) in
   let items =
     List.rev_map
       (function
@@ -573,7 +573,7 @@ and method_ map parent id m =
     doc = docs (parent :> Identifier.LabelParent.t) m.doc;
     private_ = m.private_;
     virtual_ = m.virtual_;
-    type_ = type_expr map (parent :> Identifier.Parent.t) m.type_;
+    type_ = type_expr map (parent :> Identifier.LabelParent.t) m.type_;
   }
 
 and instance_variable map parent id i =
@@ -587,7 +587,7 @@ and instance_variable map parent id i =
     doc = docs (parent :> Identifier.LabelParent.t) i.doc;
     mutable_ = i.mutable_;
     virtual_ = i.virtual_;
-    type_ = type_expr map (parent :> Identifier.Parent.t) i.type_;
+    type_ = type_expr map (parent :> Identifier.LabelParent.t) i.type_;
   }
 
 and class_constraint map parent cst =
@@ -686,7 +686,7 @@ and value_ map parent id v =
     id = identifier;
     locs = v.locs;
     doc = docs (parent :> Identifier.LabelParent.t) v.doc;
-    type_ = type_expr map (parent :> Identifier.Parent.t) v.type_;
+    type_ = type_expr map (parent :> Identifier.LabelParent.t) v.type_;
     value = v.value;
   }
 
@@ -712,7 +712,7 @@ and extension_constructor map parent c =
     doc = docs (parent :> Identifier.LabelParent.t) c.doc;
     args =
       type_decl_constructor_argument map (parent :> Identifier.Parent.t) c.args;
-    res = Opt.map (type_expr map (parent :> Identifier.Parent.t)) c.res;
+    res = Opt.map (type_expr map (parent :> Identifier.LabelParent.t)) c.res;
   }
 
 and module_ map parent id m =
@@ -893,7 +893,8 @@ and type_decl_constructor_argument :
     Odoc_model.Lang.TypeDecl.Constructor.argument =
  fun map parent a ->
   match a with
-  | Tuple ls -> Tuple (List.map (type_expr map parent) ls)
+  | Tuple ls ->
+      Tuple (List.map (type_expr map (parent :> Identifier.LabelParent.t)) ls)
   | Record fs -> Record (List.map (type_decl_field map parent) fs)
 
 and type_decl_field :
@@ -907,12 +908,13 @@ and type_decl_field :
     id = identifier;
     doc = docs (parent :> Identifier.LabelParent.t) f.doc;
     mutable_ = f.mutable_;
-    type_ = type_expr map parent f.type_;
+    type_ = type_expr map (parent :> Identifier.LabelParent.t) f.type_;
   }
 
 and type_decl_equation map (parent : Identifier.Parent.t)
     (eqn : Component.TypeDecl.Equation.t) : Odoc_model.Lang.TypeDecl.Equation.t
     =
+  let parent = (parent :> Identifier.LabelParent.t) in
   {
     params = eqn.params;
     private_ = eqn.private_;
@@ -958,14 +960,15 @@ and type_decl_constructor :
   let identifier =
     Identifier.Mk.constructor (id, ConstructorName.make_std t.name)
   in
+  let parent = (id :> Identifier.LabelParent.t) in
   {
     id = identifier;
     doc = docs (id :> Identifier.LabelParent.t) t.doc;
     args = type_decl_constructor_argument map id t.args;
-    res = Opt.map (type_expr map id) t.res;
+    res = Opt.map (type_expr map parent) t.res;
   }
 
-and type_expr_package map parent t =
+and type_expr_package map (parent : Identifier.LabelParent.t) t =
   {
     Lang.TypeExpr.Package.path =
       Path.module_type map t.Component.TypeExpr.Package.path;
@@ -976,8 +979,8 @@ and type_expr_package map parent t =
         t.substitutions;
   }
 
-and type_expr map (parent : Identifier.Parent.t) (t : Component.TypeExpr.t) :
-    Odoc_model.Lang.TypeExpr.t =
+and type_expr map (parent : Identifier.LabelParent.t) (t : Component.TypeExpr.t)
+    : Odoc_model.Lang.TypeExpr.t =
   try
     match t with
     | Var s -> Var s
@@ -1009,7 +1012,7 @@ and type_expr_polyvar map parent v =
         c.Component.TypeExpr.Polymorphic_variant.Constructor.name;
       constant = c.constant;
       arguments = List.map (type_expr map parent) c.arguments;
-      doc = docs (parent :> Identifier.LabelParent.t) c.doc;
+      doc = docs parent c.doc;
     }
   in
   let element = function
@@ -1054,7 +1057,7 @@ and exception_ map parent id (e : Component.Exception.t) :
     doc = docs (parent :> Identifier.LabelParent.t) e.doc;
     args =
       type_decl_constructor_argument map (parent :> Identifier.Parent.t) e.args;
-    res = Opt.map (type_expr map (parent :> Identifier.Parent.t)) e.res;
+    res = Opt.map (type_expr map (parent :> Identifier.LabelParent.t)) e.res;
   }
 
 and block_element parent
diff --git a/src/xref2/lang_of.mli b/src/xref2/lang_of.mli
@@ -223,25 +223,25 @@ val type_decl_constructor :
 
 val type_expr_package :
   maps ->
-  Identifier.Parent.t ->
+  Identifier.LabelParent.t ->
   Component.TypeExpr.Package.t ->
   Odoc_model.Lang.TypeExpr.Package.t
 
 val type_expr :
   maps ->
-  Identifier.Parent.t ->
+  Identifier.LabelParent.t ->
   Component.TypeExpr.t ->
   Odoc_model.Lang.TypeExpr.t
 
 val type_expr_polyvar :
   maps ->
-  Identifier.Parent.t ->
+  Identifier.LabelParent.t ->
   Component.TypeExpr.Polymorphic_variant.t ->
   Odoc_model.Lang.TypeExpr.Polymorphic_variant.t
 
 val type_expr_object :
   maps ->
-  Identifier.Parent.t ->
+  Identifier.LabelParent.t ->
   Component.TypeExpr.Object.t ->
   Odoc_model.Lang.TypeExpr.Object.t
 
diff --git a/src/xref2/link.ml b/src/xref2/link.ml
@@ -1047,7 +1047,7 @@ and type_expression : Env.t -> Id.Signature.t -> _ -> _ =
                     let t' =
                       Expand_tools.type_expr map
                         Lang_of.(
-                          type_expr (empty ()) (parent :> Id.Parent.t) expr)
+                          type_expr (empty ()) (parent :> Id.LabelParent.t) expr)
                     in
                     type_expression env parent (p :: visited) t'
                   with
@@ -1066,7 +1066,7 @@ and type_expression : Env.t -> Id.Signature.t -> _ -> _ =
             Constr (`Resolved p, ts)
         | Ok (_cp, `FType_removed (_, x, _eq)) ->
             (* Type variables ? *)
-            Lang_of.(type_expr (empty ()) (parent :> Id.Parent.t) x)
+            Lang_of.(type_expr (empty ()) (parent :> Id.LabelParent.t) x)
         | Error _ -> Constr (path', ts))
   | Polymorphic_variant v ->
       Polymorphic_variant (type_expression_polyvar env parent visited v)
