Skip to content

Commit 5a054ff

Browse files
JulowJulow
authored
Merge pull request #933 from panglesd/fix_447
Allow to omit parent type in constructor reference.
2 parents df92865 + 3c90fe0 commit 5a054ff

File tree

22 files changed

+423
-280
lines changed

22 files changed

+423
-280
lines changed

‎CHANGES.md

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -14,6 +14,8 @@ Tags:
1414
### Added
1515
- Display 'private' keyword for private type extensions (@gpetiot, #1019)
1616
- Add support for search (@panglesd, @EmileTrotignon, #972)
17+
- Allow to omit parent type in constructor reference (@panglesd,
18+
@EmileTrotignon, #933)
1719

1820
### Fixed
1921

‎src/loader/cmi.ml

Lines changed: 6 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -628,11 +628,11 @@ let read_constructor_declaration_arguments env parent arg =
628628
let read_constructor_declaration env parent cd =
629629
let open TypeDecl.Constructor in
630630
let id = Ident_env.find_constructor_identifier env cd.cd_id in
631-
let container = (parent : Identifier.DataType.t :> Identifier.LabelParent.t) in
631+
let container = (parent :> Identifier.LabelParent.t) in
632632
let doc = Doc_attr.attached_no_tag container cd.cd_attributes in
633633
let args =
634634
read_constructor_declaration_arguments env
635-
(parent :> Identifier.Parent.t) cd.cd_args
635+
(parent :> Identifier.FieldParent.t) cd.cd_args
636636
in
637637
let res = opt_map (read_type_expr env) cd.cd_res in
638638
{id; doc; args; res}
@@ -652,7 +652,7 @@ let read_type_kind env parent =
652652
| Type_record(lbls, _) ->
653653
let lbls =
654654
List.map
655-
(read_label_declaration env (parent :> Identifier.Parent.t))
655+
(read_label_declaration env (parent :> Identifier.FieldParent.t))
656656
lbls
657657
in
658658
Some (Record lbls)
@@ -713,7 +713,7 @@ let read_type_declaration env parent id decl =
713713
let params = mark_type_declaration decl in
714714
let manifest = opt_map (read_type_expr env) decl.type_manifest in
715715
let constraints = read_type_constraints env params in
716-
let representation = read_type_kind env id decl.type_kind in
716+
let representation = read_type_kind env (id :> Identifier.DataType.t) decl.type_kind in
717717
let abstr =
718718
match decl.type_kind with
719719
Type_abstract ->
@@ -745,7 +745,7 @@ let read_extension_constructor env parent id ext =
745745
let doc = Doc_attr.attached_no_tag container ext.ext_attributes in
746746
let args =
747747
read_constructor_declaration_arguments env
748-
(parent : Identifier.Signature.t :> Identifier.Parent.t) ext.ext_args
748+
(parent : Identifier.Signature.t :> Identifier.FieldParent.t) ext.ext_args
749749
in
750750
let res = opt_map (read_type_expr env) ext.ext_ret_type in
751751
{id; locs; doc; args; res}
@@ -779,7 +779,7 @@ let read_exception env parent id ext =
779779
mark_exception ext;
780780
let args =
781781
read_constructor_declaration_arguments env
782-
(parent : Identifier.Signature.t :> Identifier.Parent.t) ext.ext_args
782+
(parent : Identifier.Signature.t :> Identifier.FieldParent.t) ext.ext_args
783783
in
784784
let res = opt_map (read_type_expr env) ext.ext_ret_type in
785785
{id; locs; doc; args; res}

‎src/loader/cmti.ml

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -214,7 +214,7 @@ let read_constructor_declaration_arguments env parent label_parent arg =
214214
let read_constructor_declaration env parent cd =
215215
let open TypeDecl.Constructor in
216216
let id = Ident_env.find_constructor_identifier env cd.cd_id in
217-
let container = (parent : Identifier.DataType.t :> Identifier.Parent.t) in
217+
let container = (parent :> Identifier.FieldParent.t) in
218218
let label_container = (container :> Identifier.LabelParent.t) in
219219
let doc = Doc_attr.attached_no_tag label_container cd.cd_attributes in
220220
let args =
@@ -231,7 +231,7 @@ let read_type_kind env parent =
231231
let cstrs = List.map (read_constructor_declaration env parent) cstrs in
232232
Some (Variant cstrs)
233233
| Ttype_record lbls ->
234-
let parent = (parent : Identifier.DataType.t :> Identifier.Parent.t) in
234+
let parent = (parent :> Identifier.FieldParent.t) in
235235
let label_parent = (parent :> Identifier.LabelParent.t) in
236236
let lbls =
237237
List.map (read_label_declaration env parent label_parent) lbls in
@@ -260,7 +260,7 @@ let read_type_declaration env parent decl =
260260
let doc, canonical = Doc_attr.attached Odoc_model.Semantics.Expect_canonical container decl.typ_attributes in
261261
let canonical = (canonical :> Path.Type.t option) in
262262
let equation = read_type_equation env container decl in
263-
let representation = read_type_kind env (id :> Identifier.DataType.t) decl.typ_kind in
263+
let representation = read_type_kind env id decl.typ_kind in
264264
{id; locs; doc; canonical; equation; representation}
265265

266266
let read_type_declarations env parent rec_flag decls =
@@ -292,7 +292,7 @@ let read_extension_constructor env parent ext =
292292
let open Extension.Constructor in
293293
let id = Env.find_extension_identifier env ext.ext_id in
294294
let locs = None in
295-
let container = (parent : Identifier.Signature.t :> Identifier.Parent.t) in
295+
let container = (parent : Identifier.Signature.t :> Identifier.FieldParent.t) in
296296
let label_container = (container :> Identifier.LabelParent.t) in
297297
let doc = Doc_attr.attached_no_tag label_container ext.ext_attributes in
298298
match ext.ext_kind with
@@ -325,7 +325,7 @@ let read_exception env parent (ext : extension_constructor) =
325325
let open Exception in
326326
let id = Env.find_exception_identifier env ext.ext_id in
327327
let locs = None in
328-
let container = (parent : Identifier.Signature.t :> Identifier.Parent.t) in
328+
let container = (parent : Identifier.Signature.t :> Identifier.FieldParent.t) in
329329
let label_container = (container :> Identifier.LabelParent.t) in
330330
let doc = Doc_attr.attached_no_tag label_container ext.ext_attributes in
331331
match ext.ext_kind with

‎src/model/paths.ml

Lines changed: 23 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -166,7 +166,7 @@ module Identifier = struct
166166
| { iv = `Method (p, _); _ } | { iv = `InstanceVariable (p, _); _ } ->
167167
(p : class_signature :> label_parent)
168168
| { iv = `Constructor (p, _); _ } -> (p : datatype :> label_parent)
169-
| { iv = `Field (p, _); _ } -> (p : parent :> label_parent)
169+
| { iv = `Field (p, _); _ } -> (p : field_parent :> label_parent)
170170

171171
let label_parent n = label_parent_aux (n :> Id.non_src)
172172

@@ -217,9 +217,9 @@ module Identifier = struct
217217
type t_pv = Id.datatype_pv
218218
end
219219

220-
module Parent = struct
221-
type t = Id.parent
222-
type t_pv = Id.parent_pv
220+
module FieldParent = struct
221+
type t = Paths_types.Identifier.field_parent
222+
type t_pv = Paths_types.Identifier.field_parent_pv
223223
end
224224

225225
module LabelParent = struct
@@ -572,13 +572,14 @@ module Identifier = struct
572572
mk_fresh (fun s -> s) "coret" (fun s -> `CoreType (TypeName.make_std s))
573573

574574
let constructor :
575-
Type.t * ConstructorName.t ->
576-
[> `Constructor of Type.t * ConstructorName.t ] id =
575+
DataType.t * ConstructorName.t ->
576+
[> `Constructor of DataType.t * ConstructorName.t ] id =
577577
mk_parent ConstructorName.to_string "ctor" (fun (p, n) ->
578578
`Constructor (p, n))
579579

580580
let field :
581-
Parent.t * FieldName.t -> [> `Field of Parent.t * FieldName.t ] id =
581+
FieldParent.t * FieldName.t ->
582+
[> `Field of FieldParent.t * FieldName.t ] id =
582583
mk_parent FieldName.to_string "fld" (fun (p, n) -> `Field (p, n))
583584

584585
let extension :
@@ -991,30 +992,32 @@ module Reference = struct
991992
| `ClassType (sg, s) ->
992993
Identifier.Mk.class_type (parent_signature_identifier sg, s)
993994

994-
and parent_identifier : parent -> Identifier.Parent.t = function
995+
and field_parent_identifier : field_parent -> Identifier.FieldParent.t =
996+
function
995997
| `Identifier id -> id
996998
| (`Hidden _ | `Alias _ | `AliasModuleType _ | `Module _ | `ModuleType _)
997999
as sg ->
998-
(parent_signature_identifier sg :> Identifier.Parent.t)
999-
| `Type _ as t -> (parent_type_identifier t :> Identifier.Parent.t)
1000-
| (`Class _ | `ClassType _) as c ->
1001-
(parent_class_signature_identifier c :> Identifier.Parent.t)
1000+
(parent_signature_identifier sg :> Identifier.FieldParent.t)
1001+
| `Type _ as t -> (parent_type_identifier t :> Identifier.FieldParent.t)
10021002

10031003
and label_parent_identifier : label_parent -> Identifier.LabelParent.t =
10041004
function
10051005
| `Identifier id -> id
1006+
| (`Class _ | `ClassType _) as c ->
1007+
(parent_class_signature_identifier c :> Identifier.LabelParent.t)
10061008
| ( `Hidden _ | `Alias _ | `AliasModuleType _ | `Module _ | `ModuleType _
1007-
| `Type _ | `Class _ | `ClassType _ ) as r ->
1008-
(parent_identifier r :> Identifier.LabelParent.t)
1009+
| `Type _ ) as r ->
1010+
(field_parent_identifier r :> Identifier.LabelParent.t)
10091011

10101012
and identifier : t -> Identifier.t = function
10111013
| `Identifier id -> id
10121014
| ( `Alias _ | `AliasModuleType _ | `Module _ | `Hidden _ | `Type _
10131015
| `Class _ | `ClassType _ | `ModuleType _ ) as r ->
10141016
(label_parent_identifier r :> Identifier.t)
1015-
| `Field (p, n) -> Identifier.Mk.field (parent_identifier p, n)
1017+
| `Field (p, n) -> Identifier.Mk.field (field_parent_identifier p, n)
10161018
| `Constructor (s, n) ->
1017-
Identifier.Mk.constructor (parent_type_identifier s, n)
1019+
Identifier.Mk.constructor
1020+
((parent_type_identifier s :> Identifier.DataType.t), n)
10181021
| `Extension (p, q) ->
10191022
Identifier.Mk.extension (parent_signature_identifier p, q)
10201023
| `ExtensionDecl (p, q, r) ->
@@ -1041,8 +1044,8 @@ module Reference = struct
10411044
type t = Paths_types.Resolved_reference.datatype
10421045
end
10431046

1044-
module Parent = struct
1045-
type t = Paths_types.Resolved_reference.parent
1047+
module FieldParent = struct
1048+
type t = Paths_types.Resolved_reference.field_parent
10461049
end
10471050

10481051
module LabelParent = struct
@@ -1126,8 +1129,8 @@ module Reference = struct
11261129
type t = Paths_types.Reference.datatype
11271130
end
11281131

1129-
module Parent = struct
1130-
type t = Paths_types.Reference.parent
1132+
module FragmentTypeParent = struct
1133+
type t = Paths_types.Reference.fragment_type_parent
11311134
end
11321135

11331136
module LabelParent = struct

‎src/model/paths.mli

Lines changed: 11 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -79,9 +79,9 @@ module Identifier : sig
7979
type t = Id.datatype
8080
type t_pv = Id.datatype_pv
8181
end
82-
module Parent : sig
83-
type t = Id.parent
84-
type t_pv = Id.parent_pv
82+
module FieldParent : sig
83+
type t = Id.field_parent
84+
type t_pv = Id.field_parent_pv
8585
end
8686

8787
module FunctorResult : sig
@@ -290,11 +290,12 @@ module Identifier : sig
290290
val core_type : string -> [> `CoreType of TypeName.t ] id
291291

292292
val constructor :
293-
Type.t * ConstructorName.t ->
294-
[> `Constructor of Type.t * ConstructorName.t ] id
293+
DataType.t * ConstructorName.t ->
294+
[> `Constructor of DataType.t * ConstructorName.t ] id
295295

296296
val field :
297-
Parent.t * FieldName.t -> [> `Field of Parent.t * FieldName.t ] id
297+
FieldParent.t * FieldName.t ->
298+
[> `Field of FieldParent.t * FieldName.t ] id
298299

299300
val extension :
300301
Signature.t * ExtensionName.t ->
@@ -507,8 +508,8 @@ module rec Reference : sig
507508
type t = Paths_types.Resolved_reference.datatype
508509
end
509510

510-
module Parent : sig
511-
type t = Paths_types.Resolved_reference.parent
511+
module FieldParent : sig
512+
type t = Paths_types.Resolved_reference.field_parent
512513
end
513514

514515
module LabelParent : sig
@@ -592,8 +593,8 @@ module rec Reference : sig
592593
type t = Paths_types.Reference.datatype
593594
end
594595

595-
module Parent : sig
596-
type t = Paths_types.Reference.parent
596+
module FragmentTypeParent : sig
597+
type t = Paths_types.Reference.fragment_type_parent
597598
end
598599

599600
module LabelParent : sig

0 commit comments

Comments
 (0)