Something went wrong. Try again.
Odoc docs forked from jon.recoil.org/odd
Something went wrong. Try again.
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368(* Reference resolution against a whole opam switch — the substrate shared by [show] (render the item a reference names) and [complete] (list the children of the context a partial reference names). It is, in essence, the reference-resolution half of [odoc link] (see [src/odoc/url.ml] in odoc, the [odoc html-url] command) run standalone over the switch:
1. {!scan} the switch's [odoc/] tree once for the include directories (dirs holding [.odoc] files), the package/library roots, and an index of linked units ([.odocl] by name). 2. {!resolve_to_id} a reference string to a canonical identifier with [Odoc_xref2.Ref_tools.resolve_reference], exactly as odoc does. 3. {!owning_content} loads the linked [.odocl] that defines the identifier, and {!find} locates the item within it. *)
module Id = Odoc_model.Paths.Identifiermodule Lang = Odoc_model.Langmodule Url = Odoc_document.Url
(* {1 Stage 1: scan the switch} *)
(* All files (not directories) beneath [root], recursively. *)let all_files root = let rec loop acc dir = match Bos.OS.Dir.contents ~rel:false dir with | Error _ -> acc | Ok entries -> List.fold_left (fun acc p -> match Bos.OS.Dir.exists p with | Ok true -> loop acc p | _ -> p :: acc) acc entries in loop [] root
(* Immediate subdirectories of [dir], as (basename, path) pairs. *)let subdirs dir = match Bos.OS.Dir.contents ~rel:false dir with | Error _ -> [] | Ok entries -> List.filter_map (fun p -> match Bos.OS.Dir.exists p with | Ok true -> Some (Fpath.basename p, p) | _ -> None) entries
type scan = { odoc : Fpath.t; (** the switch's [odoc/] root *) directories : Fpath.t list; (** every dir holding a [.odoc] (the [-I] set) *) odocl : (string, Fpath.t) Hashtbl.t; (** capitalised unit name -> [.odocl] *) page_roots : (string * Fpath.t) list; (** package name -> [odoc/<pkg>] ([-P]) *) lib_roots : (string * Fpath.t) list; (** library name -> [odoc/<pkg>/<lib>] ([-L]) *)}
(* The driver links each package with [-P <pkg>:odoc/<pkg>] for every package and [-L <lib>:odoc/<pkg>/<lib>] for every library (see [landing_pages.ml] and [odoc_unit.ml] in the driver). To resolve the package-qualified path references those produce ([{!/pkg/...}]), we reconstruct the same named roots for the whole switch: packages are the top-level dirs under [odoc/], libraries their immediate subdirectories. (Name lookups for ordinary dotted references still go through the flat [-I] set; the roots only add path references.) *)let scan sw = let odoc = Switch.odoc_dir sw in let files = all_files odoc in let dirs = Hashtbl.create 256 in let odocl = Hashtbl.create 256 in List.iter (fun p -> match Fpath.get_ext p with | ".odoc" -> let d = Fpath.parent p in Hashtbl.replace dirs (Fpath.to_string d) d | ".odocl" -> let name = Fpath.(rem_ext p |> basename) |> String.capitalize_ascii in Hashtbl.add odocl name p | _ -> ()) files; let directories = Hashtbl.fold (fun _ d acc -> d :: acc) dirs [] in let page_roots = subdirs odoc in let lib_roots = List.concat_map (fun (_pkg, dir) -> subdirs dir) page_roots in { odoc; directories; odocl; page_roots; lib_roots }
(* {1 Stage 2: resolve the reference} *)
(* The resolver prints ambiguity notices straight to stderr (it cannot help it: the same module name legitimately occurs in several packages when the whole switch is on the search path). We follow the resolved identifier, so the "first match" it reports is the right one — silence the noise around the call. Errors are returned as values, not printed, so nothing useful is lost. *)let with_suppressed_stderr f = flush stderr; let saved = Unix.dup Unix.stderr in let devnull = Unix.openfile "/dev/null" [ Unix.O_WRONLY ] 0o600 in Unix.dup2 devnull Unix.stderr; Unix.close devnull; Fun.protect f ~finally:(fun () -> flush stderr; Unix.dup2 saved Unix.stderr; Unix.close saved)
(* Resolve references as if these modules were open, mirroring the compiler's (and the driver's link-time) default environment, so a bare [List] reaches [Stdlib.List]. If a module isn't documented in the switch, [open_units] simply skips it. *)let default_open = [ "Stdlib" ]
let resolve_to_id { odoc; directories; page_roots; lib_roots; _ } ref_str = let dir = Odoc_odoc.Fs.Directory.of_string in let directories = List.map (fun d -> dir (Fpath.to_string d)) directories in let named = List.map (fun (n, d) -> (n, dir (Fpath.to_string d))) in let roots = Some { Odoc_odoc.Resolver.page_roots = named page_roots; lib_roots = named lib_roots; current_lib = None; current_package = None; (* No "current" unit: we resolve a reference from nowhere, so relative/current-package path references don't apply. current_dir is required but only feeds the include set and the (here unused) hierarchy, so the odoc root is a harmless value. *) current_dir = dir (Fpath.to_string odoc); } in let resolver = Odoc_odoc.Resolver.create ~important_digests:false ~directories ~open_modules:default_open ~roots in let warnings_options = { Odoc_model.Error.warn_error = false; print_warnings = false; warnings_tag = None; } in match Odoc_model.Semantics.parse_reference ref_str |> Odoc_model.Error.handle_errors_and_warnings ~warnings_options with | Error (`Msg m) -> Error (`Msg (Printf.sprintf "cannot parse reference %S: %s" ref_str m)) | Ok reference -> ( let resolved = with_suppressed_stderr (fun () -> let env = Odoc_odoc.Resolver.build_env_for_reference resolver in Odoc_xref2.Ref_tools.resolve_reference env reference |> Odoc_model.Error.raise_warnings) in match resolved with | Error e -> Error (`Msg (Format.asprintf "cannot resolve reference %S: %a" ref_str Odoc_xref2.Errors.Tools_error.pp_reference_lookup_error e)) | Ok (resolved, _synopsis) -> ( match Odoc_model.Paths.Reference.Resolved.identifier resolved with | Some id -> Ok id | None -> Error (`Msg (Printf.sprintf "reference %S resolves to a hidden item with no \ identifier" ref_str))))
(* {1 Stage 3: load the owning unit and locate the item} *)
(* The signature exposed by a module/module-type expression, when an expansion is present (it always is in a linked [.odocl]). *)let rec simple_expansion_sig : Lang.ModuleType.simple_expansion -> _ = function | Signature s -> Some s | Functor (_, e) -> simple_expansion_sig e
let rec modtype_expr_sig : Lang.ModuleType.expr -> Lang.Signature.t option = function | Signature s -> Some s | Path { p_expansion = Some se; _ } -> simple_expansion_sig se | With { w_expansion = Some se; _ } -> simple_expansion_sig se | TypeOf { t_expansion = Some se; _ } -> simple_expansion_sig se | Strengthen { s_expansion = Some se; _ } -> simple_expansion_sig se | Functor (_, e) -> modtype_expr_sig e | Path { p_expansion = None; _ } | With { w_expansion = None; _ } | TypeOf { t_expansion = None; _ } | Strengthen { s_expansion = None; _ } -> None
let module_decl_sig : Lang.Module.decl -> Lang.Signature.t option = function | Alias (_, Some se) -> simple_expansion_sig se | Alias (_, None) -> None | ModuleType e -> modtype_expr_sig e
(* What an identifier points at, carrying both its doc comment (for [show]) and, for containers, the structure needed to enumerate children (for [complete]). For modules/module-types the signature is the expansion's signature; it can be [None] for an unexpanded alias. *)type located = | Lmodule of Odoc_model.Comment.docs * Lang.Signature.t option | Lclass of Odoc_model.Comment.docs * Lang.ClassSignature.t option | Ltype of Odoc_model.Comment.docs * Lang.TypeDecl.t | Lleaf of Odoc_model.Comment.docs
let rec find_sig target (sg : Lang.Signature.t) = List.find_map (find_item target) sg.items
and find_item target (item : Lang.Signature.item) : located option = let is t id = Id.equal (id :> Id.t) t in match item with | Module (_, m) -> let sg = module_decl_sig m.type_ in if is target m.id then Some (Lmodule (m.doc, sg)) else Option.bind sg (find_sig target) | ModuleType mt -> let sg = Option.bind mt.expr modtype_expr_sig in if is target mt.id then Some (Lmodule (mt.doc, sg)) else Option.bind sg (find_sig target) | ModuleSubstitution ms -> if is target ms.id then Some (Lleaf ms.doc) else None | ModuleTypeSubstitution mts -> if is target mts.id then Some (Lleaf mts.doc) else None | Type (_, t) -> if is target t.id then Some (Ltype (t.doc, t)) else find_in_type target t | TypeSubstitution t -> if is target t.id then Some (Ltype (t.doc, t)) else find_in_type target t | TypExt te -> List.find_map (fun (c : Lang.Extension.Constructor.t) -> if is target c.id then Some (Lleaf c.doc) else None) te.constructors | Exception e -> if is target e.id then Some (Lleaf e.doc) else find_in_args target e.args | Value v -> if is target v.id then Some (Lleaf v.doc) else None | Class (_, c) -> if is target c.id then Some (Lclass (c.doc, c.expansion)) else Option.bind c.expansion (find_class_sig target) | ClassType (_, ct) -> if is target ct.id then Some (Lclass (ct.doc, ct.expansion)) else Option.bind ct.expansion (find_class_sig target) | Include i -> find_sig target i.expansion.content | Open _ | Comment _ -> None
and find_in_type target (t : Lang.TypeDecl.t) = let is id = Id.equal (id :> Id.t) target in match t.representation with | None -> None | Some (Variant cs) -> List.find_map (find_constructor target) cs | Some (Record fs) -> List.find_map (find_field target) fs | Some (Record_unboxed_product fs) -> List.find_map (fun (f : Lang.TypeDecl.UnboxedField.t) -> if is f.id then Some (Lleaf f.doc) else None) fs | Some Extensible -> None
and find_constructor target (c : Lang.TypeDecl.Constructor.t) = if Id.equal (c.id :> Id.t) target then Some (Lleaf c.doc) else find_in_args target c.args
and find_in_args target : Lang.TypeDecl.Constructor.argument -> _ = function | Record fs -> List.find_map (find_field target) fs | Tuple _ -> None
and find_field target (f : Lang.TypeDecl.Field.t) = if Id.equal (f.id :> Id.t) target then Some (Lleaf f.doc) else None
and find_class_sig target (cs : Lang.ClassSignature.t) = List.find_map (fun (item : Lang.ClassSignature.item) -> let is id = Id.equal (id :> Id.t) target in match item with | Method m -> if is m.id then Some (Lleaf m.doc) else None | InstanceVariable v -> if is v.id then Some (Lleaf v.doc) else None | Constraint _ | Inherit _ | Comment _ -> None) cs.items
let find target (cu : Lang.Compilation_unit.t) = match cu.content with | Pack _ -> None | Module sg -> if Id.equal (cu.id :> Id.t) target then Some (Lmodule (sg.doc, Some sg)) else find_sig target sg
(* The root identifier of a loaded file: a unit's own module id, or a page's id. (Implementations and assets carry no doc comment we render.) *)let content_root : Odoc_odoc.Odoc_file.content -> Id.t option = function | Unit_content cu -> Some (cu.id :> Id.t) | Page_content p -> Some (p.name :> Id.t) | Impl_content _ | Asset_content _ -> None
(* A file owns [target] when its root identifier is a suffix of [target]'s key. Identifier keys are dotted from the leaf up to the root container page (the package), e.g. [t_result.r_Stdlib.p_stdlib.p_ocamlfind], so this both confirms the right file and disambiguates a name that occurs in more than one package — we must load the very file the reference resolved into, not just any file of the same name. *)let owns target content = match content_root content with | None -> false | Some root -> let tk = target.Id.ikey and uk = root.Id.ikey in let lt = String.length tk and lu = String.length uk in lt >= lu && String.sub tk (lt - lu) lu = uk
(* The odocl-index key (capitalised file basename) of the file owning [id]: a unit lives in [<RootModule>.odocl]; a doc page in [page-<name>.odocl]. *)let index_key ~is_page id = match Id.fullname id with | [] -> None | root :: _ -> if is_page then match List.rev (Id.fullname id) with | leaf :: _ -> Some (String.capitalize_ascii ("page-" ^ leaf)) | [] -> None else Some (String.capitalize_ascii root)
let load_content path = match Odoc_odoc.Odoc_file.load path with | Ok { content; _ } -> Some content | Error (`Msg _) -> None
let is_page_id id = match (Url.from_identifier ~stop_before:false id).Url.Anchor.kind with | `Page | `LeafPage -> true | _ -> false
(* The linked files whose name matches the root of [id]. More than one means the reference is ambiguous across packages/libraries — the resolver would otherwise silently pick the first. *)let root_candidates scan id = match index_key ~is_page:(is_page_id id) id with | None -> [] | Some key -> Hashtbl.find_all scan.odocl key
let owning_content scan ~ref_str id = let is_page = is_page_id id in match index_key ~is_page id with | None -> Error (`Msg "could not determine the root of the reference") | Some key -> ( match Hashtbl.find_all scan.odocl key with | [] -> Error (`Msg (Printf.sprintf "reference %S resolved, but no linked documentation for it \ was found in the switch" ref_str)) | candidates -> ( (* Prefer the file that actually owns the identifier; fall back to the first loadable candidate if the keying scheme ever changes. *) let rec pick fallback = function | [] -> fallback | path :: rest -> ( match load_content path with | Some c when owns id c -> Some c | Some c -> pick (Option.value fallback ~default:c |> Option.some) rest | None -> pick fallback rest) in match pick None candidates with | Some c -> Ok c | None -> Error (`Msg (Printf.sprintf "could not load linked documentation for %s" ref_str))))