Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Fix the type_expr loader in OCaml 4.14 and later #1173

Merged
merged 5 commits into from
Jul 26, 2024
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
3 changes: 3 additions & 0 deletions CHANGES.md
Original file line number Diff line number Diff line change
Expand Up @@ -56,6 +56,9 @@
- Fix wrong links to standalone comments in search results (#1118, @panglesd)
- Remove duplicated or unwanted comments (@Julow, #1133)
This could happen with inline includes.
- Fix misprinting of type variables from ml files for OCaml 4.14 and later
(multiple occurences of the same type variable could be named differently)
(@octachron, #1173)


# 2.4.0
Expand Down
115 changes: 69 additions & 46 deletions src/loader/cmi.ml
Original file line number Diff line number Diff line change
Expand Up @@ -27,6 +27,13 @@ module Paths = Odoc_model.Paths

module Compat = struct
#if OCAML_VERSION >= (4, 14, 0)
(** this is the type on which physical equality is meaningful *)
type repr_type_node = Types.transient_expr

(** repr has morally type [type_expr -> repr_type_node] in all OCaml
versions *)
let repr x = Transient_expr.repr x

let get_desc = Types.get_desc
let get_row_name = Types.row_name
let row_field_repr = Types.row_field_repr
Expand All @@ -35,30 +42,40 @@ module Compat = struct
let row_closed = Types.row_closed
let row_fields = Types.row_fields
let field_public = Types.Fpublic
let repr x = x
let self_type = Btype.self_type
let csig_self x = x.Types.csig_self
let row_repr x = x
let concr_mem = Types.Meths.mem
let csig_concr x = x.Types.csig_meths
let eq_type = Types.eq_type
let invisible_wrap ty = newty2 ~level:Btype.generic_level (Ttuple [ty])
#else
let get_desc x = x.Types.desc
type repr_type_node = Types.type_expr
let repr = Btype.repr
let get_desc x = (repr x).Types.desc
let get_row_name x = x.Types.row_name
let row_field_repr = Btype.row_field_repr
let field_kind_repr = Btype.field_kind_repr
let static_row_repr x = Btype.static_row (Btype.row_repr x)
let row_closed x = x.Types.row_closed
let row_fields x = x.Types.row_fields
let field_public = Types.Fpresent
let repr = Btype.repr
let self_type = Ctype.self_type
let csig_self x = Btype.repr x.Types.csig_self
let row_repr = Btype.row_repr
let concr_mem = Types.Concr.mem
let csig_concr x = x.Types.csig_concr
let eq_type x y = x == y || repr x == repr y

(** Create a new node pointing to [ty] that is printed in the same way as
[ty]*)
let invisible_wrap ty =
Btype.(newty2 generic_level (Ttuple [ty]))
#endif
end

let proxy ty = Compat.(repr (Btype.proxy ty))

let opt_map f = function
| None -> None
| Some x -> Some (f x)
Expand Down Expand Up @@ -87,7 +104,10 @@ let read_label lbl =

(* Handle type variable names *)

let used_names = ref []
(** To identify equal type node for type variables, we need a map from the
representative type node to names. Otherwise, equivalent variables would end
up with distinct names *)
let used_names : (Compat.repr_type_node * string) list ref = ref []
let name_counter = ref 0
let reserved_names = ref []

Expand Down Expand Up @@ -119,25 +139,27 @@ let fresh_name base =
done;
!current_name

let name_of_type (ty : Types.type_expr) =
let name_of_type_repr (ty : Compat.repr_type_node) =
try
List.assq ty !used_names
with Not_found ->
let base =
match Compat.get_desc ty with
match ty.desc with
| Tvar (Some name) | Tunivar (Some name) -> name
| _ -> next_name ()
in
let name = fresh_name base in
if name <> "_" then used_names := (ty, name) :: !used_names;
name

let name_of_type ty = name_of_type_repr (Compat.repr ty)

let remove_names tyl =
used_names := List.filter (fun (ty,_) -> not (List.memq ty tyl)) !used_names

(* Handle recursive types and shared row variables *)

let aliased = ref []
let aliased: Compat.repr_type_node list ref = ref []
let used_aliases = ref []

let reset_aliased () = aliased := []; used_aliases := []
Expand All @@ -149,20 +171,21 @@ let aliasable (ty : Types.type_expr) =
| Tvar _ | Tunivar _ | Tpoly _ -> false
| _ -> true

let add_alias ty =
let px = Btype.proxy ty in
let add_alias_proxy px =
if not (List.memq px !aliased) then begin
aliased := px :: !aliased;
match Compat.get_desc px with
match px.desc with
| Tvar name | Tunivar name -> reserve_name name
| _ -> ()
end

let used_alias (px : Types.type_expr) = List.memq px !used_aliases
let add_alias ty = add_alias_proxy (proxy ty)

let used_alias (px : Compat.repr_type_node) = List.memq px !used_aliases

let use_alias (px : Types.type_expr) = used_aliases := px :: !used_aliases
let use_alias (px : Compat.repr_type_node) = used_aliases := px :: !used_aliases

let visited_rows = ref []
let visited_rows: Compat.repr_type_node list ref = ref []

let reset_visited_rows () = visited_rows := []

Expand Down Expand Up @@ -191,9 +214,8 @@ let namable_row row =

let mark_type ty =
let rec loop visited ty =
let ty = Compat.repr ty in
let px = Btype.proxy ty in
if List.memq px visited && aliasable ty then add_alias px else
let px = proxy ty in
if List.memq px visited && aliasable ty then add_alias_proxy px else
let visited = px :: visited in
match Compat.get_desc ty with
| Tvar name -> reserve_name name
Expand All @@ -204,7 +226,7 @@ let mark_type ty =
| Tconstr(_, tyl, _) ->
List.iter (loop visited) tyl
| Tvariant row ->
if is_row_visited px then add_alias px else
if is_row_visited px then add_alias_proxy px else
begin
if not (Compat.static_row_repr row) then visit_row px;
match Compat.get_row_name row with
Expand All @@ -214,7 +236,7 @@ let mark_type ty =
Btype.iter_row (loop visited) row
end
| Tobject (fi, nm) ->
if is_row_visited px then add_alias px else
if is_row_visited px then add_alias_proxy px else
begin
visit_object ty px;
match !nm with
Expand Down Expand Up @@ -268,31 +290,34 @@ let mark_value_description vd =
mark_type vd.val_type

let mark_type_parameter param =
add_alias param;
let px = proxy param in
add_alias_proxy px;
mark_type param;
if aliasable param then use_alias (Btype.proxy param)
if aliasable param then use_alias px

#if OCAML_VERSION<(4,13,0)
let tsubst x = Tsubst x
let tvar_none ty = ty.desc <- Tvar None
#elif OCAML_VERSION < (4,14,0)
let tsubst x = Tsubst(x,None)
let tvar_none ty = Types.Private_type_expr.set_desc ty (Tvar None)
#else
let tsubst x = Tsubst(x,None)
let tvar_none ty = Types.Transient_expr.(set_desc (coerce ty) (Tvar None))
#endif

let prepare_type_parameters params manifest =
let wrap_constrained_params tyl =
let params =
List.fold_left
(fun params param ->
let param = Compat.repr param in
if List.memq param params then Btype.newgenty (tsubst param) :: params
else param :: params)
[] params
in
let params = List.rev params in
(fun tyl ty ->
if List.exists (Compat.eq_type ty) tyl
then Compat.invisible_wrap ty :: tyl
else ty :: tyl)
(* Two parameters might be identical due to a constraint but we need to
print them differently in order to make the output syntactically valid.
We use [Ttuple [ty]] because it is printed as [ty]. *)
[] tyl
in List.rev params

let prepare_type_parameters params manifest =
let params = wrap_constrained_params params in
begin match manifest with
| Some ty ->
let vars = Ctype.free_variables ty in
Expand Down Expand Up @@ -366,22 +391,22 @@ let mark_exception ext =
let rec mark_class_type params = function
| Cty_constr (_, tyl, cty) ->
let sty = Compat.self_type cty in
if is_row_visited (Btype.proxy sty)
if is_row_visited (proxy sty)
|| List.exists aliasable params
|| List.exists (Ctype.deep_occur sty) tyl
then mark_class_type params cty
else List.iter mark_type tyl
| Cty_signature sign ->
let sty = Compat.csig_self sign in
let px = Btype.proxy sty in
if is_row_visited px then add_alias sty
let px = proxy sty in
if is_row_visited px then add_alias_proxy px
else visit_row px;
let (fields, _) =
Ctype.flatten_fields (Ctype.object_fields sign.csig_self)
in
List.iter (fun (_, _, ty) -> mark_type ty) fields;
Vars.iter (fun _ (_, _, ty) -> mark_type ty) sign.csig_vars;
if is_aliased sty && aliasable sty then use_alias px
if is_aliased px && aliasable sty then use_alias px
| Cty_arrow (_, ty, cty) ->
mark_type ty;
mark_class_type params cty
Expand All @@ -398,8 +423,7 @@ let mark_class_declaration cld =

let rec read_type_expr env typ =
let open TypeExpr in
let typ = Compat.repr typ in
let px = Btype.proxy typ in
let px = proxy typ in
if used_alias px then Var (name_of_type typ)
else begin
let alias =
Expand All @@ -418,7 +442,7 @@ let rec read_type_expr env typ =
| Tarrow(lbl, arg, res, _) ->
let arg =
if Btype.is_optional lbl then
match Compat.get_desc (Compat.repr arg) with
match Compat.get_desc arg with
| Tconstr(_option, [arg], _) -> read_type_expr env arg
| _ -> assert false
else read_type_expr env arg
Expand All @@ -439,7 +463,7 @@ let rec read_type_expr env typ =
| Tpoly (typ, []) -> read_type_expr env typ
| Tpoly (typ, tyl) ->
let tyl = List.map Compat.repr tyl in
let vars = List.map name_of_type tyl in
let vars = List.map name_of_type_repr tyl in
let typ = read_type_expr env typ in
remove_names tyl;
Poly(vars, typ)
Expand Down Expand Up @@ -540,8 +564,7 @@ and read_row env _px row =
and read_object env fi nm =
let open TypeExpr in
let open TypeExpr.Object in
let fi = Compat.repr fi in
let px = Btype.proxy fi in
let px = proxy fi in
if used_alias px then Var (name_of_type fi)
else begin
use_alias px;
Expand Down Expand Up @@ -816,14 +839,14 @@ let read_instance_variable env parent (name, mutable_, virtual_, typ) =
ClassSignature.InstanceVariable {id; doc; mutable_; virtual_; type_}

let read_self_type sty =
let sty = Compat.repr sty in
if not (is_aliased sty) then None
else Some (TypeExpr.Var (name_of_type (Btype.proxy sty)))
let px = proxy sty in
if not (is_aliased px) then None
else Some (TypeExpr.Var (name_of_type_repr px))

let rec read_class_signature env parent params =
let open ClassType in function
| Cty_constr(p, _, cty) ->
if is_row_visited (Btype.proxy (Compat.self_type cty))
if is_row_visited (proxy (Compat.self_type cty))
|| List.exists aliasable params
then read_class_signature env parent params cty
else begin
Expand Down Expand Up @@ -902,7 +925,7 @@ let rec read_class_type env parent params =
| Cty_arrow(lbl, arg, cty) ->
let arg =
if Btype.is_optional lbl then
match Compat.get_desc (Compat.repr arg) with
match Compat.get_desc arg with
| Tconstr(path, [arg], _)
when OCamlPath.same path Predef.path_option ->
read_type_expr env arg
Expand Down
2 changes: 2 additions & 0 deletions test/generators/cases/bugs.ml
Original file line number Diff line number Diff line change
Expand Up @@ -3,3 +3,5 @@ let foo (type a) ?(bar : a opt) () = ()
(** Triggers an assertion failure when
{:https://github.com/ocaml/odoc/issues/101} is not fixed. *)

let repeat x y = (x, y, x, y)
(** Renders as [val repeat : 'a -> 'b -> 'c * 'd * 'e * 'f] before https://github.com/ocaml/odoc/pull/1173 *)
23 changes: 23 additions & 0 deletions test/generators/html/Bugs.html
Original file line number Diff line number Diff line change
Expand Up @@ -40,6 +40,29 @@ <h1>Module <code><span>Bugs</span></code></h1>
</p>
</div>
</div>
<div class="odoc-spec">
<div class="spec value anchored" id="val-repeat">
<a href="#val-repeat" class="anchor"></a>
<code>
<span><span class="keyword">val</span> repeat :
<span><span class="type-var">'a</span>
<span class="arrow">&#45;&gt;</span>
</span>
<span><span class="type-var">'b</span>
<span class="arrow">&#45;&gt;</span>
</span> <span class="type-var">'a</span> *
<span class="type-var">'b</span> * <span class="type-var">'a</span>
* <span class="type-var">'b</span>
</span>
</code>
</div>
<div class="spec-doc">
<p>Renders as
<code>val repeat : 'a -&gt; 'b -&gt; 'c * 'd * 'e * 'f</code> before
https://github.com/ocaml/odoc/pull/1173
</p>
</div>
</div>
</div>
</body>
</html>
2 changes: 2 additions & 0 deletions test/generators/latex/Bugs.tex
Original file line number Diff line number Diff line change
Expand Up @@ -2,5 +2,7 @@ \section{Module \ocamlinlinecode{Bugs}}\label{module-Bugs}%
\label{module-Bugs-type-opt}\ocamlcodefragment{\ocamltag{keyword}{type} 'a opt = \ocamltag{type-var}{'a} option}\\
\label{module-Bugs-val-foo}\ocamlcodefragment{\ocamltag{keyword}{val} foo : \ocamltag{optlabel}{?bar}:\ocamltag{type-var}{'a} \ocamltag{arrow}{$\rightarrow$} unit \ocamltag{arrow}{$\rightarrow$} unit}\begin{ocamlindent}Triggers an assertion failure when \href{https://github.com/ocaml/odoc/issues/101}{https://github.com/ocaml/odoc/issues/101}\footnote{\url{https://github.com/ocaml/odoc/issues/101}} is not fixed.\end{ocamlindent}%
\medbreak
\label{module-Bugs-val-repeat}\ocamlcodefragment{\ocamltag{keyword}{val} repeat : \ocamltag{type-var}{'a} \ocamltag{arrow}{$\rightarrow$} \ocamltag{type-var}{'b} \ocamltag{arrow}{$\rightarrow$} \ocamltag{type-var}{'a} * \ocamltag{type-var}{'b} * \ocamltag{type-var}{'a} * \ocamltag{type-var}{'b}}\begin{ocamlindent}Renders as \ocamlinlinecode{val repeat : 'a -> 'b -> 'c * 'd * 'e * 'f} before https://github.com/ocaml/odoc/pull/1173\end{ocamlindent}%
\medbreak


7 changes: 7 additions & 0 deletions test/generators/man/Bugs.3o
Original file line number Diff line number Diff line change
Expand Up @@ -23,4 +23,11 @@ https://github\.com/ocaml/odoc/issues/101
.UE
is not fixed\.
.nf
.sp
\f[CB]val\fR repeat : \f[CB]'a\fR \f[CB]\->\fR \f[CB]'b\fR \f[CB]\->\fR \f[CB]'a\fR * \f[CB]'b\fR * \f[CB]'a\fR * \f[CB]'b\fR
.fi
.br
.ti +2
Renders as val repeat : 'a -> 'b -> 'c * 'd * 'e * 'f before https://github\.com/ocaml/odoc/pull/1173
.nf

Loading