diff --git a/src/document/comment.ml b/src/document/comment.ml index 5fc683423d..de04499fd6 100644 --- a/src/document/comment.ml +++ b/src/document/comment.ml @@ -40,6 +40,8 @@ module Reference = struct | `Type (r, s) -> render_resolved (r :> t) ^ "." ^ TypeName.to_string s | `Constructor (r, s) -> render_resolved (r :> t) ^ "." ^ ConstructorName.to_string s + | `PolyConstructor (r, s) -> + render_resolved (r :> t) ^ ".`" ^ ConstructorName.to_string s | `Field (r, s) -> render_resolved (r :> t) ^ "." ^ FieldName.to_string s | `Extension (r, s) -> render_resolved (r :> t) ^ "." ^ ExtensionName.to_string s diff --git a/src/document/url.ml b/src/document/url.ml index af220d32df..56d8564260 100644 --- a/src/document/url.ml +++ b/src/document/url.ml @@ -263,6 +263,11 @@ module Anchor = struct let page = Path.from_identifier parent in Ok { page; anchor = str_name; kind } + (* This is needed to ensure that references to polymorphic constructors have + links that use the right suffix: those resolved references are turned into + _constructor_ identifiers. *) + let suffix_for_constructor x = x + let rec from_identifier : Identifier.t -> (t, Error.t) result = let open Error in function @@ -362,7 +367,7 @@ module Anchor = struct | { iv = `Constructor (parent, name); _ } -> from_identifier (parent :> Identifier.t) >>= fun page -> let kind = `Constructor in - let suffix = ConstructorName.to_string name in + let suffix = suffix_for_constructor (ConstructorName.to_string name) in Ok (add_suffix ~kind page suffix) | { iv = `Field (parent, name); _ } -> from_identifier (parent :> Identifier.t) >>= fun page -> @@ -415,7 +420,7 @@ module Anchor = struct add_suffix ~kind url suffix | Constructor { name; _ } -> let kind = `Constructor in - let suffix = name in + let suffix = suffix_for_constructor name in add_suffix ~kind url suffix) (** The anchor looks like diff --git a/src/model/paths.ml b/src/model/paths.ml index f2d814d698..3b84031f03 100644 --- a/src/model/paths.ml +++ b/src/model/paths.ml @@ -962,6 +962,11 @@ module Reference = struct | `Class _ | `ClassType _ | `ModuleType _ ) as r -> (label_parent_identifier r :> Identifier.t) | `Field (p, n) -> Identifier.Mk.field (field_parent_identifier p, n) + | `PolyConstructor (s, n) -> + (* Uses an identifier for constructor even though it is not + one. Document must make the links correspond. *) + Identifier.Mk.constructor + ((parent_type_identifier s :> Identifier.DataType.t), n) | `Constructor (s, n) -> Identifier.Mk.constructor ((parent_type_identifier s :> Identifier.DataType.t), n) diff --git a/src/model/paths_types.ml b/src/model/paths_types.ml index 7303cafce4..f6ef17920c 100644 --- a/src/model/paths_types.ml +++ b/src/model/paths_types.ml @@ -898,6 +898,7 @@ and Resolved_reference : sig | `ModuleType of signature * ModuleTypeName.t | `Type of signature * TypeName.t | `Constructor of datatype * ConstructorName.t + | `PolyConstructor of datatype * ConstructorName.t | `Field of field_parent * FieldName.t | `Extension of signature * ExtensionName.t | `ExtensionDecl of signature * ExtensionName.t * ExtensionName.t diff --git a/src/model_desc/paths_desc.ml b/src/model_desc/paths_desc.ml index 03b0d816ca..d072649438 100644 --- a/src/model_desc/paths_desc.ml +++ b/src/model_desc/paths_desc.ml @@ -349,6 +349,11 @@ module General_paths = struct ( "`Constructor", ((x1 :> rr), x2), Pair (resolved_reference, Names.constructorname) ) + | `PolyConstructor (x1, x2) -> + C + ( "`PolyConstructor", + ((x1 :> rr), x2), + Pair (resolved_reference, Names.constructorname) ) | `Exception (x1, x2) -> C ( "`Exception", diff --git a/src/xref2/component.ml b/src/xref2/component.ml index 05e9c87b6d..d573e80516 100644 --- a/src/xref2/component.ml +++ b/src/xref2/component.ml @@ -1576,6 +1576,11 @@ module Fmt = struct (model_resolved_reference c) (parent :> t) (ConstructorName.to_string name) + | `PolyConstructor (parent, name) -> + Format.fprintf ppf "%a.%s" + (model_resolved_reference c) + (parent :> t) + (ConstructorName.to_string name) | `Field (parent, name) -> Format.fprintf ppf "%a.%s" (model_resolved_reference c) diff --git a/src/xref2/find.ml b/src/xref2/find.ml index 7b30edbea0..2abeeb2d63 100644 --- a/src/xref2/find.ml +++ b/src/xref2/find.ml @@ -32,9 +32,12 @@ type label_parent = [ signature | type_ ] type constructor = [ `FConstructor of TypeDecl.Constructor.t ] +type polymorphic_constructor = + [ `FPoly of TypeExpr.Polymorphic_variant.Constructor.t ] + type field = [ `FField of TypeDecl.Field.t ] -type any_in_type = [ constructor | field ] +type any_in_type = [ constructor | field | polymorphic_constructor ] type any_in_type_in_sig = [ `In_type of Odoc_model.Names.TypeName.t * TypeDecl.t * any_in_type ] @@ -191,10 +194,23 @@ let any_in_type (typ : TypeDecl.t) name = | _ :: tl -> find_field tl | [] -> None in + let rec find_poly = function + | TypeExpr.Polymorphic_variant.Constructor + ({ TypeExpr.Polymorphic_variant.Constructor.name = name'; _ } as cons) + :: _ + when name' = name || name = "`" ^ name' -> + Some (`FPoly cons) + | _ :: tl -> find_poly tl + | [] -> None + in match typ.representation with | Some (Variant cons) -> find_cons cons | Some (Record fields) -> find_field fields - | Some Extensible | None -> None + | Some Extensible -> None + | None -> ( + match typ.equation.manifest with + | Some (Polymorphic_variant pv) -> find_poly pv.elements + | Some _ | None -> None) let any_in_typext (typext : Extension.t) name = let rec inner = function diff --git a/src/xref2/find.mli b/src/xref2/find.mli index c515ed4fe3..c6a065b39e 100644 --- a/src/xref2/find.mli +++ b/src/xref2/find.mli @@ -33,9 +33,12 @@ type label_parent = [ signature | type_ ] type constructor = [ `FConstructor of TypeDecl.Constructor.t ] +type polymorphic_constructor = + [ `FPoly of TypeExpr.Polymorphic_variant.Constructor.t ] + type field = [ `FField of TypeDecl.Field.t ] -type any_in_type = [ constructor | field ] +type any_in_type = [ constructor | field | polymorphic_constructor ] type any_in_type_in_sig = [ `In_type of TypeName.t * TypeDecl.t * any_in_type ] diff --git a/src/xref2/ref_tools.ml b/src/xref2/ref_tools.ml index 850f82982f..a20a02a8e9 100644 --- a/src/xref2/ref_tools.ml +++ b/src/xref2/ref_tools.ml @@ -84,6 +84,7 @@ let ref_kind_of_find = function | `FClass _ -> "class" | `FClassType _ -> "class-type" | `FConstructor _ | `In_type (_, _, `FConstructor _) -> "constructor" + | `In_type (_, _, `FPoly _) -> "polymorphic constructor" | `FExn _ -> "exception" | `FExt _ -> "extension" | `FExtDecl _ -> "extension-decl" @@ -480,11 +481,20 @@ module CS = struct 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, _, `FPoly cs) -> + Ok + (`PolyConstructor + (`Type (parent', typ_name), ConstructorName.make_std cs.name)) | `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 + | `FPoly cs -> + Ok + (`PolyConstructor + ( (parent' : Resolved.DataType.t), + ConstructorName.make_std cs.name )) | `FConstructor _ -> Ok (`Constructor ((parent' : Resolved.DataType.t), name))) @@ -492,6 +502,11 @@ module CS = struct Ok (`Constructor ((parent : Resolved.DataType.t), ConstructorName.make_std name)) + + let poly_of_component _env parent name = + Ok + (`PolyConstructor + ((parent : Resolved.DataType.t), ConstructorName.make_std name)) end module F = struct @@ -514,6 +529,7 @@ module F = struct let sg = Tools.prefix_signature (parent_cp, sg) in find_ambiguous Find.any_in_type_in_sig sg name_s >>= function | `In_type (_, _, `FConstructor _) -> got_a_constructor name_s + | `In_type (_, _, `FPoly _) -> got_a_constructor name_s | `In_type (typ_name, _, `FField _) -> Ok (`Field @@ -521,6 +537,7 @@ module F = struct | `T (parent', t) -> ( find Find.any_in_type t name_s >>= function | `FConstructor _ -> got_a_constructor name_s + | `FPoly _ -> got_a_constructor name_s | `FField _ -> Ok (`Field ((parent' :> Resolved.FieldParent.t), name))) let of_component _env parent name = @@ -779,6 +796,7 @@ let resolve_reference_dot_sg env ~parent_path ~parent_ref ~parent_sg name = let parent = `Type (parent_ref, typ_name) in match r with | `FConstructor _ -> CS.of_component env parent name >>= resolved1 + | `FPoly p -> CS.poly_of_component env parent p.name >>= resolved1 | `FField _ -> F.of_component env parent name >>= resolved1) | `FModule_subst _ | `FType_subst _ | `FModuleType_subst _ -> Error (`Find_by_name (`Any, name)) @@ -789,6 +807,7 @@ let resolve_reference_dot_page env page name = let resolve_reference_dot_type env ~parent_ref t name = find Find.any_in_type t name >>= function | `FConstructor _ -> CS.of_component env parent_ref name >>= resolved1 + | `FPoly p -> CS.poly_of_component env parent_ref p.name >>= resolved1 | `FField _ -> F.of_component env parent_ref name >>= resolved1 let resolve_reference_dot_class env p name = diff --git a/test/xref2/reference_to_polymorphic.t/main.ml b/test/xref2/reference_to_polymorphic.t/main.ml new file mode 100644 index 0000000000..26b3ec9b1d --- /dev/null +++ b/test/xref2/reference_to_polymorphic.t/main.ml @@ -0,0 +1,19 @@ +type switch = [ `On | `Off ] + +(** + + References with type as parent works: + - {!type-switch.On} + - {!type-switch.`Off} + - {!type-switch.constructor-On} + - {!type-switch.constructor-`Off} + - {!switch.On} + - {!switch.`Off} + - {!switch.constructor-On} + - {!switch.constructor-`Off} + + References in the environment don't work: + - {!On} + - {!`On} + - {!constructor-On} + - {!constructor-`On} *) diff --git a/test/xref2/reference_to_polymorphic.t/run.t b/test/xref2/reference_to_polymorphic.t/run.t new file mode 100644 index 0000000000..186e1aad6f --- /dev/null +++ b/test/xref2/reference_to_polymorphic.t/run.t @@ -0,0 +1,29 @@ + $ ocamlc -bin-annot main.ml + $ odoc compile main.cmt + $ odoc link main.odoc + File "main.ml", line 19, characters 5-23: + Warning: Failed to resolve reference unresolvedroot(`On) Couldn't find "`On" + File "main.ml", line 18, characters 5-22: + Warning: Failed to resolve reference unresolvedroot(On) Couldn't find "On" + File "main.ml", line 17, characters 5-11: + Warning: Failed to resolve reference unresolvedroot(`On) Couldn't find "`On" + File "main.ml", line 16, characters 5-10: + Warning: Failed to resolve reference unresolvedroot(On) Couldn't find "On" + + $ odoc html-generate -o html --indent main.odocl + $ cat html/Main/index.html | grep "
  • " -A 3 +

    References in the environment don't work:

    + + + +