Skip source occurrences under [@merlin.hide] (#1456)

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)

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;

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]

test/sources/merlin_hide.t/mylib.ml

@@ -0,0 +1 @@
+let truc x = x

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

test/sources/merlin_hide.t/visible.ml

@@ -0,0 +1,3 @@
+let g x = x
+
+let f x = Mylib.truc (g x)