Allow signature to be parent in constructor references

This allows to omit the type the constructor is coming from. The constructor
will be fetched from the environment.
The commit does this in a similar way to fields, which can have type `parent`
for parents of type references.

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

Author: EmileTrotignon

src/loader/cmi.ml

@@ -628,7 +628,7 @@ let read_constructor_declaration_arguments env 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 : Identifier.DataType.t :> Identifier.LabelParent.t) in
+  let container = (parent :> Identifier.LabelParent.t) in
   let doc = Doc_attr.attached_no_tag container cd.cd_attributes in
   let args =
     read_constructor_declaration_arguments env
@@ -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 decl.type_kind in
+  let representation = read_type_kind env (id :> Identifier.Parent.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 : Identifier.DataType.t :> Identifier.Parent.t) in
+  let container = parent 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 : Identifier.DataType.t :> Identifier.Parent.t) in
+        let parent = (parent ) 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.DataType.t) decl.typ_kind in
+  let representation = read_type_kind env (id :> Identifier.Parent.t) 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 : datatype :> label_parent)
+      | { iv = `Constructor (p, _); _ } -> (p : parent :> 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 :
-        Type.t * ConstructorName.t ->
-        [> `Constructor of Type.t * ConstructorName.t ] id =
+        Parent.t * ConstructorName.t ->
+        [> `Constructor of Parent.t * ConstructorName.t ] id =
       mk_parent ConstructorName.to_string "ctor" (fun (p, n) ->
           `Constructor (p, n))
 
@@ -1013,8 +1013,7 @@ 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_type_identifier s, n)
+      | `Constructor (s, n) -> Identifier.Mk.constructor (parent_identifier s, 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 :
-      Type.t * ConstructorName.t ->
-      [> `Constructor of Type.t * ConstructorName.t ] id
+      Parent.t * ConstructorName.t ->
+      [> `Constructor of Parent.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 type_ * ConstructorName.t ]
+  type constructor_pv = [ `Constructor of parent * ConstructorName.t ]
   (** @canonical Odoc_model.Paths.Identifier.Constructor.t_pv *)
 
   and constructor = constructor_pv id
@@ -666,7 +666,7 @@ module rec Reference : sig
     [ `Resolved of Resolved_reference.constructor
     | `Root of string * [ `TConstructor | `TExtension | `TException | `TUnknown ]
     | `Dot of label_parent * string
-    | `Constructor of datatype * ConstructorName.t
+    | `Constructor of parent * ConstructorName.t
     | `Extension of signature * ExtensionName.t
     | `Exception of signature * ExceptionName.t ]
   (** @canonical Odoc_model.Paths.Reference.Constructor.t *)
@@ -756,7 +756,7 @@ module rec Reference : sig
     | `Module of signature * ModuleName.t
     | `ModuleType of signature * ModuleTypeName.t
     | `Type of signature * TypeName.t
-    | `Constructor of datatype * ConstructorName.t
+    | `Constructor of parent * ConstructorName.t
     | `Field of parent * FieldName.t
     | `Extension of signature * ExtensionName.t
     | `ExtensionDecl of signature * ExtensionName.t
@@ -847,7 +847,7 @@ and Resolved_reference : sig
 
   type constructor =
     [ `Identifier of Identifier.reference_constructor
-    | `Constructor of datatype * ConstructorName.t
+    | `Constructor of parent * ConstructorName.t
     | `Extension of signature * ExtensionName.t
     | `Exception of signature * ExceptionName.t ]
   (** @canonical Odoc_model.Paths.Reference.Resolved.Constructor.t *)
@@ -920,7 +920,7 @@ and Resolved_reference : sig
     | `Hidden of module_
     | `ModuleType of signature * ModuleTypeName.t
     | `Type of signature * TypeName.t
-    | `Constructor of datatype * ConstructorName.t
+    | `Constructor of parent * ConstructorName.t
     | `Field of parent * FieldName.t
     | `Extension of signature * ExtensionName.t
     | `ExtensionDecl of signature * ExtensionName.t * ExtensionName.t

src/model/reference.ml

@@ -219,13 +219,10 @@ let parse whole_reference_location s :
     match tokens with
     | [] -> (
         match kind with
-        | (`TUnknown | `TModule | `TModuleType | `TType | `TClass | `TClassType)
-          as kind ->
+        | (`TUnknown | `TModule | `TModuleType | `TType) as kind ->
             `Root (identifier, kind)
         | _ ->
-            expected
-              [ "module"; "module-type"; "type"; "class"; "class-type" ]
-              location
+            expected [ "module"; "module-type"; "type" ] location
             |> Error.raise_exception)
     | next_token :: tokens -> (
         match kind with
@@ -238,15 +235,8 @@ let parse whole_reference_location s :
               (signature next_token tokens, ModuleTypeName.make_std identifier)
         | `TType ->
             `Type (signature next_token tokens, TypeName.make_std identifier)
-        | `TClass ->
-            `Class (signature next_token tokens, ClassName.make_std identifier)
-        | `TClassType ->
-            `ClassType
-              (signature next_token tokens, ClassTypeName.make_std identifier)
         | _ ->
-            expected
-              [ "module"; "module-type"; "type"; "class"; "class-type" ]
-              location
+            expected [ "module"; "module-type"; "type" ] location
             |> Error.raise_exception)
   in
 
@@ -273,22 +263,6 @@ let parse whole_reference_location s :
         )
   in
 
-  let datatype (kind, identifier, location) tokens : DataType.t =
-    let kind = match_reference_kind location kind in
-    match tokens with
-    | [] -> (
-        match kind with
-        | (`TUnknown | `TType) as kind -> `Root (identifier, kind)
-        | _ -> expected [ "type" ] location |> Error.raise_exception)
-    | next_token :: tokens -> (
-        match kind with
-        | `TUnknown ->
-            `Dot ((parent next_token tokens :> LabelParent.t), identifier)
-        | `TType ->
-            `Type (signature next_token tokens, TypeName.make_std identifier)
-        | _ -> expected [ "type" ] location |> Error.raise_exception)
-  in
-
   let rec label_parent (kind, identifier, location) tokens : LabelParent.t =
     let kind = match_reference_kind location kind in
     match tokens with
@@ -360,7 +334,7 @@ let parse whole_reference_location s :
             `Type (signature next_token tokens, TypeName.make_std identifier)
         | `TConstructor ->
             `Constructor
-              (datatype next_token tokens, ConstructorName.make_std identifier)
+              (parent next_token tokens, ConstructorName.make_std identifier)
         | `TField ->
             `Field (parent next_token tokens, FieldName.make_std identifier)
         | `TExtension ->

src/xref2/env.ml

@@ -288,13 +288,14 @@ let add_module identifier m docs env =
   let env' = add_to_elts Kind_Module identifier (`Module (identifier, m)) env in
   if env.linking then add_cdocs identifier docs env' else env'
 
-let add_type identifier t env =
+let add_type (identifier : Identifier.Type.t) t env =
   let open Component in
   let open_typedecl cs =
     let add_cons env (cons : TypeDecl.Constructor.t) =
       let ident =
         Paths.Identifier.Mk.constructor
-          (identifier, ConstructorName.make_std cons.name)
+          ( (identifier :> Identifier.Parent.t),
+            ConstructorName.make_std cons.name )
       in
       add_to_elts Kind_Constructor ident (`Constructor (ident, cons)) env
     and add_field env (field : TypeDecl.Field.t) =

src/xref2/lang_of.ml

@@ -940,7 +940,9 @@ 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) cs)
+  | Variant cs ->
+      Variant
+        (List.map (type_decl_constructor map (id :> Identifier.Parent.t)) cs)
   | Record fs ->
       Record
         (List.map
@@ -949,7 +951,7 @@ and type_decl_representation map id (t : Component.TypeDecl.Representation.t) :
 
 and type_decl_constructor :
     maps ->
-    Odoc_model.Paths.Identifier.Type.t ->
+    Odoc_model.Paths.Identifier.Parent.t ->
     Component.TypeDecl.Constructor.t ->
     Odoc_model.Lang.TypeDecl.Constructor.t =
  fun map id t ->
@@ -959,11 +961,8 @@ and type_decl_constructor :
   {
     id = identifier;
     doc = docs (id :> Identifier.LabelParent.t) t.doc;
-    args =
-      type_decl_constructor_argument map
-        (id :> Odoc_model.Paths.Identifier.Parent.t)
-        t.args;
-    res = Opt.map (type_expr map (id :> Identifier.Parent.t)) t.res;
+    args = type_decl_constructor_argument map id t.args;
+    res = Opt.map (type_expr map id) t.res;
   }
 
 and type_expr_package map parent t =

src/xref2/lang_of.mli

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

src/xref2/ref_tools.ml

@@ -279,15 +279,6 @@ module DT = struct
   let of_component _env t ~parent_ref name = Ok (`Type (parent_ref, name), t)
 
   let of_element _env (`Type (id, t)) : t = (`Identifier id, t)
-
-  let in_env env name =
-    env_lookup_by_name Env.s_type name env >>= fun e -> Ok (of_element env e)
-
-  let in_signature _env ((parent', parent_cp, sg) : signature_lookup_result)
-      name =
-    let sg = Tools.prefix_signature (parent_cp, sg) in
-    find Find.datatype_in_sig sg name >>= fun (`FType (name, t)) ->
-    Ok (`Type (parent', name), t)
 end
 
 module T = struct
@@ -448,14 +439,33 @@ module CS = struct
     env_lookup_by_name Env.s_constructor name env
     >>= fun (`Constructor (id, _)) -> Ok (`Identifier id :> t)
 
-  let in_datatype _env ((parent', t) : datatype_lookup_result) name =
+  let got_a_field name =
+    (* Let's pretend we didn't see the field and say we didn't find anything. *)
+    Error (`Find_by_name (`Cons, name))
+
+  let in_parent _env (parent : label_parent_lookup_result) name =
     let name_s = ConstructorName.to_string name in
-    find Find.any_in_type t name_s >>= function
-    | `FConstructor _ -> Ok (`Constructor (parent', name))
-    | `FField _ -> Error (`Find_by_name (`Cons, name_s))
+    match parent with
+    | `S (parent', parent_cp, sg) -> (
+        let sg = Tools.prefix_signature (parent_cp, sg) in
+        find_ambiguous Find.any_in_type_in_sig sg name_s >>= function
+        | `In_type (_, _, `FField _) -> got_a_field name_s
+        | `In_type (typ_name, _, `FConstructor _) ->
+            Ok (`Constructor (`Type (parent', typ_name), name)))
+    | `T (parent', t) -> (
+        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)))
+    | (`C _ | `CT _ | `P _) as r -> wrong_kind_error [ `S; `T ] r
 
   let of_component _env parent name =
-    Ok (`Constructor (parent, ConstructorName.make_std name))
+    Ok
+      (`Constructor
+        ( (parent : Resolved.DataType.t :> Resolved.Parent.t),
+          ConstructorName.make_std name ))
 end
 
 module F = struct
@@ -479,7 +489,8 @@ module F = struct
         find_ambiguous Find.any_in_type_in_sig sg name_s >>= function
         | `In_type (_, _, `FConstructor _) -> got_a_constructor name_s
         | `In_type (typ_name, _, `FField _) ->
-            Ok (`Field (`Type (parent', typ_name), name)))
+            Ok (`Field ((`Type (parent', typ_name) :> Resolved.Parent.t), name))
+        )
     | `T (parent', t) -> (
         find Find.any_in_type t name_s >>= function
         | `FConstructor _ -> got_a_constructor name_s
@@ -662,20 +673,6 @@ and resolve_signature_reference :
   in
   resolve env'
 
-and resolve_datatype_reference :
-    Env.t -> DataType.t -> datatype_lookup_result ref_result =
- fun env r ->
-  match r with
-  | `Resolved _ -> failwith "TODO"
-  | `Root (name, (`TType | `TUnknown)) -> DT.in_env env name
-  | `Type (parent, name) ->
-      resolve_signature_reference env parent >>= fun p ->
-      DT.in_signature env p (TypeName.to_string name)
-  | `Dot (parent, name) ->
-      resolve_label_parent_reference env parent
-      >>= signature_lookup_result_of_label_parent
-      >>= fun p -> DT.in_signature env p name
-
 and resolve_module_reference env (r : Module.t) : M.t ref_result =
   match r with
   | `Resolved _r -> failwith "What's going on!?"
@@ -818,8 +815,8 @@ let resolve_reference =
     | `Dot (parent, name) -> resolve_reference_dot env parent name
     | `Root (name, `TConstructor) -> CS.in_env env name >>= resolved1
     | `Constructor (parent, name) ->
-        resolve_datatype_reference env parent >>= fun p ->
-        CS.in_datatype env p name >>= resolved1
+        resolve_label_parent_reference env (parent : Parent.t :> LabelParent.t)
+        >>= fun p -> CS.in_parent env p name >>= resolved1
     | `Root (name, `TException) -> EX.in_env env name >>= resolved1
     | `Exception (parent, name) ->
         resolve_signature_reference env parent >>= fun p ->