Skip to content

Commit

Permalink
resolver: Propagate errors and improve the interface
Browse files Browse the repository at this point in the history 
Remove the 'lookup_path' function and change 'lookup_page' and
'lookup_unit' to handle by-name and by-path lookups.

This removes the dependent query and result type that are annoying to
work with and allow to propagate errors from the resolver in a unified
way.
  • Loading branch information
@Julow @panglesd
Julow authored and panglesd committed Jul 12, 2024
1 parent 6e0d14f commit 1862c3a
Show file tree
Hide file tree
Showing 5 changed files with 116 additions and 123 deletions.
80 changes: 49 additions & 31 deletions src/odoc/resolver.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -279,8 +279,8 @@ let lookup_unit_with_digest ap target_name digest =
in
let units = load_units_from_name ap target_name in
match find_map unit_that_match_digest units with
| Some (m, _) -> Odoc_xref2.Env.Found m
| None -> Not_found
| Some (m, _) -> Ok (Odoc_xref2.Env.Found m)
| None -> Error `Not_found

(** Lookup a compilation unit matching a name. If there is more than one
result, report on stderr and return the first one.
Expand Down Expand Up @@ -321,33 +321,37 @@ let lookup_unit_by_name ap target_name =

(** Lookup an unit. First looks into [imports_map] then searches into the
paths. *)
let lookup_unit ~important_digests ~imports_map ap target_name =
let lookup_unit_by_name ~important_digests ~imports_map ap target_name =
let of_option f =
match f with Some m -> Odoc_xref2.Env.Found m | None -> Not_found
match f with
| Some m -> Ok (Odoc_xref2.Env.Found m)
| None -> Error `Not_found
in
match StringMap.find target_name imports_map with
| Odoc_model.Lang.Compilation_unit.Import.Unresolved (_, Some digest) ->
lookup_unit_with_digest ap target_name digest
| Unresolved (_, None) ->
if important_digests then Odoc_xref2.Env.Forward_reference
if important_digests then Ok Odoc_xref2.Env.Forward_reference
else of_option (lookup_unit_by_name ap target_name)
| Resolved (root, _) -> lookup_unit_with_digest ap target_name root.digest
| exception Not_found ->
if important_digests then Odoc_xref2.Env.Not_found
if important_digests then Error `Not_found
else of_option (lookup_unit_by_name ap target_name)

(** Lookup a page.
TODO: Warning on ambiguous lookup. *)
let lookup_page ap target_name =
let lookup_page_by_name ap target_name =
let target_name = "page-" ^ target_name in
let is_page u =
match u with
| Odoc_file.Page_content p -> Some p
| Impl_content _ | Unit_content _ | Source_tree_content _ -> None
in
let units = load_units_from_name ap target_name in
match find_map is_page units with Some (p, _) -> Some p | None -> None
match find_map is_page units with
| Some (p, _) -> Ok p
| None -> Error `Not_found

(** Lookup an implementation. *)
let lookup_impl ap target_name =
Expand All @@ -373,12 +377,12 @@ let add_unit_to_cache u =
in
Hashtbl.add unit_cache target_name [ u ]

let lookup_path _ap ~pages ~libs:_ ~hierarchy (kind, tag, path) =
let lookup_page_by_path ~pages ~hierarchy (tag, path) =
let module Env = Odoc_xref2.Env in
let open Odoc_utils.OptionMonad in
let option_to_page_result = function
| Some p -> Env.Path_page p
| None -> Env.Path_not_found
| Some p -> Ok p
| None -> Error `Not_found
in
let page_path_to_path path =
(* Turn [foo/bar] into [foo/page-bar.odoc]. *)
Expand Down Expand Up @@ -407,18 +411,25 @@ let lookup_path _ap ~pages ~libs:_ ~hierarchy (kind, tag, path) =
| Ok path -> load_page path
| Error `Escape_hierarchy -> None (* TODO: propagate more information *)
in
match (kind, tag) with
| `Page, `TCurrentPackage ->
match tag with
| `TCurrentPackage ->
(* [path] is within the current package root. *)
page_path_to_path path >>= find_page |> option_to_page_result
| `Page, `TAbsolutePath ->
| `TAbsolutePath ->
(match path with
| root :: path -> page_path_to_path path >>= find_page ~root
| [] -> None)
|> option_to_page_result
| `Page, `TRelativePath ->
| `TRelativePath ->
page_path_to_path path >>= find_page_in_hierarchy |> option_to_page_result
| _ -> Env.Path_not_found

let lookup_unit ~important_digests ~imports_map ap = function
| `Path _ -> Error `Not_found
| `Name n -> lookup_unit_by_name ~important_digests ~imports_map ap n

let lookup_page ap ~pages ~hierarchy = function
| `Path p -> lookup_page_by_path ~pages ~hierarchy p
| `Name n -> lookup_page_by_name ap n

type t = {
important_digests : bool;
Expand Down Expand Up @@ -514,26 +525,30 @@ let build_compile_env_for_unit
} m =
add_unit_to_cache (Odoc_file.Unit_content m);
let imports_map = build_imports_map m.imports in
(* Do not implement [lookup_page] in compile mode, as that might return
different results depending on the compilation order.
On the other hand, [lookup_unit] is needed at compile time and the
compilation order is known by the driver. *)
let lookup_unit = lookup_unit ~important_digests ~imports_map ap
and lookup_page = lookup_page ap
and lookup_impl = lookup_impl ap
(* Do not implement [lookup_path] in compile mode, as that might return
different results depending on the compilation order. *)
and lookup_path _ = Env.Path_not_found in
let resolver =
{ Env.open_units; lookup_unit; lookup_page; lookup_impl; lookup_path }
in
and lookup_page _ = Error `Not_found
and lookup_impl = lookup_impl ap in
let resolver = { Env.open_units; lookup_unit; lookup_page; lookup_impl } in
Env.env_of_unit m ~linking:false resolver

(** [important_digests] and [imports_map] only apply to modules. *)
let build ?(imports_map = StringMap.empty)
{ important_digests; ap; open_modules = open_units; pages; libs; hierarchy }
=
{
important_digests;
ap;
open_modules = open_units;
pages;
libs = _;
hierarchy;
} =
let lookup_unit = lookup_unit ~important_digests ~imports_map ap
and lookup_page = lookup_page ap
and lookup_impl = lookup_impl ap
and lookup_path = lookup_path ap ~pages ~libs ~hierarchy in
{ Env.open_units; lookup_unit; lookup_page; lookup_impl; lookup_path }
and lookup_page = lookup_page ap ~pages ~hierarchy
and lookup_impl = lookup_impl ap in
{ Env.open_units; lookup_unit; lookup_page; lookup_impl }

let build_compile_env_for_impl t i =
let imports_map =
Expand Down Expand Up @@ -564,7 +579,10 @@ let build_env_for_reference t =
let resolver = build { t with important_digests = false } in
Env.env_for_reference resolver

let lookup_page t target_name = lookup_page t.ap target_name
let lookup_page t target_name =
match lookup_page_by_name t.ap target_name with
| Ok p -> Some p
| Error `Not_found -> None

let resolve_import t target_name =
let rec loop = function
Expand Down
79 changes: 36 additions & 43 deletions src/xref2/env.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -3,35 +3,23 @@ open Odoc_model
open Odoc_model.Names
open Odoc_model.Paths

type lookup_unit_result =
| Forward_reference
| Found of Lang.Compilation_unit.t
| Not_found
type lookup_unit_result = Forward_reference | Found of Lang.Compilation_unit.t

type lookup_page_result = Lang.Page.t option
type path_query = [ `Path of Reference.Hierarchy.t | `Name of string ]

type lookup_impl_result = Lang.Implementation.t option

type lookup_path_result =
| Path_unit of Lang.Compilation_unit.t
| Path_page of Lang.Page.t
| Path_directory
| Path_not_found

type root =
| Resolved of (Odoc_model.Root.t * Identifier.Module.t * Component.Module.t)
| Forward

type path_query = [ `Page | `Unit ] * Reference.tag_hierarchy * string list
type lookup_error = [ `Not_found ]

type resolver = {
open_units : string list;
lookup_unit : string -> lookup_unit_result;
lookup_impl : string -> lookup_impl_result;
lookup_page : string -> lookup_page_result;
lookup_path : path_query -> lookup_path_result;
lookup_unit : path_query -> (lookup_unit_result, lookup_error) result;
lookup_page : path_query -> (Lang.Page.t, lookup_error) result;
lookup_impl : string -> Lang.Implementation.t option;
}

type root =
| Resolved of (Root.t * Identifier.Module.t * Component.Module.t)
| Forward

let unique_id =
let i = ref 0 in
fun () ->
Expand Down Expand Up @@ -413,10 +401,10 @@ let lookup_root_module name env =
match env.resolver with
| None -> None
| Some r -> (
match r.lookup_unit name with
| Forward_reference -> Some Forward
| Not_found -> None
| Found u ->
match r.lookup_unit (`Name name) with
| Ok Forward_reference -> Some Forward
| Error `Not_found -> None
| Ok (Found u) ->
let ({ Odoc_model.Paths.Identifier.iv = `Root _; _ } as id) =
u.id
in
Expand All @@ -437,19 +425,24 @@ let lookup_root_module name env =
| None, _ -> ());
result

let lookup_page name env =
match env.resolver with None -> None | Some r -> r.lookup_page name
let lookup_page query env =
match env.resolver with
| None -> Error `Not_found
| Some r -> r.lookup_page query

let lookup_unit name env =
match env.resolver with None -> None | Some r -> Some (r.lookup_unit name)
let lookup_unit query env =
match env.resolver with
| None -> Error `Not_found
| Some r -> r.lookup_unit query

let lookup_impl name env =
match env.resolver with None -> None | Some r -> r.lookup_impl name

let lookup_path query env =
match env.resolver with
| None -> Path_not_found
| Some r -> r.lookup_path query
let lookup_page_by_name n env = lookup_page (`Name n) env
let lookup_page_by_path p env = lookup_page (`Path p) env

let lookup_unit_by_name n env = lookup_unit (`Name n) env
let lookup_unit_by_path p env = lookup_unit (`Path p) env

type 'a scope = {
filter : Component.Element.any -> ([< Component.Element.any ] as 'a) option;
Expand Down Expand Up @@ -528,9 +521,9 @@ let lookup_page_or_root_module_fallback name t =
match lookup_root_module_fallback name t with
| Some _ as x -> x
| None -> (
match lookup_page name t with
| Some page -> Some (`Page (page.Lang.Page.name, page))
| None -> None)
match lookup_page_by_name name t with
| Ok page -> Some (`Page (page.Lang.Page.name, page))
| Error `Not_found -> None)

let s_signature : Component.Element.signature scope =
make_scope ~root:lookup_root_module_fallback (function
Expand Down Expand Up @@ -814,8 +807,8 @@ let open_module_type_substitution : Lang.ModuleTypeSubstitution.t -> t -> t =
let open_units resolver env =
List.fold_left
(fun env m ->
match resolver.lookup_unit m with
| Found unit -> (
match resolver.lookup_unit (`Name m) with
| Ok (Found unit) -> (
match unit.content with
| Module sg -> open_signature sg env
| _ -> env)
Expand Down Expand Up @@ -867,10 +860,10 @@ let verify_lookups env lookups =
match env.resolver with
| None -> None
| Some r -> (
match r.lookup_unit name with
| Forward_reference -> Some `Forward
| Not_found -> None
| Found u -> Some (`Resolved u.root.digest))
match r.lookup_unit (`Name name) with
| Ok Forward_reference -> Some `Forward
| Ok (Found u) -> Some (`Resolved u.root.digest)
| Error `Not_found -> None)
in
match (res, actual_result) with
| None, None -> false
Expand Down
41 changes: 16 additions & 25 deletions src/xref2/env.mli
View file
Original file line number Diff line number Diff line change
Expand Up @@ -3,35 +3,23 @@
open Odoc_model
open Odoc_model.Paths

type lookup_unit_result =
| Forward_reference
| Found of Lang.Compilation_unit.t
| Not_found
type lookup_unit_result = Forward_reference | Found of Lang.Compilation_unit.t

type lookup_page_result = Lang.Page.t option
type path_query = [ `Path of Reference.Hierarchy.t | `Name of string ]

type lookup_impl_result = Lang.Implementation.t option
type lookup_error = [ `Not_found ]

type lookup_path_result =
| Path_unit of Lang.Compilation_unit.t
| Path_page of Lang.Page.t
| Path_directory
| Path_not_found
type resolver = {
open_units : string list;
lookup_unit : path_query -> (lookup_unit_result, lookup_error) result;
lookup_page : path_query -> (Lang.Page.t, lookup_error) result;
lookup_impl : string -> Lang.Implementation.t option;
}

type root =
| Resolved of (Root.t * Identifier.Module.t * Component.Module.t)
| Forward

type path_query = [ `Page | `Unit ] * Reference.tag_hierarchy * string list

type resolver = {
open_units : string list;
lookup_unit : string -> lookup_unit_result;
lookup_impl : string -> lookup_impl_result;
lookup_page : string -> lookup_page_result;
lookup_path : path_query -> lookup_path_result;
}

type lookup_type =
| Module of Identifier.Path.Module.t
| ModuleType of Identifier.ModuleType.t
Expand Down Expand Up @@ -102,18 +90,21 @@ val add_module_type_functor_args :

val lookup_fragment_root : t -> (int * Component.Signature.t) option

val lookup_page : string -> t -> Lang.Page.t option
val lookup_page_by_name : string -> t -> (Lang.Page.t, lookup_error) result
val lookup_page_by_path :
Reference.Hierarchy.t -> t -> (Lang.Page.t, lookup_error) result

val lookup_impl : string -> t -> Lang.Implementation.t option

val lookup_unit : string -> t -> lookup_unit_result option
val lookup_unit_by_name :
string -> t -> (lookup_unit_result, lookup_error) result
val lookup_unit_by_path :
Reference.Hierarchy.t -> t -> (lookup_unit_result, lookup_error) result

val module_of_unit : Lang.Compilation_unit.t -> Component.Module.t

val lookup_root_module : string -> t -> root option

val lookup_path : path_query -> t -> lookup_path_result

type 'a scope constraint 'a = [< Component.Element.any ]
(** Target of a lookup *)

Expand Down
19 changes: 9 additions & 10 deletions src/xref2/link.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1108,18 +1108,17 @@ let page env page =
let () =
List.iter
(fun child ->
let check_resolves ~what f name =
match f name env with
| Some _ -> ()
| None -> Errors.report ~what `Lookup
in
match child with
| Page.Asset_child _ | Page.Source_tree_child _ -> ()
| Page.Page_child page ->
check_resolves ~what:(`Child_page page) Env.lookup_page page
| Page.Module_child mod_ ->
check_resolves ~what:(`Child_module mod_) Env.lookup_root_module
mod_)
| Page.Page_child page -> (
match Env.lookup_page_by_name page env with
| Ok _ -> ()
| Error `Not_found -> Errors.report ~what:(`Child_page page) `Lookup
)
| Page.Module_child mod_ -> (
match Env.lookup_root_module mod_ env with
| Some _ -> ()
| None -> Errors.report ~what:(`Child_module mod_) `Lookup))
page.Lang.Page.children
in
{
Expand Down
Loading

0 comments on commit 1862c3a

Please sign in to comment.