Allow reference to polymorphic variants when possible

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

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

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)

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

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",

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)

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

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 ]
 

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,18 +481,32 @@ 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)))
 
   let of_component _env parent name =
     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,13 +529,15 @@ 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
                 ((`Type (parent', typ_name) :> Resolved.FieldParent.t), name)))
     | `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 =

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} *)

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 "<li>" -A 3
+     <ul><li><a href="#type-switch.On"><code>switch.`On</code></a></li>
+      <li><a href="#type-switch.Off"><code>switch.`Off</code></a></li>
+      <li><a href="#type-switch.On"><code>switch.`On</code></a></li>
+      <li><a href="#type-switch.Off"><code>switch.`Off</code></a></li>
+      <li><a href="#type-switch.On"><code>switch.`On</code></a></li>
+      <li><a href="#type-switch.Off"><code>switch.`Off</code></a></li>
+      <li><a href="#type-switch.On"><code>switch.`On</code></a></li>
+      <li><a href="#type-switch.Off"><code>switch.`Off</code></a></li>
+     </ul><p>References in the environment don't work:</p>
+     <ul><li><code>On</code></li><li><code>`On</code></li>
+      <li><code>On</code></li><li><code>`On</code></li>
+     </ul>
+    </div>
+   </body>
+