From 2402d70b7dcdf6343d853989d4783716aa64dc57 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Mon, 3 May 2021 17:32:39 +0200 Subject: [PATCH 1/9] Refactor Env to open files once Do "lookup" and "resolve" in one operation to avoid opening each files twice. Remove unecessary caches and simplify the code a bit. --- src/odoc/compilation_unit.ml | 9 +- src/odoc/compile.ml | 10 +- src/odoc/env.ml | 329 +++++++++++++++------------------- src/odoc/env.mli | 14 +- src/odoc/html_fragment.ml | 2 +- src/odoc/odoc_link.ml | 4 +- src/odoc/rendering.ml | 4 +- src/xref2/compile.ml | 28 +-- src/xref2/compile.mli | 8 +- src/xref2/env.ml | 28 +-- src/xref2/env.mli | 10 +- test/xref2/lib/common.cppo.ml | 2 +- 12 files changed, 185 insertions(+), 263 deletions(-) diff --git a/src/odoc/compilation_unit.ml b/src/odoc/compilation_unit.ml index 265dd55206..dd9758a5c6 100644 --- a/src/odoc/compilation_unit.ml +++ b/src/odoc/compilation_unit.ml @@ -34,7 +34,14 @@ let load file = | exception Not_found -> ( try let ic = open_in_bin file in - let _root = Root.load file ic in + (match Root.load file ic with + | Ok { Odoc_model.Root.file = Page _; _ } -> + (* Ensure we aren't loading a page. [Env] no longer ensures that. *) + assert false + | Ok _ -> () + | Error (`Msg msg) -> + (* avoid calling marshal again. *) + failwith msg); let res = Marshal.from_channel ic in close_in ic; Hashtbl.add units_cache file res; diff --git a/src/odoc/compile.ml b/src/odoc/compile.ml index 8f3a8a6b8f..f2c5f885bd 100644 --- a/src/odoc/compile.ml +++ b/src/odoc/compile.ml @@ -33,7 +33,7 @@ let parent directories parent_cli_spec = let ap = Env.Accessible_paths.create ~directories in let find_parent : Odoc_model.Paths.Reference.t -> - (Odoc_model.Root.t, [> `Msg of string ]) Result.result = + (Odoc_model.Lang.Page.t, [> `Msg of string ]) Result.result = fun r -> match r with | `Root (p, `TPage) | `Root (p, `TUnknown) -> ( @@ -49,9 +49,9 @@ let parent directories parent_cli_spec = match parent_cli_spec with | CliParent f -> Odoc_model.Semantics.parse_reference f >>= fun r -> - find_parent r >>= fun r -> - extract_parent r.id >>= fun parent -> - Env.fetch_page ap r >>= fun page -> Ok (Explicit (parent, page.children)) + find_parent r >>= fun page -> + extract_parent page.name >>= fun parent -> + Ok (Explicit (parent, page.children)) | CliPackage package -> Ok (Package (`RootPage (PageName.make_std package))) | CliNoparent -> Ok Noparent @@ -67,7 +67,7 @@ let resolve_and_substitute ~env ~output ~warn_error parent input_file read_file (if not (Filename.check_suffix filename "cmt") then "" (* ? *) else Printf.sprintf " Using %S while you should use the .cmti file" filename); - let env = Env.build env (`Unit unit) in + let env = Env.build_from_module env unit in Odoc_xref2.Compile.compile env unit |> Odoc_xref2.Lookup_failures.handle_failures ~warn_error:false ~filename diff --git a/src/odoc/env.ml b/src/odoc/env.ml index aaf2a1b9a7..1aae1ef1ee 100644 --- a/src/odoc/env.ml +++ b/src/odoc/env.ml @@ -33,21 +33,22 @@ open Or_error -module Accessible_paths = struct - type t = { - root_map : Fs.File.t Odoc_model.Root.Hash_table.t; - file_map : (string, Odoc_model.Root.t list) Hashtbl.t; - directories : Fs.Directory.t list; - } +type env_unit = [ `Module of Compilation_unit.t | `Page of Page.t ] +(** In this module, a unit is either a module or a page. A module is a + [Compilation_unit]. *) - let create ~directories = - { - root_map = Odoc_model.Root.Hash_table.create 42; - file_map = Hashtbl.create 42; - directories; - } +module Accessible_paths : sig + type t - let find_file_by_name t name = + val create : directories:Fs.Directory.t list -> t + + val find : t -> string -> Fs.File.t list +end = struct + type t = { directories : Fs.Directory.t list } + + let create ~directories = { directories } + + let find t name = let uname = Astring.String.Ascii.capitalize name ^ ".odoc" in let lname = Astring.String.Ascii.uncapitalize name ^ ".odoc" in let rec loop acc = function @@ -63,76 +64,12 @@ module Accessible_paths = struct | exception Unix.Unix_error _ -> loop acc dirs)) in loop [] t.directories - - (* If there's only one possible file we've discovered in the search path - we can check the digest right now. If there's more than one, we defer - until further up the call stack *) - let check_optional_digest ?digest filename (roots : Odoc_model.Root.t list) = - match (roots, digest) with - | [ root ], Some d when Digest.compare d root.digest <> 0 -> - let warning = - Odoc_model.Error.filename_only "Digest mismatch" filename - in - prerr_endline (Odoc_model.Error.to_string warning); - roots - | _ -> roots - - let find_root t ~filename = - match Hashtbl.find t.file_map filename with - | roots -> roots - | exception Not_found -> - let paths = find_file_by_name t filename in - (* This could be the empty list *) - let filter_map f l = - List.fold_right - (fun x acc -> match f x with Some y -> y :: acc | None -> acc) - l [] - in - let safe_read file = - match Root.read file with - | Ok root -> Some (root, file) - | Error (`Msg msg) -> - let warning = - Odoc_model.Error.filename_only "%s" msg (Fs.File.to_string file) - in - prerr_endline (Odoc_model.Error.to_string warning); - None - | exception End_of_file -> - let warning = - Odoc_model.Error.filename_only "End_of_file while reading" - (Fs.File.to_string file) - in - prerr_endline (Odoc_model.Error.to_string warning); - None - in - let roots_paths = filter_map safe_read paths in - let roots = List.map fst roots_paths in - Hashtbl.add t.file_map filename roots; - List.iter - (fun (root, path) -> - Odoc_model.Root.Hash_table.add t.root_map root path) - roots_paths; - roots - - let file_of_root t root = - try Odoc_model.Root.Hash_table.find t.root_map root - with Not_found -> - let _roots = - match root.file with - | Page page_name -> - let filename = "page-" ^ page_name in - check_optional_digest ~digest:root.digest filename - @@ find_root t ~filename - | Compilation_unit { name; _ } -> - check_optional_digest ~digest:root.digest name - @@ find_root t ~filename:name - in - Odoc_model.Root.Hash_table.find t.root_map root end module StringMap = Map.Make (String) -let build_imports_map imports = +let build_imports_map m = + let imports = m.Odoc_model.Lang.Compilation_unit.imports in List.fold_left (fun map import -> match import with @@ -142,127 +79,147 @@ let build_imports_map imports = StringMap.add (Odoc_model.Names.ModuleName.to_string name) import map) StringMap.empty imports -let lookup_unit ~important_digests ap target_name import_map = - let handle_root (root : Odoc_model.Root.t) = - match root.file with - | Compilation_unit { hidden; _ } -> Odoc_xref2.Env.Found { root; hidden } - | Page _ -> assert false +let unit_name (u : env_unit) = + let open Odoc_model in + let root = match u with `Page p -> p.root | `Module m -> m.root in + let (Page name | Compilation_unit { name; _ }) = root.Root.file in + name + +let load_unit_from_file file = + let file = Fs.File.to_string file in + let ic = open_in_bin file in + let res = + try + match Root.load file ic with + | Error _ as e -> e + | Ok root -> + Ok + (match root.Odoc_model.Root.file with + | Page _ -> `Page (Marshal.from_channel ic) + | Compilation_unit _ -> `Module (Marshal.from_channel ic)) + with exn -> + let msg = + Printf.sprintf "Error while unmarshalling %S: %s\n%!" file + (match exn with Failure s -> s | _ -> Printexc.to_string exn) + in + Error (`Msg msg) in - let find_root ~digest = - match (Accessible_paths.find_root ap ~filename:target_name, digest) with - | [], _ -> Odoc_xref2.Env.Not_found - | [ r ], _ -> - handle_root r (* Already checked the digest, if one's been specified *) - | r :: rs, None -> - Printf.fprintf stderr - "Warning, ambiguous lookup. Please wrap your libraries. Possible \ - files:\n\ - %!"; - let files_strs = - List.map - (fun root -> - Accessible_paths.file_of_root ap root - |> Fs.File.to_string |> Printf.sprintf " %s") - (r :: rs) + close_in ic; + res + +(** TODO: Propagate warnings instead of printing. *) +let load_units_from_files paths = + let safe_read file acc = + match load_unit_from_file file with + | Ok u -> u :: acc + | Error (`Msg msg) -> + let warning = + Odoc_model.Error.filename_only "%s" msg (Fs.File.to_string file) in - prerr_endline (String.concat "\n" files_strs); - (* We've not specified a digest, let's try the first one *) - handle_root r - | roots, Some d -> ( - try - (* If we can't find a module that matches the digest, return Not_found *) - handle_root - @@ List.find (fun root -> root.Odoc_model.Root.digest = d) roots - with Not_found -> Odoc_xref2.Env.Not_found) + prerr_endline (Odoc_model.Error.to_string warning); + acc in - match StringMap.find target_name import_map with - | Odoc_model.Lang.Compilation_unit.Import.Unresolved (_, digest) -> ( - match digest with - | None when important_digests -> Odoc_xref2.Env.Forward_reference - | _ -> find_root ~digest) - | Odoc_model.Lang.Compilation_unit.Import.Resolved (root, _) -> ( - match root.file with - | Compilation_unit { hidden; _ } -> Found { root; hidden } - | Page _ -> assert false) - | exception Not_found -> - if important_digests then Odoc_xref2.Env.Not_found - else find_root ~digest:None + List.fold_right safe_read paths [] -let lookup_page ap target_name = - match Accessible_paths.find_root ap ~filename:("page-" ^ target_name) with - | [] -> None - | [ root ] -> Some root - | root :: _roots -> Some root +let unit_cache = Hashtbl.create 42 -let fetch_page ap root = - match Accessible_paths.file_of_root ap root with - | path -> Page.load path - | exception Not_found -> - let msg = - Printf.sprintf "No unit for root: %s\n%!" - (Odoc_model.Root.to_string root) - in - Error (`Msg msg) +(** Load every units matching a given name. Cached. *) +let load_units_from_name = + let do_load ap target_name = + let paths = Accessible_paths.find ap target_name in + load_units_from_files paths + in + fun ap target_name -> + try Hashtbl.find unit_cache target_name + with Not_found -> + let units = do_load ap target_name in + Hashtbl.add unit_cache target_name units; + units -let fetch_unit ap root = - match Accessible_paths.file_of_root ap root with - | path -> Compilation_unit.load path - | exception Not_found -> - let msg = - Printf.sprintf "No unit for root: %s\n%!" - (Odoc_model.Root.to_string root) +let rec find_map f = function + | [] -> None + | hd :: tl -> ( + match f hd with Some x -> Some (x, tl) | None -> find_map f tl) + +let lookup_module_with_digest ap target_name digest = + let module_that_match_digest = function + | `Module m + when Digest.compare m.Odoc_model.Lang.Compilation_unit.digest digest = 0 + -> + Some m + | _ -> None + in + let units = load_units_from_name ap target_name in + match find_map module_that_match_digest units with + | Some (m, _) -> Odoc_xref2.Env.Found m + | None -> Not_found + +(** Lookup a module matching a name. If there is more than one result, report on + stderr and return the first one. + + TODO: Correctly propagate warnings instead of printing. *) +let lookup_module_by_name ap target_name = + let first_module = function `Module m -> Some m | `Page _ -> None in + let units = load_units_from_name ap target_name in + match find_map first_module units with + | Some (m, []) -> Odoc_xref2.Env.Found m + | Some (m, (_ :: _ as ambiguous)) -> + Printf.fprintf stderr + "Warning, ambiguous lookup. Please wrap your libraries. Possible files:\n\ + %!"; + let files_strs = + List.map + (fun u -> Printf.sprintf " %s" (unit_name u)) + (`Module m :: ambiguous) in - Error (`Msg msg) + prerr_endline (String.concat "\n" files_strs); + Found m + | None -> Not_found + +(** Lookup a module. First looks into [imports_map] then searches into the paths. *) +let lookup_unit ~important_digests ~imports_map ap target_name = + match StringMap.find target_name imports_map with + | Odoc_model.Lang.Compilation_unit.Import.Unresolved (_, Some digest) -> + lookup_module_with_digest ap target_name digest + | Unresolved (_, None) -> + if important_digests then Odoc_xref2.Env.Forward_reference + else lookup_module_by_name ap target_name + | Resolved (root, _) -> lookup_module_with_digest ap target_name root.digest + | exception Not_found -> + if important_digests then Odoc_xref2.Env.Not_found + else lookup_module_by_name ap target_name + +(** Lookup a page. + + TODO: Warning on ambiguous lookup. *) +let lookup_page ap target_name = + let target_name = "page-" ^ target_name in + let is_page = function `Page p -> Some p | `Module _ -> 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 type t = Odoc_xref2.Env.resolver -type builder = [ `Unit of Compilation_unit.t | `Page of Page.t ] -> t +type builder = env_unit -> t + +(** Add the current unit to the cache. No need to load other units with the same + name. *) +let add_unit_to_cache u = Hashtbl.add unit_cache (unit_name u) [ u ] -let create ?(important_digests = true) ~directories ~open_modules : builder = +let create ?(important_digests = true) ~directories ~open_modules = let ap = Accessible_paths.create ~directories in fun unit_or_page -> + add_unit_to_cache unit_or_page; let lookup_unit = match unit_or_page with | `Page _ -> - fun target_name -> - lookup_unit ~important_digests:false ap target_name StringMap.empty - | `Unit unit -> ( - let imports_map = - build_imports_map unit.Odoc_model.Lang.Compilation_unit.imports - in - fun target_name -> - let lookup_result = - lookup_unit ~important_digests ap target_name imports_map - in - match lookup_result with - | Not_found -> ( - let root = unit.root in - match root.file with - | Page _ -> assert false - | Compilation_unit { name; hidden } when target_name = name -> - Found { root; hidden } - | Compilation_unit _ -> Not_found) - | x -> x) - in - let fetch_unit root : (Odoc_model.Lang.Compilation_unit.t, _) Result.result - = - match unit_or_page with - | `Page _ -> fetch_unit ap root - | `Unit unit -> - let current_root = unit.root in - if Odoc_model.Root.equal root current_root then Ok unit - else fetch_unit ap root - in - let lookup_page target_name = lookup_page ap target_name in - let fetch_page root : (Odoc_model.Lang.Page.t, _) Result.result = - match unit_or_page with - | `Unit _ -> fetch_page ap root - | `Page page -> - let current_root = page.Odoc_model.Lang.Page.root in - if Odoc_model.Root.equal root current_root then Ok page - else fetch_page ap root - in - Odoc_xref2.Compile.build_resolver open_modules lookup_unit fetch_unit - lookup_page fetch_page + lookup_unit ~important_digests:false ~imports_map:StringMap.empty ap + | `Module current_m -> + let imports_map = build_imports_map current_m in + lookup_unit ~important_digests ~imports_map ap + and lookup_page = lookup_page ap in + Odoc_xref2.Compile.build_resolver open_modules lookup_unit lookup_page + +let build_from_module builder m = builder (`Module m) -let build builder unit = builder unit +let build_from_page builder p = builder (`Page p) diff --git a/src/odoc/env.mli b/src/odoc/env.mli index 772b4edf25..0533847f57 100644 --- a/src/odoc/env.mli +++ b/src/odoc/env.mli @@ -25,12 +25,7 @@ module Accessible_paths : sig val create : directories:Fs.directory list -> t end -val lookup_page : Accessible_paths.t -> string -> Odoc_model.Root.t option - -val fetch_page : - Accessible_paths.t -> - Odoc_model.Root.t -> - (Page.t, [> `Msg of string ]) Result.result +val lookup_page : Accessible_paths.t -> string -> Odoc_model.Lang.Page.t option type t = Odoc_xref2.Env.resolver @@ -47,7 +42,10 @@ val create : @param important_digests indicate whether digests should be compared when doc-ock tries to lookup or fetch a unit. It defaults to [true]. *) -val build : builder -> [ `Unit of Compilation_unit.t | `Page of Page.t ] -> t -(** Initialize the environment for the given unit. *) +val build_from_module : builder -> Odoc_model.Lang.Compilation_unit.t -> t +(** Initialize the environment for the given module. *) + +val build_from_page : builder -> Odoc_model.Lang.Page.t -> t +(** Initialize the environment for the given page. *) (* val forward_resolver : t -> Root.t DocOck.forward_resolver *) diff --git a/src/odoc/html_fragment.ml b/src/odoc/html_fragment.ml index 37a18d7404..441de5735d 100644 --- a/src/odoc/html_fragment.ml +++ b/src/odoc/html_fragment.ml @@ -16,7 +16,7 @@ let from_mld ~xref_base_uri ~env ~output ~warn_error input = Odoc_model.Lang.Page. { name = id; root; content; children = []; digest; linked = false } in - let resolve_env = Env.build env (`Page page) in + let resolve_env = Env.build_from_page env page in Odoc_xref2.Link.resolve_page resolve_env page |> Odoc_xref2.Lookup_failures.handle_failures ~warn_error ~filename:input_s >>= fun resolved -> diff --git a/src/odoc/odoc_link.ml b/src/odoc/odoc_link.ml index 00b05478c6..82dd7a21dc 100644 --- a/src/odoc/odoc_link.ml +++ b/src/odoc/odoc_link.ml @@ -6,7 +6,7 @@ let from_odoc ~env ~warn_error input output = match root.file with | Page _ -> Page.load input >>= fun page -> - let resolve_env = Env.build env (`Page page) in + let resolve_env = Env.build_from_page env page in Odoc_xref2.Link.resolve_page resolve_env page |> Odoc_xref2.Lookup_failures.handle_failures ~warn_error ~filename:input_s @@ -28,7 +28,7 @@ let from_odoc ~env ~warn_error input output = else unit in - let env = Env.build env (`Unit unit) in + let env = Env.build_from_module env unit in Odoc_xref2.Link.link env unit |> Odoc_xref2.Lookup_failures.handle_failures ~warn_error:false ~filename:input_s diff --git a/src/odoc/rendering.ml b/src/odoc/rendering.ml index 2e5b575509..0a82b90a4e 100644 --- a/src/odoc/rendering.ml +++ b/src/odoc/rendering.ml @@ -17,7 +17,7 @@ let document_of_input ~env ~warn_error ~syntax input = match root.file with | Page _ -> Page.load input >>= fun page -> - let resolve_env = Env.build env (`Page page) in + let resolve_env = Env.build_from_page env page in Odoc_xref2.Link.resolve_page resolve_env page |> Odoc_xref2.Lookup_failures.handle_failures ~warn_error ~filename:input_s @@ -37,7 +37,7 @@ let document_of_input ~env ~warn_error ~syntax input = } else unit in - let env = Env.build env (`Unit unit) in + let env = Env.build_from_module env unit in (* let startlink = Unix.gettimeofday () in *) (* Format.fprintf Format.err_formatter "**** Link...\n%!"; *) let linked = Odoc_xref2.Link.link env unit in diff --git a/src/xref2/compile.ml b/src/xref2/compile.ml index a733da3413..e0232130f8 100644 --- a/src/xref2/compile.ml +++ b/src/xref2/compile.ml @@ -741,35 +741,13 @@ and type_expression : Env.t -> Id.Parent.t -> _ -> _ = | Poly (strs, t) -> Poly (strs, type_expression env parent t) | Package p -> Package (type_expression_package env parent p) -type msg = [ `Msg of string ] - -exception Fetch_failed of msg - let build_resolver : - ?equal:(Root.t -> Root.t -> bool) -> - ?hash:(Root.t -> int) -> string list -> (string -> Env.lookup_unit_result) -> - (Root.t -> (Compilation_unit.t, _) Result.result) -> - (string -> Root.t option) -> - (Root.t -> (Page.t, _) Result.result) -> + (string -> Page.t option) -> Env.resolver = - fun ?equal:_ ?hash:_ open_units lookup_unit resolve_unit lookup_page - resolve_page -> - let resolve_unit root = - match resolve_unit root with - | Ok unit -> unit - | Error (`Msg s) -> - Format.eprintf "Fetch_failed: %s\n%!" s; - raise (Fetch_failed (`Msg s)) - and resolve_page root = - match resolve_page root with - | Ok page -> page - | Error (`Msg s) -> - Format.eprintf "Fetch_failed (resolving page): %s\n%!" s; - raise (Fetch_failed (`Msg s)) - in - { Env.lookup_unit; resolve_unit; lookup_page; resolve_page; open_units } + fun open_units lookup_unit lookup_page -> + { Env.lookup_unit; lookup_page; open_units } let compile x y = Lookup_failures.catch_failures (fun () -> unit x y) diff --git a/src/xref2/compile.mli b/src/xref2/compile.mli index 6ab64a7894..3a5e62e962 100644 --- a/src/xref2/compile.mli +++ b/src/xref2/compile.mli @@ -6,16 +6,10 @@ val signature : Odoc_model.Lang.Signature.t -> Odoc_model.Lang.Signature.t -type msg = [ `Msg of string ] - val build_resolver : - ?equal:(Odoc_model.Root.t -> Odoc_model.Root.t -> bool) -> - ?hash:(Odoc_model.Root.t -> int) -> string list -> (string -> Env.lookup_unit_result) -> - (Odoc_model.Root.t -> (Odoc_model.Lang.Compilation_unit.t, msg) Result.result) -> - (string -> Odoc_model.Root.t option) -> - (Odoc_model.Root.t -> (Odoc_model.Lang.Page.t, msg) Result.result) -> + (string -> Env.lookup_page_result) -> Env.resolver val compile : diff --git a/src/xref2/env.ml b/src/xref2/env.ml index 9763ee7486..43e12b3aaf 100644 --- a/src/xref2/env.ml +++ b/src/xref2/env.ml @@ -2,13 +2,13 @@ open Odoc_model open Odoc_model.Names -type lookup_result_found = { root : Odoc_model.Root.t; hidden : bool } - type lookup_unit_result = | Forward_reference - | Found of lookup_result_found + | Found of Odoc_model.Lang.Compilation_unit.t | Not_found +type lookup_page_result = Odoc_model.Lang.Page.t option + type root = | Resolved of (Digest.t * Odoc_model.Paths.Identifier.Module.t * Component.Module.t) @@ -17,9 +17,7 @@ type root = type resolver = { open_units : string list; lookup_unit : string -> lookup_unit_result; - resolve_unit : Odoc_model.Root.t -> Odoc_model.Lang.Compilation_unit.t; - lookup_page : string -> Odoc_model.Root.t option; - resolve_page : Odoc_model.Root.t -> Odoc_model.Lang.Page.t; + lookup_page : string -> lookup_page_result; } let unique_id = ref 0 @@ -366,13 +364,10 @@ let lookup_root_module name env = match r.lookup_unit name with | Forward_reference -> Some Forward | Not_found -> None - | Found u -> ( - match u.root.id with - | `Root _ as id -> - let unit = r.resolve_unit u.root in - let m = module_of_unit unit in - Some (Resolved (u.root.digest, id, m)) - | _ -> failwith "Expecting root module!")) + | Found u -> + let (`Root _ as id) = u.id in + let m = module_of_unit u in + Some (Resolved (u.root.digest, id, m))) in (match (env.recorder, result) with | Some r, Some Forward -> @@ -558,12 +553,7 @@ let lookup_section_title identifier env = try Some (Maps.Label.find identifier env.titles) with _ -> None let lookup_page name env = - match env.resolver with - | None -> None - | Some r -> ( - match r.lookup_page name with - | None -> None - | Some root -> Some (r.resolve_page root)) + match env.resolver with None -> None | Some r -> r.lookup_page name let add_functor_parameter : Odoc_model.Lang.FunctorParameter.t -> t -> t = fun p t -> diff --git a/src/xref2/env.mli b/src/xref2/env.mli index fa026d5919..16a37029a0 100644 --- a/src/xref2/env.mli +++ b/src/xref2/env.mli @@ -1,12 +1,12 @@ (* Env.mli *) -type lookup_result_found = { root : Odoc_model.Root.t; hidden : bool } - type lookup_unit_result = | Forward_reference - | Found of lookup_result_found + | Found of Odoc_model.Lang.Compilation_unit.t | Not_found +type lookup_page_result = Odoc_model.Lang.Page.t option + type root = | Resolved of (Digest.t * Odoc_model.Paths.Identifier.Module.t * Component.Module.t) @@ -15,9 +15,7 @@ type root = type resolver = { open_units : string list; lookup_unit : string -> lookup_unit_result; - resolve_unit : Odoc_model.Root.t -> Odoc_model.Lang.Compilation_unit.t; - lookup_page : string -> Odoc_model.Root.t option; - resolve_page : Odoc_model.Root.t -> Odoc_model.Lang.Page.t; + lookup_page : string -> lookup_page_result; } type lookup_type = diff --git a/test/xref2/lib/common.cppo.ml b/test/xref2/lib/common.cppo.ml index b7f8f25886..f156d318d0 100644 --- a/test/xref2/lib/common.cppo.ml +++ b/test/xref2/lib/common.cppo.ml @@ -622,7 +622,7 @@ let mkenv () = let resolve unit = let env = mkenv () in - let resolve_env = Odoc_odoc.Env.build env (`Unit unit) in + let resolve_env = Odoc_odoc.Env.build_from_module env unit in let result = Odoc_xref2.Compile.compile resolve_env unit in result From fa051e17c7a4356396f263d9328621ba27126239 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Tue, 4 May 2021 12:10:47 +0200 Subject: [PATCH 2/9] Don't lookup imports The result of these lookups is not used at all, except for the warnings that might be printed in case of error. Some modules have a lot of imports but need few lookups while resolving, especially the entry point of wrapped libraries. --- src/odoc/env.ml | 2 +- src/xref2/compile.ml | 12 ++---------- src/xref2/compile.mli | 6 ------ src/xref2/env.ml | 20 ++------------------ src/xref2/env.mli | 5 +---- src/xref2/link.ml | 4 ++-- 6 files changed, 8 insertions(+), 41 deletions(-) diff --git a/src/odoc/env.ml b/src/odoc/env.ml index 1aae1ef1ee..96ef850aa7 100644 --- a/src/odoc/env.ml +++ b/src/odoc/env.ml @@ -218,7 +218,7 @@ let create ?(important_digests = true) ~directories ~open_modules = let imports_map = build_imports_map current_m in lookup_unit ~important_digests ~imports_map ap and lookup_page = lookup_page ap in - Odoc_xref2.Compile.build_resolver open_modules lookup_unit lookup_page + { Odoc_xref2.Env.open_units = open_modules; lookup_unit; lookup_page } let build_from_module builder m = builder (`Module m) diff --git a/src/xref2/compile.ml b/src/xref2/compile.ml index e0232130f8..d38c3e330e 100644 --- a/src/xref2/compile.ml +++ b/src/xref2/compile.ml @@ -55,8 +55,8 @@ and class_type_path : Env.t -> Paths.Path.ClassType.t -> Paths.Path.ClassType.t let rec unit (resolver : Env.resolver) t = let open Compilation_unit in - let imports, env = Env.initial_env t resolver in - { t with content = content env t.id t.content; imports } + let env = Env.initial_env t resolver in + { t with content = content env t.id t.content } and content env id = let open Compilation_unit in @@ -741,14 +741,6 @@ and type_expression : Env.t -> Id.Parent.t -> _ -> _ = | Poly (strs, t) -> Poly (strs, type_expression env parent t) | Package p -> Package (type_expression_package env parent p) -let build_resolver : - string list -> - (string -> Env.lookup_unit_result) -> - (string -> Page.t option) -> - Env.resolver = - fun open_units lookup_unit lookup_page -> - { Env.lookup_unit; lookup_page; open_units } - let compile x y = Lookup_failures.catch_failures (fun () -> unit x y) let resolve_page _resolver y = y diff --git a/src/xref2/compile.mli b/src/xref2/compile.mli index 3a5e62e962..eac7891eea 100644 --- a/src/xref2/compile.mli +++ b/src/xref2/compile.mli @@ -6,12 +6,6 @@ val signature : Odoc_model.Lang.Signature.t -> Odoc_model.Lang.Signature.t -val build_resolver : - string list -> - (string -> Env.lookup_unit_result) -> - (string -> Env.lookup_page_result) -> - Env.resolver - val compile : Env.resolver -> Odoc_model.Lang.Compilation_unit.t -> diff --git a/src/xref2/env.ml b/src/xref2/env.ml index 43e12b3aaf..70ea72637d 100644 --- a/src/xref2/env.ml +++ b/src/xref2/env.ml @@ -708,11 +708,7 @@ let rec open_signature : Odoc_model.Lang.Signature.t -> t -> t = | Odoc_model.Lang.Signature.Open o -> open_signature o.expansion env) e s.items -let initial_env : - Odoc_model.Lang.Compilation_unit.t -> - resolver -> - Odoc_model.Lang.Compilation_unit.Import.t list * t = - fun t resolver -> +let initial_env t resolver = let open Odoc_model.Lang.Compilation_unit in let initial_env = let m = module_of_unit t in @@ -720,19 +716,7 @@ let initial_env : let dm = Component.Delayed.put (fun () -> m) in empty |> add_module (t.id :> Identifier.Path.Module.t) dm m.doc in - let initial_env = set_resolver initial_env resolver in - List.fold_right - (fun import (imports, env) -> - match import with - | Import.Resolved (_root, _name) -> (import :: imports, env) - | Import.Unresolved (str, _) -> ( - match resolver.lookup_unit str with - | Forward_reference -> (import :: imports, env) - | Found x -> - let name = Names.ModuleName.make_std str in - (Import.Resolved (x.root, name) :: imports, env) - | Not_found -> (import :: imports, env))) - t.imports ([], initial_env) + set_resolver initial_env resolver let inherit_resolver env = match env.resolver with Some r -> set_resolver empty r | None -> empty diff --git a/src/xref2/env.mli b/src/xref2/env.mli index 16a37029a0..46a97f827a 100644 --- a/src/xref2/env.mli +++ b/src/xref2/env.mli @@ -169,10 +169,7 @@ val open_class_signature : Odoc_model.Lang.ClassSignature.t -> t -> t val open_signature : Odoc_model.Lang.Signature.t -> t -> t -val initial_env : - Odoc_model.Lang.Compilation_unit.t -> - resolver -> - Odoc_model.Lang.Compilation_unit.Import.t list * t +val initial_env : Odoc_model.Lang.Compilation_unit.t -> resolver -> t val inherit_resolver : t -> t (** Create an empty environment reusing the same resolver. *) diff --git a/src/xref2/link.ml b/src/xref2/link.ml index 10eaa4ae74..f5c2813ac6 100644 --- a/src/xref2/link.ml +++ b/src/xref2/link.ml @@ -213,13 +213,13 @@ and comment env parent = function let rec unit (resolver : Env.resolver) t = let open Compilation_unit in - let imports, env = Env.initial_env t resolver in + let env = Env.initial_env t resolver in let content = match t.content with | Module sg -> Module (signature env (t.id :> Id.Signature.t) sg) | Pack _ as p -> p in - { t with content; imports; linked = true } + { t with content; linked = true } and value_ env parent t = let open Value in From 321fc822ce304332ed4694e1b4612656d3913abc Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Thu, 6 May 2021 17:14:12 +0200 Subject: [PATCH 3/9] Safer and simpler loading of .odoc files Remove the separate loading of the root. Handle pages and modules from the same loading function. Remove unecessary caching. --- src/model/root.ml | 2 + src/model/root.mli | 2 + src/odoc/compilation_unit.ml | 67 +++++++++++------ src/odoc/compilation_unit.mli | 17 ++++- src/odoc/compile.ml | 15 +--- src/odoc/depends.ml | 12 ++- src/odoc/env.ml | 138 +++++++++++++++++----------------- src/odoc/env.mli | 2 +- src/odoc/odoc_link.ml | 26 +++---- src/odoc/page.ml | 56 -------------- src/odoc/page.mli | 27 ------- src/odoc/rendering.ml | 35 ++++----- src/odoc/root.ml | 39 ---------- src/odoc/root.mli | 28 ------- test/odoc_print/odoc_print.ml | 10 +-- 15 files changed, 170 insertions(+), 306 deletions(-) delete mode 100644 src/odoc/page.ml delete mode 100644 src/odoc/page.mli delete mode 100644 src/odoc/root.ml delete mode 100644 src/odoc/root.mli diff --git a/src/model/root.ml b/src/model/root.ml index c102c6318a..85e2946de9 100644 --- a/src/model/root.ml +++ b/src/model/root.ml @@ -47,6 +47,8 @@ module Odoc_file = struct let create_page name = Page name let name = function Page name | Compilation_unit { name; _ } -> name + + let hidden = function Page _ -> false | Compilation_unit m -> m.hidden end type t = { diff --git a/src/model/root.mli b/src/model/root.mli index 49bfd59486..393aa0f2ba 100644 --- a/src/model/root.mli +++ b/src/model/root.mli @@ -35,6 +35,8 @@ module Odoc_file : sig val create_page : string -> t val name : t -> string + + val hidden : t -> bool end type t = { diff --git a/src/odoc/compilation_unit.ml b/src/odoc/compilation_unit.ml index dd9758a5c6..bf18f95f1f 100644 --- a/src/odoc/compilation_unit.ml +++ b/src/odoc/compilation_unit.ml @@ -14,41 +14,58 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) +open Odoc_model open Or_error -type t = Odoc_model.Lang.Compilation_unit.t +type content = + | Page_content of Lang.Page.t + | Module_content of Lang.Compilation_unit.t -let save file t = +type t = { root : Root.t; content : content } + +(** Written at the top of the files. Checked when loading. *) +let magic = "odoc-%%VERSION%%" + +(** Exceptions while saving are allowed to leak. *) +let save_unit file t = Fs.Directory.mkdir_p (Fs.File.dirname file); let oc = open_out_bin (Fs.File.to_string file) in - Root.save oc t.Odoc_model.Lang.Compilation_unit.root; + output_string oc magic; Marshal.to_channel oc t []; close_out oc -let units_cache = Hashtbl.create 23 (* because. *) +let save_page file page = + let dir = Fs.File.dirname file in + let base = Fs.File.(to_string @@ basename file) in + let file = + if Astring.String.is_prefix ~affix:"page-" base then file + else Fs.File.create ~directory:dir ~name:("page-" ^ base) + in + save_unit file { root = page.Lang.Page.root; content = Page_content page } + +let save_module file m = + save_unit file + { root = m.Lang.Compilation_unit.root; content = Module_content m } let load file = let file = Fs.File.to_string file in - match Hashtbl.find units_cache file with - | unit -> Ok unit - | exception Not_found -> ( - try - let ic = open_in_bin file in - (match Root.load file ic with - | Ok { Odoc_model.Root.file = Page _; _ } -> - (* Ensure we aren't loading a page. [Env] no longer ensures that. *) - assert false - | Ok _ -> () - | Error (`Msg msg) -> - (* avoid calling marshal again. *) - failwith msg); - let res = Marshal.from_channel ic in - close_in ic; - Hashtbl.add units_cache file res; - Ok res - with exn -> + let ic = open_in_bin file in + let res = + try + let actual_magic = really_input_string ic (String.length magic) in + if actual_magic = magic then Ok (Marshal.from_channel ic) + else let msg = - Printf.sprintf "Error while unmarshalling %S: %s\n%!" file - (match exn with Failure s -> s | _ -> Printexc.to_string exn) + Printf.sprintf "%s: invalid magic number %S, expected %S\n%!" file + actual_magic magic in - Error (`Msg msg)) + Error (`Msg msg) + with exn -> + let msg = + Printf.sprintf "Error while unmarshalling %S: %s\n%!" file + (match exn with Failure s -> s | _ -> Printexc.to_string exn) + in + Error (`Msg msg) + in + close_in ic; + res diff --git a/src/odoc/compilation_unit.mli b/src/odoc/compilation_unit.mli index 48b9bcc5e0..234258e716 100644 --- a/src/odoc/compilation_unit.mli +++ b/src/odoc/compilation_unit.mli @@ -14,16 +14,27 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) +(** Load and save [.odoc] and [.odocl] files. *) + +open Odoc_model open Or_error -type t = Odoc_model.Lang.Compilation_unit.t +(** Either a page or a module. *) +type content = + | Page_content of Lang.Page.t + | Module_content of Lang.Compilation_unit.t + +type t = { root : Root.t; content : content } (** {2 Serialization} *) -val save : Fs.File.t -> t -> unit +val save_page : Fs.File.t -> Lang.Page.t -> unit +(** Save a page. The [page-] prefix is added to the file name if missing. *) -val units_cache : (string, t) Hashtbl.t +val save_module : Fs.File.t -> Lang.Compilation_unit.t -> unit +(** Save a module. *) (** {2 Deserialization} *) val load : Fs.File.t -> (t, [> msg ]) result +(** Load an [.odoc] file. *) diff --git a/src/odoc/compile.ml b/src/odoc/compile.ml index f2c5f885bd..8a1c4856fb 100644 --- a/src/odoc/compile.ml +++ b/src/odoc/compile.ml @@ -79,7 +79,7 @@ let resolve_and_substitute ~env ~output ~warn_error parent input_file read_file working on. *) (* let expand_env = Env.build env (`Unit resolved) in*) (* let expanded = Odoc_xref2.Expand.expand (Env.expander expand_env) resolved in *) - Compilation_unit.save output compiled; + Compilation_unit.save_module output compiled; Ok () let root_of_compilation_unit ~parent_spec ~hidden ~output ~module_name ~digest = @@ -88,15 +88,8 @@ let root_of_compilation_unit ~parent_spec ~hidden ~output ~module_name ~digest = Filename.chop_extension Fs.File.(to_string @@ basename output) in let result parent = - let file_representation : Odoc_file.t = - Odoc_file.create_unit ~force_hidden:hidden module_name - in - Ok - { - id = `Root (parent, ModuleName.make_std module_name); - file = file_representation; - digest; - } + let file = Odoc_file.create_unit ~force_hidden:hidden module_name in + Ok { id = `Root (parent, ModuleName.make_std module_name); file; digest } in let check_child : Odoc_model.Paths.Reference.t -> bool = fun c -> @@ -166,7 +159,7 @@ let mld ~parent_spec ~output ~children ~warn_error input = Odoc_model.Lang.Page. { name; root; children; content; digest; linked = false } in - Page.save output page; + Compilation_unit.save_page output page; Ok () in Fs.File.read input >>= fun str -> diff --git a/src/odoc/depends.ml b/src/odoc/depends.ml index 83dacd7b3c..999bf1fab0 100644 --- a/src/odoc/depends.ml +++ b/src/odoc/depends.ml @@ -64,13 +64,11 @@ end = struct end let deps_of_odoc_file ~deps input = - Root.read input >>= function - | { file = Page _; _ } -> - Ok () (* XXX something should certainly be done here *) - | { file = Compilation_unit _; _ } -> - Compilation_unit.load input >>= fun odoctree -> - List.iter odoctree.Odoc_model.Lang.Compilation_unit.imports - ~f:(fun import -> + Compilation_unit.load input >>= fun { content; _ } -> + match content with + | Page_content _ -> Ok () (* XXX something should certainly be done here *) + | Module_content unit -> + List.iter unit.Odoc_model.Lang.Compilation_unit.imports ~f:(fun import -> match import with | Odoc_model.Lang.Compilation_unit.Import.Unresolved _ -> () | Odoc_model.Lang.Compilation_unit.Import.Resolved (root, _) -> diff --git a/src/odoc/env.ml b/src/odoc/env.ml index 96ef850aa7..44cbd41816 100644 --- a/src/odoc/env.ml +++ b/src/odoc/env.ml @@ -33,10 +33,6 @@ open Or_error -type env_unit = [ `Module of Compilation_unit.t | `Page of Page.t ] -(** In this module, a unit is either a module or a page. A module is a - [Compilation_unit]. *) - module Accessible_paths : sig type t @@ -79,39 +75,17 @@ let build_imports_map m = StringMap.add (Odoc_model.Names.ModuleName.to_string name) import map) StringMap.empty imports -let unit_name (u : env_unit) = - let open Odoc_model in - let root = match u with `Page p -> p.root | `Module m -> m.root in - let (Page name | Compilation_unit { name; _ }) = root.Root.file in - name - -let load_unit_from_file file = - let file = Fs.File.to_string file in - let ic = open_in_bin file in - let res = - try - match Root.load file ic with - | Error _ as e -> e - | Ok root -> - Ok - (match root.Odoc_model.Root.file with - | Page _ -> `Page (Marshal.from_channel ic) - | Compilation_unit _ -> `Module (Marshal.from_channel ic)) - with exn -> - let msg = - Printf.sprintf "Error while unmarshalling %S: %s\n%!" file - (match exn with Failure s -> s | _ -> Printexc.to_string exn) - in - Error (`Msg msg) - in - close_in ic; - res +let root_name root = Odoc_model.Root.Odoc_file.name root.Odoc_model.Root.file + +let unit_name + (Compilation_unit.Module_content { root; _ } | Page_content { root; _ }) = + root_name root (** TODO: Propagate warnings instead of printing. *) let load_units_from_files paths = let safe_read file acc = - match load_unit_from_file file with - | Ok u -> u :: acc + match Compilation_unit.load file with + | Ok u -> u.content :: acc | Error (`Msg msg) -> let warning = Odoc_model.Error.filename_only "%s" msg (Fs.File.to_string file) @@ -142,8 +116,9 @@ let rec find_map f = function match f hd with Some x -> Some (x, tl) | None -> find_map f tl) let lookup_module_with_digest ap target_name digest = - let module_that_match_digest = function - | `Module m + let module_that_match_digest u = + match u with + | Compilation_unit.Module_content m when Digest.compare m.Odoc_model.Lang.Compilation_unit.digest digest = 0 -> Some m @@ -159,21 +134,36 @@ let lookup_module_with_digest ap target_name digest = TODO: Correctly propagate warnings instead of printing. *) let lookup_module_by_name ap target_name = - let first_module = function `Module m -> Some m | `Page _ -> None in + let first_module u = + match u with + | Compilation_unit.Module_content m -> Some m + | Page_content _ -> None + in + let rec find_ambiguous tl = + match find_map first_module tl with + | Some (m, tl) -> m :: find_ambiguous tl + | None -> [] + in let units = load_units_from_name ap target_name in match find_map first_module units with - | Some (m, []) -> Odoc_xref2.Env.Found m - | Some (m, (_ :: _ as ambiguous)) -> - Printf.fprintf stderr - "Warning, ambiguous lookup. Please wrap your libraries. Possible files:\n\ - %!"; - let files_strs = - List.map - (fun u -> Printf.sprintf " %s" (unit_name u)) - (`Module m :: ambiguous) - in - prerr_endline (String.concat "\n" files_strs); - Found m + | Some (m, tl) -> + (match find_ambiguous tl with + | [] -> () + | ambiguous -> + let ambiguous = m :: ambiguous in + let ambiguous = + List.map + (fun m -> root_name m.Odoc_model.Lang.Compilation_unit.root) + ambiguous + in + let warning = + Odoc_model.Error.filename_only + "Ambiguous lookup. Possible files: %a" + Format.(pp_print_list pp_print_string) + ambiguous target_name + in + prerr_endline (Odoc_model.Error.to_string warning)); + Odoc_xref2.Env.Found m | None -> Not_found (** Lookup a module. First looks into [imports_map] then searches into the paths. *) @@ -194,32 +184,42 @@ let lookup_unit ~important_digests ~imports_map ap target_name = TODO: Warning on ambiguous lookup. *) let lookup_page ap target_name = let target_name = "page-" ^ target_name in - let is_page = function `Page p -> Some p | `Module _ -> None in + let is_page u = + match u with + | Compilation_unit.Page_content p -> Some p + | Module_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 -type t = Odoc_xref2.Env.resolver - -type builder = env_unit -> t - (** Add the current unit to the cache. No need to load other units with the same name. *) let add_unit_to_cache u = Hashtbl.add unit_cache (unit_name u) [ u ] -let create ?(important_digests = true) ~directories ~open_modules = +type t = Odoc_xref2.Env.resolver + +type builder = { + important_digests : bool; + ap : Accessible_paths.t; + open_modules : string list; +} + +let create ~important_digests ~directories ~open_modules = let ap = Accessible_paths.create ~directories in - fun unit_or_page -> - add_unit_to_cache unit_or_page; - let lookup_unit = - match unit_or_page with - | `Page _ -> - lookup_unit ~important_digests:false ~imports_map:StringMap.empty ap - | `Module current_m -> - let imports_map = build_imports_map current_m in - lookup_unit ~important_digests ~imports_map ap - and lookup_page = lookup_page ap in - { Odoc_xref2.Env.open_units = open_modules; lookup_unit; lookup_page } - -let build_from_module builder m = builder (`Module m) - -let build_from_page builder p = builder (`Page p) + { important_digests; ap; open_modules } + +(** [important_digests] and [imports_map] only apply to modules. *) +let build { important_digests; ap; open_modules } ~imports_map u = + add_unit_to_cache u; + let lookup_unit = lookup_unit ~important_digests ~imports_map ap + and lookup_page = lookup_page ap in + { Odoc_xref2.Env.open_units = open_modules; lookup_unit; lookup_page } + +let build_from_module builder m = + let imports_map = build_imports_map m in + build builder ~imports_map (Compilation_unit.Module_content m) + +let build_from_page builder p = + let imports_map = StringMap.empty in + let builder = { builder with important_digests = false } in + build builder ~imports_map (Compilation_unit.Page_content p) diff --git a/src/odoc/env.mli b/src/odoc/env.mli index 0533847f57..7611519314 100644 --- a/src/odoc/env.mli +++ b/src/odoc/env.mli @@ -32,7 +32,7 @@ type t = Odoc_xref2.Env.resolver type builder val create : - ?important_digests:bool -> + important_digests:bool -> directories:Fs.Directory.t list -> open_modules:string list -> builder diff --git a/src/odoc/odoc_link.ml b/src/odoc/odoc_link.ml index 82dd7a21dc..e1b8819649 100644 --- a/src/odoc/odoc_link.ml +++ b/src/odoc/odoc_link.ml @@ -1,38 +1,36 @@ open Or_error let from_odoc ~env ~warn_error input output = - Root.read input >>= fun root -> let input_s = Fs.File.to_string input in - match root.file with - | Page _ -> - Page.load input >>= fun page -> + Compilation_unit.load input >>= fun unit -> + match unit.content with + | Page_content page -> let resolve_env = Env.build_from_page env page in Odoc_xref2.Link.resolve_page resolve_env page |> Odoc_xref2.Lookup_failures.handle_failures ~warn_error ~filename:input_s >>= fun odoctree -> - Page.save output odoctree; + Compilation_unit.save_page output odoctree; Ok () - | Compilation_unit { hidden; _ } -> - Compilation_unit.load input >>= fun unit -> - let unit = - if hidden then + | Module_content m -> + let m = + if Odoc_model.Root.Odoc_file.hidden m.root.file then { - unit with + m with content = Odoc_model.Lang.Compilation_unit.Module { items = []; compiled = false; doc = [] }; expansion = None; } - else unit + else m in - let env = Env.build_from_module env unit in - Odoc_xref2.Link.link env unit + let env = Env.build_from_module env m in + Odoc_xref2.Link.link env m |> Odoc_xref2.Lookup_failures.handle_failures ~warn_error:false ~filename:input_s >>= fun odoctree -> - Compilation_unit.save output odoctree; + Compilation_unit.save_module output odoctree; Ok () diff --git a/src/odoc/page.ml b/src/odoc/page.ml deleted file mode 100644 index f0814be830..0000000000 --- a/src/odoc/page.ml +++ /dev/null @@ -1,56 +0,0 @@ -(* - * Copyright (c) 2014 Leo White - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - *) - -open Or_error - -type t = Odoc_model.Lang.Page.t - -let save file t = - let dir = Fs.File.dirname file in - let base = Fs.File.(to_string @@ basename file) in - let file = - if Astring.String.is_prefix ~affix:"page-" base then file - else Fs.File.create ~directory:dir ~name:("page-" ^ base) - in - Fs.Directory.mkdir_p dir; - let oc = open_out_bin (Fs.File.to_string file) in - Root.save oc t.Odoc_model.Lang.Page.root; - Marshal.to_channel oc t []; - close_out oc - -let load = - let pages = Hashtbl.create 23 (* because. *) in - fun file -> - let file = Fs.File.to_string file in - match Hashtbl.find pages file with - | page -> Ok page - | exception Not_found -> ( - try - let ic = open_in_bin file in - let res = - Root.load file ic >>= fun _root -> - let res = Marshal.from_channel ic in - Hashtbl.add pages file res; - Ok res - in - close_in ic; - res - with exn -> - let msg = - Printf.sprintf "Error while unmarshalling %S: %s\n%!" file - (match exn with Failure s -> s | _ -> Printexc.to_string exn) - in - Error (`Msg msg)) diff --git a/src/odoc/page.mli b/src/odoc/page.mli deleted file mode 100644 index 5246fbf60a..0000000000 --- a/src/odoc/page.mli +++ /dev/null @@ -1,27 +0,0 @@ -(* - * Copyright (c) 2014 Leo White - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - *) - -open Or_error - -type t = Odoc_model.Lang.Page.t - -(** {2 Serialization} *) - -val save : Fs.File.t -> t -> unit - -(** {2 Deserialization} *) - -val load : Fs.File.t -> (t, [> msg ]) result diff --git a/src/odoc/rendering.ml b/src/odoc/rendering.ml index 0a82b90a4e..4eb4d3cc77 100644 --- a/src/odoc/rendering.ml +++ b/src/odoc/rendering.ml @@ -2,45 +2,41 @@ open Odoc_document open Or_error let document_of_odocl ~syntax input = - Root.read input >>= fun root -> - match root.file with - | Page _ -> - Page.load input >>= fun odoctree -> + Compilation_unit.load input >>= fun unit -> + match unit.content with + | Compilation_unit.Page_content odoctree -> Ok (Renderer.document_of_page ~syntax odoctree) - | Compilation_unit _ -> - Compilation_unit.load input >>= fun odoctree -> + | Module_content odoctree -> Ok (Renderer.document_of_compilation_unit ~syntax odoctree) let document_of_input ~env ~warn_error ~syntax input = - Root.read input >>= fun root -> let input_s = Fs.File.to_string input in - match root.file with - | Page _ -> - Page.load input >>= fun page -> + Compilation_unit.load input >>= fun unit -> + match unit.content with + | Compilation_unit.Page_content page -> let resolve_env = Env.build_from_page env page in Odoc_xref2.Link.resolve_page resolve_env page |> Odoc_xref2.Lookup_failures.handle_failures ~warn_error ~filename:input_s >>= fun odoctree -> Ok (Renderer.document_of_page ~syntax odoctree) - | Compilation_unit { hidden; _ } -> + | Module_content m -> (* If hidden, we should not generate HTML. See https://github.com/ocaml/odoc/issues/99. *) - Compilation_unit.load input >>= fun unit -> - let unit = - if hidden then + let m = + if Odoc_model.Root.Odoc_file.hidden m.root.file then { - unit with + m with content = Odoc_model.Lang.Compilation_unit.Module { items = []; compiled = false; doc = [] }; expansion = None; } - else unit + else m in - let env = Env.build_from_module env unit in + let env = Env.build_from_module env m in (* let startlink = Unix.gettimeofday () in *) (* Format.fprintf Format.err_formatter "**** Link...\n%!"; *) - let linked = Odoc_xref2.Link.link env unit in + let linked = Odoc_xref2.Link.link env m in (* let finishlink = Unix.gettimeofday () in *) (* Format.fprintf Format.err_formatter "**** Finished: Link=%f\n%!" (finishlink -. startlink); *) (* Printf.fprintf stderr "num_times: %d\n%!" !Odoc_xref2.Tools.num_times; *) @@ -49,9 +45,8 @@ let document_of_input ~env ~warn_error ~syntax input = ~filename:input_s >>= fun odoctree -> Odoc_xref2.Tools.reset_caches (); - Hashtbl.clear Compilation_unit.units_cache; - Compilation_unit.save Fs.File.(set_ext ".odocl" input) odoctree; + Compilation_unit.save_module Fs.File.(set_ext ".odocl" input) odoctree; Ok (Renderer.document_of_compilation_unit ~syntax odoctree) let render_document renderer ~output:root_dir ~extra odoctree = diff --git a/src/odoc/root.ml b/src/odoc/root.ml deleted file mode 100644 index 9f994b282e..0000000000 --- a/src/odoc/root.ml +++ /dev/null @@ -1,39 +0,0 @@ -(* - * Copyright (c) 2014 Leo White - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - *) - -open Or_error - -let magic = "odoc-%%VERSION%%" - -let load file ic = - let m = really_input_string ic (String.length magic) in - if m = magic then Ok (Marshal.from_channel ic) - else - let msg = - Printf.sprintf "%s: invalid magic number %S, expected %S\n%!" file m magic - in - Error (`Msg msg) - -let save oc t = - output_string oc magic; - Marshal.to_channel oc t [] - -let read file = - let file = Fs.File.to_string file in - let ic = open_in_bin file in - let root = load file ic in - close_in ic; - root diff --git a/src/odoc/root.mli b/src/odoc/root.mli deleted file mode 100644 index 89e6a47eaa..0000000000 --- a/src/odoc/root.mli +++ /dev/null @@ -1,28 +0,0 @@ -(* - * Copyright (c) 2014 Leo White - * - * Permission to use, copy, modify, and distribute this software for any - * purpose with or without fee is hereby granted, provided that the above - * copyright notice and this permission notice appear in all copies. - * - * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES - * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF - * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR - * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES - * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN - * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF - * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. - *) - -open Or_error - -val load : string -> in_channel -> (Odoc_model.Root.t, [> msg ]) result -(** [load fn ic] reads a {!t} from [ic]. - [fn] is the name of the file [ic] is "watching", and is used for error - reporting. *) - -val read : Fs.File.t -> (Odoc_model.Root.t, [> msg ]) result -(** [read f] opens [f] for reading and then calls {!load}. *) - -val save : out_channel -> Odoc_model.Root.t -> unit -(** [save oc t] marshalls [t] to [oc]. *) diff --git a/test/odoc_print/odoc_print.ml b/test/odoc_print/odoc_print.ml index f6f947c88a..549675df75 100644 --- a/test/odoc_print/odoc_print.ml +++ b/test/odoc_print/odoc_print.ml @@ -10,14 +10,12 @@ let print_json_desc desc x = let run inp = let inp = Fpath.v inp in - Root.read inp >>= fun r -> - match r.file with - | Odoc_model.Root.Odoc_file.Page _ -> - Page.load inp >>= fun page -> + Compilation_unit.load inp >>= fun r -> + match r.Compilation_unit.content with + | Page_content page -> print_json_desc Lang_desc.page_t page; Ok () - | Compilation_unit _ -> - Compilation_unit.load inp >>= fun u -> + | Module_content u -> print_json_desc Lang_desc.compilation_unit_t u; Ok () From 18b97953b3f7e78699965a7537ee2201a655aac2 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Thu, 6 May 2021 17:24:50 +0200 Subject: [PATCH 4/9] Remove the 'root' field from .odoc files --- src/odoc/compilation_unit.ml | 10 +++------- src/odoc/compilation_unit.mli | 4 +--- src/odoc/depends.ml | 3 +-- src/odoc/env.ml | 2 +- src/odoc/odoc_link.ml | 3 +-- src/odoc/rendering.ml | 6 ++---- test/odoc_print/odoc_print.ml | 5 ++--- 7 files changed, 11 insertions(+), 22 deletions(-) diff --git a/src/odoc/compilation_unit.ml b/src/odoc/compilation_unit.ml index bf18f95f1f..0c59ba5c3d 100644 --- a/src/odoc/compilation_unit.ml +++ b/src/odoc/compilation_unit.ml @@ -17,12 +17,10 @@ open Odoc_model open Or_error -type content = +type t = | Page_content of Lang.Page.t | Module_content of Lang.Compilation_unit.t -type t = { root : Root.t; content : content } - (** Written at the top of the files. Checked when loading. *) let magic = "odoc-%%VERSION%%" @@ -41,11 +39,9 @@ let save_page file page = if Astring.String.is_prefix ~affix:"page-" base then file else Fs.File.create ~directory:dir ~name:("page-" ^ base) in - save_unit file { root = page.Lang.Page.root; content = Page_content page } + save_unit file (Page_content page) -let save_module file m = - save_unit file - { root = m.Lang.Compilation_unit.root; content = Module_content m } +let save_module file m = save_unit file (Module_content m) let load file = let file = Fs.File.to_string file in diff --git a/src/odoc/compilation_unit.mli b/src/odoc/compilation_unit.mli index 234258e716..aab07a171c 100644 --- a/src/odoc/compilation_unit.mli +++ b/src/odoc/compilation_unit.mli @@ -20,12 +20,10 @@ open Odoc_model open Or_error (** Either a page or a module. *) -type content = +type t = | Page_content of Lang.Page.t | Module_content of Lang.Compilation_unit.t -type t = { root : Root.t; content : content } - (** {2 Serialization} *) val save_page : Fs.File.t -> Lang.Page.t -> unit diff --git a/src/odoc/depends.ml b/src/odoc/depends.ml index 999bf1fab0..b830d7c30b 100644 --- a/src/odoc/depends.ml +++ b/src/odoc/depends.ml @@ -64,8 +64,7 @@ end = struct end let deps_of_odoc_file ~deps input = - Compilation_unit.load input >>= fun { content; _ } -> - match content with + Compilation_unit.load input >>= function | Page_content _ -> Ok () (* XXX something should certainly be done here *) | Module_content unit -> List.iter unit.Odoc_model.Lang.Compilation_unit.imports ~f:(fun import -> diff --git a/src/odoc/env.ml b/src/odoc/env.ml index 44cbd41816..117f8e6831 100644 --- a/src/odoc/env.ml +++ b/src/odoc/env.ml @@ -85,7 +85,7 @@ let unit_name let load_units_from_files paths = let safe_read file acc = match Compilation_unit.load file with - | Ok u -> u.content :: acc + | Ok u -> u :: acc | Error (`Msg msg) -> let warning = Odoc_model.Error.filename_only "%s" msg (Fs.File.to_string file) diff --git a/src/odoc/odoc_link.ml b/src/odoc/odoc_link.ml index e1b8819649..017f60370f 100644 --- a/src/odoc/odoc_link.ml +++ b/src/odoc/odoc_link.ml @@ -2,8 +2,7 @@ open Or_error let from_odoc ~env ~warn_error input output = let input_s = Fs.File.to_string input in - Compilation_unit.load input >>= fun unit -> - match unit.content with + Compilation_unit.load input >>= function | Page_content page -> let resolve_env = Env.build_from_page env page in Odoc_xref2.Link.resolve_page resolve_env page diff --git a/src/odoc/rendering.ml b/src/odoc/rendering.ml index 4eb4d3cc77..c5fcaa8d95 100644 --- a/src/odoc/rendering.ml +++ b/src/odoc/rendering.ml @@ -2,8 +2,7 @@ open Odoc_document open Or_error let document_of_odocl ~syntax input = - Compilation_unit.load input >>= fun unit -> - match unit.content with + Compilation_unit.load input >>= function | Compilation_unit.Page_content odoctree -> Ok (Renderer.document_of_page ~syntax odoctree) | Module_content odoctree -> @@ -11,8 +10,7 @@ let document_of_odocl ~syntax input = let document_of_input ~env ~warn_error ~syntax input = let input_s = Fs.File.to_string input in - Compilation_unit.load input >>= fun unit -> - match unit.content with + Compilation_unit.load input >>= function | Compilation_unit.Page_content page -> let resolve_env = Env.build_from_page env page in Odoc_xref2.Link.resolve_page resolve_env page diff --git a/test/odoc_print/odoc_print.ml b/test/odoc_print/odoc_print.ml index 549675df75..ebd4981021 100644 --- a/test/odoc_print/odoc_print.ml +++ b/test/odoc_print/odoc_print.ml @@ -10,9 +10,8 @@ let print_json_desc desc x = let run inp = let inp = Fpath.v inp in - Compilation_unit.load inp >>= fun r -> - match r.Compilation_unit.content with - | Page_content page -> + Compilation_unit.load inp >>= function + | Compilation_unit.Page_content page -> print_json_desc Lang_desc.page_t page; Ok () | Module_content u -> From 7bb7f3325521e2ccc663d771353275d23c959b38 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Thu, 6 May 2021 18:37:23 +0200 Subject: [PATCH 5/9] Simplify resolver Rename Odoc_odoc.Env into Odoc_odoc.Resolver. Remove the "builder" step. --- src/odoc/bin/main.ml | 32 +++++++++++++++--------------- src/odoc/compile.ml | 19 +++++++++--------- src/odoc/compile.mli | 3 +-- src/odoc/html_fragment.ml | 6 +++--- src/odoc/html_fragment.mli | 4 ++-- src/odoc/odoc_link.ml | 8 ++++---- src/odoc/rendering.ml | 16 +++++++-------- src/odoc/rendering.mli | 4 ++-- src/odoc/{env.ml => resolver.ml} | 18 +++++++++-------- src/odoc/{env.mli => resolver.mli} | 23 +++++++++------------ src/xref2/compile.ml | 3 +-- src/xref2/compile.mli | 2 +- src/xref2/env.ml | 11 ++++++---- src/xref2/env.mli | 6 +++++- src/xref2/link.ml | 5 +---- src/xref2/link.mli | 4 ++-- test/xref2/lib/common.cppo.ml | 8 ++++---- 17 files changed, 85 insertions(+), 87 deletions(-) rename src/odoc/{env.ml => resolver.ml} (95%) rename src/odoc/{env.mli => resolver.mli} (80%) diff --git a/src/odoc/bin/main.ml b/src/odoc/bin/main.ml index 97bb1ae13f..4bd68b8043 100644 --- a/src/odoc/bin/main.ml +++ b/src/odoc/bin/main.ml @@ -107,8 +107,8 @@ end = struct let compile hidden directories resolve_fwd_refs dst package_opt parent_name_opt open_modules children input warn_error = let open Or_error in - let env = - Env.create ~important_digests:(not resolve_fwd_refs) ~directories + let resolver = + Resolver.create ~important_digests:(not resolve_fwd_refs) ~directories ~open_modules in let input = Fs.File.of_string input in @@ -125,7 +125,7 @@ end = struct in parent_cli_spec >>= fun parent_cli_spec -> Fs.Directory.mkdir_p (Fs.File.dirname output); - Compile.compile ~env ~directories ~parent_cli_spec ~hidden ~children ~output + Compile.compile ~resolver ~parent_cli_spec ~hidden ~children ~output ~warn_error input let input = @@ -231,10 +231,10 @@ end = struct let link directories input_file output_file warn_error = let input = Fs.File.of_string input_file in let output = get_output_file ~output_file ~input in - let env = - Env.create ~important_digests:false ~directories ~open_modules:[] + let resolver = + Resolver.create ~important_digests:false ~directories ~open_modules:[] in - Odoc_link.from_odoc ~env ~warn_error input output + Odoc_link.from_odoc ~resolver ~warn_error input output let dst = let doc = @@ -278,11 +278,11 @@ end = struct module Process = struct let process extra _hidden directories output_dir syntax input_file warn_error = - let env = - Env.create ~important_digests:false ~directories ~open_modules:[] + let resolver = + Resolver.create ~important_digests:false ~directories ~open_modules:[] in let file = Fs.File.of_string input_file in - Rendering.render_odoc ~renderer:R.renderer ~env ~warn_error ~syntax + Rendering.render_odoc ~renderer:R.renderer ~resolver ~warn_error ~syntax ~output:output_dir extra file let cmd = @@ -340,10 +340,10 @@ end = struct module Targets = struct let list_targets output_dir directories extra odoc_file = let odoc_file = Fs.File.of_string odoc_file in - let env = - Env.create ~important_digests:false ~directories ~open_modules:[] + let resolver = + Resolver.create ~important_digests:false ~directories ~open_modules:[] in - Rendering.targets_odoc ~env ~warn_error:false ~syntax:OCaml + Rendering.targets_odoc ~resolver ~warn_error:false ~syntax:OCaml ~renderer:R.renderer ~output:output_dir ~extra odoc_file let back_compat = @@ -432,8 +432,8 @@ module Html_fragment : sig end = struct let html_fragment directories xref_base_uri output_file input_file warn_error = - let env = - Env.create ~important_digests:false ~directories ~open_modules:[] + let resolver = + Resolver.create ~important_digests:false ~directories ~open_modules:[] in let input_file = Fs.File.of_string input_file in let output_file = Fs.File.of_string output_file in @@ -443,8 +443,8 @@ end = struct let last_char = xref_base_uri.[String.length xref_base_uri - 1] in if last_char <> '/' then xref_base_uri ^ "/" else xref_base_uri in - Html_fragment.from_mld ~env ~xref_base_uri ~output:output_file ~warn_error - input_file + Html_fragment.from_mld ~resolver ~xref_base_uri ~output:output_file + ~warn_error input_file let cmd = let output = diff --git a/src/odoc/compile.ml b/src/odoc/compile.ml index 8a1c4856fb..6aaf126a73 100644 --- a/src/odoc/compile.ml +++ b/src/odoc/compile.ml @@ -29,15 +29,14 @@ type parent_cli_spec = | CliPackage of string | CliNoparent -let parent directories parent_cli_spec = - let ap = Env.Accessible_paths.create ~directories in +let parent resolver parent_cli_spec = let find_parent : Odoc_model.Paths.Reference.t -> (Odoc_model.Lang.Page.t, [> `Msg of string ]) Result.result = fun r -> match r with | `Root (p, `TPage) | `Root (p, `TUnknown) -> ( - match Env.lookup_page ap p with + match Resolver.lookup_page resolver p with | Some r -> Ok r | None -> Error (`Msg "Couldn't find specified parent page")) | _ -> Error (`Msg "Expecting page as parent") @@ -55,8 +54,8 @@ let parent directories parent_cli_spec = | CliPackage package -> Ok (Package (`RootPage (PageName.make_std package))) | CliNoparent -> Ok Noparent -let resolve_and_substitute ~env ~output ~warn_error parent input_file read_file - = +let resolve_and_substitute ~resolver ~output ~warn_error parent input_file + read_file = let filename = Fs.File.to_string input_file in read_file ~parent ~filename @@ -67,7 +66,7 @@ let resolve_and_substitute ~env ~output ~warn_error parent input_file read_file (if not (Filename.check_suffix filename "cmt") then "" (* ? *) else Printf.sprintf " Using %S while you should use the .cmti file" filename); - let env = Env.build_from_module env unit in + let env = Resolver.build_env_for_module resolver unit in Odoc_xref2.Compile.compile env unit |> Odoc_xref2.Lookup_failures.handle_failures ~warn_error:false ~filename @@ -171,9 +170,9 @@ let mld ~parent_spec ~output ~children ~warn_error input = | `Stop -> resolve [] (* TODO: Error? *) | `Docs content -> resolve content -let compile ~env ~directories ~parent_cli_spec ~hidden ~children ~output - ~warn_error input = - parent directories parent_cli_spec >>= fun parent_spec -> +let compile ~resolver ~parent_cli_spec ~hidden ~children ~output ~warn_error + input = + parent resolver parent_cli_spec >>= fun parent_spec -> let ext = Fs.File.get_ext input in if ext = ".mld" then mld ~parent_spec ~output ~warn_error ~children input else @@ -193,5 +192,5 @@ let compile ~env ~directories ~parent_cli_spec ~hidden ~children ~output in parent >>= fun parent -> let make_root = root_of_compilation_unit ~parent_spec ~hidden ~output in - resolve_and_substitute ~env ~output ~warn_error parent input + resolve_and_substitute ~resolver ~output ~warn_error parent input (loader ~make_root) diff --git a/src/odoc/compile.mli b/src/odoc/compile.mli index caa2e894b7..4e49458f93 100644 --- a/src/odoc/compile.mli +++ b/src/odoc/compile.mli @@ -24,8 +24,7 @@ type parent_cli_spec = (** Produces .odoc files out of [.cm{i,t,ti}] or .mld files. *) val compile : - env:Env.builder -> - directories:Fs.Directory.t list -> + resolver:Resolver.t -> parent_cli_spec:parent_cli_spec -> hidden:bool -> children:string list -> diff --git a/src/odoc/html_fragment.ml b/src/odoc/html_fragment.ml index 441de5735d..2e1d5e8ebe 100644 --- a/src/odoc/html_fragment.ml +++ b/src/odoc/html_fragment.ml @@ -1,6 +1,6 @@ open Or_error -let from_mld ~xref_base_uri ~env ~output ~warn_error input = +let from_mld ~xref_base_uri ~resolver ~output ~warn_error input = (* Internal names, they don't have effect on the output. *) let page_name = "__fragment_page__" in let id = `RootPage (Odoc_model.Names.PageName.make_std page_name) in @@ -16,8 +16,8 @@ let from_mld ~xref_base_uri ~env ~output ~warn_error input = Odoc_model.Lang.Page. { name = id; root; content; children = []; digest; linked = false } in - let resolve_env = Env.build_from_page env page in - Odoc_xref2.Link.resolve_page resolve_env page + let env = Resolver.build_env_for_page resolver page in + Odoc_xref2.Link.resolve_page env page |> Odoc_xref2.Lookup_failures.handle_failures ~warn_error ~filename:input_s >>= fun resolved -> let page = Odoc_document.Comment.to_ir resolved.content in diff --git a/src/odoc/html_fragment.mli b/src/odoc/html_fragment.mli index c2b2166886..f63baaee03 100644 --- a/src/odoc/html_fragment.mli +++ b/src/odoc/html_fragment.mli @@ -20,12 +20,12 @@ open Or_error val from_mld : xref_base_uri:string -> - env:Env.builder -> + resolver:Resolver.t -> output:Fs.File.t -> warn_error:bool -> Fs.File.t -> (unit, [> msg ]) result -(** [from_mld ~xref_base_uri ~env ~output input] parses the content of the [input] +(** [from_mld ~xref_base_uri ~resolver ~output input] parses the content of the [input] file as a documentation page ({e i.e.} the ocamldoc syntax), generates the equivalent HTML representation and writes the result into the [output] file. The produced file is an HTML fragment that can be embedded into other diff --git a/src/odoc/odoc_link.ml b/src/odoc/odoc_link.ml index 017f60370f..121b488da4 100644 --- a/src/odoc/odoc_link.ml +++ b/src/odoc/odoc_link.ml @@ -1,11 +1,11 @@ open Or_error -let from_odoc ~env ~warn_error input output = +let from_odoc ~resolver ~warn_error input output = let input_s = Fs.File.to_string input in Compilation_unit.load input >>= function | Page_content page -> - let resolve_env = Env.build_from_page env page in - Odoc_xref2.Link.resolve_page resolve_env page + let env = Resolver.build_env_for_page resolver page in + Odoc_xref2.Link.resolve_page env page |> Odoc_xref2.Lookup_failures.handle_failures ~warn_error ~filename:input_s >>= fun odoctree -> @@ -25,7 +25,7 @@ let from_odoc ~env ~warn_error input output = else m in - let env = Env.build_from_module env m in + let env = Resolver.build_env_for_module resolver m in Odoc_xref2.Link.link env m |> Odoc_xref2.Lookup_failures.handle_failures ~warn_error:false ~filename:input_s diff --git a/src/odoc/rendering.ml b/src/odoc/rendering.ml index c5fcaa8d95..57eb451c35 100644 --- a/src/odoc/rendering.ml +++ b/src/odoc/rendering.ml @@ -8,12 +8,12 @@ let document_of_odocl ~syntax input = | Module_content odoctree -> Ok (Renderer.document_of_compilation_unit ~syntax odoctree) -let document_of_input ~env ~warn_error ~syntax input = +let document_of_input ~resolver ~warn_error ~syntax input = let input_s = Fs.File.to_string input in Compilation_unit.load input >>= function | Compilation_unit.Page_content page -> - let resolve_env = Env.build_from_page env page in - Odoc_xref2.Link.resolve_page resolve_env page + let env = Resolver.build_env_for_page resolver page in + Odoc_xref2.Link.resolve_page env page |> Odoc_xref2.Lookup_failures.handle_failures ~warn_error ~filename:input_s >>= fun odoctree -> Ok (Renderer.document_of_page ~syntax odoctree) @@ -31,7 +31,7 @@ let document_of_input ~env ~warn_error ~syntax input = } else m in - let env = Env.build_from_module env m in + let env = Resolver.build_env_for_module resolver m in (* let startlink = Unix.gettimeofday () in *) (* Format.fprintf Format.err_formatter "**** Link...\n%!"; *) let linked = Odoc_xref2.Link.link env m in @@ -59,18 +59,18 @@ let render_document renderer ~output:root_dir ~extra odoctree = close_out oc); Ok () -let render_odoc ~env ~warn_error ~syntax ~renderer ~output extra file = - document_of_input ~env ~warn_error ~syntax file +let render_odoc ~resolver ~warn_error ~syntax ~renderer ~output extra file = + document_of_input ~resolver ~warn_error ~syntax file >>= render_document renderer ~output ~extra let generate_odoc ~syntax ~renderer ~output extra file = document_of_odocl ~syntax file >>= render_document renderer ~output ~extra -let targets_odoc ~env ~warn_error ~syntax ~renderer ~output:root_dir ~extra +let targets_odoc ~resolver ~warn_error ~syntax ~renderer ~output:root_dir ~extra odoctree = let doc = if Fpath.get_ext odoctree = ".odoc" then - document_of_input ~env ~warn_error ~syntax odoctree + document_of_input ~resolver ~warn_error ~syntax odoctree else document_of_odocl ~syntax:OCaml odoctree in doc >>= fun odoctree -> diff --git a/src/odoc/rendering.mli b/src/odoc/rendering.mli index a6d70c6b43..73084a0263 100644 --- a/src/odoc/rendering.mli +++ b/src/odoc/rendering.mli @@ -2,7 +2,7 @@ open Odoc_document open Or_error val render_odoc : - env:Env.builder -> + resolver:Resolver.t -> warn_error:bool -> syntax:Renderer.syntax -> renderer:'a Renderer.t -> @@ -20,7 +20,7 @@ val generate_odoc : (unit, [> msg ]) result val targets_odoc : - env:Env.builder -> + resolver:Resolver.t -> warn_error:bool -> syntax:Renderer.syntax -> renderer:'a Renderer.t -> diff --git a/src/odoc/env.ml b/src/odoc/resolver.ml similarity index 95% rename from src/odoc/env.ml rename to src/odoc/resolver.ml index 117f8e6831..0a3518b20b 100644 --- a/src/odoc/env.ml +++ b/src/odoc/resolver.ml @@ -196,9 +196,7 @@ let lookup_page ap target_name = name. *) let add_unit_to_cache u = Hashtbl.add unit_cache (unit_name u) [ u ] -type t = Odoc_xref2.Env.resolver - -type builder = { +type t = { important_digests : bool; ap : Accessible_paths.t; open_modules : string list; @@ -215,11 +213,15 @@ let build { important_digests; ap; open_modules } ~imports_map u = and lookup_page = lookup_page ap in { Odoc_xref2.Env.open_units = open_modules; lookup_unit; lookup_page } -let build_from_module builder m = +let build_env_for_module t m = let imports_map = build_imports_map m in - build builder ~imports_map (Compilation_unit.Module_content m) + let resolver = build t ~imports_map (Compilation_unit.Module_content m) in + Odoc_xref2.Env.env_of_module m resolver -let build_from_page builder p = +let build_env_for_page t p = let imports_map = StringMap.empty in - let builder = { builder with important_digests = false } in - build builder ~imports_map (Compilation_unit.Page_content p) + let t = { t with important_digests = false } in + let resolver = build t ~imports_map (Compilation_unit.Page_content p) in + Odoc_xref2.Env.env_of_page p resolver + +let lookup_page t target_name = lookup_page t.ap target_name diff --git a/src/odoc/env.mli b/src/odoc/resolver.mli similarity index 80% rename from src/odoc/env.mli rename to src/odoc/resolver.mli index 7611519314..34e1f377e9 100644 --- a/src/odoc/env.mli +++ b/src/odoc/resolver.mli @@ -19,33 +19,28 @@ This is the module which does the link between packages, directories and {!DocOck}'s needs. *) -module Accessible_paths : sig - type t - - val create : directories:Fs.directory list -> t -end - -val lookup_page : Accessible_paths.t -> string -> Odoc_model.Lang.Page.t option - -type t = Odoc_xref2.Env.resolver - -type builder +type t val create : important_digests:bool -> directories:Fs.Directory.t list -> open_modules:string list -> - builder + t (** Prepare the environment for a given list of {{!Fs.Directory.t} include directories} @param important_digests indicate whether digests should be compared when doc-ock tries to lookup or fetch a unit. It defaults to [true]. *) -val build_from_module : builder -> Odoc_model.Lang.Compilation_unit.t -> t +val lookup_page : t -> string -> Odoc_model.Lang.Page.t option + +(* val lookup_module *) + +val build_env_for_module : + t -> Odoc_model.Lang.Compilation_unit.t -> Odoc_xref2.Env.t (** Initialize the environment for the given module. *) -val build_from_page : builder -> Odoc_model.Lang.Page.t -> t +val build_env_for_page : t -> Odoc_model.Lang.Page.t -> Odoc_xref2.Env.t (** Initialize the environment for the given page. *) (* val forward_resolver : t -> Root.t DocOck.forward_resolver *) diff --git a/src/xref2/compile.ml b/src/xref2/compile.ml index d38c3e330e..ee3264ce24 100644 --- a/src/xref2/compile.ml +++ b/src/xref2/compile.ml @@ -53,9 +53,8 @@ and class_type_path : Env.t -> Paths.Path.ClassType.t -> Paths.Path.ClassType.t | Ok p' -> `Resolved (Cpath.resolved_class_type_path_of_cpath p') | Error _ -> Cpath.class_type_path_of_cpath cp) -let rec unit (resolver : Env.resolver) t = +let rec unit env t = let open Compilation_unit in - let env = Env.initial_env t resolver in { t with content = content env t.id t.content } and content env id = diff --git a/src/xref2/compile.mli b/src/xref2/compile.mli index eac7891eea..cbe349a9d9 100644 --- a/src/xref2/compile.mli +++ b/src/xref2/compile.mli @@ -7,7 +7,7 @@ val signature : Odoc_model.Lang.Signature.t val compile : - Env.resolver -> + Env.t -> Odoc_model.Lang.Compilation_unit.t -> Odoc_model.Lang.Compilation_unit.t Lookup_failures.with_failures diff --git a/src/xref2/env.ml b/src/xref2/env.ml index 70ea72637d..d2f21c6f2b 100644 --- a/src/xref2/env.ml +++ b/src/xref2/env.ml @@ -708,18 +708,21 @@ let rec open_signature : Odoc_model.Lang.Signature.t -> t -> t = | Odoc_model.Lang.Signature.Open o -> open_signature o.expansion env) e s.items -let initial_env t resolver = +let inherit_resolver env = + match env.resolver with Some r -> set_resolver empty r | None -> empty + +let env_of_module t resolver = let open Odoc_model.Lang.Compilation_unit in let initial_env = let m = module_of_unit t in - let dm = Component.Delayed.put (fun () -> m) in empty |> add_module (t.id :> Identifier.Path.Module.t) dm m.doc in set_resolver initial_env resolver -let inherit_resolver env = - match env.resolver with Some r -> set_resolver empty r | None -> empty +let env_of_page page resolver = + let initial_env = empty |> add_docs page.Odoc_model.Lang.Page.content in + set_resolver initial_env resolver let modules_of env = let f acc = function `Module (id, m) -> (id, m) :: acc | _ -> acc in diff --git a/src/xref2/env.mli b/src/xref2/env.mli index 46a97f827a..789cf7a364 100644 --- a/src/xref2/env.mli +++ b/src/xref2/env.mli @@ -169,7 +169,11 @@ val open_class_signature : Odoc_model.Lang.ClassSignature.t -> t -> t val open_signature : Odoc_model.Lang.Signature.t -> t -> t -val initial_env : Odoc_model.Lang.Compilation_unit.t -> resolver -> t +val env_of_module : Odoc_model.Lang.Compilation_unit.t -> resolver -> t +(** Create a new env with a module initially opened. *) + +val env_of_page : Odoc_model.Lang.Page.t -> resolver -> t +(** Create a new env for a page. *) val inherit_resolver : t -> t (** Create an empty environment reusing the same resolver. *) diff --git a/src/xref2/link.ml b/src/xref2/link.ml index f5c2813ac6..22087d2692 100644 --- a/src/xref2/link.ml +++ b/src/xref2/link.ml @@ -211,9 +211,8 @@ and comment env parent = function | `Stop -> `Stop | `Docs d -> `Docs (comment_docs env parent d) -let rec unit (resolver : Env.resolver) t = +let rec unit env t = let open Compilation_unit in - let env = Env.initial_env t resolver in let content = match t.content with | Module sg -> Module (signature env (t.id :> Id.Signature.t) sg) @@ -839,8 +838,6 @@ let link x y = if y.Lang.Compilation_unit.linked then y else unit x y) let page env page = - let env = Env.set_resolver Env.empty env in - let env = Env.add_docs page.Page.content env in let children = List.fold_right (fun child res -> diff --git a/src/xref2/link.mli b/src/xref2/link.mli index b424288102..a7d147b743 100644 --- a/src/xref2/link.mli +++ b/src/xref2/link.mli @@ -7,11 +7,11 @@ val signature : Odoc_model.Lang.Signature.t val link : - Env.resolver -> + Env.t -> Odoc_model.Lang.Compilation_unit.t -> Odoc_model.Lang.Compilation_unit.t Lookup_failures.with_failures val resolve_page : - Env.resolver -> + Env.t -> Odoc_model.Lang.Page.t -> Odoc_model.Lang.Page.t Lookup_failures.with_failures diff --git a/test/xref2/lib/common.cppo.ml b/test/xref2/lib/common.cppo.ml index f156d318d0..7ddf38c997 100644 --- a/test/xref2/lib/common.cppo.ml +++ b/test/xref2/lib/common.cppo.ml @@ -609,8 +609,8 @@ let my_compilation_unit id s = ; canonical = None } -let mkenv () = - Odoc_odoc.Env.create +let mkresolver () = + Odoc_odoc.Resolver.create ~important_digests:false ~directories:(List.map Odoc_odoc.Fs.Directory.of_string #if OCAML_MAJOR = 4 && OCAML_MINOR >= 08 @@ -621,8 +621,8 @@ let mkenv () = ) ~open_modules:[] let resolve unit = - let env = mkenv () in - let resolve_env = Odoc_odoc.Env.build_from_module env unit in + let resolver = mkresolver () in + let resolve_env = Odoc_odoc.Resolver.build_env_for_module resolver unit in let result = Odoc_xref2.Compile.compile resolve_env unit in result From f8cb19472923006bd744b4dcb554d9d450f71b87 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Mon, 10 May 2021 18:00:48 +0200 Subject: [PATCH 6/9] Revert "Don't lookup imports" and add a test This reverts commit 9549f364bce93cc33aa6511d4b7411ecdf90d849. Imports need to be resolved for the link-deps command. Now done in Compile rather than in Env. A test is added. --- src/xref2/compile.ml | 13 ++++++++++++- src/xref2/env.ml | 8 ++++---- src/xref2/env.mli | 4 +++- src/xref2/link.ml | 12 ------------ test/integration/depends.t/a.mli | 3 +++ test/integration/depends.t/b.mli | 3 +++ test/integration/depends.t/lib.mli | 5 +++++ test/integration/depends.t/run.t | 18 ++++++++++++++++++ 8 files changed, 48 insertions(+), 18 deletions(-) create mode 100644 test/integration/depends.t/a.mli create mode 100644 test/integration/depends.t/b.mli create mode 100644 test/integration/depends.t/lib.mli create mode 100644 test/integration/depends.t/run.t diff --git a/src/xref2/compile.ml b/src/xref2/compile.ml index ee3264ce24..9b5061c45d 100644 --- a/src/xref2/compile.ml +++ b/src/xref2/compile.ml @@ -55,7 +55,18 @@ and class_type_path : Env.t -> Paths.Path.ClassType.t -> Paths.Path.ClassType.t let rec unit env t = let open Compilation_unit in - { t with content = content env t.id t.content } + let imports = + (* Resolve imports *) + List.map + (function + | Import.Resolved _ as import -> import + | Unresolved (name, _) as unresolved -> ( + match Env.lookup_root_module name env with + | Some (Env.Resolved (root, _, _)) -> Resolved (root, Names.ModuleName.make_std name) + | Some Forward | None -> unresolved)) + t.imports + in + { t with content = content env t.id t.content; imports } and content env id = let open Compilation_unit in diff --git a/src/xref2/env.ml b/src/xref2/env.ml index d2f21c6f2b..3a4d36217f 100644 --- a/src/xref2/env.ml +++ b/src/xref2/env.ml @@ -11,7 +11,7 @@ type lookup_page_result = Odoc_model.Lang.Page.t option type root = | Resolved of - (Digest.t * Odoc_model.Paths.Identifier.Module.t * Component.Module.t) + (Root.t * Odoc_model.Paths.Identifier.Module.t * Component.Module.t) | Forward type resolver = { @@ -367,13 +367,13 @@ let lookup_root_module name env = | Found u -> let (`Root _ as id) = u.id in let m = module_of_unit u in - Some (Resolved (u.root.digest, id, m))) + Some (Resolved (u.root, id, m))) in (match (env.recorder, result) with | Some r, Some Forward -> r.lookups <- RootModule (name, Some `Forward) :: r.lookups - | Some r, Some (Resolved (digest, _, _)) -> - r.lookups <- RootModule (name, Some (`Resolved digest)) :: r.lookups + | Some r, Some (Resolved (root, _, _)) -> + r.lookups <- RootModule (name, Some (`Resolved root.digest)) :: r.lookups | Some r, None -> r.lookups <- RootModule (name, None) :: r.lookups | None, _ -> ()); result diff --git a/src/xref2/env.mli b/src/xref2/env.mli index 789cf7a364..03010b8914 100644 --- a/src/xref2/env.mli +++ b/src/xref2/env.mli @@ -9,7 +9,9 @@ type lookup_page_result = Odoc_model.Lang.Page.t option type root = | Resolved of - (Digest.t * Odoc_model.Paths.Identifier.Module.t * Component.Module.t) + (Odoc_model.Root.t + * Odoc_model.Paths.Identifier.Module.t + * Component.Module.t) | Forward type resolver = { diff --git a/src/xref2/link.ml b/src/xref2/link.ml index 22087d2692..5bcf82e234 100644 --- a/src/xref2/link.ml +++ b/src/xref2/link.ml @@ -821,18 +821,6 @@ and type_expression : Env.t -> Id.Signature.t -> _ -> _ = | Poly (strs, t) -> Poly (strs, type_expression env parent visited t) | Package p -> Package (type_expression_package env parent visited p) -(* -let build_resolver : - ?equal:(Root.t -> Root.t -> bool) -> - ?hash:(Root.t -> int) -> - (string -> Env.lookup_unit_result) -> - (Root.t -> Compilation_unit.t) -> - (string -> Root.t option) -> - (Root.t -> Page.t) -> - Env.resolver = - fun ?equal:_ ?hash:_ lookup_unit resolve_unit lookup_page resolve_page -> - { Env.lookup_unit; resolve_unit; lookup_page; resolve_page } -*) let link x y = Lookup_failures.catch_failures (fun () -> if y.Lang.Compilation_unit.linked then y else unit x y) diff --git a/test/integration/depends.t/a.mli b/test/integration/depends.t/a.mli new file mode 100644 index 0000000000..983882759c --- /dev/null +++ b/test/integration/depends.t/a.mli @@ -0,0 +1,3 @@ +(** Module A has no dependency *) + +type t diff --git a/test/integration/depends.t/b.mli b/test/integration/depends.t/b.mli new file mode 100644 index 0000000000..d24516cd81 --- /dev/null +++ b/test/integration/depends.t/b.mli @@ -0,0 +1,3 @@ +(** Module B depends on A and Lib. *) + +type t = Lib.A.t diff --git a/test/integration/depends.t/lib.mli b/test/integration/depends.t/lib.mli new file mode 100644 index 0000000000..eaeb7e3167 --- /dev/null +++ b/test/integration/depends.t/lib.mli @@ -0,0 +1,5 @@ +(** Library entry point *) + +module A = Lib_a + +module B = Lib_b diff --git a/test/integration/depends.t/run.t b/test/integration/depends.t/run.t new file mode 100644 index 0000000000..96662b1075 --- /dev/null +++ b/test/integration/depends.t/run.t @@ -0,0 +1,18 @@ +Testing the depends command. + + $ ocamlc -c -no-alias-deps -bin-annot -w -49 -o lib.cmti lib.mli + $ ocamlc -c -bin-annot -I . -o lib_a.cmti a.mli + $ ocamlc -c -bin-annot -I . -o lib_b.cmti b.mli + + $ odoc compile-deps lib_b.cmti | grep -v "CamlinternalFormatBasics\|Stdlib" + Lib bbd67101d2e61e05dcf0f0cbf5f9dbe0 + Lib_a 21c81261177d685464037918ae900b81 + Lib_b b417b775de9c850fac708cc7fb6343b5 + + $ odoc compile --pkg lib -I . lib.cmti + $ odoc compile --pkg lib -I . lib_a.cmti + $ odoc compile --pkg lib -I . lib_b.cmti + + $ odoc link-deps . + lib Lib_a 21c81261177d685464037918ae900b81 + lib Lib bbd67101d2e61e05dcf0f0cbf5f9dbe0 From 27cb8efefb12bebf8c90a643d18014a7d59550af Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Wed, 12 May 2021 20:23:35 +0200 Subject: [PATCH 7/9] Re-implement efficient lookup of imports Imports are needed for the link-deps command. Some modules have a lot of imports declared but only a few are needed. Only the "Root" is needed for imports, which is written at the beginning of the files. --- src/odoc/compilation_unit.ml | 19 ++++++++++++++----- src/odoc/compilation_unit.mli | 3 +++ src/odoc/compile.ml | 13 +++++++++++++ src/odoc/resolver.ml | 13 +++++++++++++ src/odoc/resolver.mli | 5 ++++- src/xref2/compile.ml | 13 +------------ 6 files changed, 48 insertions(+), 18 deletions(-) diff --git a/src/odoc/compilation_unit.ml b/src/odoc/compilation_unit.ml index 0c59ba5c3d..68bd9441c5 100644 --- a/src/odoc/compilation_unit.ml +++ b/src/odoc/compilation_unit.ml @@ -25,10 +25,11 @@ type t = let magic = "odoc-%%VERSION%%" (** Exceptions while saving are allowed to leak. *) -let save_unit file t = +let save_unit file (root : Root.t) (t : t) = Fs.Directory.mkdir_p (Fs.File.dirname file); let oc = open_out_bin (Fs.File.to_string file) in output_string oc magic; + Marshal.to_channel oc root []; Marshal.to_channel oc t []; close_out oc @@ -39,17 +40,20 @@ let save_page file page = if Astring.String.is_prefix ~affix:"page-" base then file else Fs.File.create ~directory:dir ~name:("page-" ^ base) in - save_unit file (Page_content page) + save_unit file page.Lang.Page.root (Page_content page) -let save_module file m = save_unit file (Module_content m) +let save_module file m = + save_unit file m.Lang.Compilation_unit.root (Module_content m) -let load file = +let load_ file f = let file = Fs.File.to_string file in let ic = open_in_bin file in let res = try let actual_magic = really_input_string ic (String.length magic) in - if actual_magic = magic then Ok (Marshal.from_channel ic) + if actual_magic = magic then + let root = Marshal.from_channel ic in + f ic root else let msg = Printf.sprintf "%s: invalid magic number %S, expected %S\n%!" file @@ -65,3 +69,8 @@ let load file = in close_in ic; res + +let load file = load_ file (fun ic _ -> Ok (Marshal.from_channel ic)) + +(** The root is saved separately in the files to support this function. *) +let load_root file = load_ file (fun _ root -> Ok root) diff --git a/src/odoc/compilation_unit.mli b/src/odoc/compilation_unit.mli index aab07a171c..315caa9ce3 100644 --- a/src/odoc/compilation_unit.mli +++ b/src/odoc/compilation_unit.mli @@ -36,3 +36,6 @@ val save_module : Fs.File.t -> Lang.Compilation_unit.t -> unit val load : Fs.File.t -> (t, [> msg ]) result (** Load an [.odoc] file. *) + +val load_root : Fs.File.t -> (Root.t, [> msg ]) result +(** Only load the root. Faster than {!load}, used for looking up imports. *) diff --git a/src/odoc/compile.ml b/src/odoc/compile.ml index 6aaf126a73..c9902bbd82 100644 --- a/src/odoc/compile.ml +++ b/src/odoc/compile.ml @@ -54,6 +54,17 @@ let parent resolver parent_cli_spec = | CliPackage package -> Ok (Package (`RootPage (PageName.make_std package))) | CliNoparent -> Ok Noparent +let resolve_imports resolver imports = + let open Odoc_model in + List.map + (function + | Lang.Compilation_unit.Import.Resolved _ as resolved -> resolved + | Unresolved (name, _) as unresolved -> ( + match Resolver.resolve_import resolver name with + | Some root -> Resolved (root, Names.ModuleName.make_std name) + | None -> unresolved)) + imports + let resolve_and_substitute ~resolver ~output ~warn_error parent input_file read_file = let filename = Fs.File.to_string input_file in @@ -66,6 +77,8 @@ let resolve_and_substitute ~resolver ~output ~warn_error parent input_file (if not (Filename.check_suffix filename "cmt") then "" (* ? *) else Printf.sprintf " Using %S while you should use the .cmti file" filename); + (* Resolve imports, used by the [link-deps] command. *) + let unit = { unit with imports = resolve_imports resolver unit.imports } in let env = Resolver.build_env_for_module resolver unit in Odoc_xref2.Compile.compile env unit diff --git a/src/odoc/resolver.ml b/src/odoc/resolver.ml index 0a3518b20b..a5201a6268 100644 --- a/src/odoc/resolver.ml +++ b/src/odoc/resolver.ml @@ -225,3 +225,16 @@ let build_env_for_page t p = Odoc_xref2.Env.env_of_page p resolver let lookup_page t target_name = lookup_page t.ap target_name + +let resolve_import t target_name = + let rec loop = function + | [] -> None + | path :: tl -> ( + match Compilation_unit.load_root path with + | Error _ -> loop tl + | Ok root -> ( + match root.Odoc_model.Root.file with + | Compilation_unit _ -> Some root + | Page _ -> loop tl)) + in + loop (Accessible_paths.find t.ap target_name) diff --git a/src/odoc/resolver.mli b/src/odoc/resolver.mli index 34e1f377e9..7e9b694eb2 100644 --- a/src/odoc/resolver.mli +++ b/src/odoc/resolver.mli @@ -43,4 +43,7 @@ val build_env_for_module : val build_env_for_page : t -> Odoc_model.Lang.Page.t -> Odoc_xref2.Env.t (** Initialize the environment for the given page. *) -(* val forward_resolver : t -> Root.t DocOck.forward_resolver *) +val resolve_import : t -> string -> Odoc_model.Root.t option +(** Similar to {!Odoc_xref2.Env.lookup_root_module} but save work by loading + only the root. Only used when resolving imports, which are needed for the + [link-deps] command. *) diff --git a/src/xref2/compile.ml b/src/xref2/compile.ml index 9b5061c45d..ee3264ce24 100644 --- a/src/xref2/compile.ml +++ b/src/xref2/compile.ml @@ -55,18 +55,7 @@ and class_type_path : Env.t -> Paths.Path.ClassType.t -> Paths.Path.ClassType.t let rec unit env t = let open Compilation_unit in - let imports = - (* Resolve imports *) - List.map - (function - | Import.Resolved _ as import -> import - | Unresolved (name, _) as unresolved -> ( - match Env.lookup_root_module name env with - | Some (Env.Resolved (root, _, _)) -> Resolved (root, Names.ModuleName.make_std name) - | Some Forward | None -> unresolved)) - t.imports - in - { t with content = content env t.id t.content; imports } + { t with content = content env t.id t.content } and content env id = let open Compilation_unit in From 8defb7b8cc18c06ff7df7d4b5cdce575f23cf68e Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Wed, 12 May 2021 20:27:51 +0200 Subject: [PATCH 8/9] Fix unstable depends.t test --- test/integration/depends.t/run.t | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/test/integration/depends.t/run.t b/test/integration/depends.t/run.t index 96662b1075..ae8279c7e9 100644 --- a/test/integration/depends.t/run.t +++ b/test/integration/depends.t/run.t @@ -4,15 +4,15 @@ Testing the depends command. $ ocamlc -c -bin-annot -I . -o lib_a.cmti a.mli $ ocamlc -c -bin-annot -I . -o lib_b.cmti b.mli - $ odoc compile-deps lib_b.cmti | grep -v "CamlinternalFormatBasics\|Stdlib" - Lib bbd67101d2e61e05dcf0f0cbf5f9dbe0 - Lib_a 21c81261177d685464037918ae900b81 - Lib_b b417b775de9c850fac708cc7fb6343b5 + $ odoc compile-deps lib_b.cmti | grep -v "CamlinternalFormatBasics\|Stdlib\|Pervasives" | cut -d ' ' -f 1 | sort -u + Lib + Lib_a + Lib_b $ odoc compile --pkg lib -I . lib.cmti $ odoc compile --pkg lib -I . lib_a.cmti $ odoc compile --pkg lib -I . lib_b.cmti - $ odoc link-deps . - lib Lib_a 21c81261177d685464037918ae900b81 - lib Lib bbd67101d2e61e05dcf0f0cbf5f9dbe0 + $ odoc link-deps . | cut -d ' ' -f 1-2 | sort + lib Lib + lib Lib_a From 80816508aebbee4b5c836b030ef6426b9d3cc703 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Wed, 12 May 2021 21:14:33 +0200 Subject: [PATCH 9/9] Use a unambiguous name for odoc files Previous commits were using "module" for Lang.Compilation_unit and "compilation unit" for .odoc files. --- src/odoc/compile.ml | 6 +-- src/odoc/depends.ml | 4 +- .../{compilation_unit.ml => odoc_file.ml} | 8 ++- .../{compilation_unit.mli => odoc_file.mli} | 8 ++- src/odoc/odoc_link.ml | 10 ++-- src/odoc/rendering.ml | 16 +++--- src/odoc/resolver.ml | 54 +++++++++---------- src/odoc/resolver.mli | 2 +- src/xref2/env.ml | 2 +- src/xref2/env.mli | 2 +- test/odoc_print/odoc_print.ml | 6 +-- test/xref2/lib/common.cppo.ml | 2 +- 12 files changed, 56 insertions(+), 64 deletions(-) rename src/odoc/{compilation_unit.ml => odoc_file.ml} (93%) rename src/odoc/{compilation_unit.mli => odoc_file.mli} (88%) diff --git a/src/odoc/compile.ml b/src/odoc/compile.ml index c9902bbd82..bc164a39cc 100644 --- a/src/odoc/compile.ml +++ b/src/odoc/compile.ml @@ -79,7 +79,7 @@ let resolve_and_substitute ~resolver ~output ~warn_error parent input_file Printf.sprintf " Using %S while you should use the .cmti file" filename); (* Resolve imports, used by the [link-deps] command. *) let unit = { unit with imports = resolve_imports resolver unit.imports } in - let env = Resolver.build_env_for_module resolver unit in + let env = Resolver.build_env_for_unit resolver unit in Odoc_xref2.Compile.compile env unit |> Odoc_xref2.Lookup_failures.handle_failures ~warn_error:false ~filename @@ -91,7 +91,7 @@ let resolve_and_substitute ~resolver ~output ~warn_error parent input_file working on. *) (* let expand_env = Env.build env (`Unit resolved) in*) (* let expanded = Odoc_xref2.Expand.expand (Env.expander expand_env) resolved in *) - Compilation_unit.save_module output compiled; + Odoc_file.save_unit output compiled; Ok () let root_of_compilation_unit ~parent_spec ~hidden ~output ~module_name ~digest = @@ -171,7 +171,7 @@ let mld ~parent_spec ~output ~children ~warn_error input = Odoc_model.Lang.Page. { name; root; children; content; digest; linked = false } in - Compilation_unit.save_page output page; + Odoc_file.save_page output page; Ok () in Fs.File.read input >>= fun str -> diff --git a/src/odoc/depends.ml b/src/odoc/depends.ml index b830d7c30b..d087774a99 100644 --- a/src/odoc/depends.ml +++ b/src/odoc/depends.ml @@ -64,9 +64,9 @@ end = struct end let deps_of_odoc_file ~deps input = - Compilation_unit.load input >>= function + Odoc_file.load input >>= function | Page_content _ -> Ok () (* XXX something should certainly be done here *) - | Module_content unit -> + | Unit_content unit -> List.iter unit.Odoc_model.Lang.Compilation_unit.imports ~f:(fun import -> match import with | Odoc_model.Lang.Compilation_unit.Import.Unresolved _ -> () diff --git a/src/odoc/compilation_unit.ml b/src/odoc/odoc_file.ml similarity index 93% rename from src/odoc/compilation_unit.ml rename to src/odoc/odoc_file.ml index 68bd9441c5..75c5129a41 100644 --- a/src/odoc/compilation_unit.ml +++ b/src/odoc/odoc_file.ml @@ -17,9 +17,7 @@ open Odoc_model open Or_error -type t = - | Page_content of Lang.Page.t - | Module_content of Lang.Compilation_unit.t +type t = Page_content of Lang.Page.t | Unit_content of Lang.Compilation_unit.t (** Written at the top of the files. Checked when loading. *) let magic = "odoc-%%VERSION%%" @@ -42,8 +40,8 @@ let save_page file page = in save_unit file page.Lang.Page.root (Page_content page) -let save_module file m = - save_unit file m.Lang.Compilation_unit.root (Module_content m) +let save_unit file m = + save_unit file m.Lang.Compilation_unit.root (Unit_content m) let load_ file f = let file = Fs.File.to_string file in diff --git a/src/odoc/compilation_unit.mli b/src/odoc/odoc_file.mli similarity index 88% rename from src/odoc/compilation_unit.mli rename to src/odoc/odoc_file.mli index 315caa9ce3..0fe3a7ea60 100644 --- a/src/odoc/compilation_unit.mli +++ b/src/odoc/odoc_file.mli @@ -20,17 +20,15 @@ open Odoc_model open Or_error (** Either a page or a module. *) -type t = - | Page_content of Lang.Page.t - | Module_content of Lang.Compilation_unit.t +type t = Page_content of Lang.Page.t | Unit_content of Lang.Compilation_unit.t (** {2 Serialization} *) val save_page : Fs.File.t -> Lang.Page.t -> unit (** Save a page. The [page-] prefix is added to the file name if missing. *) -val save_module : Fs.File.t -> Lang.Compilation_unit.t -> unit -(** Save a module. *) +val save_unit : Fs.File.t -> Lang.Compilation_unit.t -> unit +(** Save a compilation unit. *) (** {2 Deserialization} *) diff --git a/src/odoc/odoc_link.ml b/src/odoc/odoc_link.ml index 121b488da4..d40fcc1fb1 100644 --- a/src/odoc/odoc_link.ml +++ b/src/odoc/odoc_link.ml @@ -2,17 +2,17 @@ open Or_error let from_odoc ~resolver ~warn_error input output = let input_s = Fs.File.to_string input in - Compilation_unit.load input >>= function + Odoc_file.load input >>= function | Page_content page -> let env = Resolver.build_env_for_page resolver page in Odoc_xref2.Link.resolve_page env page |> Odoc_xref2.Lookup_failures.handle_failures ~warn_error ~filename:input_s >>= fun odoctree -> - Compilation_unit.save_page output odoctree; + Odoc_file.save_page output odoctree; Ok () - | Module_content m -> + | Unit_content m -> let m = if Odoc_model.Root.Odoc_file.hidden m.root.file then { @@ -25,11 +25,11 @@ let from_odoc ~resolver ~warn_error input output = else m in - let env = Resolver.build_env_for_module resolver m in + let env = Resolver.build_env_for_unit resolver m in Odoc_xref2.Link.link env m |> Odoc_xref2.Lookup_failures.handle_failures ~warn_error:false ~filename:input_s >>= fun odoctree -> - Compilation_unit.save_module output odoctree; + Odoc_file.save_unit output odoctree; Ok () diff --git a/src/odoc/rendering.ml b/src/odoc/rendering.ml index 57eb451c35..b2dc545df3 100644 --- a/src/odoc/rendering.ml +++ b/src/odoc/rendering.ml @@ -2,22 +2,22 @@ open Odoc_document open Or_error let document_of_odocl ~syntax input = - Compilation_unit.load input >>= function - | Compilation_unit.Page_content odoctree -> + Odoc_file.load input >>= function + | Odoc_file.Page_content odoctree -> Ok (Renderer.document_of_page ~syntax odoctree) - | Module_content odoctree -> + | Unit_content odoctree -> Ok (Renderer.document_of_compilation_unit ~syntax odoctree) let document_of_input ~resolver ~warn_error ~syntax input = let input_s = Fs.File.to_string input in - Compilation_unit.load input >>= function - | Compilation_unit.Page_content page -> + Odoc_file.load input >>= function + | Odoc_file.Page_content page -> let env = Resolver.build_env_for_page resolver page in Odoc_xref2.Link.resolve_page env page |> Odoc_xref2.Lookup_failures.handle_failures ~warn_error ~filename:input_s >>= fun odoctree -> Ok (Renderer.document_of_page ~syntax odoctree) - | Module_content m -> + | Unit_content m -> (* If hidden, we should not generate HTML. See https://github.com/ocaml/odoc/issues/99. *) let m = @@ -31,7 +31,7 @@ let document_of_input ~resolver ~warn_error ~syntax input = } else m in - let env = Resolver.build_env_for_module resolver m in + let env = Resolver.build_env_for_unit resolver m in (* let startlink = Unix.gettimeofday () in *) (* Format.fprintf Format.err_formatter "**** Link...\n%!"; *) let linked = Odoc_xref2.Link.link env m in @@ -44,7 +44,7 @@ let document_of_input ~resolver ~warn_error ~syntax input = >>= fun odoctree -> Odoc_xref2.Tools.reset_caches (); - Compilation_unit.save_module Fs.File.(set_ext ".odocl" input) odoctree; + Odoc_file.save_unit Fs.File.(set_ext ".odocl" input) odoctree; Ok (Renderer.document_of_compilation_unit ~syntax odoctree) let render_document renderer ~output:root_dir ~extra odoctree = diff --git a/src/odoc/resolver.ml b/src/odoc/resolver.ml index a5201a6268..9eba32687d 100644 --- a/src/odoc/resolver.ml +++ b/src/odoc/resolver.ml @@ -77,14 +77,13 @@ let build_imports_map m = let root_name root = Odoc_model.Root.Odoc_file.name root.Odoc_model.Root.file -let unit_name - (Compilation_unit.Module_content { root; _ } | Page_content { root; _ }) = +let unit_name (Odoc_file.Unit_content { root; _ } | Page_content { root; _ }) = root_name root (** TODO: Propagate warnings instead of printing. *) let load_units_from_files paths = let safe_read file acc = - match Compilation_unit.load file with + match Odoc_file.load file with | Ok u -> u :: acc | Error (`Msg msg) -> let warning = @@ -115,37 +114,35 @@ let rec find_map f = function | hd :: tl -> ( match f hd with Some x -> Some (x, tl) | None -> find_map f tl) -let lookup_module_with_digest ap target_name digest = - let module_that_match_digest u = +let lookup_unit_with_digest ap target_name digest = + let unit_that_match_digest u = match u with - | Compilation_unit.Module_content m + | Odoc_file.Unit_content m when Digest.compare m.Odoc_model.Lang.Compilation_unit.digest digest = 0 -> Some m | _ -> None in let units = load_units_from_name ap target_name in - match find_map module_that_match_digest units with + match find_map unit_that_match_digest units with | Some (m, _) -> Odoc_xref2.Env.Found m | None -> Not_found -(** Lookup a module matching a name. If there is more than one result, report on - stderr and return the first one. +(** Lookup a compilation unit matching a name. If there is more than one + result, report on stderr and return the first one. TODO: Correctly propagate warnings instead of printing. *) -let lookup_module_by_name ap target_name = - let first_module u = - match u with - | Compilation_unit.Module_content m -> Some m - | Page_content _ -> None +let lookup_unit_by_name ap target_name = + let first_unit u = + match u with Odoc_file.Unit_content m -> Some m | Page_content _ -> None in let rec find_ambiguous tl = - match find_map first_module tl with + match find_map first_unit tl with | Some (m, tl) -> m :: find_ambiguous tl | None -> [] in let units = load_units_from_name ap target_name in - match find_map first_module units with + match find_map first_unit units with | Some (m, tl) -> (match find_ambiguous tl with | [] -> () @@ -166,18 +163,19 @@ let lookup_module_by_name ap target_name = Odoc_xref2.Env.Found m | None -> Not_found -(** Lookup a module. First looks into [imports_map] then searches into the paths. *) +(** Lookup an unit. First looks into [imports_map] then searches into the + paths. *) let lookup_unit ~important_digests ~imports_map ap target_name = match StringMap.find target_name imports_map with | Odoc_model.Lang.Compilation_unit.Import.Unresolved (_, Some digest) -> - lookup_module_with_digest ap target_name digest + lookup_unit_with_digest ap target_name digest | Unresolved (_, None) -> if important_digests then Odoc_xref2.Env.Forward_reference - else lookup_module_by_name ap target_name - | Resolved (root, _) -> lookup_module_with_digest ap target_name root.digest + else 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 - else lookup_module_by_name ap target_name + else lookup_unit_by_name ap target_name (** Lookup a page. @@ -185,9 +183,7 @@ let lookup_unit ~important_digests ~imports_map ap target_name = let lookup_page ap target_name = let target_name = "page-" ^ target_name in let is_page u = - match u with - | Compilation_unit.Page_content p -> Some p - | Module_content _ -> None + match u with Odoc_file.Page_content p -> Some p | Unit_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 @@ -213,15 +209,15 @@ let build { important_digests; ap; open_modules } ~imports_map u = and lookup_page = lookup_page ap in { Odoc_xref2.Env.open_units = open_modules; lookup_unit; lookup_page } -let build_env_for_module t m = +let build_env_for_unit t m = let imports_map = build_imports_map m in - let resolver = build t ~imports_map (Compilation_unit.Module_content m) in - Odoc_xref2.Env.env_of_module m resolver + let resolver = build t ~imports_map (Odoc_file.Unit_content m) in + Odoc_xref2.Env.env_of_unit m resolver let build_env_for_page t p = let imports_map = StringMap.empty in let t = { t with important_digests = false } in - let resolver = build t ~imports_map (Compilation_unit.Page_content p) in + let resolver = build t ~imports_map (Odoc_file.Page_content p) in Odoc_xref2.Env.env_of_page p resolver let lookup_page t target_name = lookup_page t.ap target_name @@ -230,7 +226,7 @@ let resolve_import t target_name = let rec loop = function | [] -> None | path :: tl -> ( - match Compilation_unit.load_root path with + match Odoc_file.load_root path with | Error _ -> loop tl | Ok root -> ( match root.Odoc_model.Root.file with diff --git a/src/odoc/resolver.mli b/src/odoc/resolver.mli index 7e9b694eb2..671fd07a33 100644 --- a/src/odoc/resolver.mli +++ b/src/odoc/resolver.mli @@ -36,7 +36,7 @@ val lookup_page : t -> string -> Odoc_model.Lang.Page.t option (* val lookup_module *) -val build_env_for_module : +val build_env_for_unit : t -> Odoc_model.Lang.Compilation_unit.t -> Odoc_xref2.Env.t (** Initialize the environment for the given module. *) diff --git a/src/xref2/env.ml b/src/xref2/env.ml index 3a4d36217f..ccecaa97e5 100644 --- a/src/xref2/env.ml +++ b/src/xref2/env.ml @@ -711,7 +711,7 @@ let rec open_signature : Odoc_model.Lang.Signature.t -> t -> t = let inherit_resolver env = match env.resolver with Some r -> set_resolver empty r | None -> empty -let env_of_module t resolver = +let env_of_unit t resolver = let open Odoc_model.Lang.Compilation_unit in let initial_env = let m = module_of_unit t in diff --git a/src/xref2/env.mli b/src/xref2/env.mli index 03010b8914..686383b2b9 100644 --- a/src/xref2/env.mli +++ b/src/xref2/env.mli @@ -171,7 +171,7 @@ val open_class_signature : Odoc_model.Lang.ClassSignature.t -> t -> t val open_signature : Odoc_model.Lang.Signature.t -> t -> t -val env_of_module : Odoc_model.Lang.Compilation_unit.t -> resolver -> t +val env_of_unit : Odoc_model.Lang.Compilation_unit.t -> resolver -> t (** Create a new env with a module initially opened. *) val env_of_page : Odoc_model.Lang.Page.t -> resolver -> t diff --git a/test/odoc_print/odoc_print.ml b/test/odoc_print/odoc_print.ml index ebd4981021..e14e14cc4f 100644 --- a/test/odoc_print/odoc_print.ml +++ b/test/odoc_print/odoc_print.ml @@ -10,11 +10,11 @@ let print_json_desc desc x = let run inp = let inp = Fpath.v inp in - Compilation_unit.load inp >>= function - | Compilation_unit.Page_content page -> + Odoc_file.load inp >>= function + | Odoc_file.Page_content page -> print_json_desc Lang_desc.page_t page; Ok () - | Module_content u -> + | Unit_content u -> print_json_desc Lang_desc.compilation_unit_t u; Ok () diff --git a/test/xref2/lib/common.cppo.ml b/test/xref2/lib/common.cppo.ml index 7ddf38c997..8fc8766abb 100644 --- a/test/xref2/lib/common.cppo.ml +++ b/test/xref2/lib/common.cppo.ml @@ -622,7 +622,7 @@ let mkresolver () = let resolve unit = let resolver = mkresolver () in - let resolve_env = Odoc_odoc.Resolver.build_env_for_module resolver unit in + let resolve_env = Odoc_odoc.Resolver.build_env_for_unit resolver unit in let result = Odoc_xref2.Compile.compile resolve_env unit in result