aboutsummaryrefslogtreecommitdiffhomepage
path: root/tactics
diff options
context:
space:
mode:
Diffstat (limited to 'tactics')
-rw-r--r--tactics/autorewrite.ml22
-rw-r--r--tactics/btermdn.ml2
-rw-r--r--tactics/class_tactics.ml35
-rw-r--r--tactics/contradiction.ml2
-rw-r--r--tactics/eauto.ml2
-rw-r--r--tactics/eqdecide.ml2
-rw-r--r--tactics/eqschemes.ml11
-rw-r--r--tactics/equality.ml5
-rw-r--r--tactics/hints.ml95
-rw-r--r--tactics/hints.mli30
-rw-r--r--tactics/hipattern.ml2
-rw-r--r--tactics/inv.ml5
-rw-r--r--tactics/leminv.ml7
-rw-r--r--tactics/tacticals.ml2
-rw-r--r--tactics/tactics.ml91
-rw-r--r--tactics/tactics.mli2
-rw-r--r--tactics/term_dnet.ml2
-rw-r--r--tactics/term_dnet.mli2
18 files changed, 191 insertions, 128 deletions
diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml
index 0b0e629ab..c8fd0b7a7 100644
--- a/tactics/autorewrite.ml
+++ b/tactics/autorewrite.ml
@@ -228,7 +228,7 @@ let decompose_applied_relation metas env sigma c ctype left2right =
if metas then eqclause
else clenv_pose_metas_as_evars eqclause (Evd.undefined_metas eqclause.evd)
in
- let (equiv, args) = decompose_app (EConstr.Unsafe.to_constr (Clenv.clenv_type eqclause)) in
+ let (equiv, args) = EConstr.decompose_app sigma (Clenv.clenv_type eqclause) in
let rec split_last_two = function
| [c1;c2] -> [],(c1, c2)
| x::y::z ->
@@ -236,17 +236,19 @@ let decompose_applied_relation metas env sigma c ctype left2right =
| _ -> raise Not_found
in
try
- let others,(c1,c2) = split_last_two args in
- let ty1, ty2 =
- Typing.unsafe_type_of env eqclause.evd (EConstr.of_constr c1), Typing.unsafe_type_of env eqclause.evd (EConstr.of_constr c2)
- in
- let ty = EConstr.Unsafe.to_constr ty in
- let ty1 = EConstr.Unsafe.to_constr ty1 in
+ let others,(c1,c2) = split_last_two args in
+ let ty1, ty2 = Typing.unsafe_type_of env eqclause.evd c1, Typing.unsafe_type_of env eqclause.evd c2 in
+ (* XXX: It looks like mk_clenv_from_env should be fixed instead? *)
+ let open EConstr in
+ let hyp_ty = Unsafe.to_constr ty in
+ let hyp_car = Unsafe.to_constr ty1 in
+ let hyp_prf = Unsafe.to_constr @@ Clenv.clenv_value eqclause in
+ let hyp_rel = Unsafe.to_constr @@ mkApp (equiv, Array.of_list others) in
+ let hyp_left = Unsafe.to_constr @@ c1 in
+ let hyp_right = Unsafe.to_constr @@ c2 in
(* if not (evd_convertible env eqclause.evd ty1 ty2) then None *)
(* else *)
- Some { hyp_cl=eqclause; hyp_prf=EConstr.Unsafe.to_constr (Clenv.clenv_value eqclause); hyp_ty = ty;
- hyp_car=ty1; hyp_rel=mkApp (equiv, Array.of_list others);
- hyp_l2r=left2right; hyp_left=c1; hyp_right=c2; }
+ Some { hyp_cl=eqclause; hyp_prf; hyp_ty; hyp_car; hyp_rel; hyp_l2r=left2right; hyp_left; hyp_right; }
with Not_found -> None
in
match find_rel ctype with
diff --git a/tactics/btermdn.ml b/tactics/btermdn.ml
index 8f50b0aa2..aca7f6c65 100644
--- a/tactics/btermdn.ml
+++ b/tactics/btermdn.ml
@@ -9,7 +9,7 @@
(************************************************************************)
open Util
-open Term
+open Constr
open EConstr
open Names
open Pattern
diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml
index d30f0b80b..4beeaaae0 100644
--- a/tactics/class_tactics.ml
+++ b/tactics/class_tactics.ml
@@ -18,6 +18,7 @@ open CErrors
open Util
open Names
open Term
+open Constr
open Termops
open EConstr
open Tacmach
@@ -546,12 +547,7 @@ let make_resolve_hyp env sigma st flags only_classes pri decl =
let hints = build_subclasses ~check:false env sigma (VarRef id) empty_hint_info in
(List.map_append
(fun (path,info,c) ->
- let info =
- { info with hint_pattern =
- Option.map (Constrintern.intern_constr_pattern env sigma)
- info.hint_pattern }
- in
- make_resolves env sigma ~name:(PathHints path)
+ make_resolves env sigma ~name:(PathHints path)
(true,false,not !Flags.quiet) info false
(IsConstr (EConstr.of_constr c,Univ.ContextSet.empty)))
hints)
@@ -653,17 +649,6 @@ module Search = struct
Evd.add sigma gl evi')
sigma goals
- let fail_if_nonclass info =
- Proofview.Goal.enter begin fun gl ->
- let sigma = Proofview.Goal.sigma gl in
- if is_class_type sigma (Proofview.Goal.concl gl) then
- Proofview.tclUNIT ()
- else (if !typeclasses_debug > 1 then
- Feedback.msg_debug (pr_depth info.search_depth ++
- str": failure due to non-class subgoal " ++
- pr_ev sigma (Proofview.Goal.goal gl));
- Proofview.tclZERO NoApplicableEx) end
-
(** The general hint application tactic.
tac1 + tac2 .... The choice of OR or ORELSE is determined
depending on the dependencies of the goal and the unique/Prop
@@ -802,13 +787,8 @@ module Search = struct
in
if path_matches derivs [] then aux e tl
else
- let filter =
- if false (* in 8.6, still allow non-class subgoals
- info.search_only_classes *) then fail_if_nonclass info
- else Proofview.tclUNIT ()
- in
ortac
- (with_shelf (tac <*> filter) >>= fun s ->
+ (with_shelf tac >>= fun s ->
let i = !idx in incr idx; result s i None)
(fun e' ->
if CErrors.noncritical (fst e') then
@@ -872,12 +852,9 @@ module Search = struct
let search_tac_gl ?st only_classes dep hints depth i sigma gls gl :
unit Proofview.tactic =
let open Proofview in
- if false (* In 8.6, still allow non-class goals only_classes && not (is_class_type sigma (Goal.concl gl)) *) then
- Tacticals.New.tclZEROMSG (str"Not a subgoal for a class")
- else
- let dep = dep || Proofview.unifiable sigma (Goal.goal gl) gls in
- let info = make_autogoal ?st only_classes dep (cut_of_hints hints) i gl in
- search_tac hints depth 1 info
+ let dep = dep || Proofview.unifiable sigma (Goal.goal gl) gls in
+ let info = make_autogoal ?st only_classes dep (cut_of_hints hints) i gl in
+ search_tac hints depth 1 info
let search_tac ?(st=full_transparent_state) only_classes dep hints depth =
let open Proofview in
diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml
index c285f21e7..b92bc75bc 100644
--- a/tactics/contradiction.ml
+++ b/tactics/contradiction.ml
@@ -8,7 +8,7 @@
(* * (see LICENSE file for the text of the license) *)
(************************************************************************)
-open Term
+open Constr
open EConstr
open Hipattern
open Tactics
diff --git a/tactics/eauto.ml b/tactics/eauto.ml
index 3df9e3f82..80d07c5c0 100644
--- a/tactics/eauto.ml
+++ b/tactics/eauto.ml
@@ -12,7 +12,7 @@ open Pp
open CErrors
open Util
open Names
-open Term
+open Constr
open Termops
open EConstr
open Proof_type
diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml
index b0deeed17..176701d99 100644
--- a/tactics/eqdecide.ml
+++ b/tactics/eqdecide.ml
@@ -17,7 +17,7 @@
open Util
open Names
open Namegen
-open Term
+open Constr
open EConstr
open Declarations
open Tactics
diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml
index eede13329..ad5239116 100644
--- a/tactics/eqschemes.ml
+++ b/tactics/eqschemes.ml
@@ -108,9 +108,14 @@ let get_coq_eq ctx =
user_err Pp.(str "eq not found.")
let univ_of_eq env eq =
- let eq = EConstr.of_constr eq in
- match Constr.kind (EConstr.Unsafe.to_constr (Retyping.get_type_of env (Evd.from_env env) eq)) with
- | Prod (_,t,_) -> (match Constr.kind t with Sort (Type u) -> u | _ -> assert false)
+ let open EConstr in
+ let eq = of_constr eq in
+ let sigma = Evd.from_env env in
+ match kind sigma (Retyping.get_type_of env sigma eq) with
+ | Prod (_,t,_) -> (match kind sigma t with
+ Sort k ->
+ (match ESorts.kind sigma k with Type u -> u | _ -> assert false)
+ | _ -> assert false)
| _ -> assert false
(**********************************************************************)
diff --git a/tactics/equality.ml b/tactics/equality.ml
index 8904cd170..d7e697aed 100644
--- a/tactics/equality.ml
+++ b/tactics/equality.ml
@@ -15,6 +15,7 @@ open Util
open Names
open Nameops
open Term
+open Constr
open Termops
open EConstr
open Vars
@@ -1807,9 +1808,9 @@ let subst_all ?(flags=default_subst_tactic_flags) () =
(* J.F.: added to prevent failure on goal containing x=x as an hyp *)
if EConstr.eq_constr sigma x y then Proofview.tclUNIT () else
match EConstr.kind sigma x, EConstr.kind sigma y with
- | Var x', _ when not (dependent sigma x y) && not (is_evaluable env (EvalVarRef x')) ->
+ | Var x', _ when not (Termops.local_occur_var sigma x' y) && not (is_evaluable env (EvalVarRef x')) ->
subst_one flags.rewrite_dependent_proof x' (hyp,y,true)
- | _, Var y' when not (dependent sigma y x) && not (is_evaluable env (EvalVarRef y')) ->
+ | _, Var y' when not (Termops.local_occur_var sigma y' x) && not (is_evaluable env (EvalVarRef y')) ->
subst_one flags.rewrite_dependent_proof y' (hyp,x,false)
| _ ->
Proofview.tclUNIT ()
diff --git a/tactics/hints.ml b/tactics/hints.ml
index 786760122..d49c8aaa5 100644
--- a/tactics/hints.ml
+++ b/tactics/hints.ml
@@ -12,7 +12,7 @@ open Pp
open Util
open CErrors
open Names
-open Term
+open Constr
open Evd
open EConstr
open Vars
@@ -23,12 +23,10 @@ open Libobject
open Namegen
open Libnames
open Smartlocate
-open Misctypes
open Termops
open Inductiveops
open Typing
open Decl_kinds
-open Vernacexpr
open Typeclasses
open Pattern
open Patternops
@@ -101,6 +99,8 @@ let empty_hint_info =
(* The Type of Constructions Autotactic Hints *)
(************************************************************************)
+type hint_info_expr = Constrexpr.constr_pattern_expr hint_info_gen
+
type 'a hint_ast =
| Res_pf of 'a (* Hint Apply *)
| ERes_pf of 'a (* Hint EApply *)
@@ -156,6 +156,25 @@ type full_hint = hint with_metadata
type hint_entry = GlobRef.t option *
raw_hint hint_ast with_uid with_metadata
+type reference_or_constr =
+ | HintsReference of reference
+ | HintsConstr of Constrexpr.constr_expr
+
+type hint_mode =
+ | ModeInput (* No evars *)
+ | ModeNoHeadEvar (* No evar at the head *)
+ | ModeOutput (* Anything *)
+
+type hints_expr =
+ | HintsResolve of (hint_info_expr * bool * reference_or_constr) list
+ | HintsResolveIFF of bool * reference list * int option
+ | HintsImmediate of reference_or_constr list
+ | HintsUnfold of reference list
+ | HintsTransparency of reference list * bool
+ | HintsMode of reference * hint_mode list
+ | HintsConstructors of reference list
+ | HintsExtern of int * Constrexpr.constr_expr option * Genarg.raw_generic_argument
+
type import_level = [ `LAX | `WARN | `STRICT ]
let warn_hint : import_level ref = ref `LAX
@@ -276,15 +295,15 @@ let strip_params env sigma c =
| App (f, args) ->
(match EConstr.kind sigma f with
| Const (p,_) ->
- let cb = lookup_constant p env in
- (match cb.Declarations.const_proj with
- | Some pb ->
- let n = pb.Declarations.proj_npars in
- if Array.length args > n then
- mkApp (mkProj (Projection.make p false, args.(n)),
- Array.sub args (n+1) (Array.length args - (n + 1)))
- else c
- | None -> c)
+ let p = Projection.make p false in
+ (match lookup_projection p env with
+ | pb ->
+ let n = pb.Declarations.proj_npars in
+ if Array.length args > n then
+ mkApp (mkProj (p, args.(n)),
+ Array.sub args (n+1) (Array.length args - (n + 1)))
+ else c
+ | exception Not_found -> c)
| _ -> c)
| _ -> c
@@ -654,7 +673,7 @@ struct
let add_list env sigma l db = List.fold_left (fun db k -> add_one env sigma k db) db l
- let remove_sdl p sdl = List.Smart.filter p sdl
+ let remove_sdl p sdl = List.filter p sdl
let remove_he st p se =
let sl1' = remove_sdl p se.sentry_nopat in
@@ -666,7 +685,7 @@ struct
let filter (_, h) =
match h.name with PathHints [gr] -> not (List.mem_f GlobRef.equal gr grs) | _ -> true in
let hintmap = Constr_map.map (remove_he db.hintdb_state filter) db.hintdb_map in
- let hintnopat = List.Smart.filter (fun (ge, sd) -> filter sd) db.hintdb_nopat in
+ let hintnopat = List.filter (fun (ge, sd) -> filter sd) db.hintdb_nopat in
{ db with hintdb_map = hintmap; hintdb_nopat = hintnopat }
let remove_one gr db = remove_list [gr] db
@@ -1218,7 +1237,7 @@ let add_trivials env sigma l local dbnames =
type hnf = bool
-type hint_info = (patvar list * constr_pattern) hint_info_gen
+type nonrec hint_info = hint_info
type hints_entry =
| HintsResolveEntry of (hint_info * polymorphic * hnf * hints_path_atom * hint_term) list
@@ -1272,6 +1291,35 @@ let prepare_hint check (poly,local) env init (sigma,c) =
else (Lib.add_anonymous_leaf (input_context_set diff);
IsConstr (c', Univ.ContextSet.empty))
+let project_hint ~poly pri l2r r =
+ let open EConstr in
+ let open Coqlib in
+ let gr = Smartlocate.global_with_alias r in
+ let env = Global.env() in
+ let sigma = Evd.from_env env in
+ let sigma, c = Evd.fresh_global env sigma gr in
+ let t = Retyping.get_type_of env sigma c in
+ let t =
+ Tacred.reduce_to_quantified_ref env sigma (Lazy.force coq_iff_ref) t in
+ let sign,ccl = decompose_prod_assum sigma t in
+ let (a,b) = match snd (decompose_app sigma ccl) with
+ | [a;b] -> (a,b)
+ | _ -> assert false in
+ let p =
+ if l2r then build_coq_iff_left_proj () else build_coq_iff_right_proj () in
+ let sigma, p = Evd.fresh_global env sigma p in
+ let c = Reductionops.whd_beta sigma (mkApp (c, Context.Rel.to_extended_vect mkRel 0 sign)) in
+ let c = it_mkLambda_or_LetIn
+ (mkApp (p,[|mkArrow a (lift 1 b);mkArrow b (lift 1 a);c|])) sign in
+ let id =
+ Nameops.add_suffix (Nametab.basename_of_global gr) ("_proj_" ^ (if l2r then "l2r" else "r2l"))
+ in
+ let ctx = Evd.const_univ_entry ~poly sigma in
+ let c = EConstr.to_constr sigma c in
+ let c = Declare.declare_definition ~internal:Declare.InternalTacticRequest id (c,ctx) in
+ let info = {Typeclasses.hint_priority = pri; hint_pattern = None} in
+ (info,false,true,PathAny, IsGlobRef (Globnames.ConstRef c))
+
let interp_hints poly =
fun h ->
let env = Global.env () in
@@ -1301,6 +1349,8 @@ let interp_hints poly =
in
match h with
| HintsResolve lhints -> HintsResolveEntry (List.map fres lhints)
+ | HintsResolveIFF (l2r, lc, n) ->
+ HintsResolveEntry (List.map (project_hint ~poly n l2r) lc)
| HintsImmediate lhints -> HintsImmediateEntry (List.map fi lhints)
| HintsUnfold lhints -> HintsUnfoldEntry (List.map fr lhints)
| HintsTransparency (lhints, b) ->
@@ -1326,7 +1376,7 @@ let interp_hints poly =
let _, tacexp = Genintern.generic_intern env tacexp in
HintsExternEntry ({ hint_priority = Some pri; hint_pattern = pat }, tacexp)
-let add_hints local dbnames0 h =
+let add_hints ~local dbnames0 h =
if String.List.mem "nocore" dbnames0 then
user_err Pp.(str "The hint database \"nocore\" is meant to stay empty.");
let dbnames = if List.is_empty dbnames0 then ["core"] else dbnames0 in
@@ -1361,12 +1411,10 @@ let expand_constructor_hints env sigma lems =
(* builds a hint database from a constr signature *)
(* typically used with (lid, ltyp) = pf_hyps_types <some goal> *)
-let add_hint_lemmas env sigma eapply lems hint_db =
+let constructor_hints env sigma eapply lems =
let lems = expand_constructor_hints env sigma lems in
- let hintlist' =
- List.map_append (fun (poly, lem) ->
- make_resolves env sigma (eapply,true,false) empty_hint_info poly lem) lems in
- Hint_db.add_list env sigma hintlist' hint_db
+ List.map_append (fun (poly, lem) ->
+ make_resolves env sigma (eapply,true,false) empty_hint_info poly lem) lems
let make_local_hint_db env sigma ts eapply lems =
let map c = c env sigma in
@@ -1377,8 +1425,9 @@ let make_local_hint_db env sigma ts eapply lems =
| Some ts -> ts
in
let hintlist = List.map_append (make_resolve_hyp env sigma) sign in
- add_hint_lemmas env sigma eapply lems
- (Hint_db.add_list env sigma hintlist (Hint_db.empty ts false))
+ Hint_db.empty ts false
+ |> Hint_db.add_list env sigma hintlist
+ |> Hint_db.add_list env sigma (constructor_hints env sigma eapply lems)
let make_local_hint_db env sigma ?ts eapply lems =
make_local_hint_db env sigma ts eapply lems
diff --git a/tactics/hints.mli b/tactics/hints.mli
index c7de10a2a..e958f986e 100644
--- a/tactics/hints.mli
+++ b/tactics/hints.mli
@@ -14,11 +14,10 @@ open EConstr
open Environ
open Decl_kinds
open Evd
-open Misctypes
open Tactypes
open Clenv
open Pattern
-open Vernacexpr
+open Typeclasses
(** {6 General functions. } *)
@@ -34,6 +33,8 @@ val empty_hint_info : 'a Typeclasses.hint_info_gen
(** Pre-created hint databases *)
+type hint_info_expr = Constrexpr.constr_pattern_expr hint_info_gen
+
type 'a hint_ast =
| Res_pf of 'a (* Hint Apply *)
| ERes_pf of 'a (* Hint EApply *)
@@ -71,6 +72,25 @@ type search_entry
type hint_entry
+type reference_or_constr =
+ | HintsReference of Libnames.reference
+ | HintsConstr of Constrexpr.constr_expr
+
+type hint_mode =
+ | ModeInput (* No evars *)
+ | ModeNoHeadEvar (* No evar at the head *)
+ | ModeOutput (* Anything *)
+
+type hints_expr =
+ | HintsResolve of (hint_info_expr * bool * reference_or_constr) list
+ | HintsResolveIFF of bool * Libnames.reference list * int option
+ | HintsImmediate of reference_or_constr list
+ | HintsUnfold of Libnames.reference list
+ | HintsTransparency of Libnames.reference list * bool
+ | HintsMode of Libnames.reference * hint_mode list
+ | HintsConstructors of Libnames.reference list
+ | HintsExtern of int * Constrexpr.constr_expr option * Genarg.raw_generic_argument
+
type 'a hints_path_gen =
| PathAtom of 'a hints_path_atom_gen
| PathStar of 'a hints_path_gen
@@ -143,8 +163,6 @@ type hint_db = Hint_db.t
type hnf = bool
-type hint_info = (patvar list * constr_pattern) Typeclasses.hint_info_gen
-
type hint_term =
| IsGlobRef of GlobRef.t
| IsConstr of constr * Univ.ContextSet.t
@@ -178,7 +196,7 @@ val current_pure_db : unit -> hint_db list
val interp_hints : polymorphic -> hints_expr -> hints_entry
-val add_hints : locality_flag -> hint_db_name list -> hints_entry -> unit
+val add_hints : local:bool -> hint_db_name list -> hints_entry -> unit
val prepare_hint : bool (* Check no remaining evars *) ->
(bool * bool) (* polymorphic or monomorphic, local or global *) ->
@@ -273,3 +291,5 @@ val pr_hint : env -> evar_map -> hint -> Pp.t
(** Hook for changing the initialization of auto *)
val add_hints_init : (unit -> unit) -> unit
+type nonrec hint_info = hint_info
+[@@ocaml.deprecated "Use [Typeclasses.hint_info]"]
diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml
index b8f1ed720..5d264058a 100644
--- a/tactics/hipattern.ml
+++ b/tactics/hipattern.ml
@@ -12,7 +12,7 @@ open Pp
open CErrors
open Util
open Names
-open Term
+open Constr
open Termops
open EConstr
open Inductiveops
diff --git a/tactics/inv.ml b/tactics/inv.ml
index b346ed223..102b8e54d 100644
--- a/tactics/inv.ml
+++ b/tactics/inv.ml
@@ -14,6 +14,7 @@ open Util
open Names
open Term
open Termops
+open Constr
open EConstr
open Vars
open Namegen
@@ -292,7 +293,7 @@ let error_too_many_names pats =
str "Unexpected " ++
str (String.plural (List.length pats) "introduction pattern") ++
str ": " ++ pr_enum (Miscprint.pr_intro_pattern
- (fun c -> Printer.pr_constr_env env sigma (EConstr.Unsafe.to_constr (snd (c env (Evd.from_env env)))))) pats ++
+ (fun c -> Printer.pr_econstr_env env sigma (snd (c env (Evd.from_env env))))) pats ++
str ".")
let get_names (allow_conj,issimple) ({CAst.loc;v=pat} as x) = match pat with
@@ -468,7 +469,7 @@ let raw_inversion inv_kind id status names =
make_inv_predicate env evdref indf realargs id status concl in
let sigma = !evdref in
let (cut_concl,case_tac) =
- if status != NoDep && (dependent sigma c concl) then
+ if status != NoDep && (local_occur_var sigma id concl) then
Reductionops.beta_applist sigma (elim_predicate, realargs@[c]),
case_then_using
else
diff --git a/tactics/leminv.ml b/tactics/leminv.ml
index a4cdc1592..10937322e 100644
--- a/tactics/leminv.ml
+++ b/tactics/leminv.ml
@@ -12,9 +12,9 @@ open Pp
open CErrors
open Util
open Names
-open Term
open Termops
open Environ
+open Constr
open EConstr
open Vars
open Namegen
@@ -232,9 +232,8 @@ let inversion_scheme env sigma t sort dep_option inv_op =
let c = fill_holes pfterm in
(* warning: side-effect on ownSign *)
let invProof = it_mkNamedLambda_or_LetIn c !ownSign in
- let invProof = EConstr.Unsafe.to_constr invProof in
- let p = Evarutil.nf_evars_universes sigma invProof in
- p, sigma
+ let p = EConstr.to_constr sigma invProof in
+ p, sigma
let add_inversion_lemma ~poly name env sigma t sort dep inv_op =
let invProof, sigma = inversion_scheme env sigma t sort dep inv_op in
diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml
index 6c7db26c7..732d06f8a 100644
--- a/tactics/tacticals.ml
+++ b/tactics/tacticals.ml
@@ -509,7 +509,7 @@ module New = struct
match Evd.evar_body evi with
| Evd.Evar_empty -> Some (evk,evi)
| Evd.Evar_defined c -> match Constr.kind (EConstr.Unsafe.to_constr c) with
- | Term.Evar (evk,l) -> is_undefined_up_to_restriction sigma evk
+ | Evar (evk,l) -> is_undefined_up_to_restriction sigma evk
| _ ->
(* We make the assumption that there is no way to refine an
evar remaining after typing from the initial term given to
diff --git a/tactics/tactics.ml b/tactics/tactics.ml
index a42e4b44b..b571b347d 100644
--- a/tactics/tactics.ml
+++ b/tactics/tactics.ml
@@ -128,14 +128,14 @@ let unsafe_intro env store decl b =
(sigma, mkNamedLambda_or_LetIn decl ev)
end
-let introduction ?(check=true) id =
+let introduction id =
Proofview.Goal.enter begin fun gl ->
let concl = Proofview.Goal.concl gl in
let sigma = Tacmach.New.project gl in
let hyps = named_context_val (Proofview.Goal.env gl) in
let store = Proofview.Goal.extra gl in
let env = Proofview.Goal.env gl in
- let () = if check && mem_named_context_val id hyps then
+ let () = if mem_named_context_val id hyps then
user_err ~hdr:"Tactics.introduction"
(str "Variable " ++ Id.print id ++ str " is already declared.")
in
@@ -158,9 +158,9 @@ let convert_concl ?(check=true) ty k =
let sigma =
if check then begin
ignore (Typing.unsafe_type_of env sigma ty);
- let sigma,b = Reductionops.infer_conv env sigma ty conclty in
- if not b then error "Not convertible.";
- sigma
+ match Reductionops.infer_conv env sigma ty conclty with
+ | None -> error "Not convertible."
+ | Some sigma -> sigma
end else sigma in
let (sigma, x) = Evarutil.new_evar env sigma ~principal:true ~store ty in
let ans = if k == DEFAULTcast then x else mkCast(x,k,conclty) in
@@ -186,11 +186,10 @@ let convert_hyp_no_check = convert_hyp ~check:false
let convert_gen pb x y =
Proofview.Goal.enter begin fun gl ->
- try
- let sigma, b = Tacmach.New.pf_apply (Reductionops.infer_conv ~pb) gl x y in
- if b then Proofview.Unsafe.tclEVARS sigma
- else Tacticals.New.tclFAIL 0 (str "Not convertible")
- with (* Reduction.NotConvertible *) _ ->
+ match Tacmach.New.pf_apply (Reductionops.infer_conv ~pb) gl x y with
+ | Some sigma -> Proofview.Unsafe.tclEVARS sigma
+ | None -> Tacticals.New.tclFAIL 0 (str "Not convertible")
+ | exception _ ->
(** FIXME: Sometimes an anomaly is raised from conversion *)
Tacticals.New.tclFAIL 0 (str "Not convertible")
end
@@ -796,15 +795,15 @@ let check_types env sigma mayneedglobalcheck deep newc origc =
let t2 = Retyping.get_type_of env sigma origc in
let sigma, t2 = Evarsolve.refresh_universes
~onlyalg:true (Some false) env sigma t2 in
- let sigma, b = infer_conv ~pb:Reduction.CUMUL env sigma t1 t2 in
- if not b then
+ match infer_conv ~pb:Reduction.CUMUL env sigma t1 t2 with
+ | None ->
if
isSort sigma (whd_all env sigma t1) &&
isSort sigma (whd_all env sigma t2)
then (mayneedglobalcheck := true; sigma)
else
user_err ~hdr:"convert-check-hyp" (str "Types are incompatible.")
- else sigma
+ | Some sigma -> sigma
end
else
if not (isSort sigma (whd_all env sigma t1)) then
@@ -815,9 +814,9 @@ let check_types env sigma mayneedglobalcheck deep newc origc =
let change_and_check cv_pb mayneedglobalcheck deep t env sigma c =
let (sigma, t') = t sigma in
let sigma = check_types env sigma mayneedglobalcheck deep t' c in
- let sigma, b = infer_conv ~pb:cv_pb env sigma t' c in
- if not b then user_err ~hdr:"convert-check-hyp" (str "Not convertible.");
- (sigma, t')
+ match infer_conv ~pb:cv_pb env sigma t' c with
+ | None -> user_err ~hdr:"convert-check-hyp" (str "Not convertible.");
+ | Some sigma -> (sigma, t')
(* Use cumulativity only if changing the conclusion not a subterm *)
let change_on_subterm cv_pb deep t where env sigma c =
@@ -1638,13 +1637,11 @@ let tclORELSEOPT t k =
Proofview.tclZERO ~info e
| Some tac -> tac)
-let general_apply with_delta with_destruct with_evars clear_flag
- {CAst.loc;v=(c,lbind : EConstr.constr with_bindings)} =
+let general_apply ?(respect_opaque=false) with_delta with_destruct with_evars
+ clear_flag {CAst.loc;v=(c,lbind : EConstr.constr with_bindings)} =
Proofview.Goal.enter begin fun gl ->
let concl = Proofview.Goal.concl gl in
let sigma = Tacmach.New.project gl in
- let flags =
- if with_delta then default_unify_flags () else default_no_delta_unify_flags () in
(* The actual type of the theorem. It will be matched against the
goal. If this fails, then the head constant will be unfolded step by
step. *)
@@ -1653,7 +1650,12 @@ let general_apply with_delta with_destruct with_evars clear_flag
Proofview.Goal.enter begin fun gl ->
let env = Proofview.Goal.env gl in
let sigma = Tacmach.New.project gl in
-
+ let ts =
+ if respect_opaque then Conv_oracle.get_transp_state (oracle env)
+ else full_transparent_state
+ in
+ let flags =
+ if with_delta then default_unify_flags () else default_no_delta_unify_flags ts in
let thm_ty0 = nf_betaiota env sigma (Retyping.get_type_of env sigma c) in
let try_apply thm_ty nprod =
try
@@ -1719,14 +1721,14 @@ let rec apply_with_bindings_gen b e = function
(general_apply b b e k cb)
(apply_with_bindings_gen b e cbl)
-let apply_with_delayed_bindings_gen b e l =
+let apply_with_delayed_bindings_gen b e l =
let one k {CAst.loc;v=f} =
Proofview.Goal.enter begin fun gl ->
let sigma = Tacmach.New.project gl in
let env = Proofview.Goal.env gl in
let (sigma, cb) = f env sigma in
Tacticals.New.tclWITHHOLES e
- (general_apply b b e k CAst.(make ?loc cb)) sigma
+ (general_apply ~respect_opaque:(not b) b b e k CAst.(make ?loc cb)) sigma
end
in
let rec aux = function
@@ -1801,14 +1803,12 @@ let apply_in_once_main flags innerclause env sigma (loc,d,lbind) =
in
aux (make_clenv_binding env sigma (d,thm) lbind)
-let apply_in_once sidecond_first with_delta with_destruct with_evars naming
- id (clear_flag,{ CAst.loc; v= d,lbind}) tac =
+let apply_in_once ?(respect_opaque = false) sidecond_first with_delta
+ with_destruct with_evars naming id (clear_flag,{ CAst.loc; v= d,lbind}) tac =
let open Context.Rel.Declaration in
Proofview.Goal.enter begin fun gl ->
let env = Proofview.Goal.env gl in
let sigma = Tacmach.New.project gl in
- let flags =
- if with_delta then default_unify_flags () else default_no_delta_unify_flags () in
let t' = Tacmach.New.pf_get_hyp_typ id gl in
let innerclause = mk_clenv_from_env env sigma (Some 0) (mkVar id,t') in
let targetid = find_name true (LocalAssum (Anonymous,t')) naming gl in
@@ -1816,6 +1816,12 @@ let apply_in_once sidecond_first with_delta with_destruct with_evars naming
Proofview.Goal.enter begin fun gl ->
let env = Proofview.Goal.env gl in
let sigma = Tacmach.New.project gl in
+ let ts =
+ if respect_opaque then Conv_oracle.get_transp_state (oracle env)
+ else full_transparent_state
+ in
+ let flags =
+ if with_delta then default_unify_flags () else default_no_delta_unify_flags ts in
try
let clause = apply_in_once_main flags innerclause env sigma (loc,c,lbind) in
clenv_refine_in ~sidecond_first with_evars targetid id sigma clause
@@ -1835,14 +1841,14 @@ let apply_in_once sidecond_first with_delta with_destruct with_evars naming
aux [] with_destruct d
end
-let apply_in_delayed_once sidecond_first with_delta with_destruct with_evars naming
- id (clear_flag,{CAst.loc;v=f}) tac =
+let apply_in_delayed_once ?(respect_opaque = false) sidecond_first with_delta
+ with_destruct with_evars naming id (clear_flag,{CAst.loc;v=f}) tac =
Proofview.Goal.enter begin fun gl ->
let env = Proofview.Goal.env gl in
let sigma = Tacmach.New.project gl in
let (sigma, c) = f env sigma in
Tacticals.New.tclWITHHOLES with_evars
- (apply_in_once sidecond_first with_delta with_destruct with_evars
+ (apply_in_once ~respect_opaque sidecond_first with_delta with_destruct with_evars
naming id (clear_flag,CAst.(make ?loc c)) tac)
sigma
end
@@ -1910,8 +1916,8 @@ let cast_no_check cast c =
exact_no_check (mkCast (c, cast, concl))
end
-let vm_cast_no_check c = cast_no_check Term.VMcast c
-let native_cast_no_check c = cast_no_check Term.NATIVEcast c
+let vm_cast_no_check c = cast_no_check VMcast c
+let native_cast_no_check c = cast_no_check NATIVEcast c
let exact_proof c =
let open Tacmach.New in
@@ -1934,16 +1940,19 @@ let assumption =
let t = NamedDecl.get_type decl in
let concl = Proofview.Goal.concl gl in
let sigma = Tacmach.New.project gl in
- let (sigma, is_same_type) =
- if only_eq then (sigma, EConstr.eq_constr sigma t concl)
+ let ans =
+ if only_eq then
+ if EConstr.eq_constr sigma t concl then Some sigma
+ else None
else
let env = Proofview.Goal.env gl in
infer_conv env sigma t concl
in
- if is_same_type then
+ match ans with
+ | Some sigma ->
(Proofview.Unsafe.tclEVARS sigma) <*>
exact_no_check (mkVar (NamedDecl.get_id decl))
- else arec gl only_eq rest
+ | None -> arec gl only_eq rest
in
let assumption_tac gl =
let hyps = Proofview.Goal.hyps gl in
@@ -2529,11 +2538,11 @@ let assert_as first hd ipat t =
(* apply in as *)
-let general_apply_in sidecond_first with_delta with_destruct with_evars
- id lemmas ipat =
+let general_apply_in ?(respect_opaque=false) sidecond_first with_delta
+ with_destruct with_evars id lemmas ipat =
let tac (naming,lemma) tac id =
- apply_in_delayed_once sidecond_first with_delta with_destruct with_evars
- naming id lemma tac in
+ apply_in_delayed_once ~respect_opaque sidecond_first with_delta
+ with_destruct with_evars naming id lemma tac in
Proofview.Goal.enter begin fun gl ->
let destopt =
if with_evars then MoveLast (* evars would depend on the whole context *)
@@ -2564,7 +2573,7 @@ let apply_in simple with_evars id lemmas ipat =
general_apply_in false simple simple with_evars id lemmas ipat
let apply_delayed_in simple with_evars id lemmas ipat =
- general_apply_in false simple simple with_evars id lemmas ipat
+ general_apply_in ~respect_opaque:true false simple simple with_evars id lemmas ipat
(*****************************)
(* Tactics abstracting terms *)
diff --git a/tactics/tactics.mli b/tactics/tactics.mli
index ddf78b1d4..b17330f13 100644
--- a/tactics/tactics.mli
+++ b/tactics/tactics.mli
@@ -34,7 +34,7 @@ val is_quantified_hypothesis : Id.t -> Proofview.Goal.t -> bool
(** {6 Primitive tactics. } *)
-val introduction : ?check:bool -> Id.t -> unit Proofview.tactic
+val introduction : Id.t -> unit Proofview.tactic
val convert_concl : ?check:bool -> types -> cast_kind -> unit Proofview.tactic
val convert_hyp : ?check:bool -> named_declaration -> unit Proofview.tactic
val convert_concl_no_check : types -> cast_kind -> unit Proofview.tactic
diff --git a/tactics/term_dnet.ml b/tactics/term_dnet.ml
index 611799990..8bdcc6321 100644
--- a/tactics/term_dnet.ml
+++ b/tactics/term_dnet.ml
@@ -290,7 +290,7 @@ struct
| Const (c,u) -> Term (DRef (ConstRef c))
| Ind (i,u) -> Term (DRef (IndRef i))
| Construct (c,u)-> Term (DRef (ConstructRef c))
- | Term.Meta _ -> assert false
+ | Meta _ -> assert false
| Evar (i,_) ->
let meta =
try Evar.Map.find i !metas
diff --git a/tactics/term_dnet.mli b/tactics/term_dnet.mli
index 2c748f9c9..7bce57789 100644
--- a/tactics/term_dnet.mli
+++ b/tactics/term_dnet.mli
@@ -26,7 +26,7 @@ open Mod_subst
The results returned here are perfect, since post-filtering is done
inside here.
- See lib/dnet.mli for more details.
+ See tactics/dnet.mli for more details.
*)
(** Identifiers to store (right hand side of the association) *)
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-21 19:14:20 +0000