aboutsummaryrefslogtreecommitdiff
path: root/tactics
diff options
context:
space:
mode:
Diffstat (limited to 'tactics')
-rw-r--r--tactics/auto.ml11
-rw-r--r--tactics/class_tactics.ml31
-rw-r--r--tactics/class_tactics.mli2
-rw-r--r--tactics/equality.ml28
-rw-r--r--tactics/leminv.ml15
-rw-r--r--tactics/tacticals.ml16
-rw-r--r--tactics/tacticals.mli4
-rw-r--r--tactics/tactics.ml45
8 files changed, 83 insertions, 69 deletions
diff --git a/tactics/auto.ml b/tactics/auto.ml
index 74cb7a364f..42230dff17 100644
--- a/tactics/auto.ml
+++ b/tactics/auto.ml
@@ -380,7 +380,7 @@ and my_find_search_delta sigma db_list local_db secvars hdc concl =
and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly;db=dbname})) =
let tactic = function
| Res_pf (c,cl) -> unify_resolve_gen poly flags (c,cl)
- | ERes_pf _ -> Proofview.V82.tactic (fun gl -> error "eres_pf")
+ | ERes_pf _ -> Proofview.Goal.enter { enter = fun gl -> Tacticals.New.tclZEROMSG (str "eres_pf") }
| Give_exact (c, cl) -> exact poly (c, cl)
| Res_pf_THEN_trivial_fail (c,cl) ->
Tacticals.New.tclTHEN
@@ -389,10 +389,11 @@ and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly;db=
with "debug auto" we don't display the details of inner trivial *)
(trivial_fail_db (no_dbg ()) (not (Option.is_empty flags)) db_list local_db)
| Unfold_nth c ->
- Proofview.V82.tactic (fun gl ->
- if exists_evaluable_reference (pf_env gl) c then
- tclPROGRESS (Proofview.V82.of_tactic (reduce (Unfold [AllOccurrences,c]) Locusops.onConcl)) gl
- else tclFAIL 0 (str"Unbound reference") gl)
+ Proofview.Goal.enter { enter = begin fun gl ->
+ if exists_evaluable_reference (Tacmach.New.pf_env gl) c then
+ Tacticals.New.tclPROGRESS (reduce (Unfold [AllOccurrences,c]) Locusops.onConcl)
+ else Tacticals.New.tclFAIL 0 (str"Unbound reference")
+ end }
| Extern tacast ->
conclPattern concl p tacast
in
diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml
index df222eed80..54e4405d1c 100644
--- a/tactics/class_tactics.ml
+++ b/tactics/class_tactics.ml
@@ -221,18 +221,22 @@ let auto_unif_flags freeze st =
resolve_evars = false
}
-let e_give_exact flags poly (c,clenv) gl =
+let e_give_exact flags poly (c,clenv) =
+ let open Tacmach.New in
+ Proofview.Goal.s_enter { s_enter = begin fun gl ->
+ let sigma = project gl in
let (c, _, _) = c in
- let c, gl =
+ let c, sigma =
if poly then
let clenv', subst = Clenv.refresh_undefined_univs clenv in
- let evd = evars_reset_evd ~with_conv_pbs:true gl.sigma clenv'.evd in
+ let evd = evars_reset_evd ~with_conv_pbs:true sigma clenv'.evd in
let c = Vars.subst_univs_level_constr subst c in
- c, {gl with sigma = evd}
- else c, gl
+ c, evd
+ else c, sigma
in
- let t1 = pf_unsafe_type_of gl c in
- Proofview.V82.of_tactic (Clenvtac.unify ~flags t1 <*> exact_no_check c) gl
+ let (sigma, t1) = Typing.type_of (pf_env gl) sigma c in
+ Sigma.Unsafe.of_pair (Clenvtac.unify ~flags t1 <*> exact_no_check c, sigma)
+ end }
let unify_e_resolve poly flags = { enter = begin fun gls (c,_,clenv) ->
let clenv', c = connect_hint_clenv poly c clenv gls in
@@ -455,15 +459,14 @@ and e_my_find_search db_list local_db secvars hdc complete only_classes sigma co
{ enter = fun gl -> unify_resolve_refine poly flags gl (c,None,clenv) } in
Tacticals.New.tclTHEN tac Proofview.shelve_unifiable
else
- Proofview.V82.tactic (e_give_exact flags poly (c,clenv))
+ e_give_exact flags poly (c,clenv)
| Res_pf_THEN_trivial_fail (term,cl) ->
let fst = with_prods nprods poly (term,cl) (unify_e_resolve poly flags) in
let snd = if complete then Tacticals.New.tclIDTAC
else e_trivial_fail_db only_classes db_list local_db secvars in
Tacticals.New.tclTHEN fst snd
| Unfold_nth c ->
- let tac = Proofview.V82.of_tactic (unfold_in_concl [AllOccurrences,c]) in
- Proofview.V82.tactic (tclWEAK_PROGRESS tac)
+ Proofview.tclPROGRESS (unfold_in_concl [AllOccurrences,c])
| Extern tacast -> conclPattern concl p tacast
in
let tac = run_hint t tac in
@@ -1614,9 +1617,11 @@ let not_evar c =
| Evar _ -> Tacticals.New.tclFAIL 0 (str"Evar")
| _ -> Proofview.tclUNIT ()
-let is_ground c gl =
- if Evarutil.is_ground_term (project gl) c then tclIDTAC gl
- else tclFAIL 0 (str"Not ground") gl
+let is_ground c =
+ let open Tacticals.New in
+ Proofview.tclEVARMAP >>= fun sigma ->
+ if Evarutil.is_ground_term sigma c then tclIDTAC
+ else tclFAIL 0 (str"Not ground")
let autoapply c i =
let open Proofview.Notations in
diff --git a/tactics/class_tactics.mli b/tactics/class_tactics.mli
index a38be5972f..738cc0feba 100644
--- a/tactics/class_tactics.mli
+++ b/tactics/class_tactics.mli
@@ -33,7 +33,7 @@ val head_of_constr : Id.t -> constr -> unit Proofview.tactic
val not_evar : constr -> unit Proofview.tactic
-val is_ground : constr -> tactic
+val is_ground : constr -> unit Proofview.tactic
val autoapply : constr -> Hints.hint_db_name -> unit Proofview.tactic
diff --git a/tactics/equality.ml b/tactics/equality.ml
index 7ae7446c82..25c28cf4ac 100644
--- a/tactics/equality.ml
+++ b/tactics/equality.ml
@@ -97,9 +97,6 @@ let _ =
(* Rewriting tactics *)
-let tclNOTSAMEGOAL tac =
- Proofview.V82.tactic (Tacticals.tclNOTSAMEGOAL (Proofview.V82.of_tactic tac))
-
type dep_proof_flag = bool (* true = support rewriting dependent proofs *)
type freeze_evars_flag = bool (* true = don't instantiate existing evars *)
@@ -268,6 +265,25 @@ let rewrite_elim with_evars frzevars cls c e =
general_elim_clause with_evars flags cls c e
end }
+let tclNOTSAMEGOAL tac =
+ let goal gl = Proofview.Goal.goal (Proofview.Goal.assume gl) in
+ Proofview.Goal.nf_enter { enter = begin fun gl ->
+ let sigma = project gl in
+ let ev = goal gl in
+ tac >>= fun () ->
+ Proofview.Goal.goals >>= fun gls ->
+ let check accu gl' =
+ gl' >>= fun gl' ->
+ let accu = accu || Goal.V82.same_goal sigma ev (project gl') (goal gl') in
+ Proofview.tclUNIT accu
+ in
+ Proofview.Monad.List.fold_left check false gls >>= fun has_same ->
+ if has_same then
+ tclZEROMSG (str"Tactic generated a subgoal identical to the original goal.")
+ else
+ Proofview.tclUNIT ()
+ end }
+
(* Ad hoc asymmetric general_elim_clause *)
let general_elim_clause with_evars frzevars cls rew elim =
let open Pretype_errors in
@@ -642,8 +658,8 @@ let replace_using_leibniz clause c1 c2 l2r unsafe try_prove_eq_opt =
| Some evd ->
let e = build_coq_eq () in
let sym = build_coq_eq_sym () in
- Tacticals.New.pf_constr_of_global sym (fun sym ->
- Tacticals.New.pf_constr_of_global e (fun e ->
+ Tacticals.New.pf_constr_of_global sym >>= fun sym ->
+ Tacticals.New.pf_constr_of_global e >>= fun e ->
let eq = applist (e, [t1;c1;c2]) in
tclTHENLAST
(replace_core clause l2r eq)
@@ -651,7 +667,7 @@ let replace_using_leibniz clause c1 c2 l2r unsafe try_prove_eq_opt =
[assumption;
tclTHEN (apply sym) assumption;
try_prove_eq
- ])))
+ ])
end }
let replace c1 c2 =
diff --git a/tactics/leminv.ml b/tactics/leminv.ml
index daa962f1d6..83f3da30a9 100644
--- a/tactics/leminv.ml
+++ b/tactics/leminv.ml
@@ -260,22 +260,23 @@ let add_inversion_lemma_exn na com comsort bool tac =
(* Applying a given inversion lemma *)
(* ================================= *)
-let lemInv id c gls =
+let lemInv id c =
+ Proofview.Goal.enter { enter = begin fun gls ->
try
- let open Tacmach in
let clause = mk_clenv_from_env (pf_env gls) (project gls) None (c, pf_unsafe_type_of gls c) in
let clause = clenv_constrain_last_binding (EConstr.mkVar id) clause in
- Proofview.V82.of_tactic (Clenvtac.res_pf clause ~flags:(Unification.elim_flags ()) ~with_evars:false) gls
+ Clenvtac.res_pf clause ~flags:(Unification.elim_flags ()) ~with_evars:false
with
| NoSuchBinding ->
user_err
- (hov 0 (pr_econstr_env (Refiner.pf_env gls) (Refiner.project gls) c ++ spc () ++ str "does not refer to an inversion lemma."))
+ (hov 0 (pr_econstr_env (pf_env gls) (project gls) c ++ spc () ++ str "does not refer to an inversion lemma."))
| UserError (a,b) ->
user_err ~hdr:"LemInv"
(str "Cannot refine current goal with the lemma " ++
- pr_leconstr_env (Refiner.pf_env gls) (Refiner.project gls) c)
+ pr_leconstr_env (pf_env gls) (project gls) c)
+ end }
-let lemInv_gen id c = try_intros_until (fun id -> Proofview.V82.tactic (lemInv id c)) id
+let lemInv_gen id c = try_intros_until (fun id -> lemInv id c) id
let lemInvIn id c ids =
Proofview.Goal.enter { enter = begin fun gl ->
@@ -289,7 +290,7 @@ let lemInvIn id c ids =
else
(tclTHEN (tclDO nb_of_new_hyp intro) (intros_replacing ids))
in
- ((tclTHEN (tclTHEN (bring_hyps hyps) (Proofview.V82.tactic (lemInv id c)))
+ ((tclTHEN (tclTHEN (bring_hyps hyps) (lemInv id c))
(intros_replace_ids)))
end }
diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml
index 90b7d6581a..c8441a8cc9 100644
--- a/tactics/tacticals.ml
+++ b/tactics/tacticals.ml
@@ -51,10 +51,8 @@ let tclAT_LEAST_ONCE = Refiner.tclAT_LEAST_ONCE
let tclFAIL = Refiner.tclFAIL
let tclFAIL_lazy = Refiner.tclFAIL_lazy
let tclDO = Refiner.tclDO
-let tclWEAK_PROGRESS = Refiner.tclWEAK_PROGRESS
let tclPROGRESS = Refiner.tclPROGRESS
let tclSHOWHYPS = Refiner.tclSHOWHYPS
-let tclNOTSAMEGOAL = Refiner.tclNOTSAMEGOAL
let tclTHENTRY = Refiner.tclTHENTRY
let tclIFTHENELSE = Refiner.tclIFTHENELSE
let tclIFTHENSELSE = Refiner.tclIFTHENSELSE
@@ -734,13 +732,11 @@ module New = struct
let case_nodep_then_using =
general_elim_then_using gl_make_case_nodep false
- let pf_constr_of_global ref tac =
- Proofview.Goal.enter { enter = begin fun gl ->
- let env = Proofview.Goal.env gl in
- let sigma = Tacmach.New.project gl in
- let (sigma, c) = Evd.fresh_global env sigma ref in
- let c = EConstr.of_constr c in
- Proofview.Unsafe.tclEVARS sigma <*> (tac c)
- end }
+ let pf_constr_of_global ref =
+ Proofview.tclEVARMAP >>= fun sigma ->
+ Proofview.tclENV >>= fun env ->
+ let (sigma, c) = Evd.fresh_global env sigma ref in
+ let c = EConstr.of_constr c in
+ Proofview.Unsafe.tclEVARS sigma <*> Proofview.tclUNIT c
end
diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli
index 3b90ec514a..5a4ecbac75 100644
--- a/tactics/tacticals.mli
+++ b/tactics/tacticals.mli
@@ -44,10 +44,8 @@ val tclAT_LEAST_ONCE : tactic -> tactic
val tclFAIL : int -> std_ppcmds -> tactic
val tclFAIL_lazy : int -> std_ppcmds Lazy.t -> tactic
val tclDO : int -> tactic -> tactic
-val tclWEAK_PROGRESS : tactic -> tactic
val tclPROGRESS : tactic -> tactic
val tclSHOWHYPS : tactic -> tactic
-val tclNOTSAMEGOAL : tactic -> tactic
val tclTHENTRY : tactic -> tactic -> tactic
val tclMAP : ('a -> tactic) -> 'a list -> tactic
@@ -265,5 +263,5 @@ module New : sig
val elim_on_ba : (branch_assumptions -> unit Proofview.tactic) -> branch_args -> unit Proofview.tactic
val case_on_ba : (branch_assumptions -> unit Proofview.tactic) -> branch_args -> unit Proofview.tactic
- val pf_constr_of_global : Globnames.global_reference -> (constr -> unit Proofview.tactic) -> unit Proofview.tactic
+ val pf_constr_of_global : Globnames.global_reference -> constr Proofview.tactic
end
diff --git a/tactics/tactics.ml b/tactics/tactics.ml
index e792585822..9c2a1d8509 100644
--- a/tactics/tactics.ml
+++ b/tactics/tactics.ml
@@ -2811,20 +2811,18 @@ let generalize_goal_gen env sigma ids i ((occs,c,b),na) t cl =
mkProd_or_LetIn decl cl', sigma'
let generalize_goal gl i ((occs,c,b),na as o) (cl,sigma) =
- let env = Tacmach.pf_env gl in
- let ids = Tacmach.pf_ids_of_hyps gl in
- let sigma, t = Typing.type_of env sigma c in
- generalize_goal_gen env sigma ids i o t cl
-
-let new_generalize_goal gl i ((occs,c,b),na as o) (cl,sigma) =
- let env = Tacmach.New.pf_env gl in
- let ids = Tacmach.New.pf_ids_of_hyps gl in
+ let open Tacmach.New in
+ let env = pf_env gl in
+ let ids = pf_ids_of_hyps gl in
let sigma, t = Typing.type_of env sigma c in
generalize_goal_gen env sigma ids i o t cl
-let old_generalize_dep ?(with_let=false) c gl =
+let generalize_dep ?(with_let=false) c =
+ let open Tacmach.New in
+ let open Tacticals.New in
+ Proofview.Goal.nf_s_enter { s_enter = begin fun gl ->
let env = pf_env gl in
- let sign = pf_hyps gl in
+ let sign = Proofview.Goal.hyps gl in
let sigma = project gl in
let init_ids = ids_of_named_context (Global.named_context()) in
let seek (d:named_declaration) (toquant:named_context) =
@@ -2843,11 +2841,11 @@ let old_generalize_dep ?(with_let=false) c gl =
-> id::tothin
| _ -> tothin
in
- let cl' = it_mkNamedProd_or_LetIn (Tacmach.pf_concl gl) to_quantify in
+ let cl' = it_mkNamedProd_or_LetIn (pf_concl gl) to_quantify in
let body =
if with_let then
match EConstr.kind sigma c with
- | Var id -> id |> Tacmach.pf_get_hyp gl |> NamedDecl.get_value
+ | Var id -> id |> (fun id -> pf_get_hyp id gl) |> NamedDecl.get_value
| _ -> None
else None
in
@@ -2856,20 +2854,19 @@ let old_generalize_dep ?(with_let=false) c gl =
(** Check that the generalization is indeed well-typed *)
let (evd, _) = Typing.type_of env evd cl'' in
let args = Context.Named.to_instance mkVar to_quantify_rev in
- tclTHENLIST
- [tclEVARS evd;
- Proofview.V82.of_tactic (apply_type cl'' (if Option.is_empty body then c::args else args));
- Proofview.V82.of_tactic (clear (List.rev tothin'))]
- gl
-
-let generalize_dep ?(with_let = false) c =
- Proofview.V82.tactic (old_generalize_dep ~with_let c)
+ let tac =
+ tclTHEN
+ (apply_type cl'' (if Option.is_empty body then c::args else args))
+ (clear (List.rev tothin'))
+ in
+ Sigma.Unsafe.of_pair (tac, evd)
+ end }
(** *)
let generalize_gen_let lconstr = Proofview.Goal.s_enter { s_enter = begin fun gl ->
let env = Proofview.Goal.env gl in
let newcl, evd =
- List.fold_right_i (new_generalize_goal gl) 0 lconstr
+ List.fold_right_i (generalize_goal gl) 0 lconstr
(Tacmach.New.pf_concl gl,Tacmach.New.project gl)
in
let (evd, _) = Typing.type_of env evd newcl in
@@ -4724,7 +4721,7 @@ let symmetry_red allowred =
| Some eq_data,_,_ ->
Tacticals.New.tclTHEN
(convert_concl_no_check concl DEFAULTcast)
- (Tacticals.New.pf_constr_of_global eq_data.sym apply)
+ (Tacticals.New.pf_constr_of_global eq_data.sym >>= apply)
| None,eq,eq_kind -> prove_symmetry eq eq_kind
end }
@@ -4820,8 +4817,8 @@ let transitivity_red allowred t =
Tacticals.New.tclTHEN
(convert_concl_no_check concl DEFAULTcast)
(match t with
- | None -> Tacticals.New.pf_constr_of_global eq_data.trans eapply
- | Some t -> Tacticals.New.pf_constr_of_global eq_data.trans (fun trans -> apply_list [trans;t]))
+ | None -> Tacticals.New.pf_constr_of_global eq_data.trans >>= eapply
+ | Some t -> Tacticals.New.pf_constr_of_global eq_data.trans >>= fun trans -> apply_list [trans; t])
| None,eq,eq_kind ->
match t with
| None -> Tacticals.New.tclZEROMSG (str"etransitivity not supported for this relation.")
generated by cgit v1.2.3 (git 2.25.1) at 2026-02-24 19:32:21 +0000