Skip to content

Fix canonical #820

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.

Sign up for GitHub

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

Merged
merged 3 commits into from
Feb 5, 2022
Merged

Fix canonical #820

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
31c6043
Better handling of canonical paths
jonludlam Dec 2, 2021
04faa65
Add test for various canonical corner cases
jonludlam Feb 4, 2022
9bd1dd1
Clarify comment
jonludlam Feb 4, 2022
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
245 changes: 167 additions & 78 deletions src/xref2/tools.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -6,11 +6,87 @@ open ResultMonad

type ('a, 'b) either = Left of 'a | Right of 'b

let filter_map f x =
List.rev
@@ List.fold_left
(fun acc x -> match f x with Some x -> x :: acc | None -> acc)
[] x

type module_modifiers =
[ `Aliased of Cpath.Resolved.module_ | `SubstMT of Cpath.Resolved.module_type ]

type module_type_modifiers = [ `AliasModuleType of Cpath.Resolved.module_type ]

(* These three functions take a fully-qualified canonical path and return
a list of shorter possibilities to test *)
let c_mod_poss env p =
(* canonical module paths *)
let rec inner = function
| `Dot (p, n) -> (
let rest = List.map (fun p -> `Dot (p, n)) (inner p) in
match Env.lookup_by_name Env.s_module n env with
| Ok (`Module (id, m)) ->
let m = Component.Delayed.get m in
`Identifier (id, m.hidden) :: rest
| Error _ -> rest)
| p -> [ p ]
in
inner p

let c_modty_poss env p =
(* canonical module type paths *)
match p with
| `Dot (p, n) -> (
let rest = List.map (fun p -> `Dot (p, n)) (c_mod_poss env p) in
match Env.lookup_by_name Env.s_module_type n env with
| Ok (`ModuleType (id, _)) -> `Identifier (id, false) :: rest
| Error _ -> rest)
| p -> [ p ]

let c_ty_poss env p =
(* canonical type paths *)
match p with
| `Dot (p, n) -> (
let rest = List.map (fun p -> `Dot (p, n)) (c_mod_poss env p) in
match Env.lookup_by_name Env.s_type n env with
| Ok (`Type (id, _)) ->
`Identifier ((id :> Odoc_model.Paths.Identifier.Path.Type.t), false)
:: rest
| Error _ -> rest)
| p -> [ p ]

(* Small helper function for resolving canonical paths.
[canonical_helper env resolve lang_of possibilities p2] takes the
fully-qualified path [p2] and returns the shortest resolved path
whose identifier is the same as the resolved fully qualified path.
[resolve] is a function that resolves an arbitrary unresolved path,
[lang_of] turns a resolved path into a generic resolved Lang path
and [possibilities] is a function that, given the fully qualified
unresolved path, returns an ordered list of all possible unresolved
paths starting with the shortest and including the longest one. *)
let canonical_helper :
'unresolved 'resolved.
Env.t ->
(Env.t -> 'unresolved -> ('resolved * 'result, _) result) ->
('resolved -> Odoc_model.Paths.Path.Resolved.t) ->
(Env.t -> 'unresolved -> 'unresolved list) ->
'unresolved ->
('resolved * 'result) option =
fun env resolve lang_of possibilities p2 ->
let resolve p =
match resolve env p with Ok rp -> Some rp | Error _ -> None
in
let get_identifier cpath =
Odoc_model.Paths.Path.Resolved.identifier (lang_of cpath)
in
match resolve p2 with
| None -> None
| Some (rp2, _) -> (
let fallback_id = get_identifier rp2 in
let resolved = filter_map resolve (possibilities env p2) in
let find_fn (r, _) = get_identifier r = fallback_id in
try Some (List.find find_fn resolved) with _ -> None)
Comment on lines +86 to +88
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

filter_map can be avoided by doing resolve and find_fn directly during the List.find.

Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

But then I'd have to call resolve again. I could write a bit more of a specialised function but I opted for legibility here.


let core_types =
let open Odoc_model.Lang.TypeDecl in
let open Odoc_model.Paths in
Expand Down Expand Up @@ -981,88 +1057,101 @@ and reresolve_module : Env.t -> Cpath.Resolved.module_ -> Cpath.Resolved.module_
| `OpaqueModule m -> `OpaqueModule (reresolve_module env m)

and handle_canonical_module env p2 =
let resolve p =
match resolve_module ~mark_substituted:true ~add_canonical:false env p with
| Ok (p, _) -> Some p
| Error _ -> None
let strip_alias : Cpath.Resolved.module_ -> Cpath.Resolved.module_ = function
| `Alias (_, p) -> p
| p -> p
in
let rec get_cpath = function
| `Root _ as p -> resolve p
| `Dot (p, n) -> (
match get_cpath p with
| None -> None
| Some parent -> (
let fallback = `Dot (`Resolved parent, n) in
match parent with
| `Identifier pid -> (
let p' =
`Identifier
( `Module
( (pid :> Odoc_model.Paths.Identifier.Signature.t),
Odoc_model.Names.ModuleName.make_std n ),
false )
in
match resolve p' with None -> resolve fallback | x -> x)
| _ -> resolve fallback))
| _ -> None
let resolve env p =
resolve_module env ~mark_substituted:false ~add_canonical:false p
>>= fun (p, m) -> Ok (strip_alias p, m)
in
match get_cpath p2 with Some p -> `Resolved p | None -> p2

and handle_canonical_module_type env p2 =
let resolve p =
match
resolve_module_type ~mark_substituted:true ~add_canonical:false env p
with
| Ok (p, _) -> `Resolved p
| Error _ -> p2
let lang_of cpath =
(Lang_of.(Path.resolved_module (empty ()) cpath)
:> Odoc_model.Paths.Path.Resolved.t)
in
match p2 with
| `Dot (p, n) -> (
match handle_canonical_module env p with
| `Resolved r as p' -> (
let fallback = `Dot (p', n) in
match r with
| `Identifier pid -> (
let p' =
`Identifier
( `ModuleType
( (pid :> Odoc_model.Paths.Identifier.Signature.t),
Odoc_model.Names.ModuleTypeName.make_std n ),
false )
in
match resolve p' with
| `Resolved _ as x -> x
| _ -> resolve fallback)
| _ -> resolve fallback)
| _ -> p2)
| _ -> p2

and handle_canonical_type env p2 =
let resolve p =
match resolve_type ~add_canonical:false env p with
| Ok (p, _) -> `Resolved p
| Error _ -> p2
match canonical_helper env resolve lang_of c_mod_poss p2 with
| None -> p2
| Some (rp, m) ->
let m = Component.Delayed.get m in
(* Need to check if the module we're going to link to has been expanded.
ModuleTypes are always expanded if possible, but Aliases are only expanded
if they're an alias to a hidden module or if they're self canonical.

Checking if a module is self canonical is a bit tricky, since this function
is itself part of the process of resolving any canonical reference. Hence
what we do here is to look through alias chains looking for one that's marked
with the same _unresolved_ canonical path that we're currently trying to resolve.

This is particularly important because some modules don't know they're canonical!
For example the module Caml in base, which is marked as the canonical path for
all references to the standard library in the file [import0.ml], but is itself just
defined by including [Stdlib].

If a module doesn't know it's canonical, it will fail the self-canonical check, and
therefore not necessarily be expanded. If this happens, we call [process_module_path]
to stick the [`Alias] constructor back on so we'll link to the correct place. *)
Comment on lines +1090 to +1092
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Shouldn't this be done by the caller ? Because like this, it'll still be wrapped in a `Canonical and that makes this function part of the complicated recursive functions.

Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I'd prefer to leave it here so we don't spread the logic between two functions. It'd be better if we have one function to test for self-canonical modules that we can call from here and also from link.ml, but there's a bit of refactoring required for that.

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I mean the resolving could fail and the function that handles the `Canonical case can start again by calling reresolve_module and at the same time removing the `Canonical constructor.

Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Ah, no, the canonical is still valid, it's just that it's going to point to the aliased module rather than the module itself, as the module itself won't be expanded because it doesn't know it's canonical :-)

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I see.

let expanded =
match m.type_ with
| Component.Module.Alias (_, Some _) -> true
| Alias (`Resolved p, None) ->
(* check for an alias chain with a canonical in it... *)
let rec check (m, p) =
match m.Component.Module.canonical with
| Some p ->
p = p2
(* The canonical path is the same one we're trying to resolve *)
| None -> (
match lookup_module ~mark_substituted:false env p with
| Error _ -> false
| Ok m -> (
let m = Component.Delayed.get m in
match m.type_ with
| Alias (`Resolved p, _) -> check (m, p)
| _ -> false))
in
let self_canonical () = check (m, p) in
let hidden =
Cpath.is_resolved_module_hidden ~weak_canonical_test:true p
in
hidden || self_canonical ()
| Alias (_, _) -> false
| ModuleType _ -> true
in
if expanded then `Resolved rp
else `Resolved (process_module_path env ~add_canonical:false m rp)

and handle_canonical_module_type env (p2 : Cpath.module_type) =
let strip_alias : Cpath.Resolved.module_type -> Cpath.Resolved.module_type =
function
| `AliasModuleType (_, p) -> p
| p -> p
in
match p2 with
| `Dot (p, n) -> (
match handle_canonical_module env p with
| `Resolved r as p' -> (
let fallback = `Dot (p', n) in
match r with
| `Identifier pid -> (
let p' =
`Identifier
( `Type
( (pid :> Odoc_model.Paths.Identifier.Signature.t),
Odoc_model.Names.TypeName.make_std n ),
false )
in
match resolve p' with
| `Resolved _ as x -> x
| _ -> resolve fallback)
| _ -> resolve fallback)
| _ -> p2)
| _ -> p2
let resolve env p =
resolve_module_type env ~mark_substituted:false ~add_canonical:false p
>>= fun (p, m) -> Ok (strip_alias p, m)
in
let lang_of cpath =
(Lang_of.(Path.resolved_module_type (empty ()) cpath)
:> Odoc_model.Paths.Path.Resolved.t)
in
match canonical_helper env resolve lang_of c_modty_poss p2 with
| None -> p2
| Some (rp, _) -> `Resolved rp

and handle_canonical_type env (p2 : Cpath.type_) =
let lang_of cpath =
(Lang_of.(Path.resolved_type (empty ()) cpath)
:> Odoc_model.Paths.Path.Resolved.t)
in
let resolve env p =
match resolve_type env ~add_canonical:false p with
| Ok (_, `FType_removed _) -> Error `Find_failure
| Ok (x, y) -> Ok (x, y)
| Error y -> Error y
in
match canonical_helper env resolve lang_of c_ty_poss p2 with
| None -> p2
| Some (rp, _) -> `Resolved rp

and reresolve_module_type :
Env.t -> Cpath.Resolved.module_type -> Cpath.Resolved.module_type =
Expand Down
39 changes: 39 additions & 0 deletions test/generators/html/Ocamlary-Aliases-P2-Z.html
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,39 @@
<!DOCTYPE html>
<html xmlns="http://www.w3.org/1999/xhtml">
<head><title>Z (Ocamlary.Aliases.P2.Z)</title>
<link rel="stylesheet" href="odoc.css"/><meta charset="utf-8"/>
<meta name="generator" content="odoc %%VERSION%%"/>
<meta name="viewport" content="width=device-width,initial-scale=1.0"/>
<script src="highlight.pack.js"></script>
<script>hljs.initHighlightingOnLoad();</script>
</head>
<body class="odoc">
<nav class="odoc-nav"><a href="Ocamlary-Aliases-P2.html">Up</a> –
<a href="Ocamlary.html">Ocamlary</a> &#x00BB;
<a href="Ocamlary-Aliases.html">Aliases</a> &#x00BB;
<a href="Ocamlary-Aliases-P2.html">P2</a> &#x00BB; Z
</nav>
<header class="odoc-preamble">
<h1>Module <code><span>P2.Z</span></code></h1>
</header>
<div class="odoc-content">
<div class="odoc-spec">
<div class="spec type" id="type-t" class="anchored">
<a href="#type-t" class="anchor"></a>
<code><span><span class="keyword">type</span> t</span></code>
</div>
</div>
<div class="odoc-spec">
<div class="spec value" id="val-id" class="anchored">
<a href="#val-id" class="anchor"></a>
<code>
<span><span class="keyword">val</span> id :
<span><a href="#type-t">t</a> <span class="arrow">&#45;&gt;</span>
</span> <a href="#type-t">t</a>
</span>
</code>
</div>
</div>
</div>
</body>
</html>
9 changes: 7 additions & 2 deletions test/generators/html/Ocamlary-Aliases-P2.html
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -19,8 +19,13 @@ <h1>Module <code><span>Aliases.P2</span></code></h1>
<div class="odoc-spec">
<div class="spec module" id="module-Z" class="anchored">
<a href="#module-Z" class="anchor"></a>
<code><span><span class="keyword">module</span> Z</span>
<span> = <a href="Ocamlary-Aliases-P1-Y.html">Z</a></span>
<code>
<span><span class="keyword">module</span>
<a href="Ocamlary-Aliases-P2-Z.html">Z</a>
</span>
<span> : <span class="keyword">sig</span> ...
<span class="keyword">end</span>
</span>
</code>
</div>
</div>
Expand Down
8 changes: 4 additions & 4 deletions test/generators/html/Ocamlary-Aliases.html
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -206,31 +206,31 @@ <h1>Module <code><span>Ocamlary.Aliases</span></code></h1>
<div class="spec module" id="module-X1" class="anchored">
<a href="#module-X1" class="anchor"></a>
<code><span><span class="keyword">module</span> X1</span>
<span> = <a href="Ocamlary-Aliases-P1-Y.html">P2.Z</a></span>
<span> = <a href="Ocamlary-Aliases-P2-Z.html">P2.Z</a></span>
</code>
</div>
</div>
<div class="odoc-spec">
<div class="spec module" id="module-X2" class="anchored">
<a href="#module-X2" class="anchor"></a>
<code><span><span class="keyword">module</span> X2</span>
<span> = <a href="Ocamlary-Aliases-P1-Y.html">P2.Z</a></span>
<span> = <a href="Ocamlary-Aliases-P2-Z.html">P2.Z</a></span>
</code>
</div>
</div>
<div class="odoc-spec">
<div class="spec type" id="type-p1" class="anchored">
<a href="#type-p1" class="anchor"></a>
<code><span><span class="keyword">type</span> p1</span>
<span> = <a href="Ocamlary-Aliases-P1-Y.html#type-t">X1.t</a></span>
<span> = <a href="Ocamlary-Aliases-P2-Z.html#type-t">X1.t</a></span>
</code>
</div>
</div>
<div class="odoc-spec">
<div class="spec type" id="type-p2" class="anchored">
<a href="#type-p2" class="anchor"></a>
<code><span><span class="keyword">type</span> p2</span>
<span> = <a href="Ocamlary-Aliases-P1-Y.html#type-t">X2.t</a></span>
<span> = <a href="Ocamlary-Aliases-P2-Z.html#type-t">X2.t</a></span>
</code>
</div>
</div>
Expand Down
1 change: 1 addition & 0 deletions test/generators/html/ocamlary.targets
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -175,6 +175,7 @@ Ocamlary-Aliases-E.html
Ocamlary-Aliases-P1.html
Ocamlary-Aliases-P1-Y.html
Ocamlary-Aliases-P2.html
Ocamlary-Aliases-P2-Z.html
Ocamlary-module-type-M.html
Ocamlary-M.html
Ocamlary-Only_a_module.html
Expand Down
10 changes: 5 additions & 5 deletions test/generators/latex/Ocamlary.tex
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -833,13 +833,13 @@ \subsubsection{include of Foo\label{incl}}%
\ocamlcodefragment{\ocamltag{keyword}{end}}\\
\end{ocamlindent}%
\ocamlcodefragment{\ocamltag{keyword}{end}}\\
\label{module-Ocamlary-module-Aliases-module-P2}\ocamlcodefragment{\ocamltag{keyword}{module} \hyperref[module-Ocamlary-module-Aliases-module-P2]{\ocamlinlinecode{P2}}}\ocamlcodefragment{ : \ocamltag{keyword}{sig}}\begin{ocamlindent}\label{module-Ocamlary-module-Aliases-module-P2-module-Z}\ocamlcodefragment{\ocamltag{keyword}{module} Z = \hyperref[module-Ocamlary-module-Aliases-module-P1-module-Y]{\ocamlinlinecode{Z}}}\\
\label{module-Ocamlary-module-Aliases-module-P2}\ocamlcodefragment{\ocamltag{keyword}{module} \hyperref[module-Ocamlary-module-Aliases-module-P2]{\ocamlinlinecode{P2}}}\ocamlcodefragment{ : \ocamltag{keyword}{sig}}\begin{ocamlindent}\label{module-Ocamlary-module-Aliases-module-P2-module-Z}\ocamlcodefragment{\ocamltag{keyword}{module} \hyperref[module-Ocamlary-module-Aliases-module-P2-module-Z]{\ocamlinlinecode{Z}}}\ocamlcodefragment{ : \ocamltag{keyword}{sig} .\allowbreak{}.\allowbreak{}.\allowbreak{} \ocamltag{keyword}{end}}\\
\end{ocamlindent}%
\ocamlcodefragment{\ocamltag{keyword}{end}}\\
\label{module-Ocamlary-module-Aliases-module-X1}\ocamlcodefragment{\ocamltag{keyword}{module} X1 = \hyperref[module-Ocamlary-module-Aliases-module-P1-module-Y]{\ocamlinlinecode{P2.\allowbreak{}Z}}}\\
\label{module-Ocamlary-module-Aliases-module-X2}\ocamlcodefragment{\ocamltag{keyword}{module} X2 = \hyperref[module-Ocamlary-module-Aliases-module-P1-module-Y]{\ocamlinlinecode{P2.\allowbreak{}Z}}}\\
\label{module-Ocamlary-module-Aliases-type-p1}\ocamlcodefragment{\ocamltag{keyword}{type} p1 = \hyperref[module-Ocamlary-module-Aliases-module-P1-module-Y-type-t]{\ocamlinlinecode{X1.\allowbreak{}t}}}\\
\label{module-Ocamlary-module-Aliases-type-p2}\ocamlcodefragment{\ocamltag{keyword}{type} p2 = \hyperref[module-Ocamlary-module-Aliases-module-P1-module-Y-type-t]{\ocamlinlinecode{X2.\allowbreak{}t}}}\\
\label{module-Ocamlary-module-Aliases-module-X1}\ocamlcodefragment{\ocamltag{keyword}{module} X1 = \hyperref[module-Ocamlary-module-Aliases-module-P2-module-Z]{\ocamlinlinecode{P2.\allowbreak{}Z}}}\\
\label{module-Ocamlary-module-Aliases-module-X2}\ocamlcodefragment{\ocamltag{keyword}{module} X2 = \hyperref[module-Ocamlary-module-Aliases-module-P2-module-Z]{\ocamlinlinecode{P2.\allowbreak{}Z}}}\\
\label{module-Ocamlary-module-Aliases-type-p1}\ocamlcodefragment{\ocamltag{keyword}{type} p1 = \hyperref[module-Ocamlary-module-Aliases-module-P2-module-Z-type-t]{\ocamlinlinecode{X1.\allowbreak{}t}}}\\
\label{module-Ocamlary-module-Aliases-type-p2}\ocamlcodefragment{\ocamltag{keyword}{type} p2 = \hyperref[module-Ocamlary-module-Aliases-module-P2-module-Z-type-t]{\ocamlinlinecode{X2.\allowbreak{}t}}}\\
\end{ocamlindent}%
\ocamlcodefragment{\ocamltag{keyword}{end}}\begin{ocamlindent}Let's imitate jst's layout.\end{ocamlindent}%
\medbreak
Expand Down
Loading