More semi resolving of references

jonludlam · panglesd · commit 28b5ecb3edba · 2024-12-12T15:37:30.000+01:00
diff --git a/src/xref2/errors.ml b/src/xref2/errors.ml
@@ -121,7 +121,8 @@ module Tools_error = struct
       [ `Not_found | `Is_directory | `Wrong_kind of path_kind list * path_kind ]
       * Reference.tag_hierarchy
       * string list
-    | `Parent of parent_lookup_error ]
+    | `Parent of parent_lookup_error
+    | `Lookup_by_id of Identifier.t ]
 
   type any =
     [ simple_type_lookup_error
@@ -252,6 +253,8 @@ module Tools_error = struct
         )
     | `Path_error (err, tag, path) -> pp_path_error fmt err tag path
     | `Parent e -> pp fmt (e :> any)
+    | `Lookup_by_id id -> Format.fprintf fmt "Couldn't find identifier %s"
+        (String.concat "." (Identifier.fullname id))
 end
 
 type kind = [ `OpaqueModule | `Root of string ]
diff --git a/src/xref2/ref_tools.ml b/src/xref2/ref_tools.ml
@@ -181,8 +181,26 @@ let type_lookup_to_class_signature_lookup =
         |> of_option ~error:(`Parent (`Parent_type `OpaqueClass))
         >>= resolved p'
 
-module M = struct
-  (** Module *)
+module rec M 
+: sig
+            type t = module_lookup_result
+          
+            val of_component : Env.t -> Component.Module.t -> Cpath.Resolved.module_ -> Resolved.Module.t -> t
+          
+          val in_signature : Env.t -> signature_lookup_result ->
+             ModuleName.t ->
+              (t, Errors.Tools_error.reference_lookup_error) result
+          
+            val of_element : Env.t -> Component.Element.module_ -> t
+          
+            val in_env : Env.t -> string -> (t, Errors.Tools_error.reference_lookup_error) result
+
+            val in_env_by_id : Env.t -> Identifier.Module.t -> (t, Errors.Tools_error.reference_lookup_error) result
+          end 
+          
+          =
+          
+          struct  (** Module *)
 
   type t = module_lookup_result
 
@@ -225,56 +243,37 @@ module M = struct
           (`Parent
             (`Parent_module (`Lookup_failure_root (ModuleName.make_std name))))
 
-  let rec in_env_by_id env id =
+  let rec in_env_by_id env (id : Identifier.Module.t) =
     match Env.lookup_by_id Env.s_module id env with
     | Some e -> Ok (of_element env e)
     | None -> match id.iv with
-      | `Module (p, name) ->
+      | `Module ({ Identifier.iv = #Identifier.Module.t_pv; _} as p, name) ->
           in_env_by_id env p >>=
           module_lookup_to_signature_lookup env >>=
           fun x -> in_signature env x name
-     | _ -> Error
-       (`Parent
-         (`Parent_module (`Lookup_failure_root (ModuleName.make_std (Identifier.name id)))))
-end
-
-module Path = struct
-  (* let first_seg (`Root (s, _) | `Slash (_, s)) = s *)
-
-  let mk_lookup_error (tag, path) = Error (`Path_error (`Not_found, tag, path))
-
-  let handle_lookup_error p = function
-    | Ok _ as ok -> ok
-    | Error `Not_found -> mk_lookup_error p
+      |  `Module ({ Identifier.iv = #Identifier.ModuleType.t_pv; _} as p, name) ->
+        MT.in_env_by_id env p >>=
+        module_type_lookup_to_signature_lookup env >>=
+        fun x -> in_signature env x name
+      | `Module ({ Identifier.iv = `Result _; _}, _) 
+      | `Parameter (_, _)
+      | `Root _ -> Error (`Lookup_by_id (id :> Identifier.t))
+end and 
+
+MT : sig
+  type t = module_type_lookup_result
 
-  let page_in_env env p : page_lookup_result ref_result =
-    Env.lookup_page_by_path p env |> handle_lookup_error p >>= fun p ->
-    Ok (`Identifier p.name, p)
+  val of_element : Env.t -> Component.Element.module_type -> t
 
-  let asset_in_env env p : asset_lookup_result ref_result =
-    Env.lookup_asset_by_path p env |> handle_lookup_error p >>= fun p ->
-    Ok (`Identifier p.name)
+  val of_component : Env.t -> Component.ModuleType.t -> Cpath.Resolved.module_type -> Resolved.ModuleType.t -> t
 
-  let module_in_env env p : module_lookup_result ref_result =
-    Env.lookup_unit_by_path p env |> handle_lookup_error p >>= fun m ->
-    Ok (M.of_element env m)
+  val in_signature : Env.t -> signature_lookup_result -> ModuleTypeName.t -> (t, Errors.Tools_error.reference_lookup_error) result
+  
+  val in_env : Env.t -> string -> (t, Errors.Tools_error.reference_lookup_error) result
 
-  let any_in_env env p : any_path_lookup_result ref_result =
-    (* TODO: Resolve modules *)
-    let page_result = page_in_env env p in
-    let module_result = module_in_env env p in
-    match (page_result, module_result) with
-    | Ok page, Error _ -> Ok (`P page)
-    | Error _, Ok m ->
-        module_lookup_to_signature_lookup env m >>= fun s -> Ok (`S s)
-    | Ok page, Ok _ ->
-        let name = List.last (snd p) in
-        ambiguous_generic_ref_warning name [ "module"; "page" ];
-        Ok (`P page)
-    | Error _, Error _ -> mk_lookup_error p
-end
+  val in_env_by_id : Env.t -> Identifier.ModuleType.t -> (t, Errors.Tools_error.reference_lookup_error) result
 
-module MT = struct
+end = struct
   (** Module type *)
 
   type t = module_type_lookup_result
@@ -304,20 +303,60 @@ module MT = struct
     env_lookup_by_name Env.s_module_type name env >>= fun e ->
     Ok (of_element env e)
 
-  let in_env_by_id env id =
+  let rec in_env_by_id env id =
     match Env.lookup_by_id Env.s_module_type id env with
     | Some e -> Ok (of_element env e)
     | None -> match id.iv with
-      | `ModuleType (p, name) ->
+      | `ModuleType ({ Identifier.iv = #Identifier.Module.t_pv; _} as p, name) ->
           M.in_env_by_id env p >>=
           module_lookup_to_signature_lookup env >>=
           fun x -> in_signature env x name
-      | _ -> Error
-        (`Parent
-          (`Parent_module (`Lookup_failure_root (ModuleName.make_std (Identifier.name id)))))
+      | `ModuleType ({ Identifier.iv = #Identifier.ModuleType.t_pv; _} as p, name) ->
+        in_env_by_id env p >>=
+        module_type_lookup_to_signature_lookup env >>=
+        fun x -> in_signature env x name
+      | `ModuleType ({ Identifier.iv = `Result _; _}, _) ->
+        Error (`Lookup_by_id (id :> Identifier.t))
   
 end
 
+module Path = struct
+  (* let first_seg (`Root (s, _) | `Slash (_, s)) = s *)
+
+  let mk_lookup_error (tag, path) = Error (`Path_error (`Not_found, tag, path))
+
+  let handle_lookup_error p = function
+    | Ok _ as ok -> ok
+    | Error `Not_found -> mk_lookup_error p
+
+  let page_in_env env p : page_lookup_result ref_result =
+    Env.lookup_page_by_path p env |> handle_lookup_error p >>= fun p ->
+    Ok (`Identifier p.name, p)
+
+  let asset_in_env env p : asset_lookup_result ref_result =
+    Env.lookup_asset_by_path p env |> handle_lookup_error p >>= fun p ->
+    Ok (`Identifier p.name)
+
+  let module_in_env env p : module_lookup_result ref_result =
+    Env.lookup_unit_by_path p env |> handle_lookup_error p >>= fun m ->
+    Ok (M.of_element env m)
+
+  let any_in_env env p : any_path_lookup_result ref_result =
+    (* TODO: Resolve modules *)
+    let page_result = page_in_env env p in
+    let module_result = module_in_env env p in
+    match (page_result, module_result) with
+    | Ok page, Error _ -> Ok (`P page)
+    | Error _, Ok m ->
+        module_lookup_to_signature_lookup env m >>= fun s -> Ok (`S s)
+    | Ok page, Ok _ ->
+        let name = List.last (snd p) in
+        ambiguous_generic_ref_warning name [ "module"; "page" ];
+        Ok (`P page)
+    | Error _, Error _ -> mk_lookup_error p
+end
+
+
 module CL = struct
   (** Class *)
 
