Add labels to basic text block (such as paragraphs and code blocks)

src/document/comment.ml

@@ -234,16 +234,19 @@ let module_references ms =
 
 let rec nestable_block_element : Comment.nestable_block_element -> Block.one =
  fun content ->
+  let label { Odoc_model.Paths.Identifier.iv = `Label (_, label); _ } =
+    Odoc_model.Names.LabelName.to_string label
+  in
   match content with
-  | `Paragraph p -> paragraph p
-  | `Code_block (lang_tag, code) ->
+  | `Paragraph (lbl, p) -> paragraph ~label:(label lbl) p
+  | `Code_block (lbl, lang_tag, code) ->
       let lang_tag =
         match lang_tag with None -> default_lang_tag | Some t -> t
       in
-      block
+      block ~label:(label lbl)
       @@ Source (lang_tag, source_of_code (Odoc_model.Location_.value code))
-  | `Math_block s -> block @@ Math s
-  | `Verbatim s -> block @@ Verbatim s
+  | `Math_block (lbl, s) -> block ~label:(label lbl) @@ Math s
+  | `Verbatim (lbl, s) -> block ~label:(label lbl) @@ Verbatim s
   | `Modules ms -> module_references ms
   | `List (kind, items) ->
       let kind =
@@ -252,17 +255,20 @@ let rec nestable_block_element : Comment.nestable_block_element -> Block.one =
         | `Ordered -> Block.Ordered
       in
       let f = function
-        | [ { Odoc_model.Location_.value = `Paragraph content; _ } ] ->
-            [ block @@ Block.Inline (inline_element_list content) ]
+        | [ { Odoc_model.Location_.value = `Paragraph (lbl, content); _ } ] ->
+            [
+              block ~label:(label lbl)
+              @@ Block.Inline (inline_element_list content);
+            ]
         | item -> nestable_block_element_list item
       in
       let items = List.map f items in
       block @@ Block.List (kind, items)
 
-and paragraph : Comment.paragraph -> Block.one = function
+and paragraph ?label : Comment.paragraph -> Block.one = function
   | [ { value = `Raw_markup (target, s); _ } ] ->
-      block @@ Block.Raw_markup (target, s)
-  | p -> block @@ Block.Paragraph (inline_element_list p)
+      block ?label @@ Block.Raw_markup (target, s)
+  | p -> block ?label @@ Block.Paragraph (inline_element_list p)
 
 and nestable_block_element_list elements =
   elements

src/document/generator.ml

@@ -1805,7 +1805,7 @@ module Make (Syntax : SYNTAX) = struct
       in
       let page_of_dir (dir : SourceDir.t) (dir_children, file_children) =
         let url = Url.Path.source_dir_from_identifier dir in
-        let block ?(attr = []) desc = Block.{ attr; desc } in
+        let block ?(attr = []) desc = Block.{ attr; desc; label = None } in
         let inline ?(attr = []) desc = Inline.[ { attr; desc } ] in
         let header =
           let title = inline (Text (SourceDir.name dir)) in
@@ -1837,7 +1837,9 @@ module Make (Syntax : SYNTAX) = struct
           (name, url)
         in
         let items =
-          let text ?(attr = []) desc = Item.Text [ { attr; desc } ] in
+          let text ?(attr = []) desc =
+            Item.Text [ { attr; desc; label = None } ]
+          in
           let list l = Block.List (Block.Unordered, l) in
           let list_of_children =
             let dir_list =

src/document/types.ml

@@ -78,7 +78,7 @@ and Block : sig
 
   type t = one list
 
-  and one = { attr : Class.t; desc : desc }
+  and one = { attr : Class.t; desc : desc; label : string option }
 
   and desc =
     | Inline of Inline.t
@@ -187,4 +187,4 @@ end
 
 let inline ?(attr = []) desc = Inline.{ attr; desc }
 
-let block ?(attr = []) desc = Block.{ attr; desc }
+let block ?(attr = []) ?label desc = Block.{ attr; desc; label }

src/html/generator.ml

@@ -181,7 +181,10 @@ let rec block ~config ~resolve (l : Block.t) : flow Html.elt list =
   let as_flow x = (x : phrasing Html.elt list :> flow Html.elt list) in
   let one (t : Block.one) =
     let mk_block ?(extra_class = []) mk content =
-      let a = Some (class_ (extra_class @ t.attr)) in
+      let id =
+        match t.label with None -> [] | Some label -> [ Html.a_id label ]
+      in
+      let a = Some (id @ class_ (extra_class @ t.attr)) in
       [ mk ?a content ]
     in
     match t.desc with

src/model/comment.ml

@@ -42,10 +42,10 @@ type module_reference = {
     resolved during linking. *)
 
 type nestable_block_element =
-  [ `Paragraph of paragraph
-  | `Code_block of string option * string with_location
-  | `Math_block of string
-  | `Verbatim of string
+  [ `Paragraph of Identifier.Label.t * paragraph
+  | `Code_block of Identifier.Label.t * string option * string with_location
+  | `Math_block of Identifier.Label.t * string
+  | `Verbatim of Identifier.Label.t * string
   | `Modules of module_reference list
   | `List of
     [ `Unordered | `Ordered ] * nestable_block_element with_location list list
@@ -86,8 +86,7 @@ type heading_attrs = {
 
 type block_element =
   [ nestable_block_element
-  | `Heading of
-    heading_attrs * Identifier.Label.t * inline_element with_location list
+  | `Heading of heading_attrs * Identifier.Label.t * paragraph
   | `Tag of tag ]
 
 type docs = block_element with_location list
@@ -97,7 +96,7 @@ type docs_or_stop = [ `Docs of docs | `Stop ]
 (** The synopsis is the first element of a comment if it is a paragraph.
     Otherwise, there is no synopsis. *)
 let synopsis = function
-  | { Location_.value = `Paragraph p; _ } :: _ -> Some p
+  | { Location_.value = `Paragraph (_, p); _ } :: _ -> Some p
   | _ -> None
 
 let rec link_content_of_inline_element :

src/model/predefined.ml

@@ -270,20 +270,27 @@ let floatarray_decl =
     |> List.rev_map (fun s -> [ `Space; `Word s ])
     |> List.flatten |> List.tl |> List.rev
   in
+  let label =
+    Paths.Identifier.Mk.label
+      ( Paths.Identifier.Mk.root (None, ModuleName.make_std "Array"),
+        LabelName.make_std "1" )
+  in
   let doc =
     [
       `Paragraph
-        (words [ "This"; "type"; "is"; "used"; "to"; "implement"; "the" ]
-         @ [
-             `Space;
-             `Reference
-               ( `Module
-                   (`Root ("Array", `TModule), ModuleName.make_std "Floatarray"),
-                 [] );
-             `Space;
-           ]
-         @ words [ "module."; "It"; "should"; "not"; "be"; "used"; "directly." ]
-        |> List.map (Location_.at predefined_location));
+        ( label,
+          words [ "This"; "type"; "is"; "used"; "to"; "implement"; "the" ]
+          @ [
+              `Space;
+              `Reference
+                ( `Module
+                    (`Root ("Array", `TModule), ModuleName.make_std "Floatarray"),
+                  [] );
+              `Space;
+            ]
+          @ words
+              [ "module."; "It"; "should"; "not"; "be"; "used"; "directly." ]
+          |> List.map (Location_.at predefined_location) );
     ]
     |> List.map (Location_.at predefined_location)
   in

src/model/semantics.ml

@@ -216,23 +216,45 @@ let rec inline_element :
 
 and inline_elements status elements = List.map (inline_element status) elements
 
+let generate_label =
+  let current_label = ref 0 in
+  fun kind status ->
+    let lbl =
+      match kind with
+      | `Paragraph -> "p"
+      | `Code_block -> "code"
+      | `Verbatim -> "v"
+      | `Math_block -> "math"
+    in
+    let name = Format.sprintf "%s%d" lbl !current_label in
+    incr current_label;
+    Paths.Identifier.Mk.label
+      (status.parent_of_sections, Names.LabelName.make_std name)
+
 let rec nestable_block_element :
     status ->
     Odoc_parser.Ast.nestable_block_element with_location ->
     Comment.nestable_block_element with_location =
  fun status element ->
   match element with
   | { value = `Paragraph content; location } ->
-      Location.at location (`Paragraph (inline_elements status content))
+      let content = inline_elements status content in
+      let label = generate_label `Paragraph status in
+      Location.at location (`Paragraph (label, content))
   | { value = `Code_block (metadata, code); location } ->
       let lang_tag =
         match metadata with
         | Some ({ Location.value; _ }, _) -> Some value
         | None -> None
       in
-      Location.at location (`Code_block (lang_tag, code))
-  | { value = `Math_block s; location } -> Location.at location (`Math_block s)
-  | { value = `Verbatim _; _ } as element -> element
+      let label = generate_label `Code_block status in
+      Location.at location (`Code_block (label, lang_tag, code))
+  | { value = `Math_block s; location } ->
+      let label = generate_label `Verbatim status in
+      Location.at location (`Math_block (label, s))
+  | { value = `Verbatim v; location } ->
+      let label = generate_label `Math_block status in
+      Location.at location (`Verbatim (label, v))
   | { value = `Modules modules; location } ->
       let modules =
         List.fold_left
@@ -381,9 +403,10 @@ let section_heading :
   | `None, _any_level ->
       Error.raise_warning (headings_not_allowed location);
       let text = (text :> Comment.inline_element with_location list) in
+      let label = generate_label `Paragraph status in
       let element =
         Location.at location
-          (`Paragraph [ Location.at location (`Styled (`Bold, text)) ])
+          (`Paragraph (label, [ Location.at location (`Styled (`Bold, text)) ]))
       in
       (top_heading_level, element)
   | `No_titles, 0 ->

src/model_desc/comment_desc.ml

@@ -18,10 +18,10 @@ type general_inline_element =
 and general_link_content = general_inline_element with_location list
 
 type general_block_element =
-  [ `Paragraph of general_link_content
-  | `Code_block of string option * string with_location
-  | `Math_block of string
-  | `Verbatim of string
+  [ `Paragraph of Identifier.Label.t * general_link_content
+  | `Code_block of Identifier.Label.t * string option * string with_location
+  | `Math_block of Identifier.Label.t * string
+  | `Verbatim of Identifier.Label.t * string
   | `Modules of Comment.module_reference list
   | `List of
     [ `Unordered | `Ordered ] * general_block_element with_location list list
@@ -105,11 +105,11 @@ let rec block_element : general_block_element t =
   in
   Variant
     (function
-    | `Paragraph x -> C ("`Paragraph", x, link_content)
-    | `Code_block (x1, x2) ->
+    | `Paragraph (_, x) -> C ("`Paragraph", x, link_content)
+    | `Code_block (_, x1, x2) ->
         C ("`Code_block", (x1, ignore_loc x2), Pair (Option string, string))
-    | `Math_block x -> C ("`Math_block", x, string)
-    | `Verbatim x -> C ("`Verbatim", x, string)
+    | `Math_block (_, x) -> C ("`Math_block", x, string)
+    | `Verbatim (_, x) -> C ("`Verbatim", x, string)
     | `Modules x -> C ("`Modules", x, List module_reference)
     | `List (x1, x2) ->
         C ("`List", (x1, (x2 :> general_docs list)), Pair (list_kind, List docs))

src/xref2/component.ml

@@ -462,9 +462,21 @@ end =
   Substitution
 
 and CComment : sig
+  type nestable_block_element =
+    [ `Paragraph of Label.t * Odoc_model.Comment.paragraph
+    | `Code_block of
+      Label.t * string option * string Odoc_model.Comment.with_location
+    | `Math_block of Label.t * string
+    | `Verbatim of Label.t * string
+    | `Modules of Odoc_model.Comment.module_reference list
+    | `List of
+      [ `Unordered | `Ordered ]
+      * nestable_block_element Odoc_model.Comment.with_location list list ]
+
   type block_element =
-    [ Odoc_model.Comment.nestable_block_element
-    | `Heading of Label.t
+    [ nestable_block_element
+    | `Heading of
+      Odoc_model.Comment.heading_attrs * Label.t * Odoc_model.Comment.paragraph
     | `Tag of Odoc_model.Comment.tag ]
 
   type docs = block_element Odoc_model.Comment.with_location list
@@ -474,11 +486,14 @@ end =
   CComment
 
 and Label : sig
+  (** In order to generate content for links without content *)
+  type content = Heading of Odoc_model.Comment.paragraph | NestableBlock
+
   type t = {
-    attrs : Odoc_model.Comment.heading_attrs;
     label : Ident.label;
-    text : Odoc_model.Comment.paragraph;
+    content : content;
     location : Odoc_model.Location_.span;
+        (** In order to check for ambiguous labels *)
   }
 end =
   Label
@@ -2412,16 +2427,51 @@ module Of_Lang = struct
     in
     { items; removed = []; compiled = sg.compiled; doc = docs ident_map sg.doc }
 
-  and block_element _ b :
+  and nestable_block_element map
+      (b : Odoc_model.Comment.nestable_block_element Comment.with_location) =
+    let mk_label label location =
+      {
+        Label.label = Ident.Of_Identifier.label label;
+        location;
+        content = NestableBlock;
+      }
+    in
+    match b with
+    | { Odoc_model.Location_.value = `Paragraph (label, text); location } ->
+        let label = mk_label label location in
+        let para = `Paragraph (label, text) in
+        Odoc_model.Location_.same b para
+    | { value = `Code_block (label, l, s); location } ->
+        let label = mk_label label location in
+        let cb = `Code_block (label, l, s) in
+        Odoc_model.Location_.same b cb
+    | { value = `Math_block (label, s); location } ->
+        let label = mk_label label location in
+        let mb = `Math_block (label, s) in
+        Odoc_model.Location_.same b mb
+    | { value = `Verbatim (label, s); location } ->
+        let label = mk_label label location in
+        let v = `Verbatim (label, s) in
+        Odoc_model.Location_.same b v
+    | { value = `List (ord, items); _ } ->
+        let items = List.map (List.map (nestable_block_element map)) items in
+        let l = `List (ord, items) in
+        Odoc_model.Location_.same b l
+    | { value = `Modules _; _ } as n -> n
+
+  and block_element map b :
       CComment.block_element Odoc_model.Comment.with_location =
     match b with
     | { Odoc_model.Location_.value = `Heading (attrs, label, text); location }
       ->
         let label = Ident.Of_Identifier.label label in
         Odoc_model.Location_.same b
-          (`Heading { Label.attrs; label; text; location })
+          (`Heading
+            (attrs, { Label.label; content = Heading text; location }, text))
     | { value = `Tag _; _ } as t -> t
-    | { value = #Odoc_model.Comment.nestable_block_element; _ } as n -> n
+    | { value = #Odoc_model.Comment.nestable_block_element; _ } as n ->
+        (nestable_block_element map n
+          :> CComment.block_element Odoc_model.Comment.with_location)
 
   and docs ident_map d = List.map (block_element ident_map) d