From d92243e3584eabbb5584523a0c8f09e7c44bb677 Mon Sep 17 00:00:00 2001 From: Benjamin Canou Date: Tue, 7 Jul 2026 13:23:41 +0200 Subject: [PATCH 1/2] source rendering: skip occurrences under [@merlin.hide] (fixes #1456) Honor [@merlin.hide] attribute to prevent collecting occurences from generated code with invalid non ghost locations (see ocaml/odoc#1456). The [@merlin.hide] attribute is used by Merlin to hide generated code. It is automatically added by ppx_deriving, and it hides a whole subtree (as opposed to a single node like ghost locations), making it a more reliable source of truth to detect generated code. --- CHANGES.md | 3 + src/loader/typedtree_traverse.ml | 130 ++++++++++++++++++++++++++----- 2 files changed, 115 insertions(+), 18 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 551d12f499..96632ed093 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,5 +1,8 @@ # Unreleased +- Fix #1456: don't emit spurious (and sometimes nested/invalid) source links for + ppx-generated code, by honouring the `[@merlin.hide]` attribute when collecting + source occurrences (@klakplok) - Support for OxCaml unboxed named types (@art-w, #1407) - Support for OxCaml zero alloc definitions (@Leonidas-from-XIV, #1422, #1444) - Remove requirement for ppx_expect in tests (@jonludlam, #1445) diff --git a/src/loader/typedtree_traverse.ml b/src/loader/typedtree_traverse.ml index e57e08047e..7f0fab4000 100644 --- a/src/loader/typedtree_traverse.ml +++ b/src/loader/typedtree_traverse.ml @@ -86,32 +86,114 @@ module Analysis = struct | _ -> () end +(* Honor [@merlin.hide] attribute to prevent collecting occurences from + generated code with invalid non ghost locations (see ocaml/odoc#1456). + + The [@merlin.hide] attribute is used by Merlin to hide generated code. + It is automatically added by ppx_deriving, and it hides a whole + subtree (as opposed to a single node like ghost locations), making it + a more reliable source of truth to detect generated code. + + Mirrors Merlin's [iter_only_visible] (src/analysis/ast_iterators.ml) and + Ppxlib.Location_check, which check [@merlin.hide] on every attribute-bearing + node. Keep the guarded nodes below in sync: we cover the kinds odoc collects + occurrences from, plus their recursion parents. *) +let not_hidden attrs = + not + (List.exists + (fun (a : Parsetree.attribute) -> a.attr_name.txt = "merlin.hide") + attrs) + let of_cmt env structure = let poses = ref [] in let iter = Tast_iterator.default_iterator in - let module_expr iterator mod_expr = - Analysis.module_expr poses mod_expr; - iter.module_expr iterator mod_expr + (* Nodes that carry occurrences: analyse then recurse, unless hidden. *) + let module_expr iterator ({ Typedtree.mod_attributes; _ } as mod_expr) = + if not_hidden mod_attributes then ( + Analysis.module_expr poses mod_expr; + iter.module_expr iterator mod_expr) + in + let expr iterator ({ Typedtree.exp_attributes; _ } as e) = + if not_hidden exp_attributes then ( + Analysis.expr poses e; + iter.expr iterator e) + in + let pat iterator (type k) (p : k Typedtree.general_pattern) = + if not_hidden p.pat_attributes then ( + Analysis.pat env poses p; + iter.pat iterator p) + in + let typ iterator ({ Typedtree.ctyp_attributes; _ } as ctyp_expr) = + if not_hidden ctyp_attributes then ( + Analysis.core_type poses ctyp_expr; + iter.typ iterator ctyp_expr) + in + let module_type iterator ({ Typedtree.mty_attributes; _ } as mty) = + if not_hidden mty_attributes then ( + Analysis.module_type poses mty; + iter.module_type iterator mty) + in + let module_binding iterator ({ Typedtree.mb_attributes; _ } as mb) = + if not_hidden mb_attributes then ( + Analysis.module_binding env poses mb; + iter.module_binding iterator mb) + in + (* Recursion parents (no occurrence of their own): prune when hidden. *) + let value_binding iterator ({ Typedtree.vb_attributes; _ } as vb) = + if not_hidden vb_attributes then iter.value_binding iterator vb + in + let value_description iterator ({ Typedtree.val_attributes; _ } as vd) = + if not_hidden val_attributes then iter.value_description iterator vd in - let expr iterator e = - Analysis.expr poses e; - iter.expr iterator e + let type_declaration iterator ({ Typedtree.typ_attributes; _ } as td) = + if not_hidden typ_attributes then iter.type_declaration iterator td in - let pat iterator e = - Analysis.pat env poses e; - iter.pat iterator e + let type_extension iterator ({ Typedtree.tyext_attributes; _ } as te) = + if not_hidden tyext_attributes then iter.type_extension iterator te in - let typ iterator ctyp_expr = - Analysis.core_type poses ctyp_expr; - iter.typ iterator ctyp_expr + let type_exception iterator ({ Typedtree.tyexn_attributes; _ } as te) = + if not_hidden tyexn_attributes then iter.type_exception iterator te in - let module_type iterator mty = - Analysis.module_type poses mty; - iter.module_type iterator mty + let extension_constructor iterator + ({ Typedtree.ext_attributes; _ } as ec) = + if not_hidden ext_attributes then iter.extension_constructor iterator ec in - let module_binding iterator mb = - Analysis.module_binding env poses mb; - iter.module_binding iterator mb + let module_declaration iterator ({ Typedtree.md_attributes; _ } as md) = + if not_hidden md_attributes then iter.module_declaration iterator md + in + let module_type_declaration iterator + ({ Typedtree.mtd_attributes; _ } as mtd) = + if not_hidden mtd_attributes then iter.module_type_declaration iterator mtd + in + let open_declaration iterator ({ Typedtree.open_attributes; _ } as od) = + if not_hidden open_attributes then iter.open_declaration iterator od + in + let open_description iterator ({ Typedtree.open_attributes; _ } as od) = + if not_hidden open_attributes then iter.open_description iterator od + in + (* The stock [Tast_iterator] has no [include_declaration]/[include_description] + field: includes are dispatched through [structure_item]/[signature_item], + which is where a deriver's [include ... [@@merlin.hide]] wrapper lands. *) + let structure_item iterator str_item = + let visible = + match str_item.Typedtree.str_desc with + | Tstr_include { incl_attributes; _ } -> not_hidden incl_attributes + | _ -> true + in + if visible then iter.structure_item iterator str_item + in + let signature_item iterator sig_item = + let visible = + match sig_item.Typedtree.sig_desc with +#if defined OXCAML + | Tsig_include ({ incl_attributes; _ }, _) +#else + | Tsig_include { incl_attributes; _ } +#endif + -> not_hidden incl_attributes + | _ -> true + in + if visible then iter.signature_item iterator sig_item in let iterator = { @@ -122,6 +204,18 @@ let of_cmt env structure = typ; module_type; module_binding; + value_binding; + value_description; + type_declaration; + type_extension; + type_exception; + extension_constructor; + module_declaration; + module_type_declaration; + open_declaration; + open_description; + structure_item; + signature_item; } in iterator.structure iterator structure; From 5f86e2b2df786d91b1a894ec70b51dce9b675886 Mon Sep 17 00:00:00 2001 From: Benjamin Canou Date: Mon, 27 Jul 2026 15:21:12 +0200 Subject: [PATCH 2/2] test: no source links under a [@merlin.hide] attribute (#1456) --- test/sources/merlin_hide.t/hidden.ml | 5 +++ test/sources/merlin_hide.t/mylib.ml | 1 + test/sources/merlin_hide.t/run.t | 49 +++++++++++++++++++++++++++ test/sources/merlin_hide.t/visible.ml | 3 ++ 4 files changed, 58 insertions(+) create mode 100644 test/sources/merlin_hide.t/hidden.ml create mode 100644 test/sources/merlin_hide.t/mylib.ml create mode 100644 test/sources/merlin_hide.t/run.t create mode 100644 test/sources/merlin_hide.t/visible.ml diff --git a/test/sources/merlin_hide.t/hidden.ml b/test/sources/merlin_hide.t/hidden.ml new file mode 100644 index 0000000000..0748d02c38 --- /dev/null +++ b/test/sources/merlin_hide.t/hidden.ml @@ -0,0 +1,5 @@ +include struct + let g x = x + + let f x = Mylib.truc (g x) +end [@@merlin.hide] diff --git a/test/sources/merlin_hide.t/mylib.ml b/test/sources/merlin_hide.t/mylib.ml new file mode 100644 index 0000000000..30e913130d --- /dev/null +++ b/test/sources/merlin_hide.t/mylib.ml @@ -0,0 +1 @@ +let truc x = x diff --git a/test/sources/merlin_hide.t/run.t b/test/sources/merlin_hide.t/run.t new file mode 100644 index 0000000000..23a9ac4371 --- /dev/null +++ b/test/sources/merlin_hide.t/run.t @@ -0,0 +1,49 @@ +Regression test for ocaml/odoc#1456 (spurious source links on derived code). + +Occurrences under a [@merlin.hide] attribute must not be rendered as source +links. This makes odoc ignore generated code in a way that is consistent +with Merlin and ppxlib. + +[visible.ml] and [hidden.ml] hold the same definitions (a cross-module +reference ([Mylib.truc]) and local ones) but [hidden.ml] wraps them in +[include struct ... end [@@merlin.hide]]. odoc must link the references of the +former and none of the latter. + + $ ocamlc -c mylib.ml visible.ml hidden.ml -bin-annot + +Render [Mylib] too, so the cross-module occurrence has a source anchor to point +at: + + $ odoc compile-impl --source-id src/mylib.ml -I . mylib.cmt + $ odoc compile -I . mylib.cmt + $ odoc link -I . mylib.odoc + $ odoc link -I . impl-mylib.odoc + $ odoc html-generate-source --impl impl-mylib.odocl --indent -o html mylib.ml + + $ for m in visible hidden; do + > odoc compile-impl --source-id src/$m.ml -I . $m.cmt + > odoc compile -I . $m.cmt + > odoc link -I . $m.odoc + > odoc link -I . impl-$m.odoc + > odoc html-generate-source --impl impl-$m.odocl --indent -o html $m.ml + > done + +Without [@merlin.hide], both the cross-module and the local references are +linked: + + $ grep -c 'href="mylib.ml.html#val-truc"' html/src/visible.ml.html + 1 + $ grep -c 'href="#local' html/src/visible.ml.html + 2 + +Under [@merlin.hide], neither is -- yet the source itself is still rendered +(grep exits 1 when there is no match): + + $ grep -c 'href="mylib.ml.html#val-truc"' html/src/hidden.ml.html + 0 + [1] + $ grep -c 'href="#local' html/src/hidden.ml.html + 0 + [1] + $ grep -c 'class="LET"' html/src/hidden.ml.html + 2 diff --git a/test/sources/merlin_hide.t/visible.ml b/test/sources/merlin_hide.t/visible.ml new file mode 100644 index 0000000000..6e214efa81 --- /dev/null +++ b/test/sources/merlin_hide.t/visible.ml @@ -0,0 +1,3 @@ +let g x = x + +let f x = Mylib.truc (g x)