From 7e4e716a5f03c8ed92f44665d133372ac53a3814 Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Mon, 30 Oct 2023 12:08:35 +0100 Subject: [PATCH 01/41] Ident_env: Turn all maps into hashtbl OCaml Idents are unique, so there is no risk with keeping "out of scope" idents. However, it is practical to keep the full environment at the end of a traverse, for render source code purpose. Signed-off-by: Paul-Elliot --- src/loader/cmi.ml | 17 +-- src/loader/cmt.ml | 17 +-- src/loader/cmti.ml | 10 +- src/loader/ident_env.cppo.ml | 196 ++++++++++++++++++---------------- src/loader/ident_env.cppo.mli | 8 +- src/loader/implementation.ml | 19 ++-- 6 files changed, 139 insertions(+), 128 deletions(-) diff --git a/src/loader/cmi.ml b/src/loader/cmi.ml index 88576665ae..8365e5b22a 100644 --- a/src/loader/cmi.ml +++ b/src/loader/cmi.ml @@ -924,17 +924,18 @@ let rec read_module_type env parent (mty : Odoc_model.Compat.module_type) = | Mty_ident p -> Path {p_path = Env.Path.read_module_type env p; p_expansion=None } | Mty_signature sg -> Signature (read_signature env parent sg) | Mty_functor(parameter, res) -> - let f_parameter, env = + let f_parameter = match parameter with - | Unit -> Odoc_model.Lang.FunctorParameter.Unit, env + | Unit -> Odoc_model.Lang.FunctorParameter.Unit | Named (id_opt, arg) -> - let id, env = match id_opt with - | None -> Identifier.Mk.parameter(parent, Odoc_model.Names.ModuleName.make_std "_"), env - | Some id -> let env = Env.add_parameter parent id (ModuleName.of_ident id) env in - Ident_env.find_parameter_identifier env id, env + let id = match id_opt with + | None -> Identifier.Mk.parameter(parent, Odoc_model.Names.ModuleName.make_std "_") + | Some id -> + let () = Env.add_parameter parent id (ModuleName.of_ident id) env in + Ident_env.find_parameter_identifier env id in let arg = read_module_type env (id :> Identifier.Signature.t) arg in - Odoc_model.Lang.FunctorParameter.Named ({ FunctorParameter. id; expr = arg }), env + Odoc_model.Lang.FunctorParameter.Named ({ FunctorParameter. id; expr = arg }) in let res = read_module_type env (Identifier.Mk.result parent) res in Functor( f_parameter, res) @@ -1082,7 +1083,7 @@ and read_signature_noenv env parent (items : Odoc_model.Compat.signature) = loop ([],{s_modules=[]; s_module_types=[]; s_values=[];s_types=[]; s_classes=[]; s_class_types=[]}) items and read_signature env parent (items : Odoc_model.Compat.signature) = - let env = Env.handle_signature_type_items parent items env in + let () = Env.handle_signature_type_items parent items env in fst @@ read_signature_noenv env parent items diff --git a/src/loader/cmt.ml b/src/loader/cmt.ml index 34d8a5d7da..682333588a 100644 --- a/src/loader/cmt.ml +++ b/src/loader/cmt.ml @@ -363,19 +363,20 @@ let rec read_module_expr env parent label_parent mexpr = Signature sg #if OCAML_VERSION >= (4,10,0) | Tmod_functor(parameter, res) -> - let f_parameter, env = + let f_parameter = match parameter with - | Unit -> FunctorParameter.Unit, env + | Unit -> FunctorParameter.Unit | Named (id_opt, _, arg) -> - let id, env = + let id = match id_opt with - | None -> Identifier.Mk.parameter (parent, Odoc_model.Names.ModuleName.make_std "_"), env - | Some id -> let env = Env.add_parameter parent id (ModuleName.of_ident id) env in - Env.find_parameter_identifier env id, env + | None -> Identifier.Mk.parameter (parent, Odoc_model.Names.ModuleName.make_std "_") + | Some id -> + let () = Env.add_parameter parent id (ModuleName.of_ident id) env in + Env.find_parameter_identifier env id in let arg = Cmti.read_module_type env (id :> Identifier.Signature.t) label_parent arg in - Named { id; expr=arg }, env + Named { id; expr=arg } in let res = read_module_expr env (Identifier.Mk.result parent) label_parent res in Functor (f_parameter, res) @@ -576,7 +577,7 @@ and read_structure : 'tags. 'tags Odoc_model.Semantics.handle_internal_tags -> _ -> _ -> _ -> _ * 'tags = fun internal_tags env parent str -> - let env = Env.add_structure_tree_items parent str env in + let () = Env.add_structure_tree_items parent str env in let items, (doc, doc_post), tags = let classify item = match item.str_desc with diff --git a/src/loader/cmti.ml b/src/loader/cmti.ml index b7108f5eda..870cd18f69 100644 --- a/src/loader/cmti.ml +++ b/src/loader/cmti.ml @@ -517,12 +517,12 @@ and read_module_type env parent label_parent mty = match parameter with | Unit -> FunctorParameter.Unit, env | Named (id_opt, _, arg) -> - let id, env = + let id = match id_opt with - | None -> Identifier.Mk.parameter (parent, ModuleName.make_std "_"), env + | None -> Identifier.Mk.parameter (parent, ModuleName.make_std "_") | Some id -> - let env = Env.add_parameter parent id (ModuleName.of_ident id) env in - Env.find_parameter_identifier env id, env + let () = Env.add_parameter parent id (ModuleName.of_ident id) env in + Env.find_parameter_identifier env id in let arg = read_module_type env (id :> Identifier.Signature.t) label_parent arg in Named { id; expr = arg; }, env @@ -772,7 +772,7 @@ and read_signature : 'tags. 'tags Odoc_model.Semantics.handle_internal_tags -> _ -> _ -> _ -> _ * 'tags = fun internal_tags env parent sg -> - let env = Env.add_signature_tree_items parent sg env in + let () = Env.add_signature_tree_items parent sg env in let items, (doc, doc_post), tags = let classify item = match item.sig_desc with diff --git a/src/loader/ident_env.cppo.ml b/src/loader/ident_env.cppo.ml index 0d2dea858f..bcda19b082 100644 --- a/src/loader/ident_env.cppo.ml +++ b/src/loader/ident_env.cppo.ml @@ -29,36 +29,42 @@ module LocHashtbl = Hashtbl.Make(struct let hash = Hashtbl.hash end) +module IdentHashtbl = Hashtbl.Make(struct + type t = Ident.t + let equal l1 l2 = l1 = l2 + let hash = Hashtbl.hash + end) + type t = - { modules : Id.Module.t Ident.tbl; - parameters : Id.FunctorParameter.t Ident.tbl; - module_paths : P.Module.t Ident.tbl; - module_types : Id.ModuleType.t Ident.tbl; - types : Id.DataType.t Ident.tbl; - exceptions: Id.Exception.t Ident.tbl; - extensions: Id.Extension.t Ident.tbl; - constructors: Id.Constructor.t Ident.tbl; - values: Id.Value.t Ident.tbl; - classes : Id.Class.t Ident.tbl; - class_types : Id.ClassType.t Ident.tbl; + { modules : Id.Module.t IdentHashtbl.t; + parameters : Id.FunctorParameter.t IdentHashtbl.t; + module_paths : P.Module.t IdentHashtbl.t; + module_types : Id.ModuleType.t IdentHashtbl.t; + types : Id.DataType.t IdentHashtbl.t; + exceptions: Id.Exception.t IdentHashtbl.t; + extensions: Id.Extension.t IdentHashtbl.t; + constructors: Id.Constructor.t IdentHashtbl.t; + values: Id.Value.t IdentHashtbl.t; + classes : Id.Class.t IdentHashtbl.t; + class_types : Id.ClassType.t IdentHashtbl.t; loc_to_ident : Id.t LocHashtbl.t; - hidden : Ident.t list; (* we use term hidden to mean shadowed and idents_in_doc_off_mode items*) + hidden : unit IdentHashtbl.t; (* we use term hidden to mean shadowed and idents_in_doc_off_mode items*) } let empty () = - { modules = Ident.empty; - parameters = Ident.empty; - module_paths = Ident.empty; - module_types = Ident.empty; - types = Ident.empty; - exceptions = Ident.empty; - constructors = Ident.empty; - extensions = Ident.empty; - values = Ident.empty; - classes = Ident.empty; - class_types = Ident.empty; + { modules = IdentHashtbl.create 10; + parameters = IdentHashtbl.create 10; + module_paths = IdentHashtbl.create 10; + module_types = IdentHashtbl.create 10; + types = IdentHashtbl.create 10; + exceptions = IdentHashtbl.create 10; + constructors = IdentHashtbl.create 10; + extensions = IdentHashtbl.create 10; + values = IdentHashtbl.create 10; + classes = IdentHashtbl.create 10; + class_types = IdentHashtbl.create 10; loc_to_ident = LocHashtbl.create 100; - hidden = []; + hidden = IdentHashtbl.create 100; } (* The boolean is an override for whether it should be hidden - true only for @@ -481,84 +487,84 @@ let class_name_exists name items = let class_type_name_exists name items = List.exists (function | `ClassType (id',_,_,_,_) when Ident.name id' = name -> true | _ -> false) items -let add_items : Id.Signature.t -> item list -> t -> t = fun parent items env -> +let add_items : Id.Signature.t -> item list -> t -> unit = fun parent items env -> let open Odoc_model.Paths.Identifier in let rec inner items env = match items with | `Type (t, is_hidden_item, loc) :: rest -> let name = Ident.name t in let is_hidden = is_hidden_item || type_name_exists name rest in - let identifier, hidden = + let identifier = if is_hidden - then Mk.type_(parent, TypeName.internal_of_string name), t :: env.hidden - else Mk.type_(parent, TypeName.make_std name), env.hidden + then (IdentHashtbl.add env.hidden t (); Mk.type_(parent, TypeName.internal_of_string name)) + else Mk.type_(parent, TypeName.make_std name) in - let types = Ident.add t identifier env.types in + let () = IdentHashtbl.add env.types t identifier in (match loc with | Some l -> LocHashtbl.add env.loc_to_ident l (identifier :> Id.any) | _ -> ()); - inner rest { env with types; hidden } + inner rest env | `Constructor (t, t_parent, loc) :: rest -> let name = Ident.name t in let identifier = - let parent = Ident.find_same t_parent env.types in + let parent = IdentHashtbl.find env.types t_parent in Mk.constructor(parent, ConstructorName.make_std name) in - let constructors = Ident.add t identifier env.constructors in + let () = IdentHashtbl.add env.constructors t identifier in (match loc with | Some l -> LocHashtbl.add env.loc_to_ident l (identifier :> Id.any) | _ -> ()); - inner rest { env with constructors } + inner rest env | `Exception (t, loc) :: rest -> let name = Ident.name t in let identifier = Mk.exception_(parent, ExceptionName.make_std name) in (match loc with | Some l -> LocHashtbl.add env.loc_to_ident l (identifier :> Id.any) | _ -> ()); - let exceptions = Ident.add t identifier env.exceptions in - inner rest {env with exceptions } + let () = IdentHashtbl.add env.exceptions t identifier in + inner rest env | `Extension (t, loc) :: rest -> let name = Ident.name t in let identifier = Mk.extension(parent, ExtensionName.make_std name) in (match loc with | Some l -> LocHashtbl.add env.loc_to_ident l (identifier :> Id.any) | _ -> ()); - let extensions = Ident.add t identifier env.extensions in - inner rest {env with extensions } + let () = IdentHashtbl.add env.extensions t identifier in + inner rest env | `Value (t, is_hidden_item, loc) :: rest -> let name = Ident.name t in let is_hidden = is_hidden_item || value_name_exists name rest in - let identifier, hidden = + let identifier = if is_hidden - then Mk.value(parent, ValueName.internal_of_string name), t :: env.hidden - else Mk.value(parent, ValueName.make_std name), env.hidden + then (IdentHashtbl.add env.hidden t (); Mk.value(parent, ValueName.internal_of_string name)) + else Mk.value(parent, ValueName.make_std name) in - let values = Ident.add t identifier env.values in + let () = IdentHashtbl.add env.values t identifier in (match loc with | Some l -> LocHashtbl.add env.loc_to_ident l (identifier :> Id.any) | _ -> ()); - inner rest { env with values; hidden } + inner rest env | `ModuleType (t, is_hidden_item, loc) :: rest -> let name = Ident.name t in let is_hidden = is_hidden_item || module_type_name_exists name rest in - let identifier, hidden = + let identifier = if is_hidden - then Mk.module_type(parent, ModuleTypeName.internal_of_string name), t :: env.hidden - else Mk.module_type(parent, ModuleTypeName.make_std name), env.hidden + then (IdentHashtbl.add env.hidden t (); Mk.module_type(parent, ModuleTypeName.internal_of_string name)) + else Mk.module_type(parent, ModuleTypeName.make_std name) in - let module_types = Ident.add t identifier env.module_types in + let () = IdentHashtbl.add env.module_types t identifier in (match loc with | Some l -> LocHashtbl.add env.loc_to_ident l (identifier :> Id.any) | _ -> ()); - inner rest { env with module_types; hidden } + inner rest env | `Module (t, is_hidden_item, loc) :: rest -> let name = Ident.name t in let double_underscore = Odoc_model.Root.contains_double_underscore name in let is_hidden = is_hidden_item || module_name_exists name rest || double_underscore in - let identifier, hidden = - if is_hidden - then Mk.module_(parent, ModuleName.internal_of_string name), t :: env.hidden - else Mk.module_(parent, ModuleName.make_std name), env.hidden + let identifier = + if is_hidden + then (IdentHashtbl.add env.hidden t (); Mk.module_(parent, ModuleName.internal_of_string name)) + else Mk.module_(parent, ModuleName.make_std name) in let path = `Identifier(identifier, is_hidden) in - let modules = Ident.add t identifier env.modules in - let module_paths = Ident.add t path env.module_paths in + let () = IdentHashtbl.add env.modules t identifier in + let () = IdentHashtbl.add env.module_paths t path in (match loc with | Some l -> LocHashtbl.add env.loc_to_ident l (identifier :> Id.any) | _ -> ()); - inner rest { env with modules; module_paths; hidden } + inner rest env | `Class (t,t2,t3,t4, is_hidden_item, loc) :: rest -> let name = Ident.name t in @@ -567,19 +573,21 @@ let add_items : Id.Signature.t -> item list -> t -> t = fun parent items env -> | None -> [t;t2;t3] | Some t4 -> [t;t2;t3;t4] in - let identifier, hidden = + let identifier = if is_hidden - then Mk.class_(parent, ClassName.internal_of_string name), class_types @ env.hidden - else Mk.class_(parent, ClassName.make_std name), env.hidden + then ( + List.iter (fun t -> IdentHashtbl.add env.hidden t ()) class_types; + Mk.class_(parent, ClassName.internal_of_string name)) + else Mk.class_(parent, ClassName.make_std name) in - let classes = - List.fold_right (fun id classes -> Ident.add id identifier classes) - class_types env.classes in + let () = + List.fold_right (fun id () -> IdentHashtbl.add env.classes id identifier) + class_types () in (match loc with | Some l -> LocHashtbl.add env.loc_to_ident l (identifier :> Id.any) | _ -> ()); - inner rest { env with classes; hidden } + inner rest env | `ClassType (t,t2,t3, is_hidden_item, loc) :: rest -> let name = Ident.name t in @@ -588,18 +596,20 @@ let add_items : Id.Signature.t -> item list -> t -> t = fun parent items env -> | None -> [t;t2] | Some t3 -> [t;t2;t3] in - let identifier, hidden = + let identifier = if is_hidden - then Mk.class_type(parent, ClassTypeName.internal_of_string name), class_types @ env.hidden - else Mk.class_type(parent, ClassTypeName.make_std name), env.hidden + then ( + List.iter (fun t -> IdentHashtbl.add env.hidden t ()) class_types; + Mk.class_type(parent, ClassTypeName.internal_of_string name)) + else Mk.class_type(parent, ClassTypeName.make_std name) in - let class_types = - List.fold_right (fun id class_types -> Ident.add id identifier class_types) - class_types env.class_types in + let () = + List.fold_right (fun id () -> IdentHashtbl.add env.class_types id identifier) + class_types () in (match loc with | Some l -> LocHashtbl.add env.loc_to_ident l (identifier :> Id.any) | _ -> ()); - inner rest { env with class_types; hidden } + inner rest env - | [] -> env + | [] -> () in inner items env let identifier_of_loc : t -> Location.t -> Odoc_model.Paths.Identifier.t option = fun env loc -> @@ -608,17 +618,17 @@ let identifier_of_loc : t -> Location.t -> Odoc_model.Paths.Identifier.t option let iter_located_identifier : t -> (Location.t -> Odoc_model.Paths.Identifier.t -> unit) -> unit = fun env f -> LocHashtbl.iter f env.loc_to_ident -let add_signature_tree_items : Paths.Identifier.Signature.t -> Typedtree.signature -> t -> t = +let add_signature_tree_items : Paths.Identifier.Signature.t -> Typedtree.signature -> t -> unit = fun parent sg env -> let items = extract_signature_tree_items false sg.sig_items |> flatten_includes in add_items parent items env -let add_structure_tree_items : Paths.Identifier.Signature.t -> Typedtree.structure -> t -> t = +let add_structure_tree_items : Paths.Identifier.Signature.t -> Typedtree.structure -> t -> unit = fun parent sg env -> let items = extract_structure_tree_items false sg.str_items |> flatten_includes in add_items parent items env -let handle_signature_type_items : Paths.Identifier.Signature.t -> Compat.signature -> t -> t = +let handle_signature_type_items : Paths.Identifier.Signature.t -> Compat.signature -> t -> unit = fun parent sg env -> let items = extract_signature_type_items sg in add_items parent items env @@ -627,47 +637,47 @@ let add_parameter parent id name env = let hidden = ModuleName.is_hidden name in let oid = Odoc_model.Paths.Identifier.Mk.parameter(parent, name) in let path = `Identifier (oid, hidden) in - let module_paths = Ident.add id path env.module_paths in - let modules = Ident.add id oid env.modules in - let parameters = Ident.add id oid env.parameters in - { env with module_paths; modules; parameters } + let () = IdentHashtbl.add env.module_paths id path in + let () = IdentHashtbl.add env.modules id oid in + let () = IdentHashtbl.add env.parameters id oid in + () let find_module env id = - Ident.find_same id env.module_paths + IdentHashtbl.find env.module_paths id let find_module_identifier env id = - Ident.find_same id env.modules + IdentHashtbl.find env.modules id let find_parameter_identifier env id = - Ident.find_same id env.parameters + IdentHashtbl.find env.parameters id let find_module_type env id = - Ident.find_same id env.module_types + IdentHashtbl.find env.module_types id let find_type_identifier env id = - Ident.find_same id env.types + IdentHashtbl.find env.types id let find_constructor_identifier env id = - Ident.find_same id env.constructors + IdentHashtbl.find env.constructors id let find_exception_identifier env id = - Ident.find_same id env.exceptions + IdentHashtbl.find env.exceptions id let find_extension_identifier env id = - Ident.find_same id env.extensions + IdentHashtbl.find env.extensions id let find_value_identifier env id = - Ident.find_same id env.values + IdentHashtbl.find env.values id let find_type env id = try - (Ident.find_same id env.types :> Id.Path.Type.t) + (IdentHashtbl.find env.types id :> Id.Path.Type.t) with Not_found -> try - (Ident.find_same id env.classes :> Id.Path.Type.t) + (IdentHashtbl.find env.classes id :> Id.Path.Type.t) with Not_found -> try - (Ident.find_same id env.class_types :> Id.Path.Type.t) + (IdentHashtbl.find env.class_types id :> Id.Path.Type.t) with Not_found -> if List.mem id builtin_idents then match core_type_identifier (Ident.name id) with @@ -677,19 +687,19 @@ let find_type env id = let find_class_type env id = try - (Ident.find_same id env.classes :> Id.Path.ClassType.t) + (IdentHashtbl.find env.classes id :> Id.Path.ClassType.t) with Not_found -> - (Ident.find_same id env.class_types :> Id.Path.ClassType.t) + (IdentHashtbl.find env.class_types id :> Id.Path.ClassType.t) let find_class_identifier env id = - Ident.find_same id env.classes + IdentHashtbl.find env.classes id let find_class_type_identifier env id = - Ident.find_same id env.class_types + IdentHashtbl.find env.class_types id let is_shadowed env id = - List.mem id env.hidden + IdentHashtbl.mem env.hidden id module Path = struct let read_module_ident env id = diff --git a/src/loader/ident_env.cppo.mli b/src/loader/ident_env.cppo.mli index 2be505ca18..076421173c 100644 --- a/src/loader/ident_env.cppo.mli +++ b/src/loader/ident_env.cppo.mli @@ -21,16 +21,16 @@ type t val empty : unit -> t val add_parameter : - Paths.Identifier.Signature.t -> Ident.t -> Names.ModuleName.t -> t -> t + Paths.Identifier.Signature.t -> Ident.t -> Names.ModuleName.t -> t -> unit val handle_signature_type_items : - Paths.Identifier.Signature.t -> Compat.signature -> t -> t + Paths.Identifier.Signature.t -> Compat.signature -> t -> unit val add_signature_tree_items : - Paths.Identifier.Signature.t -> Typedtree.signature -> t -> t + Paths.Identifier.Signature.t -> Typedtree.signature -> t -> unit val add_structure_tree_items : - Paths.Identifier.Signature.t -> Typedtree.structure -> t -> t + Paths.Identifier.Signature.t -> Typedtree.structure -> t -> unit module Path : sig val read_module : t -> Path.t -> Paths.Path.Module.t diff --git a/src/loader/implementation.ml b/src/loader/implementation.ml index 6b8bc6c9f6..c743438788 100644 --- a/src/loader/implementation.ml +++ b/src/loader/implementation.ml @@ -15,12 +15,12 @@ module Env = struct open Odoc_model.Paths let rec structure env parent str = - let env' = Ident_env.add_structure_tree_items parent str env in - List.iter (structure_item env' parent) str.str_items + let () = Ident_env.add_structure_tree_items parent str env in + List.iter (structure_item env parent) str.str_items and signature env parent sg = - let env' = Ident_env.add_signature_tree_items parent sg env in - List.iter (signature_item env' parent) sg.sig_items + let () = Ident_env.add_signature_tree_items parent sg env in + List.iter (signature_item env parent) sg.sig_items and signature_item env parent item = match item.sig_desc with @@ -95,20 +95,19 @@ module Env = struct | Tmod_structure str -> structure env parent str | Tmod_functor (parameter, res) -> let open Odoc_model.Names in - let env = + let () = match parameter with - | Unit -> env + | Unit -> () | Named (id_opt, _, arg) -> ( match id_opt with | Some id -> - let env = + let () = Ident_env.add_parameter parent id (ModuleName.of_ident id) env in let id = Ident_env.find_module_identifier env id in - module_type env (id :> Identifier.Signature.t) arg; - env - | None -> env) + module_type env (id :> Identifier.Signature.t) arg + | None -> ()) in module_expr env (Odoc_model.Paths.Identifier.Mk.result parent) res | Tmod_constraint (me, _, constr, _) -> From 2666d1e18d10e6de6ad954bea7b66838cc998524 Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Tue, 23 May 2023 11:16:36 +0200 Subject: [PATCH 02/41] Collect occurrences info Signed-off-by: Paul-Elliot --- doc/driver.mld | 17 +++- src/document/generator.ml | 36 +++++-- src/document/types.ml | 6 +- src/html/html_source.ml | 28 +++++- src/html_support_files/odoc.css | 10 +- src/loader/ident_env.cppo.ml | 15 +++ src/loader/ident_env.cppo.mli | 2 + src/loader/implementation.ml | 85 +++++++++++----- src/loader/implementation.mli | 1 + src/loader/odoc_loader.ml | 23 ++--- src/loader/odoc_loader.mli | 2 + src/loader/typedtree_traverse.ml | 102 ++++++++++++++++---- src/model/lang.ml | 20 +++- src/model/paths.ml | 11 ++- src/model/paths.mli | 8 -- src/model/paths_types.ml | 8 +- src/model_desc/lang_desc.ml | 2 +- src/odoc/bin/main.ml | 38 +++++++- src/odoc/compile.ml | 9 +- src/odoc/compile.mli | 1 + src/odoc/html_page.ml | 8 +- src/odoc/occurrences.ml | 58 +++++++++++ src/xref2/compile.ml | 23 ++++- src/xref2/component.ml | 27 ++++-- src/xref2/cpath.ml | 6 +- src/xref2/env.ml | 4 +- src/xref2/errors.ml | 2 +- src/xref2/find.ml | 5 +- src/xref2/lang_of.ml | 6 +- src/xref2/link.ml | 62 ++++++++++-- src/xref2/shape_tools.cppo.ml | 56 ++++++++++- src/xref2/shape_tools.cppo.mli | 5 + src/xref2/tools.ml | 48 +++++++-- test/occurrences/double_wrapped.t/a.ml | 7 ++ test/occurrences/double_wrapped.t/b.ml | 13 +++ test/occurrences/double_wrapped.t/c.ml | 3 + test/occurrences/double_wrapped.t/main.ml | 5 + test/occurrences/double_wrapped.t/main__.ml | 10 ++ test/occurrences/double_wrapped.t/root.mld | 1 + test/occurrences/double_wrapped.t/run.t | 59 +++++++++++ test/occurrences/dune | 11 +++ test/occurrences/source.t/a.ml | 1 + test/occurrences/source.t/b.ml | 1 + test/occurrences/source.t/root.mld | 1 + test/occurrences/source.t/run.t | 38 ++++++++ test/odoc_print/dune | 12 +-- test/odoc_print/occurrences_print.ml | 27 ++++++ test/sources/functor.t/run.t | 8 ++ test/sources/lookup_def.t/run.t | 2 + test/sources/recursive_module.t/run.t | 8 ++ test/sources/source.t/run.t | 25 ++++- 51 files changed, 828 insertions(+), 138 deletions(-) create mode 100644 src/odoc/occurrences.ml create mode 100644 test/occurrences/double_wrapped.t/a.ml create mode 100644 test/occurrences/double_wrapped.t/b.ml create mode 100644 test/occurrences/double_wrapped.t/c.ml create mode 100644 test/occurrences/double_wrapped.t/main.ml create mode 100644 test/occurrences/double_wrapped.t/main__.ml create mode 100644 test/occurrences/double_wrapped.t/root.mld create mode 100644 test/occurrences/double_wrapped.t/run.t create mode 100644 test/occurrences/dune create mode 100644 test/occurrences/source.t/a.ml create mode 100644 test/occurrences/source.t/b.ml create mode 100644 test/occurrences/source.t/root.mld create mode 100644 test/occurrences/source.t/run.t create mode 100644 test/odoc_print/occurrences_print.ml diff --git a/doc/driver.mld b/doc/driver.mld index 6c0559f9f3..e56839fb10 100644 --- a/doc/driver.mld +++ b/doc/driver.mld @@ -135,7 +135,8 @@ Compiling a file with [odoc] requires a few arguments: the file to compile, an optional parent, a list of include paths, a list of children for [.mld] files, optional parent and name for source implementation, and an output path. Include paths can be just ['.'], and we can calculate the output file from the input -because all of the files are going into the same directory. +because all of the files are going into the same directory. If we wish to count +occurrences of each identifier, we need to pass the [--count-occurrences] flag. Linking a file with [odoc] requires the input file and a list of include paths. As for compile, we will hard-code the include path. @@ -148,6 +149,9 @@ Using the [--source] argument with an [.odocl] file that was not compiled with [--source-parent-file] and [--source-name] will result in an error, as will omitting [--source] when generating HTML of an [odocl] that was compiled with [--source-parent-file] and [--source-name]. +To get the number of uses of each identifier, we can use the [count-occurrences] +command. + In all of these, we'll capture [stdout] and [stderr] so we can check it later. {[ @@ -209,7 +213,7 @@ let add_prefixed_output cmd list prefix lines = !list @ Bos.Cmd.to_string cmd :: List.map (fun l -> prefix ^ ": " ^ l) lines -let compile file ?parent ?(output_dir = Fpath.v "./") +let compile file ?(count_occurrences = true) ?parent ?(output_dir = Fpath.v "./") ?(ignore_output = false) ?source_args children = let output_basename = let ext = Fpath.get_ext file in @@ -237,8 +241,9 @@ let compile file ?parent ?(output_dir = Fpath.v "./") | _ -> Cmd.empty else Cmd.empty in + let occ = if count_occurrences then Cmd.v "--count-occurrences" else Cmd.empty in let cmd = - odoc % "compile" % Fpath.to_string file %% source_args %% cmt_arg + odoc % "compile" % Fpath.to_string file %% source_args %% occ %% cmt_arg % "-I" % "." % "-o" % p output_file |> List.fold_right (fun child cmd -> cmd % "--child" % child) children in @@ -289,6 +294,11 @@ let support_files () = let open Cmd in let cmd = odoc % "support-files" % "-o" % "html/odoc" in run cmd + +let count_occurrences output = + let open Cmd in + let cmd = odoc % "count-occurrences" % "-I" % "." % "-o" % p output in + run cmd ]} @@ -750,6 +760,7 @@ let compiled = compile_all () in let linked = link_all compiled in let () = index_generate () in let _ = js_index () in +let _ = count_occurrences (Fpath.v "occurrences.txt") in generate_all linked ]} diff --git a/src/document/generator.ml b/src/document/generator.ml index d5babb232f..bb411cacfb 100644 --- a/src/document/generator.ml +++ b/src/document/generator.ml @@ -252,18 +252,42 @@ module Make (Syntax : SYNTAX) = struct let path id = Url.Path.from_identifier id let url id = Url.from_path (path id) + let to_link documentation implementation = + let documentation = + let open Paths.Path.Resolved in + match documentation with + | Some (`Resolved p) when not (is_hidden (p :> t)) -> ( + let id = identifier (p :> t) in + match Url.from_identifier ~stop_before:false id with + | Ok link -> Some link + | _ -> None) + | _ -> None + in + let implementation = + match implementation with + | Some (Odoc_model.Lang.Source_info.Resolved id) -> ( + match Url.Anchor.from_identifier (id :> Paths.Identifier.t) with + | Ok url -> Some url + | Error _ -> None) + | _ -> None + in + Some (Source_page.Link { implementation; documentation }) + let info_of_info : Lang.Source_info.annotation -> Source_page.info option = function - | Value id -> ( - match Url.Anchor.from_identifier (id :> Paths.Identifier.t) with - | Ok url -> Some (Link url) - | Error _ -> None) | Definition id -> ( match id.iv with | `SourceLocation (_, def) -> Some (Anchor (DefName.to_string def)) | `SourceLocationInternal (_, local) -> Some (Anchor (LocalName.to_string local)) | _ -> None) + | Module { documentation; _ } -> to_link documentation None + | ModuleType { documentation; _ } -> to_link documentation None + | Type { documentation; _ } -> to_link documentation None + | ClassType { documentation; _ } -> to_link documentation None + | Value { documentation; implementation } -> + to_link documentation implementation + | Constructor { documentation; _ } -> to_link documentation None let source id syntax_info infos source_code = let url = path id in @@ -1784,8 +1808,8 @@ module Make (Syntax : SYNTAX) = struct in let source_anchor = match t.source_info with - | Some src -> Some (Source_page.url src.id) - | None -> None + | Some { id = Some id; _ } -> Some (Source_page.url id) + | _ -> None in let page = make_expansion_page ~source_anchor url [ unit_doc ] items in Document.Page page diff --git a/src/document/types.ml b/src/document/types.ml index 2053ce902e..34e9b502d9 100644 --- a/src/document/types.ml +++ b/src/document/types.ml @@ -183,7 +183,11 @@ end = Page and Source_page : sig - type info = Syntax of string | Anchor of string | Link of Url.Anchor.t + type target = { + documentation : Url.Anchor.t option; + implementation : Url.Anchor.t option; + } + type info = Syntax of string | Anchor of string | Link of target type code = span list and span = Tagged_code of info * code | Plain_code of string diff --git a/src/html/html_source.ml b/src/html/html_source.ml index ab08665780..edd3cd32d4 100644 --- a/src/html/html_source.ml +++ b/src/html/html_source.ml @@ -24,9 +24,31 @@ let html_of_doc ~config ~resolve docs = let children = List.concat @@ List.map (doc_to_html ~is_in_a) docs in match info with | Syntax tok -> [ span ~a:[ a_class [ tok ] ] children ] - | Link anchor -> - let href = Link.href ~config ~resolve anchor in - [ a ~a:[ a_href href ] children ] + | Link { documentation; implementation } -> ( + let href_implementation = + Option.map (Link.href ~config ~resolve) implementation + in + let href_documentation = + Option.map (Link.href ~config ~resolve) documentation + in + let body = + match href_implementation with + | Some href -> [ a ~a:[ a_href href ] children ] + | None -> children + in + match href_documentation with + | None -> body + | Some href -> + [ + span + ~a:[ a_class [ "jump-to-doc-container" ] ] + [ + span ~a:[] body; + a + ~a:[ a_href href; a_class [ "jump-to-doc" ] ] + [ txt " 📖" ]; + ]; + ]) | Anchor lbl -> [ span ~a:[ a_id lbl ] children ]) in span ~a:[] @@ List.concat @@ List.map (doc_to_html ~is_in_a:false) docs diff --git a/src/html_support_files/odoc.css b/src/html_support_files/odoc.css index 4aecd851bb..228fcf4287 100644 --- a/src/html_support_files/odoc.css +++ b/src/html_support_files/odoc.css @@ -1206,6 +1206,14 @@ td.def-doc *:first-child { color: #657b83; } +.jump-to-doc-container:hover .jump-to-doc { + display: inline; +} + +.jump-to-doc { + display: none; +} + /* Source directories */ .odoc-directory::before { @@ -1390,4 +1398,4 @@ td.def-doc *:first-child { 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. - ---------------------------------------------------------------------------*/ \ No newline at end of file + ---------------------------------------------------------------------------*/ diff --git a/src/loader/ident_env.cppo.ml b/src/loader/ident_env.cppo.ml index bcda19b082..6e5094306b 100644 --- a/src/loader/ident_env.cppo.ml +++ b/src/loader/ident_env.cppo.ml @@ -718,6 +718,9 @@ module Path = struct `Identifier (find_type env id, false) with Not_found -> assert false + let read_value_ident env id : Paths.Path.Value.t = + `Identifier (find_value_identifier env id, false) + let read_class_type_ident env id : Paths.Path.ClassType.t = try `Identifier (find_class_type env id, false) @@ -796,6 +799,18 @@ module Path = struct | Path.Pextra_ty (p,_) -> read_type env p #endif + let read_value env = function + | Path.Pident id -> read_value_ident env id +#if OCAML_VERSION >= (4,8,0) + | Path.Pdot(p, s) -> `Dot(read_module env p, s) +#else + | Path.Pdot(p, s, _) -> `Dot(read_module env p, s) +#endif + | Path.Papply(_, _) -> assert false +#if OCAML_VERSION >= (5,1,0) + | Path.Pextra_ty _ -> assert false +#endif + end module Fragment = struct diff --git a/src/loader/ident_env.cppo.mli b/src/loader/ident_env.cppo.mli index 076421173c..c17f827bf3 100644 --- a/src/loader/ident_env.cppo.mli +++ b/src/loader/ident_env.cppo.mli @@ -40,6 +40,8 @@ module Path : sig val read_type : t -> Path.t -> Paths.Path.Type.t val read_class_type : t -> Path.t -> Paths.Path.ClassType.t + + val read_value : t -> Path.t -> Paths.Path.Value.t end val find_module : t -> Ident.t -> Paths.Path.Module.t diff --git a/src/loader/implementation.ml b/src/loader/implementation.ml index c743438788..344f8fab79 100644 --- a/src/loader/implementation.ml +++ b/src/loader/implementation.ml @@ -147,7 +147,7 @@ module UidHashtbl = Shape.Uid.Tbl (* Adds the local definitions found in traverse infos to the [loc_to_id] and [ident_to_id] tables. *) -let populate_local_defs source_id poses loc_to_id ident_to_id = +let populate_local_defs source_id poses loc_to_id ident_to_loc = List.iter (function | Typedtree_traverse.Analysis.Definition id, loc -> @@ -155,11 +155,15 @@ let populate_local_defs source_id poses loc_to_id ident_to_id = Odoc_model.Names.LocalName.make_std (Printf.sprintf "local_%s_%d" (Ident.name id) (counter ())) in - let identifier = - Odoc_model.Paths.Identifier.Mk.source_location_int (source_id, name) - in - IdentHashtbl.add ident_to_id id identifier; - LocHashtbl.add loc_to_id loc identifier + (match source_id with + Some source_id -> + let identifier = + Odoc_model.Paths.Identifier.Mk.source_location_int (source_id, name) + in + LocHashtbl.add loc_to_id loc identifier + | None -> () + ); + IdentHashtbl.add ident_to_loc id loc; | _ -> ()) poses @@ -245,6 +249,7 @@ let anchor_of_identifier id = (* Adds the global definitions, found in the [uid_to_loc], to the [loc_to_id] and [uid_to_id] tables. *) let populate_global_defs env source_id loc_to_id uid_to_loc uid_to_id = + match source_id with None -> () | Some source_id -> let mk_src_id id = let name = Odoc_model.Names.DefName.make_std (anchor_of_identifier id) in (Odoc_model.Paths.Identifier.Mk.source_location (source_id, name) @@ -278,23 +283,54 @@ let populate_global_defs env source_id loc_to_id uid_to_loc uid_to_id = | _ -> ())) uid_to_loc +let (>>=) a b = Option.map b a + (* Extract [Typedtree_traverse] occurrence information and turn them into proper source infos *) -let process_occurrences poses uid_to_id ident_to_id = +let process_occurrences env poses loc_to_id ident_to_loc = + let open Odoc_model.Lang.Source_info in + let process p find_in_env = + match p with + | Path.Pident id when IdentHashtbl.mem ident_to_loc id -> ( + match + LocHashtbl.find_opt loc_to_id (IdentHashtbl.find ident_to_loc id) + with + | None -> None + | Some id -> + let documentation = None and implementation = Some (Resolved id) in + Some { documentation; implementation }) + | p -> ( + match find_in_env env p with + | path -> + let documentation = Some path + and implementation = Some (Unresolved path) in + Some { documentation; implementation } + | exception _ -> None) + in List.filter_map (function - | Typedtree_traverse.Analysis.Value (LocalValue uniq), loc -> ( - match IdentHashtbl.find_opt ident_to_id uniq with - | Some anchor -> - Some (Odoc_model.Lang.Source_info.Value anchor, pos_of_loc loc) - | None -> None) - | Value (DefJmp x), loc -> ( - match UidHashtbl.find_opt uid_to_id x with - | Some id -> Some (Value id, pos_of_loc loc) - | None -> None) + | Typedtree_traverse.Analysis.Value p, loc -> + process p Ident_env.Path.read_value >>= fun l -> + (Value l, pos_of_loc loc) + | Module p, loc -> + process p Ident_env.Path.read_module >>= fun l -> + (Module l, pos_of_loc loc) + | ClassType p, loc -> + process p Ident_env.Path.read_class_type >>= fun l -> + (ClassType l, pos_of_loc loc) + | ModuleType p, loc -> + process p Ident_env.Path.read_module_type >>= fun l -> + (ModuleType l, pos_of_loc loc) + | Type p, loc -> + process p Ident_env.Path.read_type >>= fun l -> + (Type l, pos_of_loc loc) + | Constructor _p, loc -> + (* process p Ident_env.Path.read_constructor *) None >>= fun l -> + (Constructor l, pos_of_loc loc) | Definition _, _ -> None) poses + (* Add definition source info from the [loc_to_id] table *) let add_definitions loc_to_id occurrences = LocHashtbl.fold @@ -302,30 +338,31 @@ let add_definitions loc_to_id occurrences = (Odoc_model.Lang.Source_info.Definition id, pos_of_loc loc) :: acc) loc_to_id occurrences -let read_cmt_infos source_id_opt id cmt_info = +let read_cmt_infos source_id_opt id cmt_info ~count_occurrences = match Odoc_model.Compat.shape_of_cmt_infos cmt_info with | Some shape -> ( let uid_to_loc = cmt_info.cmt_uid_to_loc in - match (source_id_opt, cmt_info.cmt_annots) with - | Some source_id, Implementation impl -> + match (source_id_opt, count_occurrences, cmt_info.cmt_annots) with + | (Some _ as source_id), _, Implementation impl + | source_id, true, Implementation impl -> let env = Env.of_structure id impl in let traverse_infos = - Typedtree_traverse.of_cmt env uid_to_loc impl |> List.rev + Typedtree_traverse.of_cmt env impl |> List.rev (* Information are accumulated in a list. We need to have the first info first in the list, to assign anchors with increasing numbers, so that adding some content at the end of a file does not modify the anchors for existing anchors. *) in let loc_to_id = LocHashtbl.create 10 - and ident_to_id = IdentHashtbl.create 10 + and ident_to_loc = IdentHashtbl.create 10 and uid_to_id = UidHashtbl.create 10 in let () = (* populate [loc_to_id], [ident_to_id] and [uid_to_id] *) - populate_local_defs source_id traverse_infos loc_to_id ident_to_id; + populate_local_defs source_id traverse_infos loc_to_id ident_to_loc; populate_global_defs env source_id loc_to_id uid_to_loc uid_to_id in let source_infos = - process_occurrences traverse_infos uid_to_id ident_to_id + process_occurrences env traverse_infos loc_to_id ident_to_loc |> add_definitions loc_to_id in ( Some (shape, Shape.Uid.Tbl.to_map uid_to_id), @@ -334,7 +371,7 @@ let read_cmt_infos source_id_opt id cmt_info = Odoc_model.Lang.Source_info.id = source_id; infos = source_infos; } ) - | _, _ -> (Some (shape, Odoc_model.Compat.empty_map), None)) + | _, _, _ -> (Some (shape, Odoc_model.Compat.empty_map), None)) | None -> (None, None) #else diff --git a/src/loader/implementation.mli b/src/loader/implementation.mli index 49701e6dcc..88acd2030d 100644 --- a/src/loader/implementation.mli +++ b/src/loader/implementation.mli @@ -2,6 +2,7 @@ val read_cmt_infos : Odoc_model.Paths.Identifier.Id.source_page option -> Odoc_model.Paths.Identifier.Id.root_module -> Cmt_format.cmt_infos -> + count_occurrences:bool -> (Odoc_model.Compat.shape * Odoc_model.Paths.Identifier.Id.source_location Odoc_model.Compat.shape_uid_map) diff --git a/src/loader/odoc_loader.ml b/src/loader/odoc_loader.ml index a3f0cb8799..bdb3c177d0 100644 --- a/src/loader/odoc_loader.ml +++ b/src/loader/odoc_loader.ml @@ -42,12 +42,12 @@ exception Not_an_interface exception Make_root_error of string -let read_cmt_infos source_id_opt id ~filename () = +let read_cmt_infos source_id_opt id ~filename ~count_occurrences () = match Cmt_format.read_cmt filename with | exception Cmi_format.Error _ -> raise Corrupted | cmt_info -> ( match cmt_info.cmt_annots with - | Implementation _ -> Implementation.read_cmt_infos source_id_opt id cmt_info + | Implementation _ -> Implementation.read_cmt_infos source_id_opt id cmt_info ~count_occurrences | _ -> raise Not_an_implementation) @@ -99,7 +99,7 @@ let compilation_unit_of_sig ~make_root ~imports ~interface ?sourcefile ~name ~id make_compilation_unit ~make_root ~imports ~interface ?sourcefile ~name ~id ?canonical ?shape_info content -let read_cmti ~make_root ~parent ~filename ~cmt_filename_opt ~source_id_opt () = +let read_cmti ~make_root ~parent ~filename ~cmt_filename_opt ~source_id_opt ~count_occurrences () = let cmt_info = Cmt_format.read_cmt filename in match cmt_info.cmt_annots with | Interface intf -> ( @@ -116,15 +116,16 @@ let read_cmti ~make_root ~parent ~filename ~cmt_filename_opt ~source_id_opt () = let shape_info, source_info = match cmt_filename_opt with | Some cmt_filename -> - read_cmt_infos source_id_opt id ~filename:cmt_filename () - | None -> (None, None) + read_cmt_infos source_id_opt id ~filename:cmt_filename ~count_occurrences () + | None -> + (None, None) in compilation_unit_of_sig ~make_root ~imports:cmt_info.cmt_imports ~interface ~sourcefile ~name ~id ?shape_info ~source_info ?canonical sg) | _ -> raise Not_an_interface -let read_cmt ~make_root ~parent ~filename ~source_id_opt () = +let read_cmt ~make_root ~parent ~filename ~source_id_opt ~count_occurrences () = match Cmt_format.read_cmt filename with | exception Cmi_format.Error (Not_an_interface _) -> raise Not_an_implementation @@ -168,7 +169,7 @@ let read_cmt ~make_root ~parent ~filename ~source_id_opt () = | Implementation impl -> let id, sg, canonical = Cmt.read_implementation parent name impl in let shape_info, source_info = - read_cmt_infos source_id_opt id ~filename () + read_cmt_infos source_id_opt id ~filename ~count_occurrences () in compilation_unit_of_sig ~make_root ~imports ~interface ~sourcefile ~name ~id ?canonical ?shape_info ~source_info sg @@ -199,12 +200,12 @@ let wrap_errors ~filename f = | Not_an_interface -> not_an_interface filename | Make_root_error m -> error_msg filename m) -let read_cmti ~make_root ~parent ~filename ~source_id_opt ~cmt_filename_opt = +let read_cmti ~make_root ~parent ~filename ~source_id_opt ~cmt_filename_opt ~count_occurrences = wrap_errors ~filename - (read_cmti ~make_root ~parent ~filename ~source_id_opt ~cmt_filename_opt) + (read_cmti ~make_root ~parent ~filename ~source_id_opt ~cmt_filename_opt ~count_occurrences) -let read_cmt ~make_root ~parent ~filename ~source_id_opt = - wrap_errors ~filename (read_cmt ~make_root ~parent ~filename ~source_id_opt) +let read_cmt ~make_root ~parent ~filename ~source_id_opt ~count_occurrences = + wrap_errors ~filename (read_cmt ~make_root ~parent ~filename ~source_id_opt ~count_occurrences) let read_cmi ~make_root ~parent ~filename = wrap_errors ~filename (read_cmi ~make_root ~parent ~filename) diff --git a/src/loader/odoc_loader.mli b/src/loader/odoc_loader.mli index d60014f300..db0adc302d 100644 --- a/src/loader/odoc_loader.mli +++ b/src/loader/odoc_loader.mli @@ -19,6 +19,7 @@ val read_cmti : filename:string -> source_id_opt:Identifier.SourcePage.t option -> cmt_filename_opt:string option -> + count_occurrences:bool -> (Lang.Compilation_unit.t, Error.t) result Error.with_warnings val read_cmt : @@ -26,6 +27,7 @@ val read_cmt : parent:Identifier.ContainerPage.t option -> filename:string -> source_id_opt:Identifier.SourcePage.t option -> + count_occurrences:bool -> (Lang.Compilation_unit.t, Error.t) result Error.with_warnings val read_cmi : diff --git a/src/loader/typedtree_traverse.ml b/src/loader/typedtree_traverse.ml index 164035bb3b..7baac064f2 100644 --- a/src/loader/typedtree_traverse.ml +++ b/src/loader/typedtree_traverse.ml @@ -1,31 +1,41 @@ #if OCAML_VERSION >= (4, 14, 0) module Analysis = struct - type value_implementation = LocalValue of Ident.t | DefJmp of Shape.Uid.t + type annotation = + | Definition of Ident.t + | Value of Path.t + | Module of Path.t + | ClassType of Path.t + | ModuleType of Path.t + | Type of Path.t + | Constructor of Path.t - type annotation = Definition of Ident.t | Value of value_implementation - - let expr uid_to_loc poses expr = + let expr poses expr = let exp_loc = expr.Typedtree.exp_loc in if exp_loc.loc_ghost then () else match expr.exp_desc with - | Texp_ident (p, _, value_description) -> ( - let implementation = - match - Shape.Uid.Tbl.find_opt uid_to_loc value_description.val_uid - with - | Some _ -> Some (DefJmp value_description.val_uid) - | None -> ( - match p with Pident id -> Some (LocalValue id) | _ -> None) - in - match implementation with - | None -> () - | Some impl -> poses := (Value impl, exp_loc) :: !poses) + | Texp_ident (p, _, _) -> poses := (Value p, exp_loc) :: !poses + | Texp_construct (_, { cstr_res; _ }, _) -> ( + let desc = Types.get_desc cstr_res in + match desc with + | Types.Tconstr (p, _, _) -> + poses := (Constructor p, exp_loc) :: !poses + | _ -> ()) | _ -> () let pat env (type a) poses : a Typedtree.general_pattern -> unit = function | { Typedtree.pat_desc; pat_loc; _ } when not pat_loc.loc_ghost -> + let () = + match pat_desc with + | Typedtree.Tpat_construct (_, { cstr_res; _ }, _, _) -> ( + let desc = Types.get_desc cstr_res in + match desc with + | Types.Tconstr (p, _, _) -> + poses := (Constructor p, pat_loc) :: !poses + | _ -> ()) + | _ -> () + in let maybe_localvalue id loc = match Ident_env.identifier_of_loc env loc with | None -> Some (Definition id, loc) @@ -45,19 +55,73 @@ module Analysis = struct in () | _ -> () + + let module_expr poses mod_expr = + match mod_expr with + | { Typedtree.mod_desc = Tmod_ident (p, _); mod_loc; _ } + when not mod_loc.loc_ghost -> + poses := (Module p, mod_loc) :: !poses + | _ -> () + + let class_type poses cltyp = + match cltyp with + | { Typedtree.cltyp_desc = Tcty_constr (p, _, _); cltyp_loc; _ } + when not cltyp_loc.loc_ghost -> + poses := (ClassType p, cltyp_loc) :: !poses + | _ -> () + + let module_type poses mty_expr = + match mty_expr with + | { Typedtree.mty_desc = Tmty_ident (p, _); mty_loc; _ } + when not mty_loc.loc_ghost -> + poses := (ModuleType p, mty_loc) :: !poses + | _ -> () + + let core_type poses ctyp_expr = + match ctyp_expr with + | { Typedtree.ctyp_desc = Ttyp_constr (p, _, _); ctyp_loc; _ } + when not ctyp_loc.loc_ghost -> + poses := (Type p, ctyp_loc) :: !poses + | _ -> () end -let of_cmt env uid_to_loc structure = +let of_cmt env structure = let poses = ref [] in + let module_expr iterator mod_expr = + Analysis.module_expr poses mod_expr; + Tast_iterator.default_iterator.module_expr iterator mod_expr + in let expr iterator e = - Analysis.expr uid_to_loc poses e; + Analysis.expr poses e; Tast_iterator.default_iterator.expr iterator e in let pat iterator e = Analysis.pat env poses e; Tast_iterator.default_iterator.pat iterator e in - let iterator = { Tast_iterator.default_iterator with expr; pat } in + let typ iterator ctyp_expr = + Analysis.core_type poses ctyp_expr; + Tast_iterator.default_iterator.typ iterator ctyp_expr + in + let module_type iterator mty = + Analysis.module_type poses mty; + Tast_iterator.default_iterator.module_type iterator mty + in + let class_type iterator cl_type = + Analysis.class_type poses cl_type; + Tast_iterator.default_iterator.class_type iterator cl_type + in + let iterator = + { + Tast_iterator.default_iterator with + expr; + pat; + module_expr; + typ; + module_type; + class_type; + } + in iterator.structure iterator structure; !poses diff --git a/src/model/lang.ml b/src/model/lang.ml index 74c5b66023..dd4abf6a68 100644 --- a/src/model/lang.ml +++ b/src/model/lang.ml @@ -18,15 +18,31 @@ open Paths (** {3 Modules} *) module Source_info = struct + type 'a jump_to_impl = + | Unresolved of 'a + | Resolved of Identifier.SourceLocation.t + + type ('doc, 'impl) jump_to = { + documentation : 'doc option; + implementation : 'impl jump_to_impl option; + } + + type 'path jump_1 = ('path, 'path) jump_to + type annotation = | Definition of Paths.Identifier.SourceLocation.t - | Value of Paths.Identifier.SourceLocation.t + | Value of Path.Value.t jump_1 + | Module of Path.Module.t jump_1 + | ClassType of Path.ClassType.t jump_1 + | ModuleType of Path.ModuleType.t jump_1 + | Type of Path.Type.t jump_1 + | Constructor of Path.Constructor.t jump_1 type 'a with_pos = 'a * (int * int) type infos = annotation with_pos list - type t = { id : Identifier.SourcePage.t; infos : infos } + type t = { id : Identifier.SourcePage.t option; infos : infos } end module rec Module : sig diff --git a/src/model/paths.ml b/src/model/paths.ml index 1d9e9c7193..fa90e0d05d 100644 --- a/src/model/paths.ml +++ b/src/model/paths.ml @@ -132,16 +132,19 @@ module Identifier = struct InstanceVariableName.to_string name :: full_name_aux (parent :> t) | `Label (parent, name) -> LabelName.to_string name :: full_name_aux (parent :> t) + | `SourceDir (parent, name) -> name :: full_name_aux (parent :> t) + | `SourceLocation (parent, name) -> + DefName.to_string name :: full_name_aux (parent :> t) + | `SourceLocationInternal (parent, name) -> + LocalName.to_string name :: full_name_aux (parent :> t) + | `SourceLocationMod name -> full_name_aux (name :> t) + | `SourcePage (parent, name) -> name :: full_name_aux (parent :> t) | `AssetFile (parent, name) -> name :: full_name_aux (parent :> t) - | `SourceDir _ | `SourceLocationMod _ | `SourceLocation _ | `SourcePage _ - | `SourceLocationInternal _ -> - [] let fullname : [< t_pv ] id -> string list = fun n -> List.rev @@ full_name_aux (n :> t) let is_internal : [< t_pv ] id -> bool = fun n -> is_internal (n :> t) - let rec label_parent_aux = let open Id in fun (n : non_src) -> diff --git a/src/model/paths.mli b/src/model/paths.mli index bf0b7b1bab..f52538ba73 100644 --- a/src/model/paths.mli +++ b/src/model/paths.mli @@ -206,8 +206,6 @@ module Identifier : sig val name : [< t_pv ] id -> string - (* val root : [< t_pv ] id -> RootModule.t_pv id option *) - val fullname : [< t_pv ] id -> string list (** The fullname of value [x] in module [M] is [M.x], whereas the regular name is [x]. *) @@ -384,12 +382,6 @@ module rec Path : sig module Value : sig type t = Paths_types.Resolved_path.value - - (* val of_ident : Identifier.Path.Value.t -> t *) - - (* val is_hidden : t -> bool *) - - (* val identifier : t -> Identifier.Path.Type.t *) end module ClassType : sig diff --git a/src/model/paths_types.ml b/src/model/paths_types.ml index c14b5314f4..8c61ca316c 100644 --- a/src/model/paths_types.ml +++ b/src/model/paths_types.ml @@ -352,7 +352,10 @@ module rec Path : sig [ `Resolved of Resolved_path.constructor | `Dot of datatype * string ] (** @canonical Odoc_model.Paths.Path.Constructor.t *) - type value = [ `Resolved of Resolved_path.value | `Dot of module_ * string ] + type value = + [ `Resolved of Resolved_path.value + | `Identifier of Identifier.path_value * bool + | `Dot of module_ * string ] (** @canonical Odoc_model.Paths.Path.Value.t *) type class_type = @@ -410,7 +413,8 @@ and Resolved_path : sig type constructor = [ `Constructor of datatype * ConstructorName.t ] (** @canonical Odoc_model.Paths.Path.Resolved.Constructor.t *) - type value = [ `Value of module_ * ValueName.t ] + type value = + [ `Identifier of Identifier.path_value | `Value of module_ * ValueName.t ] (** @canonical Odoc_model.Paths.Path.Resolved.Value.t *) type class_type = diff --git a/src/model_desc/lang_desc.ml b/src/model_desc/lang_desc.ml index 56c96bc008..491fee961c 100644 --- a/src/model_desc/lang_desc.ml +++ b/src/model_desc/lang_desc.ml @@ -18,7 +18,7 @@ let inline_status = let source_info = let open Lang.Source_info in - Record [ F ("id", (fun t -> t.id), identifier) ] + Record [ F ("id", (fun t -> t.id), Option identifier) ] (** {3 Module} *) diff --git a/src/odoc/bin/main.ml b/src/odoc/bin/main.ml index ea3de5f9bd..3ecb9596e7 100644 --- a/src/odoc/bin/main.ml +++ b/src/odoc/bin/main.ml @@ -184,7 +184,7 @@ end = struct let compile hidden directories resolve_fwd_refs dst package_opt parent_name_opt open_modules children input warnings_options - source_parent_file source_name cmt_filename_opt = + source_parent_file source_name cmt_filename_opt count_occurrences = let open Or_error in let resolver = Resolver.create ~important_digests:(not resolve_fwd_refs) ~directories @@ -220,7 +220,7 @@ end = struct source >>= fun source -> Fs.Directory.mkdir_p (Fs.File.dirname output); Compile.compile ~resolver ~parent_cli_spec ~hidden ~children ~output - ~warnings_options ~source ~cmt_filename_opt input + ~warnings_options ~source ~cmt_filename_opt ~count_occurrences input let input = let doc = "Input $(i,.cmti), $(i,.cmt), $(i,.cmi) or $(i,.mld) file." in @@ -293,11 +293,18 @@ end = struct let doc = "Try resolving forward references." in Arg.(value & flag & info ~doc [ "r"; "resolve-fwd-refs" ]) in + let count_occurrences = + let doc = + "Count occurrences in implementation. Useful in search ranking." + in + Arg.(value & flag & info ~doc [ "count-occurrences" ]) + in Term.( const handle_error $ (const compile $ hidden $ odoc_file_directories $ resolve_fwd_refs $ dst $ package_opt $ parent_opt $ open_modules $ children $ input - $ warnings_options $ source_parent_file $ source_name $ source_cmt)) + $ warnings_options $ source_parent_file $ source_name $ source_cmt + $ count_occurrences)) let info ~docs = let man = @@ -1103,6 +1110,30 @@ module Targets = struct end end +module Occurrences = struct + let index directories dst warnings_options = + let dst = Fpath.v dst in + Occurrences.count ~dst ~warnings_options directories + + let cmd = + let dst = + let doc = "Output file path." in + Arg.( + required & opt (some string) None & info ~docs ~docv:"PATH" ~doc [ "o" ]) + in + Term.( + const handle_error + $ (const index $ odoc_file_directories $ dst $ warnings_options)) + + let info ~docs = + let doc = + "Generate a hashtable mapping identifiers to number of occurrences, as \ + computed from the implementations of .odocl files found in the given \ + directories." + in + Term.info "count-occurrences" ~docs ~doc +end + module Odoc_error = struct let errors input = let open Odoc_odoc in @@ -1143,6 +1174,7 @@ let () = Printexc.record_backtrace true; let subcommands = [ + Occurrences.(cmd, info ~docs:section_pipeline); Compile.(cmd, info ~docs:section_pipeline); Odoc_link.(cmd, info ~docs:section_pipeline); Odoc_html.generate ~docs:section_pipeline; diff --git a/src/odoc/compile.ml b/src/odoc/compile.ml index 5429c353bf..51244fdf0a 100644 --- a/src/odoc/compile.ml +++ b/src/odoc/compile.ml @@ -99,16 +99,17 @@ let resolve_imports resolver imports = (** Raises warnings and errors. *) let resolve_and_substitute ~resolver ~make_root ~source_id_opt ~cmt_filename_opt ~hidden (parent : Paths.Identifier.ContainerPage.t option) input_file - input_type = + input_type ~count_occurrences = let filename = Fs.File.to_string input_file in let unit = match input_type with | `Cmti -> Odoc_loader.read_cmti ~make_root ~parent ~filename ~source_id_opt - ~cmt_filename_opt + ~cmt_filename_opt ~count_occurrences |> Error.raise_errors_and_warnings | `Cmt -> Odoc_loader.read_cmt ~make_root ~parent ~filename ~source_id_opt + ~count_occurrences |> Error.raise_errors_and_warnings | `Cmi -> Odoc_loader.read_cmi ~make_root ~parent ~filename @@ -250,7 +251,7 @@ let handle_file_ext ext = Error (`Msg "Unknown extension, expected one of: cmti, cmt, cmi or mld.") let compile ~resolver ~parent_cli_spec ~hidden ~children ~output - ~warnings_options ~source ~cmt_filename_opt input = + ~warnings_options ~source ~cmt_filename_opt ~count_occurrences input = parent resolver parent_cli_spec >>= fun parent_spec -> let ext = Fs.File.get_ext input in if ext = ".mld" then @@ -296,7 +297,7 @@ let compile ~resolver ~parent_cli_spec ~hidden ~children ~output let result = Error.catch_errors_and_warnings (fun () -> resolve_and_substitute ~resolver ~make_root ~hidden ~source_id_opt - ~cmt_filename_opt parent input input_type) + ~cmt_filename_opt ~count_occurrences parent input input_type) in (* Extract warnings to write them into the output file *) let _, warnings = Error.unpack_warnings result in diff --git a/src/odoc/compile.mli b/src/odoc/compile.mli index 602d9d5724..7d2755cbf6 100644 --- a/src/odoc/compile.mli +++ b/src/odoc/compile.mli @@ -43,6 +43,7 @@ val compile : warnings_options:Odoc_model.Error.warnings_options -> source:(Fpath.t * string list) option -> cmt_filename_opt:string option -> + count_occurrences:bool -> Fs.File.t -> (unit, [> msg ]) result (** Produces .odoc files out of [.cm{i,t,ti}] or .mld files. *) diff --git a/src/odoc/html_page.ml b/src/odoc/html_page.ml index b0c790416a..c316899694 100644 --- a/src/odoc/html_page.ml +++ b/src/odoc/html_page.ml @@ -39,7 +39,7 @@ let render { html_config; source = _; assets = _ } page = let source_documents source_info source ~syntax = match (source_info, source) with - | Some { Lang.Source_info.id; infos }, Some src -> ( + | Some { Lang.Source_info.id = Some id; infos }, Some src -> ( let file = match src with | Source.File f -> f @@ -68,7 +68,7 @@ let source_documents source_info source ~syntax = Odoc_document.Renderer.document_of_source ~syntax id syntax_info infos source_code; ]) - | Some { id; _ }, None -> + | Some { id = Some id; _ }, None -> let filename = Paths.Identifier.name id in Error.raise_warning (Error.filename_only @@ -77,14 +77,14 @@ let source_documents source_info source ~syntax = --source-name" filename); [] - | None, Some src -> + | _, Some src -> Error.raise_warning (Error.filename_only "--source argument is invalid on compilation unit that were not \ compiled with --source-parent and --source-name" (Source.to_string src)); [] - | None, None -> [] + | _, None -> [] let list_filter_map f lst = List.rev diff --git a/src/odoc/occurrences.ml b/src/odoc/occurrences.ml new file mode 100644 index 0000000000..286f047600 --- /dev/null +++ b/src/odoc/occurrences.ml @@ -0,0 +1,58 @@ +open Or_error + +let handle_file file ~f = + Odoc_file.load file + |> Result.map @@ fun unit' -> + match unit' with + | { Odoc_file.content = Unit_content unit; _ } -> Some (f unit) + | _ -> None + +let fold_dirs ~dirs ~f ~init = + dirs + |> List.fold_left + (fun acc dir -> + acc >>= fun acc -> + Fs.Directory.fold_files_rec_result ~ext:"odocl" + (fun acc file -> + file |> handle_file ~f:(f acc) >>= function + | None -> Ok acc + | Some acc -> Ok acc) + acc dir) + (Ok init) + +module H = Hashtbl.Make (Odoc_model.Paths.Identifier) + +let count ~dst ~warnings_options:_ directories = + let htbl = H.create 100 in + let f () (unit : Odoc_model.Lang.Compilation_unit.t) = + let incr tbl p p' = + let id = Odoc_model.Paths.Path.Resolved.(identifier (p :> t)) in + let old_value = match H.find_opt tbl id with Some n -> n | None -> 0 in + if not Odoc_model.Paths.Path.(is_hidden p') then + H.replace tbl id (old_value + 1) + in + let () = + List.iter + (function + | ( Odoc_model.Lang.Source_info.Module + { documentation = Some (`Resolved p as p'); _ }, + _ ) -> + incr htbl p Odoc_model.Paths.Path.((p' : Module.t :> t)) + | Value { documentation = Some (`Resolved p as p'); _ }, _ -> + incr htbl p Odoc_model.Paths.Path.((p' : Value.t :> t)) + | ClassType { documentation = Some (`Resolved p as p'); _ }, _ -> + incr htbl p Odoc_model.Paths.Path.((p' : ClassType.t :> t)) + | ModuleType { documentation = Some (`Resolved p as p'); _ }, _ -> + incr htbl p Odoc_model.Paths.Path.((p' : ModuleType.t :> t)) + | Type { documentation = Some (`Resolved p as p'); _ }, _ -> + incr htbl p Odoc_model.Paths.Path.((p' : Type.t :> t)) + | _ -> ()) + (match unit.source_info with None -> [] | Some i -> i.infos) + in + () + in + fold_dirs ~dirs:directories ~f ~init:() >>= fun () -> + Fs.Directory.mkdir_p (Fs.File.dirname dst); + let oc = open_out_bin (Fs.File.to_string dst) in + Marshal.to_channel oc htbl []; + Ok () diff --git a/src/xref2/compile.ml b/src/xref2/compile.ml index ce00da4857..66df782eb5 100644 --- a/src/xref2/compile.ml +++ b/src/xref2/compile.ml @@ -85,7 +85,28 @@ let rec unit env t = and source_info env si = { si with infos = source_info_infos env si.infos } -and source_info_infos _env infos = infos +and source_info_infos env infos = + let open Source_info in + let map_doc f v = + let documentation = + match v.documentation with Some p -> Some (f p) | None -> None + in + { v with documentation } + in + List.map + (function + | v, pos -> + let v = + match v with + | Value v -> Value (map_doc (value_path env) v) + | Module v -> Module (map_doc (module_path env) v) + | ModuleType v -> ModuleType (map_doc (module_type_path env) v) + | Type v -> Type (map_doc (type_path env) v) + | Constructor v -> Constructor (map_doc (constructor_path env) v) + | i -> i + in + (v, pos)) + infos and content env id = let open Compilation_unit in diff --git a/src/xref2/component.ml b/src/xref2/component.ml index 5ccfaa4655..f0fab6a9d5 100644 --- a/src/xref2/component.ml +++ b/src/xref2/component.ml @@ -1060,6 +1060,9 @@ module Fmt = struct | `Value (p, t) -> Format.fprintf ppf "%a.%s" resolved_parent_path p (Odoc_model.Names.ValueName.to_string t) + | `Gpath p -> + Format.fprintf ppf "%a" model_resolved_path + (p :> Odoc_model.Paths.Path.Resolved.t) and resolved_constructor_path : Format.formatter -> Cpath.Resolved.constructor -> unit = @@ -1120,6 +1123,10 @@ module Fmt = struct | `Value (p, t) -> Format.fprintf ppf "%a.%s" resolved_parent_path p (Odoc_model.Names.ValueName.to_string t) + | `Identifier (id, b) -> + Format.fprintf ppf "identifier(%a, %b)" model_identifier + (id :> Odoc_model.Paths.Identifier.t) + b and constructor_path : Format.formatter -> Cpath.constructor -> unit = fun ppf p -> @@ -1872,8 +1879,11 @@ module Of_Lang = struct and resolved_value_path : _ -> Odoc_model.Paths.Path.Resolved.Value.t -> Cpath.Resolved.value = - fun ident_map (`Value (p, name)) -> - `Value (`Module (resolved_module_path ident_map p), name) + fun ident_map p -> + match p with + | `Value (p, name) -> + `Value (`Module (resolved_module_path ident_map p), name) + | `Identifier _ -> `Gpath p and resolved_constructor_path : _ -> @@ -1934,12 +1944,6 @@ module Of_Lang = struct | `Local i -> `Local (i, b)) | `Dot (path', x) -> `Dot (module_path ident_map path', x) - and value_path : _ -> Odoc_model.Paths.Path.Value.t -> Cpath.value = - fun ident_map p -> - match p with - | `Resolved r -> `Resolved (resolved_value_path ident_map r) - | `Dot (path', x) -> `Dot (module_path ident_map path', x) - and datatype : _ -> Odoc_model.Paths.Path.DataType.t -> Cpath.datatype = fun ident_map p -> match p with @@ -1950,6 +1954,13 @@ module Of_Lang = struct | `Local i -> `Local (i, b)) | `Dot (path', x) -> `Dot (module_path ident_map path', x) + and value_path : _ -> Odoc_model.Paths.Path.Value.t -> Cpath.value = + fun ident_map p -> + match p with + | `Resolved r -> `Resolved (resolved_value_path ident_map r) + | `Dot (path', x) -> `Dot (module_path ident_map path', x) + | `Identifier (i, b) -> `Identifier (i, b) + and constructor_path : _ -> Odoc_model.Paths.Path.Constructor.t -> Cpath.constructor = fun ident_map p -> diff --git a/src/xref2/cpath.ml b/src/xref2/cpath.ml index 05891c7111..cd9f5f6ac3 100644 --- a/src/xref2/cpath.ml +++ b/src/xref2/cpath.ml @@ -36,7 +36,8 @@ module rec Resolved : sig | `Class of parent * ClassName.t | `ClassType of parent * ClassTypeName.t ] - and value = [ `Value of parent * ValueName.t ] + and value = + [ `Value of parent * ValueName.t | `Gpath of Path.Resolved.Value.t ] and datatype = [ `Local of Ident.path_datatype @@ -89,7 +90,8 @@ and Cpath : sig and value = [ `Resolved of Resolved.value | `Dot of module_ * string - | `Value of Resolved.parent * ValueName.t ] + | `Value of Resolved.parent * ValueName.t + | `Identifier of Identifier.Value.t * bool ] and datatype = [ `Resolved of Resolved.datatype diff --git a/src/xref2/env.ml b/src/xref2/env.ml index c5da7d79ae..73de06de0b 100644 --- a/src/xref2/env.ml +++ b/src/xref2/env.ml @@ -361,8 +361,8 @@ let module_of_unit : Lang.Compilation_unit.t -> Component.Module.t = let id = (unit.id :> Paths.Identifier.Module.t) in let locs = match unit.source_info with - | Some src -> Some (Identifier.Mk.source_location_mod src.id) - | None -> None + | Some { id = Some id; _ } -> Some (Identifier.Mk.source_location_mod id) + | _ -> None in match unit.content with | Module s -> diff --git a/src/xref2/errors.ml b/src/xref2/errors.ml index 4ca923a9b7..56b953d785 100644 --- a/src/xref2/errors.ml +++ b/src/xref2/errors.ml @@ -197,7 +197,7 @@ module Tools_error = struct Component.Fmt.model_identifier (m :> Odoc_model.Paths.Identifier.t) | `Lookup_failureC m -> - Format.fprintf fmt "Lookup failure (value): %a" + Format.fprintf fmt "Lookup failure (constructor): %a" Component.Fmt.model_identifier (m :> Odoc_model.Paths.Identifier.t) | `ApplyNotFunctor -> Format.fprintf fmt "Apply module is not a functor" diff --git a/src/xref2/find.ml b/src/xref2/find.ml index 0287f603f3..ba5ec4108e 100644 --- a/src/xref2/find.ml +++ b/src/xref2/find.ml @@ -281,7 +281,10 @@ let module_type_in_sig sg name = let value_in_sig sg name = filter_in_sig sg (function - | Signature.Value (id, m) when N.value id = name -> + | Signature.Value (id, m) + when N.value id = name || N.value id = "(" ^ name ^ ")" -> + (* For operator, the value will have name [()]. We match that even + with name []. *) Some (`FValue (N.typed_value id, Delayed.get m)) | _ -> None) diff --git a/src/xref2/lang_of.ml b/src/xref2/lang_of.ml index 3a40397c4b..bbe07f8ac5 100644 --- a/src/xref2/lang_of.ml +++ b/src/xref2/lang_of.ml @@ -198,9 +198,11 @@ module Path = struct | `ClassType (p, name) -> `ClassType (resolved_parent map p, name) | `Substituted s -> resolved_type map s - and resolved_value map (`Value (p, name) : Cpath.Resolved.value) : + and resolved_value map (p : Cpath.Resolved.value) : Odoc_model.Paths.Path.Resolved.Value.t = - `Value (resolved_parent map p, name) + match p with + | `Value (p, name) -> `Value (resolved_parent map p, name) + | `Gpath y -> y and resolved_datatype map (p : Cpath.Resolved.datatype) : Odoc_model.Paths.Path.Resolved.DataType.t = diff --git a/src/xref2/link.ml b/src/xref2/link.ml index 2183694343..33d5003a77 100644 --- a/src/xref2/link.ml +++ b/src/xref2/link.ml @@ -398,13 +398,60 @@ and open_ env parent = function let rec unit env t = let open Compilation_unit in let content = - match t.content with - | Module sg -> - let sg = signature env (t.id :> Id.Signature.t) sg in - Module sg - | Pack _ as p -> p + if t.Lang.Compilation_unit.linked || t.hidden then t.content + else + match t.content with + | Module sg -> + let sg = signature env (t.id :> Id.Signature.t) sg in + Module sg + | Pack _ as p -> p in - { t with content; linked = true } + let source_info = + let open Source_info in + match t.source_info with + | Some inf -> + let jump_to v f_impl f_doc = + let documentation = + match v.documentation with Some p -> Some (f_doc p) | None -> None + in + let implementation = + match v.implementation with + | Some (Unresolved p) -> ( + match f_impl p with + | Some x -> Some (Resolved x) + | None -> v.implementation) + | x -> x + in + { documentation; implementation } + in + let infos = + List.map + (fun (i, pos) -> + let info = + match i with + | Value v -> + Value + (jump_to v + (Shape_tools.lookup_value_path env) + (value_path env)) + | Module v -> + Module (jump_to v (fun _ -> None) (module_path env)) + | ModuleType v -> + ModuleType + (jump_to v (fun _ -> None) (module_type_path env)) + | Type v -> Type (jump_to v (fun _ -> None) (type_path env)) + | Constructor v -> + Constructor + (jump_to v (fun _ -> None) (constructor_path env)) + | i -> i + in + (info, pos)) + inf.infos + in + Some { inf with infos } + | None -> None + in + { t with content; linked = true; source_info } and value_ env parent t = let open Value in @@ -1082,8 +1129,7 @@ and type_expression : Env.t -> Id.Signature.t -> _ -> _ = | Package p -> Package (type_expression_package env parent visited p) let link ~filename x y = - Lookup_failures.catch_failures ~filename (fun () -> - if y.Lang.Compilation_unit.linked || y.hidden then y else unit x y) + Lookup_failures.catch_failures ~filename (fun () -> unit x y) let page env page = let () = diff --git a/src/xref2/shape_tools.cppo.ml b/src/xref2/shape_tools.cppo.ml index c702e17b56..5d516dd926 100644 --- a/src/xref2/shape_tools.cppo.ml +++ b/src/xref2/shape_tools.cppo.ml @@ -53,6 +53,49 @@ let rec shape_of_id env : (* Not represented in shapes. *) None +let rec shape_of_module_path env : _ -> Shape.t option = + let proj parent kind name = + let item = Shape.Item.make name kind in + match shape_of_module_path env (parent :> Odoc_model.Paths.Path.t) with + | Some shape -> Some (Shape.proj shape item) + | None -> None + in + fun (path : Odoc_model.Paths.Path.t) -> + match path with + | `Resolved _ -> None + | `Root name -> ( + match Env.lookup_unit name env with + | Some (Env.Found unit) -> ( + match unit.shape_info with + | Some (shape, _) -> Some shape + | None -> None) + | _ -> None) + | `Forward _ -> None + | `Dot (parent, name) -> + proj (parent :> Odoc_model.Paths.Path.t) Kind.Module name + | `Apply (parent, arg) -> + shape_of_module_path env (parent :> Odoc_model.Paths.Path.t) + >>= fun parent -> + shape_of_module_path env (arg :> Odoc_model.Paths.Path.t) >>= fun arg -> + Some (Shape.app parent ~arg) + | `Identifier (id, _) -> + shape_of_id env (id :> Odoc_model.Paths.Identifier.NonSrc.t) + +let shape_of_value_path env : + Odoc_model.Paths.Path.Value.t -> Shape.t option = + let proj parent kind name = + let item = Shape.Item.make name kind in + match shape_of_module_path env (parent :> Odoc_model.Paths.Path.t) with + | Some shape -> Some (Shape.proj shape item) + | None -> None + in + fun (path : Odoc_model.Paths.Path.Value.t) -> + match path with + | `Resolved _ -> None + | `Dot (parent, name) -> proj (parent :> Odoc_model.Paths.Path.t) Kind.Value name + | `Identifier (id, _) -> shape_of_id env (id :> Odoc_model.Paths.Identifier.NonSrc.t) + + module MkId = Identifier.Mk let unit_of_uid uid = @@ -95,8 +138,8 @@ let lookup_shape : | Some x -> Some x | None -> ( match unit.source_info with - | Some si -> Some (MkId.source_location_mod si.id) - | None -> None) + | Some {id = Some id ; _} -> Some (MkId.source_location_mod id) + | _ -> None) let lookup_def : @@ -108,6 +151,15 @@ let lookup_def : | None -> None | Some query -> lookup_shape env query +let lookup_value_path : + Env.t -> + Path.Value.t -> + Identifier.SourceLocation.t option + = fun env path -> + match shape_of_value_path env path with + | None -> None + | Some query -> lookup_shape env query + #else type t = unit diff --git a/src/xref2/shape_tools.cppo.mli b/src/xref2/shape_tools.cppo.mli index d9082e06ba..607d50b8dc 100644 --- a/src/xref2/shape_tools.cppo.mli +++ b/src/xref2/shape_tools.cppo.mli @@ -13,3 +13,8 @@ val lookup_def : Env.t -> Identifier.NonSrc.t -> Identifier.SourceLocation.t option + +val lookup_value_path : + Env.t -> + Path.Value.t -> + Identifier.SourceLocation.t option diff --git a/src/xref2/tools.ml b/src/xref2/tools.ml index f1ccd6eeb5..f3486bda74 100644 --- a/src/xref2/tools.ml +++ b/src/xref2/tools.ml @@ -878,6 +878,29 @@ and lookup_type_gpath : in res +and lookup_value_gpath : + Env.t -> + Odoc_model.Paths.Path.Resolved.Value.t -> + (Find.value, simple_value_lookup_error) Result.result = + fun env p -> + let do_value p name = + lookup_parent_gpath ~mark_substituted:true env p + |> map_error (fun e -> (e :> simple_value_lookup_error)) + >>= fun (sg, sub) -> + match Find.value_in_sig sg name with + | `FValue (name, t) :: _ -> Ok (`FValue (name, Subst.value sub t)) + | [] -> Error `Find_failure + in + let res = + match p with + | `Identifier ({ iv = `Value _; _ } as i) -> + of_option ~error:(`Lookup_failureV i) (Env.(lookup_by_id s_value) i env) + >>= fun (`Value ({ iv = `Value (_, name); _ }, t)) -> + Ok (`FValue (name, t)) + | `Value (p, id) -> do_value p (ValueName.to_string id) + in + res + and lookup_datatype_gpath : Env.t -> Odoc_model.Paths.Path.Resolved.DataType.t -> @@ -1005,13 +1028,16 @@ and lookup_datatype : and lookup_value : Env.t -> Cpath.Resolved.value -> - (Find.value, simple_value_lookup_error) Result.result = - fun env (`Value (p, id)) -> - lookup_parent ~mark_substituted:true env p - |> map_error (fun e -> (e :> simple_value_lookup_error)) - >>= fun (sg, sub) -> - handle_value_lookup env (ValueName.to_string id) p sg - >>= fun (_, `FValue (name, c)) -> Ok (`FValue (name, Subst.value sub c)) + (_, simple_value_lookup_error) Result.result = + fun env p -> + match p with + | `Value (p, id) -> + lookup_parent ~mark_substituted:true env p + |> map_error (fun e -> (e :> simple_value_lookup_error)) + >>= fun (sg, sub) -> + handle_value_lookup env (ValueName.to_string id) p sg + >>= fun (_, `FValue (name, c)) -> Ok (`FValue (name, Subst.value sub c)) + | `Gpath p -> lookup_value_gpath env p and lookup_constructor : Env.t -> @@ -1357,6 +1383,9 @@ and resolve_value : Env.t -> Cpath.value -> resolve_value_result = in of_option ~error:`Find_failure result | `Resolved r -> lookup_value env r >>= fun t -> Ok (r, t) + | `Identifier (i, _) -> + let i' = `Identifier i in + lookup_value env (`Gpath i') >>= fun t -> Ok (`Gpath i', t) in result @@ -1808,7 +1837,10 @@ and reresolve_datatype : result and reresolve_value : Env.t -> Cpath.Resolved.value -> Cpath.Resolved.value = - fun env (`Value (p, n)) -> `Value (reresolve_parent env p, n) + fun env p -> + match p with + | `Value (p, n) -> `Value (reresolve_parent env p, n) + | `Gpath _ -> p and reresolve_constructor : Env.t -> Cpath.Resolved.constructor -> Cpath.Resolved.constructor = diff --git a/test/occurrences/double_wrapped.t/a.ml b/test/occurrences/double_wrapped.t/a.ml new file mode 100644 index 0000000000..0a13bbe074 --- /dev/null +++ b/test/occurrences/double_wrapped.t/a.ml @@ -0,0 +1,7 @@ +let x = 1 + +type t = string + +module type M = sig end + +let (||>) x y = x + y diff --git a/test/occurrences/double_wrapped.t/b.ml b/test/occurrences/double_wrapped.t/b.ml new file mode 100644 index 0000000000..9c65111cd5 --- /dev/null +++ b/test/occurrences/double_wrapped.t/b.ml @@ -0,0 +1,13 @@ +module Y = A + +module Z = C + +let y = Y.x + A.x + Z.y + C.y + +let (_ : A.t) = "string" + +module M : A.M = struct end + +module type Y = A.M + +let _ = let open A in 1 ||> 2 diff --git a/test/occurrences/double_wrapped.t/c.ml b/test/occurrences/double_wrapped.t/c.ml new file mode 100644 index 0000000000..b0ae315a86 --- /dev/null +++ b/test/occurrences/double_wrapped.t/c.ml @@ -0,0 +1,3 @@ +module Y = A + +let y = Y.x + A.x diff --git a/test/occurrences/double_wrapped.t/main.ml b/test/occurrences/double_wrapped.t/main.ml new file mode 100644 index 0000000000..25a40aaa6e --- /dev/null +++ b/test/occurrences/double_wrapped.t/main.ml @@ -0,0 +1,5 @@ +(** Handwritten top-level module *) + +module A = A + +module B = B diff --git a/test/occurrences/double_wrapped.t/main__.ml b/test/occurrences/double_wrapped.t/main__.ml new file mode 100644 index 0000000000..59f553e2ae --- /dev/null +++ b/test/occurrences/double_wrapped.t/main__.ml @@ -0,0 +1,10 @@ +(** Would be generated by dune *) + +module A = Main__A +(** @canonical Main.A *) + +module B = Main__B +(** @canonical Main.B *) + +module C = Main__C +(** @canonical Main.C *) diff --git a/test/occurrences/double_wrapped.t/root.mld b/test/occurrences/double_wrapped.t/root.mld new file mode 100644 index 0000000000..54f377d3e8 --- /dev/null +++ b/test/occurrences/double_wrapped.t/root.mld @@ -0,0 +1 @@ +{0 Root} diff --git a/test/occurrences/double_wrapped.t/run.t b/test/occurrences/double_wrapped.t/run.t new file mode 100644 index 0000000000..48a9a5f247 --- /dev/null +++ b/test/occurrences/double_wrapped.t/run.t @@ -0,0 +1,59 @@ +This test simulates the conditions when a dune user write a toplevel module. + +The module C is not exposed in the handwritten toplevel module. +The module A and B are exposed. +The module B depends on both B and C, the module C only depends on A. + + $ ocamlc -c -o main__.cmo main__.ml -bin-annot -w -49 -no-alias-deps -I . + $ ocamlc -c -open Main__ -o main__A.cmo a.ml -bin-annot -I . + $ ocamlc -c -open Main__ -o main__C.cmo c.ml -bin-annot -I . + $ ocamlc -c -open Main__ -o main__B.cmo b.ml -bin-annot -I . + $ ocamlc -c -open Main__ main.ml -bin-annot -I . + +Passing the count-occurrences flag to odoc compile makes it collect the +occurrences information. + + + $ odoc compile --count-occurrences -I . main__A.cmt + $ odoc compile --count-occurrences -I . main__C.cmt + $ odoc compile --count-occurrences -I . main__B.cmt + $ odoc compile --count-occurrences -I . main__.cmt + $ odoc compile --count-occurrences -I . main.cmt + + $ odoc link -I . main.odoc + $ odoc link -I . main__A.odoc + $ odoc link -I . main__B.odoc + File "main__B.odoc": + Warning: Failed to lookup value identifier((root Main__B).Z, false).y Parent_module: Lookup failure (module): (root Main__B).Z + File "main__B.odoc": + Warning: Failed to lookup value identifier((root Main__B).Y, false).x Parent_module: Lookup failure (module): (root Main__B).Y + $ odoc link -I . main__C.odoc + File "main__C.odoc": + Warning: Failed to lookup value identifier((root Main__C).Y, false).x Parent_module: Lookup failure (module): (root Main__C).Y + $ odoc link -I . main__.odoc + +The count occurrences command outputs a marshalled hashtable, whose keys are +odoc identifiers, and whose values are integers corresponding to the number of +uses. + + $ odoc count-occurrences -I . -o occurrences.txt + + $ du -h occurrences.txt + 4.0K occurrences.txt + +The occurrences_print executable, available only for testing, unmarshal the file +and prints the number of occurrences in a readable format. + +Uses of A and B are counted correctly, with the path rewritten correctly. +Uses of C are not counted, since the canonical destination (generated by dune) does not exist. +Uses of values Y.x and Z.y (in b.ml) are not counted since they come from a "local" module. +Uses of values Main__.C.y and Main__.A.x are not rewritten since we use references instead of paths. + + $ occurrences_print occurrences.txt | sort + Main.A was used 4 times + Main.A.(||>) was used 1 times + Main.A.M was used 2 times + Main.A.t was used 1 times + Main.A.x was used 2 times + Main.B was used 1 times + string was used 1 times diff --git a/test/occurrences/dune b/test/occurrences/dune new file mode 100644 index 0000000000..7ce8e1acbc --- /dev/null +++ b/test/occurrences/dune @@ -0,0 +1,11 @@ +; Tests related to linking to source code + +(env + (_ + (binaries + (../odoc_print/occurrences_print.exe as occurrences_print)))) + +(cram + (enabled_if + (>= %{ocaml_version} 4.14.1)) + (deps %{bin:odoc} %{bin:occurrences_print})) diff --git a/test/occurrences/source.t/a.ml b/test/occurrences/source.t/a.ml new file mode 100644 index 0000000000..e09e5d02a3 --- /dev/null +++ b/test/occurrences/source.t/a.ml @@ -0,0 +1 @@ +let a = B.b diff --git a/test/occurrences/source.t/b.ml b/test/occurrences/source.t/b.ml new file mode 100644 index 0000000000..56d2d5273c --- /dev/null +++ b/test/occurrences/source.t/b.ml @@ -0,0 +1 @@ +let b = 3 diff --git a/test/occurrences/source.t/root.mld b/test/occurrences/source.t/root.mld new file mode 100644 index 0000000000..54f377d3e8 --- /dev/null +++ b/test/occurrences/source.t/root.mld @@ -0,0 +1 @@ +{0 Root} diff --git a/test/occurrences/source.t/run.t b/test/occurrences/source.t/run.t new file mode 100644 index 0000000000..9c0da5e49f --- /dev/null +++ b/test/occurrences/source.t/run.t @@ -0,0 +1,38 @@ +When both source rendering and occurrence counting are enabled, the occurrences information are used to generate "jump to documentation" links. + +This test tests this. + +Files containing some values: + + $ cat a.ml | head -n 3 + let a = B.b + + $ cat b.ml | head -n 3 + let b = 3 + +Source pages require a parent: + + $ odoc compile -c module-a -c module-b -c src-source root.mld + +Compile the modules: + + $ ocamlc -c b.ml -bin-annot + $ ocamlc -c a.ml -I . -bin-annot + +Compile the pages with the source and occurrences options + + $ printf "a.ml\nb.ml\n" > source_tree.map + $ odoc source-tree -I . --parent page-root -o src-source.odoc source_tree.map + $ odoc compile --count-occurrences -I . --source-name b.ml --source-parent-file src-source.odoc b.cmt + $ odoc compile --count-occurrences -I . --source-name a.ml --source-parent-file src-source.odoc a.cmt + $ odoc link -I . b.odoc + $ odoc link -I . a.odoc + $ odoc html-generate --source b.ml --indent -o html b.odocl + $ odoc html-generate --source a.ml --indent -o html a.odocl + $ odoc support-files -o html + +The source for `a` contains a link to the documentation of `B.b`, as it is used in the implementation: + + $ cat html/root/source/a.ml.html | tr '> ' '\n\n' | grep 'href' | grep val-b + href="b.ml.html#val-b" + href="../../B/index.html#val-b" diff --git a/test/odoc_print/dune b/test/odoc_print/dune index 2ff497d279..808b543f1a 100644 --- a/test/odoc_print/dune +++ b/test/odoc_print/dune @@ -6,9 +6,9 @@ (executable (name odoc_print) (modules odoc_print) - (libraries - odoc_odoc - cmdliner - type_desc_to_yojson - odoc_model_desc - compatcmdliner)) + (libraries odoc_odoc type_desc_to_yojson odoc_model_desc compatcmdliner)) + +(executable + (name occurrences_print) + (modules occurrences_print) + (libraries odoc_model_desc compatcmdliner)) diff --git a/test/odoc_print/occurrences_print.ml b/test/odoc_print/occurrences_print.ml new file mode 100644 index 0000000000..86d39fade3 --- /dev/null +++ b/test/odoc_print/occurrences_print.ml @@ -0,0 +1,27 @@ +module H = Hashtbl.Make (Odoc_model.Paths.Identifier) + +let run inp = + let ic = open_in_bin inp in + let htbl = Marshal.from_channel ic in + H.iter + (fun id occ -> + let id = String.concat "." (Odoc_model.Paths.Identifier.fullname id) in + Format.printf "%s was used %d times\n" id occ) + htbl + +open Compatcmdliner + +let a_inp = + let doc = "Input file." in + Arg.(required & pos 0 (some file) None & info ~doc ~docv:"PATH" []) + +let term = + let doc = + "Print the content of occurrences files into a text format. For tests" + in + Term.(const run $ a_inp, info "occurrences_print" ~doc) + +let () = + match Term.eval term with + | `Ok () -> () + | (`Version | `Help | `Error _) as x -> Term.exit x diff --git a/test/sources/functor.t/run.t b/test/sources/functor.t/run.t index 4bca693672..1b41b151bd 100644 --- a/test/sources/functor.t/run.t +++ b/test/sources/functor.t/run.t @@ -12,8 +12,16 @@ Verify the behavior on functors. $ odoc compile --source-name a.ml --source-parent-file src-source.odoc -I . a.cmt $ odoc compile --source-name b.ml --source-parent-file src-source.odoc -I . b.cmt $ odoc link -I . s.odoc + File "s.odoc": + Warning: Failed to lookup type identifier((root S).S.t, false) Lookup failure (type): (root S).S.t $ odoc link -I . a.odoc + File "a.odoc": + Warning: Failed to lookup value identifier((param (root A).F S), false).x Parent_module: Lookup failure (module): (param (root A).F S) + File "a.odoc": + Warning: Failed to lookup type identifier((param (root A).F S), false).t Parent_module: Lookup failure (module): (param (root A).F S) $ odoc link -I . b.odoc + File "b.odoc": + Warning: Failed to resolve module path identifier((root B).S, false) Lookup failure (module): (root B).S $ odoc html-generate --source s.ml --indent -o html s.odocl $ odoc html-generate --source a.ml --indent -o html a.odocl $ odoc html-generate --source b.ml --indent -o html b.odocl diff --git a/test/sources/lookup_def.t/run.t b/test/sources/lookup_def.t/run.t index f6c30e1045..944b6741fd 100644 --- a/test/sources/lookup_def.t/run.t +++ b/test/sources/lookup_def.t/run.t @@ -8,6 +8,8 @@ Compile the modules: $ ocamlc -c a.mli a.ml -bin-annot $ odoc compile --cmt a.cmt --source-name a.ml --source-parent-file src-source.odoc -I . a.cmti $ odoc link a.odoc + File "a.odoc": + Warning: Failed to resolve module type path identifier((root A).N.S, false) Lookup failure (module type): (root A).N.S Show the locations: diff --git a/test/sources/recursive_module.t/run.t b/test/sources/recursive_module.t/run.t index aba686595a..0f8a5517ba 100644 --- a/test/sources/recursive_module.t/run.t +++ b/test/sources/recursive_module.t/run.t @@ -8,6 +8,14 @@ Checking that source links exists inside recursive modules. $ ocamlc -c main.ml -bin-annot -I . $ odoc compile --source-name main.ml --source-parent-file src-source.odoc -I . main.cmt $ odoc link -I . main.odoc + File "main.odoc": + Warning: Failed to lookup type identifier((root Main).A, false).t Parent_module: Lookup failure (module): (root Main).A + File "main.odoc": + Warning: Failed to resolve module path identifier((root Main).B, false) Lookup failure (module): (root Main).B + File "main.odoc": + Warning: Failed to lookup type identifier((root Main).B, false).t Parent_module: Lookup failure (module): (root Main).B + File "main.odoc": + Warning: Failed to resolve module path identifier((root Main).A, false) Lookup failure (module): (root Main).A $ odoc html-generate --source main.ml --indent -o html main.odocl Both modules should contain source links diff --git a/test/sources/source.t/run.t b/test/sources/source.t/run.t index f350b1b810..eb8eec5f03 100644 --- a/test/sources/source.t/run.t +++ b/test/sources/source.t/run.t @@ -88,6 +88,30 @@ Now, compile the pages with the --source option: $ odoc compile -I . --source-name a.ml --source-parent-file src-source.odoc a.cmt $ odoc link -I . a.odoc + File "a.odoc": + Warning: Failed to resolve module path identifier((root A).F, false) Lookup failure (module): (root A).F + File "a.odoc": + Warning: Failed to resolve module path identifier((param (root A).F M), false).A Parent_module: Lookup failure (module): (param (root A).F M) + File "a.odoc": + Warning: Failed to lookup type identifier((root A).a1, false) Lookup failure (type): (root A).a1 + File "a.odoc": + Warning: Failed to resolve module type path identifier((root A).T, false) Lookup failure (module type): (root A).T + File "a.odoc": + Warning: Failed to resolve module path identifier((root A).A, false) Lookup failure (module): (root A).A + File "a.odoc": + Warning: Failed to lookup value identifier((root A).y, false) Lookup failure (value): (root A).y + File "a.odoc": + Warning: Failed to lookup value identifier((root A).{x}2, false) Lookup failure (value): (root A).{x}2 + File "a.odoc": + Warning: Failed to lookup value identifier((root A).{x}2, false) Lookup failure (value): (root A).{x}2 + File "a.odoc": + Warning: Failed to lookup value identifier((root A).y, false) Lookup failure (value): (root A).y + File "a.odoc": + Warning: Failed to lookup value identifier((root A).{x}2, false) Lookup failure (value): (root A).{x}2 + File "a.odoc": + Warning: Failed to lookup value identifier((root A).{x}2, false) Lookup failure (value): (root A).{x}2 + File "a.odoc": + Warning: Failed to lookup value identifier((root A).{x}2, false) Lookup failure (value): (root A).{x}2 $ odoc link -I . page-root.odoc $ odoc link -I . src-source.odoc $ odoc html-generate --indent -o html src-source.odocl @@ -312,4 +336,3 @@ Ids generated in the source code: id="module-FF2" id="module-FF2.argument-1-A.module-E" id="module-FF2.argument-2-A.module-F" - From 549e9c84552bf7d06999273fd6a9f9d1699d0e26 Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Thu, 19 Oct 2023 08:46:58 +0200 Subject: [PATCH 03/41] Occurrence: change datastructure to capture more information Signed-off-by: Paul-Elliot --- src/odoc/occurrences.ml | 101 +++++++++++++++++++++++- test/occurrences/double_wrapped.t/run.t | 15 ++-- test/odoc_print/dune | 2 +- test/odoc_print/occurrences_print.ml | 11 ++- 4 files changed, 114 insertions(+), 15 deletions(-) diff --git a/src/odoc/occurrences.ml b/src/odoc/occurrences.ml index 286f047600..ab57e32acf 100644 --- a/src/odoc/occurrences.ml +++ b/src/odoc/occurrences.ml @@ -22,14 +22,109 @@ let fold_dirs ~dirs ~f ~init = module H = Hashtbl.Make (Odoc_model.Paths.Identifier) +module Occtbl : sig + type item = { direct : int; indirect : int; sub : item H.t } + type t = item H.t + type key = Odoc_model.Paths.Identifier.t + val v : unit -> t + + val add : t -> key -> unit + + val iter : (key -> item -> unit) -> t -> unit + + val get : t -> key -> item option +end = struct + type item = { direct : int; indirect : int; sub : item H.t } + type t = item H.t + type key = Odoc_model.Paths.Identifier.t + + let v_item () = { direct = 0; indirect = 0; sub = H.create 0 } + + let v () = H.create 0 + + let add tbl id = + let rec add ?(kind = `Indirect) id = + let incr htbl id = + let { direct; indirect; sub } = + match H.find_opt htbl id with Some n -> n | None -> v_item () + in + let direct, indirect = + match kind with + | `Direct -> (direct + 1, indirect) + | `Indirect -> (direct, indirect + 1) + in + H.replace htbl id { direct; indirect; sub }; + sub + in + let do_ parent = + let htbl = add (parent :> key) in + incr htbl id + in + match id.iv with + | `InstanceVariable (parent, _) -> do_ parent + | `Parameter (parent, _) -> do_ parent + | `Module (parent, _) -> do_ parent + | `ModuleType (parent, _) -> do_ parent + | `Method (parent, _) -> do_ parent + | `Field (parent, _) -> do_ parent + | `Extension (parent, _) -> do_ parent + | `Type (parent, _) -> do_ parent + | `CoreType _ -> incr tbl id + | `Constructor (parent, _) -> do_ parent + | `Exception (parent, _) -> do_ parent + | `ExtensionDecl (parent, _, _) -> do_ parent + | `Class (parent, _) -> do_ parent + | `Value (parent, _) -> do_ parent + | `ClassType (parent, _) -> do_ parent + | `Root _ -> incr tbl id + | `SourcePage _ | `Page _ | `LeafPage _ | `SourceLocation _ + | `CoreException _ | `Label _ | `SourceLocationMod _ | `Result _ + | `AssetFile _ | `SourceDir _ | `SourceLocationInternal _ -> + assert false + in + let _htbl = add ~kind:`Direct id in + () + + let rec get t id = + let ( >>= ) = Option.bind in + let do_ parent = + get t (parent :> key) >>= fun { sub; _ } -> H.find_opt sub id + in + match id.iv with + | `InstanceVariable (parent, _) -> do_ parent + | `Parameter (parent, _) -> do_ parent + | `Module (parent, _) -> do_ parent + | `ModuleType (parent, _) -> do_ parent + | `Method (parent, _) -> do_ parent + | `Field (parent, _) -> do_ parent + | `Extension (parent, _) -> do_ parent + | `ExtensionDecl (parent, _, _) -> do_ parent + | `Type (parent, _) -> do_ parent + | `Constructor (parent, _) -> do_ parent + | `Exception (parent, _) -> do_ parent + | `Class (parent, _) -> do_ parent + | `Value (parent, _) -> do_ parent + | `ClassType (parent, _) -> do_ parent + | `Root _ -> H.find_opt t id + | `SourcePage _ | `Page _ | `LeafPage _ | `CoreType _ | `SourceLocation _ + | `CoreException _ | `Label _ | `SourceLocationMod _ | `Result _ + | `AssetFile _ | `SourceDir _ | `SourceLocationInternal _ -> + assert false + + let rec iter f tbl = + H.iter + (fun id v -> + iter f v.sub; + f id v) + tbl +end + let count ~dst ~warnings_options:_ directories = let htbl = H.create 100 in let f () (unit : Odoc_model.Lang.Compilation_unit.t) = let incr tbl p p' = let id = Odoc_model.Paths.Path.Resolved.(identifier (p :> t)) in - let old_value = match H.find_opt tbl id with Some n -> n | None -> 0 in - if not Odoc_model.Paths.Path.(is_hidden p') then - H.replace tbl id (old_value + 1) + if not Odoc_model.Paths.Path.(is_hidden p') then Occtbl.add tbl id in let () = List.iter diff --git a/test/occurrences/double_wrapped.t/run.t b/test/occurrences/double_wrapped.t/run.t index 48a9a5f247..d3ff37f904 100644 --- a/test/occurrences/double_wrapped.t/run.t +++ b/test/occurrences/double_wrapped.t/run.t @@ -50,10 +50,11 @@ Uses of values Y.x and Z.y (in b.ml) are not counted since they come from a "loc Uses of values Main__.C.y and Main__.A.x are not rewritten since we use references instead of paths. $ occurrences_print occurrences.txt | sort - Main.A was used 4 times - Main.A.(||>) was used 1 times - Main.A.M was used 2 times - Main.A.t was used 1 times - Main.A.x was used 2 times - Main.B was used 1 times - string was used 1 times + Main was used directly 0 times and indirectly 11 times + Main.A was used directly 4 times and indirectly 6 times + Main.A.(||>) was used directly 1 times and indirectly 0 times + Main.A.M was used directly 2 times and indirectly 0 times + Main.A.t was used directly 1 times and indirectly 0 times + Main.A.x was used directly 2 times and indirectly 0 times + Main.B was used directly 1 times and indirectly 0 times + string was used directly 1 times and indirectly 0 times diff --git a/test/odoc_print/dune b/test/odoc_print/dune index 808b543f1a..af9fe88cde 100644 --- a/test/odoc_print/dune +++ b/test/odoc_print/dune @@ -11,4 +11,4 @@ (executable (name occurrences_print) (modules occurrences_print) - (libraries odoc_model_desc compatcmdliner)) + (libraries odoc_model_desc compatcmdliner odoc_odoc)) diff --git a/test/odoc_print/occurrences_print.ml b/test/odoc_print/occurrences_print.ml index 86d39fade3..7035bf90f8 100644 --- a/test/odoc_print/occurrences_print.ml +++ b/test/odoc_print/occurrences_print.ml @@ -2,11 +2,14 @@ module H = Hashtbl.Make (Odoc_model.Paths.Identifier) let run inp = let ic = open_in_bin inp in - let htbl = Marshal.from_channel ic in - H.iter - (fun id occ -> + let htbl : Odoc_odoc.Occurrences.Occtbl.item Odoc_odoc.Occurrences.H.t = + Marshal.from_channel ic + in + Odoc_odoc.Occurrences.Occtbl.iter + (fun id { Odoc_odoc.Occurrences.Occtbl.direct; indirect; _ } -> let id = String.concat "." (Odoc_model.Paths.Identifier.fullname id) in - Format.printf "%s was used %d times\n" id occ) + Format.printf "%s was used directly %d times and indirectly %d times\n" id + direct indirect) htbl open Compatcmdliner From 72a52f0386825978391121657a75a10daca0b6a2 Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Tue, 24 Oct 2023 13:31:49 +0200 Subject: [PATCH 04/41] Occurrences: add changelog Signed-off-by: Paul-Elliot --- CHANGES.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index 39347bd6f1..7ab0c10c53 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -11,6 +11,8 @@ - Display 'private' keyword for private type extensions (@gpetiot, #1019) - Allow to omit parent type in constructor reference (@panglesd, @EmileTrotignon, #933) +- Add jumps to documentation in rendered source code, and a `count-occurrences` + flag and command to count occurrences of every identifiers (@panglesd, #976) ### Fixed From 93b5ec4098191a0d2608340608160f2945653b39 Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Thu, 2 Nov 2023 11:37:36 +0100 Subject: [PATCH 05/41] remove duplicated function Signed-off-by: Paul-Elliot --- src/loader/implementation.ml | 8 +------- src/loader/typedtree_traverse.ml | 3 +++ 2 files changed, 4 insertions(+), 7 deletions(-) diff --git a/src/loader/implementation.ml b/src/loader/implementation.ml index 344f8fab79..88f3136c67 100644 --- a/src/loader/implementation.ml +++ b/src/loader/implementation.ml @@ -53,18 +53,12 @@ module Env = struct match item.str_desc with | Tstr_module mb -> module_binding env parent mb | Tstr_recmodule mbs -> module_bindings env parent mbs - | Tstr_modtype mtd -> module_type_decl env parent mtd + | Tstr_modtype mtd -> module_type_declaration env parent mtd | Tstr_open _ | Tstr_value _ | Tstr_class _ | Tstr_eval _ | Tstr_class_type _ | Tstr_include _ | Tstr_attribute _ | Tstr_primitive _ | Tstr_type _ | Tstr_typext _ | Tstr_exception _ -> () - and module_type_decl env _parent mtd = - let id = Ident_env.find_module_type env mtd.mtd_id in - match mtd.mtd_type with - | None -> () - | Some mty -> module_type env (id :> Identifier.Signature.t) mty - and module_type env (parent : Identifier.Signature.t) mty = match mty.mty_desc with | Tmty_signature sg -> signature env (parent : Identifier.Signature.t) sg diff --git a/src/loader/typedtree_traverse.ml b/src/loader/typedtree_traverse.ml index 7baac064f2..9c64a1d911 100644 --- a/src/loader/typedtree_traverse.ml +++ b/src/loader/typedtree_traverse.ml @@ -56,6 +56,9 @@ module Analysis = struct () | _ -> () + (* Add module_binding equivalent of pat *) + + let module_expr poses mod_expr = match mod_expr with | { Typedtree.mod_desc = Tmod_ident (p, _); mod_loc; _ } From 9072a83ef7accd42f327a465da8db99ccc681d35 Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Thu, 2 Nov 2023 14:16:11 +0100 Subject: [PATCH 06/41] Do not report resolution warning for occurrences Signed-off-by: Paul-Elliot --- src/xref2/link.ml | 130 ++++++++++++++---------- test/occurrences/double_wrapped.t/run.t | 6 -- test/sources/functor.t/run.t | 8 -- test/sources/lookup_def.t/run.t | 2 - test/sources/recursive_module.t/run.t | 8 -- test/sources/source.t/run.t | 24 ----- 6 files changed, 75 insertions(+), 103 deletions(-) diff --git a/src/xref2/link.ml b/src/xref2/link.ml index 33d5003a77..44fe6e9698 100644 --- a/src/xref2/link.ml +++ b/src/xref2/link.ml @@ -135,8 +135,9 @@ and should_resolve : Paths.Path.t -> bool = (* | `Resolved p -> should_reresolve (p :> Paths.Path.Resolved.t) *) (* | _ -> true *) -let type_path : Env.t -> Paths.Path.Type.t -> Paths.Path.Type.t = - fun env p -> +let type_path : + ?report_errors:bool -> Env.t -> Paths.Path.Type.t -> Paths.Path.Type.t = + fun ?(report_errors = true) env p -> if not (should_resolve (p :> Paths.Path.t)) then p else let cp = Component.Of_Lang.(type_path (empty ()) p) in @@ -150,49 +151,61 @@ let type_path : Env.t -> Paths.Path.Type.t -> Paths.Path.Type.t = let result = Tools.reresolve_type env p' in `Resolved Lang_of.(Path.resolved_type (empty ()) result) | Error e -> - Errors.report ~what:(`Type_path cp) ~tools_error:e `Lookup; + if report_errors then + Errors.report ~what:(`Type_path cp) ~tools_error:e `Lookup; p) -(* let value_path : Env.t -> Paths.Path.Value.t -> Paths.Path.Value.t = *) -(* fun env p -> *) -(* if not (should_resolve (p :> Paths.Path.t)) then p *) -(* else *) -(* let cp = Component.Of_Lang.(value_path (empty ()) p) in *) -(* match cp with *) -(* | `Resolved p -> *) -(* let result = Tools.reresolve_value env p in *) -(* `Resolved Lang_of.(Path.resolved_value (empty ()) result) *) -(* | _ -> ( *) -(* match Tools.resolve_value_path env cp with *) -(* | Ok p' -> *) -(* let result = Tools.reresolve_value env p' in *) -(* `Resolved Lang_of.(Path.resolved_value (empty ()) result) *) -(* | Error e -> *) -(* Errors.report ~what:(`Value_path cp) ~tools_error:e `Lookup; *) -(* p) *) - -(* let constructor_path : *) -(* Env.t -> Paths.Path.Constructor.t -> Paths.Path.Constructor.t = *) -(* fun env p -> *) -(* if not (should_resolve_constructor p) then p *) -(* else *) -(* let cp = Component.Of_Lang.(constructor_path (empty ()) p) in *) -(* match cp with *) -(* | `Resolved p -> *) -(* let result = Tools.reresolve_constructor env p in *) -(* `Resolved Lang_of.(Path.resolved_constructor (empty ()) result) *) -(* | _ -> ( *) -(* match Tools.resolve_constructor_path env cp with *) -(* | Ok p' -> *) -(* let result = Tools.reresolve_constructor env p' in *) -(* `Resolved Lang_of.(Path.resolved_constructor (empty ()) result) *) -(* | Error e -> *) -(* Errors.report ~what:(`Constructor_path cp) ~tools_error:e `Lookup; *) -(* p) *) - -let class_type_path : Env.t -> Paths.Path.ClassType.t -> Paths.Path.ClassType.t - = - fun env p -> +let value_path : + ?report_errors:bool -> Env.t -> Paths.Path.Value.t -> Paths.Path.Value.t = + fun ?(report_errors = true) env p -> + if not (should_resolve (p :> Paths.Path.t)) then p + else + let cp = Component.Of_Lang.(value_path (empty ()) p) in + match cp with + | `Resolved p -> + let result = Tools.reresolve_value env p in + `Resolved Lang_of.(Path.resolved_value (empty ()) result) + | _ -> ( + match Tools.resolve_value_path env cp with + | Ok p' -> + let result = Tools.reresolve_value env p' in + `Resolved Lang_of.(Path.resolved_value (empty ()) result) + | Error e -> + if report_errors then + Errors.report ~what:(`Value_path cp) ~tools_error:e `Lookup; + p) + +let constructor_path : + ?report_errors:bool -> + Env.t -> + Paths.Path.Constructor.t -> + Paths.Path.Constructor.t = + fun ?(report_errors = true) env p -> + (* if not (should_resolve (p : Paths.Path.Constructor.t :> Paths.Path.t)) then p *) + (* else *) + if not (should_resolve_constructor p) then p + else + let cp = Component.Of_Lang.(constructor_path (empty ()) p) in + match cp with + | `Resolved p -> + let result = Tools.reresolve_constructor env p in + `Resolved Lang_of.(Path.resolved_constructor (empty ()) result) + | _ -> ( + match Tools.resolve_constructor_path env cp with + | Ok p' -> + let result = Tools.reresolve_constructor env p' in + `Resolved Lang_of.(Path.resolved_constructor (empty ()) result) + | Error e -> + if report_errors then + Errors.report ~what:(`Constructor_path cp) ~tools_error:e `Lookup; + p) + +let class_type_path : + ?report_errors:bool -> + Env.t -> + Paths.Path.ClassType.t -> + Paths.Path.ClassType.t = + fun ?(report_errors = true) env p -> if not (should_resolve (p :> Paths.Path.t)) then p else let cp = Component.Of_Lang.(class_type_path (empty ()) p) in @@ -206,12 +219,16 @@ let class_type_path : Env.t -> Paths.Path.ClassType.t -> Paths.Path.ClassType.t let result = Tools.reresolve_class_type env p' in `Resolved Lang_of.(Path.resolved_class_type (empty ()) result) | Error e -> - Errors.report ~what:(`Class_type_path cp) ~tools_error:e `Lookup; + if report_errors then + Errors.report ~what:(`Class_type_path cp) ~tools_error:e `Lookup; p) and module_type_path : - Env.t -> Paths.Path.ModuleType.t -> Paths.Path.ModuleType.t = - fun env p -> + ?report_errors:bool -> + Env.t -> + Paths.Path.ModuleType.t -> + Paths.Path.ModuleType.t = + fun ?(report_errors = true) env p -> if not (should_resolve (p :> Paths.Path.t)) then p else let cp = Component.Of_Lang.(module_type_path (empty ()) p) in @@ -225,11 +242,13 @@ and module_type_path : let result = Tools.reresolve_module_type env p' in `Resolved Lang_of.(Path.resolved_module_type (empty ()) result) | Error e -> - Errors.report ~what:(`Module_type_path cp) ~tools_error:e `Resolve; + if report_errors then + Errors.report ~what:(`Module_type_path cp) ~tools_error:e `Resolve; p) -and module_path : Env.t -> Paths.Path.Module.t -> Paths.Path.Module.t = - fun env p -> +and module_path : + ?report_errors:bool -> Env.t -> Paths.Path.Module.t -> Paths.Path.Module.t = + fun ?(report_errors = true) env p -> if not (should_resolve (p :> Paths.Path.t)) then p else let cp = Component.Of_Lang.(module_path (empty ()) p) in @@ -244,7 +263,8 @@ and module_path : Env.t -> Paths.Path.Module.t -> Paths.Path.Module.t = `Resolved Lang_of.(Path.resolved_module (empty ()) result) | Error _ when is_forward p -> p | Error e -> - Errors.report ~what:(`Module_path cp) ~tools_error:e `Resolve; + if report_errors then + Errors.report ~what:(`Module_path cp) ~tools_error:e `Resolve; p) let rec comment_inline_element : @@ -433,16 +453,16 @@ let rec unit env t = Value (jump_to v (Shape_tools.lookup_value_path env) - (value_path env)) + (value_path ~report_errors:false env)) | Module v -> - Module (jump_to v (fun _ -> None) (module_path env)) + Module (jump_to v (fun _ -> None) (module_path ~report_errors:false env)) | ModuleType v -> ModuleType - (jump_to v (fun _ -> None) (module_type_path env)) - | Type v -> Type (jump_to v (fun _ -> None) (type_path env)) + (jump_to v (fun _ -> None) (module_type_path ~report_errors:false env)) + | Type v -> Type (jump_to v (fun _ -> None) (type_path ~report_errors:false env)) | Constructor v -> Constructor - (jump_to v (fun _ -> None) (constructor_path env)) + (jump_to v (fun _ -> None) (constructor_path ~report_errors:false env)) | i -> i in (info, pos)) diff --git a/test/occurrences/double_wrapped.t/run.t b/test/occurrences/double_wrapped.t/run.t index d3ff37f904..e87a140d68 100644 --- a/test/occurrences/double_wrapped.t/run.t +++ b/test/occurrences/double_wrapped.t/run.t @@ -23,13 +23,7 @@ occurrences information. $ odoc link -I . main.odoc $ odoc link -I . main__A.odoc $ odoc link -I . main__B.odoc - File "main__B.odoc": - Warning: Failed to lookup value identifier((root Main__B).Z, false).y Parent_module: Lookup failure (module): (root Main__B).Z - File "main__B.odoc": - Warning: Failed to lookup value identifier((root Main__B).Y, false).x Parent_module: Lookup failure (module): (root Main__B).Y $ odoc link -I . main__C.odoc - File "main__C.odoc": - Warning: Failed to lookup value identifier((root Main__C).Y, false).x Parent_module: Lookup failure (module): (root Main__C).Y $ odoc link -I . main__.odoc The count occurrences command outputs a marshalled hashtable, whose keys are diff --git a/test/sources/functor.t/run.t b/test/sources/functor.t/run.t index 1b41b151bd..4bca693672 100644 --- a/test/sources/functor.t/run.t +++ b/test/sources/functor.t/run.t @@ -12,16 +12,8 @@ Verify the behavior on functors. $ odoc compile --source-name a.ml --source-parent-file src-source.odoc -I . a.cmt $ odoc compile --source-name b.ml --source-parent-file src-source.odoc -I . b.cmt $ odoc link -I . s.odoc - File "s.odoc": - Warning: Failed to lookup type identifier((root S).S.t, false) Lookup failure (type): (root S).S.t $ odoc link -I . a.odoc - File "a.odoc": - Warning: Failed to lookup value identifier((param (root A).F S), false).x Parent_module: Lookup failure (module): (param (root A).F S) - File "a.odoc": - Warning: Failed to lookup type identifier((param (root A).F S), false).t Parent_module: Lookup failure (module): (param (root A).F S) $ odoc link -I . b.odoc - File "b.odoc": - Warning: Failed to resolve module path identifier((root B).S, false) Lookup failure (module): (root B).S $ odoc html-generate --source s.ml --indent -o html s.odocl $ odoc html-generate --source a.ml --indent -o html a.odocl $ odoc html-generate --source b.ml --indent -o html b.odocl diff --git a/test/sources/lookup_def.t/run.t b/test/sources/lookup_def.t/run.t index 944b6741fd..f6c30e1045 100644 --- a/test/sources/lookup_def.t/run.t +++ b/test/sources/lookup_def.t/run.t @@ -8,8 +8,6 @@ Compile the modules: $ ocamlc -c a.mli a.ml -bin-annot $ odoc compile --cmt a.cmt --source-name a.ml --source-parent-file src-source.odoc -I . a.cmti $ odoc link a.odoc - File "a.odoc": - Warning: Failed to resolve module type path identifier((root A).N.S, false) Lookup failure (module type): (root A).N.S Show the locations: diff --git a/test/sources/recursive_module.t/run.t b/test/sources/recursive_module.t/run.t index 0f8a5517ba..aba686595a 100644 --- a/test/sources/recursive_module.t/run.t +++ b/test/sources/recursive_module.t/run.t @@ -8,14 +8,6 @@ Checking that source links exists inside recursive modules. $ ocamlc -c main.ml -bin-annot -I . $ odoc compile --source-name main.ml --source-parent-file src-source.odoc -I . main.cmt $ odoc link -I . main.odoc - File "main.odoc": - Warning: Failed to lookup type identifier((root Main).A, false).t Parent_module: Lookup failure (module): (root Main).A - File "main.odoc": - Warning: Failed to resolve module path identifier((root Main).B, false) Lookup failure (module): (root Main).B - File "main.odoc": - Warning: Failed to lookup type identifier((root Main).B, false).t Parent_module: Lookup failure (module): (root Main).B - File "main.odoc": - Warning: Failed to resolve module path identifier((root Main).A, false) Lookup failure (module): (root Main).A $ odoc html-generate --source main.ml --indent -o html main.odocl Both modules should contain source links diff --git a/test/sources/source.t/run.t b/test/sources/source.t/run.t index eb8eec5f03..ccd15b178e 100644 --- a/test/sources/source.t/run.t +++ b/test/sources/source.t/run.t @@ -88,30 +88,6 @@ Now, compile the pages with the --source option: $ odoc compile -I . --source-name a.ml --source-parent-file src-source.odoc a.cmt $ odoc link -I . a.odoc - File "a.odoc": - Warning: Failed to resolve module path identifier((root A).F, false) Lookup failure (module): (root A).F - File "a.odoc": - Warning: Failed to resolve module path identifier((param (root A).F M), false).A Parent_module: Lookup failure (module): (param (root A).F M) - File "a.odoc": - Warning: Failed to lookup type identifier((root A).a1, false) Lookup failure (type): (root A).a1 - File "a.odoc": - Warning: Failed to resolve module type path identifier((root A).T, false) Lookup failure (module type): (root A).T - File "a.odoc": - Warning: Failed to resolve module path identifier((root A).A, false) Lookup failure (module): (root A).A - File "a.odoc": - Warning: Failed to lookup value identifier((root A).y, false) Lookup failure (value): (root A).y - File "a.odoc": - Warning: Failed to lookup value identifier((root A).{x}2, false) Lookup failure (value): (root A).{x}2 - File "a.odoc": - Warning: Failed to lookup value identifier((root A).{x}2, false) Lookup failure (value): (root A).{x}2 - File "a.odoc": - Warning: Failed to lookup value identifier((root A).y, false) Lookup failure (value): (root A).y - File "a.odoc": - Warning: Failed to lookup value identifier((root A).{x}2, false) Lookup failure (value): (root A).{x}2 - File "a.odoc": - Warning: Failed to lookup value identifier((root A).{x}2, false) Lookup failure (value): (root A).{x}2 - File "a.odoc": - Warning: Failed to lookup value identifier((root A).{x}2, false) Lookup failure (value): (root A).{x}2 $ odoc link -I . page-root.odoc $ odoc link -I . src-source.odoc $ odoc html-generate --indent -o html src-source.odocl From 5afcb1d42173f38fe30d6f9d47020c55ffa584ad Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Thu, 2 Nov 2023 14:34:35 +0100 Subject: [PATCH 07/41] Occurrences: Rename Definition to LocalDefinition when applicable Signed-off-by: Paul-Elliot --- src/loader/implementation.ml | 20 ++++++++++---------- src/loader/typedtree_traverse.ml | 4 ++-- 2 files changed, 12 insertions(+), 12 deletions(-) diff --git a/src/loader/implementation.ml b/src/loader/implementation.ml index 88f3136c67..4dbece1fa8 100644 --- a/src/loader/implementation.ml +++ b/src/loader/implementation.ml @@ -141,10 +141,10 @@ module UidHashtbl = Shape.Uid.Tbl (* Adds the local definitions found in traverse infos to the [loc_to_id] and [ident_to_id] tables. *) -let populate_local_defs source_id poses loc_to_id ident_to_loc = +let populate_local_defs source_id poses loc_to_id local_ident_to_loc = List.iter (function - | Typedtree_traverse.Analysis.Definition id, loc -> + | Typedtree_traverse.Analysis.LocalDefinition id, loc -> let name = Odoc_model.Names.LocalName.make_std (Printf.sprintf "local_%s_%d" (Ident.name id) (counter ())) @@ -157,7 +157,7 @@ let populate_local_defs source_id poses loc_to_id ident_to_loc = LocHashtbl.add loc_to_id loc identifier | None -> () ); - IdentHashtbl.add ident_to_loc id loc; + IdentHashtbl.add local_ident_to_loc id loc; | _ -> ()) poses @@ -281,13 +281,13 @@ let (>>=) a b = Option.map b a (* Extract [Typedtree_traverse] occurrence information and turn them into proper source infos *) -let process_occurrences env poses loc_to_id ident_to_loc = +let process_occurrences env poses loc_to_id local_ident_to_loc = let open Odoc_model.Lang.Source_info in let process p find_in_env = match p with - | Path.Pident id when IdentHashtbl.mem ident_to_loc id -> ( + | Path.Pident id when IdentHashtbl.mem local_ident_to_loc id -> ( match - LocHashtbl.find_opt loc_to_id (IdentHashtbl.find ident_to_loc id) + LocHashtbl.find_opt loc_to_id (IdentHashtbl.find local_ident_to_loc id) with | None -> None | Some id -> @@ -321,7 +321,7 @@ let process_occurrences env poses loc_to_id ident_to_loc = | Constructor _p, loc -> (* process p Ident_env.Path.read_constructor *) None >>= fun l -> (Constructor l, pos_of_loc loc) - | Definition _, _ -> None) + | LocalDefinition _, _ -> None) poses @@ -348,15 +348,15 @@ let read_cmt_infos source_id_opt id cmt_info ~count_occurrences = not modify the anchors for existing anchors. *) in let loc_to_id = LocHashtbl.create 10 - and ident_to_loc = IdentHashtbl.create 10 + and local_ident_to_loc = IdentHashtbl.create 10 and uid_to_id = UidHashtbl.create 10 in let () = (* populate [loc_to_id], [ident_to_id] and [uid_to_id] *) - populate_local_defs source_id traverse_infos loc_to_id ident_to_loc; + populate_local_defs source_id traverse_infos loc_to_id local_ident_to_loc; populate_global_defs env source_id loc_to_id uid_to_loc uid_to_id in let source_infos = - process_occurrences env traverse_infos loc_to_id ident_to_loc + process_occurrences env traverse_infos loc_to_id local_ident_to_loc |> add_definitions loc_to_id in ( Some (shape, Shape.Uid.Tbl.to_map uid_to_id), diff --git a/src/loader/typedtree_traverse.ml b/src/loader/typedtree_traverse.ml index 9c64a1d911..1a04257db6 100644 --- a/src/loader/typedtree_traverse.ml +++ b/src/loader/typedtree_traverse.ml @@ -2,7 +2,7 @@ module Analysis = struct type annotation = - | Definition of Ident.t + | LocalDefinition of Ident.t | Value of Path.t | Module of Path.t | ClassType of Path.t @@ -38,7 +38,7 @@ module Analysis = struct in let maybe_localvalue id loc = match Ident_env.identifier_of_loc env loc with - | None -> Some (Definition id, loc) + | None -> Some (LocalDefinition id, loc) | Some _ -> None in let () = From 06d55d2c38d68e33d2084da846122bd96bd94024 Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Thu, 2 Nov 2023 14:56:18 +0100 Subject: [PATCH 08/41] Occurrences: remove duplicated source infos Some subnodes of hidden nodes were generating twice the infos Signed-off-by: Paul-Elliot --- src/loader/implementation.ml | 46 +++++++++++++++++++++--------------- 1 file changed, 27 insertions(+), 19 deletions(-) diff --git a/src/loader/implementation.ml b/src/loader/implementation.ml index 4dbece1fa8..910b13a30f 100644 --- a/src/loader/implementation.ml +++ b/src/loader/implementation.ml @@ -137,6 +137,12 @@ module IdentHashtbl = Hashtbl.Make (struct let hash = Hashtbl.hash end) +module AnnotHashtbl = Hashtbl.Make (struct + type t = Odoc_model.Lang.Source_info.annotation Odoc_model.Lang.Source_info.with_pos + let equal l1 l2 = l1 = l2 + let hash = Hashtbl.hash +end) + module UidHashtbl = Shape.Uid.Tbl (* Adds the local definitions found in traverse infos to the [loc_to_id] and @@ -277,17 +283,18 @@ let populate_global_defs env source_id loc_to_id uid_to_loc uid_to_id = | _ -> ())) uid_to_loc -let (>>=) a b = Option.map b a - (* Extract [Typedtree_traverse] occurrence information and turn them into proper source infos *) let process_occurrences env poses loc_to_id local_ident_to_loc = let open Odoc_model.Lang.Source_info in + (* Ensure source infos are not repeated by putting them in a Set (a unit hashtbl) *) + let occ_tbl = AnnotHashtbl.create 100 in let process p find_in_env = match p with | Path.Pident id when IdentHashtbl.mem local_ident_to_loc id -> ( match - LocHashtbl.find_opt loc_to_id (IdentHashtbl.find local_ident_to_loc id) + LocHashtbl.find_opt loc_to_id + (IdentHashtbl.find local_ident_to_loc id) with | None -> None | Some id -> @@ -301,29 +308,30 @@ let process_occurrences env poses loc_to_id local_ident_to_loc = Some { documentation; implementation } | exception _ -> None) in - List.filter_map + List.iter (function | Typedtree_traverse.Analysis.Value p, loc -> - process p Ident_env.Path.read_value >>= fun l -> - (Value l, pos_of_loc loc) + process p Ident_env.Path.read_value |> Option.iter @@ fun l -> + AnnotHashtbl.replace occ_tbl (Value l, pos_of_loc loc) () | Module p, loc -> - process p Ident_env.Path.read_module >>= fun l -> - (Module l, pos_of_loc loc) + process p Ident_env.Path.read_module |> Option.iter @@ fun l -> + AnnotHashtbl.replace occ_tbl (Module l, pos_of_loc loc) () | ClassType p, loc -> - process p Ident_env.Path.read_class_type >>= fun l -> - (ClassType l, pos_of_loc loc) + process p Ident_env.Path.read_class_type |> Option.iter @@ fun l -> + AnnotHashtbl.replace occ_tbl (ClassType l, pos_of_loc loc) () | ModuleType p, loc -> - process p Ident_env.Path.read_module_type >>= fun l -> - (ModuleType l, pos_of_loc loc) + process p Ident_env.Path.read_module_type |> Option.iter @@ fun l -> + AnnotHashtbl.replace occ_tbl (ModuleType l, pos_of_loc loc) () | Type p, loc -> - process p Ident_env.Path.read_type >>= fun l -> - (Type l, pos_of_loc loc) + process p Ident_env.Path.read_type |> Option.iter @@ fun l -> + AnnotHashtbl.replace occ_tbl (Type l, pos_of_loc loc) () | Constructor _p, loc -> - (* process p Ident_env.Path.read_constructor *) None >>= fun l -> - (Constructor l, pos_of_loc loc) - | LocalDefinition _, _ -> None) - poses - + (* process p Ident_env.Path.read_constructor *) + None |> Option.iter @@ fun l -> + AnnotHashtbl.replace occ_tbl (Constructor l, pos_of_loc loc) () + | LocalDefinition _, _ -> ()) + poses; + AnnotHashtbl.fold (fun k () acc -> k :: acc) occ_tbl [] (* Add definition source info from the [loc_to_id] table *) let add_definitions loc_to_id occurrences = From 74c54c5bd56d81f0ef27fe4b11aa8eb5ae1baea7 Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Thu, 2 Nov 2023 16:25:54 +0100 Subject: [PATCH 09/41] Occurrence: collect local module definitions Signed-off-by: Paul-Elliot --- src/loader/typedtree_traverse.ml | 13 ++++++-- src/odoc/occurrences.ml | 2 +- src/xref2/link.ml | 52 +++++++++++++++++++++----------- 3 files changed, 46 insertions(+), 21 deletions(-) diff --git a/src/loader/typedtree_traverse.ml b/src/loader/typedtree_traverse.ml index 1a04257db6..8b5a96a97f 100644 --- a/src/loader/typedtree_traverse.ml +++ b/src/loader/typedtree_traverse.ml @@ -56,8 +56,12 @@ module Analysis = struct () | _ -> () - (* Add module_binding equivalent of pat *) - + let module_binding env poses = function + | { Typedtree.mb_id = Some id; mb_loc; _ } when not mb_loc.loc_ghost -> ( + match Ident_env.identifier_of_loc env mb_loc with + | None -> poses := (LocalDefinition id, mb_loc) :: !poses + | Some _ -> ()) + | _ -> () let module_expr poses mod_expr = match mod_expr with @@ -114,6 +118,10 @@ let of_cmt env structure = Analysis.class_type poses cl_type; Tast_iterator.default_iterator.class_type iterator cl_type in + let module_binding iterator mb = + Analysis.module_binding env poses mb; + Tast_iterator.default_iterator.module_binding iterator mb + in let iterator = { Tast_iterator.default_iterator with @@ -123,6 +131,7 @@ let of_cmt env structure = typ; module_type; class_type; + module_binding; } in iterator.structure iterator structure; diff --git a/src/odoc/occurrences.ml b/src/odoc/occurrences.ml index ab57e32acf..e36fb1dbbb 100644 --- a/src/odoc/occurrences.ml +++ b/src/odoc/occurrences.ml @@ -77,7 +77,7 @@ end = struct | `Value (parent, _) -> do_ parent | `ClassType (parent, _) -> do_ parent | `Root _ -> incr tbl id - | `SourcePage _ | `Page _ | `LeafPage _ | `SourceLocation _ + | `SourcePage _ | `Page _ | `LeafPage _ | `SourceLocation _ | `CoreException _ | `Label _ | `SourceLocationMod _ | `Result _ | `AssetFile _ | `SourceDir _ | `SourceLocationInternal _ -> assert false diff --git a/src/xref2/link.ml b/src/xref2/link.ml index 44fe6e9698..78e54be859 100644 --- a/src/xref2/link.ml +++ b/src/xref2/link.ml @@ -185,20 +185,20 @@ let constructor_path : (* else *) if not (should_resolve_constructor p) then p else - let cp = Component.Of_Lang.(constructor_path (empty ()) p) in - match cp with - | `Resolved p -> - let result = Tools.reresolve_constructor env p in - `Resolved Lang_of.(Path.resolved_constructor (empty ()) result) - | _ -> ( - match Tools.resolve_constructor_path env cp with - | Ok p' -> - let result = Tools.reresolve_constructor env p' in - `Resolved Lang_of.(Path.resolved_constructor (empty ()) result) - | Error e -> - if report_errors then - Errors.report ~what:(`Constructor_path cp) ~tools_error:e `Lookup; - p) + let cp = Component.Of_Lang.(constructor_path (empty ()) p) in + match cp with + | `Resolved p -> + let result = Tools.reresolve_constructor env p in + `Resolved Lang_of.(Path.resolved_constructor (empty ()) result) + | _ -> ( + match Tools.resolve_constructor_path env cp with + | Ok p' -> + let result = Tools.reresolve_constructor env p' in + `Resolved Lang_of.(Path.resolved_constructor (empty ()) result) + | Error e -> + if report_errors then + Errors.report ~what:(`Constructor_path cp) ~tools_error:e `Lookup; + p) let class_type_path : ?report_errors:bool -> @@ -427,6 +427,11 @@ let rec unit env t = | Pack _ as p -> p in let source_info = + let env = + match t.content with + | Module sg -> Env.open_signature sg env |> Env.add_docs sg.doc + | Pack _ -> env + in let open Source_info in match t.source_info with | Some inf -> @@ -455,14 +460,25 @@ let rec unit env t = (Shape_tools.lookup_value_path env) (value_path ~report_errors:false env)) | Module v -> - Module (jump_to v (fun _ -> None) (module_path ~report_errors:false env)) + Module + (jump_to v + (fun _ -> None) + (module_path ~report_errors:false env)) | ModuleType v -> ModuleType - (jump_to v (fun _ -> None) (module_type_path ~report_errors:false env)) - | Type v -> Type (jump_to v (fun _ -> None) (type_path ~report_errors:false env)) + (jump_to v + (fun _ -> None) + (module_type_path ~report_errors:false env)) + | Type v -> + Type + (jump_to v + (fun _ -> None) + (type_path ~report_errors:false env)) | Constructor v -> Constructor - (jump_to v (fun _ -> None) (constructor_path ~report_errors:false env)) + (jump_to v + (fun _ -> None) + (constructor_path ~report_errors:false env)) | i -> i in (info, pos)) From 1e2f674db95cdfcf7f1355b02aa908175e951a60 Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Thu, 2 Nov 2023 17:17:19 +0100 Subject: [PATCH 10/41] Render source code: Add jump to implementation for modules Signed-off-by: Paul-Elliot --- src/xref2/link.ml | 2 +- src/xref2/shape_tools.cppo.ml | 24 +++++++++++++++++------- src/xref2/shape_tools.cppo.mli | 5 +++++ test/sources/source.t/run.t | 2 +- 4 files changed, 24 insertions(+), 9 deletions(-) diff --git a/src/xref2/link.ml b/src/xref2/link.ml index 78e54be859..12071b6b76 100644 --- a/src/xref2/link.ml +++ b/src/xref2/link.ml @@ -462,7 +462,7 @@ let rec unit env t = | Module v -> Module (jump_to v - (fun _ -> None) + (Shape_tools.lookup_module_path env) (module_path ~report_errors:false env)) | ModuleType v -> ModuleType diff --git a/src/xref2/shape_tools.cppo.ml b/src/xref2/shape_tools.cppo.ml index 5d516dd926..a6bf903791 100644 --- a/src/xref2/shape_tools.cppo.ml +++ b/src/xref2/shape_tools.cppo.ml @@ -56,11 +56,11 @@ let rec shape_of_id env : let rec shape_of_module_path env : _ -> Shape.t option = let proj parent kind name = let item = Shape.Item.make name kind in - match shape_of_module_path env (parent :> Odoc_model.Paths.Path.t) with + match shape_of_module_path env (parent :> Odoc_model.Paths.Path.Module.t) with | Some shape -> Some (Shape.proj shape item) | None -> None in - fun (path : Odoc_model.Paths.Path.t) -> + fun (path : Odoc_model.Paths.Path.Module.t) -> match path with | `Resolved _ -> None | `Root name -> ( @@ -72,11 +72,11 @@ let rec shape_of_module_path env : _ -> Shape.t option = | _ -> None) | `Forward _ -> None | `Dot (parent, name) -> - proj (parent :> Odoc_model.Paths.Path.t) Kind.Module name + proj (parent :> Odoc_model.Paths.Path.Module.t) Kind.Module name | `Apply (parent, arg) -> - shape_of_module_path env (parent :> Odoc_model.Paths.Path.t) + shape_of_module_path env (parent :> Odoc_model.Paths.Path.Module.t) >>= fun parent -> - shape_of_module_path env (arg :> Odoc_model.Paths.Path.t) >>= fun arg -> + shape_of_module_path env (arg :> Odoc_model.Paths.Path.Module.t) >>= fun arg -> Some (Shape.app parent ~arg) | `Identifier (id, _) -> shape_of_id env (id :> Odoc_model.Paths.Identifier.NonSrc.t) @@ -85,14 +85,14 @@ let shape_of_value_path env : Odoc_model.Paths.Path.Value.t -> Shape.t option = let proj parent kind name = let item = Shape.Item.make name kind in - match shape_of_module_path env (parent :> Odoc_model.Paths.Path.t) with + match shape_of_module_path env parent with | Some shape -> Some (Shape.proj shape item) | None -> None in fun (path : Odoc_model.Paths.Path.Value.t) -> match path with | `Resolved _ -> None - | `Dot (parent, name) -> proj (parent :> Odoc_model.Paths.Path.t) Kind.Value name + | `Dot (parent, name) -> proj parent Kind.Value name | `Identifier (id, _) -> shape_of_id env (id :> Odoc_model.Paths.Identifier.NonSrc.t) @@ -160,6 +160,16 @@ let lookup_value_path : | None -> None | Some query -> lookup_shape env query + +let lookup_module_path : + Env.t -> + Path.Module.t -> + Identifier.SourceLocation.t option + = fun env path -> + match shape_of_module_path env path with + | None -> None + | Some query -> lookup_shape env query + #else type t = unit diff --git a/src/xref2/shape_tools.cppo.mli b/src/xref2/shape_tools.cppo.mli index 607d50b8dc..40caf7b433 100644 --- a/src/xref2/shape_tools.cppo.mli +++ b/src/xref2/shape_tools.cppo.mli @@ -18,3 +18,8 @@ val lookup_value_path : Env.t -> Path.Value.t -> Identifier.SourceLocation.t option + +val lookup_module_path : + Env.t -> + Path.Module.t -> + Identifier.SourceLocation.t option diff --git a/test/sources/source.t/run.t b/test/sources/source.t/run.t index ccd15b178e..9adb34e60c 100644 --- a/test/sources/source.t/run.t +++ b/test/sources/source.t/run.t @@ -307,7 +307,7 @@ Ids generated in the source code: id="module-F.argument-1-M.module-A" id="module-F.module-B" id="module-FM" - id="def_3" + id="local_A_3" id="module-FF" id="module-FF2" id="module-FF2.argument-1-A.module-E" From f28e89864aa0204c500a34f6b0e3b45b347a5410 Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Fri, 3 Nov 2023 00:12:06 +0100 Subject: [PATCH 11/41] Occurrences: style improvements Signed-off-by: Paul-Elliot --- src/document/generator.ml | 15 +++++++-------- src/xref2/link.ml | 2 +- 2 files changed, 8 insertions(+), 9 deletions(-) diff --git a/src/document/generator.ml b/src/document/generator.ml index bb411cacfb..338d3a4579 100644 --- a/src/document/generator.ml +++ b/src/document/generator.ml @@ -252,7 +252,7 @@ module Make (Syntax : SYNTAX) = struct let path id = Url.Path.from_identifier id let url id = Url.from_path (path id) - let to_link documentation implementation = + let to_link {Lang.Source_info.documentation; implementation} = let documentation = let open Paths.Path.Resolved in match documentation with @@ -281,13 +281,12 @@ module Make (Syntax : SYNTAX) = struct | `SourceLocationInternal (_, local) -> Some (Anchor (LocalName.to_string local)) | _ -> None) - | Module { documentation; _ } -> to_link documentation None - | ModuleType { documentation; _ } -> to_link documentation None - | Type { documentation; _ } -> to_link documentation None - | ClassType { documentation; _ } -> to_link documentation None - | Value { documentation; implementation } -> - to_link documentation implementation - | Constructor { documentation; _ } -> to_link documentation None + | Module v -> to_link v + | ModuleType v -> to_link v + | Type v -> to_link v + | ClassType v -> to_link v + | Value v -> to_link v + | Constructor v -> to_link v let source id syntax_info infos source_code = let url = path id in diff --git a/src/xref2/link.ml b/src/xref2/link.ml index 12071b6b76..e159f913c6 100644 --- a/src/xref2/link.ml +++ b/src/xref2/link.ml @@ -429,7 +429,7 @@ let rec unit env t = let source_info = let env = match t.content with - | Module sg -> Env.open_signature sg env |> Env.add_docs sg.doc + | Module sg -> Env.open_signature sg env | Pack _ -> env in let open Source_info in From f8bbc76298face56d875fd35bcfc9f5cd39d6dde Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Fri, 3 Nov 2023 00:24:10 +0100 Subject: [PATCH 12/41] Occurrences: add a command to aggregate occurrence tables Signed-off-by: Paul-Elliot --- src/odoc/bin/main.ml | 88 +++++++++++++++++++------ src/odoc/occurrences.ml | 55 +++++++++++++++- test/occurrences/double_wrapped.t/run.t | 74 +++++++++++++++++++-- test/odoc_print/occurrences_print.ml | 2 +- 4 files changed, 192 insertions(+), 27 deletions(-) diff --git a/src/odoc/bin/main.ml b/src/odoc/bin/main.ml index 3ecb9596e7..2f40e9e25b 100644 --- a/src/odoc/bin/main.ml +++ b/src/odoc/bin/main.ml @@ -1111,27 +1111,74 @@ module Targets = struct end module Occurrences = struct - let index directories dst warnings_options = - let dst = Fpath.v dst in - Occurrences.count ~dst ~warnings_options directories + module Count = struct + let index directories dst warnings_options = + let dst = Fpath.v dst in + Occurrences.count ~dst ~warnings_options directories - let cmd = - let dst = - let doc = "Output file path." in - Arg.( - required & opt (some string) None & info ~docs ~docv:"PATH" ~doc [ "o" ]) - in - Term.( - const handle_error - $ (const index $ odoc_file_directories $ dst $ warnings_options)) + let cmd = + let dst = + let doc = "Output file path." in + Arg.( + required + & opt (some string) None + & info ~docs ~docv:"PATH" ~doc [ "o" ]) + in + Term.( + const handle_error + $ (const index $ odoc_file_directories $ dst $ warnings_options)) - let info ~docs = - let doc = - "Generate a hashtable mapping identifiers to number of occurrences, as \ - computed from the implementations of .odocl files found in the given \ - directories." - in - Term.info "count-occurrences" ~docs ~doc + let info ~docs = + let doc = + "Generate a hashtable mapping identifiers to number of occurrences, as \ + computed from the implementations of .odocl files found in the given \ + directories." + in + Term.info "count-occurrences" ~docs ~doc + end + module Aggregate = struct + let index dst files file_list warnings_options = + match (files, file_list) with + | [], [] -> + Error + (`Msg + "At least one of --file-list or a path to a file must be passed \ + to odoc aggregate-occurrences") + | _ -> + let dst = Fpath.v dst in + Occurrences.aggregate ~dst ~warnings_options files file_list + + let cmd = + let dst = + let doc = "Output file path." in + Arg.( + required + & opt (some string) None + & info ~docs ~docv:"PATH" ~doc [ "o" ]) + in + let inputs_in_file = + let doc = + "Input text file containing a line-separated list of paths to files \ + created with count-occurrences." + in + Arg.( + value & opt_all convert_fpath [] + & info ~doc ~docv:"FILE" [ "file-list" ]) + in + let inputs = + let doc = "file created with count-occurrences" in + Arg.(value & pos_all convert_fpath [] & info ~doc ~docv:"FILE" []) + in + Term.( + const handle_error + $ (const index $ dst $ inputs $ inputs_in_file $ warnings_options)) + + let info ~docs = + let doc = + "Aggregate hashtables created with odoc count-occurrences." + in + Term.info "aggregate-occurrences" ~docs ~doc + end end module Odoc_error = struct @@ -1174,7 +1221,8 @@ let () = Printexc.record_backtrace true; let subcommands = [ - Occurrences.(cmd, info ~docs:section_pipeline); + Occurrences.Count.(cmd, info ~docs:section_pipeline); + Occurrences.Aggregate.(cmd, info ~docs:section_pipeline); Compile.(cmd, info ~docs:section_pipeline); Odoc_link.(cmd, info ~docs:section_pipeline); Odoc_html.generate ~docs:section_pipeline; diff --git a/src/odoc/occurrences.ml b/src/odoc/occurrences.ml index e36fb1dbbb..8d0f4d9ee0 100644 --- a/src/odoc/occurrences.ml +++ b/src/odoc/occurrences.ml @@ -142,7 +142,10 @@ let count ~dst ~warnings_options:_ directories = | Type { documentation = Some (`Resolved p as p'); _ }, _ -> incr htbl p Odoc_model.Paths.Path.((p' : Type.t :> t)) | _ -> ()) - (match unit.source_info with None -> [] | Some i -> i.infos) + (match unit.source_info with + | None -> [] + | Some i -> + i.infos) in () in @@ -151,3 +154,53 @@ let count ~dst ~warnings_options:_ directories = let oc = open_out_bin (Fs.File.to_string dst) in Marshal.to_channel oc htbl []; Ok () + +open Astring +open Or_error + +let parse_input_file input = + let is_sep = function '\n' | '\r' -> true | _ -> false in + Fs.File.read input >>= fun content -> + let files = + String.fields ~empty:false ~is_sep content |> List.rev_map Fs.File.of_string + in + Ok files + +let parse_input_files input = + List.fold_left + (fun acc file -> + acc >>= fun acc -> + parse_input_file file >>= fun files -> Ok (files :: acc)) + (Ok []) input + >>= fun files -> Ok (List.concat files) + +let aggregate files file_list ~warnings_options:_ ~dst = + parse_input_files file_list >>= fun new_files -> + let files = files @ new_files in + let from_file file : Occtbl.t = + let ic = open_in_bin (Fs.File.to_string file) in + Marshal.from_channel ic + in + let rec loop n f = + if n > 0 then ( + f (); + loop (n - 1) f) + else () + in + let occtbl = + match files with + | [] -> H.create 0 + | file1 :: files -> + let acc = from_file file1 in + List.iter + (fun file -> + Occtbl.iter + (fun id { direct; _ } -> + loop direct (fun () -> Occtbl.add acc id)) + (from_file file)) + files; + acc + in + let oc = open_out_bin (Fs.File.to_string dst) in + Marshal.to_channel oc occtbl []; + Ok () diff --git a/test/occurrences/double_wrapped.t/run.t b/test/occurrences/double_wrapped.t/run.t index e87a140d68..b29ba69aaa 100644 --- a/test/occurrences/double_wrapped.t/run.t +++ b/test/occurrences/double_wrapped.t/run.t @@ -13,7 +13,6 @@ The module B depends on both B and C, the module C only depends on A. Passing the count-occurrences flag to odoc compile makes it collect the occurrences information. - $ odoc compile --count-occurrences -I . main__A.cmt $ odoc compile --count-occurrences -I . main__C.cmt $ odoc compile --count-occurrences -I . main__B.cmt @@ -26,11 +25,34 @@ occurrences information. $ odoc link -I . main__C.odoc $ odoc link -I . main__.odoc + $ odoc html-generate -o html main.odocl + $ odoc html-generate -o html main__A.odocl + $ odoc html-generate -o html main__B.odocl + $ odoc html-generate -o html main__C.odocl + $ odoc html-generate -o html main__.odocl + The count occurrences command outputs a marshalled hashtable, whose keys are odoc identifiers, and whose values are integers corresponding to the number of -uses. +uses. We can later aggregate those hashtables, so we create the full hashtable, +and a hashtable for each compilation unit. + + $ mkdir dir1 + $ mkdir dir2 + $ mkdir dir3 + $ mkdir dir4 + $ mkdir dir5 + $ mv main.odocl dir1 + $ mv main__.odocl dir2 + $ mv main__A.odocl dir3 + $ mv main__B.odocl dir4 + $ mv main__C.odocl dir5 $ odoc count-occurrences -I . -o occurrences.txt + $ odoc count-occurrences -I dir1 -o occurrences1.txt + $ odoc count-occurrences -I dir2 -o occurrences2.txt + $ odoc count-occurrences -I dir3 -o occurrences3.txt + $ odoc count-occurrences -I dir4 -o occurrences4.txt + $ odoc count-occurrences -I dir5 -o occurrences5.txt $ du -h occurrences.txt 4.0K occurrences.txt @@ -38,10 +60,10 @@ uses. The occurrences_print executable, available only for testing, unmarshal the file and prints the number of occurrences in a readable format. -Uses of A and B are counted correctly, with the path rewritten correctly. -Uses of C are not counted, since the canonical destination (generated by dune) does not exist. +Uses of A are: 2 times in b.ml, 1 time in c.ml, 1 time in main.ml +Uses of B are: 1 time in main.ml +Uses of C are not counted, since the canonical destination (Main.C, generated by dune) does not exist. Uses of values Y.x and Z.y (in b.ml) are not counted since they come from a "local" module. -Uses of values Main__.C.y and Main__.A.x are not rewritten since we use references instead of paths. $ occurrences_print occurrences.txt | sort Main was used directly 0 times and indirectly 11 times @@ -52,3 +74,45 @@ Uses of values Main__.C.y and Main__.A.x are not rewritten since we use referenc Main.A.x was used directly 2 times and indirectly 0 times Main.B was used directly 1 times and indirectly 0 times string was used directly 1 times and indirectly 0 times + + $ occurrences_print occurrences1.txt | sort + Main was used directly 0 times and indirectly 2 times + Main.A was used directly 1 times and indirectly 0 times + Main.B was used directly 1 times and indirectly 0 times + + $ occurrences_print occurrences2.txt | sort + + $ occurrences_print occurrences3.txt | sort + string was used directly 1 times and indirectly 0 times + + $ occurrences_print occurrences4.txt | sort + Main was used directly 0 times and indirectly 7 times + Main.A was used directly 2 times and indirectly 5 times + Main.A.(||>) was used directly 1 times and indirectly 0 times + Main.A.M was used directly 2 times and indirectly 0 times + Main.A.t was used directly 1 times and indirectly 0 times + Main.A.x was used directly 1 times and indirectly 0 times + + $ occurrences_print occurrences5.txt | sort + Main was used directly 0 times and indirectly 2 times + Main.A was used directly 1 times and indirectly 1 times + Main.A.x was used directly 1 times and indirectly 0 times + +Now we can merge both files + + $ cat > files.map << EOF + > occurrences3.txt + > occurrences4.txt + > occurrences5.txt + > EOF + $ odoc aggregate-occurrences occurrences1.txt occurrences2.txt --file-list files.map -o aggregated.txt + + $ occurrences_print aggregated.txt | sort + Main was used directly 0 times and indirectly 11 times + Main.A was used directly 4 times and indirectly 6 times + Main.A.(||>) was used directly 1 times and indirectly 0 times + Main.A.M was used directly 2 times and indirectly 0 times + Main.A.t was used directly 1 times and indirectly 0 times + Main.A.x was used directly 2 times and indirectly 0 times + Main.B was used directly 1 times and indirectly 0 times + string was used directly 1 times and indirectly 0 times diff --git a/test/odoc_print/occurrences_print.ml b/test/odoc_print/occurrences_print.ml index 7035bf90f8..8568d507fe 100644 --- a/test/odoc_print/occurrences_print.ml +++ b/test/odoc_print/occurrences_print.ml @@ -2,7 +2,7 @@ module H = Hashtbl.Make (Odoc_model.Paths.Identifier) let run inp = let ic = open_in_bin inp in - let htbl : Odoc_odoc.Occurrences.Occtbl.item Odoc_odoc.Occurrences.H.t = + let htbl : Odoc_odoc.Occurrences.Occtbl.t = Marshal.from_channel ic in Odoc_odoc.Occurrences.Occtbl.iter From a532fcf2f14920a209c15f87c78ec28e18438376 Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Fri, 3 Nov 2023 10:12:44 +0100 Subject: [PATCH 13/41] fmt Signed-off-by: Paul-Elliot --- src/document/generator.ml | 2 +- src/odoc/bin/main.ml | 4 +- src/odoc/occurrences.ml | 5 +- src/odoc/odoc_link.ml | 8 +- src/xref2/link.ml | 106 ++++++++++++++++++++++-- test/occurrences/double_wrapped.t/run.t | 33 +++++--- test/odoc_print/occurrences_print.ml | 4 +- 7 files changed, 127 insertions(+), 35 deletions(-) diff --git a/src/document/generator.ml b/src/document/generator.ml index 338d3a4579..cdba1ffae0 100644 --- a/src/document/generator.ml +++ b/src/document/generator.ml @@ -252,7 +252,7 @@ module Make (Syntax : SYNTAX) = struct let path id = Url.Path.from_identifier id let url id = Url.from_path (path id) - let to_link {Lang.Source_info.documentation; implementation} = + let to_link { Lang.Source_info.documentation; implementation } = let documentation = let open Paths.Path.Resolved in match documentation with diff --git a/src/odoc/bin/main.ml b/src/odoc/bin/main.ml index 2f40e9e25b..ec9fdc7e53 100644 --- a/src/odoc/bin/main.ml +++ b/src/odoc/bin/main.ml @@ -1174,9 +1174,7 @@ module Occurrences = struct $ (const index $ dst $ inputs $ inputs_in_file $ warnings_options)) let info ~docs = - let doc = - "Aggregate hashtables created with odoc count-occurrences." - in + let doc = "Aggregate hashtables created with odoc count-occurrences." in Term.info "aggregate-occurrences" ~docs ~doc end end diff --git a/src/odoc/occurrences.ml b/src/odoc/occurrences.ml index 8d0f4d9ee0..b88a69086b 100644 --- a/src/odoc/occurrences.ml +++ b/src/odoc/occurrences.ml @@ -142,10 +142,7 @@ let count ~dst ~warnings_options:_ directories = | Type { documentation = Some (`Resolved p as p'); _ }, _ -> incr htbl p Odoc_model.Paths.Path.((p' : Type.t :> t)) | _ -> ()) - (match unit.source_info with - | None -> [] - | Some i -> - i.infos) + (match unit.source_info with None -> [] | Some i -> i.infos) in () in diff --git a/src/odoc/odoc_link.ml b/src/odoc/odoc_link.ml index 5762db39f3..5eed7dea36 100644 --- a/src/odoc/odoc_link.ml +++ b/src/odoc/odoc_link.ml @@ -8,13 +8,7 @@ let link_unit ~resolver ~filename m = let open Odoc_model in let open Lang.Compilation_unit in let m = - if Root.Odoc_file.hidden m.root.file then - { - m with - content = Module { items = []; compiled = false; doc = [] }; - expansion = None; - } - else m + if Root.Odoc_file.hidden m.root.file then { m with expansion = None } else m in let env = Resolver.build_link_env_for_unit resolver m in Odoc_xref2.Link.link ~filename env m diff --git a/src/xref2/link.ml b/src/xref2/link.ml index e159f913c6..af6cfeebfa 100644 --- a/src/xref2/link.ml +++ b/src/xref2/link.ml @@ -415,6 +415,106 @@ and open_ env parent = function | { Odoc_model__Lang.Open.doc; _ } as open_ -> { open_ with doc = comment_docs env parent doc } +module Build_env = struct + let rec unit env t = + let open Compilation_unit in + match t.content with + | Module sg -> + let env = signature env sg in + env + | Pack _ -> env + + and signature env s = + let env = Env.open_signature s env in + signature_items env s.items + + and simple_expansion : Env.t -> ModuleType.simple_expansion -> Env.t = + fun env m -> + match m with + | Signature sg -> signature env sg + | Functor (arg, sg) -> + let env = Env.add_functor_parameter arg env in + let env = functor_argument env arg in + simple_expansion env sg + + and functor_argument env a = + match a with + | FunctorParameter.Unit -> env + | Named arg -> functor_parameter_parameter env arg + + and functor_parameter_parameter : Env.t -> FunctorParameter.parameter -> Env.t + = + fun env a -> module_type_expr env a.expr + + and module_type_expr : Env.t -> ModuleType.expr -> Env.t = + fun env expr -> + let open ModuleType in + match expr with + | Signature s -> signature env s + | Path { p_path = _; p_expansion = Some p_expansion } -> + simple_expansion env p_expansion + | Path { p_path = _; p_expansion = None } -> env + | With _ -> env + | Functor (arg, res) -> + let env = functor_argument env arg in + let env = Env.add_functor_parameter arg env in + let env = module_type_expr env res in + env + | TypeOf { t_expansion = None; _ } -> env + | TypeOf { t_expansion = Some exp; _ } -> simple_expansion env exp + + and signature_items : Env.t -> Signature.item list -> Env.t = + fun env s -> + let open Signature in + List.fold_left + (fun env item -> + match item with + | Module (_, m) -> module_ env m + | ModuleSubstitution m -> Env.open_module_substitution m env + | Type _ -> env + | TypeSubstitution t -> Env.open_type_substitution t env + | ModuleType mt -> module_type env mt + | ModuleTypeSubstitution mts -> + let env = Env.open_module_type_substitution mts env in + module_type_substitution env mts + | Value _ -> env + | Comment _ -> env + | TypExt _ -> env + | Exception _ -> env + | Class _ -> env (* TODO *) + | ClassType _ -> env + | Include i -> include_ env i + | Open _ -> env) + env s + + and module_type_substitution : Env.t -> ModuleTypeSubstitution.t -> Env.t = + fun env m -> module_type_expr env m.manifest + + and include_ : Env.t -> Include.t -> Env.t = + fun env i -> + let open Include in + signature_items env i.expansion.content.items + + and module_type : Env.t -> ModuleType.t -> Env.t = + fun env m -> + match m.expr with None -> env | Some expr -> module_type_expr env expr + + and module_ : Env.t -> Module.t -> Env.t = + fun env m -> + let open Module in + let env = module_decl env m.type_ in + match m.type_ with + | Alias (`Resolved _, Some exp) -> simple_expansion env exp + | Alias _ | ModuleType _ -> env + + and module_decl : Env.t -> Module.decl -> Env.t = + fun env decl -> + let open Module in + match decl with + | ModuleType expr -> module_type_expr env expr + | Alias (_, None) -> env + | Alias (_, Some e) -> simple_expansion env e +end let rec unit env t = let open Compilation_unit in let content = @@ -427,11 +527,7 @@ let rec unit env t = | Pack _ as p -> p in let source_info = - let env = - match t.content with - | Module sg -> Env.open_signature sg env - | Pack _ -> env - in + let env = Build_env.unit env t in let open Source_info in match t.source_info with | Some inf -> diff --git a/test/occurrences/double_wrapped.t/run.t b/test/occurrences/double_wrapped.t/run.t index b29ba69aaa..40b4ed1726 100644 --- a/test/occurrences/double_wrapped.t/run.t +++ b/test/occurrences/double_wrapped.t/run.t @@ -66,13 +66,16 @@ Uses of C are not counted, since the canonical destination (Main.C, generated by Uses of values Y.x and Z.y (in b.ml) are not counted since they come from a "local" module. $ occurrences_print occurrences.txt | sort - Main was used directly 0 times and indirectly 11 times - Main.A was used directly 4 times and indirectly 6 times + Main was used directly 0 times and indirectly 13 times + Main.A was used directly 4 times and indirectly 8 times Main.A.(||>) was used directly 1 times and indirectly 0 times Main.A.M was used directly 2 times and indirectly 0 times Main.A.t was used directly 1 times and indirectly 0 times - Main.A.x was used directly 2 times and indirectly 0 times + Main.A.x was used directly 4 times and indirectly 0 times Main.B was used directly 1 times and indirectly 0 times + Main__B was used directly 0 times and indirectly 1 times + Main__B.Z was used directly 0 times and indirectly 1 times + Main__B.Z.y was used directly 1 times and indirectly 0 times string was used directly 1 times and indirectly 0 times $ occurrences_print occurrences1.txt | sort @@ -86,17 +89,20 @@ Uses of values Y.x and Z.y (in b.ml) are not counted since they come from a "loc string was used directly 1 times and indirectly 0 times $ occurrences_print occurrences4.txt | sort - Main was used directly 0 times and indirectly 7 times - Main.A was used directly 2 times and indirectly 5 times + Main was used directly 0 times and indirectly 8 times + Main.A was used directly 2 times and indirectly 6 times Main.A.(||>) was used directly 1 times and indirectly 0 times Main.A.M was used directly 2 times and indirectly 0 times Main.A.t was used directly 1 times and indirectly 0 times - Main.A.x was used directly 1 times and indirectly 0 times + Main.A.x was used directly 2 times and indirectly 0 times + Main__B was used directly 0 times and indirectly 1 times + Main__B.Z was used directly 0 times and indirectly 1 times + Main__B.Z.y was used directly 1 times and indirectly 0 times $ occurrences_print occurrences5.txt | sort - Main was used directly 0 times and indirectly 2 times - Main.A was used directly 1 times and indirectly 1 times - Main.A.x was used directly 1 times and indirectly 0 times + Main was used directly 0 times and indirectly 3 times + Main.A was used directly 1 times and indirectly 2 times + Main.A.x was used directly 2 times and indirectly 0 times Now we can merge both files @@ -108,11 +114,14 @@ Now we can merge both files $ odoc aggregate-occurrences occurrences1.txt occurrences2.txt --file-list files.map -o aggregated.txt $ occurrences_print aggregated.txt | sort - Main was used directly 0 times and indirectly 11 times - Main.A was used directly 4 times and indirectly 6 times + Main was used directly 0 times and indirectly 13 times + Main.A was used directly 4 times and indirectly 8 times Main.A.(||>) was used directly 1 times and indirectly 0 times Main.A.M was used directly 2 times and indirectly 0 times Main.A.t was used directly 1 times and indirectly 0 times - Main.A.x was used directly 2 times and indirectly 0 times + Main.A.x was used directly 4 times and indirectly 0 times Main.B was used directly 1 times and indirectly 0 times + Main__B was used directly 0 times and indirectly 1 times + Main__B.Z was used directly 0 times and indirectly 1 times + Main__B.Z.y was used directly 1 times and indirectly 0 times string was used directly 1 times and indirectly 0 times diff --git a/test/odoc_print/occurrences_print.ml b/test/odoc_print/occurrences_print.ml index 8568d507fe..eb2f8c4284 100644 --- a/test/odoc_print/occurrences_print.ml +++ b/test/odoc_print/occurrences_print.ml @@ -2,9 +2,7 @@ module H = Hashtbl.Make (Odoc_model.Paths.Identifier) let run inp = let ic = open_in_bin inp in - let htbl : Odoc_odoc.Occurrences.Occtbl.t = - Marshal.from_channel ic - in + let htbl : Odoc_odoc.Occurrences.Occtbl.t = Marshal.from_channel ic in Odoc_odoc.Occurrences.Occtbl.iter (fun id { Odoc_odoc.Occurrences.Occtbl.direct; indirect; _ } -> let id = String.concat "." (Odoc_model.Paths.Identifier.fullname id) in From 125bbcfdc8e8f8ff2855eb1f7bfb8b71ca221116 Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Fri, 3 Nov 2023 10:13:07 +0100 Subject: [PATCH 14/41] Occurrences: detection of hidden modules should be more efficient We consider as internal children of internal modules, and double underscored roots. Signed-off-by: Paul-Elliot --- src/model/paths.ml | 54 ++++++++++++++++++++----- test/occurrences/double_wrapped.t/run.t | 10 +---- 2 files changed, 44 insertions(+), 20 deletions(-) diff --git a/src/model/paths.ml b/src/model/paths.ml index fa90e0d05d..47225b09fa 100644 --- a/src/model/paths.ml +++ b/src/model/paths.ml @@ -19,6 +19,15 @@ module Ocaml_env = Env open Names +let contains_double_underscore s = + let len = String.length s in + let rec aux i = + if i > len - 2 then false + else if s.[i] = '_' && s.[i + 1] = '_' then true + else aux (i + 1) + in + aux 0 + module Identifier = struct type 'a id = 'a Paths_types.id = { iv : 'a; ihash : int; ikey : string } @@ -66,7 +75,9 @@ module Identifier = struct let rec is_internal : t -> bool = fun x -> match x.iv with - | `Root (_, name) -> ModuleName.is_internal name + | `Root (_, name) -> + ModuleName.is_internal name + || contains_double_underscore (ModuleName.to_string name) | `Page (_, _) -> false | `LeafPage (_, _) -> false | `Module (_, name) -> ModuleName.is_internal name @@ -91,6 +102,36 @@ module Identifier = struct | `SourceLocationInternal _ | `AssetFile _ -> false + let rec is_internal_rec : t -> bool = + fun x -> + is_internal x + || + match x.iv with + | `Root (_, name) -> ModuleName.is_internal name + | `Page (_, _) -> false + | `LeafPage (_, _) -> false + | `Module (parent, _) -> is_internal_rec (parent :> t) + | `Parameter (parent, _) -> is_internal_rec (parent :> t) + | `Result x -> is_internal_rec (x :> t) + | `ModuleType (parent, _) -> is_internal_rec (parent :> t) + | `Type (parent, _) -> is_internal_rec (parent :> t) + | `CoreType name -> TypeName.is_internal name + | `Constructor (parent, _) -> is_internal (parent :> t) + | `Field (parent, _) -> is_internal (parent :> t) + | `Extension (parent, _) -> is_internal (parent :> t) + | `ExtensionDecl (parent, _, _) -> is_internal (parent :> t) + | `Exception (parent, _) -> is_internal (parent :> t) + | `CoreException _ -> false + | `Value (parent, _) -> is_internal_rec (parent :> t) + | `Class (parent, _) -> is_internal_rec (parent :> t) + | `ClassType (parent, _) -> is_internal_rec (parent :> t) + | `Method (parent, _) -> is_internal (parent :> t) + | `InstanceVariable (parent, _) -> is_internal (parent :> t) + | `Label (parent, _) -> is_internal (parent :> t) + | `SourceDir _ | `SourceLocationMod _ | `SourceLocation _ | `SourcePage _ + | `SourceLocationInternal _ | `AssetFile _ -> + false + let name : [< t_pv ] id -> string = fun n -> name_aux (n :> t) let rec full_name_aux : t -> string list = @@ -671,7 +712,7 @@ module Path = struct | `Identifier { iv = `Module (_, m); _ } when Names.ModuleName.is_internal m -> true - | `Identifier _ -> false + | `Identifier i -> Identifier.is_internal_rec i | `Canonical (_, `Resolved _) -> false | `Canonical (x, _) -> (not weak_canonical_test) && inner (x : module_ :> any) @@ -708,15 +749,6 @@ module Path = struct in inner x - and contains_double_underscore s = - let len = String.length s in - let rec aux i = - if i > len - 2 then false - else if s.[i] = '_' && s.[i + 1] = '_' then true - else aux (i + 1) - in - aux 0 - and is_path_hidden : Paths_types.Path.any -> bool = let open Paths_types.Path in function diff --git a/test/occurrences/double_wrapped.t/run.t b/test/occurrences/double_wrapped.t/run.t index 40b4ed1726..c940324781 100644 --- a/test/occurrences/double_wrapped.t/run.t +++ b/test/occurrences/double_wrapped.t/run.t @@ -63,6 +63,7 @@ and prints the number of occurrences in a readable format. Uses of A are: 2 times in b.ml, 1 time in c.ml, 1 time in main.ml Uses of B are: 1 time in main.ml Uses of C are not counted, since the canonical destination (Main.C, generated by dune) does not exist. +Uses of B.Z are not counted since they go to a hidden module. Uses of values Y.x and Z.y (in b.ml) are not counted since they come from a "local" module. $ occurrences_print occurrences.txt | sort @@ -73,9 +74,6 @@ Uses of values Y.x and Z.y (in b.ml) are not counted since they come from a "loc Main.A.t was used directly 1 times and indirectly 0 times Main.A.x was used directly 4 times and indirectly 0 times Main.B was used directly 1 times and indirectly 0 times - Main__B was used directly 0 times and indirectly 1 times - Main__B.Z was used directly 0 times and indirectly 1 times - Main__B.Z.y was used directly 1 times and indirectly 0 times string was used directly 1 times and indirectly 0 times $ occurrences_print occurrences1.txt | sort @@ -95,9 +93,6 @@ Uses of values Y.x and Z.y (in b.ml) are not counted since they come from a "loc Main.A.M was used directly 2 times and indirectly 0 times Main.A.t was used directly 1 times and indirectly 0 times Main.A.x was used directly 2 times and indirectly 0 times - Main__B was used directly 0 times and indirectly 1 times - Main__B.Z was used directly 0 times and indirectly 1 times - Main__B.Z.y was used directly 1 times and indirectly 0 times $ occurrences_print occurrences5.txt | sort Main was used directly 0 times and indirectly 3 times @@ -121,7 +116,4 @@ Now we can merge both files Main.A.t was used directly 1 times and indirectly 0 times Main.A.x was used directly 4 times and indirectly 0 times Main.B was used directly 1 times and indirectly 0 times - Main__B was used directly 0 times and indirectly 1 times - Main__B.Z was used directly 0 times and indirectly 1 times - Main__B.Z.y was used directly 1 times and indirectly 0 times string was used directly 1 times and indirectly 0 times From 84987b9d5124c0750a945a7fa61635f6d45ec36d Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Fri, 3 Nov 2023 11:47:25 +0100 Subject: [PATCH 15/41] Occurrences: control which occurrences are counted Persistent and hidden occurrences can be counted, or not. Signed-off-by: Paul-Elliot --- src/document/generator.ml | 2 +- src/loader/implementation.ml | 10 +- src/model/lang.ml | 4 +- src/odoc/bin/main.ml | 20 +++- src/odoc/occurrences.ml | 31 +++--- src/xref2/compile.ml | 4 +- src/xref2/link.ml | 4 +- test/occurrences/double_wrapped.t/run.t | 133 ++++++++++++++---------- 8 files changed, 129 insertions(+), 79 deletions(-) diff --git a/src/document/generator.ml b/src/document/generator.ml index cdba1ffae0..1c5b72e5e7 100644 --- a/src/document/generator.ml +++ b/src/document/generator.ml @@ -256,7 +256,7 @@ module Make (Syntax : SYNTAX) = struct let documentation = let open Paths.Path.Resolved in match documentation with - | Some (`Resolved p) when not (is_hidden (p :> t)) -> ( + | Some (`Resolved p, _) when not (is_hidden (p :> t)) -> ( let id = identifier (p :> t) in match Url.from_identifier ~stop_before:false id with | Ok link -> Some link diff --git a/src/loader/implementation.ml b/src/loader/implementation.ml index 910b13a30f..58ad71bf7a 100644 --- a/src/loader/implementation.ml +++ b/src/loader/implementation.ml @@ -1,6 +1,12 @@ #if OCAML_VERSION >= (4, 14, 0) -(* open Odoc_model.Lang.Source_info *) +let rec is_persistent : Path.t -> bool = function + | Path.Pident id -> Ident.persistent id + | Path.Pdot(p, _) -> is_persistent p + | Path.Papply(p, _) -> is_persistent p +#if OCAML_VERSION >= (5,1,0) + | Path.Pextra_ty -> assert false +#endif let pos_of_loc loc = (loc.Location.loc_start.pos_cnum, loc.loc_end.pos_cnum) @@ -303,7 +309,7 @@ let process_occurrences env poses loc_to_id local_ident_to_loc = | p -> ( match find_in_env env p with | path -> - let documentation = Some path + let documentation = Some (path, is_persistent p) and implementation = Some (Unresolved path) in Some { documentation; implementation } | exception _ -> None) diff --git a/src/model/lang.ml b/src/model/lang.ml index dd4abf6a68..c6ba7edab1 100644 --- a/src/model/lang.ml +++ b/src/model/lang.ml @@ -23,7 +23,9 @@ module Source_info = struct | Resolved of Identifier.SourceLocation.t type ('doc, 'impl) jump_to = { - documentation : 'doc option; + documentation : ('doc * bool) option; + (* The boolean indicate if the path is "persistent": from the same + compilation unit. *) implementation : 'impl jump_to_impl option; } diff --git a/src/odoc/bin/main.ml b/src/odoc/bin/main.ml index ec9fdc7e53..298229f1f3 100644 --- a/src/odoc/bin/main.ml +++ b/src/odoc/bin/main.ml @@ -1112,9 +1112,11 @@ end module Occurrences = struct module Count = struct - let index directories dst warnings_options = + let count directories dst warnings_options include_hidden include_persistent + = let dst = Fpath.v dst in - Occurrences.count ~dst ~warnings_options directories + Occurrences.count ~dst ~warnings_options directories include_hidden + include_persistent let cmd = let dst = @@ -1124,9 +1126,21 @@ module Occurrences = struct & opt (some string) None & info ~docs ~docv:"PATH" ~doc [ "o" ]) in + let include_hidden = + let doc = "Include hidden identifiers in the table" in + Arg.(value & flag & info ~docs ~doc [ "include-hidden" ]) + in + let include_persistent = + let doc = + "Include persistent identifiers in the table: occurrences of in ids \ + intheir own implementation." + in + Arg.(value & flag & info ~docs ~doc [ "include-persistent" ]) + in Term.( const handle_error - $ (const index $ odoc_file_directories $ dst $ warnings_options)) + $ (const count $ odoc_file_directories $ dst $ warnings_options + $ include_hidden $ include_persistent)) let info ~docs = let doc = diff --git a/src/odoc/occurrences.ml b/src/odoc/occurrences.ml index b88a69086b..36ea9f1026 100644 --- a/src/odoc/occurrences.ml +++ b/src/odoc/occurrences.ml @@ -119,28 +119,31 @@ end = struct tbl end -let count ~dst ~warnings_options:_ directories = +let count ~dst ~warnings_options:_ directories include_hidden include_persistent = let htbl = H.create 100 in let f () (unit : Odoc_model.Lang.Compilation_unit.t) = - let incr tbl p p' = - let id = Odoc_model.Paths.Path.Resolved.(identifier (p :> t)) in - if not Odoc_model.Paths.Path.(is_hidden p') then Occtbl.add tbl id + let incr tbl p persistent = + let p = (p :> Odoc_model.Paths.Path.Resolved.t) in + let id = Odoc_model.Paths.Path.Resolved.identifier p in + if not (Odoc_model.Paths.Path.Resolved.is_hidden p) || include_hidden then + if not persistent || include_persistent then + Occtbl.add tbl id in let () = List.iter (function | ( Odoc_model.Lang.Source_info.Module - { documentation = Some (`Resolved p as p'); _ }, + { documentation = Some (`Resolved p, persistent); _ }, _ ) -> - incr htbl p Odoc_model.Paths.Path.((p' : Module.t :> t)) - | Value { documentation = Some (`Resolved p as p'); _ }, _ -> - incr htbl p Odoc_model.Paths.Path.((p' : Value.t :> t)) - | ClassType { documentation = Some (`Resolved p as p'); _ }, _ -> - incr htbl p Odoc_model.Paths.Path.((p' : ClassType.t :> t)) - | ModuleType { documentation = Some (`Resolved p as p'); _ }, _ -> - incr htbl p Odoc_model.Paths.Path.((p' : ModuleType.t :> t)) - | Type { documentation = Some (`Resolved p as p'); _ }, _ -> - incr htbl p Odoc_model.Paths.Path.((p' : Type.t :> t)) + incr htbl p persistent + | Value { documentation = Some (`Resolved p, persistent); _ }, _ -> + incr htbl p persistent + | ClassType { documentation = Some (`Resolved p, persistent); _ }, _ -> + incr htbl p persistent + | ModuleType { documentation = Some (`Resolved p, persistent); _ }, _ -> + incr htbl p persistent + | Type { documentation = Some (`Resolved p, persistent); _ }, _ -> + incr htbl p persistent | _ -> ()) (match unit.source_info with None -> [] | Some i -> i.infos) in diff --git a/src/xref2/compile.ml b/src/xref2/compile.ml index 66df782eb5..1cb0ef98f6 100644 --- a/src/xref2/compile.ml +++ b/src/xref2/compile.ml @@ -89,7 +89,9 @@ and source_info_infos env infos = let open Source_info in let map_doc f v = let documentation = - match v.documentation with Some p -> Some (f p) | None -> None + match v.documentation with + | Some (p, persistent) -> Some (f p, persistent) + | None -> None in { v with documentation } in diff --git a/src/xref2/link.ml b/src/xref2/link.ml index af6cfeebfa..d9eff95d8d 100644 --- a/src/xref2/link.ml +++ b/src/xref2/link.ml @@ -533,7 +533,9 @@ let rec unit env t = | Some inf -> let jump_to v f_impl f_doc = let documentation = - match v.documentation with Some p -> Some (f_doc p) | None -> None + match v.documentation with + | Some (p, persistent) -> Some (f_doc p, persistent) + | None -> None in let implementation = match v.implementation with diff --git a/test/occurrences/double_wrapped.t/run.t b/test/occurrences/double_wrapped.t/run.t index c940324781..989c66ad13 100644 --- a/test/occurrences/double_wrapped.t/run.t +++ b/test/occurrences/double_wrapped.t/run.t @@ -25,37 +25,27 @@ occurrences information. $ odoc link -I . main__C.odoc $ odoc link -I . main__.odoc - $ odoc html-generate -o html main.odocl - $ odoc html-generate -o html main__A.odocl - $ odoc html-generate -o html main__B.odocl - $ odoc html-generate -o html main__C.odocl - $ odoc html-generate -o html main__.odocl - The count occurrences command outputs a marshalled hashtable, whose keys are odoc identifiers, and whose values are integers corresponding to the number of uses. We can later aggregate those hashtables, so we create the full hashtable, and a hashtable for each compilation unit. - $ mkdir dir1 - $ mkdir dir2 - $ mkdir dir3 - $ mkdir dir4 - $ mkdir dir5 - - $ mv main.odocl dir1 - $ mv main__.odocl dir2 - $ mv main__A.odocl dir3 - $ mv main__B.odocl dir4 - $ mv main__C.odocl dir5 - $ odoc count-occurrences -I . -o occurrences.txt - $ odoc count-occurrences -I dir1 -o occurrences1.txt - $ odoc count-occurrences -I dir2 -o occurrences2.txt - $ odoc count-occurrences -I dir3 -o occurrences3.txt - $ odoc count-occurrences -I dir4 -o occurrences4.txt - $ odoc count-occurrences -I dir5 -o occurrences5.txt - - $ du -h occurrences.txt - 4.0K occurrences.txt + $ mkdir main + $ mkdir main__ + $ mkdir main__A + $ mkdir main__B + $ mkdir main__C + + $ mv main.odocl main + $ mv main__.odocl main__ + $ mv main__A.odocl main__A + $ mv main__B.odocl main__B + $ mv main__C.odocl main__C + $ odoc count-occurrences -I main -o main.occ + $ odoc count-occurrences -I main__ -o main__.occ + $ odoc count-occurrences -I main__A -o main__A.occ + $ odoc count-occurrences -I main__B -o main__B.occ + $ odoc count-occurrences -I main__C -o main__C.occ The occurrences_print executable, available only for testing, unmarshal the file and prints the number of occurrences in a readable format. @@ -66,49 +56,72 @@ Uses of C are not counted, since the canonical destination (Main.C, generated by Uses of B.Z are not counted since they go to a hidden module. Uses of values Y.x and Z.y (in b.ml) are not counted since they come from a "local" module. - $ occurrences_print occurrences.txt | sort - Main was used directly 0 times and indirectly 13 times - Main.A was used directly 4 times and indirectly 8 times - Main.A.(||>) was used directly 1 times and indirectly 0 times - Main.A.M was used directly 2 times and indirectly 0 times - Main.A.t was used directly 1 times and indirectly 0 times - Main.A.x was used directly 4 times and indirectly 0 times - Main.B was used directly 1 times and indirectly 0 times + $ occurrences_print main.occ | sort + + $ occurrences_print main__.occ | sort + + $ occurrences_print main__A.occ | sort string was used directly 1 times and indirectly 0 times - $ occurrences_print occurrences1.txt | sort + $ occurrences_print main__B.occ | sort + Main was used directly 0 times and indirectly 1 times + Main.A was used directly 0 times and indirectly 1 times + Main.A.x was used directly 1 times and indirectly 0 times + + $ occurrences_print main__C.occ | sort + Main was used directly 0 times and indirectly 1 times + Main.A was used directly 0 times and indirectly 1 times + Main.A.x was used directly 1 times and indirectly 0 times + +Now we can merge both files + + $ cat > files.map << EOF + > main__A.occ + > main__B.occ + > main__C.occ + > EOF + $ odoc aggregate-occurrences main.occ main__.occ --file-list files.map -o aggregated.txt + + $ occurrences_print aggregated.txt | sort Main was used directly 0 times and indirectly 2 times - Main.A was used directly 1 times and indirectly 0 times - Main.B was used directly 1 times and indirectly 0 times + Main.A was used directly 0 times and indirectly 2 times + Main.A.x was used directly 2 times and indirectly 0 times + string was used directly 1 times and indirectly 0 times - $ occurrences_print occurrences2.txt | sort +Compare with the one created directly with all occurrences: - $ occurrences_print occurrences3.txt | sort + $ odoc count-occurrences -I . -o occurrences.txt + $ occurrences_print occurrences.txt | sort + Main was used directly 0 times and indirectly 2 times + Main.A was used directly 0 times and indirectly 2 times + Main.A.x was used directly 2 times and indirectly 0 times string was used directly 1 times and indirectly 0 times - $ occurrences_print occurrences4.txt | sort - Main was used directly 0 times and indirectly 8 times - Main.A was used directly 2 times and indirectly 6 times +We can also include persistent ids, and hidden ids: + + $ odoc count-occurrences -I . -o occurrences.txt --include-persistent + $ occurrences_print occurrences.txt | sort + Main was used directly 0 times and indirectly 13 times + Main.A was used directly 4 times and indirectly 8 times Main.A.(||>) was used directly 1 times and indirectly 0 times Main.A.M was used directly 2 times and indirectly 0 times Main.A.t was used directly 1 times and indirectly 0 times - Main.A.x was used directly 2 times and indirectly 0 times + Main.A.x was used directly 4 times and indirectly 0 times + Main.B was used directly 1 times and indirectly 0 times + string was used directly 1 times and indirectly 0 times - $ occurrences_print occurrences5.txt | sort - Main was used directly 0 times and indirectly 3 times - Main.A was used directly 1 times and indirectly 2 times + $ odoc count-occurrences -I . -o occurrences.txt --include-hidden + $ occurrences_print occurrences.txt | sort + Main was used directly 0 times and indirectly 2 times + Main.A was used directly 0 times and indirectly 2 times Main.A.x was used directly 2 times and indirectly 0 times + Main__B was used directly 0 times and indirectly 1 times + Main__B.Z was used directly 0 times and indirectly 1 times + Main__B.Z.y was used directly 1 times and indirectly 0 times + string was used directly 1 times and indirectly 0 times -Now we can merge both files - - $ cat > files.map << EOF - > occurrences3.txt - > occurrences4.txt - > occurrences5.txt - > EOF - $ odoc aggregate-occurrences occurrences1.txt occurrences2.txt --file-list files.map -o aggregated.txt - - $ occurrences_print aggregated.txt | sort + $ odoc count-occurrences -I . -o occurrences.txt --include-persistent --include-hidden + $ occurrences_print occurrences.txt | sort Main was used directly 0 times and indirectly 13 times Main.A was used directly 4 times and indirectly 8 times Main.A.(||>) was used directly 1 times and indirectly 0 times @@ -116,4 +129,12 @@ Now we can merge both files Main.A.t was used directly 1 times and indirectly 0 times Main.A.x was used directly 4 times and indirectly 0 times Main.B was used directly 1 times and indirectly 0 times + Main__ was used directly 0 times and indirectly 2 times + Main__.C was used directly 1 times and indirectly 1 times + Main__.C.y was used directly 1 times and indirectly 0 times + Main__A was used directly 1 times and indirectly 0 times + Main__B was used directly 1 times and indirectly 1 times + Main__B.Z was used directly 0 times and indirectly 1 times + Main__B.Z.y was used directly 1 times and indirectly 0 times + Main__C was used directly 1 times and indirectly 0 times string was used directly 1 times and indirectly 0 times From 6774603859f174e3fe8ddb566b9b7d516bab3aa6 Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Fri, 3 Nov 2023 11:51:20 +0100 Subject: [PATCH 16/41] Occurrences: remove unused test Signed-off-by: Paul-Elliot --- test/occurrences/source.t/a.ml | 1 - test/occurrences/source.t/b.ml | 1 - test/occurrences/source.t/root.mld | 1 - test/occurrences/source.t/run.t | 38 ------------------------------ 4 files changed, 41 deletions(-) delete mode 100644 test/occurrences/source.t/a.ml delete mode 100644 test/occurrences/source.t/b.ml delete mode 100644 test/occurrences/source.t/root.mld delete mode 100644 test/occurrences/source.t/run.t diff --git a/test/occurrences/source.t/a.ml b/test/occurrences/source.t/a.ml deleted file mode 100644 index e09e5d02a3..0000000000 --- a/test/occurrences/source.t/a.ml +++ /dev/null @@ -1 +0,0 @@ -let a = B.b diff --git a/test/occurrences/source.t/b.ml b/test/occurrences/source.t/b.ml deleted file mode 100644 index 56d2d5273c..0000000000 --- a/test/occurrences/source.t/b.ml +++ /dev/null @@ -1 +0,0 @@ -let b = 3 diff --git a/test/occurrences/source.t/root.mld b/test/occurrences/source.t/root.mld deleted file mode 100644 index 54f377d3e8..0000000000 --- a/test/occurrences/source.t/root.mld +++ /dev/null @@ -1 +0,0 @@ -{0 Root} diff --git a/test/occurrences/source.t/run.t b/test/occurrences/source.t/run.t deleted file mode 100644 index 9c0da5e49f..0000000000 --- a/test/occurrences/source.t/run.t +++ /dev/null @@ -1,38 +0,0 @@ -When both source rendering and occurrence counting are enabled, the occurrences information are used to generate "jump to documentation" links. - -This test tests this. - -Files containing some values: - - $ cat a.ml | head -n 3 - let a = B.b - - $ cat b.ml | head -n 3 - let b = 3 - -Source pages require a parent: - - $ odoc compile -c module-a -c module-b -c src-source root.mld - -Compile the modules: - - $ ocamlc -c b.ml -bin-annot - $ ocamlc -c a.ml -I . -bin-annot - -Compile the pages with the source and occurrences options - - $ printf "a.ml\nb.ml\n" > source_tree.map - $ odoc source-tree -I . --parent page-root -o src-source.odoc source_tree.map - $ odoc compile --count-occurrences -I . --source-name b.ml --source-parent-file src-source.odoc b.cmt - $ odoc compile --count-occurrences -I . --source-name a.ml --source-parent-file src-source.odoc a.cmt - $ odoc link -I . b.odoc - $ odoc link -I . a.odoc - $ odoc html-generate --source b.ml --indent -o html b.odocl - $ odoc html-generate --source a.ml --indent -o html a.odocl - $ odoc support-files -o html - -The source for `a` contains a link to the documentation of `B.b`, as it is used in the implementation: - - $ cat html/root/source/a.ml.html | tr '> ' '\n\n' | grep 'href' | grep val-b - href="b.ml.html#val-b" - href="../../B/index.html#val-b" From f83923c5fa50a6d06f7120f0bd6a64ea606c4d4e Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Fri, 3 Nov 2023 12:32:46 +0100 Subject: [PATCH 17/41] Occurrences: compatibility with different OCaml versions and fmt Signed-off-by: Paul-Elliot --- src/loader/cmt.ml | 6 +++--- src/loader/implementation.ml | 4 ++-- src/odoc/occurrences.ml | 14 ++++++++------ src/xref2/shape_tools.cppo.ml | 4 ++++ 4 files changed, 17 insertions(+), 11 deletions(-) diff --git a/src/loader/cmt.ml b/src/loader/cmt.ml index 682333588a..9b06dbaa87 100644 --- a/src/loader/cmt.ml +++ b/src/loader/cmt.ml @@ -382,16 +382,16 @@ let rec read_module_expr env parent label_parent mexpr = Functor (f_parameter, res) #else | Tmod_functor(id, _, arg, res) -> - let new_env = Env.add_parameter parent id (ModuleName.of_ident id) env in + let () = Env.add_parameter parent id (ModuleName.of_ident id) env in let f_parameter = match arg with | None -> FunctorParameter.Unit | Some arg -> - let id = Env.find_parameter_identifier new_env id in + let id = Env.find_parameter_identifier env id in let arg = Cmti.read_module_type env (id :> Identifier.Signature.t) label_parent arg in Named { FunctorParameter. id; expr = arg; } in - let res = read_module_expr new_env (Identifier.Mk.result parent) label_parent res in + let res = read_module_expr env (Identifier.Mk.result parent) label_parent res in Functor(f_parameter, res) #endif | Tmod_apply _ -> diff --git a/src/loader/implementation.ml b/src/loader/implementation.ml index 58ad71bf7a..5e6782c011 100644 --- a/src/loader/implementation.ml +++ b/src/loader/implementation.ml @@ -5,7 +5,7 @@ let rec is_persistent : Path.t -> bool = function | Path.Pdot(p, _) -> is_persistent p | Path.Papply(p, _) -> is_persistent p #if OCAML_VERSION >= (5,1,0) - | Path.Pextra_ty -> assert false + | Path.Pextra_ty _ -> assert false #endif let pos_of_loc loc = (loc.Location.loc_start.pos_cnum, loc.loc_end.pos_cnum) @@ -384,7 +384,7 @@ let read_cmt_infos source_id_opt id cmt_info ~count_occurrences = #else -let read_cmt_infos _source_id_opt _id _cmt_info = +let read_cmt_infos _source_id_opt _id _cmt_info ~count_occurrences:_ = (None, None) #endif diff --git a/src/odoc/occurrences.ml b/src/odoc/occurrences.ml index 36ea9f1026..2a23478be0 100644 --- a/src/odoc/occurrences.ml +++ b/src/odoc/occurrences.ml @@ -119,15 +119,15 @@ end = struct tbl end -let count ~dst ~warnings_options:_ directories include_hidden include_persistent = +let count ~dst ~warnings_options:_ directories include_hidden include_persistent + = let htbl = H.create 100 in let f () (unit : Odoc_model.Lang.Compilation_unit.t) = let incr tbl p persistent = let p = (p :> Odoc_model.Paths.Path.Resolved.t) in let id = Odoc_model.Paths.Path.Resolved.identifier p in - if not (Odoc_model.Paths.Path.Resolved.is_hidden p) || include_hidden then - if not persistent || include_persistent then - Occtbl.add tbl id + if (not (Odoc_model.Paths.Path.Resolved.is_hidden p)) || include_hidden + then if (not persistent) || include_persistent then Occtbl.add tbl id in let () = List.iter @@ -138,9 +138,11 @@ let count ~dst ~warnings_options:_ directories include_hidden include_persistent incr htbl p persistent | Value { documentation = Some (`Resolved p, persistent); _ }, _ -> incr htbl p persistent - | ClassType { documentation = Some (`Resolved p, persistent); _ }, _ -> + | ClassType { documentation = Some (`Resolved p, persistent); _ }, _ + -> incr htbl p persistent - | ModuleType { documentation = Some (`Resolved p, persistent); _ }, _ -> + | ModuleType { documentation = Some (`Resolved p, persistent); _ }, _ + -> incr htbl p persistent | Type { documentation = Some (`Resolved p, persistent); _ }, _ -> incr htbl p persistent diff --git a/src/xref2/shape_tools.cppo.ml b/src/xref2/shape_tools.cppo.ml index a6bf903791..f4feb5970f 100644 --- a/src/xref2/shape_tools.cppo.ml +++ b/src/xref2/shape_tools.cppo.ml @@ -176,4 +176,8 @@ type t = unit let lookup_def _ _id = None +let lookup_value_path _ _id = None + +let lookup_module_path _ _id = None + #endif From 380ef02f9ec2e545ea3cf216c7018663d28c6615 Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Fri, 3 Nov 2023 16:52:07 +0100 Subject: [PATCH 18/41] fmt Signed-off-by: Paul-Elliot --- src/loader/implementation.ml | 117 +++++++++++++++++++---------------- 1 file changed, 65 insertions(+), 52 deletions(-) diff --git a/src/loader/implementation.ml b/src/loader/implementation.ml index 5e6782c011..7fc5941679 100644 --- a/src/loader/implementation.ml +++ b/src/loader/implementation.ml @@ -144,7 +144,8 @@ module IdentHashtbl = Hashtbl.Make (struct end) module AnnotHashtbl = Hashtbl.Make (struct - type t = Odoc_model.Lang.Source_info.annotation Odoc_model.Lang.Source_info.with_pos + type t = + Odoc_model.Lang.Source_info.annotation Odoc_model.Lang.Source_info.with_pos let equal l1 l2 = l1 = l2 let hash = Hashtbl.hash end) @@ -162,14 +163,14 @@ let populate_local_defs source_id poses loc_to_id local_ident_to_loc = (Printf.sprintf "local_%s_%d" (Ident.name id) (counter ())) in (match source_id with - Some source_id -> + | Some source_id -> let identifier = - Odoc_model.Paths.Identifier.Mk.source_location_int (source_id, name) + Odoc_model.Paths.Identifier.Mk.source_location_int + (source_id, name) in LocHashtbl.add loc_to_id loc identifier - | None -> () - ); - IdentHashtbl.add local_ident_to_loc id loc; + | None -> ()); + IdentHashtbl.add local_ident_to_loc id loc | _ -> ()) poses @@ -255,39 +256,44 @@ let anchor_of_identifier id = (* Adds the global definitions, found in the [uid_to_loc], to the [loc_to_id] and [uid_to_id] tables. *) let populate_global_defs env source_id loc_to_id uid_to_loc uid_to_id = - match source_id with None -> () | Some source_id -> - let mk_src_id id = - let name = Odoc_model.Names.DefName.make_std (anchor_of_identifier id) in - (Odoc_model.Paths.Identifier.Mk.source_location (source_id, name) - :> Odoc_model.Paths.Identifier.SourceLocation.t) - in - let () = - Ident_env.iter_located_identifier env @@ fun loc id -> - LocHashtbl.add loc_to_id loc (mk_src_id id) - in - let mk_src_id () = - let name = - Odoc_model.Names.DefName.make_std (Printf.sprintf "def_%d" (counter ())) - in - (Odoc_model.Paths.Identifier.Mk.source_location (source_id, name) - :> Odoc_model.Paths.Identifier.SourceLocation.t) - in - Shape.Uid.Tbl.iter - (fun uid loc -> - if loc.Location.loc_ghost then () - else - match LocHashtbl.find_opt loc_to_id loc with - | Some id -> UidHashtbl.add uid_to_id uid id - | None -> ( - (* In case there is no entry for the location of the uid, we add one. *) - match uid with - | Item _ -> - let id = mk_src_id () in - LocHashtbl.add loc_to_id loc id; - UidHashtbl.add uid_to_id uid id - | Compilation_unit _ -> () - | _ -> ())) - uid_to_loc + match source_id with + | None -> () + | Some source_id -> + let mk_src_id id = + let name = + Odoc_model.Names.DefName.make_std (anchor_of_identifier id) + in + (Odoc_model.Paths.Identifier.Mk.source_location (source_id, name) + :> Odoc_model.Paths.Identifier.SourceLocation.t) + in + let () = + Ident_env.iter_located_identifier env @@ fun loc id -> + LocHashtbl.add loc_to_id loc (mk_src_id id) + in + let mk_src_id () = + let name = + Odoc_model.Names.DefName.make_std + (Printf.sprintf "def_%d" (counter ())) + in + (Odoc_model.Paths.Identifier.Mk.source_location (source_id, name) + :> Odoc_model.Paths.Identifier.SourceLocation.t) + in + Shape.Uid.Tbl.iter + (fun uid loc -> + if loc.Location.loc_ghost then () + else + match LocHashtbl.find_opt loc_to_id loc with + | Some id -> UidHashtbl.add uid_to_id uid id + | None -> ( + (* In case there is no entry for the location of the uid, we add one. *) + match uid with + | Item _ -> + let id = mk_src_id () in + LocHashtbl.add loc_to_id loc id; + UidHashtbl.add uid_to_id uid id + | Compilation_unit _ -> () + | _ -> ())) + uid_to_loc (* Extract [Typedtree_traverse] occurrence information and turn them into proper source infos *) @@ -317,24 +323,30 @@ let process_occurrences env poses loc_to_id local_ident_to_loc = List.iter (function | Typedtree_traverse.Analysis.Value p, loc -> - process p Ident_env.Path.read_value |> Option.iter @@ fun l -> - AnnotHashtbl.replace occ_tbl (Value l, pos_of_loc loc) () + process p Ident_env.Path.read_value + |> Option.iter @@ fun l -> + AnnotHashtbl.replace occ_tbl (Value l, pos_of_loc loc) () | Module p, loc -> - process p Ident_env.Path.read_module |> Option.iter @@ fun l -> - AnnotHashtbl.replace occ_tbl (Module l, pos_of_loc loc) () + process p Ident_env.Path.read_module + |> Option.iter @@ fun l -> + AnnotHashtbl.replace occ_tbl (Module l, pos_of_loc loc) () | ClassType p, loc -> - process p Ident_env.Path.read_class_type |> Option.iter @@ fun l -> - AnnotHashtbl.replace occ_tbl (ClassType l, pos_of_loc loc) () + process p Ident_env.Path.read_class_type + |> Option.iter @@ fun l -> + AnnotHashtbl.replace occ_tbl (ClassType l, pos_of_loc loc) () | ModuleType p, loc -> - process p Ident_env.Path.read_module_type |> Option.iter @@ fun l -> - AnnotHashtbl.replace occ_tbl (ModuleType l, pos_of_loc loc) () + process p Ident_env.Path.read_module_type + |> Option.iter @@ fun l -> + AnnotHashtbl.replace occ_tbl (ModuleType l, pos_of_loc loc) () | Type p, loc -> - process p Ident_env.Path.read_type |> Option.iter @@ fun l -> - AnnotHashtbl.replace occ_tbl (Type l, pos_of_loc loc) () + process p Ident_env.Path.read_type + |> Option.iter @@ fun l -> + AnnotHashtbl.replace occ_tbl (Type l, pos_of_loc loc) () | Constructor _p, loc -> (* process p Ident_env.Path.read_constructor *) - None |> Option.iter @@ fun l -> - AnnotHashtbl.replace occ_tbl (Constructor l, pos_of_loc loc) () + None + |> Option.iter @@ fun l -> + AnnotHashtbl.replace occ_tbl (Constructor l, pos_of_loc loc) () | LocalDefinition _, _ -> ()) poses; AnnotHashtbl.fold (fun k () acc -> k :: acc) occ_tbl [] @@ -366,7 +378,8 @@ let read_cmt_infos source_id_opt id cmt_info ~count_occurrences = and uid_to_id = UidHashtbl.create 10 in let () = (* populate [loc_to_id], [ident_to_id] and [uid_to_id] *) - populate_local_defs source_id traverse_infos loc_to_id local_ident_to_loc; + populate_local_defs source_id traverse_infos loc_to_id + local_ident_to_loc; populate_global_defs env source_id loc_to_id uid_to_loc uid_to_id in let source_infos = From a3ce1e1fce2454f0cef8ef357e1a1e97afe75fe4 Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Fri, 3 Nov 2023 16:52:30 +0100 Subject: [PATCH 19/41] Occurrences: change option from -include-persistent to -include-own We always want to include persistents, the question is whether we want to include the non-persistent ident! Signed-off-by: Paul-Elliot --- src/odoc/bin/main.ml | 13 +++-- src/odoc/occurrences.ml | 4 +- test/occurrences/double_wrapped.t/run.t | 66 ++++++++++++++++++------- 3 files changed, 55 insertions(+), 28 deletions(-) diff --git a/src/odoc/bin/main.ml b/src/odoc/bin/main.ml index 298229f1f3..c71cb7aafb 100644 --- a/src/odoc/bin/main.ml +++ b/src/odoc/bin/main.ml @@ -1112,11 +1112,11 @@ end module Occurrences = struct module Count = struct - let count directories dst warnings_options include_hidden include_persistent + let count directories dst warnings_options include_hidden include_own = let dst = Fpath.v dst in Occurrences.count ~dst ~warnings_options directories include_hidden - include_persistent + include_own let cmd = let dst = @@ -1130,17 +1130,16 @@ module Occurrences = struct let doc = "Include hidden identifiers in the table" in Arg.(value & flag & info ~docs ~doc [ "include-hidden" ]) in - let include_persistent = + let include_own = let doc = - "Include persistent identifiers in the table: occurrences of in ids \ - intheir own implementation." + "Include identifiers from the compilation in the table." in - Arg.(value & flag & info ~docs ~doc [ "include-persistent" ]) + Arg.(value & flag & info ~docs ~doc [ "include-own" ]) in Term.( const handle_error $ (const count $ odoc_file_directories $ dst $ warnings_options - $ include_hidden $ include_persistent)) + $ include_hidden $ include_own)) let info ~docs = let doc = diff --git a/src/odoc/occurrences.ml b/src/odoc/occurrences.ml index 2a23478be0..48b38ebb80 100644 --- a/src/odoc/occurrences.ml +++ b/src/odoc/occurrences.ml @@ -119,7 +119,7 @@ end = struct tbl end -let count ~dst ~warnings_options:_ directories include_hidden include_persistent +let count ~dst ~warnings_options:_ directories include_hidden include_own = let htbl = H.create 100 in let f () (unit : Odoc_model.Lang.Compilation_unit.t) = @@ -127,7 +127,7 @@ let count ~dst ~warnings_options:_ directories include_hidden include_persistent let p = (p :> Odoc_model.Paths.Path.Resolved.t) in let id = Odoc_model.Paths.Path.Resolved.identifier p in if (not (Odoc_model.Paths.Path.Resolved.is_hidden p)) || include_hidden - then if (not persistent) || include_persistent then Occtbl.add tbl id + then if persistent || include_own then Occtbl.add tbl id in let () = List.iter diff --git a/test/occurrences/double_wrapped.t/run.t b/test/occurrences/double_wrapped.t/run.t index 989c66ad13..0aacfb0a2d 100644 --- a/test/occurrences/double_wrapped.t/run.t +++ b/test/occurrences/double_wrapped.t/run.t @@ -57,20 +57,25 @@ Uses of B.Z are not counted since they go to a hidden module. Uses of values Y.x and Z.y (in b.ml) are not counted since they come from a "local" module. $ occurrences_print main.occ | sort + Main was used directly 0 times and indirectly 2 times + Main.A was used directly 1 times and indirectly 0 times + Main.B was used directly 1 times and indirectly 0 times $ occurrences_print main__.occ | sort $ occurrences_print main__A.occ | sort - string was used directly 1 times and indirectly 0 times $ occurrences_print main__B.occ | sort - Main was used directly 0 times and indirectly 1 times - Main.A was used directly 0 times and indirectly 1 times + Main was used directly 0 times and indirectly 7 times + Main.A was used directly 2 times and indirectly 5 times + Main.A.(||>) was used directly 1 times and indirectly 0 times + Main.A.M was used directly 2 times and indirectly 0 times + Main.A.t was used directly 1 times and indirectly 0 times Main.A.x was used directly 1 times and indirectly 0 times $ occurrences_print main__C.occ | sort - Main was used directly 0 times and indirectly 1 times - Main.A was used directly 0 times and indirectly 1 times + Main was used directly 0 times and indirectly 2 times + Main.A was used directly 1 times and indirectly 1 times Main.A.x was used directly 1 times and indirectly 0 times Now we can merge both files @@ -83,23 +88,40 @@ Now we can merge both files $ odoc aggregate-occurrences main.occ main__.occ --file-list files.map -o aggregated.txt $ occurrences_print aggregated.txt | sort - Main was used directly 0 times and indirectly 2 times - Main.A was used directly 0 times and indirectly 2 times + Main was used directly 0 times and indirectly 11 times + Main.A was used directly 4 times and indirectly 6 times + Main.A.(||>) was used directly 1 times and indirectly 0 times + Main.A.M was used directly 2 times and indirectly 0 times + Main.A.t was used directly 1 times and indirectly 0 times Main.A.x was used directly 2 times and indirectly 0 times - string was used directly 1 times and indirectly 0 times + Main.B was used directly 1 times and indirectly 0 times Compare with the one created directly with all occurrences: $ odoc count-occurrences -I . -o occurrences.txt $ occurrences_print occurrences.txt | sort - Main was used directly 0 times and indirectly 2 times - Main.A was used directly 0 times and indirectly 2 times + Main was used directly 0 times and indirectly 11 times + Main.A was used directly 4 times and indirectly 6 times + Main.A.(||>) was used directly 1 times and indirectly 0 times + Main.A.M was used directly 2 times and indirectly 0 times + Main.A.t was used directly 1 times and indirectly 0 times Main.A.x was used directly 2 times and indirectly 0 times - string was used directly 1 times and indirectly 0 times + Main.B was used directly 1 times and indirectly 0 times We can also include persistent ids, and hidden ids: - $ odoc count-occurrences -I . -o occurrences.txt --include-persistent + $ odoc count-occurrences -I main__A -o occurrences.txt --include-own + $ occurrences_print occurrences.txt | sort + string was used directly 1 times and indirectly 0 times + + $ odoc count-occurrences -I main__A -o occurrences.txt --include-hidden + $ occurrences_print occurrences.txt | sort + + $ odoc count-occurrences -I main__A -o occurrences.txt --include-own --include-hidden + $ occurrences_print occurrences.txt | sort + string was used directly 1 times and indirectly 0 times + + $ odoc count-occurrences -I . -o occurrences.txt --include-own $ occurrences_print occurrences.txt | sort Main was used directly 0 times and indirectly 13 times Main.A was used directly 4 times and indirectly 8 times @@ -112,15 +134,21 @@ We can also include persistent ids, and hidden ids: $ odoc count-occurrences -I . -o occurrences.txt --include-hidden $ occurrences_print occurrences.txt | sort - Main was used directly 0 times and indirectly 2 times - Main.A was used directly 0 times and indirectly 2 times + Main was used directly 0 times and indirectly 11 times + Main.A was used directly 4 times and indirectly 6 times + Main.A.(||>) was used directly 1 times and indirectly 0 times + Main.A.M was used directly 2 times and indirectly 0 times + Main.A.t was used directly 1 times and indirectly 0 times Main.A.x was used directly 2 times and indirectly 0 times - Main__B was used directly 0 times and indirectly 1 times - Main__B.Z was used directly 0 times and indirectly 1 times - Main__B.Z.y was used directly 1 times and indirectly 0 times - string was used directly 1 times and indirectly 0 times + Main.B was used directly 1 times and indirectly 0 times + Main__ was used directly 0 times and indirectly 2 times + Main__.C was used directly 1 times and indirectly 1 times + Main__.C.y was used directly 1 times and indirectly 0 times + Main__A was used directly 1 times and indirectly 0 times + Main__B was used directly 1 times and indirectly 0 times + Main__C was used directly 1 times and indirectly 0 times - $ odoc count-occurrences -I . -o occurrences.txt --include-persistent --include-hidden + $ odoc count-occurrences -I . -o occurrences.txt --include-own --include-hidden $ occurrences_print occurrences.txt | sort Main was used directly 0 times and indirectly 13 times Main.A was used directly 4 times and indirectly 8 times From 1af37f5dde1dfbfc7cf242a16af91db6e6309062 Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Fri, 3 Nov 2023 18:09:53 +0100 Subject: [PATCH 20/41] Occurrences: add shapes for other nodes, improve test Signed-off-by: Paul-Elliot --- src/xref2/link.ml | 9 ++++-- src/xref2/shape_tools.cppo.ml | 40 ++++++++++++++----------- src/xref2/shape_tools.cppo.mli | 16 ++++++++++ test/occurrences/double_wrapped.t/a.ml | 2 ++ test/occurrences/double_wrapped.t/run.t | 27 ++++++++++++++++- 5 files changed, 73 insertions(+), 21 deletions(-) diff --git a/src/xref2/link.ml b/src/xref2/link.ml index d9eff95d8d..c3245db4d1 100644 --- a/src/xref2/link.ml +++ b/src/xref2/link.ml @@ -565,18 +565,23 @@ let rec unit env t = | ModuleType v -> ModuleType (jump_to v - (fun _ -> None) + (Shape_tools.lookup_module_type_path env) (module_type_path ~report_errors:false env)) | Type v -> Type (jump_to v - (fun _ -> None) + (Shape_tools.lookup_type_path env) (type_path ~report_errors:false env)) | Constructor v -> Constructor (jump_to v (fun _ -> None) (constructor_path ~report_errors:false env)) + | ClassType v -> + ClassType + (jump_to v + (Shape_tools.lookup_class_type_path env) + (class_type_path ~report_errors:false env)) | i -> i in (info, pos)) diff --git a/src/xref2/shape_tools.cppo.ml b/src/xref2/shape_tools.cppo.ml index f4feb5970f..7d2a351c32 100644 --- a/src/xref2/shape_tools.cppo.ml +++ b/src/xref2/shape_tools.cppo.ml @@ -81,21 +81,20 @@ let rec shape_of_module_path env : _ -> Shape.t option = | `Identifier (id, _) -> shape_of_id env (id :> Odoc_model.Paths.Identifier.NonSrc.t) -let shape_of_value_path env : - Odoc_model.Paths.Path.Value.t -> Shape.t option = +let shape_of_kind_path env kind : + _ -> Shape.t option = let proj parent kind name = let item = Shape.Item.make name kind in match shape_of_module_path env parent with | Some shape -> Some (Shape.proj shape item) | None -> None in - fun (path : Odoc_model.Paths.Path.Value.t) -> + fun path -> match path with | `Resolved _ -> None - | `Dot (parent, name) -> proj parent Kind.Value name + | `Dot (parent, name) -> proj parent kind name | `Identifier (id, _) -> shape_of_id env (id :> Odoc_model.Paths.Identifier.NonSrc.t) - module MkId = Identifier.Mk let unit_of_uid uid = @@ -151,25 +150,24 @@ let lookup_def : | None -> None | Some query -> lookup_shape env query -let lookup_value_path : - Env.t -> - Path.Value.t -> - Identifier.SourceLocation.t option - = fun env path -> - match shape_of_value_path env path with +let lookup_module_path = fun env path -> + match shape_of_module_path env path with | None -> None | Some query -> lookup_shape env query - -let lookup_module_path : - Env.t -> - Path.Module.t -> - Identifier.SourceLocation.t option - = fun env path -> - match shape_of_module_path env path with +let lookup_kind_path = fun kind env path -> + match shape_of_kind_path env kind path with | None -> None | Some query -> lookup_shape env query +let lookup_value_path = lookup_kind_path Kind.Value + +let lookup_type_path = lookup_kind_path Kind.Type + +let lookup_module_type_path = lookup_kind_path Kind.Module_type + +let lookup_class_type_path = lookup_kind_path Kind.Class_type + #else type t = unit @@ -180,4 +178,10 @@ let lookup_value_path _ _id = None let lookup_module_path _ _id = None +let lookup_type_path _ _id = None + +let lookup_module_type_path _ _id = None + +let lookup_class_type_path _ _id = None + #endif diff --git a/src/xref2/shape_tools.cppo.mli b/src/xref2/shape_tools.cppo.mli index 40caf7b433..adfddc5d2c 100644 --- a/src/xref2/shape_tools.cppo.mli +++ b/src/xref2/shape_tools.cppo.mli @@ -19,7 +19,23 @@ val lookup_value_path : Path.Value.t -> Identifier.SourceLocation.t option +val lookup_type_path : + Env.t -> + Path.Type.t -> + Identifier.SourceLocation.t option + val lookup_module_path : Env.t -> Path.Module.t -> Identifier.SourceLocation.t option + +val lookup_module_type_path : + Env.t -> + Path.ModuleType.t -> + Identifier.SourceLocation.t option + +val lookup_class_type_path : + Env.t -> + Path.ClassType.t -> + Identifier.SourceLocation.t option + diff --git a/test/occurrences/double_wrapped.t/a.ml b/test/occurrences/double_wrapped.t/a.ml index 0a13bbe074..aa8464151f 100644 --- a/test/occurrences/double_wrapped.t/a.ml +++ b/test/occurrences/double_wrapped.t/a.ml @@ -5,3 +5,5 @@ type t = string module type M = sig end let (||>) x y = x + y + +let _ = x + x diff --git a/test/occurrences/double_wrapped.t/run.t b/test/occurrences/double_wrapped.t/run.t index 0aacfb0a2d..a0660c6c29 100644 --- a/test/occurrences/double_wrapped.t/run.t +++ b/test/occurrences/double_wrapped.t/run.t @@ -119,6 +119,8 @@ We can also include persistent ids, and hidden ids: $ odoc count-occurrences -I main__A -o occurrences.txt --include-own --include-hidden $ occurrences_print occurrences.txt | sort + Main__A was used directly 0 times and indirectly 2 times + Main__A.x was used directly 2 times and indirectly 0 times string was used directly 1 times and indirectly 0 times $ odoc count-occurrences -I . -o occurrences.txt --include-own @@ -160,9 +162,32 @@ We can also include persistent ids, and hidden ids: Main__ was used directly 0 times and indirectly 2 times Main__.C was used directly 1 times and indirectly 1 times Main__.C.y was used directly 1 times and indirectly 0 times - Main__A was used directly 1 times and indirectly 0 times + Main__A was used directly 1 times and indirectly 2 times + Main__A.x was used directly 2 times and indirectly 0 times Main__B was used directly 1 times and indirectly 1 times Main__B.Z was used directly 0 times and indirectly 1 times Main__B.Z.y was used directly 1 times and indirectly 0 times Main__C was used directly 1 times and indirectly 0 times string was used directly 1 times and indirectly 0 times + + +REMARKS! + + $ odoc count-occurrences -I main__B -o b_only_persistent.occ + $ odoc count-occurrences -I main__B -o b_with_own.occ --include-own + $ occurrences_print b_only_persistent.occ | sort > only_persistent + $ occurrences_print b_with_own.occ | sort > with_own + $ diff only_persistent with_own | grep Main.A.x + < Main.A.x was used directly 1 times and indirectly 0 times + > Main.A.x was used directly 2 times and indirectly 0 times + +This is because the persistent Y.x is resolved into Main.A.x. So maybe relying +on Ident.persistent is not the good way of knowing if it is persistent or not? + + $ odoc count-occurrences -I main__A -o a_with_own_and_hidden.occ --include-own --include-hidden + $ occurrences_print a_with_own_and_hidden.occ | sort + Main__A was used directly 0 times and indirectly 2 times + Main__A.x was used directly 2 times and indirectly 0 times + string was used directly 1 times and indirectly 0 times + +That's a problem: it should be Main.A and Main.A.x From 02a08890df1811e86198cb40869189a4cd29d8a3 Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Fri, 3 Nov 2023 18:40:12 +0100 Subject: [PATCH 21/41] loader compatibility code Signed-off-by: Paul-Elliot --- src/loader/cmti.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/loader/cmti.ml b/src/loader/cmti.ml index 870cd18f69..436f6a6fdc 100644 --- a/src/loader/cmti.ml +++ b/src/loader/cmti.ml @@ -531,16 +531,16 @@ and read_module_type env parent label_parent mty = Functor (f_parameter, res) #else | Tmty_functor(id, _, arg, res) -> - let new_env = Env.add_parameter parent id (ModuleName.of_ident id) env in + let () = Env.add_parameter parent id (ModuleName.of_ident id) env in let f_parameter = match arg with | None -> Odoc_model.Lang.FunctorParameter.Unit | Some arg -> - let id = Ident_env.find_parameter_identifier new_env id in + let id = Ident_env.find_parameter_identifier env id in let arg = read_module_type env (id :> Identifier.Signature.t) label_parent arg in Named { FunctorParameter. id; expr = arg } in - let res = read_module_type new_env (Identifier.Mk.result parent) label_parent res in + let res = read_module_type () (Identifier.Mk.result parent) label_parent res in Functor( f_parameter, res) #endif | Tmty_with(body, subs) -> ( From 4ec54b4bf03484c4d975b92980ffc38531d4bcfd Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Wed, 6 Dec 2023 15:40:09 +0100 Subject: [PATCH 22/41] occurrences: only count persistent one Signed-off-by: Paul-Elliot --- src/document/generator.ml | 2 +- src/loader/implementation.ml | 2 +- src/model/lang.ml | 4 +- src/odoc/bin/main.ml | 12 +--- src/odoc/occurrences.ml | 27 ++++---- src/xref2/compile.ml | 4 +- src/xref2/link.ml | 4 +- test/occurrences/double_wrapped.t/b.ml | 4 +- test/occurrences/double_wrapped.t/run.t | 83 +++---------------------- 9 files changed, 30 insertions(+), 112 deletions(-) diff --git a/src/document/generator.ml b/src/document/generator.ml index 1c5b72e5e7..cdba1ffae0 100644 --- a/src/document/generator.ml +++ b/src/document/generator.ml @@ -256,7 +256,7 @@ module Make (Syntax : SYNTAX) = struct let documentation = let open Paths.Path.Resolved in match documentation with - | Some (`Resolved p, _) when not (is_hidden (p :> t)) -> ( + | Some (`Resolved p) when not (is_hidden (p :> t)) -> ( let id = identifier (p :> t) in match Url.from_identifier ~stop_before:false id with | Ok link -> Some link diff --git a/src/loader/implementation.ml b/src/loader/implementation.ml index 7fc5941679..55c011adea 100644 --- a/src/loader/implementation.ml +++ b/src/loader/implementation.ml @@ -315,7 +315,7 @@ let process_occurrences env poses loc_to_id local_ident_to_loc = | p -> ( match find_in_env env p with | path -> - let documentation = Some (path, is_persistent p) + let documentation = if is_persistent p then Some path else None and implementation = Some (Unresolved path) in Some { documentation; implementation } | exception _ -> None) diff --git a/src/model/lang.ml b/src/model/lang.ml index c6ba7edab1..dd4abf6a68 100644 --- a/src/model/lang.ml +++ b/src/model/lang.ml @@ -23,9 +23,7 @@ module Source_info = struct | Resolved of Identifier.SourceLocation.t type ('doc, 'impl) jump_to = { - documentation : ('doc * bool) option; - (* The boolean indicate if the path is "persistent": from the same - compilation unit. *) + documentation : 'doc option; implementation : 'impl jump_to_impl option; } diff --git a/src/odoc/bin/main.ml b/src/odoc/bin/main.ml index c71cb7aafb..5f51365420 100644 --- a/src/odoc/bin/main.ml +++ b/src/odoc/bin/main.ml @@ -1112,11 +1112,9 @@ end module Occurrences = struct module Count = struct - let count directories dst warnings_options include_hidden include_own - = + let count directories dst warnings_options include_hidden = let dst = Fpath.v dst in Occurrences.count ~dst ~warnings_options directories include_hidden - include_own let cmd = let dst = @@ -1130,16 +1128,10 @@ module Occurrences = struct let doc = "Include hidden identifiers in the table" in Arg.(value & flag & info ~docs ~doc [ "include-hidden" ]) in - let include_own = - let doc = - "Include identifiers from the compilation in the table." - in - Arg.(value & flag & info ~docs ~doc [ "include-own" ]) - in Term.( const handle_error $ (const count $ odoc_file_directories $ dst $ warnings_options - $ include_hidden $ include_own)) + $ include_hidden)) let info ~docs = let doc = diff --git a/src/odoc/occurrences.ml b/src/odoc/occurrences.ml index 48b38ebb80..9922257112 100644 --- a/src/odoc/occurrences.ml +++ b/src/odoc/occurrences.ml @@ -119,33 +119,28 @@ end = struct tbl end -let count ~dst ~warnings_options:_ directories include_hidden include_own - = +let count ~dst ~warnings_options:_ directories include_hidden = let htbl = H.create 100 in let f () (unit : Odoc_model.Lang.Compilation_unit.t) = - let incr tbl p persistent = + let incr tbl p = let p = (p :> Odoc_model.Paths.Path.Resolved.t) in let id = Odoc_model.Paths.Path.Resolved.identifier p in if (not (Odoc_model.Paths.Path.Resolved.is_hidden p)) || include_hidden - then if persistent || include_own then Occtbl.add tbl id + then Occtbl.add tbl id in let () = List.iter (function | ( Odoc_model.Lang.Source_info.Module - { documentation = Some (`Resolved p, persistent); _ }, + { documentation = Some (`Resolved p); _ }, _ ) -> - incr htbl p persistent - | Value { documentation = Some (`Resolved p, persistent); _ }, _ -> - incr htbl p persistent - | ClassType { documentation = Some (`Resolved p, persistent); _ }, _ - -> - incr htbl p persistent - | ModuleType { documentation = Some (`Resolved p, persistent); _ }, _ - -> - incr htbl p persistent - | Type { documentation = Some (`Resolved p, persistent); _ }, _ -> - incr htbl p persistent + incr htbl p + | Value { documentation = Some (`Resolved p); _ }, _ -> incr htbl p + | ClassType { documentation = Some (`Resolved p); _ }, _ -> + incr htbl p + | ModuleType { documentation = Some (`Resolved p); _ }, _ -> + incr htbl p + | Type { documentation = Some (`Resolved p); _ }, _ -> incr htbl p | _ -> ()) (match unit.source_info with None -> [] | Some i -> i.infos) in diff --git a/src/xref2/compile.ml b/src/xref2/compile.ml index 1cb0ef98f6..66df782eb5 100644 --- a/src/xref2/compile.ml +++ b/src/xref2/compile.ml @@ -89,9 +89,7 @@ and source_info_infos env infos = let open Source_info in let map_doc f v = let documentation = - match v.documentation with - | Some (p, persistent) -> Some (f p, persistent) - | None -> None + match v.documentation with Some p -> Some (f p) | None -> None in { v with documentation } in diff --git a/src/xref2/link.ml b/src/xref2/link.ml index c3245db4d1..ada50ad8df 100644 --- a/src/xref2/link.ml +++ b/src/xref2/link.ml @@ -533,9 +533,7 @@ let rec unit env t = | Some inf -> let jump_to v f_impl f_doc = let documentation = - match v.documentation with - | Some (p, persistent) -> Some (f_doc p, persistent) - | None -> None + match v.documentation with Some p -> Some (f_doc p) | None -> None in let implementation = match v.implementation with diff --git a/test/occurrences/double_wrapped.t/b.ml b/test/occurrences/double_wrapped.t/b.ml index 9c65111cd5..6a01b082fe 100644 --- a/test/occurrences/double_wrapped.t/b.ml +++ b/test/occurrences/double_wrapped.t/b.ml @@ -10,4 +10,6 @@ module M : A.M = struct end module type Y = A.M -let _ = let open A in 1 ||> 2 +let _ = + let open A in + 1 ||> 2 diff --git a/test/occurrences/double_wrapped.t/run.t b/test/occurrences/double_wrapped.t/run.t index a0660c6c29..5361b9d035 100644 --- a/test/occurrences/double_wrapped.t/run.t +++ b/test/occurrences/double_wrapped.t/run.t @@ -63,8 +63,10 @@ Uses of values Y.x and Z.y (in b.ml) are not counted since they come from a "loc $ occurrences_print main__.occ | sort +A only uses "persistent" values: one it defines itself. $ occurrences_print main__A.occ | sort +"Aliased" values are not counted since they become persistent $ occurrences_print main__B.occ | sort Main was used directly 0 times and indirectly 7 times Main.A was used directly 2 times and indirectly 5 times @@ -73,12 +75,13 @@ Uses of values Y.x and Z.y (in b.ml) are not counted since they come from a "loc Main.A.t was used directly 1 times and indirectly 0 times Main.A.x was used directly 1 times and indirectly 0 times +"Aliased" values are not counted since they become persistent $ occurrences_print main__C.occ | sort Main was used directly 0 times and indirectly 2 times Main.A was used directly 1 times and indirectly 1 times Main.A.x was used directly 1 times and indirectly 0 times -Now we can merge both files +Now we can merge all tables $ cat > files.map << EOF > main__A.occ @@ -87,7 +90,8 @@ Now we can merge both files > EOF $ odoc aggregate-occurrences main.occ main__.occ --file-list files.map -o aggregated.txt - $ occurrences_print aggregated.txt | sort + $ occurrences_print aggregated.txt | sort > all_merged + $ cat all_merged Main was used directly 0 times and indirectly 11 times Main.A was used directly 4 times and indirectly 6 times Main.A.(||>) was used directly 1 times and indirectly 0 times @@ -99,41 +103,14 @@ Now we can merge both files Compare with the one created directly with all occurrences: $ odoc count-occurrences -I . -o occurrences.txt - $ occurrences_print occurrences.txt | sort - Main was used directly 0 times and indirectly 11 times - Main.A was used directly 4 times and indirectly 6 times - Main.A.(||>) was used directly 1 times and indirectly 0 times - Main.A.M was used directly 2 times and indirectly 0 times - Main.A.t was used directly 1 times and indirectly 0 times - Main.A.x was used directly 2 times and indirectly 0 times - Main.B was used directly 1 times and indirectly 0 times + $ occurrences_print occurrences.txt | sort > directly_all + $ diff all_merged directly_all -We can also include persistent ids, and hidden ids: - - $ odoc count-occurrences -I main__A -o occurrences.txt --include-own - $ occurrences_print occurrences.txt | sort - string was used directly 1 times and indirectly 0 times +We can also include hidden ids: $ odoc count-occurrences -I main__A -o occurrences.txt --include-hidden $ occurrences_print occurrences.txt | sort - $ odoc count-occurrences -I main__A -o occurrences.txt --include-own --include-hidden - $ occurrences_print occurrences.txt | sort - Main__A was used directly 0 times and indirectly 2 times - Main__A.x was used directly 2 times and indirectly 0 times - string was used directly 1 times and indirectly 0 times - - $ odoc count-occurrences -I . -o occurrences.txt --include-own - $ occurrences_print occurrences.txt | sort - Main was used directly 0 times and indirectly 13 times - Main.A was used directly 4 times and indirectly 8 times - Main.A.(||>) was used directly 1 times and indirectly 0 times - Main.A.M was used directly 2 times and indirectly 0 times - Main.A.t was used directly 1 times and indirectly 0 times - Main.A.x was used directly 4 times and indirectly 0 times - Main.B was used directly 1 times and indirectly 0 times - string was used directly 1 times and indirectly 0 times - $ odoc count-occurrences -I . -o occurrences.txt --include-hidden $ occurrences_print occurrences.txt | sort Main was used directly 0 times and indirectly 11 times @@ -149,45 +126,3 @@ We can also include persistent ids, and hidden ids: Main__A was used directly 1 times and indirectly 0 times Main__B was used directly 1 times and indirectly 0 times Main__C was used directly 1 times and indirectly 0 times - - $ odoc count-occurrences -I . -o occurrences.txt --include-own --include-hidden - $ occurrences_print occurrences.txt | sort - Main was used directly 0 times and indirectly 13 times - Main.A was used directly 4 times and indirectly 8 times - Main.A.(||>) was used directly 1 times and indirectly 0 times - Main.A.M was used directly 2 times and indirectly 0 times - Main.A.t was used directly 1 times and indirectly 0 times - Main.A.x was used directly 4 times and indirectly 0 times - Main.B was used directly 1 times and indirectly 0 times - Main__ was used directly 0 times and indirectly 2 times - Main__.C was used directly 1 times and indirectly 1 times - Main__.C.y was used directly 1 times and indirectly 0 times - Main__A was used directly 1 times and indirectly 2 times - Main__A.x was used directly 2 times and indirectly 0 times - Main__B was used directly 1 times and indirectly 1 times - Main__B.Z was used directly 0 times and indirectly 1 times - Main__B.Z.y was used directly 1 times and indirectly 0 times - Main__C was used directly 1 times and indirectly 0 times - string was used directly 1 times and indirectly 0 times - - -REMARKS! - - $ odoc count-occurrences -I main__B -o b_only_persistent.occ - $ odoc count-occurrences -I main__B -o b_with_own.occ --include-own - $ occurrences_print b_only_persistent.occ | sort > only_persistent - $ occurrences_print b_with_own.occ | sort > with_own - $ diff only_persistent with_own | grep Main.A.x - < Main.A.x was used directly 1 times and indirectly 0 times - > Main.A.x was used directly 2 times and indirectly 0 times - -This is because the persistent Y.x is resolved into Main.A.x. So maybe relying -on Ident.persistent is not the good way of knowing if it is persistent or not? - - $ odoc count-occurrences -I main__A -o a_with_own_and_hidden.occ --include-own --include-hidden - $ occurrences_print a_with_own_and_hidden.occ | sort - Main__A was used directly 0 times and indirectly 2 times - Main__A.x was used directly 2 times and indirectly 0 times - string was used directly 1 times and indirectly 0 times - -That's a problem: it should be Main.A and Main.A.x From d8b0b1b5f9946ce3281a651d12b6784a4e5de3b3 Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Tue, 5 Dec 2023 17:46:51 +0100 Subject: [PATCH 23/41] Remove rendering of links to documentation Signed-off-by: Paul-Elliot --- src/html/html_source.ml | 30 +++++------------------------- src/html_support_files/odoc.css | 8 -------- 2 files changed, 5 insertions(+), 33 deletions(-) diff --git a/src/html/html_source.ml b/src/html/html_source.ml index edd3cd32d4..4a859369d4 100644 --- a/src/html/html_source.ml +++ b/src/html/html_source.ml @@ -24,31 +24,11 @@ let html_of_doc ~config ~resolve docs = let children = List.concat @@ List.map (doc_to_html ~is_in_a) docs in match info with | Syntax tok -> [ span ~a:[ a_class [ tok ] ] children ] - | Link { documentation; implementation } -> ( - let href_implementation = - Option.map (Link.href ~config ~resolve) implementation - in - let href_documentation = - Option.map (Link.href ~config ~resolve) documentation - in - let body = - match href_implementation with - | Some href -> [ a ~a:[ a_href href ] children ] - | None -> children - in - match href_documentation with - | None -> body - | Some href -> - [ - span - ~a:[ a_class [ "jump-to-doc-container" ] ] - [ - span ~a:[] body; - a - ~a:[ a_href href; a_class [ "jump-to-doc" ] ] - [ txt " 📖" ]; - ]; - ]) + (* Currently, we do not render links to documentation *) + | Link { documentation = _; implementation = None } -> children + | Link { documentation = _; implementation = Some anchor } -> + let href = Link.href ~config ~resolve anchor in + [ a ~a:[ a_href href ] children ] | Anchor lbl -> [ span ~a:[ a_id lbl ] children ]) in span ~a:[] @@ List.concat @@ List.map (doc_to_html ~is_in_a:false) docs diff --git a/src/html_support_files/odoc.css b/src/html_support_files/odoc.css index 228fcf4287..db5a6b112a 100644 --- a/src/html_support_files/odoc.css +++ b/src/html_support_files/odoc.css @@ -1206,14 +1206,6 @@ td.def-doc *:first-child { color: #657b83; } -.jump-to-doc-container:hover .jump-to-doc { - display: inline; -} - -.jump-to-doc { - display: none; -} - /* Source directories */ .odoc-directory::before { From b48dcff6615126587389dd4dd4117e04582cb7f3 Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Thu, 7 Dec 2023 10:36:03 +0100 Subject: [PATCH 24/41] occurrences: review comments - Handle `Pextra_ty` in `is_persistent` - alias `Tast_iterator.default_iterator` to improve readability - Remove possibility for `jump_to` type to have different types for doc and impl - Factorize all instances of `contains_double_underscore` - Use `ModuleName.is_hidden` instead of inlining its definition... - Handle `ClassType` occurrences in compile, and avoid future miss by having an exhaustive match. Signed-off-by: Paul-Elliot --- src/loader/cmi.ml | 2 +- src/loader/cmt.ml | 2 +- src/loader/cmti.ml | 2 +- src/loader/ident_env.cppo.ml | 2 +- src/loader/implementation.ml | 2 +- src/loader/odoc_loader.ml | 2 +- src/loader/typedtree_traverse.ml | 17 +++++++++-------- src/model/lang.ml | 20 +++++++++----------- src/model/names.ml | 27 +++++++++++---------------- src/model/names.mli | 2 ++ src/model/paths.ml | 15 ++------------- src/model/root.ml | 11 +---------- src/model/root.mli | 4 ---- src/xref2/compile.ml | 3 ++- 14 files changed, 42 insertions(+), 69 deletions(-) diff --git a/src/loader/cmi.ml b/src/loader/cmi.ml index 8365e5b22a..86fe68bdd2 100644 --- a/src/loader/cmi.ml +++ b/src/loader/cmi.ml @@ -968,7 +968,7 @@ and read_module_declaration env parent ident (md : Odoc_model.Compat.module_decl let hidden = match canonical with | Some _ -> false - | None -> Odoc_model.Root.contains_double_underscore (Ident.name ident) + | None -> Odoc_model.Names.contains_double_underscore (Ident.name ident) in {id; locs; doc; type_; canonical; hidden } diff --git a/src/loader/cmt.ml b/src/loader/cmt.ml index 9b06dbaa87..4d173fd4a7 100644 --- a/src/loader/cmt.ml +++ b/src/loader/cmt.ml @@ -450,7 +450,7 @@ and read_module_binding env parent mb = let hidden = #if OCAML_VERSION >= (4,10,0) match canonical, mb.mb_id with - | None, Some id -> Odoc_model.Root.contains_double_underscore (Ident.name id) + | None, Some id -> Odoc_model.Names.contains_double_underscore (Ident.name id) | _, _ -> false #else match canonical with diff --git a/src/loader/cmti.ml b/src/loader/cmti.ml index 436f6a6fdc..4fc2228094 100644 --- a/src/loader/cmti.ml +++ b/src/loader/cmti.ml @@ -628,7 +628,7 @@ and read_module_declaration env parent md = let hidden = #if OCAML_VERSION >= (4,10,0) match canonical, md.md_id with - | None, Some id -> Odoc_model.Root.contains_double_underscore (Ident.name id) + | None, Some id -> Odoc_model.Names.contains_double_underscore (Ident.name id) | _,_ -> false #else match canonical with diff --git a/src/loader/ident_env.cppo.ml b/src/loader/ident_env.cppo.ml index 6e5094306b..32ce6b797d 100644 --- a/src/loader/ident_env.cppo.ml +++ b/src/loader/ident_env.cppo.ml @@ -553,7 +553,7 @@ let add_items : Id.Signature.t -> item list -> t -> unit = fun parent items env | `Module (t, is_hidden_item, loc) :: rest -> let name = Ident.name t in - let double_underscore = Odoc_model.Root.contains_double_underscore name in + let double_underscore = Odoc_model.Names.contains_double_underscore name in let is_hidden = is_hidden_item || module_name_exists name rest || double_underscore in let identifier = if is_hidden diff --git a/src/loader/implementation.ml b/src/loader/implementation.ml index 55c011adea..902f58cd53 100644 --- a/src/loader/implementation.ml +++ b/src/loader/implementation.ml @@ -5,7 +5,7 @@ let rec is_persistent : Path.t -> bool = function | Path.Pdot(p, _) -> is_persistent p | Path.Papply(p, _) -> is_persistent p #if OCAML_VERSION >= (5,1,0) - | Path.Pextra_ty _ -> assert false + | Path.Pextra_ty (p, _) -> is_persistent p #endif let pos_of_loc loc = (loc.Location.loc_start.pos_cnum, loc.loc_end.pos_cnum) diff --git a/src/loader/odoc_loader.ml b/src/loader/odoc_loader.ml index bdb3c177d0..79dda8c67b 100644 --- a/src/loader/odoc_loader.ml +++ b/src/loader/odoc_loader.ml @@ -83,7 +83,7 @@ let make_compilation_unit ~make_root ~imports ~interface ?sourcefile ~name ~id imports; source; interface; - hidden = Odoc_model.Root.contains_double_underscore name; + hidden = Odoc_model.Names.contains_double_underscore name; content; expansion = None; linked = false; diff --git a/src/loader/typedtree_traverse.ml b/src/loader/typedtree_traverse.ml index 8b5a96a97f..67be8ae96f 100644 --- a/src/loader/typedtree_traverse.ml +++ b/src/loader/typedtree_traverse.ml @@ -94,37 +94,38 @@ end let of_cmt env structure = let poses = ref [] in + let iter = Tast_iterator.default_iterator in let module_expr iterator mod_expr = Analysis.module_expr poses mod_expr; - Tast_iterator.default_iterator.module_expr iterator mod_expr + iter.module_expr iterator mod_expr in let expr iterator e = Analysis.expr poses e; - Tast_iterator.default_iterator.expr iterator e + iter.expr iterator e in let pat iterator e = Analysis.pat env poses e; - Tast_iterator.default_iterator.pat iterator e + iter.pat iterator e in let typ iterator ctyp_expr = Analysis.core_type poses ctyp_expr; - Tast_iterator.default_iterator.typ iterator ctyp_expr + iter.typ iterator ctyp_expr in let module_type iterator mty = Analysis.module_type poses mty; - Tast_iterator.default_iterator.module_type iterator mty + iter.module_type iterator mty in let class_type iterator cl_type = Analysis.class_type poses cl_type; - Tast_iterator.default_iterator.class_type iterator cl_type + iter.class_type iterator cl_type in let module_binding iterator mb = Analysis.module_binding env poses mb; - Tast_iterator.default_iterator.module_binding iterator mb + iter.module_binding iterator mb in let iterator = { - Tast_iterator.default_iterator with + iter with expr; pat; module_expr; diff --git a/src/model/lang.ml b/src/model/lang.ml index dd4abf6a68..800666b962 100644 --- a/src/model/lang.ml +++ b/src/model/lang.ml @@ -22,21 +22,19 @@ module Source_info = struct | Unresolved of 'a | Resolved of Identifier.SourceLocation.t - type ('doc, 'impl) jump_to = { - documentation : 'doc option; - implementation : 'impl jump_to_impl option; + type 'a jump_to = { + documentation : 'a option; + implementation : 'a jump_to_impl option; } - type 'path jump_1 = ('path, 'path) jump_to - type annotation = | Definition of Paths.Identifier.SourceLocation.t - | Value of Path.Value.t jump_1 - | Module of Path.Module.t jump_1 - | ClassType of Path.ClassType.t jump_1 - | ModuleType of Path.ModuleType.t jump_1 - | Type of Path.Type.t jump_1 - | Constructor of Path.Constructor.t jump_1 + | Value of Path.Value.t jump_to + | Module of Path.Module.t jump_to + | ClassType of Path.ClassType.t jump_to + | ModuleType of Path.ModuleType.t jump_to + | Type of Path.Type.t jump_to + | Constructor of Path.Constructor.t jump_to type 'a with_pos = 'a * (int * int) diff --git a/src/model/names.ml b/src/model/names.ml index d508d27abe..9ae4701b2c 100644 --- a/src/model/names.ml +++ b/src/model/names.ml @@ -15,6 +15,15 @@ let parenthesise name = | _ -> "(" ^ name ^ ")" else name +let contains_double_underscore s = + let len = String.length s in + let rec aux i = + if i > len - 2 then false + else if s.[i] = '_' && s.[i + 1] = '_' then true + else aux (i + 1) + in + aux 0 + module type Name = sig type t @@ -73,14 +82,7 @@ module Name : Name = struct let fmt ppf x = Format.fprintf ppf "%s" (to_string x) let is_hidden = function - | Std s -> - let len = String.length s in - let rec aux i = - if i > len - 2 then false - else if s.[i] = '_' && s.[i + 1] = '_' then true - else aux (i + 1) - in - aux 0 + | Std s -> contains_double_underscore s | Internal _ -> true end @@ -117,14 +119,7 @@ module SimpleName : SimpleName = struct let fmt ppf t = Format.pp_print_string ppf (to_string t) - let is_hidden s = - let len = String.length s in - let rec aux i = - if i > len - 2 then false - else if s.[i] = '_' && s.[i + 1] = '_' then true - else aux (i + 1) - in - aux 0 + let is_hidden s = contains_double_underscore s end module ModuleName = Name diff --git a/src/model/names.mli b/src/model/names.mli index 9d6b3a68dd..7854988977 100644 --- a/src/model/names.mli +++ b/src/model/names.mli @@ -7,6 +7,8 @@ *) val parenthesise : string -> string +val contains_double_underscore : string -> bool +(* not the best place for this but. *) (** Name is the signature for names that could possibly be internal. Internal names occur when we generate items that don't have a path that will be diff --git a/src/model/paths.ml b/src/model/paths.ml index 47225b09fa..586f8123a4 100644 --- a/src/model/paths.ml +++ b/src/model/paths.ml @@ -19,15 +19,6 @@ module Ocaml_env = Env open Names -let contains_double_underscore s = - let len = String.length s in - let rec aux i = - if i > len - 2 then false - else if s.[i] = '_' && s.[i + 1] = '_' then true - else aux (i + 1) - in - aux 0 - module Identifier = struct type 'a id = 'a Paths_types.id = { iv : 'a; ihash : int; ikey : string } @@ -75,9 +66,7 @@ module Identifier = struct let rec is_internal : t -> bool = fun x -> match x.iv with - | `Root (_, name) -> - ModuleName.is_internal name - || contains_double_underscore (ModuleName.to_string name) + | `Root (_, name) -> ModuleName.is_hidden name | `Page (_, _) -> false | `LeafPage (_, _) -> false | `Module (_, name) -> ModuleName.is_internal name @@ -754,7 +743,7 @@ module Path = struct function | `Resolved r -> is_resolved_hidden ~weak_canonical_test:false r | `Identifier (_, hidden) -> hidden - | `Root s -> contains_double_underscore s + | `Root s -> Names.contains_double_underscore s | `Forward _ -> false | `Dot (p, _) -> is_path_hidden (p : module_ :> any) | `Apply (p1, p2) -> diff --git a/src/model/root.ml b/src/model/root.ml index 99ea13add7..a11e88f803 100644 --- a/src/model/root.ml +++ b/src/model/root.ml @@ -14,15 +14,6 @@ * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) -let contains_double_underscore s = - let len = String.length s in - let rec aux i = - if i > len - 2 then false - else if s.[i] = '_' && s.[i + 1] = '_' then true - else aux (i + 1) - in - aux 0 - module Package = struct type t = string @@ -41,7 +32,7 @@ module Odoc_file = struct type t = Page of string | Compilation_unit of compilation_unit let create_unit ~force_hidden name = - let hidden = force_hidden || contains_double_underscore name in + let hidden = force_hidden || Names.contains_double_underscore name in Compilation_unit { name; hidden } let create_page name = Page name diff --git a/src/model/root.mli b/src/model/root.mli index 393aa0f2ba..2d905f3cd5 100644 --- a/src/model/root.mli +++ b/src/model/root.mli @@ -54,7 +54,3 @@ val compare : t -> t -> int val to_string : t -> string module Hash_table : Hashtbl.S with type key = t - -val contains_double_underscore : string -> bool - -(* not the best place for this but. *) diff --git a/src/xref2/compile.ml b/src/xref2/compile.ml index 66df782eb5..28322c34b1 100644 --- a/src/xref2/compile.ml +++ b/src/xref2/compile.ml @@ -103,7 +103,8 @@ and source_info_infos env infos = | ModuleType v -> ModuleType (map_doc (module_type_path env) v) | Type v -> Type (map_doc (type_path env) v) | Constructor v -> Constructor (map_doc (constructor_path env) v) - | i -> i + | ClassType v -> ClassType (map_doc (class_type_path env) v) + | Definition _ as d -> d in (v, pos)) infos From bd2cb72f620467ae65e35ea70d461279f16edb61 Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Thu, 7 Dec 2023 17:37:39 +0100 Subject: [PATCH 25/41] implementation loader: centralize+comment decision wrt src rendering Signed-off-by: Paul-Elliot --- src/loader/implementation.ml | 96 +++++++++++++++++------------------- 1 file changed, 46 insertions(+), 50 deletions(-) diff --git a/src/loader/implementation.ml b/src/loader/implementation.ml index 902f58cd53..c3d2f76732 100644 --- a/src/loader/implementation.ml +++ b/src/loader/implementation.ml @@ -162,14 +162,10 @@ let populate_local_defs source_id poses loc_to_id local_ident_to_loc = Odoc_model.Names.LocalName.make_std (Printf.sprintf "local_%s_%d" (Ident.name id) (counter ())) in - (match source_id with - | Some source_id -> - let identifier = - Odoc_model.Paths.Identifier.Mk.source_location_int - (source_id, name) - in - LocHashtbl.add loc_to_id loc identifier - | None -> ()); + let identifier = + Odoc_model.Paths.Identifier.Mk.source_location_int (source_id, name) + in + LocHashtbl.add loc_to_id loc identifier; IdentHashtbl.add local_ident_to_loc id loc | _ -> ()) poses @@ -256,44 +252,38 @@ let anchor_of_identifier id = (* Adds the global definitions, found in the [uid_to_loc], to the [loc_to_id] and [uid_to_id] tables. *) let populate_global_defs env source_id loc_to_id uid_to_loc uid_to_id = - match source_id with - | None -> () - | Some source_id -> - let mk_src_id id = - let name = - Odoc_model.Names.DefName.make_std (anchor_of_identifier id) - in - (Odoc_model.Paths.Identifier.Mk.source_location (source_id, name) - :> Odoc_model.Paths.Identifier.SourceLocation.t) - in - let () = - Ident_env.iter_located_identifier env @@ fun loc id -> - LocHashtbl.add loc_to_id loc (mk_src_id id) - in - let mk_src_id () = - let name = - Odoc_model.Names.DefName.make_std - (Printf.sprintf "def_%d" (counter ())) - in - (Odoc_model.Paths.Identifier.Mk.source_location (source_id, name) - :> Odoc_model.Paths.Identifier.SourceLocation.t) - in - Shape.Uid.Tbl.iter - (fun uid loc -> - if loc.Location.loc_ghost then () - else - match LocHashtbl.find_opt loc_to_id loc with - | Some id -> UidHashtbl.add uid_to_id uid id - | None -> ( - (* In case there is no entry for the location of the uid, we add one. *) - match uid with - | Item _ -> - let id = mk_src_id () in - LocHashtbl.add loc_to_id loc id; - UidHashtbl.add uid_to_id uid id - | Compilation_unit _ -> () - | _ -> ())) - uid_to_loc + let mk_src_id id = + let name = Odoc_model.Names.DefName.make_std (anchor_of_identifier id) in + (Odoc_model.Paths.Identifier.Mk.source_location (source_id, name) + :> Odoc_model.Paths.Identifier.SourceLocation.t) + in + let () = + Ident_env.iter_located_identifier env @@ fun loc id -> + LocHashtbl.add loc_to_id loc (mk_src_id id) + in + let mk_src_id () = + let name = + Odoc_model.Names.DefName.make_std (Printf.sprintf "def_%d" (counter ())) + in + (Odoc_model.Paths.Identifier.Mk.source_location (source_id, name) + :> Odoc_model.Paths.Identifier.SourceLocation.t) + in + Shape.Uid.Tbl.iter + (fun uid loc -> + if loc.Location.loc_ghost then () + else + match LocHashtbl.find_opt loc_to_id loc with + | Some id -> UidHashtbl.add uid_to_id uid id + | None -> ( + (* In case there is no entry for the location of the uid, we add one. *) + match uid with + | Item _ -> + let id = mk_src_id () in + LocHashtbl.add loc_to_id loc id; + UidHashtbl.add uid_to_id uid id + | Compilation_unit _ -> () + | _ -> ())) + uid_to_loc (* Extract [Typedtree_traverse] occurrence information and turn them into proper source infos *) @@ -377,10 +367,16 @@ let read_cmt_infos source_id_opt id cmt_info ~count_occurrences = and local_ident_to_loc = IdentHashtbl.create 10 and uid_to_id = UidHashtbl.create 10 in let () = - (* populate [loc_to_id], [ident_to_id] and [uid_to_id] *) - populate_local_defs source_id traverse_infos loc_to_id - local_ident_to_loc; - populate_global_defs env source_id loc_to_id uid_to_loc uid_to_id + match source_id with + | None -> () + (* populate [loc_to_id], [ident_to_id] and [uid_to_id] only when + rendering source code, as these are only used to compute source + locations id *) + | Some source_id -> + populate_local_defs source_id traverse_infos loc_to_id + local_ident_to_loc; + populate_global_defs env source_id loc_to_id uid_to_loc + uid_to_id in let source_infos = process_occurrences env traverse_infos loc_to_id local_ident_to_loc From 7a7c4a62267826118e1b1cad4ae794eb38e6c4df Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Thu, 7 Dec 2023 17:40:30 +0100 Subject: [PATCH 26/41] Occurrences: Review comments - Remove now unused is_internal_rec. It was added for non-persistent values, but this has been delayed to another PR - Remove TODO comment on Classes when building the environment: classes cannot contain items that are contained in our current set of occurrence kinds (values, modules, module types, ...) Signed-off-by: Paul-Elliot --- src/model/paths.ml | 32 +------------------------------- src/xref2/link.ml | 2 +- 2 files changed, 2 insertions(+), 32 deletions(-) diff --git a/src/model/paths.ml b/src/model/paths.ml index 586f8123a4..497bcf0f98 100644 --- a/src/model/paths.ml +++ b/src/model/paths.ml @@ -91,36 +91,6 @@ module Identifier = struct | `SourceLocationInternal _ | `AssetFile _ -> false - let rec is_internal_rec : t -> bool = - fun x -> - is_internal x - || - match x.iv with - | `Root (_, name) -> ModuleName.is_internal name - | `Page (_, _) -> false - | `LeafPage (_, _) -> false - | `Module (parent, _) -> is_internal_rec (parent :> t) - | `Parameter (parent, _) -> is_internal_rec (parent :> t) - | `Result x -> is_internal_rec (x :> t) - | `ModuleType (parent, _) -> is_internal_rec (parent :> t) - | `Type (parent, _) -> is_internal_rec (parent :> t) - | `CoreType name -> TypeName.is_internal name - | `Constructor (parent, _) -> is_internal (parent :> t) - | `Field (parent, _) -> is_internal (parent :> t) - | `Extension (parent, _) -> is_internal (parent :> t) - | `ExtensionDecl (parent, _, _) -> is_internal (parent :> t) - | `Exception (parent, _) -> is_internal (parent :> t) - | `CoreException _ -> false - | `Value (parent, _) -> is_internal_rec (parent :> t) - | `Class (parent, _) -> is_internal_rec (parent :> t) - | `ClassType (parent, _) -> is_internal_rec (parent :> t) - | `Method (parent, _) -> is_internal (parent :> t) - | `InstanceVariable (parent, _) -> is_internal (parent :> t) - | `Label (parent, _) -> is_internal (parent :> t) - | `SourceDir _ | `SourceLocationMod _ | `SourceLocation _ | `SourcePage _ - | `SourceLocationInternal _ | `AssetFile _ -> - false - let name : [< t_pv ] id -> string = fun n -> name_aux (n :> t) let rec full_name_aux : t -> string list = @@ -701,7 +671,7 @@ module Path = struct | `Identifier { iv = `Module (_, m); _ } when Names.ModuleName.is_internal m -> true - | `Identifier i -> Identifier.is_internal_rec i + | `Identifier _ -> false | `Canonical (_, `Resolved _) -> false | `Canonical (x, _) -> (not weak_canonical_test) && inner (x : module_ :> any) diff --git a/src/xref2/link.ml b/src/xref2/link.ml index ada50ad8df..ad6188ac0e 100644 --- a/src/xref2/link.ml +++ b/src/xref2/link.ml @@ -481,7 +481,7 @@ module Build_env = struct | Comment _ -> env | TypExt _ -> env | Exception _ -> env - | Class _ -> env (* TODO *) + | Class _ -> env | ClassType _ -> env | Include i -> include_ env i | Open _ -> env) From 60281abb9b68c87b684ca20dcf13a1c3a1c82b45 Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Fri, 8 Dec 2023 09:14:17 +0100 Subject: [PATCH 27/41] Occurrences: Constrain output file name Similar to source trees: must have `odoc` extension and `occurrences-` prefix Signed-off-by: Paul-Elliot --- doc/driver.mld | 2 +- src/odoc/bin/main.ml | 16 ++++++- src/odoc/occurrences.ml | 60 +++++++++++++------------ test/occurrences/double_wrapped.t/run.t | 51 ++++++++++++--------- 4 files changed, 76 insertions(+), 53 deletions(-) diff --git a/doc/driver.mld b/doc/driver.mld index e56839fb10..106123159a 100644 --- a/doc/driver.mld +++ b/doc/driver.mld @@ -760,7 +760,7 @@ let compiled = compile_all () in let linked = link_all compiled in let () = index_generate () in let _ = js_index () in -let _ = count_occurrences (Fpath.v "occurrences.txt") in +let _ = count_occurrences (Fpath.v "occurrences-odoc_and_deps.odoc") in generate_all linked ]} diff --git a/src/odoc/bin/main.ml b/src/odoc/bin/main.ml index 5f51365420..f2e3ffe13c 100644 --- a/src/odoc/bin/main.ml +++ b/src/odoc/bin/main.ml @@ -1111,9 +1111,21 @@ module Targets = struct end module Occurrences = struct + let has_occurrences_prefix input = + input |> Fs.File.basename |> Fs.File.to_string + |> Astring.String.is_prefix ~affix:"occurrences-" + + let dst_of_string s = + let f = Fs.File.of_string s in + if not (Fs.File.has_ext ".odoc" f) then + Error (`Msg "Output file must have '.odoc' extension.") + else if not (has_occurrences_prefix f) then + Error (`Msg "Output file must be prefixed with 'occurrences-'.") + else Ok f + open Or_error module Count = struct let count directories dst warnings_options include_hidden = - let dst = Fpath.v dst in + dst_of_string dst >>= fun dst -> Occurrences.count ~dst ~warnings_options directories include_hidden let cmd = @@ -1150,7 +1162,7 @@ module Occurrences = struct "At least one of --file-list or a path to a file must be passed \ to odoc aggregate-occurrences") | _ -> - let dst = Fpath.v dst in + dst_of_string dst >>= fun dst -> Occurrences.aggregate ~dst ~warnings_options files file_list let cmd = diff --git a/src/odoc/occurrences.ml b/src/odoc/occurrences.ml index 9922257112..9f28d0fbd3 100644 --- a/src/odoc/occurrences.ml +++ b/src/odoc/occurrences.ml @@ -172,32 +172,34 @@ let parse_input_files input = >>= fun files -> Ok (List.concat files) let aggregate files file_list ~warnings_options:_ ~dst = - parse_input_files file_list >>= fun new_files -> - let files = files @ new_files in - let from_file file : Occtbl.t = - let ic = open_in_bin (Fs.File.to_string file) in - Marshal.from_channel ic - in - let rec loop n f = - if n > 0 then ( - f (); - loop (n - 1) f) - else () - in - let occtbl = - match files with - | [] -> H.create 0 - | file1 :: files -> - let acc = from_file file1 in - List.iter - (fun file -> - Occtbl.iter - (fun id { direct; _ } -> - loop direct (fun () -> Occtbl.add acc id)) - (from_file file)) - files; - acc - in - let oc = open_out_bin (Fs.File.to_string dst) in - Marshal.to_channel oc occtbl []; - Ok () + try + parse_input_files file_list >>= fun new_files -> + let files = files @ new_files in + let from_file file : Occtbl.t = + let ic = open_in_bin (Fs.File.to_string file) in + Marshal.from_channel ic + in + let rec loop n f = + if n > 0 then ( + f (); + loop (n - 1) f) + else () + in + let occtbl = + match files with + | [] -> H.create 0 + | file1 :: files -> + let acc = from_file file1 in + List.iter + (fun file -> + Occtbl.iter + (fun id { direct; _ } -> + loop direct (fun () -> Occtbl.add acc id)) + (from_file file)) + files; + acc + in + let oc = open_out_bin (Fs.File.to_string dst) in + Marshal.to_channel oc occtbl []; + Ok () + with Sys_error s -> Error (`Msg s) diff --git a/test/occurrences/double_wrapped.t/run.t b/test/occurrences/double_wrapped.t/run.t index 5361b9d035..756ffba5a1 100644 --- a/test/occurrences/double_wrapped.t/run.t +++ b/test/occurrences/double_wrapped.t/run.t @@ -41,11 +41,11 @@ and a hashtable for each compilation unit. $ mv main__A.odocl main__A $ mv main__B.odocl main__B $ mv main__C.odocl main__C - $ odoc count-occurrences -I main -o main.occ - $ odoc count-occurrences -I main__ -o main__.occ - $ odoc count-occurrences -I main__A -o main__A.occ - $ odoc count-occurrences -I main__B -o main__B.occ - $ odoc count-occurrences -I main__C -o main__C.occ + $ odoc count-occurrences -I main -o occurrences-main.odoc + $ odoc count-occurrences -I main__ -o occurrences-main__.odoc + $ odoc count-occurrences -I main__A -o occurrences-main__A.odoc + $ odoc count-occurrences -I main__B -o occurrences-main__B.odoc + $ odoc count-occurrences -I main__C -o occurrences-main__C.odoc The occurrences_print executable, available only for testing, unmarshal the file and prints the number of occurrences in a readable format. @@ -56,18 +56,18 @@ Uses of C are not counted, since the canonical destination (Main.C, generated by Uses of B.Z are not counted since they go to a hidden module. Uses of values Y.x and Z.y (in b.ml) are not counted since they come from a "local" module. - $ occurrences_print main.occ | sort + $ occurrences_print occurrences-main.odoc | sort Main was used directly 0 times and indirectly 2 times Main.A was used directly 1 times and indirectly 0 times Main.B was used directly 1 times and indirectly 0 times - $ occurrences_print main__.occ | sort + $ occurrences_print occurrences-main__.odoc | sort A only uses "persistent" values: one it defines itself. - $ occurrences_print main__A.occ | sort + $ occurrences_print occurrences-main__A.odoc | sort "Aliased" values are not counted since they become persistent - $ occurrences_print main__B.occ | sort + $ occurrences_print occurrences-main__B.odoc | sort Main was used directly 0 times and indirectly 7 times Main.A was used directly 2 times and indirectly 5 times Main.A.(||>) was used directly 1 times and indirectly 0 times @@ -76,7 +76,7 @@ A only uses "persistent" values: one it defines itself. Main.A.x was used directly 1 times and indirectly 0 times "Aliased" values are not counted since they become persistent - $ occurrences_print main__C.occ | sort + $ occurrences_print occurrences-main__C.odoc | sort Main was used directly 0 times and indirectly 2 times Main.A was used directly 1 times and indirectly 1 times Main.A.x was used directly 1 times and indirectly 0 times @@ -84,13 +84,13 @@ A only uses "persistent" values: one it defines itself. Now we can merge all tables $ cat > files.map << EOF - > main__A.occ - > main__B.occ - > main__C.occ + > occurrences-main__A.odoc + > occurrences-main__B.odoc + > occurrences-main__C.odoc > EOF - $ odoc aggregate-occurrences main.occ main__.occ --file-list files.map -o aggregated.txt + $ odoc aggregate-occurrences occurrences-main.odoc occurrences-main__.odoc --file-list files.map -o occurrences-aggregated.odoc - $ occurrences_print aggregated.txt | sort > all_merged + $ occurrences_print occurrences-aggregated.odoc | sort > all_merged $ cat all_merged Main was used directly 0 times and indirectly 11 times Main.A was used directly 4 times and indirectly 6 times @@ -102,17 +102,26 @@ Now we can merge all tables Compare with the one created directly with all occurrences: - $ odoc count-occurrences -I . -o occurrences.txt - $ occurrences_print occurrences.txt | sort > directly_all + $ odoc count-occurrences -I . -o occurrences-all.odoc + $ occurrences_print occurrences-all.odoc | sort > directly_all $ diff all_merged directly_all We can also include hidden ids: - $ odoc count-occurrences -I main__A -o occurrences.txt --include-hidden - $ occurrences_print occurrences.txt | sort + $ odoc count-occurrences -I main__B -o occurrences-b.odoc --include-hidden + $ occurrences_print occurrences-b.odoc | sort + Main was used directly 0 times and indirectly 7 times + Main.A was used directly 2 times and indirectly 5 times + Main.A.(||>) was used directly 1 times and indirectly 0 times + Main.A.M was used directly 2 times and indirectly 0 times + Main.A.t was used directly 1 times and indirectly 0 times + Main.A.x was used directly 1 times and indirectly 0 times + Main__ was used directly 0 times and indirectly 2 times + Main__.C was used directly 1 times and indirectly 1 times + Main__.C.y was used directly 1 times and indirectly 0 times - $ odoc count-occurrences -I . -o occurrences.txt --include-hidden - $ occurrences_print occurrences.txt | sort + $ odoc count-occurrences -I . -o occurrences-all.odoc --include-hidden + $ occurrences_print occurrences-all.odoc | sort Main was used directly 0 times and indirectly 11 times Main.A was used directly 4 times and indirectly 6 times Main.A.(||>) was used directly 1 times and indirectly 0 times From d8809850fddda59b21bafbdc4e5c62e270732af8 Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Mon, 11 Dec 2023 10:39:41 +0100 Subject: [PATCH 28/41] Consider warnings in occurrence resolving as normal warnings They used to not be raised, as with non-persistent occurrences, some of them could never be got rid of! Signed-off-by: Paul-Elliot --- src/xref2/link.ml | 171 +++++++--------------------------------------- 1 file changed, 25 insertions(+), 146 deletions(-) diff --git a/src/xref2/link.ml b/src/xref2/link.ml index ad6188ac0e..a288e4d0b7 100644 --- a/src/xref2/link.ml +++ b/src/xref2/link.ml @@ -135,9 +135,8 @@ and should_resolve : Paths.Path.t -> bool = (* | `Resolved p -> should_reresolve (p :> Paths.Path.Resolved.t) *) (* | _ -> true *) -let type_path : - ?report_errors:bool -> Env.t -> Paths.Path.Type.t -> Paths.Path.Type.t = - fun ?(report_errors = true) env p -> +let type_path : Env.t -> Paths.Path.Type.t -> Paths.Path.Type.t = + fun env p -> if not (should_resolve (p :> Paths.Path.t)) then p else let cp = Component.Of_Lang.(type_path (empty ()) p) in @@ -151,13 +150,11 @@ let type_path : let result = Tools.reresolve_type env p' in `Resolved Lang_of.(Path.resolved_type (empty ()) result) | Error e -> - if report_errors then - Errors.report ~what:(`Type_path cp) ~tools_error:e `Lookup; + Errors.report ~what:(`Type_path cp) ~tools_error:e `Lookup; p) -let value_path : - ?report_errors:bool -> Env.t -> Paths.Path.Value.t -> Paths.Path.Value.t = - fun ?(report_errors = true) env p -> +let value_path : Env.t -> Paths.Path.Value.t -> Paths.Path.Value.t = + fun env p -> if not (should_resolve (p :> Paths.Path.t)) then p else let cp = Component.Of_Lang.(value_path (empty ()) p) in @@ -171,16 +168,12 @@ let value_path : let result = Tools.reresolve_value env p' in `Resolved Lang_of.(Path.resolved_value (empty ()) result) | Error e -> - if report_errors then - Errors.report ~what:(`Value_path cp) ~tools_error:e `Lookup; + Errors.report ~what:(`Value_path cp) ~tools_error:e `Lookup; p) let constructor_path : - ?report_errors:bool -> - Env.t -> - Paths.Path.Constructor.t -> - Paths.Path.Constructor.t = - fun ?(report_errors = true) env p -> + Env.t -> Paths.Path.Constructor.t -> Paths.Path.Constructor.t = + fun env p -> (* if not (should_resolve (p : Paths.Path.Constructor.t :> Paths.Path.t)) then p *) (* else *) if not (should_resolve_constructor p) then p @@ -196,16 +189,12 @@ let constructor_path : let result = Tools.reresolve_constructor env p' in `Resolved Lang_of.(Path.resolved_constructor (empty ()) result) | Error e -> - if report_errors then - Errors.report ~what:(`Constructor_path cp) ~tools_error:e `Lookup; + Errors.report ~what:(`Constructor_path cp) ~tools_error:e `Lookup; p) -let class_type_path : - ?report_errors:bool -> - Env.t -> - Paths.Path.ClassType.t -> - Paths.Path.ClassType.t = - fun ?(report_errors = true) env p -> +let class_type_path : Env.t -> Paths.Path.ClassType.t -> Paths.Path.ClassType.t + = + fun env p -> if not (should_resolve (p :> Paths.Path.t)) then p else let cp = Component.Of_Lang.(class_type_path (empty ()) p) in @@ -219,16 +208,12 @@ let class_type_path : let result = Tools.reresolve_class_type env p' in `Resolved Lang_of.(Path.resolved_class_type (empty ()) result) | Error e -> - if report_errors then - Errors.report ~what:(`Class_type_path cp) ~tools_error:e `Lookup; + Errors.report ~what:(`Class_type_path cp) ~tools_error:e `Lookup; p) and module_type_path : - ?report_errors:bool -> - Env.t -> - Paths.Path.ModuleType.t -> - Paths.Path.ModuleType.t = - fun ?(report_errors = true) env p -> + Env.t -> Paths.Path.ModuleType.t -> Paths.Path.ModuleType.t = + fun env p -> if not (should_resolve (p :> Paths.Path.t)) then p else let cp = Component.Of_Lang.(module_type_path (empty ()) p) in @@ -242,13 +227,11 @@ and module_type_path : let result = Tools.reresolve_module_type env p' in `Resolved Lang_of.(Path.resolved_module_type (empty ()) result) | Error e -> - if report_errors then - Errors.report ~what:(`Module_type_path cp) ~tools_error:e `Resolve; + Errors.report ~what:(`Module_type_path cp) ~tools_error:e `Resolve; p) -and module_path : - ?report_errors:bool -> Env.t -> Paths.Path.Module.t -> Paths.Path.Module.t = - fun ?(report_errors = true) env p -> +and module_path : Env.t -> Paths.Path.Module.t -> Paths.Path.Module.t = + fun env p -> if not (should_resolve (p :> Paths.Path.t)) then p else let cp = Component.Of_Lang.(module_path (empty ()) p) in @@ -263,8 +246,7 @@ and module_path : `Resolved Lang_of.(Path.resolved_module (empty ()) result) | Error _ when is_forward p -> p | Error e -> - if report_errors then - Errors.report ~what:(`Module_path cp) ~tools_error:e `Resolve; + Errors.report ~what:(`Module_path cp) ~tools_error:e `Resolve; p) let rec comment_inline_element : @@ -415,106 +397,6 @@ and open_ env parent = function | { Odoc_model__Lang.Open.doc; _ } as open_ -> { open_ with doc = comment_docs env parent doc } -module Build_env = struct - let rec unit env t = - let open Compilation_unit in - match t.content with - | Module sg -> - let env = signature env sg in - env - | Pack _ -> env - - and signature env s = - let env = Env.open_signature s env in - signature_items env s.items - - and simple_expansion : Env.t -> ModuleType.simple_expansion -> Env.t = - fun env m -> - match m with - | Signature sg -> signature env sg - | Functor (arg, sg) -> - let env = Env.add_functor_parameter arg env in - let env = functor_argument env arg in - simple_expansion env sg - - and functor_argument env a = - match a with - | FunctorParameter.Unit -> env - | Named arg -> functor_parameter_parameter env arg - - and functor_parameter_parameter : Env.t -> FunctorParameter.parameter -> Env.t - = - fun env a -> module_type_expr env a.expr - - and module_type_expr : Env.t -> ModuleType.expr -> Env.t = - fun env expr -> - let open ModuleType in - match expr with - | Signature s -> signature env s - | Path { p_path = _; p_expansion = Some p_expansion } -> - simple_expansion env p_expansion - | Path { p_path = _; p_expansion = None } -> env - | With _ -> env - | Functor (arg, res) -> - let env = functor_argument env arg in - let env = Env.add_functor_parameter arg env in - let env = module_type_expr env res in - env - | TypeOf { t_expansion = None; _ } -> env - | TypeOf { t_expansion = Some exp; _ } -> simple_expansion env exp - - and signature_items : Env.t -> Signature.item list -> Env.t = - fun env s -> - let open Signature in - List.fold_left - (fun env item -> - match item with - | Module (_, m) -> module_ env m - | ModuleSubstitution m -> Env.open_module_substitution m env - | Type _ -> env - | TypeSubstitution t -> Env.open_type_substitution t env - | ModuleType mt -> module_type env mt - | ModuleTypeSubstitution mts -> - let env = Env.open_module_type_substitution mts env in - module_type_substitution env mts - | Value _ -> env - | Comment _ -> env - | TypExt _ -> env - | Exception _ -> env - | Class _ -> env - | ClassType _ -> env - | Include i -> include_ env i - | Open _ -> env) - env s - - and module_type_substitution : Env.t -> ModuleTypeSubstitution.t -> Env.t = - fun env m -> module_type_expr env m.manifest - - and include_ : Env.t -> Include.t -> Env.t = - fun env i -> - let open Include in - signature_items env i.expansion.content.items - - and module_type : Env.t -> ModuleType.t -> Env.t = - fun env m -> - match m.expr with None -> env | Some expr -> module_type_expr env expr - - and module_ : Env.t -> Module.t -> Env.t = - fun env m -> - let open Module in - let env = module_decl env m.type_ in - match m.type_ with - | Alias (`Resolved _, Some exp) -> simple_expansion env exp - | Alias _ | ModuleType _ -> env - - and module_decl : Env.t -> Module.decl -> Env.t = - fun env decl -> - let open Module in - match decl with - | ModuleType expr -> module_type_expr env expr - | Alias (_, None) -> env - | Alias (_, Some e) -> simple_expansion env e -end let rec unit env t = let open Compilation_unit in let content = @@ -527,7 +409,6 @@ let rec unit env t = | Pack _ as p -> p in let source_info = - let env = Build_env.unit env t in let open Source_info in match t.source_info with | Some inf -> @@ -554,32 +435,30 @@ let rec unit env t = Value (jump_to v (Shape_tools.lookup_value_path env) - (value_path ~report_errors:false env)) + (value_path env)) | Module v -> Module (jump_to v (Shape_tools.lookup_module_path env) - (module_path ~report_errors:false env)) + (module_path env)) | ModuleType v -> ModuleType (jump_to v (Shape_tools.lookup_module_type_path env) - (module_type_path ~report_errors:false env)) + (module_type_path env)) | Type v -> Type (jump_to v (Shape_tools.lookup_type_path env) - (type_path ~report_errors:false env)) + (type_path env)) | Constructor v -> Constructor - (jump_to v - (fun _ -> None) - (constructor_path ~report_errors:false env)) + (jump_to v (fun _ -> None) (constructor_path env)) | ClassType v -> ClassType (jump_to v (Shape_tools.lookup_class_type_path env) - (class_type_path ~report_errors:false env)) + (class_type_path env)) | i -> i in (info, pos)) From 0a83ebc1772fe42e1330410659571a47dcdf2e43 Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Mon, 11 Dec 2023 10:51:28 +0100 Subject: [PATCH 29/41] Do no link twice the occurrences Signed-off-by: Paul-Elliot --- src/xref2/link.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/xref2/link.ml b/src/xref2/link.ml index a288e4d0b7..7d5fe5ea63 100644 --- a/src/xref2/link.ml +++ b/src/xref2/link.ml @@ -400,7 +400,7 @@ and open_ env parent = function let rec unit env t = let open Compilation_unit in let content = - if t.Lang.Compilation_unit.linked || t.hidden then t.content + if t.hidden then t.content else match t.content with | Module sg -> @@ -1145,7 +1145,8 @@ and type_expression : Env.t -> Id.Signature.t -> _ -> _ = | Package p -> Package (type_expression_package env parent visited p) let link ~filename x y = - Lookup_failures.catch_failures ~filename (fun () -> unit x y) + Lookup_failures.catch_failures ~filename (fun () -> + if y.Lang.Compilation_unit.linked then y else unit x y) let page env page = let () = From 15382c165eda006af5e839da4c112b6639c091a0 Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Tue, 12 Dec 2023 09:14:29 +0100 Subject: [PATCH 30/41] Revert "Adding support for resolving constructor and datatype" This reverts commit 9eee68437c846c271a36bde3ea5f262d9df4ded2. --- src/xref2/compile.ml | 29 ++--- src/xref2/errors.ml | 39 ------ src/xref2/find.ml | 29 +---- src/xref2/find.mli | 6 - src/xref2/link.ml | 30 ----- src/xref2/tools.ml | 285 ------------------------------------------- src/xref2/tools.mli | 8 -- 7 files changed, 14 insertions(+), 412 deletions(-) diff --git a/src/xref2/compile.ml b/src/xref2/compile.ml index 28322c34b1..6e57e442ac 100644 --- a/src/xref2/compile.ml +++ b/src/xref2/compile.ml @@ -21,26 +21,15 @@ let type_path : Env.t -> Paths.Path.Type.t -> Paths.Path.Type.t = | Ok p' -> `Resolved Lang_of.(Path.resolved_type (empty ()) p') | Error _ -> p) -(* and value_path : Env.t -> Paths.Path.Value.t -> Paths.Path.Value.t = *) -(* fun env p -> *) -(* match p with *) -(* | `Resolved _ -> p *) -(* | _ -> ( *) -(* let cp = Component.Of_Lang.(value_path (empty ()) p) in *) -(* match Tools.resolve_value_path env cp with *) -(* | Ok p' -> `Resolved Lang_of.(Path.resolved_value (empty ()) p') *) -(* | Error _ -> p) *) - -(* and constructor_path : *) -(* Env.t -> Paths.Path.Constructor.t -> Paths.Path.Constructor.t = *) -(* fun env p -> *) -(* match p with *) -(* | `Resolved _ -> p *) -(* | _ -> ( *) -(* let cp = Component.Of_Lang.(constructor_path (empty ()) p) in *) -(* match Tools.resolve_constructor_path env cp with *) -(* | Ok p' -> `Resolved Lang_of.(Path.resolved_constructor (empty ()) p') *) -(* | Error _ -> p) *) +and value_path : Env.t -> Paths.Path.Value.t -> Paths.Path.Value.t = + fun env p -> + match p with + | `Resolved _ -> p + | _ -> ( + let cp = Component.Of_Lang.(value_path (empty ()) p) in + match Tools.resolve_value_path env cp with + | Ok p' -> `Resolved Lang_of.(Path.resolved_value (empty ()) p') + | Error _ -> p) and module_type_path : Env.t -> Paths.Path.ModuleType.t -> Paths.Path.ModuleType.t = diff --git a/src/xref2/errors.ml b/src/xref2/errors.ml index 56b953d785..f5044308be 100644 --- a/src/xref2/errors.ml +++ b/src/xref2/errors.ml @@ -72,17 +72,6 @@ module Tools_error = struct (* Could not find the module in the environment *) | `Parent of parent_lookup_error ] - and simple_datatype_lookup_error = - [ `LocalDataType of - Env.t * Ident.path_datatype - (* Internal error: Found local path during lookup *) - | `Find_failure - (* Internal error: the type was not found in the parent signature *) - | `Lookup_failureT of - Identifier.Path.Type.t - (* Could not find the module in the environment *) - | `Parent of parent_lookup_error ] - and simple_value_lookup_error = [ `LocalValue of Env.t * Ident.path_value @@ -94,17 +83,6 @@ module Tools_error = struct (* Could not find the module in the environment *) | `Parent of parent_lookup_error ] - and simple_constructor_lookup_error = - [ `LocalConstructor of - Env.t * Ident.constructor - (* Internal error: Found local path during lookup *) - | `Find_failure - (* Internal error: the type was not found in the parent signature *) - | `Lookup_failureC of - Identifier.Path.Constructor.t - (* Could not find the module in the environment *) - | `ParentC of simple_datatype_lookup_error ] - and parent_lookup_error = [ `Parent_sig of expansion_of_module_error @@ -132,8 +110,6 @@ module Tools_error = struct type any = [ simple_type_lookup_error | simple_value_lookup_error - | simple_constructor_lookup_error - | simple_datatype_lookup_error | simple_module_type_lookup_error | simple_module_type_expr_of_module_error | simple_module_lookup_error @@ -171,10 +147,6 @@ module Tools_error = struct | `LocalMT (_, id) -> Format.fprintf fmt "Local id found: %a" Ident.fmt id | `Local (_, id) -> Format.fprintf fmt "Local id found: %a" Ident.fmt id | `LocalType (_, id) -> Format.fprintf fmt "Local id found: %a" Ident.fmt id - | `LocalDataType (_, id) -> - Format.fprintf fmt "Local id found: %a" Ident.fmt id - | `LocalConstructor (_, id) -> - Format.fprintf fmt "Local id found: %a" Ident.fmt id | `LocalValue (_, id) -> Format.fprintf fmt "Local id found: %a" Ident.fmt id | `Find_failure -> Format.fprintf fmt "Find failure" @@ -196,14 +168,9 @@ module Tools_error = struct Format.fprintf fmt "Lookup failure (value): %a" Component.Fmt.model_identifier (m :> Odoc_model.Paths.Identifier.t) - | `Lookup_failureC m -> - Format.fprintf fmt "Lookup failure (constructor): %a" - Component.Fmt.model_identifier - (m :> Odoc_model.Paths.Identifier.t) | `ApplyNotFunctor -> Format.fprintf fmt "Apply module is not a functor" | `Class_replaced -> Format.fprintf fmt "Class replaced" | `Parent p -> pp fmt (p :> any) - | `ParentC p -> pp fmt (p :> any) | `UnexpandedTypeOf t -> Format.fprintf fmt "Unexpanded `module type of` expression: %a" Component.Fmt.module_type_type_of_desc t @@ -239,9 +206,7 @@ let is_unexpanded_module_type_of = | `Find_failure -> false | `Lookup_failure _ -> false | `Lookup_failure_root _ -> false - | `Lookup_failureC _ -> false | `Parent p -> inner (p :> any) - | `ParentC p -> inner (p :> any) | `Parent_sig p -> inner (p :> any) | `Parent_module_type p -> inner (p :> any) | `Parent_expr p -> inner (p :> any) @@ -259,8 +224,6 @@ let is_unexpanded_module_type_of = | `Lookup_failureT _ -> false | `Lookup_failureV _ -> false | `LocalType _ -> false - | `LocalDataType _ -> false - | `LocalConstructor _ -> false | `LocalValue _ -> false | `Class_replaced -> false | `OpaqueClass -> false @@ -335,7 +298,6 @@ type what = | `Module of Identifier.Module.t | `Module_type of Identifier.Signature.t | `Module_path of Cpath.module_ - | `Constructor_path of Cpath.constructor | `Module_type_path of Cpath.module_type | `Module_type_U of Component.ModuleType.U.expr | `Include of Component.Include.decl @@ -388,7 +350,6 @@ let report ~(what : what) ?tools_error action = | `Type cfrag -> r "type" type_fragment cfrag | `Type_path path -> r "type" type_path path | `Value_path path -> r "value" value_path path - | `Constructor_path path -> r "constructor" constructor_path path | `Class_type_path path -> r "class_type" class_type_path path | `With_module frag -> r "module substitution" module_fragment frag | `With_module_type frag -> diff --git a/src/xref2/find.ml b/src/xref2/find.ml index ba5ec4108e..7b30edbea0 100644 --- a/src/xref2/find.ml +++ b/src/xref2/find.ml @@ -111,12 +111,6 @@ let type_in_sig sg name = Some (`FClassType (N.class_type' id, c)) | _ -> None) -let datatype_in_sig sg name = - find_in_sig sg (function - | Signature.Type (id, _, m) when N.type_ id = name -> - Some (`FType (N.type' id, Delayed.get m)) - | _ -> None) - type removed_type = [ `FType_removed of TypeName.t * TypeExpr.t * TypeDecl.Equation.t ] @@ -127,8 +121,6 @@ type careful_module_type = type careful_type = [ type_ | removed_type ] -type careful_datatype = [ datatype | removed_type ] - type careful_class = [ class_ | removed_type ] let careful_module_in_sig sg name = @@ -164,10 +156,11 @@ let careful_type_in_sig sg name = | Some _ as x -> x | None -> removed_type_in_sig sg name -let careful_datatype_in_sig sg name = - match datatype_in_sig sg name with - | Some _ as x -> x - | None -> removed_type_in_sig sg name +let datatype_in_sig sg name = + find_in_sig sg (function + | Signature.Type (id, _, t) when N.type_ id = name -> + Some (`FType (N.type' id, Component.Delayed.get t)) + | _ -> None) let class_in_sig sg name = filter_in_sig sg (function @@ -184,18 +177,6 @@ let careful_class_in_sig sg name = | Some _ as x -> x | None -> removed_type_in_sig sg name -let constructor_in_type (typ : TypeDecl.t) name = - let rec find_cons = function - | ({ TypeDecl.Constructor.name = name'; _ } as cons) :: _ when name' = name - -> - Some (`FConstructor cons) - | _ :: tl -> find_cons tl - | [] -> None - in - match typ.representation with - | Some (Variant cons) -> find_cons cons - | Some (Record _) | Some Extensible | None -> None - let any_in_type (typ : TypeDecl.t) name = let rec find_cons = function | ({ TypeDecl.Constructor.name = name'; _ } as cons) :: _ when name' = name diff --git a/src/xref2/find.mli b/src/xref2/find.mli index 5809dab339..c515ed4fe3 100644 --- a/src/xref2/find.mli +++ b/src/xref2/find.mli @@ -71,8 +71,6 @@ val extension_in_sig : Signature.t -> string -> extension option val any_in_type : TypeDecl.t -> string -> any_in_type option -val constructor_in_type : TypeDecl.t -> string -> constructor option - val any_in_typext : Extension.t -> string -> extension option val method_in_class_signature : ClassSignature.t -> string -> method_ option @@ -116,8 +114,6 @@ type careful_module_type = type careful_type = [ type_ | removed_type ] -type careful_datatype = [ datatype | removed_type ] - type careful_class = [ class_ | removed_type ] val careful_module_in_sig : Signature.t -> string -> careful_module option @@ -127,6 +123,4 @@ val careful_module_type_in_sig : val careful_type_in_sig : Signature.t -> string -> careful_type option -val careful_datatype_in_sig : Signature.t -> string -> careful_datatype option - val careful_class_in_sig : Signature.t -> string -> careful_class option diff --git a/src/xref2/link.ml b/src/xref2/link.ml index 7d5fe5ea63..ecdb29946e 100644 --- a/src/xref2/link.ml +++ b/src/xref2/link.ml @@ -106,8 +106,6 @@ let rec should_reresolve : Paths.Path.Resolved.t -> bool = should_reresolve (x :> t) || should_resolve (y :> Paths.Path.t) | `CanonicalType (x, y) -> should_reresolve (x :> t) || should_resolve (y :> Paths.Path.t) - | `CanonicalDataType (x, y) -> - should_reresolve (x :> t) || should_resolve (y :> Paths.Path.t) | `Apply (x, y) -> should_reresolve (x :> t) || should_reresolve (y :> Paths.Path.Resolved.t) | `SubstT (x, y) -> should_reresolve (x :> t) || should_reresolve (y :> t) @@ -122,19 +120,12 @@ let rec should_reresolve : Paths.Path.Resolved.t -> bool = | `ModuleType (p, _) | `Module (p, _) -> should_reresolve (p :> t) - | `Constructor (p, _) -> should_reresolve (p :> t) | `OpaqueModule m -> should_reresolve (m :> t) | `OpaqueModuleType m -> should_reresolve (m :> t) and should_resolve : Paths.Path.t -> bool = fun p -> match p with `Resolved p -> should_reresolve p | _ -> true -(* and should_resolve_constructor : Paths.Path.Constructor.t -> bool = *) -(* fun p -> *) -(* match p with *) -(* | `Resolved p -> should_reresolve (p :> Paths.Path.Resolved.t) *) -(* | _ -> true *) - let type_path : Env.t -> Paths.Path.Type.t -> Paths.Path.Type.t = fun env p -> if not (should_resolve (p :> Paths.Path.t)) then p @@ -171,27 +162,6 @@ let value_path : Env.t -> Paths.Path.Value.t -> Paths.Path.Value.t = Errors.report ~what:(`Value_path cp) ~tools_error:e `Lookup; p) -let constructor_path : - Env.t -> Paths.Path.Constructor.t -> Paths.Path.Constructor.t = - fun env p -> - (* if not (should_resolve (p : Paths.Path.Constructor.t :> Paths.Path.t)) then p *) - (* else *) - if not (should_resolve_constructor p) then p - else - let cp = Component.Of_Lang.(constructor_path (empty ()) p) in - match cp with - | `Resolved p -> - let result = Tools.reresolve_constructor env p in - `Resolved Lang_of.(Path.resolved_constructor (empty ()) result) - | _ -> ( - match Tools.resolve_constructor_path env cp with - | Ok p' -> - let result = Tools.reresolve_constructor env p' in - `Resolved Lang_of.(Path.resolved_constructor (empty ()) result) - | Error e -> - Errors.report ~what:(`Constructor_path cp) ~tools_error:e `Lookup; - p) - let class_type_path : Env.t -> Paths.Path.ClassType.t -> Paths.Path.ClassType.t = fun env p -> diff --git a/src/xref2/tools.ml b/src/xref2/tools.ml index f3486bda74..d628bea92c 100644 --- a/src/xref2/tools.ml +++ b/src/xref2/tools.ml @@ -59,19 +59,6 @@ let c_ty_poss env p = | Error _ -> rest) | p -> [ p ] -let c_daty_poss env p = - (* canonical datatype paths *) - match p with - | `Dot (p, n) -> ( - let rest = List.map (fun p -> `Dot (p, n)) (c_mod_poss env p) in - match Env.lookup_by_name Env.s_datatype n env with - | Ok (`Type (id, _)) -> - `Identifier - ((id :> Odoc_model.Paths.Identifier.Path.DataType.t), false) - :: rest - | Error _ -> rest) - | p -> [ p ] - (* Small helper function for resolving canonical paths. [canonical_helper env resolve lang_of possibilities p2] takes the fully-qualified path [p2] and returns the shortest resolved path @@ -273,19 +260,9 @@ type resolve_type_result = simple_type_lookup_error ) Result.result -type resolve_datatype_result = - ( Cpath.Resolved.datatype * Find.careful_datatype, - simple_datatype_lookup_error ) - Result.result - type resolve_value_result = (Cpath.Resolved.value * Find.value, simple_value_lookup_error) Result.result -type resolve_constructor_result = - ( Cpath.Resolved.constructor * Find.constructor, - simple_constructor_lookup_error ) - Result.result - type resolve_class_type_result = ( Cpath.Resolved.class_type * Find.careful_class, simple_type_lookup_error ) @@ -441,18 +418,6 @@ let simplify_type : Env.t -> Cpath.Resolved.type_ -> Cpath.Resolved.type_ = | None -> m) | _ -> m -let simplify_datatype : - Env.t -> Cpath.Resolved.datatype -> Cpath.Resolved.datatype = - fun env m -> - let open Odoc_model.Paths.Identifier in - match m with - | `Type (`Module (`Gpath (`Identifier p)), name) -> ( - let ident = (Mk.type_ ((p :> Signature.t), name) : Path.DataType.t) in - match Env.(lookup_by_id s_datatype (ident :> Path.Type.t) env) with - | Some _ -> `Gpath (`Identifier ident) - | None -> m) - | _ -> m - let rec handle_apply ~mark_substituted env func_path arg_path m = let rec find_functor mty = match mty with @@ -625,24 +590,11 @@ and handle_type_lookup env id p sg = | Some (`FType_removed (name, _, _) as t) -> Ok (`Type (p, name), t) | None -> Error `Find_failure -and handle_datatype_lookup env id p sg = - match Find.careful_datatype_in_sig sg id with - | Some (`FType (name, _) as t) -> - Ok (simplify_datatype env (`Type (p, name)), t) - | Some (`FType_removed (name, _, _) as t) -> Ok (`Type (p, name), t) - | None -> Error `Find_failure - and handle_value_lookup _env id p sg = match Find.value_in_sig sg id with | (`FValue (name, _) as v) :: _ -> Ok (`Value (p, name), v) | _ -> Error `Find_failure -and handle_constructor_lookup _env id p t = - match Find.constructor_in_type t id with - | Some (`FConstructor cons as v) -> - Ok (`Constructor (p, ConstructorName.make_std cons.name), v) - | _ -> Error `Find_failure - and handle_class_type_lookup id p sg = match Find.careful_class_in_sig sg id with | Some (`FClass (name, _) as t) -> Ok (`Class (p, name), t) @@ -878,60 +830,6 @@ and lookup_type_gpath : in res -and lookup_value_gpath : - Env.t -> - Odoc_model.Paths.Path.Resolved.Value.t -> - (Find.value, simple_value_lookup_error) Result.result = - fun env p -> - let do_value p name = - lookup_parent_gpath ~mark_substituted:true env p - |> map_error (fun e -> (e :> simple_value_lookup_error)) - >>= fun (sg, sub) -> - match Find.value_in_sig sg name with - | `FValue (name, t) :: _ -> Ok (`FValue (name, Subst.value sub t)) - | [] -> Error `Find_failure - in - let res = - match p with - | `Identifier ({ iv = `Value _; _ } as i) -> - of_option ~error:(`Lookup_failureV i) (Env.(lookup_by_id s_value) i env) - >>= fun (`Value ({ iv = `Value (_, name); _ }, t)) -> - Ok (`FValue (name, t)) - | `Value (p, id) -> do_value p (ValueName.to_string id) - in - res - -and lookup_datatype_gpath : - Env.t -> - Odoc_model.Paths.Path.Resolved.DataType.t -> - (Find.careful_datatype, simple_datatype_lookup_error) Result.result = - fun env p -> - let do_type p name = - lookup_parent_gpath ~mark_substituted:true env p - |> map_error (fun e -> (e :> simple_datatype_lookup_error)) - >>= fun (sg, sub) -> - match Find.careful_datatype_in_sig sg name with - | Some (`FType (name, t)) -> Ok (`FType (name, Subst.type_ sub t)) - | Some (`FType_removed (name, texpr, eq)) -> - Ok (`FType_removed (name, Subst.type_expr sub texpr, eq)) - | None -> Error `Find_failure - in - let res = - match p with - | `Identifier { iv = `CoreType name; _ } -> - (* CoreTypes aren't put into the environment, so they can't be handled by the - next clause. We just look them up here in the list of core types *) - Ok (`FType (name, List.assoc (TypeName.to_string name) core_types)) - | `Identifier ({ iv = `Type _; _ } as i) -> - of_option ~error:(`Lookup_failureT i) - (Env.(lookup_by_id s_datatype) i env) - >>= fun (`Type ({ iv = `CoreType name | `Type (_, name); _ }, t)) -> - Ok (`FType (name, t)) - | `CanonicalDataType (t1, _) -> lookup_datatype_gpath env t1 - | `Type (p, id) -> do_type p (TypeName.to_string id) - in - res - and lookup_class_type_gpath : Env.t -> Odoc_model.Paths.Path.Resolved.ClassType.t -> @@ -997,34 +895,6 @@ and lookup_type : in res -and lookup_datatype : - Env.t -> - Cpath.Resolved.datatype -> - (Find.careful_datatype, simple_datatype_lookup_error) Result.result = - fun env p -> - let do_type p name = - lookup_parent ~mark_substituted:true env p - |> map_error (fun e -> (e :> simple_datatype_lookup_error)) - >>= fun (sg, sub) -> - handle_datatype_lookup env name p sg >>= fun (_, t') -> - let t = - match t' with - | `FType (name, t) -> `FType (name, Subst.type_ sub t) - | `FType_removed (name, texpr, eq) -> - `FType_removed (name, Subst.type_expr sub texpr, eq) - in - Ok t - in - let res = - match p with - | `Local id -> Error (`LocalDataType (env, id)) - | `Gpath p -> lookup_datatype_gpath env p - | `CanonicalDataType (t1, _) -> lookup_datatype env t1 - | `Substituted s -> lookup_datatype env s - | `Type (p, id) -> do_type p (TypeName.to_string id) - in - res - and lookup_value : Env.t -> Cpath.Resolved.value -> @@ -1039,20 +909,6 @@ and lookup_value : >>= fun (_, `FValue (name, c)) -> Ok (`FValue (name, Subst.value sub c)) | `Gpath p -> lookup_value_gpath env p -and lookup_constructor : - Env.t -> - Cpath.Resolved.constructor -> - (Find.constructor, simple_constructor_lookup_error) Result.result = - fun env (`Constructor (parent, name)) -> - lookup_datatype env parent - |> map_error (fun e -> (`ParentC e :> simple_constructor_lookup_error)) - >>= fun t -> - match t with - | `FType (_, t) -> - handle_constructor_lookup env (ConstructorName.to_string name) parent t - >>= fun (_, x) -> Ok x - | `FType_removed _ -> Error `Find_failure - and lookup_class_type : Env.t -> Cpath.Resolved.class_type -> @@ -1277,83 +1133,6 @@ and resolve_type : if add_canonical then Ok (`CanonicalType (p, c), t) else result | _ -> result -and resolve_datatype : - Env.t -> add_canonical:bool -> Cpath.datatype -> resolve_datatype_result = - fun env ~add_canonical p -> - let ( >>> ) = OptionMonad.bind in - let rec id_datatype_of_type (id : Odoc_model.Comment.Identifier.Id.path_type) - : Odoc_model.Comment.Identifier.Id.path_datatype option = - match id with - | { iv = `Class _ | `ClassType _; _ } -> None - | { iv = `CoreType _ | `Type _; _ } as t -> Some t - and resolved_datatype_of_type (c : Odoc_model.Comment.Path.Resolved.Type.t) : - Odoc_model.Comment.Path.Resolved.DataType.t option = - match c with - | `Identifier id -> - id_datatype_of_type id >>> fun id -> Some (`Identifier id) - | `CanonicalType (t, p) -> - resolved_datatype_of_type t >>> fun t -> - datatype_of_type p >>> fun p -> Some (`CanonicalDataType (t, p)) - | `Type (m, t) -> Some (`Type (m, t)) - | `Class _ -> None - | `ClassType _ -> None - and datatype_of_type (c : Odoc_model.Comment.Path.Type.t) = - match c with - | `Dot (c, s) -> Some (`Dot (c, s)) - | `Identifier (id, b) -> - id_datatype_of_type id >>> fun id -> Some (`Identifier (id, b)) - | `Resolved r -> resolved_datatype_of_type r >>> fun r -> Some (`Resolved r) - in - let result = - match p with - | `Dot (parent, id) -> - resolve_module ~mark_substituted:true ~add_canonical:true env parent - |> map_error (fun e -> `Parent (`Parent_module e)) - >>= fun (p, m) -> - let m = Component.Delayed.get m in - expansion_of_module_cached env p m - |> map_error (fun e -> `Parent (`Parent_sig e)) - >>= assert_not_functor - >>= fun sg -> - let sub = prefix_substitution (`Module p) sg in - handle_datatype_lookup env id (`Module p) sg >>= fun (p', t') -> - let t = - match t' with - | `FType (name, t) -> `FType (name, Subst.type_ sub t) - | `FType_removed (name, texpr, eq) -> - `FType_removed (name, Subst.type_expr sub texpr, eq) - in - Ok (p', t) - | `Type (parent, id) -> - lookup_parent ~mark_substituted:true env parent - |> map_error (fun e -> (e :> simple_datatype_lookup_error)) - >>= fun (parent_sig, sub) -> - let result = - match Find.datatype_in_sig parent_sig (TypeName.to_string id) with - | Some (`FType (name, t)) -> - Some (`Type (parent, name), `FType (name, Subst.type_ sub t)) - | None -> None - in - of_option ~error:`Find_failure result - | `Identifier (i, _) -> - let i' = `Identifier i in - lookup_datatype env (`Gpath i') >>= fun t -> Ok (`Gpath i', t) - | `Resolved r -> lookup_datatype env r >>= fun t -> Ok (r, t) - | `Local (l, _) -> Error (`LocalDataType (env, l)) - | `Substituted s -> - resolve_datatype env ~add_canonical s >>= fun (p, m) -> - Ok (`Substituted p, m) - in - result >>= fun (p, t) -> - match t with - | `FType (_, { canonical = Some c; _ }) -> - if add_canonical then - match datatype_of_type c with - | None -> result - | Some c -> Ok (`CanonicalDataType (p, c), t) - else result - | _ -> result - and resolve_value : Env.t -> Cpath.value -> resolve_value_result = fun env p -> let result = @@ -1389,31 +1168,6 @@ and resolve_value : Env.t -> Cpath.value -> resolve_value_result = in result -and resolve_constructor : - Env.t -> Cpath.constructor -> resolve_constructor_result = - fun env p -> - match p with - | `Dot (parent, id) -> ( - resolve_datatype ~add_canonical:true env parent - |> map_error (fun e -> `ParentC e) - >>= fun (p, m) -> - match m with - | `FType (_, t) -> - handle_constructor_lookup env id p t >>= fun (p', `FConstructor c) -> - Ok (p', `FConstructor c) - | `FType_removed _ -> Error `Find_failure) - | `Constructor (parent, id) -> ( - lookup_datatype env parent - |> map_error (fun e -> (`ParentC e :> simple_constructor_lookup_error)) - >>= fun parent_type -> - match parent_type with - | `FType_removed _ -> Error `Find_failure - | `FType (_, t) -> - handle_constructor_lookup env (ConstructorName.to_string id) parent t) - | `Resolved r -> - let x = lookup_constructor env r in - x >>= fun t -> Ok (r, t) - and resolve_class_type : Env.t -> Cpath.class_type -> resolve_class_type_result = fun env p -> @@ -1748,24 +1502,6 @@ and handle_canonical_type env p2 = | None -> p2 | Some (rp, _) -> `Resolved Lang_of.(Path.resolved_type (empty ()) rp) -and handle_canonical_datatype env p2 = - let cp2 = Component.Of_Lang.(datatype (empty ()) p2) in - let lang_of cpath = - (Lang_of.(Path.resolved_datatype (empty ()) cpath) - :> Odoc_model.Paths.Path.Resolved.t) - in - let resolve env p = - match resolve_datatype env ~add_canonical:false p with - | Ok (_, `FType_removed _) -> Error `Find_failure - | Ok (x, y) -> - (* See comment in handle_canonical_module_type for why we're reresolving here *) - Ok (reresolve_datatype env x, y) - | Error y -> Error y - in - match canonical_helper env resolve lang_of c_daty_poss cp2 with - | None -> p2 - | Some (rp, _) -> `Resolved Lang_of.(Path.resolved_datatype (empty ()) rp) - and reresolve_module_type_gpath : Env.t -> Odoc_model.Paths.Path.Resolved.ModuleType.t -> @@ -1822,30 +1558,12 @@ and reresolve_type : Env.t -> Cpath.Resolved.type_ -> Cpath.Resolved.type_ = in result -and reresolve_datatype : - Env.t -> Cpath.Resolved.datatype -> Cpath.Resolved.datatype = - fun env path -> - let result = - match path with - | `Gpath _ | `Local _ -> path - | `Substituted s -> `Substituted (reresolve_datatype env s) - | `CanonicalDataType (p1, p2) -> - `CanonicalDataType - (reresolve_datatype env p1, handle_canonical_datatype env p2) - | `Type (p, n) -> `Type (reresolve_parent env p, n) - in - result - and reresolve_value : Env.t -> Cpath.Resolved.value -> Cpath.Resolved.value = fun env p -> match p with | `Value (p, n) -> `Value (reresolve_parent env p, n) | `Gpath _ -> p -and reresolve_constructor : - Env.t -> Cpath.Resolved.constructor -> Cpath.Resolved.constructor = - fun env (`Constructor (p, n)) -> `Constructor (reresolve_datatype env p, n) - and reresolve_class_type : Env.t -> Cpath.Resolved.class_type -> Cpath.Resolved.class_type = fun env path -> @@ -2656,8 +2374,5 @@ let resolve_type_path env p = let resolve_value_path env p = resolve_value env p >>= fun (p, _) -> Ok p -let resolve_constructor_path env p = - resolve_constructor env p >>= fun (p, _) -> Ok p - let resolve_class_type_path env p = resolve_class_type env p >>= fun (p, _) -> Ok p diff --git a/src/xref2/tools.mli b/src/xref2/tools.mli index 04513cde83..f955630128 100644 --- a/src/xref2/tools.mli +++ b/src/xref2/tools.mli @@ -154,11 +154,6 @@ val resolve_value_path : Cpath.value -> (Cpath.Resolved.value, simple_value_lookup_error) Result.result -val resolve_constructor_path : - Env.t -> - Cpath.constructor -> - (Cpath.Resolved.constructor, simple_constructor_lookup_error) Result.result - val resolve_class_type_path : Env.t -> Cpath.class_type -> @@ -178,9 +173,6 @@ val reresolve_module_type : val reresolve_type : Env.t -> Cpath.Resolved.type_ -> Cpath.Resolved.type_ -val reresolve_constructor : - Env.t -> Cpath.Resolved.constructor -> Cpath.Resolved.constructor - val reresolve_value : Env.t -> Cpath.Resolved.value -> Cpath.Resolved.value val reresolve_class_type : From 2a50d5e6206b1b4668671397168cd9ac3ec8b4af Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Tue, 12 Dec 2023 09:16:06 +0100 Subject: [PATCH 31/41] Revert "Adding constructors and datatypes to component path" This reverts commit e38f4144d228ea0ae3c7a32e49deca315266ce33. --- src/xref2/component.ml | 96 ----------------------------------------- src/xref2/component.mli | 12 ------ src/xref2/cpath.ml | 22 ---------- src/xref2/ident.ml | 2 - src/xref2/lang_of.ml | 15 ------- src/xref2/lang_of.mli | 6 --- 6 files changed, 153 deletions(-) diff --git a/src/xref2/component.ml b/src/xref2/component.ml index f0fab6a9d5..6406a9c76a 100644 --- a/src/xref2/component.ml +++ b/src/xref2/component.ml @@ -1036,24 +1036,6 @@ module Fmt = struct Format.fprintf ppf "%a.%s" resolved_parent_path p (Odoc_model.Names.TypeName.to_string t) - and resolved_datatype_path : - Format.formatter -> Cpath.Resolved.datatype -> unit = - fun ppf p -> - match p with - | `Local id -> Format.fprintf ppf "%a" Ident.fmt id - | `Gpath p -> - Format.fprintf ppf "%a" model_resolved_path - (p :> Odoc_model.Paths.Path.Resolved.t) - | `Substituted x -> - Format.fprintf ppf "substituted(%a)" resolved_datatype_path x - | `CanonicalDataType (t1, t2) -> - Format.fprintf ppf "canonicalty(%a,%a)" resolved_datatype_path t1 - model_path - (t2 :> Odoc_model.Paths.Path.t) - | `Type (p, t) -> - Format.fprintf ppf "%a.%s" resolved_parent_path p - (Odoc_model.Names.TypeName.to_string t) - and resolved_value_path : Format.formatter -> Cpath.Resolved.value -> unit = fun ppf p -> match p with @@ -1064,14 +1046,6 @@ module Fmt = struct Format.fprintf ppf "%a" model_resolved_path (p :> Odoc_model.Paths.Path.Resolved.t) - and resolved_constructor_path : - Format.formatter -> Cpath.Resolved.constructor -> unit = - fun ppf p -> - match p with - | `Constructor (p, t) -> - Format.fprintf ppf "%a.%s" resolved_datatype_path p - (Odoc_model.Names.ConstructorName.to_string t) - and resolved_parent_path : Format.formatter -> Cpath.Resolved.parent -> unit = fun ppf p -> match p with @@ -1100,21 +1074,6 @@ module Fmt = struct Format.fprintf ppf "%a.%s" resolved_parent_path p (Odoc_model.Names.TypeName.to_string t) - and datatype_path : Format.formatter -> Cpath.datatype -> unit = - fun ppf p -> - match p with - | `Resolved r -> Format.fprintf ppf "r(%a)" resolved_datatype_path r - | `Identifier (id, b) -> - Format.fprintf ppf "identifier(%a, %b)" model_identifier - (id :> Odoc_model.Paths.Identifier.t) - b - | `Local (id, b) -> Format.fprintf ppf "local(%a,%b)" Ident.fmt id b - | `Substituted s -> Format.fprintf ppf "substituted(%a)" datatype_path s - | `Dot (m, s) -> Format.fprintf ppf "%a.%s" module_path m s - | `Type (p, t) -> - Format.fprintf ppf "%a.%s" resolved_parent_path p - (Odoc_model.Names.TypeName.to_string t) - and value_path : Format.formatter -> Cpath.value -> unit = fun ppf p -> match p with @@ -1128,15 +1087,6 @@ module Fmt = struct (id :> Odoc_model.Paths.Identifier.t) b - and constructor_path : Format.formatter -> Cpath.constructor -> unit = - fun ppf p -> - match p with - | `Resolved r -> Format.fprintf ppf "r(%a)" resolved_constructor_path r - | `Dot (m, s) -> Format.fprintf ppf "%a.%s" datatype_path m s - | `Constructor (p, t) -> - Format.fprintf ppf "%a.%s" resolved_datatype_path p - (Odoc_model.Names.ConstructorName.to_string t) - and resolved_class_type_path : Format.formatter -> Cpath.Resolved.class_type -> unit = fun ppf p -> @@ -1210,10 +1160,6 @@ module Fmt = struct Format.fprintf ppf "%a.%s" model_resolved_path (parent :> t) (Odoc_model.Names.TypeName.to_string name) - | `Constructor (parent, name) -> - Format.fprintf ppf "%a.%s" model_resolved_path - (parent :> t) - (Odoc_model.Names.ConstructorName.to_string name) | `Value (parent, name) -> Format.fprintf ppf "%a.%s" model_resolved_path (parent :> t) @@ -1248,11 +1194,6 @@ module Fmt = struct (t1 :> t) model_path (t2 :> Odoc_model.Paths.Path.t) - | `CanonicalDataType (t1, t2) -> - Format.fprintf ppf "canonicaldaty(%a,%a)" model_resolved_path - (t1 :> t) - model_path - (t2 :> Odoc_model.Paths.Path.t) | `Apply (funct, arg) -> Format.fprintf ppf "%a(%a)" model_resolved_path (funct :> t) @@ -1864,19 +1805,6 @@ module Of_Lang = struct | `ClassType (p, name) -> `ClassType (`Module (resolved_module_path ident_map p), name) - and resolved_datatype_path : - _ -> Odoc_model.Paths.Path.Resolved.DataType.t -> Cpath.Resolved.datatype - = - fun ident_map p -> - match p with - | `Identifier i -> ( - match identifier Maps.Type.find ident_map.types i with - | `Local l -> `Local l - | `Identifier _ -> `Gpath p) - | `CanonicalDataType (p1, p2) -> - `CanonicalDataType (resolved_datatype_path ident_map p1, p2) - | `Type (p, name) -> `Type (`Module (resolved_module_path ident_map p), name) - and resolved_value_path : _ -> Odoc_model.Paths.Path.Resolved.Value.t -> Cpath.Resolved.value = fun ident_map p -> @@ -1885,13 +1813,6 @@ module Of_Lang = struct `Value (`Module (resolved_module_path ident_map p), name) | `Identifier _ -> `Gpath p - and resolved_constructor_path : - _ -> - Odoc_model.Paths.Path.Resolved.Constructor.t -> - Cpath.Resolved.constructor = - fun ident_map (`Constructor (p, name)) -> - `Constructor (resolved_datatype_path ident_map p, name) - and resolved_class_type_path : _ -> Odoc_model.Paths.Path.Resolved.ClassType.t -> @@ -1944,16 +1865,6 @@ module Of_Lang = struct | `Local i -> `Local (i, b)) | `Dot (path', x) -> `Dot (module_path ident_map path', x) - and datatype : _ -> Odoc_model.Paths.Path.DataType.t -> Cpath.datatype = - fun ident_map p -> - match p with - | `Resolved r -> `Resolved (resolved_datatype_path ident_map r) - | `Identifier (i, b) -> ( - match identifier Maps.Type.find ident_map.types i with - | `Identifier i -> `Identifier (i, b) - | `Local i -> `Local (i, b)) - | `Dot (path', x) -> `Dot (module_path ident_map path', x) - and value_path : _ -> Odoc_model.Paths.Path.Value.t -> Cpath.value = fun ident_map p -> match p with @@ -1961,13 +1872,6 @@ module Of_Lang = struct | `Dot (path', x) -> `Dot (module_path ident_map path', x) | `Identifier (i, b) -> `Identifier (i, b) - and constructor_path : - _ -> Odoc_model.Paths.Path.Constructor.t -> Cpath.constructor = - fun ident_map p -> - match p with - | `Resolved r -> `Resolved (resolved_constructor_path ident_map r) - | `Dot (path', x) -> `Dot (datatype ident_map path', x) - and class_type_path : _ -> Odoc_model.Paths.Path.ClassType.t -> Cpath.class_type = fun ident_map p -> diff --git a/src/xref2/component.mli b/src/xref2/component.mli index ca945cb8f3..beb42738c0 100644 --- a/src/xref2/component.mli +++ b/src/xref2/component.mli @@ -597,8 +597,6 @@ module Fmt : sig val value_path : Format.formatter -> Cpath.value -> unit - val constructor_path : Format.formatter -> Cpath.constructor -> unit - val resolved_class_type_path : Format.formatter -> Cpath.Resolved.class_type -> unit @@ -663,11 +661,6 @@ module Of_Lang : sig val resolved_value_path : map -> Odoc_model.Paths.Path.Resolved.Value.t -> Cpath.Resolved.value - val resolved_constructor_path : - map -> - Odoc_model.Paths.Path.Resolved.Constructor.t -> - Cpath.Resolved.constructor - val resolved_class_type_path : map -> Odoc_model.Paths.Path.Resolved.ClassType.t -> @@ -680,13 +673,8 @@ module Of_Lang : sig val type_path : map -> Odoc_model.Paths.Path.Type.t -> Cpath.type_ - val datatype : map -> Odoc_model.Paths.Path.DataType.t -> Cpath.datatype - val value_path : map -> Odoc_model.Paths.Path.Value.t -> Cpath.value - val constructor_path : - map -> Odoc_model.Paths.Path.Constructor.t -> Cpath.constructor - val class_type_path : map -> Odoc_model.Paths.Path.ClassType.t -> Cpath.class_type diff --git a/src/xref2/cpath.ml b/src/xref2/cpath.ml index cd9f5f6ac3..112da89d57 100644 --- a/src/xref2/cpath.ml +++ b/src/xref2/cpath.ml @@ -39,15 +39,6 @@ module rec Resolved : sig and value = [ `Value of parent * ValueName.t | `Gpath of Path.Resolved.Value.t ] - and datatype = - [ `Local of Ident.path_datatype - | `Gpath of Path.Resolved.DataType.t - | `Substituted of datatype - | `CanonicalDataType of datatype * Path.DataType.t - | `Type of parent * TypeName.t ] - - and constructor = [ `Constructor of datatype * ConstructorName.t ] - and class_type = [ `Local of Ident.path_class_type | `Substituted of class_type @@ -93,19 +84,6 @@ and Cpath : sig | `Value of Resolved.parent * ValueName.t | `Identifier of Identifier.Value.t * bool ] - and datatype = - [ `Resolved of Resolved.datatype - | `Substituted of datatype - | `Local of Ident.path_datatype * bool - | `Identifier of Odoc_model.Paths.Identifier.Path.DataType.t * bool - | `Dot of module_ * string - | `Type of Resolved.parent * TypeName.t ] - - and constructor = - [ `Resolved of Resolved.constructor - | `Dot of datatype * string - | `Constructor of Resolved.datatype * ConstructorName.t ] - and class_type = [ `Resolved of Resolved.class_type | `Substituted of class_type diff --git a/src/xref2/ident.ml b/src/xref2/ident.ml index 65adeb2bf3..e075e45dc7 100644 --- a/src/xref2/ident.ml +++ b/src/xref2/ident.ml @@ -53,8 +53,6 @@ type class_type = [ `LClassType of ClassTypeName.t * int ] type path_type = [ type_ | class_ | class_type ] -type path_datatype = type_ - type path_value = value type path_class_type = [ class_ | class_type ] diff --git a/src/xref2/lang_of.ml b/src/xref2/lang_of.ml index bbe07f8ac5..91f07c62f1 100644 --- a/src/xref2/lang_of.ml +++ b/src/xref2/lang_of.ml @@ -204,21 +204,6 @@ module Path = struct | `Value (p, name) -> `Value (resolved_parent map p, name) | `Gpath y -> y - and resolved_datatype map (p : Cpath.Resolved.datatype) : - Odoc_model.Paths.Path.Resolved.DataType.t = - match p with - | `Gpath y -> y - | `Local id -> `Identifier (Component.TypeMap.find id map.type_) - | `CanonicalDataType (t1, t2) -> - `CanonicalDataType (resolved_datatype map t1, t2) - | `Type (p, name) -> `Type (resolved_parent map p, name) - | `Substituted s -> resolved_datatype map s - - and resolved_constructor map - (`Constructor (p, name) : Cpath.Resolved.constructor) : - Odoc_model.Paths.Path.Resolved.Constructor.t = - `Constructor (resolved_datatype map p, name) - and resolved_class_type map (p : Cpath.Resolved.class_type) : Odoc_model.Paths.Path.Resolved.ClassType.t = match p with diff --git a/src/xref2/lang_of.mli b/src/xref2/lang_of.mli index 136eeba668..f0952626d0 100644 --- a/src/xref2/lang_of.mli +++ b/src/xref2/lang_of.mli @@ -29,14 +29,8 @@ module Path : sig val resolved_type : maps -> Cpath.Resolved.type_ -> Path.Resolved.Type.t - val resolved_datatype : - maps -> Cpath.Resolved.datatype -> Path.Resolved.DataType.t - val resolved_value : maps -> Cpath.Resolved.value -> Path.Resolved.Value.t - val resolved_constructor : - maps -> Cpath.Resolved.constructor -> Path.Resolved.Constructor.t - val resolved_class_type : maps -> Cpath.Resolved.class_type -> Path.Resolved.ClassType.t From 6c869acdf3fad6e0997cbe31e871e6347249c7ce Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Tue, 12 Dec 2023 09:17:30 +0100 Subject: [PATCH 32/41] Revert "Adding datatype and constructor to lang model" This reverts commit 5826eb1985d5bd1f5288058de27df202479eca25. --- src/document/url.ml | 4 --- src/model/paths.ml | 47 ----------------------------------- src/model/paths.mli | 22 ---------------- src/model/paths_types.ml | 29 --------------------- src/model_desc/paths_desc.ml | 10 -------- test/xref2/lib/common.cppo.ml | 2 -- 6 files changed, 114 deletions(-) diff --git a/src/document/url.ml b/src/document/url.ml index 0f2be81658..af220d32df 100644 --- a/src/document/url.ml +++ b/src/document/url.ml @@ -33,8 +33,6 @@ let render_path : Odoc_model.Paths.Path.t -> string = | `CanonicalModuleType (p, _) -> render_resolved (p :> t) | `CanonicalType (_, `Resolved p) -> render_resolved (p :> t) | `CanonicalType (p, _) -> render_resolved (p :> t) - | `CanonicalDataType (_, `Resolved p) -> render_resolved (p :> t) - | `CanonicalDataType (p, _) -> render_resolved (p :> t) | `Apply (rp, p) -> render_resolved (rp :> t) ^ "(" @@ -44,8 +42,6 @@ let render_path : Odoc_model.Paths.Path.t -> string = render_resolved (p :> t) ^ "." ^ ModuleTypeName.to_string s | `Type (p, s) -> render_resolved (p :> t) ^ "." ^ TypeName.to_string s | `Value (p, s) -> render_resolved (p :> t) ^ "." ^ ValueName.to_string s - | `Constructor (p, s) -> - render_resolved (p :> t) ^ "." ^ ConstructorName.to_string s | `Class (p, s) -> render_resolved (p :> t) ^ "." ^ ClassName.to_string s | `ClassType (p, s) -> render_resolved (p :> t) ^ "." ^ ClassTypeName.to_string s diff --git a/src/model/paths.ml b/src/model/paths.ml index 497bcf0f98..f2d814d698 100644 --- a/src/model/paths.ml +++ b/src/model/paths.ml @@ -424,22 +424,6 @@ module Identifier = struct let compare = compare end - module DataType = struct - type t = Id.path_datatype - type t_pv = Id.path_datatype_pv - let equal = equal - let hash = hash - let compare = compare - end - - module Constructor = struct - type t = Id.path_constructor - type t_pv = Id.constructor_pv - let equal = equal - let hash = hash - let compare = compare - end - module Value = struct type t = Id.path_value type t_pv = Id.value_pv @@ -686,7 +670,6 @@ module Path = struct | `Type (p, _) -> inner (p : module_ :> any) | `Value (_, t) when Names.ValueName.is_internal t -> true | `Value (p, _) -> inner (p : module_ :> any) - | `Constructor (p, _) -> inner (p : datatype :> any) | `Class (p, _) -> inner (p : module_ :> any) | `ClassType (p, _) -> inner (p : module_ :> any) | `Alias (dest, `Resolved src) -> @@ -701,8 +684,6 @@ module Path = struct | `CanonicalModuleType (x, _) -> inner (x : module_type :> any) | `CanonicalType (_, `Resolved _) -> false | `CanonicalType (x, _) -> inner (x : type_ :> any) - | `CanonicalDataType (_, `Resolved _) -> false - | `CanonicalDataType (x, _) -> inner (x : datatype :> any) | `OpaqueModule m -> inner (m :> any) | `OpaqueModuleType mt -> inner (mt :> any) in @@ -756,14 +737,6 @@ module Path = struct | `Alias (dest, _src) -> parent_module_identifier dest | `OpaqueModule m -> parent_module_identifier m - and parent_datatype_identifier : - Paths_types.Resolved_path.datatype -> Identifier.DataType.t = function - | `Identifier id -> - (id : Identifier.Path.DataType.t :> Identifier.DataType.t) - | `CanonicalDataType (_, `Resolved p) -> parent_datatype_identifier p - | `CanonicalDataType (p, _) -> parent_datatype_identifier p - | `Type (m, n) -> Identifier.Mk.type_ (parent_module_identifier m, n) - module Module = struct type t = Paths_types.Resolved_path.module_ @@ -779,14 +752,6 @@ module Path = struct type t = Paths_types.Resolved_path.type_ end - module DataType = struct - type t = Paths_types.Resolved_path.datatype - end - - module Constructor = struct - type t = Paths_types.Resolved_path.constructor - end - module Value = struct type t = Paths_types.Resolved_path.value end @@ -805,8 +770,6 @@ module Path = struct | `Apply (m, _) -> identifier (m :> t) | `Type (m, n) -> Identifier.Mk.type_ (parent_module_identifier m, n) | `Value (m, n) -> Identifier.Mk.value (parent_module_identifier m, n) - | `Constructor (m, n) -> - Identifier.Mk.constructor (parent_datatype_identifier m, n) | `ModuleType (m, n) -> Identifier.Mk.module_type (parent_module_identifier m, n) | `Class (m, n) -> Identifier.Mk.class_ (parent_module_identifier m, n) @@ -826,8 +789,6 @@ module Path = struct | `CanonicalModuleType (p, _) -> identifier (p :> t) | `CanonicalType (_, `Resolved p) -> identifier (p :> t) | `CanonicalType (p, _) -> identifier (p :> t) - | `CanonicalDataType (_, `Resolved p) -> identifier (p :> t) - | `CanonicalDataType (p, _) -> identifier (p :> t) | `OpaqueModule m -> identifier (m :> t) | `OpaqueModuleType mt -> identifier (mt :> t) @@ -846,14 +807,6 @@ module Path = struct type t = Paths_types.Path.type_ end - module DataType = struct - type t = Paths_types.Path.datatype - end - - module Constructor = struct - type t = Paths_types.Path.constructor - end - module Value = struct type t = Paths_types.Path.value end diff --git a/src/model/paths.mli b/src/model/paths.mli index f52538ba73..2105b8b210 100644 --- a/src/model/paths.mli +++ b/src/model/paths.mli @@ -182,12 +182,6 @@ module Identifier : sig module Type : IdSig with type t = Id.path_type and type t_pv = Id.path_type_pv - module DataType : - IdSig with type t = Id.path_datatype and type t_pv = Id.path_datatype_pv - - module Constructor : - IdSig with type t = Id.path_constructor and type t_pv = Id.constructor_pv - module Value : IdSig with type t = Id.path_value and type t_pv = Id.value_pv module ClassType : @@ -372,14 +366,6 @@ module rec Path : sig (* val identifier : t -> Identifier.Path.Type.t *) end - module DataType : sig - type t = Paths_types.Resolved_path.datatype - end - - module Constructor : sig - type t = Paths_types.Resolved_path.constructor - end - module Value : sig type t = Paths_types.Resolved_path.value end @@ -413,14 +399,6 @@ module rec Path : sig type t = Paths_types.Path.type_ end - module DataType : sig - type t = Paths_types.Path.datatype - end - - module Constructor : sig - type t = Paths_types.Path.constructor - end - module Value : sig type t = Paths_types.Path.value end diff --git a/src/model/paths_types.ml b/src/model/paths_types.ml index 8c61ca316c..bf306203d4 100644 --- a/src/model/paths_types.ml +++ b/src/model/paths_types.ml @@ -259,14 +259,6 @@ module Identifier = struct and path_type = path_type_pv id (** @canonical Odoc_model.Paths.Identifier.Path.Type.t *) - type path_datatype_pv = type_pv - (** @canonical Odoc_model.Paths.Identifier.Path.DataType.t_pv *) - - and path_datatype = path_datatype_pv id - (** @canonical Odoc_model.Paths.Identifier.Path.DataType.t *) - - type path_constructor = constructor - type path_value = value type path_class_type_pv = [ class_pv | class_type_pv ] @@ -342,16 +334,6 @@ module rec Path : sig | `Dot of module_ * string ] (** @canonical Odoc_model.Paths.Path.Type.t *) - type datatype = - [ `Resolved of Resolved_path.datatype - | `Identifier of Identifier.path_datatype * bool - | `Dot of module_ * string ] - (** @canonical Odoc_model.Paths.Path.DataType.t *) - - type constructor = - [ `Resolved of Resolved_path.constructor | `Dot of datatype * string ] - (** @canonical Odoc_model.Paths.Path.Constructor.t *) - type value = [ `Resolved of Resolved_path.value | `Identifier of Identifier.path_value * bool @@ -404,15 +386,6 @@ and Resolved_path : sig | `ClassType of module_ * ClassTypeName.t ] (** @canonical Odoc_model.Paths.Path.Resolved.Type.t *) - type datatype = - [ `Identifier of Identifier.datatype - | `CanonicalDataType of datatype * Path.datatype - | `Type of module_ * TypeName.t ] - (** @canonical Odoc_model.Paths.Path.Resolved.DataType.t *) - - type constructor = [ `Constructor of datatype * ConstructorName.t ] - (** @canonical Odoc_model.Paths.Path.Resolved.Constructor.t *) - type value = [ `Identifier of Identifier.path_value | `Value of module_ * ValueName.t ] (** @canonical Odoc_model.Paths.Path.Resolved.Value.t *) @@ -437,9 +410,7 @@ and Resolved_path : sig | `SubstT of module_type * module_type | `OpaqueModuleType of module_type | `CanonicalType of type_ * Path.type_ - | `CanonicalDataType of datatype * Path.datatype | `Type of module_ * TypeName.t - | `Constructor of datatype * ConstructorName.t | `Class of module_ * ClassName.t | `ClassType of module_ * ClassTypeName.t | `Class of module_ * ClassName.t diff --git a/src/model_desc/paths_desc.ml b/src/model_desc/paths_desc.ml index edec9cbc09..03b0d816ca 100644 --- a/src/model_desc/paths_desc.ml +++ b/src/model_desc/paths_desc.ml @@ -262,21 +262,11 @@ module General_paths = struct ( "`CanonicalType", ((x1 :> rp), (x2 :> p)), Pair (resolved_path, path) ) - | `CanonicalDataType (x1, x2) -> - C - ( "`CanonicalDataType", - ((x1 :> rp), (x2 :> p)), - Pair (resolved_path, path) ) | `OpaqueModuleType x -> C ("`OpaqueModuleType", (x :> rp), resolved_path) | `Type (x1, x2) -> C ("`Type", ((x1 :> rp), x2), Pair (resolved_path, Names.typename)) | `Value (x1, x2) -> C ("`Value", ((x1 :> rp), x2), Pair (resolved_path, Names.valuename)) - | `Constructor (x1, x2) -> - C - ( "`Constructor", - ((x1 :> rp), x2), - Pair (resolved_path, Names.constructorname) ) | `Class (x1, x2) -> C ("`Class", ((x1 :> rp), x2), Pair (resolved_path, Names.classname)) | `ClassType (x1, x2) -> diff --git a/test/xref2/lib/common.cppo.ml b/test/xref2/lib/common.cppo.ml index 9a7534f52b..d0161003c2 100644 --- a/test/xref2/lib/common.cppo.ml +++ b/test/xref2/lib/common.cppo.ml @@ -565,13 +565,11 @@ module LangUtils = struct | `ModuleType (p, mt) -> Format.fprintf ppf "%a.%s" resolved_path (cast p) (Odoc_model.Names.ModuleTypeName.to_string mt) | `Type (p, t) -> Format.fprintf ppf "%a.%s" resolved_path (cast p) (Odoc_model.Names.TypeName.to_string t) | `Value (p, t) -> Format.fprintf ppf "%a.%s" resolved_path (cast p) (Odoc_model.Names.ValueName.to_string t) - | `Constructor (p, t) -> Format.fprintf ppf "%a.%s" resolved_path (cast p) (Odoc_model.Names.ConstructorName.to_string t) | `OpaqueModule m -> Format.fprintf ppf "opaquemodule(%a)" resolved_path (cast m) | `OpaqueModuleType m -> Format.fprintf ppf "opaquemoduletype(%a)" resolved_path (cast m) | `SubstT (_, _) | `CanonicalModuleType (_, _) | `CanonicalType (_, _) - | `CanonicalDataType (_, _) | `Class (_, _) | `ClassType (_, _) | `Hidden _ From a958e8fd826028de28904dc1e017f646d112b511 Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Tue, 12 Dec 2023 09:44:17 +0100 Subject: [PATCH 33/41] Remove occurrence count for constructors The resolving of constructor paths introduced was wrong and never tested. It is removed in this commit as well. Signed-off-by: Paul-Elliot --- src/document/generator.ml | 1 - src/loader/implementation.ml | 5 ----- src/loader/typedtree_traverse.ml | 17 ----------------- src/model/lang.ml | 1 - src/xref2/compile.ml | 1 - src/xref2/link.ml | 3 --- src/xref2/tools.ml | 23 +++++++++++++++++++++++ 7 files changed, 23 insertions(+), 28 deletions(-) diff --git a/src/document/generator.ml b/src/document/generator.ml index cdba1ffae0..5a88c82760 100644 --- a/src/document/generator.ml +++ b/src/document/generator.ml @@ -286,7 +286,6 @@ module Make (Syntax : SYNTAX) = struct | Type v -> to_link v | ClassType v -> to_link v | Value v -> to_link v - | Constructor v -> to_link v let source id syntax_info infos source_code = let url = path id in diff --git a/src/loader/implementation.ml b/src/loader/implementation.ml index c3d2f76732..ed09ac053b 100644 --- a/src/loader/implementation.ml +++ b/src/loader/implementation.ml @@ -332,11 +332,6 @@ let process_occurrences env poses loc_to_id local_ident_to_loc = process p Ident_env.Path.read_type |> Option.iter @@ fun l -> AnnotHashtbl.replace occ_tbl (Type l, pos_of_loc loc) () - | Constructor _p, loc -> - (* process p Ident_env.Path.read_constructor *) - None - |> Option.iter @@ fun l -> - AnnotHashtbl.replace occ_tbl (Constructor l, pos_of_loc loc) () | LocalDefinition _, _ -> ()) poses; AnnotHashtbl.fold (fun k () acc -> k :: acc) occ_tbl [] diff --git a/src/loader/typedtree_traverse.ml b/src/loader/typedtree_traverse.ml index 67be8ae96f..4bfcc3b722 100644 --- a/src/loader/typedtree_traverse.ml +++ b/src/loader/typedtree_traverse.ml @@ -8,7 +8,6 @@ module Analysis = struct | ClassType of Path.t | ModuleType of Path.t | Type of Path.t - | Constructor of Path.t let expr poses expr = let exp_loc = expr.Typedtree.exp_loc in @@ -16,26 +15,10 @@ module Analysis = struct else match expr.exp_desc with | Texp_ident (p, _, _) -> poses := (Value p, exp_loc) :: !poses - | Texp_construct (_, { cstr_res; _ }, _) -> ( - let desc = Types.get_desc cstr_res in - match desc with - | Types.Tconstr (p, _, _) -> - poses := (Constructor p, exp_loc) :: !poses - | _ -> ()) | _ -> () let pat env (type a) poses : a Typedtree.general_pattern -> unit = function | { Typedtree.pat_desc; pat_loc; _ } when not pat_loc.loc_ghost -> - let () = - match pat_desc with - | Typedtree.Tpat_construct (_, { cstr_res; _ }, _, _) -> ( - let desc = Types.get_desc cstr_res in - match desc with - | Types.Tconstr (p, _, _) -> - poses := (Constructor p, pat_loc) :: !poses - | _ -> ()) - | _ -> () - in let maybe_localvalue id loc = match Ident_env.identifier_of_loc env loc with | None -> Some (LocalDefinition id, loc) diff --git a/src/model/lang.ml b/src/model/lang.ml index 800666b962..ea3ecaa0e5 100644 --- a/src/model/lang.ml +++ b/src/model/lang.ml @@ -34,7 +34,6 @@ module Source_info = struct | ClassType of Path.ClassType.t jump_to | ModuleType of Path.ModuleType.t jump_to | Type of Path.Type.t jump_to - | Constructor of Path.Constructor.t jump_to type 'a with_pos = 'a * (int * int) diff --git a/src/xref2/compile.ml b/src/xref2/compile.ml index 6e57e442ac..1a781bba4a 100644 --- a/src/xref2/compile.ml +++ b/src/xref2/compile.ml @@ -91,7 +91,6 @@ and source_info_infos env infos = | Module v -> Module (map_doc (module_path env) v) | ModuleType v -> ModuleType (map_doc (module_type_path env) v) | Type v -> Type (map_doc (type_path env) v) - | Constructor v -> Constructor (map_doc (constructor_path env) v) | ClassType v -> ClassType (map_doc (class_type_path env) v) | Definition _ as d -> d in diff --git a/src/xref2/link.ml b/src/xref2/link.ml index ecdb29946e..3ac072fb55 100644 --- a/src/xref2/link.ml +++ b/src/xref2/link.ml @@ -421,9 +421,6 @@ let rec unit env t = (jump_to v (Shape_tools.lookup_type_path env) (type_path env)) - | Constructor v -> - Constructor - (jump_to v (fun _ -> None) (constructor_path env)) | ClassType v -> ClassType (jump_to v diff --git a/src/xref2/tools.ml b/src/xref2/tools.ml index d628bea92c..5f9e143e0d 100644 --- a/src/xref2/tools.ml +++ b/src/xref2/tools.ml @@ -830,6 +830,29 @@ and lookup_type_gpath : in res +and lookup_value_gpath : + Env.t -> + Odoc_model.Paths.Path.Resolved.Value.t -> + (Find.value, simple_value_lookup_error) Result.result = + fun env p -> + let do_value p name = + lookup_parent_gpath ~mark_substituted:true env p + |> map_error (fun e -> (e :> simple_value_lookup_error)) + >>= fun (sg, sub) -> + match Find.value_in_sig sg name with + | `FValue (name, t) :: _ -> Ok (`FValue (name, Subst.value sub t)) + | [] -> Error `Find_failure + in + let res = + match p with + | `Identifier ({ iv = `Value _; _ } as i) -> + of_option ~error:(`Lookup_failureV i) (Env.(lookup_by_id s_value) i env) + >>= fun (`Value ({ iv = `Value (_, name); _ }, t)) -> + Ok (`FValue (name, t)) + | `Value (p, id) -> do_value p (ValueName.to_string id) + in + res + and lookup_class_type_gpath : Env.t -> Odoc_model.Paths.Path.Resolved.ClassType.t -> From 009254fff60f203ada6e52841130229b4b2ec0fc Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Tue, 12 Dec 2023 11:08:28 +0100 Subject: [PATCH 34/41] Add test for class types Signed-off-by: Paul-Elliot --- test/occurrences/double_wrapped.t/a.ml | 4 +++- test/occurrences/double_wrapped.t/b.ml | 4 ++++ test/occurrences/double_wrapped.t/run.t | 22 ++++++++++++++-------- 3 files changed, 21 insertions(+), 9 deletions(-) diff --git a/test/occurrences/double_wrapped.t/a.ml b/test/occurrences/double_wrapped.t/a.ml index aa8464151f..01e9710c47 100644 --- a/test/occurrences/double_wrapped.t/a.ml +++ b/test/occurrences/double_wrapped.t/a.ml @@ -4,6 +4,8 @@ type t = string module type M = sig end -let (||>) x y = x + y +let ( ||> ) x y = x + y let _ = x + x + +class ct = object end diff --git a/test/occurrences/double_wrapped.t/b.ml b/test/occurrences/double_wrapped.t/b.ml index 6a01b082fe..4c118e5fd2 100644 --- a/test/occurrences/double_wrapped.t/b.ml +++ b/test/occurrences/double_wrapped.t/b.ml @@ -13,3 +13,7 @@ module type Y = A.M let _ = let open A in 1 ||> 2 + +let ob = new A.ct + +class ct : A.ct = A.ct diff --git a/test/occurrences/double_wrapped.t/run.t b/test/occurrences/double_wrapped.t/run.t index 756ffba5a1..7712c5cfa2 100644 --- a/test/occurrences/double_wrapped.t/run.t +++ b/test/occurrences/double_wrapped.t/run.t @@ -16,6 +16,8 @@ occurrences information. $ odoc compile --count-occurrences -I . main__A.cmt $ odoc compile --count-occurrences -I . main__C.cmt $ odoc compile --count-occurrences -I . main__B.cmt + File "main__B.cmt": + Warning: Failed to compile expansion for class (root Main__B).ct $ odoc compile --count-occurrences -I . main__.cmt $ odoc compile --count-occurrences -I . main.cmt @@ -68,10 +70,11 @@ A only uses "persistent" values: one it defines itself. "Aliased" values are not counted since they become persistent $ occurrences_print occurrences-main__B.odoc | sort - Main was used directly 0 times and indirectly 7 times - Main.A was used directly 2 times and indirectly 5 times + Main was used directly 0 times and indirectly 8 times + Main.A was used directly 2 times and indirectly 6 times Main.A.(||>) was used directly 1 times and indirectly 0 times Main.A.M was used directly 2 times and indirectly 0 times + Main.A.ct was used directly 1 times and indirectly 0 times Main.A.t was used directly 1 times and indirectly 0 times Main.A.x was used directly 1 times and indirectly 0 times @@ -92,10 +95,11 @@ Now we can merge all tables $ occurrences_print occurrences-aggregated.odoc | sort > all_merged $ cat all_merged - Main was used directly 0 times and indirectly 11 times - Main.A was used directly 4 times and indirectly 6 times + Main was used directly 0 times and indirectly 12 times + Main.A was used directly 4 times and indirectly 7 times Main.A.(||>) was used directly 1 times and indirectly 0 times Main.A.M was used directly 2 times and indirectly 0 times + Main.A.ct was used directly 1 times and indirectly 0 times Main.A.t was used directly 1 times and indirectly 0 times Main.A.x was used directly 2 times and indirectly 0 times Main.B was used directly 1 times and indirectly 0 times @@ -110,10 +114,11 @@ We can also include hidden ids: $ odoc count-occurrences -I main__B -o occurrences-b.odoc --include-hidden $ occurrences_print occurrences-b.odoc | sort - Main was used directly 0 times and indirectly 7 times - Main.A was used directly 2 times and indirectly 5 times + Main was used directly 0 times and indirectly 8 times + Main.A was used directly 2 times and indirectly 6 times Main.A.(||>) was used directly 1 times and indirectly 0 times Main.A.M was used directly 2 times and indirectly 0 times + Main.A.ct was used directly 1 times and indirectly 0 times Main.A.t was used directly 1 times and indirectly 0 times Main.A.x was used directly 1 times and indirectly 0 times Main__ was used directly 0 times and indirectly 2 times @@ -122,10 +127,11 @@ We can also include hidden ids: $ odoc count-occurrences -I . -o occurrences-all.odoc --include-hidden $ occurrences_print occurrences-all.odoc | sort - Main was used directly 0 times and indirectly 11 times - Main.A was used directly 4 times and indirectly 6 times + Main was used directly 0 times and indirectly 12 times + Main.A was used directly 4 times and indirectly 7 times Main.A.(||>) was used directly 1 times and indirectly 0 times Main.A.M was used directly 2 times and indirectly 0 times + Main.A.ct was used directly 1 times and indirectly 0 times Main.A.t was used directly 1 times and indirectly 0 times Main.A.x was used directly 2 times and indirectly 0 times Main.B was used directly 1 times and indirectly 0 times From f8a5b088ba03fc76f7aa293b46d0ea9fe1e424d1 Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Tue, 12 Dec 2023 18:42:29 +0100 Subject: [PATCH 35/41] occurrence: comment code for when documentation links are readded Signed-off-by: Paul-Elliot --- src/document/generator.ml | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/src/document/generator.ml b/src/document/generator.ml index 5a88c82760..0a9af9e594 100644 --- a/src/document/generator.ml +++ b/src/document/generator.ml @@ -254,14 +254,18 @@ module Make (Syntax : SYNTAX) = struct let to_link { Lang.Source_info.documentation; implementation } = let documentation = - let open Paths.Path.Resolved in - match documentation with - | Some (`Resolved p) when not (is_hidden (p :> t)) -> ( - let id = identifier (p :> t) in - match Url.from_identifier ~stop_before:false id with - | Ok link -> Some link - | _ -> None) - | _ -> None + (* Since documentation link are not rendered, we comment the code to + extract the href, and always output [None] *) + ignore documentation; + None + (* let open Paths.Path.Resolved in *) + (* match documentation with *) + (* | Some (`Resolved p) when not (is_hidden (p :> t)) -> ( *) + (* let id = identifier (p :> t) in *) + (* match Url.from_identifier ~stop_before:false id with *) + (* | Ok link -> Some link *) + (* | _ -> None) *) + (* | _ -> None *) in let implementation = match implementation with From c7b684abb7d1ab6c3a6ba44829eec61fa4b8f753 Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Tue, 12 Dec 2023 18:46:07 +0100 Subject: [PATCH 36/41] Remove support for class types Signed-off-by: Paul-Elliot --- src/document/generator.ml | 1 - src/loader/implementation.ml | 4 ---- src/loader/typedtree_traverse.ml | 13 ------------- src/model/lang.ml | 1 - src/odoc/occurrences.ml | 2 -- src/xref2/compile.ml | 1 - src/xref2/link.ml | 5 ----- test/occurrences/double_wrapped.t/a.ml | 2 -- test/occurrences/double_wrapped.t/b.ml | 4 ---- test/occurrences/double_wrapped.t/run.t | 22 ++++++++-------------- 10 files changed, 8 insertions(+), 47 deletions(-) diff --git a/src/document/generator.ml b/src/document/generator.ml index 0a9af9e594..f6df604d3b 100644 --- a/src/document/generator.ml +++ b/src/document/generator.ml @@ -288,7 +288,6 @@ module Make (Syntax : SYNTAX) = struct | Module v -> to_link v | ModuleType v -> to_link v | Type v -> to_link v - | ClassType v -> to_link v | Value v -> to_link v let source id syntax_info infos source_code = diff --git a/src/loader/implementation.ml b/src/loader/implementation.ml index ed09ac053b..f062bdf401 100644 --- a/src/loader/implementation.ml +++ b/src/loader/implementation.ml @@ -320,10 +320,6 @@ let process_occurrences env poses loc_to_id local_ident_to_loc = process p Ident_env.Path.read_module |> Option.iter @@ fun l -> AnnotHashtbl.replace occ_tbl (Module l, pos_of_loc loc) () - | ClassType p, loc -> - process p Ident_env.Path.read_class_type - |> Option.iter @@ fun l -> - AnnotHashtbl.replace occ_tbl (ClassType l, pos_of_loc loc) () | ModuleType p, loc -> process p Ident_env.Path.read_module_type |> Option.iter @@ fun l -> diff --git a/src/loader/typedtree_traverse.ml b/src/loader/typedtree_traverse.ml index 4bfcc3b722..15ff46a940 100644 --- a/src/loader/typedtree_traverse.ml +++ b/src/loader/typedtree_traverse.ml @@ -5,7 +5,6 @@ module Analysis = struct | LocalDefinition of Ident.t | Value of Path.t | Module of Path.t - | ClassType of Path.t | ModuleType of Path.t | Type of Path.t @@ -53,13 +52,6 @@ module Analysis = struct poses := (Module p, mod_loc) :: !poses | _ -> () - let class_type poses cltyp = - match cltyp with - | { Typedtree.cltyp_desc = Tcty_constr (p, _, _); cltyp_loc; _ } - when not cltyp_loc.loc_ghost -> - poses := (ClassType p, cltyp_loc) :: !poses - | _ -> () - let module_type poses mty_expr = match mty_expr with | { Typedtree.mty_desc = Tmty_ident (p, _); mty_loc; _ } @@ -98,10 +90,6 @@ let of_cmt env structure = Analysis.module_type poses mty; iter.module_type iterator mty in - let class_type iterator cl_type = - Analysis.class_type poses cl_type; - iter.class_type iterator cl_type - in let module_binding iterator mb = Analysis.module_binding env poses mb; iter.module_binding iterator mb @@ -114,7 +102,6 @@ let of_cmt env structure = module_expr; typ; module_type; - class_type; module_binding; } in diff --git a/src/model/lang.ml b/src/model/lang.ml index ea3ecaa0e5..3f9e09ffb7 100644 --- a/src/model/lang.ml +++ b/src/model/lang.ml @@ -31,7 +31,6 @@ module Source_info = struct | Definition of Paths.Identifier.SourceLocation.t | Value of Path.Value.t jump_to | Module of Path.Module.t jump_to - | ClassType of Path.ClassType.t jump_to | ModuleType of Path.ModuleType.t jump_to | Type of Path.Type.t jump_to diff --git a/src/odoc/occurrences.ml b/src/odoc/occurrences.ml index 9f28d0fbd3..711e46c977 100644 --- a/src/odoc/occurrences.ml +++ b/src/odoc/occurrences.ml @@ -136,8 +136,6 @@ let count ~dst ~warnings_options:_ directories include_hidden = _ ) -> incr htbl p | Value { documentation = Some (`Resolved p); _ }, _ -> incr htbl p - | ClassType { documentation = Some (`Resolved p); _ }, _ -> - incr htbl p | ModuleType { documentation = Some (`Resolved p); _ }, _ -> incr htbl p | Type { documentation = Some (`Resolved p); _ }, _ -> incr htbl p diff --git a/src/xref2/compile.ml b/src/xref2/compile.ml index 1a781bba4a..4d4d331033 100644 --- a/src/xref2/compile.ml +++ b/src/xref2/compile.ml @@ -91,7 +91,6 @@ and source_info_infos env infos = | Module v -> Module (map_doc (module_path env) v) | ModuleType v -> ModuleType (map_doc (module_type_path env) v) | Type v -> Type (map_doc (type_path env) v) - | ClassType v -> ClassType (map_doc (class_type_path env) v) | Definition _ as d -> d in (v, pos)) diff --git a/src/xref2/link.ml b/src/xref2/link.ml index 3ac072fb55..fa9c45a287 100644 --- a/src/xref2/link.ml +++ b/src/xref2/link.ml @@ -421,11 +421,6 @@ let rec unit env t = (jump_to v (Shape_tools.lookup_type_path env) (type_path env)) - | ClassType v -> - ClassType - (jump_to v - (Shape_tools.lookup_class_type_path env) - (class_type_path env)) | i -> i in (info, pos)) diff --git a/test/occurrences/double_wrapped.t/a.ml b/test/occurrences/double_wrapped.t/a.ml index 01e9710c47..969be61ecf 100644 --- a/test/occurrences/double_wrapped.t/a.ml +++ b/test/occurrences/double_wrapped.t/a.ml @@ -7,5 +7,3 @@ module type M = sig end let ( ||> ) x y = x + y let _ = x + x - -class ct = object end diff --git a/test/occurrences/double_wrapped.t/b.ml b/test/occurrences/double_wrapped.t/b.ml index 4c118e5fd2..6a01b082fe 100644 --- a/test/occurrences/double_wrapped.t/b.ml +++ b/test/occurrences/double_wrapped.t/b.ml @@ -13,7 +13,3 @@ module type Y = A.M let _ = let open A in 1 ||> 2 - -let ob = new A.ct - -class ct : A.ct = A.ct diff --git a/test/occurrences/double_wrapped.t/run.t b/test/occurrences/double_wrapped.t/run.t index 7712c5cfa2..756ffba5a1 100644 --- a/test/occurrences/double_wrapped.t/run.t +++ b/test/occurrences/double_wrapped.t/run.t @@ -16,8 +16,6 @@ occurrences information. $ odoc compile --count-occurrences -I . main__A.cmt $ odoc compile --count-occurrences -I . main__C.cmt $ odoc compile --count-occurrences -I . main__B.cmt - File "main__B.cmt": - Warning: Failed to compile expansion for class (root Main__B).ct $ odoc compile --count-occurrences -I . main__.cmt $ odoc compile --count-occurrences -I . main.cmt @@ -70,11 +68,10 @@ A only uses "persistent" values: one it defines itself. "Aliased" values are not counted since they become persistent $ occurrences_print occurrences-main__B.odoc | sort - Main was used directly 0 times and indirectly 8 times - Main.A was used directly 2 times and indirectly 6 times + Main was used directly 0 times and indirectly 7 times + Main.A was used directly 2 times and indirectly 5 times Main.A.(||>) was used directly 1 times and indirectly 0 times Main.A.M was used directly 2 times and indirectly 0 times - Main.A.ct was used directly 1 times and indirectly 0 times Main.A.t was used directly 1 times and indirectly 0 times Main.A.x was used directly 1 times and indirectly 0 times @@ -95,11 +92,10 @@ Now we can merge all tables $ occurrences_print occurrences-aggregated.odoc | sort > all_merged $ cat all_merged - Main was used directly 0 times and indirectly 12 times - Main.A was used directly 4 times and indirectly 7 times + Main was used directly 0 times and indirectly 11 times + Main.A was used directly 4 times and indirectly 6 times Main.A.(||>) was used directly 1 times and indirectly 0 times Main.A.M was used directly 2 times and indirectly 0 times - Main.A.ct was used directly 1 times and indirectly 0 times Main.A.t was used directly 1 times and indirectly 0 times Main.A.x was used directly 2 times and indirectly 0 times Main.B was used directly 1 times and indirectly 0 times @@ -114,11 +110,10 @@ We can also include hidden ids: $ odoc count-occurrences -I main__B -o occurrences-b.odoc --include-hidden $ occurrences_print occurrences-b.odoc | sort - Main was used directly 0 times and indirectly 8 times - Main.A was used directly 2 times and indirectly 6 times + Main was used directly 0 times and indirectly 7 times + Main.A was used directly 2 times and indirectly 5 times Main.A.(||>) was used directly 1 times and indirectly 0 times Main.A.M was used directly 2 times and indirectly 0 times - Main.A.ct was used directly 1 times and indirectly 0 times Main.A.t was used directly 1 times and indirectly 0 times Main.A.x was used directly 1 times and indirectly 0 times Main__ was used directly 0 times and indirectly 2 times @@ -127,11 +122,10 @@ We can also include hidden ids: $ odoc count-occurrences -I . -o occurrences-all.odoc --include-hidden $ occurrences_print occurrences-all.odoc | sort - Main was used directly 0 times and indirectly 12 times - Main.A was used directly 4 times and indirectly 7 times + Main was used directly 0 times and indirectly 11 times + Main.A was used directly 4 times and indirectly 6 times Main.A.(||>) was used directly 1 times and indirectly 0 times Main.A.M was used directly 2 times and indirectly 0 times - Main.A.ct was used directly 1 times and indirectly 0 times Main.A.t was used directly 1 times and indirectly 0 times Main.A.x was used directly 2 times and indirectly 0 times Main.B was used directly 1 times and indirectly 0 times From 32e9c59987cc2c786be83aaa196e537c793d2196 Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Wed, 13 Dec 2023 20:36:21 +0100 Subject: [PATCH 37/41] Revert "Ident_env: Turn all maps into hashtbl" This reverts commit 7e4e716a5f03c8ed92f44665d133372ac53a3814. --- src/loader/cmi.ml | 17 ++- src/loader/cmt.ml | 23 ++-- src/loader/cmti.ml | 16 +-- src/loader/ident_env.cppo.ml | 196 ++++++++++++++++------------------ src/loader/ident_env.cppo.mli | 8 +- src/loader/implementation.ml | 19 ++-- 6 files changed, 134 insertions(+), 145 deletions(-) diff --git a/src/loader/cmi.ml b/src/loader/cmi.ml index 86fe68bdd2..169fbc53b5 100644 --- a/src/loader/cmi.ml +++ b/src/loader/cmi.ml @@ -924,18 +924,17 @@ let rec read_module_type env parent (mty : Odoc_model.Compat.module_type) = | Mty_ident p -> Path {p_path = Env.Path.read_module_type env p; p_expansion=None } | Mty_signature sg -> Signature (read_signature env parent sg) | Mty_functor(parameter, res) -> - let f_parameter = + let f_parameter, env = match parameter with - | Unit -> Odoc_model.Lang.FunctorParameter.Unit + | Unit -> Odoc_model.Lang.FunctorParameter.Unit, env | Named (id_opt, arg) -> - let id = match id_opt with - | None -> Identifier.Mk.parameter(parent, Odoc_model.Names.ModuleName.make_std "_") - | Some id -> - let () = Env.add_parameter parent id (ModuleName.of_ident id) env in - Ident_env.find_parameter_identifier env id + let id, env = match id_opt with + | None -> Identifier.Mk.parameter(parent, Odoc_model.Names.ModuleName.make_std "_"), env + | Some id -> let env = Env.add_parameter parent id (ModuleName.of_ident id) env in + Ident_env.find_parameter_identifier env id, env in let arg = read_module_type env (id :> Identifier.Signature.t) arg in - Odoc_model.Lang.FunctorParameter.Named ({ FunctorParameter. id; expr = arg }) + Odoc_model.Lang.FunctorParameter.Named ({ FunctorParameter. id; expr = arg }), env in let res = read_module_type env (Identifier.Mk.result parent) res in Functor( f_parameter, res) @@ -1083,7 +1082,7 @@ and read_signature_noenv env parent (items : Odoc_model.Compat.signature) = loop ([],{s_modules=[]; s_module_types=[]; s_values=[];s_types=[]; s_classes=[]; s_class_types=[]}) items and read_signature env parent (items : Odoc_model.Compat.signature) = - let () = Env.handle_signature_type_items parent items env in + let env = Env.handle_signature_type_items parent items env in fst @@ read_signature_noenv env parent items diff --git a/src/loader/cmt.ml b/src/loader/cmt.ml index 4d173fd4a7..3dafa060aa 100644 --- a/src/loader/cmt.ml +++ b/src/loader/cmt.ml @@ -363,35 +363,34 @@ let rec read_module_expr env parent label_parent mexpr = Signature sg #if OCAML_VERSION >= (4,10,0) | Tmod_functor(parameter, res) -> - let f_parameter = + let f_parameter, env = match parameter with - | Unit -> FunctorParameter.Unit + | Unit -> FunctorParameter.Unit, env | Named (id_opt, _, arg) -> - let id = + let id, env = match id_opt with - | None -> Identifier.Mk.parameter (parent, Odoc_model.Names.ModuleName.make_std "_") - | Some id -> - let () = Env.add_parameter parent id (ModuleName.of_ident id) env in - Env.find_parameter_identifier env id + | None -> Identifier.Mk.parameter (parent, Odoc_model.Names.ModuleName.make_std "_"), env + | Some id -> let env = Env.add_parameter parent id (ModuleName.of_ident id) env in + Env.find_parameter_identifier env id, env in let arg = Cmti.read_module_type env (id :> Identifier.Signature.t) label_parent arg in - Named { id; expr=arg } + Named { id; expr=arg }, env in let res = read_module_expr env (Identifier.Mk.result parent) label_parent res in Functor (f_parameter, res) #else | Tmod_functor(id, _, arg, res) -> - let () = Env.add_parameter parent id (ModuleName.of_ident id) env in + let new_env = Env.add_parameter parent id (ModuleName.of_ident id) env in let f_parameter = match arg with | None -> FunctorParameter.Unit | Some arg -> - let id = Env.find_parameter_identifier env id in + let id = Env.find_parameter_identifier new_env id in let arg = Cmti.read_module_type env (id :> Identifier.Signature.t) label_parent arg in Named { FunctorParameter. id; expr = arg; } in - let res = read_module_expr env (Identifier.Mk.result parent) label_parent res in + let res = read_module_expr new_env (Identifier.Mk.result parent) label_parent res in Functor(f_parameter, res) #endif | Tmod_apply _ -> @@ -577,7 +576,7 @@ and read_structure : 'tags. 'tags Odoc_model.Semantics.handle_internal_tags -> _ -> _ -> _ -> _ * 'tags = fun internal_tags env parent str -> - let () = Env.add_structure_tree_items parent str env in + let env = Env.add_structure_tree_items parent str env in let items, (doc, doc_post), tags = let classify item = match item.str_desc with diff --git a/src/loader/cmti.ml b/src/loader/cmti.ml index 4fc2228094..80ed044dd8 100644 --- a/src/loader/cmti.ml +++ b/src/loader/cmti.ml @@ -517,12 +517,12 @@ and read_module_type env parent label_parent mty = match parameter with | Unit -> FunctorParameter.Unit, env | Named (id_opt, _, arg) -> - let id = + let id, env = match id_opt with - | None -> Identifier.Mk.parameter (parent, ModuleName.make_std "_") + | None -> Identifier.Mk.parameter (parent, ModuleName.make_std "_"), env | Some id -> - let () = Env.add_parameter parent id (ModuleName.of_ident id) env in - Env.find_parameter_identifier env id + let env = Env.add_parameter parent id (ModuleName.of_ident id) env in + Env.find_parameter_identifier env id, env in let arg = read_module_type env (id :> Identifier.Signature.t) label_parent arg in Named { id; expr = arg; }, env @@ -531,16 +531,16 @@ and read_module_type env parent label_parent mty = Functor (f_parameter, res) #else | Tmty_functor(id, _, arg, res) -> - let () = Env.add_parameter parent id (ModuleName.of_ident id) env in + let new_env = Env.add_parameter parent id (ModuleName.of_ident id) env in let f_parameter = match arg with | None -> Odoc_model.Lang.FunctorParameter.Unit | Some arg -> - let id = Ident_env.find_parameter_identifier env id in + let id = Ident_env.find_parameter_identifier new_env id in let arg = read_module_type env (id :> Identifier.Signature.t) label_parent arg in Named { FunctorParameter. id; expr = arg } in - let res = read_module_type () (Identifier.Mk.result parent) label_parent res in + let res = read_module_type new_env (Identifier.Mk.result parent) label_parent res in Functor( f_parameter, res) #endif | Tmty_with(body, subs) -> ( @@ -772,7 +772,7 @@ and read_signature : 'tags. 'tags Odoc_model.Semantics.handle_internal_tags -> _ -> _ -> _ -> _ * 'tags = fun internal_tags env parent sg -> - let () = Env.add_signature_tree_items parent sg env in + let env = Env.add_signature_tree_items parent sg env in let items, (doc, doc_post), tags = let classify item = match item.sig_desc with diff --git a/src/loader/ident_env.cppo.ml b/src/loader/ident_env.cppo.ml index 32ce6b797d..83e61520e9 100644 --- a/src/loader/ident_env.cppo.ml +++ b/src/loader/ident_env.cppo.ml @@ -29,42 +29,36 @@ module LocHashtbl = Hashtbl.Make(struct let hash = Hashtbl.hash end) -module IdentHashtbl = Hashtbl.Make(struct - type t = Ident.t - let equal l1 l2 = l1 = l2 - let hash = Hashtbl.hash - end) - type t = - { modules : Id.Module.t IdentHashtbl.t; - parameters : Id.FunctorParameter.t IdentHashtbl.t; - module_paths : P.Module.t IdentHashtbl.t; - module_types : Id.ModuleType.t IdentHashtbl.t; - types : Id.DataType.t IdentHashtbl.t; - exceptions: Id.Exception.t IdentHashtbl.t; - extensions: Id.Extension.t IdentHashtbl.t; - constructors: Id.Constructor.t IdentHashtbl.t; - values: Id.Value.t IdentHashtbl.t; - classes : Id.Class.t IdentHashtbl.t; - class_types : Id.ClassType.t IdentHashtbl.t; + { modules : Id.Module.t Ident.tbl; + parameters : Id.FunctorParameter.t Ident.tbl; + module_paths : P.Module.t Ident.tbl; + module_types : Id.ModuleType.t Ident.tbl; + types : Id.DataType.t Ident.tbl; + exceptions: Id.Exception.t Ident.tbl; + extensions: Id.Extension.t Ident.tbl; + constructors: Id.Constructor.t Ident.tbl; + values: Id.Value.t Ident.tbl; + classes : Id.Class.t Ident.tbl; + class_types : Id.ClassType.t Ident.tbl; loc_to_ident : Id.t LocHashtbl.t; - hidden : unit IdentHashtbl.t; (* we use term hidden to mean shadowed and idents_in_doc_off_mode items*) + hidden : Ident.t list; (* we use term hidden to mean shadowed and idents_in_doc_off_mode items*) } let empty () = - { modules = IdentHashtbl.create 10; - parameters = IdentHashtbl.create 10; - module_paths = IdentHashtbl.create 10; - module_types = IdentHashtbl.create 10; - types = IdentHashtbl.create 10; - exceptions = IdentHashtbl.create 10; - constructors = IdentHashtbl.create 10; - extensions = IdentHashtbl.create 10; - values = IdentHashtbl.create 10; - classes = IdentHashtbl.create 10; - class_types = IdentHashtbl.create 10; + { modules = Ident.empty; + parameters = Ident.empty; + module_paths = Ident.empty; + module_types = Ident.empty; + types = Ident.empty; + exceptions = Ident.empty; + constructors = Ident.empty; + extensions = Ident.empty; + values = Ident.empty; + classes = Ident.empty; + class_types = Ident.empty; loc_to_ident = LocHashtbl.create 100; - hidden = IdentHashtbl.create 100; + hidden = []; } (* The boolean is an override for whether it should be hidden - true only for @@ -487,84 +481,84 @@ let class_name_exists name items = let class_type_name_exists name items = List.exists (function | `ClassType (id',_,_,_,_) when Ident.name id' = name -> true | _ -> false) items -let add_items : Id.Signature.t -> item list -> t -> unit = fun parent items env -> +let add_items : Id.Signature.t -> item list -> t -> t = fun parent items env -> let open Odoc_model.Paths.Identifier in let rec inner items env = match items with | `Type (t, is_hidden_item, loc) :: rest -> let name = Ident.name t in let is_hidden = is_hidden_item || type_name_exists name rest in - let identifier = + let identifier, hidden = if is_hidden - then (IdentHashtbl.add env.hidden t (); Mk.type_(parent, TypeName.internal_of_string name)) - else Mk.type_(parent, TypeName.make_std name) + then Mk.type_(parent, TypeName.internal_of_string name), t :: env.hidden + else Mk.type_(parent, TypeName.make_std name), env.hidden in - let () = IdentHashtbl.add env.types t identifier in + let types = Ident.add t identifier env.types in (match loc with | Some l -> LocHashtbl.add env.loc_to_ident l (identifier :> Id.any) | _ -> ()); - inner rest env + inner rest { env with types; hidden } | `Constructor (t, t_parent, loc) :: rest -> let name = Ident.name t in let identifier = - let parent = IdentHashtbl.find env.types t_parent in + let parent = Ident.find_same t_parent env.types in Mk.constructor(parent, ConstructorName.make_std name) in - let () = IdentHashtbl.add env.constructors t identifier in + let constructors = Ident.add t identifier env.constructors in (match loc with | Some l -> LocHashtbl.add env.loc_to_ident l (identifier :> Id.any) | _ -> ()); - inner rest env + inner rest { env with constructors } | `Exception (t, loc) :: rest -> let name = Ident.name t in let identifier = Mk.exception_(parent, ExceptionName.make_std name) in (match loc with | Some l -> LocHashtbl.add env.loc_to_ident l (identifier :> Id.any) | _ -> ()); - let () = IdentHashtbl.add env.exceptions t identifier in - inner rest env + let exceptions = Ident.add t identifier env.exceptions in + inner rest {env with exceptions } | `Extension (t, loc) :: rest -> let name = Ident.name t in let identifier = Mk.extension(parent, ExtensionName.make_std name) in (match loc with | Some l -> LocHashtbl.add env.loc_to_ident l (identifier :> Id.any) | _ -> ()); - let () = IdentHashtbl.add env.extensions t identifier in - inner rest env + let extensions = Ident.add t identifier env.extensions in + inner rest {env with extensions } | `Value (t, is_hidden_item, loc) :: rest -> let name = Ident.name t in let is_hidden = is_hidden_item || value_name_exists name rest in - let identifier = + let identifier, hidden = if is_hidden - then (IdentHashtbl.add env.hidden t (); Mk.value(parent, ValueName.internal_of_string name)) - else Mk.value(parent, ValueName.make_std name) + then Mk.value(parent, ValueName.internal_of_string name), t :: env.hidden + else Mk.value(parent, ValueName.make_std name), env.hidden in - let () = IdentHashtbl.add env.values t identifier in + let values = Ident.add t identifier env.values in (match loc with | Some l -> LocHashtbl.add env.loc_to_ident l (identifier :> Id.any) | _ -> ()); - inner rest env + inner rest { env with values; hidden } | `ModuleType (t, is_hidden_item, loc) :: rest -> let name = Ident.name t in let is_hidden = is_hidden_item || module_type_name_exists name rest in - let identifier = + let identifier, hidden = if is_hidden - then (IdentHashtbl.add env.hidden t (); Mk.module_type(parent, ModuleTypeName.internal_of_string name)) - else Mk.module_type(parent, ModuleTypeName.make_std name) + then Mk.module_type(parent, ModuleTypeName.internal_of_string name), t :: env.hidden + else Mk.module_type(parent, ModuleTypeName.make_std name), env.hidden in - let () = IdentHashtbl.add env.module_types t identifier in + let module_types = Ident.add t identifier env.module_types in (match loc with | Some l -> LocHashtbl.add env.loc_to_ident l (identifier :> Id.any) | _ -> ()); - inner rest env + inner rest { env with module_types; hidden } | `Module (t, is_hidden_item, loc) :: rest -> let name = Ident.name t in let double_underscore = Odoc_model.Names.contains_double_underscore name in let is_hidden = is_hidden_item || module_name_exists name rest || double_underscore in - let identifier = - if is_hidden - then (IdentHashtbl.add env.hidden t (); Mk.module_(parent, ModuleName.internal_of_string name)) - else Mk.module_(parent, ModuleName.make_std name) + let identifier, hidden = + if is_hidden + then Mk.module_(parent, ModuleName.internal_of_string name), t :: env.hidden + else Mk.module_(parent, ModuleName.make_std name), env.hidden in let path = `Identifier(identifier, is_hidden) in - let () = IdentHashtbl.add env.modules t identifier in - let () = IdentHashtbl.add env.module_paths t path in + let modules = Ident.add t identifier env.modules in + let module_paths = Ident.add t path env.module_paths in (match loc with | Some l -> LocHashtbl.add env.loc_to_ident l (identifier :> Id.any) | _ -> ()); - inner rest env + inner rest { env with modules; module_paths; hidden } | `Class (t,t2,t3,t4, is_hidden_item, loc) :: rest -> let name = Ident.name t in @@ -573,21 +567,19 @@ let add_items : Id.Signature.t -> item list -> t -> unit = fun parent items env | None -> [t;t2;t3] | Some t4 -> [t;t2;t3;t4] in - let identifier = + let identifier, hidden = if is_hidden - then ( - List.iter (fun t -> IdentHashtbl.add env.hidden t ()) class_types; - Mk.class_(parent, ClassName.internal_of_string name)) - else Mk.class_(parent, ClassName.make_std name) + then Mk.class_(parent, ClassName.internal_of_string name), class_types @ env.hidden + else Mk.class_(parent, ClassName.make_std name), env.hidden in - let () = - List.fold_right (fun id () -> IdentHashtbl.add env.classes id identifier) - class_types () in + let classes = + List.fold_right (fun id classes -> Ident.add id identifier classes) + class_types env.classes in (match loc with | Some l -> LocHashtbl.add env.loc_to_ident l (identifier :> Id.any) | _ -> ()); - inner rest env + inner rest { env with classes; hidden } | `ClassType (t,t2,t3, is_hidden_item, loc) :: rest -> let name = Ident.name t in @@ -596,20 +588,18 @@ let add_items : Id.Signature.t -> item list -> t -> unit = fun parent items env | None -> [t;t2] | Some t3 -> [t;t2;t3] in - let identifier = + let identifier, hidden = if is_hidden - then ( - List.iter (fun t -> IdentHashtbl.add env.hidden t ()) class_types; - Mk.class_type(parent, ClassTypeName.internal_of_string name)) - else Mk.class_type(parent, ClassTypeName.make_std name) + then Mk.class_type(parent, ClassTypeName.internal_of_string name), class_types @ env.hidden + else Mk.class_type(parent, ClassTypeName.make_std name), env.hidden in - let () = - List.fold_right (fun id () -> IdentHashtbl.add env.class_types id identifier) - class_types () in + let class_types = + List.fold_right (fun id class_types -> Ident.add id identifier class_types) + class_types env.class_types in (match loc with | Some l -> LocHashtbl.add env.loc_to_ident l (identifier :> Id.any) | _ -> ()); - inner rest env + inner rest { env with class_types; hidden } - | [] -> () + | [] -> env in inner items env let identifier_of_loc : t -> Location.t -> Odoc_model.Paths.Identifier.t option = fun env loc -> @@ -618,17 +608,17 @@ let identifier_of_loc : t -> Location.t -> Odoc_model.Paths.Identifier.t option let iter_located_identifier : t -> (Location.t -> Odoc_model.Paths.Identifier.t -> unit) -> unit = fun env f -> LocHashtbl.iter f env.loc_to_ident -let add_signature_tree_items : Paths.Identifier.Signature.t -> Typedtree.signature -> t -> unit = +let add_signature_tree_items : Paths.Identifier.Signature.t -> Typedtree.signature -> t -> t = fun parent sg env -> let items = extract_signature_tree_items false sg.sig_items |> flatten_includes in add_items parent items env -let add_structure_tree_items : Paths.Identifier.Signature.t -> Typedtree.structure -> t -> unit = +let add_structure_tree_items : Paths.Identifier.Signature.t -> Typedtree.structure -> t -> t = fun parent sg env -> let items = extract_structure_tree_items false sg.str_items |> flatten_includes in add_items parent items env -let handle_signature_type_items : Paths.Identifier.Signature.t -> Compat.signature -> t -> unit = +let handle_signature_type_items : Paths.Identifier.Signature.t -> Compat.signature -> t -> t = fun parent sg env -> let items = extract_signature_type_items sg in add_items parent items env @@ -637,47 +627,47 @@ let add_parameter parent id name env = let hidden = ModuleName.is_hidden name in let oid = Odoc_model.Paths.Identifier.Mk.parameter(parent, name) in let path = `Identifier (oid, hidden) in - let () = IdentHashtbl.add env.module_paths id path in - let () = IdentHashtbl.add env.modules id oid in - let () = IdentHashtbl.add env.parameters id oid in - () + let module_paths = Ident.add id path env.module_paths in + let modules = Ident.add id oid env.modules in + let parameters = Ident.add id oid env.parameters in + { env with module_paths; modules; parameters } let find_module env id = - IdentHashtbl.find env.module_paths id + Ident.find_same id env.module_paths let find_module_identifier env id = - IdentHashtbl.find env.modules id + Ident.find_same id env.modules let find_parameter_identifier env id = - IdentHashtbl.find env.parameters id + Ident.find_same id env.parameters let find_module_type env id = - IdentHashtbl.find env.module_types id + Ident.find_same id env.module_types let find_type_identifier env id = - IdentHashtbl.find env.types id + Ident.find_same id env.types let find_constructor_identifier env id = - IdentHashtbl.find env.constructors id + Ident.find_same id env.constructors let find_exception_identifier env id = - IdentHashtbl.find env.exceptions id + Ident.find_same id env.exceptions let find_extension_identifier env id = - IdentHashtbl.find env.extensions id + Ident.find_same id env.extensions let find_value_identifier env id = - IdentHashtbl.find env.values id + Ident.find_same id env.values let find_type env id = try - (IdentHashtbl.find env.types id :> Id.Path.Type.t) + (Ident.find_same id env.types :> Id.Path.Type.t) with Not_found -> try - (IdentHashtbl.find env.classes id :> Id.Path.Type.t) + (Ident.find_same id env.classes :> Id.Path.Type.t) with Not_found -> try - (IdentHashtbl.find env.class_types id :> Id.Path.Type.t) + (Ident.find_same id env.class_types :> Id.Path.Type.t) with Not_found -> if List.mem id builtin_idents then match core_type_identifier (Ident.name id) with @@ -687,19 +677,19 @@ let find_type env id = let find_class_type env id = try - (IdentHashtbl.find env.classes id :> Id.Path.ClassType.t) + (Ident.find_same id env.classes :> Id.Path.ClassType.t) with Not_found -> - (IdentHashtbl.find env.class_types id :> Id.Path.ClassType.t) + (Ident.find_same id env.class_types :> Id.Path.ClassType.t) let find_class_identifier env id = - IdentHashtbl.find env.classes id + Ident.find_same id env.classes let find_class_type_identifier env id = - IdentHashtbl.find env.class_types id + Ident.find_same id env.class_types let is_shadowed env id = - IdentHashtbl.mem env.hidden id + List.mem id env.hidden module Path = struct let read_module_ident env id = diff --git a/src/loader/ident_env.cppo.mli b/src/loader/ident_env.cppo.mli index c17f827bf3..b487ca2f81 100644 --- a/src/loader/ident_env.cppo.mli +++ b/src/loader/ident_env.cppo.mli @@ -21,16 +21,16 @@ type t val empty : unit -> t val add_parameter : - Paths.Identifier.Signature.t -> Ident.t -> Names.ModuleName.t -> t -> unit + Paths.Identifier.Signature.t -> Ident.t -> Names.ModuleName.t -> t -> t val handle_signature_type_items : - Paths.Identifier.Signature.t -> Compat.signature -> t -> unit + Paths.Identifier.Signature.t -> Compat.signature -> t -> t val add_signature_tree_items : - Paths.Identifier.Signature.t -> Typedtree.signature -> t -> unit + Paths.Identifier.Signature.t -> Typedtree.signature -> t -> t val add_structure_tree_items : - Paths.Identifier.Signature.t -> Typedtree.structure -> t -> unit + Paths.Identifier.Signature.t -> Typedtree.structure -> t -> t module Path : sig val read_module : t -> Path.t -> Paths.Path.Module.t diff --git a/src/loader/implementation.ml b/src/loader/implementation.ml index f062bdf401..7ac6c36741 100644 --- a/src/loader/implementation.ml +++ b/src/loader/implementation.ml @@ -21,12 +21,12 @@ module Env = struct open Odoc_model.Paths let rec structure env parent str = - let () = Ident_env.add_structure_tree_items parent str env in - List.iter (structure_item env parent) str.str_items + let env' = Ident_env.add_structure_tree_items parent str env in + List.iter (structure_item env' parent) str.str_items and signature env parent sg = - let () = Ident_env.add_signature_tree_items parent sg env in - List.iter (signature_item env parent) sg.sig_items + let env' = Ident_env.add_signature_tree_items parent sg env in + List.iter (signature_item env' parent) sg.sig_items and signature_item env parent item = match item.sig_desc with @@ -95,19 +95,20 @@ module Env = struct | Tmod_structure str -> structure env parent str | Tmod_functor (parameter, res) -> let open Odoc_model.Names in - let () = + let env = match parameter with - | Unit -> () + | Unit -> env | Named (id_opt, _, arg) -> ( match id_opt with | Some id -> - let () = + let env = Ident_env.add_parameter parent id (ModuleName.of_ident id) env in let id = Ident_env.find_module_identifier env id in - module_type env (id :> Identifier.Signature.t) arg - | None -> ()) + module_type env (id :> Identifier.Signature.t) arg; + env + | None -> env) in module_expr env (Odoc_model.Paths.Identifier.Mk.result parent) res | Tmod_constraint (me, _, constr, _) -> From e400590ca3dc621d7a926699a27e00d8f72811af Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Wed, 13 Dec 2023 20:38:07 +0100 Subject: [PATCH 38/41] Count occurrences: fix change entry Signed-off-by: Paul-Elliot --- CHANGES.md | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 7ab0c10c53..9ab5191c07 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,5 +1,11 @@ # (unreleased) +### Added + +- Improve jump to implementation in rendered source code, and add a + `count-occurrences` flag and command to count occurrences of every identifiers + (@panglesd, #976) + # 2.4.0 ### Added @@ -11,8 +17,6 @@ - Display 'private' keyword for private type extensions (@gpetiot, #1019) - Allow to omit parent type in constructor reference (@panglesd, @EmileTrotignon, #933) -- Add jumps to documentation in rendered source code, and a `count-occurrences` - flag and command to count occurrences of every identifiers (@panglesd, #976) ### Fixed From d1462a6423163249382dbcc20f9f17d3458f8453 Mon Sep 17 00:00:00 2001 From: panglesd Date: Thu, 14 Dec 2023 11:25:11 +0100 Subject: [PATCH 39/41] Occurrence: compatibility Co-authored-by: Jules Aguillon --- src/odoc/occurrences.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/odoc/occurrences.ml b/src/odoc/occurrences.ml index 711e46c977..6d912e68ff 100644 --- a/src/odoc/occurrences.ml +++ b/src/odoc/occurrences.ml @@ -46,7 +46,7 @@ end = struct let rec add ?(kind = `Indirect) id = let incr htbl id = let { direct; indirect; sub } = - match H.find_opt htbl id with Some n -> n | None -> v_item () + try H.find htbl id with Not_found -> v_item () in let direct, indirect = match kind with From c8221c01491735aac31c36a03946de7978e65984 Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Thu, 14 Dec 2023 11:29:02 +0100 Subject: [PATCH 40/41] Occurrence: compatibility Signed-off-by: Paul-Elliot --- src/odoc/occurrences.ml | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/src/odoc/occurrences.ml b/src/odoc/occurrences.ml index 6d912e68ff..1d502628f6 100644 --- a/src/odoc/occurrences.ml +++ b/src/odoc/occurrences.ml @@ -1,11 +1,12 @@ open Or_error let handle_file file ~f = - Odoc_file.load file - |> Result.map @@ fun unit' -> - match unit' with - | { Odoc_file.content = Unit_content unit; _ } -> Some (f unit) - | _ -> None + Odoc_file.load file |> function + | Error _ as e -> e + | Ok unit' -> ( + match unit' with + | { Odoc_file.content = Unit_content unit; _ } -> Ok (Some (f unit)) + | _ -> Ok None) let fold_dirs ~dirs ~f ~init = dirs From 975bf16a5ce08b047df9e3be950df211e833dc3c Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Thu, 14 Dec 2023 14:54:04 +0100 Subject: [PATCH 41/41] Compat with 4.02 Signed-off-by: Paul-Elliot --- src/loader/cmt.ml | 2 +- src/loader/cmti.ml | 2 +- src/odoc/bin/main.ml | 3 ++- src/odoc/occurrences.ml | 7 ++++--- 4 files changed, 8 insertions(+), 6 deletions(-) diff --git a/src/loader/cmt.ml b/src/loader/cmt.ml index 3dafa060aa..582b03273f 100644 --- a/src/loader/cmt.ml +++ b/src/loader/cmt.ml @@ -453,7 +453,7 @@ and read_module_binding env parent mb = | _, _ -> false #else match canonical with - | None -> Odoc_model.Root.contains_double_underscore (Ident.name mb.mb_id) + | None -> Odoc_model.Names.contains_double_underscore (Ident.name mb.mb_id) | _ -> false #endif in diff --git a/src/loader/cmti.ml b/src/loader/cmti.ml index 80ed044dd8..1fcc6bb890 100644 --- a/src/loader/cmti.ml +++ b/src/loader/cmti.ml @@ -632,7 +632,7 @@ and read_module_declaration env parent md = | _,_ -> false #else match canonical with - | None -> Odoc_model.Root.contains_double_underscore (Ident.name md.md_id) + | None -> Odoc_model.Names.contains_double_underscore (Ident.name md.md_id) | _ -> false #endif in diff --git a/src/odoc/bin/main.ml b/src/odoc/bin/main.ml index f2e3ffe13c..03024d77b2 100644 --- a/src/odoc/bin/main.ml +++ b/src/odoc/bin/main.ml @@ -1111,6 +1111,8 @@ module Targets = struct end module Occurrences = struct + open Or_error + let has_occurrences_prefix input = input |> Fs.File.basename |> Fs.File.to_string |> Astring.String.is_prefix ~affix:"occurrences-" @@ -1122,7 +1124,6 @@ module Occurrences = struct else if not (has_occurrences_prefix f) then Error (`Msg "Output file must be prefixed with 'occurrences-'.") else Ok f - open Or_error module Count = struct let count directories dst warnings_options include_hidden = dst_of_string dst >>= fun dst -> diff --git a/src/odoc/occurrences.ml b/src/odoc/occurrences.ml index 1d502628f6..04ef7c53ae 100644 --- a/src/odoc/occurrences.ml +++ b/src/odoc/occurrences.ml @@ -87,9 +87,10 @@ end = struct () let rec get t id = - let ( >>= ) = Option.bind in let do_ parent = - get t (parent :> key) >>= fun { sub; _ } -> H.find_opt sub id + get t (parent :> key) |> function + | None -> None + | Some { sub; _ } -> ( try Some (H.find sub id) with Not_found -> None) in match id.iv with | `InstanceVariable (parent, _) -> do_ parent @@ -106,7 +107,7 @@ end = struct | `Class (parent, _) -> do_ parent | `Value (parent, _) -> do_ parent | `ClassType (parent, _) -> do_ parent - | `Root _ -> H.find_opt t id + | `Root _ -> ( try Some (H.find t id) with Not_found -> None) | `SourcePage _ | `Page _ | `LeafPage _ | `CoreType _ | `SourceLocation _ | `CoreException _ | `Label _ | `SourceLocationMod _ | `Result _ | `AssetFile _ | `SourceDir _ | `SourceLocationInternal _ ->