Skip to content

Handle ambiguous labels #720

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 12 commits into from
Oct 1, 2021
14 changes: 7 additions & 7 deletions src/document/comment.ml
Original file line number Diff line number Diff line change
Expand Up @@ -272,30 +272,30 @@ let attached_block_element : Comment.attached_block_element -> Block.t =

let block_element : Comment.block_element -> Block.t = function
| #Comment.attached_block_element as e -> attached_block_element e
| `Heading (_, `Label (_, _), content) ->
| `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 content) ]
[ block @@ Paragraph (non_link_inline_element_list text) ]

let heading_level = function
let heading_level_to_int = function
| `Title -> 0
| `Section -> 1
| `Subsection -> 2
| `Subsubsection -> 3
| `Paragraph -> 4
| `Subparagraph -> 5

let heading (`Heading (level, `Label (_, label), content)) =
let heading (attrs, `Label (_, label), text) =
let label = Odoc_model.Names.LabelName.to_string label in
let title = non_link_inline_element_list content in
let level = heading_level level in
let title = non_link_inline_element_list text in
let level = heading_level_to_int attrs.Comment.heading_level in
let label = Some label in
Item.Heading { label; level; title }

let item_element : Comment.block_element -> Item.t list = function
| #Comment.attached_block_element as e ->
[ Item.Text (attached_block_element e) ]
| `Heading _ as h -> [ heading h ]
| `Heading h -> [ heading h ]

(** The documentation of the expansion is used if there is no comment attached
to the declaration. *)
Expand Down
110 changes: 110 additions & 0 deletions src/document/doctree.ml
Original file line number Diff line number Diff line change
Expand Up @@ -172,3 +172,113 @@ module Shift = struct
let shift_state = start in
walk_item ~on_sub shift_state i
end

module Headings : sig
val fold : ('a -> Heading.t -> 'a) -> 'a -> Page.t -> 'a
(** Fold over every headings, follow subpages, nested documentedsrc and
expansions. *)

val foldmap :
('a -> Heading.t -> 'a * Heading.t) -> 'a -> Page.t -> 'a * Page.t
end = struct
let fold =
let rec w_page f acc page =
w_items f (w_items f acc page.Page.header) page.items
and w_items f acc ts = List.fold_left (w_item f) acc ts
and w_item f acc = function
| Heading h -> f acc h
| Text _ -> acc
| Declaration t -> w_documentedsrc f acc t.Item.content
| Include t -> w_items f acc t.Item.content.content
and w_documentedsrc f acc t = List.fold_left (w_documentedsrc_one f) acc t
and w_documentedsrc_one f acc = function
| DocumentedSrc.Code _ | Documented _ -> acc
| Nested t -> w_documentedsrc f acc t.code
| Subpage sp -> w_page f acc sp.content
| Alternative (Expansion exp) -> w_documentedsrc f acc exp.expansion
in
w_page

let rec foldmap_left f acc rlst = function
| [] -> (acc, List.rev rlst)
| hd :: tl ->
let acc, hd = f acc hd in
foldmap_left f acc (hd :: rlst) tl

let foldmap_left f acc lst = foldmap_left f acc [] lst

let foldmap =
let rec w_page f acc page =
let acc, header = w_items f acc page.Page.header in
let acc, items = w_items f acc page.items in
(acc, { page with header; items })
and w_items f acc items = foldmap_left (w_item f) acc items
and w_item f acc = function
| Heading h ->
let acc, h = f acc h in
(acc, Heading h)
| Text _ as x -> (acc, x)
| Declaration t ->
let acc, content = w_documentedsrc f acc t.content in
(acc, Declaration { t with content })
| Include t ->
let acc, content = w_items f acc t.Item.content.content in
(acc, Include { t with content = { t.content with content } })
and w_documentedsrc f acc t = foldmap_left (w_documentedsrc_one f) acc t
and w_documentedsrc_one f acc = function
| (Code _ | Documented _) as x -> (acc, x)
| Nested t ->
let acc, code = w_documentedsrc f acc t.code in
(acc, Nested { t with code })
| Subpage sp ->
let acc, content = w_page f acc sp.content in
(acc, Subpage { sp with content })
| Alternative (Expansion exp) ->
let acc, expansion = w_documentedsrc f acc exp.expansion in
(acc, Alternative (Expansion { exp with expansion }))
in
w_page
end

module Labels : sig
val disambiguate_page : Page.t -> Page.t
(** Colliding labels are allowed in the model but don't make sense in
generators because we need to link to everything (eg. the TOC).
Post-process the doctree, add a "_N" suffix to dupplicates, the first
occurence is unchanged. Iterate through subpages. *)
end = struct
module StringMap = Map.Make (String)

let rec make_label_unique labels di label =
let label' = label ^ "_" in
(* start at [_2]. *)
let new_label = label' ^ string_of_int (di + 1) in
(* If the label is still ambiguous after suffixing, add an extra '_'. *)
if StringMap.mem new_label labels then make_label_unique labels di label'
else new_label

let disambiguate_page page =
(* Perform two passes, we need to know every labels before allocating new
ones. *)
let labels =
Headings.fold
(fun acc h ->
match h.label with Some l -> StringMap.add l 0 acc | None -> acc)
StringMap.empty page
in
Headings.foldmap
(fun acc h ->
match h.label with
| Some l ->
let d_index = StringMap.find l acc in
let h =
if d_index = 0 then h
else
let label = Some (make_label_unique acc d_index l) in
{ h with label }
in
(StringMap.add l (d_index + 1) acc, h)
| None -> (acc, h))
labels page
|> snd
end
3 changes: 1 addition & 2 deletions src/document/generator.ml
Original file line number Diff line number Diff line change
Expand Up @@ -838,8 +838,7 @@ module Make (Syntax : SYNTAX) = struct
| [] -> List.rev acc
| element :: input_comment -> (
match element.Location.value with
| `Heading (level, label, content) ->
let h = `Heading (level, label, content) in
| `Heading h ->
let item = Comment.heading h in
loop input_comment (item :: acc)
| _ ->
Expand Down
18 changes: 11 additions & 7 deletions src/html/generator.ml
Original file line number Diff line number Diff line change
Expand Up @@ -373,16 +373,20 @@ module Page = struct
let rec include_ ?theme_uri indent { Subpage.content; _ } =
[ page ?theme_uri indent content ]

and subpages ?theme_uri indent i =
Utils.list_concat_map ~f:(include_ ?theme_uri indent)
@@ Doctree.Subpages.compute i

and page ?theme_uri ?support_uri indent
({ Page.title; header; items = i; url } as p) =
and subpages ?theme_uri indent subpages =
Utils.list_concat_map ~f:(include_ ?theme_uri indent) subpages

and page ?theme_uri ?support_uri indent p =
let { Page.title; header; items = i; url } =
Doctree.Labels.disambiguate_page p
and subpages =
(* Don't use the output of [disambiguate_page] to avoid unecessarily
mangled labels. *)
subpages ?theme_uri indent @@ Doctree.Subpages.compute p
in
let resolve = Link.Current url in
let i = Doctree.Shift.compute ~on_sub i in
let toc = Toc.from_items ~resolve ~path:url i in
let subpages = subpages ?theme_uri indent p in
let header = items ~resolve header in
let content = (items ~resolve i :> any Html.elt list) in
let page =
Expand Down
12 changes: 6 additions & 6 deletions src/latex/generator.ml
Original file line number Diff line number Diff line change
Expand Up @@ -455,14 +455,14 @@ module Page = struct
if Link.should_inline p.status p.content.url then []
else [ page ~with_children p.content ]

and subpages ~with_children i =
List.flatten
@@ List.map (subpage ~with_children)
@@ Doctree.Subpages.compute i
and subpages ~with_children subpages =
List.flatten @@ List.map (subpage ~with_children) subpages

and page ~with_children ({ Page.title = _; header; items = i; url } as p) =
and page ~with_children p =
let { Page.title = _; header; items = i; url } =
Doctree.Labels.disambiguate_page p
and subpages = subpages ~with_children @@ Doctree.Subpages.compute p in
let i = Doctree.Shift.compute ~on_sub i in
let subpages = subpages ~with_children p in
let header = items header in
let content = items i in
let page = Doc.make ~with_children url (header @ content) subpages in
Expand Down
3 changes: 2 additions & 1 deletion src/manpage/generator.ml
Original file line number Diff line number Diff line change
Expand Up @@ -488,7 +488,8 @@ let rec subpage subp =
if Link.should_inline p.url then [] else [ render p ]

and render (p : Page.t) =
let p = Doctree.Labels.disambiguate_page p
and children = Utils.flatmap ~f:subpage @@ Subpages.compute p in
let content ppf = Format.fprintf ppf "%a@." Roff.pp (page p) in
let children = Utils.flatmap ~f:subpage @@ Subpages.compute p in
let filename = Link.as_filename p.url in
{ Renderer.filename; content; children }
8 changes: 7 additions & 1 deletion src/model/comment.ml
Original file line number Diff line number Diff line change
Expand Up @@ -71,9 +71,15 @@ type heading_level =

type attached_block_element = [ nestable_block_element | `Tag of tag ]

type heading_attrs = {
heading_level : heading_level;
heading_label_explicit : bool;
(** Whether the label have been written by the user. *)
}

type block_element =
[ nestable_block_element
| `Heading of heading_level * Identifier.Label.t * link_content
| `Heading of heading_attrs * Identifier.Label.t * link_content
| `Tag of tag ]

type docs = block_element with_location list
Expand Down
4 changes: 4 additions & 0 deletions src/model/location_.ml
Original file line number Diff line number Diff line change
Expand Up @@ -25,3 +25,7 @@ let in_string s ~offset ~length s_span =
start = point_in_string s offset s_span.start;
end_ = point_in_string s (offset + length) s_span.start;
}

let pp_span_start fmt s =
Format.fprintf fmt "File \"%s\", line %d, character %d" s.file s.start.line
s.start.column
2 changes: 2 additions & 0 deletions src/model/location_.mli
Original file line number Diff line number Diff line change
Expand Up @@ -5,3 +5,5 @@ end
val set_end_as_offset_from_start : int -> span -> span

val in_string : string -> offset:int -> length:int -> span -> span

val pp_span_start : Format.formatter -> span -> unit
11 changes: 11 additions & 0 deletions src/model/paths.ml
Original file line number Diff line number Diff line change
Expand Up @@ -78,6 +78,16 @@ module Identifier = struct

type any = t

module Any = struct
type t = any

let equal = equal

let hash = hash

let compare = compare
end

module Signature = struct
type t = Paths_types.Identifier.signature

Expand Down Expand Up @@ -395,6 +405,7 @@ module Identifier = struct
end

module Maps = struct
module Any = Map.Make (Any)
module Signature = Map.Make (Signature)
module ClassSignature = Map.Make (ClassSignature)
module DataType = Map.Make (DataType)
Expand Down
12 changes: 12 additions & 0 deletions src/model/paths.mli
Original file line number Diff line number Diff line change
Expand Up @@ -19,6 +19,16 @@
module Identifier : sig
(** {2 Generic operations} *)

module Any : sig
type t = Paths_types.Identifier.any

val equal : t -> t -> bool

val hash : t -> int

val compare : t -> t -> int
end

module Signature : sig
type t = Paths_types.Identifier.signature

Expand Down Expand Up @@ -358,6 +368,8 @@ module Identifier : sig
end

module Maps : sig
module Any : Map.S with type key = Any.t

module Signature : Map.S with type key = Signature.t

module ClassSignature : Map.S with type key = ClassSignature.t
Expand Down
35 changes: 17 additions & 18 deletions src/model/semantics.ml
Original file line number Diff line number Diff line change
Expand Up @@ -326,38 +326,42 @@ let section_heading :
fun status ~top_heading_level location heading ->
let (`Heading (level, label, content)) = heading in

let content =
let text =
non_link_inline_elements status
~surrounding:(heading :> surrounding)
content
in

let label =
let heading_label_explicit, label =
match label with
| Some label -> label
| None -> generate_heading_label content
| Some label -> (true, label)
| None -> (false, generate_heading_label text)
in
let label =
`Label (status.parent_of_sections, Names.LabelName.make_std label)
in

let mk_heading heading_level =
let attrs = { Comment.heading_level; heading_label_explicit } in
let element = Location.at location (`Heading (attrs, label, text)) in
let top_heading_level =
match top_heading_level with None -> Some level | some -> some
in
(top_heading_level, element)
in

match (status.sections_allowed, level) with
| `None, _any_level ->
Error.raise_warning (headings_not_allowed location);
let content = (content :> Comment.inline_element with_location list) in
let text = (text :> Comment.inline_element with_location list) in
let element =
Location.at location
(`Paragraph [ Location.at location (`Styled (`Bold, content)) ])
(`Paragraph [ Location.at location (`Styled (`Bold, text)) ])
in
(top_heading_level, element)
| `No_titles, 0 ->
Error.raise_warning (titles_not_allowed location);
let element = `Heading (`Title, label, content) in
let element = Location.at location element in
let top_heading_level =
match top_heading_level with None -> Some level | some -> some
in
(top_heading_level, element)
mk_heading `Title
| _, level ->
let level' =
match level with
Expand All @@ -380,12 +384,7 @@ let section_heading :
(heading_level_should_be_lower_than_top_level level top_level
location)
| _ -> ());
let element = `Heading (level', label, content) in
let element = Location.at location element in
let top_heading_level =
match top_heading_level with None -> Some level | some -> some
in
(top_heading_level, element)
mk_heading level'

let validate_first_page_heading status ast_element =
match status.parent_of_sections with
Expand Down
Loading