Force identifiers + resolved references to have a datatype as parent

Resolved references/ids already always had datatype as parent, but it is now
enforced by the subtyping system.

The reason we cannot symmetrically do the same for fields is the following:
```ocaml
type t = ..

type t += Inline of { a : int}
```
In this example, `a` cannot have a `datatype` as parent. Parent for fields
should ideally be `[datatype | constructor | extension]`.

Signed-off-by: Paul-Elliot <[email protected]>
Co-authored-by: Emile Trotignon <[email protected]>

Author: panglesd

src/loader/cmi.ml

@@ -713,7 +713,7 @@ let read_type_declaration env parent id decl =
   let params = mark_type_declaration decl in
   let manifest = opt_map (read_type_expr env) decl.type_manifest in
   let constraints = read_type_constraints env params in
-  let representation = read_type_kind env (id :> Identifier.Parent.t) decl.type_kind in
+  let representation = read_type_kind env (id :> Identifier.DataType.t) decl.type_kind in
   let abstr =
     match decl.type_kind with
       Type_abstract ->

src/loader/cmti.ml

@@ -214,7 +214,7 @@ let read_constructor_declaration_arguments env parent label_parent arg =
 let read_constructor_declaration env parent cd =
   let open TypeDecl.Constructor in
   let id = Ident_env.find_constructor_identifier env cd.cd_id in
-  let container = parent in
+  let container = (parent :> Identifier.Parent.t) in
   let label_container = (container :> Identifier.LabelParent.t) in
   let doc = Doc_attr.attached_no_tag label_container cd.cd_attributes in
   let args =
@@ -231,7 +231,7 @@ let read_type_kind env parent =
         let cstrs = List.map (read_constructor_declaration env parent) cstrs in
           Some (Variant cstrs)
     | Ttype_record lbls ->
-        let parent = (parent ) in
+        let parent = (parent :> Identifier.Parent.t) in
       let label_parent = (parent :> Identifier.LabelParent.t) in
       let lbls =
         List.map (read_label_declaration env parent label_parent) lbls in
@@ -260,7 +260,7 @@ let read_type_declaration env parent decl =
   let doc, canonical = Doc_attr.attached Odoc_model.Semantics.Expect_canonical container decl.typ_attributes in
   let canonical = (canonical :> Path.Type.t option) in
   let equation = read_type_equation env container decl in
-  let representation = read_type_kind env (id :> Identifier.Parent.t) decl.typ_kind in
+  let representation = read_type_kind env id decl.typ_kind in
   {id; locs; doc; canonical; equation; representation}
 
 let read_type_declarations env parent rec_flag decls =

src/model/paths.ml

@@ -165,7 +165,7 @@ module Identifier = struct
       | { iv = `Label (p, _); _ } -> p
       | { iv = `Method (p, _); _ } | { iv = `InstanceVariable (p, _); _ } ->
           (p : class_signature :> label_parent)
-      | { iv = `Constructor (p, _); _ } -> (p : parent :> label_parent)
+      | { iv = `Constructor (p, _); _ } -> (p : datatype :> label_parent)
       | { iv = `Field (p, _); _ } -> (p : parent :> label_parent)
 
   let label_parent n = label_parent_aux (n :> Id.non_src)
@@ -572,8 +572,8 @@ module Identifier = struct
       mk_fresh (fun s -> s) "coret" (fun s -> `CoreType (TypeName.make_std s))
 
     let constructor :
-        Parent.t * ConstructorName.t ->
-        [> `Constructor of Parent.t * ConstructorName.t ] id =
+        DataType.t * ConstructorName.t ->
+        [> `Constructor of DataType.t * ConstructorName.t ] id =
       mk_parent ConstructorName.to_string "ctor" (fun (p, n) ->
           `Constructor (p, n))
 
@@ -1013,7 +1013,9 @@ module Reference = struct
         | `Class _ | `ClassType _ | `ModuleType _ ) as r ->
           (label_parent_identifier r :> Identifier.t)
       | `Field (p, n) -> Identifier.Mk.field (parent_identifier p, n)
-      | `Constructor (s, n) -> Identifier.Mk.constructor (parent_identifier s, n)
+      | `Constructor (s, n) ->
+          Identifier.Mk.constructor
+            ((parent_type_identifier s :> Identifier.DataType.t), n)
       | `Extension (p, q) ->
           Identifier.Mk.extension (parent_signature_identifier p, q)
       | `ExtensionDecl (p, q, r) ->

src/model/paths.mli

@@ -290,8 +290,8 @@ module Identifier : sig
     val core_type : string -> [> `CoreType of TypeName.t ] id
 
     val constructor :
-      Parent.t * ConstructorName.t ->
-      [> `Constructor of Parent.t * ConstructorName.t ] id
+      DataType.t * ConstructorName.t ->
+      [> `Constructor of DataType.t * ConstructorName.t ] id
 
     val field :
       Parent.t * FieldName.t -> [> `Field of Parent.t * FieldName.t ] id

src/model/paths_types.ml

@@ -132,7 +132,7 @@ module Identifier = struct
   and type_ = type_pv id
   (** @canonical Odoc_model.Paths.Identifier.Type.t *)
 
-  type constructor_pv = [ `Constructor of parent * ConstructorName.t ]
+  type constructor_pv = [ `Constructor of datatype * ConstructorName.t ]
   (** @canonical Odoc_model.Paths.Identifier.Constructor.t_pv *)
 
   and constructor = constructor_pv id
@@ -843,7 +843,7 @@ and Resolved_reference : sig
 
   type constructor =
     [ `Identifier of Identifier.reference_constructor
-    | `Constructor of parent * ConstructorName.t
+    | `Constructor of datatype * ConstructorName.t
     | `Extension of signature * ExtensionName.t
     | `Exception of signature * ExceptionName.t ]
   (** @canonical Odoc_model.Paths.Reference.Resolved.Constructor.t *)
@@ -916,7 +916,7 @@ and Resolved_reference : sig
     | `Hidden of module_
     | `ModuleType of signature * ModuleTypeName.t
     | `Type of signature * TypeName.t
-    | `Constructor of parent * ConstructorName.t
+    | `Constructor of datatype * ConstructorName.t
     | `Field of parent * FieldName.t
     | `Extension of signature * ExtensionName.t
     | `ExtensionDecl of signature * ExtensionName.t * ExtensionName.t

src/xref2/env.ml

@@ -294,7 +294,7 @@ let add_type (identifier : Identifier.Type.t) t env =
     let add_cons env (cons : TypeDecl.Constructor.t) =
       let ident =
         Paths.Identifier.Mk.constructor
-          ( (identifier :> Identifier.Parent.t),
+          ( (identifier :> Identifier.DataType.t),
             ConstructorName.make_std cons.name )
       in
       add_to_elts Kind_Constructor ident (`Constructor (ident, cons)) env

src/xref2/lang_of.ml

@@ -895,7 +895,8 @@ and type_decl_constructor_argument :
   match a with
   | Tuple ls ->
       Tuple (List.map (type_expr map (parent :> Identifier.LabelParent.t)) ls)
-  | Record fs -> Record (List.map (type_decl_field map parent) fs)
+  | Record fs ->
+      Record (List.map (type_decl_field map (parent :> Identifier.Parent.t)) fs)
 
 and type_decl_field :
     maps ->
@@ -942,9 +943,7 @@ and type_decl_representation map id (t : Component.TypeDecl.Representation.t) :
     Odoc_model.Lang.TypeDecl.Representation.t =
   match t with
   | Extensible -> Extensible
-  | Variant cs ->
-      Variant
-        (List.map (type_decl_constructor map (id :> Identifier.Parent.t)) cs)
+  | Variant cs -> Variant (List.map (type_decl_constructor map id) cs)
   | Record fs ->
       Record
         (List.map
@@ -953,7 +952,7 @@ and type_decl_representation map id (t : Component.TypeDecl.Representation.t) :
 
 and type_decl_constructor :
     maps ->
-    Odoc_model.Paths.Identifier.Parent.t ->
+    Odoc_model.Paths.Identifier.DataType.t ->
     Component.TypeDecl.Constructor.t ->
     Odoc_model.Lang.TypeDecl.Constructor.t =
  fun map id t ->
@@ -963,8 +962,8 @@ and type_decl_constructor :
   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;
+    doc = docs parent t.doc;
+    args = type_decl_constructor_argument map (id :> Identifier.Parent.t) t.args;
     res = Opt.map (type_expr map parent) t.res;
   }
 

src/xref2/lang_of.mli

@@ -217,7 +217,7 @@ val type_decl_representation :
 
 val type_decl_constructor :
   maps ->
-  Identifier.Parent.t ->
+  Identifier.DataType.t ->
   Component.TypeDecl.Constructor.t ->
   Odoc_model.Lang.TypeDecl.Constructor.t
 

src/xref2/ref_tools.ml

@@ -456,16 +456,13 @@ module CS = struct
         find Find.any_in_type t name_s >>= function
         | `FField _ -> got_a_field name_s
         | `FConstructor _ ->
-            Ok
-              (`Constructor
-                ((parent' : Resolved.DataType.t :> Resolved.Parent.t), name)))
+            Ok (`Constructor ((parent' : Resolved.DataType.t), name)))
     | (`C _ | `CT _ | `P _) as r -> wrong_kind_error [ `S; `T ] r
 
   let of_component _env parent name =
     Ok
       (`Constructor
-        ( (parent : Resolved.DataType.t :> Resolved.Parent.t),
-          ConstructorName.make_std name ))
+        ((parent : Resolved.DataType.t), ConstructorName.make_std name))
 end
 
 module F = struct