Merge pull request #933 from panglesd/fix_447

Allow to omit parent type in constructor reference.

CHANGES.md

@@ -14,6 +14,8 @@ Tags:
 ### Added
 - Display 'private' keyword for private type extensions (@gpetiot, #1019)
 - Add support for search (@panglesd, @EmileTrotignon, #972)
+- Allow to omit parent type in constructor reference (@panglesd,
+  @EmileTrotignon, #933)
 
 ### Fixed
 

src/loader/cmi.ml

@@ -628,11 +628,11 @@ 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
-      (parent :> Identifier.Parent.t) cd.cd_args
+      (parent :> Identifier.FieldParent.t) cd.cd_args
   in
   let res = opt_map (read_type_expr env) cd.cd_res in
     {id; doc; args; res}
@@ -652,7 +652,7 @@ let read_type_kind env parent =
     | Type_record(lbls, _) ->
         let lbls =
           List.map
-            (read_label_declaration env (parent :> Identifier.Parent.t))
+            (read_label_declaration env (parent :> Identifier.FieldParent.t))
             lbls
         in
           Some (Record lbls)
@@ -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.DataType.t) decl.type_kind in
   let abstr =
     match decl.type_kind with
       Type_abstract ->
@@ -745,7 +745,7 @@ let read_extension_constructor env parent id ext =
   let doc = Doc_attr.attached_no_tag container ext.ext_attributes in
   let args =
     read_constructor_declaration_arguments env
-      (parent : Identifier.Signature.t :> Identifier.Parent.t) ext.ext_args
+      (parent : Identifier.Signature.t :> Identifier.FieldParent.t) ext.ext_args
   in
   let res = opt_map (read_type_expr env) ext.ext_ret_type in
   {id; locs; doc; args; res}
@@ -779,7 +779,7 @@ let read_exception env parent id ext =
     mark_exception ext;
     let args =
       read_constructor_declaration_arguments env
-        (parent : Identifier.Signature.t :> Identifier.Parent.t) ext.ext_args
+        (parent : Identifier.Signature.t :> Identifier.FieldParent.t) ext.ext_args
     in
     let res = opt_map (read_type_expr env) ext.ext_ret_type in
     {id; locs; doc; args; res}

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 :> Identifier.FieldParent.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 : Identifier.DataType.t :> Identifier.Parent.t) in
+      let parent = (parent :> Identifier.FieldParent.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.DataType.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 =
@@ -292,7 +292,7 @@ let read_extension_constructor env parent ext =
   let open Extension.Constructor in
   let id = Env.find_extension_identifier env ext.ext_id in
   let locs = None in
-  let container = (parent : Identifier.Signature.t :> Identifier.Parent.t) in
+  let container = (parent : Identifier.Signature.t :> Identifier.FieldParent.t) in
   let label_container = (container :> Identifier.LabelParent.t) in
   let doc = Doc_attr.attached_no_tag label_container ext.ext_attributes in
   match ext.ext_kind with
@@ -325,7 +325,7 @@ let read_exception env parent (ext : extension_constructor) =
   let open Exception in
   let id = Env.find_exception_identifier env ext.ext_id in
   let locs = None in
-  let container = (parent : Identifier.Signature.t :> Identifier.Parent.t) in
+  let container = (parent : Identifier.Signature.t :> Identifier.FieldParent.t) in
   let label_container = (container :> Identifier.LabelParent.t) in
   let doc = Doc_attr.attached_no_tag label_container ext.ext_attributes in
   match ext.ext_kind with

src/model/paths.ml

@@ -166,7 +166,7 @@ module Identifier = struct
       | { iv = `Method (p, _); _ } | { iv = `InstanceVariable (p, _); _ } ->
           (p : class_signature :> label_parent)
       | { iv = `Constructor (p, _); _ } -> (p : datatype :> label_parent)
-      | { iv = `Field (p, _); _ } -> (p : parent :> label_parent)
+      | { iv = `Field (p, _); _ } -> (p : field_parent :> label_parent)
 
   let label_parent n = label_parent_aux (n :> Id.non_src)
 
@@ -217,9 +217,9 @@ module Identifier = struct
     type t_pv = Id.datatype_pv
   end
 
-  module Parent = struct
-    type t = Id.parent
-    type t_pv = Id.parent_pv
+  module FieldParent = struct
+    type t = Paths_types.Identifier.field_parent
+    type t_pv = Paths_types.Identifier.field_parent_pv
   end
 
   module LabelParent = struct
@@ -572,13 +572,14 @@ 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 =
+        DataType.t * ConstructorName.t ->
+        [> `Constructor of DataType.t * ConstructorName.t ] id =
       mk_parent ConstructorName.to_string "ctor" (fun (p, n) ->
           `Constructor (p, n))
 
     let field :
-        Parent.t * FieldName.t -> [> `Field of Parent.t * FieldName.t ] id =
+        FieldParent.t * FieldName.t ->
+        [> `Field of FieldParent.t * FieldName.t ] id =
       mk_parent FieldName.to_string "fld" (fun (p, n) -> `Field (p, n))
 
     let extension :
@@ -991,30 +992,32 @@ module Reference = struct
       | `ClassType (sg, s) ->
           Identifier.Mk.class_type (parent_signature_identifier sg, s)
 
-    and parent_identifier : parent -> Identifier.Parent.t = function
+    and field_parent_identifier : field_parent -> Identifier.FieldParent.t =
+      function
       | `Identifier id -> id
       | (`Hidden _ | `Alias _ | `AliasModuleType _ | `Module _ | `ModuleType _)
         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)
+          (parent_signature_identifier sg :> Identifier.FieldParent.t)
+      | `Type _ as t -> (parent_type_identifier t :> Identifier.FieldParent.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 ->
-          (parent_identifier r :> Identifier.LabelParent.t)
+        | `Type _ ) as r ->
+          (field_parent_identifier r :> Identifier.LabelParent.t)
 
     and identifier : t -> Identifier.t = function
       | `Identifier id -> id
       | ( `Alias _ | `AliasModuleType _ | `Module _ | `Hidden _ | `Type _
         | `Class _ | `ClassType _ | `ModuleType _ ) as r ->
           (label_parent_identifier r :> Identifier.t)
-      | `Field (p, n) -> Identifier.Mk.field (parent_identifier p, n)
+      | `Field (p, n) -> Identifier.Mk.field (field_parent_identifier p, n)
       | `Constructor (s, n) ->
-          Identifier.Mk.constructor (parent_type_identifier 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) ->
@@ -1041,8 +1044,8 @@ module Reference = struct
       type t = Paths_types.Resolved_reference.datatype
     end
 
-    module Parent = struct
-      type t = Paths_types.Resolved_reference.parent
+    module FieldParent = struct
+      type t = Paths_types.Resolved_reference.field_parent
     end
 
     module LabelParent = struct
@@ -1126,8 +1129,8 @@ module Reference = struct
     type t = Paths_types.Reference.datatype
   end
 
-  module Parent = struct
-    type t = Paths_types.Reference.parent
+  module FragmentTypeParent = struct
+    type t = Paths_types.Reference.fragment_type_parent
   end
 
   module LabelParent = struct

src/model/paths.mli

@@ -79,9 +79,9 @@ module Identifier : sig
     type t = Id.datatype
     type t_pv = Id.datatype_pv
   end
-  module Parent : sig
-    type t = Id.parent
-    type t_pv = Id.parent_pv
+  module FieldParent : sig
+    type t = Id.field_parent
+    type t_pv = Id.field_parent_pv
   end
 
   module FunctorResult : sig
@@ -290,11 +290,12 @@ 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
+      DataType.t * ConstructorName.t ->
+      [> `Constructor of DataType.t * ConstructorName.t ] id
 
     val field :
-      Parent.t * FieldName.t -> [> `Field of Parent.t * FieldName.t ] id
+      FieldParent.t * FieldName.t ->
+      [> `Field of FieldParent.t * FieldName.t ] id
 
     val extension :
       Signature.t * ExtensionName.t ->
@@ -507,8 +508,8 @@ module rec Reference : sig
       type t = Paths_types.Resolved_reference.datatype
     end
 
-    module Parent : sig
-      type t = Paths_types.Resolved_reference.parent
+    module FieldParent : sig
+      type t = Paths_types.Resolved_reference.field_parent
     end
 
     module LabelParent : sig
@@ -592,8 +593,8 @@ module rec Reference : sig
     type t = Paths_types.Reference.datatype
   end
 
-  module Parent : sig
-    type t = Paths_types.Reference.parent
+  module FragmentTypeParent : sig
+    type t = Paths_types.Reference.fragment_type_parent
   end
 
   module LabelParent : sig