diff options
Diffstat (limited to 'proofs/tacmach.ml')
| -rw-r--r-- | proofs/tacmach.ml | 91 |
1 files changed, 40 insertions, 51 deletions
diff --git a/proofs/tacmach.ml b/proofs/tacmach.ml index 330594af..1889054f 100644 --- a/proofs/tacmach.ml +++ b/proofs/tacmach.ml @@ -1,9 +1,11 @@ (************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* * The Coq Proof Assistant / The Coq Development Team *) +(* v * INRIA, CNRS and contributors - Copyright 1999-2018 *) +(* <O___,, * (see CREDITS file for the list of authors) *) (* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(* * (see LICENSE file for the text of the license) *) (************************************************************************) open Util @@ -18,9 +20,10 @@ open Tacred open Proof_type open Logic open Refiner -open Sigma.Notations open Context.Named.Declaration +module NamedDecl = Context.Named.Declaration + let re_sig it gc = { it = it; sigma = gc; } (**************************************************************) @@ -39,44 +42,43 @@ let project = Refiner.project let pf_env = Refiner.pf_env let pf_hyps = Refiner.pf_hyps +let test_conversion env sigma pb c1 c2 = + Reductionops.check_conv ~pb env sigma c1 c2 + let pf_concl gls = Goal.V82.concl (project gls) (sig_it gls) let pf_hyps_types gls = let sign = Environ.named_context (pf_env gls) in List.map (function LocalAssum (id,x) - | LocalDef (id,_,x) -> id, x) + | LocalDef (id,_,x) -> id, EConstr.of_constr x) sign -let pf_nth_hyp_id gls n = List.nth (pf_hyps gls) (n-1) |> get_id +let pf_nth_hyp_id gls n = List.nth (pf_hyps gls) (n-1) |> NamedDecl.get_id let pf_last_hyp gl = List.hd (pf_hyps gl) let pf_get_hyp gls id = + let env, sigma = pf_env gls, project gls in try Context.Named.lookup id (pf_hyps gls) with Not_found -> - raise (RefinerError (NoSuchHyp id)) + raise (RefinerError (env, sigma, NoSuchHyp id)) let pf_get_hyp_typ gls id = - pf_get_hyp gls id |> get_type + id |> pf_get_hyp gls |> NamedDecl.get_type let pf_ids_of_hyps gls = ids_of_named_context (pf_hyps gls) +let pf_ids_set_of_hyps gls = + Environ.ids_of_named_context_val (Environ.named_context_val (pf_env gls)) let pf_get_new_id id gls = - next_ident_away id (pf_ids_of_hyps gls) - -let pf_get_new_ids ids gls = - let avoid = pf_ids_of_hyps gls in - List.fold_right - (fun id acc -> (next_ident_away id (acc@avoid))::acc) - ids [] + next_ident_away id (pf_ids_set_of_hyps gls) -let pf_global gls id = Constrintern.construct_reference (pf_hyps gls) id +let pf_global gls id = EConstr.of_constr (Universes.constr_of_global (Constrintern.construct_reference (pf_hyps gls) id)) let pf_reduction_of_red_expr gls re c = let (redfun, _) = reduction_of_red_expr (pf_env gls) re in - let sigma = Sigma.Unsafe.of_evar_map (project gls) in - let Sigma (c, sigma, _) = redfun.e_redfun (pf_env gls) sigma c in - (Sigma.to_evar_map sigma, c) + let sigma = project gls in + redfun (pf_env gls) sigma c let pf_apply f gls = f (pf_env gls) (project gls) let pf_eapply f gls x = @@ -87,7 +89,7 @@ let pf_e_reduce = pf_apply let pf_whd_all = pf_reduce whd_all let pf_hnf_constr = pf_reduce hnf_constr let pf_nf = pf_reduce simpl -let pf_nf_betaiota = pf_reduce (fun _ -> nf_betaiota) +let pf_nf_betaiota = pf_reduce nf_betaiota let pf_compute = pf_reduce compute let pf_unfoldn ubinds = pf_reduce (unfoldn ubinds) let pf_unsafe_type_of = pf_reduce unsafe_type_of @@ -96,15 +98,12 @@ let pf_get_type_of = pf_reduce Retyping.get_type_of let pf_conv_x gl = pf_reduce test_conversion gl Reduction.CONV let pf_conv_x_leq gl = pf_reduce test_conversion gl Reduction.CUMUL -let pf_const_value = pf_reduce (fun env _ -> constant_value_in env) +let pf_const_value = pf_reduce (fun env _ c -> EConstr.of_constr (constant_value_in env c)) let pf_reduce_to_quantified_ind = pf_reduce reduce_to_quantified_ind let pf_reduce_to_atomic_ind = pf_reduce reduce_to_atomic_ind -let pf_hnf_type_of gls = pf_whd_all gls % pf_get_type_of gls - -let pf_is_matching = pf_apply Constr_matching.is_matching_conv -let pf_matches = pf_apply Constr_matching.matches_conv +let pf_hnf_type_of gls = pf_get_type_of gls %> pf_whd_all gls (********************************************) (* Definition of the most primitive tactics *) @@ -112,19 +111,12 @@ let pf_matches = pf_apply Constr_matching.matches_conv let refiner = refiner -let internal_cut_no_check replace id t gl = - refiner (Cut (true,replace,id,t)) gl - -let internal_cut_rev_no_check replace id t gl = - refiner (Cut (false,replace,id,t)) gl - let refine_no_check c gl = + let c = EConstr.Unsafe.to_constr c in refiner (Refine c) gl (* Versions with consistency checks *) -let internal_cut b d t = with_check (internal_cut_no_check b d t) -let internal_cut_rev b d t = with_check (internal_cut_rev_no_check b d t) let refine c = with_check (refine_no_check c) (* Pretty-printers *) @@ -134,7 +126,7 @@ open Pp let db_pr_goal sigma g = let env = Goal.V82.env sigma g in let penv = print_named_context env in - let pc = print_constr_env env (Goal.V82.concl sigma g) in + let pc = print_constr_env env sigma (Goal.V82.concl sigma g) in str" " ++ hv 0 (penv ++ fnl () ++ str "============================" ++ fnl () ++ str" " ++ pc) ++ fnl () @@ -150,8 +142,7 @@ let pr_glls glls = module New = struct let project gl = - let sigma = Proofview.Goal.sigma gl in - Sigma.to_evar_map sigma + Proofview.Goal.sigma gl let pf_apply f gl = f (Proofview.Goal.env gl) (project gl) @@ -161,7 +152,6 @@ module New = struct let pf_global id gl = (** We only check for the existence of an [id] in [hyps] *) - let gl = Proofview.Goal.assume gl in let hyps = Proofview.Goal.hyps gl in Constrintern.construct_reference hyps id @@ -171,9 +161,6 @@ module New = struct let pf_unsafe_type_of gl t = pf_apply unsafe_type_of gl t - let pf_get_type_of gl t = - pf_apply (Retyping.get_type_of ~lax:true) gl t - let pf_type_of gl t = pf_apply type_of gl t @@ -181,39 +168,43 @@ module New = struct let pf_ids_of_hyps gl = (** We only get the identifiers in [hyps] *) - let gl = Proofview.Goal.assume gl in let hyps = Proofview.Goal.hyps gl in ids_of_named_context hyps + let pf_ids_set_of_hyps gl = + (** We only get the identifiers in [hyps] *) + let env = Proofview.Goal.env gl in + Environ.ids_of_named_context_val (Environ.named_context_val env) + let pf_get_new_id id gl = - let ids = pf_ids_of_hyps gl in + let ids = pf_ids_set_of_hyps gl in next_ident_away id ids let pf_get_hyp id gl = let hyps = Proofview.Goal.env gl in + let sigma = project gl in let sign = - try Environ.lookup_named id hyps - with Not_found -> raise (RefinerError (NoSuchHyp id)) + try EConstr.lookup_named id hyps + with Not_found -> raise (RefinerError (hyps, sigma, NoSuchHyp id)) in sign let pf_get_hyp_typ id gl = - pf_get_hyp id gl |> get_type + pf_get_hyp id gl |> NamedDecl.get_type let pf_hyps_types gl = let env = Proofview.Goal.env gl in let sign = Environ.named_context env in List.map (function LocalAssum (id,x) - | LocalDef (id,_,x) -> id, x) + | LocalDef (id,_,x) -> id, EConstr.of_constr x) sign let pf_last_hyp gl = let hyps = Proofview.Goal.hyps gl in List.hd hyps - let pf_nf_concl (gl : ([ `LZ ], 'r) Proofview.Goal.t) = + let pf_nf_concl (gl : Proofview.Goal.t) = (** We normalize the conclusion just after *) - let gl = Proofview.Goal.assume gl in let concl = Proofview.Goal.concl gl in let sigma = project gl in nf_evar sigma concl @@ -229,8 +220,6 @@ module New = struct let pf_hnf_type_of gl t = pf_whd_all gl (pf_get_type_of gl t) - let pf_matches gl pat t = pf_apply Constr_matching.matches_conv gl pat t - let pf_whd_all gl t = pf_apply whd_all gl t let pf_compute gl t = pf_apply compute gl t |