Fix references to extension declarations

CHANGES.md

@@ -13,7 +13,11 @@ Tags:
 
 ### Added
 - Display 'private' keyword for private type extensions (@gpetiot, #1019)
+
+### Fixed
+
 - Fix rendering of polymorphic variants (@wikku, @panglesd, #971)
+- Add references to extension declarations (@gpetiot, @panglesd, #949)
 
 # 2.3.0
 

doc/ocamldoc_differences.mld

@@ -51,6 +51,7 @@ Additionally we support extra annotations:
 - [class-type] is a replacement for [classtype]
 - [exn] is recognised as [exception]
 - [extension] refers to a type extension
+- [extension-decl] refers to the declaration point of an extension constructor
 - [field] is a replacement for [recfield]
 - [instance-variable] refers to instance variables
 - [label] refers to labels introduced in anchors

doc/odoc_for_authors.mld

@@ -388,6 +388,7 @@ The prefixes supported are:
 - [method]
 - [constructor] (and the equivalent deprecated prefix [const])
 - [extension]
+- [extension-decl] for refering to the declaration point of an extension constructor
 - [field] (and the equivalent deprecated prefix [recfield])
 - [instance-variable]
 - [section] (and the equivalent deprecated prefix [label]) - for referring to headings

src/document/comment.ml

@@ -43,6 +43,8 @@ module Reference = struct
     | `Field (r, s) -> render_resolved (r :> t) ^ "." ^ FieldName.to_string s
     | `Extension (r, s) ->
         render_resolved (r :> t) ^ "." ^ ExtensionName.to_string s
+    | `ExtensionDecl (r, _, s) ->
+        render_resolved (r :> t) ^ "." ^ ExtensionName.to_string s
     | `Exception (r, s) ->
         render_resolved (r :> t) ^ "." ^ ExceptionName.to_string s
     | `Value (r, s) -> render_resolved (r :> t) ^ "." ^ ValueName.to_string s
@@ -73,6 +75,8 @@ module Reference = struct
     | `Field (p, f) -> render_unresolved (p :> t) ^ "." ^ FieldName.to_string f
     | `Extension (p, f) ->
         render_unresolved (p :> t) ^ "." ^ ExtensionName.to_string f
+    | `ExtensionDecl (p, f) ->
+        render_unresolved (p :> t) ^ "." ^ ExtensionName.to_string f
     | `Exception (p, f) ->
         render_unresolved (p :> t) ^ "." ^ ExceptionName.to_string f
     | `Value (p, f) -> render_unresolved (p :> t) ^ "." ^ ValueName.to_string f

src/document/url.ml

@@ -312,6 +312,17 @@ module Anchor = struct
                 (ExtensionName.to_string name);
             kind;
           }
+    | { iv = `ExtensionDecl (parent, name, _); _ } ->
+        let page = Path.from_identifier (parent :> Path.any) in
+        let kind = `ExtensionDecl in
+        Ok
+          {
+            page;
+            anchor =
+              Format.asprintf "%a-%s" pp_kind kind
+                (ExtensionName.to_string name);
+            kind;
+          }
     | { iv = `Exception (parent, name); _ } ->
         let page = Path.from_identifier (parent :> Path.any) in
         let kind = `Exception in

src/loader/implementation.ml

@@ -451,6 +451,9 @@ let anchor_of_identifier id =
     | `Extension (parent, name) ->
         let anchor = anchor `Extension (ExtensionName.to_string name) in
         continue anchor parent
+    | `ExtensionDecl (parent, name, _) ->
+        let anchor = anchor `ExtensionDecl (ExtensionName.to_string name) in
+        continue anchor parent
   in
   anchor_of_identifier [] id |> String.concat "."
 

src/model/paths.ml

@@ -43,6 +43,7 @@ module Identifier = struct
     | `Constructor (_, name) -> ConstructorName.to_string name
     | `Field (_, name) -> FieldName.to_string name
     | `Extension (_, name) -> ExtensionName.to_string name
+    | `ExtensionDecl (_, _, name) -> ExtensionName.to_string name
     | `Exception (_, name) -> ExceptionName.to_string name
     | `CoreException name -> ExceptionName.to_string name
     | `Value (_, name) -> ValueName.to_string name
@@ -80,6 +81,7 @@ module Identifier = struct
       | { iv = `ClassType (p, _); _ }
       | { iv = `Type (p, _); _ }
       | { iv = `Extension (p, _); _ }
+      | { iv = `ExtensionDecl (p, _, _); _ }
       | { iv = `Exception (p, _); _ }
       | { iv = `Value (p, _); _ } ->
           (p : signature :> label_parent)
@@ -218,6 +220,18 @@ module Identifier = struct
     type t_pv = Id.extension_pv
   end
 
+  module ExtensionDecl = struct
+    type t = Paths_types.Identifier.extension_decl
+
+    type t_pv = Paths_types.Identifier.extension_decl_pv
+
+    let equal = equal
+
+    let hash = hash
+
+    let compare = compare
+  end
+
   module Exception = struct
     type t = Id.exception_
     type t_pv = Id.exception_pv
@@ -471,6 +485,16 @@ module Identifier = struct
         [> `Extension of Signature.t * ExtensionName.t ] id =
       mk_parent ExtensionName.to_string "extn" (fun (p, n) -> `Extension (p, n))
 
+    let extension_decl :
+        Signature.t * (ExtensionName.t * ExtensionName.t) ->
+        [> `ExtensionDecl of Signature.t * ExtensionName.t * ExtensionName.t ]
+        id =
+      mk_parent
+        (fun (n, m) ->
+          ExtensionName.to_string n ^ "." ^ ExtensionName.to_string m)
+        "extn-decl"
+        (fun (p, (n, m)) -> `ExtensionDecl (p, n, m))
+
     let exception_ :
         Signature.t * ExceptionName.t ->
         [> `Exception of Signature.t * ExceptionName.t ] id =
@@ -850,6 +874,8 @@ module Reference = struct
           Identifier.Mk.constructor (parent_type_identifier s, n)
       | `Extension (p, q) ->
           Identifier.Mk.extension (parent_signature_identifier p, q)
+      | `ExtensionDecl (p, q, r) ->
+          Identifier.Mk.extension_decl (parent_signature_identifier p, (q, r))
       | `Exception (p, q) ->
           Identifier.Mk.exception_ (parent_signature_identifier p, q)
       | `Value (p, q) -> Identifier.Mk.value (parent_signature_identifier p, q)
@@ -904,6 +930,10 @@ module Reference = struct
       type t = Paths_types.Resolved_reference.extension
     end
 
+    module ExtensionDecl = struct
+      type t = Paths_types.Resolved_reference.extension_decl
+    end
+
     module Exception = struct
       type t = Paths_types.Resolved_reference.exception_
     end
@@ -985,6 +1015,10 @@ module Reference = struct
     type t = Paths_types.Reference.extension
   end
 
+  module ExtensionDecl = struct
+    type t = Paths_types.Reference.extension_decl
+  end
+
   module Exception = struct
     type t = Paths_types.Reference.exception_
   end

src/model/paths.mli

@@ -104,6 +104,18 @@ module Identifier : sig
     type t_pv = Id.extension_pv
   end
 
+  module ExtensionDecl : sig
+    type t = Paths_types.Identifier.extension_decl
+
+    type t_pv = Paths_types.Identifier.extension_decl_pv
+
+    val equal : t -> t -> bool
+
+    val hash : t -> int
+
+    val compare : t -> t -> int
+  end
+
   module Exception : sig
     type t = Id.exception_
     type t_pv = Id.exception_pv
@@ -274,6 +286,14 @@ module Identifier : sig
       Signature.t * ExtensionName.t ->
       [> `Extension of Signature.t * ExtensionName.t ] id
 
+    val extension_decl :
+      Signature.t * (ExtensionName.t * ExtensionName.t) ->
+      [> `ExtensionDecl of Signature.t * ExtensionName.t * ExtensionName.t ] id
+    (** [extension_decl (sg, e1, eN)] defines an extension declaration where [sg] is the parent,
+        [e1] is the first constructor of the extension, and [eN] is the constructor the Id is created for.
+        [e1] will be used for the url, and [eN] will be the one displayed.
+        The first constructor of the extension will always be used to reference the extension point. *)
+
     val exception_ :
       Signature.t * ExceptionName.t ->
       [> `Exception of Signature.t * ExceptionName.t ] id
@@ -475,6 +495,10 @@ module rec Reference : sig
       type t = Paths_types.Resolved_reference.extension
     end
 
+    module ExtensionDecl : sig
+      type t = Paths_types.Resolved_reference.extension_decl
+    end
+
     module Exception : sig
       type t = Paths_types.Resolved_reference.exception_
     end
@@ -556,6 +580,10 @@ module rec Reference : sig
     type t = Paths_types.Reference.extension
   end
 
+  module ExtensionDecl : sig
+    type t = Paths_types.Reference.extension_decl
+  end
+
   module Exception : sig
     type t = Paths_types.Reference.exception_
   end

src/model/paths_types.ml

@@ -147,9 +147,16 @@ module Identifier = struct
   type extension_pv = [ `Extension of signature * ExtensionName.t ]
   (** @canonical Odoc_model.Paths.Identifier.Extension.t_pv *)
 
+  type extension_decl_pv =
+    [ `ExtensionDecl of signature * ExtensionName.t * ExtensionName.t ]
+  (** @canonical Odoc_model.Paths.Identifier.ExtensionDecl.t_pv *)
+
   and extension = extension_pv id
   (** @canonical Odoc_model.Paths.Identifier.Extension.t *)
 
+  and extension_decl = extension_decl_pv id
+  (** @canonical Odoc_model.Paths.Identifier.ExtensionDecl.t *)
+
   type exception_pv =
     [ `Exception of signature * ExceptionName.t
     | `CoreException of ExceptionName.t ]
@@ -209,6 +216,7 @@ module Identifier = struct
     | constructor_pv
     | field_pv
     | extension_pv
+    | extension_decl_pv
     | exception_pv
     | value_pv
     | class_pv
@@ -275,6 +283,8 @@ module Identifier = struct
 
   type reference_extension = [ extension_pv | exception_pv ] id
 
+  type reference_extension_decl = extension_decl
+
   type reference_exception = exception_
 
   type reference_value = value
@@ -508,6 +518,7 @@ module rec Reference : sig
     | `TConstructor
     | `TField
     | `TExtension
+    | `TExtensionDecl
     | `TException
     | `TValue
     | `TClass
@@ -632,6 +643,13 @@ module rec Reference : sig
     | `Exception of signature * ExceptionName.t ]
   (** @canonical Odoc_model.Paths.Reference.Extension.t *)
 
+  type extension_decl =
+    [ `Resolved of Resolved_reference.extension_decl
+    | `Root of string * [ `TExtension | `TException | `TUnknown ]
+    | `Dot of label_parent * string
+    | `ExtensionDecl of signature * ExtensionName.t ]
+  (** @canonical Odoc_model.Paths.Reference.ExtensionDecl.t *)
+
   type exception_ =
     [ `Resolved of Resolved_reference.exception_
     | `Root of string * [ `TException | `TUnknown ]
@@ -698,6 +716,7 @@ module rec Reference : sig
     | `Constructor of datatype * ConstructorName.t
     | `Field of parent * FieldName.t
     | `Extension of signature * ExtensionName.t
+    | `ExtensionDecl of signature * ExtensionName.t
     | `Exception of signature * ExceptionName.t
     | `Value of signature * ValueName.t
     | `Class of signature * ClassName.t
@@ -801,6 +820,16 @@ and Resolved_reference : sig
     | `Exception of signature * ExceptionName.t ]
   (** @canonical Odoc_model.Paths.Reference.Resolved.Extension.t *)
 
+  type extension_decl =
+    [ `Identifier of Identifier.reference_extension_decl
+    | `ExtensionDecl of
+      signature
+      * ExtensionName.t
+        (* The extension_name used in the url.
+           It is the extension_name of the first constructor of the extension (there is always at least 1). *)
+      * ExtensionName.t (* displayed *) ]
+  (** @canonical Odoc_model.Paths.Reference.Resolved.Extension.t *)
+
   type exception_ =
     [ `Identifier of Identifier.reference_exception
     | `Exception of signature * ExceptionName.t ]
@@ -851,6 +880,7 @@ and Resolved_reference : sig
     | `Constructor of datatype * ConstructorName.t
     | `Field of parent * FieldName.t
     | `Extension of signature * ExtensionName.t
+    | `ExtensionDecl of signature * ExtensionName.t * ExtensionName.t
     | `Exception of signature * ExceptionName.t
     | `Value of signature * ValueName.t
     | `Class of signature * ClassName.t

src/model/reference.ml

@@ -68,6 +68,7 @@ let match_extra_odoc_reference_kind (_location as loc) s :
       d loc "exn" "exception";
       Some `TException
   | Some "extension" -> Some `TExtension
+  | Some "extension-decl" -> Some `TExtensionDecl
   | Some "field" -> Some `TField
   | Some "instance-variable" -> Some `TInstanceVariable
   | Some "label" ->
@@ -365,6 +366,9 @@ let parse whole_reference_location s :
         | `TExtension ->
             `Extension
               (signature next_token tokens, ExtensionName.make_std identifier)
+        | `TExtensionDecl ->
+            `ExtensionDecl
+              (signature next_token tokens, ExtensionName.make_std identifier)
         | `TException ->
             `Exception
               (signature next_token tokens, ExceptionName.make_std identifier)

src/model_desc/paths_desc.ml

@@ -130,6 +130,11 @@ module General_paths = struct
               ( "`Extension",
                 ((parent :> id_t), name),
                 Pair (identifier, Names.extensionname) )
+        | `ExtensionDecl (parent, name, name') ->
+            C
+              ( "`ExtensionDecl",
+                ((parent :> id_t), name, name'),
+                Triple (identifier, Names.extensionname, Names.extensionname) )
         | `Exception (parent, name) ->
             C
               ( "`Exception",
@@ -184,6 +189,7 @@ module General_paths = struct
       | `TConstructor -> C0 "`TConstructor"
       | `TException -> C0 "`TException"
       | `TExtension -> C0 "`TExtension"
+      | `TExtensionDecl -> C0 "`TExtensionDecl"
       | `TField -> C0 "`TField"
       | `TInstanceVariable -> C0 "`TInstanceVariable"
       | `TLabel -> C0 "`TLabel"
@@ -294,6 +300,11 @@ module General_paths = struct
             ( "`Extension",
               ((x1 :> r), x2),
               Pair (reference, Names.extensionname) )
+      | `ExtensionDecl (x1, x2) ->
+          C
+            ( "`ExtensionDecl",
+              ((x1 :> r), x2),
+              Pair (reference, Names.extensionname) )
       | `Exception (x1, x2) ->
           C
             ( "`Exception",
@@ -346,6 +357,13 @@ module General_paths = struct
             ( "`Extension",
               ((x1 :> rr), x2),
               Pair (resolved_reference, Names.extensionname) )
+      | `ExtensionDecl (x1, x2, x3) ->
+          C
+            ( "`ExtensionDecl",
+              ((x1 :> rr), x2, x3),
+              Triple
+                (resolved_reference, Names.extensionname, Names.extensionname)
+            )
       | `Field (x1, x2) ->
           C
             ( "`Field",