Merge pull request #942 from EmileTrotignon/fix-342

Fixes issue #342 : links and references are now allowed in headings.

They are displayed as regular text inside the table of content, as the headings here are already links, and nesting links is a bad idea.

Author: Julow

src/document/comment.ml

@@ -332,7 +332,7 @@ let block_element : Comment.block_element -> Block.t = function
   | `Heading (_, _, text) ->
       (* We are not supposed to receive Heading in this context.
          TODO: Remove heading in attached documentation in the model *)
-      [ block @@ Paragraph (non_link_inline_element_list text) ]
+      [ block @@ Paragraph (inline_element_list text) ]
 
 let heading_level_to_int = function
   | `Title -> 0
@@ -345,7 +345,7 @@ let heading_level_to_int = function
 let heading
     (attrs, { Odoc_model.Paths.Identifier.iv = `Label (_, label); _ }, text) =
   let label = Odoc_model.Names.LabelName.to_string label in
-  let title = non_link_inline_element_list text in
+  let title = inline_element_list text in
   let level = heading_level_to_int attrs.Comment.heading_level in
   let label = Some label in
   let source_anchor = None in

src/document/doctree.ml

@@ -55,6 +55,27 @@ end = struct
   type t = one list
 
   and one = { url : Url.t; text : Inline.t; children : t }
+  let rec remove_links l =
+    let open Inline in
+    l
+    |> List.map (fun one ->
+           let return desc = [ { one with desc } ] in
+           match one.desc with
+           | Text _ as t -> return t
+           | Entity _ as t -> return t
+           | Linebreak as t -> return t
+           | Styled (st, content) -> return (Styled (st, remove_links content))
+           | Link (_, t) -> t
+           | InternalLink { target = Resolved _; content = t; _ } -> t
+           | InternalLink { target = Unresolved; content = t; _ } -> t
+           | Source l ->
+               let rec f = function
+                 | Source.Elt t -> Source.Elt (remove_links t)
+                 | Tag (tag, t) -> Tag (tag, List.map f t)
+               in
+               return @@ Source (List.map f l)
+           | (Math _ | Raw_markup _) as t -> return t)
+    |> List.concat
 
   let classify ~on_sub (i : Item.t) : _ Rewire.action =
     match i with
@@ -63,6 +84,7 @@ end = struct
         if on_sub status then Rec content else Skip
     | Heading { label = None; _ } -> Skip
     | Heading { label = Some label; level; title; _ } ->
+        let title = remove_links title in
         Heading ((label, title), level)
 
   let node mkurl (anchor, text) children =

src/model/comment.ml

@@ -82,7 +82,8 @@ type heading_attrs = {
 
 type block_element =
   [ nestable_block_element
-  | `Heading of heading_attrs * Identifier.Label.t * link_content
+  | `Heading of
+    heading_attrs * Identifier.Label.t * inline_element with_location list
   | `Tag of tag ]
 
 type docs = block_element with_location list
@@ -94,3 +95,17 @@ type docs_or_stop = [ `Docs of docs | `Stop ]
 let synopsis = function
   | { Location_.value = `Paragraph p; _ } :: _ -> Some p
   | _ -> None
+
+let rec link_content_of_inline_element :
+    inline_element with_location -> link_content =
+ fun x ->
+  let v = x.Location_.value in
+  match v with
+  | #leaf_inline_element as e -> [ { x with value = e } ]
+  | `Reference (_, r) -> r
+  | `Link (_, l) -> l
+  | `Styled (st, elems) ->
+      [ { x with value = `Styled (st, link_content_of_inline_elements elems) } ]
+
+and link_content_of_inline_elements l =
+  l |> List.map link_content_of_inline_element |> List.concat

src/model/semantics.ml

@@ -150,11 +150,7 @@ let leaf_inline_element :
       | Some target -> Location.same element (`Raw_markup (target, s)))
 
 type surrounding =
-  [ `Heading of
-    int
-    * string option
-    * Odoc_parser.Ast.inline_element Location_.with_location list
-  | `Link of
+  [ `Link of
     string * Odoc_parser.Ast.inline_element Location_.with_location list
   | `Reference of
     [ `Simple | `With_text ]
@@ -290,7 +286,8 @@ let tag :
 
    This must be done in the parser (i.e. early, not at HTML/other output
    generation time), so that the cross-referencer can see these anchors. *)
-let generate_heading_label : Comment.link_content -> string =
+let generate_heading_label : Comment.inline_element with_location list -> string
+    =
  fun content ->
   (* Code spans can contain spaces, so we need to replace them with hyphens. We
      also lowercase all the letters, for consistency with the rest of this
@@ -308,13 +305,14 @@ let generate_heading_label : Comment.link_content -> string =
     Bytes.unsafe_to_string result
   in
 
+  let strip_locs li = List.map (fun ele -> ele.Location.value) li in
   (* Perhaps this should be done using a [Buffer.t]; we can switch to that as
      needed. *)
   let rec scan_inline_elements anchor = function
     | [] -> anchor
     | element :: more ->
         let anchor =
-          match element.Location.value with
+          match (element : Comment.inline_element) with
           | `Space -> anchor ^ "-"
           | `Word w -> anchor ^ Astring.String.Ascii.lowercase w
           | `Code_span c | `Math_span c ->
@@ -323,11 +321,22 @@ let generate_heading_label : Comment.link_content -> string =
               (* TODO Perhaps having raw markup in a section heading should be an
                  error? *)
               anchor
-          | `Styled (_, content) -> scan_inline_elements anchor content
+          | `Styled (_, content) ->
+              content |> strip_locs |> scan_inline_elements anchor
+          | `Reference (_, content) ->
+              content |> strip_locs
+              |> List.map (fun (ele : Comment.non_link_inline_element) ->
+                     (ele :> Comment.inline_element))
+              |> scan_inline_elements anchor
+          | `Link (_, content) ->
+              content |> strip_locs
+              |> List.map (fun (ele : Comment.non_link_inline_element) ->
+                     (ele :> Comment.inline_element))
+              |> scan_inline_elements anchor
         in
         scan_inline_elements anchor more
   in
-  scan_inline_elements "" content
+  content |> List.map (fun ele -> ele.Location.value) |> scan_inline_elements ""
 
 let section_heading :
     status ->
@@ -338,11 +347,7 @@ let section_heading :
  fun status ~top_heading_level location heading ->
   let (`Heading (level, label, content)) = heading in
 
-  let text =
-    non_link_inline_elements status
-      ~surrounding:(heading :> surrounding)
-      content
-  in
+  let text = inline_elements status content in
 
   let heading_label_explicit, label =
     match label with

src/xref2/component.ml

@@ -477,7 +477,7 @@ and Label : sig
   type t = {
     attrs : Odoc_model.Comment.heading_attrs;
     label : Ident.label;
-    text : Odoc_model.Comment.link_content;
+    text : Odoc_model.Comment.paragraph;
     location : Odoc_model.Location_.span;
   }
 end =

src/xref2/component.mli

@@ -446,7 +446,7 @@ and Label : sig
   type t = {
     attrs : Odoc_model.Comment.heading_attrs;
     label : Ident.label;
-    text : Odoc_model.Comment.link_content;
+    text : Odoc_model.Comment.paragraph;
     location : Odoc_model.Location_.span;
   }
 end

src/xref2/link.ml

@@ -212,7 +212,9 @@ let rec comment_inline_element :
             match (content, x) with
             | [], `Identifier ({ iv = #Id.Label.t_pv; _ } as i) -> (
                 match Env.lookup_by_id Env.s_label i env with
-                | Some (`Label (_, lbl)) -> lbl.Component.Label.text
+                | Some (`Label (_, lbl)) ->
+                    Odoc_model.Comment.link_content_of_inline_elements
+                      lbl.Component.Label.text
                 | None -> [])
             | content, _ -> content
           in
@@ -292,9 +294,14 @@ and comment_block_element env parent ~loc (x : Comment.block_element) =
   | #Comment.nestable_block_element as x ->
       (comment_nestable_block_element env parent ~loc x
         :> Comment.block_element)
-  | `Heading h as x ->
+  | `Heading (attrs, label, elems) ->
+      let cie = comment_inline_element env in
+      let elems =
+        List.rev_map (fun ele -> with_location cie ele) elems |> List.rev
+      in
+      let h = (attrs, label, elems) in
       check_ambiguous_label ~loc env h;
-      x
+      `Heading h
   | `Tag t -> `Tag (comment_tag env parent ~loc t)
 
 and with_location :

test/model/semantics/test.ml

@@ -1823,13 +1823,11 @@ let%expect_test _ =
               "`Heading": [
                 { "heading_level": "`Subsection", "heading_label_explicit": "false" },
                 { "`Label": [ { "`Page": [ "None", "f.ml" ] }, "" ] },
-                [ { "`Styled": [ "`Emphasis", [] ] } ]
+                [ { "`Link": [ "foo", [] ] } ]
               ]
             }
           ],
-          "warnings": [
-            "File \"f.ml\", line 1, characters 3-11:\n'{{:...} ...}' (external link) is not allowed in '{2 ...}' (section heading)."
-          ]
+          "warnings": []
         } |}]
 
     let reference_in_markup =
@@ -1842,13 +1840,11 @@ let%expect_test _ =
               "`Heading": [
                 { "heading_level": "`Subsection", "heading_label_explicit": "false" },
                 { "`Label": [ { "`Page": [ "None", "f.ml" ] }, "" ] },
-                [ { "`Styled": [ "`Emphasis", [] ] } ]
+                [ { "`Reference": [ { "`Root": [ "foo", "`TUnknown" ] }, [] ] } ]
               ]
             }
           ],
-          "warnings": [
-            "File \"f.ml\", line 1, characters 3-9:\n'{!...}' (cross-reference) is not allowed in '{2 ...}' (section heading)."
-          ]
+          "warnings": []
         } |}]
 
     let two =

test/xref2/github_issue_342.t/foo.mli

@@ -0,0 +1,8 @@
+module A : sig end
+
+(**  {1 References {!A} and {{!A}with text} in title}
+
+{1 An url {:http://ocaml.org} and {{:http://ocaml.org}with text} in a title}
+
+*)
+

test/xref2/github_issue_342.t/run.t

@@ -0,0 +1,36 @@
+A quick test to repro the issue found in #342
+
+  $ ocamlc -bin-annot -c foo.mli
+
+  $ odoc compile foo.cmti
+  $ odoc link foo.odoc
+
+  $ odoc html-generate --indent -o html/ foo.odocl
+
+The table of content:
+
+  $ cat html/Foo/index.html | grep "odoc-toc" -A 9
+    <nav class="odoc-toc">
+     <ul>
+      <li>
+       <a href="#references--and-with-text-in-title">References <code>A</code>
+         and with text in title
+       </a>
+      </li>
+      <li>
+       <a href="#an-url--and-with-text-in-a-title">An url http://ocaml.org
+         and with text in a title
+
+The rendered headings
+
+  $ cat html/Foo/index.html | grep "<h2" -A 3
+     <h2 id="references--and-with-text-in-title">
+      <a href="#references--and-with-text-in-title" class="anchor"></a>
+      References <a href="A/index.html"><code>A</code></a> and 
+      <a href="A/index.html" title="A">with text</a> in title
+  --
+     <h2 id="an-url--and-with-text-in-a-title">
+      <a href="#an-url--and-with-text-in-a-title" class="anchor"></a>An
+       url <a href="http://ocaml.org">http://ocaml.org</a> and 
+      <a href="http://ocaml.org">with text</a> in a title
+