Treat hidden representations differently

Instead of omitting variant constructors where they've got hidden elements in their types, we now show all constructors and just emit a warning when we detect the problem. In addition, also check the fields of records similarly.
ocaml · Apr 5, 2024 · 253329e · 253329e
1 parent 61c80fa
commit 253329e
Show file tree

Hide file tree

Showing 7 changed files with 182 additions and 35 deletions.
diff --git a/src/document/generator.ml b/src/document/generator.ml
@@ -594,27 +594,6 @@ 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
@@ -634,7 +613,6 @@ 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 =

diff --git a/src/xref2/link.ml b/src/xref2/link.ml
@@ -365,6 +365,51 @@ and open_ env parent = function
   | { Odoc_model__Lang.Open.doc; _ } as open_ ->
       { open_ with doc = comment_docs env parent doc }
 
+let warn_on_hidden_representation (id : Id.Type.t)
+    (r : Lang.TypeDecl.Representation.t) =
+  let open Paths.Identifier in
+  let rec internal_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 -> internal_typ_exp t) ts
+    | Poly (_, t) | Alias (t, _) -> internal_typ_exp t
+    | Arrow (_, t, t2) -> internal_typ_exp t || internal_typ_exp t2
+    | Tuple ts | Class (_, ts) -> List.exists (fun t -> internal_typ_exp t) ts
+    | _ -> false
+  in
+
+  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 -> internal_typ_exp type_expr) type_exprs
+    | Record fields ->
+        List.exists (fun field -> internal_typ_exp field.type_) fields
+  in
+
+  let internal_field t =
+    let open Lang.TypeDecl.Field in
+    internal_typ_exp t.type_
+  in
+
+  let fmt_cfg = Component.Fmt.{ default with short_paths = true } in
+  match r with
+  | Variant constructors ->
+      if List.exists internal_cstr_arg constructors then
+        Lookup_failures.report_warning "@[<2>Hidden constructors in type '%a'@]"
+          Component.Fmt.(model_identifier fmt_cfg)
+          (id :> Id.any)
+  | Record fields ->
+      if List.exists internal_field fields then
+        Lookup_failures.report_warning "@[<2>Hidden fields in type '%a'@]"
+          Component.Fmt.(model_identifier fmt_cfg)
+          (id :> Id.any)
+  | Extensible -> ()
+
 let rec unit env t =
   let open Compilation_unit in
   let content =
@@ -877,7 +922,12 @@ and type_decl : Env.t -> Id.Signature.t -> TypeDecl.t -> TypeDecl.t =
     | _ -> None
   in
   let representation =
-    Opt.map (type_decl_representation env parent) t.representation
+    Opt.map
+      (fun r ->
+        let r' = type_decl_representation env parent r in
+        warn_on_hidden_representation t.id r';
+        r')
+      t.representation
   in
   let default = { t with source_loc; equation; doc; representation } in
   match hidden_path with

diff --git a/test/generators/html/Stop_dead_link_doc.html b/test/generators/html/Stop_dead_link_doc.html
@@ -112,25 +112,87 @@ <h1>Module <code><span>Stop_dead_link_doc</span></code></h1>
    <div class="odoc-spec">
     <div class="spec type anchored" id="type-another_foo">
      <a href="#type-another_foo" class="anchor"></a>
-     <code><span><span class="keyword">type</span> another_foo</span></code>
+     <code><span><span class="keyword">type</span> another_foo</span>
+      <span> = </span>
+     </code>
+     <ol>
+      <li id="type-another_foo.Bar" class="def variant constructor anchored">
+       <a href="#type-another_foo.Bar" class="anchor"></a>
+       <code><span>| </span>
+        <span><span class="constructor">Bar</span> 
+         <span class="keyword">of</span> 
+         <span class="xref-unresolved">{Another_Foo}1.t</span>
+        </span>
+       </code>
+      </li>
+     </ol>
     </div>
    </div>
    <div class="odoc-spec">
     <div class="spec type anchored" id="type-another_bar">
      <a href="#type-another_bar" class="anchor"></a>
-     <code><span><span class="keyword">type</span> another_bar</span></code>
+     <code><span><span class="keyword">type</span> another_bar</span>
+      <span> = </span>
+     </code>
+     <ol>
+      <li id="type-another_bar.Bar" class="def variant constructor anchored">
+       <a href="#type-another_bar.Bar" class="anchor"></a>
+       <code><span>| </span>
+        <span><span class="constructor">Bar</span> 
+         <span class="keyword">of</span> 
+        </span><span>{</span>
+       </code>
+       <ol>
+        <li id="type-another_bar.field" class="def record field anchored">
+         <a href="#type-another_bar.field" class="anchor"></a>
+         <code>
+          <span>field : <span class="xref-unresolved">{Another_Foo}1.t</span>
+           ;
+          </span>
+         </code>
+        </li>
+       </ol><code><span>}</span></code>
+      </li>
+     </ol>
     </div>
    </div>
    <div class="odoc-spec">
     <div class="spec type anchored" id="type-another_foo_">
      <a href="#type-another_foo_" class="anchor"></a>
-     <code><span><span class="keyword">type</span> another_foo_</span></code>
+     <code><span><span class="keyword">type</span> another_foo_</span>
+      <span> = </span>
+     </code>
+     <ol>
+      <li id="type-another_foo_.Bar_" class="def variant constructor
+       anchored"><a href="#type-another_foo_.Bar_" class="anchor"></a>
+       <code><span>| </span>
+        <span><span class="constructor">Bar_</span> 
+         <span class="keyword">of</span> int * 
+         <span class="xref-unresolved">{Another_Foo}1.t</span> * int
+        </span>
+       </code>
+      </li>
+     </ol>
     </div>
    </div>
    <div class="odoc-spec">
     <div class="spec type anchored" id="type-another_bar_">
      <a href="#type-another_bar_" class="anchor"></a>
-     <code><span><span class="keyword">type</span> another_bar_</span></code>
+     <code><span><span class="keyword">type</span> another_bar_</span>
+      <span> = </span>
+     </code>
+     <ol>
+      <li id="type-another_bar_.Bar__" class="def variant constructor
+       anchored"><a href="#type-another_bar_.Bar__" class="anchor"></a>
+       <code><span>| </span>
+        <span><span class="constructor">Bar__</span> 
+         <span class="keyword">of</span> 
+         <span><span class="xref-unresolved">{Another_Foo}1.t</span> option
+         </span>
+        </span>
+       </code>
+      </li>
+     </ol>
     </div>
    </div>
   </div>

diff --git a/test/generators/latex/Stop_dead_link_doc.tex b/test/generators/latex/Stop_dead_link_doc.tex
@@ -20,9 +20,23 @@ \section{Module \ocamlinlinecode{Stop\_\allowbreak{}dead\_\allowbreak{}link\_\al
 \begin{ocamltabular}{p{1.000\textwidth}}\ocamlcodefragment{| \ocamltag{constructor}{Bar\_\allowbreak{}\_\allowbreak{}} \ocamltag{keyword}{of} \hyperref[module-Stop_dead_link_doc-module-Foo-type-t]{\ocamlinlinecode{Foo.\allowbreak{}t}} option}\label{module-Stop_dead_link_doc-type-bar_.Bar__}\\
 \end{ocamltabular}%
 \\
-\label{module-Stop_dead_link_doc-type-another_foo}\ocamlcodefragment{\ocamltag{keyword}{type} another\_\allowbreak{}foo}\\
-\label{module-Stop_dead_link_doc-type-another_bar}\ocamlcodefragment{\ocamltag{keyword}{type} another\_\allowbreak{}bar}\\
-\label{module-Stop_dead_link_doc-type-another_foo_}\ocamlcodefragment{\ocamltag{keyword}{type} another\_\allowbreak{}foo\_\allowbreak{}}\\
-\label{module-Stop_dead_link_doc-type-another_bar_}\ocamlcodefragment{\ocamltag{keyword}{type} another\_\allowbreak{}bar\_\allowbreak{}}\\
+\label{module-Stop_dead_link_doc-type-another_foo}\ocamlcodefragment{\ocamltag{keyword}{type} another\_\allowbreak{}foo = }\\
+\begin{ocamltabular}{p{1.000\textwidth}}\ocamlcodefragment{| \ocamltag{constructor}{Bar} \ocamltag{keyword}{of} \hyperref[xref-unresolved]{\ocamlinlinecode{\{Another\_\allowbreak{}Foo\}1.\allowbreak{}t}}}\label{module-Stop_dead_link_doc-type-another_foo.Bar}\\
+\end{ocamltabular}%
+\\
+\label{module-Stop_dead_link_doc-type-another_bar}\ocamlcodefragment{\ocamltag{keyword}{type} another\_\allowbreak{}bar = }\begin{ocamlindent}\ocamlcodefragment{| \ocamltag{constructor}{Bar} \ocamltag{keyword}{of} \{}\\
+\begin{ocamltabular}{p{1.000\textwidth}}\ocamlinlinecode{field : \hyperref[xref-unresolved]{\ocamlinlinecode{\{Another\_\allowbreak{}Foo\}1.\allowbreak{}t}};\allowbreak{}}\label{module-Stop_dead_link_doc-type-another_bar.field}\\
+\end{ocamltabular}%
+\\
+\ocamlcodefragment{\}}\label{module-Stop_dead_link_doc-type-another_bar.Bar}\\
+\end{ocamlindent}%
+\label{module-Stop_dead_link_doc-type-another_foo_}\ocamlcodefragment{\ocamltag{keyword}{type} another\_\allowbreak{}foo\_\allowbreak{} = }\\
+\begin{ocamltabular}{p{1.000\textwidth}}\ocamlcodefragment{| \ocamltag{constructor}{Bar\_\allowbreak{}} \ocamltag{keyword}{of} int * \hyperref[xref-unresolved]{\ocamlinlinecode{\{Another\_\allowbreak{}Foo\}1.\allowbreak{}t}} * int}\label{module-Stop_dead_link_doc-type-another_foo_.Bar_}\\
+\end{ocamltabular}%
+\\
+\label{module-Stop_dead_link_doc-type-another_bar_}\ocamlcodefragment{\ocamltag{keyword}{type} another\_\allowbreak{}bar\_\allowbreak{} = }\\
+\begin{ocamltabular}{p{1.000\textwidth}}\ocamlcodefragment{| \ocamltag{constructor}{Bar\_\allowbreak{}\_\allowbreak{}} \ocamltag{keyword}{of} \hyperref[xref-unresolved]{\ocamlinlinecode{\{Another\_\allowbreak{}Foo\}1.\allowbreak{}t}} option}\label{module-Stop_dead_link_doc-type-another_bar_.Bar__}\\
+\end{ocamltabular}%
+\\
 
 
diff --git a/test/generators/man/Stop_dead_link_doc.3o b/test/generators/man/Stop_dead_link_doc.3o
@@ -43,10 +43,33 @@ field : Foo\.t;
 | \f[CB]Bar__\fR \f[CB]of\fR Foo\.t option
 .br 
 .sp 
-\f[CB]type\fR another_foo
+\f[CB]type\fR another_foo = 
+.br 
+.ti +2
+| \f[CB]Bar\fR \f[CB]of\fR {Another_Foo}1\.t
+.br 
 .sp 
-\f[CB]type\fR another_bar
+\f[CB]type\fR another_bar = 
+.br 
+.ti +2
+| \f[CB]Bar\fR \f[CB]of\fR {
+.br 
+.ti +6
+field : {Another_Foo}1\.t;
+.br 
+.ti +4
+}
+.br 
 .sp 
-\f[CB]type\fR another_foo_
+\f[CB]type\fR another_foo_ = 
+.br 
+.ti +2
+| \f[CB]Bar_\fR \f[CB]of\fR int * {Another_Foo}1\.t * int
+.br 
 .sp 
-\f[CB]type\fR another_bar_
+\f[CB]type\fR another_bar_ = 
+.br 
+.ti +2
+| \f[CB]Bar__\fR \f[CB]of\fR {Another_Foo}1\.t option
+.br 
+
diff --git a/test/xref2/hidden_representations.t/run.t b/test/xref2/hidden_representations.t/run.t
@@ -0,0 +1,8 @@
+  $ ocamlc -bin-annot -c test.mli
+  $ odoc compile test.cmti
+  $ odoc link test.odoc
+  File "test.odoc":
+  Warning: Hidden fields in type 'Test.u'
+  File "test.odoc":
+  Warning: Hidden constructors in type 'Test.t'
+
diff --git a/test/xref2/hidden_representations.t/test.mli b/test/xref2/hidden_representations.t/test.mli
@@ -0,0 +1,12 @@
+module Hidden__ : sig
+  type t
+end
+
+type t =
+  | Variant of int
+  | Hidden of Hidden__.t
+
+type u =
+  { not_hidden : int
+  ; hidden : Hidden__.t }
+