From 8493161a873efaa384d2efb83308c07bf58a85ce Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Thu, 27 Jun 2024 15:43:21 +0200 Subject: [PATCH] Resolve relative references to pages --- src/odoc/bin/main.ml | 10 ++- src/odoc/fs.ml | 6 ++ src/odoc/fs.mli | 7 ++ src/odoc/indexing.ml | 9 ++- src/odoc/resolver.ml | 105 ++++++++++++++++++++++------- src/odoc/resolver.mli | 6 +- test/xref2/path_references.t/run.t | 32 +++------ 7 files changed, 125 insertions(+), 50 deletions(-) diff --git a/src/odoc/bin/main.ml b/src/odoc/bin/main.ml index 486dd7169c..94aa46784b 100644 --- a/src/odoc/bin/main.ml +++ b/src/odoc/bin/main.ml @@ -725,8 +725,16 @@ end = struct (if is_page then current_package_of_page ~current_package page_roots output else validate_current_package page_roots current_package) >>= fun current_package -> + let current_dir = Fs.File.dirname output in let roots = - Some { Resolver.page_roots; lib_roots; current_lib; current_package } + Some + { + Resolver.page_roots; + lib_roots; + current_lib; + current_package; + current_dir; + } in let resolver = Resolver.create ~important_digests:false ~directories ~open_modules ~roots diff --git a/src/odoc/fs.ml b/src/odoc/fs.ml index 1849627494..a7d78e9b81 100644 --- a/src/odoc/fs.ml +++ b/src/odoc/fs.ml @@ -103,6 +103,8 @@ module File = struct | "" :: rest -> of_segs_tl (Fpath.v "/") rest | first :: rest -> of_segs_tl (Fpath.v first) rest + let append_segs path segs = of_segs_tl path segs + module Table = Hashtbl.Make (struct type nonrec t = t @@ -136,6 +138,8 @@ module Directory = struct invalid_arg "Odoc.Fs.Directory.create: not a directory"; path + let contains ~parentdir f = Fpath.is_rooted ~root:parentdir f + let mkdir_p dir = let mkdir d = try Unix.mkdir (Fpath.to_string d) 0o755 with @@ -157,6 +161,8 @@ module Directory = struct | Result.Error (`Msg e) -> invalid_arg ("Odoc.Fs.Directory.of_string: " ^ e) | Result.Ok p -> Fpath.to_dir_path p + let of_file f = Fpath.to_dir_path f + let fold_files_rec ?(ext = "") f acc d = let fold_non_dirs ext f acc files = let is_dir d = try Sys.is_directory d with Sys_error _ -> false in diff --git a/src/odoc/fs.mli b/src/odoc/fs.mli index d2ac15c32b..09a162fcbf 100644 --- a/src/odoc/fs.mli +++ b/src/odoc/fs.mli @@ -36,8 +36,12 @@ module Directory : sig val reach_from : dir:t -> string -> t (** @raises Invalid_argument if [parent/name] exists but is not a directory. *) + val contains : parentdir:t -> file -> bool + val mkdir_p : t -> unit + val of_file : file -> t + val of_string : string -> t val to_string : t -> string @@ -93,5 +97,8 @@ module File : sig (** [of_segs segs] Returns an absolute path if [segs] starts with an empty segment. Raises [Invalid_argument] if [segs] is empty. *) + val append_segs : t -> string list -> t + (** Append a list of segments to a path. Do not raise. *) + module Table : Hashtbl.S with type key = t end diff --git a/src/odoc/indexing.ml b/src/odoc/indexing.ml index 4109999dde..243ab062fa 100644 --- a/src/odoc/indexing.ml +++ b/src/odoc/indexing.ml @@ -114,13 +114,20 @@ open Odoc_model.Lang.Sidebar let compile out_format ~output ~warnings_options ~lib_roots ~page_roots ~inputs_in_file ~odocls = + let current_dir = Fs.File.dirname output in parse_input_files inputs_in_file >>= fun files -> let files = List.rev_append odocls files in let resolver = Resolver.create ~important_digests:false ~directories:[] ~roots: (Some - { page_roots; lib_roots; current_lib = None; current_package = None }) + { + page_roots; + lib_roots; + current_lib = None; + current_package = None; + current_dir; + }) ~open_modules:[] in (* if files = [] && then Error (`Msg "No .odocl files were included") *) diff --git a/src/odoc/resolver.ml b/src/odoc/resolver.ml index a93b427e57..3ea90dfbdd 100644 --- a/src/odoc/resolver.ml +++ b/src/odoc/resolver.ml @@ -184,6 +184,32 @@ end = struct Hashtbl.find_all t name end +module Hierarchy : sig + (** Represent a file hierarchy and allow file path manipulations that do not + escape it. *) + + type t + + type error = [ `Escape_hierarchy ] + + val make : current_package:Fs.Directory.t -> current_dir:Fs.Directory.t -> t + + val resolve_relative : t -> Fs.File.t -> (Fs.File.t, error) result + (** [resolve_relative h relpath] resolve [relpath] relatively to the current + directory, making sure not to escape the hierarchy. *) +end = struct + type t = { current_package : Fs.Directory.t; current_dir : Fs.Directory.t } + + type error = [ `Escape_hierarchy ] + + let make ~current_package ~current_dir = { current_package; current_dir } + + let resolve_relative t relpath = + let path = Fs.File.append t.current_dir relpath in + if Fs.Directory.contains ~parentdir:t.current_package path then Ok path + else Error `Escape_hierarchy +end + module StringMap = Map.Make (String) let build_imports_map imports = @@ -413,41 +439,51 @@ let add_unit_to_cache u = in Hashtbl.add unit_cache target_name [ u ] -let lookup_path _ap ~pages ~libs:_ (kind, tag, path) = +let lookup_path _ap ~pages ~libs:_ ~hierarchy (kind, tag, path) = let module Env = Odoc_xref2.Env in let ( >>= ) x f = match x with Some x' -> f x' | None -> None in let page_path_to_path path = (* Turn [foo/bar] into [foo/page-bar.odoc]. *) - match List.rev path with - | [] -> [] - | name :: rest -> List.rev (("page-" ^ name ^ ".odoc") :: rest) + let segs = + match List.rev path with + | [] -> [] + | name :: rest -> List.rev (("page-" ^ name ^ ".odoc") :: rest) + in + Fs.File.of_segs segs in let find_by_path ?root named_roots path = match Named_roots.find_by_path ?root named_roots ~path with | Ok x -> x | Error (NoPackage | NoRoot) -> None in + let load_page path = + match load_unit_from_file path with + | Some (Odoc_file.Page_content page) -> Env.Path_page page + | _ -> Env.Path_not_found + in let find_page ?root path = - ( pages >>= fun pages -> - find_by_path ?root pages path >>= fun path -> - load_unit_from_file path >>= function - | Odoc_file.Page_content page -> Some page - | _ -> None ) - |> function - | Some page -> Env.Path_page page + (pages >>= fun pages -> find_by_path ?root pages path) |> function + | Some path -> load_page path + | None -> Env.Path_not_found + in + let find_page_in_hierarchy path = + match hierarchy with + | Some hierarchy -> ( + match Hierarchy.resolve_relative hierarchy path with + | Ok path -> load_page path + | Error `Escape_hierarchy -> + Env.Path_not_found (* TODO: propagate more information *)) | None -> Env.Path_not_found in match (kind, tag) with | `Page, `TCurrentPackage -> (* [path] is within the current package root. *) - let path = Fs.File.of_segs (page_path_to_path path) in - find_page path + find_page (page_path_to_path path) | `Page, `TAbsolutePath -> ( match path with - | root :: path -> - let path = Fs.File.of_segs (page_path_to_path path) in - find_page ~root path + | root :: path -> find_page ~root (page_path_to_path path) | [] -> Env.Path_not_found) + | `Page, `TRelativePath -> find_page_in_hierarchy (page_path_to_path path) | _ -> Env.Path_not_found type t = { @@ -456,6 +492,7 @@ type t = { pages : Named_roots.t option; libs : Named_roots.t option; open_modules : string list; + hierarchy : Hierarchy.t option; } let all_roots ?root named_roots = @@ -505,25 +542,42 @@ type roots = { lib_roots : (string * Fs.Directory.t) list; current_lib : string option; current_package : string option; + current_dir : Fs.Directory.t; } let create ~important_digests ~directories ~open_modules ~roots = let ap = Accessible_paths.create ~directories in - let pages, libs = + let pages, libs, hierarchy = match roots with - | None -> (None, None) - | Some { page_roots; lib_roots; current_lib; current_package } -> - ( Some (Named_roots.create ~current_root:current_package page_roots), - Some (Named_roots.create ~current_root:current_lib lib_roots) ) + | None -> (None, None, None) + | Some { page_roots; lib_roots; current_lib; current_package; current_dir } + -> + let pages = Named_roots.create ~current_root:current_package page_roots + and libs = Named_roots.create ~current_root:current_lib lib_roots in + let hierarchy = + match Named_roots.find_by_path pages ~path:(Fpath.v ".") with + | Ok (Some current_package) -> + let current_package = Fs.Directory.of_file current_package in + Some (Hierarchy.make ~current_package ~current_dir) + | Ok None | Error _ -> None + in + (Some pages, Some libs, hierarchy) in - { important_digests; ap; open_modules; pages; libs } + { important_digests; ap; open_modules; pages; libs; hierarchy } (** Helpers for creating xref2 env. *) open Odoc_xref2 let build_compile_env_for_unit - { important_digests; ap; open_modules = open_units; pages; libs } m = + { + important_digests; + ap; + open_modules = open_units; + pages; + libs; + hierarchy = _; + } m = add_unit_to_cache (Odoc_file.Unit_content m); let imports_map = build_imports_map m.imports in let lookup_unit = lookup_unit ~important_digests ~imports_map ~libs ap @@ -539,11 +593,12 @@ let build_compile_env_for_unit (** [important_digests] and [imports_map] only apply to modules. *) let build ?(imports_map = StringMap.empty) - { important_digests; ap; open_modules = open_units; pages; libs } = + { important_digests; ap; open_modules = open_units; pages; libs; hierarchy } + = let lookup_unit = lookup_unit ~libs ~important_digests ~imports_map ap and lookup_page = lookup_page ~pages ap and lookup_impl = lookup_impl ap - and lookup_path = lookup_path ap ~pages ~libs in + and lookup_path = lookup_path ap ~pages ~libs ~hierarchy in { Env.open_units; lookup_unit; lookup_page; lookup_impl; lookup_path } let build_compile_env_for_impl t i = diff --git a/src/odoc/resolver.mli b/src/odoc/resolver.mli index af32dc662f..0cc5472829 100644 --- a/src/odoc/resolver.mli +++ b/src/odoc/resolver.mli @@ -24,8 +24,10 @@ type t type roots = { page_roots : (string * Fs.Directory.t) list; lib_roots : (string * Fs.Directory.t) list; - current_lib : string option; - current_package : string option; + current_lib : string option; (** Name of the current [-L]. *) + current_package : string option; (** Name of the current [-P]. *) + current_dir : Fs.Directory.t; + (** Directory containing the output for the current unit. *) } val create : diff --git a/test/xref2/path_references.t/run.t b/test/xref2/path_references.t/run.t index bc715825be..da0efa361c 100644 --- a/test/xref2/path_references.t/run.t +++ b/test/xref2/path_references.t/run.t @@ -9,6 +9,8 @@ $ odoc link -P pkg:h/pkg/doc -L libname:h/pkg/lib/libname h/pkg/doc/subdir/page-dup.odoc $ odoc link -P pkg:h/pkg/doc -L libname:h/pkg/lib/libname h/pkg/doc/subdir/page-bar.odoc + File "h/pkg/doc/subdir/page-Test.odoc": + File does not exist File "doc/subdir/bar.mld", line 12, characters 49-56: Warning: Failed to resolve reference unresolvedroot(Test) Couldn't find "Test" File "doc/subdir/bar.mld", line 12, characters 39-48: @@ -17,14 +19,12 @@ Warning: Failed to resolve reference /pkg/libname/Test Path '/pkg/libname/Test' not found File "doc/subdir/bar.mld", line 12, characters 0-17: Warning: Failed to resolve reference //libname/Test Path '//libname/Test' not found - File "doc/subdir/bar.mld", line 10, characters 35-43: - Warning: Failed to resolve reference ./dup Path 'dup' not found - File "doc/subdir/bar.mld", line 6, characters 42-50: - Warning: Failed to resolve reference ./bar Path 'bar' not found File "doc/subdir/bar.mld", line 4, characters 21-27: Warning: Failed to resolve reference unresolvedroot(foo) Couldn't find "foo" $ odoc link -P pkg:h/pkg/doc -L libname:h/pkg/lib/libname h/pkg/doc/page-dup.odoc $ odoc link -P pkg:h/pkg/doc -L libname:h/pkg/lib/libname h/pkg/doc/page-foo.odoc + File "h/pkg/doc/page-Test.odoc": + File does not exist File "doc/foo.mld", line 12, characters 49-56: Warning: Failed to resolve reference unresolvedroot(Test) Couldn't find "Test" File "doc/foo.mld", line 12, characters 39-48: @@ -33,18 +33,8 @@ Warning: Failed to resolve reference /pkg/libname/Test Path '/pkg/libname/Test' not found File "doc/foo.mld", line 12, characters 0-17: Warning: Failed to resolve reference //libname/Test Path '//libname/Test' not found - File "doc/foo.mld", line 10, characters 35-48: - Warning: Failed to resolve reference ./subdir/dup Path 'subdir/dup' not found - File "doc/foo.mld", line 8, characters 21-29: - Warning: Failed to resolve reference ./dup Path 'dup' not found - File "doc/foo.mld", line 6, characters 56-71: - Warning: Failed to resolve reference ./subdir/bar Path 'subdir/bar' not found - File "doc/foo.mld", line 6, characters 42-55: - Warning: Failed to resolve reference ./subdir/bar Path 'subdir/bar' not found File "doc/foo.mld", line 6, characters 35-41: Warning: Failed to resolve reference unresolvedroot(bar) Couldn't find "bar" - File "doc/foo.mld", line 4, characters 28-36: - Warning: Failed to resolve reference ./foo Path 'foo' not found $ odoc link --current-package pkg -P pkg:h/pkg/doc -L libname:h/pkg/lib/libname h/pkg/lib/libname/test.odoc File "test.ml", line 12, characters 42-51: Warning: Failed to resolve reference ./Test Path 'Test' not found @@ -69,21 +59,21 @@ Helper that extracts references in a compact way. Headings help to interpret the {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"foo"]}}},[]]} {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"foo"]}}},[]]} {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"foo"]}}},[]]} - {"`Reference":[{"`Any_path":["`TRelativePath",["foo"]]},[]]} + {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"foo"]}}},[]]} ["Page","subdir/bar"] {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"subdir"]}},"bar"]}}},[]]} {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"subdir"]}},"bar"]}}},[]]} {"`Reference":[{"`Root":["bar","`TUnknown"]},[]]} - {"`Reference":[{"`Any_path":["`TRelativePath",["subdir","bar"]]},[]]} - {"`Reference":[{"`Any_path":["`TRelativePath",["subdir","bar"]]},[]]} + {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"subdir"]}},"bar"]}}},[]]} + {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"subdir"]}},"bar"]}}},[]]} ["Page","dup"] {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"dup"]}}},[]]} {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"dup"]}}},[]]} - {"`Reference":[{"`Any_path":["`TRelativePath",["dup"]]},[]]} + {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"dup"]}}},[]]} ["Page","subdir/dup"] {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"subdir"]}},"dup"]}}},[]]} {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"subdir"]}},"dup"]}}},[]]} - {"`Reference":[{"`Any_path":["`TRelativePath",["subdir","dup"]]},[]]} + {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"subdir"]}},"dup"]}}},[]]} ["Module","Test"] {"`Reference":[{"`Any_path":["`TCurrentPackage",["libname","Test"]]},[]]} {"`Reference":[{"`Any_path":["`TAbsolutePath",["pkg","libname","Test"]]},[]]} @@ -100,14 +90,14 @@ Helper that extracts references in a compact way. Headings help to interpret the {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"subdir"]}},"bar"]}}},[]]} {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"subdir"]}},"bar"]}}},[]]} {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"subdir"]}},"bar"]}}},[]]} - {"`Reference":[{"`Any_path":["`TRelativePath",["bar"]]},[]]} + {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"subdir"]}},"bar"]}}},[]]} ["Page","dup"] {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"dup"]}}},[]]} {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"dup"]}}},[]]} ["Page","subdir/dup"] {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"subdir"]}},"dup"]}}},[]]} {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"subdir"]}},"dup"]}}},[]]} - {"`Reference":[{"`Any_path":["`TRelativePath",["dup"]]},[]]} + {"`Reference":[{"`Resolved":{"`Identifier":{"`LeafPage":[{"Some":{"`Page":[{"Some":{"`Page":[{"Some":{"`Page":["None","pkg"]}},"doc"]}},"subdir"]}},"dup"]}}},[]]} ["Module","Test"] {"`Reference":[{"`Any_path":["`TCurrentPackage",["libname","Test"]]},[]]} {"`Reference":[{"`Any_path":["`TAbsolutePath",["pkg","libname","Test"]]},[]]}