Adding path to values in the odoc model

Signed-off-by: Paul-Elliot <[email protected]>

Author: panglesd

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

src/model/paths.ml

@@ -421,6 +421,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
@@ -656,6 +664,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) ->
@@ -747,6 +757,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
@@ -760,6 +774,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)
@@ -797,6 +812,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

src/model/paths.mli

@@ -182,6 +182,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
@@ -365,6 +367,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
 
@@ -394,6 +406,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

src/model/paths_types.ml

@@ -256,14 +256,21 @@ 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 *)
 
   and path_class_type = path_class_type_pv id
   (** @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
@@ -324,6 +331,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
@@ -370,6 +380,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
@@ -394,6 +407,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 =

src/model_desc/paths_desc.ml

@@ -265,6 +265,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) ->

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 ->

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
 
@@ -1028,6 +1034,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
@@ -1056,6 +1069,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 ->
@@ -1129,6 +1151,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)
@@ -1770,6 +1796,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 ->
@@ -1822,6 +1853,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 ->

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
@@ -585,10 +587,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
 
@@ -650,6 +656,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 ->
@@ -662,6 +671,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
 

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

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 ->