Optionally (and by default) split typeclasses evars into connected

components and resolving them separately, reporting more precise failures. 
Improve error messages.


git-svn-id: svn+ssh://scm.gforge.inria.fr/svn/coq/trunk@11105 85f007b7-540e-0410-9357-904b9bb8a0f7

4 files changed, 17 insertions, 13 deletions

diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml
index 4b078ff304..519aee85d7 100644
--- a/pretyping/typeclasses.ml
+++ b/pretyping/typeclasses.ml
@@ -258,7 +258,7 @@ let instances r =
   let cl = class_info r in instances_of cl
 
 let solve_instanciation_problem = ref (fun _ _ _ _ -> assert false)
-let solve_instanciations_problem = ref (fun _ _ _ _ -> assert false)
+let solve_instanciations_problem = ref (fun _ _ _ _ _ -> assert false)
 
 let resolve_typeclass env ev evi (evd, defined as acc) =
   try
@@ -415,10 +415,10 @@ let has_typeclasses evd =
 	&& is_resolvable evi))
     evd false
 
-let resolve_typeclasses ?(onlyargs=false) ?(fail=true) env evd =
+let resolve_typeclasses ?(onlyargs=false) ?(split=true) ?(fail=true) env evd =
   if not (has_typeclasses (Evd.evars_of evd)) then evd
   else
-    !solve_instanciations_problem env (Evarutil.nf_evar_defs evd) onlyargs fail
+    !solve_instanciations_problem env (Evarutil.nf_evar_defs evd) onlyargs split fail
 
 type substitution = (identifier * constr) list
 
diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli
index b12a858695..cb867a0710 100644
--- a/pretyping/typeclasses.mli
+++ b/pretyping/typeclasses.mli
@@ -79,10 +79,10 @@ val is_resolvable : evar_info -> bool
 val mark_unresolvable : evar_info -> evar_info
 val mark_unresolvables : evar_map -> evar_map
 
-val resolve_typeclasses : ?onlyargs:bool -> ?fail:bool -> env -> evar_defs -> evar_defs
+val resolve_typeclasses : ?onlyargs:bool -> ?split:bool -> ?fail:bool -> env -> evar_defs -> evar_defs
 
 val solve_instanciation_problem : (env -> evar_defs -> existential_key -> evar_info -> evar_defs * bool) ref
-val solve_instanciations_problem : (env -> evar_defs -> bool -> bool -> evar_defs) ref
+val solve_instanciations_problem : (env -> evar_defs -> bool -> bool -> bool -> evar_defs) ref
 
 type substitution = (identifier * constr) list
 
diff --git a/pretyping/typeclasses_errors.ml b/pretyping/typeclasses_errors.ml
index aed42aa04d..72d23946cb 100644
--- a/pretyping/typeclasses_errors.ml
+++ b/pretyping/typeclasses_errors.ml
@@ -28,7 +28,7 @@ type typeclass_error =
     | NotAClass of constr
     | UnboundMethod of global_reference * identifier located (* Class name, method *)
     | NoInstance of identifier located * constr list
-    | UnsatisfiableConstraints of evar_defs
+    | UnsatisfiableConstraints of evar_defs * (evar_info * hole_kind) option
     | MismatchedContextInstance of contexts * constr_expr list * named_context (* found, expected *)
 
 exception TypeClassError of env * typeclass_error
@@ -41,10 +41,14 @@ let unbound_method env cid id = typeclass_error env (UnboundMethod (cid, id))
 
 let no_instance env id args = typeclass_error env (NoInstance (id, args))
 
-let unsatisfiable_constraints env evd = 
+let unsatisfiable_constraints env evd ev = 
   let evd = Evd.undefined_evars evd in
-  let ev = List.hd (Evd.dom (Evd.evars_of evd)) in
-  let loc, _ = Evd.evar_source ev evd in
-    raise (Stdpp.Exc_located (loc, TypeClassError (env, UnsatisfiableConstraints evd)))
-
+    match ev with
+    | None ->
+	raise (TypeClassError (env, UnsatisfiableConstraints (evd, None)))
+    | Some ev ->
+	let evi = Evd.find (Evd.evars_of evd) ev in
+	let loc, kind = Evd.evar_source ev evd in
+	  raise (Stdpp.Exc_located (loc, TypeClassError (env, UnsatisfiableConstraints (evd, Some (evi, kind)))))
+	    
 let mismatched_ctx_inst env c n m = typeclass_error env (MismatchedContextInstance (c, n, m))
diff --git a/pretyping/typeclasses_errors.mli b/pretyping/typeclasses_errors.mli
index d93a354eca..df196ae4ce 100644
--- a/pretyping/typeclasses_errors.mli
+++ b/pretyping/typeclasses_errors.mli
@@ -28,7 +28,7 @@ type typeclass_error =
     | NotAClass of constr
     | UnboundMethod of global_reference * identifier located (* Class name, method *)
     | NoInstance of identifier located * constr list
-    | UnsatisfiableConstraints of evar_defs
+    | UnsatisfiableConstraints of evar_defs * (evar_info * hole_kind) option
     | MismatchedContextInstance of contexts * constr_expr list * named_context (* found, expected *)
 
 exception TypeClassError of env * typeclass_error
@@ -39,6 +39,6 @@ val unbound_method : env -> global_reference -> identifier located -> 'a
 
 val no_instance : env -> identifier located -> constr list -> 'a
 
-val unsatisfiable_constraints : env -> evar_defs -> 'a
+val unsatisfiable_constraints : env -> evar_defs -> evar option -> 'a
 
 val mismatched_ctx_inst : env -> contexts -> constr_expr list -> named_context -> 'a