aboutsummaryrefslogtreecommitdiff
path: root/tactics
diff options
context:
space:
mode:
Diffstat (limited to 'tactics')
-rw-r--r--tactics/auto.ml2
-rw-r--r--tactics/class_tactics.ml48
-rw-r--r--tactics/contradiction.ml11
-rw-r--r--tactics/eqdecide.ml27
-rw-r--r--tactics/eqschemes.ml2
-rw-r--r--tactics/equality.ml46
-rw-r--r--tactics/equality.mli2
-rw-r--r--tactics/hints.ml2
-rw-r--r--tactics/hipattern.ml14
-rw-r--r--tactics/hipattern.mli2
-rw-r--r--tactics/tacticals.ml6
-rw-r--r--tactics/tactics.ml164
-rw-r--r--tactics/tactics.mli2
13 files changed, 205 insertions, 123 deletions
diff --git a/tactics/auto.ml b/tactics/auto.ml
index b76c0a96ae..e213965485 100644
--- a/tactics/auto.ml
+++ b/tactics/auto.ml
@@ -139,7 +139,7 @@ let conclPattern concl pat tac =
try
Proofview.tclUNIT (Constr_matching.matches env sigma pat concl)
with Constr_matching.PatternMatchingFailure ->
- Tacticals.New.tclZEROMSG (str "conclPattern")
+ Tacticals.New.tclZEROMSG (str "pattern-matching failed")
in
Proofview.Goal.enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml
index 46d66b9d06..672f9cffb5 100644
--- a/tactics/class_tactics.ml
+++ b/tactics/class_tactics.ml
@@ -226,16 +226,22 @@ let e_give_exact flags poly (c,clenv) =
Sigma.Unsafe.of_pair (Clenvtac.unify ~flags t1 <*> exact_no_check c, sigma)
end }
+let clenv_unique_resolver_tac with_evars ~flags clenv' =
+ Proofview.Goal.enter { enter = begin fun gls ->
+ let resolve =
+ try Proofview.tclUNIT (clenv_unique_resolver ~flags clenv' gls)
+ with e -> Proofview.tclZERO e
+ in resolve >>= fun clenv' ->
+ Clenvtac.clenv_refine with_evars ~with_classes:false clenv'
+ end }
+
let unify_e_resolve poly flags = { enter = begin fun gls (c,_,clenv) ->
let clenv', c = connect_hint_clenv poly c clenv gls in
- let clenv' = clenv_unique_resolver ~flags clenv' gls in
- Clenvtac.clenv_refine true ~with_classes:false clenv'
- end }
+ clenv_unique_resolver_tac true ~flags clenv' end }
let unify_resolve poly flags = { enter = begin fun gls (c,_,clenv) ->
let clenv', _ = connect_hint_clenv poly c clenv gls in
- let clenv' = clenv_unique_resolver ~flags clenv' gls in
- Clenvtac.clenv_refine false ~with_classes:false clenv'
+ clenv_unique_resolver_tac false ~flags clenv'
end }
(** Application of a lemma using [refine] instead of the old [w_unify] *)
@@ -691,7 +697,7 @@ module V85 = struct
let merge_failures x y =
match x, y with
| _, ReachedLimit
- | ReachedLimit, _ -> ReachedLimit
+ | ReachedLimit, _ -> ReachedLimit
| NotApplicable, NotApplicable -> NotApplicable
let or_tac (x : 'a tac) (y : 'a tac) : 'a tac =
@@ -1004,9 +1010,9 @@ module Search = struct
(** In the proof engine failures are represented as exceptions *)
exception ReachedLimitEx
- exception NotApplicableEx
+ exception NoApplicableEx
- (** ReachedLimitEx has priority over NotApplicableEx to handle
+ (** ReachedLimitEx has priority over NoApplicableEx to handle
iterative deepening: it should fail when no hints are applicable,
but go to a deeper depth otherwise. *)
let merge_exceptions e e' =
@@ -1042,7 +1048,7 @@ module Search = struct
Feedback.msg_debug (pr_depth info.search_depth ++
str": failure due to non-class subgoal " ++
pr_ev sigma (Proofview.Goal.goal gl));
- Proofview.tclZERO NotApplicableEx) }
+ Proofview.tclZERO NoApplicableEx) }
(** The general hint application tactic.
tac1 + tac2 .... The choice of OR or ORELSE is determined
@@ -1078,14 +1084,24 @@ module Search = struct
let derivs = path_derivate info.search_cut name in
let pr_error ie =
if !typeclasses_debug > 1 then
- let msg =
- pr_depth (!idx :: info.search_depth) ++ str": " ++
+ let idx = if fst ie == NoApplicableEx then pred !idx else !idx in
+ let header =
+ pr_depth (idx :: info.search_depth) ++ str": " ++
Lazy.force pp ++
(if !foundone != true then
str" on" ++ spc () ++ pr_ev s (Proofview.Goal.goal (Proofview.Goal.assume gl))
else mt ())
in
- Feedback.msg_debug (msg ++ str " failed with " ++ CErrors.iprint ie)
+ let msg =
+ match fst ie with
+ | Pretype_errors.PretypeError (env, evd, Pretype_errors.CannotUnify (x,y,_)) ->
+ str"Cannot unify " ++ print_constr_env env evd x ++ str" and " ++
+ print_constr_env env evd y
+ | ReachedLimitEx -> str "Proof-search reached its limit."
+ | NoApplicableEx -> str "Proof-search failed."
+ | e -> CErrors.iprint ie
+ in
+ Feedback.msg_debug (header ++ str " failed with: " ++ msg)
else ()
in
let tac_of gls i j = Goal.enter { enter = fun gl' ->
@@ -1196,10 +1212,10 @@ module Search = struct
str" possibilities");
match e with
| (ReachedLimitEx,ie) -> Proofview.tclZERO ~info:ie ReachedLimitEx
- | (_,ie) -> Proofview.tclZERO ~info:ie NotApplicableEx
+ | (_,ie) -> Proofview.tclZERO ~info:ie NoApplicableEx
in
- if backtrack then aux (NotApplicableEx,Exninfo.null) poss
- else tclONCE (aux (NotApplicableEx,Exninfo.null) poss)
+ if backtrack then aux (NoApplicableEx,Exninfo.null) poss
+ else tclONCE (aux (NoApplicableEx,Exninfo.null) poss)
let hints_tac hints info kont : unit Proofview.tactic =
Proofview.Goal.enter
@@ -1303,7 +1319,7 @@ module Search = struct
match e with
| ReachedLimitEx ->
Tacticals.New.tclFAIL 0 (str"Proof search reached its limit")
- | NotApplicableEx ->
+ | NoApplicableEx ->
Tacticals.New.tclFAIL 0 (str"Proof search failed" ++
(if Option.is_empty depth then mt()
else str" without reaching its limit"))
diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml
index fe44559ed8..5e7090ded1 100644
--- a/tactics/contradiction.ml
+++ b/tactics/contradiction.ml
@@ -19,10 +19,9 @@ module NamedDecl = Context.Named.Declaration
(* Absurd *)
-let mk_absurd_proof t =
- let build_coq_not () = EConstr.of_constr (Universes.constr_of_global @@ build_coq_not ()) in
+let mk_absurd_proof coq_not t =
let id = Namegen.default_dependent_ident in
- mkLambda (Names.Name id,mkApp(build_coq_not (),[|t|]),
+ mkLambda (Names.Name id,mkApp(coq_not,[|t|]),
mkLambda (Names.Name id,t,mkApp (mkRel 2,[|mkRel 1|])))
let absurd c =
@@ -34,9 +33,11 @@ let absurd c =
let sigma, j = Coercion.inh_coerce_to_sort env sigma j in
let t = j.Environ.utj_val in
let tac =
+ Tacticals.New.pf_constr_of_global (build_coq_not ()) >>= fun coqnot ->
+ Tacticals.New.pf_constr_of_global (build_coq_False ()) >>= fun coqfalse ->
Tacticals.New.tclTHENLIST [
- elim_type (EConstr.of_constr (Universes.constr_of_global @@ build_coq_False ()));
- Simple.apply (mk_absurd_proof t)
+ elim_type coqfalse;
+ Simple.apply (mk_absurd_proof coqnot t)
] in
Sigma.Unsafe.of_pair (tac, sigma)
end }
diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml
index bda25d7f02..48ce52f092 100644
--- a/tactics/eqdecide.ml
+++ b/tactics/eqdecide.ml
@@ -104,14 +104,9 @@ let solveNoteqBranch side =
(* Constructs the type {c1=c2}+{~c1=c2} *)
-let make_eq () =
-(*FIXME*) EConstr.of_constr (Universes.constr_of_global (Coqlib.build_coq_eq ()))
-let build_coq_not () = EConstr.of_constr (Universes.constr_of_global @@ build_coq_not ())
-let build_coq_sumbool () = EConstr.of_constr (Universes.constr_of_global @@ build_coq_sumbool ())
-
-let mkDecideEqGoal eqonleft op rectype c1 c2 =
- let equality = mkApp(make_eq(), [|rectype; c1; c2|]) in
- let disequality = mkApp(build_coq_not (), [|equality|]) in
+let mkDecideEqGoal eqonleft (op,eq,neg) rectype c1 c2 =
+ let equality = mkApp(eq, [|rectype; c1; c2|]) in
+ let disequality = mkApp(neg, [|equality|]) in
if eqonleft then mkApp(op, [|equality; disequality |])
else mkApp(op, [|disequality; equality |])
@@ -121,13 +116,13 @@ let mkDecideEqGoal eqonleft op rectype c1 c2 =
let idx = Id.of_string "x"
let idy = Id.of_string "y"
-let mkGenDecideEqGoal rectype g =
+let mkGenDecideEqGoal rectype ops g =
let hypnames = pf_ids_of_hyps g in
let xname = next_ident_away idx hypnames
and yname = next_ident_away idy hypnames in
(mkNamedProd xname rectype
(mkNamedProd yname rectype
- (mkDecideEqGoal true (build_coq_sumbool ())
+ (mkDecideEqGoal true ops
rectype (mkVar xname) (mkVar yname))))
let rec rewrite_and_clear hyps = match hyps with
@@ -256,9 +251,9 @@ let decideGralEquality =
let decideEqualityGoal = tclTHEN intros decideGralEquality
-let decideEquality rectype =
+let decideEquality rectype ops =
Proofview.Goal.enter { enter = begin fun gl ->
- let decide = mkGenDecideEqGoal rectype gl in
+ let decide = mkGenDecideEqGoal rectype ops gl in
(tclTHENS (cut decide) [default_auto;decideEqualityGoal])
end }
@@ -266,11 +261,15 @@ let decideEquality rectype =
(* The tactic Compare *)
let compare c1 c2 =
+ pf_constr_of_global (build_coq_sumbool ()) >>= fun opc ->
+ pf_constr_of_global (Coqlib.build_coq_eq ()) >>= fun eqc ->
+ pf_constr_of_global (build_coq_not ()) >>= fun notc ->
Proofview.Goal.enter { enter = begin fun gl ->
let rectype = pf_unsafe_type_of gl c1 in
- let decide = mkDecideEqGoal true (build_coq_sumbool ()) rectype c1 c2 in
+ let ops = (opc,eqc,notc) in
+ let decide = mkDecideEqGoal true ops rectype c1 c2 in
(tclTHENS (cut decide)
[(tclTHEN intro
(tclTHEN (onLastHyp simplest_case) clear_last));
- decideEquality rectype])
+ decideEquality rectype ops])
end }
diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml
index bcd31cb7e7..507ff10eea 100644
--- a/tactics/eqschemes.ml
+++ b/tactics/eqschemes.ml
@@ -632,7 +632,7 @@ let fix_r2l_forward_rew_scheme (c, ctx') =
(EConstr.of_constr (applist (c,
Context.Rel.to_extended_list mkRel 3 indargs @ [mkRel 1;mkRel 3;mkRel 2]))))))))
in c', ctx'
- | _ -> anomaly (Pp.str "Ill-formed non-dependent left-to-right rewriting scheme")
+ | _ -> anomaly (Pp.str "Ill-formed non-dependent left-to-right rewriting scheme.")
(**********************************************************************)
(* Build the right-to-left rewriting lemma for conclusion associated *)
diff --git a/tactics/equality.ml b/tactics/equality.ml
index e6278943df..d64cc38eff 100644
--- a/tactics/equality.ml
+++ b/tactics/equality.ml
@@ -874,7 +874,7 @@ let descend_then env sigma head dirn =
let dirn_env = Environ.push_rel_context cstr.(dirn-1).cs_args env in
(dirn_nlams,
dirn_env,
- (fun dirnval (dfltval,resty) ->
+ (fun sigma dirnval (dfltval,resty) ->
let deparsign = make_arity_signature env sigma true indf in
let p =
it_mkLambda_or_LetIn (lift (mip.mind_nrealargs+1) resty) deparsign in
@@ -887,7 +887,7 @@ let descend_then env sigma head dirn =
List.map build_branch
(List.interval 1 (Array.length mip.mind_consnames)) in
let ci = make_case_info env ind RegularStyle in
- Inductiveops.make_case_or_project env sigma indf ci p head (Array.of_list brl)))
+ sigma, Inductiveops.make_case_or_project env sigma indf ci p head (Array.of_list brl)))
(* Now we need to construct the discriminator, given a discriminable
position. This boils down to:
@@ -932,23 +932,28 @@ let build_selector env sigma dirn c ind special default =
let brl =
List.map build_branch(List.interval 1 (Array.length mip.mind_consnames)) in
let ci = make_case_info env ind RegularStyle in
- mkCase (ci, p, c, Array.of_list brl)
+ sigma, mkCase (ci, p, c, Array.of_list brl)
-let build_coq_False () = EConstr.of_constr (Universes.constr_of_global @@ build_coq_False ())
-let build_coq_True () = EConstr.of_constr (Universes.constr_of_global @@ build_coq_True ())
-let build_coq_I () = EConstr.of_constr (Universes.constr_of_global @@ build_coq_I ())
+let new_global sigma gr =
+ let Sigma (c, sigma, _) = Evarutil.new_global (Sigma.Unsafe.of_evar_map sigma) gr
+ in Sigma.to_evar_map sigma, c
+
+let build_coq_False sigma = new_global sigma (build_coq_False ())
+let build_coq_True sigma = new_global sigma (build_coq_True ())
+let build_coq_I sigma = new_global sigma (build_coq_I ())
let rec build_discriminator env sigma dirn c = function
| [] ->
let ind = get_type_of env sigma c in
- let true_0,false_0 =
- build_coq_True(),build_coq_False() in
+ let sigma, true_0 = build_coq_True sigma in
+ let sigma, false_0 = build_coq_False sigma in
build_selector env sigma dirn c ind true_0 false_0
| ((sp,cnum),argnum)::l ->
+ let sigma, false_0 = build_coq_False sigma in
let (cnum_nlams,cnum_env,kont) = descend_then env sigma c cnum in
let newc = mkRel(cnum_nlams-argnum) in
- let subval = build_discriminator cnum_env sigma dirn newc l in
- kont subval (build_coq_False (),mkSort (Prop Null))
+ let sigma, subval = build_discriminator cnum_env sigma dirn newc l in
+ kont sigma subval (false_0,mkSort (Prop Null))
(* Note: discrimination could be more clever: if some elimination is
not allowed because of a large impredicative constructor in the
@@ -991,9 +996,9 @@ let ind_scheme_of_eq lbeq =
let discrimination_pf env sigma e (t,t1,t2) discriminator lbeq =
- let i = build_coq_I () in
- let absurd_term = build_coq_False () in
- let eq_elim, eff = ind_scheme_of_eq lbeq in
+ let sigma, i = build_coq_I sigma in
+ let sigma, absurd_term = build_coq_False sigma in
+ let eq_elim, eff = ind_scheme_of_eq lbeq in
let sigma, eq_elim = Evd.fresh_global (Global.env ()) sigma eq_elim in
let eq_elim = EConstr.of_constr eq_elim in
sigma, (applist (eq_elim, [t;t1;mkNamedLambda e t discriminator;i;t2]), absurd_term),
@@ -1013,7 +1018,7 @@ let apply_on_clause (f,t) clause =
let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn =
let e = next_ident_away eq_baseid (ids_of_context env) in
let e_env = push_named (Context.Named.Declaration.LocalAssum (e,t)) env in
- let discriminator =
+ let sigma, discriminator =
build_discriminator e_env sigma dirn (mkVar e) cpath in
let sigma,(pf, absurd_term), eff =
discrimination_pf env sigma e (t,t1,t2) discriminator lbeq in
@@ -1206,7 +1211,7 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt =
else
let (a,p_i_minus_1) = match whd_beta_stack !evdref p_i with
| (_sigS,[a;p]) -> (a, p)
- | _ -> anomaly ~label:"sig_clausal_form" (Pp.str "should be a sigma type") in
+ | _ -> anomaly ~label:"sig_clausal_form" (Pp.str "should be a sigma type.") in
let ev = Evarutil.e_new_evar env evdref a in
let rty = beta_applist sigma (p_i_minus_1,[ev]) in
let tuple_tail = sigrec_clausal_form (siglen-1) rty in
@@ -1309,7 +1314,8 @@ let rec build_injrec env sigma dflt c = function
let (cnum_nlams,cnum_env,kont) = descend_then env sigma c cnum in
let newc = mkRel(cnum_nlams-argnum) in
let sigma, (subval,tuplety,dfltval) = build_injrec cnum_env sigma dflt newc l in
- sigma, (kont subval (dfltval,tuplety), tuplety,dfltval)
+ let sigma, res = kont sigma subval (dfltval,tuplety) in
+ sigma, (res, tuplety,dfltval)
with
UserError _ -> failwith "caught"
@@ -1326,8 +1332,6 @@ let inject_if_homogenous_dependent_pair ty =
let sigma = Tacmach.New.project gl in
let eq,u,(t,t1,t2) = find_this_eq_data_decompose gl ty in
(* fetch the informations of the pair *)
- let ceq = Universes.constr_of_global Coqlib.glob_eq in
- let ceq = EConstr.of_constr ceq in
let sigTconstr () = (Coqlib.build_sigma_type()).Coqlib.typ in
let existTconstr () = (Coqlib.build_sigma_type()).Coqlib.intro in
(* check whether the equality deals with dep pairs or not *)
@@ -1346,16 +1350,18 @@ let inject_if_homogenous_dependent_pair ty =
pf_apply is_conv gl ar1.(2) ar2.(2)) then raise Exit;
Coqlib.check_required_library ["Coq";"Logic";"Eqdep_dec"];
let new_eq_args = [|pf_unsafe_type_of gl ar1.(3);ar1.(3);ar2.(3)|] in
- let inj2 = EConstr.of_constr @@ Universes.constr_of_global @@
- Coqlib.coq_reference "inj_pair2_eq_dec is missing" ["Logic";"Eqdep_dec"] "inj_pair2_eq_dec" in
+ let inj2 = Coqlib.coq_reference "inj_pair2_eq_dec is missing" ["Logic";"Eqdep_dec"]
+ "inj_pair2_eq_dec" in
let c, eff = find_scheme (!eq_dec_scheme_kind_name()) ind in
(* cut with the good equality and prove the requested goal *)
tclTHENLIST
[Proofview.tclEFFECTS eff;
intro;
onLastHyp (fun hyp ->
+ Tacticals.New.pf_constr_of_global Coqlib.glob_eq >>= fun ceq ->
tclTHENS (cut (mkApp (ceq,new_eq_args)))
[clear [destVar sigma hyp];
+ Tacticals.New.pf_constr_of_global inj2 >>= fun inj2 ->
Proofview.V82.tactic (Tacmach.refine
(mkApp(inj2,[|ar1.(0);mkConst c;ar1.(1);ar1.(2);ar1.(3);ar2.(3);hyp|])))
])]
diff --git a/tactics/equality.mli b/tactics/equality.mli
index b47be3bbc0..27be5affb1 100644
--- a/tactics/equality.mli
+++ b/tactics/equality.mli
@@ -126,4 +126,4 @@ val set_eq_dec_scheme_kind : mutual scheme_kind -> unit
(* [build_selector env sigma i c t u v] matches on [c] of
type [t] and returns [u] in branch [i] and [v] on other branches *)
val build_selector : env -> evar_map -> int -> constr -> types ->
- constr -> constr -> constr
+ constr -> constr -> evar_map * constr
diff --git a/tactics/hints.ml b/tactics/hints.ml
index 48a7b3f75c..70e62eabac 100644
--- a/tactics/hints.ml
+++ b/tactics/hints.ml
@@ -912,7 +912,7 @@ let make_resolve_hyp env sigma decl =
(c, NamedDecl.get_type decl, Univ.ContextSet.empty)]
with
| Failure _ -> []
- | e when Logic.catchable_exception e -> anomaly (Pp.str "make_resolve_hyp")
+ | e when Logic.catchable_exception e -> anomaly (Pp.str "make_resolve_hyp.")
(* REM : in most cases hintname = id *)
diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml
index fd5eabe648..4db744224a 100644
--- a/tactics/hipattern.ml
+++ b/tactics/hipattern.ml
@@ -254,13 +254,13 @@ open Evar_kinds
let mkPattern c = snd (Patternops.pattern_of_glob_constr c)
let mkGApp f args = CAst.make @@ GApp (f, args)
let mkGHole = CAst.make @@
- GHole (QuestionMark (Define false), Misctypes.IntroAnonymous, None)
+ GHole (QuestionMark (Define false,Anonymous), Misctypes.IntroAnonymous, None)
let mkGProd id c1 c2 = CAst.make @@
GProd (Name (Id.of_string id), Explicit, c1, c2)
let mkGArrow c1 c2 = CAst.make @@
GProd (Anonymous, Explicit, c1, c2)
let mkGVar id = CAst.make @@ GVar (Id.of_string id)
-let mkGPatVar id = CAst.make @@ GPatVar((false, Id.of_string id))
+let mkGPatVar id = CAst.make @@ GPatVar(Evar_kinds.FirstOrderPatVar (Id.of_string id))
let mkGRef r = CAst.make @@ GRef (Lazy.force r, None)
let mkGAppRef r args = mkGApp (mkGRef r) args
@@ -340,7 +340,7 @@ let match_arrow_pattern sigma t =
match Id.Map.bindings result with
| [(m1,arg);(m2,mind)] ->
assert (Id.equal m1 meta1 && Id.equal m2 meta2); (arg, mind)
- | _ -> anomaly (Pp.str "Incorrect pattern matching")
+ | _ -> anomaly (Pp.str "Incorrect pattern matching.")
let match_with_imp_term sigma c =
match EConstr.kind sigma c with
@@ -471,7 +471,7 @@ let match_eq_nf gls eqn (ref, hetero) =
| [(m1,t);(m2,x);(m3,y)] ->
assert (Id.equal m1 meta1 && Id.equal m2 meta2 && Id.equal m3 meta3);
(t,pf_whd_all gls x,pf_whd_all gls y)
- | _ -> anomaly ~label:"match_eq" (Pp.str "an eq pattern should match 3 terms")
+ | _ -> anomaly ~label:"match_eq" (Pp.str "an eq pattern should match 3 terms.")
let dest_nf_eq gls eqn =
try
@@ -499,7 +499,7 @@ let coq_sig_pattern =
let match_sigma sigma t =
match Id.Map.bindings (matches sigma (Lazy.force coq_sig_pattern) t) with
| [(_,a); (_,p)] -> (a,p)
- | _ -> anomaly (Pp.str "Unexpected pattern")
+ | _ -> anomaly (Pp.str "Unexpected pattern.")
let is_matching_sigma sigma t = is_matching sigma (Lazy.force coq_sig_pattern) t
@@ -544,8 +544,8 @@ let match_eqdec sigma t =
false,op_or,matches sigma (Lazy.force coq_eqdec_rev_pattern) t in
match Id.Map.bindings subst with
| [(_,typ);(_,c1);(_,c2)] ->
- eqonleft, EConstr.of_constr (Universes.constr_of_global (Lazy.force op)), c1, c2, typ
- | _ -> anomaly (Pp.str "Unexpected pattern")
+ eqonleft, Lazy.force op, c1, c2, typ
+ | _ -> anomaly (Pp.str "Unexpected pattern.")
(* Patterns "~ ?" and "? -> False" *)
let coq_not_pattern = lazy (mkPattern (mkGAppRef coq_not_ref [mkGHole]))
diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli
index 82a3d47b59..9110830aae 100644
--- a/tactics/hipattern.mli
+++ b/tactics/hipattern.mli
@@ -142,7 +142,7 @@ val is_matching_sigma : evar_map -> constr -> bool
(** Match a decidable equality judgement (e.g [{t=u:>T}+{~t=u}]), returns
[t,u,T] and a boolean telling if equality is on the left side *)
-val match_eqdec : evar_map -> constr -> bool * constr * constr * constr * constr
+val match_eqdec : evar_map -> constr -> bool * Globnames.global_reference * constr * constr * constr
(** Match an equality up to conversion; returns [(eq,t1,t2)] in normal form *)
val dest_nf_eq : ('a, 'r) Proofview.Goal.t -> constr -> (constr * constr * constr)
diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml
index c495b5ece2..a7eadc3c3e 100644
--- a/tactics/tacticals.ml
+++ b/tactics/tacticals.ml
@@ -238,7 +238,7 @@ let compute_constructor_signatures isrec ((_,k as ity),u) =
end
| LetIn (_,_,_,c), rest -> false :: analrec c rest
| _, [] -> []
- | _ -> anomaly (Pp.str "compute_constructor_signatures")
+ | _ -> anomaly (Pp.str "compute_constructor_signatures.")
in
let (mib,mip) = Global.lookup_inductive ity in
let n = mib.mind_nparams in
@@ -613,7 +613,7 @@ module New = struct
let indmv =
match EConstr.kind elimclause.evd (last_arg elimclause.evd elimclause.templval.Evd.rebus) with
| Meta mv -> mv
- | _ -> anomaly (str"elimination")
+ | _ -> anomaly (str"elimination.")
in
let pmv =
let p, _ = decompose_app elimclause.evd elimclause.templtyp.Evd.rebus in
@@ -700,7 +700,7 @@ module New = struct
let make_elim_branch_assumptions ba hyps =
let assums =
try List.rev (List.firstn ba.nassums hyps)
- with Failure _ -> anomaly (Pp.str "make_elim_branch_assumptions") in
+ with Failure _ -> anomaly (Pp.str "make_elim_branch_assumptions.") in
{ ba = ba; assums = assums }
let elim_on_ba tac ba =
diff --git a/tactics/tactics.ml b/tactics/tactics.ml
index 7e8cb4e632..a93a86d3a3 100644
--- a/tactics/tactics.ml
+++ b/tactics/tactics.ml
@@ -1246,7 +1246,7 @@ let cut c =
let error_uninstantiated_metas t clenv =
let t = EConstr.Unsafe.to_constr t in
let na = meta_name clenv.evd (List.hd (Metaset.elements (metavars_of t))) in
- let id = match na with Name id -> id | _ -> anomaly (Pp.str "unnamed dependent meta")
+ let id = match na with Name id -> id | _ -> anomaly (Pp.str "unnamed dependent meta.")
in user_err (str "Cannot find an instance for " ++ pr_id id ++ str".")
let check_unresolved_evars_of_metas sigma clenv =
@@ -1305,13 +1305,13 @@ let clenv_refine_in ?(sidecond_first=false) with_evars ?(with_classes=true)
let last_arg sigma c = match EConstr.kind sigma c with
| App (f,cl) ->
Array.last cl
- | _ -> anomaly (Pp.str "last_arg")
+ | _ -> anomaly (Pp.str "last_arg.")
let nth_arg sigma i c =
if Int.equal i (-1) then last_arg sigma c else
match EConstr.kind sigma c with
| App (f,cl) -> cl.(i)
- | _ -> anomaly (Pp.str "nth_arg")
+ | _ -> anomaly (Pp.str "nth_arg.")
let index_of_ind_arg sigma t =
let rec aux i j t = match EConstr.kind sigma t with
@@ -2756,7 +2756,7 @@ let letin_tac with_eq id c ty occs =
Sigma (tac, sigma, p)
end }
-let letin_pat_tac with_eq id c occs =
+let letin_pat_tac with_evars with_eq id c occs =
Proofview.Goal.s_enter { s_enter = begin fun gl ->
let sigma = Proofview.Goal.sigma gl in
let env = Proofview.Goal.env gl in
@@ -2765,7 +2765,7 @@ let letin_pat_tac with_eq id c occs =
let abs = AbstractPattern (false,check,id,c,occs,false) in
let (id,_,depdecls,lastlhyp,ccl,res) = make_abstraction env sigma ccl abs in
let Sigma (c, sigma, p) = match res with
- | None -> finish_evar_resolution ~flags:(tactic_infer_flags false) env sigma c
+ | None -> finish_evar_resolution ~flags:(tactic_infer_flags with_evars) env sigma c
| Some res -> res in
let tac =
(letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) None)
@@ -2954,6 +2954,19 @@ let quantify lconstr =
(* Modifying/Adding an hypothesis *)
+(* Instantiating some arguments (whatever their position) of an hypothesis
+ or any term, leaving other arguments quantified. If operating on an
+ hypothesis of the goal, the new hypothesis replaces it.
+
+ (c,lbind) are supposed to be of the form
+ ((t t1 t2 ... tm) , someBindings)
+
+ in which case we pose a proof with body
+
+ (fun y1...yp => H t1 t2 ... tm u1 ... uq) where yi are the
+ remaining arguments of H that lbind could not resolve, ui are a mix
+ of inferred args and yi. The overall effect is to remove from H as
+ much quantification as possible given lbind. *)
let specialize (c,lbind) ipat =
Proofview.Goal.enter { enter = begin fun gl ->
let env = Proofview.Goal.env gl in
@@ -2962,22 +2975,49 @@ let specialize (c,lbind) ipat =
if lbind == NoBindings then
sigma, c
else
- let clause = make_clenv_binding env sigma (c,Retyping.get_type_of env sigma c) lbind in
+ let typ_of_c = Retyping.get_type_of env sigma c in
+ (* If the term is lambda then we put a letin to put avoid
+ interaction between the term and the bindings. *)
+ let c = match EConstr.kind sigma c with
+ | Lambda(_,_,_) ->
+ mkLetIn(Name.Anonymous, c, typ_of_c, (mkRel 1))
+ | _ -> c in
+ let clause = make_clenv_binding env sigma (c,typ_of_c) lbind in
let flags = { (default_unify_flags ()) with resolve_evars = true } in
let clause = clenv_unify_meta_types ~flags clause in
- let (thd,tstack) = whd_nored_stack clause.evd (clenv_value clause) in
- let rec chk = function
- | [] -> []
- | t::l -> if occur_meta clause.evd t then [] else t :: chk l
- in
- let tstack = chk tstack in
- let term = applist(thd,List.map (nf_evar clause.evd) tstack) in
- if occur_meta clause.evd term then
- user_err (str "Cannot infer an instance for " ++
-
- pr_name (meta_name clause.evd (List.hd (collect_metas clause.evd term))) ++
- str ".");
- clause.evd, term in
+ let sigma = clause.evd in
+ let (thd,tstack) = whd_nored_stack sigma (clenv_value clause) in
+ let c_hd , c_args = decompose_app sigma c in
+ let liftrel x =
+ match kind sigma x with
+ | Rel n -> mkRel (n+1)
+ | _ -> x in
+ (* We grab names used in product to remember them at re-abstracting phase *)
+ let typ_of_c_hd = pf_get_type_of gl c_hd in
+ let lprod, concl = decompose_prod_assum sigma typ_of_c_hd in
+ (* accumulator args: arguments to apply to c_hd: all infered
+ args + re-abstracted rels *)
+ let rec rebuild_lambdas sigma lprd args hd l =
+ match lprd , l with
+ | _, [] -> sigma,applist (hd, (List.map (nf_evar sigma) args))
+ | Context.Rel.Declaration.LocalAssum(nme,_)::lp' , t::l' when occur_meta sigma t ->
+ (* nme has not been resolved, let us re-abstract it. Same
+ name but type updated by instanciation of other args. *)
+ let sigma,new_typ_of_t = Typing.type_of clause.env sigma t in
+ let liftedargs = List.map liftrel args in
+ (* lifting rels in the accumulator args *)
+ let sigma,hd' = rebuild_lambdas sigma lp' (liftedargs@[mkRel 1 ]) hd l' in
+ (* replace meta variable by the abstracted variable *)
+ let hd'' = subst_term sigma t hd' in
+ (* lambda expansion *)
+ sigma,mkLambda (nme,new_typ_of_t,hd'')
+ | Context.Rel.Declaration.LocalAssum(_,_)::lp' , t::l' ->
+ let sigma,hd' = rebuild_lambdas sigma lp' (args@[t]) hd l' in
+ sigma,hd'
+ | _ ,_ -> assert false in
+ let sigma,hd = rebuild_lambdas sigma (List.rev lprod) [] c_hd tstack in
+ sigma, hd
+ in
let typ = Retyping.get_type_of env sigma term in
let tac =
match EConstr.kind sigma (fst(EConstr.decompose_app sigma (snd(EConstr.decompose_lam_assum sigma c)))) with
@@ -2994,7 +3034,9 @@ let specialize (c,lbind) ipat =
| None ->
(* Like generalize with extra support for "with" bindings *)
(* even though the "with" bindings forces full application *)
- Tacticals.New.tclTHENLAST (cut typ) (exact_no_check term)
+ (* TODO: add intro to be more homogeneous. It will break
+ scripts but will be easy to fix *)
+ (Tacticals.New.tclTHENLAST (cut typ) (exact_no_check term))
| Some (loc,ipat) ->
(* Like pose proof with extra support for "with" bindings *)
(* even though the "with" bindings forces full application *)
@@ -3519,27 +3561,32 @@ let error_ind_scheme s =
let s = if not (String.is_empty s) then s^" " else s in
user_err ~hdr:"Tactics" (str "Cannot recognize " ++ str s ++ str "an induction scheme.")
-let glob c = EConstr.of_constr (Universes.constr_of_global c)
+let glob sigma gr =
+ let Sigma (c, sigma, _) = Evarutil.new_global (Sigma.Unsafe.of_evar_map sigma) gr
+ in Sigma.to_evar_map sigma, c
-let coq_eq = lazy (glob (Coqlib.build_coq_eq ()))
-let coq_eq_refl = lazy (glob (Coqlib.build_coq_eq_refl ()))
+let coq_eq sigma = glob sigma (Coqlib.build_coq_eq ())
+let coq_eq_refl sigma = glob sigma (Coqlib.build_coq_eq_refl ())
-let coq_heq = lazy (EConstr.of_constr @@ Universes.constr_of_global (Coqlib.coq_reference"mkHEq" ["Logic";"JMeq"] "JMeq"))
-let coq_heq_refl = lazy (EConstr.of_constr @@ Universes.constr_of_global (Coqlib.coq_reference "mkHEq" ["Logic";"JMeq"] "JMeq_refl"))
+let coq_heq_ref = lazy (Coqlib.coq_reference"mkHEq" ["Logic";"JMeq"] "JMeq")
+let coq_heq sigma = glob sigma (Lazy.force coq_heq_ref)
+let coq_heq_refl sigma = glob sigma (Coqlib.coq_reference "mkHEq" ["Logic";"JMeq"] "JMeq_refl")
-let mkEq t x y =
- mkApp (Lazy.force coq_eq, [| t; x; y |])
+let mkEq sigma t x y =
+ let sigma, eq = coq_eq sigma in
+ sigma, mkApp (eq, [| t; x; y |])
-let mkRefl t x =
- mkApp (Lazy.force coq_eq_refl, [| t; x |])
+let mkRefl sigma t x =
+ let sigma, refl = coq_eq_refl sigma in
+ sigma, mkApp (refl, [| t; x |])
-let mkHEq t x u y =
- mkApp (Lazy.force coq_heq,
- [| t; x; u; y |])
+let mkHEq sigma t x u y =
+ let sigma, c = coq_heq sigma in
+ sigma, mkApp (c,[| t; x; u; y |])
-let mkHRefl t x =
- mkApp (Lazy.force coq_heq_refl,
- [| t; x |])
+let mkHRefl sigma t x =
+ let sigma, c = coq_heq_refl sigma in
+ sigma, mkApp (c, [| t; x |])
let lift_togethern n l =
let l', _ =
@@ -3577,23 +3624,30 @@ let decompose_indapp sigma f args =
mkApp (f, pars), args
| _ -> f, args
-let mk_term_eq env sigma ty t ty' t' =
+let mk_term_eq homogeneous env sigma ty t ty' t' =
let sigma = Sigma.to_evar_map sigma in
- if Reductionops.is_conv env sigma ty ty' then
- mkEq ty t t', mkRefl ty' t'
+ if homogeneous then
+ let sigma, eq = mkEq sigma ty t t' in
+ let sigma, refl = mkRefl sigma ty' t' in
+ Sigma.Unsafe.of_evar_map sigma, (eq, refl)
else
- mkHEq ty t ty' t', mkHRefl ty' t'
+ let sigma, heq = mkHEq sigma ty t ty' t' in
+ let sigma, hrefl = mkHRefl sigma ty' t' in
+ Sigma.Unsafe.of_evar_map sigma, (heq, hrefl)
let make_abstract_generalize env id typ concl dep ctx body c eqs args refls =
let open Context.Rel.Declaration in
Refine.refine { run = begin fun sigma ->
let eqslen = List.length eqs in
(* Abstract by the "generalized" hypothesis equality proof if necessary. *)
- let abshypeq, abshypt =
+ let sigma, abshypeq, abshypt =
if dep then
- let eq, refl = mk_term_eq (push_rel_context ctx env) sigma (lift 1 c) (mkRel 1) typ (mkVar id) in
- mkProd (Anonymous, eq, lift 1 concl), [| refl |]
- else concl, [||]
+ let ty = lift 1 c in
+ let homogeneous = Reductionops.is_conv env (Sigma.to_evar_map sigma) ty typ in
+ let sigma, (eq, refl) =
+ mk_term_eq homogeneous (push_rel_context ctx env) sigma ty (mkRel 1) typ (mkVar id) in
+ sigma, mkProd (Anonymous, eq, lift 1 concl), [| refl |]
+ else sigma, concl, [||]
in
(* Abstract by equalities *)
let eqs = lift_togethern 1 eqs in (* lift together and past genarg *)
@@ -3699,9 +3753,13 @@ let abstract_args gl generalize_vars dep id defined f args =
let liftarg = lift (List.length ctx) arg in
let eq, refl =
if leq then
- mkEq (lift 1 ty) (mkRel 1) liftarg, mkRefl (lift (-lenctx) ty) arg
+ let sigma', eq = mkEq !sigma (lift 1 ty) (mkRel 1) liftarg in
+ let sigma', refl = mkRefl sigma' (lift (-lenctx) ty) arg in
+ sigma := sigma'; eq, refl
else
- mkHEq (lift 1 ty) (mkRel 1) liftargty liftarg, mkHRefl argty arg
+ let sigma', eq = mkHEq !sigma (lift 1 ty) (mkRel 1) liftargty liftarg in
+ let sigma', refl = mkHRefl sigma' argty arg in
+ sigma := sigma'; eq, refl
in
let eqs = eq :: lift_list eqs in
let refls = refl :: refls in
@@ -3801,17 +3859,19 @@ let specialize_eqs id gl =
match EConstr.kind !evars ty with
| Prod (na, t, b) ->
(match EConstr.kind !evars t with
- | App (eq, [| eqty; x; y |]) when EConstr.eq_constr !evars (Lazy.force coq_eq) eq ->
+ | App (eq, [| eqty; x; y |]) when EConstr.is_global !evars (Lazy.force coq_eq_ref) eq ->
let c = if noccur_between !evars 1 (List.length ctx) x then y else x in
- let pt = mkApp (Lazy.force coq_eq, [| eqty; c; c |]) in
- let p = mkApp (Lazy.force coq_eq_refl, [| eqty; c |]) in
+ let pt = mkApp (eq, [| eqty; c; c |]) in
+ let ind = destInd !evars eq in
+ let p = mkApp (mkConstructUi (ind,0), [| eqty; c |]) in
if unif (push_rel_context ctx env) evars pt t then
aux true ctx (mkApp (acc, [| p |])) (subst1 p b)
else acc, in_eqs, ctx, ty
- | App (heq, [| eqty; x; eqty'; y |]) when EConstr.eq_constr !evars heq (Lazy.force coq_heq) ->
+ | App (heq, [| eqty; x; eqty'; y |]) when EConstr.is_global !evars (Lazy.force coq_heq_ref) heq ->
let eqt, c = if noccur_between !evars 1 (List.length ctx) x then eqty', y else eqty, x in
- let pt = mkApp (Lazy.force coq_heq, [| eqt; c; eqt; c |]) in
- let p = mkApp (Lazy.force coq_heq_refl, [| eqt; c |]) in
+ let pt = mkApp (heq, [| eqt; c; eqt; c |]) in
+ let ind = destInd !evars heq in
+ let p = mkApp (mkConstructUi (ind,0), [| eqt; c |]) in
if unif (push_rel_context ctx env) evars pt t then
aux true ctx (mkApp (acc, [| p |])) (subst1 p b)
else acc, in_eqs, ctx, ty
@@ -4645,7 +4705,7 @@ let elim_scheme_type elim t =
clenv_unify ~flags:(elim_flags ()) Reduction.CUMUL t
(clenv_meta_type clause mv) clause in
Clenvtac.res_pf clause' ~flags:(elim_flags ()) ~with_evars:false
- | _ -> anomaly (Pp.str "elim_scheme_type")
+ | _ -> anomaly (Pp.str "elim_scheme_type.")
end }
let elim_type t =
diff --git a/tactics/tactics.mli b/tactics/tactics.mli
index 07a8035427..0dbcce02c5 100644
--- a/tactics/tactics.mli
+++ b/tactics/tactics.mli
@@ -385,7 +385,7 @@ val letin_tac : (bool * intro_pattern_naming) option ->
(** Common entry point for user-level "set", "pose" and "remember" *)
-val letin_pat_tac : (bool * intro_pattern_naming) option ->
+val letin_pat_tac : evars_flag -> (bool * intro_pattern_naming) option ->
Name.t -> (evar_map * constr) -> clause -> unit Proofview.tactic
(** {6 Generalize tactics. } *)
generated by cgit v1.2.3 (git 2.25.1) at 2026-04-30 00:50:19 +0000