From 1056affb811fc1b6967697fa1250929d563a14ee Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Thu, 22 Jun 2023 20:56:25 +0200 Subject: [PATCH 1/5] Adding path to values in the odoc model Signed-off-by: Paul-Elliot --- src/document/url.ml | 1 + src/model/paths.ml | 19 ++++++++++++ src/model/paths.mli | 16 ++++++++++ src/model/paths_types.ml | 16 +++++++++- src/model_desc/paths_desc.ml | 2 ++ src/xref2/compile.ml | 10 +++++++ src/xref2/component.ml | 37 +++++++++++++++++++++++ src/xref2/component.mli | 11 +++++++ src/xref2/cpath.ml | 7 +++++ src/xref2/errors.ml | 22 ++++++++++++++ src/xref2/ident.ml | 2 ++ src/xref2/lang_of.ml | 4 +++ src/xref2/lang_of.mli | 2 ++ src/xref2/link.ml | 19 ++++++++++++ src/xref2/tools.ml | 56 +++++++++++++++++++++++++++++++++++ src/xref2/tools.mli | 7 +++++ test/xref2/lib/common.cppo.ml | 1 + 17 files changed, 231 insertions(+), 1 deletion(-) diff --git a/src/document/url.ml b/src/document/url.ml index 4dac33eb5b..8f2c5f2c38 100644 --- a/src/document/url.ml +++ b/src/document/url.ml @@ -41,6 +41,7 @@ let render_path : Odoc_model.Paths.Path.t -> string = | `ModuleType (p, s) -> 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 | `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 a7099e0321..9274f8a5ac 100644 --- a/src/model/paths.ml +++ b/src/model/paths.ml @@ -330,6 +330,14 @@ module Identifier = struct let compare = compare end + module Value = struct + type t = Id.path_value + type t_pv = Id.value_pv + let equal = equal + let hash = hash + let compare = compare + end + module ClassType = struct type t = Id.path_class_type type t_pv = Id.path_class_type_pv @@ -555,6 +563,8 @@ module Path = struct | `ModuleType (p, _) -> inner (p : module_ :> any) | `Type (_, t) when Names.TypeName.is_internal t -> true | `Type (p, _) -> inner (p : module_ :> any) + | `Value (_, t) when Names.ValueName.is_internal t -> true + | `Value (p, _) -> inner (p : module_ :> any) | `Class (p, _) -> inner (p : module_ :> any) | `ClassType (p, _) -> inner (p : module_ :> any) | `Alias (dest, `Resolved src) -> @@ -646,6 +656,10 @@ module Path = struct type t = Paths_types.Resolved_path.type_ end + module Value = struct + type t = Paths_types.Resolved_path.value + end + module ClassType = struct type t = Paths_types.Resolved_path.class_type end @@ -659,6 +673,7 @@ module Path = struct | `Canonical (p, _) -> identifier (p :> t) | `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) | `ModuleType (m, n) -> Identifier.Mk.module_type (parent_module_identifier m, n) | `Class (m, n) -> Identifier.Mk.class_ (parent_module_identifier m, n) @@ -696,6 +711,10 @@ module Path = struct type t = Paths_types.Path.type_ end + module Value = struct + type t = Paths_types.Path.value + end + module ClassType = struct type t = Paths_types.Path.class_type end diff --git a/src/model/paths.mli b/src/model/paths.mli index 7e1a25b597..6456029631 100644 --- a/src/model/paths.mli +++ b/src/model/paths.mli @@ -170,6 +170,8 @@ module Identifier : sig module Type : IdSig with type t = Id.path_type and type t_pv = Id.path_type_pv + module Value : IdSig with type t = Id.path_value and type t_pv = Id.value_pv + module ClassType : IdSig with type t = Id.path_class_type @@ -339,6 +341,16 @@ module rec Path : sig (* val identifier : t -> Identifier.Path.Type.t *) end + 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 type t = Paths_types.Resolved_path.class_type @@ -368,6 +380,10 @@ module rec Path : sig type t = Paths_types.Path.type_ end + module Value : sig + type t = Paths_types.Path.value + end + module ClassType : sig type t = Paths_types.Path.class_type end diff --git a/src/model/paths_types.ml b/src/model/paths_types.ml index 70a838496c..7b17fda6dc 100644 --- a/src/model/paths_types.ml +++ b/src/model/paths_types.ml @@ -248,6 +248,8 @@ module Identifier = struct and path_type = path_type_pv id (** @canonical Odoc_model.Paths.Identifier.Path.Type.t *) + type path_value = value + type path_class_type_pv = [ class_pv | class_type_pv ] (** @canonical Odoc_model.Paths.Identifier.Path.ClassType.t_pv *) @@ -255,7 +257,12 @@ module Identifier = struct (** @canonical Odoc_model.Paths.Identifier.Path.ClassType.t *) type path_any = - [ path_module_pv | module_type_pv | path_type_pv | path_class_type_pv ] id + [ path_module_pv + | module_type_pv + | path_type_pv + | path_class_type_pv + | value_pv ] + id (** @canonical Odoc_model.Paths.Identifier.Path.t *) type fragment_module = path_module @@ -314,6 +321,9 @@ module rec Path : sig | `Dot of module_ * string ] (** @canonical Odoc_model.Paths.Path.Type.t *) + type value = [ `Resolved of Resolved_path.value | `Dot of module_ * string ] + (** @canonical Odoc_model.Paths.Path.Value.t *) + type class_type = [ `Resolved of Resolved_path.class_type | `Identifier of Identifier.path_class_type * bool @@ -360,6 +370,9 @@ and Resolved_path : sig | `ClassType of module_ * ClassTypeName.t ] (** @canonical Odoc_model.Paths.Path.Resolved.Type.t *) + type value = [ `Value of module_ * ValueName.t ] + (** @canonical Odoc_model.Paths.Path.Resolved.Value.t *) + type class_type = [ `Identifier of Identifier.path_class_type | `Class of module_ * ClassName.t @@ -384,6 +397,7 @@ and Resolved_path : sig | `Class of module_ * ClassName.t | `ClassType of module_ * ClassTypeName.t | `Class of module_ * ClassName.t + | `Value of module_ * ValueName.t | `ClassType of module_ * ClassTypeName.t ] (** @canonical Odoc_model.Paths.Path.Resolved.t *) end = diff --git a/src/model_desc/paths_desc.ml b/src/model_desc/paths_desc.ml index 0a42a9d4ed..c8cccdf99d 100644 --- a/src/model_desc/paths_desc.ml +++ b/src/model_desc/paths_desc.ml @@ -259,6 +259,8 @@ module General_paths = struct | `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)) | `Class (x1, x2) -> C ("`Class", ((x1 :> rp), x2), Pair (resolved_path, Names.classname)) | `ClassType (x1, x2) -> diff --git a/src/xref2/compile.ml b/src/xref2/compile.ml index 7ce0502377..7f4079161c 100644 --- a/src/xref2/compile.ml +++ b/src/xref2/compile.ml @@ -21,6 +21,16 @@ 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 module_type_path : Env.t -> Paths.Path.ModuleType.t -> Paths.Path.ModuleType.t = fun env p -> diff --git a/src/xref2/component.ml b/src/xref2/component.ml index 0fb9a9723f..76e15e371b 100644 --- a/src/xref2/component.ml +++ b/src/xref2/component.ml @@ -30,6 +30,12 @@ module PathTypeMap = Map.Make (struct let compare a b = Ident.compare (a :> Ident.any) (b :> Ident.any) end) +module PathValueMap = Map.Make (struct + type t = Ident.path_value + + let compare a b = Ident.compare (a :> Ident.any) (b :> Ident.any) +end) + module PathClassTypeMap = Map.Make (struct type t = Ident.path_class_type @@ -1022,6 +1028,13 @@ module Fmt = struct 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 + | `Value (p, t) -> + Format.fprintf ppf "%a.%s" resolved_parent_path p + (Odoc_model.Names.ValueName.to_string t) + and resolved_parent_path : Format.formatter -> Cpath.Resolved.parent -> unit = fun ppf p -> match p with @@ -1050,6 +1063,15 @@ module Fmt = struct 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 + | `Resolved r -> Format.fprintf ppf "r(%a)" resolved_value_path r + | `Dot (m, s) -> Format.fprintf ppf "%a.%s" module_path m s + | `Value (p, t) -> + Format.fprintf ppf "%a.%s" resolved_parent_path p + (Odoc_model.Names.ValueName.to_string t) + and resolved_class_type_path : Format.formatter -> Cpath.Resolved.class_type -> unit = fun ppf p -> @@ -1123,6 +1145,10 @@ module Fmt = struct Format.fprintf ppf "%a.%s" model_resolved_path (parent :> t) (Odoc_model.Names.TypeName.to_string name) + | `Value (parent, name) -> + Format.fprintf ppf "%a.%s" model_resolved_path + (parent :> t) + (Odoc_model.Names.ValueName.to_string name) | `Alias (dest, src) -> Format.fprintf ppf "alias(%a,%a)" model_resolved_path (dest :> t) @@ -1752,6 +1778,11 @@ module Of_Lang = struct | `ClassType (p, name) -> `ClassType (`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 (`Value (p, name)) -> + `Value (`Module (resolved_module_path ident_map p), name) + and resolved_class_type_path : _ -> Odoc_model.Paths.Path.Resolved.ClassType.t -> @@ -1804,6 +1835,12 @@ 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 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 bc289ad73e..54e6a6429d 100644 --- a/src/xref2/component.mli +++ b/src/xref2/component.mli @@ -11,6 +11,8 @@ module ModuleTypeMap : Map.S with type key = Ident.module_type module PathTypeMap : Map.S with type key = Ident.path_type +module PathValueMap : Map.S with type key = Ident.path_value + module PathClassTypeMap : Map.S with type key = Ident.path_class_type module IdentMap : Map.S with type key = Ident.any @@ -580,10 +582,14 @@ module Fmt : sig val resolved_type_path : Format.formatter -> Cpath.Resolved.type_ -> unit + val resolved_value_path : Format.formatter -> Cpath.Resolved.value -> unit + val resolved_parent_path : Format.formatter -> Cpath.Resolved.parent -> unit val type_path : Format.formatter -> Cpath.type_ -> unit + val value_path : Format.formatter -> Cpath.value -> unit + val resolved_class_type_path : Format.formatter -> Cpath.Resolved.class_type -> unit @@ -645,6 +651,9 @@ module Of_Lang : sig val resolved_type_path : map -> Odoc_model.Paths.Path.Resolved.Type.t -> Cpath.Resolved.type_ + val resolved_value_path : + map -> Odoc_model.Paths.Path.Resolved.Value.t -> Cpath.Resolved.value + val resolved_class_type_path : map -> Odoc_model.Paths.Path.Resolved.ClassType.t -> @@ -657,6 +666,8 @@ module Of_Lang : sig val type_path : map -> Odoc_model.Paths.Path.Type.t -> Cpath.type_ + val value_path : map -> Odoc_model.Paths.Path.Value.t -> Cpath.value + 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 fac68c865f..40004e1b8e 100644 --- a/src/xref2/cpath.ml +++ b/src/xref2/cpath.ml @@ -36,6 +36,8 @@ module rec Resolved : sig | `Class of parent * ClassName.t | `ClassType of parent * ClassTypeName.t ] + and value = [ `Value of parent * ValueName.t ] + and class_type = [ `Local of Ident.path_class_type | `Substituted of class_type @@ -75,6 +77,11 @@ and Cpath : sig | `Class of Resolved.parent * ClassName.t | `ClassType of Resolved.parent * ClassTypeName.t ] + and value = + [ `Resolved of Resolved.value + | `Dot of module_ * string + | `Value of Resolved.parent * ValueName.t ] + and class_type = [ `Resolved of Resolved.class_type | `Substituted of class_type diff --git a/src/xref2/errors.ml b/src/xref2/errors.ml index 459d010386..f5044308be 100644 --- a/src/xref2/errors.ml +++ b/src/xref2/errors.ml @@ -72,6 +72,17 @@ module Tools_error = struct (* 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 + (* Internal error: Found local path during lookup *) + | `Find_failure + (* Internal error: the type was not found in the parent signature *) + | `Lookup_failureV of + Identifier.Path.Value.t + (* Could not find the module in the environment *) + | `Parent of parent_lookup_error ] + and parent_lookup_error = [ `Parent_sig of expansion_of_module_error @@ -98,6 +109,7 @@ module Tools_error = struct type any = [ simple_type_lookup_error + | simple_value_lookup_error | simple_module_type_lookup_error | simple_module_type_expr_of_module_error | simple_module_lookup_error @@ -135,6 +147,8 @@ 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 + | `LocalValue (_, id) -> + Format.fprintf fmt "Local id found: %a" Ident.fmt id | `Find_failure -> Format.fprintf fmt "Find failure" | `Lookup_failure m -> Format.fprintf fmt "Lookup failure (module): %a" @@ -150,6 +164,10 @@ module Tools_error = struct Format.fprintf fmt "Lookup failure (type): %a" Component.Fmt.model_identifier (m :> Odoc_model.Paths.Identifier.t) + | `Lookup_failureV m -> + Format.fprintf fmt "Lookup failure (value): %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) @@ -204,7 +222,9 @@ let is_unexpanded_module_type_of = | `UnresolvedPath (`Module (_, e)) -> inner (e :> any) | `UnresolvedPath (`ModuleType (_, e)) -> inner (e :> any) | `Lookup_failureT _ -> false + | `Lookup_failureV _ -> false | `LocalType _ -> false + | `LocalValue _ -> false | `Class_replaced -> false | `OpaqueClass -> false | `Reference (`Parent p) -> inner (p :> any) @@ -272,6 +292,7 @@ open Paths type what = [ `Functor_parameter of Identifier.FunctorParameter.t | `Value of Identifier.Value.t + | `Value_path of Cpath.value | `Class of Identifier.Class.t | `Class_type of Identifier.ClassType.t | `Module of Identifier.Module.t @@ -328,6 +349,7 @@ let report ~(what : what) ?tools_error action = r "module package" module_type_path (path :> Cpath.module_type) | `Type cfrag -> r "type" type_fragment cfrag | `Type_path path -> r "type" type_path path + | `Value_path path -> r "value" value_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/ident.ml b/src/xref2/ident.ml index 09776216b4..535bf9127b 100644 --- a/src/xref2/ident.ml +++ b/src/xref2/ident.ml @@ -50,6 +50,8 @@ type class_type = [ `LClassType of ClassTypeName.t * int ] type path_type = [ type_ | class_ | class_type ] +type path_value = value + type path_class_type = [ class_ | class_type ] type method_ = [ `LMethod of MethodName.t * int ] diff --git a/src/xref2/lang_of.ml b/src/xref2/lang_of.ml index 4d838d4404..79cba0c232 100644 --- a/src/xref2/lang_of.ml +++ b/src/xref2/lang_of.ml @@ -198,6 +198,10 @@ 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) : + Odoc_model.Paths.Path.Resolved.Value.t = + `Value (resolved_parent 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 1421a3dc36..3d0529a825 100644 --- a/src/xref2/lang_of.mli +++ b/src/xref2/lang_of.mli @@ -29,6 +29,8 @@ module Path : sig val resolved_type : maps -> Cpath.Resolved.type_ -> Path.Resolved.Type.t + val resolved_value : maps -> Cpath.Resolved.value -> Path.Resolved.Value.t + val resolved_class_type : maps -> Cpath.Resolved.class_type -> Path.Resolved.ClassType.t diff --git a/src/xref2/link.ml b/src/xref2/link.ml index 8b62c16074..298b9ea149 100644 --- a/src/xref2/link.ml +++ b/src/xref2/link.ml @@ -114,6 +114,7 @@ let rec should_reresolve : Paths.Path.Resolved.t -> bool = | `AliasModuleType (x, y) -> should_reresolve (x :> t) || should_reresolve (y :> t) | `Type (p, _) + | `Value (p, _) | `Class (p, _) | `ClassType (p, _) | `ModuleType (p, _) @@ -143,6 +144,24 @@ let type_path : Env.t -> Paths.Path.Type.t -> Paths.Path.Type.t = 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 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 cdde65142f..430f565368 100644 --- a/src/xref2/tools.ml +++ b/src/xref2/tools.ml @@ -260,6 +260,9 @@ type resolve_type_result = simple_type_lookup_error ) Result.result +type resolve_value_result = + (Cpath.Resolved.value * Find.value, simple_value_lookup_error) Result.result + type resolve_class_type_result = ( Cpath.Resolved.class_type * Find.careful_class, simple_type_lookup_error ) @@ -587,6 +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_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_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) @@ -886,6 +894,17 @@ and lookup_type : in res +and lookup_value : + Env.t -> + Cpath.Resolved.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)) + and lookup_class_type : Env.t -> Cpath.Resolved.class_type -> @@ -1110,6 +1129,38 @@ and resolve_type : if add_canonical then Ok (`CanonicalType (p, c), t) else result | _ -> result +and resolve_value : Env.t -> Cpath.value -> resolve_value_result = + fun env p -> + 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_value_lookup env id (`Module p) sg + >>= fun (p', `FValue (name, c)) -> + Ok (p', `FValue (name, Subst.value sub c)) + | `Value (parent, id) -> + lookup_parent ~mark_substituted:true env parent + |> map_error (fun e -> (e :> simple_value_lookup_error)) + >>= fun (parent_sig, sub) -> + let result = + match Find.value_in_sig parent_sig (ValueName.to_string id) with + | `FValue (name, t) :: _ -> + Some (`Value (parent, name), `FValue (name, Subst.value sub t)) + | [] -> None + in + of_option ~error:`Find_failure result + | `Resolved r -> lookup_value env r >>= fun t -> Ok (r, t) + in + result + and resolve_class_type : Env.t -> Cpath.class_type -> resolve_class_type_result = fun env p -> @@ -1500,6 +1551,9 @@ and reresolve_type : Env.t -> Cpath.Resolved.type_ -> Cpath.Resolved.type_ = in result +and reresolve_value : Env.t -> Cpath.Resolved.value -> Cpath.Resolved.value = + fun env (`Value (p, n)) -> `Value (reresolve_parent env p, n) + and reresolve_class_type : Env.t -> Cpath.Resolved.class_type -> Cpath.Resolved.class_type = fun env path -> @@ -2308,5 +2362,7 @@ let resolve_module_type_path env p = let resolve_type_path env p = resolve_type env ~add_canonical:true p >>= fun (p, _) -> Ok p +let resolve_value_path env p = resolve_value 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 ebd03e8648..f955630128 100644 --- a/src/xref2/tools.mli +++ b/src/xref2/tools.mli @@ -149,6 +149,11 @@ val resolve_type_path : Cpath.type_ -> (Cpath.Resolved.type_, simple_type_lookup_error) Result.result +val resolve_value_path : + Env.t -> + Cpath.value -> + (Cpath.Resolved.value, simple_value_lookup_error) Result.result + val resolve_class_type_path : Env.t -> Cpath.class_type -> @@ -168,6 +173,8 @@ val reresolve_module_type : val reresolve_type : Env.t -> Cpath.Resolved.type_ -> Cpath.Resolved.type_ +val reresolve_value : Env.t -> Cpath.Resolved.value -> Cpath.Resolved.value + val reresolve_class_type : Env.t -> Cpath.Resolved.class_type -> Cpath.Resolved.class_type diff --git a/test/xref2/lib/common.cppo.ml b/test/xref2/lib/common.cppo.ml index 685c2548ec..d0161003c2 100644 --- a/test/xref2/lib/common.cppo.ml +++ b/test/xref2/lib/common.cppo.ml @@ -564,6 +564,7 @@ module LangUtils = struct | `Module (p, m) -> Format.fprintf ppf "%a.%s" resolved_path (cast p) (Odoc_model.Names.ModuleName.to_string m) | `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) | `OpaqueModule m -> Format.fprintf ppf "opaquemodule(%a)" resolved_path (cast m) | `OpaqueModuleType m -> Format.fprintf ppf "opaquemoduletype(%a)" resolved_path (cast m) | `SubstT (_, _) From 5207ea17bf7383f1d77780290f7ae7dc67e2b289 Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Tue, 4 Jul 2023 16:29:21 +0200 Subject: [PATCH 2/5] Adding datatype and constructor to lang model Signed-off-by: Paul-Elliot --- 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 insertions(+) diff --git a/src/document/url.ml b/src/document/url.ml index 8f2c5f2c38..713526a5d9 100644 --- a/src/document/url.ml +++ b/src/document/url.ml @@ -33,6 +33,8 @@ 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) ^ "(" @@ -42,6 +44,8 @@ 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 9274f8a5ac..d8350004c4 100644 --- a/src/model/paths.ml +++ b/src/model/paths.ml @@ -330,6 +330,22 @@ 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 @@ -565,6 +581,7 @@ 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) -> @@ -579,6 +596,8 @@ 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 @@ -641,6 +660,14 @@ 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_ @@ -656,6 +683,14 @@ 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 @@ -674,6 +709,8 @@ 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) @@ -693,6 +730,8 @@ 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) @@ -711,6 +750,14 @@ 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 6456029631..b13bab7deb 100644 --- a/src/model/paths.mli +++ b/src/model/paths.mli @@ -170,6 +170,12 @@ 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 : @@ -341,6 +347,14 @@ 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 @@ -380,6 +394,14 @@ 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 7b17fda6dc..ff85a041df 100644 --- a/src/model/paths_types.ml +++ b/src/model/paths_types.ml @@ -248,6 +248,14 @@ 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 ] @@ -321,6 +329,16 @@ 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 | `Dot of module_ * string ] (** @canonical Odoc_model.Paths.Path.Value.t *) @@ -370,6 +388,15 @@ 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 = [ `Value of module_ * ValueName.t ] (** @canonical Odoc_model.Paths.Path.Resolved.Value.t *) @@ -393,7 +420,9 @@ 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 c8cccdf99d..bee4003f1b 100644 --- a/src/model_desc/paths_desc.ml +++ b/src/model_desc/paths_desc.ml @@ -256,11 +256,21 @@ 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 d0161003c2..9a7534f52b 100644 --- a/test/xref2/lib/common.cppo.ml +++ b/test/xref2/lib/common.cppo.ml @@ -565,11 +565,13 @@ 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 619ca16b359060564164af0a91a79d9b9426e4c2 Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Tue, 4 Jul 2023 16:31:07 +0200 Subject: [PATCH 3/5] Adding constructors and datatypes to component path Signed-off-by: Paul-Elliot --- 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 insertions(+) diff --git a/src/xref2/component.ml b/src/xref2/component.ml index 76e15e371b..9206688869 100644 --- a/src/xref2/component.ml +++ b/src/xref2/component.ml @@ -1028,6 +1028,24 @@ 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 @@ -1035,6 +1053,14 @@ module Fmt = struct Format.fprintf ppf "%a.%s" resolved_parent_path p (Odoc_model.Names.ValueName.to_string 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 @@ -1063,6 +1089,21 @@ 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 @@ -1072,6 +1113,15 @@ module Fmt = struct Format.fprintf ppf "%a.%s" resolved_parent_path p (Odoc_model.Names.ValueName.to_string t) + 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 -> @@ -1145,6 +1195,10 @@ 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) @@ -1179,6 +1233,11 @@ 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) @@ -1778,11 +1837,31 @@ 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 (`Value (p, name)) -> `Value (`Module (resolved_module_path ident_map p), name) + 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 -> @@ -1841,6 +1920,23 @@ module Of_Lang = struct | `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 + | `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 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 54e6a6429d..514ebf4ba6 100644 --- a/src/xref2/component.mli +++ b/src/xref2/component.mli @@ -590,6 +590,8 @@ 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 @@ -654,6 +656,11 @@ 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 -> @@ -666,8 +673,13 @@ 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 40004e1b8e..05891c7111 100644 --- a/src/xref2/cpath.ml +++ b/src/xref2/cpath.ml @@ -38,6 +38,15 @@ module rec Resolved : sig and value = [ `Value of parent * ValueName.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 @@ -82,6 +91,19 @@ and Cpath : sig | `Dot of module_ * string | `Value of Resolved.parent * ValueName.t ] + 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 535bf9127b..7fe4285cc7 100644 --- a/src/xref2/ident.ml +++ b/src/xref2/ident.ml @@ -50,6 +50,8 @@ 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 79cba0c232..f780747dba 100644 --- a/src/xref2/lang_of.ml +++ b/src/xref2/lang_of.ml @@ -202,6 +202,21 @@ module Path = struct Odoc_model.Paths.Path.Resolved.Value.t = `Value (resolved_parent map p, name) + 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 3d0529a825..24ccf08a2c 100644 --- a/src/xref2/lang_of.mli +++ b/src/xref2/lang_of.mli @@ -29,8 +29,14 @@ 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 20221d9a9fe536931d9b2c0b79a6ada238b999e5 Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Tue, 4 Jul 2023 17:01:10 +0200 Subject: [PATCH 4/5] Adding support for resolving constructor and datatype Signed-off-by: Paul-Elliot --- src/xref2/compile.ml | 11 ++ src/xref2/errors.ml | 39 +++++++ src/xref2/find.ml | 29 ++++- src/xref2/find.mli | 6 + src/xref2/link.ml | 28 +++++ src/xref2/tools.ml | 263 ++++++++++++++++++++++++++++++++++++++++++- src/xref2/tools.mli | 8 ++ 7 files changed, 378 insertions(+), 6 deletions(-) diff --git a/src/xref2/compile.ml b/src/xref2/compile.ml index 7f4079161c..8507acdfec 100644 --- a/src/xref2/compile.ml +++ b/src/xref2/compile.ml @@ -31,6 +31,17 @@ and value_path : Env.t -> Paths.Path.Value.t -> Paths.Path.Value.t = | 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 module_type_path : Env.t -> Paths.Path.ModuleType.t -> Paths.Path.ModuleType.t = fun env p -> diff --git a/src/xref2/errors.ml b/src/xref2/errors.ml index f5044308be..4ca923a9b7 100644 --- a/src/xref2/errors.ml +++ b/src/xref2/errors.ml @@ -72,6 +72,17 @@ 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 @@ -83,6 +94,17 @@ 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 @@ -110,6 +132,8 @@ 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 @@ -147,6 +171,10 @@ 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" @@ -168,9 +196,14 @@ 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 (value): %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 @@ -206,7 +239,9 @@ 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) @@ -224,6 +259,8 @@ 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 @@ -298,6 +335,7 @@ 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 @@ -350,6 +388,7 @@ 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 354a022bdc..0287f603f3 100644 --- a/src/xref2/find.ml +++ b/src/xref2/find.ml @@ -111,6 +111,12 @@ 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 ] @@ -121,6 +127,8 @@ 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 = @@ -156,11 +164,10 @@ let careful_type_in_sig sg name = | 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 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 class_in_sig sg name = filter_in_sig sg (function @@ -177,6 +184,18 @@ 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 c515ed4fe3..5809dab339 100644 --- a/src/xref2/find.mli +++ b/src/xref2/find.mli @@ -71,6 +71,8 @@ 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 @@ -114,6 +116,8 @@ 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 @@ -123,4 +127,6 @@ 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 298b9ea149..7fdd83609a 100644 --- a/src/xref2/link.ml +++ b/src/xref2/link.ml @@ -106,6 +106,8 @@ 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) @@ -120,12 +122,19 @@ 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 @@ -162,6 +171,25 @@ 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_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 430f565368..bbf35ecede 100644 --- a/src/xref2/tools.ml +++ b/src/xref2/tools.ml @@ -59,6 +59,19 @@ 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_type 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 @@ -260,9 +273,19 @@ 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 ) @@ -418,6 +441,18 @@ 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 @@ -590,11 +625,24 @@ 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) @@ -829,6 +877,36 @@ and lookup_type_gpath : 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_type) 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 -> @@ -894,10 +972,38 @@ 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 -> - (_, simple_value_lookup_error) Result.result = + (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)) @@ -905,6 +1011,20 @@ and lookup_value : handle_value_lookup env (ValueName.to_string id) p sg >>= fun (_, `FValue (name, c)) -> Ok (`FValue (name, Subst.value sub c)) +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 -> @@ -1129,6 +1249,83 @@ 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 ( >>> ) = Option.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 = @@ -1161,6 +1358,31 @@ 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 -> @@ -1495,6 +1717,24 @@ 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 -> @@ -1551,9 +1791,27 @@ 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 (`Value (p, n)) -> `Value (reresolve_parent env p, n) +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 -> @@ -2364,5 +2622,8 @@ 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 f955630128..04513cde83 100644 --- a/src/xref2/tools.mli +++ b/src/xref2/tools.mli @@ -154,6 +154,11 @@ 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 -> @@ -173,6 +178,9 @@ 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 949f955381df8bc7d398fdab98e916efd89ba897 Mon Sep 17 00:00:00 2001 From: Paul-Elliot Date: Fri, 27 Oct 2023 08:45:14 +0200 Subject: [PATCH 5/5] Ignore {value/constructor}_path unused value Signed-off-by: Paul-Elliot --- src/xref2/compile.ml | 5 +++++ src/xref2/link.ml | 5 +++++ 2 files changed, 10 insertions(+) diff --git a/src/xref2/compile.ml b/src/xref2/compile.ml index 8507acdfec..716222eb63 100644 --- a/src/xref2/compile.ml +++ b/src/xref2/compile.ml @@ -74,6 +74,11 @@ and class_type_path : Env.t -> Paths.Path.ClassType.t -> Paths.Path.ClassType.t | Ok p' -> `Resolved Lang_of.(Path.resolved_class_type (empty ()) p') | Error _ -> p) +let () = + (* Until those are used *) + ignore value_path; + ignore constructor_path + let rec unit env t = let open Compilation_unit in let source_info = diff --git a/src/xref2/link.ml b/src/xref2/link.ml index 7fdd83609a..04f088c2c7 100644 --- a/src/xref2/link.ml +++ b/src/xref2/link.ml @@ -190,6 +190,11 @@ let constructor_path : Errors.report ~what:(`Constructor_path cp) ~tools_error:e `Lookup; p) +let () = + (* Until those are used *) + ignore value_path; + ignore constructor_path + let class_type_path : Env.t -> Paths.Path.ClassType.t -> Paths.Path.ClassType.t = fun env p ->