From 8c6e322cdd224951e43cbc278b067515ea14433f Mon Sep 17 00:00:00 2001 From: lubegasimon Date: Fri, 26 Feb 2021 20:12:25 +0300 Subject: [PATCH] stop rendering dead links Signed-off-by: lubegasimon --- src/compat/odoc_compat.ml | 6 +- src/document/generator.ml | 38 ++- src/loader/cmi.ml | 3 +- src/loader/cmi.mli | 2 - src/loader/cmt.ml | 2 +- src/loader/cmti.ml | 3 +- src/loader/cmti.mli | 1 - src/loader/doc_attr.ml | 58 ++-- src/loader/doc_attr.mli | 2 + src/loader/dune | 18 + src/{model => loader}/ident_env.cppo.ml | 319 ++++++++++-------- src/{model => loader}/ident_env.cppo.mli | 2 + src/model/dune | 18 - test/cases/stop_dead_link_doc.mli | 27 ++ .../Stop_dead_link_doc/index.html | 119 +++++++ .../Stop_dead_link_doc/index.html | 123 +++++++ test/html/test.ml | 4 + 17 files changed, 527 insertions(+), 218 deletions(-) rename src/{model => loader}/ident_env.cppo.ml (63%) rename src/{model => loader}/ident_env.cppo.mli (99%) create mode 100644 test/cases/stop_dead_link_doc.mli create mode 100644 test/html/expect/test_package+ml/Stop_dead_link_doc/index.html create mode 100644 test/html/expect/test_package+re/Stop_dead_link_doc/index.html diff --git a/src/compat/odoc_compat.ml b/src/compat/odoc_compat.ml index 46c05ad123..2812d249af 100644 --- a/src/compat/odoc_compat.ml +++ b/src/compat/odoc_compat.ml @@ -1,7 +1,7 @@ (** - Compatibility module reexporting ~equivalent functions based on the current - OCaml version - *) + Compatibility module reexporting ~equivalent functions based on the current + OCaml version +*) module String = struct include String diff --git a/src/document/generator.ml b/src/document/generator.ml index 140b138c78..4b39067d42 100644 --- a/src/document/generator.ml +++ b/src/document/generator.ml @@ -459,6 +459,27 @@ module Make (Syntax : SYNTAX) = struct O.documentedSrc (cstr ++ O.txt " " ++ O.keyword "of" ++ O.txt " ") @ record fields + let rec read_typ_exp typ_expr = + let open Lang.TypeExpr in + let open Paths.Path in + match typ_expr with + | Constr (p, ts) -> + is_hidden (p :> Paths.Path.t) + || List.exists (fun t -> read_typ_exp t) ts + | Poly (_, t) | Alias (t, _) -> read_typ_exp t + | Arrow (_, t, t2) -> read_typ_exp t || read_typ_exp t2 + | Tuple ts | Class (_, ts) -> List.exists (fun t -> read_typ_exp t) ts + | _ -> false + + let internal_cstr_arg t = + let open Lang.TypeDecl.Constructor in + let open Lang.TypeDecl.Field in + match t.args with + | Tuple type_exprs -> + List.exists (fun type_expr -> read_typ_exp type_expr) type_exprs + | Record fields -> + List.exists (fun field -> read_typ_exp field.type_) fields + let variant cstrs : DocumentedSrc.t = let constructor id args res = match Url.from_identifier ~stop_before:true id with @@ -476,6 +497,7 @@ module Make (Syntax : SYNTAX) = struct | _ :: _ -> let rows = cstrs + |> List.filter (fun cstr -> not (internal_cstr_arg cstr)) |> List.map (fun cstr -> let open Odoc_model.Lang.TypeDecl.Constructor in let url, attrs, code = @@ -693,13 +715,15 @@ module Make (Syntax : SYNTAX) = struct | Variant cstrs -> variant cstrs | Record fields -> record fields in - O.documentedSrc - ( O.txt " = " - ++ - if need_private then - O.keyword Syntax.Type.private_keyword ++ O.txt " " - else O.noop ) - @ content + if List.length content > 0 then + O.documentedSrc + ( O.txt " = " + ++ + if need_private then + O.keyword Syntax.Type.private_keyword ++ O.txt " " + else O.noop ) + @ content + else [] in let tconstr = match t.equation.params with diff --git a/src/loader/cmi.ml b/src/loader/cmi.ml index 4040085882..726ebff9e3 100644 --- a/src/loader/cmi.ml +++ b/src/loader/cmi.ml @@ -23,9 +23,8 @@ open Odoc_model.Paths open Odoc_model.Lang open Odoc_model.Names -module Env = Odoc_model.Ident_env +module Env = Ident_env module Paths = Odoc_model.Paths -module Ident_env = Odoc_model.Ident_env let opt_map f = function | None -> None diff --git a/src/loader/cmi.mli b/src/loader/cmi.mli index 48619a3317..23a198fe16 100644 --- a/src/loader/cmi.mli +++ b/src/loader/cmi.mli @@ -17,8 +17,6 @@ module Paths = Odoc_model.Paths -module Ident_env = Odoc_model.Ident_env - val read_interface: Odoc_model.Paths.Identifier.ContainerPage.t -> string -> Odoc_model.Compat.signature -> diff --git a/src/loader/cmt.ml b/src/loader/cmt.ml index 02d3278446..6669d0d9db 100644 --- a/src/loader/cmt.ml +++ b/src/loader/cmt.ml @@ -23,7 +23,7 @@ module OCamlPath = Path open Odoc_model.Paths open Odoc_model.Lang -module Env = Odoc_model.Ident_env +module Env = Ident_env let read_core_type env ctyp = diff --git a/src/loader/cmti.ml b/src/loader/cmti.ml index 6fe03b400e..3220eedf04 100644 --- a/src/loader/cmti.ml +++ b/src/loader/cmti.ml @@ -23,9 +23,8 @@ open Odoc_model.Paths open Odoc_model.Lang open Odoc_model.Names -module Env = Odoc_model.Ident_env +module Env = Ident_env module Paths = Odoc_model.Paths -module Ident_env = Odoc_model.Ident_env let read_module_expr : (Ident_env.t -> Identifier.Signature.t -> Identifier.LabelParent.t -> Typedtree.module_expr -> ModuleType.expr) ref = ref (fun _ _ _ _ -> failwith "unset") diff --git a/src/loader/cmti.mli b/src/loader/cmti.mli index 951d2a2aef..4032332a19 100644 --- a/src/loader/cmti.mli +++ b/src/loader/cmti.mli @@ -15,7 +15,6 @@ *) module Paths = Odoc_model.Paths -module Ident_env = Odoc_model.Ident_env val read_module_expr : (Ident_env.t -> Paths.Identifier.Signature.t -> Paths.Identifier.LabelParent.t -> Typedtree.module_expr -> Odoc_model.Lang.ModuleType.expr) ref val read_interface : diff --git a/src/loader/doc_attr.ml b/src/loader/doc_attr.ml index 300b3ccc31..97c6d2e95c 100644 --- a/src/loader/doc_attr.ml +++ b/src/loader/doc_attr.ml @@ -28,7 +28,7 @@ let empty : Odoc_model.Comment.docs = empty_body -let load_payload : Parsetree.payload -> (string * Location.t) option = function +let load_payload : Parsetree.payload -> string * Location.t = function | PStr [{pstr_desc = Pstr_eval ({pexp_desc = #if OCAML_MAJOR = 4 && OCAML_MINOR = 02 @@ -39,9 +39,21 @@ let load_payload : Parsetree.payload -> (string * Location.t) option = function Pexp_constant (Pconst_string (text, _, _)) #endif ; pexp_loc = loc; _}, _); _}] -> - Some (text, loc) - | _ -> - None + (text, loc) + | _ -> assert false + + + let parse_attribute : Parsetree.attribute -> (string * Location.t) option = function + #if OCAML_MAJOR = 4 && OCAML_MINOR >= 08 + | { attr_name = { Location.txt = + ("text" | "ocaml.text"); loc = _loc}; attr_payload; _ } -> begin + #else + | ({Location.txt = + ("text" | "ocaml.text"); loc = _loc}, attr_payload) -> begin + #endif + Some (load_payload attr_payload) + end + | _ -> None let attached parent attrs = let ocaml_deprecated = ref None in @@ -56,7 +68,7 @@ let attached parent attrs = ("doc" | "ocaml.doc"); loc = _loc}, attr_payload) :: rest -> begin #endif match load_payload attr_payload with - | Some (str, loc) -> begin + | (str, loc) -> begin let start_pos = loc.Location.loc_start in let start_pos = {start_pos with pos_cnum = start_pos.pos_cnum + 3} in @@ -70,7 +82,6 @@ let attached parent attrs = in loop false 0 (acc @ parsed) rest end - | None -> (* TODO *) assert false end | _ :: rest -> loop first nb_deprecated acc rest | [] -> begin @@ -96,32 +107,15 @@ let read_string parent loc str : Odoc_model.Comment.docs_or_stop = let page = read_string -let standalone parent - : Parsetree.attribute -> Odoc_model.Comment.docs_or_stop option = - - function -#if OCAML_MAJOR = 4 && OCAML_MINOR >= 08 - | { attr_name = { Location.txt = - ("text" | "ocaml.text"); loc = _loc}; attr_payload; _ } -> begin -#else - | ({Location.txt = - ("text" | "ocaml.text"); loc = _loc}, attr_payload) -> begin -#endif - match load_payload attr_payload with - | Some ("/*", _loc) -> Some `Stop - | Some (str, loc) -> - let loc' = - { loc with - loc_start = { loc.loc_start with pos_cnum = loc.loc_start.pos_cnum + 3 } } - in - Some (read_string parent loc' str) - | None -> - (* TODO *) - assert false - (* let doc : Odoc_model.Comment.t = - Error (invalid_attribute_error parent loc) in - Some (Documentation doc) *) - end +let standalone parent(attr : Parsetree.attribute): Odoc_model.Comment.docs_or_stop option = + match parse_attribute attr with + | Some ("/*", _loc) -> Some `Stop + | Some (str, loc) -> + let loc' = + { loc with + loc_start = { loc.loc_start with pos_cnum = loc.loc_start.pos_cnum + 3 } } + in + Some (read_string parent loc' str) | _ -> None let standalone_multiple parent attrs = diff --git a/src/loader/doc_attr.mli b/src/loader/doc_attr.mli index 34f7f8e9bf..357fb99a0d 100644 --- a/src/loader/doc_attr.mli +++ b/src/loader/doc_attr.mli @@ -22,6 +22,8 @@ module Paths = Odoc_model.Paths val empty : Odoc_model.Comment.docs +val parse_attribute : Parsetree.attribute -> (string * Location.t) option + val attached : Paths.Identifier.LabelParent.t -> Parsetree.attributes -> diff --git a/src/loader/dune b/src/loader/dune index 0657954867..a6b842122a 100644 --- a/src/loader/dune +++ b/src/loader/dune @@ -1,3 +1,21 @@ +(rule + (targets ident_env.ml) + (deps + (:x ident_env.cppo.ml)) + (action + (chdir + %{workspace_root} + (run %{bin:cppo} -V OCAML:%{ocaml_version} %{x} -o %{targets})))) + +(rule + (targets ident_env.mli) + (deps + (:x ident_env.cppo.mli)) + (action + (chdir + %{workspace_root} + (run %{bin:cppo} -V OCAML:%{ocaml_version} %{x} -o %{targets})))) + (library (name odoc_loader) (public_name odoc.loader) diff --git a/src/model/ident_env.cppo.ml b/src/loader/ident_env.cppo.ml similarity index 63% rename from src/model/ident_env.cppo.ml rename to src/loader/ident_env.cppo.ml index 20d3388b51..fe475a3fa7 100644 --- a/src/model/ident_env.cppo.ml +++ b/src/loader/ident_env.cppo.ml @@ -14,6 +14,7 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) +open Odoc_model open Predefined open Names @@ -30,7 +31,8 @@ type t = values: Id.Value.t Ident.tbl; classes : Id.Class.t Ident.tbl; class_types : Id.ClassType.t Ident.tbl; - shadowed : Ident.t list } + hidden : Ident.t list; (* we use term hidden to mean shadowed and idents_in_doc_off_mode items*) + } let empty = { modules = Ident.empty; @@ -40,7 +42,8 @@ let empty = values = Ident.empty; classes = Ident.empty; class_types = Ident.empty; - shadowed = [] } + hidden = []; + } (* The boolean is an override for whether it should be hidden - true only for items introduced by extended open *) @@ -153,55 +156,63 @@ let extract_extended_open o = #endif -let extract_signature_tree_item item = +let rec extract_signature_tree_items hide_item items = let open Typedtree in - match item.sig_desc with + match items with #if OCAML_MAJOR = 4 && OCAML_MINOR = 02 - | Tsig_type decls -> + | { sig_desc = Tsig_type decls; _} :: rest -> #else - | Tsig_type (_rec_flag, decls) -> (* TODO: handle rec_flag *) + | { sig_desc = Tsig_type (_, decls); _} :: rest -> #endif - List.map (fun decl -> `Type (decl.typ_id, false)) decls + List.map (fun decl -> `Type (decl.typ_id, hide_item)) + decls @ extract_signature_tree_items hide_item rest #if OCAML_MAJOR = 4 && OCAML_MINOR >= 10 - | Tsig_module { md_id = Some id; _ } -> - [`Module (id, false)] - | Tsig_module _ -> - [] - | Tsig_recmodule mds -> - List.fold_right - (fun md items -> - match md.md_id with - | Some id -> `Module (id, false) :: items - | None -> items) - mds [] -#else - | Tsig_module { md_id; _ } -> - [`Module (md_id, false)] - | Tsig_recmodule mds -> - List.map (fun md -> `Module (md.md_id, false)) mds + | { sig_desc = Tsig_module { md_id = Some id; _ }; _} :: rest -> + [`Module (id, hide_item)] @ extract_signature_tree_items hide_item rest + | { sig_desc = Tsig_module _; _ } :: rest -> + extract_signature_tree_items hide_item rest + | { sig_desc = Tsig_recmodule mds; _} :: rest -> + List.fold_right ( + fun md items -> + match md.md_id with + | Some id -> `Module (id, hide_item) :: items + | None -> items) + mds [] @ extract_signature_tree_items hide_item rest +#else + | { sig_desc = Tsig_module{ md_id; _}; _} :: rest -> + [`Module (md_id, hide_item)] @ extract_signature_tree_items hide_item rest + | { sig_desc = Tsig_recmodule mds; _ } :: rest -> + List.map (fun md -> `Module (md.md_id, hide_item)) + mds @ extract_signature_tree_items hide_item rest #endif - | Tsig_value {val_id; _} -> - [`Value (val_id, false)] - | Tsig_modtype mtd -> - [`ModuleType (mtd.mtd_id, false)] - | Tsig_include incl -> - [`Include (extract_signature_type_items (Compat.signature incl.incl_type))] - | Tsig_class cls -> - List.map - (fun cld -> - let typehash = + | { sig_desc = Tsig_value {val_id; _}; _ } :: rest-> + [`Value (val_id, hide_item)] @ extract_signature_tree_items hide_item rest + | { sig_desc = Tsig_modtype mtd; _} :: rest -> + [`ModuleType (mtd.mtd_id, hide_item)] @ extract_signature_tree_items hide_item rest + | {sig_desc = Tsig_include incl; _ } :: rest -> + [`Include (extract_signature_type_items (Compat.signature incl.incl_type))] @ extract_signature_tree_items hide_item rest + | {sig_desc = Tsig_attribute attr; _ } :: rest -> begin + match Doc_attr.parse_attribute attr with + | Some ("/*", _) -> extract_signature_tree_items (not hide_item) rest + | _ -> extract_signature_tree_items hide_item rest + end + | {sig_desc = Tsig_class cls; _} :: rest -> + List.map + (fun cld -> + let typehash = #if OCAML_MAJOR = 4 && OCAML_MINOR < 04 - cld.ci_id_typesharp + cld.ci_id_typesharp #else - cld.ci_id_typehash + cld.ci_id_typehash #endif - in - `Class (cld.ci_id_class, cld.ci_id_class_type, cld.ci_id_object, typehash, false)) cls - | Tsig_class_type cltyps -> - List.map - (fun clty -> - let typehash = + in + `Class (cld.ci_id_class, cld.ci_id_class_type, cld.ci_id_object, typehash, hide_item)) + cls @ extract_signature_tree_items hide_item rest + | { sig_desc = Tsig_class_type cltyps; _ } :: rest -> + List.map + (fun clty -> + let typehash = #if OCAML_MAJOR = 4 && OCAML_MINOR < 04 clty.ci_id_typesharp #else @@ -209,77 +220,86 @@ let extract_signature_tree_item item = #endif in - `ClassType (clty.ci_id_class_type, clty.ci_id_object, typehash, false )) cltyps + `ClassType (clty.ci_id_class_type, clty.ci_id_object, typehash, hide_item)) + cltyps @ extract_signature_tree_items hide_item rest #if OCAML_MAJOR = 4 && OCAML_MINOR >= 08 - | Tsig_modsubst ms -> - [`Module (ms.ms_id, false)] - | Tsig_typesubst ts -> - List.map (fun decl -> `Type (decl.typ_id, false)) ts + | { sig_desc = Tsig_modsubst ms; _} :: rest -> + [`Module (ms.ms_id, hide_item)] @ extract_signature_tree_items hide_item rest + | { sig_desc = Tsig_typesubst ts; _} :: rest -> + List.map (fun decl -> `Type (decl.typ_id, hide_item)) + ts @ extract_signature_tree_items hide_item rest #endif - | Tsig_typext _ - | Tsig_exception _ | Tsig_open _ - | Tsig_attribute _ -> [] - -let extract_signature_tree_items sg = - let open Typedtree in - List.map extract_signature_tree_item sg.sig_items |> List.flatten + | { sig_desc = Tsig_typext _; _} :: rest + | { sig_desc = Tsig_exception _; _} :: rest + | { sig_desc = Tsig_open _;_} :: rest -> extract_signature_tree_items hide_item rest + | [] -> [] -let rec read_pattern pat = +let rec read_pattern hide_item pat = let open Typedtree in match pat.pat_desc with - | Tpat_var(id, _) -> [`Value(id, false)] - | Tpat_alias(pat, id, _) -> `Value(id, false) :: read_pattern pat + | Tpat_var(id, _) -> [`Value(id, hide_item)] + | Tpat_alias(pat, id, _) -> `Value(id, hide_item) :: read_pattern hide_item pat | Tpat_record(pats, _) -> - List.concat (List.map (fun (_, _, pat) -> read_pattern pat) pats) + List.concat (List.map (fun (_, _, pat) -> read_pattern hide_item pat) pats) | Tpat_construct(_, _, pats) | Tpat_array pats - | Tpat_tuple pats -> List.concat (List.map read_pattern pats) + | Tpat_tuple pats -> List.concat (List.map (fun pat -> read_pattern hide_item pat) pats) | Tpat_or(pat, _, _) | Tpat_variant(_, Some pat, _) - | Tpat_lazy pat -> read_pattern pat + | Tpat_lazy pat -> read_pattern hide_item pat | Tpat_any | Tpat_constant _ | Tpat_variant(_, None, _) -> [] #if OCAML_MAJOR = 4 && OCAML_MINOR >= 08 && OCAML_MINOR < 11 - | Tpat_exception pat -> read_pattern pat + | Tpat_exception pat -> read_pattern hide_item pat #endif -let extract_structure_tree_item item = +let rec extract_structure_tree_items hide_item items = let open Typedtree in - match item.str_desc with + match items with #if OCAML_MAJOR = 4 && OCAML_MINOR = 02 - | Tstr_type decls -> + | { str_desc = Tstr_type decls; _ } :: rest -> #else - | Tstr_type (_rec_flag, decls) -> (* TODO: handle rec_flag *) + | { str_desc = Tstr_type (_, decls); _ } :: rest -> (* TODO: handle rec_flag *) #endif - List.map (fun decl -> `Type (decl.typ_id, false)) decls + List.map (fun decl -> `Type (decl.typ_id, hide_item)) + decls @ extract_structure_tree_items hide_item rest #if OCAML_MAJOR = 4 && OCAML_MINOR < 03 - | Tstr_value (_, vbs )-> + | { str_desc = Tstr_value (_, vbs ); _} :: rest -> #else - | Tstr_value (_rec_flag, vbs) -> (*TODO: handle rec_flag *) + | { str_desc = Tstr_value (_, vbs); _ } :: rest -> (*TODO: handle rec_flag *) #endif - List.map (fun vb -> read_pattern vb.vb_pat) vbs |> List.flatten + ( List.map (fun vb -> read_pattern hide_item vb.vb_pat) vbs + |> List.flatten) @ extract_structure_tree_items hide_item rest #if OCAML_MAJOR = 4 && OCAML_MINOR >= 10 - | Tstr_module { mb_id = Some id; _} -> - [`Module (id, false)] - | Tstr_module _ -> [] - | Tstr_recmodule mbs -> + | { str_desc = Tstr_module { mb_id = Some id; _}; _} :: rest -> + [`Module (id, hide_item)] @ extract_structure_tree_items hide_item rest + | { str_desc = Tstr_module _; _} :: rest -> extract_structure_tree_items hide_item rest + | { str_desc = Tstr_recmodule mbs; _ } :: rest -> List.fold_right (fun mb items -> match mb.mb_id with - | Some id -> `Module (id, false) :: items - | None -> items) mbs [] + | Some id -> `Module (id, hide_item) :: items + | None -> items) mbs [] @ extract_structure_tree_items hide_item rest #else - | Tstr_module { mb_id; _} -> [`Module (mb_id, false)] - | Tstr_recmodule mbs -> - List.map (fun mb -> `Module (mb.mb_id, false)) mbs + | { str_desc = Tstr_module { mb_id; _}; _} :: rest -> + [`Module (mb_id, hide_item)] @ extract_structure_tree_items hide_item rest + | { str_desc = Tstr_recmodule mbs; _} :: rest -> + List.map (fun mb -> `Module (mb.mb_id, hide_item)) + mbs @ extract_structure_tree_items hide_item rest #endif - | Tstr_modtype mtd -> - [`ModuleType (mtd.mtd_id, false)] - | Tstr_include incl -> - [`Include (extract_signature_type_items (Compat.signature incl.incl_type))] - | Tstr_class cls -> + | { str_desc = Tstr_modtype mtd; _ } :: rest -> + [`ModuleType (mtd.mtd_id, hide_item)] @ extract_structure_tree_items hide_item rest + | { str_desc = Tstr_include incl; _ } :: rest -> + [`Include (extract_signature_type_items (Compat.signature incl.incl_type))] @ extract_structure_tree_items hide_item rest + + | { str_desc = Tstr_attribute attr; _} :: rest -> begin + match Doc_attr.parse_attribute attr with + | Some ("/*", _) -> extract_structure_tree_items (not hide_item) rest + | _ -> extract_structure_tree_items hide_item rest + end + | { str_desc = Tstr_class cls; _ } :: rest -> List.map #if OCAML_MAJOR = 4 && OCAML_MINOR = 02 (fun (cld, _, _) -> @@ -293,9 +313,9 @@ let extract_structure_tree_item item = #else cld.ci_id_typehash, #endif - false - )) cls - | Tstr_class_type cltyps -> + hide_item + )) cls @ extract_structure_tree_items hide_item rest + | {str_desc = Tstr_class_type cltyps; _ } :: rest -> List.map (fun (_, _, clty) -> `ClassType (clty.ci_id_class_type, @@ -305,24 +325,21 @@ let extract_structure_tree_item item = #else clty.ci_id_typehash, #endif - false - )) cltyps + hide_item + )) cltyps @ extract_structure_tree_items hide_item rest #if OCAML_MAJOR = 4 && OCAML_MINOR < 08 - | Tstr_open _ -> [] + | { str_desc = Tstr_open _; _} :: rest -> extract_structure_tree_items hide_item rest #else - | Tstr_open o -> - ((extract_extended_open o) :> extracted_items list) + | { str_desc = Tstr_open o; _ } :: rest -> + ((extract_extended_open o) :> extracted_items list) @ extract_structure_tree_items hide_item rest #endif - | Tstr_primitive {val_id; _} -> - [`Value (val_id, false)] - | Tstr_eval _ - | Tstr_typext _ - | Tstr_exception _ - | Tstr_attribute _ -> [] - -let extract_structure_tree_items str = - let open Typedtree in - List.map extract_structure_tree_item str.str_items |> List.flatten + | { str_desc = Tstr_primitive {val_id; _}; _} :: rest -> + [`Value (val_id, false)] @ extract_structure_tree_items hide_item rest + | { str_desc = Tstr_eval _; _} :: rest + | { str_desc = Tstr_typext _; _} :: rest + | {str_desc = Tstr_exception _; _ } :: rest -> extract_structure_tree_items hide_item rest + | [] -> [] + let flatten_extracted : extracted_items list -> extracted_item list = fun items -> List.map (function @@ -355,88 +372,90 @@ let class_type_name_exists name items = let env_of_items parent items env = let rec inner items env = match items with - | `Type (t,force_shadowed) :: rest -> + | `Type (t, is_hidden_item) :: rest -> let name = Ident.name t in - let is_shadowed = force_shadowed || type_name_exists name rest in - let identifier, shadowed = - if is_shadowed - then `Type(parent, TypeName.internal_of_string name), t :: env.shadowed - else `Type(parent, TypeName.make_std name), env.shadowed + let is_hidden = is_hidden_item || type_name_exists name rest in + let identifier, hidden = + if is_hidden + then `Type(parent, TypeName.internal_of_string name), t :: env.hidden + else `Type(parent, TypeName.make_std name), env.hidden in let types = Ident.add t identifier env.types in - inner rest { env with types; shadowed } + inner rest { env with types; hidden } - | `Value (t,force_shadowed) :: rest -> + | `Value (t, is_hidden_item) :: rest -> let name = Ident.name t in - let is_shadowed = force_shadowed || value_name_exists name rest in - let identifier, shadowed = - if is_shadowed - then `Value(parent, ValueName.internal_of_string name), t :: env.shadowed - else `Value(parent, ValueName.make_std name), env.shadowed + let is_hidden = is_hidden_item || value_name_exists name rest in + let identifier, hidden = + if is_hidden + then `Value(parent, ValueName.internal_of_string name), t :: env.hidden + else `Value(parent, ValueName.make_std name), env.hidden in let values = Ident.add t identifier env.values in - inner rest { env with values; shadowed } + inner rest { env with values; hidden } - | `ModuleType (t, force_shadowed) :: rest -> + | `ModuleType (t, is_hidden_item) :: rest -> let name = Ident.name t in - let is_shadowed = force_shadowed || module_type_name_exists name rest in - let identifier, shadowed = - if is_shadowed - then `ModuleType(parent, ModuleTypeName.internal_of_string name), t :: env.shadowed - else `ModuleType(parent, ModuleTypeName.make_std name), env.shadowed + let is_hidden = is_hidden_item || module_type_name_exists name rest in + let identifier, hidden = + if is_hidden + then `ModuleType(parent, ModuleTypeName.internal_of_string name), t :: env.hidden + else `ModuleType(parent, ModuleTypeName.make_std name), env.hidden in let module_types = Ident.add t identifier env.module_types in - inner rest { env with module_types; shadowed } - | `Module (t, force_shadowed) :: rest -> + inner rest { env with module_types; hidden } + + | `Module (t, is_hidden_item) :: rest -> let name = Ident.name t in - let is_shadowed = force_shadowed || module_name_exists name rest in - let identifier, shadowed = - if is_shadowed - then `Module(parent, ModuleName.internal_of_string name), t :: env.shadowed - else `Module(parent, ModuleName.make_std name), env.shadowed + let is_hidden = is_hidden_item || module_name_exists name rest in + let identifier, hidden = + if is_hidden + then `Module(parent, ModuleName.internal_of_string name), t :: env.hidden + else `Module(parent, ModuleName.make_std name), env.hidden in - let path = `Identifier(identifier, is_shadowed) in + let path = `Identifier(identifier, is_hidden) in let modules = Ident.add t identifier env.modules in let module_paths = Ident.add t path env.module_paths in - inner rest { env with modules; module_paths; shadowed } - | `Class (t,t2,t3,t4,force_shadowed) :: rest -> + inner rest { env with modules; module_paths; hidden } + + | `Class (t,t2,t3,t4, is_hidden_item) :: rest -> let name = Ident.name t in - let is_shadowed = force_shadowed || class_name_exists name rest in - let identifier, shadowed = - if is_shadowed - then `Class(parent, ClassName.internal_of_string name), t :: t2 :: t3 :: t4 :: env.shadowed - else `Class(parent, ClassName.make_std name), env.shadowed + let is_hidden = is_hidden_item || class_name_exists name rest in + let identifier, hidden = + if is_hidden + then `Class(parent, ClassName.internal_of_string name), t :: t2 :: t3 :: t4 :: env.hidden + else `Class(parent, ClassName.make_std name), env.hidden in let classes = List.fold_right (fun id classes -> Ident.add id identifier classes) [t; t2; t3; t4] env.classes in - inner rest { env with classes; shadowed } - | `ClassType (t,t2,t3,force_shadowed) :: rest -> + inner rest { env with classes; hidden } + + | `ClassType (t,t2,t3, is_hidden_item) :: rest -> let name = Ident.name t in - let is_shadowed = force_shadowed || class_type_name_exists name rest in - let identifier, shadowed = - if is_shadowed - then `ClassType(parent, ClassTypeName.internal_of_string name), t :: t2 :: t3 :: env.shadowed - else `ClassType(parent, ClassTypeName.make_std name), env.shadowed + let is_hidden = is_hidden_item || class_type_name_exists name rest in + let identifier, hidden = + if is_hidden + then `ClassType(parent, ClassTypeName.internal_of_string name), t :: t2 :: t3 :: env.hidden + else `ClassType(parent, ClassTypeName.make_std name), env.hidden in let class_types = List.fold_right (fun id class_types -> Ident.add id identifier class_types) [t; t2; t3] env.class_types in - inner rest { env with class_types; shadowed } + inner rest { env with class_types; hidden } + | [] -> env in inner items env - - let add_signature_tree_items : Paths.Identifier.Signature.t -> Typedtree.signature -> t -> t = fun parent sg env -> - let items = extract_signature_tree_items sg |> flatten_extracted in + let items = extract_signature_tree_items false sg.sig_items |> flatten_extracted in env_of_items parent items env let add_structure_tree_items : Paths.Identifier.Signature.t -> Typedtree.structure -> t -> t = fun parent sg env -> - let items = extract_structure_tree_items sg |> flatten_extracted in + let items = extract_structure_tree_items false sg.str_items |> flatten_extracted in env_of_items parent items env let handle_signature_type_items : Paths.Identifier.Signature.t -> Compat.signature -> t -> t = @@ -495,9 +514,9 @@ let find_class_identifier env id = let find_class_type_identifier env id = Ident.find_same id env.class_types -let is_shadowed env id = - List.mem id env.shadowed - +let is_shadowed + env id = + List.mem id env.hidden module Path = struct let read_module_ident env id = diff --git a/src/model/ident_env.cppo.mli b/src/loader/ident_env.cppo.mli similarity index 99% rename from src/model/ident_env.cppo.mli rename to src/loader/ident_env.cppo.mli index 246c6234a7..0976448d06 100644 --- a/src/model/ident_env.cppo.mli +++ b/src/loader/ident_env.cppo.mli @@ -14,6 +14,8 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) +open Odoc_model + type t val empty : t diff --git a/src/model/dune b/src/model/dune index a35617ab49..ebbf059dc2 100644 --- a/src/model/dune +++ b/src/model/dune @@ -1,21 +1,3 @@ -(rule - (targets ident_env.ml) - (deps - (:x ident_env.cppo.ml)) - (action - (chdir - %{workspace_root} - (run %{bin:cppo} -V OCAML:%{ocaml_version} %{x} -o %{targets})))) - -(rule - (targets ident_env.mli) - (deps - (:x ident_env.cppo.mli)) - (action - (chdir - %{workspace_root} - (run %{bin:cppo} -V OCAML:%{ocaml_version} %{x} -o %{targets})))) - (rule (targets compat.ml) (deps diff --git a/test/cases/stop_dead_link_doc.mli b/test/cases/stop_dead_link_doc.mli new file mode 100644 index 0000000000..351e2b1b6c --- /dev/null +++ b/test/cases/stop_dead_link_doc.mli @@ -0,0 +1,27 @@ +(* This tests that references to hidden items (items in no documentation mode) don't get rendered *) + +module Foo : sig + type t +end + +type foo = | Bar of Foo.t + +type bar = | Bar of { field : Foo.t } + +type foo_ = Bar_ of (int * Foo.t) * int +type bar_ = Bar__ of Foo.t option + +(**/**) +module Another_Foo : sig + type t +end +(**/**) + +(* this should be rendered as `type another_foo` because it contains a reference to a hidden module*) +type another_foo = | Bar of Another_Foo.t + +(* this should be rendered as `type another_bar` because it contains a reference to a hidden module*) +type another_bar = | Bar of { field : Another_Foo.t } + +type another_foo_ = Bar_ of (int * Another_Foo.t) * int +type another_bar_ = Bar__ of Another_Foo.t option diff --git a/test/html/expect/test_package+ml/Stop_dead_link_doc/index.html b/test/html/expect/test_package+ml/Stop_dead_link_doc/index.html new file mode 100644 index 0000000000..5e466b451f --- /dev/null +++ b/test/html/expect/test_package+ml/Stop_dead_link_doc/index.html @@ -0,0 +1,119 @@ + + + + + Stop_dead_link_doc (test_package+ml.Stop_dead_link_doc) + + + + + + + + + + +
+

+ Module Stop_dead_link_doc +

+
+
+
+
+ module Foo : sig ... end +
+
+
+
+ type foo = + + + + + + +
+ | Bar of Foo.t +
+
+
+
+
+ type bar = + + + + + + +
+ | Bar of { + + + + + + +
+ field : Foo.t; +
+ } +
+
+
+
+
+ type foo_ = + + + + + + +
+ | Bar_ of int * Foo.t * int +
+
+
+
+
+ type bar_ = + + + + + + +
+ | Bar__ of Foo.t option +
+
+
+
+
+ type another_foo +
+
+
+
+ type another_bar +
+
+
+
+ type another_foo_ +
+
+
+
+ type another_bar_ +
+
+
+ + diff --git a/test/html/expect/test_package+re/Stop_dead_link_doc/index.html b/test/html/expect/test_package+re/Stop_dead_link_doc/index.html new file mode 100644 index 0000000000..c8a34efc8c --- /dev/null +++ b/test/html/expect/test_package+re/Stop_dead_link_doc/index.html @@ -0,0 +1,123 @@ + + + + + Stop_dead_link_doc (test_package+re.Stop_dead_link_doc) + + + + + + + + + + +
+

+ Module Stop_dead_link_doc +

+
+
+
+
+ module Foo: { ... }; +
+
+
+
+ type foo = + + + + + + +
+ | Bar(Foo.t) +
+ ; +
+
+
+
+ type bar = + + + + + + +
+ | Bar of { + + + + + + +
+ field: Foo.t, +
+ } +
+ ; +
+
+
+
+ type foo_ = + + + + + + +
+ | Bar_((int, Foo.t), int) +
+ ; +
+
+
+
+ type bar_ = + + + + + + +
+ | Bar__(option(Foo.t)) +
+ ; +
+
+
+
+ type another_foo; +
+
+
+
+ type another_bar; +
+
+
+
+ type another_foo_; +
+
+
+
+ type another_bar_; +
+
+
+ + diff --git a/test/html/test.ml b/test/html/test.ml index 6269a448a0..0a380cd1f9 100644 --- a/test/html/test.ml +++ b/test/html/test.ml @@ -289,6 +289,9 @@ let source_files_post408 = let source_files_pre410 = [ ("bugs_pre_410.ml", [ "Bugs_pre_410/index.html" ]) ] +let source_files_post404 = + [ ("stop_dead_link_doc.mli", [ "Stop_dead_link_doc/index.html" ]) ] + let source_files = let cur = Astring.String.cuts ~sep:"." Sys.ocaml_version @@ -301,6 +304,7 @@ let source_files = (if major = 4 && minor < 10 then source_files_pre410 else []); (if major = 4 && minor > 8 then source_files_post408 else []); (if major = 4 && minor >= 6 then source_files_post406 else []); + (if major = 4 && minor >= 4 then source_files_post404 else []); source_files_all; ] | _ -> source_files_all