From 547e7ac53d556c1a8036334301c1a707f22b0230 Mon Sep 17 00:00:00 2001
From: msozeau
Date: Wed, 11 Jun 2008 13:47:21 +0000
Subject: 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
---
 pretyping/typeclasses_errors.ml | 16 ++++++++++------
 1 file changed, 10 insertions(+), 6 deletions(-)

(limited to 'pretyping/typeclasses_errors.ml')

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))
-- 
cgit v1.2.3