From c8c15b6c3457ac307d5ebd6acc28e6cbcb3c5298 Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Thu, 12 Dec 2024 11:44:30 +0100 Subject: [PATCH 1/8] Warnings: allow disabling warnings coming from specific units When docstrings go are inherited, eg from an include or a functor expansion, warnings may be generated in one docs while the fix is in a dependency. This commit allows to tag each docstring with a boolean to indicate whether it comes from a unit with warnings enabled or disabled. --- src/document/comment.ml | 2 +- src/document/generator.ml | 63 ++++--- src/document/sidebar.ml | 2 +- src/index/skeleton.ml | 7 +- src/index/skeleton_of.ml | 8 +- src/loader/cmi.ml | 122 +++++++------ src/loader/cmi.mli | 28 +-- src/loader/cmt.ml | 83 +++++---- src/loader/cmt.mli | 1 + src/loader/cmti.ml | 129 ++++++++------ src/loader/cmti.mli | 13 +- src/loader/doc_attr.ml | 41 +++-- src/loader/doc_attr.mli | 4 + src/loader/odoc_loader.ml | 31 ++-- src/loader/odoc_loader.mli | 3 + src/markdown/odoc_md.ml | 6 +- src/model/comment.ml | 4 +- src/model/error.ml | 6 +- src/model/error.mli | 1 + src/model/lang.ml | 3 +- src/model/semantics.ml | 2 +- src/model/semantics.mli | 4 +- src/model_desc/comment_desc.ml | 40 +++-- src/model_desc/comment_desc.mli | 6 +- src/odoc/bin/main.ml | 35 +++- src/odoc/compile.ml | 15 +- src/odoc/odoc_link.ml | 11 +- src/odoc/url.ml | 8 +- src/search/text.ml | 2 +- src/xref2/compile.ml | 6 +- src/xref2/component.ml | 16 +- src/xref2/component.mli | 5 +- src/xref2/env.ml | 28 ++- src/xref2/find.ml | 4 +- src/xref2/lang_of.ml | 7 +- src/xref2/link.ml | 156 +++++++++++----- src/xref2/ref_tools.ml | 2 +- src/xref2/tools.ml | 2 +- test/frontmatter/frontmatter.t/run.t | 4 +- test/integration/dune | 8 +- test/integration/suppress_warnings.t/main.mli | 3 + .../module_with_errors.mli | 9 + test/integration/suppress_warnings.t/run.t | 20 +++ test/model/semantics/test.ml | 2 +- test/pages/resolution.t/run.t | 6 +- test/xref2/canonical_nested.t/run.t | 25 ++- test/xref2/classes.t/run.t | 10 +- test/xref2/cross_references.t/run.t | 4 +- test/xref2/deep_substitution.t/run.t | 5 +- test/xref2/hidden_modules.t/run.t | 12 +- test/xref2/labels/page_labels.t/run.t | 2 +- test/xref2/lib/common.cppo.ml | 6 +- test/xref2/module_type_alias.t/run.t | 167 +++++++++--------- 53 files changed, 753 insertions(+), 436 deletions(-) create mode 100644 test/integration/suppress_warnings.t/main.mli create mode 100644 test/integration/suppress_warnings.t/module_with_errors.mli create mode 100644 test/integration/suppress_warnings.t/run.t diff --git a/src/document/comment.ml b/src/document/comment.ml index 70a06b4322..da8bb53af2 100644 --- a/src/document/comment.ml +++ b/src/document/comment.ml @@ -415,6 +415,6 @@ let standalone docs = let to_ir (docs : Comment.docs) = Utils.flatmap ~f:block_element - @@ List.map (fun x -> x.Odoc_model.Location_.value) docs + @@ List.map (fun x -> x.Odoc_model.Location_.value) docs.elements let has_doc docs = docs <> [] diff --git a/src/document/generator.ml b/src/document/generator.ml index b3beecb0ed..b751147f44 100644 --- a/src/document/generator.ml +++ b/src/document/generator.ml @@ -531,7 +531,9 @@ module Make (Syntax : SYNTAX) = struct in let anchor = Some url in let rhs = Comment.to_ir fld.doc in - let doc = if not (Comment.has_doc fld.doc) then [] else rhs in + let doc = + if not (Comment.has_doc fld.doc.elements) then [] else rhs + in let markers = Syntax.Comment.markers in DocumentedSrc.Documented { anchor; attrs; code; doc; markers }) in @@ -610,7 +612,7 @@ module Make (Syntax : SYNTAX) = struct let anchor = Some url in let rhs = Comment.to_ir cstr.doc in let doc = - if not (Comment.has_doc cstr.doc) then [] else rhs + if not (Comment.has_doc cstr.doc.elements) then [] else rhs in let markers = Syntax.Comment.markers in DocumentedSrc.Nested { anchor; attrs; code; doc; markers }) @@ -706,7 +708,9 @@ module Make (Syntax : SYNTAX) = struct ++ if Syntax.Type.Variant.parenthesize_params then params else O.txt " " ++ O.keyword "of" ++ O.sp ++ params)), - match doc with [] -> None | _ -> Some (Comment.to_ir doc) )) + match doc with + | { elements = []; _ } -> None + | _ -> Some (Comment.to_ir doc) )) in let markers = Syntax.Comment.markers in try @@ -920,11 +924,11 @@ module Make (Syntax : SYNTAX) = struct module Sectioning : sig open Odoc_model - val comment_items : Comment.docs -> Item.t list + val comment_items : Comment.elements -> Item.t list - val docs : Comment.docs -> Item.t list * Item.t list + val docs : Comment.elements -> Item.t list * Item.t list end = struct - let take_until_heading_or_end (docs : Odoc_model.Comment.docs) = + let take_until_heading_or_end (docs : Odoc_model.Comment.elements) = let content, _, rest = Doctree.Take.until docs ~classify:(fun b -> match b.Location.value with @@ -935,7 +939,7 @@ module Make (Syntax : SYNTAX) = struct in (content, rest) - let comment_items (input0 : Odoc_model.Comment.docs) = + let comment_items (input0 : Odoc_model.Comment.elements) = let rec loop input_comment acc = match input_comment with | [] -> List.rev acc @@ -1070,11 +1074,11 @@ module Make (Syntax : SYNTAX) = struct in loop rest acc_items | Comment (`Docs c) -> - let items = Sectioning.comment_items c in + let items = Sectioning.comment_items c.elements in loop rest (List.rev_append items acc_items)) in (* FIXME: use [t.self] *) - (c.doc, loop c.items []) + (c.doc.elements, loop c.items []) let rec class_decl (cd : Odoc_model.Lang.Class.decl) = match cd with @@ -1111,7 +1115,8 @@ module Make (Syntax : SYNTAX) = struct let expansion_doc, items = class_signature csig in let url = Url.Path.from_identifier t.id in let page = - make_expansion_page ~source_anchor url [ t.doc; expansion_doc ] + make_expansion_page ~source_anchor url + [ t.doc.elements; expansion_doc ] items in ( O.documentedSrc @@ path url [ inline @@ Text name ], @@ -1132,7 +1137,7 @@ module Make (Syntax : SYNTAX) = struct in let attr = [ "class" ] in let anchor = path_to_id t.id in - let doc = Comment.synopsis ~decl_doc:t.doc ~expansion_doc in + let doc = Comment.synopsis ~decl_doc:t.doc.elements ~expansion_doc in Item.Declaration { attr; anchor; doc; content; source_anchor } let class_type (t : Odoc_model.Lang.ClassType.t) = @@ -1149,7 +1154,8 @@ module Make (Syntax : SYNTAX) = struct let url = Url.Path.from_identifier t.id in let expansion_doc, items = class_signature csig in let page = - make_expansion_page ~source_anchor url [ t.doc; expansion_doc ] + make_expansion_page ~source_anchor url + [ t.doc.elements; expansion_doc ] items in ( O.documentedSrc @@ path url [ inline @@ Text name ], @@ -1166,14 +1172,14 @@ module Make (Syntax : SYNTAX) = struct in let attr = [ "class-type" ] in let anchor = path_to_id t.id in - let doc = Comment.synopsis ~decl_doc:t.doc ~expansion_doc in + let doc = Comment.synopsis ~decl_doc:t.doc.elements ~expansion_doc in Item.Declaration { attr; anchor; doc; content; source_anchor } end open Class module Module : sig - val signature : Lang.Signature.t -> Comment.Comment.docs * Item.t list + val signature : Lang.Signature.t -> Comment.Comment.elements * Item.t list (** Returns [header_doc, content]. *) end = struct let internal_module m = @@ -1242,7 +1248,7 @@ module Make (Syntax : SYNTAX) = struct | Exception e -> continue @@ exn e | Value v -> continue @@ value v | Open o -> - let items = Sectioning.comment_items o.doc in + let items = Sectioning.comment_items o.doc.elements in loop rest (List.rev_append items acc_items) | Comment `Stop -> let rest = @@ -1252,10 +1258,10 @@ module Make (Syntax : SYNTAX) = struct in loop rest acc_items | Comment (`Docs c) -> - let items = Sectioning.comment_items c in + let items = Sectioning.comment_items c.elements in loop rest (List.rev_append items acc_items)) in - (Lang.extract_signature_doc s, loop s.items []) + ((Lang.extract_signature_doc s).elements, loop s.items []) and functor_parameter : Odoc_model.Lang.FunctorParameter.parameter -> DocumentedSrc.t = @@ -1319,8 +1325,8 @@ module Make (Syntax : SYNTAX) = struct let source_anchor = None in let modname = Paths.Identifier.name t.id in let modname, expansion_doc, mty = - module_type_manifest ~subst:true ~source_anchor modname t.id t.doc - (Some t.manifest) prefix + module_type_manifest ~subst:true ~source_anchor modname t.id + t.doc.elements (Some t.manifest) prefix in let content = O.documentedSrc (prefix ++ modname) @@ -1330,12 +1336,12 @@ module Make (Syntax : SYNTAX) = struct in let attr = [ "module-type" ] in let anchor = path_to_id t.id in - let doc = Comment.synopsis ~decl_doc:t.doc ~expansion_doc in + let doc = Comment.synopsis ~decl_doc:t.doc.elements ~expansion_doc in Item.Declaration { attr; anchor; doc; content; source_anchor } and simple_expansion : Odoc_model.Lang.ModuleType.simple_expansion -> - Comment.Comment.docs * Item.t list = + Comment.Comment.elements * Item.t list = fun t -> let rec extract_functor_params (f : Odoc_model.Lang.ModuleType.simple_expansion) = @@ -1373,7 +1379,7 @@ module Make (Syntax : SYNTAX) = struct and expansion_of_module_type_expr : Odoc_model.Lang.ModuleType.expr -> - (Comment.Comment.docs * Item.t list) option = + (Comment.Comment.elements * Item.t list) option = fun t -> let rec simple_expansion_of (t : Odoc_model.Lang.ModuleType.expr) = match t with @@ -1417,7 +1423,8 @@ module Make (Syntax : SYNTAX) = struct let url = Url.Path.from_identifier t.id in let link = path url [ inline @@ Text modname ] in let page = - make_expansion_page ~source_anchor url [ t.doc; expansion_doc ] + make_expansion_page ~source_anchor url + [ t.doc.elements; expansion_doc ] items in (link, status, Some page, Some expansion_doc) @@ -1436,7 +1443,7 @@ module Make (Syntax : SYNTAX) = struct in let attr = [ "module" ] in let anchor = path_to_id t.id in - let doc = Comment.synopsis ~decl_doc:t.doc ~expansion_doc in + let doc = Comment.synopsis ~decl_doc:t.doc.elements ~expansion_doc in Item.Declaration { attr; anchor; doc; content; source_anchor } and simple_expansion_in_decl (base : Paths.Identifier.Module.t) se = @@ -1501,8 +1508,8 @@ module Make (Syntax : SYNTAX) = struct let modname = Paths.Identifier.name t.id in let source_anchor = source_anchor t.source_loc in let modname, expansion_doc, mty = - module_type_manifest ~subst:false ~source_anchor modname t.id t.doc - t.expr prefix + module_type_manifest ~subst:false ~source_anchor modname t.id + t.doc.elements t.expr prefix in let content = O.documentedSrc (prefix ++ modname) @@ -1512,7 +1519,7 @@ module Make (Syntax : SYNTAX) = struct in let attr = [ "module-type" ] in let anchor = path_to_id t.id in - let doc = Comment.synopsis ~decl_doc:t.doc ~expansion_doc in + let doc = Comment.synopsis ~decl_doc:t.doc.elements ~expansion_doc in Item.Declaration { attr; anchor; doc; content; source_anchor } and umty_hidden : Odoc_model.Lang.ModuleType.U.expr -> bool = function @@ -1772,7 +1779,7 @@ module Make (Syntax : SYNTAX) = struct in*) (*let title = Odoc_model.Names.PageName.to_string name in*) let url = Url.Path.from_identifier t.name in - let preamble, items = Sectioning.docs t.content in + let preamble, items = Sectioning.docs t.content.elements in let source_anchor = None in Document.Page { Page.preamble; items; url; source_anchor } diff --git a/src/document/sidebar.ml b/src/document/sidebar.ml index 98eed7e9af..4ac5cfc5de 100644 --- a/src/document/sidebar.ml +++ b/src/document/sidebar.ml @@ -94,7 +94,7 @@ end = struct | Page { short_title = None; _ } -> let title = let open Odoc_model in - match Comment.find_zero_heading entry.doc with + match Comment.find_zero_heading entry.doc.elements with | Some t -> t | None -> let name = diff --git a/src/index/skeleton.ml b/src/index/skeleton.ml index 01dc6ab078..669e7065e6 100644 --- a/src/index/skeleton.ml +++ b/src/index/skeleton.ml @@ -8,7 +8,12 @@ type t = Entry.t Tree.t module Entry = struct let of_comp_unit (u : Compilation_unit.t) = let has_expansion = true in - let doc = match u.content with Pack _ -> [] | Module m -> m.doc in + let doc = + match u.content with + | Pack _ -> + { Odoc_model.Comment.elements = []; suppress_warnings = false } + | Module m -> m.doc + in Entry.entry ~id:u.id ~doc ~kind:(Module { has_expansion }) let of_module (m : Module.t) = diff --git a/src/index/skeleton_of.ml b/src/index/skeleton_of.ml index 247609f8e3..86fae97b3c 100644 --- a/src/index/skeleton_of.ml +++ b/src/index/skeleton_of.ml @@ -39,6 +39,8 @@ let compare_entry (t1 : t) (t2 : t) = try_ Astring.String.compare by_name @@ fun () -> 0 let rec t_of_in_progress (dir : In_progress.in_progress) : t = + let empty_doc = { Comment.elements = []; suppress_warnings = false } in + let entry_of_page page = let kind = Entry.Page page.Lang.Page.frontmatter in let doc = page.content in @@ -47,7 +49,7 @@ let rec t_of_in_progress (dir : In_progress.in_progress) : t = in let entry_of_impl id = let kind = Entry.Impl in - let doc = [] in + let doc = empty_doc in Entry.entry ~kind ~doc ~id in let children_order, index = @@ -61,7 +63,7 @@ let rec t_of_in_progress (dir : In_progress.in_progress) : t = match In_progress.root_dir dir with | Some id -> let kind = Entry.Dir in - let doc = [] in + let doc = empty_doc in Entry.entry ~kind ~doc ~id | None -> let id = @@ -69,7 +71,7 @@ let rec t_of_in_progress (dir : In_progress.in_progress) : t = Id.Mk.leaf_page (None, Names.PageName.make_std "index") in let kind = Entry.Dir in - let doc = [] in + let doc = empty_doc in Entry.entry ~kind ~doc ~id in (None, entry) diff --git a/src/loader/cmi.ml b/src/loader/cmi.ml index bd4ccfc6f9..2e2fc58205 100644 --- a/src/loader/cmi.ml +++ b/src/loader/cmi.ml @@ -25,6 +25,14 @@ open Odoc_model.Names module Env = Ident_env module Paths = Odoc_model.Paths + +type env = { + ident_env : Env.t; + suppress_warnings : bool; (** suppress warnings *) +} + +let empty_doc = { Odoc_model.Comment.elements = []; suppress_warnings = false } + module Compat = struct #if OCAML_VERSION >= (4, 14, 0) #if OCAML_VERSION >= (5, 3, 0) @@ -458,7 +466,7 @@ let rec read_type_expr env typ = let typs = List.map (read_type_expr env) typs in Tuple typs | Tconstr(p, params, _) -> - let p = Env.Path.read_type env p in + let p = Env.Path.read_type env.ident_env p in let params = List.map (read_type_expr env) params in Constr(p, params) | Tvariant row -> read_row env px row @@ -479,7 +487,7 @@ let rec read_type_expr env typ = let eqs = List.combine frags tyl in #endif let open TypeExpr.Package in - let path = Env.Path.read_module_type env p in + let path = Env.Path.read_module_type env.ident_env p in let substitutions = List.map (fun (frag,typ) -> @@ -522,7 +530,7 @@ and read_row env _px row = let all_present = List.length present = List.length sorted_fields in match Compat.get_row_name row with | Some(p, params) when namable_row row -> - let p = Env.Path.read_type env p in + let p = Env.Path.read_type env.ident_env p in let params = List.map (read_type_expr env) params in if Compat.row_closed row && all_present then Constr (p, params) @@ -535,15 +543,16 @@ and read_row env _px row = let elements = List.map (fun (name, f) -> + let doc = empty_doc in match Compat.row_field_repr f with | Rpresent None -> - Constructor {name; constant = true; arguments = []; doc = []} + Constructor {name; constant = true; arguments = []; doc} | Rpresent (Some typ) -> Constructor { name; constant = false; arguments = [read_type_expr env typ]; - doc = []; + doc; } #if OCAML_VERSION >= (4, 14, 0) | Reither(constant, typs, _) -> @@ -553,7 +562,7 @@ and read_row env _px row = let arguments = List.map (read_type_expr env) typs in - Constructor {name; constant; arguments; doc = []} + Constructor {name; constant; arguments; doc} | Rabsent -> assert false) sorted_fields in @@ -600,20 +609,20 @@ and read_object env fi nm = in Object {fields = methods; open_} | Some (p, _ :: params) -> - let p = Env.Path.read_class_type env p in + let p = Env.Path.read_class_type env.ident_env p in let params = List.map (read_type_expr env) params in Class (p, params) | _ -> assert false end -let read_value_description env parent id vd = +let read_value_description ({ident_env ; suppress_warnings} as env) parent id vd = let open Signature in - let id = Env.find_value_identifier env id in + let id = Env.find_value_identifier ident_env id in let source_loc = None in let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc = Doc_attr.attached_no_tag container vd.val_attributes in + let doc = Doc_attr.attached_no_tag ~suppress_warnings container vd.val_attributes in mark_value_description vd; let type_ = read_type_expr env vd.val_type in let value = @@ -635,7 +644,7 @@ let read_label_declaration env parent ld = let name = Ident.name ld.ld_id in let id = Identifier.Mk.field (parent, Odoc_model.Names.FieldName.make_std name) in let doc = - Doc_attr.attached_no_tag + Doc_attr.attached_no_tag ~suppress_warnings:env.suppress_warnings (parent :> Identifier.LabelParent.t) ld.ld_attributes in let mutable_ = (ld.ld_mutable = Mutable) in @@ -658,9 +667,9 @@ let read_constructor_declaration_arguments env parent arg = let read_constructor_declaration env parent cd = let open TypeDecl.Constructor in - let id = Ident_env.find_constructor_identifier env cd.cd_id in + let id = Ident_env.find_constructor_identifier env.ident_env cd.cd_id in let container = (parent :> Identifier.LabelParent.t) in - let doc = Doc_attr.attached_no_tag container cd.cd_attributes in + let doc = Doc_attr.attached_no_tag ~suppress_warnings:env.suppress_warnings container cd.cd_attributes in let args = read_constructor_declaration_arguments env (parent :> Identifier.FieldParent.t) cd.cd_args @@ -735,15 +744,15 @@ let read_class_constraints env params = let open ClassSignature in read_type_constraints env params |> List.map (fun (left, right) -> - Constraint { Constraint.left; right; doc = [] }) + Constraint { Constraint.left; right; doc = empty_doc }) let read_type_declaration env parent id decl = let open TypeDecl in - let id = Env.find_type_identifier env id in + let id = Env.find_type_identifier env.ident_env id in let source_loc = None in let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in let doc, canonical = - Doc_attr.attached Odoc_model.Semantics.Expect_canonical container decl.type_attributes + Doc_attr.attached ~suppress_warnings:env.suppress_warnings Odoc_model.Semantics.Expect_canonical container decl.type_attributes in let canonical = match canonical with | None -> None | Some s -> Doc_attr.conv_canonical_type s in let params = mark_type_declaration decl in @@ -779,10 +788,10 @@ let read_type_declaration env parent id decl = let read_extension_constructor env parent id ext = let open Extension.Constructor in - let id = Env.find_extension_identifier env id in + let id = Env.find_extension_identifier env.ident_env id in let source_loc = None in let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc = Doc_attr.attached_no_tag container ext.ext_attributes in + let doc = Doc_attr.attached_no_tag ~suppress_warnings:env.suppress_warnings container ext.ext_attributes in let args = read_constructor_declaration_arguments env (parent : Identifier.Signature.t :> Identifier.FieldParent.t) ext.ext_args @@ -792,7 +801,7 @@ let read_extension_constructor env parent id ext = let read_type_extension env parent id ext rest = let open Extension in - let type_path = Env.Path.read_type env ext.ext_type_path in + let type_path = Env.Path.read_type env.ident_env ext.ext_type_path in let doc = Doc_attr.empty in let type_params = mark_type_extension' ext rest in let first = read_extension_constructor env parent id ext in @@ -812,10 +821,10 @@ let read_type_extension env parent id ext rest = let read_exception env parent id ext = let open Exception in - let id = Env.find_exception_identifier env id in + let id = Env.find_exception_identifier env.ident_env id in let source_loc = None in let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc = Doc_attr.attached_no_tag container ext.ext_attributes in + let doc = Doc_attr.attached_no_tag ~suppress_warnings:env.suppress_warnings container ext.ext_attributes in mark_exception ext; let args = read_constructor_declaration_arguments env @@ -854,7 +863,7 @@ let rec read_class_signature env parent params = || List.exists aliasable params then read_class_signature env parent params cty else begin - let p = Env.Path.read_class_type env p in + let p = Env.Path.read_class_type env.ident_env p in let params = List.map (read_type_expr env) params in Constr(p, params) end @@ -881,7 +890,7 @@ let rec read_class_signature env parent params = List.map (read_method env parent (Compat.csig_concr csig)) methods in let items = constraints @ instance_variables @ methods in - Signature {self; items; doc = []} + Signature {self; items; doc = empty_doc} | Cty_arrow _ -> assert false let rec read_virtual = function @@ -906,10 +915,10 @@ let rec read_virtual = function let read_class_type_declaration env parent id cltd = let open ClassType in - let id = Env.find_class_type_identifier env id in + let id = Env.find_class_type_identifier env.ident_env id in let source_loc = None in let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc = Doc_attr.attached_no_tag container cltd.clty_attributes in + let doc = Doc_attr.attached_no_tag ~suppress_warnings:env.suppress_warnings container cltd.clty_attributes in mark_class_type_declaration cltd; let params = List.map2 @@ -942,10 +951,10 @@ let rec read_class_type env parent params = let read_class_declaration env parent id cld = let open Class in - let id = Env.find_class_identifier env id in + let id = Env.find_class_identifier env.ident_env id in let source_loc = None in let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc = Doc_attr.attached_no_tag container cld.cty_attributes in + let doc = Doc_attr.attached_no_tag ~suppress_warnings:env.suppress_warnings container cld.cty_attributes in mark_class_declaration cld; let params = List.map2 @@ -961,7 +970,7 @@ let read_class_declaration env parent id cld = let rec read_module_type env parent (mty : Odoc_model.Compat.module_type) = let open ModuleType in match mty with - | Mty_ident p -> Path {p_path = Env.Path.read_module_type env p; p_expansion=None } + | Mty_ident p -> Path {p_path = Env.Path.read_module_type env.ident_env p; p_expansion=None } | Mty_signature sg -> Signature (read_signature env parent sg) | Mty_functor(parameter, res) -> let f_parameter, env = @@ -970,8 +979,8 @@ let rec read_module_type env parent (mty : Odoc_model.Compat.module_type) = | Named (id_opt, arg) -> let id, env = match id_opt with | None -> Identifier.Mk.parameter(parent, Odoc_model.Names.ModuleName.make_std "_"), env - | Some id -> let env = Env.add_parameter parent id (ModuleName.of_ident id) env in - Ident_env.find_parameter_identifier env id, env + | Some id -> let e' = Env.add_parameter parent id (ModuleName.of_ident id) env.ident_env in + Ident_env.find_parameter_identifier e' id, {env with ident_env = e'} in let arg = read_module_type env (id :> Identifier.Signature.t) arg in Odoc_model.Lang.FunctorParameter.Named ({ FunctorParameter. id; expr = arg }), env @@ -979,30 +988,30 @@ let rec read_module_type env parent (mty : Odoc_model.Compat.module_type) = let res = read_module_type env (Identifier.Mk.result parent) res in Functor( f_parameter, res) | Mty_alias p -> - let t_original_path = Env.Path.read_module env p in + let t_original_path = Env.Path.read_module env.ident_env p in let t_desc = ModPath t_original_path in TypeOf { t_desc; t_expansion = None; t_original_path } and read_module_type_declaration env parent id (mtd : Odoc_model.Compat.modtype_declaration) = let open ModuleType in - let id = Env.find_module_type env id in + let id = Env.find_module_type env.ident_env id in let source_loc = None in let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc, canonical = Doc_attr.attached Odoc_model.Semantics.Expect_canonical container mtd.mtd_attributes in + let doc, canonical = Doc_attr.attached ~suppress_warnings:env.suppress_warnings Odoc_model.Semantics.Expect_canonical container mtd.mtd_attributes in let canonical = match canonical with | None -> None | Some s -> Doc_attr.conv_canonical_module_type s in let expr = opt_map (read_module_type env (id :> Identifier.Signature.t)) mtd.mtd_type in {id; source_loc; doc; canonical; expr } and read_module_declaration env parent ident (md : Odoc_model.Compat.module_declaration) = let open Module in - let id = (Env.find_module_identifier env ident :> Identifier.Module.t) in + let id = (Env.find_module_identifier env.ident_env ident :> Identifier.Module.t) in let source_loc = None in let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc, canonical = Doc_attr.attached Odoc_model.Semantics.Expect_canonical container md.md_attributes in + let doc, canonical = Doc_attr.attached ~suppress_warnings:env.suppress_warnings Odoc_model.Semantics.Expect_canonical container md.md_attributes in let canonical = match canonical with | None -> None | Some s -> Some (Doc_attr.conv_canonical_module s) in let type_ = match md.md_type with - | Mty_alias p -> Alias (Env.Path.read_module env p, None) + | Mty_alias p -> Alias (Env.Path.read_module env.ident_env p, None) | _ -> ModuleType (read_module_type env (id :> Identifier.Signature.t) md.md_type) in let hidden = @@ -1035,9 +1044,9 @@ and read_signature_noenv env parent (items : Odoc_model.Compat.signature) = | Sig_value(id, v, _) :: rest -> let vd = read_value_description env parent id v in let shadowed = - if Env.is_shadowed env id + if Env.is_shadowed env.ident_env id then - let identifier = Env.find_value_identifier env id in + let identifier = Env.find_value_identifier env.ident_env id in match identifier.iv with | `Value (_, n) -> { shadowed with s_values = (Odoc_model.Names.parenthesise (Ident.name id), n) :: shadowed.s_values } else shadowed @@ -1049,9 +1058,9 @@ and read_signature_noenv env parent (items : Odoc_model.Compat.signature) = | Sig_type(id, decl, rec_status, _)::rest -> let decl = read_type_declaration env parent id decl in let shadowed = - if Env.is_shadowed env id + if Env.is_shadowed env.ident_env id then - let identifier = Env.find_type_identifier env id in + let identifier = Env.find_type_identifier env.ident_env id in let `Type (_, name) = identifier.iv in { shadowed with s_types = (Ident.name id, name) :: shadowed.s_types } else shadowed @@ -1077,9 +1086,9 @@ and read_signature_noenv env parent (items : Odoc_model.Compat.signature) = | Sig_module (id, _, md, rec_status, _)::rest -> let md = read_module_declaration env parent id md in let shadowed = - if Env.is_shadowed env id + if Env.is_shadowed env.ident_env id then - let identifier = Env.find_module_identifier env id in + let identifier = Env.find_module_identifier env.ident_env id in let name = match identifier.iv with | `Module (_, n) -> n @@ -1093,9 +1102,9 @@ and read_signature_noenv env parent (items : Odoc_model.Compat.signature) = | Sig_modtype(id, mtd, _) :: rest -> let mtd = read_module_type_declaration env parent id mtd in let shadowed = - if Env.is_shadowed env id + if Env.is_shadowed env.ident_env id then - let identifier = Env.find_module_type env id in + let identifier = Env.find_module_type env.ident_env id in let name = match identifier.iv with | `ModuleType (_, n) -> n @@ -1114,9 +1123,9 @@ and read_signature_noenv env parent (items : Odoc_model.Compat.signature) = #endif let cl = read_class_declaration env parent id cl in let shadowed = - if Env.is_shadowed env id + if Env.is_shadowed env.ident_env id then - let identifier = Env.find_class_identifier env id in + let identifier = Env.find_class_identifier env.ident_env id in let name = match identifier.iv with | `Class (_, n) -> n @@ -1133,9 +1142,9 @@ and read_signature_noenv env parent (items : Odoc_model.Compat.signature) = #endif let cltyp = read_class_type_declaration env parent id cltyp in let shadowed = - if Env.is_shadowed env id + if Env.is_shadowed env.ident_env id then - let identifier = Env.find_class_type_identifier env id in + let identifier = Env.find_class_type_identifier env.ident_env id in let name = match identifier.iv with | `ClassType (_, n) -> n @@ -1152,16 +1161,23 @@ and read_signature_noenv env parent (items : Odoc_model.Compat.signature) = | Sig_class_type _ :: _ | Sig_class _ :: _ -> assert false - | [] -> ({items = List.rev acc; compiled=false; removed = []; doc = [] }, shadowed) + | [] -> ({items = List.rev acc; compiled=false; removed = []; doc = empty_doc }, shadowed) in loop ([],{s_modules=[]; s_module_types=[]; s_values=[];s_types=[]; s_classes=[]; s_class_types=[]}) items and read_signature env parent (items : Odoc_model.Compat.signature) = - let env = Env.handle_signature_type_items parent items env in + let e' = Env.handle_signature_type_items parent items env.ident_env in + let env = { env with ident_env = e' } in fst @@ read_signature_noenv env parent items -let read_interface root name intf = - let id = Identifier.Mk.root (root, Odoc_model.Names.ModuleName.make_std name) in - let items = read_signature (Env.empty ()) id intf in +let read_interface root name suppress_warnings intf = + let id = + Identifier.Mk.root (root, Odoc_model.Names.ModuleName.make_std name) + in + let items = + read_signature + { ident_env = Env.empty (); suppress_warnings } + id intf + in (id, items) diff --git a/src/loader/cmi.mli b/src/loader/cmi.mli index 23768302d0..4539070e27 100644 --- a/src/loader/cmi.mli +++ b/src/loader/cmi.mli @@ -18,9 +18,16 @@ module Paths = Odoc_model.Paths + +type env = { + ident_env : Ident_env.t; (** Environment *) + suppress_warnings : bool (** Suppress warnings *) +} + val read_interface : Odoc_model.Paths.Identifier.ContainerPage.t option -> string -> + bool -> Odoc_model.Compat.signature -> Paths.Identifier.RootModule.t * Odoc_model.Lang.Signature.t @@ -32,7 +39,7 @@ val read_label : Asttypes.arg_label -> Odoc_model.Lang.TypeExpr.label option val mark_type_expr : Types.type_expr -> unit -val read_type_expr : Ident_env.t -> +val read_type_expr : env -> Types.type_expr -> Odoc_model.Lang.TypeExpr.t val mark_type_extension : Types.type_expr list -> @@ -46,44 +53,45 @@ val mark_class_declaration : Types.class_declaration -> unit val read_self_type : Types.type_expr -> Odoc_model.Lang.TypeExpr.t option -val read_type_constraints : Ident_env.t -> Types.type_expr list -> +val read_type_constraints : env -> Types.type_expr list -> (Odoc_model.Lang.TypeExpr.t * Odoc_model.Lang.TypeExpr.t) list val read_class_constraints : - Ident_env.t -> + env -> Types.type_expr list -> Odoc_model.Lang.ClassSignature.item list -val read_class_signature : Ident_env.t -> +val read_class_signature : env -> Paths.Identifier.ClassSignature.t -> Types.type_expr list -> Types.class_type -> Odoc_model.Lang.ClassType.expr -val read_class_type : Ident_env.t -> +val read_class_type : env -> Paths.Identifier.ClassSignature.t -> Types.type_expr list -> Types.class_type -> Odoc_model.Lang.Class.decl -val read_module_type : Ident_env.t -> +val read_module_type : env -> Paths.Identifier.Signature.t -> Odoc_model.Compat.module_type -> Odoc_model.Lang.ModuleType.expr -val read_signature_noenv : Ident_env.t -> +val read_signature_noenv : env -> Paths.Identifier.Signature.t -> Odoc_model.Compat.signature -> (Odoc_model.Lang.Signature.t * Odoc_model.Lang.Include.shadowed) -val read_signature : Ident_env.t -> +val read_signature : env -> Paths.Identifier.Signature.t -> Odoc_model.Compat.signature -> Odoc_model.Lang.Signature.t -val read_extension_constructor : Ident_env.t -> +val read_extension_constructor : env -> Paths.Identifier.Signature.t -> Ident.t -> Types.extension_constructor -> Odoc_model.Lang.Extension.Constructor.t -val read_exception : Ident_env.t -> +val read_exception : env -> Paths.Identifier.Signature.t -> Ident.t -> Types.extension_constructor -> Odoc_model.Lang.Exception.t + diff --git a/src/loader/cmt.ml b/src/loader/cmt.ml index 7018848885..5f4ad66c08 100644 --- a/src/loader/cmt.ml +++ b/src/loader/cmt.ml @@ -25,6 +25,12 @@ open Odoc_model.Lang module Env = Ident_env +type env = Cmi.env = { + ident_env : Ident_env.t; + suppress_warnings : bool; +} + + let read_core_type env ctyp = Cmi.read_type_expr env ctyp.ctyp_type @@ -39,7 +45,7 @@ let rec read_pattern env parent doc pat = | Tpat_var(id,_,_uid) -> #endif let open Value in - let id = Env.find_value_identifier env id in + let id = Env.find_value_identifier env.ident_env id in Cmi.mark_type_expr pat.pat_type; let type_ = Cmi.read_type_expr env pat.pat_type in let value = Abstract in @@ -50,7 +56,7 @@ let rec read_pattern env parent doc pat = | Tpat_alias(pat, id, _,_) -> #endif let open Value in - let id = Env.find_value_identifier env id in + let id = Env.find_value_identifier env.ident_env id in Cmi.mark_type_expr pat.pat_type; let type_ = Cmi.read_type_expr env pat.pat_type in let value = Abstract in @@ -85,7 +91,7 @@ let rec read_pattern env parent doc pat = let read_value_binding env parent vb = let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc = Doc_attr.attached_no_tag container vb.vb_attributes in + let doc = Doc_attr.attached_no_tag ~suppress_warnings:env.suppress_warnings container vb.vb_attributes in read_pattern env parent doc vb.vb_pat let read_value_bindings env parent vbs = @@ -95,7 +101,7 @@ let read_value_bindings env parent vbs = (fun acc vb -> let open Signature in let comments = - Doc_attr.standalone_multiple container vb.vb_attributes in + Doc_attr.standalone_multiple container ~suppress_warnings:env.suppress_warnings vb.vb_attributes in let comments = List.map (fun com -> Comment com) comments in let vb = read_value_binding env parent vb in List.rev_append vb (List.rev_append comments acc)) @@ -105,9 +111,9 @@ let read_value_bindings env parent vbs = let read_type_extension env parent tyext = let open Extension in - let type_path = Env.Path.read_type env tyext.tyext_path in + let type_path = Env.Path.read_type env.ident_env tyext.tyext_path in let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc = Doc_attr.attached_no_tag container tyext.tyext_attributes in + let doc = Doc_attr.attached_no_tag ~suppress_warnings:env.suppress_warnings container tyext.tyext_attributes in let type_params = List.map (fun (ctyp, _) -> ctyp.ctyp_type) tyext.tyext_params in @@ -136,14 +142,14 @@ let read_type_extension env parent tyext = rendered. For example, [constraint] items are read separately and not associated with their comment. *) let mk_class_comment = function - | [] -> None + | { Odoc_model.Comment.elements = []; _} -> None | doc -> Some (ClassSignature.Comment (`Docs doc)) let rec read_class_type_field env parent ctf = let open ClassSignature in let open Odoc_model.Names in let container = (parent : Identifier.ClassSignature.t :> Identifier.LabelParent.t) in - let doc = Doc_attr.attached_no_tag container ctf.ctf_attributes in + let doc = Doc_attr.attached_no_tag ~suppress_warnings:env.suppress_warnings container ctf.ctf_attributes in match ctf.ctf_desc with | Tctf_val(name, mutable_, virtual_, typ) -> let open InstanceVariable in @@ -164,7 +170,7 @@ let rec read_class_type_field env parent ctf = let expr = read_class_signature env parent [] cltyp in Some (Inherit {Inherit.expr; doc}) | Tctf_attribute attr -> - match Doc_attr.standalone container attr with + match Doc_attr.standalone container ~suppress_warnings:env.suppress_warnings attr with | None -> None | Some doc -> Some (Comment doc) @@ -172,7 +178,7 @@ and read_class_signature env parent params cltyp = let open ClassType in match cltyp.cltyp_desc with | Tcty_constr(p, _, params) -> - let p = Env.Path.read_class_type env p in + let p = Env.Path.read_class_type env.ident_env p in let params = List.map (read_core_type env) params in Constr(p, params) | Tcty_signature csig -> @@ -193,7 +199,7 @@ and read_class_signature env parent params cltyp = let items, (doc, doc_post) = Doc_attr.extract_top_comment_class items in let items = match doc_post with - | [] -> items + | { elements = []; _ } -> items | _ -> Comment (`Docs doc_post) :: items in Signature {self; items; doc} @@ -224,7 +230,7 @@ let rec read_class_field env parent cf = let open ClassSignature in let open Odoc_model.Names in let container = (parent : Identifier.ClassSignature.t :> Identifier.LabelParent.t) in - let doc = Doc_attr.attached_no_tag container (cf.cf_attributes) in + let doc = Doc_attr.attached_no_tag ~suppress_warnings:env.suppress_warnings container (cf.cf_attributes) in match cf.cf_desc with | Tcf_val({txt = name; _}, mutable_, _, kind, _) -> let open InstanceVariable in @@ -264,7 +270,7 @@ let rec read_class_field env parent cf = Some (Inherit {Inherit.expr; doc}) | Tcf_initializer _ -> mk_class_comment doc | Tcf_attribute attr -> - match Doc_attr.standalone container attr with + match Doc_attr.standalone container ~suppress_warnings:env.suppress_warnings attr with | None -> None | Some doc -> Some (Comment doc) @@ -289,7 +295,7 @@ and read_class_structure env parent params cl = let items, (doc, doc_post) = Doc_attr.extract_top_comment_class items in let items = match doc_post with - | [] -> items + | { elements = []; _ } -> items | _ -> Comment (`Docs doc_post) :: items in Signature {self; items; doc} @@ -331,10 +337,10 @@ let rec read_class_expr env parent params cl = let read_class_declaration env parent cld = let open Class in - let id = Env.find_class_identifier env cld.ci_id_class in + let id = Env.find_class_identifier env.ident_env cld.ci_id_class in let source_loc = None in let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc = Doc_attr.attached_no_tag container cld.ci_attributes in + let doc = Doc_attr.attached_no_tag ~suppress_warnings:env.suppress_warnings container cld.ci_attributes in Cmi.mark_class_declaration cld.ci_decl; let virtual_ = (cld.ci_virt = Virtual) in let clparams = @@ -352,7 +358,7 @@ let read_class_declarations env parent clds = let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in let open Signature in List.fold_left begin fun (acc, recursive) cld -> - let comments = Doc_attr.standalone_multiple container cld.ci_attributes in + let comments = Doc_attr.standalone_multiple container ~suppress_warnings:env.suppress_warnings cld.ci_attributes in let comments = List.map (fun com -> Comment com) comments in let cld = read_class_declaration env parent cld in ((Class (recursive, cld))::(List.rev_append comments acc), And) @@ -378,8 +384,8 @@ let rec read_module_expr env parent label_parent mexpr = let id, env = match id_opt with | None -> Identifier.Mk.parameter (parent, Odoc_model.Names.ModuleName.make_std "_"), env - | Some id -> let env = Env.add_parameter parent id (ModuleName.of_ident id) env in - Env.find_parameter_identifier env id, env + | Some id -> let e' = Env.add_parameter parent id (ModuleName.of_ident id) env.ident_env in + Env.find_parameter_identifier e' id, {env with ident_env=e'} in let arg = Cmti.read_module_type env (id :> Identifier.Signature.t) label_parent arg in @@ -435,17 +441,17 @@ and read_module_binding env parent mb = match mb.mb_id with | None -> None | Some id -> - let mid = Env.find_module_identifier env id in + let mid = Env.find_module_identifier env.ident_env id in #else - let mid = Env.find_module_identifier env mb.mb_id in + let mid = Env.find_module_identifier env.ident_env mb.mb_id in #endif let id = (mid :> Identifier.Module.t) in let source_loc = None in let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc, canonical = Doc_attr.attached Odoc_model.Semantics.Expect_canonical container mb.mb_attributes in + let doc, canonical = Doc_attr.attached ~suppress_warnings:env.suppress_warnings Odoc_model.Semantics.Expect_canonical container mb.mb_attributes in let type_, canonical = match unwrap_module_expr_desc mb.mb_expr.mod_desc with - | Tmod_ident (p, _) -> (Alias (Env.Path.read_module env p, None), canonical) + | Tmod_ident (p, _) -> (Alias (Env.Path.read_module env.ident_env p, None), canonical) | _ -> let id = (id :> Identifier.Signature.t) in let expr, canonical = @@ -473,7 +479,7 @@ and read_module_bindings env parent mbs = let open Signature in List.fold_left (fun (acc, recursive) mb -> - let comments = Doc_attr.standalone_multiple container mb.mb_attributes in + let comments = Doc_attr.standalone_multiple container ~suppress_warnings:env.suppress_warnings mb.mb_attributes in let comments = List.map (fun com -> Comment com) comments in match read_module_binding env parent mb with | Some mb -> @@ -543,7 +549,7 @@ and read_structure_item env parent item = Cmti.read_class_type_declarations env parent cltyps | Tstr_attribute attr -> let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - match Doc_attr.standalone container attr with + match Doc_attr.standalone container ~suppress_warnings:env.suppress_warnings attr with | None -> [] | Some doc -> [Comment doc] @@ -551,11 +557,11 @@ and read_include env parent incl = let open Include in let loc = Doc_attr.read_location incl.incl_loc in let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc, status = Doc_attr.attached Odoc_model.Semantics.Expect_status container incl.incl_attributes in + let doc, status = Doc_attr.attached ~suppress_warnings:env.suppress_warnings Odoc_model.Semantics.Expect_status container incl.incl_attributes in let decl_modty = match unwrap_module_expr_desc incl.incl_mod.mod_desc with | Tmod_ident(p, _) -> - let p = Env.Path.read_module env p in + let p = Env.Path.read_module env.ident_env p in Some (ModuleType.U.TypeOf (ModuleType.StructInclude p, p)) | _ -> let mty = read_module_expr env parent container incl.incl_mod in @@ -572,7 +578,7 @@ and read_include env parent incl = and read_open env parent o = let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc = Doc_attr.attached_no_tag container o.open_attributes in + let doc = Doc_attr.attached_no_tag ~suppress_warnings:env.suppress_warnings container o.open_attributes in #if OCAML_VERSION >= (4,8,0) let signature = o.open_bound_items in #else @@ -585,7 +591,8 @@ and read_structure : 'tags. 'tags Odoc_model.Semantics.handle_internal_tags -> _ -> _ -> _ -> _ * 'tags = fun internal_tags env parent str -> - let env = Env.add_structure_tree_items parent str env in + let e' = Env.add_structure_tree_items parent str env.ident_env in + let env = { env with ident_env=e' } in let items, (doc, doc_post), tags = let classify item = match item.str_desc with @@ -603,17 +610,25 @@ and read_structure : |> List.rev in match doc_post with - | [] -> + | { elements = [] ; _} -> ({ Signature.items; compiled = false; removed = []; doc }, tags) | _ -> ({ Signature.items = Comment (`Docs doc_post) :: items; compiled=false; removed = []; doc }, tags) -let read_implementation root name impl = - let id = Identifier.Mk.root (root, Odoc_model.Names.ModuleName.make_std name) in +let read_implementation root name suppress_warnings impl = + let id = + Identifier.Mk.root (root, Odoc_model.Names.ModuleName.make_std name) + in let sg, canonical = - read_structure Odoc_model.Semantics.Expect_canonical (Env.empty ()) id impl + read_structure Odoc_model.Semantics.Expect_canonical + { ident_env = Env.empty (); suppress_warnings } + id impl + in + let canonical = + match canonical with + | None -> None + | Some s -> Some (Doc_attr.conv_canonical_module s) in - let canonical = match canonical with | None -> None | Some s -> Some (Doc_attr.conv_canonical_module s) in (id, sg, canonical) let _ = Cmti.read_module_expr := read_module_expr diff --git a/src/loader/cmt.mli b/src/loader/cmt.mli index 87d0d96480..297bb368b8 100644 --- a/src/loader/cmt.mli +++ b/src/loader/cmt.mli @@ -17,6 +17,7 @@ val read_implementation : Odoc_model.Paths.Identifier.ContainerPage.t option -> string -> + bool -> Typedtree.structure -> Odoc_model.Paths.Identifier.RootModule.t * Odoc_model.Lang.Signature.t diff --git a/src/loader/cmti.ml b/src/loader/cmti.ml index 945de00f81..5e7b431d01 100644 --- a/src/loader/cmti.ml +++ b/src/loader/cmti.ml @@ -26,7 +26,12 @@ open Odoc_model.Names module Env = Ident_env module Paths = Odoc_model.Paths -let read_module_expr : (Ident_env.t -> Identifier.Signature.t -> Identifier.LabelParent.t -> Typedtree.module_expr -> ModuleType.expr) ref = ref (fun _ _ _ _ -> failwith "unset") +type env = Cmi.env = { + ident_env : Ident_env.t; + suppress_warnings : bool; +} + +let read_module_expr : (env -> Identifier.Signature.t -> Identifier.LabelParent.t -> Typedtree.module_expr -> ModuleType.expr) ref = ref (fun _ _ _ _ -> failwith "unset") let opt_map f = function | None -> None @@ -62,7 +67,7 @@ let rec read_core_type env container ctyp = let typs = List.map (read_core_type env container) typs in Tuple typs | Ttyp_constr(p, _, params) -> - let p = Env.Path.read_type env p in + let p = Env.Path.read_type env.ident_env p in let params = List.map (read_core_type env container) params in Constr(p, params) | Ttyp_object(methods, closed) -> @@ -93,7 +98,7 @@ let rec read_core_type env container ctyp = in Object {fields; open_ = (closed = Asttypes.Open)} | Ttyp_class(p, _, params) -> - let p = Env.Path.read_class_type env p in + let p = Env.Path.read_class_type env.ident_env p in let params = List.map (read_core_type env container) params in Class(p, params) | Ttyp_alias(typ, var) -> @@ -120,7 +125,7 @@ let rec read_core_type env container ctyp = #if OCAML_VERSION >= (4,6,0) let name = name.txt in #endif - let doc = Doc_attr.attached_no_tag container attributes in + let doc = Doc_attr.attached_no_tag ~suppress_warnings:env.suppress_warnings container attributes in Constructor {name; constant; arguments; doc} | Tinherit typ -> Type (read_core_type env container typ) end @@ -136,7 +141,7 @@ let rec read_core_type env container ctyp = | Ttyp_poly(vars, typ) -> Poly(vars, read_core_type env container typ) | Ttyp_package {pack_path; pack_fields; _} -> let open TypeExpr.Package in - let path = Env.Path.read_module_type env pack_path in + let path = Env.Path.read_module_type env.ident_env pack_path in let substitutions = List.map (fun (frag, typ) -> @@ -154,12 +159,12 @@ let rec read_core_type env container ctyp = let read_value_description env parent vd = let open Signature in - let id = Env.find_value_identifier env vd.val_id in + let id = Env.find_value_identifier env.ident_env vd.val_id in let source_loc = None in let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc = Doc_attr.attached_no_tag container vd.val_attributes in + let doc = Doc_attr.attached_no_tag ~suppress_warnings:env.suppress_warnings container vd.val_attributes in let type_ = read_core_type env container vd.val_desc in let value = match vd.val_prim with @@ -203,7 +208,7 @@ let read_label_declaration env parent label_parent ld = let open Odoc_model.Names in let name = Ident.name ld.ld_id in let id = Identifier.Mk.field(parent, FieldName.make_std name) in - let doc = Doc_attr.attached_no_tag label_parent ld.ld_attributes in + let doc = Doc_attr.attached_no_tag ~suppress_warnings:env.suppress_warnings label_parent ld.ld_attributes in let mutable_ = (ld.ld_mutable = Mutable) in let type_ = read_core_type env label_parent ld.ld_type in {id; doc; mutable_; type_} @@ -222,10 +227,10 @@ let read_constructor_declaration_arguments env parent label_parent arg = let read_constructor_declaration env parent cd = let open TypeDecl.Constructor in - let id = Ident_env.find_constructor_identifier env cd.cd_id in + let id = Ident_env.find_constructor_identifier env.ident_env cd.cd_id in let container = (parent :> Identifier.FieldParent.t) in let label_container = (container :> Identifier.LabelParent.t) in - let doc = Doc_attr.attached_no_tag label_container cd.cd_attributes in + let doc = Doc_attr.attached_no_tag ~suppress_warnings:env.suppress_warnings label_container cd.cd_attributes in let args = read_constructor_declaration_arguments env container label_container cd.cd_args @@ -263,10 +268,10 @@ let read_type_equation env container decl = let read_type_declaration env parent decl = let open TypeDecl in - let id = Env.find_type_identifier env decl.typ_id in + let id = Env.find_type_identifier env.ident_env decl.typ_id in let source_loc = None in let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc, canonical = Doc_attr.attached Odoc_model.Semantics.Expect_canonical container decl.typ_attributes in + let doc, canonical = Doc_attr.attached ~suppress_warnings:env.suppress_warnings Odoc_model.Semantics.Expect_canonical container decl.typ_attributes in let canonical = match canonical with | None -> None | Some s -> Doc_attr.conv_canonical_type s in let equation = read_type_equation env container decl in let representation = read_type_kind env id decl.typ_kind in @@ -282,7 +287,7 @@ let read_type_declarations env parent rec_flag decls = then (acc, recursive) else begin let comments = - Doc_attr.standalone_multiple container decl.typ_attributes in + Doc_attr.standalone_multiple container ~suppress_warnings:env.suppress_warnings decl.typ_attributes in let comments = List.map (fun com -> Comment com) comments in let decl = read_type_declaration env parent decl in ((Type (recursive, decl)) :: (List.rev_append comments acc), And) @@ -299,11 +304,11 @@ let read_type_substitutions env parent decls = let read_extension_constructor env parent ext = let open Extension.Constructor in - let id = Env.find_extension_identifier env ext.ext_id in + let id = Env.find_extension_identifier env.ident_env ext.ext_id in let source_loc = None in let container = (parent : Identifier.Signature.t :> Identifier.FieldParent.t) in let label_container = (container :> Identifier.LabelParent.t) in - let doc = Doc_attr.attached_no_tag label_container ext.ext_attributes in + let doc = Doc_attr.attached_no_tag ~suppress_warnings:env.suppress_warnings label_container ext.ext_attributes in match ext.ext_kind with | Text_rebind _ -> assert false #if OCAML_VERSION >= (4, 14, 0) @@ -320,9 +325,9 @@ let read_extension_constructor env parent ext = let read_type_extension env parent tyext = let open Extension in - let type_path = Env.Path.read_type env tyext.tyext_path in + let type_path = Env.Path.read_type env.ident_env tyext.tyext_path in let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc = Doc_attr.attached_no_tag container tyext.tyext_attributes in + let doc = Doc_attr.attached_no_tag ~suppress_warnings:env.suppress_warnings container tyext.tyext_attributes in let type_params = List.map read_type_parameter tyext.tyext_params in let private_ = (tyext.tyext_private = Private) in let constructors = @@ -332,11 +337,11 @@ let read_type_extension env parent tyext = let read_exception env parent (ext : extension_constructor) = let open Exception in - let id = Env.find_exception_identifier env ext.ext_id in + let id = Env.find_exception_identifier env.ident_env ext.ext_id in let source_loc = None in let container = (parent : Identifier.Signature.t :> Identifier.FieldParent.t) in let label_container = (container :> Identifier.LabelParent.t) in - let doc = Doc_attr.attached_no_tag label_container ext.ext_attributes in + let doc = Doc_attr.attached_no_tag ~suppress_warnings:env.suppress_warnings label_container ext.ext_attributes in match ext.ext_kind with | Text_rebind _ -> assert false #if OCAML_VERSION >= (4, 14, 0) @@ -355,7 +360,7 @@ let rec read_class_type_field env parent ctf = let open ClassSignature in let open Odoc_model.Names in let container = (parent : Identifier.ClassSignature.t :> Identifier.LabelParent.t) in - let doc = Doc_attr.attached_no_tag container ctf.ctf_attributes in + let doc = Doc_attr.attached_no_tag ~suppress_warnings:env.suppress_warnings container ctf.ctf_attributes in match ctf.ctf_desc with | Tctf_val(name, mutable_, virtual_, typ) -> let open InstanceVariable in @@ -379,7 +384,7 @@ let rec read_class_type_field env parent ctf = let expr = read_class_signature env parent container cltyp in Some (Inherit {expr; doc}) | Tctf_attribute attr -> - match Doc_attr.standalone container attr with + match Doc_attr.standalone container ~suppress_warnings:env.suppress_warnings attr with | None -> None | Some doc -> Some (Comment doc) @@ -391,7 +396,7 @@ and read_class_signature env parent label_parent cltyp = let open ClassType in match cltyp.cltyp_desc with | Tcty_constr(p, _, params) -> - let p = Env.Path.read_class_type env p in + let p = Env.Path.read_class_type env.ident_env p in let params = List.map (read_core_type env label_parent) params in Constr(p, params) | Tcty_signature csig -> @@ -409,7 +414,7 @@ and read_class_signature env parent label_parent cltyp = let items, (doc, doc_post) = Doc_attr.extract_top_comment_class items in let items = match doc_post with - | [] -> items + | {elements=[]; _} -> items | _ -> Comment (`Docs doc_post) :: items in Signature {self; items; doc} @@ -422,10 +427,10 @@ and read_class_signature env parent label_parent cltyp = let read_class_type_declaration env parent cltd = let open ClassType in - let id = Env.find_class_type_identifier env cltd.ci_id_class_type in + let id = Env.find_class_type_identifier env.ident_env cltd.ci_id_class_type in let source_loc = None in let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc = Doc_attr.attached_no_tag container cltd.ci_attributes in + let doc = Doc_attr.attached_no_tag container ~suppress_warnings:env.suppress_warnings cltd.ci_attributes in let virtual_ = (cltd.ci_virt = Virtual) in let params = List.map read_type_parameter cltd.ci_params in let expr = read_class_signature env (id :> Identifier.ClassSignature.t) container cltd.ci_expr in @@ -435,7 +440,7 @@ let read_class_type_declarations env parent cltds = let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in let open Signature in List.fold_left begin fun (acc,recursive) cltd -> - let comments = Doc_attr.standalone_multiple container cltd.ci_attributes in + let comments = Doc_attr.standalone_multiple container ~suppress_warnings:env.suppress_warnings cltd.ci_attributes in let comments = List.map (fun com -> Comment com) comments in let cltd = read_class_type_declaration env parent cltd in ((ClassType (recursive, cltd))::(List.rev_append comments acc), And) @@ -461,10 +466,10 @@ let rec read_class_type env parent label_parent cty = let read_class_description env parent cld = let open Class in - let id = Env.find_class_identifier env cld.ci_id_class in + let id = Env.find_class_identifier env.ident_env cld.ci_id_class in let source_loc = None in let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc = Doc_attr.attached_no_tag container cld.ci_attributes in + let doc = Doc_attr.attached_no_tag container ~suppress_warnings:env.suppress_warnings cld.ci_attributes in let virtual_ = (cld.ci_virt = Virtual) in let params = List.map read_type_parameter cld.ci_params in let type_ = read_class_type env (id :> Identifier.ClassSignature.t) container cld.ci_expr in @@ -474,7 +479,7 @@ let read_class_descriptions env parent clds = let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in let open Signature in List.fold_left begin fun (acc, recursive) cld -> - let comments = Doc_attr.standalone_multiple container cld.ci_attributes in + let comments = Doc_attr.standalone_multiple container ~suppress_warnings:env.suppress_warnings cld.ci_attributes in let comments = List.map (fun com -> Comment com) comments in let cld = read_class_description env parent cld in ((Class (recursive, cld))::(List.rev_append comments acc), And) @@ -500,7 +505,7 @@ let rec read_with_constraint env global_parent parent (_, frag, constr) = TypeSubst(frag, eq) | Twith_modsubst(p, _) -> let frag = Env.Fragment.read_module frag.Location.txt in - let p = Env.Path.read_module env p in + let p = Env.Path.read_module env.ident_env p in ModuleSubst(frag, p) #if OCAML_VERSION >= (4,13,0) | Twith_modtype mty -> @@ -516,7 +521,7 @@ let rec read_with_constraint env global_parent parent (_, frag, constr) = and read_module_type env parent label_parent mty = let open ModuleType in match mty.mty_desc with - | Tmty_ident(p, _) -> Path { p_path = Env.Path.read_module_type env p; p_expansion = None } + | Tmty_ident(p, _) -> Path { p_path = Env.Path.read_module_type env.ident_env p; p_expansion = None } | Tmty_signature sg -> let sg, () = read_signature Odoc_model.Semantics.Expect_none env parent sg in Signature sg @@ -530,8 +535,9 @@ and read_module_type env parent label_parent mty = match id_opt with | None -> Identifier.Mk.parameter (parent, ModuleName.make_std "_"), env | Some id -> - let env = Env.add_parameter parent id (ModuleName.of_ident id) env in - Env.find_parameter_identifier env id, env + let e' = Env.add_parameter parent id (ModuleName.of_ident id) env.ident_env in + let env = {env with ident_env = e'} in + Env.find_parameter_identifier e' id, env in let arg = read_module_type env (id :> Identifier.Signature.t) label_parent arg in Named { id; expr = arg; }, env @@ -564,12 +570,12 @@ and read_module_type env parent label_parent mty = let decl = match mexpr.mod_desc with | Tmod_ident(p, _) -> - let p = Env.Path.read_module env p in + let p = Env.Path.read_module env.ident_env p in TypeOf {t_desc = ModPath p; t_original_path = p; t_expansion = None} | Tmod_structure {str_items = [{str_desc = Tstr_include {incl_mod; _}; _}]; _} -> begin match Typemod.path_of_module incl_mod with | Some p -> - let p = Env.Path.read_module env p in + let p = Env.Path.read_module env.ident_env p in TypeOf {t_desc=StructInclude p; t_original_path = p; t_expansion = None} | None -> !read_module_expr env parent label_parent mexpr @@ -593,10 +599,10 @@ and read_module_type_maybe_canonical env parent container ~canonical mty = and read_module_type_declaration env parent mtd = let open ModuleType in - let id = Env.find_module_type env mtd.mtd_id in + let id = Env.find_module_type env.ident_env mtd.mtd_id in let source_loc = None in let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc, canonical = Doc_attr.attached Odoc_model.Semantics.Expect_canonical container mtd.mtd_attributes in + let doc, canonical = Doc_attr.attached ~suppress_warnings:env.suppress_warnings Odoc_model.Semantics.Expect_canonical container mtd.mtd_attributes in let expr, canonical = match mtd.mtd_type with | Some mty -> @@ -617,17 +623,17 @@ and read_module_declaration env parent md = match md.md_id with | None -> None | Some id -> - let mid = Env.find_module_identifier env id in + let mid = Env.find_module_identifier env.ident_env id in #else - let mid = Env.find_module_identifier env md.md_id in + let mid = Env.find_module_identifier env.ident_env md.md_id in #endif let id = (mid :> Identifier.Module.t) in let source_loc = None in let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc, canonical = Doc_attr.attached Odoc_model.Semantics.Expect_canonical container md.md_attributes in + let doc, canonical = Doc_attr.attached ~suppress_warnings:env.suppress_warnings Odoc_model.Semantics.Expect_canonical container md.md_attributes in let type_, canonical = match md.md_type.mty_desc with - | Tmty_alias (p, _) -> (Alias (Env.Path.read_module env p, None), canonical) + | Tmty_alias (p, _) -> (Alias (Env.Path.read_module env.ident_env p, None), canonical) | _ -> let expr, canonical = read_module_type_maybe_canonical env @@ -655,7 +661,7 @@ and read_module_declarations env parent mds = let open Signature in List.fold_left (fun (acc, recursive) md -> - let comments = Doc_attr.standalone_multiple container md.md_attributes in + let comments = Doc_attr.standalone_multiple container ~suppress_warnings:env.suppress_warnings md.md_attributes in let comments = List.map (fun com -> Comment com) comments in match read_module_declaration env parent md with | Some md -> ((Module (recursive, md))::(List.rev_append comments acc), And) @@ -666,7 +672,7 @@ and read_module_declarations env parent mds = and read_module_equation env p = let open Module in - Alias (Env.Path.read_module env p, None) + Alias (Env.Path.read_module env.ident_env p, None) and read_signature_item env parent item = let open Signature in @@ -714,7 +720,7 @@ and read_signature_item env parent item = read_class_type_declarations env parent cltyps | Tsig_attribute attr -> begin let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - match Doc_attr.standalone container attr with + match Doc_attr.standalone container ~suppress_warnings:env.suppress_warnings attr with | None -> [] | Some doc -> [Comment doc] end @@ -731,18 +737,18 @@ and read_signature_item env parent item = and read_module_substitution env parent ms = let open ModuleSubstitution in - let id = Env.find_module_identifier env ms.ms_id in + let id = Env.find_module_identifier env.ident_env ms.ms_id in let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc, () = Doc_attr.attached Odoc_model.Semantics.Expect_none container ms.ms_attributes in - let manifest = Env.Path.read_module env ms.ms_manifest in + let doc, () = Doc_attr.attached ~suppress_warnings:env.suppress_warnings Odoc_model.Semantics.Expect_none container ms.ms_attributes in + let manifest = Env.Path.read_module env.ident_env ms.ms_manifest in { id; doc; manifest } #if OCAML_VERSION >= (4,13,0) and read_module_type_substitution env parent mtd = let open ModuleTypeSubstitution in - let id = Env.find_module_type env mtd.mtd_id in + let id = Env.find_module_type env.ident_env mtd.mtd_id in let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc, () = Doc_attr.attached Odoc_model.Semantics.Expect_none container mtd.mtd_attributes in + let doc, () = Doc_attr.attached ~suppress_warnings:env.suppress_warnings Odoc_model.Semantics.Expect_none container mtd.mtd_attributes in let expr = match opt_map (read_module_type env (id :> Identifier.Signature.t) container) mtd.mtd_type with | None -> assert false | Some x -> x @@ -757,7 +763,7 @@ and read_include env parent incl = let open Include in let loc = Doc_attr.read_location incl.incl_loc in let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc, status = Doc_attr.attached Odoc_model.Semantics.Expect_status container incl.incl_attributes in + let doc, status = Doc_attr.attached ~suppress_warnings:env.suppress_warnings Odoc_model.Semantics.Expect_status container incl.incl_attributes in let content, shadowed = Cmi.read_signature_noenv env parent (Odoc_model.Compat.signature incl.incl_type) in let expr = read_module_type env parent container incl.incl_mod in let umty = Odoc_model.Lang.umty_of_mty expr in @@ -771,7 +777,7 @@ and read_include env parent incl = and read_open env parent o = let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc = Doc_attr.attached_no_tag container o.open_attributes in + let doc = Doc_attr.attached_no_tag container ~suppress_warnings:env.suppress_warnings o.open_attributes in #if OCAML_VERSION >= (4,8,0) let signature = o.open_bound_items in #else @@ -784,7 +790,8 @@ and read_signature : 'tags. 'tags Odoc_model.Semantics.handle_internal_tags -> _ -> _ -> _ -> _ * 'tags = fun internal_tags env parent sg -> - let env = Env.add_signature_tree_items parent sg env in + let e' = Env.add_signature_tree_items parent sg env.ident_env in + let env = { env with ident_env = e' } in let items, (doc, doc_post), tags = let classify item = match item.sig_desc with @@ -802,15 +809,23 @@ and read_signature : |> List.rev in match doc_post with - | [] -> + | {elements=[]; _} -> ({ Signature.items; compiled = false; removed = []; doc }, tags) | _ -> ({ Signature.items = Comment (`Docs doc_post) :: items; compiled=false; removed = []; doc }, tags) -let read_interface root name intf = - let id = Identifier.Mk.root (root, Odoc_model.Names.ModuleName.make_std name) in +let read_interface root name suppress_warnings intf = + let id = + Identifier.Mk.root (root, Odoc_model.Names.ModuleName.make_std name) + in let sg, canonical = - read_signature Odoc_model.Semantics.Expect_canonical (Env.empty ()) id intf + read_signature Odoc_model.Semantics.Expect_canonical + { ident_env = Env.empty (); suppress_warnings } + id intf + in + let canonical = + match canonical with + | None -> None + | Some s -> Some (Doc_attr.conv_canonical_module s) in - let canonical = match canonical with | None -> None | Some s -> Some (Doc_attr.conv_canonical_module s) in (id, sg, canonical) diff --git a/src/loader/cmti.mli b/src/loader/cmti.mli index 257ed0210a..9f3c82002f 100644 --- a/src/loader/cmti.mli +++ b/src/loader/cmti.mli @@ -17,7 +17,7 @@ module Paths = Odoc_model.Paths val read_module_expr : - (Ident_env.t -> + (Cmi.env -> Paths.Identifier.Signature.t -> Paths.Identifier.LabelParent.t -> Typedtree.module_expr -> @@ -27,6 +27,7 @@ val read_module_expr : val read_interface : Odoc_model.Paths.Identifier.ContainerPage.t option -> string -> + bool -> Typedtree.signature -> Paths.Identifier.RootModule.t * Odoc_model.Lang.Signature.t @@ -35,33 +36,33 @@ val read_interface : [@canonical] tag. *) val read_module_type : - Ident_env.t -> + Cmi.env -> Paths.Identifier.Signature.t -> Paths.Identifier.LabelParent.t -> Typedtree.module_type -> Odoc_model.Lang.ModuleType.expr val read_value_description : - Ident_env.t -> + Cmi.env -> Paths.Identifier.Signature.t -> Typedtree.value_description -> Odoc_model.Lang.Signature.item val read_type_declarations : - Ident_env.t -> + Cmi.env -> Paths.Identifier.Signature.t -> Odoc_model.Lang.Signature.recursive -> Typedtree.type_declaration list -> Odoc_model.Lang.Signature.item list val read_module_type_declaration : - Ident_env.t -> + Cmi.env -> Paths.Identifier.Signature.t -> Typedtree.module_type_declaration -> Odoc_model.Lang.ModuleType.t val read_class_type_declarations : - Ident_env.t -> + Cmi.env -> Paths.Identifier.Signature.t -> Typedtree.class_type Typedtree.class_infos list -> Odoc_model.Lang.Signature.item list diff --git a/src/loader/doc_attr.ml b/src/loader/doc_attr.ml index d248339547..efa50ee5bc 100644 --- a/src/loader/doc_attr.ml +++ b/src/loader/doc_attr.ml @@ -29,7 +29,7 @@ let read_location { Location.loc_start; loc_end; _ } = end_ = point_of_pos loc_end; } -let empty_body = [] +let empty_body = { Comment.elements = []; suppress_warnings = false } let empty : Odoc_model.Comment.docs = empty_body @@ -124,7 +124,7 @@ let mk_alert_payload ~loc name p = let span = read_location loc in Location_.at span elt -let attached internal_tags parent attrs = +let attached ~suppress_warnings internal_tags parent attrs = let rec loop acc_docs acc_alerts = function | attr :: rest -> ( match parse_attribute attr with @@ -141,10 +141,11 @@ let attached internal_tags parent attrs = | [] -> (List.rev acc_docs, List.rev acc_alerts) in let ast_docs, alerts = loop [] [] attrs in - ast_to_comment ~internal_tags parent ast_docs alerts + let elements, warnings = ast_to_comment ~internal_tags parent ast_docs alerts in + { Comment.elements; suppress_warnings }, warnings -let attached_no_tag parent attrs = - let x, () = attached Semantics.Expect_none parent attrs in +let attached_no_tag ~suppress_warnings parent attrs = + let x, () = attached ~suppress_warnings Semantics.Expect_none parent attrs in x let read_string ~tags_allowed internal_tags parent location str = @@ -160,31 +161,32 @@ let read_string_comment internal_tags parent loc str = read_string ~tags_allowed:true internal_tags parent (pad_loc loc) str let page parent loc str = - read_string ~tags_allowed:false Odoc_model.Semantics.Expect_page_tags parent loc.Location.loc_start + let elements, tags = read_string ~tags_allowed:false Odoc_model.Semantics.Expect_page_tags parent loc.Location.loc_start str + in + { Comment.elements; suppress_warnings = false}, tags -let standalone parent (attr : Parsetree.attribute) : +let standalone parent ~suppress_warnings (attr : Parsetree.attribute) : Odoc_model.Comment.docs_or_stop option = match parse_attribute attr with | Some (`Stop _loc) -> Some `Stop | Some (`Text (str, loc)) -> - let doc, () = read_string_comment Semantics.Expect_none parent loc str in - Some (`Docs doc) + let elements, () = read_string_comment Semantics.Expect_none parent loc str in + Some (`Docs { elements; suppress_warnings }) | Some (`Doc _) -> None | Some (`Alert (name, _, attr_loc)) -> let w = - Error.make "Alert %s not expected here." name - (read_location attr_loc) + Error.make "Alert %s not expected here." name (read_location attr_loc) in Error.raise_warning w; None | _ -> None -let standalone_multiple parent attrs = +let standalone_multiple parent ~suppress_warnings attrs = let coms = List.fold_left (fun acc attr -> - match standalone parent attr with + match standalone parent ~suppress_warnings attr with | None -> acc | Some com -> com :: acc) [] attrs @@ -251,12 +253,19 @@ let extract_top_comment internal_tags ~classify parent items = (parent : Paths.Identifier.Signature.t :> Paths.Identifier.LabelParent.t) ast_docs alerts in - (items, split_docs docs, tags) + let d1, d2 = split_docs docs in + ( items, + ( { Comment.elements = d1; suppress_warnings = false }, + { Comment.elements = d2; suppress_warnings = false } ), + tags ) let extract_top_comment_class items = + let mk elements suppress_warnings = { Comment.elements; suppress_warnings } in match items with - | Lang.ClassSignature.Comment (`Docs doc) :: tl -> (tl, split_docs doc) - | _ -> items, (empty,empty) + | Lang.ClassSignature.Comment (`Docs doc) :: tl -> + let d1, d2 = split_docs doc.elements in + (tl, (mk d1 doc.suppress_warnings, mk d2 doc.suppress_warnings)) + | _ -> (items, (mk [] false, mk [] false)) let rec conv_canonical_module : Odoc_model.Reference.path -> Paths.Path.Module.t = function | `Dot (parent, name) -> `Dot (conv_canonical_module parent, Names.ModuleName.make_std name) diff --git a/src/loader/doc_attr.mli b/src/loader/doc_attr.mli index d4a9117689..dba8e386b4 100644 --- a/src/loader/doc_attr.mli +++ b/src/loader/doc_attr.mli @@ -22,12 +22,14 @@ val empty : Odoc_model.Comment.docs val is_stop_comment : Parsetree.attribute -> bool val attached : + suppress_warnings:bool -> 'tags Semantics.handle_internal_tags -> Paths.Identifier.LabelParent.t -> Parsetree.attributes -> Odoc_model.Comment.docs * 'tags val attached_no_tag : + suppress_warnings:bool -> Paths.Identifier.LabelParent.t -> Parsetree.attributes -> Odoc_model.Comment.docs @@ -47,11 +49,13 @@ val page : val standalone : Paths.Identifier.LabelParent.t -> + suppress_warnings:bool -> Parsetree.attribute -> Odoc_model.Comment.docs_or_stop option val standalone_multiple : Paths.Identifier.LabelParent.t -> + suppress_warnings:bool -> Parsetree.attributes -> Odoc_model.Comment.docs_or_stop list diff --git a/src/loader/odoc_loader.ml b/src/loader/odoc_loader.ml index 72bb572629..cea4ebd45e 100644 --- a/src/loader/odoc_loader.ml +++ b/src/loader/odoc_loader.ml @@ -101,7 +101,7 @@ let compilation_unit_of_sig ~make_root ~imports ~interface ?sourcefile ~name ~id make_compilation_unit ~make_root ~imports ~interface ?sourcefile ~name ~id ?canonical content -let read_cmti ~make_root ~parent ~filename () = +let read_cmti ~make_root ~parent ~filename ~suppress_warnings () = let cmt_info = Cmt_format.read_cmt filename in match cmt_info.cmt_annots with | Interface intf -> ( @@ -118,12 +118,14 @@ let read_cmti ~make_root ~parent ~filename () = cmt_info.cmt_source_digest, cmt_info.cmt_builddir ) in - let id, sg, canonical = Cmti.read_interface parent name intf in + let id, sg, canonical = + Cmti.read_interface parent name suppress_warnings intf + in compilation_unit_of_sig ~make_root ~imports:cmt_info.cmt_imports ~interface ~sourcefile ~name ~id ?canonical sg) | _ -> raise Not_an_interface -let read_cmt ~make_root ~parent ~filename () = +let read_cmt ~make_root ~parent ~filename ~suppress_warnings () = match Cmt_format.read_cmt filename with | exception Cmi_format.Error (Not_an_interface _) -> raise Not_an_implementation @@ -175,17 +177,19 @@ let read_cmt ~make_root ~parent ~filename () = make_compilation_unit ~make_root ~imports ~interface ~sourcefile ~name ~id content | Implementation impl -> - let id, sg, canonical = Cmt.read_implementation parent name impl in + let id, sg, canonical = + Cmt.read_implementation parent name suppress_warnings impl + in compilation_unit_of_sig ~make_root ~imports ~interface ~sourcefile ~name ~id ?canonical sg | _ -> raise Not_an_implementation) -let read_cmi ~make_root ~parent ~filename () = +let read_cmi ~make_root ~parent ~filename ~suppress_warnings () = let cmi_info = Cmi_format.read_cmi filename in match cmi_info.cmi_crcs with | (name, (Some _ as interface)) :: imports when name = cmi_info.cmi_name -> let id, sg = - Cmi.read_interface parent name + Cmi.read_interface parent name suppress_warnings (Odoc_model.Compat.signature cmi_info.cmi_sign) in compilation_unit_of_sig ~make_root ~imports ~interface ~name ~id sg @@ -251,16 +255,19 @@ let wrap_errors ~filename f = | Not_an_interface -> not_an_interface filename | Make_root_error m -> error_msg filename m) -let read_cmti ~make_root ~parent ~filename = - wrap_errors ~filename (read_cmti ~make_root ~parent ~filename) +let read_cmti ~make_root ~parent ~filename ~suppress_warnings = + wrap_errors ~filename + (read_cmti ~make_root ~parent ~filename ~suppress_warnings) -let read_cmt ~make_root ~parent ~filename = - wrap_errors ~filename (read_cmt ~make_root ~parent ~filename) +let read_cmt ~make_root ~parent ~filename ~suppress_warnings = + wrap_errors ~filename + (read_cmt ~make_root ~parent ~filename ~suppress_warnings) let read_impl ~make_root ~filename ~source_id = wrap_errors ~filename (read_impl ~make_root ~source_id ~filename) -let read_cmi ~make_root ~parent ~filename = - wrap_errors ~filename (read_cmi ~make_root ~parent ~filename) +let read_cmi ~make_root ~parent ~filename ~suppress_warnings = + wrap_errors ~filename + (read_cmi ~make_root ~parent ~filename ~suppress_warnings) let read_location = Doc_attr.read_location diff --git a/src/loader/odoc_loader.mli b/src/loader/odoc_loader.mli index 68baddc13f..6f22f40485 100644 --- a/src/loader/odoc_loader.mli +++ b/src/loader/odoc_loader.mli @@ -17,12 +17,14 @@ val read_cmti : make_root:make_root -> parent:Identifier.ContainerPage.t option -> filename:string -> + suppress_warnings:bool -> (Lang.Compilation_unit.t, Error.t) result Error.with_warnings val read_cmt : make_root:make_root -> parent:Identifier.ContainerPage.t option -> filename:string -> + suppress_warnings:bool -> (Lang.Compilation_unit.t, Error.t) result Error.with_warnings val read_impl : @@ -35,6 +37,7 @@ val read_cmi : make_root:make_root -> parent:Identifier.ContainerPage.t option -> filename:string -> + suppress_warnings:bool -> (Lang.Compilation_unit.t, Error.t) result Error.with_warnings val read_location : Location.t -> Location_.span diff --git a/src/markdown/odoc_md.ml b/src/markdown/odoc_md.ml index d8c77f12d4..177b8cac00 100644 --- a/src/markdown/odoc_md.ml +++ b/src/markdown/odoc_md.ml @@ -20,9 +20,9 @@ let parse id input_s = in (content, List.map Error.t_of_parser_t parser_warnings @ semantics_warnings) -let mk_page input_s id content = +let mk_page input_s id elements = (* Construct the output file representation *) - let zero_heading = Comment.find_zero_heading content in + let zero_heading = Comment.find_zero_heading elements in let frontmatter = Frontmatter.empty in let digest = Digest.file input_s in let root = @@ -34,7 +34,7 @@ let mk_page input_s id content = Lang.Page.name = id; root; children; - content; + content = { elements; suppress_warnings = false }; digest; linked = false; frontmatter; diff --git a/src/model/comment.ml b/src/model/comment.ml index 53260cf311..561a3b25cd 100644 --- a/src/model/comment.ml +++ b/src/model/comment.ml @@ -113,7 +113,9 @@ type block_element = heading_attrs * Identifier.Label.t * inline_element with_location list | `Tag of tag ] -type docs = block_element with_location list +type elements = block_element with_location list + +type docs = { elements : elements; suppress_warnings : bool } type docs_or_stop = [ `Docs of docs | `Stop ] diff --git a/src/model/error.ml b/src/model/error.ml index 460e6775c4..7dbbd9c872 100644 --- a/src/model/error.ml +++ b/src/model/error.ml @@ -101,7 +101,11 @@ let print_error ?prefix t = prerr_endline (_to_string ?prefix t) let print_errors = List.iter print_error -type warnings_options = { warn_error : bool; print_warnings : bool } +type warnings_options = { + warn_error : bool; + print_warnings : bool; + suppress_warnings : bool; +} let print_warnings ~warnings_options warnings = if warnings_options.print_warnings then diff --git a/src/model/error.mli b/src/model/error.mli index 1309fd3bfc..2f0ef7164b 100644 --- a/src/model/error.mli +++ b/src/model/error.mli @@ -41,6 +41,7 @@ val catch_errors_and_warnings : (unit -> 'a) -> 'a with_errors_and_warnings type warnings_options = { warn_error : bool; (** If [true], warnings will result in an error. *) print_warnings : bool; (** Whether to print warnings. *) + suppress_warnings : bool; (** Whether to suppress warnings. *) } val handle_warnings : diff --git a/src/model/lang.ml b/src/model/lang.ml index 8dc917a407..a530cba7d6 100644 --- a/src/model/lang.ml +++ b/src/model/lang.ml @@ -571,5 +571,6 @@ let extract_signature_doc (s : Signature.t) = | { decl = ModuleType expr; _ } -> uexpr_considered_hidden expr in match (s.doc, s.items) with - | [], Include inc :: _ when should_take_top inc -> inc.expansion.content.doc + | { elements = []; _ }, Include inc :: _ when should_take_top inc -> + inc.expansion.content.doc | doc, _ -> doc diff --git a/src/model/semantics.ml b/src/model/semantics.ml index e7b79cfcf6..2c54501996 100644 --- a/src/model/semantics.ml +++ b/src/model/semantics.ml @@ -531,7 +531,7 @@ let append_alerts_to_comment alerts comment) alerts in - comment @ (alerts : alerts :> Comment.docs) + comment @ (alerts :> Comment.elements) let handle_internal_tags (type a) tags : a handle_internal_tags -> a = function | Expect_status -> ( diff --git a/src/model/semantics.mli b/src/model/semantics.mli index fea10ac04f..0649948acd 100644 --- a/src/model/semantics.mli +++ b/src/model/semantics.mli @@ -17,7 +17,7 @@ val ast_to_comment : parent_of_sections:Paths.Identifier.LabelParent.t -> Odoc_parser.Ast.t -> alerts -> - (Comment.docs * 'tags) Error.with_warnings + (Comment.elements * 'tags) Error.with_warnings val non_link_inline_element : context:string -> @@ -30,6 +30,6 @@ val parse_comment : containing_definition:Paths.Identifier.LabelParent.t -> location:Lexing.position -> text:string -> - (Comment.docs * 'tags) Error.with_warnings + (Comment.elements * 'tags) Error.with_warnings val parse_reference : string -> Paths.Reference.t Error.with_errors_and_warnings diff --git a/src/model_desc/comment_desc.ml b/src/model_desc/comment_desc.ml index 4964b8c79f..99981e115a 100644 --- a/src/model_desc/comment_desc.ml +++ b/src/model_desc/comment_desc.ml @@ -33,8 +33,7 @@ type general_block_element = Comment.heading_attrs * Identifier.Label.t * general_link_content | `Tag of general_tag | `Media of - [ `Reference of Paths.Reference.t | `Link of string ] * media * string - | `MediaLink of string * media * general_link_content ] + [ `Reference of Paths.Reference.t | `Link of string ] * media * string ] and general_tag = [ `Author of string @@ -133,12 +132,15 @@ let rec block_element : general_block_element t = | `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)) + C + ( "`List", + (x1, (x2 :> general_docs list)), + Pair (list_kind, List general_content) ) | `Table { data; align } -> let cell_type_desc = Variant (function `Header -> C0 "`Header" | `Data -> C0 "`Data") in - let data_desc = List (List (Pair (docs, cell_type_desc))) in + let data_desc = List (List (Pair (general_content, cell_type_desc))) in let align_desc = Option (Variant @@ -153,9 +155,7 @@ let rec block_element : general_block_element t = | `Heading h -> C ("`Heading", h, heading) | `Tag x -> C ("`Tag", x, tag) | `Media (x1, m, x2) -> - C ("`MediaReference", (x1, m, x2), Triple (media_href, media, string)) - | `MediaLink (x1, m, x2) -> - C ("`MediaLink", (x1, m, x2), Triple (string, media, link_content))) + C ("`Media", (x1, m, x2), Triple (media_href, media, string))) and tag : general_tag t = let url_kind = @@ -166,24 +166,32 @@ and tag : general_tag t = Variant (function | `Author x -> C ("`Author", x, string) - | `Deprecated x -> C ("`Deprecated", x, docs) - | `Param (x1, x2) -> C ("`Param", (x1, x2), Pair (string, docs)) + | `Deprecated x -> C ("`Deprecated", x, general_content) + | `Param (x1, x2) -> C ("`Param", (x1, x2), Pair (string, general_content)) | `Raise (x1, x2) -> C ( "`Raise", ((x1 :> general_inline_element), x2), - Pair (inline_element, docs) ) - | `Return x -> C ("`Return", x, docs) + Pair (inline_element, general_content) ) + | `Return x -> C ("`Return", x, general_content) | `See (x1, x2, x3) -> - C ("`See", (x1, x2, x3), Triple (url_kind, string, docs)) + C ("`See", (x1, x2, x3), Triple (url_kind, string, general_content)) | `Since x -> C ("`Since", x, string) - | `Before (x1, x2) -> C ("`Before", (x1, x2), Pair (string, docs)) + | `Before (x1, x2) -> C ("`Before", (x1, x2), Pair (string, general_content)) | `Version x -> C ("`Version", x, string) | `Alert (x1, x2) -> C ("`Alert", (x1, x2), Pair (string, Option string))) -and docs : general_docs t = List (Indirect (ignore_loc, block_element)) - -let docs = Indirect ((fun n -> ((n :> docs) :> general_docs)), docs) +and general_content : general_docs t = + List (Indirect (ignore_loc, block_element)) + +let elements : elements t = + Indirect ((fun x -> (x :> general_docs)), general_content) +let docs = + Record + [ + F ("elements", (fun h -> h.elements), elements); + F ("suppress_warnings", (fun h -> h.suppress_warnings), bool); + ] let docs_or_stop : docs_or_stop t = Variant (function `Docs x -> C ("`Docs", x, docs) | `Stop -> C0 "`Stop") diff --git a/src/model_desc/comment_desc.mli b/src/model_desc/comment_desc.mli index 707b5bf49c..ebedd23f0d 100644 --- a/src/model_desc/comment_desc.mli +++ b/src/model_desc/comment_desc.mli @@ -1,8 +1,10 @@ open Odoc_model open Odoc_model.Comment -val docs : docs Type_desc.t - val inline_element : inline_element Location_.with_location list Type_desc.t +val elements : elements Type_desc.t + +val docs : docs Type_desc.t + val docs_or_stop : docs_or_stop Type_desc.t diff --git a/src/odoc/bin/main.ml b/src/odoc/bin/main.ml index 46635ea5cd..86da013d23 100644 --- a/src/odoc/bin/main.ml +++ b/src/odoc/bin/main.ml @@ -141,12 +141,29 @@ let warnings_options = let env = Arg.env_var "ODOC_ENABLE_MISSING_ROOT_WARNING" ~doc in Arg.(value & flag & info ~docs ~doc ~env [ "enable-missing-root-warning" ]) in + let suppress_warnings = + let doc = + "Suppress warnings. This is useful when you want to declare that \ + warnings that would be generated resolving the references defined in \ + this unit should be ignored if they end up in expansions in other \ + units." + in + let env = Arg.env_var "ODOC_SUPPRESS_WARNINGS" ~doc in + Arg.(value & flag & info ~docs ~doc ~env [ "suppress-warnings" ]) + in Term.( - const (fun warn_error print_warnings enable_missing_root_warning -> + const + (fun + warn_error + print_warnings + enable_missing_root_warning + suppress_warnings + -> Odoc_model.Error.enable_missing_root_warning := enable_missing_root_warning; - { Odoc_model.Error.warn_error; print_warnings }) - $ warn_error $ print_warnings $ enable_missing_root_warning) + { Odoc_model.Error.warn_error; print_warnings; suppress_warnings }) + $ warn_error $ print_warnings $ enable_missing_root_warning + $ suppress_warnings) let dst ?create () = let doc = "Output directory where the HTML tree is expected to be saved." in @@ -965,7 +982,11 @@ end = struct ~roots:None in let warnings_options = - { Odoc_model.Error.warn_error = false; print_warnings = false } + { + Odoc_model.Error.warn_error = false; + print_warnings = false; + suppress_warnings = false; + } in Rendering.targets_odoc ~resolver ~warnings_options ~syntax:OCaml ~renderer:R.renderer ~output:output_dir ~extra odoc_file @@ -1000,7 +1021,11 @@ end = struct module Targets_source = struct let list_targets output_dir source_file extra odoc_file = let warnings_options = - { Odoc_model.Error.warn_error = false; print_warnings = false } + { + Odoc_model.Error.warn_error = false; + print_warnings = false; + suppress_warnings = false; + } in Rendering.targets_source_odoc ~warnings_options ~syntax:OCaml ~renderer:R.renderer ~output:output_dir ~extra ~source_file odoc_file diff --git a/src/odoc/compile.ml b/src/odoc/compile.ml index 7a626a143f..e81371baaf 100644 --- a/src/odoc/compile.ml +++ b/src/odoc/compile.ml @@ -121,19 +121,19 @@ let resolve_imports resolver imports = imports (** Raises warnings and errors. *) -let resolve_and_substitute ~resolver ~make_root ~hidden +let resolve_and_substitute ~resolver ~make_root ~hidden ~suppress_warnings (parent : Paths.Identifier.ContainerPage.t option) input_file input_type = let filename = Fs.File.to_string input_file in let unit = match input_type with | `Cmti -> - Odoc_loader.read_cmti ~make_root ~parent ~filename + Odoc_loader.read_cmti ~make_root ~parent ~filename ~suppress_warnings |> Error.raise_errors_and_warnings | `Cmt -> - Odoc_loader.read_cmt ~make_root ~parent ~filename + Odoc_loader.read_cmt ~make_root ~parent ~filename ~suppress_warnings |> Error.raise_errors_and_warnings | `Cmi -> - Odoc_loader.read_cmi ~make_root ~parent ~filename + Odoc_loader.read_cmi ~make_root ~parent ~filename ~suppress_warnings |> Error.raise_errors_and_warnings in let unit = { unit with hidden = hidden || unit.hidden } in @@ -246,7 +246,7 @@ let mld ~parent_id ~parents_children ~output ~children ~warnings_options input = >>= fun id -> Ok (id :> Paths.Identifier.Page.t)) >>= fun id -> let resolve content frontmatter = - let zero_heading = Comment.find_zero_heading content in + let zero_heading = Comment.find_zero_heading content.Comment.elements in if (not (is_index_page id)) && has_children_order frontmatter then Error.raise_warning (Error.filename_only "Non-index page cannot specify @children_order." @@ -352,8 +352,9 @@ let compile ~resolver ~hidden ~cli_spec ~warnings_options input = in let result = Error.catch_errors_and_warnings (fun () -> - resolve_and_substitute ~resolver ~make_root ~hidden parent_id input - input_type) + resolve_and_substitute ~resolver ~make_root ~hidden + ~suppress_warnings:warnings_options.suppress_warnings parent_id + input input_type) in (* Extract warnings to write them into the output file *) let _, warnings = Error.unpack_warnings result in diff --git a/src/odoc/odoc_link.ml b/src/odoc/odoc_link.ml index 894cb25a8d..9c27b4a5e1 100644 --- a/src/odoc/odoc_link.ml +++ b/src/odoc/odoc_link.ml @@ -34,7 +34,14 @@ let content_for_hidden_modules = `Word "hidden."; ] in - [ Comment (`Docs [ with_loc @@ `Paragraph (List.map with_loc sentence) ]) ] + [ + Comment + (`Docs + { + elements = [ with_loc @@ `Paragraph (List.map with_loc sentence) ]; + suppress_warnings = true; + }); + ] let link_unit ~resolver ~filename m = let open Odoc_model in @@ -49,7 +56,7 @@ let link_unit ~resolver ~filename m = items = content_for_hidden_modules; compiled = false; removed = []; - doc = []; + doc = { elements = []; suppress_warnings = false }; }; expansion = None; } diff --git a/src/odoc/url.ml b/src/odoc/url.ml index 6b60874e94..01b71286c5 100644 --- a/src/odoc/url.ml +++ b/src/odoc/url.ml @@ -7,7 +7,13 @@ let resolve url_to_string directories reference = in let reference = let open Odoc_model in - let warnings_options = { Error.warn_error = true; print_warnings = true } in + let warnings_options = + { + Error.warn_error = true; + print_warnings = true; + suppress_warnings = false; + } + in Semantics.parse_reference reference |> Error.handle_errors_and_warnings ~warnings_options in diff --git a/src/search/text.ml b/src/search/text.ml index 189c72dcd8..6aef8bf37e 100644 --- a/src/search/text.ml +++ b/src/search/text.ml @@ -42,7 +42,7 @@ module Of_comments = struct let get_value x = x.Odoc_model.Location_.value let rec string_of_doc (doc : Odoc_model.Comment.docs) = - doc |> List.map get_value + doc.elements |> List.map get_value |> List.map s_of_block_element |> String.concat "\n" diff --git a/src/xref2/compile.ml b/src/xref2/compile.ml index 140ba42188..60baa97257 100644 --- a/src/xref2/compile.ml +++ b/src/xref2/compile.ml @@ -253,7 +253,11 @@ and signature_items : Env.t -> Id.Signature.t -> Signature.item list -> _ = Component.Delayed.( put (fun () -> Component.Of_Lang.(module_ (empty ()) m))) in - Env.add_module (m.id :> Paths.Identifier.Path.Module.t) ty [] env + Env.add_module + (m.id :> Paths.Identifier.Path.Module.t) + ty + { elements = []; suppress_warnings = false } + env in let env = match r with diff --git a/src/xref2/component.ml b/src/xref2/component.ml index 9f08ccbd16..3909ee4cfe 100644 --- a/src/xref2/component.ml +++ b/src/xref2/component.ml @@ -456,7 +456,10 @@ and CComment : sig | `Media of Odoc_model.Comment.media_href * Odoc_model.Comment.media * string ] - type docs = block_element Odoc_model.Comment.with_location list + type docs = { + elements : block_element Odoc_model.Comment.with_location list; + suppress_warnings : bool; + } type docs_or_stop = [ `Docs of docs | `Stop ] end = @@ -2704,7 +2707,11 @@ module Of_Lang = struct | { value = `Tag _ | `Media _; _ } 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 ident_map d = + { + elements = List.map (block_element ident_map) d.elements; + suppress_warnings = d.suppress_warnings; + } and docs_or_stop ident_map = function | `Docs d -> `Docs (docs ident_map d) @@ -2714,7 +2721,7 @@ end let module_of_functor_argument (arg : FunctorParameter.parameter) = { Module.source_loc = None; - doc = []; + doc = { elements = []; suppress_warnings = false }; type_ = ModuleType arg.expr; canonical = None; hidden = false; @@ -2723,5 +2730,6 @@ let module_of_functor_argument (arg : FunctorParameter.parameter) = (** This is equivalent to {!Lang.extract_signature_doc}. *) let extract_signature_doc (s : Signature.t) = match (s.doc, s.items) with - | [], Include { expansion_; status = `Inline; _ } :: _ -> expansion_.doc + | { elements = []; _ }, Include { expansion_; status = `Inline; _ } :: _ -> + expansion_.doc | doc, _ -> doc diff --git a/src/xref2/component.mli b/src/xref2/component.mli index 5e009dc2d6..a8a3050a10 100644 --- a/src/xref2/component.mli +++ b/src/xref2/component.mli @@ -433,7 +433,10 @@ and CComment : sig | `Media of Odoc_model.Comment.media_href * Odoc_model.Comment.media * string ] - type docs = block_element Odoc_model.Comment.with_location list + type docs = { + elements : block_element Odoc_model.Comment.with_location list; + suppress_warnings : bool; + } type docs_or_stop = [ `Docs of docs | `Stop ] end diff --git a/src/xref2/env.ml b/src/xref2/env.ml index 87ae379795..0bff1246a1 100644 --- a/src/xref2/env.ml +++ b/src/xref2/env.ml @@ -273,7 +273,7 @@ let add_docs (docs : Comment.docs) env = let label = Ident.Of_Identifier.label id in add_label id { Component.Label.attrs; label; text; location } env | _ -> env) - env docs + env docs.elements let add_comment (com : Comment.docs_or_stop) env = match com with `Docs doc -> add_docs doc env | `Stop -> env @@ -289,7 +289,7 @@ let add_cdocs p (docs : Component.CComment.docs) env = in add_label label h env | _ -> env) - env docs + env docs.elements let add_module identifier m docs env = let env' = add_to_elts Kind_Module identifier (`Module (identifier, m)) env in @@ -373,7 +373,7 @@ let module_of_unit : Lang.Compilation_unit.t -> Component.Module.t = { id; source_loc = None; - doc = []; + doc = { elements = []; suppress_warnings = false }; type_ = ModuleType (Signature s); canonical = unit.canonical; hidden = unit.hidden; @@ -387,11 +387,16 @@ let module_of_unit : Lang.Compilation_unit.t -> Component.Module.t = { id; source_loc = None; - doc = []; + doc = { elements = []; suppress_warnings = false }; type_ = ModuleType (Signature - { items = []; compiled = true; removed = []; doc = [] }); + { + items = []; + compiled = true; + removed = []; + doc = { elements = []; suppress_warnings = false }; + }); canonical = unit.canonical; hidden = unit.hidden; } @@ -644,7 +649,13 @@ let lookup_fragment_root env = let mk_functor_parameter module_type = let type_ = Component.Module.ModuleType module_type in Component.Module. - { source_loc = None; doc = []; type_; canonical = None; hidden = false } + { + source_loc = None; + doc = { elements = []; suppress_warnings = false }; + type_; + canonical = None; + hidden = false; + } let add_functor_parameter : Lang.FunctorParameter.t -> t -> t = fun p t -> @@ -656,7 +667,10 @@ let add_functor_parameter : Lang.FunctorParameter.t -> t -> t = let open Component.Of_Lang in mk_functor_parameter (module_type_expr (empty ()) n.expr) in - add_module id (Component.Delayed.put_val m) [] t + add_module id + (Component.Delayed.put_val m) + { elements = []; suppress_warnings = false } + t let add_functor_args' : Paths.Identifier.Signature.t -> Component.ModuleType.expr -> t -> t = diff --git a/src/xref2/find.ml b/src/xref2/find.ml index 7aabd3e1a1..92ad35fb18 100644 --- a/src/xref2/find.ml +++ b/src/xref2/find.ml @@ -271,7 +271,7 @@ let any_in_sig sg name = | Some r -> Some (`In_type (N.typed_type id, typ, r)) | None -> None) | TypExt typext -> any_in_typext typext name - | Comment (`Docs d) -> any_in_comment d (LabelName.make_std name) + | Comment (`Docs d) -> any_in_comment d.elements (LabelName.make_std name) | _ -> None) let signature_in_sig sg name = @@ -303,7 +303,7 @@ let value_in_sig sg name = let label_in_sig sg name = filter_in_sig sg (function - | Signature.Comment (`Docs d) -> any_in_comment d name + | Signature.Comment (`Docs d) -> any_in_comment d.elements name | _ -> None) let exception_in_sig sg name = diff --git a/src/xref2/lang_of.ml b/src/xref2/lang_of.ml index db8e0f304a..693c6d7ce7 100644 --- a/src/xref2/lang_of.ml +++ b/src/xref2/lang_of.ml @@ -1092,7 +1092,12 @@ and docs : Identifier.LabelParent.t -> Component.CComment.docs -> Odoc_model.Comment.docs = - fun parent ds -> List.rev_map (fun d -> block_element parent d) ds |> List.rev + fun parent ds -> + { + elements = + List.rev_map (fun d -> block_element parent d) ds.elements |> List.rev; + suppress_warnings = ds.suppress_warnings; + } and docs_or_stop parent (d : Component.CComment.docs_or_stop) = match d with `Docs d -> `Docs (docs parent d) | `Stop -> `Stop diff --git a/src/xref2/link.ml b/src/xref2/link.ml index 6684315665..cc42c4f218 100644 --- a/src/xref2/link.ml +++ b/src/xref2/link.ml @@ -7,13 +7,23 @@ module Opt = struct let map f = function Some x -> Some (f x) | None -> None end +(* omg. Our current warning system is spread on different system. Hence this + atrocity. *) +let maybe_suppress suppress_warnings = + if suppress_warnings then fun f -> + Lookup_failures.catch_failures ~filename:"" (fun () -> + Error.catch_warnings f |> fun x -> + Error.unpack_warnings x |> fst |> Error.unpack_warnings |> fst) + |> Error.unpack_warnings |> fst + else fun f -> f () |> Error.raise_warnings + let source_loc env id loc = let id = (id :> Id.NonSrc.t) in match loc with Some _ as loc -> loc | None -> Shape_tools.lookup_def env id (** Equivalent to {!Comment.synopsis}. *) let synopsis_from_comment (docs : Component.CComment.docs) = - match docs with + match docs.elements with | ({ value = #Comment.nestable_block_element; _ } as e) :: _ -> (* Only the first element is considered. *) Comment.synopsis [ e ] @@ -222,13 +232,20 @@ and module_path : Env.t -> Paths.Path.Module.t -> Paths.Path.Module.t = p) let rec comment_inline_element : - loc:_ -> Env.t -> Comment.inline_element -> Comment.inline_element = - fun ~loc:_ env x -> + loc:_ -> Env.t -> bool -> Comment.inline_element -> Comment.inline_element = + fun ~loc:_ env suppress_warnings x -> match x with | `Styled (s, ls) -> - `Styled (s, List.map (with_location (comment_inline_element env)) ls) + `Styled + ( s, + List.map + (with_location (comment_inline_element env suppress_warnings)) + ls ) | `Reference (r, content) as orig -> ( - match Ref_tools.resolve_reference env r |> Error.raise_warnings with + match + maybe_suppress suppress_warnings (fun () -> + Ref_tools.resolve_reference env r) + with | Ok (ref_, c) -> let content = (* In case of labels, use the heading text as reference text if @@ -240,34 +257,39 @@ let rec comment_inline_element : in `Reference (`Resolved ref_, content) | Error e -> - Errors.report ~what:(`Reference r) ~tools_error:(`Reference e) - `Resolve; + if not suppress_warnings then + Errors.report ~what:(`Reference r) ~tools_error:(`Reference e) + `Resolve; orig) | y -> y -and paragraph env elts = - List.map (with_location (comment_inline_element env)) elts +and paragraph env suppress_warnings elts = + List.map (with_location (comment_inline_element env suppress_warnings)) elts -and resolve_external_synopsis env synopsis = +and resolve_external_synopsis env suppress_warnings synopsis = let env = Env.inherit_resolver env in - paragraph env synopsis + paragraph env suppress_warnings synopsis -and comment_nestable_block_element env parent ~loc:_ +and comment_nestable_block_element env suppress_warnings parent ~loc:_ (x : Comment.nestable_block_element) = match x with - | `Paragraph elts -> `Paragraph (paragraph env elts) + | `Paragraph elts -> `Paragraph (paragraph env suppress_warnings elts) | (`Code_block _ | `Math_block _ | `Verbatim _) as x -> x | `List (x, ys) -> `List ( x, - List.rev_map (comment_nestable_block_element_list env parent) ys + List.rev_map + (comment_nestable_block_element_list env suppress_warnings parent) + ys |> List.rev ) | `Table { data; align } -> let data = let map f x = List.rev_map f x |> List.rev in map (map (fun (cell, cell_type) -> - (comment_nestable_block_element_list env parent cell, cell_type))) + ( comment_nestable_block_element_list env suppress_warnings + parent cell, + cell_type ))) data in `Table { Comment.data; align } @@ -276,81 +298,115 @@ and comment_nestable_block_element env parent ~loc:_ List.rev_map (fun (r : Comment.module_reference) -> match - Ref_tools.resolve_module_reference env r.module_reference - |> Error.raise_warnings + maybe_suppress suppress_warnings (fun () -> + Ref_tools.resolve_module_reference env r.module_reference) with | Ok (r, _, m) -> let module_synopsis = Opt.map - (resolve_external_synopsis env) + (resolve_external_synopsis env suppress_warnings) (synopsis_of_module env m) in { Comment.module_reference = `Resolved r; module_synopsis } | Error e -> - Errors.report - ~what:(`Reference (r.module_reference :> Paths.Reference.t)) - ~tools_error:(`Reference e) `Resolve; + if not suppress_warnings then + Errors.report + ~what:(`Reference (r.module_reference :> Paths.Reference.t)) + ~tools_error:(`Reference e) `Resolve; r) refs |> List.rev in `Modules refs | `Media (`Reference r, m, content) as orig -> ( - match Ref_tools.resolve_asset_reference env r |> Error.raise_warnings with + match + maybe_suppress suppress_warnings (fun () -> + Ref_tools.resolve_asset_reference env r) + with | Ok x -> `Media (`Reference (`Resolved x), m, content) | Error e -> - Errors.report - ~what:(`Reference (r :> Paths.Reference.t)) - ~tools_error:(`Reference e) `Resolve; + if not suppress_warnings then + Errors.report + ~what:(`Reference (r :> Paths.Reference.t)) + ~tools_error:(`Reference e) `Resolve; orig) | `Media _ as orig -> orig -and comment_nestable_block_element_list env parent +and comment_nestable_block_element_list env suppress_warnings parent (xs : Comment.nestable_block_element Comment.with_location list) = - List.rev_map (with_location (comment_nestable_block_element env parent)) xs + List.rev_map + (with_location + (comment_nestable_block_element env suppress_warnings parent)) + xs |> List.rev -and comment_tag env parent ~loc:_ (x : Comment.tag) = +and comment_tag env suppress_warnings parent ~loc:_ (x : Comment.tag) = match x with | `Deprecated content -> - `Deprecated (comment_nestable_block_element_list env parent content) + `Deprecated + (comment_nestable_block_element_list env suppress_warnings parent + content) | `Param (name, content) -> - `Param (name, comment_nestable_block_element_list env parent content) + `Param + ( name, + comment_nestable_block_element_list env suppress_warnings parent + content ) | `Raise ((`Reference (r, reference_content) as orig), content) -> ( - match Ref_tools.resolve_reference env r |> Error.raise_warnings with + match + maybe_suppress suppress_warnings (fun () -> + Ref_tools.resolve_reference env r) + with | Ok (x, _) -> `Raise ( `Reference (`Resolved x, reference_content), - comment_nestable_block_element_list env parent content ) + comment_nestable_block_element_list env suppress_warnings parent + content ) | Error e -> - Errors.report ~what:(`Reference r) ~tools_error:(`Reference e) - `Resolve; - `Raise (orig, comment_nestable_block_element_list env parent content)) + if not suppress_warnings then + Errors.report ~what:(`Reference r) ~tools_error:(`Reference e) + `Resolve; + `Raise + ( orig, + comment_nestable_block_element_list env suppress_warnings parent + content )) | `Raise ((`Code_span _ as orig), content) -> - `Raise (orig, comment_nestable_block_element_list env parent content) + `Raise + ( orig, + comment_nestable_block_element_list env suppress_warnings parent + content ) | `Return content -> - `Return (comment_nestable_block_element_list env parent content) + `Return + (comment_nestable_block_element_list env suppress_warnings parent + content) | `See (kind, target, content) -> - `See (kind, target, comment_nestable_block_element_list env parent content) + `See + ( kind, + target, + comment_nestable_block_element_list env suppress_warnings parent + content ) | `Before (version, content) -> - `Before (version, comment_nestable_block_element_list env parent content) + `Before + ( version, + comment_nestable_block_element_list env suppress_warnings parent + content ) | `Author _ | `Since _ | `Alert _ | `Version _ -> x (* only contain primitives *) -and comment_block_element env parent ~loc (x : Comment.block_element) = +and comment_block_element env suppress_warnings parent ~loc + (x : Comment.block_element) = match x with | #Comment.nestable_block_element as x -> - (comment_nestable_block_element env parent ~loc x + (comment_nestable_block_element env suppress_warnings parent ~loc x :> Comment.block_element) | `Heading (attrs, label, elems) -> - let cie = comment_inline_element env in + let cie = comment_inline_element env suppress_warnings 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; `Heading h - | `Tag t -> `Tag (comment_tag env parent ~loc t) + | `Tag t -> `Tag (comment_tag env suppress_warnings parent ~loc t) and with_location : type a. @@ -361,10 +417,16 @@ and with_location : { value; location = loc } and comment_docs env parent d = - List.rev_map - (with_location (comment_block_element env (parent :> Id.LabelParent.t))) - d - |> List.rev + { + Comment.elements = + List.rev_map + (with_location + (comment_block_element env d.Comment.suppress_warnings + (parent :> Id.LabelParent.t))) + d.Comment.elements + |> List.rev; + suppress_warnings = d.suppress_warnings; + } and comment env parent = function | `Stop -> `Stop diff --git a/src/xref2/ref_tools.ml b/src/xref2/ref_tools.ml index f41da8c2d5..12b919d039 100644 --- a/src/xref2/ref_tools.ml +++ b/src/xref2/ref_tools.ml @@ -402,7 +402,7 @@ module L = struct | _ -> find tl) | [] -> Error (`Find_by_name (`Page, name)) in - find p.Odoc_model.Lang.Page.content + find p.Odoc_model.Lang.Page.content.elements let of_component _env ~parent_ref label = Ok diff --git a/src/xref2/tools.ml b/src/xref2/tools.ml index 77f842d66c..49414ab480 100644 --- a/src/xref2/tools.ml +++ b/src/xref2/tools.ml @@ -1711,7 +1711,7 @@ and expansion_of_module : let sg = (* Override the signature's documentation when the module also has a comment attached. *) - match m.doc with [] -> sg | doc -> { sg with doc } + match m.doc.elements with [] -> sg | _ -> { sg with doc = m.doc } in Ok (Signature sg) | Functor _ as f -> Ok f diff --git a/test/frontmatter/frontmatter.t/run.t b/test/frontmatter/frontmatter.t/run.t index e9a4bffc86..d3a9cab135 100644 --- a/test/frontmatter/frontmatter.t/run.t +++ b/test/frontmatter/frontmatter.t/run.t @@ -36,7 +36,7 @@ When there is one frontmatter, it is extracted from the content: "toc_status": "None", "order_category": "None" } - $ odoc_print page-one_frontmatter.odoc | jq '.content' + $ odoc_print page-one_frontmatter.odoc | jq '.content.elements' [ { "`Heading": [ @@ -91,7 +91,7 @@ When there is more than one children order, we raise a warning and keep only the "toc_status": "None", "order_category": "None" } - $ odoc_print page-two_frontmatters.odoc | jq '.content' + $ odoc_print page-two_frontmatters.odoc | jq '.content.elements' [ { "`Heading": [ diff --git a/test/integration/dune b/test/integration/dune index 0d27fb102d..846fe0e57c 100644 --- a/test/integration/dune +++ b/test/integration/dune @@ -1,6 +1,12 @@ +(env + (_ + (binaries + (../odoc_print/odoc_print.exe as odoc_print)))) + (cram (deps - (package odoc))) + (package odoc) + %{bin:odoc_print})) (cram (applies_to json_expansion_with_sources) diff --git a/test/integration/suppress_warnings.t/main.mli b/test/integration/suppress_warnings.t/main.mli new file mode 100644 index 0000000000..24646d45ea --- /dev/null +++ b/test/integration/suppress_warnings.t/main.mli @@ -0,0 +1,3 @@ +include Module_with_errors.S + + diff --git a/test/integration/suppress_warnings.t/module_with_errors.mli b/test/integration/suppress_warnings.t/module_with_errors.mli new file mode 100644 index 0000000000..2f76e20161 --- /dev/null +++ b/test/integration/suppress_warnings.t/module_with_errors.mli @@ -0,0 +1,9 @@ +module type S = sig + (** {1:t section} *) + + type t + + val here_is_the_problem : t + (** {!t} *) +end + diff --git a/test/integration/suppress_warnings.t/run.t b/test/integration/suppress_warnings.t/run.t new file mode 100644 index 0000000000..35cbbac5e6 --- /dev/null +++ b/test/integration/suppress_warnings.t/run.t @@ -0,0 +1,20 @@ + $ ocamlc -c -bin-annot module_with_errors.mli + $ ocamlc -c -bin-annot main.mli + + $ odoc compile module_with_errors.cmti + $ odoc compile main.cmti -I . + $ odoc link main.odoc + File "module_with_errors.mli", line 7, characters 6-10: + Warning: While resolving the expansion of include at File "main.mli", line 1, character 0 + Reference to 't' is ambiguous. Please specify its kind: section-t, type-t. + $ odoc html-generate -o html main.odocl + $ odoc support-files -o html + + $ odoc compile --suppress-warnings module_with_errors.cmti + $ odoc compile main.cmti -I . + $ odoc link main.odoc + $ odoc html-generate -o html2 main.odocl + $ odoc support-files -o html2 + + + diff --git a/test/model/semantics/test.ml b/test/model/semantics/test.ml index ed784a24c1..26ddd6c0fd 100644 --- a/test/model/semantics/test.ml +++ b/test/model/semantics/test.ml @@ -11,7 +11,7 @@ let parser_output_desc = ( Error.unpack_warnings, Record [ - F ("value", fst, Indirect (fst, Comment_desc.docs)); + F ("value", fst, Indirect (fst, Comment_desc.elements)); F ("warnings", snd, List warning_desc); ] ) diff --git a/test/pages/resolution.t/run.t b/test/pages/resolution.t/run.t index d0a6539edf..9443aaacff 100644 --- a/test/pages/resolution.t/run.t +++ b/test/pages/resolution.t/run.t @@ -27,7 +27,7 @@ If everything has worked to plan, we'll have resolved references for all of the references should be to the correct identifiers - so top1 should be a RootPage, sub1 is a Page, sub2 is a LeafPage, and m1 is a Root. This is the '{!childpage-sub1}' reference - $ odoc_print page-top1.odocl | jq '.content[1]["`Paragraph"][0]["`Reference"][0]' + $ odoc_print page-top1.odocl | jq '.content.elements[1]["`Paragraph"][0]["`Reference"][0]' { "`Resolved": { "`Identifier": { @@ -47,7 +47,7 @@ This is the '{!childpage-sub1}' reference } This is the '{!childpage:sub2}' reference - $ odoc_print page-top1.odocl | jq '.content[1]["`Paragraph"][2]["`Reference"][0]' + $ odoc_print page-top1.odocl | jq '.content.elements[1]["`Paragraph"][2]["`Reference"][0]' { "`Resolved": { "`Identifier": { @@ -67,7 +67,7 @@ This is the '{!childpage:sub2}' reference } This is the '{!childmodule:M1}' reference - $ odoc_print page-sub1.odocl | jq '.content[1]["`Paragraph"][0]["`Reference"][0]' + $ odoc_print page-sub1.odocl | jq '.content.elements[1]["`Paragraph"][0]["`Reference"][0]' { "`Resolved": { "`Identifier": { diff --git a/test/xref2/canonical_nested.t/run.t b/test/xref2/canonical_nested.t/run.t index 27b6f6ac77..948c02b0f7 100644 --- a/test/xref2/canonical_nested.t/run.t +++ b/test/xref2/canonical_nested.t/run.t @@ -55,7 +55,10 @@ unresolved in the paths though: ] }, "source_loc": "None", - "doc": [], + "doc": { + "elements": [], + "suppress_warnings": "false" + }, "type_": { "Alias": [ { @@ -121,7 +124,10 @@ unresolved in the paths though: ] }, "source_loc": "None", - "doc": [], + "doc": { + "elements": [], + "suppress_warnings": "false" + }, "type_": { "Alias": [ { @@ -186,7 +192,10 @@ unresolved in the paths though: ] }, "source_loc": "None", - "doc": [], + "doc": { + "elements": [], + "suppress_warnings": "false" + }, "type_": { "Alias": [ { @@ -278,7 +287,10 @@ unresolved in the paths though: ] }, "source_loc": "None", - "doc": [], + "doc": { + "elements": [], + "suppress_warnings": "false" + }, "equation": { "params": [], "private_": "false", @@ -291,7 +303,10 @@ unresolved in the paths though: } ], "compiled": "true", - "doc": [] + "doc": { + "elements": [], + "suppress_warnings": "false" + } } } } diff --git a/test/xref2/classes.t/run.t b/test/xref2/classes.t/run.t index f83eb9bec8..ecf0c8dc65 100644 --- a/test/xref2/classes.t/run.t +++ b/test/xref2/classes.t/run.t @@ -27,7 +27,10 @@ resolve correctly. All of the 'Class' json objects should contain ] }, "source_loc": "None", - "doc": [], + "doc": { + "elements": [], + "suppress_warnings": "false" + }, "type_": { "Class": [ { @@ -64,7 +67,10 @@ resolve correctly. All of the 'Class' json objects should contain ] }, "source_loc": "None", - "doc": [], + "doc": { + "elements": [], + "suppress_warnings": "false" + }, "type_": { "Class": [ { diff --git a/test/xref2/cross_references.t/run.t b/test/xref2/cross_references.t/run.t index c72f0ddf1e..2e4157b746 100644 --- a/test/xref2/cross_references.t/run.t +++ b/test/xref2/cross_references.t/run.t @@ -11,7 +11,7 @@ Two modules that reference each other: Check that references are resolved: - $ odoc_print a.odocl | jq '.content.Module.items[0].Type[1].doc[0]' + $ odoc_print a.odocl | jq '.content.Module.items[0].Type[1].doc.elements[0]' { "`Paragraph": [ { @@ -38,7 +38,7 @@ Check that references are resolved: } ] } - $ odoc_print b.odocl | jq '.content.Module.items[0].Type[1].doc[0]' + $ odoc_print b.odocl | jq '.content.Module.items[0].Type[1].doc.elements[0]' { "`Paragraph": [ { diff --git a/test/xref2/deep_substitution.t/run.t b/test/xref2/deep_substitution.t/run.t index 3431498bac..0e8af7ed1e 100644 --- a/test/xref2/deep_substitution.t/run.t +++ b/test/xref2/deep_substitution.t/run.t @@ -38,7 +38,10 @@ its RHS correctly replaced with an `int` ] }, "source_loc": "None", - "doc": [], + "doc": { + "elements": [], + "suppress_warnings": "false" + }, "equation": { "params": [], "private_": "false", diff --git a/test/xref2/hidden_modules.t/run.t b/test/xref2/hidden_modules.t/run.t index ecfa1690e1..bf02f09eeb 100644 --- a/test/xref2/hidden_modules.t/run.t +++ b/test/xref2/hidden_modules.t/run.t @@ -101,7 +101,10 @@ There should be an expansion on `NotHidden` ] }, "source_loc": "None", - "doc": [], + "doc": { + "elements": [], + "suppress_warnings": "false" + }, "equation": { "params": [], "private_": "false", @@ -114,7 +117,10 @@ There should be an expansion on `NotHidden` } ], "compiled": "true", - "doc": [] + "doc": { + "elements": [], + "suppress_warnings": "false" + } } } } @@ -128,7 +134,7 @@ There should be an expansion on `NotHidden` ] }, "source_loc": "None", - "doc": [], + "doc": { "elements": [], "suppress_warnings": "false" }, "type_": { "Constr": [ { diff --git a/test/xref2/labels/page_labels.t/run.t b/test/xref2/labels/page_labels.t/run.t index 784fa74ea6..fad2ff5944 100644 --- a/test/xref2/labels/page_labels.t/run.t +++ b/test/xref2/labels/page_labels.t/run.t @@ -1,6 +1,6 @@ $ odoc compile page.mld $ odoc link page-page.odoc - $ odoc_print page-page.odocl | jq '.content[1]["`Paragraph"][0]["`Reference"][0]' + $ odoc_print page-page.odocl | jq '.content.elements[1]["`Paragraph"][0]["`Reference"][0]' { "`Resolved": { "`Identifier": { diff --git a/test/xref2/lib/common.cppo.ml b/test/xref2/lib/common.cppo.ml index 3a7822761d..9f4237c9d7 100644 --- a/test/xref2/lib/common.cppo.ml +++ b/test/xref2/lib/common.cppo.ml @@ -70,7 +70,7 @@ let root_pp fmt (_ : Odoc_model.Root.t) = Format.fprintf fmt "Common.root" let model_of_string str = let cmti = cmti_of_string str in - Odoc_loader__Cmti.read_interface (Some parent) "Root" cmti + Odoc_loader__Cmti.read_interface (Some parent) "Root" false cmti let model_of_string_impl str = #if OCAML_VERSION < (4,13,0) @@ -78,7 +78,7 @@ let model_of_string_impl str = #else let cmt = (cmt_of_string str).structure in #endif - Odoc_loader__Cmt.read_implementation (Some parent) "Root" cmt + Odoc_loader__Cmt.read_implementation (Some parent) "Root" false cmt let signature_of_mli_string str = Odoc_xref2.Ident.reset (); @@ -650,7 +650,7 @@ let mkresolver () = ) ~open_modules:[] let warnings_options = - { Odoc_model.Error.warn_error = false; print_warnings = true } + { Odoc_model.Error.warn_error = false; print_warnings = true; suppress_warnings = false } let handle_warnings ww = match Odoc_model.Error.handle_warnings ~warnings_options ww with diff --git a/test/xref2/module_type_alias.t/run.t b/test/xref2/module_type_alias.t/run.t index b9f44712d6..2bf24928a3 100644 --- a/test/xref2/module_type_alias.t/run.t +++ b/test/xref2/module_type_alias.t/run.t @@ -23,92 +23,95 @@ as they are both referencing items that won't be expanded. $ odoc_print test.odocl | jq ".content.Module.items[2]" { "Comment": { - "`Docs": [ - { - "`Paragraph": [ - { - "`Reference": [ - { - "`Resolved": { - "`AliasModuleType": [ - { - "`Identifier": { - "`ModuleType": [ - { - "`Root": [ - "None", - "Test" - ] - }, - "A" - ] + "`Docs": { + "elements": [ + { + "`Paragraph": [ + { + "`Reference": [ + { + "`Resolved": { + "`AliasModuleType": [ + { + "`Identifier": { + "`ModuleType": [ + { + "`Root": [ + "None", + "Test" + ] + }, + "A" + ] + } + }, + { + "`Identifier": { + "`ModuleType": [ + { + "`Root": [ + "None", + "Test" + ] + }, + "B" + ] + } } - }, - { - "`Identifier": { - "`ModuleType": [ + ] + } + }, + [] + ] + }, + "`Space", + { + "`Reference": [ + { + "`Resolved": { + "`Type": [ + { + "`AliasModuleType": [ { - "`Root": [ - "None", - "Test" - ] + "`Identifier": { + "`ModuleType": [ + { + "`Root": [ + "None", + "Test" + ] + }, + "A" + ] + } }, - "B" - ] - } - } - ] - } - }, - [] - ] - }, - "`Space", - { - "`Reference": [ - { - "`Resolved": { - "`Type": [ - { - "`AliasModuleType": [ - { - "`Identifier": { - "`ModuleType": [ - { - "`Root": [ - "None", - "Test" - ] - }, - "A" - ] - } - }, - { - "`Identifier": { - "`ModuleType": [ - { - "`Root": [ - "None", - "Test" - ] - }, - "B" - ] + { + "`Identifier": { + "`ModuleType": [ + { + "`Root": [ + "None", + "Test" + ] + }, + "B" + ] + } } - } - ] - }, - "t" - ] - } - }, - [] - ] - } - ] - } - ] + ] + }, + "t" + ] + } + }, + [] + ] + } + ] + } + ], + "suppress_warnings": "false" + } } } From b9aeeaf36a1e7c908ebdf97c44da520d7ffa778e Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Thu, 28 Nov 2024 16:15:41 +0000 Subject: [PATCH 2/8] Make driver suppress warnings for unselected packages --- src/driver/compile.ml | 3 ++- src/driver/odoc.ml | 3 ++- src/driver/odoc.mli | 1 + 3 files changed, 5 insertions(+), 2 deletions(-) diff --git a/src/driver/compile.ml b/src/driver/compile.ml index 482fd4a887..29c38f7886 100644 --- a/src/driver/compile.ml +++ b/src/driver/compile.ml @@ -143,6 +143,7 @@ let compile ?partial ~partial_dir (all : Odoc_unit.t list) = in Odoc.compile ~output_dir:unit.output_dir ~input_file:unit.input_file ~includes + ~suppress_warnings:(not unit.enable_warnings) ~parent_id:unit.parent_id; Atomic.incr Stats.stats.compiled_units; @@ -191,7 +192,7 @@ let compile ?partial ~partial_dir (all : Odoc_unit.t list) = | `Mld -> let includes = Fpath.Set.empty in Odoc.compile ~output_dir:unit.output_dir ~input_file:unit.input_file - ~includes ~parent_id:unit.parent_id; + ~includes ~suppress_warnings:false ~parent_id:unit.parent_id; Atomic.incr Stats.stats.compiled_mlds; Ok [ unit ] | `Md -> diff --git a/src/driver/odoc.ml b/src/driver/odoc.ml index 05783baa3c..c719f04d05 100644 --- a/src/driver/odoc.ml +++ b/src/driver/odoc.ml @@ -36,7 +36,7 @@ let compile_deps f = | [ (_, digest) ], deps -> Ok { digest; deps } | _ -> Error (`Msg "odd") -let compile ~output_dir ~input_file:file ~includes ~parent_id = +let compile ~output_dir ~input_file:file ~includes ~suppress_warnings ~parent_id = let open Cmd in let includes = Fpath.Set.fold @@ -52,6 +52,7 @@ let compile ~output_dir ~input_file:file ~includes ~parent_id = %% includes % "--enable-missing-root-warning" in let cmd = cmd % "--parent-id" % Id.to_string parent_id in + let cmd = if suppress_warnings then cmd % "--suppress-warnings" else cmd in let desc = Printf.sprintf "Compiling %s" (Fpath.to_string file) in ignore @@ Cmd_outputs.submit diff --git a/src/driver/odoc.mli b/src/driver/odoc.mli index 11e769b9a9..127d83db9c 100644 --- a/src/driver/odoc.mli +++ b/src/driver/odoc.mli @@ -24,6 +24,7 @@ val compile : output_dir:Fpath.t -> input_file:Fpath.t -> includes:Fpath.set -> + suppress_warnings:bool -> parent_id:Id.t -> unit val compile_md : From 269661fdf1427f316c6e1e4345982681e615467d Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Fri, 29 Nov 2024 17:12:07 +0000 Subject: [PATCH 3/8] Fix errors in odoc's docs --- doc/examples/resolution.mli | 1 - doc/odoc.mld | 4 +--- dune | 5 +++++ odoc-config.sexp | 2 ++ src/model/paths_types.ml | 6 +++--- src/ocamlary/ocamlary.mli | 7 ------- src/search/html.mli | 2 +- src/search/odoc_html_frontend.mli | 2 +- src/utils/odoc_list.ml | 2 +- test/generators/html/Ocamlary.html | 8 -------- test/generators/latex/Ocamlary.tex | 5 ----- test/generators/man/Ocamlary.3o | 15 --------------- 12 files changed, 14 insertions(+), 45 deletions(-) create mode 100644 odoc-config.sexp diff --git a/doc/examples/resolution.mli b/doc/examples/resolution.mli index 06b30790cb..c84d5e2ee0 100644 --- a/doc/examples/resolution.mli +++ b/doc/examples/resolution.mli @@ -86,7 +86,6 @@ module Hidden : sig type v = T of t - type w = U of u end module References : sig diff --git a/doc/odoc.mld b/doc/odoc.mld index b900b605fa..a4db08d1c5 100644 --- a/doc/odoc.mld +++ b/doc/odoc.mld @@ -58,6 +58,4 @@ The main other pages of this site: - {!page-ocamldoc_differences} outlines differences from OCamldoc. - {!page-dune} shows how to create docs using Dune. - {!page-parent_child_spec} delineates parent/child specifications. -- {!page-interface} describes [odoc]'s public-facing interface and their support guarantees. -- {!page-ocamlary} demonstrates the rendering of most of the OCaml constructs. -- {!page-api_reference} lists [odoc]'s API reference library. +- {!page-interface} describes [odoc]'s public-facing interface and their support guarantees. \ No newline at end of file diff --git a/dune b/dune index 3a7000ca50..7622449207 100644 --- a/dune +++ b/dune @@ -23,3 +23,8 @@ (progn (bash "diff doc/driver.mld doc/driver.mld.corrected >&2 || true") (cat doc/driver-benchmarks.json)))) + +(install + (files odoc-config.sexp) + (section doc) + (package odoc)) diff --git a/odoc-config.sexp b/odoc-config.sexp new file mode 100644 index 0000000000..c6b2ea188f --- /dev/null +++ b/odoc-config.sexp @@ -0,0 +1,2 @@ +(libraries fmt) + diff --git a/src/model/paths_types.ml b/src/model/paths_types.ml index ac0d0cfc18..6b02f75ba3 100644 --- a/src/model/paths_types.ml +++ b/src/model/paths_types.ml @@ -551,9 +551,9 @@ module rec Reference : sig type tag_only_child_module = [ `TChildModule ] type tag_hierarchy = - [ `TRelativePath (** {!identifier/} *) - | `TAbsolutePath (** {!/identifier} *) - | `TCurrentPackage (** {!//identifier} *) ] + [ `TRelativePath (** [{!identifier/}] *) + | `TAbsolutePath (** [{!/identifier}] *) + | `TCurrentPackage (** [{!//identifier}] *) ] (** @canonical Odoc_model.Paths.Reference.tag_hierarchy *) type tag_any = diff --git a/src/ocamlary/ocamlary.mli b/src/ocamlary/ocamlary.mli index f5a8de70bd..e5ba4d1038 100644 --- a/src/ocamlary/ocamlary.mli +++ b/src/ocamlary/ocamlary.mli @@ -1068,10 +1068,3 @@ type new_t = .. type new_t += C module type TypeExtPruned = TypeExt with type t := new_t - -(** {1 Unresolved references} *) - -(** - {!Stdlib.Invalid_argument} - - {!Hashtbl.t} - - {!Set.S.empty} - - {!CollectionModule.InnerModuleA.foo} *) diff --git a/src/search/html.mli b/src/search/html.mli index 32862220b6..0a069e6506 100644 --- a/src/search/html.mli +++ b/src/search/html.mli @@ -9,7 +9,7 @@ val url : Entry.t -> string (** The below is intended for search engine that do not use the Json output but Odoc as a library. Most search engine will use their own representation - instead of {!Entry.t}, and may not want to store the whole HTML in their + instead of {!Odoc_index.Entry.t}, and may not want to store the whole HTML in their database. The following functions help give correct values to store in a search database. *) diff --git a/src/search/odoc_html_frontend.mli b/src/search/odoc_html_frontend.mli index 7e1c135d20..1134225f48 100644 --- a/src/search/odoc_html_frontend.mli +++ b/src/search/odoc_html_frontend.mli @@ -1,6 +1,6 @@ (** This library is intended for search engine that do not use the Json output but Odoc as a library. Most search engine will use their own representation - instead of {!Entry.t}, and may not want to store the whole HTML in their + instead of {!Odoc_index.Entry.t}, and may not want to store the whole HTML in their database. This library contains functions that are useful for the frontend of such search engines. diff --git a/src/utils/odoc_list.ml b/src/utils/odoc_list.ml index a571bb9241..4b2927befe 100644 --- a/src/utils/odoc_list.ml +++ b/src/utils/odoc_list.ml @@ -16,7 +16,7 @@ let rec filter_map acc f = function let filter_map f x = filter_map [] f x -(** @raise [Failure] if the list is empty. *) +(** @raise Failure if the list is empty. *) let rec last = function | [] -> failwith "Odoc_utils.List.last" | [ x ] -> x diff --git a/test/generators/html/Ocamlary.html b/test/generators/html/Ocamlary.html index 00d6c31562..20f88447e8 100644 --- a/test/generators/html/Ocamlary.html +++ b/test/generators/html/Ocamlary.html @@ -71,7 +71,6 @@

Module Ocamlary

  • Aliases again
  • Section title splicing
  • New reference syntax
    • -
  • Unresolved references
    • @@ -2961,13 +2960,6 @@

    -

    - Unresolved references -

    -
    • Stdlib.Invalid_argument
      • -
    • Hashtbl.t
    • Set.S.empty
      • -
    • CollectionModule.InnerModuleA.foo
      • -
    diff --git a/test/generators/latex/Ocamlary.tex b/test/generators/latex/Ocamlary.tex index 3cf7bc5a1e..96aae99f30 100644 --- a/test/generators/latex/Ocamlary.tex +++ b/test/generators/latex/Ocamlary.tex @@ -895,11 +895,6 @@ \subsection{New reference syntax\label{new-reference-syntax}}% \label{Ocamlary-module-type-TypeExtPruned-val-f}\ocamlcodefragment{\ocamltag{keyword}{val} f : \hyperref[Ocamlary-type-new_t]{\ocamlinlinecode{new\_\allowbreak{}t}} \ocamltag{arrow}{$\rightarrow$} unit}\\ \end{ocamlindent}% \ocamlcodefragment{\ocamltag{keyword}{end}}\\ -\subsection{Unresolved references\label{unresolved-references}}% -\begin{itemize}\item{\ocamlinlinecode{Stdlib.\allowbreak{}Invalid\_\allowbreak{}argument}}% -\item{\ocamlinlinecode{Hashtbl.\allowbreak{}t}}% -\item{\ocamlinlinecode{Set.\allowbreak{}S.\allowbreak{}empty}}% -\item{\ocamlinlinecode{CollectionModule.\allowbreak{}InnerModuleA.\allowbreak{}foo}}\end{itemize}% \input{Ocamlary.ModuleWithSignature.tex} \input{Ocamlary.ModuleWithSignatureAlias.tex} diff --git a/test/generators/man/Ocamlary.3o b/test/generators/man/Ocamlary.3o index 1ef3504938..b3babc10d4 100644 --- a/test/generators/man/Ocamlary.3o +++ b/test/generators/man/Ocamlary.3o @@ -1902,18 +1902,3 @@ Here goes: \f[CB]val\fR f : new_t \f[CB]\->\fR unit .br \f[CB]end\fR -.sp -.in 3 -\fB8 Unresolved references\fR -.in -.sp -.fi -\(bu Stdlib\.Invalid_argument -.br -\(bu Hashtbl\.t -.br -\(bu Set\.S\.empty -.br -\(bu CollectionModule\.InnerModuleA\.foo -.nf - From 2aba8dc17a732fb0d22e7bcbfcbdadf4e5860cf2 Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Fri, 29 Nov 2024 17:12:49 +0000 Subject: [PATCH 4/8] Driver: Make pkg_args opaque and use maps --- src/driver/landing_pages.ml | 3 ++- src/driver/odoc_unit.ml | 16 ++++++++++------ src/driver/odoc_unit.mli | 13 +++++++------ src/driver/odoc_units_of.ml | 4 ++-- 4 files changed, 21 insertions(+), 15 deletions(-) diff --git a/src/driver/landing_pages.ml b/src/driver/landing_pages.ml index c07d389b52..ab1881b23e 100644 --- a/src/driver/landing_pages.ml +++ b/src/driver/landing_pages.ml @@ -18,13 +18,14 @@ let make_index ~dirs ?pkg ~rel_dir ?index ~content () = let odoc_file = Fpath.(odoc_dir // rel_dir / "page-index.odoc") in let odocl_file = Fpath.(odocl_dir // rel_dir / "page-index.odocl") in let parent_id = rel_dir |> Odoc.Id.of_fpath in + let pkg_args = Pkg_args.v ~pages ~libs ~odoc_dir ~odocl_dir in Util.with_out_to input_file (fun oc -> fpf (Format.formatter_of_out_channel oc) "%t@?" content) |> Result.get_ok; { output_dir = dirs.odoc_dir; pkgname = None; - pkg_args = { Pkg_args.pages; libs; odoc_dir; odocl_dir }; + pkg_args; parent_id; input_file; odoc_file; diff --git a/src/driver/odoc_unit.ml b/src/driver/odoc_unit.ml index bb47b86dc5..7d3ad65c90 100644 --- a/src/driver/odoc_unit.ml +++ b/src/driver/odoc_unit.ml @@ -2,11 +2,15 @@ module Pkg_args = struct type t = { odoc_dir : Fpath.t; odocl_dir : Fpath.t; - pages : (string * Fpath.t) list; - libs : (string * Fpath.t) list; + pages : Fpath.t Util.StringMap.t; + libs : Fpath.t Util.StringMap.t; } - let map_rel dir = List.map (fun (a, b) -> (a, Fpath.(dir // b))) + let v ~odoc_dir ~odocl_dir ~pages ~libs = + let pages, libs = Util.StringMap.(of_list pages, of_list libs) in + { odoc_dir; odocl_dir; pages; libs } + + let map_rel dir m = Util.StringMap.fold (fun a b acc -> (a, Fpath.(dir // b)) :: acc) m [] let compiled_pages v = map_rel v.odoc_dir v.pages let compiled_libs v = map_rel v.odoc_dir v.libs @@ -21,8 +25,8 @@ module Pkg_args = struct { odoc_dir = v1.odoc_dir; odocl_dir = v1.odocl_dir; - pages = v1.pages @ v2.pages; - libs = v1.libs @ v2.libs; + pages = Util.StringMap.union (fun _ x _ -> Some x) v1.pages v2.pages; + libs = Util.StringMap.union (fun _ x _ -> Some x) v1.libs v2.libs; } let pp fmt x = @@ -33,7 +37,7 @@ module Pkg_args = struct in Format.fprintf fmt "@[odoc_dir: %a@;odocl_dir: %a@;pages: [%a]@;libs: [%a]@]" Fpath.pp - x.odoc_dir Fpath.pp x.odocl_dir sfp_pp x.pages sfp_pp x.libs + x.odoc_dir Fpath.pp x.odocl_dir sfp_pp (Util.StringMap.bindings x.pages) sfp_pp (Util.StringMap.bindings x.libs) end type sidebar = { output_file : Fpath.t; json : bool } diff --git a/src/driver/odoc_unit.mli b/src/driver/odoc_unit.mli index 1f9d505c58..ad99e3fc35 100644 --- a/src/driver/odoc_unit.mli +++ b/src/driver/odoc_unit.mli @@ -1,16 +1,17 @@ module Pkg_args : sig - type t = { - odoc_dir : Fpath.t; - odocl_dir : Fpath.t; - pages : (string * Fpath.t) list; - libs : (string * Fpath.t) list; - } + type t val compiled_pages : t -> (string * Fpath.t) list val compiled_libs : t -> (string * Fpath.t) list val linked_pages : t -> (string * Fpath.t) list val linked_libs : t -> (string * Fpath.t) list + val v : odoc_dir:Fpath.t -> + odocl_dir:Fpath.t -> + pages:(string * Fpath.t) list -> + libs:(string * Fpath.t) list -> + t + val combine : t -> t -> t val pp : t Fmt.t diff --git a/src/driver/odoc_units_of.ml b/src/driver/odoc_units_of.ml index df21fada32..9644db249e 100644 --- a/src/driver/odoc_units_of.ml +++ b/src/driver/odoc_units_of.ml @@ -46,7 +46,7 @@ let packages ~dirs ~extra_paths ~remap (pkgs : Packages.t list) : t list = let base_args pkg lib_deps : Pkg_args.t = let own_page = dash_p pkg.Packages.name (doc_dir pkg) in let own_libs = List.concat_map dash_l (Util.StringSet.to_list lib_deps) in - { pages = [ own_page ]; libs = own_libs; odoc_dir; odocl_dir } + Pkg_args.v ~pages:[ own_page ] ~libs:own_libs ~odoc_dir ~odocl_dir in let args_of_config config : Pkg_args.t = let { Global_config.deps = { packages; libraries } } = config in @@ -61,7 +61,7 @@ let packages ~dirs ~extra_paths ~remap (pkgs : Packages.t list) : t list = packages in let libs_rel = List.concat_map dash_l libraries in - { pages = pages_rel; libs = libs_rel; odoc_dir; odocl_dir } + Pkg_args.v ~pages:pages_rel ~libs:libs_rel ~odoc_dir ~odocl_dir in let args_of = let cache = Hashtbl.create 10 in From 45877964d60bc3cd800812988ca1e83ef05d4679 Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Fri, 29 Nov 2024 17:16:13 +0000 Subject: [PATCH 5/8] Driver: Ensure all package libraries are available for linking This means that for any documentation file in a package, either mld or module interface, any module in the entire package can be referenced with or without a fully qualified path --- src/driver/odoc_units_of.ml | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/driver/odoc_units_of.ml b/src/driver/odoc_units_of.ml index 9644db249e..cc1f331ebc 100644 --- a/src/driver/odoc_units_of.ml +++ b/src/driver/odoc_units_of.ml @@ -193,10 +193,9 @@ let packages ~dirs ~extra_paths ~remap (pkgs : Packages.t list) : t list = in let of_lib pkg (lib : Packages.libty) = let lib_deps = Util.StringSet.add lib.lib_name lib.lib_deps in - let landing_page :> t = - let index = index_of pkg in - Landing_pages.library ~dirs ~pkg ~index lib - in + let lib_deps = List.fold_left (fun acc lib -> Util.StringSet.add lib.Packages.lib_name acc) lib_deps pkg.Packages.libraries in + let index = index_of pkg in + let landing_page :> t = Landing_pages.library ~dirs ~pkg ~index lib in landing_page :: List.concat_map (of_module pkg lib lib_deps) lib.modules in let of_mld pkg (mld : Packages.mld) : mld unit list = From 5e65ca0b11587f975d07d54334a86a15e314a0d7 Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Thu, 12 Dec 2024 15:10:23 +0100 Subject: [PATCH 6/8] Added changelog entry for #1260 --- CHANGES.md | 3 +++ 1 file changed, 3 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index 4db107788a..1a9ed1fd0d 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -2,6 +2,9 @@ ### Added +- Addded `--suppress-warnings` to the CLI to remove warnings from a unit, even + if they end up being raised in another unit through expansion (@jonludlam, + #1260) - Improve jump to implementation in rendered source code, and add a `count-occurrences` flag and command to count occurrences of every identifiers (@panglesd, #976) From d031eed50f3d9f6a14b01a764c2d29c064eccc46 Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Wed, 27 Nov 2024 13:31:37 +0000 Subject: [PATCH 7/8] Resolve references better --- src/loader/cmi.ml | 185 +++++++++++++++++--------- src/loader/cmt.ml | 213 +++++++++++++++++------------- src/loader/cmti.ml | 229 +++++++++++++++++++++++---------- src/loader/doc_attr.ml | 15 ++- src/loader/doc_attr.mli | 3 + src/loader/ident_env.cppo.ml | 73 ++++++++++- src/loader/ident_env.cppo.mli | 28 ++++ src/loader/resolve_init.ml | 137 ++++++++++++++++++++ src/xref2/ref_tools.ml | 41 +++++- test/xref2/module_list.t/run.t | 8 +- 10 files changed, 697 insertions(+), 235 deletions(-) create mode 100644 src/loader/resolve_init.ml diff --git a/src/loader/cmi.ml b/src/loader/cmi.ml index 2e2fc58205..ee743cfd19 100644 --- a/src/loader/cmi.ml +++ b/src/loader/cmi.ml @@ -615,14 +615,17 @@ and read_object env fi nm = | _ -> assert false end -let read_value_description ({ident_env ; suppress_warnings} as env) parent id vd = +let read_value_description ({ ident_env; suppress_warnings } as env) parent id + vd = let open Signature in let id = Env.find_value_identifier ident_env id in let source_loc = None in let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc = Doc_attr.attached_no_tag ~suppress_warnings container vd.val_attributes in + let doc = + Doc_attr.attached_no_tag ~env:env.ident_env ~suppress_warnings container vd.val_attributes + in mark_value_description vd; let type_ = read_type_expr env vd.val_type in let value = @@ -642,14 +645,17 @@ let read_value_description ({ident_env ; suppress_warnings} as env) parent id vd let read_label_declaration env parent ld = let open TypeDecl.Field in let name = Ident.name ld.ld_id in - let id = Identifier.Mk.field (parent, Odoc_model.Names.FieldName.make_std name) in + let id = + Identifier.Mk.field (parent, Odoc_model.Names.FieldName.make_std name) + in let doc = - Doc_attr.attached_no_tag ~suppress_warnings:env.suppress_warnings - (parent :> Identifier.LabelParent.t) ld.ld_attributes + Doc_attr.attached_no_tag ~env:env.ident_env ~suppress_warnings:env.suppress_warnings + (parent :> Identifier.LabelParent.t) + ld.ld_attributes in - let mutable_ = (ld.ld_mutable = Mutable) in + let mutable_ = ld.ld_mutable = Mutable in let type_ = read_type_expr env ld.ld_type in - {id; doc; mutable_; type_} + { id; doc; mutable_; type_ } let read_constructor_declaration_arguments env parent arg = #if OCAML_VERSION < (4,3,0) @@ -669,13 +675,17 @@ let read_constructor_declaration env parent cd = let open TypeDecl.Constructor in let id = Ident_env.find_constructor_identifier env.ident_env cd.cd_id in let container = (parent :> Identifier.LabelParent.t) in - let doc = Doc_attr.attached_no_tag ~suppress_warnings:env.suppress_warnings container cd.cd_attributes in + let doc = + Doc_attr.attached_no_tag ~env:env.ident_env ~suppress_warnings:env.suppress_warnings + container cd.cd_attributes + in let args = read_constructor_declaration_arguments env - (parent :> Identifier.FieldParent.t) cd.cd_args + (parent :> Identifier.FieldParent.t) + cd.cd_args in let res = opt_map (read_type_expr env) cd.cd_res in - {id; doc; args; res} + { id; doc; args; res } let read_type_kind env parent = let open TypeDecl.Representation in function @@ -752,7 +762,8 @@ let read_type_declaration env parent id decl = let source_loc = None in let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in let doc, canonical = - Doc_attr.attached ~suppress_warnings:env.suppress_warnings Odoc_model.Semantics.Expect_canonical container decl.type_attributes + Doc_attr.attached ~env:env.ident_env ~suppress_warnings:env.suppress_warnings + Odoc_model.Semantics.Expect_canonical container decl.type_attributes in let canonical = match canonical with | None -> None | Some s -> Doc_attr.conv_canonical_type s in let params = mark_type_declaration decl in @@ -790,14 +801,20 @@ let read_extension_constructor env parent id ext = let open Extension.Constructor in let id = Env.find_extension_identifier env.ident_env id in let source_loc = None in - let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc = Doc_attr.attached_no_tag ~suppress_warnings:env.suppress_warnings container ext.ext_attributes in + let container = + (parent : Identifier.Signature.t :> Identifier.LabelParent.t) + in + let doc = + Doc_attr.attached_no_tag ~env:env.ident_env ~suppress_warnings:env.suppress_warnings + container ext.ext_attributes + in let args = read_constructor_declaration_arguments env - (parent : Identifier.Signature.t :> Identifier.FieldParent.t) ext.ext_args + (parent : Identifier.Signature.t :> Identifier.FieldParent.t) + ext.ext_args in let res = opt_map (read_type_expr env) ext.ext_ret_type in - {id; source_loc; doc; args; res} + { id; source_loc; doc; args; res } let read_type_extension env parent id ext rest = let open Extension in @@ -823,15 +840,21 @@ let read_exception env parent id ext = let open Exception in let id = Env.find_exception_identifier env.ident_env id in let source_loc = None in - let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc = Doc_attr.attached_no_tag ~suppress_warnings:env.suppress_warnings container ext.ext_attributes in - mark_exception ext; - let args = - read_constructor_declaration_arguments env - (parent : Identifier.Signature.t :> Identifier.FieldParent.t) ext.ext_args - in - let res = opt_map (read_type_expr env) ext.ext_ret_type in - {id; source_loc; doc; args; res} + let container = + (parent : Identifier.Signature.t :> Identifier.LabelParent.t) + in + let doc = + Doc_attr.attached_no_tag ~env:env.ident_env ~suppress_warnings:env.suppress_warnings + container ext.ext_attributes + in + mark_exception ext; + let args = + read_constructor_declaration_arguments env + (parent : Identifier.Signature.t :> Identifier.FieldParent.t) + ext.ext_args + in + let res = opt_map (read_type_expr env) ext.ext_ret_type in + { id; source_loc; doc; args; res } let read_method env parent concrete (name, kind, typ) = let open Method in @@ -917,19 +940,24 @@ let read_class_type_declaration env parent id cltd = let open ClassType in let id = Env.find_class_type_identifier env.ident_env id in let source_loc = None in - let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc = Doc_attr.attached_no_tag ~suppress_warnings:env.suppress_warnings container cltd.clty_attributes in - mark_class_type_declaration cltd; - let params = - List.map2 - (read_type_parameter false) - cltd.clty_variance cltd.clty_params - in - let expr = - read_class_signature env (id :> Identifier.ClassSignature.t) cltd.clty_params cltd.clty_type - in - let virtual_ = read_virtual cltd.clty_type in - { id; source_loc; doc; virtual_; params; expr; expansion = None } + let container = + (parent : Identifier.Signature.t :> Identifier.LabelParent.t) + in + let doc = + Doc_attr.attached_no_tag ~env:env.ident_env ~suppress_warnings:env.suppress_warnings + container cltd.clty_attributes + in + mark_class_type_declaration cltd; + let params = + List.map2 (read_type_parameter false) cltd.clty_variance cltd.clty_params + in + let expr = + read_class_signature env + (id :> Identifier.ClassSignature.t) + cltd.clty_params cltd.clty_type + in + let virtual_ = read_virtual cltd.clty_type in + { id; source_loc; doc; virtual_; params; expr; expansion = None } let rec read_class_type env parent params = let open Class in function @@ -953,19 +981,24 @@ let read_class_declaration env parent id cld = let open Class in let id = Env.find_class_identifier env.ident_env id in let source_loc = None in - let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc = Doc_attr.attached_no_tag ~suppress_warnings:env.suppress_warnings container cld.cty_attributes in - mark_class_declaration cld; - let params = - List.map2 - (read_type_parameter false) - cld.cty_variance cld.cty_params - in - let type_ = - read_class_type env (id :> Identifier.ClassSignature.t) cld.cty_params cld.cty_type - in - let virtual_ = cld.cty_new = None in - { id; source_loc; doc; virtual_; params; type_; expansion = None } + let container = + (parent : Identifier.Signature.t :> Identifier.LabelParent.t) + in + let doc = + Doc_attr.attached_no_tag ~env:env.ident_env ~suppress_warnings:env.suppress_warnings + container cld.cty_attributes + in + mark_class_declaration cld; + let params = + List.map2 (read_type_parameter false) cld.cty_variance cld.cty_params + in + let type_ = + read_class_type env + (id :> Identifier.ClassSignature.t) + cld.cty_params cld.cty_type + in + let virtual_ = cld.cty_new = None in + { id; source_loc; doc; virtual_; params; type_; expansion = None } let rec read_module_type env parent (mty : Odoc_model.Compat.module_type) = let open ModuleType in @@ -992,34 +1025,60 @@ let rec read_module_type env parent (mty : Odoc_model.Compat.module_type) = let t_desc = ModPath t_original_path in TypeOf { t_desc; t_expansion = None; t_original_path } -and read_module_type_declaration env parent id (mtd : Odoc_model.Compat.modtype_declaration) = +and read_module_type_declaration env parent id + (mtd : Odoc_model.Compat.modtype_declaration) = let open ModuleType in let id = Env.find_module_type env.ident_env id in let source_loc = None in - let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc, canonical = Doc_attr.attached ~suppress_warnings:env.suppress_warnings Odoc_model.Semantics.Expect_canonical container mtd.mtd_attributes in - let canonical = match canonical with | None -> None | Some s -> Doc_attr.conv_canonical_module_type s in - let expr = opt_map (read_module_type env (id :> Identifier.Signature.t)) mtd.mtd_type in - {id; source_loc; doc; canonical; expr } + let container = + (parent : Identifier.Signature.t :> Identifier.LabelParent.t) + in + let doc, canonical = + Doc_attr.attached ~env:env.ident_env ~suppress_warnings:env.suppress_warnings + Odoc_model.Semantics.Expect_canonical container mtd.mtd_attributes + in + let canonical = + match canonical with + | None -> None + | Some s -> Doc_attr.conv_canonical_module_type s + in + let expr = + opt_map (read_module_type env (id :> Identifier.Signature.t)) mtd.mtd_type + in + { id; source_loc; doc; canonical; expr } -and read_module_declaration env parent ident (md : Odoc_model.Compat.module_declaration) = +and read_module_declaration env parent ident + (md : Odoc_model.Compat.module_declaration) = let open Module in - let id = (Env.find_module_identifier env.ident_env ident :> Identifier.Module.t) in + let id = + (Env.find_module_identifier env.ident_env ident :> Identifier.Module.t) + in let source_loc = None in - let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc, canonical = Doc_attr.attached ~suppress_warnings:env.suppress_warnings Odoc_model.Semantics.Expect_canonical container md.md_attributes in - let canonical = match canonical with | None -> None | Some s -> Some (Doc_attr.conv_canonical_module s) in + let container = + (parent : Identifier.Signature.t :> Identifier.LabelParent.t) + in + let doc, canonical = + Doc_attr.attached ~env:env.ident_env ~suppress_warnings:env.suppress_warnings + Odoc_model.Semantics.Expect_canonical container md.md_attributes + in + let canonical = + match canonical with + | None -> None + | Some s -> Some (Doc_attr.conv_canonical_module s) + in let type_ = match md.md_type with | Mty_alias p -> Alias (Env.Path.read_module env.ident_env p, None) - | _ -> ModuleType (read_module_type env (id :> Identifier.Signature.t) md.md_type) + | _ -> + ModuleType + (read_module_type env (id :> Identifier.Signature.t) md.md_type) in let hidden = match canonical with | Some _ -> false | None -> Odoc_model.Names.contains_double_underscore (Ident.name ident) in - {id; source_loc; doc; type_; canonical; hidden } + { id; source_loc; doc; type_; canonical; hidden } and read_type_rec_status rec_status = let open Signature in diff --git a/src/loader/cmt.ml b/src/loader/cmt.ml index 5f4ad66c08..a060e27072 100644 --- a/src/loader/cmt.ml +++ b/src/loader/cmt.ml @@ -90,9 +90,14 @@ let rec read_pattern env parent doc pat = #endif let read_value_binding env parent vb = - let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc = Doc_attr.attached_no_tag ~suppress_warnings:env.suppress_warnings container vb.vb_attributes in - read_pattern env parent doc vb.vb_pat + let container = + (parent : Identifier.Signature.t :> Identifier.LabelParent.t) + in + let doc = + Doc_attr.attached_no_tag ~env:env.ident_env ~suppress_warnings:env.suppress_warnings + container vb.vb_attributes + in + read_pattern env parent doc vb.vb_pat let read_value_bindings env parent vbs = let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in @@ -112,31 +117,31 @@ let read_value_bindings env parent vbs = let read_type_extension env parent tyext = let open Extension in let type_path = Env.Path.read_type env.ident_env tyext.tyext_path in - let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc = Doc_attr.attached_no_tag ~suppress_warnings:env.suppress_warnings container tyext.tyext_attributes in + let container = + (parent : Identifier.Signature.t :> Identifier.LabelParent.t) + in + let doc = + Doc_attr.attached_no_tag ~env:env.ident_env ~suppress_warnings:env.suppress_warnings + container tyext.tyext_attributes + in let type_params = List.map (fun (ctyp, _) -> ctyp.ctyp_type) tyext.tyext_params in let constructors = List.map (fun ext -> ext.ext_type) tyext.tyext_constructors in + let type_params = Cmi.mark_type_extension type_params constructors in let type_params = - Cmi.mark_type_extension type_params constructors - in - let type_params = - List.map - (Cmi.read_type_parameter false Types.Variance.null) - type_params + List.map (Cmi.read_type_parameter false Types.Variance.null) type_params in - let private_ = (tyext.tyext_private = Private) in + let private_ = tyext.tyext_private = Private in let constructors = List.map (fun ext -> - Cmi.read_extension_constructor - env parent ext.ext_id ext.ext_type) + Cmi.read_extension_constructor env parent ext.ext_id ext.ext_type) tyext.tyext_constructors in - { parent; type_path; doc; type_params; private_; constructors; } + { parent; type_path; doc; type_params; private_; constructors } (** Make a standalone comment out of a comment attached to an item that isn't rendered. For example, [constraint] items are read separately and not @@ -148,31 +153,42 @@ let mk_class_comment = function let rec read_class_type_field env parent ctf = let open ClassSignature in let open Odoc_model.Names in - let container = (parent : Identifier.ClassSignature.t :> Identifier.LabelParent.t) in - let doc = Doc_attr.attached_no_tag ~suppress_warnings:env.suppress_warnings container ctf.ctf_attributes in + let container = + (parent : Identifier.ClassSignature.t :> Identifier.LabelParent.t) + in + let doc = + Doc_attr.attached_no_tag ~env:env.ident_env ~suppress_warnings:env.suppress_warnings + container ctf.ctf_attributes + in match ctf.ctf_desc with - | Tctf_val(name, mutable_, virtual_, typ) -> + | Tctf_val (name, mutable_, virtual_, typ) -> let open InstanceVariable in - let id = Identifier.Mk.instance_variable(parent, InstanceVariableName.make_std name) in - let mutable_ = (mutable_ = Mutable) in - let virtual_ = (virtual_ = Virtual) in + let id = + Identifier.Mk.instance_variable + (parent, InstanceVariableName.make_std name) + in + let mutable_ = mutable_ = Mutable in + let virtual_ = virtual_ = Virtual in let type_ = read_core_type env typ in - Some (InstanceVariable {id; doc; mutable_; virtual_; type_}) - | Tctf_method(name, private_, virtual_, typ) -> + Some (InstanceVariable { id; doc; mutable_; virtual_; type_ }) + | Tctf_method (name, private_, virtual_, typ) -> let open Method in - let id = Identifier.Mk.method_(parent, MethodName.make_std name) in - let private_ = (private_ = Private) in - let virtual_ = (virtual_ = Virtual) in + let id = Identifier.Mk.method_ (parent, MethodName.make_std name) in + let private_ = private_ = Private in + let virtual_ = virtual_ = Virtual in let type_ = read_core_type env typ in - Some (Method {id; doc; private_; virtual_; type_}) - | Tctf_constraint(_, _) -> mk_class_comment doc + Some (Method { id; doc; private_; virtual_; type_ }) + | Tctf_constraint (_, _) -> mk_class_comment doc | Tctf_inherit cltyp -> let expr = read_class_signature env parent [] cltyp in - Some (Inherit {Inherit.expr; doc}) - | Tctf_attribute attr -> - match Doc_attr.standalone container ~suppress_warnings:env.suppress_warnings attr with + Some (Inherit { Inherit.expr; doc }) + | Tctf_attribute attr -> ( + match + Doc_attr.standalone container ~suppress_warnings:env.suppress_warnings + attr + with | None -> None - | Some doc -> Some (Comment doc) + | Some doc -> Some (Comment doc)) and read_class_signature env parent params cltyp = let open ClassType in @@ -229,30 +245,36 @@ let rec read_class_type env parent params cty = let rec read_class_field env parent cf = let open ClassSignature in let open Odoc_model.Names in - let container = (parent : Identifier.ClassSignature.t :> Identifier.LabelParent.t) in - let doc = Doc_attr.attached_no_tag ~suppress_warnings:env.suppress_warnings container (cf.cf_attributes) in + let container = + (parent : Identifier.ClassSignature.t :> Identifier.LabelParent.t) + in + let doc = + Doc_attr.attached_no_tag ~env:env.ident_env ~suppress_warnings:env.suppress_warnings + container cf.cf_attributes + in match cf.cf_desc with - | Tcf_val({txt = name; _}, mutable_, _, kind, _) -> + | Tcf_val ({ txt = name; _ }, mutable_, _, kind, _) -> let open InstanceVariable in - let id = Identifier.Mk.instance_variable(parent, InstanceVariableName.make_std name) in - let mutable_ = (mutable_ = Mutable) in + let id = + Identifier.Mk.instance_variable + (parent, InstanceVariableName.make_std name) + in + let mutable_ = mutable_ = Mutable in let virtual_, type_ = match kind with - | Tcfk_virtual typ -> - true, read_core_type env typ - | Tcfk_concrete(_, expr) -> - false, Cmi.read_type_expr env expr.exp_type + | Tcfk_virtual typ -> (true, read_core_type env typ) + | Tcfk_concrete (_, expr) -> + (false, Cmi.read_type_expr env expr.exp_type) in - Some (InstanceVariable {id; doc; mutable_; virtual_; type_}) - | Tcf_method({txt = name; _}, private_, kind) -> + Some (InstanceVariable { id; doc; mutable_; virtual_; type_ }) + | Tcf_method ({ txt = name; _ }, private_, kind) -> let open Method in - let id = Identifier.Mk.method_(parent, MethodName.make_std name) in - let private_ = (private_ = Private) in + let id = Identifier.Mk.method_ (parent, MethodName.make_std name) in + let private_ = private_ = Private in let virtual_, type_ = match kind with - | Tcfk_virtual typ -> - true, read_core_type env typ - | Tcfk_concrete(_, expr) -> + | Tcfk_virtual typ -> (true, read_core_type env typ) + | Tcfk_concrete (_, expr) -> (* Types of concrete methods in class implementation begin with the object as first (implicit) argument, so we must keep only the type after the first arrow. *) @@ -261,18 +283,21 @@ let rec read_class_field env parent cf = | Arrow (_, _, t) -> t | t -> t in - false, type_ + (false, type_) in - Some (Method {id; doc; private_; virtual_; type_}) - | Tcf_constraint(_, _) -> mk_class_comment doc - | Tcf_inherit(_, cl, _, _, _) -> + Some (Method { id; doc; private_; virtual_; type_ }) + | Tcf_constraint (_, _) -> mk_class_comment doc + | Tcf_inherit (_, cl, _, _, _) -> let expr = read_class_structure env parent [] cl in - Some (Inherit {Inherit.expr; doc}) + Some (Inherit { Inherit.expr; doc }) | Tcf_initializer _ -> mk_class_comment doc - | Tcf_attribute attr -> - match Doc_attr.standalone container ~suppress_warnings:env.suppress_warnings attr with + | Tcf_attribute attr -> ( + match + Doc_attr.standalone container ~suppress_warnings:env.suppress_warnings + attr + with | None -> None - | Some doc -> Some (Comment doc) + | Some doc -> Some (Comment doc)) and read_class_structure env parent params cl = let open ClassType in @@ -339,20 +364,23 @@ let read_class_declaration env parent cld = let open Class in let id = Env.find_class_identifier env.ident_env cld.ci_id_class in let source_loc = None in - let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc = Doc_attr.attached_no_tag ~suppress_warnings:env.suppress_warnings container cld.ci_attributes in - Cmi.mark_class_declaration cld.ci_decl; - let virtual_ = (cld.ci_virt = Virtual) in - let clparams = - List.map (fun (ctyp, _) -> ctyp.ctyp_type) cld.ci_params - in - let params = - List.map - (Cmi.read_type_parameter false Types.Variance.null) - clparams - in - let type_ = read_class_expr env (id :> Identifier.ClassSignature.t) clparams cld.ci_expr in - { id; source_loc; doc; virtual_; params; type_; expansion = None } + let container = + (parent : Identifier.Signature.t :> Identifier.LabelParent.t) + in + let doc = + Doc_attr.attached_no_tag ~env:env.ident_env ~suppress_warnings:env.suppress_warnings + container cld.ci_attributes + in + Cmi.mark_class_declaration cld.ci_decl; + let virtual_ = cld.ci_virt = Virtual in + let clparams = List.map (fun (ctyp, _) -> ctyp.ctyp_type) cld.ci_params in + let params = + List.map (Cmi.read_type_parameter false Types.Variance.null) clparams + in + let type_ = + read_class_expr env (id :> Identifier.ClassSignature.t) clparams cld.ci_expr + in + { id; source_loc; doc; virtual_; params; type_; expansion = None } let read_class_declarations env parent clds = let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in @@ -448,7 +476,10 @@ and read_module_binding env parent mb = let id = (mid :> Identifier.Module.t) in let source_loc = None in let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc, canonical = Doc_attr.attached ~suppress_warnings:env.suppress_warnings Odoc_model.Semantics.Expect_canonical container mb.mb_attributes in + let doc, canonical = + Doc_attr.attached ~env:env.ident_env ~suppress_warnings:env.suppress_warnings + Odoc_model.Semantics.Expect_canonical container mb.mb_attributes + in let type_, canonical = match unwrap_module_expr_desc mb.mb_expr.mod_desc with | Tmod_ident (p, _) -> (Alias (Env.Path.read_module env.ident_env p, None), canonical) @@ -556,29 +587,39 @@ and read_structure_item env parent item = and read_include env parent incl = let open Include in let loc = Doc_attr.read_location incl.incl_loc in - let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc, status = Doc_attr.attached ~suppress_warnings:env.suppress_warnings Odoc_model.Semantics.Expect_status container incl.incl_attributes in + let container = + (parent : Identifier.Signature.t :> Identifier.LabelParent.t) + in + let doc, status = + Doc_attr.attached ~env:env.ident_env ~suppress_warnings:env.suppress_warnings + Odoc_model.Semantics.Expect_status container incl.incl_attributes + in let decl_modty = match unwrap_module_expr_desc incl.incl_mod.mod_desc with - | Tmod_ident(p, _) -> - let p = Env.Path.read_module env.ident_env p in - Some (ModuleType.U.TypeOf (ModuleType.StructInclude p, p)) + | Tmod_ident (p, _) -> + let p = Env.Path.read_module env.ident_env p in + Some (ModuleType.U.TypeOf (ModuleType.StructInclude p, p)) | _ -> - let mty = read_module_expr env parent container incl.incl_mod in - umty_of_mty mty + let mty = read_module_expr env parent container incl.incl_mod in + umty_of_mty mty + in + let content, shadowed = + Cmi.read_signature_noenv env parent + (Odoc_model.Compat.signature incl.incl_type) in - let content, shadowed = Cmi.read_signature_noenv env parent (Odoc_model.Compat.signature incl.incl_type) in - let expansion = { content; shadowed; } in + let expansion = { content; shadowed } in match decl_modty with | Some m -> - let decl = ModuleType m in - [Include {parent; doc; decl; expansion; status; strengthened=None; loc }] - | _ -> - content.items + let decl = ModuleType m in + [ + Include + { parent; doc; decl; expansion; status; strengthened = None; loc }; + ] + | _ -> content.items and read_open env parent o = let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc = Doc_attr.attached_no_tag ~suppress_warnings:env.suppress_warnings container o.open_attributes in + let doc = Doc_attr.attached_no_tag ~env:env.ident_env ~suppress_warnings:env.suppress_warnings container o.open_attributes in #if OCAML_VERSION >= (4,8,0) let signature = o.open_bound_items in #else @@ -600,7 +641,7 @@ and read_structure : | Tstr_attribute attr -> Some (`Attribute attr) | _ -> None in - Doc_attr.extract_top_comment internal_tags ~classify parent str.str_items + Doc_attr.extract_top_comment ~env:env.ident_env internal_tags ~classify parent str.str_items in let items = List.fold_left diff --git a/src/loader/cmti.ml b/src/loader/cmti.ml index 5e7b431d01..5e48270ded 100644 --- a/src/loader/cmti.ml +++ b/src/loader/cmti.ml @@ -125,7 +125,7 @@ let rec read_core_type env container ctyp = #if OCAML_VERSION >= (4,6,0) let name = name.txt in #endif - let doc = Doc_attr.attached_no_tag ~suppress_warnings:env.suppress_warnings container attributes in + let doc = Doc_attr.attached_no_tag ~env:env.ident_env ~suppress_warnings:env.suppress_warnings container attributes in Constructor {name; constant; arguments; doc} | Tinherit typ -> Type (read_core_type env container typ) end @@ -164,7 +164,10 @@ let read_value_description env parent vd = let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc = Doc_attr.attached_no_tag ~suppress_warnings:env.suppress_warnings container vd.val_attributes in + let doc = + Doc_attr.attached_no_tag ~env:env.ident_env ~suppress_warnings:env.suppress_warnings + container vd.val_attributes + in let type_ = read_core_type env container vd.val_desc in let value = match vd.val_prim with @@ -207,11 +210,14 @@ let read_label_declaration env parent label_parent ld = let open TypeDecl.Field in let open Odoc_model.Names in let name = Ident.name ld.ld_id in - let id = Identifier.Mk.field(parent, FieldName.make_std name) in - let doc = Doc_attr.attached_no_tag ~suppress_warnings:env.suppress_warnings label_parent ld.ld_attributes in - let mutable_ = (ld.ld_mutable = Mutable) in + let id = Identifier.Mk.field (parent, FieldName.make_std name) in + let doc = + Doc_attr.attached_no_tag ~env:env.ident_env ~suppress_warnings:env.suppress_warnings + label_parent ld.ld_attributes + in + let mutable_ = ld.ld_mutable = Mutable in let type_ = read_core_type env label_parent ld.ld_type in - {id; doc; mutable_; type_} + { id; doc; mutable_; type_ } let read_constructor_declaration_arguments env parent label_parent arg = let open TypeDecl.Constructor in @@ -230,13 +236,16 @@ let read_constructor_declaration env parent cd = let id = Ident_env.find_constructor_identifier env.ident_env cd.cd_id in let container = (parent :> Identifier.FieldParent.t) in let label_container = (container :> Identifier.LabelParent.t) in - let doc = Doc_attr.attached_no_tag ~suppress_warnings:env.suppress_warnings label_container cd.cd_attributes in + let doc = + Doc_attr.attached_no_tag ~env:env.ident_env ~suppress_warnings:env.suppress_warnings + label_container cd.cd_attributes + in let args = - read_constructor_declaration_arguments - env container label_container cd.cd_args + read_constructor_declaration_arguments env container label_container + cd.cd_args in let res = opt_map (read_core_type env label_container) cd.cd_res in - {id; doc; args; res} + { id; doc; args; res } let read_type_kind env parent = let open TypeDecl.Representation in function @@ -270,12 +279,21 @@ let read_type_declaration env parent decl = let open TypeDecl in let id = Env.find_type_identifier env.ident_env decl.typ_id in let source_loc = None in - let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc, canonical = Doc_attr.attached ~suppress_warnings:env.suppress_warnings Odoc_model.Semantics.Expect_canonical container decl.typ_attributes in - let canonical = match canonical with | None -> None | Some s -> Doc_attr.conv_canonical_type s in + let container = + (parent : Identifier.Signature.t :> Identifier.LabelParent.t) + in + let doc, canonical = + Doc_attr.attached ~env:env.ident_env ~suppress_warnings:env.suppress_warnings + Odoc_model.Semantics.Expect_canonical container decl.typ_attributes + in + let canonical = + match canonical with + | None -> None + | Some s -> Doc_attr.conv_canonical_type s + in let equation = read_type_equation env container decl in let representation = read_type_kind env id decl.typ_kind in - {id; source_loc; doc; canonical; equation; representation} + { id; source_loc; doc; canonical; equation; representation } let read_type_declarations env parent rec_flag decls = let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in @@ -308,7 +326,10 @@ let read_extension_constructor env parent ext = let source_loc = None in let container = (parent : Identifier.Signature.t :> Identifier.FieldParent.t) in let label_container = (container :> Identifier.LabelParent.t) in - let doc = Doc_attr.attached_no_tag ~suppress_warnings:env.suppress_warnings label_container ext.ext_attributes in + let doc = + Doc_attr.attached_no_tag ~env:env.ident_env ~suppress_warnings:env.suppress_warnings + label_container ext.ext_attributes + in match ext.ext_kind with | Text_rebind _ -> assert false #if OCAML_VERSION >= (4, 14, 0) @@ -326,14 +347,19 @@ let read_extension_constructor env parent ext = let read_type_extension env parent tyext = let open Extension in let type_path = Env.Path.read_type env.ident_env tyext.tyext_path in - let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc = Doc_attr.attached_no_tag ~suppress_warnings:env.suppress_warnings container tyext.tyext_attributes in + let container = + (parent : Identifier.Signature.t :> Identifier.LabelParent.t) + in + let doc = + Doc_attr.attached_no_tag ~env:env.ident_env ~suppress_warnings:env.suppress_warnings + container tyext.tyext_attributes + in let type_params = List.map read_type_parameter tyext.tyext_params in - let private_ = (tyext.tyext_private = Private) in + let private_ = tyext.tyext_private = Private in let constructors = List.map (read_extension_constructor env parent) tyext.tyext_constructors in - { parent; type_path; doc; type_params; private_; constructors; } + { parent; type_path; doc; type_params; private_; constructors } let read_exception env parent (ext : extension_constructor) = let open Exception in @@ -341,7 +367,10 @@ let read_exception env parent (ext : extension_constructor) = let source_loc = None in let container = (parent : Identifier.Signature.t :> Identifier.FieldParent.t) in let label_container = (container :> Identifier.LabelParent.t) in - let doc = Doc_attr.attached_no_tag ~suppress_warnings:env.suppress_warnings label_container ext.ext_attributes in + let doc = + Doc_attr.attached_no_tag ~env:env.ident_env ~suppress_warnings:env.suppress_warnings + label_container ext.ext_attributes + in match ext.ext_kind with | Text_rebind _ -> assert false #if OCAML_VERSION >= (4, 14, 0) @@ -359,34 +388,45 @@ let read_exception env parent (ext : extension_constructor) = let rec read_class_type_field env parent ctf = let open ClassSignature in let open Odoc_model.Names in - let container = (parent : Identifier.ClassSignature.t :> Identifier.LabelParent.t) in - let doc = Doc_attr.attached_no_tag ~suppress_warnings:env.suppress_warnings container ctf.ctf_attributes in + let container = + (parent : Identifier.ClassSignature.t :> Identifier.LabelParent.t) + in + let doc = + Doc_attr.attached_no_tag ~env:env.ident_env ~suppress_warnings:env.suppress_warnings + container ctf.ctf_attributes + in match ctf.ctf_desc with - | Tctf_val(name, mutable_, virtual_, typ) -> + | Tctf_val (name, mutable_, virtual_, typ) -> let open InstanceVariable in - let id = Identifier.Mk.instance_variable(parent, InstanceVariableName.make_std name) in - let mutable_ = (mutable_ = Mutable) in - let virtual_ = (virtual_ = Virtual) in + let id = + Identifier.Mk.instance_variable + (parent, InstanceVariableName.make_std name) + in + let mutable_ = mutable_ = Mutable in + let virtual_ = virtual_ = Virtual in let type_ = read_core_type env container typ in - Some (InstanceVariable {id; doc; mutable_; virtual_; type_}) - | Tctf_method(name, private_, virtual_, typ) -> + Some (InstanceVariable { id; doc; mutable_; virtual_; type_ }) + | Tctf_method (name, private_, virtual_, typ) -> let open Method in - let id = Identifier.Mk.method_(parent, MethodName.make_std name) in - let private_ = (private_ = Private) in - let virtual_ = (virtual_ = Virtual) in + let id = Identifier.Mk.method_ (parent, MethodName.make_std name) in + let private_ = private_ = Private in + let virtual_ = virtual_ = Virtual in let type_ = read_core_type env container typ in - Some (Method {id; doc; private_; virtual_; type_}) - | Tctf_constraint(typ1, typ2) -> + Some (Method { id; doc; private_; virtual_; type_ }) + | Tctf_constraint (typ1, typ2) -> let left = read_core_type env container typ1 in let right = read_core_type env container typ2 in - Some (Constraint {left; right; doc}) + Some (Constraint { left; right; doc }) | Tctf_inherit cltyp -> let expr = read_class_signature env parent container cltyp in - Some (Inherit {expr; doc}) - | Tctf_attribute attr -> - match Doc_attr.standalone container ~suppress_warnings:env.suppress_warnings attr with + Some (Inherit { expr; doc }) + | Tctf_attribute attr -> ( + match + Doc_attr.standalone container ~suppress_warnings:env.suppress_warnings + attr + with | None -> None - | Some doc -> Some (Comment doc) + | Some doc -> Some (Comment doc)) and read_self_type env container typ = if typ.ctyp_desc = Ttyp_any then None @@ -429,11 +469,20 @@ let read_class_type_declaration env parent cltd = let open ClassType in let id = Env.find_class_type_identifier env.ident_env cltd.ci_id_class_type in let source_loc = None in - let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc = Doc_attr.attached_no_tag container ~suppress_warnings:env.suppress_warnings cltd.ci_attributes in - let virtual_ = (cltd.ci_virt = Virtual) in + let container = + (parent : Identifier.Signature.t :> Identifier.LabelParent.t) + in + let doc = + Doc_attr.attached_no_tag container ~env:env.ident_env + ~suppress_warnings:env.suppress_warnings cltd.ci_attributes + in + let virtual_ = cltd.ci_virt = Virtual in let params = List.map read_type_parameter cltd.ci_params in - let expr = read_class_signature env (id :> Identifier.ClassSignature.t) container cltd.ci_expr in + let expr = + read_class_signature env + (id :> Identifier.ClassSignature.t) + container cltd.ci_expr + in { id; source_loc; doc; virtual_; params; expr; expansion = None } let read_class_type_declarations env parent cltds = @@ -468,11 +517,20 @@ let read_class_description env parent cld = let open Class in let id = Env.find_class_identifier env.ident_env cld.ci_id_class in let source_loc = None in - let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc = Doc_attr.attached_no_tag container ~suppress_warnings:env.suppress_warnings cld.ci_attributes in - let virtual_ = (cld.ci_virt = Virtual) in + let container = + (parent : Identifier.Signature.t :> Identifier.LabelParent.t) + in + let doc = + Doc_attr.attached_no_tag ~env:env.ident_env container + ~suppress_warnings:env.suppress_warnings cld.ci_attributes + in + let virtual_ = cld.ci_virt = Virtual in let params = List.map read_type_parameter cld.ci_params in - let type_ = read_class_type env (id :> Identifier.ClassSignature.t) container cld.ci_expr in + let type_ = + read_class_type env + (id :> Identifier.ClassSignature.t) + container cld.ci_expr + in { id; source_loc; doc; virtual_; params; type_; expansion = None } let read_class_descriptions env parent clds = @@ -601,8 +659,13 @@ and read_module_type_declaration env parent mtd = let open ModuleType in let id = Env.find_module_type env.ident_env mtd.mtd_id in let source_loc = None in - let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc, canonical = Doc_attr.attached ~suppress_warnings:env.suppress_warnings Odoc_model.Semantics.Expect_canonical container mtd.mtd_attributes in + let container = + (parent : Identifier.Signature.t :> Identifier.LabelParent.t) + in + let doc, canonical = + Doc_attr.attached ~env:env.ident_env ~suppress_warnings:env.suppress_warnings + Odoc_model.Semantics.Expect_canonical container mtd.mtd_attributes + in let expr, canonical = match mtd.mtd_type with | Some mty -> @@ -614,7 +677,11 @@ and read_module_type_declaration env parent mtd = (Some expr, canonical) | None -> (None, canonical) in - let canonical = match canonical with | None -> None | Some s -> Doc_attr.conv_canonical_module_type s in + let canonical = + match canonical with + | None -> None + | Some s -> Doc_attr.conv_canonical_module_type s + in { id; source_loc; doc; canonical; expr } and read_module_declaration env parent md = @@ -630,7 +697,10 @@ and read_module_declaration env parent md = let id = (mid :> Identifier.Module.t) in let source_loc = None in let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc, canonical = Doc_attr.attached ~suppress_warnings:env.suppress_warnings Odoc_model.Semantics.Expect_canonical container md.md_attributes in + let doc, canonical = + Doc_attr.attached ~env:env.ident_env ~suppress_warnings:env.suppress_warnings + Odoc_model.Semantics.Expect_canonical container md.md_attributes + in let type_, canonical = match md.md_type.mty_desc with | Tmty_alias (p, _) -> (Alias (Env.Path.read_module env.ident_env p, None), canonical) @@ -738,8 +808,13 @@ and read_signature_item env parent item = and read_module_substitution env parent ms = let open ModuleSubstitution in let id = Env.find_module_identifier env.ident_env ms.ms_id in - let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc, () = Doc_attr.attached ~suppress_warnings:env.suppress_warnings Odoc_model.Semantics.Expect_none container ms.ms_attributes in + let container = + (parent : Identifier.Signature.t :> Identifier.LabelParent.t) + in + let doc, () = + Doc_attr.attached ~env:env.ident_env ~suppress_warnings:env.suppress_warnings + Odoc_model.Semantics.Expect_none container ms.ms_attributes + in let manifest = Env.Path.read_module env.ident_env ms.ms_manifest in { id; doc; manifest } @@ -747,13 +822,23 @@ and read_module_substitution env parent ms = and read_module_type_substitution env parent mtd = let open ModuleTypeSubstitution in let id = Env.find_module_type env.ident_env mtd.mtd_id in - let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc, () = Doc_attr.attached ~suppress_warnings:env.suppress_warnings Odoc_model.Semantics.Expect_none container mtd.mtd_attributes in - let expr = match opt_map (read_module_type env (id :> Identifier.Signature.t) container) mtd.mtd_type with + let container = + (parent : Identifier.Signature.t :> Identifier.LabelParent.t) + in + let doc, () = + Doc_attr.attached ~env:env.ident_env ~suppress_warnings:env.suppress_warnings + Odoc_model.Semantics.Expect_none container mtd.mtd_attributes + in + let expr = + match + opt_map + (read_module_type env (id :> Identifier.Signature.t) container) + mtd.mtd_type + with | None -> assert false | Some x -> x in - {id; doc; manifest=expr;} + { id; doc; manifest = expr } #endif @@ -762,22 +847,32 @@ and read_module_type_substitution env parent mtd = and read_include env parent incl = let open Include in let loc = Doc_attr.read_location incl.incl_loc in - let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc, status = Doc_attr.attached ~suppress_warnings:env.suppress_warnings Odoc_model.Semantics.Expect_status container incl.incl_attributes in - let content, shadowed = Cmi.read_signature_noenv env parent (Odoc_model.Compat.signature incl.incl_type) in + let container = + (parent : Identifier.Signature.t :> Identifier.LabelParent.t) + in + let doc, status = + Doc_attr.attached ~env:env.ident_env ~suppress_warnings:env.suppress_warnings + Odoc_model.Semantics.Expect_status container incl.incl_attributes + in + let content, shadowed = + Cmi.read_signature_noenv env parent + (Odoc_model.Compat.signature incl.incl_type) + in let expr = read_module_type env parent container incl.incl_mod in - let umty = Odoc_model.Lang.umty_of_mty expr in - let expansion = { content; shadowed; } in + let umty = Odoc_model.Lang.umty_of_mty expr in + let expansion = { content; shadowed } in match umty with | Some uexpr -> - let decl = Include.ModuleType uexpr in - [Include {parent; doc; decl; expansion; status; strengthened=None; loc }] - | _ -> - content.items + let decl = Include.ModuleType uexpr in + [ + Include + { parent; doc; decl; expansion; status; strengthened = None; loc }; + ] + | _ -> content.items and read_open env parent o = let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in - let doc = Doc_attr.attached_no_tag container ~suppress_warnings:env.suppress_warnings o.open_attributes in + let doc = Doc_attr.attached_no_tag ~env:env.ident_env container ~suppress_warnings:env.suppress_warnings o.open_attributes in #if OCAML_VERSION >= (4,8,0) let signature = o.open_bound_items in #else @@ -799,7 +894,7 @@ and read_signature : | Tsig_open _ -> Some `Open | _ -> None in - Doc_attr.extract_top_comment internal_tags ~classify parent sg.sig_items + Doc_attr.extract_top_comment ~env:env.ident_env internal_tags ~classify parent sg.sig_items in let items = List.fold_left diff --git a/src/loader/doc_attr.ml b/src/loader/doc_attr.ml index efa50ee5bc..7c5f12b1e2 100644 --- a/src/loader/doc_attr.ml +++ b/src/loader/doc_attr.ml @@ -113,10 +113,11 @@ let is_stop_comment attr = let pad_loc loc = { loc.Location.loc_start with pos_cnum = loc.loc_start.pos_cnum + 3 } -let ast_to_comment ~internal_tags parent ast_docs alerts = +let ast_to_comment ~env ~internal_tags parent ast_docs alerts = Odoc_model.Semantics.ast_to_comment ~internal_tags ~tags_allowed:true ~parent_of_sections:parent ast_docs alerts |> Error.raise_warnings + |> (fun (x, b) -> (Resolve_init.resolve env x, b)) let mk_alert_payload ~loc name p = let p = match p with Some (p, _) -> Some p | None -> None in @@ -124,7 +125,7 @@ let mk_alert_payload ~loc name p = let span = read_location loc in Location_.at span elt -let attached ~suppress_warnings internal_tags parent attrs = +let attached ~suppress_warnings ~env internal_tags parent attrs = let rec loop acc_docs acc_alerts = function | attr :: rest -> ( match parse_attribute attr with @@ -141,11 +142,11 @@ let attached ~suppress_warnings internal_tags parent attrs = | [] -> (List.rev acc_docs, List.rev acc_alerts) in let ast_docs, alerts = loop [] [] attrs in - let elements, warnings = ast_to_comment ~internal_tags parent ast_docs alerts in + let elements, warnings = ast_to_comment ~env ~internal_tags parent ast_docs alerts in { Comment.elements; suppress_warnings }, warnings -let attached_no_tag ~suppress_warnings parent attrs = - let x, () = attached ~suppress_warnings Semantics.Expect_none parent attrs in +let attached_no_tag ~suppress_warnings ~env parent attrs = + let x, () = attached ~env ~suppress_warnings Semantics.Expect_none parent attrs in x let read_string ~tags_allowed internal_tags parent location str = @@ -202,7 +203,7 @@ let split_docs docs = in inner [] docs -let extract_top_comment internal_tags ~classify parent items = +let extract_top_comment ~env internal_tags ~classify parent items = let classify x = match classify x with | Some (`Attribute attr) -> ( @@ -249,7 +250,7 @@ let extract_top_comment internal_tags ~classify parent items = in let items, ast_docs, alerts = extract items in let docs, tags = - ast_to_comment ~internal_tags + ast_to_comment ~env ~internal_tags (parent : Paths.Identifier.Signature.t :> Paths.Identifier.LabelParent.t) ast_docs alerts in diff --git a/src/loader/doc_attr.mli b/src/loader/doc_attr.mli index dba8e386b4..6781042b8d 100644 --- a/src/loader/doc_attr.mli +++ b/src/loader/doc_attr.mli @@ -23,6 +23,7 @@ val is_stop_comment : Parsetree.attribute -> bool val attached : suppress_warnings:bool -> + env:Ident_env.t -> 'tags Semantics.handle_internal_tags -> Paths.Identifier.LabelParent.t -> Parsetree.attributes -> @@ -30,6 +31,7 @@ val attached : val attached_no_tag : suppress_warnings:bool -> + env:Ident_env.t -> Paths.Identifier.LabelParent.t -> Parsetree.attributes -> Odoc_model.Comment.docs @@ -60,6 +62,7 @@ val standalone_multiple : Odoc_model.Comment.docs_or_stop list val extract_top_comment : + env:Ident_env.t -> 'tags Semantics.handle_internal_tags -> classify:('item -> [ `Attribute of Parsetree.attribute | `Open ] option) -> Paths.Identifier.Signature.t -> diff --git a/src/loader/ident_env.cppo.ml b/src/loader/ident_env.cppo.ml index 389dab488b..f906364e2a 100644 --- a/src/loader/ident_env.cppo.ml +++ b/src/loader/ident_env.cppo.ml @@ -26,6 +26,48 @@ module LocHashtbl = Hashtbl.Make(struct let hash = Hashtbl.hash end) +(* duplicated code *) +#if OCAML_VERSION >= (4,8,0) + let attribute_unpack = function + | { Parsetree.attr_name = { Location.txt = name; _ }; attr_payload; attr_loc } -> + (name, attr_payload, attr_loc) + #else + let attribute_unpack = function + | { Location.txt = name; loc }, attr_payload -> (name, attr_payload, loc) + #endif + + let load_constant_string = function + | {Parsetree.pexp_desc = +#if OCAML_VERSION < (4,3,0) + Pexp_constant (Const_string (text, _)) +#elif OCAML_VERSION < (4,11,0) + Pexp_constant (Pconst_string (text, _)) +#elif OCAML_VERSION < (5,3,0) + Pexp_constant (Pconst_string (text, _, _)) +#else + Pexp_constant {pconst_desc= Pconst_string (text, _, _); _} +#endif + ; pexp_loc = loc; _} -> + Some (text , loc) + | _ -> None + + let load_payload = function + | Parsetree.PStr [ { pstr_desc = Pstr_eval (constant_string, _); _ } ] -> + load_constant_string constant_string + | _ -> None + + let is_stop_comment : Parsetree.attribute -> bool = + fun attr -> + let name, attr_payload, _attr_loc = attribute_unpack attr in + match name with + | "text" | "ocaml.text" -> ( + match load_payload attr_payload with + | Some ("/*", _) -> true + | Some _ -> false + | None -> false) + | _ -> false + + type t = { modules : Id.Module.t Ident.tbl; parameters : Id.FunctorParameter.t Ident.tbl; @@ -252,7 +294,7 @@ let rec extract_signature_tree_items : bool -> Typedtree.signature_item list -> | {sig_desc = Tsig_include incl; _ } :: rest -> [`Include (extract_signature_type_items Exported (Compat.signature incl.incl_type))] @ extract_signature_tree_items hide_item rest | {sig_desc = Tsig_attribute attr; _ } :: rest -> - let hide_item = if Doc_attr.is_stop_comment attr then not hide_item else hide_item in + let hide_item = if is_stop_comment attr then not hide_item else hide_item in extract_signature_tree_items hide_item rest | {sig_desc = Tsig_class cls; _} :: rest -> List.map @@ -388,7 +430,7 @@ let rec extract_structure_tree_items : bool -> Typedtree.structure_item list -> | { str_desc = Tstr_include incl; _ } :: rest -> [`Include (extract_signature_type_items Exported (Compat.signature incl.incl_type))] @ extract_structure_tree_items hide_item rest | { str_desc = Tstr_attribute attr; _} :: rest -> - let hide_item = if Doc_attr.is_stop_comment attr then not hide_item else hide_item in + let hide_item = if is_stop_comment attr then not hide_item else hide_item in extract_structure_tree_items hide_item rest | { str_desc = Tstr_class cls; _ } :: rest -> List.map @@ -798,3 +840,30 @@ module Fragment = struct | Longident.Lapply _ -> assert false end + +let lookup_by_name tbl n = + Ident.fold_all (fun _ id acc -> if Id.name id = n then id :: acc else acc) tbl [] + +let lookup_module_by_name env = lookup_by_name env.modules + +let lookup_module_type_by_name env = + lookup_by_name env.module_types + +let lookup_type_by_name env = + lookup_by_name env.types + +let lookup_value_by_name env = + lookup_by_name env.values + +let lookup_exception_by_name env = + lookup_by_name env.exceptions + +let lookup_constructor_by_name env = + lookup_by_name env.constructors + +let lookup_class_by_name env = + lookup_by_name env.classes + +let lookup_class_type_by_name env = + lookup_by_name env.class_types + diff --git a/src/loader/ident_env.cppo.mli b/src/loader/ident_env.cppo.mli index 337f9ffafe..a0a25e181d 100644 --- a/src/loader/ident_env.cppo.mli +++ b/src/loader/ident_env.cppo.mli @@ -87,3 +87,31 @@ val identifier_of_loc : t -> Location.t -> Paths.Identifier.t option val iter_located_identifier : t -> (Location.t -> Paths.Identifier.t -> unit) -> unit (** Iter on all stored pair [location]-[identifier]. *) + +val lookup_module_by_name : t -> string -> Paths.Identifier.Module.t list +(** Lookup a module by its name. *) + +val lookup_module_type_by_name : + t -> string -> Paths.Identifier.ModuleType.t list +(** Lookup a module type by its name. *) + +val lookup_type_by_name : t -> string -> Paths.Identifier.Type.t list +(** Lookup a type by its name. *) + +val lookup_value_by_name : t -> string -> Paths.Identifier.Value.t list +(** Lookup a value by its name. *) + +val lookup_exception_by_name : + t -> string -> Paths.Identifier.Exception.t list +(** Lookup an exception by its name. *) + +val lookup_constructor_by_name : + t -> string -> Paths.Identifier.Constructor.t list +(** Lookup a constructor by its name. *) + +val lookup_class_by_name : t -> string -> Paths.Identifier.Class.t list +(** Lookup a class by its name *) + +val lookup_class_type_by_name : + t -> string -> Paths.Identifier.ClassType.t list +(** Lookup a class type by its name *) \ No newline at end of file diff --git a/src/loader/resolve_init.ml b/src/loader/resolve_init.ml new file mode 100644 index 0000000000..e71bc2c2f0 --- /dev/null +++ b/src/loader/resolve_init.ml @@ -0,0 +1,137 @@ +(* Partially resolve references in docs *) +open Odoc_model + +module Resolve = struct + let lookup_signature env name : Paths.Reference.Signature.t option = + let all = + (Ident_env.lookup_module_by_name env name + :> Paths.Identifier.Signature.t list) + @ (Ident_env.lookup_module_type_by_name env name + :> Paths.Identifier.Signature.t list) + in + match all with x :: _ -> Some (`Resolved (`Identifier x)) | _ -> None + + let lookup_any env name : Paths.Reference.t option = + let all = + (Ident_env.lookup_module_by_name env name :> Paths.Identifier.t list) + @ (Ident_env.lookup_module_type_by_name env name + :> Paths.Identifier.t list) + @ (Ident_env.lookup_type_by_name env name :> Paths.Identifier.t list) + @ (Ident_env.lookup_value_by_name env name :> Paths.Identifier.t list) + in + match all with x :: _ -> Some (`Resolved (`Identifier x)) | _ -> None + + let rec signature env (x : Odoc_model.Paths.Reference.Signature.t) : + Odoc_model.Paths.Reference.Signature.t = + match x with + | `Resolved _ -> x + | `Root (r, t) -> ( + match t with + | `TUnknown -> ( + match lookup_signature env r with Some x -> x | None -> x) + | `TModule | `TModuleType -> x) + | `Dot (p, n) -> `Dot (label_parent env p, n) + | `Module_path _ -> x + | `Module (x, n) -> `Module (signature env x, n) + | `ModuleType (x, n) -> `ModuleType (signature env x, n) + + and label_parent env (x : Odoc_model.Paths.Reference.LabelParent.t) : + Odoc_model.Paths.Reference.LabelParent.t = + match x with + | `Resolved _ -> x + | `Dot (p, n) -> `Dot (label_parent env p, n) + | `Root (r, t) -> ( + match t with + | `TUnknown -> ( + match lookup_signature env r with + | Some x -> (x :> Odoc_model.Paths.Reference.LabelParent.t) + | None -> x) + | `TModule | `TModuleType | `TClass | `TClassType | `TType | `TPage + | `TChildPage | `TChildModule -> + x) + | `Module_path _ | `Any_path _ | `Page_path _ -> x + | `Module (x, n) -> `Module (signature env x, n) + | `ModuleType (x, n) -> `ModuleType (signature env x, n) + | `Type (x, n) -> `Type (signature env x, n) + | `Class (x, n) -> `Class (signature env x, n) + | `ClassType (x, n) -> `ClassType (signature env x, n) + + let do_resolve env (x : Odoc_model.Paths.Reference.t) : + Odoc_model.Paths.Reference.t = + match x with + | `Resolved _ -> x + | `Root + ( _r, + ( `TModule | `TModuleType | `TType | `TConstructor | `TField + | `TExtension | `TExtensionDecl | `TException | `TValue | `TClass + | `TClassType | `TMethod | `TInstanceVariable | `TLabel | `TPage + | `TAsset | `TChildPage | `TChildModule | `TUnknown ) ) -> + x + | `Dot (p, n) -> `Dot (label_parent env p, n) + | `Page_path _ | `Module_path _ | `Asset_path _ | `Any_path _ -> x + | `Module (r, n) -> `Module (signature env r, n) + | `ModuleType (r, n) -> `ModuleType (signature env r, n) + | `Type (r, n) -> `Type (signature env r, n) + | `Constructor _ -> x (* TODO *) + | `Field _ -> x (* TODO *) + | `Extension _ -> x (* TODO *) + | `ExtensionDecl _ -> x (* TODO *) + | `Exception _ -> x (* TODO *) + | `Value _ -> x (* TODO *) + | `Class (r, n) -> `Class (signature env r, n) + | `ClassType (r, n) -> `ClassType (signature env r, n) + | `Method _ -> x (* TODO *) + | `InstanceVariable _ -> x (* TODO *) + | `Label _ -> x (* TODO *) +end + +let with_location : + ('a -> 'b) -> 'a Comment.with_location -> 'b Comment.with_location = + fun handler v -> { v with value = handler v.value } + +let rec inline_element env (x : Comment.inline_element) : Comment.inline_element + = + match x with + | `Space -> x + | `Word _ -> x + | `Code_span _ -> x + | `Math_span _ -> x + | `Raw_markup _ -> x + | `Reference (r, x) -> `Reference (Resolve.do_resolve env r, x) + | `Styled (s, i) -> + `Styled (s, List.map (with_location (inline_element env)) i) + | `Link _ -> x + +let paragraph env = List.map (with_location (inline_element env)) + +let rec nestable_block_element : + Ident_env.t -> + Comment.nestable_block_element -> + Comment.nestable_block_element = + fun env -> function + | `Paragraph p -> `Paragraph (paragraph env p) + | `Code_block _ as x -> x + | `Math_block _ as x -> x + | `Verbatim _ as x -> x + | `Modules _ as x -> x + | `Table _ as x -> x + | `List (kind, items) -> + `List + ( kind, + List.map (List.map (with_location (nestable_block_element env))) items + ) + | `Media _ as x -> x + +let tag : Comment.tag -> Comment.tag = function x -> x + +let block_element env : Comment.block_element -> Comment.block_element = + function + | #Comment.nestable_block_element as e -> + (nestable_block_element env e :> Comment.block_element) + | `Heading (attrs, label, content) -> + `Heading + (attrs, label, List.map (with_location (inline_element env)) content) + | `Tag t -> `Tag t + +let resolve env (v : Comment.elements) = + List.map (with_location (block_element env)) v diff --git a/src/xref2/ref_tools.ml b/src/xref2/ref_tools.ml index 12b919d039..ba84a6b78b 100644 --- a/src/xref2/ref_tools.ml +++ b/src/xref2/ref_tools.ml @@ -224,6 +224,18 @@ module M = struct Error (`Parent (`Parent_module (`Lookup_failure_root (ModuleName.make_std name)))) + + let rec in_env_by_id env id = + match Env.lookup_by_id Env.s_module id env with + | Some e -> Ok (of_element env e) + | None -> match id.iv with + | `Module (p, name) -> + in_env_by_id env p >>= + module_lookup_to_signature_lookup env >>= + fun x -> in_signature env x name + | _ -> Error + (`Parent + (`Parent_module (`Lookup_failure_root (ModuleName.make_std (Identifier.name id))))) end module Path = struct @@ -291,6 +303,19 @@ module MT = struct let in_env env name = env_lookup_by_name Env.s_module_type name env >>= fun e -> Ok (of_element env e) + + let in_env_by_id env id = + match Env.lookup_by_id Env.s_module_type id env with + | Some e -> Ok (of_element env e) + | None -> match id.iv with + | `ModuleType (p, name) -> + M.in_env_by_id env p >>= + module_lookup_to_signature_lookup env >>= + fun x -> in_signature env x name + | _ -> Error + (`Parent + (`Parent_module (`Lookup_failure_root (ModuleName.make_std (Identifier.name id))))) + end module CL = struct @@ -697,7 +722,9 @@ let rec resolve_label_parent_reference env (r : LabelParent.t) = fun r -> Ok (r :> label_parent_lookup_result) in match r with - | `Resolved _ -> failwith "unimplemented" + | `Resolved (`Identifier {iv=(`Module _ | `ModuleType _); _}) as sr -> + resolve_signature_reference env sr >>= fun s -> Ok (`S s) + | `Resolved _ -> failwith "Unimplemented" | `Root (name, `TUnknown) -> LP.in_env env name | (`Module _ | `ModuleType _ | `Root (_, (`TModule | `TModuleType))) as sr -> resolve_signature_reference env sr >>= fun s -> Ok (`S s) @@ -760,9 +787,6 @@ and resolve_signature_reference : fun env' r -> let resolve env = match r with - | `Resolved _r -> - failwith "What's going on here then?" - (* Some (resolve_resolved_signature_reference env r ~add_canonical) *) | `Root (name, `TModule) -> M.in_env env name >>= module_lookup_to_signature_lookup env | `Module (parent, name) -> @@ -799,6 +823,15 @@ and resolve_signature_reference : (`ModuleType (parent, name)))) | `Module_path p -> Path.module_in_env env p >>= module_lookup_to_signature_lookup env + | `Resolved (`Identifier ({iv=`Module _; _} as ident)) -> ( + let m = M.in_env_by_id env ident in + m >>= module_lookup_to_signature_lookup env) + | `Resolved (`Identifier ({iv=`ModuleType _; _} as ident)) -> ( + let m = MT.in_env_by_id env ident in + m >>= module_type_lookup_to_signature_lookup env) + | `Resolved _ -> failwith "What's going on!?" + (* Some (resolve_resolved_signature_reference env r ~add_canonical) *) + in resolve env' diff --git a/test/xref2/module_list.t/run.t b/test/xref2/module_list.t/run.t index 91966549fc..65fa28b1b5 100644 --- a/test/xref2/module_list.t/run.t +++ b/test/xref2/module_list.t/run.t @@ -1,14 +1,10 @@ # Testing {!modules:...} lists $ compile external.mli starts_with_open.mli main.mli - File "main.mli", line 63, characters 22-43: - Warning: Failed to resolve reference unresolvedroot(Resolve_synopsis).t Couldn't find "Resolve_synopsis" File "main.mli", line 63, characters 17-21: Warning: Failed to resolve reference unresolvedroot(t) Couldn't find "t" File "external.mli", line 9, characters 6-10: Warning: Failed to resolve reference unresolvedroot(t) Couldn't find "t" - File "main.mli", line 63, characters 22-43: - Warning: Failed to resolve reference unresolvedroot(Resolve_synopsis).t Couldn't find "Resolve_synopsis" File "main.mli", line 63, characters 17-21: Warning: Failed to resolve reference unresolvedroot(t) Couldn't find "t" @@ -46,7 +42,7 @@ Everything should resolve: {"`Resolved":{"`Identifier":{"`Root":[{"Some":{"`Page":["None","test"]}},"Starts_with_open"]}}} {"Some":[{"`Word":"Synopsis"},"`Space",{"`Word":"of"},"`Space",{"`Code_span":"Starts_with_open"},{"`Word":"."}]} {"`Resolved":{"`Identifier":{"`Module":[{"`Root":[{"Some":{"`Page":["None","test"]}},"Main"]},"Resolve_synopsis"]}}} - {"Some":[{"`Word":"This"},"`Space",{"`Word":"should"},"`Space",{"`Word":"be"},"`Space",{"`Word":"resolved"},"`Space",{"`Word":"when"},"`Space",{"`Word":"included:"},"`Space",{"`Reference":[{"`Resolved":{"`Type":[{"`Module":[{"`Identifier":{"`Root":[{"Some":{"`Page":["None","test"]}},"Main"]}},"Resolve_synopsis"]},"t"]}},[]]},{"`Word":"."},"`Space",{"`Word":"These"},"`Space",{"`Word":"shouldn't:"},"`Space",{"`Reference":[{"`Root":["t","`TUnknown"]},[]]},"`Space",{"`Reference":[{"`Dot":[{"`Root":["Resolve_synopsis","`TUnknown"]},"t"]},[]]}]} + {"Some":[{"`Word":"This"},"`Space",{"`Word":"should"},"`Space",{"`Word":"be"},"`Space",{"`Word":"resolved"},"`Space",{"`Word":"when"},"`Space",{"`Word":"included:"},"`Space",{"`Reference":[{"`Resolved":{"`Type":[{"`Module":[{"`Identifier":{"`Root":[{"Some":{"`Page":["None","test"]}},"Main"]}},"Resolve_synopsis"]},"t"]}},[]]},{"`Word":"."},"`Space",{"`Word":"These"},"`Space",{"`Word":"shouldn't:"},"`Space",{"`Reference":[{"`Root":["t","`TUnknown"]},[]]},"`Space",{"`Reference":[{"`Resolved":{"`Type":[{"`Module":[{"`Identifier":{"`Root":[{"Some":{"`Page":["None","test"]}},"Main"]}},"Resolve_synopsis"]},"t"]}},[]]}]} {"`Resolved":{"`Module":[{"`Identifier":{"`Root":[{"Some":{"`Page":["None","test"]}},"External"]}},"Resolve_synopsis"]}} {"Some":[{"`Reference":[{"`Root":["t","`TUnknown"]},[]]}]} @@ -55,6 +51,6 @@ References in the synopses above should be resolved. $ odoc_print external.odocl | jq -c '.. | .["`Modules"]? | select(.) | .[] | .[]' {"`Resolved":{"`Module":[{"`Identifier":{"`Root":[{"Some":{"`Page":["None","test"]}},"Main"]}},"Resolve_synopsis"]}} - {"Some":[{"`Word":"This"},"`Space",{"`Word":"should"},"`Space",{"`Word":"be"},"`Space",{"`Word":"resolved"},"`Space",{"`Word":"when"},"`Space",{"`Word":"included:"},"`Space",{"`Reference":[{"`Resolved":{"`Type":[{"`Module":[{"`Identifier":{"`Root":[{"Some":{"`Page":["None","test"]}},"Main"]}},"Resolve_synopsis"]},"t"]}},[]]},{"`Word":"."},"`Space",{"`Word":"These"},"`Space",{"`Word":"shouldn't:"},"`Space",{"`Reference":[{"`Root":["t","`TUnknown"]},[]]},"`Space",{"`Reference":[{"`Dot":[{"`Root":["Resolve_synopsis","`TUnknown"]},"t"]},[]]}]} + {"Some":[{"`Word":"This"},"`Space",{"`Word":"should"},"`Space",{"`Word":"be"},"`Space",{"`Word":"resolved"},"`Space",{"`Word":"when"},"`Space",{"`Word":"included:"},"`Space",{"`Reference":[{"`Resolved":{"`Type":[{"`Module":[{"`Identifier":{"`Root":[{"Some":{"`Page":["None","test"]}},"Main"]}},"Resolve_synopsis"]},"t"]}},[]]},{"`Word":"."},"`Space",{"`Word":"These"},"`Space",{"`Word":"shouldn't:"},"`Space",{"`Reference":[{"`Root":["t","`TUnknown"]},[]]},"`Space",{"`Reference":[{"`Resolved":{"`Type":[{"`Module":[{"`Identifier":{"`Root":[{"Some":{"`Page":["None","test"]}},"Main"]}},"Resolve_synopsis"]},"t"]}},[]]}]} 'Type_of' and 'Alias' don't have a summary. `C1` and `C2` neither, we expect at least `C2` to have one. From 28b5ecb3edba87bb642080c41699fd040338744a Mon Sep 17 00:00:00 2001 From: Jon Ludlam Date: Wed, 27 Nov 2024 15:59:32 +0000 Subject: [PATCH 8/8] More semi resolving of references --- src/xref2/errors.ml | 5 +- src/xref2/ref_tools.ml | 131 ++++++++++++++++++++++++++--------------- 2 files changed, 89 insertions(+), 47 deletions(-) diff --git a/src/xref2/errors.ml b/src/xref2/errors.ml index 007ba83e94..09049cd320 100644 --- a/src/xref2/errors.ml +++ b/src/xref2/errors.ml @@ -121,7 +121,8 @@ module Tools_error = struct [ `Not_found | `Is_directory | `Wrong_kind of path_kind list * path_kind ] * Reference.tag_hierarchy * string list - | `Parent of parent_lookup_error ] + | `Parent of parent_lookup_error + | `Lookup_by_id of Identifier.t ] type any = [ simple_type_lookup_error @@ -252,6 +253,8 @@ module Tools_error = struct ) | `Path_error (err, tag, path) -> pp_path_error fmt err tag path | `Parent e -> pp fmt (e :> any) + | `Lookup_by_id id -> Format.fprintf fmt "Couldn't find identifier %s" + (String.concat "." (Identifier.fullname id)) end type kind = [ `OpaqueModule | `Root of string ] diff --git a/src/xref2/ref_tools.ml b/src/xref2/ref_tools.ml index ba84a6b78b..6dfd0a555a 100644 --- a/src/xref2/ref_tools.ml +++ b/src/xref2/ref_tools.ml @@ -181,8 +181,26 @@ let type_lookup_to_class_signature_lookup = |> of_option ~error:(`Parent (`Parent_type `OpaqueClass)) >>= resolved p' -module M = struct - (** Module *) +module rec M +: sig + type t = module_lookup_result + + val of_component : Env.t -> Component.Module.t -> Cpath.Resolved.module_ -> Resolved.Module.t -> t + + val in_signature : Env.t -> signature_lookup_result -> + ModuleName.t -> + (t, Errors.Tools_error.reference_lookup_error) result + + val of_element : Env.t -> Component.Element.module_ -> t + + val in_env : Env.t -> string -> (t, Errors.Tools_error.reference_lookup_error) result + + val in_env_by_id : Env.t -> Identifier.Module.t -> (t, Errors.Tools_error.reference_lookup_error) result + end + + = + + struct (** Module *) type t = module_lookup_result @@ -225,56 +243,37 @@ module M = struct (`Parent (`Parent_module (`Lookup_failure_root (ModuleName.make_std name)))) - let rec in_env_by_id env id = + let rec in_env_by_id env (id : Identifier.Module.t) = match Env.lookup_by_id Env.s_module id env with | Some e -> Ok (of_element env e) | None -> match id.iv with - | `Module (p, name) -> + | `Module ({ Identifier.iv = #Identifier.Module.t_pv; _} as p, name) -> in_env_by_id env p >>= module_lookup_to_signature_lookup env >>= fun x -> in_signature env x name - | _ -> Error - (`Parent - (`Parent_module (`Lookup_failure_root (ModuleName.make_std (Identifier.name id))))) -end - -module Path = struct - (* let first_seg (`Root (s, _) | `Slash (_, s)) = s *) - - let mk_lookup_error (tag, path) = Error (`Path_error (`Not_found, tag, path)) - - let handle_lookup_error p = function - | Ok _ as ok -> ok - | Error `Not_found -> mk_lookup_error p + | `Module ({ Identifier.iv = #Identifier.ModuleType.t_pv; _} as p, name) -> + MT.in_env_by_id env p >>= + module_type_lookup_to_signature_lookup env >>= + fun x -> in_signature env x name + | `Module ({ Identifier.iv = `Result _; _}, _) + | `Parameter (_, _) + | `Root _ -> Error (`Lookup_by_id (id :> Identifier.t)) +end and + +MT : sig + type t = module_type_lookup_result - let page_in_env env p : page_lookup_result ref_result = - Env.lookup_page_by_path p env |> handle_lookup_error p >>= fun p -> - Ok (`Identifier p.name, p) + val of_element : Env.t -> Component.Element.module_type -> t - let asset_in_env env p : asset_lookup_result ref_result = - Env.lookup_asset_by_path p env |> handle_lookup_error p >>= fun p -> - Ok (`Identifier p.name) + val of_component : Env.t -> Component.ModuleType.t -> Cpath.Resolved.module_type -> Resolved.ModuleType.t -> t - let module_in_env env p : module_lookup_result ref_result = - Env.lookup_unit_by_path p env |> handle_lookup_error p >>= fun m -> - Ok (M.of_element env m) + val in_signature : Env.t -> signature_lookup_result -> ModuleTypeName.t -> (t, Errors.Tools_error.reference_lookup_error) result + + val in_env : Env.t -> string -> (t, Errors.Tools_error.reference_lookup_error) result - let any_in_env env p : any_path_lookup_result ref_result = - (* TODO: Resolve modules *) - let page_result = page_in_env env p in - let module_result = module_in_env env p in - match (page_result, module_result) with - | Ok page, Error _ -> Ok (`P page) - | Error _, Ok m -> - module_lookup_to_signature_lookup env m >>= fun s -> Ok (`S s) - | Ok page, Ok _ -> - let name = List.last (snd p) in - ambiguous_generic_ref_warning name [ "module"; "page" ]; - Ok (`P page) - | Error _, Error _ -> mk_lookup_error p -end + val in_env_by_id : Env.t -> Identifier.ModuleType.t -> (t, Errors.Tools_error.reference_lookup_error) result -module MT = struct +end = struct (** Module type *) type t = module_type_lookup_result @@ -304,20 +303,60 @@ module MT = struct env_lookup_by_name Env.s_module_type name env >>= fun e -> Ok (of_element env e) - let in_env_by_id env id = + let rec in_env_by_id env id = match Env.lookup_by_id Env.s_module_type id env with | Some e -> Ok (of_element env e) | None -> match id.iv with - | `ModuleType (p, name) -> + | `ModuleType ({ Identifier.iv = #Identifier.Module.t_pv; _} as p, name) -> M.in_env_by_id env p >>= module_lookup_to_signature_lookup env >>= fun x -> in_signature env x name - | _ -> Error - (`Parent - (`Parent_module (`Lookup_failure_root (ModuleName.make_std (Identifier.name id))))) + | `ModuleType ({ Identifier.iv = #Identifier.ModuleType.t_pv; _} as p, name) -> + in_env_by_id env p >>= + module_type_lookup_to_signature_lookup env >>= + fun x -> in_signature env x name + | `ModuleType ({ Identifier.iv = `Result _; _}, _) -> + Error (`Lookup_by_id (id :> Identifier.t)) end +module Path = struct + (* let first_seg (`Root (s, _) | `Slash (_, s)) = s *) + + let mk_lookup_error (tag, path) = Error (`Path_error (`Not_found, tag, path)) + + let handle_lookup_error p = function + | Ok _ as ok -> ok + | Error `Not_found -> mk_lookup_error p + + let page_in_env env p : page_lookup_result ref_result = + Env.lookup_page_by_path p env |> handle_lookup_error p >>= fun p -> + Ok (`Identifier p.name, p) + + let asset_in_env env p : asset_lookup_result ref_result = + Env.lookup_asset_by_path p env |> handle_lookup_error p >>= fun p -> + Ok (`Identifier p.name) + + let module_in_env env p : module_lookup_result ref_result = + Env.lookup_unit_by_path p env |> handle_lookup_error p >>= fun m -> + Ok (M.of_element env m) + + let any_in_env env p : any_path_lookup_result ref_result = + (* TODO: Resolve modules *) + let page_result = page_in_env env p in + let module_result = module_in_env env p in + match (page_result, module_result) with + | Ok page, Error _ -> Ok (`P page) + | Error _, Ok m -> + module_lookup_to_signature_lookup env m >>= fun s -> Ok (`S s) + | Ok page, Ok _ -> + let name = List.last (snd p) in + ambiguous_generic_ref_warning name [ "module"; "page" ]; + Ok (`P page) + | Error _, Error _ -> mk_lookup_error p +end + + module CL = struct (** Class *)