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/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/compilation_unit.ml b/src/odoc/compilation_unit.ml deleted file mode 100644 index 265dd55206..0000000000 --- a/src/odoc/compilation_unit.ml +++ /dev/null @@ -1,47 +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.Compilation_unit.t - -let save 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; - Marshal.to_channel oc t []; - close_out oc - -let units_cache = Hashtbl.create 23 (* because. *) - -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 - let _root = Root.load file ic in - let res = Marshal.from_channel ic in - close_in ic; - Hashtbl.add units_cache file res; - Ok 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/compile.ml b/src/odoc/compile.ml index 8f3a8a6b8f..bc164a39cc 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.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) -> ( - 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") @@ -49,14 +48,25 @@ 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 -let resolve_and_substitute ~env ~output ~warn_error parent input_file read_file - = +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 read_file ~parent ~filename @@ -67,7 +77,9 @@ 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 + (* 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_unit resolver unit in Odoc_xref2.Compile.compile env unit |> Odoc_xref2.Lookup_failures.handle_failures ~warn_error:false ~filename @@ -79,7 +91,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; + Odoc_file.save_unit output compiled; Ok () let root_of_compilation_unit ~parent_spec ~hidden ~output ~module_name ~digest = @@ -88,15 +100,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 +171,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; + Odoc_file.save_page output page; Ok () in Fs.File.read input >>= fun str -> @@ -178,9 +183,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 @@ -200,5 +205,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/depends.ml b/src/odoc/depends.ml index 83dacd7b3c..d087774a99 100644 --- a/src/odoc/depends.ml +++ b/src/odoc/depends.ml @@ -64,13 +64,10 @@ 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 -> + Odoc_file.load input >>= function + | Page_content _ -> Ok () (* XXX something should certainly be done here *) + | 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 _ -> () | Odoc_model.Lang.Compilation_unit.Import.Resolved (root, _) -> diff --git a/src/odoc/env.ml b/src/odoc/env.ml deleted file mode 100644 index aaf2a1b9a7..0000000000 --- a/src/odoc/env.ml +++ /dev/null @@ -1,268 +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. - *) - -(* We are slightly more flexible here than OCaml usually is, and allow - 'linking' of modules that have the same name. This is because we do - documentation at a package level - it's perfectly acceptable to have - libraries within a package that are never meant to be linked into the same - binary, however package-level documents such as module and type indexes - effectively have to link those libraries together. Hence we may find - ourselves in the unfortunate situation where there are multiple modules with the same - name in our include path. We therefore maintain a mapping of module/page - name to Root _list_. Where we've already made a judgement about which module - we're looking for we have a digest, and can pick the correct module. When we - don't (for example, when handling package-level mld files), we pick the - first right now. The ocamldoc syntax doesn't currently allow for specifying - more accurately than just the module name anyway. - - Where we notice this ambiguity we warn the user to wrap their libraries, - which will generally fix this issue. *) - -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; - } - - let create ~directories = - { - root_map = Odoc_model.Root.Hash_table.create 42; - file_map = Hashtbl.create 42; - directories; - } - - let find_file_by_name 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 - | [] -> acc - | directory :: dirs -> ( - let lfile = Fs.File.create ~directory ~name:lname in - match Unix.stat (Fs.File.to_string lfile) with - | _ -> loop (lfile :: acc) dirs - | exception Unix.Unix_error _ -> ( - let ufile = Fs.File.create ~directory ~name:uname in - match Unix.stat (Fs.File.to_string ufile) with - | _ -> loop (ufile :: acc) dirs - | 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 = - List.fold_left - (fun map import -> - match import with - | Odoc_model.Lang.Compilation_unit.Import.Unresolved (name, _) -> - StringMap.add name import map - | Odoc_model.Lang.Compilation_unit.Import.Resolved (_, name) -> - 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 - 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) - 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) - 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 - -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 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) - -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) - in - Error (`Msg msg) - -type t = Odoc_xref2.Env.resolver - -type builder = [ `Unit of Compilation_unit.t | `Page of Page.t ] -> t - -let create ?(important_digests = true) ~directories ~open_modules : builder = - let ap = Accessible_paths.create ~directories in - fun 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 - -let build builder unit = builder unit diff --git a/src/odoc/html_fragment.ml b/src/odoc/html_fragment.ml index 37a18d7404..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 env (`Page 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_file.ml b/src/odoc/odoc_file.ml new file mode 100644 index 0000000000..75c5129a41 --- /dev/null +++ b/src/odoc/odoc_file.ml @@ -0,0 +1,74 @@ +(* + * 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 Odoc_model +open Or_error + +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%%" + +(** Exceptions while saving are allowed to leak. *) +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 + +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 page.Lang.Page.root (Page_content page) + +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 + 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 + let root = Marshal.from_channel ic in + f ic root + else + let msg = + Printf.sprintf "%s: invalid magic number %S, expected %S\n%!" file + actual_magic magic + in + 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 + +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/odoc_file.mli similarity index 61% rename from src/odoc/compilation_unit.mli rename to src/odoc/odoc_file.mli index 48b9bcc5e0..0fe3a7ea60 100644 --- a/src/odoc/compilation_unit.mli +++ b/src/odoc/odoc_file.mli @@ -14,16 +14,26 @@ * 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 t = Page_content of Lang.Page.t | Unit_content of Lang.Compilation_unit.t (** {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_unit : Fs.File.t -> Lang.Compilation_unit.t -> unit +(** Save a compilation unit. *) (** {2 Deserialization} *) 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/odoc_link.ml b/src/odoc/odoc_link.ml index 00b05478c6..d40fcc1fb1 100644 --- a/src/odoc/odoc_link.ml +++ b/src/odoc/odoc_link.ml @@ -1,38 +1,35 @@ open Or_error -let from_odoc ~env ~warn_error input output = - Root.read input >>= fun root -> +let from_odoc ~resolver ~warn_error input output = let input_s = Fs.File.to_string input in - match root.file with - | Page _ -> - Page.load input >>= fun page -> - let resolve_env = Env.build env (`Page page) in - Odoc_xref2.Link.resolve_page resolve_env page + 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 -> - Page.save output odoctree; + Odoc_file.save_page output odoctree; Ok () - | Compilation_unit { hidden; _ } -> - Compilation_unit.load input >>= fun unit -> - let unit = - if hidden then + | Unit_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 env (`Unit unit) in - Odoc_xref2.Link.link env unit + 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 output odoctree; + Odoc_file.save_unit 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 2e5b575509..b2dc545df3 100644 --- a/src/odoc/rendering.ml +++ b/src/odoc/rendering.ml @@ -2,45 +2,39 @@ 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 -> + Odoc_file.load input >>= function + | Odoc_file.Page_content odoctree -> Ok (Renderer.document_of_page ~syntax odoctree) - | Compilation_unit _ -> - Compilation_unit.load input >>= fun odoctree -> + | Unit_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 document_of_input ~resolver ~warn_error ~syntax input = let input_s = Fs.File.to_string input in - match root.file with - | Page _ -> - Page.load input >>= fun page -> - let resolve_env = Env.build env (`Page page) in - Odoc_xref2.Link.resolve_page resolve_env 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) - | Compilation_unit { hidden; _ } -> + | Unit_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 env (`Unit unit) 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 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 +43,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; + 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 = @@ -66,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/resolver.ml b/src/odoc/resolver.ml new file mode 100644 index 0000000000..9eba32687d --- /dev/null +++ b/src/odoc/resolver.ml @@ -0,0 +1,236 @@ +(* + * 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. + *) + +(* We are slightly more flexible here than OCaml usually is, and allow + 'linking' of modules that have the same name. This is because we do + documentation at a package level - it's perfectly acceptable to have + libraries within a package that are never meant to be linked into the same + binary, however package-level documents such as module and type indexes + effectively have to link those libraries together. Hence we may find + ourselves in the unfortunate situation where there are multiple modules with the same + name in our include path. We therefore maintain a mapping of module/page + name to Root _list_. Where we've already made a judgement about which module + we're looking for we have a digest, and can pick the correct module. When we + don't (for example, when handling package-level mld files), we pick the + first right now. The ocamldoc syntax doesn't currently allow for specifying + more accurately than just the module name anyway. + + Where we notice this ambiguity we warn the user to wrap their libraries, + which will generally fix this issue. *) + +open Or_error + +module Accessible_paths : sig + type t + + 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 + | [] -> acc + | directory :: dirs -> ( + let lfile = Fs.File.create ~directory ~name:lname in + match Unix.stat (Fs.File.to_string lfile) with + | _ -> loop (lfile :: acc) dirs + | exception Unix.Unix_error _ -> ( + let ufile = Fs.File.create ~directory ~name:uname in + match Unix.stat (Fs.File.to_string ufile) with + | _ -> loop (ufile :: acc) dirs + | exception Unix.Unix_error _ -> loop acc dirs)) + in + loop [] t.directories +end + +module StringMap = Map.Make (String) + +let build_imports_map m = + let imports = m.Odoc_model.Lang.Compilation_unit.imports in + List.fold_left + (fun map import -> + match import with + | Odoc_model.Lang.Compilation_unit.Import.Unresolved (name, _) -> + StringMap.add name import map + | Odoc_model.Lang.Compilation_unit.Import.Resolved (_, name) -> + StringMap.add (Odoc_model.Names.ModuleName.to_string name) import map) + StringMap.empty imports + +let root_name root = Odoc_model.Root.Odoc_file.name root.Odoc_model.Root.file + +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 Odoc_file.load 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 (Odoc_model.Error.to_string warning); + acc + in + List.fold_right safe_read paths [] + +let unit_cache = Hashtbl.create 42 + +(** 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 rec find_map f = function + | [] -> None + | hd :: tl -> ( + match f hd with Some x -> Some (x, tl) | None -> find_map f tl) + +let lookup_unit_with_digest ap target_name digest = + let unit_that_match_digest u = + match u with + | 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 unit_that_match_digest units with + | Some (m, _) -> Odoc_xref2.Env.Found m + | None -> Not_found + +(** 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_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_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_unit units with + | 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 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_unit_with_digest ap target_name digest + | Unresolved (_, None) -> + if important_digests then Odoc_xref2.Env.Forward_reference + 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_unit_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 u = + 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 + +(** 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 ] + +type t = { + 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 + { 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_env_for_unit t m = + let imports_map = build_imports_map m in + 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 (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 + +let resolve_import t target_name = + let rec loop = function + | [] -> None + | path :: tl -> ( + match Odoc_file.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/env.mli b/src/odoc/resolver.mli similarity index 66% rename from src/odoc/env.mli rename to src/odoc/resolver.mli index 772b4edf25..671fd07a33 100644 --- a/src/odoc/env.mli +++ b/src/odoc/resolver.mli @@ -19,35 +19,31 @@ 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.Root.t option - -val fetch_page : - Accessible_paths.t -> - Odoc_model.Root.t -> - (Page.t, [> `Msg of string ]) Result.result - -type t = Odoc_xref2.Env.resolver - -type builder +type t val create : - ?important_digests:bool -> + 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 : builder -> [ `Unit of Compilation_unit.t | `Page of Page.t ] -> t -(** Initialize the environment for the given unit. *) +val lookup_page : t -> string -> Odoc_model.Lang.Page.t option + +(* val lookup_module *) + +val build_env_for_unit : + t -> Odoc_model.Lang.Compilation_unit.t -> Odoc_xref2.Env.t +(** Initialize the environment for the given 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/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/src/xref2/compile.ml b/src/xref2/compile.ml index a733da3413..ee3264ce24 100644 --- a/src/xref2/compile.ml +++ b/src/xref2/compile.ml @@ -53,10 +53,9 @@ 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 imports, env = Env.initial_env t resolver 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 @@ -741,36 +740,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) -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) -> - 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 } - 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 6ab64a7894..cbe349a9d9 100644 --- a/src/xref2/compile.mli +++ b/src/xref2/compile.mli @@ -6,20 +6,8 @@ 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) -> - Env.resolver - 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 9763ee7486..ccecaa97e5 100644 --- a/src/xref2/env.ml +++ b/src/xref2/env.ml @@ -2,24 +2,22 @@ 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) + (Root.t * Odoc_model.Paths.Identifier.Module.t * Component.Module.t) | Forward 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,19 +364,16 @@ 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, 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 @@ -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 -> @@ -718,34 +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 : - Odoc_model.Lang.Compilation_unit.t -> - resolver -> - Odoc_model.Lang.Compilation_unit.Import.t list * t = - fun t resolver -> +let inherit_resolver env = + match env.resolver with Some r -> set_resolver empty r | None -> empty + +let env_of_unit 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 - 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 +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 fa026d5919..686383b2b9 100644 --- a/src/xref2/env.mli +++ b/src/xref2/env.mli @@ -1,23 +1,23 @@ (* 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) + (Odoc_model.Root.t + * Odoc_model.Paths.Identifier.Module.t + * Component.Module.t) | Forward 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 = @@ -171,10 +171,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 -> - Odoc_model.Lang.Compilation_unit.Import.t list * 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 +(** 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 10eaa4ae74..5bcf82e234 100644 --- a/src/xref2/link.ml +++ b/src/xref2/link.ml @@ -211,15 +211,14 @@ 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 imports, 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 @@ -822,25 +821,11 @@ 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) 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/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..ae8279c7e9 --- /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\|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 . | cut -d ' ' -f 1-2 | sort + lib Lib + lib Lib_a diff --git a/test/odoc_print/odoc_print.ml b/test/odoc_print/odoc_print.ml index f6f947c88a..e14e14cc4f 100644 --- a/test/odoc_print/odoc_print.ml +++ b/test/odoc_print/odoc_print.ml @@ -10,14 +10,11 @@ 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 -> + Odoc_file.load inp >>= function + | Odoc_file.Page_content page -> print_json_desc Lang_desc.page_t page; Ok () - | Compilation_unit _ -> - Compilation_unit.load inp >>= fun 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 b7f8f25886..8fc8766abb 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 env (`Unit unit) in + let resolver = mkresolver () 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