diff options
Diffstat (limited to 'proofs/clenvtac.ml')
| -rw-r--r-- | proofs/clenvtac.ml | 42 |
1 files changed, 31 insertions, 11 deletions
diff --git a/proofs/clenvtac.ml b/proofs/clenvtac.ml index 8e922599..98b5bc8b 100644 --- a/proofs/clenvtac.ml +++ b/proofs/clenvtac.ml @@ -16,7 +16,7 @@ open Logic open Reduction open Tacmach open Clenv - +open Proofview.Notations (* This function put casts around metavariables whose type could not be * infered by the refiner, that is head of applications, predicates and @@ -59,6 +59,19 @@ let clenv_pose_dependent_evars with_evars clenv = (RefinerError (UnresolvedBindings (List.map (meta_name clenv.evd) dep_mvs))); clenv_pose_metas_as_evars clenv dep_mvs +(** Use our own fast path, more informative than from Typeclasses *) +let check_tc evd = + let has_resolvable = ref false in + let check _ evi = + let res = Typeclasses.is_resolvable evi in + if res then + let () = has_resolvable := true in + Typeclasses.is_class_evar evd evi + else false + in + let has_typeclass = Evar.Map.exists check (Evd.undefined_map evd) in + (has_typeclass, !has_resolvable) + let clenv_refine with_evars ?(with_classes=true) clenv = (** ppedrot: a Goal.enter here breaks things, because the tactic below may solve goals by side effects, while the compatibility layer keeps those @@ -67,9 +80,16 @@ let clenv_refine with_evars ?(with_classes=true) clenv = let clenv = clenv_pose_dependent_evars with_evars clenv in let evd' = if with_classes then - let evd' = Typeclasses.resolve_typeclasses ~filter:Typeclasses.all_evars - ~fail:(not with_evars) clenv.env clenv.evd - in Typeclasses.mark_unresolvables ~filter:Typeclasses.all_goals evd' + let (has_typeclass, has_resolvable) = check_tc clenv.evd in + let evd' = + if has_typeclass then + Typeclasses.resolve_typeclasses ~fast_path:false ~filter:Typeclasses.all_evars + ~fail:(not with_evars) clenv.env clenv.evd + else clenv.evd + in + if has_resolvable then + Typeclasses.mark_unresolvables ~filter:Typeclasses.all_goals evd' + else evd' else clenv.evd in let clenv = { clenv with evd = evd' } in @@ -83,10 +103,10 @@ open Unification let dft = default_unify_flags let res_pf ?(with_evars=false) ?(with_classes=true) ?(flags=dft ()) clenv = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let clenv gl = clenv_unique_resolver ~flags clenv gl in clenv_refine with_evars ~with_classes (Tacmach.New.of_old clenv (Proofview.Goal.assume gl)) - end + end } (* [unifyTerms] et [unify] ne semble pas gérer les Meta, en particulier ne semblent pas vérifier que des instances différentes @@ -118,12 +138,12 @@ let fail_quick_unif_flags = { (* let unifyTerms m n = walking (fun wc -> fst (w_Unify CONV m n [] wc)) *) let unify ?(flags=fail_quick_unif_flags) m = - Proofview.Goal.enter begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Tacmach.New.pf_env gl in - let n = Tacmach.New.pf_nf_concl gl in - let evd = create_goal_evar_defs (Proofview.Goal.sigma gl) in + let n = Tacmach.New.pf_concl (Proofview.Goal.assume gl) in + let evd = clear_metas (Tacmach.New.project gl) in try let evd' = w_unify env evd CONV ~flags m n in Proofview.Unsafe.tclEVARSADVANCE evd' - with e when Errors.noncritical e -> Proofview.tclZERO e - end + with e when CErrors.noncritical e -> Proofview.tclZERO e + end } |