diff options
| -rw-r--r-- | pretyping/typeclasses.ml | 11 | ||||
| -rw-r--r-- | pretyping/typeclasses.mli | 1 | ||||
| -rw-r--r-- | tactics/btermdn.ml | 2 | ||||
| -rw-r--r-- | tactics/class_tactics.ml4 | 7 | ||||
| -rw-r--r-- | tactics/termdn.ml | 1 |
5 files changed, 15 insertions, 7 deletions
diff --git a/pretyping/typeclasses.ml b/pretyping/typeclasses.ml index 0d15034ce..04b34db38 100644 --- a/pretyping/typeclasses.ml +++ b/pretyping/typeclasses.ml @@ -357,10 +357,17 @@ let mark_unresolvables sigma = Evd.add evs ev (mark_unresolvable evi)) sigma Evd.empty +let rec is_class_type c = + match kind_of_term c with + | Prod (_, _, t) -> is_class_type t + | _ -> class_of_constr c <> None + +let is_class_evar evi = + is_class_type evi.Evd.evar_concl + let has_typeclasses evd = Evd.fold (fun ev evi has -> has || - (evi.evar_body = Evar_empty && class_of_constr evi.evar_concl <> None - && is_resolvable evi)) + (evi.evar_body = Evar_empty && is_class_evar evi && is_resolvable evi)) evd false let solve_instanciations_problem = ref (fun _ _ _ _ _ -> assert false) diff --git a/pretyping/typeclasses.mli b/pretyping/typeclasses.mli index 8960ab21b..ce0975c69 100644 --- a/pretyping/typeclasses.mli +++ b/pretyping/typeclasses.mli @@ -75,6 +75,7 @@ val bool_out : Dyn.t -> bool val is_resolvable : evar_info -> bool val mark_unresolvable : evar_info -> evar_info val mark_unresolvables : evar_map -> evar_map +val is_class_evar : evar_info -> bool val resolve_typeclasses : ?onlyargs:bool -> ?split:bool -> ?fail:bool -> env -> evar_defs -> evar_defs diff --git a/tactics/btermdn.ml b/tactics/btermdn.ml index 2412968a1..379949f46 100644 --- a/tactics/btermdn.ml +++ b/tactics/btermdn.ml @@ -52,7 +52,7 @@ let bounded_constr_val_discr (t,depth) = match constr_val_discr t with | Dn.Label (c,l) -> Dn.Label(c,List.map (fun c -> (c,depth-1)) l) | Dn.Nothing -> Dn.Nothing - | Dn.Everything -> Dn.Nothing + | Dn.Everything -> Dn.Everything type 'a t = (global_reference,constr_pattern * int,'a) Dn.t diff --git a/tactics/class_tactics.ml4 b/tactics/class_tactics.ml4 index 64ea47a9b..16e8bce3a 100644 --- a/tactics/class_tactics.ml4 +++ b/tactics/class_tactics.ml4 @@ -515,11 +515,10 @@ let resolve_typeclass_evars d p env evd onlyargs split fail = let pred = if onlyargs then (fun ev evi -> Typeclasses.is_implicit_arg (snd (Evd.evar_source ev evd)) && - class_of_constr evi.Evd.evar_concl <> None) - else - (fun ev evi -> class_of_constr evi.Evd.evar_concl <> None) + Typeclasses.is_class_evar evi) + else (fun ev evi -> Typeclasses.is_class_evar evi) in resolve_all_evars d p env pred evd split fail - + let solve_inst debug mode depth env evd onlyargs split fail = resolve_typeclass_evars debug (mode, depth) env evd onlyargs split fail diff --git a/tactics/termdn.ml b/tactics/termdn.ml index 995183dc9..591b2947c 100644 --- a/tactics/termdn.ml +++ b/tactics/termdn.ml @@ -70,6 +70,7 @@ let constr_val_discr t = | Ind ind_sp -> Label(IndRef ind_sp,l) | Construct cstr_sp -> Label((ConstructRef cstr_sp),l) | Var id -> Label(VarRef id,l) + | Const _ -> Everything | _ -> Nothing let constr_val_discr_st (idpred,cpred) t = |