Adding support for resolving constructor and datatype

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

Author: panglesd

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

src/xref2/errors.ml

@@ -72,6 +72,21 @@ 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 *)
+    | `Class_replaced
+      (* Class was replaced with a destructive substitution and we're not sure
+          what to do now *)
+    | `OpaqueClass (* Couldn't resolve class signature. *)
+    | `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 +98,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 +136,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 +175,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 +200,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 +243,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 +263,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 +339,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 +392,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 ->

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

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

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,29 @@ 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;
+            let _ =
+              ignore e;
+              failwith "todo"
+            in
+            p)
+
 let class_type_path : Env.t -> Paths.Path.ClassType.t -> Paths.Path.ClassType.t
     =
  fun env p ->