From d95bafca4d212d3dde23c77821c3956ffb2861e0 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Mon, 17 May 2021 19:43:17 +0200 Subject: [PATCH 1/3] Add a failing testcase for references to shadowed items The output for 'shadowed.mli' is right but the warnings shouldn't occur. The output for 'shadowed_through_open.mli' is wrong. --- test/xref2/references_scope.t/run.t | 27 ++++++++++++++++- test/xref2/references_scope.t/shadowed.mli | 16 ++++++++++ .../shadowed_through_open.mli | 29 +++++++++++++++++++ 3 files changed, 71 insertions(+), 1 deletion(-) create mode 100644 test/xref2/references_scope.t/shadowed.mli create mode 100644 test/xref2/references_scope.t/shadowed_through_open.mli diff --git a/test/xref2/references_scope.t/run.t b/test/xref2/references_scope.t/run.t index 43992b0ee9..7a1504fd2f 100644 --- a/test/xref2/references_scope.t/run.t +++ b/test/xref2/references_scope.t/run.t @@ -1,6 +1,14 @@ # Testing the scope of references - $ compile a.mli + $ compile a.mli shadowed.mli shadowed_through_open.mli + File "shadowed.mli", line 9, characters 31-53: + Reference to 't' is ambiguous. Please specify its kind: type-t, type-t. + File "shadowed.mli", line 15, characters 31-52: + Reference to 't' is ambiguous. Please specify its kind: type-t, type-t. + File "shadowed_through_open.mli", line 24, characters 6-27: + Reference to 't' is ambiguous. Please specify its kind: type-t, type-t. + File "shadowed_through_open.mli", line 28, characters 6-26: + Reference to 't' is ambiguous. Please specify its kind: type-t, type-t. $ jq_scan_references() { jq -c '.. | .["`Reference"]? | select(.)'; } @@ -12,3 +20,20 @@ The references from a.mli, see the attached text to recognize them: [{"`Root":["C","`TUnknown"]},[{"`Word":"Through-open"}]] [{"`Resolved":{"`Module":[{"`Identifier":{"`Module":[{"`Root":[{"`RootPage":"test"},"A"]},"B"]}},"C"]}},[{"`Word":"Doc-relative"}]] [{"`Resolved":{"`Module":[{"`Module":[{"`Identifier":{"`Root":[{"`RootPage":"test"},"A"]}},"B"]},"C"]}},[{"`Word":"Doc-absolute"}]] + +References should be resolved after the whole signature has been added to the +scope. Both "Before-shadowed" and "After-shadowed" should resolve to [M.t]. + + $ odoc_print shadowed.odocl | jq_scan_references + [{"`Resolved":{"`Identifier":{"`Type":[{"`Module":[{"`Root":[{"`RootPage":"test"},"Shadowed"]},"M"]},"t"]}}},[{"`Word":"Before-shadowed"}]] + [{"`Resolved":{"`Type":[{"`Identifier":{"`Root":[{"`RootPage":"test"},"Shadowed"]}},"t"]}},[]] + [{"`Resolved":{"`Identifier":{"`Type":[{"`Module":[{"`Root":[{"`RootPage":"test"},"Shadowed"]},"M"]},"t"]}}},[{"`Word":"After-shadowed"}]] + +"Before-open" and "After-open" should resolve to to [T.t]. +"Before-include" and "After-include" should resolve to [Through_include.t]. + + $ odoc_print shadowed_through_open.odocl | jq_scan_references + [{"`Resolved":{"`Identifier":{"`Type":[{"`Root":[{"`RootPage":"test"},"Shadowed_through_open"]},"t"]}}},[{"`Word":"Before-open"}]] + [{"`Resolved":{"`Identifier":{"`Type":[{"`Root":[{"`RootPage":"test"},"Shadowed_through_open"]},"t"]}}},[{"`Word":"After-open"}]] + [{"`Resolved":{"`Identifier":{"`Type":[{"`Module":[{"`Root":[{"`RootPage":"test"},"Shadowed_through_open"]},"Through_include"]},"t"]}}},[{"`Word":"Before-include"}]] + [{"`Resolved":{"`Identifier":{"`Type":[{"`Module":[{"`Root":[{"`RootPage":"test"},"Shadowed_through_open"]},"Through_include"]},"t"]}}},[{"`Word":"After-include"}]] diff --git a/test/xref2/references_scope.t/shadowed.mli b/test/xref2/references_scope.t/shadowed.mli new file mode 100644 index 0000000000..1492d5ca30 --- /dev/null +++ b/test/xref2/references_scope.t/shadowed.mli @@ -0,0 +1,16 @@ +(** Reference to a shadowed module. References should be resolved after the + whole signature has been added to the scope. *) + +type t + +module M : sig + (** . *) + + (** Should resolve to [M.t]: {{!t} Before-shadowed}. + + Of course, it's possible to reference {!Shadowed.t}. *) + + type t + + (** Should resolve to [M.t]: {{!t} After-shadowed} *) +end diff --git a/test/xref2/references_scope.t/shadowed_through_open.mli b/test/xref2/references_scope.t/shadowed_through_open.mli new file mode 100644 index 0000000000..b2357f689a --- /dev/null +++ b/test/xref2/references_scope.t/shadowed_through_open.mli @@ -0,0 +1,29 @@ +module T : sig + type t +end + +module type T' = sig + type t +end + +type t + +module Through_open : sig + (** . *) + + (** {{!t} Before-open} *) + + open T + + (** {{!t} After-open} *) +end + +module Through_include : sig + (** . *) + + (** {{!t} Before-include} *) + + include T' + + (** {{!t} After-include} *) +end From 1a5eb681fb985a4df32793d72a8899e2c0231752 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Fri, 21 May 2021 15:08:59 +0200 Subject: [PATCH 2/3] Implement shadowing in sub-modules Before this patch, Odoc_xref2.Env doesn't implement shadowing and several elements of the same kind with the same name could be represented. --- src/xref2/env.ml | 245 +++++++----------- src/xref2/env.mli | 74 ++---- src/xref2/ref_tools.ml | 70 ++--- test/xref2/references_scope.t/run.t | 8 - test/xref2/v407_and_above/labels.t/run.t | 2 - .../v408_and_above/github_issue_587.t/run.t | 20 ++ 6 files changed, 175 insertions(+), 244 deletions(-) diff --git a/src/xref2/env.ml b/src/xref2/env.ml index ccecaa97e5..e156b61a4f 100644 --- a/src/xref2/env.ml +++ b/src/xref2/env.ml @@ -1,6 +1,7 @@ (* A bunch of association lists. Let's hashtbl them up later *) open Odoc_model open Odoc_model.Names +open Odoc_model.Paths type lookup_unit_result = | Forward_reference @@ -20,7 +21,11 @@ type resolver = { lookup_page : string -> lookup_page_result; } -let unique_id = ref 0 +let unique_id = + let i = ref 0 in + fun () -> + incr i; + !i type lookup_type = | Module of Odoc_model.Paths.Identifier.Path.Module.t @@ -61,10 +66,61 @@ type recorder = { mutable lookups : lookup_type list } module Maps = Odoc_model.Paths.Identifier.Maps module StringMap = Map.Make (String) +type kind = + | Kind_Module + | Kind_ModuleType + | Kind_Type + | Kind_Value + | Kind_Label + | Kind_Class + | Kind_ClassType + | Kind_External + | Kind_Constructor + | Kind_Exception + | Kind_Extension + | Kind_Field + +module Elements : sig + type t + + val empty : t + + val add : kind -> [< Identifier.t ] -> [< Component.Element.any ] -> t -> t + + val find_by_name : + (Component.Element.any -> 'b option) -> string -> t -> 'b list + + val fold : ('a -> kind * Component.Element.any -> 'a) -> 'a -> t -> 'a +end = struct + type t = (kind * Component.Element.any) list StringMap.t + + let empty = StringMap.empty + + let add kind identifier comp t = + let name = Identifier.name identifier in + let v = (kind, (comp :> Component.Element.any)) in + try + let tl = StringMap.find name t in + let tl = + let not_dup (kind', _) = kind' <> kind in + if List.for_all not_dup tl then tl else List.filter not_dup tl + in + StringMap.add name (v :: tl) t + with Not_found -> StringMap.add name [ v ] t + + let find_by_name f name t = + let filter acc (_, e) = match f e with Some e -> e :: acc | None -> acc in + let found = try StringMap.find name t with Not_found -> [] in + List.fold_left filter [] found |> List.rev + + let fold f acc t = + StringMap.fold (fun _ e acc -> List.fold_left f acc e) t acc +end + type t = { id : int; titles : Odoc_model.Comment.link_content Maps.Label.t; - elts : Component.Element.any list StringMap.t; + elts : Elements.t; resolver : resolver option; recorder : recorder option; fragmentroot : (int * Component.Signature.t) option; @@ -96,45 +152,29 @@ let empty = { id = 0; titles = Maps.Label.empty; - elts = StringMap.empty; + elts = Elements.empty; resolver = None; recorder = None; fragmentroot = None; } let add_fragment_root sg env = - let id = - incr unique_id; - !unique_id - in + let id = unique_id () in { env with fragmentroot = Some (id, sg); id } -let add_to_elts name v elts = - try - let cur = StringMap.find name elts in - StringMap.add name (v :: cur) elts - with Not_found -> StringMap.add name [ v ] elts - -let add_label identifier env = +(** Implements most [add_*] functions. *) +let add_to_elts kind identifier component env = { env with - id = - (incr unique_id; - !unique_id); - elts = - add_to_elts - (Odoc_model.Paths.Identifier.name identifier) - (`Label identifier) env.elts; + id = unique_id (); + elts = Elements.add kind identifier component env.elts; } +let add_label identifier env = + add_to_elts Kind_Label identifier (`Label identifier) env + let add_label_title label elts env = - { - env with - id = - (incr unique_id; - !unique_id); - titles = Maps.Label.add label elts env.titles; - } + { env with id = unique_id (); titles = Maps.Label.add label elts env.titles } let add_docs (docs : Odoc_model.Comment.docs) env = List.fold_right @@ -163,18 +203,7 @@ let add_cdocs p (docs : Component.CComment.docs) env = docs env let add_module identifier m docs env = - { - env with - id = - (incr unique_id; - (*Format.fprintf Format.err_formatter "unique_id=%d\n%!" !unique_id; *) - !unique_id); - elts = - add_to_elts - (Odoc_model.Paths.Identifier.name identifier) - (`Module (identifier, m)) - env.elts; - } + add_to_elts Kind_Module identifier (`Module (identifier, m)) env |> add_cdocs identifier docs let add_type identifier t env = @@ -184,20 +213,14 @@ let add_type identifier t env = let ident = `Constructor (identifier, ConstructorName.make_std cons.name) in - add_to_elts - (Odoc_model.Paths.Identifier.name ident) - (`Constructor (ident, cons)) - elts + Elements.add Kind_Constructor ident (`Constructor (ident, cons)) elts and add_field elts (field : TypeDecl.Field.t) = let ident = `Field ( (identifier :> Odoc_model.Paths.Identifier.Parent.t), FieldName.make_std field.name ) in - add_to_elts - (Odoc_model.Paths.Identifier.name ident) - (`Field (ident, field)) - elts + Elements.add Kind_Field ident (`Field (ident, field)) elts in let open TypeDecl in match t.representation with @@ -210,87 +233,29 @@ let add_type identifier t env = | Some Extensible | None -> (cs, []) in let elts, docs = open_typedecl env.elts in - { - env with - id = - (incr unique_id; - !unique_id); - elts = - add_to_elts - (Odoc_model.Paths.Identifier.name identifier) - (`Type (identifier, t)) - elts; - } - |> List.fold_right (add_cdocs identifier) (t.doc :: docs) + let elts = Elements.add Kind_Type identifier (`Type (identifier, t)) elts in + { env with id = unique_id (); elts } + |> add_cdocs identifier t.doc + |> List.fold_right (add_cdocs identifier) docs let add_module_type identifier t env = - { - env with - id = - (incr unique_id; - !unique_id); - elts = - add_to_elts - (Odoc_model.Paths.Identifier.name identifier) - (`ModuleType (identifier, t)) - env.elts; - } + add_to_elts Kind_ModuleType identifier (`ModuleType (identifier, t)) env |> add_cdocs identifier t.doc let add_value identifier t env = - { - env with - id = - (incr unique_id; - !unique_id); - elts = - add_to_elts - (Odoc_model.Paths.Identifier.name identifier) - (`Value (identifier, t)) - env.elts; - } + add_to_elts Kind_Value identifier (`Value (identifier, t)) env |> add_cdocs identifier t.doc let add_external identifier t env = - { - env with - id = - (incr unique_id; - !unique_id); - elts = - add_to_elts - (Odoc_model.Paths.Identifier.name identifier) - (`External (identifier, t)) - env.elts; - } + add_to_elts Kind_External identifier (`External (identifier, t)) env |> add_cdocs identifier t.doc let add_class identifier t env = - { - env with - id = - (incr unique_id; - !unique_id); - elts = - add_to_elts - (Odoc_model.Paths.Identifier.name identifier) - (`Class (identifier, t)) - env.elts; - } + add_to_elts Kind_Class identifier (`Class (identifier, t)) env |> add_cdocs identifier t.doc let add_class_type identifier t env = - { - env with - id = - (incr unique_id; - !unique_id); - elts = - add_to_elts - (Odoc_model.Paths.Identifier.name identifier) - (`ClassType (identifier, t)) - env.elts; - } + add_to_elts Kind_ClassType identifier (`ClassType (identifier, t)) env |> add_cdocs identifier t.doc let add_method _identifier _t env = @@ -298,31 +263,11 @@ let add_method _identifier _t env = env let add_exception identifier e env = - { - env with - id = - (incr unique_id; - !unique_id); - elts = - add_to_elts - (Odoc_model.Paths.Identifier.name identifier) - (`Exception (identifier, e)) - env.elts; - } + add_to_elts Kind_Exception identifier (`Exception (identifier, e)) env |> add_cdocs identifier e.doc let add_extension_constructor identifier ec env = - { - env with - id = - (incr unique_id; - !unique_id); - elts = - add_to_elts - (Odoc_model.Paths.Identifier.name identifier) - (`Extension (identifier, ec)) - env.elts; - } + add_to_elts Kind_Extension identifier (`Extension (identifier, ec)) env |> add_cdocs identifier ec.doc let module_of_unit : Odoc_model.Lang.Compilation_unit.t -> Component.Module.t = @@ -394,15 +339,8 @@ let make_scope ?(root = fun _ _ -> None) (filter : _ -> ([< Component.Element.any ] as 'a) option) : 'a scope = { filter; root } -let lookup_by_name' scope name env = - let filter acc r = - match scope.filter r with Some r' -> r' :: acc | None -> acc - in - let found = try StringMap.find name env.elts with Not_found -> [] in - List.fold_left filter [] found |> List.rev - let lookup_by_name scope name env = - let record_lookup_results results = + let record_lookup_results env results = match env.recorder with | Some r -> List.iter @@ -413,18 +351,16 @@ let lookup_by_name scope name env = (results :> Component.Element.any list) | None -> () in - match lookup_by_name' scope name env with + match Elements.find_by_name scope.filter name env.elts with | [ x ] as results -> - record_lookup_results results; + record_lookup_results env results; Result.Ok x | x :: tl as results -> - record_lookup_results results; + record_lookup_results env results; Error (`Ambiguous (x, tl)) | [] -> ( match scope.root name env with Some x -> Ok x | None -> Error `Not_found) -open Odoc_model.Paths - let ident_of_element = function | `Module (id, _) -> (id :> Identifier.t) | `ModuleType (id, _) -> (id :> Identifier.t) @@ -455,7 +391,10 @@ let lookup_by_id (scope : 'a scope) id env : 'a option = | _ -> ()) | None -> () in - match disam_id id (lookup_by_name' scope (Identifier.name id) env) with + match + disam_id id + (Elements.find_by_name scope.filter (Identifier.name id) env.elts) + with | Some result as x -> record_lookup_result result; x @@ -725,8 +664,8 @@ let env_of_page page resolver = set_resolver initial_env resolver let modules_of env = - let f acc = function `Module (id, m) -> (id, m) :: acc | _ -> acc in - StringMap.fold (fun _ e acc -> List.fold_left f acc e) env.elts [] + let f acc = function _, `Module (id, m) -> (id, m) :: acc | _ -> acc in + Elements.fold f [] env.elts let verify_lookups env lookups = let bad_lookup = function diff --git a/src/xref2/env.mli b/src/xref2/env.mli index 686383b2b9..504593be0a 100644 --- a/src/xref2/env.mli +++ b/src/xref2/env.mli @@ -1,5 +1,7 @@ (* Env.mli *) +open Odoc_model.Paths + type lookup_unit_result = | Forward_reference | Found of Odoc_model.Lang.Compilation_unit.t @@ -8,10 +10,7 @@ type lookup_unit_result = type lookup_page_result = Odoc_model.Lang.Page.t option type root = - | Resolved of - (Odoc_model.Root.t - * Odoc_model.Paths.Identifier.Module.t - * Component.Module.t) + | Resolved of (Odoc_model.Root.t * Identifier.Module.t * Component.Module.t) | Forward type resolver = { @@ -21,10 +20,10 @@ type resolver = { } type lookup_type = - | Module of Odoc_model.Paths.Identifier.Path.Module.t - | ModuleType of Odoc_model.Paths.Identifier.ModuleType.t + | Module of Identifier.Path.Module.t + | ModuleType of Identifier.ModuleType.t | RootModule of string * [ `Forward | `Resolved of Digest.t ] option - | ModuleByName of string * Odoc_model.Paths.Identifier.Path.Module.t + | ModuleByName of string * Identifier.Path.Module.t | FragmentRoot of int val pp_lookup_type_list : Format.formatter -> lookup_type list -> unit @@ -44,69 +43,51 @@ val empty : t val add_fragment_root : Component.Signature.t -> t -> t val add_module : - Odoc_model.Paths.Identifier.Path.Module.t -> + Identifier.Path.Module.t -> Component.Module.t Component.Delayed.t -> Component.CComment.docs -> t -> t -val add_type : - Odoc_model.Paths.Identifier.Type.t -> Component.TypeDecl.t -> t -> t +val add_type : Identifier.Type.t -> Component.TypeDecl.t -> t -> t val add_module_type : - Odoc_model.Paths.Identifier.Path.ModuleType.t -> - Component.ModuleType.t -> - t -> - t + Identifier.Path.ModuleType.t -> Component.ModuleType.t -> t -> t -val add_value : - Odoc_model.Paths.Identifier.Value.t -> Component.Value.t -> t -> t +val add_value : Identifier.Value.t -> Component.Value.t -> t -> t -val add_external : - Odoc_model.Paths.Identifier.Value.t -> Component.External.t -> t -> t +val add_external : Identifier.Value.t -> Component.External.t -> t -> t -val add_label : Odoc_model.Paths.Identifier.Label.t -> t -> t +val add_label : Identifier.Label.t -> t -> t val add_label_title : - Odoc_model.Paths.Identifier.Label.t -> - Odoc_model.Comment.link_content -> - t -> - t + Identifier.Label.t -> Odoc_model.Comment.link_content -> t -> t -val add_class : - Odoc_model.Paths.Identifier.Class.t -> Component.Class.t -> t -> t +val add_class : Identifier.Class.t -> Component.Class.t -> t -> t -val add_class_type : - Odoc_model.Paths.Identifier.ClassType.t -> Component.ClassType.t -> t -> t +val add_class_type : Identifier.ClassType.t -> Component.ClassType.t -> t -> t -val add_exception : - Odoc_model.Paths.Identifier.Exception.t -> Component.Exception.t -> t -> t +val add_exception : Identifier.Exception.t -> Component.Exception.t -> t -> t val add_extension_constructor : - Odoc_model.Paths.Identifier.Extension.t -> - Component.Extension.Constructor.t -> - t -> - t + Identifier.Extension.t -> Component.Extension.Constructor.t -> t -> t val add_docs : Odoc_model.Comment.docs -> t -> t val add_comment : Odoc_model.Comment.docs_or_stop -> t -> t -val add_method : - Odoc_model.Paths.Identifier.Method.t -> Component.Method.t -> t -> t +val add_method : Identifier.Method.t -> Component.Method.t -> t -> t val add_module_functor_args : - Component.Module.t -> Odoc_model.Paths.Identifier.Path.Module.t -> t -> t + Component.Module.t -> Identifier.Path.Module.t -> t -> t val add_module_type_functor_args : - Component.ModuleType.t -> Odoc_model.Paths.Identifier.ModuleType.t -> t -> t + Component.ModuleType.t -> Identifier.ModuleType.t -> t -> t val lookup_fragment_root : t -> (int * Component.Signature.t) option val lookup_section_title : - Odoc_model.Paths.Identifier.Label.t -> - t -> - Odoc_model.Comment.link_content option + Identifier.Label.t -> t -> Odoc_model.Comment.link_content option val lookup_page : string -> t -> Odoc_model.Lang.Page.t option @@ -125,11 +106,11 @@ type 'a maybe_ambiguous = ('a, [ `Ambiguous of 'a * 'a list | `Not_found ]) Result.result val lookup_by_name : 'a scope -> string -> t -> 'a maybe_ambiguous -(** Lookup an element in Env depending on the given [scope]. - Return [Error (`Ambiguous _)] when two or more elements match the given scope and name. *) +(** Lookup an element in Env depending on the given [scope]. Return + [Error (`Ambiguous _)] when two or more elements match the given scope and + name. *) -val lookup_by_id : - 'a scope -> [< Odoc_model.Paths.Identifier.t ] -> t -> 'a option +val lookup_by_id : 'a scope -> [< Identifier.t ] -> t -> 'a option (** Like [lookup_by_name] but use an identifier as key. *) val s_any : Component.Element.any scope @@ -181,10 +162,7 @@ val inherit_resolver : t -> t (** Create an empty environment reusing the same resolver. *) val modules_of : - t -> - (Odoc_model.Paths.Identifier.Path.Module.t - * Component.Module.t Component.Delayed.t) - list + t -> (Identifier.Path.Module.t * Component.Module.t Component.Delayed.t) list val len : int ref diff --git a/src/xref2/ref_tools.ml b/src/xref2/ref_tools.ml index 8b619bc498..76df26b53c 100644 --- a/src/xref2/ref_tools.ml +++ b/src/xref2/ref_tools.ml @@ -114,7 +114,7 @@ let env_lookup_by_name scope name env = Some hd | Error `Not_found -> None -let find_ambiguous find sg name : 'b option = +let find_ambiguous find sg name = match find sg name with | [ x ] -> Some x | x :: _ as results -> @@ -180,19 +180,22 @@ module M = struct Some (of_component env m (`Module (parent_cp, name)) (`Module (parent, name))) - let of_element env (`Module (id, m)) : t option = + let of_element env (`Module (id, m)) : t = let m = Component.Delayed.get m in - let base = `Identifier (id :> Odoc_model.Paths.Identifier.Path.Module.t) in - Some (of_component env m base base) + let base = `Identifier (id :> Identifier.Path.Module.t) in + of_component env m base base + + let lookup_root_module env name = + match Env.lookup_root_module name env with + | Some (Env.Resolved (_, id, m)) -> + let base = `Identifier (id :> Identifier.Path.Module.t) in + Some (of_component env m base base) + | _ -> None let in_env env name : t option = match env_lookup_by_name Env.s_module name env with - | Some e -> of_element env e - | None -> ( - match Env.lookup_root_module name env with - | Some (Env.Resolved (_, id, m)) -> - of_element env (`Module (id, Component.Delayed.put_val m)) - | _ -> None) + | Some e -> Some (of_element env e) + | None -> lookup_root_module env name end module MT = struct @@ -211,11 +214,12 @@ module MT = struct (`ModuleType (parent_cp, name)) (`ModuleType (parent', name))) - let of_element _env (`ModuleType (id, mt)) : t option = - Some (`Identifier id, `Identifier id, mt) + let of_element _env (`ModuleType (id, mt)) : t = + (`Identifier id, `Identifier id, mt) let in_env env name : t option = - env_lookup_by_name Env.s_module_type name env >>= of_element env + env_lookup_by_name Env.s_module_type name env >>= fun e -> + Some (of_element env e) end module CL = struct @@ -257,9 +261,7 @@ module DT = struct let of_element _env (`Type (id, t)) : t = (`Identifier id, t) let in_env env name : t option = - env_lookup_by_name Env.s_datatype name env >>= function - | `Type _ as e -> Some (of_element env e) - | _ -> None + env_lookup_by_name Env.s_type name env >>= fun e -> Some (of_element env e) let in_signature _env ((parent', parent_cp, sg) : signature_lookup_result) name : t option = @@ -273,11 +275,14 @@ module T = struct type t = type_lookup_result + let of_element env : _ -> t = function + | `Type _ as e -> `T (DT.of_element env e) + | `Class _ as e -> `C (CL.of_element env e) + | `ClassType _ as e -> `CT (CT.of_element env e) + let in_env env name : t option = - env_lookup_by_name Env.s_datatype name env >>= function - | `Type (id, t) -> Some (`T (`Identifier id, t)) - | `Class _ as e -> Some (`C (CL.of_element env e)) - | `ClassType _ as e -> Some (`CT (CT.of_element env e)) + env_lookup_by_name Env.s_datatype name env >>= fun e -> + Some (of_element env e) (* Don't handle name collisions between class, class types and type decls *) let in_signature _env ((parent', parent_cp, sg) : signature_lookup_result) @@ -461,18 +466,20 @@ module LP = struct type t = label_parent_lookup_result - let in_env env name : t option = - env_lookup_by_name Env.s_label_parent name env >>= function + let of_element env : _ -> t option = function | `Module _ as e -> - M.of_element env e >>= module_lookup_to_signature_lookup env - >>= fun r -> Some (`S r) + M.of_element env e |> module_lookup_to_signature_lookup env >>= fun r -> + Some (`S r) | `ModuleType _ as e -> - MT.of_element env e >>= module_type_lookup_to_signature_lookup env + MT.of_element env e |> module_type_lookup_to_signature_lookup env >>= fun r -> Some (`S r) | `Type _ as e -> Some (`T (DT.of_element env e)) | `Class _ as e -> Some (`C (CL.of_element env e)) | `ClassType _ as e -> Some (`CT (CT.of_element env e)) + let in_env env name : t option = + env_lookup_by_name Env.s_label_parent name env >>= of_element env + let in_signature env ((parent', parent_cp, sg) : signature_lookup_result) name : t option = let sg = Tools.prefix_signature (parent_cp, sg) in @@ -578,10 +585,9 @@ and resolve_signature_reference : | `Root (name, `TUnknown) -> ( env_lookup_by_name Env.s_signature name env >>= function | `Module (_, _) as e -> - M.of_element env e >>= module_lookup_to_signature_lookup env + module_lookup_to_signature_lookup env (M.of_element env e) | `ModuleType (_, _) as e -> - MT.of_element env e >>= module_type_lookup_to_signature_lookup env - ) + module_type_lookup_to_signature_lookup env (MT.of_element env e)) | `Dot (parent, name) -> ( resolve_label_parent_reference env parent >>= signature_lookup_result_of_label_parent @@ -709,12 +715,10 @@ let resolve_reference : Env.t -> t -> Resolved.t option = fun env r -> match r with | `Root (name, `TUnknown) -> ( - let identifier id = - return (`Identifier (id :> Odoc_model.Paths.Identifier.t)) - in + let identifier id = return (`Identifier (id :> Identifier.t)) in env_lookup_by_name Env.s_any name env >>= function - | `Module (_, _) as e -> M.of_element env e >>= resolved - | `ModuleType (_, _) as e -> MT.of_element env e >>= resolved + | `Module (_, _) as e -> resolved (M.of_element env e) + | `ModuleType (_, _) as e -> resolved (MT.of_element env e) | `Value (id, _) -> identifier id | `Type (id, _) -> identifier id | `Label id -> identifier id diff --git a/test/xref2/references_scope.t/run.t b/test/xref2/references_scope.t/run.t index 7a1504fd2f..0110290c1c 100644 --- a/test/xref2/references_scope.t/run.t +++ b/test/xref2/references_scope.t/run.t @@ -1,14 +1,6 @@ # Testing the scope of references $ compile a.mli shadowed.mli shadowed_through_open.mli - File "shadowed.mli", line 9, characters 31-53: - Reference to 't' is ambiguous. Please specify its kind: type-t, type-t. - File "shadowed.mli", line 15, characters 31-52: - Reference to 't' is ambiguous. Please specify its kind: type-t, type-t. - File "shadowed_through_open.mli", line 24, characters 6-27: - Reference to 't' is ambiguous. Please specify its kind: type-t, type-t. - File "shadowed_through_open.mli", line 28, characters 6-26: - Reference to 't' is ambiguous. Please specify its kind: type-t, type-t. $ jq_scan_references() { jq -c '.. | .["`Reference"]? | select(.)'; } diff --git a/test/xref2/v407_and_above/labels.t/run.t b/test/xref2/v407_and_above/labels.t/run.t index e81d4cf26a..6b7a14a129 100644 --- a/test/xref2/v407_and_above/labels.t/run.t +++ b/test/xref2/v407_and_above/labels.t/run.t @@ -1,7 +1,5 @@ $ compile test.mli - File "test.mli", line 18, characters 6-10: - Reference to 'B' is ambiguous. Please specify its kind: section-B, section-B. Labels: Some are not in order because the 'doc' field appears after the rest in the output. diff --git a/test/xref2/v408_and_above/github_issue_587.t/run.t b/test/xref2/v408_and_above/github_issue_587.t/run.t index 9b720edd7d..3e2f9ffaeb 100644 --- a/test/xref2/v408_and_above/github_issue_587.t/run.t +++ b/test/xref2/v408_and_above/github_issue_587.t/run.t @@ -1,5 +1,25 @@ A quick test to repro the issue found in #587 $ ./build.sh + File "odoc_bug__a_intf.cmt": + Failed to compile expansion for module type expression identifier((root Odoc_bug__a_intf).S, false) Unresolved module type path identifier((root Odoc_bug__a_intf).S, false) (Lookup failure (module type): (root Odoc_bug__a_intf).S) + File "odoc_bug__a_intf.cmt": + Failed to compile expansion for module type expression identifier((root Odoc_bug__a_intf).S, false) Unresolved module type path identifier((root Odoc_bug__a_intf).S, false) (Lookup failure (module type): (root Odoc_bug__a_intf).S) + File "odoc_bug__a_intf.cmt": + Failed to compile expansion for module type expression identifier((root Odoc_bug__a_intf).S, false) Unresolved module type path identifier((root Odoc_bug__a_intf).S, false) (Lookup failure (module type): (root Odoc_bug__a_intf).S) + File "odoc_bug__a_intf.cmt": + Failed to compile expansion for module type expression identifier((root Odoc_bug__a_intf).S, false) Unresolved module type path identifier((root Odoc_bug__a_intf).S, false) (Lookup failure (module type): (root Odoc_bug__a_intf).S) + File "odoc_bug__b_intf.cmt": + Failed to compile expansion for module type expression identifier((root Odoc_bug__b_intf).S, false) Unresolved module type path identifier((root Odoc_bug__b_intf).S, false) (Lookup failure (module type): (root Odoc_bug__b_intf).S) + File "odoc_bug__b_intf.cmt": + Failed to compile expansion for module type expression identifier((root Odoc_bug__b_intf).S, false) Unresolved module type path identifier((root Odoc_bug__b_intf).S, false) (Lookup failure (module type): (root Odoc_bug__b_intf).S) + File "odoc_bug__b_intf.cmt": + Failed to compile expansion for include : identifier((root Odoc_bug__b_intf).B.S, false) Unresolved module type path identifier((root Odoc_bug__b_intf).S, false) (Lookup failure (module type): (root Odoc_bug__b_intf).S) + File "odoc_bug__b_intf.cmt": + Failed to compile expansion for module type expression identifier((root Odoc_bug__b_intf).S, false) Unresolved module type path identifier((root Odoc_bug__b_intf).S, false) (Lookup failure (module type): (root Odoc_bug__b_intf).S) + File "odoc_bug__b_intf.cmt": + Failed to compile expansion for module type expression identifier((root Odoc_bug__b_intf).S, false) Unresolved module type path identifier((root Odoc_bug__b_intf).S, false) (Lookup failure (module type): (root Odoc_bug__b_intf).S) + File "odoc_bug__b_intf.cmt": + Failed to compile expansion for include : identifier((root Odoc_bug__b_intf).B.S, false) Unresolved module type path identifier((root Odoc_bug__b_intf).S, false) (Lookup failure (module type): (root Odoc_bug__b_intf).S) From 9646abc11a8a0dbaa072e4410dfd01438e57b2aa Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Tue, 8 Jun 2021 12:26:55 +0200 Subject: [PATCH 3/3] Allow lookup by identifier to shadowed items Shadowing should only be implemented when looking up by name. This is important for aliases to an item of the same name. --- src/xref2/env.ml | 93 ++++++++++--------- src/xref2/env.mli | 3 - .../v408_and_above/github_issue_587.t/run.t | 22 ----- 3 files changed, 50 insertions(+), 68 deletions(-) diff --git a/src/xref2/env.ml b/src/xref2/env.ml index e156b61a4f..61144f7f2e 100644 --- a/src/xref2/env.ml +++ b/src/xref2/env.ml @@ -63,6 +63,20 @@ let pp_lookup_type_list fmt ls = type recorder = { mutable lookups : lookup_type list } +let ident_of_element = function + | `Module (id, _) -> (id :> Identifier.t) + | `ModuleType (id, _) -> (id :> Identifier.t) + | `Type (id, _) -> (id :> Identifier.t) + | `Value (id, _) -> (id :> Identifier.t) + | `Label id -> (id :> Identifier.t) + | `Class (id, _) -> (id :> Identifier.t) + | `ClassType (id, _) -> (id :> Identifier.t) + | `External (id, _) -> (id :> Identifier.t) + | `Constructor (id, _) -> (id :> Identifier.t) + | `Exception (id, _) -> (id :> Identifier.t) + | `Extension (id, _) -> (id :> Identifier.t) + | `Field (id, _) -> (id :> Identifier.t) + module Maps = Odoc_model.Paths.Identifier.Maps module StringMap = Map.Make (String) @@ -90,31 +104,51 @@ module Elements : sig val find_by_name : (Component.Element.any -> 'b option) -> string -> t -> 'b list - val fold : ('a -> kind * Component.Element.any -> 'a) -> 'a -> t -> 'a + val find_by_id : + (Component.Element.any -> 'b option) -> Identifier.t -> t -> 'b list end = struct - type t = (kind * Component.Element.any) list StringMap.t + type elem = { kind : kind; elem : Component.Element.any; shadowed : bool } + + type t = elem list StringMap.t let empty = StringMap.empty let add kind identifier comp t = let name = Identifier.name identifier in - let v = (kind, (comp :> Component.Element.any)) in + let v = + { kind; elem = (comp :> Component.Element.any); shadowed = false } + in try let tl = StringMap.find name t in let tl = - let not_dup (kind', _) = kind' <> kind in - if List.for_all not_dup tl then tl else List.filter not_dup tl + let has_shadow e = e.kind = kind in + let mark_shadow e = + if e.kind = kind then { e with shadowed = true } else e + in + if List.exists has_shadow tl then List.map mark_shadow tl else tl in StringMap.add name (v :: tl) t with Not_found -> StringMap.add name [ v ] t - let find_by_name f name t = - let filter acc (_, e) = match f e with Some e -> e :: acc | None -> acc in - let found = try StringMap.find name t with Not_found -> [] in - List.fold_left filter [] found |> List.rev + let find' f name t = + try List.fold_right f (StringMap.find name t) [] with Not_found -> [] - let fold f acc t = - StringMap.fold (fun _ e acc -> List.fold_left f acc e) t acc + (** Do not consider shadowed elements. *) + let find_by_name f name t = + let filter e acc = + if e.shadowed then acc + else match f e.elem with Some r -> r :: acc | None -> acc + in + find' filter name t + + (** Allow matching shadowed elements. *) + let find_by_id f id t = + let filter e acc = + match f e.elem with + | Some r -> if ident_of_element e.elem = id then r :: acc else acc + | None -> acc + in + find' filter (Identifier.name id) t end type t = { @@ -361,26 +395,6 @@ let lookup_by_name scope name env = | [] -> ( match scope.root name env with Some x -> Ok x | None -> Error `Not_found) -let ident_of_element = function - | `Module (id, _) -> (id :> Identifier.t) - | `ModuleType (id, _) -> (id :> Identifier.t) - | `Type (id, _) -> (id :> Identifier.t) - | `Value (id, _) -> (id :> Identifier.t) - | `Label id -> (id :> Identifier.t) - | `Class (id, _) -> (id :> Identifier.t) - | `ClassType (id, _) -> (id :> Identifier.t) - | `External (id, _) -> (id :> Identifier.t) - | `Constructor (id, _) -> (id :> Identifier.t) - | `Exception (id, _) -> (id :> Identifier.t) - | `Extension (id, _) -> (id :> Identifier.t) - | `Field (id, _) -> (id :> Identifier.t) - -let rec disam_id id = function - | hd :: tl -> - if ident_of_element hd = (id :> Identifier.t) then Some hd - else disam_id id tl - | [] -> None - let lookup_by_id (scope : 'a scope) id env : 'a option = let record_lookup_result result = match env.recorder with @@ -391,14 +405,11 @@ let lookup_by_id (scope : 'a scope) id env : 'a option = | _ -> ()) | None -> () in - match - disam_id id - (Elements.find_by_name scope.filter (Identifier.name id) env.elts) - with - | Some result as x -> - record_lookup_result result; - x - | None -> ( + match Elements.find_by_id scope.filter (id :> Identifier.t) env.elts with + | x :: _ -> + record_lookup_result x; + Some x + | [] -> ( match (id :> Identifier.t) with | `Root (_, name) -> scope.root (ModuleName.to_string name) env | _ -> None) @@ -663,10 +674,6 @@ let env_of_page page resolver = let initial_env = empty |> add_docs page.Odoc_model.Lang.Page.content in set_resolver initial_env resolver -let modules_of env = - let f acc = function _, `Module (id, m) -> (id, m) :: acc | _ -> acc in - Elements.fold f [] env.elts - let verify_lookups env lookups = let bad_lookup = function | Module id -> diff --git a/src/xref2/env.mli b/src/xref2/env.mli index 504593be0a..41a613add3 100644 --- a/src/xref2/env.mli +++ b/src/xref2/env.mli @@ -161,9 +161,6 @@ val env_of_page : Odoc_model.Lang.Page.t -> resolver -> t val inherit_resolver : t -> t (** Create an empty environment reusing the same resolver. *) -val modules_of : - t -> (Identifier.Path.Module.t * Component.Module.t Component.Delayed.t) list - val len : int ref val n : int ref diff --git a/test/xref2/v408_and_above/github_issue_587.t/run.t b/test/xref2/v408_and_above/github_issue_587.t/run.t index 3e2f9ffaeb..be44f897e6 100644 --- a/test/xref2/v408_and_above/github_issue_587.t/run.t +++ b/test/xref2/v408_and_above/github_issue_587.t/run.t @@ -1,25 +1,3 @@ A quick test to repro the issue found in #587 $ ./build.sh - File "odoc_bug__a_intf.cmt": - Failed to compile expansion for module type expression identifier((root Odoc_bug__a_intf).S, false) Unresolved module type path identifier((root Odoc_bug__a_intf).S, false) (Lookup failure (module type): (root Odoc_bug__a_intf).S) - File "odoc_bug__a_intf.cmt": - Failed to compile expansion for module type expression identifier((root Odoc_bug__a_intf).S, false) Unresolved module type path identifier((root Odoc_bug__a_intf).S, false) (Lookup failure (module type): (root Odoc_bug__a_intf).S) - File "odoc_bug__a_intf.cmt": - Failed to compile expansion for module type expression identifier((root Odoc_bug__a_intf).S, false) Unresolved module type path identifier((root Odoc_bug__a_intf).S, false) (Lookup failure (module type): (root Odoc_bug__a_intf).S) - File "odoc_bug__a_intf.cmt": - Failed to compile expansion for module type expression identifier((root Odoc_bug__a_intf).S, false) Unresolved module type path identifier((root Odoc_bug__a_intf).S, false) (Lookup failure (module type): (root Odoc_bug__a_intf).S) - File "odoc_bug__b_intf.cmt": - Failed to compile expansion for module type expression identifier((root Odoc_bug__b_intf).S, false) Unresolved module type path identifier((root Odoc_bug__b_intf).S, false) (Lookup failure (module type): (root Odoc_bug__b_intf).S) - File "odoc_bug__b_intf.cmt": - Failed to compile expansion for module type expression identifier((root Odoc_bug__b_intf).S, false) Unresolved module type path identifier((root Odoc_bug__b_intf).S, false) (Lookup failure (module type): (root Odoc_bug__b_intf).S) - File "odoc_bug__b_intf.cmt": - Failed to compile expansion for include : identifier((root Odoc_bug__b_intf).B.S, false) Unresolved module type path identifier((root Odoc_bug__b_intf).S, false) (Lookup failure (module type): (root Odoc_bug__b_intf).S) - File "odoc_bug__b_intf.cmt": - Failed to compile expansion for module type expression identifier((root Odoc_bug__b_intf).S, false) Unresolved module type path identifier((root Odoc_bug__b_intf).S, false) (Lookup failure (module type): (root Odoc_bug__b_intf).S) - File "odoc_bug__b_intf.cmt": - Failed to compile expansion for module type expression identifier((root Odoc_bug__b_intf).S, false) Unresolved module type path identifier((root Odoc_bug__b_intf).S, false) (Lookup failure (module type): (root Odoc_bug__b_intf).S) - File "odoc_bug__b_intf.cmt": - Failed to compile expansion for include : identifier((root Odoc_bug__b_intf).B.S, false) Unresolved module type path identifier((root Odoc_bug__b_intf).S, false) (Lookup failure (module type): (root Odoc_bug__b_intf).S) - -