diff --git a/src/document/comment.ml b/src/document/comment.ml index 60a21a3674..b5fa1b84bb 100644 --- a/src/document/comment.ml +++ b/src/document/comment.ml @@ -272,12 +272,12 @@ 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 @@ -285,17 +285,17 @@ let heading_level = function | `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. *) diff --git a/src/document/doctree.ml b/src/document/doctree.ml index 6b5a15ae17..46e4a97317 100644 --- a/src/document/doctree.ml +++ b/src/document/doctree.ml @@ -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 diff --git a/src/document/generator.ml b/src/document/generator.ml index 5ac3b8dd75..7a6f5f0f87 100644 --- a/src/document/generator.ml +++ b/src/document/generator.ml @@ -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) | _ -> diff --git a/src/html/generator.ml b/src/html/generator.ml index ea6e3bb147..a1870592e4 100644 --- a/src/html/generator.ml +++ b/src/html/generator.ml @@ -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 = diff --git a/src/latex/generator.ml b/src/latex/generator.ml index cd9ddf818f..e4cfc7461a 100644 --- a/src/latex/generator.ml +++ b/src/latex/generator.ml @@ -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 diff --git a/src/manpage/generator.ml b/src/manpage/generator.ml index 524dd2f453..3342ff183c 100644 --- a/src/manpage/generator.ml +++ b/src/manpage/generator.ml @@ -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 } diff --git a/src/model/comment.ml b/src/model/comment.ml index 7b50602228..abc57a1e1a 100644 --- a/src/model/comment.ml +++ b/src/model/comment.ml @@ -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 diff --git a/src/model/location_.ml b/src/model/location_.ml index 2067aa66fb..b72f92f38f 100644 --- a/src/model/location_.ml +++ b/src/model/location_.ml @@ -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 diff --git a/src/model/location_.mli b/src/model/location_.mli index f05e877baa..36890183e1 100644 --- a/src/model/location_.mli +++ b/src/model/location_.mli @@ -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 diff --git a/src/model/paths.ml b/src/model/paths.ml index ae09e9c149..e0edafdcf9 100644 --- a/src/model/paths.ml +++ b/src/model/paths.ml @@ -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 @@ -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) diff --git a/src/model/paths.mli b/src/model/paths.mli index 65df803e5f..8fad3e9fc6 100644 --- a/src/model/paths.mli +++ b/src/model/paths.mli @@ -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 @@ -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 diff --git a/src/model/semantics.ml b/src/model/semantics.ml index aad965b533..8695a2cb01 100644 --- a/src/model/semantics.ml +++ b/src/model/semantics.ml @@ -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 @@ -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 diff --git a/src/model_desc/comment_desc.ml b/src/model_desc/comment_desc.ml index ab57fe2e5a..5d7f21d781 100644 --- a/src/model_desc/comment_desc.ml +++ b/src/model_desc/comment_desc.ml @@ -23,7 +23,8 @@ type general_block_element = | `Modules of Comment.module_reference list | `List of [ `Unordered | `Ordered ] * general_block_element with_location list list - | `Heading of heading_level * Paths.Identifier.Label.t * general_link_content + | `Heading of + Comment.heading_attrs * Identifier.Label.t * general_link_content | `Tag of general_tag ] and general_tag = @@ -70,7 +71,7 @@ let module_reference = in Indirect (simplify, Pair (reference, Option link_content)) -let rec block_element : general_block_element t = +let heading = let heading_level = Variant (function @@ -81,6 +82,16 @@ let rec block_element : general_block_element t = | `Paragraph -> C0 "`Paragraph" | `Subparagraph -> C0 "`Subparagraph") in + let heading_attrs = + Record + [ + F ("heading_level", (fun h -> h.heading_level), heading_level); + F ("heading_label_explicit", (fun h -> h.heading_label_explicit), bool); + ] + in + Triple (heading_attrs, identifier, link_content) + +let rec block_element : general_block_element t = let list_kind = Variant (function `Unordered -> C0 "`Unordered" | `Ordered -> C0 "`Ordered") @@ -98,11 +109,7 @@ let rec block_element : general_block_element t = | `Modules x -> C ("`Modules", x, List module_reference) | `List (x1, x2) -> C ("`List", (x1, (x2 :> general_docs list)), Pair (list_kind, List docs)) - | `Heading (x1, x2, x3) -> - C - ( "`Heading", - (x1, x2, x3), - Triple (heading_level, identifier, link_content) ) + | `Heading h -> C ("`Heading", h, heading) | `Tag x -> C ("`Tag", x, tag)) and tag : general_tag t = diff --git a/src/xref2/component.ml b/src/xref2/component.ml index 8918db8b9e..2b086dfcf8 100644 --- a/src/xref2/component.ml +++ b/src/xref2/component.ml @@ -443,10 +443,7 @@ end = and CComment : sig type block_element = [ Odoc_model.Comment.nestable_block_element - | `Heading of - Odoc_model.Comment.heading_level - * Ident.label - * Odoc_model.Comment.link_content + | `Heading of Label.t | `Tag of Odoc_model.Comment.tag ] type docs = block_element Odoc_model.Comment.with_location list @@ -455,6 +452,16 @@ and CComment : sig end = CComment +and Label : sig + type t = { + attrs : Odoc_model.Comment.heading_attrs; + label : Ident.label; + text : Odoc_model.Comment.link_content; + location : Odoc_model.Location_.span; + } +end = + Label + module Element = struct open Odoc_model.Paths @@ -466,7 +473,7 @@ module Element = struct type value = [ `Value of Identifier.Value.t * Value.t ] - type label = [ `Label of Identifier.Label.t ] + type label = [ `Label of Identifier.Label.t * Label.t ] type class_ = [ `Class of Identifier.Class.t * Class.t ] @@ -2365,21 +2372,18 @@ module Of_Lang = struct in { items; removed = []; compiled = sg.compiled; doc = docs ident_map sg.doc } - and with_location : - 'a 'b. (map -> 'a -> 'b) -> map -> 'a Location_.with_location -> - 'b Location_.with_location = - fun conv ident_map v -> { v with value = conv ident_map v.Location_.value } - - and block_element : - _ -> Odoc_model.Comment.block_element -> CComment.block_element = - fun _ b -> + and block_element _ b : + CComment.block_element Odoc_model.Comment.with_location = match b with - | `Heading (l, id, content) -> - `Heading (l, Ident.Of_Identifier.label id, content) - | `Tag t -> `Tag t - | #Odoc_model.Comment.nestable_block_element as n -> n - - and docs ident_map d = List.map (with_location block_element ident_map) d + | { 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 }) + | { value = `Tag _; _ } as t -> t + | { value = #Odoc_model.Comment.nestable_block_element; _ } as n -> n + + and docs ident_map d = List.map (block_element ident_map) d and docs_or_stop ident_map = function | `Docs d -> `Docs (docs ident_map d) diff --git a/src/xref2/component.mli b/src/xref2/component.mli index 5fb4855a3e..21e7a5e153 100644 --- a/src/xref2/component.mli +++ b/src/xref2/component.mli @@ -413,10 +413,7 @@ end and CComment : sig type block_element = [ Odoc_model.Comment.nestable_block_element - | `Heading of - Odoc_model.Comment.heading_level - * Ident.label - * Odoc_model.Comment.link_content + | `Heading of Label.t | `Tag of Odoc_model.Comment.tag ] type docs = block_element Odoc_model.Comment.with_location list @@ -424,6 +421,15 @@ and CComment : sig type docs_or_stop = [ `Docs of docs | `Stop ] end +and Label : sig + type t = { + attrs : Odoc_model.Comment.heading_attrs; + label : Ident.label; + text : Odoc_model.Comment.link_content; + location : Odoc_model.Location_.span; + } +end + module Element : sig open Odoc_model.Paths @@ -435,7 +441,7 @@ module Element : sig type value = [ `Value of Identifier.Value.t * Value.t ] - type label = [ `Label of Identifier.Label.t ] + type label = [ `Label of Identifier.Label.t * Label.t ] type class_ = [ `Class of Identifier.Class.t * Class.t ] @@ -758,9 +764,6 @@ module Of_Lang : sig val apply_sig_map : map -> Odoc_model.Lang.Signature.t -> Signature.t - val block_element : - map -> Odoc_model.Comment.block_element -> CComment.block_element - val docs : map -> Odoc_model.Comment.docs -> CComment.docs val docs_or_stop : diff --git a/src/xref2/env.ml b/src/xref2/env.ml index 99f05d7fe4..fcff64a54b 100644 --- a/src/xref2/env.ml +++ b/src/xref2/env.ml @@ -63,22 +63,10 @@ let pp_lookup_type_list fmt ls = type recorder = { mutable lookups : lookup_type list } -let ident_of_element = function - | `Module (id, _) -> (id :> Identifier.t) - | `ModuleType (id, _) -> (id :> Identifier.t) - | `Type (id, _) -> (id :> Identifier.t) - | `Value (id, _) -> (id :> Identifier.t) - | `Label id -> (id :> Identifier.t) - | `Class (id, _) -> (id :> Identifier.t) - | `ClassType (id, _) -> (id :> Identifier.t) - | `Constructor (id, _) -> (id :> Identifier.t) - | `Exception (id, _) -> (id :> Identifier.t) - | `Extension (id, _) -> (id :> Identifier.t) - | `Field (id, _) -> (id :> Identifier.t) - module Maps = Odoc_model.Paths.Identifier.Maps module StringMap = Map.Make (String) +(** Used only to handle shadowing, see {!Elements}. *) type kind = | Kind_Module | Kind_ModuleType @@ -97,61 +85,58 @@ module Elements : sig val empty : t - val add : kind -> [< Identifier.t ] -> [< Component.Element.any ] -> t -> t + val add : + ?shadow:bool -> + kind -> + [< Identifier.t ] -> + [< Component.Element.any ] -> + t -> + t + (** If [shadow] is set to [false] (defaults to [true]), existing + elements of the same name won't be shadowed. This is used for labels, + which doesn't allow shadowing. *) val find_by_name : (Component.Element.any -> 'b option) -> string -> t -> 'b list - val find_by_id : - (Component.Element.any -> 'b option) -> Identifier.t -> t -> 'b list + val find_by_id : Identifier.t -> t -> Component.Element.any option end = struct - type elem = { kind : kind; elem : Component.Element.any; shadowed : bool } + module IdMap = Identifier.Maps.Any - type t = elem list StringMap.t + type elem = { kind : kind; elem : Component.Element.any } - let empty = StringMap.empty + type t = elem list StringMap.t * Component.Element.any IdMap.t + (** The first map is queried with {!find_by_name}, shadowed elements are + removed from it. The second map is queried with {!find_by_id}. *) - let add kind identifier comp t = + let empty = (StringMap.empty, IdMap.empty) + + let add ?(shadow = true) kind identifier elem (names, ids) = + let elem = (elem :> Component.Element.any) in let name = Identifier.name identifier in - let v = - { kind; elem = (comp :> Component.Element.any); shadowed = false } + let tl = + try + let tl = StringMap.find name names in + let not_shadow e = e.kind <> kind in + if shadow && not (List.for_all not_shadow tl) then + List.filter not_shadow tl + else tl + with Not_found -> [] in - try - let tl = StringMap.find name t in - let tl = - let has_shadow e = e.kind = kind in - let mark_shadow e = - if e.kind = kind then { e with shadowed = true } else e - in - if List.exists has_shadow tl then List.map mark_shadow tl else tl - in - StringMap.add name (v :: tl) t - with Not_found -> StringMap.add name [ v ] t + let ids = IdMap.add (identifier :> Identifier.t) elem ids in + let names = StringMap.add name ({ kind; elem } :: tl) names in + (names, ids) - let find' f name t = - try List.fold_right f (StringMap.find name t) [] with Not_found -> [] + let find_by_name f name (names, _) = + let filter e acc = match f e.elem with Some r -> r :: acc | None -> acc in + try List.fold_right filter (StringMap.find name names) [] + with Not_found -> [] - (** Do not consider shadowed elements. *) - let find_by_name f name t = - let filter e acc = - if e.shadowed then acc - else match f e.elem with Some r -> r :: acc | None -> acc - in - find' filter name t - - (** Allow matching shadowed elements. *) - let find_by_id f id t = - let filter e acc = - match f e.elem with - | Some r -> if ident_of_element e.elem = id then r :: acc else acc - | None -> acc - in - find' filter (Identifier.name id) t + let find_by_id id (_, ids) = try Some (IdMap.find id ids) with _ -> None end type t = { id : int; - titles : Odoc_model.Comment.link_content Maps.Label.t; elts : Elements.t; resolver : resolver option; recorder : recorder option; @@ -183,7 +168,6 @@ let with_recorded_lookups env f = let empty = { id = 0; - titles = Maps.Label.empty; elts = Elements.empty; resolver = None; recorder = None; @@ -195,44 +179,42 @@ let add_fragment_root sg env = { env with fragmentroot = Some (id, sg); id } (** Implements most [add_*] functions. *) -let add_to_elts kind identifier component env = +let add_to_elts ?shadow kind identifier component env = { env with id = unique_id (); - elts = Elements.add kind identifier component env.elts; + elts = Elements.add ?shadow kind identifier component env.elts; } -let add_label identifier env = - add_to_elts Kind_Label identifier (`Label identifier) env - -let add_label_title label elts env = - { env with id = unique_id (); titles = Maps.Label.add label elts env.titles } +let add_label identifier heading env = + (* Disallow shadowing for labels. Duplicate names are disallowed and reported + during linking. *) + add_to_elts ~shadow:false Kind_Label identifier + (`Label (identifier, heading)) + env let add_docs (docs : Odoc_model.Comment.docs) env = - List.fold_right - (fun element env -> - match element.Odoc_model.Location_.value with - | `Heading (_, label, nested_elements) -> - let env = add_label label env in - let env = add_label_title label nested_elements env in - env + List.fold_left + (fun env -> function + | { Odoc_model.Location_.value = `Heading (attrs, id, text); location } -> + let label = Ident.Of_Identifier.label id in + add_label id { Component.Label.attrs; label; text; location } env | _ -> env) - docs env + env docs let add_comment (com : Odoc_model.Comment.docs_or_stop) env = match com with `Docs doc -> add_docs doc env | `Stop -> env let add_cdocs p (docs : Component.CComment.docs) env = - List.fold_right - (fun element env -> + List.fold_left + (fun env element -> match element.Odoc_model.Location_.value with - | `Heading (_, `LLabel (name, _), nested_elements) -> + | `Heading h -> + let (`LLabel (name, _)) = h.Component.Label.label in let label = `Label (Paths.Identifier.label_parent p, name) in - let env = add_label label env in - let env = add_label_title label nested_elements env in - env + add_label label h env | _ -> env) - docs env + env docs let add_module identifier m docs env = add_to_elts Kind_Module identifier (`Module (identifier, m)) env @@ -396,11 +378,11 @@ let lookup_by_id (scope : 'a scope) id env : 'a option = | _ -> ()) | None -> () in - match Elements.find_by_id scope.filter (id :> Identifier.t) env.elts with - | x :: _ -> + match Elements.find_by_id (id :> Identifier.t) env.elts with + | Some x -> record_lookup_result x; - Some x - | [] -> ( + scope.filter x + | None -> ( match (id :> Identifier.t) with | `Root (_, name) -> scope.root (ModuleName.to_string name) env | _ -> None) @@ -490,9 +472,6 @@ let lookup_fragment_root env = result | None -> None -let lookup_section_title identifier env = - try Some (Maps.Label.find identifier env.titles) with _ -> None - let lookup_page name env = match env.resolver with None -> None | Some r -> r.lookup_page name diff --git a/src/xref2/env.mli b/src/xref2/env.mli index 974378de70..b889b8bf72 100644 --- a/src/xref2/env.mli +++ b/src/xref2/env.mli @@ -56,10 +56,7 @@ val add_module_type : val add_value : Identifier.Value.t -> Component.Value.t -> t -> t -val add_label : Identifier.Label.t -> t -> t - -val add_label_title : - Identifier.Label.t -> Odoc_model.Comment.link_content -> t -> t +val add_label : Identifier.Label.t -> Component.Label.t -> t -> t val add_class : Identifier.Class.t -> Component.Class.t -> t -> t @@ -84,9 +81,6 @@ val add_module_type_functor_args : val lookup_fragment_root : t -> (int * Component.Signature.t) option -val lookup_section_title : - Identifier.Label.t -> t -> Odoc_model.Comment.link_content option - val lookup_page : string -> t -> Odoc_model.Lang.Page.t option val module_of_unit : Odoc_model.Lang.Compilation_unit.t -> Component.Module.t diff --git a/src/xref2/find.ml b/src/xref2/find.ml index 918c6be12a..edfab5f7dd 100644 --- a/src/xref2/find.ml +++ b/src/xref2/find.ml @@ -13,7 +13,7 @@ type class_ = type value = [ `FValue of ValueName.t * Value.t ] -type label = [ `FLabel of Ident.label ] +type label = [ `FLabel of Label.t ] type exception_ = [ `FExn of ExceptionName.t * Exception.t ] @@ -210,8 +210,8 @@ let any_in_comment d name = match xs with | elt :: rest -> ( match elt.Odoc_model.Location_.value with - | `Heading (_, label, _) when Ident.Name.label label = name -> - Some (`FLabel label) + | `Heading lbl when Ident.Name.label lbl.Label.label = name -> + Some (`FLabel lbl) | _ -> inner rest) | [] -> None in diff --git a/src/xref2/find.mli b/src/xref2/find.mli index 34767a0430..26e9049889 100644 --- a/src/xref2/find.mli +++ b/src/xref2/find.mli @@ -14,7 +14,7 @@ type class_ = type value = [ `FValue of ValueName.t * Value.t ] -type label = [ `FLabel of Ident.label ] +type label = [ `FLabel of Label.t ] type exception_ = [ `FExn of ExceptionName.t * Exception.t ] diff --git a/src/xref2/lang_of.ml b/src/xref2/lang_of.ml index 108a6758de..28d963a3cc 100644 --- a/src/xref2/lang_of.ml +++ b/src/xref2/lang_of.ml @@ -1000,12 +1000,16 @@ and block_element parent Odoc_model.Comment.block_element Odoc_model.Location_.with_location = let value = match d.Odoc_model.Location_.value with - | `Heading (l, id, content) -> ( - try `Heading (l, `Label (parent, Ident.Name.typed_label id), content) - with Not_found -> - Format.fprintf Format.err_formatter "Failed to find id: %a\n" - Ident.fmt id; - raise Not_found) + | `Heading h -> + let { Component.Label.attrs; label; text; location = _ } = h in + let label = + try `Label (parent, Ident.Name.typed_label label) + with Not_found -> + Format.fprintf Format.err_formatter "Failed to find id: %a\n" + Ident.fmt label; + raise Not_found + in + `Heading (attrs, label, text) | `Tag t -> `Tag t | #Odoc_model.Comment.nestable_block_element as n -> n in diff --git a/src/xref2/link.ml b/src/xref2/link.ml index a7d5330c54..eb1e4abf61 100644 --- a/src/xref2/link.ml +++ b/src/xref2/link.ml @@ -28,6 +28,27 @@ let synopsis_of_module env (m : Component.Module.t) = | Ok sg -> synopsis_from_comment (Component.extract_signature_doc sg) | Error _ -> None) +let ambiguous_label_warning label_name labels = + let pp_label_loc fmt (`Label (_, x)) = + Location_.pp_span_start fmt x.Component.Label.location + in + Lookup_failures.report_warning + "@[<2>Label '%s' is ambiguous. The other occurences are:@ %a@]" label_name + (Format.pp_print_list ~pp_sep:Format.pp_force_newline pp_label_loc) + labels + +(** Raise a warning when a label explicitly set by the user collides. This + warning triggers even if one of the colliding labels have been automatically + generated. *) +let check_ambiguous_label env (attrs, label, _) = + if attrs.Comment.heading_label_explicit then + let (`Label (_, label_name)) = label in + let label_name = Names.LabelName.to_string label_name in + match Env.lookup_by_name Env.s_label label_name env with + | Ok _ | Error `Not_found -> () + | Error (`Ambiguous (hd, tl)) -> + ambiguous_label_warning label_name (hd :: tl) + exception Loop let rec is_forward : Paths.Path.Module.t -> bool = function @@ -133,15 +154,15 @@ let rec comment_inline_element : | `Styled (s, ls) -> `Styled (s, List.map (with_location (comment_inline_element env)) ls) | `Reference (r, content) as orig -> ( - match Ref_tools.resolve_reference env r with + match Ref_tools.resolve_reference env r |> Error.raise_warnings with | Ok x -> let content = (* In case of labels, use the heading text as reference text if it's not specified. *) match (content, x) with | [], `Identifier (#Id.Label.t as i) -> ( - match Env.lookup_section_title i env with - | Some x -> x + match Env.lookup_by_id Env.s_label i env with + | Some (`Label (_, lbl)) -> lbl.Component.Label.text | None -> []) | content, _ -> content in @@ -175,7 +196,10 @@ and comment_nestable_block_element env parent let refs = List.map (fun (r : Comment.module_reference) -> - match Ref_tools.resolve_module_reference env r.module_reference with + match + Ref_tools.resolve_module_reference env r.module_reference + |> Error.raise_warnings + with | Ok (r, _, m) -> let module_synopsis = Opt.map @@ -196,7 +220,9 @@ and comment_block_element env parent (x : Comment.block_element) = match x with | #Comment.nestable_block_element as x -> (comment_nestable_block_element env parent x :> Comment.block_element) - | `Heading _ as x -> x + | `Heading h as x -> + check_ambiguous_label env h; + x | `Tag _ as x -> x and with_location : @@ -890,7 +916,7 @@ let page env page = let children = List.fold_right (fun child res -> - match Ref_tools.resolve_reference env child with + match Ref_tools.resolve_reference env child |> Error.raise_warnings with | Ok r -> `Resolved r :: res | Error _ -> Errors.report ~what:(`Child child) `Resolve; diff --git a/src/xref2/ref_tools.ml b/src/xref2/ref_tools.ml index 4b8a7377f3..664b5b7b69 100644 --- a/src/xref2/ref_tools.ml +++ b/src/xref2/ref_tools.ml @@ -83,13 +83,28 @@ let ref_kind_of_find = function | `FMethod _ -> "method" | `FInstance_variable _ -> "instance-variable" -let ambiguous_ref_warning name results = - let pp_sep pp () = Format.fprintf pp ", " - and pp_kind pp r = Format.fprintf pp "%s-%s" r name in +(** Labels work differently from other values and the warning generated by + [ambiguous_ref_warning] would be out of scope. *) +let ambiguous_label_warning name = Lookup_failures.report_warning - "Reference to '%s' is ambiguous. Please specify its kind: %a." name - (Format.pp_print_list ~pp_sep pp_kind) - results + "Reference to label '%s' is ambiguous.@ This reference will point to the \ + first occurence of '%s'.@\n\ + @[<2>Hint:@ Define labels explicitly using the syntax '{1:explicit-label \ + Heading text}'.@]" + name name + +let ambiguous_ref_warning name results = + (* We only expect duplicate kinds in case of ambiguous label. When the + ambiguity is only related to labels, use a more precise error message. *) + match List.sort_uniq String.compare results with + | [ "section" ] -> ambiguous_label_warning name + | results -> + let pp_sep pp () = Format.fprintf pp ", " + and pp_kind pp r = Format.fprintf pp "%s-%s" r name in + Lookup_failures.report_warning + "Reference to '%s' is ambiguous. Please specify its kind: %a." name + (Format.pp_print_list ~pp_sep pp_kind) + results let env_lookup_by_name ?(kind = `Any) scope name env = match Env.lookup_by_name scope name env with @@ -305,7 +320,7 @@ module L = struct type t = Resolved.Label.t let in_env env name : t ref_result = - env_lookup_by_name Env.s_label name env >>= fun (`Label id) -> + env_lookup_by_name Env.s_label name env >>= fun (`Label (id, _)) -> Ok (`Identifier id) let in_page _env (`Page (_, p)) name = @@ -315,7 +330,8 @@ module L = struct let of_component _env ~parent_ref label = Ok (`Label - ((parent_ref :> Resolved.LabelParent.t), Ident.Name.typed_label label)) + ( (parent_ref :> Resolved.LabelParent.t), + Ident.Name.typed_label label.Component.Label.label )) let in_label_parent env (parent : label_parent_lookup_result) name = match parent with @@ -530,8 +546,9 @@ let rec resolve_label_parent_reference env r = List.fold_right (fun element l -> match element.Odoc_model.Location_.value with - | `Heading (_, (`Label (_, name) as x), _nested_elements) -> - (LabelName.to_string name, x) :: l + | `Heading (_, label, _) -> + let (`Label (_, name)) = label in + (LabelName.to_string name, label) :: l | _ -> l) p.Odoc_model.Lang.Page.content [] in @@ -699,7 +716,7 @@ let resolve_reference = | `ModuleType (_, _) as e -> resolved (MT.of_element env e) | `Value (id, _) -> identifier id | `Type (id, _) -> identifier id - | `Label id -> identifier id + | `Label (id, _) -> identifier id | `Class (id, _) -> identifier id | `ClassType (id, _) -> identifier id | `Constructor (id, _) -> identifier id @@ -775,3 +792,9 @@ let resolve_reference = | `InstanceVariable (parent, name) -> resolve_class_signature_reference env parent >>= fun p -> MV.in_class_signature env p name >>= resolved1 + +let resolve_module_reference env m = + Odoc_model.Error.catch_warnings (fun () -> resolve_module_reference env m) + +let resolve_reference env m = + Odoc_model.Error.catch_warnings (fun () -> resolve_reference env m) diff --git a/src/xref2/ref_tools.mli b/src/xref2/ref_tools.mli index bbf3c83f6c..c6608379e1 100644 --- a/src/xref2/ref_tools.mli +++ b/src/xref2/ref_tools.mli @@ -7,7 +7,9 @@ type 'a ref_result = ('a, Errors.Tools_error.reference_lookup_error) Result.result val resolve_module_reference : - Env.t -> Module.t -> module_lookup_result ref_result + Env.t -> + Module.t -> + module_lookup_result ref_result Odoc_model.Error.with_warnings -val resolve_reference : Env.t -> t -> Resolved.t ref_result -(** Calls [Lookup_failures.report_warning]. *) +val resolve_reference : + Env.t -> t -> Resolved.t ref_result Odoc_model.Error.with_warnings diff --git a/test/generators/html/Include_sections.html b/test/generators/html/Include_sections.html index 4d8dcba1ed..81d5e6aea1 100644 --- a/test/generators/html/Include_sections.html +++ b/test/generators/html/Include_sections.html @@ -13,19 +13,19 @@

Module Include_sections