Better handling of errors in 'type_of.ml'

The code for 'module type of' expansion runs before any other resolution
happens, and it needs to run until a fixed point. Since the change to
use 'Result.t' over simply raising exceptions when we notice we'll need
to recurse, a bug was introduced when the specific error case we're
looking for was swallowed in another layer. This PR attempts to make
sure we don't ever throw away an error raised during signature expansion
and adds some code to check in the combined error whether the root cause
was in fact the case we're looking for; `` `UnexpandedTypeOf `` in this
case.

Signed-off-by: Jon Ludlam <jon@recoil.org>

Author: jonludlam

src/xref2/errors.ml

@@ -13,12 +13,13 @@ module Tools_error = struct
     | `UnresolvedForwardPath
       (** The module signature depends upon a forward path *)
     | `UnresolvedPath of
-      [ `Module of Cpath.module_ | `ModuleType of Cpath.module_type ]
+      [ `Module of Cpath.module_ * simple_module_lookup_error
+      | `ModuleType of Cpath.module_type * simple_module_type_lookup_error ]
       (** The path to the module or module type could not be resolved *)
     | `UnexpandedTypeOf of Component.ModuleType.type_of_desc
       (** The `module type of` expression could not be expanded *) ]
 
-  type simple_module_lookup_error =
+  and simple_module_lookup_error =
     [ `Local of Env.t * Ident.path_module
       (** Internal error: Found local path during lookup *)
     | `Unresolved_apply  (** [`Apply] argument is not [`Resolved] *)
@@ -37,7 +38,8 @@ module Tools_error = struct
     | `UnresolvedForwardPath
       (** The module signature depends upon a forward path *)
     | `UnresolvedPath of
-      [ `Module of Cpath.module_ | `ModuleType of Cpath.module_type ]
+      [ `Module of Cpath.module_ * simple_module_lookup_error
+      | `ModuleType of Cpath.module_type * simple_module_type_lookup_error ]
     | `Parent of parent_lookup_error ]
 
   and simple_module_type_lookup_error =
@@ -77,19 +79,20 @@ module Tools_error = struct
     | simple_module_type_lookup_error
     | simple_module_type_expr_of_module_error
     | simple_module_lookup_error
-    | signature_of_module_error ]
+    | signature_of_module_error
+    | parent_lookup_error ]
 
   let rec pp : Format.formatter -> any -> unit =
    fun fmt err ->
     match err with
     | `OpaqueModule -> Format.fprintf fmt "OpaqueModule"
     | `UnresolvedForwardPath -> Format.fprintf fmt "Unresolved forward path"
-    | `UnresolvedPath (`Module p) ->
-        Format.fprintf fmt "Unresolved module path %a" Component.Fmt.module_path
-          p
-    | `UnresolvedPath (`ModuleType p) ->
-        Format.fprintf fmt "Unresolved module type path %a"
-          Component.Fmt.module_type_path p
+    | `UnresolvedPath (`Module (p, e)) ->
+        Format.fprintf fmt "Unresolved module path %a (%a)" Component.Fmt.module_path
+          p pp (e :> any)
+    | `UnresolvedPath (`ModuleType (p, e)) ->
+        Format.fprintf fmt "Unresolved module type path %a (%a)"
+          Component.Fmt.module_type_path p pp (e :> any)
     | `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
@@ -111,16 +114,10 @@ module Tools_error = struct
           (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_parent fmt p
+    | `Parent p -> pp fmt (p :> any)
     | `UnexpandedTypeOf t ->
         Format.fprintf fmt "Unexpanded `module type of` expression: %a"
           Component.Fmt.module_type_type_of_desc t
-
-
-  and pp_parent : Format.formatter -> parent_lookup_error -> unit =
-   fun fmt err ->
-    match err with
-    | `Parent p -> pp_parent fmt p
     | `Parent_sig e -> Format.fprintf fmt "Parent_sig: %a" pp (e :> any)
     | `Parent_module_type e ->
         Format.fprintf fmt "Parent_module_type: %a" pp (e :> any)
@@ -129,6 +126,35 @@ module Tools_error = struct
     | `Fragment_root -> Format.fprintf fmt "Fragment root"
 end
 
+ (* Ugh. we need to determine whether this was down to an unexpanded module type error. This is horrendous. *)
+ let is_unexpanded_module_type_of =
+  let open Tools_error in
+  let rec inner : any -> bool = function
+  | `Local _ -> false
+  | `Find_failure -> false
+  | `Lookup_failure _ -> false
+  | `Unresolved_apply -> false
+  | `Lookup_failure_root _ -> false
+  | `Parent p -> inner (p :> any)
+  | `Parent_sig p -> inner (p :> any)
+  | `Parent_module_type p -> inner (p :> any)
+  | `Parent_expr p -> inner (p :> any)
+  | `Parent_module p -> inner (p :> any)
+  | `Fragment_root -> false
+  | `OpaqueModule -> false
+  | `UnresolvedForwardPath -> false
+  | `UnexpandedTypeOf _ -> true (* woo *)
+  | `LocalMT _ -> false
+  | `Lookup_failureMT _ -> false
+  | `ApplyNotFunctor -> false
+  | `UnresolvedPath (`Module (_, e)) -> inner (e :> any)
+  | `UnresolvedPath (`ModuleType (_, e)) -> inner (e :> any)
+  | `Lookup_failureT _ -> false
+  | `LocalType _ -> false
+  | `Class_replaced -> false
+  in inner
+
+
 (** To use as [Lookup_failures.kind]. *)
 let rec kind_of_module_cpath = function
   | `Root _ -> Some `Root
@@ -145,8 +171,8 @@ let rec kind_of_module_type_cpath = function
   | _ -> None
 
 let rec kind_of_error = function
-  | `UnresolvedPath (`Module cp) -> kind_of_module_cpath cp
-  | `UnresolvedPath (`ModuleType cp) -> kind_of_module_type_cpath cp
+  | `UnresolvedPath (`Module (cp, _)) -> kind_of_module_cpath cp
+  | `UnresolvedPath (`ModuleType (cp, _)) -> kind_of_module_type_cpath cp
   | `Lookup_failure (`Root _) | `Lookup_failure_root _ -> Some `Root
   | `Parent (`Parent_sig e) -> kind_of_error (e :> Tools_error.any)
   | `Parent (`Parent_module_type e) -> kind_of_error (e :> Tools_error.any)

src/xref2/expand_tools.ml

@@ -83,7 +83,8 @@ and aux_expansion_of_module_alias env ~strengthen path =
              Component.Fmt.signature sg'; *)
           Ok (Signature { sg' with items = Comment (`Docs docs) :: sg'.items })
       | Ok (Functor _ as x), _ -> Ok x )
-  | Error _ -> Error (`UnresolvedPath (`Module path))
+  | Error e ->
+    Error (`UnresolvedPath (`Module (path, e)))
 
 (* We need to reresolve fragments in expansions as the root of the fragment
    may well change - so we turn resolved fragments back into unresolved ones
@@ -114,7 +115,7 @@ and aux_expansion_of_u_module_type_expr env expr :
   match expr with
   | Component.ModuleType.U.Path p ->
     Tools.resolve_module_type ~mark_substituted:false env p
-    |> map_error (fun _ -> (`UnresolvedPath (`ModuleType p) : signature_of_module_error))
+    |> map_error (fun e -> (`UnresolvedPath (`ModuleType (p, e)) : signature_of_module_error))
     >>= fun (_, mt) -> aux_expansion_of_module_type env mt
     >>= assert_not_functor
   | Signature sg -> Ok (sg)
@@ -131,7 +132,7 @@ and aux_expansion_of_module_type_expr env expr :
   match expr with
   | Path {p_path; _} ->
       Tools.resolve_module_type ~mark_substituted:false env p_path
-      |> map_error (fun _ -> (`UnresolvedPath (`ModuleType p_path) : signature_of_module_error))
+      |> map_error (fun e -> (`UnresolvedPath (`ModuleType (p_path, e)) : signature_of_module_error))
       >>= fun (_, mt) -> aux_expansion_of_module_type env mt
   | Signature s -> Ok (Signature s)
   | With {w_substitutions; w_expr; _} -> (

src/xref2/tools.ml

@@ -404,10 +404,9 @@ and handle_module_lookup env ~add_canonical id parent sg sub =
       let m' = Subst.module_ sub m in
       let md' = Component.Delayed.put_val m' in
       Ok (process_module_path env ~add_canonical m' p', md')
-  | Some (`FModule_removed p) -> (
-      match lookup_module ~mark_substituted:false env p with
-      | Ok m -> Ok (p, m)
-      | Error _ as e -> e )
+  | Some (`FModule_removed p) ->
+      lookup_module ~mark_substituted:false env p
+      >>= fun m -> Ok (p, m)
   | None -> Error `Find_failure
 
 and handle_module_type_lookup env id p sg sub =
@@ -447,15 +446,14 @@ and lookup_module :
         of_option ~error:(`Lookup_failure i) (Env.(lookup_by_id s_module) i env)
         >>= fun (`Module (_, m)) -> Ok m
     | `Substituted x -> lookup_module ~mark_substituted env x
-    | `Apply (functor_path, argument_path) -> (
-        match lookup_module ~mark_substituted env functor_path with
-        | Ok functor_module ->
-            let functor_module = Component.Delayed.get functor_module in
-            handle_apply ~mark_substituted:false env functor_path argument_path
-              functor_module
-            |> map_error (fun e -> `Parent (`Parent_expr e))
-            >>= fun (_, m) -> Ok (Component.Delayed.put_val m)
-        | Error _ as e -> e )
+    | `Apply (functor_path, argument_path) ->
+        lookup_module ~mark_substituted env functor_path
+        >>= fun functor_module ->
+        let functor_module = Component.Delayed.get functor_module in
+        handle_apply ~mark_substituted:false env functor_path argument_path
+          functor_module
+        |> map_error (fun e -> `Parent (`Parent_expr e))
+        >>= fun (_, m) -> Ok (Component.Delayed.put_val m)        
     | `Module (parent, name) ->
         let find_in_sg sg sub =
           match Find.careful_module_in_sig sg (ModuleName.to_string name) with
@@ -958,7 +956,7 @@ and module_type_expr_of_module_decl :
           module_type_expr_of_module env m
       | Error _ when Cpath.is_module_forward path ->
           Error `UnresolvedForwardPath
-      | Error _ -> Error (`UnresolvedPath (`Module path)) )
+      | Error e -> Error (`UnresolvedPath (`Module (path, e))) )
   | Component.Module.ModuleType expr -> Ok expr
 
 and module_type_expr_of_module :
@@ -982,7 +980,7 @@ and signature_of_module_path :
       signature_of_module_cached env p' m >>= fun sg ->
       if strengthen then Ok (Strengthen.signature (`Resolved p') sg) else Ok sg
   | Error _ when Cpath.is_module_forward path -> Error `UnresolvedForwardPath
-  | Error _ -> Error (`UnresolvedPath (`Module path))
+  | Error e -> Error (`UnresolvedPath (`Module (path, e)))
 
 and handle_signature_with_subs :
     mark_substituted:bool ->
@@ -1007,7 +1005,7 @@ and signature_of_u_module_type_expr :
   | Component.ModuleType.U.Path p -> (
       match resolve_module_type ~mark_substituted env p with
       | Ok (_, mt) -> signature_of_module_type env mt
-      | Error _ -> Error (`UnresolvedPath (`ModuleType p)) )
+      | Error e -> Error (`UnresolvedPath (`ModuleType (p, e))) )
   | Signature s -> Ok s
   | With (subs, s) ->
       signature_of_u_module_type_expr ~mark_substituted env s >>= fun sg ->
@@ -1032,7 +1030,7 @@ and signature_of_module_type_expr :
   | Component.ModuleType.Path {p_path; _} -> (
       match resolve_module_type ~mark_substituted env p_path with
       | Ok (_, mt) -> signature_of_module_type env mt
-      | Error _ -> Error (`UnresolvedPath (`ModuleType p_path)) )
+      | Error e -> Error (`UnresolvedPath (`ModuleType (p_path, e))) )
   | Component.ModuleType.Signature s -> Ok s
   | Component.ModuleType.With {w_expansion=Some e; _} ->
     Ok (signature_of_simple_expansion e)
@@ -1227,10 +1225,10 @@ and fragmap :
                 resolve_module ~mark_substituted ~add_canonical:false env p
               with
               | Ok (p, _) -> Ok (Right p)
-              | Error _ ->
+              | Error e ->
                   Format.fprintf Format.err_formatter
                     "failed to resolve path: %a\n%!" Component.Fmt.module_path p;
-                  Error (`UnresolvedPath (`Module p))
+                  Error (`UnresolvedPath (`Module (p, e)))
             in
             map_signature None (Some (name, mapfn)) sg.items )
     | TypeEq (frag, equation) -> (

src/xref2/type_of.ml

@@ -61,8 +61,9 @@ and module_type_expr env (id : Id.Signature.t) expr =
   | TypeOf t ->
     match module_type_expr_typeof env id t with
     | Ok e -> TypeOf {t with t_expansion = Some (Lang_of.(simple_expansion empty id e)) }
-    | Error (`UnexpandedTypeOf _) -> again := true; expr
-    | Error _ -> expr
+    | Error e when Errors.is_unexpanded_module_type_of (e :> Errors.Tools_error.any) -> again := true; expr
+    | Error _e ->
+      expr
 
 and u_module_type_expr env id expr =
   match expr with
@@ -72,8 +73,9 @@ and u_module_type_expr env id expr =
   | TypeOf t ->
     match module_type_expr_typeof env id t with
     | Ok e -> TypeOf {t with t_expansion = Some (Lang_of.(simple_expansion empty id e)) }
-    | Error (`UnexpandedTypeOf _) -> again := true; expr
-    | Error _ -> expr
+    | Error e when Errors.is_unexpanded_module_type_of (e :> Errors.Tools_error.any) -> again := true; expr
+    | Error _e ->
+      expr
 
 and functor_parameter env p =
   { p with expr = module_type_expr env (p.id :> Id.Signature.t) p.expr}