From 5143129baac805d3a49ac3ee9f3344c7a447634f Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 30 Oct 2016 17:53:07 +0100 Subject: Termops API using EConstr. --- tactics/auto.ml | 18 ++++--- tactics/class_tactics.ml | 29 +++++------ tactics/contradiction.ml | 10 ++-- tactics/eauto.ml | 17 ++++--- tactics/elim.ml | 11 +++-- tactics/equality.ml | 41 +++++++++------- tactics/hints.ml | 40 +++++++-------- tactics/hints.mli | 2 +- tactics/hipattern.ml | 96 ++++++++++++++++++------------------ tactics/hipattern.mli | 4 +- tactics/inv.ml | 17 ++++--- tactics/leminv.ml | 7 +-- tactics/tacticals.ml | 2 +- tactics/tactics.ml | 125 ++++++++++++++++++++++++++--------------------- tactics/term_dnet.ml | 2 +- 15 files changed, 223 insertions(+), 198 deletions(-) (limited to 'tactics') diff --git a/tactics/auto.ml b/tactics/auto.ml index d4251555d8..17fe7362d2 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -302,7 +302,7 @@ let hintmap_of secvars hdc concl = match hdc with | None -> Hint_db.map_none ~secvars | Some hdc -> - if occur_existential concl then + if occur_existential Evd.empty (EConstr.of_constr concl) then (** FIXME *) Hint_db.map_existential ~secvars hdc concl else Hint_db.map_auto ~secvars hdc concl @@ -329,11 +329,12 @@ let rec trivial_fail_db dbg mod_delta db_list local_db = in Proofview.Goal.enter { enter = begin fun gl -> let concl = Tacmach.New.pf_nf_concl gl in + let sigma = Tacmach.New.project gl in let secvars = compute_secvars gl in Tacticals.New.tclFIRST ((dbg_assumption dbg)::intro_tac:: (List.map Tacticals.New.tclCOMPLETE - (trivial_resolve dbg mod_delta db_list local_db secvars concl))) + (trivial_resolve sigma dbg mod_delta db_list local_db secvars concl))) end } and my_find_search_nodelta db_list local_db secvars hdc concl = @@ -346,7 +347,7 @@ and my_find_search mod_delta = and my_find_search_delta db_list local_db secvars hdc concl = let f = hintmap_of secvars hdc concl in - if occur_existential concl then + if occur_existential Evd.empty (EConstr.of_constr concl) (** FIXME *) then List.map_append (fun db -> if Hint_db.use_dn db then @@ -402,10 +403,10 @@ and tac_of_hint dbg db_list local_db concl (flags, ({pat=p; code=t;poly=poly;db= in tclLOG dbg pr_hint (run_hint t tactic) -and trivial_resolve dbg mod_delta db_list local_db secvars cl = +and trivial_resolve sigma dbg mod_delta db_list local_db secvars cl = try let head = - try let hdconstr = decompose_app_bound cl in + try let hdconstr = decompose_app_bound sigma cl in Some hdconstr with Bound -> None in @@ -449,10 +450,10 @@ let h_trivial ?(debug=Off) lems l = gen_trivial ~debug lems l (* The classical Auto tactic *) (**************************************************************************) -let possible_resolve dbg mod_delta db_list local_db secvars cl = +let possible_resolve sigma dbg mod_delta db_list local_db secvars cl = try let head = - try let hdconstr = decompose_app_bound cl in + try let hdconstr = decompose_app_bound sigma cl in Some hdconstr with Bound -> None in @@ -488,12 +489,13 @@ let search d n mod_delta db_list local_db = (Tacticals.New.tclORELSE0 (intro_register d (search d n) local_db) ( Proofview.Goal.enter { enter = begin fun gl -> let concl = Tacmach.New.pf_nf_concl gl in + let sigma = Tacmach.New.project gl in let secvars = compute_secvars gl in let d' = incr_dbg d in Tacticals.New.tclFIRST (List.map (fun ntac -> Tacticals.New.tclTHEN ntac (search d' (n-1) local_db)) - (possible_resolve d mod_delta db_list local_db secvars concl)) + (possible_resolve sigma d mod_delta db_list local_db secvars concl)) end })) end [] in diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index a4243164ed..fe7a09f77d 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -279,9 +279,9 @@ let clenv_of_prods poly nprods (c, clenv) gl = let (c, _, _) = c in if poly || Int.equal nprods 0 then Some (None, clenv) else - let ty = Retyping.get_type_of (Proofview.Goal.env gl) - (Sigma.to_evar_map (Proofview.Goal.sigma gl)) c in - let diff = nb_prod ty - nprods in + let sigma = Tacmach.New.project gl in + let ty = Retyping.get_type_of (Proofview.Goal.env gl) sigma c in + let diff = nb_prod sigma (EConstr.of_constr ty) - nprods in if Pervasives.(>=) diff 0 then (* Was Some clenv... *) Some (Some diff, @@ -454,13 +454,13 @@ and e_my_find_search db_list local_db secvars hdc complete only_classes sigma co and e_trivial_resolve db_list local_db secvars only_classes sigma concl = try e_my_find_search db_list local_db secvars - (decompose_app_bound concl) true only_classes sigma concl + (decompose_app_bound sigma concl) true only_classes sigma concl with Bound | Not_found -> [] let e_possible_resolve db_list local_db secvars only_classes sigma concl = try e_my_find_search db_list local_db secvars - (decompose_app_bound concl) false only_classes sigma concl + (decompose_app_bound sigma concl) false only_classes sigma concl with Bound | Not_found -> [] let cut_of_hints h = @@ -666,7 +666,7 @@ module V85 = struct let needs_backtrack env evd oev concl = if Option.is_empty oev || is_Prop env evd concl then - occur_existential concl + occur_existential evd (EConstr.of_constr concl) else true let hints_tac hints sk fk {it = gl,info; sigma = s} = @@ -740,7 +740,7 @@ module V85 = struct let fk' = (fun e -> let do_backtrack = - if unique then occur_existential concl + if unique then occur_existential s' (EConstr.of_constr concl) else if info.unique then true else if List.is_empty gls' then needs_backtrack env s' info.is_evar concl @@ -975,7 +975,7 @@ module Search = struct NOT backtrack. *) let needs_backtrack env evd unique concl = if unique || is_Prop env evd concl then - occur_existential concl + occur_existential evd (EConstr.of_constr concl) else true let mark_unresolvables sigma goals = @@ -1486,16 +1486,17 @@ let _ = (** Take the head of the arity of a constr. Used in the partial application tactic. *) -let rec head_of_constr t = - let t = strip_outer_cast(collapse_appl t) in +let rec head_of_constr sigma t = + let t = strip_outer_cast sigma (EConstr.of_constr (collapse_appl sigma (EConstr.of_constr t))) in match kind_of_term t with - | Prod (_,_,c2) -> head_of_constr c2 - | LetIn (_,_,_,c2) -> head_of_constr c2 - | App (f,args) -> head_of_constr f + | Prod (_,_,c2) -> head_of_constr sigma c2 + | LetIn (_,_,_,c2) -> head_of_constr sigma c2 + | App (f,args) -> head_of_constr sigma f | _ -> t let head_of_constr h c = - let c = head_of_constr c in + Proofview.tclEVARMAP >>= fun sigma -> + let c = head_of_constr sigma c in letin_tac None (Name h) c None Locusops.allHyps let not_evar c = diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index 6b29f574cc..fcbad4bf0d 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -66,12 +66,12 @@ let contradiction_context = let id = NamedDecl.get_id d in let typ = nf_evar sigma (NamedDecl.get_type d) in let typ = whd_all env sigma typ in - if is_empty_type typ then + if is_empty_type sigma typ then simplest_elim (mkVar id) else match kind_of_term typ with - | Prod (na,t,u) when is_empty_type u -> + | Prod (na,t,u) when is_empty_type sigma u -> let is_unit_or_eq = - if use_negated_unit_or_eq_type () then match_with_unit_or_eq_type t + if use_negated_unit_or_eq_type () then match_with_unit_or_eq_type sigma t else None in Tacticals.New.tclORELSE (match is_unit_or_eq with @@ -105,7 +105,7 @@ let is_negation_of env sigma typ t = match kind_of_term (whd_all env sigma t) with | Prod (na,t,u) -> let u = nf_evar sigma u in - is_empty_type u && is_conv_leq env sigma typ t + is_empty_type sigma u && is_conv_leq env sigma typ t | _ -> false let contradiction_term (c,lbind as cl) = @@ -115,7 +115,7 @@ let contradiction_term (c,lbind as cl) = let type_of = Tacmach.New.pf_unsafe_type_of gl in let typ = type_of c in let _, ccl = splay_prod env sigma typ in - if is_empty_type ccl then + if is_empty_type sigma ccl then Tacticals.New.tclTHEN (elim false None cl None) (Tacticals.New.tclTRY assumption) diff --git a/tactics/eauto.ml b/tactics/eauto.ml index 10c975b8d8..6250fef2d6 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -32,7 +32,8 @@ let e_give_exact ?(flags=eauto_unif_flags) c = Proofview.Goal.enter { enter = begin fun gl -> let t1 = Tacmach.New.pf_unsafe_type_of gl c in let t2 = Tacmach.New.pf_concl (Proofview.Goal.assume gl) in - if occur_existential t1 || occur_existential t2 then + let sigma = Tacmach.New.project gl in + if occur_existential sigma (EConstr.of_constr t1) || occur_existential sigma (EConstr.of_constr t2) then Tacticals.New.tclTHEN (Clenvtac.unify ~flags t1) (exact_no_check c) else exact_check c end } @@ -123,7 +124,7 @@ let hintmap_of secvars hdc concl = match hdc with | None -> fun db -> Hint_db.map_none ~secvars db | Some hdc -> - if occur_existential concl then + if occur_existential Evd.empty (EConstr.of_constr concl) then (** FIXME *) (fun db -> Hint_db.map_existential ~secvars hdc concl db) else (fun db -> Hint_db.map_auto ~secvars hdc concl db) (* FIXME: should be (Hint_db.map_eauto hdc concl db) *) @@ -147,7 +148,7 @@ let rec e_trivial_fail_db db_list local_db = let tacl = registered_e_assumption :: (Tacticals.New.tclTHEN Tactics.intro next) :: - (List.map fst (e_trivial_resolve db_list local_db secvars (Tacmach.New.pf_nf_concl gl))) + (List.map fst (e_trivial_resolve (Tacmach.New.project gl) db_list local_db secvars (Tacmach.New.pf_nf_concl gl))) in Tacticals.New.tclFIRST (List.map Tacticals.New.tclCOMPLETE tacl) end } @@ -181,13 +182,13 @@ and e_my_find_search db_list local_db secvars hdc concl = in List.map tac_of_hint hintl -and e_trivial_resolve db_list local_db secvars gl = - let hd = try Some (decompose_app_bound gl) with Bound -> None in +and e_trivial_resolve sigma db_list local_db secvars gl = + let hd = try Some (decompose_app_bound sigma gl) with Bound -> None in try priority (e_my_find_search db_list local_db secvars hd gl) with Not_found -> [] -let e_possible_resolve db_list local_db secvars gl = - let hd = try Some (decompose_app_bound gl) with Bound -> None in +let e_possible_resolve sigma db_list local_db secvars gl = + let hd = try Some (decompose_app_bound sigma gl) with Bound -> None in try List.map (fun (b, (tac, pp)) -> (tac, b, pp)) (e_my_find_search db_list local_db secvars hd gl) with Not_found -> [] @@ -289,7 +290,7 @@ module SearchProblem = struct let l = let concl = Reductionops.nf_evar (project g)(pf_concl g) in filter_tactics s.tacres - (e_possible_resolve s.dblist (List.hd s.localdb) secvars concl) + (e_possible_resolve (project g) s.dblist (List.hd s.localdb) secvars concl) in List.map (fun (lgls, cost, pp) -> diff --git a/tactics/elim.ml b/tactics/elim.ml index 3f0c01a29c..12d8e98c43 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -79,11 +79,12 @@ let up_to_delta = ref false (* true *) let general_decompose recognizer c = Proofview.Goal.enter { enter = begin fun gl -> let type_of = pf_unsafe_type_of gl in + let sigma = project gl in let typc = type_of c in tclTHENS (cut typc) [ tclTHEN (intro_using tmphyp_name) (onLastHypId - (ifOnHyp recognizer (general_decompose_aux recognizer) + (ifOnHyp (recognizer sigma) (general_decompose_aux (recognizer sigma)) (fun id -> clear [id]))); exact_no_check c ] end } @@ -102,17 +103,17 @@ let head_in indl t gl = let decompose_these c l = Proofview.Goal.enter { enter = begin fun gl -> let indl = List.map (fun x -> x, Univ.Instance.empty) l in - general_decompose (fun (_,t) -> head_in indl t gl) c + general_decompose (fun sigma (_,t) -> head_in indl t gl) c end } let decompose_and c = general_decompose - (fun (_,t) -> is_record t) + (fun sigma (_,t) -> is_record sigma t) c let decompose_or c = general_decompose - (fun (_,t) -> is_disjunction t) + (fun sigma (_,t) -> is_disjunction sigma t) c let h_decompose l c = decompose_these c l @@ -133,7 +134,7 @@ let induction_trailer abs_i abs_j bargs = (fun id -> Proofview.Goal.nf_enter { enter = begin fun gl -> let idty = pf_unsafe_type_of gl (mkVar id) in - let fvty = global_vars (pf_env gl) idty in + let fvty = global_vars (pf_env gl) (project gl) (EConstr.of_constr idty) in let possible_bring_hyps = (List.tl (nLastDecls gl (abs_j - abs_i))) @ bargs.Tacticals.assums in diff --git a/tactics/equality.ml b/tactics/equality.ml index 7c819edadc..74f6dd44ae 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -405,7 +405,7 @@ let leibniz_rewrite_ebindings_clause cls lft2rgt tac c t l with_evars frzevars d let isatomic = isProd (whd_zeta evd hdcncl) in let dep_fun = if isatomic then dependent else dependent_no_evar in let type_of_cls = type_of_clause cls gl in - let dep = dep_proof_ok && dep_fun c type_of_cls in + let dep = dep_proof_ok && dep_fun evd (EConstr.of_constr c) (EConstr.of_constr type_of_cls) in let Sigma ((elim, effs), sigma, p) = find_elim hdcncl lft2rgt dep cls (Some t) gl in let tac = Proofview.tclEFFECTS effs <*> @@ -442,7 +442,7 @@ let general_rewrite_ebindings_clause cls lft2rgt occs frzevars dep_proof_ok ?tac let env = Proofview.Goal.env gl in let ctype = get_type_of env sigma c in let rels, t = decompose_prod_assum (whd_betaiotazeta sigma ctype) in - match match_with_equality_type t with + match match_with_equality_type sigma t with | Some (hdcncl,args) -> (* Fast path: direct leibniz-like rewrite *) let lft2rgt = adjust_rewriting_direction args lft2rgt in leibniz_rewrite_ebindings_clause cls lft2rgt tac c (it_mkProd_or_LetIn t rels) @@ -455,9 +455,10 @@ let general_rewrite_ebindings_clause cls lft2rgt occs frzevars dep_proof_ok ?tac end begin function | (e, info) -> + Proofview.tclEVARMAP >>= fun sigma -> let env' = push_rel_context rels env in let rels',t' = splay_prod_assum env' sigma t in (* Search for underlying eq *) - match match_with_equality_type t' with + match match_with_equality_type sigma t' with | Some (hdcncl,args) -> let lft2rgt = adjust_rewriting_direction args lft2rgt in leibniz_rewrite_ebindings_clause cls lft2rgt tac c @@ -932,9 +933,10 @@ let rec build_discriminator env sigma dirn c = function let gen_absurdity id = Proofview.Goal.enter { enter = begin fun gl -> + let sigma = project gl in let hyp_typ = pf_get_hyp_typ id (Proofview.Goal.assume gl) in let hyp_typ = pf_nf_evar gl hyp_typ in - if is_empty_type hyp_typ + if is_empty_type sigma hyp_typ then simplest_elim (mkVar id) else @@ -973,7 +975,7 @@ let apply_on_clause (f,t) clause = let sigma = clause.evd in let f_clause = mk_clenv_from_env clause.env sigma None (f,t) in let argmv = - (match kind_of_term (last_arg f_clause.templval.Evd.rebus) with + (match kind_of_term (last_arg f_clause.evd (EConstr.of_constr f_clause.templval.Evd.rebus)) with | Meta mv -> mv | _ -> user_err (str "Ill-formed clause applicator.")) in clenv_fchain ~with_univs:false argmv f_clause clause @@ -1025,7 +1027,7 @@ let onNegatedEquality with_evars tac = let ccl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in match kind_of_term (hnf_constr env sigma ccl) with - | Prod (_,t,u) when is_empty_type u -> + | Prod (_,t,u) when is_empty_type sigma u -> tclTHEN introf (onLastHypId (fun id -> onEquality with_evars tac (mkVar id,NoBindings))) @@ -1079,7 +1081,7 @@ let find_sigma_data env s = build_sigma_type () *) let make_tuple env sigma (rterm,rty) lind = - assert (dependent (mkRel lind) rty); + assert (not (EConstr.Vars.noccurn sigma lind (EConstr.of_constr rty))); let sigdata = find_sigma_data env (get_sort_of env sigma rty) in let sigma, a = type_of ~refresh:true env sigma (mkRel lind) in let na = Context.Rel.Declaration.get_name (lookup_rel lind env) in @@ -1101,9 +1103,9 @@ let make_tuple env sigma (rterm,rty) lind = normalization *) let minimal_free_rels env sigma (c,cty) = - let cty_rels = free_rels cty in + let cty_rels = free_rels sigma (EConstr.of_constr cty) in let cty' = simpl env sigma cty in - let rels' = free_rels cty' in + let rels' = free_rels sigma (EConstr.of_constr cty') in if Int.Set.subset cty_rels rels' then (cty,cty_rels) else @@ -1302,6 +1304,7 @@ let set_eq_dec_scheme_kind k = eq_dec_scheme_kind_name := (fun _ -> k) let inject_if_homogenous_dependent_pair ty = Proofview.Goal.nf_enter { enter = begin fun gl -> try + 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 @@ -1310,8 +1313,8 @@ let inject_if_homogenous_dependent_pair ty = (* check whether the equality deals with dep pairs or not *) let eqTypeDest = fst (decompose_app t) in if not (Globnames.is_global (sigTconstr()) eqTypeDest) then raise Exit; - let hd1,ar1 = decompose_app_vect t1 and - hd2,ar2 = decompose_app_vect t2 in + let hd1,ar1 = decompose_app_vect sigma (EConstr.of_constr t1) and + hd2,ar2 = decompose_app_vect sigma (EConstr.of_constr t2) in if not (Globnames.is_global (existTconstr()) hd1) then raise Exit; if not (Globnames.is_global (existTconstr()) hd2) then raise Exit; let ind,_ = try pf_apply find_mrectype gl ar1.(0) with Not_found -> raise Exit in @@ -1543,7 +1546,7 @@ let subst_tuple_term env sigma dep_pair1 dep_pair2 b = (* We build the expected goal *) let abst_B = List.fold_right - (fun (e,t) body -> lambda_create env (t,subst_term e body)) e1_list b in + (fun (e,t) body -> lambda_create env (t,subst_term sigma (EConstr.of_constr e) (EConstr.of_constr body))) e1_list b in let pred_body = beta_applist(abst_B,proj_list) in let body = mkApp (lambda_create env (typ,pred_body),[|dep_pair1|]) in let expected_goal = beta_applist (abst_B,List.map fst e2_list) in @@ -1674,8 +1677,8 @@ let is_eq_x gl x d = in let c = pf_nf_evar gl (NamedDecl.get_type d) in let (_,lhs,rhs) = pi3 (find_eq_data_decompose gl c) in - if (is_var x lhs) && not (local_occur_var x rhs) then raise (FoundHyp (id,rhs,true)); - if (is_var x rhs) && not (local_occur_var x lhs) then raise (FoundHyp (id,lhs,false)) + if (is_var x lhs) && not (local_occur_var (project gl) x (EConstr.of_constr rhs)) then raise (FoundHyp (id,rhs,true)); + if (is_var x rhs) && not (local_occur_var (project gl) x (EConstr.of_constr lhs)) then raise (FoundHyp (id,lhs,false)) with Constr_matching.PatternMatchingFailure -> () @@ -1685,6 +1688,7 @@ let is_eq_x gl x d = let subst_one dep_proof_ok x (hyp,rhs,dir) = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in (* The set of hypotheses using x *) @@ -1692,7 +1696,7 @@ let subst_one dep_proof_ok x (hyp,rhs,dir) = List.rev (pi3 (List.fold_right (fun dcl (dest,deps,allhyps) -> let id = NamedDecl.get_id dcl in if not (Id.equal id hyp) - && List.exists (fun y -> occur_var_in_decl env y dcl) deps + && List.exists (fun y -> occur_var_in_decl env sigma y dcl) deps then let id_dest = if !regular_subst_tactic then dest else MoveLast in (dest,id::deps,(id_dest,id)::allhyps) @@ -1701,7 +1705,7 @@ let subst_one dep_proof_ok x (hyp,rhs,dir) = hyps (MoveBefore x,[x],[]))) in (* In practice, no dep hyps before x, so MoveBefore x is good enough *) (* Decides if x appears in conclusion *) - let depconcl = occur_var env x concl in + let depconcl = occur_var env sigma x (EConstr.of_constr concl) in let need_rewrite = not (List.is_empty dephyps) || depconcl in tclTHENLIST ((if need_rewrite then @@ -1787,6 +1791,7 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () = let process hyp = Proofview.Goal.enter { enter = begin fun gl -> let gl = Proofview.Goal.assume gl in + let sigma = project gl in let env = Proofview.Goal.env gl in let find_eq_data_decompose = find_eq_data_decompose gl in let c = pf_get_hyp hyp gl |> NamedDecl.get_type in @@ -1794,9 +1799,9 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () = (* J.F.: added to prevent failure on goal containing x=x as an hyp *) if Term.eq_constr x y then Proofview.tclUNIT () else match kind_of_term x, kind_of_term y with - | Var x', _ when not (occur_term x y) && not (is_evaluable env (EvalVarRef x')) -> + | Var x', _ when not (occur_term sigma (EConstr.of_constr x) (EConstr.of_constr y)) && not (is_evaluable env (EvalVarRef x')) -> subst_one flags.rewrite_dependent_proof x' (hyp,y,true) - | _, Var y' when not (occur_term y x) && not (is_evaluable env (EvalVarRef y')) -> + | _, Var y' when not (occur_term sigma (EConstr.of_constr y) (EConstr.of_constr 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 9fa49264fe..55bf5f29ea 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -45,8 +45,8 @@ type debug = Debug | Info | Off exception Bound -let head_constr_bound t = - let t = strip_outer_cast t in +let head_constr_bound sigma t = + let t = strip_outer_cast sigma (EConstr.of_constr t) in let _,ccl = decompose_prod_assum t in let hd,args = decompose_app ccl in match kind_of_term hd with @@ -54,13 +54,13 @@ let head_constr_bound t = | Proj (p, _) -> mkConst (Projection.constant p) | _ -> raise Bound -let head_constr c = - try head_constr_bound c with Bound -> error "Bound head variable." +let head_constr sigma c = + try head_constr_bound sigma c with Bound -> error "Bound head variable." -let decompose_app_bound t = - let t = strip_outer_cast t in +let decompose_app_bound sigma t = + let t = strip_outer_cast sigma (EConstr.of_constr t) in let _,ccl = decompose_prod_assum t in - let hd,args = decompose_app_vect ccl in + let hd,args = decompose_app_vect sigma (EConstr.of_constr ccl) in match kind_of_term hd with | Const (c,u) -> ConstRef c, args | Ind (i,u) -> IndRef i, args @@ -505,7 +505,7 @@ struct let match_mode m arg = match m with - | ModeInput -> not (occur_existential arg) + | ModeInput -> not (occur_existential Evd.empty (EConstr.of_constr arg)) (** FIXME *) | ModeNoHeadEvar -> Evarutil.(try ignore(head_evar arg); false with NoHeadEvar -> true) @@ -742,7 +742,7 @@ let secvars_of_global env gr = let make_exact_entry env sigma pri poly ?(name=PathAny) (c, cty, ctx) = let secvars = secvars_of_constr env c in - let cty = strip_outer_cast cty in + let cty = strip_outer_cast sigma (EConstr.of_constr cty) in match kind_of_term cty with | Prod _ -> failwith "make_exact_entry" | _ -> @@ -911,7 +911,7 @@ let make_trivial env sigma poly ?(name=PathAny) r = let c,ctx = fresh_global_or_constr env sigma poly r in let sigma = Evd.merge_context_set univ_flexible sigma ctx in let t = hnf_constr env sigma (unsafe_type_of env sigma c) in - let hd = head_of_constr_reference (head_constr t) in + let hd = head_of_constr_reference (head_constr sigma t) in let ce = mk_clenv_from_env env sigma None (c,t) in (Some hd, { pri=1; poly = poly; @@ -1013,7 +1013,7 @@ let subst_autohint (subst, obj) = let subst_key gr = let (lab'', elab') = subst_global subst gr in let gr' = - (try head_of_constr_reference (head_constr_bound elab') + (try head_of_constr_reference (head_constr_bound Evd.empty (** FIXME *) elab') with Bound -> lab'') in if gr' == gr then gr else gr' in @@ -1190,17 +1190,17 @@ let prepare_hint check (poly,local) env init (sigma,c) = thing make_resolves will do is to re-instantiate the products *) let sigma, subst = Evd.nf_univ_variables sigma in let c = Vars.subst_univs_constr subst (Evarutil.nf_evar sigma c) in - let c = drop_extra_implicit_args c in - let vars = ref (collect_vars c) in + let c = drop_extra_implicit_args sigma (EConstr.of_constr c) in + let vars = ref (collect_vars sigma (EConstr.of_constr c)) in let subst = ref [] in let rec find_next_evar c = match kind_of_term c with | Evar (evk,args as ev) -> (* We skip the test whether args is the identity or not *) let t = Evarutil.nf_evar sigma (existential_type sigma ev) in - let t = List.fold_right (fun (e,id) c -> replace_term e id c) !subst t in + let t = List.fold_right (fun (e,id) c -> replace_term sigma (EConstr.of_constr e) (EConstr.of_constr id) (EConstr.of_constr c)) !subst t in if not (closed0 c) then error "Hints with holes dependent on a bound variable not supported."; - if occur_existential t then + if occur_existential sigma (EConstr.of_constr t) then (* Not clever enough to construct dependency graph of evars *) error "Not clever enough to deal with evars dependent in other evars."; raise (Found (c,t)) @@ -1211,7 +1211,7 @@ let prepare_hint check (poly,local) env init (sigma,c) = let id = next_ident_away_from default_prepare_hint_ident (fun id -> Id.Set.mem id !vars) in vars := Id.Set.add id !vars; subst := (evar,mkVar id)::!subst; - mkNamedLambda id t (iter (replace_term evar (mkVar id) c)) in + mkNamedLambda id t (iter (replace_term sigma (EConstr.of_constr evar) (EConstr.mkVar id) (EConstr.of_constr c))) in let c' = iter c in if check then Pretyping.check_evars (Global.env()) Evd.empty sigma c'; let diff = Univ.ContextSet.diff (Evd.universe_context_set sigma) (Evd.universe_context_set init) in @@ -1394,13 +1394,13 @@ let pr_hint_ref ref = pr_hint_list_for_head ref (* Print all hints associated to head id in any database *) -let pr_hint_term cl = +let pr_hint_term sigma cl = try let dbs = current_db () in let valid_dbs = let fn = try - let hdc = decompose_app_bound cl in - if occur_existential cl then + let hdc = decompose_app_bound sigma cl in + if occur_existential sigma (EConstr.of_constr cl) then Hint_db.map_existential ~secvars:Id.Pred.full hdc cl else Hint_db.map_auto ~secvars:Id.Pred.full hdc cl with Bound -> Hint_db.map_none ~secvars:Id.Pred.full @@ -1423,7 +1423,7 @@ let pr_applicable_hint () = match glss.Evd.it with | [] -> CErrors.error "No focused goal." | g::_ -> - pr_hint_term (Goal.V82.concl glss.Evd.sigma g) + pr_hint_term glss.Evd.sigma (Goal.V82.concl glss.Evd.sigma g) let pp_hint_mode = function | ModeInput -> str"+" diff --git a/tactics/hints.mli b/tactics/hints.mli index edc65c4070..c0eb2c3b86 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -24,7 +24,7 @@ open Vernacexpr exception Bound -val decompose_app_bound : constr -> global_reference * constr array +val decompose_app_bound : evar_map -> constr -> global_reference * constr array type debug = Debug | Info | Off diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml index 27af7200bd..847ecf4b0e 100644 --- a/tactics/hipattern.ml +++ b/tactics/hipattern.ml @@ -31,9 +31,9 @@ module RelDecl = Context.Rel.Declaration -- Eduardo (6/8/97). *) -type 'a matching_function = constr -> 'a option +type 'a matching_function = Evd.evar_map -> constr -> 'a option -type testing_function = constr -> bool +type testing_function = Evd.evar_map -> constr -> bool let mkmeta n = Nameops.make_ident "X" (Some n) let meta1 = mkmeta 1 @@ -43,7 +43,7 @@ let meta4 = mkmeta 4 let op2bool = function Some _ -> true | None -> false -let match_with_non_recursive_type t = +let match_with_non_recursive_type sigma t = match kind_of_term t with | App _ -> let (hdapp,args) = decompose_app t in @@ -56,21 +56,21 @@ let match_with_non_recursive_type t = | _ -> None) | _ -> None -let is_non_recursive_type t = op2bool (match_with_non_recursive_type t) +let is_non_recursive_type sigma t = op2bool (match_with_non_recursive_type sigma t) (* Test dependencies *) (* NB: we consider also the let-in case in the following function, since they may appear in types of inductive constructors (see #2629) *) -let rec has_nodep_prod_after n c = +let rec has_nodep_prod_after n sigma c = match kind_of_term c with | Prod (_,_,b) | LetIn (_,_,_,b) -> - ( n>0 || not (dependent (mkRel 1) b)) - && (has_nodep_prod_after (n-1) b) + ( n>0 || EConstr.Vars.noccurn sigma 1 (EConstr.of_constr b)) + && (has_nodep_prod_after (n-1) sigma b) | _ -> true -let has_nodep_prod = has_nodep_prod_after 0 +let has_nodep_prod sigma c = has_nodep_prod_after 0 sigma c (* A general conjunctive type is a non-recursive with-no-indices inductive type with only one constructor and no dependencies between argument; @@ -87,7 +87,7 @@ let is_lax_conjunction = function | Some false -> true | _ -> false -let match_with_one_constructor style onlybinary allow_rec t = +let match_with_one_constructor sigma style onlybinary allow_rec t = let (hdapp,args) = decompose_app t in let res = match kind_of_term hdapp with | Ind ind -> @@ -112,7 +112,7 @@ let match_with_one_constructor style onlybinary allow_rec t = else let ctyp = prod_applist mip.mind_nf_lc.(0) args in let cargs = List.map RelDecl.get_type (prod_assum ctyp) in - if not (is_lax_conjunction style) || has_nodep_prod ctyp then + if not (is_lax_conjunction style) || has_nodep_prod sigma ctyp then (* Record or non strict conjunction *) Some (hdapp,List.rev cargs) else @@ -125,28 +125,28 @@ let match_with_one_constructor style onlybinary allow_rec t = | Some (hdapp, [_; _]) -> res | _ -> None -let match_with_conjunction ?(strict=false) ?(onlybinary=false) t = - match_with_one_constructor (Some strict) onlybinary false t +let match_with_conjunction ?(strict=false) ?(onlybinary=false) sigma t = + match_with_one_constructor sigma (Some strict) onlybinary false t -let match_with_record t = - match_with_one_constructor None false false t +let match_with_record sigma t = + match_with_one_constructor sigma None false false t -let is_conjunction ?(strict=false) ?(onlybinary=false) t = - op2bool (match_with_conjunction ~strict ~onlybinary t) +let is_conjunction ?(strict=false) ?(onlybinary=false) sigma t = + op2bool (match_with_conjunction sigma ~strict ~onlybinary t) -let is_record t = - op2bool (match_with_record t) +let is_record sigma t = + op2bool (match_with_record sigma t) -let match_with_tuple t = - let t = match_with_one_constructor None false true t in +let match_with_tuple sigma t = + let t = match_with_one_constructor sigma None false true t in Option.map (fun (hd,l) -> let ind = destInd hd in let (mib,mip) = Global.lookup_pinductive ind in let isrec = mis_is_recursive (fst ind,mib,mip) in (hd,l,isrec)) t -let is_tuple t = - op2bool (match_with_tuple t) +let is_tuple sigma t = + op2bool (match_with_tuple sigma t) (* A general disjunction type is a non-recursive with-no-indices inductive type with of which all constructors have a single argument; @@ -159,7 +159,7 @@ let test_strict_disjunction n lc = | [LocalAssum (_,c)] -> isRel c && Int.equal (destRel c) (n - i) | _ -> false) 0 lc -let match_with_disjunction ?(strict=false) ?(onlybinary=false) t = +let match_with_disjunction ?(strict=false) ?(onlybinary=false) sigma t = let (hdapp,args) = decompose_app t in let res = match kind_of_term hdapp with | Ind (ind,u) -> @@ -187,13 +187,13 @@ let match_with_disjunction ?(strict=false) ?(onlybinary=false) t = | Some (hdapp,[_; _]) -> res | _ -> None -let is_disjunction ?(strict=false) ?(onlybinary=false) t = - op2bool (match_with_disjunction ~strict ~onlybinary t) +let is_disjunction ?(strict=false) ?(onlybinary=false) sigma t = + op2bool (match_with_disjunction ~strict ~onlybinary sigma t) (* An empty type is an inductive type, possible with indices, that has no constructors *) -let match_with_empty_type t = +let match_with_empty_type sigma t = let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with | Ind ind -> @@ -202,33 +202,33 @@ let match_with_empty_type t = if Int.equal nconstr 0 then Some hdapp else None | _ -> None -let is_empty_type t = op2bool (match_with_empty_type t) +let is_empty_type sigma t = op2bool (match_with_empty_type sigma t) (* This filters inductive types with one constructor with no arguments; Parameters and indices are allowed *) -let match_with_unit_or_eq_type t = +let match_with_unit_or_eq_type sigma t = let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with | Ind ind -> let (mib,mip) = Global.lookup_pinductive ind in let constr_types = mip.mind_nf_lc in let nconstr = Array.length mip.mind_consnames in - let zero_args c = Int.equal (nb_prod c) mib.mind_nparams in + let zero_args c = Int.equal (nb_prod sigma (EConstr.of_constr c)) mib.mind_nparams in if Int.equal nconstr 1 && zero_args constr_types.(0) then Some hdapp else None | _ -> None -let is_unit_or_eq_type t = op2bool (match_with_unit_or_eq_type t) +let is_unit_or_eq_type sigma t = op2bool (match_with_unit_or_eq_type sigma t) (* A unit type is an inductive type with no indices but possibly (useless) parameters, and that has no arguments in its unique constructor *) -let is_unit_type t = - match match_with_conjunction t with +let is_unit_type sigma t = + match match_with_conjunction sigma t with | Some (_,[]) -> true | _ -> false @@ -318,13 +318,13 @@ let is_inductive_equality ind = let nconstr = Array.length mip.mind_consnames in Int.equal nconstr 1 && Int.equal (constructor_nrealargs (ind,1)) 0 -let match_with_equality_type t = +let match_with_equality_type sigma t = let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with | Ind (ind,_) when is_inductive_equality ind -> Some (hdapp,args) | _ -> None -let is_equality_type t = op2bool (match_with_equality_type t) +let is_equality_type sigma t = op2bool (match_with_equality_type sigma t) (* Arrows/Implication/Negation *) @@ -338,37 +338,37 @@ let match_arrow_pattern t = assert (Id.equal m1 meta1 && Id.equal m2 meta2); (arg, mind) | _ -> anomaly (Pp.str "Incorrect pattern matching") -let match_with_imp_term c= +let match_with_imp_term sigma c = match kind_of_term c with - | Prod (_,a,b) when not (dependent (mkRel 1) b) ->Some (a,b) + | Prod (_,a,b) when EConstr.Vars.noccurn sigma 1 (EConstr.of_constr b) -> Some (a,b) | _ -> None -let is_imp_term c = op2bool (match_with_imp_term c) +let is_imp_term sigma c = op2bool (match_with_imp_term sigma c) -let match_with_nottype t = +let match_with_nottype sigma t = try let (arg,mind) = match_arrow_pattern t in - if is_empty_type mind then Some (mind,arg) else None + if is_empty_type sigma mind then Some (mind,arg) else None with PatternMatchingFailure -> None -let is_nottype t = op2bool (match_with_nottype t) +let is_nottype sigma t = op2bool (match_with_nottype sigma t) (* Forall *) -let match_with_forall_term c= +let match_with_forall_term sigma c= match kind_of_term c with | Prod (nam,a,b) -> Some (nam,a,b) | _ -> None -let is_forall_term c = op2bool (match_with_forall_term c) +let is_forall_term sigma c = op2bool (match_with_forall_term sigma c) -let match_with_nodep_ind t = +let match_with_nodep_ind sigma t = let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with | Ind ind -> let (mib,mip) = Global.lookup_pinductive ind in if Array.length (mib.mind_packets)>1 then None else - let nodep_constr = has_nodep_prod_after mib.mind_nparams in + let nodep_constr = has_nodep_prod_after mib.mind_nparams sigma in if Array.for_all nodep_constr mip.mind_nf_lc then let params= if Int.equal mip.mind_nrealargs 0 then args else @@ -378,9 +378,9 @@ let match_with_nodep_ind t = None | _ -> None -let is_nodep_ind t=op2bool (match_with_nodep_ind t) +let is_nodep_ind sigma t = op2bool (match_with_nodep_ind sigma t) -let match_with_sigma_type t= +let match_with_sigma_type sigma t = let (hdapp,args) = decompose_app t in match (kind_of_term hdapp) with | Ind ind -> @@ -388,14 +388,14 @@ let match_with_sigma_type t= if Int.equal (Array.length (mib.mind_packets)) 1 && (Int.equal mip.mind_nrealargs 0) && (Int.equal (Array.length mip.mind_consnames)1) && - has_nodep_prod_after (mib.mind_nparams+1) mip.mind_nf_lc.(0) then + has_nodep_prod_after (mib.mind_nparams+1) sigma mip.mind_nf_lc.(0) then (*allowing only 1 existential*) Some (hdapp,args) else None | _ -> None -let is_sigma_type t=op2bool (match_with_sigma_type t) +let is_sigma_type sigma t = op2bool (match_with_sigma_type sigma t) (***** Destructing patterns bound to some theory *) diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli index 7cc41f1b93..8a453bf31f 100644 --- a/tactics/hipattern.mli +++ b/tactics/hipattern.mli @@ -40,8 +40,8 @@ open Coqlib also work on ad-hoc disjunctions introduced by the user. (Eduardo, 6/8/97). *) -type 'a matching_function = constr -> 'a option -type testing_function = constr -> bool +type 'a matching_function = Evd.evar_map -> constr -> 'a option +type testing_function = Evd.evar_map -> constr -> bool val match_with_non_recursive_type : (constr * constr list) matching_function val is_non_recursive_type : testing_function diff --git a/tactics/inv.ml b/tactics/inv.ml index e7d8249e43..d1d6178da2 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -32,8 +32,9 @@ module NamedDecl = Context.Named.Declaration let var_occurs_in_pf gl id = let env = Proofview.Goal.env gl in - occur_var env id (Proofview.Goal.concl gl) || - List.exists (occur_var_in_decl env id) (Proofview.Goal.hyps gl) + let sigma = project gl in + occur_var env sigma id (EConstr.of_constr (Proofview.Goal.concl gl)) || + List.exists (occur_var_in_decl env sigma id) (Proofview.Goal.hyps gl) (* [make_inv_predicate (ity,args) C] @@ -75,7 +76,7 @@ let make_inv_predicate env evd indf realargs id status concl = let hyps_arity,_ = get_arity env indf in (hyps_arity,concl) | Dep dflt_concl -> - if not (occur_var env id concl) then + if not (occur_var env !evd id (EConstr.of_constr concl)) then user_err ~hdr:"make_inv_predicate" (str "Current goal does not depend on " ++ pr_id id ++ str"."); (* We abstract the conclusion of goal with respect to @@ -183,7 +184,7 @@ let dependent_hyps env id idlist gl = | d::l -> (* Update the type of id1: it may have been subject to rewriting *) let d = pf_get_hyp (NamedDecl.get_id d) gl in - if occur_var_in_decl env id d + if occur_var_in_decl env (project gl) id d then d :: dep_rec l else dep_rec l in @@ -448,7 +449,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 c concl) then + if status != NoDep && (dependent sigma (EConstr.of_constr c) (EConstr.of_constr concl)) then Reduction.beta_appvect elim_predicate (Array.of_list (realargs@[c])), case_then_using else @@ -514,12 +515,14 @@ let invIn k names ids id = Proofview.Goal.nf_enter { enter = begin fun gl -> let hyps = List.map (fun id -> pf_get_hyp id gl) ids in let concl = Proofview.Goal.concl gl in - let nb_prod_init = nb_prod concl in + let sigma = project gl in + let nb_prod_init = nb_prod sigma (EConstr.of_constr concl) in let intros_replace_ids = Proofview.Goal.enter { enter = begin fun gl -> let concl = pf_nf_concl gl in + let sigma = project gl in let nb_of_new_hyp = - nb_prod concl - (List.length hyps + nb_prod_init) + nb_prod sigma (EConstr.of_constr concl) - (List.length hyps + nb_prod_init) in if nb_of_new_hyp < 1 then intros_replacing ids diff --git a/tactics/leminv.ml b/tactics/leminv.ml index 10fc5076c2..46f1f7c8d0 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -154,7 +154,7 @@ let compute_first_inversion_scheme env sigma ind sort dep_option = pty,goal else let i = mkAppliedInd ind in - let ivars = global_vars env i in + let ivars = global_vars env sigma (EConstr.of_constr i) in let revargs,ownsign = fold_named_context (fun env d (revargs,hyps) -> @@ -192,7 +192,7 @@ let inversion_scheme env sigma t sort dep_option inv_op = in assert (List.subset - (global_vars env invGoal) + (global_vars env sigma (EConstr.of_constr invGoal)) (ids_of_named_context (named_context invEnv))); (* user_err ~hdr:"lemma_inversion" @@ -277,7 +277,8 @@ let lemInvIn id c ids = let hyps = List.map (fun id -> pf_get_hyp id gl) ids in let intros_replace_ids = let concl = Proofview.Goal.concl gl in - let nb_of_new_hyp = nb_prod concl - List.length ids in + let sigma = project gl in + let nb_of_new_hyp = nb_prod sigma (EConstr.of_constr concl) - List.length ids in if nb_of_new_hyp < 1 then intros_replacing ids else diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index 93c04e373c..676b23d095 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -630,7 +630,7 @@ module New = struct (* applying elimination_scheme just a little modified *) let elimclause = Tacmach.New.of_old (fun gls -> mk_clenv_from gls (elim,Tacmach.New.pf_unsafe_type_of gl elim)) gl in let indmv = - match kind_of_term (last_arg elimclause.templval.Evd.rebus) with + match kind_of_term (last_arg elimclause.evd (EConstr.of_constr elimclause.templval.Evd.rebus)) with | Meta mv -> mv | _ -> anomaly (str"elimination") in diff --git a/tactics/tactics.ml b/tactics/tactics.ml index e17bbfcb06..15dd1a97ce 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -323,10 +323,11 @@ let apply_clear_request clear_flag dft c = let move_hyp id dest = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in let ty = Proofview.Goal.raw_concl gl in let store = Proofview.Goal.extra gl in let sign = named_context_val env in - let sign' = move_hyp_in_named_context id dest sign in + let sign' = move_hyp_in_named_context sigma id dest sign in let env = reset_with_named_context sign' env in Refine.refine ~unsafe:true { run = begin fun sigma -> Evarutil.new_evar env sigma ~principal:true ~store ty @@ -497,7 +498,7 @@ fun env sigma p -> function let Sigma (rem, sigma, r) = mk_holes env sigma (p +> q) rem in Sigma (arg :: rem, sigma, r) -let rec check_mutind env sigma k cl = match kind_of_term (strip_outer_cast cl) with +let rec check_mutind env sigma k cl = match kind_of_term (strip_outer_cast sigma (EConstr.of_constr cl)) with | Prod (na, c1, b) -> if Int.equal k 1 then try @@ -936,13 +937,14 @@ let build_intro_tac id dest tac = match dest with let rec intro_then_gen name_flag move_flag force_flag dep_flag tac = let open Context.Rel.Declaration in Proofview.Goal.enter { enter = begin fun gl -> + let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in let concl = nf_evar (Tacmach.New.project gl) concl in match kind_of_term concl with - | Prod (name,t,u) when not dep_flag || (dependent (mkRel 1) u) -> + | Prod (name,t,u) when not dep_flag || not (EConstr.Vars.noccurn sigma 1 (EConstr.of_constr u)) -> let name = find_name false (LocalAssum (name,t)) name_flag gl in build_intro_tac name move_flag tac - | LetIn (name,b,t,u) when not dep_flag || (dependent (mkRel 1) u) -> + | LetIn (name,b,t,u) when not dep_flag || not (EConstr.Vars.noccurn sigma 1 (EConstr.of_constr u)) -> let name = find_name false (LocalDef (name,b,t)) name_flag gl in build_intro_tac name move_flag tac | _ -> @@ -1285,7 +1287,7 @@ let clenv_refine_in ?(sidecond_first=false) with_evars ?(with_classes=true) in let new_hyp_typ = clenv_type clenv in if not with_evars then check_unresolved_evars_of_metas sigma0 clenv; - if not with_evars && occur_meta new_hyp_typ then + if not with_evars && occur_meta clenv.evd (EConstr.of_constr new_hyp_typ) then error_uninstantiated_metas new_hyp_typ clenv; let new_hyp_prf = clenv_value clenv in let exact_tac = Proofview.V82.tactic (Tacmach.refine_no_check new_hyp_prf) in @@ -1440,7 +1442,7 @@ let general_case_analysis_in_context with_evars clear_flag (c,lbindc) = let (mind,_) = reduce_to_quantified_ind env (Sigma.to_evar_map sigma) t in let sort = Tacticals.New.elimination_sort_of_goal gl in let Sigma (elim, sigma, p) = - if occur_term c concl then + if occur_term (Sigma.to_evar_map sigma) (EConstr.of_constr c) (EConstr.of_constr concl) then build_case_analysis_scheme env sigma mind true sort else build_case_analysis_scheme_default env sigma mind sort in @@ -1624,7 +1626,7 @@ let descend_in_conjunctions avoid tac (err, info) c = let t = Retyping.get_type_of env sigma c in let ((ind,u),t) = reduce_to_quantified_ind env sigma t in let sign,ccl = decompose_prod_assum t in - match match_with_tuple ccl with + match match_with_tuple sigma ccl with | Some (_,_,isrec) -> let n = (constructors_nrealargs ind).(0) in let sort = Tacticals.New.elimination_sort_of_goal gl in @@ -1689,12 +1691,13 @@ let tclORELSEOPT t k = let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind)) = Proofview.Goal.nf_enter { 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. *) - let concl_nprod = nb_prod_modulo_zeta concl in + let concl_nprod = nb_prod_modulo_zeta sigma (EConstr.of_constr concl) in let rec try_main_apply with_destruct c = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in @@ -1703,7 +1706,7 @@ let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind)) let thm_ty0 = nf_betaiota sigma (Retyping.get_type_of env sigma c) in let try_apply thm_ty nprod = try - let n = nb_prod_modulo_zeta thm_ty - nprod in + let n = nb_prod_modulo_zeta sigma (EConstr.of_constr thm_ty) - nprod in if n<0 then error "Applied theorem has not enough premisses."; let clause = make_clenv_binding_apply env sigma (Some n) (c,thm_ty) lbind in Clenvtac.res_pf clause ~with_evars ~flags @@ -1901,8 +1904,9 @@ let apply_in_delayed_once sidecond_first with_delta with_destruct with_evars nam let cut_and_apply c = Proofview.Goal.nf_enter { enter = begin fun gl -> + let sigma = Tacmach.New.project gl in match kind_of_term (Tacmach.New.pf_hnf_constr gl (Tacmach.New.pf_unsafe_type_of gl c)) with - | Prod (_,c1,c2) when not (dependent (mkRel 1) c2) -> + | Prod (_,c1,c2) when EConstr.Vars.noccurn sigma 1 (EConstr.of_constr c2) -> let concl = Proofview.Goal.concl gl in let env = Tacmach.New.pf_env gl in Refine.refine { run = begin fun sigma -> @@ -2049,7 +2053,7 @@ let clear_body ids = (** Do no recheck hypotheses that do not depend *) let sigma = if not seen then sigma - else if List.exists (fun id -> occur_var_in_decl env id decl) ids then + else if List.exists (fun id -> occur_var_in_decl env sigma id decl) ids then check_decl env sigma decl else sigma in @@ -2058,7 +2062,7 @@ let clear_body ids = in let (env, sigma, _) = List.fold_left check (base_env, sigma, false) (List.rev ctx) in let sigma = - if List.exists (fun id -> occur_var env id concl) ids then + if List.exists (fun id -> occur_var env sigma id (EConstr.of_constr concl)) ids then check_is_type env sigma concl else sigma in @@ -2096,12 +2100,13 @@ let keep hyps = Proofview.Goal.nf_enter { enter = begin fun gl -> Proofview.tclENV >>= fun env -> let ccl = Proofview.Goal.concl gl in + let sigma = Tacmach.New.project gl in let cl,_ = fold_named_context_reverse (fun (clear,keep) decl -> let hyp = NamedDecl.get_id decl in if Id.List.mem hyp hyps - || List.exists (occur_var_in_decl env hyp) keep - || occur_var env hyp ccl + || List.exists (occur_var_in_decl env sigma hyp) keep + || occur_var env sigma hyp (EConstr.of_constr ccl) then (clear,decl::keep) else (hyp::clear,keep)) ~init:([],[]) (Proofview.Goal.env gl) @@ -2310,15 +2315,16 @@ let rewrite_hyp_then assert_style with_evars thin l2r id tac = List.filter (fun (_,id) -> not (Id.equal id id')) thin in Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in let type_of = Tacmach.New.pf_unsafe_type_of gl in let whd_all = Tacmach.New.pf_apply whd_all gl in let t = whd_all (type_of (mkVar id)) in - let eqtac, thin = match match_with_equality_type t with + let eqtac, thin = match match_with_equality_type sigma t with | Some (hdcncl,[_;lhs;rhs]) -> - if l2r && isVar lhs && not (occur_var env (destVar lhs) rhs) then + if l2r && isVar lhs && not (occur_var env sigma (destVar lhs) (EConstr.of_constr rhs)) then let id' = destVar lhs in subst_on l2r id' rhs, early_clear id' thin - else if not l2r && isVar rhs && not (occur_var env (destVar rhs) lhs) then + else if not l2r && isVar rhs && not (occur_var env sigma (destVar rhs) (EConstr.of_constr lhs)) then let id' = destVar rhs in subst_on l2r id' lhs, early_clear id' thin else @@ -2763,8 +2769,8 @@ let generalized_name c t ids cl = function let generalize_goal_gen env sigma ids i ((occs,c,b),na) t cl = let open Context.Rel.Declaration in let decls,cl = decompose_prod_n_assum i cl in - let dummy_prod = it_mkProd_or_LetIn mkProp decls in - let newdecls,_ = decompose_prod_n_assum i (subst_term_gen eq_constr_nounivs c dummy_prod) in + let dummy_prod = EConstr.of_constr (it_mkProd_or_LetIn mkProp decls) in + let newdecls,_ = decompose_prod_n_assum i (subst_term_gen sigma EConstr.eq_constr_nounivs (EConstr.of_constr c) dummy_prod) in let cl',sigma' = subst_closed_term_occ env sigma (AtOccs occs) c (it_mkProd_or_LetIn cl newdecls) in let na = generalized_name c t ids cl' na in let decl = match b with @@ -2782,10 +2788,11 @@ let generalize_goal gl i ((occs,c,b),na as o) (cl,sigma) = let old_generalize_dep ?(with_let=false) c gl = let env = pf_env gl in let sign = pf_hyps gl in + let sigma = project gl in let init_ids = ids_of_named_context (Global.named_context()) in let seek (d:Context.Named.Declaration.t) (toquant:Context.Named.t) = - if List.exists (fun d' -> occur_var_in_decl env (NamedDecl.get_id d') d) toquant - || dependent_in_decl c d then + if List.exists (fun d' -> occur_var_in_decl env sigma (NamedDecl.get_id d') d) toquant + || dependent_in_decl sigma (EConstr.of_constr c) d then d::toquant else toquant in @@ -2901,14 +2908,14 @@ let specialize (c,lbind) ipat = let (thd,tstack) = whd_nored_stack clause.evd (clenv_value clause) in let rec chk = function | [] -> [] - | t::l -> if occur_meta t then [] else t :: chk l + | t::l -> if occur_meta clause.evd (EConstr.of_constr 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 term then + if occur_meta clause.evd (EConstr.of_constr term) then user_err (str "Cannot infer an instance for " ++ - pr_name (meta_name clause.evd (List.hd (collect_metas term))) ++ + pr_name (meta_name clause.evd (List.hd (collect_metas clause.evd (EConstr.of_constr term)))) ++ str "."); clause.evd, term in let typ = Retyping.get_type_of env sigma term in @@ -3143,10 +3150,11 @@ let induct_discharge with_evars dests avoid' tac (avoid,ra) names = let expand_projections env sigma c = let sigma = Sigma.to_evar_map sigma in let rec aux env c = - match kind_of_term c with - | Proj (p, c) -> Retyping.expand_projection env sigma p (aux env c) [] - | _ -> map_constr_with_full_binders push_rel aux env c - in aux env c + match EConstr.kind sigma c with + | Proj (p, c) -> EConstr.of_constr (Retyping.expand_projection env sigma p (EConstr.Unsafe.to_constr (aux env c)) []) + | _ -> map_constr_with_full_binders sigma push_rel aux env c + in + EConstr.Unsafe.to_constr (aux env (EConstr.of_constr c)) (* Marche pas... faut prendre en compte l'occurrence précise... *) @@ -3173,16 +3181,17 @@ let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = else let c = List.nth argl (i-1) in match kind_of_term c with - | Var id when not (List.exists (occur_var env id) args') && - not (List.exists (occur_var env id) params') -> + | Var id when not (List.exists (fun c -> occur_var env (Sigma.to_evar_map sigma) id (EConstr.of_constr c)) args') && + not (List.exists (fun c -> occur_var env (Sigma.to_evar_map sigma) id (EConstr.of_constr c)) params') -> (* Based on the knowledge given by the user, all constraints on the variable are generalizable in the current environment so that it is clearable after destruction *) atomize_one (i-1) (c::args) (c::args') (id::avoid) | _ -> let c' = expand_projections env' sigma c in - if List.exists (dependent c) params' || - List.exists (dependent c) args' + let dependent t = dependent (Sigma.to_evar_map sigma) (EConstr.of_constr c) (EConstr.of_constr t) in + if List.exists dependent params' || + List.exists dependent args' then (* This is a case where the argument is constrained in a way which would require some kind of inversion; we @@ -3272,7 +3281,7 @@ let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = exception Shunt of Id.t move_location -let cook_sign hyp0_opt inhyps indvars env = +let cook_sign hyp0_opt inhyps indvars env sigma = (* First phase from L to R: get [toclear], [decldep] and [statuslist] for the hypotheses before (= more ancient than) hyp0 (see above) *) let toclear = ref [] in @@ -3299,11 +3308,11 @@ let cook_sign hyp0_opt inhyps indvars env = rhyp end else let dephyp0 = List.is_empty inhyps && - (Option.cata (fun id -> occur_var_in_decl env id decl) false hyp0_opt) + (Option.cata (fun id -> occur_var_in_decl env sigma id decl) false hyp0_opt) in let depother = List.is_empty inhyps && - (List.exists (fun id -> occur_var_in_decl env id decl) indvars || - List.exists (fun decl' -> occur_var_in_decl env (NamedDecl.get_id decl') decl) !decldeps) + (List.exists (fun id -> occur_var_in_decl env sigma id decl) indvars || + List.exists (fun decl' -> occur_var_in_decl env sigma (NamedDecl.get_id decl') decl) !decldeps) in if not (List.is_empty inhyps) && Id.List.mem hyp inhyps || dephyp0 || depother @@ -3549,7 +3558,7 @@ let make_abstract_generalize env id typ concl dep ctx body c eqs args refls = Sigma (mkApp (appeqs, abshypt), sigma, p) end } -let hyps_of_vars env sign nogen hyps = +let hyps_of_vars env sigma sign nogen hyps = if Id.Set.is_empty hyps then [] else let (_,lh) = @@ -3559,7 +3568,7 @@ let hyps_of_vars env sign nogen hyps = if Id.Set.mem x nogen then (hs,hl) else if Id.Set.mem x hs then (hs,x::hl) else - let xvars = global_vars_set_of_decl env d in + let xvars = global_vars_set_of_decl env sigma d in if not (Id.Set.is_empty (Id.Set.diff xvars hs)) then (Id.Set.add x hs, x :: hl) else (hs, hl)) @@ -3592,7 +3601,7 @@ let abstract_args gl generalize_vars dep id defined f args = let sigma = ref (Tacmach.project gl) in let env = Tacmach.pf_env gl in let concl = Tacmach.pf_concl gl in - let dep = dep || dependent (mkVar id) concl in + let dep = dep || local_occur_var !sigma id (EConstr.of_constr concl) in let avoid = ref [] in let get_id name = let id = fresh_id !avoid (match name with Name n -> n | Anonymous -> Id.of_string "gen_x") gl in @@ -3659,7 +3668,7 @@ let abstract_args gl generalize_vars dep id defined f args = let vars = if generalize_vars then let nogen = Id.Set.add id nogen in - hyps_of_vars (pf_env gl) (pf_hyps gl) nogen vars + hyps_of_vars (pf_env gl) (project gl) (pf_hyps gl) nogen vars else [] in let body, c' = @@ -3845,7 +3854,7 @@ let compute_elim_sig ?elimc elimt = let ccl = exchange_hd_app (mkVar (Id.of_string "__QI_DUMMY__")) conclusion in let concl_with_args = it_mkProd_or_LetIn ccl args_indargs in - let nparams = Int.Set.cardinal (free_rels concl_with_args) in + let nparams = Int.Set.cardinal (free_rels Evd.empty (** FIXME *) (EConstr.of_constr concl_with_args)) in let preds,params = List.chop (List.length params_preds - nparams) params_preds in (* A first approximation, further analysis will tweak it *) @@ -3905,7 +3914,7 @@ let compute_elim_sig ?elimc elimt = with e when CErrors.noncritical e -> error "Cannot find the inductive type of the inductive scheme." -let compute_scheme_signature scheme names_info ind_type_guess = +let compute_scheme_signature evd scheme names_info ind_type_guess = let open Context.Rel.Declaration in let f,l = decompose_app scheme.concl in (* Vérifier que les arguments de Qi sont bien les xi. *) @@ -3940,9 +3949,9 @@ let compute_scheme_signature scheme names_info ind_type_guess = let rec check_branch p c = match kind_of_term c with | Prod (_,t,c) -> - (is_pred p t, true, dependent (mkRel 1) c) :: check_branch (p+1) c + (is_pred p t, true, not (EConstr.Vars.noccurn evd 1 (EConstr.of_constr c))) :: check_branch (p+1) c | LetIn (_,_,_,c) -> - (OtherArg, false, dependent (mkRel 1) c) :: check_branch (p+1) c + (OtherArg, false, not (EConstr.Vars.noccurn evd 1 (EConstr.of_constr c))) :: check_branch (p+1) c | _ when is_pred p c == IndArg -> [] | _ -> raise Exit in @@ -3975,7 +3984,7 @@ let compute_scheme_signature scheme names_info ind_type_guess = different. *) let compute_elim_signature (evd,(elimc,elimt),ind_type_guess) names_info = let scheme = compute_elim_sig ~elimc:elimc elimt in - evd, (compute_scheme_signature scheme names_info ind_type_guess, scheme) + evd, (compute_scheme_signature evd scheme names_info ind_type_guess, scheme) let guess_elim isrec dep s hyp0 gl = let tmptyp0 = Tacmach.New.pf_get_hyp_typ hyp0 gl in @@ -4022,7 +4031,7 @@ let find_induction_type isrec elim hyp0 gl = let evd, (elimc,elimt),ind_guess = given_elim hyp0 e gl in let scheme = compute_elim_sig ~elimc elimt in if Option.is_empty scheme.indarg then error "Cannot find induction type"; - let indsign = compute_scheme_signature scheme hyp0 ind_guess in + let indsign = compute_scheme_signature evd scheme hyp0 ind_guess in let elim = ({elimindex = Some(-1); elimbody = elimc; elimrename = None},elimt) in scheme, ElimUsing (elim,indsign) in @@ -4049,7 +4058,7 @@ let get_eliminator elim dep s gl = | ElimOver (isrec,id) -> let evd, (elimc,elimt),_ as elims = guess_elim isrec dep s id gl in let _, (l, s) = compute_elim_signature elims id in - let branchlengthes = List.map (fun d -> assert (RelDecl.is_local_assum d); pi1 (decompose_prod_letin (RelDecl.get_type d))) + let branchlengthes = List.map (fun d -> assert (RelDecl.is_local_assum d); pi1 (decompose_prod_letin (Tacmach.New.project gl) (EConstr.of_constr (RelDecl.get_type d)))) (List.rev s.branches) in evd, isrec, ({elimindex = None; elimbody = elimc; elimrename = Some (isrec,Array.of_list branchlengthes)}, elimt), l @@ -4118,8 +4127,8 @@ let apply_induction_in_context with_evars hyp0 inhyps elim indvars names induct_ let env = Proofview.Goal.env gl in let sigma = Sigma.to_evar_map sigma in let concl = Tacmach.New.pf_nf_concl gl in - let statuslists,lhyp0,toclear,deps,avoid,dep_in_hyps = cook_sign hyp0 inhyps indvars env in - let dep_in_concl = Option.cata (fun id -> occur_var env id concl) false hyp0 in + let statuslists,lhyp0,toclear,deps,avoid,dep_in_hyps = cook_sign hyp0 inhyps indvars env sigma in + let dep_in_concl = Option.cata (fun id -> occur_var env sigma id (EConstr.of_constr concl)) false hyp0 in let dep = dep_in_hyps || dep_in_concl in let tmpcl = it_mkNamedProd_or_LetIn concl deps in let s = Retyping.get_sort_family_of env sigma tmpcl in @@ -4207,7 +4216,7 @@ let induction_without_atomization isrec with_evars elim names lid = (* assume that no occurrences are selected *) let clear_unselected_context id inhyps cls = Proofview.Goal.nf_enter { enter = begin fun gl -> - if occur_var (Tacmach.New.pf_env gl) id (Tacmach.New.pf_concl gl) && + if occur_var (Tacmach.New.pf_env gl) (Tacmach.New.project gl) id (EConstr.of_constr (Tacmach.New.pf_concl gl)) && cls.concl_occs == NoOccurrences then user_err (str "Conclusion must be mentioned: it depends on " ++ pr_id id @@ -4219,7 +4228,7 @@ let clear_unselected_context id inhyps cls = if Id.List.mem id' inhyps then (* if selected, do not erase *) None else (* erase if not selected and dependent on id or selected hyps *) - let test id = occur_var_in_decl (Tacmach.New.pf_env gl) id d in + let test id = occur_var_in_decl (Tacmach.New.pf_env gl) (Tacmach.New.project gl) id d in if List.exists test (id::inhyps) then Some id' else None in let ids = List.map_filter to_erase (Proofview.Goal.hyps gl) in clear ids @@ -4246,7 +4255,7 @@ let use_bindings env sigma elim must_be_closed (c,lbind) typ = let rec find_clause typ = try let indclause = make_clenv_binding env sigma (c,typ) lbind in - if must_be_closed && occur_meta (clenv_value indclause) then + if must_be_closed && occur_meta indclause.evd (EConstr.of_constr (clenv_value indclause)) then error "Need a fully applied argument."; (* We lose the possibility of coercions in with-bindings *) let (sigma, c) = pose_all_metas_as_evars env indclause.evd (clenv_value indclause) in @@ -4351,10 +4360,10 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim Sigma (tac, sigma', p +> q) end } -let has_generic_occurrences_but_goal cls id env ccl = +let has_generic_occurrences_but_goal cls id env sigma ccl = clause_with_generic_context_selection cls && (* TODO: whd_evar of goal *) - (cls.concl_occs != NoOccurrences || not (occur_var env id ccl)) + (cls.concl_occs != NoOccurrences || not (occur_var env sigma id (EConstr.of_constr ccl))) let induction_gen clear_flag isrec with_evars elim ((_pending,(c,lbind)),(eqname,names) as arg) cls = @@ -4371,7 +4380,7 @@ let induction_gen clear_flag isrec with_evars elim isVar c && not (mem_named_context_val (destVar c) (Global.named_context_val ())) && lbind == NoBindings && not with_evars && Option.is_empty eqname && clear_flag == None - && has_generic_occurrences_but_goal cls (destVar c) env ccl in + && has_generic_occurrences_but_goal cls (destVar c) env (Sigma.to_evar_map sigma) ccl in let enough_applied = check_enough_applied env sigma elim t in if is_arg_pure_hyp && enough_applied then (* First case: induction on a variable already in an inductive type and @@ -4423,11 +4432,12 @@ let induction_gen_l isrec with_evars elim names lc = | _ -> Proofview.Goal.enter { enter = begin fun gl -> let type_of = Tacmach.New.pf_unsafe_type_of gl in + let sigma = Tacmach.New.project gl in let x = id_of_name_using_hdchar (Global.env()) (type_of c) Anonymous in let id = new_fresh_id [] x gl in - let newl' = List.map (replace_term c (mkVar id)) l' in + let newl' = List.map (fun r -> replace_term sigma (EConstr.of_constr c) (EConstr.mkVar id) (EConstr.of_constr r)) l' in let _ = newlc:=id::!newlc in Tacticals.New.tclTHEN (letin_tac None (Name id) c None allHypsAndConcl) @@ -4601,8 +4611,9 @@ let reflexivity_red allowred = (* PL: usual reflexivity don't perform any reduction when searching for an equality, but we may need to do some when called back from inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *) + let sigma = Tacmach.New.project gl in let concl = maybe_betadeltaiota_concl allowred gl in - match match_with_equality_type concl with + match match_with_equality_type sigma concl with | None -> Proofview.tclZERO NoEquationFound | Some _ -> one_constructor 1 NoBindings end } diff --git a/tactics/term_dnet.ml b/tactics/term_dnet.ml index e4b45489dc..6294f9fdc2 100644 --- a/tactics/term_dnet.ml +++ b/tactics/term_dnet.ml @@ -351,7 +351,7 @@ struct (fun id acc -> let c_id = Opt.reduce (Ident.constr_of id) in let (ctx,wc) = - try Termops.align_prod_letin whole_c c_id + try Termops.align_prod_letin Evd.empty (EConstr.of_constr whole_c) (EConstr.of_constr c_id) (** FIXME *) with Invalid_argument _ -> [],c_id in let wc,whole_c = if Opt.direction then whole_c,wc else wc,whole_c in try -- cgit v1.2.3 From 8f6aab1f4d6d60842422abc5217daac806eb0897 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 1 Nov 2016 20:53:32 +0100 Subject: Reductionops API using EConstr. --- tactics/autorewrite.ml | 2 +- tactics/contradiction.ml | 10 +++--- tactics/eauto.ml | 2 +- tactics/elim.ml | 4 +-- tactics/eqdecide.ml | 2 +- tactics/eqschemes.ml | 4 +-- tactics/equality.ml | 60 ++++++++++++++++++----------------- tactics/hints.ml | 4 +-- tactics/hipattern.ml | 4 +-- tactics/inv.ml | 2 +- tactics/leminv.ml | 6 ++-- tactics/tactics.ml | 81 ++++++++++++++++++++++++------------------------ tactics/tactics.mli | 2 +- 13 files changed, 93 insertions(+), 90 deletions(-) (limited to 'tactics') diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index dae1cc9f1b..46600cdd75 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -284,7 +284,7 @@ let decompose_applied_relation metas env sigma c ctype left2right = match find_rel ctype with | Some c -> Some c | None -> - let ctx,t' = Reductionops.splay_prod_assum env sigma ctype in (* Search for underlying eq *) + let ctx,t' = Reductionops.splay_prod_assum env sigma (EConstr.of_constr ctype) in (* Search for underlying eq *) match find_rel (it_mkProd_or_LetIn t' ctx) with | Some c -> Some c | None -> None diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index fcbad4bf0d..b9704b846f 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -65,7 +65,7 @@ let contradiction_context = | d :: rest -> let id = NamedDecl.get_id d in let typ = nf_evar sigma (NamedDecl.get_type d) in - let typ = whd_all env sigma typ in + let typ = whd_all env sigma (EConstr.of_constr typ) in if is_empty_type sigma typ then simplest_elim (mkVar id) else match kind_of_term typ with @@ -88,7 +88,7 @@ let contradiction_context = (Proofview.tclORELSE (Proofview.Goal.enter { enter = begin fun gl -> let is_conv_leq = Tacmach.New.pf_apply is_conv_leq gl in - filter_hyp (fun typ -> is_conv_leq typ t) + filter_hyp (fun typ -> is_conv_leq (EConstr.of_constr typ) (EConstr.of_constr t)) (fun id' -> simplest_elim (mkApp (mkVar id,[|mkVar id'|]))) end }) begin function (e, info) -> match e with @@ -105,7 +105,7 @@ let is_negation_of env sigma typ t = match kind_of_term (whd_all env sigma t) with | Prod (na,t,u) -> let u = nf_evar sigma u in - is_empty_type sigma u && is_conv_leq env sigma typ t + is_empty_type sigma u && is_conv_leq env sigma (EConstr.of_constr typ) (EConstr.of_constr t) | _ -> false let contradiction_term (c,lbind as cl) = @@ -114,7 +114,7 @@ let contradiction_term (c,lbind as cl) = let env = Proofview.Goal.env gl in let type_of = Tacmach.New.pf_unsafe_type_of gl in let typ = type_of c in - let _, ccl = splay_prod env sigma typ in + let _, ccl = splay_prod env sigma (EConstr.of_constr typ) in if is_empty_type sigma ccl then Tacticals.New.tclTHEN (elim false None cl None) @@ -123,7 +123,7 @@ let contradiction_term (c,lbind as cl) = Proofview.tclORELSE begin if lbind = NoBindings then - filter_hyp (is_negation_of env sigma typ) + filter_hyp (fun c -> is_negation_of env sigma typ (EConstr.of_constr c)) (fun id -> simplest_elim (mkApp (mkVar id,[|c|]))) else Proofview.tclZERO Not_found diff --git a/tactics/eauto.ml b/tactics/eauto.ml index 6250fef2d6..0869ac0c76 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -478,7 +478,7 @@ let unfold_head env (ids, csts) c = true, Environ.constant_value_in env c | App (f, args) -> (match aux f with - | true, f' -> true, Reductionops.whd_betaiota Evd.empty (mkApp (f', args)) + | true, f' -> true, Reductionops.whd_betaiota Evd.empty (EConstr.of_constr (mkApp (f', args))) | false, _ -> let done_, args' = Array.fold_left_i (fun i (done_, acc) arg -> diff --git a/tactics/elim.ml b/tactics/elim.ml index 12d8e98c43..b830ccefee 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -96,14 +96,14 @@ let head_in indl t gl = let ity,_ = if !up_to_delta then find_mrectype env sigma t - else extract_mrectype t + else extract_mrectype sigma t in List.exists (fun i -> eq_ind (fst i) (fst ity)) indl with Not_found -> false let decompose_these c l = Proofview.Goal.enter { enter = begin fun gl -> let indl = List.map (fun x -> x, Univ.Instance.empty) l in - general_decompose (fun sigma (_,t) -> head_in indl t gl) c + general_decompose (fun sigma (_,t) -> head_in indl (EConstr.of_constr t) gl) c end } let decompose_and c = diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml index 1a67bedc28..1554d43f09 100644 --- a/tactics/eqdecide.ml +++ b/tactics/eqdecide.ml @@ -197,7 +197,7 @@ let decideGralEquality = Proofview.Goal.enter { enter = begin fun gl -> let concl = pf_nf_concl gl in match_eqdec concl >>= fun (eqonleft,_,c1,c2,typ) -> - let headtyp = hd_app (pf_compute gl typ) in + let headtyp = hd_app (pf_compute gl (EConstr.of_constr typ)) in begin match kind_of_term headtyp with | Ind (mi,_) -> Proofview.tclUNIT mi | _ -> tclZEROMSG (Pp.str"This decision procedure only works for inductive objects.") diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml index c94dcfa9df..aea3ca17ec 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -606,8 +606,8 @@ let fix_r2l_forward_rew_scheme (c, ctx') = (mkLambda_or_LetIn (RelDecl.map_constr (liftn (-1) 2) hp) (mkLambda_or_LetIn (RelDecl.map_constr (lift 2) ind) (Reductionops.whd_beta Evd.empty - (applist (c, - Context.Rel.to_extended_list 3 indargs @ [mkRel 1;mkRel 3;mkRel 2])))))) + (EConstr.of_constr (applist (c, + Context.Rel.to_extended_list 3 indargs @ [mkRel 1;mkRel 3;mkRel 2]))))))) in c', ctx' | _ -> anomaly (Pp.str "Ill-formed non-dependent left-to-right rewriting scheme") diff --git a/tactics/equality.ml b/tactics/equality.ml index 74f6dd44ae..48f46b36be 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -328,7 +328,7 @@ let jmeq_same_dom gl = function | Some t -> let rels, t = decompose_prod_assum t in let env = Environ.push_rel_context rels (Proofview.Goal.env gl) in - match decompose_app t with + match EConstr.decompose_app (project gl) (EConstr.of_constr t) with | _, [dom1; _; dom2;_] -> is_conv env (Tacmach.New.project gl) dom1 dom2 | _ -> false @@ -402,7 +402,7 @@ let type_of_clause cls gl = match cls with let leibniz_rewrite_ebindings_clause cls lft2rgt tac c t l with_evars frzevars dep_proof_ok hdcncl = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let evd = Sigma.to_evar_map (Proofview.Goal.sigma gl) in - let isatomic = isProd (whd_zeta evd hdcncl) in + let isatomic = isProd (whd_zeta evd (EConstr.of_constr hdcncl)) in let dep_fun = if isatomic then dependent else dependent_no_evar in let type_of_cls = type_of_clause cls gl in let dep = dep_proof_ok && dep_fun evd (EConstr.of_constr c) (EConstr.of_constr type_of_cls) in @@ -441,7 +441,7 @@ let general_rewrite_ebindings_clause cls lft2rgt occs frzevars dep_proof_ok ?tac let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let ctype = get_type_of env sigma c in - let rels, t = decompose_prod_assum (whd_betaiotazeta sigma ctype) in + let rels, t = decompose_prod_assum (whd_betaiotazeta sigma (EConstr.of_constr ctype)) in match match_with_equality_type sigma t with | Some (hdcncl,args) -> (* Fast path: direct leibniz-like rewrite *) let lft2rgt = adjust_rewriting_direction args lft2rgt in @@ -457,7 +457,7 @@ let general_rewrite_ebindings_clause cls lft2rgt occs frzevars dep_proof_ok ?tac | (e, info) -> Proofview.tclEVARMAP >>= fun sigma -> let env' = push_rel_context rels env in - let rels',t' = splay_prod_assum env' sigma t in (* Search for underlying eq *) + let rels',t' = splay_prod_assum env' sigma (EConstr.of_constr t) in (* Search for underlying eq *) match match_with_equality_type sigma t' with | Some (hdcncl,args) -> let lft2rgt = adjust_rewriting_direction args lft2rgt in @@ -714,9 +714,11 @@ let _ = optread = (fun () -> !keep_proof_equalities_for_injection) ; optwrite = (fun b -> keep_proof_equalities_for_injection := b) } - let find_positions env sigma t1 t2 = + let open EConstr in let project env sorts posn t1 t2 = + let t1 = EConstr.Unsafe.to_constr t1 in + let t2 = EConstr.Unsafe.to_constr t2 in let ty1 = get_type_of env sigma t1 in let s = get_sort_family_of env sigma ty1 in if Sorts.List.mem s sorts @@ -725,7 +727,7 @@ let find_positions env sigma t1 t2 = let rec findrec sorts posn t1 t2 = let hd1,args1 = whd_all_stack env sigma t1 in let hd2,args2 = whd_all_stack env sigma t2 in - match (kind_of_term hd1, kind_of_term hd2) with + match (EConstr.kind sigma hd1, EConstr.kind sigma hd2) with | Construct (sp1,_), Construct (sp2,_) when Int.equal (List.length args1) (constructor_nallargs_env env sp1) -> @@ -760,7 +762,7 @@ let find_positions env sigma t1 t2 = let sorts = if !keep_proof_equalities_for_injection then [InSet;InType;InProp] else [InSet;InType] in - Inr (findrec sorts [] t1 t2) + Inr (findrec sorts [] (EConstr.of_constr t1) (EConstr.of_constr t2)) with DiscrFound (path,c1,c2) -> Inl (path,c1,c2) @@ -840,7 +842,7 @@ let injectable env sigma t1 t2 = let descend_then env sigma head dirn = let IndType (indf,_) = - try find_rectype env sigma (get_type_of env sigma head) + try find_rectype env sigma (EConstr.of_constr (get_type_of env sigma head)) with Not_found -> error "Cannot project on an inductive type derived from a dependency." in let indp,_ = (dest_ind_family indf) in @@ -883,7 +885,7 @@ let descend_then env sigma head dirn = let build_selector env sigma dirn c ind special default = let IndType(indf,_) = - try find_rectype env sigma ind + try find_rectype env sigma (EConstr.of_constr ind) with Not_found -> (* one can find Rel(k) in case of dependent constructors like T := c : (A:Set)A->T and a discrimination @@ -1026,7 +1028,7 @@ let onNegatedEquality with_evars tac = let sigma = Tacmach.New.project gl in let ccl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in - match kind_of_term (hnf_constr env sigma ccl) with + match kind_of_term (hnf_constr env sigma (EConstr.of_constr ccl)) with | Prod (_,t,u) when is_empty_type sigma u -> tclTHEN introf (onLastHypId (fun id -> @@ -1104,7 +1106,7 @@ let make_tuple env sigma (rterm,rty) lind = let minimal_free_rels env sigma (c,cty) = let cty_rels = free_rels sigma (EConstr.of_constr cty) in - let cty' = simpl env sigma cty in + let cty' = simpl env sigma (EConstr.of_constr cty) in let rels' = free_rels sigma (EConstr.of_constr cty') in if Int.Set.subset cty_rels rels' then (cty,cty_rels) @@ -1171,11 +1173,11 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt = with Evarconv.UnableToUnify _ -> error "Cannot solve a unification problem." else - let (a,p_i_minus_1) = match whd_beta_stack !evdref p_i with - | (_sigS,[a;p]) -> (a,p) + let (a,p_i_minus_1) = match whd_beta_stack !evdref (EConstr.of_constr p_i) with + | (_sigS,[a;p]) -> (EConstr.Unsafe.to_constr a, EConstr.Unsafe.to_constr p) | _ -> 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(p_i_minus_1,[ev]) in + let rty = beta_applist sigma (EConstr.of_constr p_i_minus_1,[EConstr.of_constr ev]) in let tuple_tail = sigrec_clausal_form (siglen-1) rty in match Evd.existential_opt_value !evdref @@ -1317,13 +1319,13 @@ let inject_if_homogenous_dependent_pair ty = hd2,ar2 = decompose_app_vect sigma (EConstr.of_constr t2) in if not (Globnames.is_global (existTconstr()) hd1) then raise Exit; if not (Globnames.is_global (existTconstr()) hd2) then raise Exit; - let ind,_ = try pf_apply find_mrectype gl ar1.(0) with Not_found -> raise Exit in + let ind,_ = try pf_apply find_mrectype gl (EConstr.of_constr ar1.(0)) with Not_found -> raise Exit in (* check if the user has declared the dec principle *) (* and compare the fst arguments of the dep pair *) (* Note: should work even if not an inductive type, but the table only *) (* knows inductive types *) if not (Ind_tables.check_scheme (!eq_dec_scheme_kind_name()) (fst ind) && - pf_apply is_conv gl ar1.(2) ar2.(2)) then raise Exit; + pf_apply is_conv gl (EConstr.of_constr ar1.(2)) (EConstr.of_constr 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 = Coqlib.coq_constant "inj_pair2_eq_dec is missing" @@ -1350,8 +1352,8 @@ let inject_if_homogenous_dependent_pair ty = let simplify_args env sigma t = (* Quick hack to reduce in arguments of eq only *) match decompose_app t with - | eq, [t;c1;c2] -> applist (eq,[t;simpl env sigma c1;simpl env sigma c2]) - | eq, [t1;c1;t2;c2] -> applist (eq,[t1;simpl env sigma c1;t2;simpl env sigma c2]) + | eq, [t;c1;c2] -> applist (eq,[t;simpl env sigma (EConstr.of_constr c1);simpl env sigma (EConstr.of_constr c2)]) + | eq, [t1;c1;t2;c2] -> applist (eq,[t1;simpl env sigma (EConstr.of_constr c1);t2;simpl env sigma (EConstr.of_constr c2)]) | _ -> t let inject_at_positions env sigma l2r (eq,_,(t,t1,t2)) eq_clause posns tac = @@ -1515,14 +1517,14 @@ let _ = declare_intro_decomp_eq intro_decomp_eq *) -let decomp_tuple_term env c t = +let decomp_tuple_term env sigma c t = let rec decomprec inner_code ex exty = let iterated_decomp = try let ({proj1=p1; proj2=p2}),(i,a,p,car,cdr) = find_sigma_data_decompose ex in let car_code = applist (mkConstU (destConstRef p1,i),[a;p;inner_code]) and cdr_code = applist (mkConstU (destConstRef p2,i),[a;p;inner_code]) in - let cdrtyp = beta_applist (p,[car]) in + let cdrtyp = beta_applist sigma (EConstr.of_constr p,[EConstr.of_constr car]) in List.map (fun l -> ((car,a),car_code)::l) (decomprec cdr_code cdr cdrtyp) with Constr_matching.PatternMatchingFailure -> [] @@ -1533,8 +1535,8 @@ let subst_tuple_term env sigma dep_pair1 dep_pair2 b = let sigma = Sigma.to_evar_map sigma in let typ = get_type_of env sigma dep_pair1 in (* We find all possible decompositions *) - let decomps1 = decomp_tuple_term env dep_pair1 typ in - let decomps2 = decomp_tuple_term env dep_pair2 typ in + let decomps1 = decomp_tuple_term env sigma dep_pair1 typ in + let decomps2 = decomp_tuple_term env sigma dep_pair2 typ in (* We adjust to the shortest decomposition *) let n = min (List.length decomps1) (List.length decomps2) in let decomp1 = List.nth decomps1 (n-1) in @@ -1547,11 +1549,11 @@ let subst_tuple_term env sigma dep_pair1 dep_pair2 b = let abst_B = List.fold_right (fun (e,t) body -> lambda_create env (t,subst_term sigma (EConstr.of_constr e) (EConstr.of_constr body))) e1_list b in - let pred_body = beta_applist(abst_B,proj_list) in + let pred_body = beta_applist sigma (EConstr.of_constr abst_B, List.map EConstr.of_constr proj_list) in let body = mkApp (lambda_create env (typ,pred_body),[|dep_pair1|]) in - let expected_goal = beta_applist (abst_B,List.map fst e2_list) in + let expected_goal = beta_applist sigma (EConstr.of_constr abst_B,List.map (fst %> EConstr.of_constr) e2_list) in (* Simulate now the normalisation treatment made by Logic.mk_refgoals *) - let expected_goal = nf_betaiota sigma expected_goal in + let expected_goal = nf_betaiota sigma (EConstr.of_constr expected_goal) in (* Retype to get universes right *) let sigma, expected_goal_ty = Typing.type_of env sigma expected_goal in let sigma, _ = Typing.type_of env sigma body in @@ -1842,20 +1844,20 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () = let cond_eq_term_left c t gl = try let (_,x,_) = pi3 (find_eq_data_decompose gl t) in - if pf_conv_x gl c x then true else failwith "not convertible" + if pf_conv_x gl (EConstr.of_constr c) (EConstr.of_constr x) then true else failwith "not convertible" with Constr_matching.PatternMatchingFailure -> failwith "not an equality" let cond_eq_term_right c t gl = try let (_,_,x) = pi3 (find_eq_data_decompose gl t) in - if pf_conv_x gl c x then false else failwith "not convertible" + if pf_conv_x gl (EConstr.of_constr c) (EConstr.of_constr x) then false else failwith "not convertible" with Constr_matching.PatternMatchingFailure -> failwith "not an equality" let cond_eq_term c t gl = try let (_,x,y) = pi3 (find_eq_data_decompose gl t) in - if pf_conv_x gl c x then true - else if pf_conv_x gl c y then false + if pf_conv_x gl (EConstr.of_constr c) (EConstr.of_constr x) then true + else if pf_conv_x gl (EConstr.of_constr c) (EConstr.of_constr y) then false else failwith "not convertible" with Constr_matching.PatternMatchingFailure -> failwith "not an equality" diff --git a/tactics/hints.ml b/tactics/hints.ml index 55bf5f29ea..c41f88ab7f 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -761,7 +761,7 @@ let make_exact_entry env sigma pri poly ?(name=PathAny) (c, cty, ctx) = code = with_uid (Give_exact (c, cty, ctx)); }) let make_apply_entry env sigma (eapply,hnf,verbose) pri poly ?(name=PathAny) (c, cty, ctx) = - let cty = if hnf then hnf_constr env sigma cty else cty in + let cty = if hnf then hnf_constr env sigma (EConstr.of_constr cty) else cty in match kind_of_term cty with | Prod _ -> let sigma' = Evd.merge_context_set univ_flexible sigma ctx in @@ -910,7 +910,7 @@ let make_mode ref m = let make_trivial env sigma poly ?(name=PathAny) r = let c,ctx = fresh_global_or_constr env sigma poly r in let sigma = Evd.merge_context_set univ_flexible sigma ctx in - let t = hnf_constr env sigma (unsafe_type_of env sigma c) in + let t = hnf_constr env sigma (EConstr.of_constr (unsafe_type_of env sigma c)) in let hd = head_of_constr_reference (head_constr sigma t) in let ce = mk_clenv_from_env env sigma None (c,t) in (Some hd, { pri=1; diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml index 847ecf4b0e..a42a51fc09 100644 --- a/tactics/hipattern.ml +++ b/tactics/hipattern.ml @@ -440,7 +440,7 @@ let extract_eq_args gl = function let t = pf_unsafe_type_of gl e1 in (t,e1,e2) | PolymorphicLeibnizEq (t,e1,e2) -> (t,e1,e2) | HeterogenousEq (t1,e1,t2,e2) -> - if pf_conv_x gl t1 t2 then (t1,e1,e2) + if pf_conv_x gl (EConstr.of_constr t1) (EConstr.of_constr t2) then (t1,e1,e2) else raise PatternMatchingFailure let find_eq_data_decompose gl eqn = @@ -466,7 +466,7 @@ let match_eq_nf gls eqn (ref, hetero) = match Id.Map.bindings (pf_matches gls pat eqn) with | [(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) + (t,pf_whd_all gls (EConstr.of_constr x),pf_whd_all gls (EConstr.of_constr y)) | _ -> anomaly ~label:"match_eq" (Pp.str "an eq pattern should match 3 terms") let dest_nf_eq gls eqn = diff --git a/tactics/inv.ml b/tactics/inv.ml index d1d6178da2..0b2d2f0b2f 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -443,7 +443,7 @@ let raw_inversion inv_kind id status names = let msg = str "The type of " ++ pr_id id ++ str " is not inductive." in CErrors.user_err msg in - let IndType (indf,realargs) = find_rectype env sigma t in + let IndType (indf,realargs) = find_rectype env sigma (EConstr.of_constr t) in let evdref = ref sigma in let (elim_predicate, args) = make_inv_predicate env evdref indf realargs id status concl in diff --git a/tactics/leminv.ml b/tactics/leminv.ml index 46f1f7c8d0..85910355ea 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -116,7 +116,7 @@ let max_prefix_sign lid sign = | id::l -> snd (max_rec (id, sign_prefix id sign) l) *) let rec add_prods_sign env sigma t = - match kind_of_term (whd_all env sigma t) with + match kind_of_term (whd_all env sigma (EConstr.of_constr t)) with | Prod (na,c1,b) -> let id = id_of_name_using_hdchar env t na in let b'= subst1 (mkVar id) b in @@ -169,7 +169,7 @@ let compute_first_inversion_scheme env sigma ind sort dep_option = let goal = mkArrow i (applist(mkVar p, List.rev revargs)) in (pty,goal) in - let npty = nf_all env sigma pty in + let npty = nf_all env sigma (EConstr.of_constr pty) in let extenv = push_named (LocalAssum (p,npty)) env in extenv, goal @@ -183,7 +183,7 @@ let compute_first_inversion_scheme env sigma ind sort dep_option = let inversion_scheme env sigma t sort dep_option inv_op = let (env,i) = add_prods_sign env sigma t in let ind = - try find_rectype env sigma i + try find_rectype env sigma (EConstr.of_constr i) with Not_found -> user_err ~hdr:"inversion_scheme" (no_inductive_inconstr env sigma i) in diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 15dd1a97ce..c96553fae5 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -502,7 +502,7 @@ let rec check_mutind env sigma k cl = match kind_of_term (strip_outer_cast sigma | Prod (na, c1, b) -> if Int.equal k 1 then try - let ((sp, _), u), _ = find_inductive env sigma c1 in + let ((sp, _), u), _ = find_inductive env sigma (EConstr.of_constr c1) in (sp, u) with Not_found -> error "Cannot do a fixpoint on a non inductive type." else @@ -555,14 +555,14 @@ let fix ido n = match ido with mutual_fix id n [] 0 let rec check_is_mutcoind env sigma cl = - let b = whd_all env sigma cl in + let b = whd_all env sigma (EConstr.of_constr cl) in match kind_of_term b with | Prod (na, c1, b) -> let open Context.Rel.Declaration in check_is_mutcoind (push_rel (LocalAssum (na,c1)) env) sigma b | _ -> try - let _ = find_coinductive env sigma b in () + let _ = find_coinductive env sigma (EConstr.of_constr b) in () with Not_found -> error "All methods must construct elements in coinductive types." @@ -609,11 +609,11 @@ let cofix ido = match ido with (* Reduction and conversion tactics *) (**************************************************************) -type tactic_reduction = env -> evar_map -> constr -> constr +type tactic_reduction = env -> evar_map -> EConstr.t -> constr let pf_reduce_decl redfun where decl gl = let open Context.Named.Declaration in - let redfun' = Tacmach.New.pf_apply redfun gl in + let redfun' c = Tacmach.New.pf_apply redfun gl (EConstr.of_constr c) in match decl with | LocalAssum (id,ty) -> if where == InHypValueOnly then @@ -694,7 +694,7 @@ let bind_red_expr_occurrences occs nbcl redexp = let reduct_in_concl (redfun,sty) = Proofview.Goal.nf_enter { enter = begin fun gl -> - convert_concl_no_check (Tacmach.New.pf_apply redfun gl (Tacmach.New.pf_concl gl)) sty + convert_concl_no_check (Tacmach.New.pf_apply redfun gl (EConstr.of_constr (Tacmach.New.pf_concl gl))) sty end } let reduct_in_hyp ?(check=false) redfun (id,where) = @@ -714,7 +714,7 @@ let reduct_option ?(check=false) redfun = function let pf_e_reduce_decl redfun where decl gl = let open Context.Named.Declaration in let sigma = Proofview.Goal.sigma gl in - let redfun sigma c = redfun.e_redfun (Tacmach.New.pf_env gl) sigma c in + let redfun sigma c = redfun.e_redfun (Tacmach.New.pf_env gl) sigma (EConstr.of_constr c) in match decl with | LocalAssum (id,ty) -> if where == InHypValueOnly then @@ -729,7 +729,7 @@ let pf_e_reduce_decl redfun where decl gl = let e_reduct_in_concl ~check (redfun, sty) = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in - let Sigma (c', sigma, p) = redfun.e_redfun (Tacmach.New.pf_env gl) sigma (Tacmach.New.pf_concl gl) in + let Sigma (c', sigma, p) = redfun.e_redfun (Tacmach.New.pf_env gl) sigma (EConstr.of_constr (Tacmach.New.pf_concl gl)) in Sigma (convert_concl ~check c' sty, sigma, p) end } @@ -749,7 +749,7 @@ let e_reduct_option ?(check=false) redfun = function let e_change_in_concl (redfun,sty) = Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in - let Sigma (c, sigma, p) = redfun.e_redfun (Proofview.Goal.env gl) sigma (Proofview.Goal.raw_concl gl) in + let Sigma (c, sigma, p) = redfun.e_redfun (Proofview.Goal.env gl) sigma (EConstr.of_constr (Proofview.Goal.raw_concl gl)) in Sigma (convert_concl_no_check c sty, sigma, p) end } @@ -759,14 +759,14 @@ let e_pf_change_decl (redfun : bool -> e_reduction_function) where decl env sigm | LocalAssum (id,ty) -> if where == InHypValueOnly then user_err (pr_id id ++ str " has no value."); - let Sigma (ty', sigma, p) = (redfun false).e_redfun env sigma ty in + let Sigma (ty', sigma, p) = (redfun false).e_redfun env sigma (EConstr.of_constr ty) in Sigma (LocalAssum (id, ty'), sigma, p) | LocalDef (id,b,ty) -> let Sigma (b', sigma, p) = - if where != InHypTypeOnly then (redfun true).e_redfun env sigma b else Sigma.here b sigma + if where != InHypTypeOnly then (redfun true).e_redfun env sigma (EConstr.of_constr b) else Sigma.here b sigma in let Sigma (ty', sigma, q) = - if where != InHypValueOnly then (redfun false).e_redfun env sigma ty else Sigma.here ty sigma + if where != InHypValueOnly then (redfun false).e_redfun env sigma (EConstr.of_constr ty) else Sigma.here ty sigma in Sigma (LocalDef (id,b',ty'), sigma, p +> q) @@ -792,20 +792,21 @@ let check_types env sigma mayneedglobalcheck deep newc origc = let sigma, b = infer_conv ~pb:Reduction.CUMUL env sigma t1 t2 in if not b then if - isSort (whd_all env sigma t1) && - isSort (whd_all env sigma t2) + isSort (whd_all env sigma (EConstr.of_constr t1)) && + isSort (whd_all env sigma (EConstr.of_constr t2)) then (mayneedglobalcheck := true; sigma) else user_err ~hdr:"convert-check-hyp" (str "Types are incompatible.") else sigma end else - if not (isSort (whd_all env sigma t1)) then + if not (isSort (whd_all env sigma (EConstr.of_constr t1))) then user_err ~hdr:"convert-check-hyp" (str "Not a type.") else sigma (* Now we introduce different instances of the previous tacticals *) let change_and_check cv_pb mayneedglobalcheck deep t = { e_redfun = begin fun env sigma c -> + let c = EConstr.Unsafe.to_constr c in let Sigma (t', sigma, p) = t.run sigma in let sigma = Sigma.to_evar_map sigma in let sigma = check_types env sigma mayneedglobalcheck deep t' c in @@ -1079,7 +1080,7 @@ let lookup_hypothesis_as_renamed_gen red h gl = match lookup_hypothesis_as_renamed env ccl h with | None when red -> let (redfun, _) = Redexpr.reduction_of_red_expr env (Red true) in - let Sigma (c, _, _) = redfun.e_redfun env (Proofview.Goal.sigma gl) ccl in + let Sigma (c, _, _) = redfun.e_redfun env (Proofview.Goal.sigma gl) (EConstr.of_constr ccl) in aux c | x -> x in @@ -1228,7 +1229,7 @@ let cut c = try (** Backward compat: ensure that [c] is well-typed. *) let typ = Typing.unsafe_type_of env sigma c in - let typ = whd_all env sigma typ in + let typ = whd_all env sigma (EConstr.of_constr typ) in match kind_of_term typ with | Sort _ -> true | _ -> false @@ -1237,7 +1238,7 @@ let cut c = if is_sort then let id = next_name_away_with_default "H" Anonymous (Tacmach.New.pf_ids_of_hyps gl) in (** Backward compat: normalize [c]. *) - let c = if normalize_cut then local_strong whd_betaiota sigma c else c in + let c = if normalize_cut then local_strong whd_betaiota sigma (EConstr.of_constr c) else c in Refine.refine ~unsafe:true { run = begin fun h -> let Sigma (f, h, p) = Evarutil.new_evar ~principal:true env h (mkArrow c (Vars.lift 1 concl)) in let Sigma (x, h, q) = Evarutil.new_evar env h c in @@ -1591,12 +1592,12 @@ let make_projection env sigma params cstr sign elim i n c u = noccur_between 1 (n-i-1) t (* to avoid surprising unifications, excludes flexible projection types or lambda which will be instantiated by Meta/Evar *) - && not (isEvar (fst (whd_betaiota_stack sigma t))) + && not (EConstr.isEvar sigma (fst (whd_betaiota_stack sigma (EConstr.of_constr t)))) && (accept_universal_lemma_under_conjunctions () || not (isRel t)) then let t = lift (i+1-n) t in - let abselim = beta_applist (elim,params@[t;branch]) in - let c = beta_applist (abselim, [mkApp (c, Context.Rel.to_extended_vect 0 sign)]) in + let abselim = beta_applist sigma (EConstr.of_constr elim, List.map EConstr.of_constr (params@[t;branch])) in + let c = beta_applist sigma (EConstr.of_constr abselim, [EConstr.of_constr (mkApp (c, Context.Rel.to_extended_vect 0 sign))]) in Some (it_mkLambda_or_LetIn c sign, it_mkProd_or_LetIn t sign) else None @@ -1630,7 +1631,7 @@ let descend_in_conjunctions avoid tac (err, info) c = | Some (_,_,isrec) -> let n = (constructors_nrealargs ind).(0) in let sort = Tacticals.New.elimination_sort_of_goal gl in - let IndType (indf,_) = find_rectype env sigma ccl in + let IndType (indf,_) = find_rectype env sigma (EConstr.of_constr ccl) in let (_,inst), params = dest_ind_family indf in let cstr = (get_constructors env indf).(0) in let elim = @@ -1703,7 +1704,7 @@ let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind)) let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in - let thm_ty0 = nf_betaiota sigma (Retyping.get_type_of env sigma c) in + let thm_ty0 = nf_betaiota sigma (EConstr.of_constr (Retyping.get_type_of env sigma c)) in let try_apply thm_ty nprod = try let n = nb_prod_modulo_zeta sigma (EConstr.of_constr thm_ty) - nprod in @@ -1716,7 +1717,7 @@ let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind)) let rec try_red_apply thm_ty (exn0, info) = try (* Try to head-reduce the conclusion of the theorem *) - let red_thm = try_red_product env sigma thm_ty in + let red_thm = try_red_product env sigma (EConstr.of_constr thm_ty) in tclORELSEOPT (try_apply red_thm concl_nprod) (function (e, info) -> match e with @@ -1829,7 +1830,7 @@ let progress_with_clause flags innerclause clause = with Not_found -> error "Unable to unify." let apply_in_once_main flags innerclause env sigma (d,lbind) = - let thm = nf_betaiota sigma (Retyping.get_type_of env sigma d) in + let thm = nf_betaiota sigma (EConstr.of_constr (Retyping.get_type_of env sigma d)) in let rec aux clause = try progress_with_clause flags innerclause clause with e when CErrors.noncritical e -> @@ -2127,7 +2128,7 @@ let apply_type newcl args = let env = Proofview.Goal.env gl in let store = Proofview.Goal.extra gl in Refine.refine { run = begin fun sigma -> - let newcl = nf_betaiota (Sigma.to_evar_map sigma) newcl (* As in former Logic.refine *) in + let newcl = nf_betaiota (Sigma.to_evar_map sigma) (EConstr.of_constr newcl) (* As in former Logic.refine *) in let Sigma (ev, sigma, p) = Evarutil.new_evar env sigma ~principal:true ~store newcl in Sigma (applist (ev, args), sigma, p) @@ -2318,7 +2319,7 @@ let rewrite_hyp_then assert_style with_evars thin l2r id tac = let sigma = Tacmach.New.project gl in let type_of = Tacmach.New.pf_unsafe_type_of gl in let whd_all = Tacmach.New.pf_apply whd_all gl in - let t = whd_all (type_of (mkVar id)) in + let t = whd_all (EConstr.of_constr (type_of (mkVar id))) in let eqtac, thin = match match_with_equality_type sigma t with | Some (hdcncl,[_;lhs;rhs]) -> if l2r && isVar lhs && not (occur_var env sigma (destVar lhs) (EConstr.of_constr rhs)) then @@ -2905,13 +2906,13 @@ let specialize (c,lbind) ipat = let clause = make_clenv_binding env sigma (c,Retyping.get_type_of env sigma 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 (thd,tstack) = whd_nored_stack clause.evd (EConstr.of_constr (clenv_value clause)) in let rec chk = function | [] -> [] - | t::l -> if occur_meta clause.evd (EConstr.of_constr t) then [] else t :: chk l + | t::l -> if occur_meta clause.evd t then [] else EConstr.Unsafe.to_constr t :: chk l in let tstack = chk tstack in - let term = applist(thd,List.map (nf_evar clause.evd) tstack) in + let term = applist(EConstr.Unsafe.to_constr thd,List.map (nf_evar clause.evd) tstack) in if occur_meta clause.evd (EConstr.of_constr term) then user_err (str "Cannot infer an instance for " ++ @@ -2964,7 +2965,7 @@ let unfold_body x = in Tacticals.New.afterHyp x begin fun aft -> let hl = List.fold_right (fun decl cl -> (NamedDecl.get_id decl, InHyp) :: cl) aft [] in - let rfun _ _ c = replace_vars [x, xval] c in + let rfun _ _ c = replace_vars [x, xval] (EConstr.Unsafe.to_constr c) in let reducth h = reduct_in_hyp rfun h in let reductc = reduct_in_concl (rfun, DEFAULTcast) in Tacticals.New.tclTHENLIST [Tacticals.New.tclMAP reducth hl; reductc] @@ -3519,7 +3520,7 @@ let decompose_indapp f args = let mk_term_eq env sigma ty t ty' t' = let sigma = Sigma.to_evar_map sigma in - if Reductionops.is_conv env sigma ty ty' then + if Reductionops.is_conv env sigma (EConstr.of_constr ty) (EConstr.of_constr ty') then mkEq ty t t', mkRefl ty' t' else mkHEq ty t ty' t', mkHRefl ty' t' @@ -3615,7 +3616,7 @@ let abstract_args gl generalize_vars dep id defined f args = *) let aux (prod, ctx, ctxenv, c, args, eqs, refls, nongenvars, vars, env) arg = let name, ty, arity = - let rel, c = Reductionops.splay_prod_n env !sigma 1 prod in + let rel, c = Reductionops.splay_prod_n env !sigma 1 (EConstr.of_constr prod) in let decl = List.hd rel in RelDecl.get_name decl, RelDecl.get_type decl, c in @@ -3765,8 +3766,8 @@ let specialize_eqs id gl = in let ty' = it_mkProd_or_LetIn ty ctx'' in let acc' = it_mkLambda_or_LetIn acc ctx'' in - let ty' = Tacred.whd_simpl env !evars ty' - and acc' = Tacred.whd_simpl env !evars acc' in + let ty' = Tacred.whd_simpl env !evars (EConstr.of_constr ty') + and acc' = Tacred.whd_simpl env !evars (EConstr.of_constr acc') in let ty' = Evarutil.nf_evar !evars ty' in if worked then tclTHENFIRST (Tacmach.internal_cut true id ty') @@ -4244,7 +4245,7 @@ let use_bindings env sigma elim must_be_closed (c,lbind) typ = known only by pattern-matching, as in the case of a term of the form "nat_rect ?A ?o ?s n", with ?A to be inferred by matching. *) - let sign,t = splay_prod env sigma typ in it_mkProd t sign + let sign,t = splay_prod env sigma (EConstr.of_constr typ) in it_mkProd t sign else (* Otherwise, we exclude the case of an induction argument in an explicitly functional type. Henceforth, we can complete the @@ -4261,14 +4262,14 @@ let use_bindings env sigma elim must_be_closed (c,lbind) typ = let (sigma, c) = pose_all_metas_as_evars env indclause.evd (clenv_value indclause) in Sigma.Unsafe.of_pair (c, sigma) with e when catchable_exception e -> - try find_clause (try_red_product env sigma typ) + try find_clause (try_red_product env sigma (EConstr.of_constr typ)) with Redelimination -> raise e in find_clause typ let check_expected_type env sigma (elimc,bl) elimt = (* Compute the expected template type of the term in case a using clause is given *) - let sign,_ = splay_prod env sigma elimt in + let sign,_ = splay_prod env sigma (EConstr.of_constr elimt) in let n = List.length sign in if n == 0 then error "Scheme cannot be applied."; let sigma,cl = make_evar_clause env sigma ~len:(n - 1) elimt in @@ -4283,7 +4284,7 @@ let check_enough_applied env sigma elim = | None -> (* No eliminator given *) fun u -> - let t,_ = decompose_app (whd_all env sigma u) in isInd t + let t,_ = decompose_app (whd_all env sigma (EConstr.of_constr u)) in isInd t | Some elimc -> let elimt = Retyping.get_type_of env sigma (fst elimc) in let scheme = compute_elim_sig ~elimc elimt in @@ -4604,7 +4605,7 @@ let maybe_betadeltaiota_concl allowred gl = if not allowred then concl else let env = Proofview.Goal.env gl in - whd_all env sigma concl + whd_all env sigma (EConstr.of_constr concl) let reflexivity_red allowred = Proofview.Goal.enter { enter = begin fun gl -> diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 7acfb62864..2684531529 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -128,7 +128,7 @@ val exact_proof : Constrexpr.constr_expr -> unit Proofview.tactic (** {6 Reduction tactics. } *) -type tactic_reduction = env -> evar_map -> constr -> constr +type tactic_reduction = env -> evar_map -> EConstr.t -> constr type change_arg = patvar_map -> constr Sigma.run -- cgit v1.2.3 From d528fdaf12b74419c47698cca7c6f1ec762245a3 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 4 Nov 2016 14:48:36 +0100 Subject: Retyping API using EConstr. --- tactics/class_tactics.ml | 4 ++-- tactics/contradiction.ml | 2 +- tactics/eqschemes.ml | 2 +- tactics/equality.ml | 24 ++++++++++++------------ tactics/hints.ml | 2 +- tactics/inv.ml | 4 ++-- tactics/tacticals.ml | 8 ++++---- tactics/tactics.ml | 44 ++++++++++++++++++++++---------------------- 8 files changed, 45 insertions(+), 45 deletions(-) (limited to 'tactics') diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index fe7a09f77d..6fb90e7af3 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -280,7 +280,7 @@ let clenv_of_prods poly nprods (c, clenv) gl = if poly || Int.equal nprods 0 then Some (None, clenv) else let sigma = Tacmach.New.project gl in - let ty = Retyping.get_type_of (Proofview.Goal.env gl) sigma c in + let ty = Retyping.get_type_of (Proofview.Goal.env gl) sigma (EConstr.of_constr c) in let diff = nb_prod sigma (EConstr.of_constr ty) - nprods in if Pervasives.(>=) diff 0 then (* Was Some clenv... *) @@ -473,7 +473,7 @@ let catchable = function let pr_depth l = prlist_with_sep (fun () -> str ".") int (List.rev l) let is_Prop env sigma concl = - let ty = Retyping.get_type_of env sigma concl in + let ty = Retyping.get_type_of env sigma (EConstr.of_constr concl) in match kind_of_term ty with | Sort (Prop Null) -> true | _ -> false diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index b9704b846f..789028ac15 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -28,7 +28,7 @@ let absurd c = let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let sigma = Sigma.to_evar_map sigma in - let j = Retyping.get_judgment_of env sigma c in + let j = Retyping.get_judgment_of env sigma (EConstr.of_constr c) in let sigma, j = Coercion.inh_coerce_to_sort Loc.ghost env sigma j in let t = j.Environ.utj_val in let tac = diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml index aea3ca17ec..92480e253b 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -596,7 +596,7 @@ let build_r2l_forward_rew_scheme dep env ind kind = (**********************************************************************) let fix_r2l_forward_rew_scheme (c, ctx') = - let t = Retyping.get_type_of (Global.env()) Evd.empty c in + let t = Retyping.get_type_of (Global.env()) Evd.empty (EConstr.of_constr c) in let ctx,_ = decompose_prod_assum t in match ctx with | hp :: p :: ind :: indargs -> diff --git a/tactics/equality.ml b/tactics/equality.ml index 48f46b36be..e87746a28e 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -440,7 +440,7 @@ let general_rewrite_ebindings_clause cls lft2rgt occs frzevars dep_proof_ok ?tac Proofview.Goal.enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in - let ctype = get_type_of env sigma c in + let ctype = get_type_of env sigma (EConstr.of_constr c) in let rels, t = decompose_prod_assum (whd_betaiotazeta sigma (EConstr.of_constr ctype)) in match match_with_equality_type sigma t with | Some (hdcncl,args) -> (* Fast path: direct leibniz-like rewrite *) @@ -621,8 +621,8 @@ let replace_using_leibniz clause c1 c2 l2r unsafe try_prove_eq_opt = in Proofview.Goal.enter { enter = begin fun gl -> let get_type_of = pf_apply get_type_of gl in - let t1 = get_type_of c1 - and t2 = get_type_of c2 in + let t1 = get_type_of (EConstr.of_constr c1) + and t2 = get_type_of (EConstr.of_constr c2) in let evd = if unsafe then Some (Tacmach.New.project gl) else @@ -719,8 +719,8 @@ let find_positions env sigma t1 t2 = let project env sorts posn t1 t2 = let t1 = EConstr.Unsafe.to_constr t1 in let t2 = EConstr.Unsafe.to_constr t2 in - let ty1 = get_type_of env sigma t1 in - let s = get_sort_family_of env sigma ty1 in + let ty1 = get_type_of env sigma (EConstr.of_constr t1) in + let s = get_sort_family_of env sigma (EConstr.of_constr ty1) in if Sorts.List.mem s sorts then [(List.rev posn,t1,t2)] else [] in @@ -842,7 +842,7 @@ let injectable env sigma t1 t2 = let descend_then env sigma head dirn = let IndType (indf,_) = - try find_rectype env sigma (EConstr.of_constr (get_type_of env sigma head)) + try find_rectype env sigma (EConstr.of_constr (get_type_of env sigma (EConstr.of_constr head))) with Not_found -> error "Cannot project on an inductive type derived from a dependency." in let indp,_ = (dest_ind_family indf) in @@ -897,7 +897,7 @@ let build_selector env sigma dirn c ind special default = dependent types.") in let (indp,_) = dest_ind_family indf in let ind, _ = check_privacy env indp in - let typ = Retyping.get_type_of env sigma default in + let typ = Retyping.get_type_of env sigma (EConstr.of_constr default) in let (mib,mip) = lookup_mind_specif env ind in let deparsign = make_arity_signature env true indf in let p = it_mkLambda_or_LetIn typ deparsign in @@ -912,7 +912,7 @@ let build_selector env sigma dirn c ind special default = let rec build_discriminator env sigma dirn c = function | [] -> - let ind = get_type_of env sigma c in + let ind = get_type_of env sigma (EConstr.of_constr c) in let true_0,false_0 = build_coq_True(),build_coq_False() in build_selector env sigma dirn c ind true_0 false_0 @@ -1084,7 +1084,7 @@ let find_sigma_data env s = build_sigma_type () let make_tuple env sigma (rterm,rty) lind = assert (not (EConstr.Vars.noccurn sigma lind (EConstr.of_constr rty))); - let sigdata = find_sigma_data env (get_sort_of env sigma rty) in + let sigdata = find_sigma_data env (get_sort_of env sigma (EConstr.of_constr rty)) in let sigma, a = type_of ~refresh:true env sigma (mkRel lind) in let na = Context.Rel.Declaration.get_name (lookup_rel lind env) in (* We move [lind] to [1] and lift other rels > [lind] by 1 *) @@ -1262,7 +1262,7 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt = let make_iterated_tuple env sigma dflt (z,zty) = let (zty,rels) = minimal_free_rels_rec env sigma (z,zty) in - let sort_of_zty = get_sort_of env sigma zty in + let sort_of_zty = get_sort_of env sigma (EConstr.of_constr zty) in let sorted_rels = Int.Set.elements rels in let sigma, (tuple,tuplety) = List.fold_left (fun (sigma, t) -> make_tuple env sigma t) (sigma, (z,zty)) sorted_rels @@ -1533,7 +1533,7 @@ let decomp_tuple_term env sigma c t = let subst_tuple_term env sigma dep_pair1 dep_pair2 b = let sigma = Sigma.to_evar_map sigma in - let typ = get_type_of env sigma dep_pair1 in + let typ = get_type_of env sigma (EConstr.of_constr dep_pair1) in (* We find all possible decompositions *) let decomps1 = decomp_tuple_term env sigma dep_pair1 typ in let decomps2 = decomp_tuple_term env sigma dep_pair2 typ in @@ -1623,7 +1623,7 @@ let cutRewriteInConcl l2r eqn = cutRewriteClause l2r eqn None let substClause l2r c cls = Proofview.Goal.enter { enter = begin fun gl -> - let eq = pf_apply get_type_of gl c in + let eq = pf_apply get_type_of gl (EConstr.of_constr c) in tclTHENS (cutSubstClause l2r eq cls) [Proofview.tclUNIT (); exact_no_check c] end } diff --git a/tactics/hints.ml b/tactics/hints.ml index c41f88ab7f..2aa4347779 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -846,7 +846,7 @@ let fresh_global_or_constr env sigma poly cr = let make_resolves env sigma flags pri poly ?name cr = let c, ctx = fresh_global_or_constr env sigma poly cr in - let cty = Retyping.get_type_of env sigma c in + let cty = Retyping.get_type_of env sigma (EConstr.of_constr c) in let try_apply f = try Some (f (c, cty, ctx)) with Failure _ -> None in let ents = List.map_filter try_apply diff --git a/tactics/inv.ml b/tactics/inv.ml index 0b2d2f0b2f..38f75995b9 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -65,7 +65,7 @@ let var_occurs_in_pf gl id = type inversion_status = Dep of constr option | NoDep let compute_eqn env sigma n i ai = - (mkRel (n-i),get_type_of env sigma (mkRel (n-i))) + (mkRel (n-i),get_type_of env sigma (EConstr.of_constr (mkRel (n-i)))) let make_inv_predicate env evd indf realargs id status concl = let nrealargs = List.length realargs in @@ -86,7 +86,7 @@ let make_inv_predicate env evd indf realargs id status concl = match dflt_concl with | Some concl -> concl (*assumed it's some [x1..xn,H:I(x1..xn)]C*) | None -> - let sort = get_sort_family_of env !evd concl in + let sort = get_sort_family_of env !evd (EConstr.of_constr concl) in let sort = Evarutil.evd_comb1 (Evd.fresh_sort_in_family env) evd sort in let p = make_arity env true indf sort in let evd',(p,ptyp) = Unification.abstract_list_all env diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index 676b23d095..2754db0101 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -248,10 +248,10 @@ let compute_constructor_signatures isrec ((_,k as ity),u) = Array.map2 analrec lc lrecargs let elimination_sort_of_goal gl = - pf_apply Retyping.get_sort_family_of gl (pf_concl gl) + pf_apply Retyping.get_sort_family_of gl (EConstr.of_constr (pf_concl gl)) let elimination_sort_of_hyp id gl = - pf_apply Retyping.get_sort_family_of gl (pf_get_hyp_typ gl id) + pf_apply Retyping.get_sort_family_of gl (EConstr.of_constr (pf_get_hyp_typ gl id)) let elimination_sort_of_clause = function | None -> elimination_sort_of_goal @@ -708,12 +708,12 @@ module New = struct let elimination_sort_of_goal gl = (** Retyping will expand evars anyway. *) let c = Proofview.Goal.concl (Goal.assume gl) in - pf_apply Retyping.get_sort_family_of gl c + pf_apply Retyping.get_sort_family_of gl (EConstr.of_constr c) let elimination_sort_of_hyp id gl = (** Retyping will expand evars anyway. *) let c = pf_get_hyp_typ id (Goal.assume gl) in - pf_apply Retyping.get_sort_family_of gl c + pf_apply Retyping.get_sort_family_of gl (EConstr.of_constr c) let elimination_sort_of_clause id gl = match id with | None -> elimination_sort_of_goal gl diff --git a/tactics/tactics.ml b/tactics/tactics.ml index c96553fae5..e294f928eb 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -412,7 +412,7 @@ let default_id env sigma decl = let open Context.Rel.Declaration in match decl with | LocalAssum (name,t) -> - let dft = default_id_of_sort (Retyping.get_sort_of env sigma t) in + let dft = default_id_of_sort (Retyping.get_sort_of env sigma (EConstr.of_constr t)) in id_of_name_with_default dft name | LocalDef (name,b,_) -> id_of_name_using_hdchar env b name @@ -784,9 +784,9 @@ let make_change_arg c pats = { run = fun sigma -> Sigma.here (replace_vars (Id.Map.bindings pats) c) sigma } let check_types env sigma mayneedglobalcheck deep newc origc = - let t1 = Retyping.get_type_of env sigma newc in + let t1 = Retyping.get_type_of env sigma (EConstr.of_constr newc) in if deep then begin - let t2 = Retyping.get_type_of env sigma origc in + let t2 = Retyping.get_type_of env sigma (EConstr.of_constr 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 @@ -1341,7 +1341,7 @@ let enforce_prop_bound_names rename tac = | Prod (Name _ as na,t,t') -> let very_standard = true in let na = - if Retyping.get_sort_family_of env sigma t = InProp then + if Retyping.get_sort_family_of env sigma (EConstr.of_constr t) = InProp then (* "very_standard" says that we should have "H" names only, but this would break compatibility even more... *) let s = match Namegen.head_name t with @@ -1411,7 +1411,7 @@ let general_elim_clause_gen elimtac indclause elim = let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let (elimc,lbindelimc) = elim.elimbody in - let elimt = Retyping.get_type_of env sigma elimc in + let elimt = Retyping.get_type_of env sigma (EConstr.of_constr elimc) in let i = match elim.elimindex with None -> index_of_ind_arg elimt | Some i -> i in elimtac elim.elimrename i (elimc, elimt, lbindelimc) indclause @@ -1421,7 +1421,7 @@ let general_elim with_evars clear_flag (c, lbindc) elim = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in - let ct = Retyping.get_type_of env sigma c in + let ct = Retyping.get_type_of env sigma (EConstr.of_constr c) in let t = try snd (reduce_to_quantified_ind env sigma ct) with UserError _ -> ct in let elimtac = elimination_clause_scheme with_evars in let indclause = make_clenv_binding env sigma (c, t) lbindc in @@ -1439,7 +1439,7 @@ let general_case_analysis_in_context with_evars clear_flag (c,lbindc) = let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl gl in - let t = Retyping.get_type_of env (Sigma.to_evar_map sigma) c in + let t = Retyping.get_type_of env (Sigma.to_evar_map sigma) (EConstr.of_constr c) in let (mind,_) = reduce_to_quantified_ind env (Sigma.to_evar_map sigma) t in let sort = Tacticals.New.elimination_sort_of_goal gl in let Sigma (elim, sigma, p) = @@ -1554,7 +1554,7 @@ let elimination_in_clause_scheme with_evars ?(flags=elim_flags ()) (str "The type of elimination clause is not well-formed.") in let elimclause' = clenv_fchain ~flags indmv elimclause indclause in let hyp = mkVar id in - let hyp_typ = Retyping.get_type_of env sigma hyp in + let hyp_typ = Retyping.get_type_of env sigma (EConstr.of_constr hyp) in let hypclause = mk_clenv_from_env env sigma (Some 0) (hyp, hyp_typ) in let elimclause'' = clenv_fchain_in id ~flags hypmv elimclause' hypclause in let new_hyp_typ = clenv_type elimclause'' in @@ -1614,7 +1614,7 @@ let make_projection env sigma params cstr sign elim i n c u = [|mkApp (c, args)|]) in let app = it_mkLambda_or_LetIn proj sign in - let t = Retyping.get_type_of env sigma app in + let t = Retyping.get_type_of env sigma (EConstr.of_constr app) in Some (app, t) | None -> None in elim @@ -1624,7 +1624,7 @@ let descend_in_conjunctions avoid tac (err, info) c = let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in try - let t = Retyping.get_type_of env sigma c in + let t = Retyping.get_type_of env sigma (EConstr.of_constr c) in let ((ind,u),t) = reduce_to_quantified_ind env sigma t in let sign,ccl = decompose_prod_assum t in match match_with_tuple sigma ccl with @@ -1704,7 +1704,7 @@ let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind)) let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in - let thm_ty0 = nf_betaiota sigma (EConstr.of_constr (Retyping.get_type_of env sigma c)) in + let thm_ty0 = nf_betaiota sigma (EConstr.of_constr (Retyping.get_type_of env sigma (EConstr.of_constr c))) in let try_apply thm_ty nprod = try let n = nb_prod_modulo_zeta sigma (EConstr.of_constr thm_ty) - nprod in @@ -1830,7 +1830,7 @@ let progress_with_clause flags innerclause clause = with Not_found -> error "Unable to unify." let apply_in_once_main flags innerclause env sigma (d,lbind) = - let thm = nf_betaiota sigma (EConstr.of_constr (Retyping.get_type_of env sigma d)) in + let thm = nf_betaiota sigma (EConstr.of_constr (Retyping.get_type_of env sigma (EConstr.of_constr d))) in let rec aux clause = try progress_with_clause flags innerclause clause with e when CErrors.noncritical e -> @@ -2604,7 +2604,7 @@ let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty = let Sigma (t, sigma, p) = match ty with | Some t -> Sigma.here t sigma | None -> - let t = typ_of env sigma c in + let t = typ_of env sigma (EConstr.of_constr c) in let sigma, c = Evarsolve.refresh_universes ~onlyalg:true (Some false) env (Sigma.to_evar_map sigma) t in Sigma.Unsafe.of_pair (c, sigma) in @@ -2656,7 +2656,7 @@ let insert_before decls lasthyp env = let mkletin_goal env sigma store with_eq dep (id,lastlhyp,ccl,c) ty = let open Context.Named.Declaration in - let t = match ty with Some t -> t | _ -> typ_of env sigma c in + let t = match ty with Some t -> t | _ -> typ_of env sigma (EConstr.of_constr c) in let decl = if dep then LocalDef (id,c,t) else LocalAssum (id,t) in @@ -2903,7 +2903,7 @@ let specialize (c,lbind) ipat = let sigma = Typeclasses.resolve_typeclasses env sigma in sigma, nf_evar sigma c else - let clause = make_clenv_binding env sigma (c,Retyping.get_type_of env sigma c) lbind in + let clause = make_clenv_binding env sigma (c,Retyping.get_type_of env sigma (EConstr.of_constr 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 (EConstr.of_constr (clenv_value clause)) in @@ -2919,7 +2919,7 @@ let specialize (c,lbind) ipat = pr_name (meta_name clause.evd (List.hd (collect_metas clause.evd (EConstr.of_constr term)))) ++ str "."); clause.evd, term in - let typ = Retyping.get_type_of env sigma term in + let typ = Retyping.get_type_of env sigma (EConstr.of_constr term) in let tac = match kind_of_term (fst(decompose_app (snd(decompose_lam_assum c)))) with | Var id when Id.List.mem id (Tacmach.New.pf_ids_of_hyps gl) -> @@ -3152,7 +3152,7 @@ let expand_projections env sigma c = let sigma = Sigma.to_evar_map sigma in let rec aux env c = match EConstr.kind sigma c with - | Proj (p, c) -> EConstr.of_constr (Retyping.expand_projection env sigma p (EConstr.Unsafe.to_constr (aux env c)) []) + | Proj (p, c) -> EConstr.of_constr (Retyping.expand_projection env sigma p (aux env c) []) | _ -> map_constr_with_full_binders sigma push_rel aux env c in EConstr.Unsafe.to_constr (aux env (EConstr.of_constr c)) @@ -3673,7 +3673,7 @@ let abstract_args gl generalize_vars dep id defined f args = else [] in let body, c' = - if defined then Some c', Retyping.get_type_of ctxenv !sigma c' + if defined then Some c', Retyping.get_type_of ctxenv !sigma (EConstr.of_constr c') else None, c' in let typ = Tacmach.pf_get_hyp_typ gl id in @@ -4132,7 +4132,7 @@ let apply_induction_in_context with_evars hyp0 inhyps elim indvars names induct_ let dep_in_concl = Option.cata (fun id -> occur_var env sigma id (EConstr.of_constr concl)) false hyp0 in let dep = dep_in_hyps || dep_in_concl in let tmpcl = it_mkNamedProd_or_LetIn concl deps in - let s = Retyping.get_sort_family_of env sigma tmpcl in + let s = Retyping.get_sort_family_of env sigma (EConstr.of_constr tmpcl) in let deps_cstr = List.fold_left (fun a decl -> if NamedDecl.is_local_assum decl then (mkVar (NamedDecl.get_id decl))::a else a) [] deps in @@ -4286,7 +4286,7 @@ let check_enough_applied env sigma elim = fun u -> let t,_ = decompose_app (whd_all env sigma (EConstr.of_constr u)) in isInd t | Some elimc -> - let elimt = Retyping.get_type_of env sigma (fst elimc) in + let elimt = Retyping.get_type_of env sigma (EConstr.of_constr (fst elimc)) in let scheme = compute_elim_sig ~elimc elimt in match scheme.indref with | None -> @@ -4331,7 +4331,7 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim Refine.refine ~unsafe:true { run = begin fun sigma -> let b = not with_evars && with_eq != None in let Sigma (c, sigma, p) = use_bindings env sigma elim b (c0,lbind) t0 in - let t = Retyping.get_type_of env (Sigma.to_evar_map sigma) c in + let t = Retyping.get_type_of env (Sigma.to_evar_map sigma) (EConstr.of_constr c) in let Sigma (ans, sigma, q) = mkletin_goal env sigma store with_eq false (id,lastlhyp,ccl,c) (Some t) in Sigma (ans, sigma, p +> q) end }; @@ -4376,7 +4376,7 @@ let induction_gen clear_flag isrec with_evars elim let sigma = Proofview.Goal.sigma gl in let ccl = Proofview.Goal.raw_concl gl in let cls = Option.default allHypsAndConcl cls in - let t = typ_of env sigma c in + let t = typ_of env sigma (EConstr.of_constr c) in let is_arg_pure_hyp = isVar c && not (mem_named_context_val (destVar c) (Global.named_context_val ())) && lbind == NoBindings && not with_evars && Option.is_empty eqname -- cgit v1.2.3 From 83607f75a13ea915affa8cfc5bfc14cc944c61ef Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 5 Nov 2016 18:45:55 +0100 Subject: Find_subterm API using EConstr. --- tactics/tactics.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'tactics') diff --git a/tactics/tactics.ml b/tactics/tactics.ml index e294f928eb..22d01e4011 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -2772,7 +2772,7 @@ let generalize_goal_gen env sigma ids i ((occs,c,b),na) t cl = let decls,cl = decompose_prod_n_assum i cl in let dummy_prod = EConstr.of_constr (it_mkProd_or_LetIn mkProp decls) in let newdecls,_ = decompose_prod_n_assum i (subst_term_gen sigma EConstr.eq_constr_nounivs (EConstr.of_constr c) dummy_prod) in - let cl',sigma' = subst_closed_term_occ env sigma (AtOccs occs) c (it_mkProd_or_LetIn cl newdecls) in + let cl',sigma' = subst_closed_term_occ env sigma (AtOccs occs) (EConstr.of_constr c) (EConstr.of_constr (it_mkProd_or_LetIn cl newdecls)) in let na = generalized_name c t ids cl' na in let decl = match b with | None -> LocalAssum (na,t) -- cgit v1.2.3 From b7fd585b89ac5e0b7770f52739c33fe179f2eed8 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 5 Nov 2016 21:36:40 +0100 Subject: Evarsolve API using EConstr. --- tactics/tactics.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'tactics') diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 22d01e4011..1c10cdfea2 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -788,7 +788,7 @@ let check_types env sigma mayneedglobalcheck deep newc origc = if deep then begin let t2 = Retyping.get_type_of env sigma (EConstr.of_constr origc) in let sigma, t2 = Evarsolve.refresh_universes - ~onlyalg:true (Some false) env sigma t2 in + ~onlyalg:true (Some false) env sigma (EConstr.of_constr t2) in let sigma, b = infer_conv ~pb:Reduction.CUMUL env sigma t1 t2 in if not b then if @@ -2604,7 +2604,7 @@ let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty = let Sigma (t, sigma, p) = match ty with | Some t -> Sigma.here t sigma | None -> - let t = typ_of env sigma (EConstr.of_constr c) in + let t = EConstr.of_constr (typ_of env sigma (EConstr.of_constr c)) in let sigma, c = Evarsolve.refresh_universes ~onlyalg:true (Some false) env (Sigma.to_evar_map sigma) t in Sigma.Unsafe.of_pair (c, sigma) in @@ -3621,7 +3621,7 @@ let abstract_args gl generalize_vars dep id defined f args = RelDecl.get_name decl, RelDecl.get_type decl, c in let argty = Tacmach.pf_unsafe_type_of gl arg in - let sigma', ty = Evarsolve.refresh_universes (Some true) env !sigma ty in + let sigma', ty = Evarsolve.refresh_universes (Some true) env !sigma (EConstr.of_constr ty) in let () = sigma := sigma' in let lenctx = List.length ctx in let liftargty = lift lenctx argty in -- cgit v1.2.3 From b365304d32db443194b7eaadda63c784814f53f1 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 6 Nov 2016 03:23:13 +0100 Subject: Evarconv API using EConstr. --- tactics/class_tactics.ml | 4 ++-- tactics/equality.ml | 6 +++--- tactics/tactics.ml | 4 ++-- 3 files changed, 7 insertions(+), 7 deletions(-) (limited to 'tactics') diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 6fb90e7af3..a31e581e85 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -264,7 +264,7 @@ let unify_resolve_refine poly flags = let sigma' = let evdref = ref sigma' in if not (Evarconv.e_cumul env ~ts:flags.core_unify_flags.modulo_delta - evdref cl.cl_concl concl) then + evdref (EConstr.of_constr cl.cl_concl) (EConstr.of_constr concl)) then Type_errors.error_actual_type env {Environ.uj_val = term; Environ.uj_type = cl.cl_concl} concl; @@ -1506,7 +1506,7 @@ let not_evar c = | _ -> Proofview.tclUNIT () let is_ground c gl = - if Evarutil.is_ground_term (project gl) c then tclIDTAC gl + if Evarutil.is_ground_term (project gl) (EConstr.of_constr c) then tclIDTAC gl else tclFAIL 0 (str"Not ground") gl let autoapply c i gl = diff --git a/tactics/equality.ml b/tactics/equality.ml index e87746a28e..17038e42d1 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -626,7 +626,7 @@ let replace_using_leibniz clause c1 c2 l2r unsafe try_prove_eq_opt = let evd = if unsafe then Some (Tacmach.New.project gl) else - try Some (Evarconv.the_conv_x (Proofview.Goal.env gl) t1 t2 (Tacmach.New.project gl)) + try Some (Evarconv.the_conv_x (Proofview.Goal.env gl) (EConstr.of_constr t1) (EConstr.of_constr t2) (Tacmach.New.project gl)) with Evarconv.UnableToUnify _ -> None in match evd with @@ -1167,7 +1167,7 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt = (* is the default value typable with the expected type *) let dflt_typ = unsafe_type_of env sigma dflt in try - let () = evdref := Evarconv.the_conv_x_leq env dflt_typ p_i !evdref in + let () = evdref := Evarconv.the_conv_x_leq env (EConstr.of_constr dflt_typ) (EConstr.of_constr p_i) !evdref in let () = evdref := Evarconv.consider_remaining_unif_problems env !evdref in dflt with Evarconv.UnableToUnify _ -> @@ -1185,7 +1185,7 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt = with | Some w -> let w_type = unsafe_type_of env sigma w in - if Evarconv.e_cumul env evdref w_type a then + if Evarconv.e_cumul env evdref (EConstr.of_constr w_type) (EConstr.of_constr a) then let exist_term = Evarutil.evd_comb1 (Evd.fresh_global env) evdref sigdata.intro in applist(exist_term,[a;p_i_minus_1;w;tuple_tail]) else diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 1c10cdfea2..c2163a274f 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -3731,7 +3731,7 @@ let specialize_eqs id gl = let ty = Tacmach.pf_get_hyp_typ gl id in let evars = ref (project gl) in let unif env evars c1 c2 = - compare_upto_variables c1 c2 && Evarconv.e_conv env evars c1 c2 + compare_upto_variables c1 c2 && Evarconv.e_conv env evars (EConstr.of_constr c1) (EConstr.of_constr c2) in let rec aux in_eqs ctx acc ty = match kind_of_term ty with @@ -4275,7 +4275,7 @@ let check_expected_type env sigma (elimc,bl) elimt = let sigma,cl = make_evar_clause env sigma ~len:(n - 1) elimt in let sigma = solve_evar_clause env sigma true cl bl in let (_,u,_) = destProd cl.cl_concl in - fun t -> Evarconv.e_cumul env (ref sigma) t u + fun t -> Evarconv.e_cumul env (ref sigma) (EConstr.of_constr t) (EConstr.of_constr u) let check_enough_applied env sigma elim = let sigma = Sigma.to_evar_map sigma in -- cgit v1.2.3 From e27949240f5b1ee212e7d0fe3326a21a13c4abb0 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 6 Nov 2016 17:21:44 +0100 Subject: Typing API using EConstr. --- tactics/autorewrite.ml | 4 ++-- tactics/equality.ml | 16 ++++++++-------- tactics/hints.ml | 2 +- tactics/inv.ml | 4 ++-- tactics/tactics.ml | 26 +++++++++++++------------- 5 files changed, 26 insertions(+), 26 deletions(-) (limited to 'tactics') diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index 46600cdd75..80b9ec06e1 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -272,7 +272,7 @@ let decompose_applied_relation metas env sigma c ctype left2right = try 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 + Typing.unsafe_type_of env eqclause.evd (EConstr.of_constr c1), Typing.unsafe_type_of env eqclause.evd (EConstr.of_constr c2) in (* if not (evd_convertible env eqclause.evd ty1 ty2) then None *) (* else *) @@ -290,7 +290,7 @@ let decompose_applied_relation metas env sigma c ctype left2right = | None -> None let find_applied_relation metas loc env sigma c left2right = - let ctype = Typing.unsafe_type_of env sigma c in + let ctype = Typing.unsafe_type_of env sigma (EConstr.of_constr c) in match decompose_applied_relation metas env sigma c ctype left2right with | Some c -> c | None -> diff --git a/tactics/equality.ml b/tactics/equality.ml index 17038e42d1..58c86ff426 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -1085,7 +1085,7 @@ let find_sigma_data env s = build_sigma_type () let make_tuple env sigma (rterm,rty) lind = assert (not (EConstr.Vars.noccurn sigma lind (EConstr.of_constr rty))); let sigdata = find_sigma_data env (get_sort_of env sigma (EConstr.of_constr rty)) in - let sigma, a = type_of ~refresh:true env sigma (mkRel lind) in + let sigma, a = type_of ~refresh:true env sigma (EConstr.mkRel lind) in let na = Context.Rel.Declaration.get_name (lookup_rel lind env) in (* We move [lind] to [1] and lift other rels > [lind] by 1 *) let rty = lift (1-lind) (liftn lind (lind+1) rty) in @@ -1119,7 +1119,7 @@ let minimal_free_rels_rec env sigma = let rec minimalrec_free_rels_rec prev_rels (c,cty) = let (cty,direct_rels) = minimal_free_rels env sigma (c,cty) in let combined_rels = Int.Set.union prev_rels direct_rels in - let folder rels i = snd (minimalrec_free_rels_rec rels (c, unsafe_type_of env sigma (mkRel i))) + let folder rels i = snd (minimalrec_free_rels_rec rels (c, unsafe_type_of env sigma (EConstr.mkRel i))) in (cty, List.fold_left folder combined_rels (Int.Set.elements (Int.Set.diff direct_rels prev_rels))) in minimalrec_free_rels_rec Int.Set.empty @@ -1165,7 +1165,7 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt = let rec sigrec_clausal_form siglen p_i = if Int.equal siglen 0 then (* is the default value typable with the expected type *) - let dflt_typ = unsafe_type_of env sigma dflt in + let dflt_typ = unsafe_type_of env sigma (EConstr.of_constr dflt) in try let () = evdref := Evarconv.the_conv_x_leq env (EConstr.of_constr dflt_typ) (EConstr.of_constr p_i) !evdref in let () = evdref := Evarconv.consider_remaining_unif_problems env !evdref in @@ -1184,7 +1184,7 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt = (destEvar ev) with | Some w -> - let w_type = unsafe_type_of env sigma w in + let w_type = unsafe_type_of env sigma (EConstr.of_constr w) in if Evarconv.e_cumul env evdref (EConstr.of_constr w_type) (EConstr.of_constr a) then let exist_term = Evarutil.evd_comb1 (Evd.fresh_global env) evdref sigdata.intro in applist(exist_term,[a;p_i_minus_1;w;tuple_tail]) @@ -1273,7 +1273,7 @@ let make_iterated_tuple env sigma dflt (z,zty) = sigma, (tuple,tuplety,dfltval) let rec build_injrec env sigma dflt c = function - | [] -> make_iterated_tuple env sigma dflt (c,unsafe_type_of env sigma c) + | [] -> make_iterated_tuple env sigma dflt (c,unsafe_type_of env sigma (EConstr.of_constr c)) | ((sp,cnum),argnum)::l -> try let (cnum_nlams,cnum_env,kont) = descend_then env sigma c cnum in @@ -1367,7 +1367,7 @@ let inject_at_positions env sigma l2r (eq,_,(t,t1,t2)) eq_clause posns tac = let injfun = mkNamedLambda e t injbody in let sigma,congr = Evd.fresh_global env sigma eq.congr in let pf = applist(congr,[t;resty;injfun;t1;t2]) in - let sigma, pf_typ = Typing.type_of env sigma pf in + let sigma, pf_typ = Typing.type_of env sigma (EConstr.of_constr pf) in let inj_clause = apply_on_clause (pf,pf_typ) eq_clause in let pf = Clenvtac.clenv_value_cast_meta inj_clause in let ty = simplify_args env sigma (clenv_type inj_clause) in @@ -1555,8 +1555,8 @@ let subst_tuple_term env sigma dep_pair1 dep_pair2 b = (* Simulate now the normalisation treatment made by Logic.mk_refgoals *) let expected_goal = nf_betaiota sigma (EConstr.of_constr expected_goal) in (* Retype to get universes right *) - let sigma, expected_goal_ty = Typing.type_of env sigma expected_goal in - let sigma, _ = Typing.type_of env sigma body in + let sigma, expected_goal_ty = Typing.type_of env sigma (EConstr.of_constr expected_goal) in + let sigma, _ = Typing.type_of env sigma (EConstr.of_constr body) in Sigma.Unsafe.of_pair ((body, expected_goal), sigma) (* Like "replace" but decompose dependent equalities *) diff --git a/tactics/hints.ml b/tactics/hints.ml index 2aa4347779..63d10573a9 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -910,7 +910,7 @@ let make_mode ref m = let make_trivial env sigma poly ?(name=PathAny) r = let c,ctx = fresh_global_or_constr env sigma poly r in let sigma = Evd.merge_context_set univ_flexible sigma ctx in - let t = hnf_constr env sigma (EConstr.of_constr (unsafe_type_of env sigma c)) in + let t = hnf_constr env sigma (EConstr.of_constr (unsafe_type_of env sigma (EConstr.of_constr c))) in let hd = head_of_constr_reference (head_constr sigma t) in let ce = mk_clenv_from_env env sigma None (c,t) in (Some hd, { pri=1; diff --git a/tactics/inv.ml b/tactics/inv.ml index 38f75995b9..9282af7590 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -123,13 +123,13 @@ let make_inv_predicate env evd indf realargs id status concl = let refl_term = eqdata.Coqlib.refl in let refl_term = Evarutil.evd_comb1 (Evd.fresh_global env) evd refl_term in let refl = mkApp (refl_term, [|eqnty; rhs|]) in - let _ = Evarutil.evd_comb1 (Typing.type_of env) evd refl in + let _ = Evarutil.evd_comb1 (Typing.type_of env) evd (EConstr.of_constr refl) in let args = refl :: args in build_concl eqns args (succ n) restlist in let (newconcl, args) = build_concl [] [] 0 realargs in let predicate = it_mkLambda_or_LetIn_name env newconcl hyps in - let _ = Evarutil.evd_comb1 (Typing.type_of env) evd predicate in + let _ = Evarutil.evd_comb1 (Typing.type_of env) evd (EConstr.of_constr predicate) in (* OK - this predicate should now be usable by res_elimination_then to do elimination on the conclusion. *) predicate, args diff --git a/tactics/tactics.ml b/tactics/tactics.ml index c2163a274f..8fb47b9942 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -210,7 +210,7 @@ let convert_concl ?(check=true) ty k = let Sigma ((), sigma, p) = if check then begin let sigma = Sigma.to_evar_map sigma in - ignore (Typing.unsafe_type_of env sigma ty); + ignore (Typing.unsafe_type_of env sigma (EConstr.of_constr ty)); let sigma,b = Reductionops.infer_conv env sigma ty conclty in if not b then error "Not convertible."; Sigma.Unsafe.of_pair ((), sigma) @@ -827,7 +827,7 @@ let change_on_subterm cv_pb deep t where = { e_redfun = begin fun env sigma c -> env sigma c in if !mayneedglobalcheck then begin - try ignore (Typing.unsafe_type_of env (Sigma.to_evar_map sigma) c) + try ignore (Typing.unsafe_type_of env (Sigma.to_evar_map sigma) (EConstr.of_constr c)) with e when catchable_exception e -> error "Replacement would lead to an ill-typed term." end; @@ -1228,7 +1228,7 @@ let cut c = let is_sort = try (** Backward compat: ensure that [c] is well-typed. *) - let typ = Typing.unsafe_type_of env sigma c in + let typ = Typing.unsafe_type_of env sigma (EConstr.of_constr c) in let typ = whd_all env sigma (EConstr.of_constr typ) in match kind_of_term typ with | Sort _ -> true @@ -1940,7 +1940,7 @@ let exact_check c = let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in let env = Proofview.Goal.env gl in let sigma = Sigma.to_evar_map sigma in - let sigma, ct = Typing.type_of env sigma c in + let sigma, ct = Typing.type_of env sigma (EConstr.of_constr c) in let tac = Tacticals.New.tclTHEN (convert_leq ct concl) (exact_no_check c) in @@ -2009,20 +2009,20 @@ exception DependsOnBody of Id.t option let check_is_type env sigma ty = let evdref = ref sigma in try - let _ = Typing.e_sort_of env evdref ty in + let _ = Typing.e_sort_of env evdref (EConstr.of_constr ty) in !evdref with e when CErrors.noncritical e -> raise (DependsOnBody None) let check_decl env sigma decl = let open Context.Named.Declaration in - let ty = NamedDecl.get_type decl in + let ty = EConstr.of_constr (NamedDecl.get_type decl) in let evdref = ref sigma in try let _ = Typing.e_sort_of env evdref ty in let _ = match decl with | LocalAssum _ -> () - | LocalDef (_,c,_) -> Typing.e_check env evdref c ty + | LocalDef (_,c,_) -> Typing.e_check env evdref (EConstr.of_constr c) ty in !evdref with e when CErrors.noncritical e -> @@ -2622,7 +2622,7 @@ let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty = let refl = applist (refl, [t;mkVar id]) in let term = mkNamedLetIn id c t (mkLetIn (Name heq, refl, eq, ccl)) in let sigma = Sigma.to_evar_map sigma in - let sigma, _ = Typing.type_of env sigma term in + let sigma, _ = Typing.type_of env sigma (EConstr.of_constr term) in let ans = term, Tacticals.New.tclTHEN (intro_gen (NamingMustBe (loc,heq)) (decode_hyp lastlhyp) true false) @@ -2783,7 +2783,7 @@ let generalize_goal_gen env sigma ids i ((occs,c,b),na) t cl = 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 + let sigma, t = Typing.type_of env sigma (EConstr.of_constr c) in generalize_goal_gen env sigma ids i o t cl let old_generalize_dep ?(with_let=false) c gl = @@ -2818,7 +2818,7 @@ let old_generalize_dep ?(with_let=false) c gl = let cl'',evd = generalize_goal gl 0 ((AllOccurrences,c,body),Anonymous) (cl',project gl) in (** Check that the generalization is indeed well-typed *) - let (evd, _) = Typing.type_of env evd cl'' in + let (evd, _) = Typing.type_of env evd (EConstr.of_constr cl'') in let args = Context.Named.to_instance to_quantify_rev in tclTHENLIST [tclEVARS evd; @@ -2836,7 +2836,7 @@ let generalize_gen_let lconstr = Proofview.Goal.nf_s_enter { s_enter = begin fun List.fold_right_i (Tacmach.New.of_old generalize_goal gl) 0 lconstr (Tacmach.New.pf_concl gl,Tacmach.New.project gl) in - let (evd, _) = Typing.type_of env evd newcl in + let (evd, _) = Typing.type_of env evd (EConstr.of_constr newcl) in let map ((_, c, b),_) = if Option.is_empty b then Some c else None in let tac = apply_type newcl (List.map_filter map lconstr) in Sigma.Unsafe.of_pair (tac, evd) @@ -2853,7 +2853,7 @@ let new_generalize_gen_let lconstr = let newcl, sigma, args = List.fold_right_i (fun i ((_,c,b),_ as o) (cl, sigma, args) -> - let sigma, t = Typing.type_of env sigma c in + let sigma, t = Typing.type_of env sigma (EConstr.of_constr c) in let args = if Option.is_empty b then c :: args else args in let cl, sigma = generalize_goal_gen env sigma ids i o t cl in (cl, sigma, args)) @@ -4738,7 +4738,7 @@ let prove_transitivity hdcncl eq_kind t = let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let type_of = Typing.unsafe_type_of env sigma in - let typt = type_of t in + let typt = type_of (EConstr.of_constr t) in (mkApp(hdcncl, [| typ1; c1; typt ;t |]), mkApp(hdcncl, [| typt; t; typ2; c2 |])) in -- cgit v1.2.3 From 77e638121b6683047be915da9d0499a58fcb6e52 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 6 Nov 2016 19:30:24 +0100 Subject: Patternops API using EConstr. --- tactics/hints.ml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) (limited to 'tactics') diff --git a/tactics/hints.ml b/tactics/hints.ml index 63d10573a9..b2aa02191e 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -746,7 +746,7 @@ let make_exact_entry env sigma pri poly ?(name=PathAny) (c, cty, ctx) = match kind_of_term cty with | Prod _ -> failwith "make_exact_entry" | _ -> - let pat = Patternops.pattern_of_constr env sigma cty in + let pat = Patternops.pattern_of_constr env sigma (EConstr.of_constr cty) in let hd = try head_pattern_bound pat with BoundPattern -> failwith "make_exact_entry" @@ -767,7 +767,7 @@ let make_apply_entry env sigma (eapply,hnf,verbose) pri poly ?(name=PathAny) (c, let sigma' = Evd.merge_context_set univ_flexible sigma ctx in let ce = mk_clenv_from_env env sigma' None (c,cty) in let c' = clenv_type (* ~reduce:false *) ce in - let pat = Patternops.pattern_of_constr env ce.evd c' in + let pat = Patternops.pattern_of_constr env ce.evd (EConstr.of_constr c') in let hd = try head_pattern_bound pat with BoundPattern -> failwith "make_apply_entry" in @@ -911,11 +911,11 @@ let make_trivial env sigma poly ?(name=PathAny) r = let c,ctx = fresh_global_or_constr env sigma poly r in let sigma = Evd.merge_context_set univ_flexible sigma ctx in let t = hnf_constr env sigma (EConstr.of_constr (unsafe_type_of env sigma (EConstr.of_constr c))) in - let hd = head_of_constr_reference (head_constr sigma t) in + let hd = head_of_constr_reference sigma (EConstr.of_constr (head_constr sigma t)) in let ce = mk_clenv_from_env env sigma None (c,t) in (Some hd, { pri=1; poly = poly; - pat = Some (Patternops.pattern_of_constr env ce.evd (clenv_type ce)); + pat = Some (Patternops.pattern_of_constr env ce.evd (EConstr.of_constr (clenv_type ce))); name = name; db = None; secvars = secvars_of_constr env c; @@ -1013,7 +1013,7 @@ let subst_autohint (subst, obj) = let subst_key gr = let (lab'', elab') = subst_global subst gr in let gr' = - (try head_of_constr_reference (head_constr_bound Evd.empty (** FIXME *) elab') + (try head_of_constr_reference Evd.empty (EConstr.of_constr (head_constr_bound Evd.empty (** FIXME *) elab')) with Bound -> lab'') in if gr' == gr then gr else gr' in -- cgit v1.2.3 From 258c8502eafd3e078a5c7478a452432b5c046f71 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 6 Nov 2016 19:59:28 +0100 Subject: Constr_matching API using EConstr. --- tactics/auto.ml | 2 +- tactics/class_tactics.ml | 2 +- tactics/hipattern.ml | 4 ++-- 3 files changed, 4 insertions(+), 4 deletions(-) (limited to 'tactics') diff --git a/tactics/auto.ml b/tactics/auto.ml index 17fe7362d2..7462b8d855 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -139,7 +139,7 @@ let conclPattern concl pat tac = | None -> Proofview.tclUNIT Id.Map.empty | Some pat -> try - Proofview.tclUNIT (Constr_matching.matches env sigma pat concl) + Proofview.tclUNIT (Constr_matching.matches env sigma pat (EConstr.of_constr concl)) with Constr_matching.PatternMatchingFailure -> Tacticals.New.tclZEROMSG (str "conclPattern") in diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index a31e581e85..bef43d20b4 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -305,7 +305,7 @@ let matches_pattern concl pat = | None -> Proofview.tclUNIT () | Some pat -> let sigma = Sigma.to_evar_map sigma in - if Constr_matching.is_matching env sigma pat concl then + if Constr_matching.is_matching env sigma pat (EConstr.of_constr concl) then Proofview.tclUNIT () else Tacticals.New.tclZEROMSG (str "conclPattern") diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml index a42a51fc09..d27e4afb74 100644 --- a/tactics/hipattern.ml +++ b/tactics/hipattern.ml @@ -276,8 +276,8 @@ let coq_refl_jm_pattern = open Globnames -let is_matching x y = is_matching (Global.env ()) Evd.empty x y -let matches x y = matches (Global.env ()) Evd.empty x y +let is_matching x y = is_matching (Global.env ()) Evd.empty x (EConstr.of_constr y) +let matches x y = matches (Global.env ()) Evd.empty x (EConstr.of_constr y) let match_with_equation t = if not (isApp t) then raise NoEquationFound; -- cgit v1.2.3 From b77579ac873975a15978c5a4ecf312d577746d26 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 6 Nov 2016 21:59:18 +0100 Subject: Tacred API using EConstr. --- tactics/tactics.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'tactics') diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 8fb47b9942..e4503dab68 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -875,7 +875,7 @@ let normalise_vm_in_concl = reduct_in_concl (Redexpr.cbv_vm,VMcast) let unfold_in_concl loccname = reduct_in_concl (unfoldn loccname,REVERTcast) let unfold_in_hyp loccname = reduct_in_hyp (unfoldn loccname) let unfold_option loccname = reduct_option (unfoldn loccname,DEFAULTcast) -let pattern_option l = e_reduct_option (pattern_occs l,DEFAULTcast) +let pattern_option l = e_reduct_option (pattern_occs (List.map (on_snd EConstr.of_constr) l),DEFAULTcast) (* The main reduction function *) @@ -3165,7 +3165,7 @@ let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = let env = Proofview.Goal.env gl in let tmptyp0 = Tacmach.New.pf_get_hyp_typ hyp0 (Proofview.Goal.assume gl) in let reduce_to_quantified_ref = Tacmach.New.pf_apply reduce_to_quantified_ref gl in - let typ0 = reduce_to_quantified_ref indref tmptyp0 in + let typ0 = reduce_to_quantified_ref indref (EConstr.of_constr tmptyp0) in let prods, indtyp = decompose_prod_assum typ0 in let hd,argl = decompose_app indtyp in let env' = push_rel_context prods env in -- cgit v1.2.3 From 3b8acc174490878a3d0c9345e34a0ecb1d3abd66 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 7 Nov 2016 13:27:16 +0100 Subject: Typeclasses API using EConstr. --- tactics/class_tactics.ml | 14 +++++++------- tactics/tactics.ml | 1 + 2 files changed, 8 insertions(+), 7 deletions(-) (limited to 'tactics') diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index bef43d20b4..ff7dbfa911 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -478,9 +478,9 @@ let is_Prop env sigma concl = | Sort (Prop Null) -> true | _ -> false -let is_unique env concl = +let is_unique env sigma concl = try - let (cl,u), args = dest_class_app env concl in + let (cl,u), args = dest_class_app env sigma concl in cl.cl_unique with e when CErrors.noncritical e -> false @@ -675,7 +675,7 @@ module V85 = struct let tacgl = {it = gl; sigma = s;} in let secvars = secvars_of_hyps (Environ.named_context_of_val (Goal.V82.hyps s gl)) in let poss = e_possible_resolve hints info.hints secvars info.only_classes s concl in - let unique = is_unique env concl in + let unique = is_unique env s (EConstr.of_constr concl) in let rec aux i foundone = function | (tac, _, extern, name, pp) :: tl -> let derivs = path_derivate info.auto_cut name in @@ -997,7 +997,7 @@ module Search = struct let concl = Goal.concl gl in let sigma = Goal.sigma gl in let s = Sigma.to_evar_map sigma in - let unique = not info.search_dep || is_unique env concl in + let unique = not info.search_dep || is_unique env s (EConstr.of_constr concl) in let backtrack = needs_backtrack env s unique concl in if !typeclasses_debug > 0 then Feedback.msg_debug @@ -1071,7 +1071,7 @@ module Search = struct try let evi = Evd.find_undefined sigma ev in if info.search_only_classes then - Some (ev, is_class_type sigma (Evd.evar_concl evi)) + Some (ev, is_class_evar sigma evi) else Some (ev, true) with Not_found -> None in @@ -1351,7 +1351,7 @@ let error_unresolvable env comp evd = | Some s -> Evar.Set.mem ev s in let fold ev evi (found, accu) = - let ev_class = class_of_constr evi.evar_concl in + let ev_class = class_of_constr evd (EConstr.of_constr evi.evar_concl) in if not (Option.is_empty ev_class) && is_part ev then (* focus on one instance if only one was searched for *) if not found then (true, Some ev) @@ -1481,7 +1481,7 @@ let resolve_one_typeclass env ?(sigma=Evd.empty) gl unique = let _ = Hook.set Typeclasses.solve_one_instance_hook - (fun x y z w -> resolve_one_typeclass x ~sigma:y z w) + (fun x y z w -> resolve_one_typeclass x ~sigma:y (EConstr.Unsafe.to_constr z) w) (** Take the head of the arity of a constr. Used in the partial application tactic. *) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index e4503dab68..a6bc805bd4 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1672,6 +1672,7 @@ let solve_remaining_apply_goals = let env = Proofview.Goal.env gl in let evd = Sigma.to_evar_map sigma in let concl = Proofview.Goal.concl gl in + let concl = EConstr.of_constr concl in if Typeclasses.is_class_type evd concl then let evd', c' = Typeclasses.resolve_one_typeclass env evd concl in let tac = Refine.refine ~unsafe:true { run = fun h -> Sigma.here c' h } in -- cgit v1.2.3 From 67dc22d8389234d0c9b329944ff579e7056b7250 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 8 Nov 2016 10:57:05 +0100 Subject: Cases API using EConstr. --- tactics/equality.ml | 2 +- tactics/hipattern.ml | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) (limited to 'tactics') diff --git a/tactics/equality.ml b/tactics/equality.ml index 58c86ff426..9679ac4026 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -864,7 +864,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 indf ci p head (Array.of_list brl))) + EConstr.Unsafe.to_constr (Inductiveops.make_case_or_project env sigma indf ci (EConstr.of_constr p) (EConstr.of_constr head) (Array.map_of_list EConstr.of_constr brl)))) (* Now we need to construct the discriminator, given a discriminable position. This boils down to: diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml index d27e4afb74..87e252a380 100644 --- a/tactics/hipattern.ml +++ b/tactics/hipattern.ml @@ -110,7 +110,7 @@ let match_with_one_constructor sigma style onlybinary allow_rec t = Some (hdapp,args) else None else - let ctyp = prod_applist mip.mind_nf_lc.(0) args in + let ctyp = Term.prod_applist mip.mind_nf_lc.(0) args in let cargs = List.map RelDecl.get_type (prod_assum ctyp) in if not (is_lax_conjunction style) || has_nodep_prod sigma ctyp then (* Record or non strict conjunction *) @@ -176,7 +176,7 @@ let match_with_disjunction ?(strict=false) ?(onlybinary=false) sigma t = None else let cargs = - Array.map (fun ar -> pi2 (destProd (prod_applist ar args))) + Array.map (fun ar -> pi2 (destProd (Term.prod_applist ar args))) mip.mind_nf_lc in Some (hdapp,Array.to_list cargs) else -- cgit v1.2.3 From 85ab3e298aa1d7333787c1fa44d25df189ac255c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 8 Nov 2016 19:02:40 +0100 Subject: Pretyping API using EConstr. --- tactics/class_tactics.ml | 4 +-- tactics/equality.ml | 2 +- tactics/hints.ml | 2 +- tactics/tactics.ml | 63 +++++++++++++++++++++++++----------------------- 4 files changed, 37 insertions(+), 34 deletions(-) (limited to 'tactics') diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index ff7dbfa911..bc1d0ed6b3 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -1458,7 +1458,7 @@ let _ = let resolve_one_typeclass env ?(sigma=Evd.empty) gl unique = let nc, gl, subst, _, _ = Evarutil.push_rel_context_to_named_context env gl in let (gl,t,sigma) = - Goal.V82.mk_goal sigma nc gl Store.empty in + Goal.V82.mk_goal sigma nc (EConstr.Unsafe.to_constr gl) Store.empty in let gls = { it = gl ; sigma = sigma; } in let hints = searchtable_map typeclasses_db in let st = Hint_db.transparent_state hints in @@ -1481,7 +1481,7 @@ let resolve_one_typeclass env ?(sigma=Evd.empty) gl unique = let _ = Hook.set Typeclasses.solve_one_instance_hook - (fun x y z w -> resolve_one_typeclass x ~sigma:y (EConstr.Unsafe.to_constr z) w) + (fun x y z w -> resolve_one_typeclass x ~sigma:y z w) (** Take the head of the arity of a constr. Used in the partial application tactic. *) diff --git a/tactics/equality.ml b/tactics/equality.ml index 9679ac4026..be175937ba 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -1176,7 +1176,7 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt = let (a,p_i_minus_1) = match whd_beta_stack !evdref (EConstr.of_constr p_i) with | (_sigS,[a;p]) -> (EConstr.Unsafe.to_constr a, EConstr.Unsafe.to_constr p) | _ -> anomaly ~label:"sig_clausal_form" (Pp.str "should be a sigma type") in - let ev = Evarutil.e_new_evar env evdref a in + let ev = Evarutil.e_new_evar env evdref (EConstr.of_constr a) in let rty = beta_applist sigma (EConstr.of_constr p_i_minus_1,[EConstr.of_constr ev]) in let tuple_tail = sigrec_clausal_form (siglen-1) rty in match diff --git a/tactics/hints.ml b/tactics/hints.ml index b2aa02191e..e8225df2d0 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -1213,7 +1213,7 @@ let prepare_hint check (poly,local) env init (sigma,c) = subst := (evar,mkVar id)::!subst; mkNamedLambda id t (iter (replace_term sigma (EConstr.of_constr evar) (EConstr.mkVar id) (EConstr.of_constr c))) in let c' = iter c in - if check then Pretyping.check_evars (Global.env()) Evd.empty sigma c'; + if check then Pretyping.check_evars (Global.env()) Evd.empty sigma (EConstr.of_constr c'); let diff = Univ.ContextSet.diff (Evd.universe_context_set sigma) (Evd.universe_context_set init) in if poly then IsConstr (c', diff) else if local then IsConstr (c', diff) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index a6bc805bd4..3bb285aa85 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -176,7 +176,7 @@ let unsafe_intro env store decl b = let inst = List.map (NamedDecl.get_id %> mkVar) (named_context env) in let ninst = mkRel 1 :: inst in let nb = subst1 (mkVar (NamedDecl.get_id decl)) b in - let Sigma (ev, sigma, p) = new_evar_instance nctx sigma nb ~principal:true ~store ninst in + let Sigma (ev, sigma, p) = new_evar_instance nctx sigma (EConstr.of_constr nb) ~principal:true ~store ninst in Sigma (mkNamedLambda_or_LetIn decl ev, sigma, p) end } @@ -206,12 +206,13 @@ let convert_concl ?(check=true) ty k = let env = Proofview.Goal.env gl in let store = Proofview.Goal.extra gl in let conclty = Proofview.Goal.raw_concl gl in + let ty = EConstr.of_constr ty in Refine.refine ~unsafe:true { run = begin fun sigma -> let Sigma ((), sigma, p) = if check then begin let sigma = Sigma.to_evar_map sigma in - ignore (Typing.unsafe_type_of env sigma (EConstr.of_constr ty)); - let sigma,b = Reductionops.infer_conv env sigma ty conclty in + ignore (Typing.unsafe_type_of env sigma ty); + let sigma,b = Reductionops.infer_conv env sigma ty (EConstr.of_constr conclty) in if not b then error "Not convertible."; Sigma.Unsafe.of_pair ((), sigma) end else Sigma.here () sigma in @@ -230,7 +231,7 @@ let convert_hyp ?(check=true) d = let sign = convert_hyp check (named_context_val env) sigma d in let env = reset_with_named_context sign env in Refine.refine ~unsafe:true { run = begin fun sigma -> - Evarutil.new_evar env sigma ~principal:true ~store ty + Evarutil.new_evar env sigma ~principal:true ~store (EConstr.of_constr ty) end } end } @@ -248,8 +249,8 @@ let convert_gen pb x y = Tacticals.New.tclFAIL 0 (str "Not convertible") end } -let convert x y = convert_gen Reduction.CONV x y -let convert_leq x y = convert_gen Reduction.CUMUL x y +let convert x y = convert_gen Reduction.CONV (EConstr.of_constr x) (EConstr.of_constr y) +let convert_leq x y = convert_gen Reduction.CUMUL (EConstr.of_constr x) (EConstr.of_constr y) let clear_dependency_msg env sigma id = function | Evarutil.OccurHypInSimpleClause None -> @@ -300,7 +301,7 @@ let clear_gen fail = function in let env = reset_with_named_context hyps env in let tac = Refine.refine ~unsafe:true { run = fun sigma -> - Evarutil.new_evar env sigma ~principal:true concl + Evarutil.new_evar env sigma ~principal:true (EConstr.of_constr concl) } in Sigma.Unsafe.of_pair (tac, !evdref) end } @@ -330,7 +331,7 @@ let move_hyp id dest = let sign' = move_hyp_in_named_context sigma id dest sign in let env = reset_with_named_context sign' env in Refine.refine ~unsafe:true { run = begin fun sigma -> - Evarutil.new_evar env sigma ~principal:true ~store ty + Evarutil.new_evar env sigma ~principal:true ~store (EConstr.of_constr ty) end } end } @@ -384,7 +385,7 @@ let rename_hyp repl = let nctx = Environ.val_of_named_context nhyps in let instance = List.map (NamedDecl.get_id %> mkVar) hyps in Refine.refine ~unsafe:true { run = begin fun sigma -> - Evarutil.new_evar_instance nctx sigma nconcl ~principal:true ~store instance + Evarutil.new_evar_instance nctx sigma (EConstr.of_constr nconcl) ~principal:true ~store instance end } end } @@ -494,7 +495,7 @@ let rec mk_holes : type r s. _ -> r Sigma.t -> (s, r) Sigma.le -> _ -> (_, s) Si fun env sigma p -> function | [] -> Sigma ([], sigma, p) | arg :: rem -> - let Sigma (arg, sigma, q) = Evarutil.new_evar env sigma arg in + let Sigma (arg, sigma, q) = Evarutil.new_evar env sigma (EConstr.of_constr arg) in let Sigma (rem, sigma, r) = mk_holes env sigma (p +> q) rem in Sigma (arg :: rem, sigma, r) @@ -784,35 +785,37 @@ let make_change_arg c pats = { run = fun sigma -> Sigma.here (replace_vars (Id.Map.bindings pats) c) sigma } let check_types env sigma mayneedglobalcheck deep newc origc = - let t1 = Retyping.get_type_of env sigma (EConstr.of_constr newc) in + let t1 = Retyping.get_type_of env sigma newc in + let t1 = EConstr.of_constr t1 in if deep then begin - let t2 = Retyping.get_type_of env sigma (EConstr.of_constr origc) in + let t2 = Retyping.get_type_of env sigma origc in let sigma, t2 = Evarsolve.refresh_universes ~onlyalg:true (Some false) env sigma (EConstr.of_constr t2) in + let t2 = EConstr.of_constr t2 in let sigma, b = infer_conv ~pb:Reduction.CUMUL env sigma t1 t2 in if not b then if - isSort (whd_all env sigma (EConstr.of_constr t1)) && - isSort (whd_all env sigma (EConstr.of_constr t2)) + isSort (whd_all env sigma t1) && + isSort (whd_all env sigma t2) then (mayneedglobalcheck := true; sigma) else user_err ~hdr:"convert-check-hyp" (str "Types are incompatible.") else sigma end else - if not (isSort (whd_all env sigma (EConstr.of_constr t1))) then + if not (isSort (whd_all env sigma t1)) then user_err ~hdr:"convert-check-hyp" (str "Not a type.") else sigma (* Now we introduce different instances of the previous tacticals *) let change_and_check cv_pb mayneedglobalcheck deep t = { e_redfun = begin fun env sigma c -> - let c = EConstr.Unsafe.to_constr c in let Sigma (t', sigma, p) = t.run sigma in let sigma = Sigma.to_evar_map sigma in + let t' = EConstr.of_constr t' 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.Unsafe.of_pair (t', sigma) + Sigma.Unsafe.of_pair (EConstr.Unsafe.to_constr t', sigma) end } (* Use cumulativity only if changing the conclusion not a subterm *) @@ -1240,8 +1243,8 @@ let cut c = (** Backward compat: normalize [c]. *) let c = if normalize_cut then local_strong whd_betaiota sigma (EConstr.of_constr c) else c in Refine.refine ~unsafe:true { run = begin fun h -> - let Sigma (f, h, p) = Evarutil.new_evar ~principal:true env h (mkArrow c (Vars.lift 1 concl)) in - let Sigma (x, h, q) = Evarutil.new_evar env h c in + let Sigma (f, h, p) = Evarutil.new_evar ~principal:true env h (EConstr.of_constr (mkArrow c (Vars.lift 1 concl))) in + let Sigma (x, h, q) = Evarutil.new_evar env h (EConstr.of_constr c) in let f = mkLetIn (Name id, x, c, mkApp (Vars.lift 1 f, [|mkRel 1|])) in Sigma (f, h, p +> q) end } @@ -1913,8 +1916,8 @@ let cut_and_apply c = let env = Tacmach.New.pf_env gl in Refine.refine { run = begin fun sigma -> let typ = mkProd (Anonymous, c2, concl) in - let Sigma (f, sigma, p) = Evarutil.new_evar env sigma typ in - let Sigma (x, sigma, q) = Evarutil.new_evar env sigma c1 in + let Sigma (f, sigma, p) = Evarutil.new_evar env sigma (EConstr.of_constr typ) in + let Sigma (x, sigma, q) = Evarutil.new_evar env sigma (EConstr.of_constr c1) in let ans = mkApp (f, [|mkApp (c, [|x|])|]) in Sigma (ans, sigma, p +> q) end } @@ -1983,7 +1986,7 @@ let assumption = if only_eq then (sigma, Constr.equal t concl) else let env = Proofview.Goal.env gl in - infer_conv env sigma t concl + infer_conv env sigma (EConstr.of_constr t) (EConstr.of_constr concl) in if is_same_type then (Proofview.Unsafe.tclEVARS sigma) <*> @@ -2078,7 +2081,7 @@ let clear_body ids = in check <*> Refine.refine ~unsafe:true { run = begin fun sigma -> - Evarutil.new_evar env sigma ~principal:true concl + Evarutil.new_evar env sigma ~principal:true (EConstr.of_constr concl) end } end } @@ -2131,7 +2134,7 @@ let apply_type newcl args = Refine.refine { run = begin fun sigma -> let newcl = nf_betaiota (Sigma.to_evar_map sigma) (EConstr.of_constr newcl) (* As in former Logic.refine *) in let Sigma (ev, sigma, p) = - Evarutil.new_evar env sigma ~principal:true ~store newcl in + Evarutil.new_evar env sigma ~principal:true ~store (EConstr.of_constr newcl) in Sigma (applist (ev, args), sigma, p) end } end } @@ -2151,7 +2154,7 @@ let bring_hyps hyps = let args = Array.of_list (Context.Named.to_instance hyps) in Refine.refine { run = begin fun sigma -> let Sigma (ev, sigma, p) = - Evarutil.new_evar env sigma ~principal:true ~store newcl in + Evarutil.new_evar env sigma ~principal:true ~store (EConstr.of_constr newcl) in Sigma (mkApp (ev, args), sigma, p) end } end } @@ -2677,11 +2680,11 @@ let mkletin_goal env sigma store with_eq dep (id,lastlhyp,ccl,c) ty = let eq = applist (eq,args) in let refl = applist (refl, [t;mkVar id]) in let newenv = insert_before [LocalAssum (heq,eq); decl] lastlhyp env in - let Sigma (x, sigma, r) = new_evar newenv sigma ~principal:true ~store ccl in + let Sigma (x, sigma, r) = new_evar newenv sigma ~principal:true ~store (EConstr.of_constr ccl) in Sigma (mkNamedLetIn id c t (mkNamedLetIn heq refl eq x), sigma, p +> q +> r) | None -> let newenv = insert_before [decl] lastlhyp env in - let Sigma (x, sigma, p) = new_evar newenv sigma ~principal:true ~store ccl in + let Sigma (x, sigma, p) = new_evar newenv sigma ~principal:true ~store (EConstr.of_constr ccl) in Sigma (mkNamedLetIn id c t x, sigma, p) let letin_tac with_eq id c ty occs = @@ -2862,7 +2865,7 @@ let new_generalize_gen_let lconstr = in let tac = Refine.refine { run = begin fun sigma -> - let Sigma (ev, sigma, p) = Evarutil.new_evar env sigma ~principal:true newcl in + let Sigma (ev, sigma, p) = Evarutil.new_evar env sigma ~principal:true (EConstr.of_constr newcl) in Sigma ((applist (ev, args)), sigma, p) end } in @@ -3549,7 +3552,7 @@ let make_abstract_generalize env id typ concl dep ctx body c eqs args refls = (* Abstract by the extension of the context *) let genctyp = it_mkProd_or_LetIn genarg ctx in (* The goal will become this product. *) - let Sigma (genc, sigma, p) = Evarutil.new_evar env sigma ~principal:true genctyp in + let Sigma (genc, sigma, p) = Evarutil.new_evar env sigma ~principal:true (EConstr.of_constr genctyp) in (* Apply the old arguments giving the proper instantiation of the hyp *) let instc = mkApp (genc, Array.of_list args) in (* Then apply to the original instantiated hyp. *) @@ -3755,7 +3758,7 @@ let specialize_eqs id gl = | _ -> if in_eqs then acc, in_eqs, ctx, ty else - let e = e_new_evar (push_rel_context ctx env) evars t in + let e = e_new_evar (push_rel_context ctx env) evars (EConstr.of_constr t) in aux false (LocalDef (na,e,t) :: ctx) (mkApp (lift 1 acc, [| mkRel 1 |])) b) | t -> acc, in_eqs, ctx, ty in -- cgit v1.2.3 From c2855a3387be134d1220f301574b743572a94239 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 10 Nov 2016 11:39:27 +0100 Subject: Unification API using EConstr. --- tactics/equality.ml | 2 +- tactics/inv.ml | 4 ++-- tactics/tactics.ml | 29 +++++++++++++++++++++++------ 3 files changed, 26 insertions(+), 9 deletions(-) (limited to 'tactics') diff --git a/tactics/equality.ml b/tactics/equality.ml index be175937ba..64b56b99bc 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -177,7 +177,7 @@ let instantiate_lemma_all frzevars gl c ty l l2r concl = let flags = make_flags frzevars (Tacmach.New.project gl) rewrite_unif_flags eqclause in let occs = w_unify_to_subterm_all ~flags env eqclause.evd - ((if l2r then c1 else c2),concl) + (EConstr.of_constr (if l2r then c1 else c2),EConstr.of_constr concl) in List.map try_occ occs let instantiate_lemma gl c ty l l2r concl = diff --git a/tactics/inv.ml b/tactics/inv.ml index 9282af7590..9324d8e374 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -90,8 +90,8 @@ let make_inv_predicate env evd indf realargs id status concl = let sort = Evarutil.evd_comb1 (Evd.fresh_sort_in_family env) evd sort in let p = make_arity env true indf sort in let evd',(p,ptyp) = Unification.abstract_list_all env - !evd p concl (realargs@[mkVar id]) - in evd := evd'; p in + !evd (EConstr.of_constr p) (EConstr.of_constr concl) (List.map EConstr.of_constr realargs@[EConstr.mkVar id]) + in evd := evd'; EConstr.Unsafe.to_constr p in let hyps,bodypred = decompose_lam_n_assum (nrealargs+1) pred in (* We lift to make room for the equations *) (hyps,lift nrealargs bodypred) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 3bb285aa85..2cb9e08648 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1204,10 +1204,12 @@ let map_destruction_arg f sigma = function let finish_delayed_evar_resolution with_evars env sigma f = let ((c, lbind), sigma') = run_delayed env sigma f in + let c = EConstr.of_constr c in let pending = (sigma,sigma') in let sigma' = Sigma.Unsafe.of_evar_map sigma' in let flags = tactic_infer_flags with_evars in let Sigma (c, sigma', _) = finish_evar_resolution ~flags env sigma' (pending,c) in + let c = EConstr.Unsafe.to_constr c in (Sigma.to_evar_map sigma', (c, lbind)) let with_no_bindings (c, lbind) = @@ -2692,14 +2694,18 @@ let letin_tac with_eq id c ty occs = let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let ccl = Proofview.Goal.concl gl in - let abs = AbstractExact (id,c,ty,occs,true) in + let c = EConstr.of_constr c in + let abs = AbstractExact (id,c,Option.map EConstr.of_constr ty,occs,true) in + let ccl = EConstr.of_constr ccl in let (id,_,depdecls,lastlhyp,ccl,res) = make_abstraction env sigma ccl abs in + let ccl = EConstr.Unsafe.to_constr ccl in (* We keep the original term to match but record the potential side-effects of unifying universes. *) let Sigma (c, sigma, p) = match res with | None -> Sigma.here c sigma | Some (Sigma (_, sigma, p)) -> Sigma (c, sigma, p) in + let c = EConstr.Unsafe.to_constr c in let tac = letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty in Sigma (tac, sigma, p) end } @@ -2711,10 +2717,13 @@ let letin_pat_tac with_eq id c occs = let ccl = Proofview.Goal.concl gl in let check t = true in let abs = AbstractPattern (false,check,id,c,occs,false) in + let ccl = EConstr.of_constr ccl in let (id,_,depdecls,lastlhyp,ccl,res) = make_abstraction env sigma ccl abs in + let ccl = EConstr.Unsafe.to_constr ccl in let Sigma (c, sigma, p) = match res with | None -> finish_evar_resolution ~flags:(tactic_infer_flags false) env sigma c | Some res -> res in + let c = EConstr.Unsafe.to_constr c in let tac = (letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) None) in @@ -4263,8 +4272,8 @@ let use_bindings env sigma elim must_be_closed (c,lbind) typ = if must_be_closed && occur_meta indclause.evd (EConstr.of_constr (clenv_value indclause)) then error "Need a fully applied argument."; (* We lose the possibility of coercions in with-bindings *) - let (sigma, c) = pose_all_metas_as_evars env indclause.evd (clenv_value indclause) in - Sigma.Unsafe.of_pair (c, sigma) + let (sigma, c) = pose_all_metas_as_evars env indclause.evd (EConstr.of_constr (clenv_value indclause)) in + Sigma.Unsafe.of_pair (EConstr.Unsafe.to_constr c, sigma) with e when catchable_exception e -> try find_clause (try_red_product env sigma (EConstr.of_constr typ)) with Redelimination -> raise e in @@ -4279,7 +4288,7 @@ let check_expected_type env sigma (elimc,bl) elimt = let sigma,cl = make_evar_clause env sigma ~len:(n - 1) elimt in let sigma = solve_evar_clause env sigma true cl bl in let (_,u,_) = destProd cl.cl_concl in - fun t -> Evarconv.e_cumul env (ref sigma) (EConstr.of_constr t) (EConstr.of_constr u) + fun t -> Evarconv.e_cumul env (ref sigma) t (EConstr.of_constr u) let check_enough_applied env sigma elim = let sigma = Sigma.to_evar_map sigma in @@ -4288,7 +4297,7 @@ let check_enough_applied env sigma elim = | None -> (* No eliminator given *) fun u -> - let t,_ = decompose_app (whd_all env sigma (EConstr.of_constr u)) in isInd t + let t,_ = decompose_app (whd_all env sigma u) in isInd t | Some elimc -> let elimt = Retyping.get_type_of env sigma (EConstr.of_constr (fst elimc)) in let scheme = compute_elim_sig ~elimc elimt in @@ -4314,8 +4323,11 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim let store = Proofview.Goal.extra gl in let check = check_enough_applied env sigma elim in let Sigma (c, sigma', p) = use_bindings env sigma elim false (c0,lbind) t0 in + let c = EConstr.of_constr c in let abs = AbstractPattern (from_prefix,check,Name id,(pending,c),cls,false) in + let ccl = EConstr.of_constr ccl in let (id,sign,_,lastlhyp,ccl,res) = make_abstraction env sigma' ccl abs in + let ccl = EConstr.Unsafe.to_constr ccl in match res with | None -> (* pattern not found *) @@ -4323,7 +4335,9 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim (* we restart using bindings after having tried type-class resolution etc. on the term given by the user *) let flags = tactic_infer_flags (with_evars && (* do not give a success semantics to edestruct on an open term yet *) false) in + let c0 = EConstr.of_constr c0 in let Sigma (c0, sigma, q) = finish_evar_resolution ~flags env sigma (pending,c0) in + let c0 = EConstr.Unsafe.to_constr c0 in let tac = (if isrec then (* Historically, induction has side conditions last *) @@ -4350,6 +4364,7 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim Sigma (tac, sigma, q) | Some (Sigma (c, sigma', q)) -> + let c = EConstr.Unsafe.to_constr c in (* pattern found *) let with_eq = Option.map (fun eq -> (false,eq)) eqname in (* TODO: if ind has predicate parameters, use JMeq instead of eq *) @@ -4386,7 +4401,7 @@ let induction_gen clear_flag isrec with_evars elim && lbind == NoBindings && not with_evars && Option.is_empty eqname && clear_flag == None && has_generic_occurrences_but_goal cls (destVar c) env (Sigma.to_evar_map sigma) ccl in - let enough_applied = check_enough_applied env sigma elim t in + let enough_applied = check_enough_applied env sigma elim (EConstr.of_constr t) in if is_arg_pure_hyp && enough_applied then (* First case: induction on a variable already in an inductive type and with maximal abstraction over the variable. @@ -4935,6 +4950,8 @@ let tclABSTRACT name_op tac = abstract_subproof s gk tac let unify ?(state=full_transparent_state) x y = + let x = EConstr.of_constr x in + let y = EConstr.of_constr y in Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in try -- cgit v1.2.3 From ca993b9e7765ac58f70740818758457c9367b0da Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 11 Nov 2016 00:29:02 +0100 Subject: Making judgment type generic over the type of inner constrs. This allows to factorize code and prevents the unnecessary use of back and forth conversions between the various types of terms. Note that functions from typing may now raise errors as PretypeError rather than TypeError, because they call the proper wrapper. I think that they were wrongly calling the kernel because of an overlook of open modules. --- tactics/contradiction.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'tactics') diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index 789028ac15..9580fdbfca 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -30,7 +30,7 @@ let absurd c = let sigma = Sigma.to_evar_map sigma in let j = Retyping.get_judgment_of env sigma (EConstr.of_constr c) in let sigma, j = Coercion.inh_coerce_to_sort Loc.ghost env sigma j in - let t = j.Environ.utj_val in + let t = EConstr.Unsafe.to_constr j.Environ.utj_val in let tac = Tacticals.New.tclTHENLIST [ elim_type (build_coq_False ()); -- cgit v1.2.3 From 536026f3e20f761e8ef366ed732da7d3b626ac5e Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 11 Nov 2016 15:39:01 +0100 Subject: Cleaning up opening of the EConstr module in pretyping folder. --- tactics/tactics.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'tactics') diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 2cb9e08648..eebb2a0380 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -3165,7 +3165,7 @@ let expand_projections env sigma c = let sigma = Sigma.to_evar_map sigma in let rec aux env c = match EConstr.kind sigma c with - | Proj (p, c) -> EConstr.of_constr (Retyping.expand_projection env sigma p (aux env c) []) + | Proj (p, c) -> Retyping.expand_projection env sigma p (aux env c) [] | _ -> map_constr_with_full_binders sigma push_rel aux env c in EConstr.Unsafe.to_constr (aux env (EConstr.of_constr c)) -- cgit v1.2.3 From 7267dfafe9215c35275a39814c8af451961e997c Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 11 Nov 2016 17:48:47 +0100 Subject: Goal API using EConstr. --- tactics/class_tactics.ml | 8 +++++--- tactics/hints.ml | 2 +- 2 files changed, 6 insertions(+), 4 deletions(-) (limited to 'tactics') diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index bc1d0ed6b3..be8d7eaa5f 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -185,7 +185,7 @@ let set_typeclasses_depth = let pr_ev evs ev = Printer.pr_constr_env (Goal.V82.env evs ev) evs - (Evarutil.nf_evar evs (Goal.V82.concl evs ev)) + (Evarutil.nf_evar evs (EConstr.Unsafe.to_constr (Goal.V82.concl evs ev))) (** Typeclasses instance search tactic / eauto *) @@ -672,6 +672,7 @@ module V85 = struct let hints_tac hints sk fk {it = gl,info; sigma = s} = let env = Goal.V82.env s gl in let concl = Goal.V82.concl s gl in + let concl = EConstr.Unsafe.to_constr concl in let tacgl = {it = gl; sigma = s;} in let secvars = secvars_of_hyps (Environ.named_context_of_val (Goal.V82.hyps s gl)) in let poss = e_possible_resolve hints info.hints secvars info.only_classes s concl in @@ -784,7 +785,7 @@ module V85 = struct let fk'' = if not info.unique && List.is_empty gls' && not (needs_backtrack (Goal.V82.env s gl) s - info.is_evar (Goal.V82.concl s gl)) + info.is_evar (EConstr.Unsafe.to_constr (Goal.V82.concl s gl))) then fk else fk' in @@ -1458,7 +1459,7 @@ let _ = let resolve_one_typeclass env ?(sigma=Evd.empty) gl unique = let nc, gl, subst, _, _ = Evarutil.push_rel_context_to_named_context env gl in let (gl,t,sigma) = - Goal.V82.mk_goal sigma nc (EConstr.Unsafe.to_constr gl) Store.empty in + Goal.V82.mk_goal sigma nc gl Store.empty in let gls = { it = gl ; sigma = sigma; } in let hints = searchtable_map typeclasses_db in let st = Hint_db.transparent_state hints in @@ -1473,6 +1474,7 @@ let resolve_one_typeclass env ?(sigma=Evd.empty) gl unique = with Refiner.FailError _ -> raise Not_found in let evd = sig_sig gls' in + let t = EConstr.Unsafe.to_constr t in let t' = let (ev, inst) = destEvar t in mkEvar (ev, Array.of_list subst) in diff --git a/tactics/hints.ml b/tactics/hints.ml index e8225df2d0..57358bb769 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -1423,7 +1423,7 @@ let pr_applicable_hint () = match glss.Evd.it with | [] -> CErrors.error "No focused goal." | g::_ -> - pr_hint_term glss.Evd.sigma (Goal.V82.concl glss.Evd.sigma g) + pr_hint_term glss.Evd.sigma (EConstr.Unsafe.to_constr (Goal.V82.concl glss.Evd.sigma g)) let pp_hint_mode = function | ModeInput -> str"+" -- cgit v1.2.3 From 53fe23265daafd47e759e73e8f97361c7fdd331b Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 11 Nov 2016 18:20:29 +0100 Subject: Refine API using EConstr. --- tactics/class_tactics.ml | 2 +- tactics/inv.ml | 1 + tactics/tactics.ml | 42 +++++++++++++++++++++++++++++------------- 3 files changed, 31 insertions(+), 14 deletions(-) (limited to 'tactics') diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index be8d7eaa5f..b0f3551705 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -269,7 +269,7 @@ let unify_resolve_refine poly flags = {Environ.uj_val = term; Environ.uj_type = cl.cl_concl} concl; !evdref - in Sigma.here term (Sigma.Unsafe.of_evar_map sigma') } + in Sigma.here (EConstr.of_constr term) (Sigma.Unsafe.of_evar_map sigma') } end } (** Dealing with goals of the form A -> B and hints of the form diff --git a/tactics/inv.ml b/tactics/inv.ml index 9324d8e374..eebc672224 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -458,6 +458,7 @@ let raw_inversion inv_kind id status names = in let refined id = let prf = mkApp (mkVar id, args) in + let prf = EConstr.of_constr prf in Refine.refine { run = fun h -> Sigma (prf, h, Sigma.refl) } in let neqns = List.length realargs in diff --git a/tactics/tactics.ml b/tactics/tactics.ml index eebb2a0380..639a12b343 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -177,7 +177,7 @@ let unsafe_intro env store decl b = let ninst = mkRel 1 :: inst in let nb = subst1 (mkVar (NamedDecl.get_id decl)) b in let Sigma (ev, sigma, p) = new_evar_instance nctx sigma (EConstr.of_constr nb) ~principal:true ~store ninst in - Sigma (mkNamedLambda_or_LetIn decl ev, sigma, p) + Sigma (EConstr.of_constr (mkNamedLambda_or_LetIn decl ev), sigma, p) end } let introduction ?(check=true) id = @@ -218,7 +218,7 @@ let convert_concl ?(check=true) ty k = end else Sigma.here () sigma in let Sigma (x, sigma, q) = Evarutil.new_evar env sigma ~principal:true ~store ty in let ans = if k == DEFAULTcast then x else mkCast(x,k,conclty) in - Sigma (ans, sigma, p +> q) + Sigma (EConstr.of_constr ans, sigma, p +> q) end } end } @@ -231,7 +231,8 @@ let convert_hyp ?(check=true) d = let sign = convert_hyp check (named_context_val env) sigma d in let env = reset_with_named_context sign env in Refine.refine ~unsafe:true { run = begin fun sigma -> - Evarutil.new_evar env sigma ~principal:true ~store (EConstr.of_constr ty) + let Sigma (c, sigma, p) = Evarutil.new_evar env sigma ~principal:true ~store (EConstr.of_constr ty) in + Sigma (EConstr.of_constr c, sigma, p) end } end } @@ -301,7 +302,8 @@ let clear_gen fail = function in let env = reset_with_named_context hyps env in let tac = Refine.refine ~unsafe:true { run = fun sigma -> - Evarutil.new_evar env sigma ~principal:true (EConstr.of_constr concl) + let Sigma (c, sigma, p) = Evarutil.new_evar env sigma ~principal:true (EConstr.of_constr concl) in + Sigma (EConstr.of_constr c, sigma, p) } in Sigma.Unsafe.of_pair (tac, !evdref) end } @@ -331,7 +333,8 @@ let move_hyp id dest = let sign' = move_hyp_in_named_context sigma id dest sign in let env = reset_with_named_context sign' env in Refine.refine ~unsafe:true { run = begin fun sigma -> - Evarutil.new_evar env sigma ~principal:true ~store (EConstr.of_constr ty) + let Sigma (c, sigma, p) = Evarutil.new_evar env sigma ~principal:true ~store (EConstr.of_constr ty) in + Sigma (EConstr.of_constr c, sigma, p) end } end } @@ -385,7 +388,8 @@ let rename_hyp repl = let nctx = Environ.val_of_named_context nhyps in let instance = List.map (NamedDecl.get_id %> mkVar) hyps in Refine.refine ~unsafe:true { run = begin fun sigma -> - Evarutil.new_evar_instance nctx sigma (EConstr.of_constr nconcl) ~principal:true ~store instance + let Sigma (c, sigma, p) = Evarutil.new_evar_instance nctx sigma (EConstr.of_constr nconcl) ~principal:true ~store instance in + Sigma (EConstr.of_constr c, sigma, p) end } end } @@ -541,6 +545,7 @@ let mutual_fix f n rest j = Proofview.Goal.nf_enter { enter = begin fun gl -> let typarray = Array.of_list (List.map pi3 all) in let bodies = Array.of_list evs in let oterm = Term.mkFix ((indxs,0),(funnames,typarray,bodies)) in + let oterm = EConstr.of_constr oterm in Sigma (oterm, sigma, p) end } end } @@ -592,6 +597,7 @@ let mutual_cofix f others j = Proofview.Goal.nf_enter { enter = begin fun gl -> let typarray = Array.of_list types in let bodies = Array.of_list evs in let oterm = Term.mkCoFix (0, (funnames, typarray, bodies)) in + let oterm = EConstr.of_constr oterm in Sigma (oterm, sigma, p) end } end } @@ -1248,6 +1254,7 @@ let cut c = let Sigma (f, h, p) = Evarutil.new_evar ~principal:true env h (EConstr.of_constr (mkArrow c (Vars.lift 1 concl))) in let Sigma (x, h, q) = Evarutil.new_evar env h (EConstr.of_constr c) in let f = mkLetIn (Name id, x, c, mkApp (Vars.lift 1 f, [|mkRel 1|])) in + let f = EConstr.of_constr f in Sigma (f, h, p +> q) end } else @@ -1680,6 +1687,7 @@ let solve_remaining_apply_goals = let concl = EConstr.of_constr concl in if Typeclasses.is_class_type evd concl then let evd', c' = Typeclasses.resolve_one_typeclass env evd concl in + let c' = EConstr.of_constr c' in let tac = Refine.refine ~unsafe:true { run = fun h -> Sigma.here c' h } in Sigma.Unsafe.of_pair (tac, evd') else Sigma.here (Proofview.tclUNIT ()) sigma @@ -1921,6 +1929,7 @@ let cut_and_apply c = let Sigma (f, sigma, p) = Evarutil.new_evar env sigma (EConstr.of_constr typ) in let Sigma (x, sigma, q) = Evarutil.new_evar env sigma (EConstr.of_constr c1) in let ans = mkApp (f, [|mkApp (c, [|x|])|]) in + let ans = EConstr.of_constr ans in Sigma (ans, sigma, p +> q) end } | _ -> error "lapply needs a non-dependent product." @@ -1937,6 +1946,7 @@ let cut_and_apply c = (* let refine_no_check = Profile.profile2 refine_no_checkkey refine_no_check *) let exact_no_check c = + let c = EConstr.of_constr c in Refine.refine ~unsafe:true { run = fun h -> Sigma.here c h } let exact_check c = @@ -1968,6 +1978,7 @@ let exact_proof c = Refine.refine { run = begin fun sigma -> let sigma = Sigma.to_evar_map sigma in let (c, ctx) = Constrintern.interp_casted_constr (pf_env gl) sigma c (pf_concl gl) in + let c = EConstr.of_constr c in let sigma = Evd.merge_universe_context sigma ctx in Sigma.Unsafe.of_pair (c, sigma) end } @@ -2083,7 +2094,8 @@ let clear_body ids = in check <*> Refine.refine ~unsafe:true { run = begin fun sigma -> - Evarutil.new_evar env sigma ~principal:true (EConstr.of_constr concl) + let Sigma (c, sigma, p) = Evarutil.new_evar env sigma ~principal:true (EConstr.of_constr concl) in + Sigma (EConstr.of_constr c, sigma, p) end } end } @@ -2137,7 +2149,7 @@ let apply_type newcl args = let newcl = nf_betaiota (Sigma.to_evar_map sigma) (EConstr.of_constr newcl) (* As in former Logic.refine *) in let Sigma (ev, sigma, p) = Evarutil.new_evar env sigma ~principal:true ~store (EConstr.of_constr newcl) in - Sigma (applist (ev, args), sigma, p) + Sigma (EConstr.of_constr (applist (ev, args)), sigma, p) end } end } @@ -2157,7 +2169,7 @@ let bring_hyps hyps = Refine.refine { run = begin fun sigma -> let Sigma (ev, sigma, p) = Evarutil.new_evar env sigma ~principal:true ~store (EConstr.of_constr newcl) in - Sigma (mkApp (ev, args), sigma, p) + Sigma (EConstr.of_constr (mkApp (ev, args)), sigma, p) end } end } @@ -2683,11 +2695,11 @@ let mkletin_goal env sigma store with_eq dep (id,lastlhyp,ccl,c) ty = let refl = applist (refl, [t;mkVar id]) in let newenv = insert_before [LocalAssum (heq,eq); decl] lastlhyp env in let Sigma (x, sigma, r) = new_evar newenv sigma ~principal:true ~store (EConstr.of_constr ccl) in - Sigma (mkNamedLetIn id c t (mkNamedLetIn heq refl eq x), sigma, p +> q +> r) + Sigma (EConstr.of_constr (mkNamedLetIn id c t (mkNamedLetIn heq refl eq x)), sigma, p +> q +> r) | None -> let newenv = insert_before [decl] lastlhyp env in let Sigma (x, sigma, p) = new_evar newenv sigma ~principal:true ~store (EConstr.of_constr ccl) in - Sigma (mkNamedLetIn id c t x, sigma, p) + Sigma (EConstr.of_constr (mkNamedLetIn id c t x), sigma, p) let letin_tac with_eq id c ty occs = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> @@ -2875,7 +2887,7 @@ let new_generalize_gen_let lconstr = let tac = Refine.refine { run = begin fun sigma -> let Sigma (ev, sigma, p) = Evarutil.new_evar env sigma ~principal:true (EConstr.of_constr newcl) in - Sigma ((applist (ev, args)), sigma, p) + Sigma (EConstr.of_constr (applist (ev, args)), sigma, p) end } in Sigma.Unsafe.of_pair (tac, sigma) @@ -3569,7 +3581,7 @@ let make_abstract_generalize env id typ concl dep ctx body c eqs args refls = (* Apply the reflexivity proofs on the indices. *) let appeqs = mkApp (instc, Array.of_list refls) in (* Finally, apply the reflexivity proof for the original hyp, to get a term of type gl again. *) - Sigma (mkApp (appeqs, abshypt), sigma, p) + Sigma (EConstr.of_constr (mkApp (appeqs, abshypt)), sigma, p) end } let hyps_of_vars env sigma sign nogen hyps = @@ -5005,6 +5017,10 @@ module New = struct {onhyps=None; concl_occs=AllOccurrences } let refine ?unsafe c = + let c = { run = begin fun sigma -> + let Sigma (c, sigma, p) = c.run sigma in + Sigma (EConstr.of_constr c, sigma, p) + end } in Refine.refine ?unsafe c <*> reduce_after_refine end -- cgit v1.2.3 From cbea91d815f134d63d02d8fb1bd78ed97db28cd1 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 11 Nov 2016 19:52:48 +0100 Subject: Tacmach API using EConstr. --- tactics/class_tactics.ml | 4 ++-- tactics/contradiction.ml | 2 +- tactics/eauto.ml | 2 +- tactics/elim.ml | 4 ++-- tactics/eqdecide.ml | 4 ++-- tactics/equality.ml | 15 ++++++++------- tactics/hipattern.ml | 3 ++- tactics/inv.ml | 2 +- tactics/tacticals.ml | 4 ++-- tactics/tactics.ml | 44 ++++++++++++++++++++++++++++++-------------- 10 files changed, 51 insertions(+), 33 deletions(-) (limited to 'tactics') diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index b0f3551705..a2699ba8d9 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -226,7 +226,7 @@ let e_give_exact flags poly (c,clenv) gl = c, {gl with sigma = evd} else c, gl in - let t1 = pf_unsafe_type_of gl c in + let t1 = pf_unsafe_type_of gl (EConstr.of_constr c) in Proofview.V82.of_tactic (Clenvtac.unify ~flags t1 <*> exact_no_check c) gl let unify_e_resolve poly flags = { enter = begin fun gls (c,_,clenv) -> @@ -1514,7 +1514,7 @@ let is_ground c gl = let autoapply c i gl = let flags = auto_unif_flags Evar.Set.empty (Hints.Hint_db.transparent_state (Hints.searchtable_map i)) in - let cty = pf_unsafe_type_of gl c in + let cty = pf_unsafe_type_of gl (EConstr.of_constr c) in let ce = mk_clenv_from gl (c,cty) in let tac = { enter = fun gl -> (unify_e_resolve false flags).enter gl ((c,cty,Univ.ContextSet.empty),0,ce) } in diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index 9580fdbfca..2058b95a6a 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -113,7 +113,7 @@ let contradiction_term (c,lbind as cl) = let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let type_of = Tacmach.New.pf_unsafe_type_of gl in - let typ = type_of c in + let typ = type_of (EConstr.of_constr c) in let _, ccl = splay_prod env sigma (EConstr.of_constr typ) in if is_empty_type sigma ccl then Tacticals.New.tclTHEN diff --git a/tactics/eauto.ml b/tactics/eauto.ml index 0869ac0c76..2fad4fcf7f 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -30,7 +30,7 @@ let eauto_unif_flags = auto_flags_of_state full_transparent_state let e_give_exact ?(flags=eauto_unif_flags) c = Proofview.Goal.enter { enter = begin fun gl -> - let t1 = Tacmach.New.pf_unsafe_type_of gl c in + let t1 = Tacmach.New.pf_unsafe_type_of gl (EConstr.of_constr c) in let t2 = Tacmach.New.pf_concl (Proofview.Goal.assume gl) in let sigma = Tacmach.New.project gl in if occur_existential sigma (EConstr.of_constr t1) || occur_existential sigma (EConstr.of_constr t2) then diff --git a/tactics/elim.ml b/tactics/elim.ml index b830ccefee..bcb1c05cc9 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -80,7 +80,7 @@ let general_decompose recognizer c = Proofview.Goal.enter { enter = begin fun gl -> let type_of = pf_unsafe_type_of gl in let sigma = project gl in - let typc = type_of c in + let typc = type_of (EConstr.of_constr c) in tclTHENS (cut typc) [ tclTHEN (intro_using tmphyp_name) (onLastHypId @@ -133,7 +133,7 @@ let induction_trailer abs_i abs_j bargs = (onLastHypId (fun id -> Proofview.Goal.nf_enter { enter = begin fun gl -> - let idty = pf_unsafe_type_of gl (mkVar id) in + let idty = pf_unsafe_type_of gl (EConstr.mkVar id) in let fvty = global_vars (pf_env gl) (project gl) (EConstr.of_constr idty) in let possible_bring_hyps = (List.tl (nLastDecls gl (abs_j - abs_i))) @ bargs.Tacticals.assums diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml index 1554d43f09..d1b14a9076 100644 --- a/tactics/eqdecide.ml +++ b/tactics/eqdecide.ml @@ -156,7 +156,7 @@ let rec solveArg hyps eqonleft op largs rargs = match largs, rargs with ] | a1 :: largs, a2 :: rargs -> Proofview.Goal.enter { enter = begin fun gl -> - let rectype = pf_unsafe_type_of gl a1 in + let rectype = pf_unsafe_type_of gl (EConstr.of_constr a1) in let decide = mkDecideEqGoal eqonleft op rectype a1 a2 in let tac hyp = solveArg (hyp :: hyps) eqonleft op largs rargs in let subtacs = @@ -226,7 +226,7 @@ let decideEquality rectype = let compare c1 c2 = Proofview.Goal.enter { enter = begin fun gl -> - let rectype = pf_unsafe_type_of gl c1 in + let rectype = pf_unsafe_type_of gl (EConstr.of_constr c1) in let decide = mkDecideEqGoal true (build_coq_sumbool ()) rectype c1 c2 in (tclTHENS (cut decide) [(tclTHEN intro diff --git a/tactics/equality.ml b/tactics/equality.ml index 64b56b99bc..ad80d2d1fb 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -181,8 +181,8 @@ let instantiate_lemma_all frzevars gl c ty l l2r concl = in List.map try_occ occs let instantiate_lemma gl c ty l l2r concl = - let sigma, ct = pf_type_of gl c in - let t = try snd (reduce_to_quantified_ind (pf_env gl) sigma ct) with UserError _ -> ct in + let sigma, ct = pf_type_of gl (EConstr.of_constr c) in + let t = try snd (reduce_to_quantified_ind (pf_env gl) sigma (EConstr.of_constr ct)) with UserError _ -> ct in let eqclause = Clenv.make_clenv_binding (pf_env gl) sigma (c,t) l in [eqclause] @@ -992,6 +992,7 @@ let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn = let pf_ty = mkArrow eqn absurd_term in let absurd_clause = apply_on_clause (pf,pf_ty) eq_clause in let pf = Clenvtac.clenv_value_cast_meta absurd_clause in + let pf = EConstr.of_constr pf in Proofview.Unsafe.tclEVARS sigma <*> Proofview.tclEFFECTS eff <*> tclTHENS (assert_after Anonymous absurd_term) @@ -1012,8 +1013,8 @@ let onEquality with_evars tac (c,lbindc) = Proofview.Goal.nf_enter { enter = begin fun gl -> let type_of = pf_unsafe_type_of gl in let reduce_to_quantified_ind = pf_apply Tacred.reduce_to_quantified_ind gl in - let t = type_of c in - let t' = try snd (reduce_to_quantified_ind t) with UserError _ -> t in + let t = type_of (EConstr.of_constr c) in + let t' = try snd (reduce_to_quantified_ind (EConstr.of_constr t)) with UserError _ -> t in let eq_clause = pf_apply make_clenv_binding gl (c,t') lbindc in let eq_clause' = Clenvtac.clenv_pose_dependent_evars with_evars eq_clause in let eqn = clenv_type eq_clause' in @@ -1327,7 +1328,7 @@ let inject_if_homogenous_dependent_pair ty = if not (Ind_tables.check_scheme (!eq_dec_scheme_kind_name()) (fst ind) && pf_apply is_conv gl (EConstr.of_constr ar1.(2)) (EConstr.of_constr 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 new_eq_args = [|pf_unsafe_type_of gl (EConstr.of_constr ar1.(3));ar1.(3);ar2.(3)|] in let inj2 = Coqlib.coq_constant "inj_pair2_eq_dec is missing" ["Logic";"Eqdep_dec"] "inj_pair2_eq_dec" in let c, eff = find_scheme (!eq_dec_scheme_kind_name()) (Univ.out_punivs ind) in @@ -1339,7 +1340,7 @@ let inject_if_homogenous_dependent_pair ty = tclTHENS (cut (mkApp (ceq,new_eq_args))) [clear [destVar hyp]; Proofview.V82.tactic (Tacmach.refine - (mkApp(inj2,[|ar1.(0);mkConst c;ar1.(1);ar1.(2);ar1.(3);ar2.(3);hyp|]))) + (EConstr.of_constr (mkApp(inj2,[|ar1.(0);mkConst c;ar1.(1);ar1.(2);ar1.(3);ar2.(3);hyp|])))) ])] with Exit -> Proofview.tclUNIT () @@ -1384,7 +1385,7 @@ let inject_at_positions env sigma l2r (eq,_,(t,t1,t2)) eq_clause posns tac = (Proofview.tclIGNORE (Proofview.Monad.List.map (fun (pf,ty) -> tclTHENS (cut ty) [inject_if_homogenous_dependent_pair ty; - Proofview.V82.tactic (Tacmach.refine pf)]) + Proofview.V82.tactic (Tacmach.refine (EConstr.of_constr pf))]) (if l2r then List.rev injectors else injectors))) (tac (List.length injectors))) diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml index 87e252a380..5d78fd5853 100644 --- a/tactics/hipattern.ml +++ b/tactics/hipattern.ml @@ -437,7 +437,7 @@ let find_eq_data eqn = (* fails with PatternMatchingFailure *) let extract_eq_args gl = function | MonomorphicLeibnizEq (e1,e2) -> - let t = pf_unsafe_type_of gl e1 in (t,e1,e2) + let t = pf_unsafe_type_of gl (EConstr.of_constr e1) in (t,e1,e2) | PolymorphicLeibnizEq (t,e1,e2) -> (t,e1,e2) | HeterogenousEq (t1,e1,t2,e2) -> if pf_conv_x gl (EConstr.of_constr t1) (EConstr.of_constr t2) then (t1,e1,e2) @@ -463,6 +463,7 @@ let match_eq_nf gls eqn (ref, hetero) = let n = if hetero then 4 else 3 in let args = List.init n (fun i -> mkGPatVar ("X" ^ string_of_int (i + 1))) in let pat = mkPattern (mkGAppRef ref args) in + let eqn = EConstr.of_constr eqn in match Id.Map.bindings (pf_matches gls pat eqn) with | [(m1,t);(m2,x);(m3,y)] -> assert (Id.equal m1 meta1 && Id.equal m2 meta2 && Id.equal m3 meta3); diff --git a/tactics/inv.ml b/tactics/inv.ml index eebc672224..2f5186f81f 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -438,7 +438,7 @@ let raw_inversion inv_kind id status names = let concl = Proofview.Goal.concl gl in let c = mkVar id in let (ind, t) = - try pf_apply Tacred.reduce_to_atomic_ind gl (pf_unsafe_type_of gl c) + try pf_apply Tacred.reduce_to_atomic_ind gl (EConstr.of_constr (pf_unsafe_type_of gl (EConstr.of_constr c))) with UserError _ -> let msg = str "The type of " ++ pr_id id ++ str " is not inductive." in CErrors.user_err msg diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index 2754db0101..02909243d5 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -628,7 +628,7 @@ module New = struct (Proofview.Goal.nf_enter { enter = begin fun gl -> let indclause = Tacmach.New.of_old (fun gl -> mk_clenv_from gl (c, t)) gl in (* applying elimination_scheme just a little modified *) - let elimclause = Tacmach.New.of_old (fun gls -> mk_clenv_from gls (elim,Tacmach.New.pf_unsafe_type_of gl elim)) gl in + let elimclause = Tacmach.New.of_old (fun gls -> mk_clenv_from gls (elim,Tacmach.New.pf_unsafe_type_of gl (EConstr.of_constr elim))) gl in let indmv = match kind_of_term (last_arg elimclause.evd (EConstr.of_constr elimclause.templval.Evd.rebus)) with | Meta mv -> mv @@ -678,7 +678,7 @@ module New = struct let elimination_then tac c = Proofview.Goal.nf_enter { enter = begin fun gl -> - let (ind,t) = pf_reduce_to_quantified_ind gl (pf_unsafe_type_of gl c) in + let (ind,t) = pf_reduce_to_quantified_ind gl (EConstr.of_constr (pf_unsafe_type_of gl (EConstr.of_constr c))) in let isrec,mkelim = match (Global.lookup_mind (fst (fst ind))).mind_record with | None -> true,gl_make_elim diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 639a12b343..b9a219a2c9 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -457,6 +457,7 @@ let assert_before_then_gen b naming t tac = let open Context.Rel.Declaration in Proofview.Goal.enter { enter = begin fun gl -> let id = find_name b (LocalAssum (Anonymous,t)) naming gl in + let t = EConstr.of_constr t in Tacticals.New.tclTHENLAST (Proofview.V82.tactic (fun gl -> @@ -476,6 +477,7 @@ let assert_after_then_gen b naming t tac = let open Context.Rel.Declaration in Proofview.Goal.enter { enter = begin fun gl -> let id = find_name b (LocalAssum (Anonymous,t)) naming gl in + let t = EConstr.of_constr t in Tacticals.New.tclTHENFIRST (Proofview.V82.tactic (fun gl -> @@ -1303,6 +1305,7 @@ let clenv_refine_in ?(sidecond_first=false) with_evars ?(with_classes=true) if not with_evars && occur_meta clenv.evd (EConstr.of_constr new_hyp_typ) then error_uninstantiated_metas new_hyp_typ clenv; let new_hyp_prf = clenv_value clenv in + let new_hyp_prf = EConstr.of_constr new_hyp_prf in let exact_tac = Proofview.V82.tactic (Tacmach.refine_no_check new_hyp_prf) in let naming = NamingMustBe (dloc,targetid) in let with_clear = do_replace (Some id) naming in @@ -1434,7 +1437,7 @@ let general_elim with_evars clear_flag (c, lbindc) elim = let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let ct = Retyping.get_type_of env sigma (EConstr.of_constr c) in - let t = try snd (reduce_to_quantified_ind env sigma ct) with UserError _ -> ct in + let t = try snd (reduce_to_quantified_ind env sigma (EConstr.of_constr ct)) with UserError _ -> ct in let elimtac = elimination_clause_scheme with_evars in let indclause = make_clenv_binding env sigma (c, t) lbindc in let sigma = meta_merge sigma (clear_metas indclause.evd) in @@ -1452,6 +1455,7 @@ let general_case_analysis_in_context with_evars clear_flag (c,lbindc) = let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl gl in let t = Retyping.get_type_of env (Sigma.to_evar_map sigma) (EConstr.of_constr c) in + let t = EConstr.of_constr t in let (mind,_) = reduce_to_quantified_ind env (Sigma.to_evar_map sigma) t in let sort = Tacticals.New.elimination_sort_of_goal gl in let Sigma (elim, sigma, p) = @@ -1491,7 +1495,8 @@ let find_ind_eliminator ind s gl = evd, c let find_eliminator c gl = - let ((ind,u),t) = Tacmach.New.pf_reduce_to_quantified_ind gl (Tacmach.New.pf_unsafe_type_of gl c) in + let c = EConstr.of_constr c in + let ((ind,u),t) = Tacmach.New.pf_reduce_to_quantified_ind gl (EConstr.of_constr (Tacmach.New.pf_unsafe_type_of gl c)) in if is_nonrec ind then raise IsNonrec; let evd, c = find_ind_eliminator ind (Tacticals.New.elimination_sort_of_goal gl) gl in evd, {elimindex = None; elimbody = (c,NoBindings); @@ -1637,6 +1642,7 @@ let descend_in_conjunctions avoid tac (err, info) c = let sigma = Tacmach.New.project gl in try let t = Retyping.get_type_of env sigma (EConstr.of_constr c) in + let t = EConstr.of_constr t in let ((ind,u),t) = reduce_to_quantified_ind env sigma t in let sign,ccl = decompose_prod_assum t in match match_with_tuple sigma ccl with @@ -1661,6 +1667,7 @@ let descend_in_conjunctions avoid tac (err, info) c = match make_projection env sigma params cstr sign elim i n c u with | None -> Tacticals.New.tclFAIL 0 (mt()) | Some (p,pt) -> + let p = EConstr.of_constr p in Tacticals.New.tclTHENS (assert_before_gen false (NamingAvoid avoid) pt) [Proofview.V82.tactic (refine p); @@ -1920,7 +1927,7 @@ let apply_in_delayed_once sidecond_first with_delta with_destruct with_evars nam let cut_and_apply c = Proofview.Goal.nf_enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in - match kind_of_term (Tacmach.New.pf_hnf_constr gl (Tacmach.New.pf_unsafe_type_of gl c)) with + match kind_of_term (Tacmach.New.pf_hnf_constr gl (EConstr.of_constr (Tacmach.New.pf_unsafe_type_of gl (EConstr.of_constr c)))) with | Prod (_,c1,c2) when EConstr.Vars.noccurn sigma 1 (EConstr.of_constr c2) -> let concl = Proofview.Goal.concl gl in let env = Tacmach.New.pf_env gl in @@ -2201,6 +2208,7 @@ let constructor_tac with_evars expctdnumopt i lbind = let reduce_to_quantified_ind = Tacmach.New.pf_apply Tacred.reduce_to_quantified_ind gl in + let cl = EConstr.of_constr cl in let (mind,redcl) = reduce_to_quantified_ind cl in let nconstr = Array.length (snd (Global.lookup_inductive (fst mind))).mind_consnames in @@ -2240,6 +2248,7 @@ let any_constructor with_evars tacopt = let reduce_to_quantified_ind = Tacmach.New.pf_apply Tacred.reduce_to_quantified_ind gl in + let cl = EConstr.of_constr cl in let mind = fst (reduce_to_quantified_ind cl) in let nconstr = Array.length (snd (Global.lookup_inductive (fst mind))).mind_consnames in @@ -2298,7 +2307,8 @@ let my_find_eq_data_decompose gl t = let intro_decomp_eq loc l thin tac id = Proofview.Goal.nf_enter { enter = begin fun gl -> let c = mkVar id in - let t = Tacmach.New.pf_unsafe_type_of gl c in + let t = Tacmach.New.pf_unsafe_type_of gl (EConstr.of_constr c) in + let t = EConstr.of_constr t in let _,t = Tacmach.New.pf_reduce_to_quantified_ind gl t in match my_find_eq_data_decompose gl t with | Some (eq,u,eq_args) -> @@ -2312,7 +2322,8 @@ let intro_decomp_eq loc l thin tac id = let intro_or_and_pattern loc with_evars bracketed ll thin tac id = Proofview.Goal.enter { enter = begin fun gl -> let c = mkVar id in - let t = Tacmach.New.pf_unsafe_type_of gl c in + let t = Tacmach.New.pf_unsafe_type_of gl (EConstr.of_constr c) in + let t = EConstr.of_constr t in let (ind,t) = Tacmach.New.pf_reduce_to_quantified_ind gl t in let branchsigns = compute_constructor_signatures false ind in let nv_with_let = Array.map List.length branchsigns in @@ -2337,7 +2348,7 @@ let rewrite_hyp_then assert_style with_evars thin l2r id tac = let sigma = Tacmach.New.project gl in let type_of = Tacmach.New.pf_unsafe_type_of gl in let whd_all = Tacmach.New.pf_apply whd_all gl in - let t = whd_all (EConstr.of_constr (type_of (mkVar id))) in + let t = whd_all (EConstr.of_constr (type_of (EConstr.mkVar id))) in let eqtac, thin = match match_with_equality_type sigma t with | Some (hdcncl,[_;lhs;rhs]) -> if l2r && isVar lhs && not (occur_var env sigma (destVar lhs) (EConstr.of_constr rhs)) then @@ -2747,7 +2758,7 @@ let forward b usetac ipat c = match usetac with | None -> Proofview.Goal.enter { enter = begin fun gl -> - let t = Tacmach.New.pf_unsafe_type_of gl c in + let t = Tacmach.New.pf_unsafe_type_of gl (EConstr.of_constr c) in let hd = head_ident c in Tacticals.New.tclTHENFIRST (assert_as true hd ipat t) (exact_no_check c) end } @@ -3233,7 +3244,7 @@ let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = | Var id -> id | _ -> let type_of = Tacmach.New.pf_unsafe_type_of gl in - id_of_name_using_hdchar (Global.env()) (type_of c) Anonymous in + id_of_name_using_hdchar (Global.env()) (type_of (EConstr.of_constr c)) Anonymous in let x = fresh_id_in_env avoid id env in Tacticals.New.tclTHEN (letin_tac None (Name x) c None allHypsAndConcl) @@ -3645,7 +3656,7 @@ let abstract_args gl generalize_vars dep id defined f args = let decl = List.hd rel in RelDecl.get_name decl, RelDecl.get_type decl, c in - let argty = Tacmach.pf_unsafe_type_of gl arg in + let argty = Tacmach.pf_unsafe_type_of gl (EConstr.of_constr arg) in let sigma', ty = Evarsolve.refresh_universes (Some true) env !sigma (EConstr.of_constr ty) in let () = sigma := sigma' in let lenctx = List.length ctx in @@ -3686,7 +3697,7 @@ let abstract_args gl generalize_vars dep id defined f args = true, mkApp (f', before), after in if dogen then - let tyf' = Tacmach.pf_unsafe_type_of gl f' in + let tyf' = Tacmach.pf_unsafe_type_of gl (EConstr.of_constr f') in let arity, ctx, ctxenv, c', args, eqs, refls, nogen, vars, env = Array.fold_left aux (tyf',[],env,f',[],[],[],Id.Set.empty,Id.Set.empty,env) args' in @@ -3794,6 +3805,7 @@ let specialize_eqs id gl = let ty' = Tacred.whd_simpl env !evars (EConstr.of_constr ty') and acc' = Tacred.whd_simpl env !evars (EConstr.of_constr acc') in let ty' = Evarutil.nf_evar !evars ty' in + let ty' = EConstr.of_constr ty' in if worked then tclTHENFIRST (Tacmach.internal_cut true id ty') (Proofview.V82.of_tactic (exact_no_check ((* refresh_universes_strict *) acc'))) gl @@ -4014,6 +4026,7 @@ let compute_elim_signature (evd,(elimc,elimt),ind_type_guess) names_info = let guess_elim isrec dep s hyp0 gl = let tmptyp0 = Tacmach.New.pf_get_hyp_typ hyp0 gl in + let tmptyp0 = EConstr.of_constr tmptyp0 in let mind,_ = Tacmach.New.pf_reduce_to_quantified_ind gl tmptyp0 in let evd, elimc = if isrec && not (is_nonrec (fst mind)) then find_ind_eliminator (fst mind) s gl @@ -4028,12 +4041,13 @@ let guess_elim isrec dep s hyp0 gl = let Sigma (ind, sigma, _) = build_case_analysis_scheme_default env sigma mind s in (Sigma.to_evar_map sigma, ind) in - let elimt = Tacmach.New.pf_unsafe_type_of gl elimc in + let elimt = Tacmach.New.pf_unsafe_type_of gl (EConstr.of_constr elimc) in evd, ((elimc, NoBindings), elimt), mkIndU mind let given_elim hyp0 (elimc,lbind as e) gl = let tmptyp0 = Tacmach.New.pf_get_hyp_typ hyp0 gl in let ind_type_guess,_ = decompose_app ((strip_prod tmptyp0)) in + let elimc = EConstr.of_constr elimc in Tacmach.New.project gl, (e, Tacmach.New.pf_unsafe_type_of gl elimc), ind_type_guess type scheme_signature = @@ -4069,7 +4083,7 @@ let get_elim_signature elim hyp0 gl = compute_elim_signature (given_elim hyp0 elim gl) hyp0 let is_functional_induction elimc gl = - let scheme = compute_elim_sig ~elimc (Tacmach.New.pf_unsafe_type_of gl (fst elimc)) in + let scheme = compute_elim_sig ~elimc (Tacmach.New.pf_unsafe_type_of gl (EConstr.of_constr (fst elimc))) in (* The test is not safe: with non-functional induction on non-standard induction scheme, this may fail *) Option.is_empty scheme.indarg @@ -4466,7 +4480,7 @@ let induction_gen_l isrec with_evars elim names lc = let type_of = Tacmach.New.pf_unsafe_type_of gl in let sigma = Tacmach.New.project gl in let x = - id_of_name_using_hdchar (Global.env()) (type_of c) Anonymous in + id_of_name_using_hdchar (Global.env()) (type_of (EConstr.of_constr c)) Anonymous in let id = new_fresh_id [] x gl in let newl' = List.map (fun r -> replace_term sigma (EConstr.of_constr c) (EConstr.mkVar id) (EConstr.of_constr r)) l' in @@ -4606,6 +4620,7 @@ let elim_scheme_type elim t = let elim_type t = Proofview.Goal.s_enter { s_enter = begin fun gl -> + let t = EConstr.of_constr t in let (ind,t) = Tacmach.New.pf_apply reduce_to_atomic_ind gl t in let evd, elimc = find_ind_eliminator (fst ind) (Tacticals.New.elimination_sort_of_goal gl) gl in Sigma.Unsafe.of_pair (elim_scheme_type elimc t, evd) @@ -4613,6 +4628,7 @@ let elim_type t = let case_type t = Proofview.Goal.s_enter { s_enter = begin fun gl -> + let t = EConstr.of_constr t in let sigma = Proofview.Goal.sigma gl in let env = Tacmach.New.pf_env gl in let (ind,t) = reduce_to_atomic_ind env (Sigma.to_evar_map sigma) t in @@ -4717,7 +4733,7 @@ let (forward_setoid_symmetry_in, setoid_symmetry_in) = Hook.make () let symmetry_in id = Proofview.Goal.enter { enter = begin fun gl -> - let ctype = Tacmach.New.pf_unsafe_type_of gl (mkVar id) in + let ctype = Tacmach.New.pf_unsafe_type_of gl (EConstr.mkVar id) in let sign,t = decompose_prod_assum ctype in Proofview.tclORELSE begin -- cgit v1.2.3 From 0489e8b56d7e10f7111c0171960e25d32201b963 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 11 Nov 2016 21:55:33 +0100 Subject: Clenv API using EConstr. --- tactics/auto.ml | 5 ++-- tactics/autorewrite.ml | 6 ++--- tactics/class_tactics.ml | 21 ++++++++++----- tactics/eauto.ml | 3 ++- tactics/equality.ml | 38 +++++++++++++++++--------- tactics/hints.ml | 12 +++++---- tactics/leminv.ml | 4 +-- tactics/tacticals.ml | 12 +++++---- tactics/tactics.ml | 70 +++++++++++++++++++++++++++++++++--------------- 9 files changed, 113 insertions(+), 58 deletions(-) (limited to 'tactics') diff --git a/tactics/auto.ml b/tactics/auto.ml index 7462b8d855..2b654f5634 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -84,11 +84,12 @@ let connect_hint_clenv poly (c, _, ctx) clenv gl = (** Refresh the instance of the hint *) let (subst, ctx) = Universes.fresh_universe_context_set_instance ctx in let map c = Vars.subst_univs_level_constr subst c in + let emap c = EConstr.Vars.subst_univs_level_constr subst c in let evd = Evd.merge_context_set Evd.univ_flexible evd ctx in (** Only metas are mentioning the old universes. *) let clenv = { - templval = Evd.map_fl map clenv.templval; - templtyp = Evd.map_fl map clenv.templtyp; + templval = Evd.map_fl emap clenv.templval; + templtyp = Evd.map_fl emap clenv.templtyp; evd = Evd.map_metas map evd; env = Proofview.Goal.env gl; } in diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index 80b9ec06e1..b567344c99 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -257,12 +257,12 @@ type hypinfo = { let decompose_applied_relation metas env sigma c ctype left2right = let find_rel ty = - let eqclause = Clenv.mk_clenv_from_env env sigma None (c,ty) in + let eqclause = Clenv.mk_clenv_from_env env sigma None (EConstr.of_constr c,EConstr.of_constr ty) in let eqclause = if metas then eqclause else clenv_pose_metas_as_evars eqclause (Evd.undefined_metas eqclause.evd) in - let (equiv, args) = decompose_app (Clenv.clenv_type eqclause) in + let (equiv, args) = decompose_app (EConstr.Unsafe.to_constr (Clenv.clenv_type eqclause)) in let rec split_last_two = function | [c1;c2] -> [],(c1, c2) | x::y::z -> @@ -276,7 +276,7 @@ let decompose_applied_relation metas env sigma c ctype left2right = in (* if not (evd_convertible env eqclause.evd ty1 ty2) then None *) (* else *) - Some { hyp_cl=eqclause; hyp_prf=(Clenv.clenv_value eqclause); hyp_ty = ty; + 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; } with Not_found -> None diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index a2699ba8d9..a8768b6edd 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -227,6 +227,7 @@ let e_give_exact flags poly (c,clenv) gl = else c, gl in let t1 = pf_unsafe_type_of gl (EConstr.of_constr c) in + let t1 = EConstr.of_constr t1 in Proofview.V82.of_tactic (Clenvtac.unify ~flags t1 <*> exact_no_check c) gl let unify_e_resolve poly flags = { enter = begin fun gls (c,_,clenv) -> @@ -247,6 +248,7 @@ let unify_resolve_refine poly flags = { enter = begin fun gls ((c, t, ctx),n,clenv) -> let env = Proofview.Goal.env gls in let concl = Proofview.Goal.concl gls in + let concl = EConstr.of_constr concl in Refine.refine ~unsafe:true { Sigma.run = fun sigma -> let sigma = Sigma.to_evar_map sigma in let sigma, term, ty = @@ -259,17 +261,20 @@ let unify_resolve_refine poly flags = let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in sigma, c, t in + let open EConstr in + let ty = EConstr.of_constr ty in + let term = EConstr.of_constr term in let sigma', cl = Clenv.make_evar_clause env sigma ?len:n ty in - let term = applistc term (List.map (fun x -> x.hole_evar) cl.cl_holes) in + let term = applist (term, List.map (fun x -> x.hole_evar) cl.cl_holes) in let sigma' = let evdref = ref sigma' in if not (Evarconv.e_cumul env ~ts:flags.core_unify_flags.modulo_delta - evdref (EConstr.of_constr cl.cl_concl) (EConstr.of_constr concl)) then - Type_errors.error_actual_type env + evdref cl.cl_concl concl) then + Pretype_errors.error_actual_type_core env sigma' {Environ.uj_val = term; Environ.uj_type = cl.cl_concl} concl; !evdref - in Sigma.here (EConstr.of_constr term) (Sigma.Unsafe.of_evar_map sigma') } + in Sigma.here term (Sigma.Unsafe.of_evar_map sigma') } end } (** Dealing with goals of the form A -> B and hints of the form @@ -279,9 +284,11 @@ let clenv_of_prods poly nprods (c, clenv) gl = let (c, _, _) = c in if poly || Int.equal nprods 0 then Some (None, clenv) else + let c = EConstr.of_constr c in let sigma = Tacmach.New.project gl in - let ty = Retyping.get_type_of (Proofview.Goal.env gl) sigma (EConstr.of_constr c) in - let diff = nb_prod sigma (EConstr.of_constr ty) - nprods in + let ty = Retyping.get_type_of (Proofview.Goal.env gl) sigma c in + let ty = EConstr.of_constr ty in + let diff = nb_prod sigma ty - nprods in if Pervasives.(>=) diff 0 then (* Was Some clenv... *) Some (Some diff, @@ -1515,7 +1522,7 @@ let autoapply c i gl = let flags = auto_unif_flags Evar.Set.empty (Hints.Hint_db.transparent_state (Hints.searchtable_map i)) in let cty = pf_unsafe_type_of gl (EConstr.of_constr c) in - let ce = mk_clenv_from gl (c,cty) in + let ce = mk_clenv_from gl (EConstr.of_constr c,EConstr.of_constr cty) in let tac = { enter = fun gl -> (unify_e_resolve false flags).enter gl ((c,cty,Univ.ContextSet.empty),0,ce) } in Proofview.V82.of_tactic (Proofview.Goal.nf_enter tac) gl diff --git a/tactics/eauto.ml b/tactics/eauto.ml index 2fad4fcf7f..7b07c93097 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -31,9 +31,10 @@ let eauto_unif_flags = auto_flags_of_state full_transparent_state let e_give_exact ?(flags=eauto_unif_flags) c = Proofview.Goal.enter { enter = begin fun gl -> let t1 = Tacmach.New.pf_unsafe_type_of gl (EConstr.of_constr c) in + let t1 = EConstr.of_constr t1 in let t2 = Tacmach.New.pf_concl (Proofview.Goal.assume gl) in let sigma = Tacmach.New.project gl in - if occur_existential sigma (EConstr.of_constr t1) || occur_existential sigma (EConstr.of_constr t2) then + if occur_existential sigma t1 || occur_existential sigma (EConstr.of_constr t2) then Tacticals.New.tclTHEN (Clenvtac.unify ~flags t1) (exact_no_check c) else exact_check c end } diff --git a/tactics/equality.ml b/tactics/equality.ml index ad80d2d1fb..fbf461f6f8 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -144,7 +144,7 @@ let freeze_initial_evars sigma flags clause = (* We take evars of the type: this may include old evars! For excluding *) (* all old evars, including the ones occurring in the rewriting lemma, *) (* we would have to take the clenv_value *) - let newevars = Evd.evars_of_term (clenv_type clause) in + let newevars = Evd.evars_of_term (EConstr.Unsafe.to_constr (clenv_type clause)) in let evars = fold_undefined (fun evk _ evars -> if Evar.Set.mem evk newevars then evars @@ -165,8 +165,11 @@ let side_tac tac sidetac = let instantiate_lemma_all frzevars gl c ty l l2r concl = let env = Proofview.Goal.env gl in + let c = EConstr.of_constr c in + let ty = EConstr.of_constr ty in + let l = Miscops.map_bindings EConstr.of_constr l in let eqclause = pf_apply Clenv.make_clenv_binding gl (c,ty) l in - let (equiv, args) = decompose_appvect (Clenv.clenv_type eqclause) in + let (equiv, args) = decompose_appvect (EConstr.Unsafe.to_constr (Clenv.clenv_type eqclause)) in let arglen = Array.length args in let () = if arglen < 2 then error "The term provided is not an applied relation." in let c1 = args.(arglen - 2) in @@ -181,8 +184,11 @@ let instantiate_lemma_all frzevars gl c ty l l2r concl = in List.map try_occ occs let instantiate_lemma gl c ty l l2r concl = - let sigma, ct = pf_type_of gl (EConstr.of_constr c) in + let c = EConstr.of_constr c in + let sigma, ct = pf_type_of gl c in let t = try snd (reduce_to_quantified_ind (pf_env gl) sigma (EConstr.of_constr ct)) with UserError _ -> ct in + let t = EConstr.of_constr t in + let l = Miscops.map_bindings EConstr.of_constr l in let eqclause = Clenv.make_clenv_binding (pf_env gl) sigma (c,t) l in [eqclause] @@ -975,9 +981,11 @@ let eq_baseid = Id.of_string "e" let apply_on_clause (f,t) clause = let sigma = clause.evd in + let f = EConstr.of_constr f in + let t = EConstr.of_constr t in let f_clause = mk_clenv_from_env clause.env sigma None (f,t) in let argmv = - (match kind_of_term (last_arg f_clause.evd (EConstr.of_constr f_clause.templval.Evd.rebus)) with + (match kind_of_term (last_arg f_clause.evd f_clause.templval.Evd.rebus) with | Meta mv -> mv | _ -> user_err (str "Ill-formed clause applicator.")) in clenv_fchain ~with_univs:false argmv f_clause clause @@ -992,7 +1000,6 @@ let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn = let pf_ty = mkArrow eqn absurd_term in let absurd_clause = apply_on_clause (pf,pf_ty) eq_clause in let pf = Clenvtac.clenv_value_cast_meta absurd_clause in - let pf = EConstr.of_constr pf in Proofview.Unsafe.tclEVARS sigma <*> Proofview.tclEFFECTS eff <*> tclTHENS (assert_after Anonymous absurd_term) @@ -1011,13 +1018,17 @@ let discrEq (lbeq,_,(t,t1,t2) as u) eq_clause = let onEquality with_evars tac (c,lbindc) = Proofview.Goal.nf_enter { enter = begin fun gl -> + let c = EConstr.of_constr c in + let lbindc = Miscops.map_bindings EConstr.of_constr lbindc in let type_of = pf_unsafe_type_of gl in let reduce_to_quantified_ind = pf_apply Tacred.reduce_to_quantified_ind gl in - let t = type_of (EConstr.of_constr c) in + let t = type_of c in let t' = try snd (reduce_to_quantified_ind (EConstr.of_constr t)) with UserError _ -> t in + let t' = EConstr.of_constr t' in let eq_clause = pf_apply make_clenv_binding gl (c,t') lbindc in let eq_clause' = Clenvtac.clenv_pose_dependent_evars with_evars eq_clause in let eqn = clenv_type eq_clause' in + let eqn = EConstr.Unsafe.to_constr eqn in let (eq,u,eq_args) = find_this_eq_data_decompose gl eqn in tclTHEN (Proofview.Unsafe.tclEVARS eq_clause'.evd) @@ -1371,7 +1382,8 @@ let inject_at_positions env sigma l2r (eq,_,(t,t1,t2)) eq_clause posns tac = let sigma, pf_typ = Typing.type_of env sigma (EConstr.of_constr pf) in let inj_clause = apply_on_clause (pf,pf_typ) eq_clause in let pf = Clenvtac.clenv_value_cast_meta inj_clause in - let ty = simplify_args env sigma (clenv_type inj_clause) in + let ty = simplify_args env sigma (EConstr.Unsafe.to_constr (clenv_type inj_clause)) in + let pf = EConstr.Unsafe.to_constr pf in evdref := sigma; Some (pf, ty) with Failure _ -> None @@ -1405,7 +1417,7 @@ let injEqThen tac l2r (eq,_,(t,t1,t2) as u) eq_clause = tclZEROMSG (str"Nothing to inject.") | Inr posns -> inject_at_positions env sigma l2r u eq_clause posns - (tac (clenv_value eq_clause)) + (tac (EConstr.Unsafe.to_constr (clenv_value eq_clause))) let get_previous_hyp_position id gl = let rec aux dest = function @@ -1464,10 +1476,10 @@ let decompEqThen ntac (lbeq,_,(t,t1,t2) as u) clause = | Inl (cpath, (_,dirn), _) -> discr_positions env sigma u clause cpath dirn | Inr [] -> (* Change: do not fail, simplify clear this trivial hyp *) - ntac (clenv_value clause) 0 + ntac (EConstr.Unsafe.to_constr (clenv_value clause)) 0 | Inr posns -> inject_at_positions env sigma true u clause posns - (ntac (clenv_value clause)) + (ntac (EConstr.Unsafe.to_constr (clenv_value clause))) end } let dEqThen with_evars ntac = function @@ -1478,9 +1490,11 @@ let dEq with_evars = dEqThen with_evars (fun clear_flag c x -> (apply_clear_request clear_flag (use_clear_hyp_by_default ()) c)) -let intro_decomp_eq tac data cl = +let intro_decomp_eq tac data (c, t) = Proofview.Goal.enter { enter = begin fun gl -> - let cl = pf_apply make_clenv_binding gl cl NoBindings in + let c = EConstr.of_constr c in + let t = EConstr.of_constr t in + let cl = pf_apply make_clenv_binding gl (c, t) NoBindings in decompEqThen (fun _ -> tac) data cl end } diff --git a/tactics/hints.ml b/tactics/hints.ml index 57358bb769..ea95fb1ade 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -276,9 +276,11 @@ let strip_params env c = let instantiate_hint env sigma p = let mk_clenv (c, cty, ctx) = let sigma = Evd.merge_context_set univ_flexible sigma ctx in + let c = EConstr.of_constr c in + let cty = EConstr.of_constr cty in let cl = mk_clenv_from_env env sigma None (c,cty) in {cl with templval = - { cl.templval with rebus = strip_params env cl.templval.rebus }; + { cl.templval with rebus = EConstr.of_constr (strip_params env (EConstr.Unsafe.to_constr cl.templval.rebus)) }; env = empty_env} in let code = match p.code.obj with @@ -765,9 +767,9 @@ let make_apply_entry env sigma (eapply,hnf,verbose) pri poly ?(name=PathAny) (c, match kind_of_term cty with | Prod _ -> let sigma' = Evd.merge_context_set univ_flexible sigma ctx in - let ce = mk_clenv_from_env env sigma' None (c,cty) in + let ce = mk_clenv_from_env env sigma' None (EConstr.of_constr c,EConstr.of_constr cty) in let c' = clenv_type (* ~reduce:false *) ce in - let pat = Patternops.pattern_of_constr env ce.evd (EConstr.of_constr c') in + let pat = Patternops.pattern_of_constr env ce.evd c' in let hd = try head_pattern_bound pat with BoundPattern -> failwith "make_apply_entry" in @@ -912,10 +914,10 @@ let make_trivial env sigma poly ?(name=PathAny) r = let sigma = Evd.merge_context_set univ_flexible sigma ctx in let t = hnf_constr env sigma (EConstr.of_constr (unsafe_type_of env sigma (EConstr.of_constr c))) in let hd = head_of_constr_reference sigma (EConstr.of_constr (head_constr sigma t)) in - let ce = mk_clenv_from_env env sigma None (c,t) in + let ce = mk_clenv_from_env env sigma None (EConstr.of_constr c,EConstr.of_constr t) in (Some hd, { pri=1; poly = poly; - pat = Some (Patternops.pattern_of_constr env ce.evd (EConstr.of_constr (clenv_type ce))); + pat = Some (Patternops.pattern_of_constr env ce.evd (clenv_type ce)); name = name; db = None; secvars = secvars_of_constr env c; diff --git a/tactics/leminv.ml b/tactics/leminv.ml index 85910355ea..16a048af82 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -258,8 +258,8 @@ let add_inversion_lemma_exn na com comsort bool tac = let lemInv id c gls = try - let clause = mk_clenv_type_of gls c in - let clause = clenv_constrain_last_binding (mkVar id) clause in + let clause = mk_clenv_type_of gls (EConstr.of_constr 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 with | NoSuchBinding -> diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index 02909243d5..4599470511 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -622,20 +622,22 @@ module New = struct (* c should be of type A1->.. An->B with B an inductive definition *) let general_elim_then_using mk_elim isrec allnames tac predicate ind (c, t) = + let c = EConstr.of_constr c in + let t = EConstr.of_constr t in Proofview.Goal.nf_enter { enter = begin fun gl -> let sigma, elim = Tacmach.New.of_old (mk_elim ind) gl in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (Proofview.Goal.nf_enter { enter = begin fun gl -> let indclause = Tacmach.New.of_old (fun gl -> mk_clenv_from gl (c, t)) gl in (* applying elimination_scheme just a little modified *) - let elimclause = Tacmach.New.of_old (fun gls -> mk_clenv_from gls (elim,Tacmach.New.pf_unsafe_type_of gl (EConstr.of_constr elim))) gl in + let elimclause = Tacmach.New.of_old (fun gls -> mk_clenv_from gls (EConstr.of_constr elim,EConstr.of_constr (Tacmach.New.pf_unsafe_type_of gl (EConstr.of_constr elim)))) gl in let indmv = - match kind_of_term (last_arg elimclause.evd (EConstr.of_constr elimclause.templval.Evd.rebus)) with + match kind_of_term (last_arg elimclause.evd elimclause.templval.Evd.rebus) with | Meta mv -> mv | _ -> anomaly (str"elimination") in let pmv = - let p, _ = decompose_app elimclause.templtyp.Evd.rebus in + let p, _ = decompose_app (EConstr.Unsafe.to_constr elimclause.templtyp.Evd.rebus) in match kind_of_term p with | Meta p -> p | _ -> @@ -655,11 +657,11 @@ module New = struct let elimclause' = match predicate with | None -> elimclause' - | Some p -> clenv_unify ~flags Reduction.CONV (mkMeta pmv) p elimclause' + | Some p -> clenv_unify ~flags Reduction.CONV (EConstr.mkMeta pmv) (EConstr.of_constr p) elimclause' in let clenv' = Tacmach.New.of_old (clenv_unique_resolver ~flags elimclause') gl in let after_tac i = - let (hd,largs) = decompose_app clenv'.templtyp.Evd.rebus in + let (hd,largs) = decompose_app (EConstr.Unsafe.to_constr clenv'.templtyp.Evd.rebus) in let ba = { branchsign = branchsigns.(i); branchnames = brnames.(i); nassums = List.length branchsigns.(i); diff --git a/tactics/tactics.ml b/tactics/tactics.ml index b9a219a2c9..f262aefa7f 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1301,11 +1301,11 @@ let clenv_refine_in ?(sidecond_first=false) with_evars ?(with_classes=true) else clenv in let new_hyp_typ = clenv_type clenv in + let new_hyp_typ = EConstr.Unsafe.to_constr new_hyp_typ in if not with_evars then check_unresolved_evars_of_metas sigma0 clenv; if not with_evars && occur_meta clenv.evd (EConstr.of_constr new_hyp_typ) then error_uninstantiated_metas new_hyp_typ clenv; let new_hyp_prf = clenv_value clenv in - let new_hyp_prf = EConstr.of_constr new_hyp_prf in let exact_tac = Proofview.V82.tactic (Tacmach.refine_no_check new_hyp_prf) in let naming = NamingMustBe (dloc,targetid) in let with_clear = do_replace (Some id) naming in @@ -1396,9 +1396,12 @@ let elimination_clause_scheme with_evars ?(with_classes=true) ?(flags=elim_flags let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let elim = contract_letin_in_lam_header elim in + let bindings = Miscops.map_bindings EConstr.of_constr bindings in + let elim = EConstr.of_constr elim in + let elimty = EConstr.of_constr elimty in let elimclause = make_clenv_binding env sigma (elim, elimty) bindings in let indmv = - (match kind_of_term (nth_arg i elimclause.templval.rebus) with + (match kind_of_term (nth_arg i (EConstr.Unsafe.to_constr elimclause.templval.rebus)) with | Meta mv -> mv | _ -> user_err ~hdr:"elimination_clause" (str "The type of elimination clause is not well-formed.")) @@ -1438,8 +1441,10 @@ let general_elim with_evars clear_flag (c, lbindc) elim = let sigma = Tacmach.New.project gl in let ct = Retyping.get_type_of env sigma (EConstr.of_constr c) in let t = try snd (reduce_to_quantified_ind env sigma (EConstr.of_constr ct)) with UserError _ -> ct in + let t = EConstr.of_constr t in let elimtac = elimination_clause_scheme with_evars in - let indclause = make_clenv_binding env sigma (c, t) lbindc in + let lbindc = Miscops.map_bindings EConstr.of_constr lbindc in + let indclause = make_clenv_binding env sigma (EConstr.of_constr c, t) lbindc in let sigma = meta_merge sigma (clear_metas indclause.evd) in Proofview.Unsafe.tclEVARS sigma <*> Tacticals.New.tclTHEN @@ -1561,8 +1566,11 @@ let elimination_in_clause_scheme with_evars ?(flags=elim_flags ()) let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let elim = contract_letin_in_lam_header elim in + let elim = EConstr.of_constr elim in + let elimty = EConstr.of_constr elimty in + let bindings = Miscops.map_bindings EConstr.of_constr bindings in let elimclause = make_clenv_binding env sigma (elim, elimty) bindings in - let indmv = destMeta (nth_arg i elimclause.templval.rebus) in + let indmv = destMeta (nth_arg i (EConstr.Unsafe.to_constr elimclause.templval.rebus)) in let hypmv = try match List.remove Int.equal indmv (clenv_independent elimclause) with | [a] -> a @@ -1570,12 +1578,13 @@ let elimination_in_clause_scheme with_evars ?(flags=elim_flags ()) with Failure _ -> user_err ~hdr:"elimination_clause" (str "The type of elimination clause is not well-formed.") in let elimclause' = clenv_fchain ~flags indmv elimclause indclause in - let hyp = mkVar id in - let hyp_typ = Retyping.get_type_of env sigma (EConstr.of_constr hyp) in + let hyp = EConstr.mkVar id in + let hyp_typ = Retyping.get_type_of env sigma hyp in + let hyp_typ = EConstr.of_constr hyp_typ in let hypclause = mk_clenv_from_env env sigma (Some 0) (hyp, hyp_typ) in let elimclause'' = clenv_fchain_in id ~flags hypmv elimclause' hypclause in let new_hyp_typ = clenv_type elimclause'' in - if Term.eq_constr hyp_typ new_hyp_typ then + if EConstr.eq_constr sigma hyp_typ new_hyp_typ then user_err ~hdr:"general_rewrite_in" (str "Nothing to rewrite in " ++ pr_id id ++ str"."); clenv_refine_in with_evars id id sigma elimclause'' @@ -1728,9 +1737,11 @@ let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind)) let thm_ty0 = nf_betaiota sigma (EConstr.of_constr (Retyping.get_type_of env sigma (EConstr.of_constr c))) in let try_apply thm_ty nprod = try - let n = nb_prod_modulo_zeta sigma (EConstr.of_constr thm_ty) - nprod in + let thm_ty = EConstr.of_constr thm_ty in + let n = nb_prod_modulo_zeta sigma thm_ty - nprod in if n<0 then error "Applied theorem has not enough premisses."; - let clause = make_clenv_binding_apply env sigma (Some n) (c,thm_ty) lbind in + let lbind = Miscops.map_bindings EConstr.of_constr lbind in + let clause = make_clenv_binding_apply env sigma (Some n) (EConstr.of_constr c,thm_ty) lbind in Clenvtac.res_pf clause ~with_evars ~flags with exn when catchable_exception exn -> Proofview.tclZERO exn @@ -1851,7 +1862,9 @@ let progress_with_clause flags innerclause clause = with Not_found -> error "Unable to unify." let apply_in_once_main flags innerclause env sigma (d,lbind) = - let thm = nf_betaiota sigma (EConstr.of_constr (Retyping.get_type_of env sigma (EConstr.of_constr d))) in + let d = EConstr.of_constr d in + let thm = nf_betaiota sigma (EConstr.of_constr (Retyping.get_type_of env sigma d)) in + let thm = EConstr.of_constr thm in let rec aux clause = try progress_with_clause flags innerclause clause with e when CErrors.noncritical e -> @@ -1859,6 +1872,7 @@ let apply_in_once_main flags innerclause env sigma (d,lbind) = try aux (clenv_push_prod clause) with NotExtensibleClause -> iraise e in + let lbind = Miscops.map_bindings EConstr.of_constr lbind in aux (make_clenv_binding env sigma (d,thm) lbind) let apply_in_once sidecond_first with_delta with_destruct with_evars naming @@ -1870,7 +1884,7 @@ let apply_in_once sidecond_first with_delta with_destruct with_evars naming 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 innerclause = mk_clenv_from_env env sigma (Some 0) (EConstr.mkVar id,EConstr.of_constr t') in let targetid = find_name true (LocalAssum (Anonymous,t')) naming gl in let rec aux idstoclear with_destruct c = Proofview.Goal.enter { enter = begin fun gl -> @@ -2939,10 +2953,12 @@ let specialize (c,lbind) ipat = let sigma = Typeclasses.resolve_typeclasses env sigma in sigma, nf_evar sigma c else - let clause = make_clenv_binding env sigma (c,Retyping.get_type_of env sigma (EConstr.of_constr c)) lbind in + let c = EConstr.of_constr c in + let lbind = Miscops.map_bindings EConstr.of_constr lbind in + let clause = make_clenv_binding env sigma (c,EConstr.of_constr (Retyping.get_type_of env sigma 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 (EConstr.of_constr (clenv_value 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 EConstr.Unsafe.to_constr t :: chk l @@ -4107,7 +4123,7 @@ let get_eliminator elim dep s gl = of lid are parameters (first ones), the other are arguments. Returns the clause obtained. *) let recolle_clenv i params args elimclause gl = - let _,arr = destApp elimclause.templval.rebus in + let _,arr = destApp (EConstr.Unsafe.to_constr elimclause.templval.rebus) in let lindmv = Array.map (fun x -> @@ -4132,6 +4148,8 @@ let recolle_clenv i params args elimclause gl = (* from_n (Some 0) means that x should be taken "as is" without trying to unify (which would lead to trying to apply it to evars if y is a product). *) + let x = EConstr.of_constr x in + let y = EConstr.of_constr y in let indclause = Tacmach.New.of_old (fun gl -> mk_clenv_from_n gl (Some 0) (x,y)) gl in let elimclause' = clenv_fchain ~with_univs:false i acc indclause in elimclause') @@ -4149,6 +4167,9 @@ let induction_tac with_evars params indvars elim = (* elimclause contains this: (elimc ?i ?j ?k...?l) *) let elimc = contract_letin_in_lam_header elimc in let elimc = mkCast (elimc, DEFAULTcast, elimt) in + let elimc = EConstr.of_constr elimc in + let elimt = EConstr.of_constr elimt in + let lbindelimc = Miscops.map_bindings EConstr.of_constr lbindelimc in let elimclause = pf_apply make_clenv_binding gl (elimc,elimt) lbindelimc in (* elimclause' is built from elimclause by instanciating all args and params. *) let elimclause' = recolle_clenv i params indvars elimclause gl in @@ -4294,11 +4315,14 @@ let use_bindings env sigma elim must_be_closed (c,lbind) typ = typ in let rec find_clause typ = try + let typ = EConstr.of_constr typ in + let c = EConstr.of_constr c in + let lbind = Miscops.map_bindings EConstr.of_constr lbind in let indclause = make_clenv_binding env sigma (c,typ) lbind in - if must_be_closed && occur_meta indclause.evd (EConstr.of_constr (clenv_value indclause)) then + if must_be_closed && occur_meta indclause.evd (clenv_value indclause) then error "Need a fully applied argument."; (* We lose the possibility of coercions in with-bindings *) - let (sigma, c) = pose_all_metas_as_evars env indclause.evd (EConstr.of_constr (clenv_value indclause)) in + let (sigma, c) = pose_all_metas_as_evars env indclause.evd (clenv_value indclause) in Sigma.Unsafe.of_pair (EConstr.Unsafe.to_constr c, sigma) with e when catchable_exception e -> try find_clause (try_red_product env sigma (EConstr.of_constr typ)) @@ -4308,13 +4332,15 @@ let use_bindings env sigma elim must_be_closed (c,lbind) typ = let check_expected_type env sigma (elimc,bl) elimt = (* Compute the expected template type of the term in case a using clause is given *) - let sign,_ = splay_prod env sigma (EConstr.of_constr elimt) in + let open EConstr in + let elimt = EConstr.of_constr elimt in + let sign,_ = splay_prod env sigma elimt in let n = List.length sign in if n == 0 then error "Scheme cannot be applied."; let sigma,cl = make_evar_clause env sigma ~len:(n - 1) elimt in let sigma = solve_evar_clause env sigma true cl bl in - let (_,u,_) = destProd cl.cl_concl in - fun t -> Evarconv.e_cumul env (ref sigma) t (EConstr.of_constr u) + let (_,u,_) = destProd sigma cl.cl_concl in + fun t -> Evarconv.e_cumul env (ref sigma) t u let check_enough_applied env sigma elim = let sigma = Sigma.to_evar_map sigma in @@ -4327,6 +4353,7 @@ let check_enough_applied env sigma elim = | Some elimc -> let elimt = Retyping.get_type_of env sigma (EConstr.of_constr (fst elimc)) in let scheme = compute_elim_sig ~elimc elimt in + let elimc = Miscops.map_with_bindings EConstr.of_constr elimc in match scheme.indref with | None -> (* in the absence of information, do not assume it may be @@ -4607,12 +4634,13 @@ let simple_destruct = function let elim_scheme_type elim t = Proofview.Goal.nf_enter { enter = begin fun gl -> + let elim = EConstr.of_constr elim in let clause = Tacmach.New.of_old (fun gl -> mk_clenv_type_of gl elim) gl in - match kind_of_term (last_arg clause.templval.rebus) with + match kind_of_term (last_arg (EConstr.Unsafe.to_constr clause.templval.rebus)) with | Meta mv -> let clause' = (* t is inductive, then CUMUL or CONV is irrelevant *) - clenv_unify ~flags:(elim_flags ()) Reduction.CUMUL t + clenv_unify ~flags:(elim_flags ()) Reduction.CUMUL (EConstr.of_constr t) (clenv_meta_type clause mv) clause in Clenvtac.res_pf clause' ~flags:(elim_flags ()) ~with_evars:false | _ -> anomaly (Pp.str "elim_scheme_type") -- cgit v1.2.3 From 45562afa065aadc207dca4e904e309d835cb66ef Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 12 Nov 2016 01:28:45 +0100 Subject: Tacticals API using EConstr. --- tactics/elim.ml | 6 +++--- tactics/equality.ml | 2 +- tactics/inv.ml | 6 ++++-- tactics/tacticals.ml | 20 ++++++++++---------- tactics/tacticals.mli | 14 +++++++------- 5 files changed, 25 insertions(+), 23 deletions(-) (limited to 'tactics') diff --git a/tactics/elim.ml b/tactics/elim.ml index bcb1c05cc9..fe36085b87 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -55,7 +55,7 @@ Another example : *) let elimHypThen tac id = - elimination_then tac (mkVar id) + elimination_then tac (EConstr.mkVar id) let rec general_decompose_on_hyp recognizer = ifOnHyp recognizer (general_decompose_aux recognizer) (fun _ -> Proofview.tclUNIT()) @@ -125,7 +125,7 @@ let h_decompose_and = decompose_and (* The tactic Double performs a double induction *) let simple_elimination c = - elimination_then (fun _ -> tclIDTAC) c + elimination_then (fun _ -> tclIDTAC) (EConstr.of_constr c) let induction_trailer abs_i abs_j bargs = tclTHEN @@ -166,7 +166,7 @@ let double_ind h1 h2 = (onLastHypId (fun id -> elimination_then - (introElimAssumsThen (induction_trailer abs_i abs_j)) (mkVar id)))) + (introElimAssumsThen (induction_trailer abs_i abs_j)) (EConstr.mkVar id)))) end } let h_double_induction = double_ind diff --git a/tactics/equality.ml b/tactics/equality.ml index fbf461f6f8..fa4164bb96 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -985,7 +985,7 @@ let apply_on_clause (f,t) clause = let t = EConstr.of_constr t in let f_clause = mk_clenv_from_env clause.env sigma None (f,t) in let argmv = - (match kind_of_term (last_arg f_clause.evd f_clause.templval.Evd.rebus) with + (match EConstr.kind sigma (last_arg f_clause.evd f_clause.templval.Evd.rebus) with | Meta mv -> mv | _ -> user_err (str "Ill-formed clause applicator.")) in clenv_fchain ~with_univs:false argmv f_clause clause diff --git a/tactics/inv.ml b/tactics/inv.ml index 2f5186f81f..60f1c3542f 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -443,7 +443,8 @@ let raw_inversion inv_kind id status names = let msg = str "The type of " ++ pr_id id ++ str " is not inductive." in CErrors.user_err msg in - let IndType (indf,realargs) = find_rectype env sigma (EConstr.of_constr t) in + let t = EConstr.of_constr t in + let IndType (indf,realargs) = find_rectype env sigma t in let evdref = ref sigma in let (elim_predicate, args) = make_inv_predicate env evdref indf realargs id status concl in @@ -463,13 +464,14 @@ let raw_inversion inv_kind id status names = in let neqns = List.length realargs in let as_mode = names != None in + let elim_predicate = EConstr.of_constr elim_predicate in let tac = (tclTHENS (assert_before Anonymous cut_concl) [case_tac names (introCaseAssumsThen false (* ApplyOn not supported by inversion *) (rewrite_equations_tac as_mode inv_kind id neqns)) - (Some elim_predicate) ind (c, t); + (Some elim_predicate) ind (EConstr.of_constr c,t); onLastHypId (fun id -> tclTHEN (refined id) reflexivity)]) in Sigma.Unsafe.of_pair (tac, sigma) diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index 4599470511..0546132c13 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -147,9 +147,9 @@ let ifOnHyp pred tac1 tac2 id gl = type branch_args = { ity : pinductive; (* the type we were eliminating on *) - largs : constr list; (* its arguments *) + largs : EConstr.constr list; (* its arguments *) branchnum : int; (* the branch number *) - pred : constr; (* the predicate we used *) + pred : EConstr.constr; (* the predicate we used *) nassums : int; (* number of assumptions/letin to be introduced *) branchsign : bool list; (* the signature of the branch. true=assumption, false=let-in *) @@ -622,8 +622,7 @@ module New = struct (* c should be of type A1->.. An->B with B an inductive definition *) let general_elim_then_using mk_elim isrec allnames tac predicate ind (c, t) = - let c = EConstr.of_constr c in - let t = EConstr.of_constr t in + let open EConstr in Proofview.Goal.nf_enter { enter = begin fun gl -> let sigma, elim = Tacmach.New.of_old (mk_elim ind) gl in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) @@ -632,13 +631,13 @@ module New = struct (* applying elimination_scheme just a little modified *) let elimclause = Tacmach.New.of_old (fun gls -> mk_clenv_from gls (EConstr.of_constr elim,EConstr.of_constr (Tacmach.New.pf_unsafe_type_of gl (EConstr.of_constr elim)))) gl in let indmv = - match kind_of_term (last_arg elimclause.evd elimclause.templval.Evd.rebus) with + match EConstr.kind elimclause.evd (last_arg elimclause.evd elimclause.templval.Evd.rebus) with | Meta mv -> mv | _ -> anomaly (str"elimination") in let pmv = - let p, _ = decompose_app (EConstr.Unsafe.to_constr elimclause.templtyp.Evd.rebus) in - match kind_of_term p with + let p, _ = decompose_app elimclause.evd elimclause.templtyp.Evd.rebus in + match EConstr.kind elimclause.evd p with | Meta p -> p | _ -> let name_elim = @@ -657,11 +656,11 @@ module New = struct let elimclause' = match predicate with | None -> elimclause' - | Some p -> clenv_unify ~flags Reduction.CONV (EConstr.mkMeta pmv) (EConstr.of_constr p) elimclause' + | Some p -> clenv_unify ~flags Reduction.CONV (EConstr.mkMeta pmv) p elimclause' in let clenv' = Tacmach.New.of_old (clenv_unique_resolver ~flags elimclause') gl in let after_tac i = - let (hd,largs) = decompose_app (EConstr.Unsafe.to_constr clenv'.templtyp.Evd.rebus) in + let (hd,largs) = decompose_app clenv'.evd clenv'.templtyp.Evd.rebus in let ba = { branchsign = branchsigns.(i); branchnames = brnames.(i); nassums = List.length branchsigns.(i); @@ -680,7 +679,8 @@ module New = struct let elimination_then tac c = Proofview.Goal.nf_enter { enter = begin fun gl -> - let (ind,t) = pf_reduce_to_quantified_ind gl (EConstr.of_constr (pf_unsafe_type_of gl (EConstr.of_constr c))) in + let (ind,t) = pf_reduce_to_quantified_ind gl (EConstr.of_constr (pf_unsafe_type_of gl c)) in + let t = EConstr.of_constr t in let isrec,mkelim = match (Global.lookup_mind (fst (fst ind))).mind_record with | None -> true,gl_make_elim diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index 18cf03c51d..974bf83a31 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -97,17 +97,17 @@ val onClauseLR : (Id.t option -> tactic) -> clause -> tactic (** {6 Elimination tacticals. } *) -type branch_args = { +type branch_args = private { ity : pinductive; (** the type we were eliminating on *) - largs : constr list; (** its arguments *) + largs : EConstr.constr list; (** its arguments *) branchnum : int; (** the branch number *) - pred : constr; (** the predicate we used *) + pred : EConstr.constr; (** the predicate we used *) nassums : int; (** number of assumptions/letin to be introduced *) branchsign : bool list; (** the signature of the branch. true=assumption, false=let-in *) branchnames : intro_patterns} -type branch_assumptions = { +type branch_assumptions = private { ba : branch_args; (** the branch args *) assums : Context.Named.t} (** the list of assumptions introduced *) @@ -253,15 +253,15 @@ module New : sig val elimination_then : (branch_args -> unit Proofview.tactic) -> - constr -> unit Proofview.tactic + EConstr.constr -> unit Proofview.tactic val case_then_using : or_and_intro_pattern option -> (branch_args -> unit Proofview.tactic) -> - constr option -> pinductive -> Term.constr * Term.types -> unit Proofview.tactic + EConstr.constr option -> pinductive -> EConstr.constr * EConstr.types -> unit Proofview.tactic val case_nodep_then_using : or_and_intro_pattern option -> (branch_args -> unit Proofview.tactic) -> - constr option -> pinductive -> Term.constr * Term.types -> unit Proofview.tactic + EConstr.constr option -> pinductive -> EConstr.constr * EConstr.types -> unit Proofview.tactic 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 -- cgit v1.2.3 From 771be16883c8c47828f278ce49545716918764c4 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 12 Nov 2016 01:52:15 +0100 Subject: Hipattern API using EConstr. --- tactics/contradiction.ml | 10 +-- tactics/elim.ml | 4 +- tactics/eqdecide.ml | 12 ++-- tactics/equality.ml | 72 +++++++++++++++------- tactics/equality.mli | 4 +- tactics/hipattern.ml | 156 ++++++++++++++++++++++++----------------------- tactics/hipattern.mli | 24 ++++---- tactics/inv.ml | 2 +- tactics/tactics.ml | 38 +++++++++--- tactics/tactics.mli | 2 +- 10 files changed, 192 insertions(+), 132 deletions(-) (limited to 'tactics') diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index 2058b95a6a..a8be704b2a 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -66,12 +66,12 @@ let contradiction_context = let id = NamedDecl.get_id d in let typ = nf_evar sigma (NamedDecl.get_type d) in let typ = whd_all env sigma (EConstr.of_constr typ) in - if is_empty_type sigma typ then + if is_empty_type sigma (EConstr.of_constr typ) then simplest_elim (mkVar id) else match kind_of_term typ with - | Prod (na,t,u) when is_empty_type sigma u -> + | Prod (na,t,u) when is_empty_type sigma (EConstr.of_constr u) -> let is_unit_or_eq = - if use_negated_unit_or_eq_type () then match_with_unit_or_eq_type sigma t + if use_negated_unit_or_eq_type () then match_with_unit_or_eq_type sigma (EConstr.of_constr t) else None in Tacticals.New.tclORELSE (match is_unit_or_eq with @@ -105,7 +105,7 @@ let is_negation_of env sigma typ t = match kind_of_term (whd_all env sigma t) with | Prod (na,t,u) -> let u = nf_evar sigma u in - is_empty_type sigma u && is_conv_leq env sigma (EConstr.of_constr typ) (EConstr.of_constr t) + is_empty_type sigma (EConstr.of_constr u) && is_conv_leq env sigma (EConstr.of_constr typ) (EConstr.of_constr t) | _ -> false let contradiction_term (c,lbind as cl) = @@ -115,7 +115,7 @@ let contradiction_term (c,lbind as cl) = let type_of = Tacmach.New.pf_unsafe_type_of gl in let typ = type_of (EConstr.of_constr c) in let _, ccl = splay_prod env sigma (EConstr.of_constr typ) in - if is_empty_type sigma ccl then + if is_empty_type sigma (EConstr.of_constr ccl) then Tacticals.New.tclTHEN (elim false None cl None) (Tacticals.New.tclTRY assumption) diff --git a/tactics/elim.ml b/tactics/elim.ml index fe36085b87..d00e504ff5 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -108,12 +108,12 @@ let decompose_these c l = let decompose_and c = general_decompose - (fun sigma (_,t) -> is_record sigma t) + (fun sigma (_,t) -> is_record sigma (EConstr.of_constr t)) c let decompose_or c = general_decompose - (fun sigma (_,t) -> is_disjunction sigma t) + (fun sigma (_,t) -> is_disjunction sigma (EConstr.of_constr t)) c let h_decompose l c = decompose_these c l diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml index d1b14a9076..ed81d748a4 100644 --- a/tactics/eqdecide.ml +++ b/tactics/eqdecide.ml @@ -141,8 +141,8 @@ open Proofview.Notations (* spiwack: a small wrapper around [Hipattern]. *) -let match_eqdec c = - try Proofview.tclUNIT (match_eqdec c) +let match_eqdec sigma c = + try Proofview.tclUNIT (match_eqdec sigma c) with PatternMatchingFailure -> Proofview.tclZERO PatternMatchingFailure (* /spiwack *) @@ -171,7 +171,9 @@ let solveEqBranch rectype = begin Proofview.Goal.enter { enter = begin fun gl -> let concl = pf_nf_concl gl in - match_eqdec concl >>= fun (eqonleft,op,lhs,rhs,_) -> + let concl = EConstr.of_constr concl in + let sigma = project gl in + match_eqdec sigma concl >>= fun (eqonleft,op,lhs,rhs,_) -> let (mib,mip) = Global.lookup_inductive rectype in let nparams = mib.mind_nparams in let getargs l = List.skipn nparams (snd (decompose_app l)) in @@ -196,7 +198,9 @@ let decideGralEquality = begin Proofview.Goal.enter { enter = begin fun gl -> let concl = pf_nf_concl gl in - match_eqdec concl >>= fun (eqonleft,_,c1,c2,typ) -> + let concl = EConstr.of_constr concl in + let sigma = project gl in + match_eqdec sigma concl >>= fun (eqonleft,_,c1,c2,typ) -> let headtyp = hd_app (pf_compute gl (EConstr.of_constr typ)) in begin match kind_of_term headtyp with | Ind (mi,_) -> Proofview.tclUNIT mi diff --git a/tactics/equality.ml b/tactics/equality.ml index fa4164bb96..e1a8d2bdb1 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -448,8 +448,9 @@ let general_rewrite_ebindings_clause cls lft2rgt occs frzevars dep_proof_ok ?tac let env = Proofview.Goal.env gl in let ctype = get_type_of env sigma (EConstr.of_constr c) in let rels, t = decompose_prod_assum (whd_betaiotazeta sigma (EConstr.of_constr ctype)) in - match match_with_equality_type sigma t with + match match_with_equality_type sigma (EConstr.of_constr t) with | Some (hdcncl,args) -> (* Fast path: direct leibniz-like rewrite *) + let hdcncl = EConstr.Unsafe.to_constr hdcncl in let lft2rgt = adjust_rewriting_direction args lft2rgt in leibniz_rewrite_ebindings_clause cls lft2rgt tac c (it_mkProd_or_LetIn t rels) l with_evars frzevars dep_proof_ok hdcncl @@ -464,8 +465,9 @@ let general_rewrite_ebindings_clause cls lft2rgt occs frzevars dep_proof_ok ?tac Proofview.tclEVARMAP >>= fun sigma -> let env' = push_rel_context rels env in let rels',t' = splay_prod_assum env' sigma (EConstr.of_constr t) in (* Search for underlying eq *) - match match_with_equality_type sigma t' with + match match_with_equality_type sigma (EConstr.of_constr t') with | Some (hdcncl,args) -> + let hdcncl = EConstr.Unsafe.to_constr hdcncl in let lft2rgt = adjust_rewriting_direction args lft2rgt in leibniz_rewrite_ebindings_clause cls lft2rgt tac c (it_mkProd_or_LetIn t' (rels' @ rels)) l with_evars frzevars dep_proof_ok hdcncl @@ -768,7 +770,7 @@ let find_positions env sigma t1 t2 = let sorts = if !keep_proof_equalities_for_injection then [InSet;InType;InProp] else [InSet;InType] in - Inr (findrec sorts [] (EConstr.of_constr t1) (EConstr.of_constr t2)) + Inr (findrec sorts [] t1 t2) with DiscrFound (path,c1,c2) -> Inl (path,c1,c2) @@ -943,7 +945,7 @@ let gen_absurdity id = Proofview.Goal.enter { enter = begin fun gl -> let sigma = project gl in let hyp_typ = pf_get_hyp_typ id (Proofview.Goal.assume gl) in - let hyp_typ = pf_nf_evar gl hyp_typ in + let hyp_typ = EConstr.of_constr hyp_typ in if is_empty_type sigma hyp_typ then simplest_elim (mkVar id) @@ -991,6 +993,9 @@ let apply_on_clause (f,t) clause = clenv_fchain ~with_univs:false argmv f_clause clause let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn = + let t = EConstr.Unsafe.to_constr t in + let t1 = EConstr.Unsafe.to_constr t1 in + let t2 = EConstr.Unsafe.to_constr t2 in 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 = @@ -1029,7 +1034,7 @@ let onEquality with_evars tac (c,lbindc) = let eq_clause' = Clenvtac.clenv_pose_dependent_evars with_evars eq_clause in let eqn = clenv_type eq_clause' in let eqn = EConstr.Unsafe.to_constr eqn in - let (eq,u,eq_args) = find_this_eq_data_decompose gl eqn in + let (eq,u,eq_args) = find_this_eq_data_decompose gl (EConstr.of_constr eqn) in tclTHEN (Proofview.Unsafe.tclEVARS eq_clause'.evd) (tac (eq,eqn,eq_args) eq_clause') @@ -1041,7 +1046,7 @@ let onNegatedEquality with_evars tac = let ccl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in match kind_of_term (hnf_constr env sigma (EConstr.of_constr ccl)) with - | Prod (_,t,u) when is_empty_type sigma u -> + | Prod (_,t,u) when is_empty_type sigma (EConstr.of_constr u) -> tclTHEN introf (onLastHypId (fun id -> onEquality with_evars tac (mkVar id,NoBindings))) @@ -1320,6 +1325,7 @@ let inject_if_homogenous_dependent_pair ty = try let sigma = Tacmach.New.project gl in let eq,u,(t,t1,t2) = find_this_eq_data_decompose gl ty in + let t = EConstr.Unsafe.to_constr t in (* fetch the informations of the pair *) let ceq = Universes.constr_of_global Coqlib.glob_eq in let sigTconstr () = (Coqlib.build_sigma_type()).Coqlib.typ in @@ -1327,8 +1333,8 @@ let inject_if_homogenous_dependent_pair ty = (* check whether the equality deals with dep pairs or not *) let eqTypeDest = fst (decompose_app t) in if not (Globnames.is_global (sigTconstr()) eqTypeDest) then raise Exit; - let hd1,ar1 = decompose_app_vect sigma (EConstr.of_constr t1) and - hd2,ar2 = decompose_app_vect sigma (EConstr.of_constr t2) in + let hd1,ar1 = decompose_app_vect sigma t1 and + hd2,ar2 = decompose_app_vect sigma t2 in if not (Globnames.is_global (existTconstr()) hd1) then raise Exit; if not (Globnames.is_global (existTconstr()) hd2) then raise Exit; let ind,_ = try pf_apply find_mrectype gl (EConstr.of_constr ar1.(0)) with Not_found -> raise Exit in @@ -1369,6 +1375,9 @@ let simplify_args env sigma t = | _ -> t let inject_at_positions env sigma l2r (eq,_,(t,t1,t2)) eq_clause posns tac = + let t = EConstr.Unsafe.to_constr t in + let t1 = EConstr.Unsafe.to_constr t1 in + let t2 = EConstr.Unsafe.to_constr t2 in let e = next_ident_away eq_baseid (ids_of_context env) in let e_env = push_named (LocalAssum (e,t)) env in let evdref = ref sigma in @@ -1396,7 +1405,7 @@ let inject_at_positions env sigma l2r (eq,_,(t,t1,t2)) eq_clause posns tac = (Tacticals.New.tclTHENFIRST (Proofview.tclIGNORE (Proofview.Monad.List.map (fun (pf,ty) -> tclTHENS (cut ty) - [inject_if_homogenous_dependent_pair ty; + [inject_if_homogenous_dependent_pair (EConstr.of_constr ty); Proofview.V82.tactic (Tacmach.refine (EConstr.of_constr pf))]) (if l2r then List.rev injectors else injectors))) (tac (List.length injectors))) @@ -1536,7 +1545,12 @@ let decomp_tuple_term env sigma c t = let rec decomprec inner_code ex exty = let iterated_decomp = try - let ({proj1=p1; proj2=p2}),(i,a,p,car,cdr) = find_sigma_data_decompose ex in + let ex = EConstr.of_constr ex in + let ({proj1=p1; proj2=p2}),(i,a,p,car,cdr) = find_sigma_data_decompose sigma ex in + let a = EConstr.Unsafe.to_constr a in + let p = EConstr.Unsafe.to_constr p in + let car = EConstr.Unsafe.to_constr car in + let cdr = EConstr.Unsafe.to_constr cdr in let car_code = applist (mkConstU (destConstRef p1,i),[a;p;inner_code]) and cdr_code = applist (mkConstU (destConstRef p2,i),[a;p;inner_code]) in let cdrtyp = beta_applist sigma (EConstr.of_constr p,[EConstr.of_constr car]) in @@ -1547,6 +1561,8 @@ let decomp_tuple_term env sigma c t = in decomprec (mkRel 1) c t let subst_tuple_term env sigma dep_pair1 dep_pair2 b = + let dep_pair1 = EConstr.Unsafe.to_constr dep_pair1 in + let dep_pair2 = EConstr.Unsafe.to_constr dep_pair2 in let sigma = Sigma.to_evar_map sigma in let typ = get_type_of env sigma (EConstr.of_constr dep_pair1) in (* We find all possible decompositions *) @@ -1583,7 +1599,7 @@ let cutSubstInConcl l2r eqn = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in - let (lbeq,u,(t,e1,e2)) = find_eq_data_decompose gl eqn in + let (lbeq,u,(t,e1,e2)) = find_eq_data_decompose gl (EConstr.of_constr eqn) in let typ = pf_concl gl in let (e1,e2) = if l2r then (e1,e2) else (e2,e1) in let Sigma ((typ, expected), sigma, p) = subst_tuple_term env sigma e1 e2 typ in @@ -1602,7 +1618,7 @@ let cutSubstInHyp l2r eqn id = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in - let (lbeq,u,(t,e1,e2)) = find_eq_data_decompose gl eqn in + let (lbeq,u,(t,e1,e2)) = find_eq_data_decompose gl (EConstr.of_constr eqn) in let typ = pf_get_hyp_typ id gl in let (e1,e2) = if l2r then (e1,e2) else (e2,e1) in let Sigma ((typ, expected), sigma, p) = subst_tuple_term env sigma e1 e2 typ in @@ -1682,20 +1698,21 @@ let restrict_to_eq_and_identity eq = (* compatibility *) not (is_global glob_identity eq) then raise Constr_matching.PatternMatchingFailure -exception FoundHyp of (Id.t * constr * bool) +exception FoundHyp of (Id.t * EConstr.constr * bool) (* tests whether hyp [c] is [x = t] or [t = x], [x] not occurring in [t] *) let is_eq_x gl x d = let id = NamedDecl.get_id d in try - let is_var id c = match kind_of_term c with + let is_var id c = match EConstr.kind (project gl) c with | Var id' -> Id.equal id id' | _ -> false in let c = pf_nf_evar gl (NamedDecl.get_type d) in + let c = EConstr.of_constr c in let (_,lhs,rhs) = pi3 (find_eq_data_decompose gl c) in - if (is_var x lhs) && not (local_occur_var (project gl) x (EConstr.of_constr rhs)) then raise (FoundHyp (id,rhs,true)); - if (is_var x rhs) && not (local_occur_var (project gl) x (EConstr.of_constr lhs)) then raise (FoundHyp (id,lhs,false)) + if (is_var x lhs) && not (local_occur_var (project gl) x rhs) then raise (FoundHyp (id,rhs,true)); + if (is_var x rhs) && not (local_occur_var (project gl) x lhs) then raise (FoundHyp (id,lhs,false)) with Constr_matching.PatternMatchingFailure -> () @@ -1753,7 +1770,7 @@ let subst_one_var dep_proof_ok x = user_err ~hdr:"Subst" (str "Cannot find any non-recursive equality over " ++ pr_id x ++ str".") - with FoundHyp res -> res in + with FoundHyp (id, c, b) -> (id, EConstr.Unsafe.to_constr c, b) in subst_one dep_proof_ok x res end } @@ -1788,7 +1805,9 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () = let find_eq_data_decompose = find_eq_data_decompose gl in let select_equation_name decl = try - let lbeq,u,(_,x,y) = find_eq_data_decompose (NamedDecl.get_type decl) in + let lbeq,u,(_,x,y) = find_eq_data_decompose (EConstr.of_constr (NamedDecl.get_type decl)) in + let x = EConstr.Unsafe.to_constr x in + let y = EConstr.Unsafe.to_constr y in let eq = Universes.constr_of_global_univ (lbeq.eq,u) in if flags.only_leibniz then restrict_to_eq_and_identity eq; match kind_of_term x, kind_of_term y with @@ -1812,7 +1831,10 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () = let env = Proofview.Goal.env gl in let find_eq_data_decompose = find_eq_data_decompose gl in let c = pf_get_hyp hyp gl |> NamedDecl.get_type in + let c = EConstr.of_constr c in let _,_,(_,x,y) = find_eq_data_decompose c in + let x = EConstr.Unsafe.to_constr x in + let y = EConstr.Unsafe.to_constr y in (* J.F.: added to prevent failure on goal containing x=x as an hyp *) if Term.eq_constr x y then Proofview.tclUNIT () else match kind_of_term x, kind_of_term y with @@ -1838,7 +1860,10 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () = let find_eq_data_decompose = find_eq_data_decompose gl in let test (_,c) = try + let c = EConstr.of_constr c in let lbeq,u,(_,x,y) = find_eq_data_decompose c in + let x = EConstr.Unsafe.to_constr x in + let y = EConstr.Unsafe.to_constr y in let eq = Universes.constr_of_global_univ (lbeq.eq,u) in if flags.only_leibniz then restrict_to_eq_and_identity eq; (* J.F.: added to prevent failure on goal containing x=x as an hyp *) @@ -1858,21 +1883,24 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () = let cond_eq_term_left c t gl = try + let t = EConstr.of_constr t in let (_,x,_) = pi3 (find_eq_data_decompose gl t) in - if pf_conv_x gl (EConstr.of_constr c) (EConstr.of_constr x) then true else failwith "not convertible" + if pf_conv_x gl (EConstr.of_constr c) x then true else failwith "not convertible" with Constr_matching.PatternMatchingFailure -> failwith "not an equality" let cond_eq_term_right c t gl = try + let t = EConstr.of_constr t in let (_,_,x) = pi3 (find_eq_data_decompose gl t) in - if pf_conv_x gl (EConstr.of_constr c) (EConstr.of_constr x) then false else failwith "not convertible" + if pf_conv_x gl (EConstr.of_constr c) x then false else failwith "not convertible" with Constr_matching.PatternMatchingFailure -> failwith "not an equality" let cond_eq_term c t gl = try + let t = EConstr.of_constr t in let (_,x,y) = pi3 (find_eq_data_decompose gl t) in - if pf_conv_x gl (EConstr.of_constr c) (EConstr.of_constr x) then true - else if pf_conv_x gl (EConstr.of_constr c) (EConstr.of_constr y) then false + if pf_conv_x gl (EConstr.of_constr c) x then true + else if pf_conv_x gl (EConstr.of_constr c) y then false else failwith "not convertible" with Constr_matching.PatternMatchingFailure -> failwith "not an equality" diff --git a/tactics/equality.mli b/tactics/equality.mli index 6a4a8126e1..779d1e9b21 100644 --- a/tactics/equality.mli +++ b/tactics/equality.mli @@ -96,8 +96,8 @@ val cutRewriteInConcl : bool -> constr -> unit Proofview.tactic val rewriteInHyp : bool -> constr -> Id.t -> unit Proofview.tactic val rewriteInConcl : bool -> constr -> unit Proofview.tactic -val discriminable : env -> evar_map -> constr -> constr -> bool -val injectable : env -> evar_map -> constr -> constr -> bool +val discriminable : env -> evar_map -> EConstr.constr -> EConstr.constr -> bool +val injectable : env -> evar_map -> EConstr.constr -> EConstr.constr -> bool (* Subst *) diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml index 5d78fd5853..6681e5e491 100644 --- a/tactics/hipattern.ml +++ b/tactics/hipattern.ml @@ -12,6 +12,7 @@ open Util open Names open Term open Termops +open EConstr open Inductiveops open Constr_matching open Coqlib @@ -31,9 +32,9 @@ module RelDecl = Context.Rel.Declaration -- Eduardo (6/8/97). *) -type 'a matching_function = Evd.evar_map -> constr -> 'a option +type 'a matching_function = Evd.evar_map -> EConstr.constr -> 'a option -type testing_function = Evd.evar_map -> constr -> bool +type testing_function = Evd.evar_map -> EConstr.constr -> bool let mkmeta n = Nameops.make_ident "X" (Some n) let meta1 = mkmeta 1 @@ -44,10 +45,10 @@ let meta4 = mkmeta 4 let op2bool = function Some _ -> true | None -> false let match_with_non_recursive_type sigma t = - match kind_of_term t with + match EConstr.kind sigma t with | App _ -> - let (hdapp,args) = decompose_app t in - (match kind_of_term hdapp with + let (hdapp,args) = decompose_app sigma t in + (match EConstr.kind sigma hdapp with | Ind (ind,u) -> if (Global.lookup_mind (fst ind)).mind_finite == Decl_kinds.CoFinite then Some (hdapp,args) @@ -64,9 +65,9 @@ let is_non_recursive_type sigma t = op2bool (match_with_non_recursive_type sigma since they may appear in types of inductive constructors (see #2629) *) let rec has_nodep_prod_after n sigma c = - match kind_of_term c with + match EConstr.kind sigma c with | Prod (_,_,b) | LetIn (_,_,_,b) -> - ( n>0 || EConstr.Vars.noccurn sigma 1 (EConstr.of_constr b)) + ( n>0 || Vars.noccurn sigma 1 b) && (has_nodep_prod_after (n-1) sigma b) | _ -> true @@ -87,9 +88,11 @@ let is_lax_conjunction = function | Some false -> true | _ -> false +let prod_assum sigma t = fst (decompose_prod_assum sigma t) + let match_with_one_constructor sigma style onlybinary allow_rec t = - let (hdapp,args) = decompose_app t in - let res = match kind_of_term hdapp with + let (hdapp,args) = decompose_app sigma t in + let res = match EConstr.kind sigma hdapp with | Ind ind -> let (mib,mip) = Global.lookup_inductive (fst ind) in if Int.equal (Array.length mip.mind_consnames) 1 @@ -98,22 +101,23 @@ let match_with_one_constructor sigma style onlybinary allow_rec t = then if is_strict_conjunction style (* strict conjunction *) then let ctx = - (prod_assum (snd - (decompose_prod_n_assum mib.mind_nparams mip.mind_nf_lc.(0)))) in + (prod_assum sigma (snd + (decompose_prod_n_assum sigma mib.mind_nparams (EConstr.of_constr mip.mind_nf_lc.(0))))) in if List.for_all (fun decl -> let c = RelDecl.get_type decl in is_local_assum decl && - isRel c && - Int.equal (destRel c) mib.mind_nparams) ctx + Term.isRel c && + Int.equal (Term.destRel c) mib.mind_nparams) ctx then Some (hdapp,args) else None else - let ctyp = Term.prod_applist mip.mind_nf_lc.(0) args in - let cargs = List.map RelDecl.get_type (prod_assum ctyp) in + let ctyp = Termops.prod_applist sigma (EConstr.of_constr mip.mind_nf_lc.(0)) args in + let cargs = List.map RelDecl.get_type (prod_assum sigma ctyp) in if not (is_lax_conjunction style) || has_nodep_prod sigma ctyp then (* Record or non strict conjunction *) + let cargs = List.map EConstr.of_constr cargs in Some (hdapp,List.rev cargs) else None @@ -140,7 +144,7 @@ let is_record sigma t = let match_with_tuple sigma t = let t = match_with_one_constructor sigma None false true t in Option.map (fun (hd,l) -> - let ind = destInd hd in + let ind = destInd sigma hd in let (mib,mip) = Global.lookup_pinductive ind in let isrec = mis_is_recursive (fst ind,mib,mip) in (hd,l,isrec)) t @@ -154,14 +158,15 @@ let is_tuple sigma t = "Inductive I A1 ... An := C1 (_:A1) | ... | Cn : (_:An)" *) let test_strict_disjunction n lc = + let open Term in Array.for_all_i (fun i c -> match (prod_assum (snd (decompose_prod_n_assum n c))) with | [LocalAssum (_,c)] -> isRel c && Int.equal (destRel c) (n - i) | _ -> false) 0 lc let match_with_disjunction ?(strict=false) ?(onlybinary=false) sigma t = - let (hdapp,args) = decompose_app t in - let res = match kind_of_term hdapp with + let (hdapp,args) = decompose_app sigma t in + let res = match EConstr.kind sigma hdapp with | Ind (ind,u) -> let car = constructors_nrealargs ind in let (mib,mip) = Global.lookup_inductive ind in @@ -176,7 +181,7 @@ let match_with_disjunction ?(strict=false) ?(onlybinary=false) sigma t = None else let cargs = - Array.map (fun ar -> pi2 (destProd (Term.prod_applist ar args))) + Array.map (fun ar -> pi2 (destProd sigma (prod_applist sigma (EConstr.of_constr ar) args))) mip.mind_nf_lc in Some (hdapp,Array.to_list cargs) else @@ -194,8 +199,8 @@ let is_disjunction ?(strict=false) ?(onlybinary=false) sigma t = constructors *) let match_with_empty_type sigma t = - let (hdapp,args) = decompose_app t in - match (kind_of_term hdapp) with + let (hdapp,args) = decompose_app sigma t in + match EConstr.kind sigma hdapp with | Ind ind -> let (mib,mip) = Global.lookup_pinductive ind in let nconstr = Array.length mip.mind_consnames in @@ -208,8 +213,8 @@ let is_empty_type sigma t = op2bool (match_with_empty_type sigma t) Parameters and indices are allowed *) let match_with_unit_or_eq_type sigma t = - let (hdapp,args) = decompose_app t in - match (kind_of_term hdapp) with + let (hdapp,args) = decompose_app sigma t in + match EConstr.kind sigma hdapp with | Ind ind -> let (mib,mip) = Global.lookup_pinductive ind in let constr_types = mip.mind_nf_lc in @@ -276,13 +281,13 @@ let coq_refl_jm_pattern = open Globnames -let is_matching x y = is_matching (Global.env ()) Evd.empty x (EConstr.of_constr y) -let matches x y = matches (Global.env ()) Evd.empty x (EConstr.of_constr y) +let is_matching sigma x y = is_matching (Global.env ()) sigma x y +let matches sigma x y = matches (Global.env ()) sigma x y -let match_with_equation t = - if not (isApp t) then raise NoEquationFound; - let (hdapp,args) = destApp t in - match kind_of_term hdapp with +let match_with_equation sigma t = + if not (isApp sigma t) then raise NoEquationFound; + let (hdapp,args) = destApp sigma t in + match EConstr.kind sigma hdapp with | Ind (ind,u) -> if eq_gr (IndRef ind) glob_eq then Some (build_coq_eq_data()),hdapp, @@ -298,11 +303,11 @@ let match_with_equation t = let constr_types = mip.mind_nf_lc in let nconstr = Array.length mip.mind_consnames in if Int.equal nconstr 1 then - if is_matching coq_refl_leibniz1_pattern constr_types.(0) then + if is_matching sigma coq_refl_leibniz1_pattern (EConstr.of_constr constr_types.(0)) then None, hdapp, MonomorphicLeibnizEq(args.(0),args.(1)) - else if is_matching coq_refl_leibniz2_pattern constr_types.(0) then + else if is_matching sigma coq_refl_leibniz2_pattern (EConstr.of_constr constr_types.(0)) then None, hdapp, PolymorphicLeibnizEq(args.(0),args.(1),args.(2)) - else if is_matching coq_refl_jm_pattern constr_types.(0) then + else if is_matching sigma coq_refl_jm_pattern (EConstr.of_constr constr_types.(0)) then None, hdapp, HeterogenousEq(args.(0),args.(1),args.(2),args.(3)) else raise NoEquationFound else raise NoEquationFound @@ -319,8 +324,8 @@ let is_inductive_equality ind = Int.equal nconstr 1 && Int.equal (constructor_nrealargs (ind,1)) 0 let match_with_equality_type sigma t = - let (hdapp,args) = decompose_app t in - match (kind_of_term hdapp) with + let (hdapp,args) = decompose_app sigma t in + match EConstr.kind sigma hdapp with | Ind (ind,_) when is_inductive_equality ind -> Some (hdapp,args) | _ -> None @@ -331,23 +336,25 @@ let is_equality_type sigma t = op2bool (match_with_equality_type sigma t) (** X1 -> X2 **) let coq_arrow_pattern = mkPattern (mkGArrow (mkGPatVar "X1") (mkGPatVar "X2")) -let match_arrow_pattern t = - let result = matches coq_arrow_pattern t in +let match_arrow_pattern sigma t = + let result = matches sigma coq_arrow_pattern t in 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") let match_with_imp_term sigma c = - match kind_of_term c with - | Prod (_,a,b) when EConstr.Vars.noccurn sigma 1 (EConstr.of_constr b) -> Some (a,b) + match EConstr.kind sigma c with + | Prod (_,a,b) when Vars.noccurn sigma 1 b -> Some (a,b) | _ -> None let is_imp_term sigma c = op2bool (match_with_imp_term sigma c) let match_with_nottype sigma t = try - let (arg,mind) = match_arrow_pattern t in + let (arg,mind) = match_arrow_pattern sigma t in + let arg = EConstr.of_constr arg in + let mind = EConstr.of_constr mind in if is_empty_type sigma mind then Some (mind,arg) else None with PatternMatchingFailure -> None @@ -356,19 +363,19 @@ let is_nottype sigma t = op2bool (match_with_nottype sigma t) (* Forall *) let match_with_forall_term sigma c= - match kind_of_term c with + match EConstr.kind sigma c with | Prod (nam,a,b) -> Some (nam,a,b) | _ -> None let is_forall_term sigma c = op2bool (match_with_forall_term sigma c) let match_with_nodep_ind sigma t = - let (hdapp,args) = decompose_app t in - match (kind_of_term hdapp) with + let (hdapp,args) = decompose_app sigma t in + match EConstr.kind sigma hdapp with | Ind ind -> let (mib,mip) = Global.lookup_pinductive ind in if Array.length (mib.mind_packets)>1 then None else - let nodep_constr = has_nodep_prod_after mib.mind_nparams sigma in + let nodep_constr c = has_nodep_prod_after mib.mind_nparams sigma (EConstr.of_constr c) in if Array.for_all nodep_constr mip.mind_nf_lc then let params= if Int.equal mip.mind_nrealargs 0 then args else @@ -381,14 +388,14 @@ let match_with_nodep_ind sigma t = let is_nodep_ind sigma t = op2bool (match_with_nodep_ind sigma t) let match_with_sigma_type sigma t = - let (hdapp,args) = decompose_app t in - match (kind_of_term hdapp) with + let (hdapp,args) = decompose_app sigma t in + match EConstr.kind sigma hdapp with | Ind ind -> let (mib,mip) = Global.lookup_pinductive ind in if Int.equal (Array.length (mib.mind_packets)) 1 && (Int.equal mip.mind_nrealargs 0) && (Int.equal (Array.length mip.mind_consnames)1) && - has_nodep_prod_after (mib.mind_nparams+1) sigma mip.mind_nf_lc.(0) then + has_nodep_prod_after (mib.mind_nparams+1) sigma (EConstr.of_constr mip.mind_nf_lc.(0)) then (*allowing only 1 existential*) Some (hdapp,args) else @@ -408,17 +415,17 @@ let rec first_match matcher = function (*** Equality *) -let match_eq eqn (ref, hetero) = +let match_eq sigma eqn (ref, hetero) = let ref = try Lazy.force ref with e when CErrors.noncritical e -> raise PatternMatchingFailure in - match kind_of_term eqn with + match EConstr.kind sigma eqn with | App (c, [|t; x; y|]) -> - if not hetero && is_global ref c then PolymorphicLeibnizEq (t, x, y) + if not hetero && Termops.is_global sigma ref c then PolymorphicLeibnizEq (t, x, y) else raise PatternMatchingFailure | App (c, [|t; x; t'; x'|]) -> - if hetero && is_global ref c then HeterogenousEq (t, x, t', x') + if hetero && Termops.is_global sigma ref c then HeterogenousEq (t, x, t', x') else raise PatternMatchingFailure | _ -> raise PatternMatchingFailure @@ -430,27 +437,27 @@ let equalities = (coq_jmeq_ref, true), check_jmeq_loaded, build_coq_jmeq_data; (coq_identity_ref, false), no_check, build_coq_identity_data] -let find_eq_data eqn = (* fails with PatternMatchingFailure *) - let d,k = first_match (match_eq eqn) equalities in - let hd,u = destInd (fst (destApp eqn)) in +let find_eq_data sigma eqn = (* fails with PatternMatchingFailure *) + let d,k = first_match (match_eq sigma eqn) equalities in + let hd,u = destInd sigma (fst (destApp sigma eqn)) in d,u,k let extract_eq_args gl = function | MonomorphicLeibnizEq (e1,e2) -> - let t = pf_unsafe_type_of gl (EConstr.of_constr e1) in (t,e1,e2) + let t = pf_unsafe_type_of gl e1 in (EConstr.of_constr t,e1,e2) | PolymorphicLeibnizEq (t,e1,e2) -> (t,e1,e2) | HeterogenousEq (t1,e1,t2,e2) -> - if pf_conv_x gl (EConstr.of_constr t1) (EConstr.of_constr t2) then (t1,e1,e2) + if pf_conv_x gl t1 t2 then (t1,e1,e2) else raise PatternMatchingFailure let find_eq_data_decompose gl eqn = - let (lbeq,u,eq_args) = find_eq_data eqn in + let (lbeq,u,eq_args) = find_eq_data (project gl) eqn in (lbeq,u,extract_eq_args gl eq_args) let find_this_eq_data_decompose gl eqn = let (lbeq,u,eq_args) = try (*first_match (match_eq eqn) inversible_equalities*) - find_eq_data eqn + find_eq_data (project gl) eqn with PatternMatchingFailure -> user_err (str "No primitive equality found.") in let eq_args = @@ -463,7 +470,6 @@ let match_eq_nf gls eqn (ref, hetero) = let n = if hetero then 4 else 3 in let args = List.init n (fun i -> mkGPatVar ("X" ^ string_of_int (i + 1))) in let pat = mkPattern (mkGAppRef ref args) in - let eqn = EConstr.of_constr eqn in match Id.Map.bindings (pf_matches gls pat eqn) with | [(m1,t);(m2,x);(m3,y)] -> assert (Id.equal m1 meta1 && Id.equal m2 meta2 && Id.equal m3 meta3); @@ -478,12 +484,12 @@ let dest_nf_eq gls eqn = (*** Sigma-types *) -let match_sigma ex = - match kind_of_term ex with - | App (f, [| a; p; car; cdr |]) when is_global (Lazy.force coq_exist_ref) f -> - build_sigma (), (snd (destConstruct f), a, p, car, cdr) - | App (f, [| a; p; car; cdr |]) when is_global (Lazy.force coq_existT_ref) f -> - build_sigma_type (), (snd (destConstruct f), a, p, car, cdr) +let match_sigma sigma ex = + match EConstr.kind sigma ex with + | App (f, [| a; p; car; cdr |]) when Termops.is_global sigma (Lazy.force coq_exist_ref) f -> + build_sigma (), (snd (destConstruct sigma f), a, p, car, cdr) + | App (f, [| a; p; car; cdr |]) when Termops.is_global sigma (Lazy.force coq_existT_ref) f -> + build_sigma_type (), (snd (destConstruct sigma f), a, p, car, cdr) | _ -> raise PatternMatchingFailure let find_sigma_data_decompose ex = (* fails with PatternMatchingFailure *) @@ -493,12 +499,12 @@ let find_sigma_data_decompose ex = (* fails with PatternMatchingFailure *) let coq_sig_pattern = lazy (mkPattern (mkGAppRef coq_sig_ref [mkGPatVar "X1"; mkGPatVar "X2"])) -let match_sigma t = - match Id.Map.bindings (matches (Lazy.force coq_sig_pattern) t) with - | [(_,a); (_,p)] -> (a,p) +let match_sigma sigma t = + match Id.Map.bindings (matches sigma (Lazy.force coq_sig_pattern) t) with + | [(_,a); (_,p)] -> (EConstr.of_constr a,EConstr.of_constr p) | _ -> anomaly (Pp.str "Unexpected pattern") -let is_matching_sigma t = is_matching (Lazy.force coq_sig_pattern) t +let is_matching_sigma sigma t = is_matching sigma (Lazy.force coq_sig_pattern) t (*** Decidable equalities *) @@ -530,15 +536,15 @@ let coq_eqdec_rev_pattern = coq_eqdec ~sum:coq_or_ref ~rev:true let op_or = coq_or_ref let op_sum = coq_sumbool_ref -let match_eqdec t = +let match_eqdec sigma t = let eqonleft,op,subst = - try true,op_sum,matches (Lazy.force coq_eqdec_inf_pattern) t + try true,op_sum,matches sigma (Lazy.force coq_eqdec_inf_pattern) t with PatternMatchingFailure -> - try false,op_sum,matches (Lazy.force coq_eqdec_inf_rev_pattern) t + try false,op_sum,matches sigma (Lazy.force coq_eqdec_inf_rev_pattern) t with PatternMatchingFailure -> - try true,op_or,matches (Lazy.force coq_eqdec_pattern) t + try true,op_or,matches sigma (Lazy.force coq_eqdec_pattern) t with PatternMatchingFailure -> - false,op_or,matches (Lazy.force coq_eqdec_rev_pattern) t in + false,op_or,matches sigma (Lazy.force coq_eqdec_rev_pattern) t in match Id.Map.bindings subst with | [(_,typ);(_,c1);(_,c2)] -> eqonleft, Universes.constr_of_global (Lazy.force op), c1, c2, typ @@ -548,8 +554,8 @@ let match_eqdec t = let coq_not_pattern = lazy (mkPattern (mkGAppRef coq_not_ref [mkGHole])) let coq_imp_False_pattern = lazy (mkPattern (mkGArrow mkGHole (mkGRef coq_False_ref))) -let is_matching_not t = is_matching (Lazy.force coq_not_pattern) t -let is_matching_imp_False t = is_matching (Lazy.force coq_imp_False_pattern) t +let is_matching_not sigma t = is_matching sigma (Lazy.force coq_not_pattern) t +let is_matching_imp_False sigma t = is_matching sigma (Lazy.force coq_imp_False_pattern) t (* Remark: patterns that have references to the standard library must be evaluated lazily (i.e. at the time they are used, not a the time diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli index 8a453bf31f..094d62df65 100644 --- a/tactics/hipattern.mli +++ b/tactics/hipattern.mli @@ -8,6 +8,8 @@ open Names open Term +open Evd +open EConstr open Coqlib (** High-order patterns *) @@ -40,8 +42,8 @@ open Coqlib also work on ad-hoc disjunctions introduced by the user. (Eduardo, 6/8/97). *) -type 'a matching_function = Evd.evar_map -> constr -> 'a option -type testing_function = Evd.evar_map -> constr -> bool +type 'a matching_function = evar_map -> constr -> 'a option +type testing_function = evar_map -> constr -> bool val match_with_non_recursive_type : (constr * constr list) matching_function val is_non_recursive_type : testing_function @@ -113,7 +115,7 @@ type equation_kind = exception NoEquationFound val match_with_equation: - constr -> coq_eq_data option * constr * equation_kind + evar_map -> constr -> coq_eq_data option * constr * equation_kind (***** Destructing patterns bound to some theory *) @@ -127,25 +129,25 @@ val find_this_eq_data_decompose : ([ `NF ], 'r) Proofview.Goal.t -> constr -> coq_eq_data * Univ.universe_instance * (types * constr * constr) (** A variant that returns more informative structure on the equality found *) -val find_eq_data : constr -> coq_eq_data * Univ.universe_instance * equation_kind +val find_eq_data : evar_map -> constr -> coq_eq_data * Univ.universe_instance * equation_kind (** Match a term of the form [(existT A P t p)] Returns associated lemmas and [A,P,t,p] *) -val find_sigma_data_decompose : constr -> +val find_sigma_data_decompose : evar_map -> constr -> coq_sigma_data * (Univ.universe_instance * constr * constr * constr * constr) (** Match a term of the form [{x:A|P}], returns [A] and [P] *) -val match_sigma : constr -> constr * constr +val match_sigma : evar_map -> constr -> constr * constr -val is_matching_sigma : constr -> bool +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 : constr -> bool * constr * constr * constr * constr +val match_eqdec : evar_map -> constr -> bool * Constr.constr * Constr.constr * Constr.constr * Constr.constr (** Match an equality up to conversion; returns [(eq,t1,t2)] in normal form *) -val dest_nf_eq : ([ `NF ], 'r) Proofview.Goal.t -> constr -> (constr * constr * constr) +val dest_nf_eq : ([ `NF ], 'r) Proofview.Goal.t -> constr -> (Constr.constr * Constr.constr * Constr.constr) (** Match a negation *) -val is_matching_not : constr -> bool -val is_matching_imp_False : constr -> bool +val is_matching_not : evar_map -> constr -> bool +val is_matching_imp_False : evar_map -> constr -> bool diff --git a/tactics/inv.ml b/tactics/inv.ml index 60f1c3542f..a971b9356f 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -341,7 +341,7 @@ let projectAndApply as_mode thin avoid id eqname names depids = Proofview.Goal.nf_enter { enter = begin fun gl -> (** We only look at the type of hypothesis "id" *) let hyp = pf_nf_evar gl (pf_get_hyp_typ id (Proofview.Goal.assume gl)) in - let (t,t1,t2) = Hipattern.dest_nf_eq gl hyp in + let (t,t1,t2) = Hipattern.dest_nf_eq gl (EConstr.of_constr hyp) in match (kind_of_term t1, kind_of_term t2) with | Var id1, _ -> generalizeRewriteIntros as_mode (subst_hyp true id) depids id1 | _, Var id2 -> generalizeRewriteIntros as_mode (subst_hyp false id) depids id2 diff --git a/tactics/tactics.ml b/tactics/tactics.ml index f262aefa7f..a04fb7ca21 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1654,11 +1654,12 @@ let descend_in_conjunctions avoid tac (err, info) c = let t = EConstr.of_constr t in let ((ind,u),t) = reduce_to_quantified_ind env sigma t in let sign,ccl = decompose_prod_assum t in + let ccl = EConstr.of_constr ccl in match match_with_tuple sigma ccl with | Some (_,_,isrec) -> let n = (constructors_nrealargs ind).(0) in let sort = Tacticals.New.elimination_sort_of_goal gl in - let IndType (indf,_) = find_rectype env sigma (EConstr.of_constr ccl) in + let IndType (indf,_) = find_rectype env sigma ccl in let (_,inst), params = dest_ind_family indf in let cstr = (get_constructors env indf).(0) in let elim = @@ -2324,7 +2325,7 @@ let intro_decomp_eq loc l thin tac id = let t = Tacmach.New.pf_unsafe_type_of gl (EConstr.of_constr c) in let t = EConstr.of_constr t in let _,t = Tacmach.New.pf_reduce_to_quantified_ind gl t in - match my_find_eq_data_decompose gl t with + match my_find_eq_data_decompose gl (EConstr.of_constr t) with | Some (eq,u,eq_args) -> !intro_decomp_eq_function (fun n -> tac ((dloc,id)::thin) (Some (true,n)) l) @@ -2363,8 +2364,11 @@ let rewrite_hyp_then assert_style with_evars thin l2r id tac = let type_of = Tacmach.New.pf_unsafe_type_of gl in let whd_all = Tacmach.New.pf_apply whd_all gl in let t = whd_all (EConstr.of_constr (type_of (EConstr.mkVar id))) in + let t = EConstr.of_constr t in let eqtac, thin = match match_with_equality_type sigma t with | Some (hdcncl,[_;lhs;rhs]) -> + let lhs = EConstr.Unsafe.to_constr lhs in + let rhs = EConstr.Unsafe.to_constr rhs in if l2r && isVar lhs && not (occur_var env sigma (destVar lhs) (EConstr.of_constr rhs)) then let id' = destVar lhs in subst_on l2r id' rhs, early_clear id' thin @@ -2375,6 +2379,7 @@ let rewrite_hyp_then assert_style with_evars thin l2r id tac = Tacticals.New.tclTHEN (rew_on l2r onConcl) (clear [id]), thin | Some (hdcncl,[c]) -> + let c = EConstr.Unsafe.to_constr c in let l2r = not l2r in (* equality of the form eq_true *) if isVar c then let id' = destVar c in @@ -4689,6 +4694,7 @@ let reflexivity_red allowred = inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *) let sigma = Tacmach.New.project gl in let concl = maybe_betadeltaiota_concl allowred gl in + let concl = EConstr.of_constr concl in match match_with_equality_type sigma concl with | None -> Proofview.tclZERO NoEquationFound | Some _ -> one_constructor 1 NoBindings @@ -4716,19 +4722,21 @@ let (forward_setoid_symmetry, setoid_symmetry) = Hook.make () (* This is probably not very useful any longer *) let prove_symmetry hdcncl eq_kind = let symc = + let open EConstr in match eq_kind with | MonomorphicLeibnizEq (c1,c2) -> mkApp(hdcncl,[|c2;c1|]) | PolymorphicLeibnizEq (typ,c1,c2) -> mkApp(hdcncl,[|typ;c2;c1|]) | HeterogenousEq (t1,c1,t2,c2) -> mkApp(hdcncl,[|t2;c2;t1;c1|]) in + let symc = EConstr.Unsafe.to_constr symc in Tacticals.New.tclTHENFIRST (cut symc) (Tacticals.New.tclTHENLIST [ intro; Tacticals.New.onLastHyp simplest_case; one_constructor 1 NoBindings ]) -let match_with_equation c = +let match_with_equation sigma c = try - let res = match_with_equation c in + let res = match_with_equation sigma c in Proofview.tclUNIT res with NoEquationFound -> Proofview.tclZERO NoEquationFound @@ -4738,8 +4746,9 @@ let symmetry_red allowred = (* PL: usual symmetry don't perform any reduction when searching for an equality, but we may need to do some when called back from inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *) + let sigma = Tacmach.New.project gl in let concl = maybe_betadeltaiota_concl allowred gl in - match_with_equation concl >>= fun with_eqn -> + match_with_equation sigma (EConstr.of_constr concl) >>= fun with_eqn -> match with_eqn with | Some eq_data,_,_ -> Tacticals.New.tclTHEN @@ -4761,15 +4770,20 @@ let (forward_setoid_symmetry_in, setoid_symmetry_in) = Hook.make () let symmetry_in id = Proofview.Goal.enter { enter = begin fun gl -> + let sigma = Tacmach.New.project gl in let ctype = Tacmach.New.pf_unsafe_type_of gl (EConstr.mkVar id) in let sign,t = decompose_prod_assum ctype in + let t = EConstr.of_constr t in Proofview.tclORELSE begin - match_with_equation t >>= fun (_,hdcncl,eq) -> - let symccl = match eq with + match_with_equation sigma t >>= fun (_,hdcncl,eq) -> + let symccl = + let open EConstr in + match eq with | MonomorphicLeibnizEq (c1,c2) -> mkApp (hdcncl, [| c2; c1 |]) | PolymorphicLeibnizEq (typ,c1,c2) -> mkApp (hdcncl, [| typ; c2; c1 |]) | HeterogenousEq (t1,c1,t2,c2) -> mkApp (hdcncl, [| t2; c2; t1; c1 |]) in + let symccl = EConstr.Unsafe.to_constr symccl in Tacticals.New.tclTHENS (cut (it_mkProd_or_LetIn symccl sign)) [ intro_replacing id; Tacticals.New.tclTHENLIST [ intros; symmetry; apply (mkVar id); assumption ] ] @@ -4804,6 +4818,8 @@ let (forward_setoid_transitivity, setoid_transitivity) = Hook.make () (* This is probably not very useful any longer *) let prove_transitivity hdcncl eq_kind t = Proofview.Goal.enter { enter = begin fun gl -> + let t = EConstr.of_constr t in + let open EConstr in let (eq1,eq2) = match eq_kind with | MonomorphicLeibnizEq (c1,c2) -> mkApp (hdcncl, [| c1; t|]), mkApp (hdcncl, [| t; c2 |]) @@ -4813,10 +4829,13 @@ let prove_transitivity hdcncl eq_kind t = let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let type_of = Typing.unsafe_type_of env sigma in - let typt = type_of (EConstr.of_constr t) in + let typt = type_of t in + let typt = EConstr.of_constr typt in (mkApp(hdcncl, [| typ1; c1; typt ;t |]), mkApp(hdcncl, [| typt; t; typ2; c2 |])) in + let eq1 = EConstr.Unsafe.to_constr eq1 in + let eq2 = EConstr.Unsafe.to_constr eq2 in Tacticals.New.tclTHENFIRST (cut eq2) (Tacticals.New.tclTHENFIRST (cut eq1) (Tacticals.New.tclTHENLIST @@ -4830,8 +4849,9 @@ let transitivity_red allowred t = (* PL: usual transitivity don't perform any reduction when searching for an equality, but we may need to do some when called back from inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *) + let sigma = Tacmach.New.project gl in let concl = maybe_betadeltaiota_concl allowred gl in - match_with_equation concl >>= fun with_eqn -> + match_with_equation sigma (EConstr.of_constr concl) >>= fun with_eqn -> match with_eqn with | Some eq_data,_,_ -> Tacticals.New.tclTHEN diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 2684531529..368a1df76f 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -413,7 +413,7 @@ val subst_one : val declare_intro_decomp_eq : ((int -> unit Proofview.tactic) -> Coqlib.coq_eq_data * types * - (types * constr * constr) -> + (EConstr.types * EConstr.constr * EConstr.constr) -> constr * types -> unit Proofview.tactic) -> unit (** {6 Simple form of basic tactics. } *) -- cgit v1.2.3 From 485bbfbed4ae4a28119c4e42c5e40fd77abf4f8a Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 13 Nov 2016 20:38:41 +0100 Subject: Tactics API using EConstr. --- tactics/auto.ml | 1 + tactics/class_tactics.ml | 6 +- tactics/contradiction.ml | 14 +- tactics/contradiction.mli | 2 +- tactics/eauto.ml | 10 +- tactics/elim.ml | 4 +- tactics/eqdecide.ml | 19 +- tactics/eqschemes.ml | 2 +- tactics/equality.ml | 63 ++-- tactics/equality.mli | 16 +- tactics/hints.ml | 2 +- tactics/inv.ml | 8 +- tactics/inv.mli | 2 +- tactics/leminv.ml | 4 +- tactics/leminv.mli | 2 +- tactics/tacticals.ml | 5 +- tactics/tacticals.mli | 8 +- tactics/tactics.ml | 832 ++++++++++++++++++++++++---------------------- tactics/tactics.mli | 7 +- tactics/term_dnet.ml | 2 +- 20 files changed, 541 insertions(+), 468 deletions(-) (limited to 'tactics') diff --git a/tactics/auto.ml b/tactics/auto.ml index 2b654f5634..41b56bd3d0 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -115,6 +115,7 @@ let unify_resolve_gen poly = function let exact poly (c,clenv) = Proofview.Goal.enter { enter = begin fun gl -> let clenv', c = connect_hint_clenv poly c clenv gl in + let c = EConstr.of_constr c in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARUNIVCONTEXT (Evd.evar_universe_context clenv'.evd)) (exact_check c) diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index a8768b6edd..7d8fc79f4b 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -226,7 +226,8 @@ let e_give_exact flags poly (c,clenv) gl = c, {gl with sigma = evd} else c, gl in - let t1 = pf_unsafe_type_of gl (EConstr.of_constr c) in + let c = EConstr.of_constr c in + let t1 = pf_unsafe_type_of gl c in let t1 = EConstr.of_constr t1 in Proofview.V82.of_tactic (Clenvtac.unify ~flags t1 <*> exact_no_check c) gl @@ -1483,7 +1484,7 @@ let resolve_one_typeclass env ?(sigma=Evd.empty) gl unique = let evd = sig_sig gls' in let t = EConstr.Unsafe.to_constr t in let t' = let (ev, inst) = destEvar t in - mkEvar (ev, Array.of_list subst) + mkEvar (ev, Array.map_of_list EConstr.Unsafe.to_constr subst) in let term = Evarutil.nf_evar evd t' in evd, term @@ -1506,6 +1507,7 @@ let rec head_of_constr sigma t = let head_of_constr h c = Proofview.tclEVARMAP >>= fun sigma -> let c = head_of_constr sigma c in + let c = EConstr.of_constr c in letin_tac None (Name h) c None Locusops.allHyps let not_evar c = diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index a8be704b2a..a92b14dbe9 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -33,8 +33,8 @@ let absurd c = let t = EConstr.Unsafe.to_constr j.Environ.utj_val in let tac = Tacticals.New.tclTHENLIST [ - elim_type (build_coq_False ()); - Simple.apply (mk_absurd_proof t) + elim_type (EConstr.of_constr (build_coq_False ())); + Simple.apply (EConstr.of_constr (mk_absurd_proof t)) ] in Sigma.Unsafe.of_pair (tac, sigma) end } @@ -67,7 +67,7 @@ let contradiction_context = let typ = nf_evar sigma (NamedDecl.get_type d) in let typ = whd_all env sigma (EConstr.of_constr typ) in if is_empty_type sigma (EConstr.of_constr typ) then - simplest_elim (mkVar id) + simplest_elim (EConstr.mkVar id) else match kind_of_term typ with | Prod (na,t,u) when is_empty_type sigma (EConstr.of_constr u) -> let is_unit_or_eq = @@ -82,14 +82,14 @@ let contradiction_context = let params = Util.List.firstn nparams args in let p = applist ((mkConstructUi (indu,1)), params) in (* Checking on the fly that it type-checks *) - simplest_elim (mkApp (mkVar id,[|p|])) + simplest_elim (EConstr.mkApp (EConstr.mkVar id,[|EConstr.of_constr p|])) | None -> Tacticals.New.tclZEROMSG (Pp.str"Not a negated unit type.")) (Proofview.tclORELSE (Proofview.Goal.enter { enter = begin fun gl -> let is_conv_leq = Tacmach.New.pf_apply is_conv_leq gl in filter_hyp (fun typ -> is_conv_leq (EConstr.of_constr typ) (EConstr.of_constr t)) - (fun id' -> simplest_elim (mkApp (mkVar id,[|mkVar id'|]))) + (fun id' -> simplest_elim (EConstr.mkApp (EConstr.mkVar id,[|EConstr.mkVar id'|]))) end }) begin function (e, info) -> match e with | Not_found -> seek_neg rest @@ -113,7 +113,7 @@ let contradiction_term (c,lbind as cl) = let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let type_of = Tacmach.New.pf_unsafe_type_of gl in - let typ = type_of (EConstr.of_constr c) in + let typ = type_of c in let _, ccl = splay_prod env sigma (EConstr.of_constr typ) in if is_empty_type sigma (EConstr.of_constr ccl) then Tacticals.New.tclTHEN @@ -124,7 +124,7 @@ let contradiction_term (c,lbind as cl) = begin if lbind = NoBindings then filter_hyp (fun c -> is_negation_of env sigma typ (EConstr.of_constr c)) - (fun id -> simplest_elim (mkApp (mkVar id,[|c|]))) + (fun id -> simplest_elim (EConstr.mkApp (EConstr.mkVar id,[|c|]))) else Proofview.tclZERO Not_found end diff --git a/tactics/contradiction.mli b/tactics/contradiction.mli index b876aee909..5cc4b2e013 100644 --- a/tactics/contradiction.mli +++ b/tactics/contradiction.mli @@ -10,4 +10,4 @@ open Term open Misctypes val absurd : constr -> unit Proofview.tactic -val contradiction : constr with_bindings option -> unit Proofview.tactic +val contradiction : EConstr.constr with_bindings option -> unit Proofview.tactic diff --git a/tactics/eauto.ml b/tactics/eauto.ml index 7b07c93097..24e4de7506 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -29,8 +29,9 @@ open Proofview.Notations let eauto_unif_flags = auto_flags_of_state full_transparent_state let e_give_exact ?(flags=eauto_unif_flags) c = + let c = EConstr.of_constr c in Proofview.Goal.enter { enter = begin fun gl -> - let t1 = Tacmach.New.pf_unsafe_type_of gl (EConstr.of_constr c) in + let t1 = Tacmach.New.pf_unsafe_type_of gl c in let t1 = EConstr.of_constr t1 in let t2 = Tacmach.New.pf_concl (Proofview.Goal.assume gl) in let sigma = Tacmach.New.project gl in @@ -77,7 +78,7 @@ let apply_tac_list tac glls = let one_step l gl = [Proofview.V82.of_tactic Tactics.intro] - @ (List.map (fun c -> Proofview.V82.of_tactic (Tactics.Simple.eapply c)) (List.map mkVar (pf_ids_of_hyps gl))) + @ (List.map (fun c -> Proofview.V82.of_tactic (Tactics.Simple.eapply c)) (List.map EConstr.mkVar (pf_ids_of_hyps gl))) @ (List.map (fun c -> Proofview.V82.of_tactic (Tactics.Simple.eapply c)) l) @ (List.map (fun c -> Proofview.V82.of_tactic (assumption c)) (pf_ids_of_hyps gl)) @@ -94,8 +95,9 @@ let prolog_tac l n = Proofview.V82.tactic begin fun gl -> let map c = let (c, sigma) = Tactics.run_delayed (pf_env gl) (project gl) c in + let c = EConstr.Unsafe.to_constr c in let c = pf_apply (prepare_hint false (false,true)) gl (sigma, c) in - out_term c + EConstr.of_constr (out_term c) in let l = List.map map l in try (prolog l n gl) @@ -114,6 +116,7 @@ let priority l = List.map snd (List.filter (fun (pr,_) -> Int.equal pr 0) l) let unify_e_resolve poly flags (c,clenv) = Proofview.Goal.nf_enter { enter = begin fun gl -> let clenv', c = connect_hint_clenv poly c clenv gl in + let c = EConstr.of_constr c in Proofview.V82.tactic (fun gls -> let clenv' = clenv_unique_resolver ~flags clenv' gls in @@ -515,6 +518,7 @@ let autounfold_one db cl = let did, c' = unfold_head env st (match cl with Some (id, _) -> Tacmach.New.pf_get_hyp_typ id gl | None -> concl) in + let c' = EConstr.of_constr c' in if did then match cl with | Some hyp -> change_in_hyp None (make_change_arg c') hyp diff --git a/tactics/elim.ml b/tactics/elim.ml index d00e504ff5..e641f970aa 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -77,10 +77,12 @@ let tmphyp_name = Id.of_string "_TmpHyp" let up_to_delta = ref false (* true *) let general_decompose recognizer c = + let c = EConstr.of_constr c in Proofview.Goal.enter { enter = begin fun gl -> let type_of = pf_unsafe_type_of gl in let sigma = project gl in - let typc = type_of (EConstr.of_constr c) in + let typc = type_of c in + let typc = EConstr.of_constr typc in tclTHENS (cut typc) [ tclTHEN (intro_using tmphyp_name) (onLastHypId diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml index ed81d748a4..eb75cbf7dc 100644 --- a/tactics/eqdecide.ml +++ b/tactics/eqdecide.ml @@ -25,6 +25,7 @@ open Misctypes open Tactypes open Hipattern open Pretyping +open Proofview.Notations open Tacmach.New open Coqlib @@ -50,7 +51,10 @@ open Coqlib Eduardo Gimenez (30/3/98). *) -let clear_last = (onLastHyp (fun c -> (clear [destVar c]))) +let clear_last = + let open EConstr in + Proofview.tclEVARMAP >>= fun sigma -> + (onLastHyp (fun c -> (clear [destVar sigma c]))) let choose_eq eqonleft = if eqonleft then @@ -66,14 +70,14 @@ let choose_noteq eqonleft = let mkBranches c1 c2 = tclTHENLIST [generalize [c2]; - Simple.elim c1; + Simple.elim (EConstr.of_constr c1); intros; onLastHyp Simple.case; clear_last; intros] let discrHyp id = - let c = { delayed = fun env sigma -> Sigma.here (Term.mkVar id, NoBindings) sigma } in + let c = { delayed = fun env sigma -> Sigma.here (EConstr.mkVar id, NoBindings) sigma } in let tac c = Equality.discr_tac false (Some (None, ElimOnConstr c)) in Tacticals.New.tclDELAYEDWITHHOLES false c tac @@ -121,7 +125,7 @@ let eqCase tac = tclTHEN intro (onLastHypId tac) let injHyp id = - let c = { delayed = fun env sigma -> Sigma.here (Term.mkVar id, NoBindings) sigma } in + let c = { delayed = fun env sigma -> Sigma.here (EConstr.mkVar id, NoBindings) sigma } in let tac c = Equality.injClause None false (Some (None, ElimOnConstr c)) in Tacticals.New.tclDELAYEDWITHHOLES false c tac @@ -133,7 +137,7 @@ let diseqCase hyps eqonleft = (tclTHEN (rewrite_and_clear (List.rev hyps)) (tclTHEN (red_in_concl) (tclTHEN (intro_using absurd) - (tclTHEN (Simple.apply (mkVar diseq)) + (tclTHEN (Simple.apply (EConstr.mkVar diseq)) (tclTHEN (injHyp absurd) (full_trivial [])))))))) @@ -158,6 +162,7 @@ let rec solveArg hyps eqonleft op largs rargs = match largs, rargs with Proofview.Goal.enter { enter = begin fun gl -> let rectype = pf_unsafe_type_of gl (EConstr.of_constr a1) in let decide = mkDecideEqGoal eqonleft op rectype a1 a2 in + let decide = EConstr.of_constr decide in let tac hyp = solveArg (hyp :: hyps) eqonleft op largs rargs in let subtacs = if eqonleft then [eqCase tac;diseqCase hyps eqonleft;default_auto] @@ -207,7 +212,7 @@ let decideGralEquality = | _ -> tclZEROMSG (Pp.str"This decision procedure only works for inductive objects.") end >>= fun rectype -> (tclTHEN - (mkBranches c1 c2) + (mkBranches c1 (EConstr.of_constr c2)) (tclORELSE (solveNoteqBranch eqonleft) (solveEqBranch rectype))) end } end @@ -222,6 +227,7 @@ let decideEqualityGoal = tclTHEN intros decideGralEquality let decideEquality rectype = Proofview.Goal.enter { enter = begin fun gl -> let decide = mkGenDecideEqGoal rectype gl in + let decide = EConstr.of_constr decide in (tclTHENS (cut decide) [default_auto;decideEqualityGoal]) end } @@ -232,6 +238,7 @@ let compare c1 c2 = Proofview.Goal.enter { enter = begin fun gl -> let rectype = pf_unsafe_type_of gl (EConstr.of_constr c1) in let decide = mkDecideEqGoal true (build_coq_sumbool ()) rectype c1 c2 in + let decide = EConstr.of_constr decide in (tclTHENS (cut decide) [(tclTHEN intro (tclTHEN (onLastHyp simplest_case) clear_last)); diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml index 92480e253b..57bac25b90 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -120,7 +120,7 @@ let get_sym_eq_data env (ind,u) = let paramsctxt = Vars.subst_instance_context u mib.mind_params_ctxt in let paramsctxt1,_ = List.chop (mib.mind_nparams-mip.mind_nrealargs) paramsctxt in - if not (List.equal eq_constr params2 constrargs) then + if not (List.equal Term.eq_constr params2 constrargs) then error "Constructors arguments must repeat the parameters."; (* nrealargs_ctxt and nrealargs are the same here *) (specif,mip.mind_nrealargs,realsign,paramsctxt,paramsctxt1) diff --git a/tactics/equality.ml b/tactics/equality.ml index e1a8d2bdb1..80f83f19bf 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -186,8 +186,8 @@ let instantiate_lemma_all frzevars gl c ty l l2r concl = let instantiate_lemma gl c ty l l2r concl = let c = EConstr.of_constr c in let sigma, ct = pf_type_of gl c in - let t = try snd (reduce_to_quantified_ind (pf_env gl) sigma (EConstr.of_constr ct)) with UserError _ -> ct in - let t = EConstr.of_constr t in + let ct = EConstr.of_constr ct in + let t = try snd (reduce_to_quantified_ind (pf_env gl) sigma ct) with UserError _ -> ct in let l = Miscops.map_bindings EConstr.of_constr l in let eqclause = Clenv.make_clenv_binding (pf_env gl) sigma (c,t) l in [eqclause] @@ -413,6 +413,7 @@ let leibniz_rewrite_ebindings_clause cls lft2rgt tac c t l with_evars frzevars d let type_of_cls = type_of_clause cls gl in let dep = dep_proof_ok && dep_fun evd (EConstr.of_constr c) (EConstr.of_constr type_of_cls) in let Sigma ((elim, effs), sigma, p) = find_elim hdcncl lft2rgt dep cls (Some t) gl in + let elim = EConstr.of_constr elim in let tac = Proofview.tclEFFECTS effs <*> general_elim_clause with_evars frzevars tac cls c t l @@ -562,6 +563,7 @@ let general_multi_rewrite with_evars l cl tac = let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let (c, sigma) = run_delayed env sigma f in + let c = Miscops.map_with_bindings EConstr.Unsafe.to_constr c in tclWITHHOLES with_evars (general_rewrite_clause l2r with_evars ?tac c cl) sigma end } @@ -646,6 +648,8 @@ let replace_using_leibniz clause c1 c2 l2r unsafe try_prove_eq_opt = 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 + let sym = EConstr.of_constr sym in + let eq = EConstr.of_constr eq in tclTHENLAST (replace_core clause l2r eq) (tclFIRST @@ -948,7 +952,7 @@ let gen_absurdity id = let hyp_typ = EConstr.of_constr hyp_typ in if is_empty_type sigma hyp_typ then - simplest_elim (mkVar id) + simplest_elim (EConstr.mkVar id) else tclZEROMSG (str "Not the negation of an equality.") end } @@ -996,6 +1000,7 @@ let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn = let t = EConstr.Unsafe.to_constr t in let t1 = EConstr.Unsafe.to_constr t1 in let t2 = EConstr.Unsafe.to_constr t2 in + let eqn = EConstr.Unsafe.to_constr eqn in 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 = @@ -1004,6 +1009,7 @@ let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn = discrimination_pf env sigma e (t,t1,t2) discriminator lbeq in let pf_ty = mkArrow eqn absurd_term in let absurd_clause = apply_on_clause (pf,pf_ty) eq_clause in + let absurd_term = EConstr.of_constr absurd_term in let pf = Clenvtac.clenv_value_cast_meta absurd_clause in Proofview.Unsafe.tclEVARS sigma <*> Proofview.tclEFFECTS eff <*> @@ -1023,18 +1029,15 @@ let discrEq (lbeq,_,(t,t1,t2) as u) eq_clause = let onEquality with_evars tac (c,lbindc) = Proofview.Goal.nf_enter { enter = begin fun gl -> - let c = EConstr.of_constr c in - let lbindc = Miscops.map_bindings EConstr.of_constr lbindc in let type_of = pf_unsafe_type_of gl in let reduce_to_quantified_ind = pf_apply Tacred.reduce_to_quantified_ind gl in let t = type_of c in - let t' = try snd (reduce_to_quantified_ind (EConstr.of_constr t)) with UserError _ -> t in - let t' = EConstr.of_constr t' in + let t = EConstr.of_constr t in + let t' = try snd (reduce_to_quantified_ind t) with UserError _ -> t in let eq_clause = pf_apply make_clenv_binding gl (c,t') lbindc in let eq_clause' = Clenvtac.clenv_pose_dependent_evars with_evars eq_clause in let eqn = clenv_type eq_clause' in - let eqn = EConstr.Unsafe.to_constr eqn in - let (eq,u,eq_args) = find_this_eq_data_decompose gl (EConstr.of_constr eqn) in + let (eq,u,eq_args) = find_this_eq_data_decompose gl eqn in tclTHEN (Proofview.Unsafe.tclEVARS eq_clause'.evd) (tac (eq,eqn,eq_args) eq_clause') @@ -1049,14 +1052,14 @@ let onNegatedEquality with_evars tac = | Prod (_,t,u) when is_empty_type sigma (EConstr.of_constr u) -> tclTHEN introf (onLastHypId (fun id -> - onEquality with_evars tac (mkVar id,NoBindings))) + onEquality with_evars tac (EConstr.mkVar id,NoBindings))) | _ -> tclZEROMSG (str "Not a negated primitive equality.") end } let discrSimpleClause with_evars = function | None -> onNegatedEquality with_evars discrEq - | Some id -> onEquality with_evars discrEq (mkVar id,NoBindings) + | Some id -> onEquality with_evars discrEq (EConstr.mkVar id,NoBindings) let discr with_evars = onEquality with_evars discrEq @@ -1070,7 +1073,7 @@ let discrEverywhere with_evars = (tclTHEN (tclREPEAT introf) (tryAllHyps - (fun id -> tclCOMPLETE (discr with_evars (mkVar id,NoBindings))))) + (fun id -> tclCOMPLETE (discr with_evars (EConstr.mkVar id,NoBindings))))) else (* <= 8.2 compat *) tryAllHypsAndConcl (discrSimpleClause with_evars)) (* (fun gls -> @@ -1194,17 +1197,15 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt = | (_sigS,[a;p]) -> (EConstr.Unsafe.to_constr a, EConstr.Unsafe.to_constr p) | _ -> anomaly ~label:"sig_clausal_form" (Pp.str "should be a sigma type") in let ev = Evarutil.e_new_evar env evdref (EConstr.of_constr a) in - let rty = beta_applist sigma (EConstr.of_constr p_i_minus_1,[EConstr.of_constr ev]) in + let rty = beta_applist sigma (EConstr.of_constr p_i_minus_1,[ev]) in let tuple_tail = sigrec_clausal_form (siglen-1) rty in - match - Evd.existential_opt_value !evdref - (destEvar ev) - with + let evopt = match EConstr.kind !evdref ev with Evar _ -> None | _ -> Some ev in + match evopt with | Some w -> - let w_type = unsafe_type_of env sigma (EConstr.of_constr w) in + let w_type = unsafe_type_of env !evdref w in if Evarconv.e_cumul env evdref (EConstr.of_constr w_type) (EConstr.of_constr a) then let exist_term = Evarutil.evd_comb1 (Evd.fresh_global env) evdref sigdata.intro in - applist(exist_term,[a;p_i_minus_1;w;tuple_tail]) + applist(exist_term,[a;p_i_minus_1;EConstr.Unsafe.to_constr w;tuple_tail]) else error "Cannot solve a unification problem." | None -> @@ -1354,7 +1355,8 @@ let inject_if_homogenous_dependent_pair ty = [Proofview.tclEFFECTS eff; intro; onLastHyp (fun hyp -> - tclTHENS (cut (mkApp (ceq,new_eq_args))) + let hyp = EConstr.Unsafe.to_constr hyp in + tclTHENS (cut (EConstr.of_constr (mkApp (ceq,new_eq_args)))) [clear [destVar hyp]; Proofview.V82.tactic (Tacmach.refine (EConstr.of_constr (mkApp(inj2,[|ar1.(0);mkConst c;ar1.(1);ar1.(2);ar1.(3);ar2.(3);hyp|])))) @@ -1404,7 +1406,7 @@ let inject_at_positions env sigma l2r (eq,_,(t,t1,t2)) eq_clause posns tac = Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (Tacticals.New.tclTHENFIRST (Proofview.tclIGNORE (Proofview.Monad.List.map - (fun (pf,ty) -> tclTHENS (cut ty) + (fun (pf,ty) -> tclTHENS (cut (EConstr.of_constr ty)) [inject_if_homogenous_dependent_pair (EConstr.of_constr ty); Proofview.V82.tactic (Tacmach.refine (EConstr.of_constr pf))]) (if l2r then List.rev injectors else injectors))) @@ -1452,6 +1454,7 @@ let injEq ?(old=false) with_evars clear_flag ipats = let destopt = match kind_of_term c with | Var id -> get_previous_hyp_position id gl | _ -> MoveLast in + let c = EConstr.of_constr c in let clear_tac = tclTRY (apply_clear_request clear_flag dft_clear_flag c) in (* Try should be removal if dependency were treated *) @@ -1497,12 +1500,11 @@ let dEqThen with_evars ntac = function let dEq with_evars = dEqThen with_evars (fun clear_flag c x -> + let c = EConstr.of_constr c in (apply_clear_request clear_flag (use_clear_hyp_by_default ()) c)) let intro_decomp_eq tac data (c, t) = Proofview.Goal.enter { enter = begin fun gl -> - let c = EConstr.of_constr c in - let t = EConstr.of_constr t in let cl = pf_apply make_clenv_binding gl (c, t) NoBindings in decompEqThen (fun _ -> tac) data cl end } @@ -1596,13 +1598,16 @@ let subst_tuple_term env sigma dep_pair1 dep_pair2 b = (* on for further iterated sigma-tuples *) let cutSubstInConcl l2r eqn = + let eqn = EConstr.of_constr eqn in Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in - let (lbeq,u,(t,e1,e2)) = find_eq_data_decompose gl (EConstr.of_constr eqn) in + let (lbeq,u,(t,e1,e2)) = find_eq_data_decompose gl eqn in let typ = pf_concl gl in let (e1,e2) = if l2r then (e1,e2) else (e2,e1) in let Sigma ((typ, expected), sigma, p) = subst_tuple_term env sigma e1 e2 typ in + let typ = EConstr.of_constr typ in + let expected = EConstr.of_constr expected in let tac = tclTHENFIRST (tclTHENLIST [ @@ -1615,13 +1620,16 @@ let cutSubstInConcl l2r eqn = end } let cutSubstInHyp l2r eqn id = + let eqn = EConstr.of_constr eqn in Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in - let (lbeq,u,(t,e1,e2)) = find_eq_data_decompose gl (EConstr.of_constr eqn) in + let (lbeq,u,(t,e1,e2)) = find_eq_data_decompose gl eqn in let typ = pf_get_hyp_typ id gl in let (e1,e2) = if l2r then (e1,e2) else (e2,e1) in let Sigma ((typ, expected), sigma, p) = subst_tuple_term env sigma e1 e2 typ in + let typ = EConstr.of_constr typ in + let expected = EConstr.of_constr expected in let tac = tclTHENFIRST (tclTHENLIST [ @@ -1653,8 +1661,9 @@ let cutRewriteInHyp l2r eqn id = cutRewriteClause l2r eqn (Some id) let cutRewriteInConcl l2r eqn = cutRewriteClause l2r eqn None let substClause l2r c cls = + let c = EConstr.of_constr c in Proofview.Goal.enter { enter = begin fun gl -> - let eq = pf_apply get_type_of gl (EConstr.of_constr c) in + let eq = pf_apply get_type_of gl c in tclTHENS (cutSubstClause l2r eq cls) [Proofview.tclUNIT (); exact_no_check c] end } @@ -1937,7 +1946,7 @@ let replace_term dir_opt c = (* Declare rewriting tactic for intro patterns "<-" and "->" *) let _ = - let gmr l2r with_evars tac c = general_rewrite_clause l2r with_evars tac c in + let gmr l2r with_evars tac c = general_rewrite_clause l2r with_evars (Miscops.map_with_bindings EConstr.Unsafe.to_constr tac) c in Hook.set Tactics.general_rewrite_clause gmr let _ = Hook.set Tactics.subst_one subst_one diff --git a/tactics/equality.mli b/tactics/equality.mli index 779d1e9b21..97f51ae202 100644 --- a/tactics/equality.mli +++ b/tactics/equality.mli @@ -60,30 +60,30 @@ val general_rewrite_clause : orientation -> evars_flag -> ?tac:(unit Proofview.tactic * conditions) -> constr with_bindings -> clause -> unit Proofview.tactic val general_multi_rewrite : - evars_flag -> (bool * multi * clear_flag * delayed_open_constr_with_bindings) list -> + evars_flag -> (bool * multi * clear_flag * EConstr.constr with_bindings delayed_open) list -> clause -> (unit Proofview.tactic * conditions) option -> unit Proofview.tactic val replace_in_clause_maybe_by : constr -> constr -> clause -> unit Proofview.tactic option -> unit Proofview.tactic val replace : constr -> constr -> unit Proofview.tactic val replace_by : constr -> constr -> unit Proofview.tactic -> unit Proofview.tactic -val discr : evars_flag -> constr with_bindings -> unit Proofview.tactic +val discr : evars_flag -> EConstr.constr with_bindings -> unit Proofview.tactic val discrConcl : unit Proofview.tactic val discrHyp : Id.t -> unit Proofview.tactic val discrEverywhere : evars_flag -> unit Proofview.tactic val discr_tac : evars_flag -> - constr with_bindings destruction_arg option -> unit Proofview.tactic + EConstr.constr with_bindings destruction_arg option -> unit Proofview.tactic val inj : intro_patterns option -> evars_flag -> - clear_flag -> constr with_bindings -> unit Proofview.tactic + clear_flag -> EConstr.constr with_bindings -> unit Proofview.tactic val injClause : intro_patterns option -> evars_flag -> - constr with_bindings destruction_arg option -> unit Proofview.tactic + EConstr.constr with_bindings destruction_arg option -> unit Proofview.tactic val injHyp : clear_flag -> Id.t -> unit Proofview.tactic val injConcl : unit Proofview.tactic val simpleInjClause : evars_flag -> - constr with_bindings destruction_arg option -> unit Proofview.tactic + EConstr.constr with_bindings destruction_arg option -> unit Proofview.tactic -val dEq : evars_flag -> constr with_bindings destruction_arg option -> unit Proofview.tactic -val dEqThen : evars_flag -> (clear_flag -> constr -> int -> unit Proofview.tactic) -> constr with_bindings destruction_arg option -> unit Proofview.tactic +val dEq : evars_flag -> EConstr.constr with_bindings destruction_arg option -> unit Proofview.tactic +val dEqThen : evars_flag -> (clear_flag -> constr -> int -> unit Proofview.tactic) -> EConstr.constr with_bindings destruction_arg option -> unit Proofview.tactic val make_iterated_tuple : env -> evar_map -> constr -> (constr * types) -> evar_map * (constr * constr * constr) diff --git a/tactics/hints.ml b/tactics/hints.ml index ea95fb1ade..560e7e43da 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -1320,7 +1320,7 @@ let make_local_hint_db env sigma ts eapply lems = let map c = let sigma = Sigma.Unsafe.of_evar_map sigma in let Sigma (c, sigma, _) = c.delayed env sigma in - (Sigma.to_evar_map sigma, c) + (Sigma.to_evar_map sigma, EConstr.Unsafe.to_constr c) in let lems = List.map map lems in let sign = Environ.named_context env in diff --git a/tactics/inv.ml b/tactics/inv.ml index a971b9356f..c66b356c7d 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -284,7 +284,7 @@ let error_too_many_names pats = tclZEROMSG ~loc ( str "Unexpected " ++ str (String.plural (List.length pats) "introduction pattern") ++ - str ": " ++ pr_enum (Miscprint.pr_intro_pattern (fun c -> Printer.pr_constr (fst (run_delayed env Evd.empty c)))) pats ++ + str ": " ++ pr_enum (Miscprint.pr_intro_pattern (fun c -> Printer.pr_constr (EConstr.Unsafe.to_constr (fst (run_delayed env Evd.empty c))))) pats ++ str ".") let get_names (allow_conj,issimple) (loc, pat as x) = match pat with @@ -369,7 +369,7 @@ let projectAndApply as_mode thin avoid id eqname names depids = (* and apply a trailer which again try to substitute *) (fun id -> dEqThen false (deq_trailer id) - (Some (None,ElimOnConstr (mkVar id,NoBindings)))) + (Some (None,ElimOnConstr (EConstr.mkVar id,NoBindings)))) id let nLastDecls i tac = @@ -443,7 +443,6 @@ let raw_inversion inv_kind id status names = let msg = str "The type of " ++ pr_id id ++ str " is not inductive." in CErrors.user_err msg in - let t = EConstr.of_constr t in let IndType (indf,realargs) = find_rectype env sigma t in let evdref = ref sigma in let (elim_predicate, args) = @@ -457,6 +456,7 @@ let raw_inversion inv_kind id status names = Reduction.beta_appvect elim_predicate (Array.of_list realargs), case_nodep_then_using in + let cut_concl = EConstr.of_constr cut_concl in let refined id = let prf = mkApp (mkVar id, args) in let prf = EConstr.of_constr prf in @@ -505,7 +505,7 @@ let inv k = inv_gen k NoDep let inv_tac id = inv FullInversion None (NamedHyp id) let inv_clear_tac id = inv FullInversionClear None (NamedHyp id) -let dinv k c = inv_gen k (Dep c) +let dinv k c = inv_gen k (Dep (Option.map EConstr.Unsafe.to_constr c)) let dinv_tac id = dinv FullInversion None None (NamedHyp id) let dinv_clear_tac id = dinv FullInversionClear None None (NamedHyp id) diff --git a/tactics/inv.mli b/tactics/inv.mli index df629e7c9f..6bb2b72829 100644 --- a/tactics/inv.mli +++ b/tactics/inv.mli @@ -20,7 +20,7 @@ val inv_clause : val inv : inversion_kind -> or_and_intro_pattern option -> quantified_hypothesis -> unit Proofview.tactic -val dinv : inversion_kind -> constr option -> +val dinv : inversion_kind -> EConstr.constr option -> or_and_intro_pattern option -> quantified_hypothesis -> unit Proofview.tactic val inv_tac : Id.t -> unit Proofview.tactic diff --git a/tactics/leminv.ml b/tactics/leminv.ml index 16a048af82..a942384184 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -291,5 +291,5 @@ let lemInvIn id c ids = let lemInvIn_gen id c l = try_intros_until (fun id -> lemInvIn id c l) id let lemInv_clause id c = function - | [] -> lemInv_gen id c - | l -> lemInvIn_gen id c l + | [] -> lemInv_gen id (EConstr.Unsafe.to_constr c) + | l -> lemInvIn_gen id (EConstr.Unsafe.to_constr c) l diff --git a/tactics/leminv.mli b/tactics/leminv.mli index c6ed9606f2..58b82002da 100644 --- a/tactics/leminv.mli +++ b/tactics/leminv.mli @@ -12,7 +12,7 @@ open Constrexpr open Misctypes val lemInv_clause : - quantified_hypothesis -> constr -> Id.t list -> unit Proofview.tactic + quantified_hypothesis -> EConstr.constr -> Id.t list -> unit Proofview.tactic val add_inversion_lemma_exn : Id.t -> constr_expr -> glob_sort -> bool -> (Id.t -> unit Proofview.tactic) -> diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index 0546132c13..e15ee149d1 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -73,7 +73,7 @@ let nthDecl m gl = with Failure _ -> error "No such assumption." let nthHypId m gl = nthDecl m gl |> NamedDecl.get_id -let nthHyp m gl = mkVar (nthHypId m gl) +let nthHyp m gl = EConstr.mkVar (nthHypId m gl) let lastDecl gl = nthDecl 1 gl let lastHypId gl = nthHypId 1 gl @@ -564,7 +564,7 @@ module New = struct let gl = Proofview.Goal.assume gl in nthDecl m gl |> NamedDecl.get_id let nthHyp m gl = - mkVar (nthHypId m gl) + EConstr.mkVar (nthHypId m gl) let onNthHypId m tac = Proofview.Goal.enter { enter = begin fun gl -> tac (nthHypId m gl) end } @@ -680,7 +680,6 @@ module New = struct let elimination_then tac c = Proofview.Goal.nf_enter { enter = begin fun gl -> let (ind,t) = pf_reduce_to_quantified_ind gl (EConstr.of_constr (pf_unsafe_type_of gl c)) in - let t = EConstr.of_constr t in let isrec,mkelim = match (Global.lookup_mind (fst (fst ind))).mind_record with | None -> true,gl_make_elim diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index 974bf83a31..2c3e512806 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -58,17 +58,17 @@ val tclIFTHENTRYELSEMUST : tactic -> tactic -> tactic (** {6 Tacticals applying to hypotheses } *) val onNthHypId : int -> (Id.t -> tactic) -> tactic -val onNthHyp : int -> (constr -> tactic) -> tactic +val onNthHyp : int -> (EConstr.constr -> tactic) -> tactic val onNthDecl : int -> (Context.Named.Declaration.t -> tactic) -> tactic val onLastHypId : (Id.t -> tactic) -> tactic -val onLastHyp : (constr -> tactic) -> tactic +val onLastHyp : (EConstr.constr -> tactic) -> tactic val onLastDecl : (Context.Named.Declaration.t -> tactic) -> tactic val onNLastHypsId : int -> (Id.t list -> tactic) -> tactic val onNLastHyps : int -> (constr list -> tactic) -> tactic val onNLastDecls : int -> (Context.Named.t -> tactic) -> tactic val lastHypId : goal sigma -> Id.t -val lastHyp : goal sigma -> constr +val lastHyp : goal sigma -> EConstr.constr val lastDecl : goal sigma -> Context.Named.Declaration.t val nLastHypsId : int -> goal sigma -> Id.t list val nLastHyps : int -> goal sigma -> constr list @@ -236,7 +236,7 @@ module New : sig val onNthHypId : int -> (identifier -> unit tactic) -> unit tactic val onLastHypId : (identifier -> unit tactic) -> unit tactic - val onLastHyp : (constr -> unit tactic) -> unit tactic + val onLastHyp : (EConstr.constr -> unit tactic) -> unit tactic val onLastDecl : (Context.Named.Declaration.t -> unit tactic) -> unit tactic val onHyps : ([ `NF ], Context.Named.t) Proofview.Goal.enter -> diff --git a/tactics/tactics.ml b/tactics/tactics.ml index a04fb7ca21..b9da110210 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -6,14 +6,17 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +module CVars = Vars + open Pp open CErrors open Util open Names open Nameops open Term -open Vars open Termops +open EConstr +open Vars open Find_subterm open Namegen open Declarations @@ -48,7 +51,7 @@ open Context.Named.Declaration module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration -let inj_with_occurrences e = (AllOccurrences,e) +let inj_with_occurrences e = (AllOccurrences,EConstr.Unsafe.to_constr e) let dloc = Loc.ghost @@ -167,6 +170,26 @@ let _ = (* Primitive tactics *) (******************************************) +let local_assum (na, t) = + let open Context.Rel.Declaration in + let inj = EConstr.Unsafe.to_constr in + LocalAssum (na, inj t) + +let local_def (na, b, t) = + let open Context.Rel.Declaration in + let inj = EConstr.Unsafe.to_constr in + LocalDef (na, inj b, inj t) + +let nlocal_assum (na, t) = + let open Context.Named.Declaration in + let inj = EConstr.Unsafe.to_constr in + LocalAssum (na, inj t) + +let nlocal_def (na, b, t) = + let open Context.Named.Declaration in + let inj = EConstr.Unsafe.to_constr in + LocalDef (na, inj b, inj t) + (** This tactic creates a partial proof realizing the introduction rule, but does not check anything. *) let unsafe_intro env store decl b = @@ -176,14 +199,15 @@ let unsafe_intro env store decl b = let inst = List.map (NamedDecl.get_id %> mkVar) (named_context env) in let ninst = mkRel 1 :: inst in let nb = subst1 (mkVar (NamedDecl.get_id decl)) b in - let Sigma (ev, sigma, p) = new_evar_instance nctx sigma (EConstr.of_constr nb) ~principal:true ~store ninst in - Sigma (EConstr.of_constr (mkNamedLambda_or_LetIn decl ev), sigma, p) + let Sigma (ev, sigma, p) = new_evar_instance nctx sigma nb ~principal:true ~store ninst in + Sigma (mkNamedLambda_or_LetIn decl ev, sigma, p) end } let introduction ?(check=true) id = Proofview.Goal.enter { enter = begin fun gl -> let gl = Proofview.Goal.assume gl in let concl = Proofview.Goal.concl gl in + let concl = EConstr.of_constr concl 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 @@ -193,9 +217,9 @@ let introduction ?(check=true) id = (str "Variable " ++ pr_id id ++ str " is already declared.") in let open Context.Named.Declaration in - match kind_of_term (whd_evar sigma concl) with - | Prod (_, t, b) -> unsafe_intro env store (LocalAssum (id, t)) b - | LetIn (_, c, t, b) -> unsafe_intro env store (LocalDef (id, c, t)) b + match EConstr.kind sigma concl with + | Prod (_, t, b) -> unsafe_intro env store (nlocal_assum (id, t)) b + | LetIn (_, c, t, b) -> unsafe_intro env store (nlocal_def (id, c, t)) b | _ -> raise (RefinerError IntroNeedsProduct) end } @@ -206,19 +230,19 @@ let convert_concl ?(check=true) ty k = let env = Proofview.Goal.env gl in let store = Proofview.Goal.extra gl in let conclty = Proofview.Goal.raw_concl gl in - let ty = EConstr.of_constr ty in + let conclty = EConstr.of_constr conclty in Refine.refine ~unsafe:true { run = begin fun sigma -> let Sigma ((), sigma, p) = if check then begin let sigma = Sigma.to_evar_map sigma in ignore (Typing.unsafe_type_of env sigma ty); - let sigma,b = Reductionops.infer_conv env sigma ty (EConstr.of_constr conclty) in + let sigma,b = Reductionops.infer_conv env sigma ty conclty in if not b then error "Not convertible."; Sigma.Unsafe.of_pair ((), sigma) end else Sigma.here () sigma in let Sigma (x, sigma, q) = Evarutil.new_evar env sigma ~principal:true ~store ty in let ans = if k == DEFAULTcast then x else mkCast(x,k,conclty) in - Sigma (EConstr.of_constr ans, sigma, p +> q) + Sigma (ans, sigma, p +> q) end } end } @@ -227,12 +251,12 @@ let convert_hyp ?(check=true) d = let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let ty = Proofview.Goal.raw_concl gl in + let ty = EConstr.of_constr ty in let store = Proofview.Goal.extra gl in let sign = convert_hyp check (named_context_val env) sigma d in let env = reset_with_named_context sign env in Refine.refine ~unsafe:true { run = begin fun sigma -> - let Sigma (c, sigma, p) = Evarutil.new_evar env sigma ~principal:true ~store (EConstr.of_constr ty) in - Sigma (EConstr.of_constr c, sigma, p) + Evarutil.new_evar env sigma ~principal:true ~store ty end } end } @@ -250,8 +274,8 @@ let convert_gen pb x y = Tacticals.New.tclFAIL 0 (str "Not convertible") end } -let convert x y = convert_gen Reduction.CONV (EConstr.of_constr x) (EConstr.of_constr y) -let convert_leq x y = convert_gen Reduction.CUMUL (EConstr.of_constr x) (EConstr.of_constr y) +let convert x y = convert_gen Reduction.CONV x y +let convert_leq x y = convert_gen Reduction.CUMUL x y let clear_dependency_msg env sigma id = function | Evarutil.OccurHypInSimpleClause None -> @@ -300,10 +324,10 @@ let clear_gen fail = function try clear_hyps_in_evi env evdref (named_context_val env) concl ids with Evarutil.ClearDependencyError (id,err) -> fail env sigma id err in + let concl = EConstr.of_constr concl in let env = reset_with_named_context hyps env in let tac = Refine.refine ~unsafe:true { run = fun sigma -> - let Sigma (c, sigma, p) = Evarutil.new_evar env sigma ~principal:true (EConstr.of_constr concl) in - Sigma (EConstr.of_constr c, sigma, p) + Evarutil.new_evar env sigma ~principal:true concl } in Sigma.Unsafe.of_pair (tac, !evdref) end } @@ -312,14 +336,15 @@ let clear ids = clear_gen error_clear_dependency ids let clear_for_replacing ids = clear_gen error_replacing_dependency ids let apply_clear_request clear_flag dft c = + Proofview.tclEVARMAP >>= fun sigma -> let check_isvar c = - if not (isVar c) then + if not (isVar sigma c) then error "keep/clear modifiers apply only to hypothesis names." in let doclear = match clear_flag with - | None -> dft && isVar c + | None -> dft && isVar sigma c | Some true -> check_isvar c; true | Some false -> false in - if doclear then clear [destVar c] + if doclear then clear [destVar sigma c] else Tacticals.New.tclIDTAC (* Moving hypotheses *) @@ -328,13 +353,13 @@ let move_hyp id dest = let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let ty = Proofview.Goal.raw_concl gl in + let ty = EConstr.of_constr ty in let store = Proofview.Goal.extra gl in let sign = named_context_val env in let sign' = move_hyp_in_named_context sigma id dest sign in let env = reset_with_named_context sign' env in Refine.refine ~unsafe:true { run = begin fun sigma -> - let Sigma (c, sigma, p) = Evarutil.new_evar env sigma ~principal:true ~store (EConstr.of_constr ty) in - Sigma (EConstr.of_constr c, sigma, p) + Evarutil.new_evar env sigma ~principal:true ~store ty end } end } @@ -376,20 +401,20 @@ let rename_hyp repl = with Not_found -> () in (** All is well *) - let make_subst (src, dst) = (src, mkVar dst) in + let make_subst (src, dst) = (src, Constr.mkVar dst) in let subst = List.map make_subst repl in - let subst c = Vars.replace_vars subst c in + let subst c = CVars.replace_vars subst c in let map decl = decl |> NamedDecl.map_id (fun id -> try List.assoc_f Id.equal id repl with Not_found -> id) |> NamedDecl.map_constr subst in let nhyps = List.map map hyps in let nconcl = subst concl in + let nconcl = EConstr.of_constr nconcl in let nctx = Environ.val_of_named_context nhyps in let instance = List.map (NamedDecl.get_id %> mkVar) hyps in Refine.refine ~unsafe:true { run = begin fun sigma -> - let Sigma (c, sigma, p) = Evarutil.new_evar_instance nctx sigma (EConstr.of_constr nconcl) ~principal:true ~store instance in - Sigma (EConstr.of_constr c, sigma, p) + Evarutil.new_evar_instance nctx sigma nconcl ~principal:true ~store instance end } end } @@ -456,8 +481,7 @@ let find_name mayrepl decl naming gl = match naming with let assert_before_then_gen b naming t tac = let open Context.Rel.Declaration in Proofview.Goal.enter { enter = begin fun gl -> - let id = find_name b (LocalAssum (Anonymous,t)) naming gl in - let t = EConstr.of_constr t in + let id = find_name b (local_assum (Anonymous,t)) naming gl in Tacticals.New.tclTHENLAST (Proofview.V82.tactic (fun gl -> @@ -476,8 +500,7 @@ let assert_before_replacing id = assert_before_gen true (NamingMustBe (dloc,id)) let assert_after_then_gen b naming t tac = let open Context.Rel.Declaration in Proofview.Goal.enter { enter = begin fun gl -> - let id = find_name b (LocalAssum (Anonymous,t)) naming gl in - let t = EConstr.of_constr t in + let id = find_name b (local_assum (Anonymous,t)) naming gl in Tacticals.New.tclTHENFIRST (Proofview.V82.tactic (fun gl -> @@ -501,20 +524,20 @@ let rec mk_holes : type r s. _ -> r Sigma.t -> (s, r) Sigma.le -> _ -> (_, s) Si fun env sigma p -> function | [] -> Sigma ([], sigma, p) | arg :: rem -> - let Sigma (arg, sigma, q) = Evarutil.new_evar env sigma (EConstr.of_constr arg) in + let Sigma (arg, sigma, q) = Evarutil.new_evar env sigma arg in let Sigma (rem, sigma, r) = mk_holes env sigma (p +> q) rem in Sigma (arg :: rem, sigma, r) -let rec check_mutind env sigma k cl = match kind_of_term (strip_outer_cast sigma (EConstr.of_constr cl)) with +let rec check_mutind env sigma k cl = match EConstr.kind sigma (EConstr.of_constr (strip_outer_cast sigma cl)) with | Prod (na, c1, b) -> if Int.equal k 1 then try - let ((sp, _), u), _ = find_inductive env sigma (EConstr.of_constr c1) in + let ((sp, _), u), _ = find_inductive env sigma c1 in (sp, u) with Not_found -> error "Cannot do a fixpoint on a non inductive type." else let open Context.Rel.Declaration in - check_mutind (push_rel (LocalAssum (na, c1)) env) sigma (pred k) b + check_mutind (push_rel (local_assum (na, c1)) env) sigma (pred k) b | _ -> error "Not enough products." (* Refine as a fixpoint *) @@ -522,20 +545,20 @@ let mutual_fix f n rest j = Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl gl in + let concl = EConstr.of_constr concl in let (sp, u) = check_mutind env sigma n concl in let firsts, lasts = List.chop j rest in let all = firsts @ (f, n, concl) :: lasts in let rec mk_sign sign = function | [] -> sign | (f, n, ar) :: oth -> - let open Context.Named.Declaration in let (sp', u') = check_mutind env sigma n ar in if not (eq_mind sp sp') then error "Fixpoints should be on the same mutual inductive declaration."; if mem_named_context_val f sign then user_err ~hdr:"Logic.prim_refiner" (str "Name " ++ pr_id f ++ str " already used in the environment"); - mk_sign (push_named_context_val (LocalAssum (f, ar)) sign) oth + mk_sign (push_named_context_val (nlocal_assum (f, ar)) sign) oth in let nenv = reset_with_named_context (mk_sign (named_context_val env) all) env in Refine.refine { run = begin fun sigma -> @@ -546,8 +569,7 @@ let mutual_fix f n rest j = Proofview.Goal.nf_enter { enter = begin fun gl -> let funnames = Array.of_list (List.map (fun i -> Name i) ids) in let typarray = Array.of_list (List.map pi3 all) in let bodies = Array.of_list evs in - let oterm = Term.mkFix ((indxs,0),(funnames,typarray,bodies)) in - let oterm = EConstr.of_constr oterm in + let oterm = mkFix ((indxs,0),(funnames,typarray,bodies)) in Sigma (oterm, sigma, p) end } end } @@ -563,14 +585,14 @@ let fix ido n = match ido with mutual_fix id n [] 0 let rec check_is_mutcoind env sigma cl = - let b = whd_all env sigma (EConstr.of_constr cl) in - match kind_of_term b with + let b = whd_all env sigma cl in + let b = EConstr.of_constr b in + match EConstr.kind sigma b with | Prod (na, c1, b) -> - let open Context.Rel.Declaration in - check_is_mutcoind (push_rel (LocalAssum (na,c1)) env) sigma b + check_is_mutcoind (push_rel (local_assum (na,c1)) env) sigma b | _ -> try - let _ = find_coinductive env sigma (EConstr.of_constr b) in () + let _ = find_coinductive env sigma b in () with Not_found -> error "All methods must construct elements in coinductive types." @@ -579,16 +601,16 @@ let mutual_cofix f others j = Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl gl in + let concl = EConstr.of_constr concl in let firsts,lasts = List.chop j others in let all = firsts @ (f, concl) :: lasts in List.iter (fun (_, c) -> check_is_mutcoind env sigma c) all; let rec mk_sign sign = function | [] -> sign | (f, ar) :: oth -> - let open Context.Named.Declaration in if mem_named_context_val f sign then error "Name already used in the environment."; - mk_sign (push_named_context_val (LocalAssum (f, ar)) sign) oth + mk_sign (push_named_context_val (nlocal_assum (f, ar)) sign) oth in let nenv = reset_with_named_context (mk_sign (named_context_val env) all) env in Refine.refine { run = begin fun sigma -> @@ -598,8 +620,7 @@ let mutual_cofix f others j = Proofview.Goal.nf_enter { enter = begin fun gl -> let funnames = Array.of_list (List.map (fun i -> Name i) ids) in let typarray = Array.of_list types in let bodies = Array.of_list evs in - let oterm = Term.mkCoFix (0, (funnames, typarray, bodies)) in - let oterm = EConstr.of_constr oterm in + let oterm = mkCoFix (0, (funnames, typarray, bodies)) in Sigma (oterm, sigma, p) end } end } @@ -618,20 +639,23 @@ let cofix ido = match ido with (* Reduction and conversion tactics *) (**************************************************************) -type tactic_reduction = env -> evar_map -> EConstr.t -> constr +type tactic_reduction = env -> evar_map -> constr -> Constr.constr let pf_reduce_decl redfun where decl gl = let open Context.Named.Declaration in - let redfun' c = Tacmach.New.pf_apply redfun gl (EConstr.of_constr c) in + let redfun' c = EConstr.of_constr (Tacmach.New.pf_apply redfun gl c) in match decl with | LocalAssum (id,ty) -> + let ty = EConstr.of_constr ty in if where == InHypValueOnly then user_err (pr_id id ++ str " has no value."); - LocalAssum (id,redfun' ty) + nlocal_assum (id,redfun' ty) | LocalDef (id,b,ty) -> + let b = EConstr.of_constr b in + let ty = EConstr.of_constr ty in let b' = if where != InHypTypeOnly then redfun' b else b in let ty' = if where != InHypValueOnly then redfun' ty else ty in - LocalDef (id,b',ty') + nlocal_def (id,b',ty') (* Possibly equip a reduction with the occurrences mentioned in an occurrence clause *) @@ -703,7 +727,7 @@ let bind_red_expr_occurrences occs nbcl redexp = let reduct_in_concl (redfun,sty) = Proofview.Goal.nf_enter { enter = begin fun gl -> - convert_concl_no_check (Tacmach.New.pf_apply redfun gl (EConstr.of_constr (Tacmach.New.pf_concl gl))) sty + convert_concl_no_check (EConstr.of_constr (Tacmach.New.pf_apply redfun gl (EConstr.of_constr (Tacmach.New.pf_concl gl)))) sty end } let reduct_in_hyp ?(check=false) redfun (id,where) = @@ -739,6 +763,7 @@ let e_reduct_in_concl ~check (redfun, sty) = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let Sigma (c', sigma, p) = redfun.e_redfun (Tacmach.New.pf_env gl) sigma (EConstr.of_constr (Tacmach.New.pf_concl gl)) in + let c' = EConstr.of_constr c' in Sigma (convert_concl ~check c' sty, sigma, p) end } @@ -759,6 +784,7 @@ let e_change_in_concl (redfun,sty) = Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let Sigma (c, sigma, p) = redfun.e_redfun (Proofview.Goal.env gl) sigma (EConstr.of_constr (Proofview.Goal.raw_concl gl)) in + let c = EConstr.of_constr c in Sigma (convert_concl_no_check c sty, sigma, p) end } @@ -787,9 +813,10 @@ let e_change_in_hyp redfun (id,where) = Sigma (convert_hyp c, sigma, p) end } -type change_arg = Pattern.patvar_map -> constr Sigma.run +type change_arg = Pattern.patvar_map -> EConstr.constr Sigma.run let make_change_arg c pats = + let pats = Id.Map.map EConstr.of_constr pats in { run = fun sigma -> Sigma.here (replace_vars (Id.Map.bindings pats) c) sigma } let check_types env sigma mayneedglobalcheck deep newc origc = @@ -803,15 +830,15 @@ let check_types env sigma mayneedglobalcheck deep newc origc = let sigma, b = infer_conv ~pb:Reduction.CUMUL env sigma t1 t2 in if not b then if - isSort (whd_all env sigma t1) && - isSort (whd_all env sigma t2) + isSort sigma (EConstr.of_constr (whd_all env sigma t1)) && + isSort sigma (EConstr.of_constr (whd_all env sigma t2)) then (mayneedglobalcheck := true; sigma) else user_err ~hdr:"convert-check-hyp" (str "Types are incompatible.") else sigma end else - if not (isSort (whd_all env sigma t1)) then + if not (isSort sigma (EConstr.of_constr (whd_all env sigma t1))) then user_err ~hdr:"convert-check-hyp" (str "Not a type.") else sigma @@ -819,7 +846,6 @@ let check_types env sigma mayneedglobalcheck deep newc origc = let change_and_check cv_pb mayneedglobalcheck deep t = { e_redfun = begin fun env sigma c -> let Sigma (t', sigma, p) = t.run sigma in let sigma = Sigma.to_evar_map sigma in - let t' = EConstr.of_constr t' 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."); @@ -886,7 +912,7 @@ let normalise_vm_in_concl = reduct_in_concl (Redexpr.cbv_vm,VMcast) let unfold_in_concl loccname = reduct_in_concl (unfoldn loccname,REVERTcast) let unfold_in_hyp loccname = reduct_in_hyp (unfoldn loccname) let unfold_option loccname = reduct_option (unfoldn loccname,DEFAULTcast) -let pattern_option l = e_reduct_option (pattern_occs (List.map (on_snd EConstr.of_constr) l),DEFAULTcast) +let pattern_option l = e_reduct_option (pattern_occs l,DEFAULTcast) (* The main reduction function *) @@ -951,13 +977,13 @@ let rec intro_then_gen name_flag move_flag force_flag dep_flag tac = Proofview.Goal.enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in - let concl = nf_evar (Tacmach.New.project gl) concl in - match kind_of_term concl with - | Prod (name,t,u) when not dep_flag || not (EConstr.Vars.noccurn sigma 1 (EConstr.of_constr u)) -> - let name = find_name false (LocalAssum (name,t)) name_flag gl in + let concl = EConstr.of_constr concl in + match EConstr.kind sigma concl with + | Prod (name,t,u) when not dep_flag || not (noccurn sigma 1 u) -> + let name = find_name false (local_assum (name,t)) name_flag gl in build_intro_tac name move_flag tac - | LetIn (name,b,t,u) when not dep_flag || not (EConstr.Vars.noccurn sigma 1 (EConstr.of_constr u)) -> - let name = find_name false (LocalDef (name,b,t)) name_flag gl in + | LetIn (name,b,t,u) when not dep_flag || not (noccurn sigma 1 u) -> + let name = find_name false (local_def (name,b,t)) name_flag gl in build_intro_tac name move_flag tac | _ -> begin if not force_flag then Proofview.tclZERO (RefinerError IntroNeedsProduct) @@ -1212,12 +1238,10 @@ let map_destruction_arg f sigma = function let finish_delayed_evar_resolution with_evars env sigma f = let ((c, lbind), sigma') = run_delayed env sigma f in - let c = EConstr.of_constr c in let pending = (sigma,sigma') in let sigma' = Sigma.Unsafe.of_evar_map sigma' in let flags = tactic_infer_flags with_evars in let Sigma (c, sigma', _) = finish_evar_resolution ~flags env sigma' (pending,c) in - let c = EConstr.Unsafe.to_constr c in (Sigma.to_evar_map sigma', (c, lbind)) let with_no_bindings (c, lbind) = @@ -1238,12 +1262,15 @@ let cut c = let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let concl = Tacmach.New.pf_nf_concl gl in + let concl = EConstr.of_constr concl in let is_sort = try (** Backward compat: ensure that [c] is well-typed. *) - let typ = Typing.unsafe_type_of env sigma (EConstr.of_constr c) in - let typ = whd_all env sigma (EConstr.of_constr typ) in - match kind_of_term typ with + let typ = Typing.unsafe_type_of env sigma c in + let typ = EConstr.of_constr typ in + let typ = whd_all env sigma typ in + let typ = EConstr.of_constr typ in + match EConstr.kind sigma typ with | Sort _ -> true | _ -> false with e when Pretype_errors.precatchable_exception e -> false @@ -1251,12 +1278,11 @@ let cut c = if is_sort then let id = next_name_away_with_default "H" Anonymous (Tacmach.New.pf_ids_of_hyps gl) in (** Backward compat: normalize [c]. *) - let c = if normalize_cut then local_strong whd_betaiota sigma (EConstr.of_constr c) else c in + let c = if normalize_cut then EConstr.of_constr (local_strong whd_betaiota sigma c) else c in Refine.refine ~unsafe:true { run = begin fun h -> - let Sigma (f, h, p) = Evarutil.new_evar ~principal:true env h (EConstr.of_constr (mkArrow c (Vars.lift 1 concl))) in - let Sigma (x, h, q) = Evarutil.new_evar env h (EConstr.of_constr c) in + let Sigma (f, h, p) = Evarutil.new_evar ~principal:true env h (mkArrow c (Vars.lift 1 concl)) in + let Sigma (x, h, q) = Evarutil.new_evar env h c in let f = mkLetIn (Name id, x, c, mkApp (Vars.lift 1 f, [|mkRel 1|])) in - let f = EConstr.of_constr f in Sigma (f, h, p +> q) end } else @@ -1264,6 +1290,7 @@ let cut c = end } 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") in user_err (str "Cannot find an instance for " ++ pr_id id ++ str".") @@ -1276,7 +1303,7 @@ let check_unresolved_evars_of_metas sigma clenv = (match kind_of_term c.rebus with | Evar (evk,_) when Evd.is_undefined clenv.evd evk && not (Evd.mem sigma evk) -> - error_uninstantiated_metas (mkMeta mv) clenv + error_uninstantiated_metas (EConstr.mkMeta mv) clenv | _ -> ()) | _ -> ()) (meta_list clenv.evd) @@ -1301,9 +1328,8 @@ let clenv_refine_in ?(sidecond_first=false) with_evars ?(with_classes=true) else clenv in let new_hyp_typ = clenv_type clenv in - let new_hyp_typ = EConstr.Unsafe.to_constr new_hyp_typ in if not with_evars then check_unresolved_evars_of_metas sigma0 clenv; - if not with_evars && occur_meta clenv.evd (EConstr.of_constr new_hyp_typ) then + if not with_evars && occur_meta clenv.evd new_hyp_typ then error_uninstantiated_metas new_hyp_typ clenv; let new_hyp_prf = clenv_value clenv in let exact_tac = Proofview.V82.tactic (Tacmach.refine_no_check new_hyp_prf) in @@ -1322,22 +1348,22 @@ let clenv_refine_in ?(sidecond_first=false) with_evars ?(with_classes=true) (* Elimination tactics *) (********************************************) -let last_arg c = match kind_of_term c with +let last_arg sigma c = match EConstr.kind sigma c with | App (f,cl) -> Array.last cl | _ -> anomaly (Pp.str "last_arg") -let nth_arg i c = - if Int.equal i (-1) then last_arg c else - match kind_of_term c with +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") -let index_of_ind_arg t = - let rec aux i j t = match kind_of_term t with +let index_of_ind_arg sigma t = + let rec aux i j t = match EConstr.kind sigma t with | Prod (_,t,u) -> (* heuristic *) - if isInd (fst (decompose_app t)) then aux (Some j) (j+1) u + if isInd sigma (fst (decompose_app sigma t)) then aux (Some j) (j+1) u else aux i (j+1) u | _ -> match i with | Some i -> i @@ -1352,30 +1378,31 @@ let enforce_prop_bound_names rename tac = (* so as to avoid having hypothesis such as "t:True", "n:~A" when calling *) (* elim or induction with schemes built by Indrec.build_induction_scheme *) let rec aux env sigma i t = - if i = 0 then t else match kind_of_term t with + if i = 0 then t else match EConstr.kind sigma t with | Prod (Name _ as na,t,t') -> let very_standard = true in let na = - if Retyping.get_sort_family_of env sigma (EConstr.of_constr t) = InProp then + if Retyping.get_sort_family_of env sigma t = InProp then (* "very_standard" says that we should have "H" names only, but this would break compatibility even more... *) - let s = match Namegen.head_name t with + let s = match Namegen.head_name (EConstr.Unsafe.to_constr t) with | Some id when not very_standard -> string_of_id id | _ -> "" in Name (add_suffix Namegen.default_prop_ident s) else na in - mkProd (na,t,aux (push_rel (LocalAssum (na,t)) env) sigma (i-1) t') + mkProd (na,t,aux (push_rel (local_assum (na,t)) env) sigma (i-1) t') | Prod (Anonymous,t,t') -> - mkProd (Anonymous,t,aux (push_rel (LocalAssum (Anonymous,t)) env) sigma (i-1) t') + mkProd (Anonymous,t,aux (push_rel (local_assum (Anonymous,t)) env) sigma (i-1) t') | LetIn (na,c,t,t') -> - mkLetIn (na,c,t,aux (push_rel (LocalDef (na,c,t)) env) sigma (i-1) t') - | _ -> print_int i; Feedback.msg_notice (print_constr t); assert false in + mkLetIn (na,c,t,aux (push_rel (local_def (na,c,t)) env) sigma (i-1) t') + | _ -> assert false in let rename_branch i = Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let t = Proofview.Goal.concl gl in + let t = EConstr.of_constr t in change_concl (aux env sigma i t) end } in (if isrec then Tacticals.New.tclTHENFIRSTn else Tacticals.New.tclTHENLASTn) @@ -1384,10 +1411,10 @@ let enforce_prop_bound_names rename tac = | _ -> tac -let rec contract_letin_in_lam_header c = - match kind_of_term c with - | Lambda (x,t,c) -> mkLambda (x,t,contract_letin_in_lam_header c) - | LetIn (x,b,t,c) -> contract_letin_in_lam_header (subst1 b c) +let rec contract_letin_in_lam_header sigma c = + match EConstr.kind sigma c with + | Lambda (x,t,c) -> mkLambda (x,t,contract_letin_in_lam_header sigma c) + | LetIn (x,b,t,c) -> contract_letin_in_lam_header sigma (subst1 b c) | _ -> c let elimination_clause_scheme with_evars ?(with_classes=true) ?(flags=elim_flags ()) @@ -1395,13 +1422,10 @@ let elimination_clause_scheme with_evars ?(with_classes=true) ?(flags=elim_flags Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in - let elim = contract_letin_in_lam_header elim in - let bindings = Miscops.map_bindings EConstr.of_constr bindings in - let elim = EConstr.of_constr elim in - let elimty = EConstr.of_constr elimty in + let elim = contract_letin_in_lam_header sigma elim in let elimclause = make_clenv_binding env sigma (elim, elimty) bindings in let indmv = - (match kind_of_term (nth_arg i (EConstr.Unsafe.to_constr elimclause.templval.rebus)) with + (match EConstr.kind sigma (nth_arg sigma i elimclause.templval.rebus) with | Meta mv -> mv | _ -> user_err ~hdr:"elimination_clause" (str "The type of elimination clause is not well-formed.")) @@ -1421,7 +1445,7 @@ let elimination_clause_scheme with_evars ?(with_classes=true) ?(flags=elim_flags type eliminator = { elimindex : int option; (* None = find it automatically *) elimrename : (bool * int array) option; (** None = don't rename Prop hyps with H-names *) - elimbody : constr with_bindings + elimbody : EConstr.constr with_bindings } let general_elim_clause_gen elimtac indclause elim = @@ -1429,9 +1453,10 @@ let general_elim_clause_gen elimtac indclause elim = let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let (elimc,lbindelimc) = elim.elimbody in - let elimt = Retyping.get_type_of env sigma (EConstr.of_constr elimc) in + let elimt = Retyping.get_type_of env sigma elimc in + let elimt = EConstr.of_constr elimt in let i = - match elim.elimindex with None -> index_of_ind_arg elimt | Some i -> i in + match elim.elimindex with None -> index_of_ind_arg sigma elimt | Some i -> i in elimtac elim.elimrename i (elimc, elimt, lbindelimc) indclause end } @@ -1439,12 +1464,11 @@ let general_elim with_evars clear_flag (c, lbindc) elim = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in - let ct = Retyping.get_type_of env sigma (EConstr.of_constr c) in - let t = try snd (reduce_to_quantified_ind env sigma (EConstr.of_constr ct)) with UserError _ -> ct in - let t = EConstr.of_constr t in + let ct = Retyping.get_type_of env sigma c in + let ct = EConstr.of_constr ct in + let t = try snd (reduce_to_quantified_ind env sigma ct) with UserError _ -> ct in let elimtac = elimination_clause_scheme with_evars in - let lbindc = Miscops.map_bindings EConstr.of_constr lbindc in - let indclause = make_clenv_binding env sigma (EConstr.of_constr c, t) lbindc in + let indclause = make_clenv_binding env sigma (c, t) lbindc in let sigma = meta_merge sigma (clear_metas indclause.evd) in Proofview.Unsafe.tclEVARS sigma <*> Tacticals.New.tclTHEN @@ -1459,15 +1483,16 @@ let general_case_analysis_in_context with_evars clear_flag (c,lbindc) = let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl gl in - let t = Retyping.get_type_of env (Sigma.to_evar_map sigma) (EConstr.of_constr c) in + let t = Retyping.get_type_of env (Sigma.to_evar_map sigma) c in let t = EConstr.of_constr t in let (mind,_) = reduce_to_quantified_ind env (Sigma.to_evar_map sigma) t in let sort = Tacticals.New.elimination_sort_of_goal gl in let Sigma (elim, sigma, p) = - if occur_term (Sigma.to_evar_map sigma) (EConstr.of_constr c) (EConstr.of_constr concl) then + if occur_term (Sigma.to_evar_map sigma) c (EConstr.of_constr concl) then build_case_analysis_scheme env sigma mind true sort else build_case_analysis_scheme_default env sigma mind sort in + let elim = EConstr.of_constr elim in let tac = (general_elim with_evars clear_flag (c,lbindc) {elimindex = None; elimbody = (elim,NoBindings); @@ -1477,7 +1502,8 @@ let general_case_analysis_in_context with_evars clear_flag (c,lbindc) = end } let general_case_analysis with_evars clear_flag (c,lbindc as cx) = - match kind_of_term c with + Proofview.tclEVARMAP >>= fun sigma -> + match EConstr.kind sigma c with | Var id when lbindc == NoBindings -> Tacticals.New.tclTHEN (try_intros_until_id_check id) (general_case_analysis_in_context with_evars clear_flag cx) @@ -1497,10 +1523,10 @@ let is_nonrec mind = (Global.lookup_mind (fst mind)).mind_finite == Decl_kinds.B let find_ind_eliminator ind s gl = let gr = lookup_eliminator ind s in let evd, c = Tacmach.New.pf_apply Evd.fresh_global gl gr in + let c = EConstr.of_constr c in evd, c let find_eliminator c gl = - let c = EConstr.of_constr c in let ((ind,u),t) = Tacmach.New.pf_reduce_to_quantified_ind gl (EConstr.of_constr (Tacmach.New.pf_unsafe_type_of gl c)) in if is_nonrec ind then raise IsNonrec; let evd, c = find_ind_eliminator ind (Tacticals.New.elimination_sort_of_goal gl) gl in @@ -1531,7 +1557,8 @@ let elim_in_context with_evars clear_flag c = function | None -> default_elim with_evars clear_flag c let elim with_evars clear_flag (c,lbindc as cx) elim = - match kind_of_term c with + Proofview.tclEVARMAP >>= fun sigma -> + match EConstr.kind sigma c with | Var id when lbindc == NoBindings -> Tacticals.New.tclTHEN (try_intros_until_id_check id) (elim_in_context with_evars clear_flag cx elim) @@ -1565,12 +1592,9 @@ let elimination_in_clause_scheme with_evars ?(flags=elim_flags ()) Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in - let elim = contract_letin_in_lam_header elim in - let elim = EConstr.of_constr elim in - let elimty = EConstr.of_constr elimty in - let bindings = Miscops.map_bindings EConstr.of_constr bindings in + let elim = contract_letin_in_lam_header sigma elim in let elimclause = make_clenv_binding env sigma (elim, elimty) bindings in - let indmv = destMeta (nth_arg i (EConstr.Unsafe.to_constr elimclause.templval.rebus)) in + let indmv = destMeta sigma (nth_arg sigma i elimclause.templval.rebus) in let hypmv = try match List.remove Int.equal indmv (clenv_independent elimclause) with | [a] -> a @@ -1578,7 +1602,7 @@ let elimination_in_clause_scheme with_evars ?(flags=elim_flags ()) with Failure _ -> user_err ~hdr:"elimination_clause" (str "The type of elimination clause is not well-formed.") in let elimclause' = clenv_fchain ~flags indmv elimclause indclause in - let hyp = EConstr.mkVar id in + let hyp = mkVar id in let hyp_typ = Retyping.get_type_of env sigma hyp in let hyp_typ = EConstr.of_constr hyp_typ in let hypclause = mk_clenv_from_env env sigma (Some 0) (hyp, hyp_typ) in @@ -1611,19 +1635,23 @@ let make_projection env sigma params cstr sign elim i n c u = (* bugs: goes from right to left when i increases! *) let decl = List.nth cstr.cs_args i in let t = RelDecl.get_type decl in - let b = match decl with LocalAssum _ -> mkRel (i+1) | LocalDef (_,b,_) -> b in + let t = EConstr.of_constr t in + let b = match decl with LocalAssum _ -> mkRel (i+1) | LocalDef (_,b,_) -> EConstr.of_constr b in let branch = it_mkLambda_or_LetIn b cstr.cs_args in if (* excludes dependent projection types *) - noccur_between 1 (n-i-1) t + noccur_between sigma 1 (n-i-1) t (* to avoid surprising unifications, excludes flexible projection types or lambda which will be instantiated by Meta/Evar *) - && not (EConstr.isEvar sigma (fst (whd_betaiota_stack sigma (EConstr.of_constr t)))) - && (accept_universal_lemma_under_conjunctions () || not (isRel t)) + && not (isEvar sigma (fst (whd_betaiota_stack sigma t))) + && (accept_universal_lemma_under_conjunctions () || not (isRel sigma t)) then let t = lift (i+1-n) t in - let abselim = beta_applist sigma (EConstr.of_constr elim, List.map EConstr.of_constr (params@[t;branch])) in - let c = beta_applist sigma (EConstr.of_constr abselim, [EConstr.of_constr (mkApp (c, Context.Rel.to_extended_vect 0 sign))]) in + let abselim = beta_applist sigma (elim, params@[t;branch]) in + let abselim = EConstr.of_constr abselim in + let args = Array.map EConstr.of_constr (Context.Rel.to_extended_vect 0 sign) in + let c = beta_applist sigma (abselim, [mkApp (c, args)]) in + let c = EConstr.of_constr c in Some (it_mkLambda_or_LetIn c sign, it_mkProd_or_LetIn t sign) else None @@ -1632,6 +1660,7 @@ let make_projection env sigma params cstr sign elim i n c u = match List.nth l i with | Some proj -> let args = Context.Rel.to_extended_vect 0 sign in + let args = Array.map EConstr.of_constr args in let proj = if Environ.is_projection proj env then mkProj (Projection.make proj false, mkApp (c, args)) @@ -1640,7 +1669,8 @@ let make_projection env sigma params cstr sign elim i n c u = [|mkApp (c, args)|]) in let app = it_mkLambda_or_LetIn proj sign in - let t = Retyping.get_type_of env sigma (EConstr.of_constr app) in + let t = Retyping.get_type_of env sigma app in + let t = EConstr.of_constr t in Some (app, t) | None -> None in elim @@ -1650,23 +1680,24 @@ let descend_in_conjunctions avoid tac (err, info) c = let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in try - let t = Retyping.get_type_of env sigma (EConstr.of_constr c) in + let t = Retyping.get_type_of env sigma c in let t = EConstr.of_constr t in let ((ind,u),t) = reduce_to_quantified_ind env sigma t in - let sign,ccl = decompose_prod_assum t in - let ccl = EConstr.of_constr ccl in + let sign,ccl = EConstr.decompose_prod_assum sigma t in match match_with_tuple sigma ccl with | Some (_,_,isrec) -> let n = (constructors_nrealargs ind).(0) in let sort = Tacticals.New.elimination_sort_of_goal gl in let IndType (indf,_) = find_rectype env sigma ccl in let (_,inst), params = dest_ind_family indf in + let params = List.map EConstr.of_constr params in let cstr = (get_constructors env indf).(0) in let elim = try DefinedRecord (Recordops.lookup_projections ind) with Not_found -> let sigma = Sigma.Unsafe.of_evar_map sigma in let Sigma (elim, _, _) = build_case_analysis_scheme env sigma (ind,u) false sort in + let elim = EConstr.of_constr elim in NotADefinedRecordUseScheme elim in Tacticals.New.tclORELSE0 (Tacticals.New.tclFIRST @@ -1677,7 +1708,6 @@ let descend_in_conjunctions avoid tac (err, info) c = match make_projection env sigma params cstr sign elim i n c u with | None -> Tacticals.New.tclFAIL 0 (mt()) | Some (p,pt) -> - let p = EConstr.of_constr p in Tacticals.New.tclTHENS (assert_before_gen false (NamingAvoid avoid) pt) [Proofview.V82.tactic (refine p); @@ -1720,7 +1750,7 @@ let tclORELSEOPT t k = Proofview.tclZERO ~info e | Some tac -> tac) -let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind)) = +let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind : EConstr.constr with_bindings)) = Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in let sigma = Tacmach.New.project gl in @@ -1735,14 +1765,13 @@ let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind)) let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in - let thm_ty0 = nf_betaiota sigma (EConstr.of_constr (Retyping.get_type_of env sigma (EConstr.of_constr c))) in + let thm_ty0 = nf_betaiota sigma (EConstr.of_constr (Retyping.get_type_of env sigma c)) in let try_apply thm_ty nprod = try let thm_ty = EConstr.of_constr thm_ty in let n = nb_prod_modulo_zeta sigma thm_ty - nprod in if n<0 then error "Applied theorem has not enough premisses."; - let lbind = Miscops.map_bindings EConstr.of_constr lbind in - let clause = make_clenv_binding_apply env sigma (Some n) (EConstr.of_constr c,thm_ty) lbind in + let clause = make_clenv_binding_apply env sigma (Some n) (c,thm_ty) lbind in Clenvtac.res_pf clause ~with_evars ~flags with exn when catchable_exception exn -> Proofview.tclZERO exn @@ -1863,7 +1892,6 @@ let progress_with_clause flags innerclause clause = with Not_found -> error "Unable to unify." let apply_in_once_main flags innerclause env sigma (d,lbind) = - let d = EConstr.of_constr d in let thm = nf_betaiota sigma (EConstr.of_constr (Retyping.get_type_of env sigma d)) in let thm = EConstr.of_constr thm in let rec aux clause = @@ -1873,7 +1901,6 @@ let apply_in_once_main flags innerclause env sigma (d,lbind) = try aux (clenv_push_prod clause) with NotExtensibleClause -> iraise e in - let lbind = Miscops.map_bindings EConstr.of_constr lbind in aux (make_clenv_binding env sigma (d,thm) lbind) let apply_in_once sidecond_first with_delta with_destruct with_evars naming @@ -1885,8 +1912,9 @@ let apply_in_once sidecond_first with_delta with_destruct with_evars naming 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) (EConstr.mkVar id,EConstr.of_constr t') in - let targetid = find_name true (LocalAssum (Anonymous,t')) naming gl in + let t' = EConstr.of_constr t' in + let innerclause = mk_clenv_from_env env sigma (Some 0) (mkVar id,t') in + let targetid = find_name true (local_assum (Anonymous,t')) naming gl in let rec aux idstoclear with_destruct c = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in @@ -1942,16 +1970,16 @@ let apply_in_delayed_once sidecond_first with_delta with_destruct with_evars nam let cut_and_apply c = Proofview.Goal.nf_enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in - match kind_of_term (Tacmach.New.pf_hnf_constr gl (EConstr.of_constr (Tacmach.New.pf_unsafe_type_of gl (EConstr.of_constr c)))) with - | Prod (_,c1,c2) when EConstr.Vars.noccurn sigma 1 (EConstr.of_constr c2) -> + match EConstr.kind sigma (EConstr.of_constr (Tacmach.New.pf_hnf_constr gl (EConstr.of_constr (Tacmach.New.pf_unsafe_type_of gl c)))) with + | Prod (_,c1,c2) when Vars.noccurn sigma 1 c2 -> let concl = Proofview.Goal.concl gl in + let concl = EConstr.of_constr concl in let env = Tacmach.New.pf_env gl in Refine.refine { run = begin fun sigma -> let typ = mkProd (Anonymous, c2, concl) in - let Sigma (f, sigma, p) = Evarutil.new_evar env sigma (EConstr.of_constr typ) in - let Sigma (x, sigma, q) = Evarutil.new_evar env sigma (EConstr.of_constr c1) in + let Sigma (f, sigma, p) = Evarutil.new_evar env sigma typ in + let Sigma (x, sigma, q) = Evarutil.new_evar env sigma c1 in let ans = mkApp (f, [|mkApp (c, [|x|])|]) in - let ans = EConstr.of_constr ans in Sigma (ans, sigma, p +> q) end } | _ -> error "lapply needs a non-dependent product." @@ -1968,7 +1996,6 @@ let cut_and_apply c = (* let refine_no_check = Profile.profile2 refine_no_checkkey refine_no_check *) let exact_no_check c = - let c = EConstr.of_constr c in Refine.refine ~unsafe:true { run = fun h -> Sigma.here c h } let exact_check c = @@ -1976,9 +2003,11 @@ let exact_check c = let sigma = Proofview.Goal.sigma gl in (** We do not need to normalize the goal because we just check convertibility *) let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in + let concl = EConstr.of_constr concl in let env = Proofview.Goal.env gl in let sigma = Sigma.to_evar_map sigma in - let sigma, ct = Typing.type_of env sigma (EConstr.of_constr c) in + let sigma, ct = Typing.type_of env sigma c in + let ct = EConstr.of_constr ct in let tac = Tacticals.New.tclTHEN (convert_leq ct concl) (exact_no_check c) in @@ -1988,7 +2017,8 @@ let exact_check c = let cast_no_check cast c = Proofview.Goal.enter { enter = begin fun gl -> let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in - exact_no_check (Term.mkCast (c, cast, concl)) + let concl = EConstr.of_constr concl in + exact_no_check (EConstr.mkCast (c, cast, concl)) end } let vm_cast_no_check c = cast_no_check Term.VMcast c @@ -2048,7 +2078,7 @@ exception DependsOnBody of Id.t option let check_is_type env sigma ty = let evdref = ref sigma in try - let _ = Typing.e_sort_of env evdref (EConstr.of_constr ty) in + let _ = Typing.e_sort_of env evdref ty in !evdref with e when CErrors.noncritical e -> raise (DependsOnBody None) @@ -2073,6 +2103,7 @@ let clear_body ids = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in + let concl = EConstr.of_constr concl in let sigma = Tacmach.New.project gl in let ctx = named_context env in let map = function @@ -2102,7 +2133,7 @@ let clear_body ids = in let (env, sigma, _) = List.fold_left check (base_env, sigma, false) (List.rev ctx) in let sigma = - if List.exists (fun id -> occur_var env sigma id (EConstr.of_constr concl)) ids then + if List.exists (fun id -> occur_var env sigma id concl) ids then check_is_type env sigma concl else sigma in @@ -2116,8 +2147,7 @@ let clear_body ids = in check <*> Refine.refine ~unsafe:true { run = begin fun sigma -> - let Sigma (c, sigma, p) = Evarutil.new_evar env sigma ~principal:true (EConstr.of_constr concl) in - Sigma (EConstr.of_constr c, sigma, p) + Evarutil.new_evar env sigma ~principal:true concl end } end } @@ -2168,10 +2198,11 @@ let apply_type newcl args = let env = Proofview.Goal.env gl in let store = Proofview.Goal.extra gl in Refine.refine { run = begin fun sigma -> - let newcl = nf_betaiota (Sigma.to_evar_map sigma) (EConstr.of_constr newcl) (* As in former Logic.refine *) in + let newcl = nf_betaiota (Sigma.to_evar_map sigma) newcl (* As in former Logic.refine *) in + let newcl = EConstr.of_constr newcl in let Sigma (ev, sigma, p) = - Evarutil.new_evar env sigma ~principal:true ~store (EConstr.of_constr newcl) in - Sigma (EConstr.of_constr (applist (ev, args)), sigma, p) + Evarutil.new_evar env sigma ~principal:true ~store newcl in + Sigma (applist (ev, args), sigma, p) end } end } @@ -2186,12 +2217,13 @@ let bring_hyps hyps = let env = Proofview.Goal.env gl in let store = Proofview.Goal.extra gl in let concl = Tacmach.New.pf_nf_concl gl in + let concl = EConstr.of_constr concl in let newcl = List.fold_right mkNamedProd_or_LetIn hyps concl in - let args = Array.of_list (Context.Named.to_instance hyps) in + let args = Array.map_of_list EConstr.of_constr (Context.Named.to_instance hyps) in Refine.refine { run = begin fun sigma -> let Sigma (ev, sigma, p) = - Evarutil.new_evar env sigma ~principal:true ~store (EConstr.of_constr newcl) in - Sigma (EConstr.of_constr (mkApp (ev, args)), sigma, p) + Evarutil.new_evar env sigma ~principal:true ~store newcl in + Sigma (mkApp (ev, args), sigma, p) end } end } @@ -2322,10 +2354,10 @@ let my_find_eq_data_decompose gl t = let intro_decomp_eq loc l thin tac id = Proofview.Goal.nf_enter { enter = begin fun gl -> let c = mkVar id in - let t = Tacmach.New.pf_unsafe_type_of gl (EConstr.of_constr c) in + let t = Tacmach.New.pf_unsafe_type_of gl c in let t = EConstr.of_constr t in let _,t = Tacmach.New.pf_reduce_to_quantified_ind gl t in - match my_find_eq_data_decompose gl (EConstr.of_constr t) with + match my_find_eq_data_decompose gl t with | Some (eq,u,eq_args) -> !intro_decomp_eq_function (fun n -> tac ((dloc,id)::thin) (Some (true,n)) l) @@ -2337,7 +2369,7 @@ let intro_decomp_eq loc l thin tac id = let intro_or_and_pattern loc with_evars bracketed ll thin tac id = Proofview.Goal.enter { enter = begin fun gl -> let c = mkVar id in - let t = Tacmach.New.pf_unsafe_type_of gl (EConstr.of_constr c) in + let t = Tacmach.New.pf_unsafe_type_of gl c in let t = EConstr.of_constr t in let (ind,t) = Tacmach.New.pf_reduce_to_quantified_ind gl t in let branchsigns = compute_constructor_signatures false ind in @@ -2363,26 +2395,23 @@ let rewrite_hyp_then assert_style with_evars thin l2r id tac = let sigma = Tacmach.New.project gl in let type_of = Tacmach.New.pf_unsafe_type_of gl in let whd_all = Tacmach.New.pf_apply whd_all gl in - let t = whd_all (EConstr.of_constr (type_of (EConstr.mkVar id))) in + let t = whd_all (EConstr.of_constr (type_of (mkVar id))) in let t = EConstr.of_constr t in let eqtac, thin = match match_with_equality_type sigma t with | Some (hdcncl,[_;lhs;rhs]) -> - let lhs = EConstr.Unsafe.to_constr lhs in - let rhs = EConstr.Unsafe.to_constr rhs in - if l2r && isVar lhs && not (occur_var env sigma (destVar lhs) (EConstr.of_constr rhs)) then - let id' = destVar lhs in + if l2r && isVar sigma lhs && not (occur_var env sigma (destVar sigma lhs) rhs) then + let id' = destVar sigma lhs in subst_on l2r id' rhs, early_clear id' thin - else if not l2r && isVar rhs && not (occur_var env sigma (destVar rhs) (EConstr.of_constr lhs)) then - let id' = destVar rhs in + else if not l2r && isVar sigma rhs && not (occur_var env sigma (destVar sigma rhs) lhs) then + let id' = destVar sigma rhs in subst_on l2r id' lhs, early_clear id' thin else Tacticals.New.tclTHEN (rew_on l2r onConcl) (clear [id]), thin | Some (hdcncl,[c]) -> - let c = EConstr.Unsafe.to_constr c in let l2r = not l2r in (* equality of the form eq_true *) - if isVar c then - let id' = destVar c in + if isVar sigma c then + let id' = destVar sigma c in Tacticals.New.tclTHEN (rew_on l2r allHypsAndConcl) (clear_var_and_eq id'), early_clear id' thin @@ -2581,9 +2610,9 @@ let ipat_of_name = function | Anonymous -> None | Name id -> Some (dloc, IntroNaming (IntroIdentifier id)) -let head_ident c = - let c = fst (decompose_app ((strip_lam_assum c))) in - if isVar c then Some (destVar c) else None +let head_ident sigma c = + let c = fst (decompose_app sigma (snd (decompose_lam_assum sigma c))) in + if isVar sigma c then Some (destVar sigma c) else None let assert_as first hd ipat t = let naming,tac = prepare_intros false IntroAnonymous MoveLast ipat in @@ -2652,8 +2681,10 @@ let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty = let Sigma (t, sigma, p) = match ty with | Some t -> Sigma.here t sigma | None -> - let t = EConstr.of_constr (typ_of env sigma (EConstr.of_constr c)) in + let t = typ_of env sigma c in + let t = EConstr.of_constr t in let sigma, c = Evarsolve.refresh_universes ~onlyalg:true (Some false) env (Sigma.to_evar_map sigma) t in + let c = EConstr.of_constr c in Sigma.Unsafe.of_pair (c, sigma) in let Sigma ((newcl, eq_tac), sigma, q) = match with_eq with @@ -2665,12 +2696,14 @@ let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty = let eqdata = build_coq_eq_data () in let args = if lr then [t;mkVar id;c] else [t;c;mkVar id]in let Sigma (eq, sigma, p) = Sigma.fresh_global env sigma eqdata.eq in + let eq = EConstr.of_constr eq in let Sigma (refl, sigma, q) = Sigma.fresh_global env sigma eqdata.refl in + let refl = EConstr.of_constr refl in let eq = applist (eq,args) in let refl = applist (refl, [t;mkVar id]) in let term = mkNamedLetIn id c t (mkLetIn (Name heq, refl, eq, ccl)) in let sigma = Sigma.to_evar_map sigma in - let sigma, _ = Typing.type_of env sigma (EConstr.of_constr term) in + let sigma, _ = Typing.type_of env sigma term in let ans = term, Tacticals.New.tclTHEN (intro_gen (NamingMustBe (loc,heq)) (decode_hyp lastlhyp) true false) @@ -2704,9 +2737,9 @@ let insert_before decls lasthyp env = let mkletin_goal env sigma store with_eq dep (id,lastlhyp,ccl,c) ty = let open Context.Named.Declaration in - let t = match ty with Some t -> t | _ -> typ_of env sigma (EConstr.of_constr c) in - let decl = if dep then LocalDef (id,c,t) - else LocalAssum (id,t) + let t = match ty with Some t -> t | _ -> EConstr.of_constr (typ_of env sigma c) in + let decl = if dep then nlocal_def (id,c,t) + else nlocal_assum (id,t) in match with_eq with | Some (lr,(loc,ido)) -> @@ -2720,34 +2753,33 @@ let mkletin_goal env sigma store with_eq dep (id,lastlhyp,ccl,c) ty = let eqdata = build_coq_eq_data () in let args = if lr then [t;mkVar id;c] else [t;c;mkVar id]in let Sigma (eq, sigma, p) = Sigma.fresh_global env sigma eqdata.eq in + let eq = EConstr.of_constr eq in let Sigma (refl, sigma, q) = Sigma.fresh_global env sigma eqdata.refl in + let refl = EConstr.of_constr refl in let eq = applist (eq,args) in let refl = applist (refl, [t;mkVar id]) in - let newenv = insert_before [LocalAssum (heq,eq); decl] lastlhyp env in - let Sigma (x, sigma, r) = new_evar newenv sigma ~principal:true ~store (EConstr.of_constr ccl) in - Sigma (EConstr.of_constr (mkNamedLetIn id c t (mkNamedLetIn heq refl eq x)), sigma, p +> q +> r) + let newenv = insert_before [nlocal_assum (heq,eq); decl] lastlhyp env in + let Sigma (x, sigma, r) = new_evar newenv sigma ~principal:true ~store ccl in + Sigma (mkNamedLetIn id c t (mkNamedLetIn heq refl eq x), sigma, p +> q +> r) | None -> let newenv = insert_before [decl] lastlhyp env in - let Sigma (x, sigma, p) = new_evar newenv sigma ~principal:true ~store (EConstr.of_constr ccl) in - Sigma (EConstr.of_constr (mkNamedLetIn id c t x), sigma, p) + let Sigma (x, sigma, p) = new_evar newenv sigma ~principal:true ~store ccl in + Sigma (mkNamedLetIn id c t x, sigma, p) let letin_tac with_eq id c ty occs = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let ccl = Proofview.Goal.concl gl in - let c = EConstr.of_constr c in - let abs = AbstractExact (id,c,Option.map EConstr.of_constr ty,occs,true) in + let abs = AbstractExact (id,c,ty,occs,true) in let ccl = EConstr.of_constr ccl in let (id,_,depdecls,lastlhyp,ccl,res) = make_abstraction env sigma ccl abs in - let ccl = EConstr.Unsafe.to_constr ccl in (* We keep the original term to match but record the potential side-effects of unifying universes. *) let Sigma (c, sigma, p) = match res with | None -> Sigma.here c sigma | Some (Sigma (_, sigma, p)) -> Sigma (c, sigma, p) in - let c = EConstr.Unsafe.to_constr c in let tac = letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty in Sigma (tac, sigma, p) end } @@ -2761,11 +2793,9 @@ let letin_pat_tac with_eq id c occs = let abs = AbstractPattern (false,check,id,c,occs,false) in let ccl = EConstr.of_constr ccl in let (id,_,depdecls,lastlhyp,ccl,res) = make_abstraction env sigma ccl abs in - let ccl = EConstr.Unsafe.to_constr ccl in let Sigma (c, sigma, p) = match res with | None -> finish_evar_resolution ~flags:(tactic_infer_flags false) env sigma c | Some res -> res in - let c = EConstr.Unsafe.to_constr c in let tac = (letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) None) in @@ -2777,8 +2807,10 @@ let forward b usetac ipat c = match usetac with | None -> Proofview.Goal.enter { enter = begin fun gl -> - let t = Tacmach.New.pf_unsafe_type_of gl (EConstr.of_constr c) in - let hd = head_ident c in + let t = Tacmach.New.pf_unsafe_type_of gl c in + let t = EConstr.of_constr t in + let sigma = Tacmach.New.project gl in + let hd = head_ident sigma c in Tacticals.New.tclTHENFIRST (assert_as true hd ipat t) (exact_no_check c) end } | Some tac -> @@ -2801,22 +2833,22 @@ let enough_by na t tac = forward false (Some (Some tac)) (ipat_of_name na) t (* Compute a name for a generalization *) -let generalized_name c t ids cl = function +let generalized_name sigma c t ids cl = function | Name id as na -> if Id.List.mem id ids then user_err (pr_id id ++ str " is already used."); na | Anonymous -> - match kind_of_term c with + match EConstr.kind sigma c with | Var id -> (* Keep the name even if not occurring: may be used by intros later *) Name id | _ -> - if noccurn 1 cl then Anonymous else + if noccurn sigma 1 cl then Anonymous else (* On ne s'etait pas casse la tete : on avait pris pour nom de variable la premiere lettre du type, meme si "c" avait ete une constante dont on aurait pu prendre directement le nom *) - named_hd (Global.env()) t Anonymous + named_hd (Global.env()) (EConstr.Unsafe.to_constr t) Anonymous (* Abstract over [c] in [forall x1:A1(c)..xi:Ai(c).T(c)] producing [forall x, x1:A1(x1), .., xi:Ai(x). T(x)] with all [c] abtracted in [Ai] @@ -2824,21 +2856,23 @@ let generalized_name c t ids cl = function let generalize_goal_gen env sigma ids i ((occs,c,b),na) t cl = let open Context.Rel.Declaration in - let decls,cl = decompose_prod_n_assum i cl in - let dummy_prod = EConstr.of_constr (it_mkProd_or_LetIn mkProp decls) in - let newdecls,_ = decompose_prod_n_assum i (subst_term_gen sigma EConstr.eq_constr_nounivs (EConstr.of_constr c) dummy_prod) in - let cl',sigma' = subst_closed_term_occ env sigma (AtOccs occs) (EConstr.of_constr c) (EConstr.of_constr (it_mkProd_or_LetIn cl newdecls)) in - let na = generalized_name c t ids cl' na in + let decls,cl = decompose_prod_n_assum sigma i cl in + let dummy_prod = it_mkProd_or_LetIn mkProp decls in + let newdecls,_ = decompose_prod_n_assum sigma i (EConstr.of_constr (subst_term_gen sigma EConstr.eq_constr_nounivs c dummy_prod)) in + let cl',sigma' = subst_closed_term_occ env sigma (AtOccs occs) c (it_mkProd_or_LetIn cl newdecls) in + let cl' = EConstr.of_constr cl' in + let na = generalized_name sigma c t ids cl' na in let decl = match b with - | None -> LocalAssum (na,t) - | Some b -> LocalDef (na,b,t) + | None -> local_assum (na,t) + | Some b -> local_def (na,b,t) in 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 (EConstr.of_constr c) in + let sigma, t = Typing.type_of env sigma c in + let t = EConstr.of_constr t in generalize_goal_gen env sigma ids i o t cl let old_generalize_dep ?(with_let=false) c gl = @@ -2848,7 +2882,7 @@ let old_generalize_dep ?(with_let=false) c gl = let init_ids = ids_of_named_context (Global.named_context()) in let seek (d:Context.Named.Declaration.t) (toquant:Context.Named.t) = if List.exists (fun d' -> occur_var_in_decl env sigma (NamedDecl.get_id d') d) toquant - || dependent_in_decl sigma (EConstr.of_constr c) d then + || dependent_in_decl sigma c d then d::toquant else toquant in @@ -2857,24 +2891,27 @@ let old_generalize_dep ?(with_let=false) c gl = let qhyps = List.map NamedDecl.get_id to_quantify_rev in let tothin = List.filter (fun id -> not (Id.List.mem id init_ids)) qhyps in let tothin' = - match kind_of_term c with + match EConstr.kind sigma c with | Var id when mem_named_context_val id (val_of_named_context sign) && not (Id.List.mem id init_ids) -> id::tothin | _ -> tothin in let cl' = it_mkNamedProd_or_LetIn (Tacmach.pf_concl gl) to_quantify in + let cl' = EConstr.of_constr cl' in let body = if with_let then - match kind_of_term c with + match EConstr.kind sigma c with | Var id -> id |> Tacmach.pf_get_hyp gl |> NamedDecl.get_value | _ -> None else None in + let body = Option.map EConstr.of_constr body in let cl'',evd = generalize_goal gl 0 ((AllOccurrences,c,body),Anonymous) (cl',project gl) in (** Check that the generalization is indeed well-typed *) - let (evd, _) = Typing.type_of env evd (EConstr.of_constr cl'') in + let (evd, _) = Typing.type_of env evd cl'' in let args = Context.Named.to_instance to_quantify_rev in + let args = List.map EConstr.of_constr args in tclTHENLIST [tclEVARS evd; Proofview.V82.of_tactic (apply_type cl'' (if Option.is_empty body then c::args else args)); @@ -2889,9 +2926,9 @@ let generalize_gen_let lconstr = Proofview.Goal.nf_s_enter { s_enter = begin fun let env = Proofview.Goal.env gl in let newcl, evd = List.fold_right_i (Tacmach.New.of_old generalize_goal gl) 0 lconstr - (Tacmach.New.pf_concl gl,Tacmach.New.project gl) + (EConstr.of_constr (Tacmach.New.pf_concl gl),Tacmach.New.project gl) in - let (evd, _) = Typing.type_of env evd (EConstr.of_constr newcl) in + let (evd, _) = Typing.type_of env evd newcl in let map ((_, c, b),_) = if Option.is_empty b then Some c else None in let tac = apply_type newcl (List.map_filter map lconstr) in Sigma.Unsafe.of_pair (tac, evd) @@ -2902,13 +2939,15 @@ let new_generalize_gen_let lconstr = let sigma = Proofview.Goal.sigma gl in let gl = Proofview.Goal.assume gl in let concl = Proofview.Goal.concl gl in + let concl = EConstr.of_constr concl in let sigma = Sigma.to_evar_map sigma in let env = Proofview.Goal.env gl in let ids = Tacmach.New.pf_ids_of_hyps gl in let newcl, sigma, args = List.fold_right_i (fun i ((_,c,b),_ as o) (cl, sigma, args) -> - let sigma, t = Typing.type_of env sigma (EConstr.of_constr c) in + let sigma, t = Typing.type_of env sigma c in + let t = EConstr.of_constr t in let args = if Option.is_empty b then c :: args else args in let cl, sigma = generalize_goal_gen env sigma ids i o t cl in (cl, sigma, args)) @@ -2916,8 +2955,8 @@ let new_generalize_gen_let lconstr = in let tac = Refine.refine { run = begin fun sigma -> - let Sigma (ev, sigma, p) = Evarutil.new_evar env sigma ~principal:true (EConstr.of_constr newcl) in - Sigma (EConstr.of_constr (applist (ev, args)), sigma, p) + let Sigma (ev, sigma, p) = Evarutil.new_evar env sigma ~principal:true newcl in + Sigma ((applist (ev, args)), sigma, p) end } in Sigma.Unsafe.of_pair (tac, sigma) @@ -2950,6 +2989,7 @@ let quantify lconstr = (* Modifying/Adding an hypothesis *) let specialize (c,lbind) ipat = + let nf_evar sigma c = EConstr.of_constr (nf_evar sigma (EConstr.Unsafe.to_constr c)) in Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in @@ -2958,27 +2998,26 @@ let specialize (c,lbind) ipat = let sigma = Typeclasses.resolve_typeclasses env sigma in sigma, nf_evar sigma c else - let c = EConstr.of_constr c in - let lbind = Miscops.map_bindings EConstr.of_constr lbind in let clause = make_clenv_binding env sigma (c,EConstr.of_constr (Retyping.get_type_of env sigma 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 EConstr.Unsafe.to_constr t :: chk l + | t::l -> if occur_meta clause.evd t then [] else t :: chk l in let tstack = chk tstack in - let term = applist(EConstr.Unsafe.to_constr thd,List.map (nf_evar clause.evd) tstack) in - if occur_meta clause.evd (EConstr.of_constr term) then + 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 (EConstr.of_constr term)))) ++ + pr_name (meta_name clause.evd (List.hd (collect_metas clause.evd term))) ++ str "."); clause.evd, term in - let typ = Retyping.get_type_of env sigma (EConstr.of_constr term) in + let typ = Retyping.get_type_of env sigma term in + let typ = EConstr.of_constr typ in let tac = - match kind_of_term (fst(decompose_app (snd(decompose_lam_assum c)))) with + match EConstr.kind sigma (fst(EConstr.decompose_app sigma (snd(EConstr.decompose_lam_assum sigma c)))) with | Var id when Id.List.mem id (Tacmach.New.pf_ids_of_hyps gl) -> (* Like assert (id:=id args) but with the concept of specialization *) let naming,tac = @@ -3020,9 +3059,10 @@ let unfold_body x = (pr_id x ++ str" is not a defined hypothesis.") | LocalDef (_,xval,_) -> xval in + let xval = EConstr.of_constr xval in Tacticals.New.afterHyp x begin fun aft -> let hl = List.fold_right (fun decl cl -> (NamedDecl.get_id decl, InHyp) :: cl) aft [] in - let rfun _ _ c = replace_vars [x, xval] (EConstr.Unsafe.to_constr c) in + let rfun _ _ c = EConstr.Unsafe.to_constr (replace_vars [x, xval] c) in let reducth h = reduct_in_hyp rfun h in let reductc = reduct_in_concl (rfun, DEFAULTcast) in Tacticals.New.tclTHENLIST [Tacticals.New.tclMAP reducth hl; reductc] @@ -3072,7 +3112,7 @@ let warn_unused_intro_pattern = strbrk"Unused introduction " ++ str (String.plural (List.length names) "pattern") ++ str": " ++ prlist_with_sep spc (Miscprint.pr_intro_pattern - (fun c -> Printer.pr_constr (fst (run_delayed (Global.env()) Evd.empty c)))) names) + (fun c -> Printer.pr_constr (EConstr.Unsafe.to_constr (fst (run_delayed (Global.env()) Evd.empty c))))) names) let check_unused_names names = if not (List.is_empty names) && Flags.is_verbose () then @@ -3206,13 +3246,12 @@ let induct_discharge with_evars dests avoid' tac (avoid,ra) names = substitutions aussi sur l'argument voisin *) let expand_projections env sigma c = - let sigma = Sigma.to_evar_map sigma in let rec aux env c = match EConstr.kind sigma c with | Proj (p, c) -> Retyping.expand_projection env sigma p (aux env c) [] | _ -> map_constr_with_full_binders sigma push_rel aux env c in - EConstr.Unsafe.to_constr (aux env (EConstr.of_constr c)) + aux env c (* Marche pas... faut prendre en compte l'occurrence précise... *) @@ -3220,13 +3259,14 @@ let expand_projections env sigma c = let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in let tmptyp0 = Tacmach.New.pf_get_hyp_typ hyp0 (Proofview.Goal.assume gl) in + let tmptyp0 = EConstr.of_constr tmptyp0 in let reduce_to_quantified_ref = Tacmach.New.pf_apply reduce_to_quantified_ref gl in - let typ0 = reduce_to_quantified_ref indref (EConstr.of_constr tmptyp0) in - let prods, indtyp = decompose_prod_assum typ0 in - let hd,argl = decompose_app indtyp in + let typ0 = reduce_to_quantified_ref indref tmptyp0 in + let prods, indtyp = decompose_prod_assum sigma typ0 in + let hd,argl = decompose_app sigma indtyp in let env' = push_rel_context prods env in - let sigma = Proofview.Goal.sigma gl in let params = List.firstn nparams argl in let params' = List.map (expand_projections env' sigma) params in (* le gl est important pour ne pas préévaluer *) @@ -3238,16 +3278,16 @@ let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = (tac avoid) else let c = List.nth argl (i-1) in - match kind_of_term c with - | Var id when not (List.exists (fun c -> occur_var env (Sigma.to_evar_map sigma) id (EConstr.of_constr c)) args') && - not (List.exists (fun c -> occur_var env (Sigma.to_evar_map sigma) id (EConstr.of_constr c)) params') -> + match EConstr.kind sigma c with + | Var id when not (List.exists (fun c -> occur_var env sigma id c) args') && + not (List.exists (fun c -> occur_var env sigma id c) params') -> (* Based on the knowledge given by the user, all constraints on the variable are generalizable in the current environment so that it is clearable after destruction *) atomize_one (i-1) (c::args) (c::args') (id::avoid) | _ -> let c' = expand_projections env' sigma c in - let dependent t = dependent (Sigma.to_evar_map sigma) (EConstr.of_constr c) (EConstr.of_constr t) in + let dependent t = dependent sigma c t in if List.exists dependent params' || List.exists dependent args' then @@ -3261,11 +3301,11 @@ let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = (* We reason blindly on the term and do as if it were generalizable, ignoring the constraints coming from its structure *) - let id = match kind_of_term c with + let id = match EConstr.kind sigma c with | Var id -> id | _ -> let type_of = Tacmach.New.pf_unsafe_type_of gl in - id_of_name_using_hdchar (Global.env()) (type_of (EConstr.of_constr c)) Anonymous in + id_of_name_using_hdchar (Global.env()) (type_of c) Anonymous in let x = fresh_id_in_env avoid id env in Tacticals.New.tclTHEN (letin_tac None (Name x) c None allHypsAndConcl) @@ -3440,8 +3480,8 @@ let cook_sign hyp0_opt inhyps indvars env sigma = (* [rel_contexts] and [rel_declaration] actually contain triples, and lists are actually in reverse order to fit [compose_prod]. *) type elim_scheme = { - elimc: constr with_bindings option; - elimt: types; + elimc: EConstr.constr with_bindings option; + elimt: EConstr.types; indref: global_reference option; params: Context.Rel.t; (* (prm1,tprm1);(prm2,tprm2)...(prmp,tprmp) *) nparams: int; (* number of parameters *) @@ -3453,7 +3493,7 @@ type elim_scheme = { nargs: int; (* number of arguments *) indarg: Context.Rel.Declaration.t option; (* Some (H,I prm1..prmp x1...xni) if HI is in premisses, None otherwise *) - concl: types; (* Qi x1...xni HI (f...), HI and (f...) + concl: EConstr.types; (* Qi x1...xni HI (f...), HI and (f...) are optional and mutually exclusive *) indarg_in_concl: bool; (* true if HI appears at the end of conclusion *) farg_in_concl: bool; (* true if (f...) appears at the end of conclusion *) @@ -3462,7 +3502,7 @@ type elim_scheme = { let empty_scheme = { elimc = None; - elimt = mkProp; + elimt = EConstr.mkProp; indref = None; params = []; nparams = 0; @@ -3473,7 +3513,7 @@ let empty_scheme = args = []; nargs = 0; indarg = None; - concl = mkProp; + concl = EConstr.mkProp; indarg_in_concl = false; farg_in_concl = false; } @@ -3516,13 +3556,13 @@ 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 = Universes.constr_of_global +let glob c = EConstr.of_constr (Universes.constr_of_global c) let coq_eq = lazy (glob (Coqlib.build_coq_eq ())) let coq_eq_refl = lazy (glob (Coqlib.build_coq_eq_refl ())) -let coq_heq = lazy (Coqlib.coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq") -let coq_heq_refl = lazy (Coqlib.coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq_refl") +let coq_heq = lazy (EConstr.of_constr (Coqlib.coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq")) +let coq_heq_refl = lazy (EConstr.of_constr (Coqlib.coq_constant "mkHEq" ["Logic";"JMeq"] "JMeq_refl")) let mkEq t x y = @@ -3547,26 +3587,26 @@ let lift_togethern n l = l ([], n) in l' -let lift_list l = List.map (lift 1) l +let lift_list l = List.map (EConstr.Vars.lift 1) l -let ids_of_constr ?(all=false) vars c = +let ids_of_constr sigma ?(all=false) vars c = let rec aux vars c = - match kind_of_term c with + match EConstr.kind sigma c with | Var id -> Id.Set.add id vars | App (f, args) -> - (match kind_of_term f with + (match EConstr.kind sigma f with | Construct ((ind,_),_) | Ind (ind,_) -> let (mib,mip) = Global.lookup_inductive ind in Array.fold_left_from (if all then 0 else mib.Declarations.mind_nparams) aux vars args - | _ -> Term.fold_constr aux vars c) - | _ -> Term.fold_constr aux vars c + | _ -> EConstr.fold sigma aux vars c) + | _ -> EConstr.fold sigma aux vars c in aux vars c -let decompose_indapp f args = - match kind_of_term f with +let decompose_indapp sigma f args = + match EConstr.kind sigma f with | Construct ((ind,_),_) | Ind (ind,_) -> let (mib,mip) = Global.lookup_inductive ind in @@ -3577,7 +3617,7 @@ let decompose_indapp f args = let mk_term_eq env sigma ty t ty' t' = let sigma = Sigma.to_evar_map sigma in - if Reductionops.is_conv env sigma (EConstr.of_constr ty) (EConstr.of_constr ty') then + if Reductionops.is_conv env sigma ty ty' then mkEq ty t t', mkRefl ty' t' else mkHEq ty t ty' t', mkHRefl ty' t' @@ -3595,17 +3635,17 @@ let make_abstract_generalize env id typ concl dep ctx body c eqs args refls = in (* Abstract by equalities *) let eqs = lift_togethern 1 eqs in (* lift together and past genarg *) - let abseqs = it_mkProd_or_LetIn (lift eqslen abshypeq) (List.map (fun x -> LocalAssum (Anonymous, x)) eqs) in + let abseqs = it_mkProd_or_LetIn (lift eqslen abshypeq) (List.map (fun x -> local_assum (Anonymous, x)) eqs) in let decl = match body with - | None -> LocalAssum (Name id, c) - | Some body -> LocalDef (Name id, body, c) + | None -> local_assum (Name id, c) + | Some body -> local_def (Name id, body, c) in (* Abstract by the "generalized" hypothesis. *) let genarg = mkProd_or_LetIn decl abseqs in (* Abstract by the extension of the context *) let genctyp = it_mkProd_or_LetIn genarg ctx in (* The goal will become this product. *) - let Sigma (genc, sigma, p) = Evarutil.new_evar env sigma ~principal:true (EConstr.of_constr genctyp) in + let Sigma (genc, sigma, p) = Evarutil.new_evar env sigma ~principal:true genctyp in (* Apply the old arguments giving the proper instantiation of the hyp *) let instc = mkApp (genc, Array.of_list args) in (* Then apply to the original instantiated hyp. *) @@ -3613,7 +3653,7 @@ let make_abstract_generalize env id typ concl dep ctx body c eqs args refls = (* Apply the reflexivity proofs on the indices. *) let appeqs = mkApp (instc, Array.of_list refls) in (* Finally, apply the reflexivity proof for the original hyp, to get a term of type gl again. *) - Sigma (EConstr.of_constr (mkApp (appeqs, abshypt)), sigma, p) + Sigma (mkApp (appeqs, abshypt), sigma, p) end } let hyps_of_vars env sigma sign nogen hyps = @@ -3636,11 +3676,11 @@ let hyps_of_vars env sigma sign nogen hyps = exception Seen -let linear vars args = +let linear sigma vars args = let seen = ref vars in try Array.iter (fun i -> - let rels = ids_of_constr ~all:true Id.Set.empty i in + let rels = ids_of_constr sigma ~all:true Id.Set.empty i in let seen' = Id.Set.fold (fun id acc -> if Id.Set.mem id acc then raise Seen @@ -3659,7 +3699,8 @@ let abstract_args gl generalize_vars dep id defined f args = let sigma = ref (Tacmach.project gl) in let env = Tacmach.pf_env gl in let concl = Tacmach.pf_concl gl in - let dep = dep || local_occur_var !sigma id (EConstr.of_constr concl) in + let concl = EConstr.of_constr concl in + let dep = dep || local_occur_var !sigma id concl in let avoid = ref [] in let get_id name = let id = fresh_id !avoid (match name with Name n -> n | Anonymous -> Id.of_string "gen_x") gl in @@ -3673,23 +3714,27 @@ let abstract_args gl generalize_vars dep id defined f args = *) let aux (prod, ctx, ctxenv, c, args, eqs, refls, nongenvars, vars, env) arg = let name, ty, arity = - let rel, c = Reductionops.splay_prod_n env !sigma 1 (EConstr.of_constr prod) in + let rel, c = Reductionops.splay_prod_n env !sigma 1 prod in + let c = EConstr.of_constr c in let decl = List.hd rel in RelDecl.get_name decl, RelDecl.get_type decl, c in - let argty = Tacmach.pf_unsafe_type_of gl (EConstr.of_constr arg) in - let sigma', ty = Evarsolve.refresh_universes (Some true) env !sigma (EConstr.of_constr ty) in + let ty = EConstr.of_constr ty in + let argty = Tacmach.pf_unsafe_type_of gl arg in + let argty = EConstr.of_constr argty in + let sigma', ty = Evarsolve.refresh_universes (Some true) env !sigma ty in let () = sigma := sigma' in + let ty = EConstr.of_constr ty in let lenctx = List.length ctx in let liftargty = lift lenctx argty in - let leq = constr_cmp Reduction.CUMUL liftargty ty in - match kind_of_term arg with + let leq = constr_cmp !sigma Reduction.CUMUL liftargty ty in + match EConstr.kind !sigma arg with | Var id when not (is_defined_variable env id) && leq && not (Id.Set.mem id nongenvars) -> (subst1 arg arity, ctx, ctxenv, mkApp (c, [|arg|]), args, eqs, refls, Id.Set.add id nongenvars, Id.Set.remove id vars, env) | _ -> let name = get_id name in - let decl = LocalAssum (Name name, ty) in + let decl = local_assum (Name name, ty) in let ctx = decl :: ctx in let c' = mkApp (lift 1 c, [|mkRel 1|]) in let args = arg :: args in @@ -3702,23 +3747,24 @@ let abstract_args gl generalize_vars dep id defined f args = in let eqs = eq :: lift_list eqs in let refls = refl :: refls in - let argvars = ids_of_constr vars arg in + let argvars = ids_of_constr !sigma vars arg in (arity, ctx, push_rel decl ctxenv, c', args, eqs, refls, nongenvars, Id.Set.union argvars vars, env) in - let f', args' = decompose_indapp f args in + let f', args' = decompose_indapp !sigma f args in let dogen, f', args' = - let parvars = ids_of_constr ~all:true Id.Set.empty f' in - if not (linear parvars args') then true, f, args + let parvars = ids_of_constr !sigma ~all:true Id.Set.empty f' in + if not (linear !sigma parvars args') then true, f, args else - match Array.findi (fun i x -> not (isVar x) || is_defined_variable env (destVar x)) args' with + match Array.findi (fun i x -> not (isVar !sigma x) || is_defined_variable env (destVar !sigma x)) args' with | None -> false, f', args' | Some nonvar -> let before, after = Array.chop nonvar args' in true, mkApp (f', before), after in if dogen then - let tyf' = Tacmach.pf_unsafe_type_of gl (EConstr.of_constr f') in + let tyf' = Tacmach.pf_unsafe_type_of gl f' in + let tyf' = EConstr.of_constr tyf' in let arity, ctx, ctxenv, c', args, eqs, refls, nogen, vars, env = Array.fold_left aux (tyf',[],env,f',[],[],[],Id.Set.empty,Id.Set.empty,env) args' in @@ -3730,10 +3776,11 @@ let abstract_args gl generalize_vars dep id defined f args = else [] in let body, c' = - if defined then Some c', Retyping.get_type_of ctxenv !sigma (EConstr.of_constr c') + if defined then Some c', EConstr.of_constr (Retyping.get_type_of ctxenv !sigma c') else None, c' in let typ = Tacmach.pf_get_hyp_typ gl id in + let typ = EConstr.of_constr typ in let tac = make_abstract_generalize (pf_env gl) id typ concl dep ctx body c' eqs args refls in let tac = Proofview.Unsafe.tclEVARS !sigma <*> tac in Some (tac, dep, succ (List.length ctx), vars) @@ -3743,13 +3790,15 @@ let abstract_generalize ?(generalize_vars=true) ?(force_dep=false) id = let open Context.Named.Declaration in Proofview.Goal.nf_enter { enter = begin fun gl -> Coqlib.check_required_library Coqlib.jmeq_module_name; + let sigma = Tacmach.New.project gl in let (f, args, def, id, oldid) = let oldid = Tacmach.New.pf_get_new_id id gl in match Tacmach.New.pf_get_hyp id gl with - | LocalAssum (_,t) -> let f, args = decompose_app t in + | LocalAssum (_,t) -> let f, args = decompose_app sigma (EConstr.of_constr t) in (f, args, false, id, oldid) | LocalDef (_,t,_) -> - let f, args = decompose_app t in + let t = EConstr.of_constr t in + let f, args = decompose_app sigma t in (f, args, true, id, oldid) in if List.is_empty args then Proofview.tclUNIT () @@ -3778,31 +3827,35 @@ let abstract_generalize ?(generalize_vars=true) ?(force_dep=false) id = Tacticals.New.tclTRY (generalize_dep ~with_let:true (mkVar id))) vars]) end } -let rec compare_upto_variables x y = - if (isVar x || isRel x) && (isVar y || isRel y) then true - else compare_constr compare_upto_variables x y +let compare_upto_variables sigma x y = + let rec compare x y = + if (isVar sigma x || isRel sigma x) && (isVar sigma y || isRel sigma y) then true + else compare_constr sigma compare x y + in + compare x y let specialize_eqs id gl = let open Context.Rel.Declaration in let env = Tacmach.pf_env gl in let ty = Tacmach.pf_get_hyp_typ gl id in + let ty = EConstr.of_constr ty in let evars = ref (project gl) in let unif env evars c1 c2 = - compare_upto_variables c1 c2 && Evarconv.e_conv env evars (EConstr.of_constr c1) (EConstr.of_constr c2) + compare_upto_variables !evars c1 c2 && Evarconv.e_conv env evars c1 c2 in let rec aux in_eqs ctx acc ty = - match kind_of_term ty with + match EConstr.kind !evars ty with | Prod (na, t, b) -> - (match kind_of_term t with - | App (eq, [| eqty; x; y |]) when Term.eq_constr (Lazy.force coq_eq) eq -> - let c = if noccur_between 1 (List.length ctx) x then y else x in + (match EConstr.kind !evars t with + | App (eq, [| eqty; x; y |]) when EConstr.eq_constr !evars (Lazy.force coq_eq) 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 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 Term.eq_constr heq (Lazy.force coq_heq) -> - let eqt, c = if noccur_between 1 (List.length ctx) x then eqty', y else eqty, x in + | App (heq, [| eqty; x; eqty'; y |]) when EConstr.eq_constr !evars heq (Lazy.force coq_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 if unif (push_rel_context ctx env) evars pt t then @@ -3811,20 +3864,21 @@ let specialize_eqs id gl = | _ -> if in_eqs then acc, in_eqs, ctx, ty else - let e = e_new_evar (push_rel_context ctx env) evars (EConstr.of_constr t) in - aux false (LocalDef (na,e,t) :: ctx) (mkApp (lift 1 acc, [| mkRel 1 |])) b) + let e = e_new_evar (push_rel_context ctx env) evars t in + aux false (local_def (na,e,t) :: ctx) (mkApp (lift 1 acc, [| mkRel 1 |])) b) | t -> acc, in_eqs, ctx, ty in let acc, worked, ctx, ty = aux false [] (mkVar id) ty in let ctx' = nf_rel_context_evar !evars ctx in let ctx'' = List.map (function - | LocalDef (n,k,t) when isEvar k -> LocalAssum (n,t) + | LocalDef (n,k,t) when isEvar !evars (EConstr.of_constr k) -> LocalAssum (n,t) | decl -> decl) ctx' in let ty' = it_mkProd_or_LetIn ty ctx'' in let acc' = it_mkLambda_or_LetIn acc ctx'' in - let ty' = Tacred.whd_simpl env !evars (EConstr.of_constr ty') - and acc' = Tacred.whd_simpl env !evars (EConstr.of_constr acc') in + let ty' = Tacred.whd_simpl env !evars ty' + and acc' = Tacred.whd_simpl env !evars acc' in + let acc' = EConstr.of_constr acc' in let ty' = Evarutil.nf_evar !evars ty' in let ty' = EConstr.of_constr ty' in if worked then @@ -3840,8 +3894,8 @@ let specialize_eqs id = Proofview.Goal.nf_enter { enter = begin fun gl -> Proofview.V82.tactic (specialize_eqs id) end } -let occur_rel n c = - let res = not (noccurn n c) in +let occur_rel sigma n c = + let res = not (noccurn sigma n c) in res (* This function splits the products of the induction scheme [elimt] into four @@ -3852,20 +3906,20 @@ let occur_rel n c = if there is no branch, we try to fill in acc3 with args/indargs. We also return the conclusion. *) -let decompose_paramspred_branch_args elimt = +let decompose_paramspred_branch_args sigma elimt = let open Context.Rel.Declaration in let rec cut_noccur elimt acc2 = - match kind_of_term elimt with + match EConstr.kind sigma elimt with | Prod(nme,tpe,elimt') -> - let hd_tpe,_ = decompose_app ((strip_prod_assum tpe)) in - if not (occur_rel 1 elimt') && isRel hd_tpe - then cut_noccur elimt' (LocalAssum (nme,tpe)::acc2) - else let acc3,ccl = decompose_prod_assum elimt in acc2 , acc3 , ccl + let hd_tpe,_ = decompose_app sigma (snd (decompose_prod_assum sigma tpe)) in + if not (occur_rel sigma 1 elimt') && isRel sigma hd_tpe + then cut_noccur elimt' (local_assum (nme,tpe)::acc2) + else let acc3,ccl = decompose_prod_assum sigma elimt in acc2 , acc3 , ccl | App(_, _) | Rel _ -> acc2 , [] , elimt | _ -> error_ind_scheme "" in let rec cut_occur elimt acc1 = - match kind_of_term elimt with - | Prod(nme,tpe,c) when occur_rel 1 c -> cut_occur c (LocalAssum (nme,tpe)::acc1) + match EConstr.kind sigma elimt with + | Prod(nme,tpe,c) when occur_rel sigma 1 c -> cut_occur c (local_assum (nme,tpe)::acc1) | Prod(nme,tpe,c) -> let acc2,acc3,ccl = cut_noccur elimt [] in acc1,acc2,acc3,ccl | App(_, _) | Rel _ -> acc1,[],[],elimt | _ -> error_ind_scheme "" in @@ -3878,17 +3932,17 @@ let decompose_paramspred_branch_args elimt = args. We suppose there is only one predicate here. *) match acc2 with | [] -> - let hyps,ccl = decompose_prod_assum elimt in - let hd_ccl_pred,_ = decompose_app ccl in - begin match kind_of_term hd_ccl_pred with + let hyps,ccl = decompose_prod_assum sigma elimt in + let hd_ccl_pred,_ = decompose_app sigma ccl in + begin match EConstr.kind sigma hd_ccl_pred with | Rel i -> let acc3,acc1 = List.chop (i-1) hyps in acc1 , [] , acc3 , ccl | _ -> error_ind_scheme "" end | _ -> acc1, acc2 , acc3, ccl -let exchange_hd_app subst_hd t = - let hd,args= decompose_app t in mkApp (subst_hd,Array.of_list args) +let exchange_hd_app sigma subst_hd t = + let hd,args= decompose_app sigma t in mkApp (subst_hd,Array.of_list args) (* Builds an elim_scheme from its type and calling form (const+binding). We first separate branches. We obtain branches, hyps before (params + preds), @@ -3906,14 +3960,14 @@ let exchange_hd_app subst_hd t = predicates are cited in the conclusion. - finish to fill in the elim_scheme: indarg/farg/args and finally indref. *) -let compute_elim_sig ?elimc elimt = +let compute_elim_sig sigma ?elimc elimt = let open Context.Rel.Declaration in let params_preds,branches,args_indargs,conclusion = - decompose_paramspred_branch_args elimt in + decompose_paramspred_branch_args sigma elimt in - let ccl = exchange_hd_app (mkVar (Id.of_string "__QI_DUMMY__")) conclusion in + let ccl = exchange_hd_app sigma (mkVar (Id.of_string "__QI_DUMMY__")) conclusion in let concl_with_args = it_mkProd_or_LetIn ccl args_indargs in - let nparams = Int.Set.cardinal (free_rels Evd.empty (** FIXME *) (EConstr.of_constr concl_with_args)) in + let nparams = Int.Set.cardinal (free_rels sigma concl_with_args) in let preds,params = List.chop (List.length params_preds - nparams) params_preds in (* A first approximation, further analysis will tweak it *) @@ -3922,7 +3976,7 @@ let compute_elim_sig ?elimc elimt = elimc = elimc; elimt = elimt; concl = conclusion; predicates = preds; npredicates = List.length preds; branches = branches; nbranches = List.length branches; - farg_in_concl = isApp ccl && isApp (last_arg ccl); + farg_in_concl = isApp sigma ccl && isApp sigma (last_arg sigma ccl); params = params; nparams = nparams; (* all other fields are unsure at this point. Including these:*) args = args_indargs; nargs = List.length args_indargs; } in @@ -3943,9 +3997,10 @@ let compute_elim_sig ?elimc elimt = match List.hd args_indargs with | LocalDef (hiname,_,hi) -> error_ind_scheme "" | LocalAssum (hiname,hi) -> - let hi_ind, hi_args = decompose_app hi in + let hi = EConstr.of_constr hi in + let hi_ind, hi_args = decompose_app sigma hi in let hi_is_ind = (* hi est d'un type globalisable *) - match kind_of_term hi_ind with + match EConstr.kind sigma hi_ind with | Ind (mind,_) -> true | Var _ -> true | Const _ -> true @@ -3958,7 +4013,7 @@ let compute_elim_sig ?elimc elimt = else (* Last arg is the indarg *) res := {!res with indarg = Some (List.hd !res.args); - indarg_in_concl = occur_rel 1 ccl; + indarg_in_concl = occur_rel sigma 1 ccl; args = List.tl !res.args; nargs = !res.nargs - 1; }; raise Exit); @@ -3968,55 +4023,58 @@ let compute_elim_sig ?elimc elimt = | None -> !res (* No indref *) | Some (LocalDef _) -> error_ind_scheme "" | Some (LocalAssum (_,ind)) -> - let indhd,indargs = decompose_app ind in - try {!res with indref = Some (global_of_constr indhd) } + let ind = EConstr.of_constr ind in + let indhd,indargs = decompose_app sigma ind in + try {!res with indref = Some (fst (Termops.global_of_constr sigma indhd)) } with e when CErrors.noncritical e -> error "Cannot find the inductive type of the inductive scheme." let compute_scheme_signature evd scheme names_info ind_type_guess = let open Context.Rel.Declaration in - let f,l = decompose_app scheme.concl in + let f,l = decompose_app evd scheme.concl in (* Vérifier que les arguments de Qi sont bien les xi. *) let cond, check_concl = match scheme.indarg with | Some (LocalDef _) -> error "Strange letin, cannot recognize an induction scheme." | None -> (* Non standard scheme *) - let cond hd = Term.eq_constr hd ind_type_guess && not scheme.farg_in_concl + let cond hd = EConstr.eq_constr evd hd ind_type_guess && not scheme.farg_in_concl in (cond, fun _ _ -> ()) | Some (LocalAssum (_,ind)) -> (* Standard scheme from an inductive type *) - let indhd,indargs = decompose_app ind in - let cond hd = Term.eq_constr hd indhd in + let ind = EConstr.of_constr ind in + let indhd,indargs = decompose_app evd ind in + let cond hd = EConstr.eq_constr evd hd indhd in let check_concl is_pred p = (* Check again conclusion *) let ccl_arg_ok = is_pred (p + scheme.nargs + 1) f == IndArg in let ind_is_ok = - List.equal Term.eq_constr + List.equal (fun c1 c2 -> EConstr.eq_constr evd c1 c2) (List.lastn scheme.nargs indargs) - (Context.Rel.to_extended_list 0 scheme.args) in + (List.map EConstr.of_constr (Context.Rel.to_extended_list 0 scheme.args)) in if not (ccl_arg_ok && ind_is_ok) then error_ind_scheme "the conclusion of" in (cond, check_concl) in let is_pred n c = - let hd = fst (decompose_app c) in - match kind_of_term hd with + let hd = fst (decompose_app evd c) in + match EConstr.kind evd hd with | Rel q when n < q && q <= n+scheme.npredicates -> IndArg | _ when cond hd -> RecArg | _ -> OtherArg in let rec check_branch p c = - match kind_of_term c with + match EConstr.kind evd c with | Prod (_,t,c) -> - (is_pred p t, true, not (EConstr.Vars.noccurn evd 1 (EConstr.of_constr c))) :: check_branch (p+1) c + (is_pred p t, true, not (Vars.noccurn evd 1 c)) :: check_branch (p+1) c | LetIn (_,_,_,c) -> - (OtherArg, false, not (EConstr.Vars.noccurn evd 1 (EConstr.of_constr c))) :: check_branch (p+1) c + (OtherArg, false, not (Vars.noccurn evd 1 c)) :: check_branch (p+1) c | _ when is_pred p c == IndArg -> [] | _ -> raise Exit in let rec find_branches p lbrch = match lbrch with | LocalAssum (_,t) :: brs -> + let t = EConstr.of_constr t in (try let lchck_brch = check_branch p t in let n = List.fold_left @@ -4042,7 +4100,7 @@ let compute_scheme_signature evd scheme names_info ind_type_guess = the non standard case, naming of generated hypos is slightly different. *) let compute_elim_signature (evd,(elimc,elimt),ind_type_guess) names_info = - let scheme = compute_elim_sig ~elimc:elimc elimt in + let scheme = compute_elim_sig evd ~elimc:elimc elimt in evd, (compute_scheme_signature evd scheme names_info ind_type_guess, scheme) let guess_elim isrec dep s hyp0 gl = @@ -4057,40 +4115,47 @@ let guess_elim isrec dep s hyp0 gl = if use_dependent_propositions_elimination () && dep then let Sigma (ind, sigma, _) = build_case_analysis_scheme env sigma mind true s in + let ind = EConstr.of_constr ind in (Sigma.to_evar_map sigma, ind) else let Sigma (ind, sigma, _) = build_case_analysis_scheme_default env sigma mind s in + let ind = EConstr.of_constr ind in (Sigma.to_evar_map sigma, ind) in - let elimt = Tacmach.New.pf_unsafe_type_of gl (EConstr.of_constr elimc) in + let elimt = Tacmach.New.pf_unsafe_type_of gl elimc in + let elimt = EConstr.of_constr elimt in evd, ((elimc, NoBindings), elimt), mkIndU mind let given_elim hyp0 (elimc,lbind as e) gl = + let sigma = Tacmach.New.project gl in let tmptyp0 = Tacmach.New.pf_get_hyp_typ hyp0 gl in - let ind_type_guess,_ = decompose_app ((strip_prod tmptyp0)) in - let elimc = EConstr.of_constr elimc in - Tacmach.New.project gl, (e, Tacmach.New.pf_unsafe_type_of gl elimc), ind_type_guess + let tmptyp0 = EConstr.of_constr tmptyp0 in + let ind_type_guess,_ = decompose_app sigma (snd (decompose_prod sigma tmptyp0)) in + let elimt = Tacmach.New.pf_unsafe_type_of gl elimc in + let elimt = EConstr.of_constr elimt in + Tacmach.New.project gl, (e, elimt), ind_type_guess type scheme_signature = (Id.t list * (elim_arg_kind * bool * bool * Id.t) list) array type eliminator_source = - | ElimUsing of (eliminator * types) * scheme_signature + | ElimUsing of (eliminator * EConstr.types) * scheme_signature | ElimOver of bool * Id.t let find_induction_type isrec elim hyp0 gl = + let sigma = Tacmach.New.project gl in let scheme,elim = match elim with | None -> let sort = Tacticals.New.elimination_sort_of_goal gl in let _, (elimc,elimt),_ = guess_elim isrec (* dummy: *) true sort hyp0 gl in - let scheme = compute_elim_sig ~elimc elimt in + let scheme = compute_elim_sig sigma ~elimc elimt in (* We drop the scheme waiting to know if it is dependent *) scheme, ElimOver (isrec,hyp0) | Some e -> let evd, (elimc,elimt),ind_guess = given_elim hyp0 e gl in - let scheme = compute_elim_sig ~elimc elimt in + let scheme = compute_elim_sig sigma ~elimc elimt in if Option.is_empty scheme.indarg then error "Cannot find induction type"; let indsign = compute_scheme_signature evd scheme hyp0 ind_guess in let elim = ({elimindex = Some(-1); elimbody = elimc; elimrename = None},elimt) in @@ -4104,7 +4169,8 @@ let get_elim_signature elim hyp0 gl = compute_elim_signature (given_elim hyp0 elim gl) hyp0 let is_functional_induction elimc gl = - let scheme = compute_elim_sig ~elimc (Tacmach.New.pf_unsafe_type_of gl (EConstr.of_constr (fst elimc))) in + let sigma = Tacmach.New.project gl in + let scheme = compute_elim_sig sigma ~elimc (EConstr.of_constr (Tacmach.New.pf_unsafe_type_of gl (fst elimc))) in (* The test is not safe: with non-functional induction on non-standard induction scheme, this may fail *) Option.is_empty scheme.indarg @@ -4128,17 +4194,18 @@ let get_eliminator elim dep s gl = of lid are parameters (first ones), the other are arguments. Returns the clause obtained. *) let recolle_clenv i params args elimclause gl = - let _,arr = destApp (EConstr.Unsafe.to_constr elimclause.templval.rebus) in + let _,arr = destApp elimclause.evd elimclause.templval.rebus in let lindmv = Array.map (fun x -> - match kind_of_term x with + match EConstr.kind elimclause.evd x with | Meta mv -> mv | _ -> user_err ~hdr:"elimination_clause" (str "The type of the elimination clause is not well-formed.")) arr in let k = match i with -1 -> Array.length lindmv - List.length args | _ -> i in (* parameters correspond to first elts of lid. *) + let pf_get_hyp_typ id gl = EConstr.of_constr (pf_get_hyp_typ id gl) in let clauses_params = List.map_i (fun i id -> mkVar id , pf_get_hyp_typ id gl, lindmv.(i)) 0 params in @@ -4153,8 +4220,6 @@ let recolle_clenv i params args elimclause gl = (* from_n (Some 0) means that x should be taken "as is" without trying to unify (which would lead to trying to apply it to evars if y is a product). *) - let x = EConstr.of_constr x in - let y = EConstr.of_constr y in let indclause = Tacmach.New.of_old (fun gl -> mk_clenv_from_n gl (Some 0) (x,y)) gl in let elimclause' = clenv_fchain ~with_univs:false i acc indclause in elimclause') @@ -4167,14 +4232,12 @@ let recolle_clenv i params args elimclause gl = *) let induction_tac with_evars params indvars elim = Proofview.Goal.nf_enter { enter = begin fun gl -> + let sigma = Tacmach.New.project gl in let ({elimindex=i;elimbody=(elimc,lbindelimc);elimrename=rename},elimt) = elim in - let i = match i with None -> index_of_ind_arg elimt | Some i -> i in + let i = match i with None -> index_of_ind_arg sigma elimt | Some i -> i in (* elimclause contains this: (elimc ?i ?j ?k...?l) *) - let elimc = contract_letin_in_lam_header elimc in + let elimc = contract_letin_in_lam_header sigma elimc in let elimc = mkCast (elimc, DEFAULTcast, elimt) in - let elimc = EConstr.of_constr elimc in - let elimt = EConstr.of_constr elimt in - let lbindelimc = Miscops.map_bindings EConstr.of_constr lbindelimc in let elimclause = pf_apply make_clenv_binding gl (elimc,elimt) lbindelimc in (* elimclause' is built from elimclause by instanciating all args and params. *) let elimclause' = recolle_clenv i params indvars elimclause gl in @@ -4197,7 +4260,8 @@ let apply_induction_in_context with_evars hyp0 inhyps elim indvars names induct_ let dep_in_concl = Option.cata (fun id -> occur_var env sigma id (EConstr.of_constr concl)) false hyp0 in let dep = dep_in_hyps || dep_in_concl in let tmpcl = it_mkNamedProd_or_LetIn concl deps in - let s = Retyping.get_sort_family_of env sigma (EConstr.of_constr tmpcl) in + let tmpcl = EConstr.of_constr tmpcl in + let s = Retyping.get_sort_family_of env sigma tmpcl in let deps_cstr = List.fold_left (fun a decl -> if NamedDecl.is_local_assum decl then (mkVar (NamedDecl.get_id decl))::a else a) [] deps in @@ -4321,14 +4385,12 @@ let use_bindings env sigma elim must_be_closed (c,lbind) typ = let rec find_clause typ = try let typ = EConstr.of_constr typ in - let c = EConstr.of_constr c in - let lbind = Miscops.map_bindings EConstr.of_constr lbind in let indclause = make_clenv_binding env sigma (c,typ) lbind in if must_be_closed && occur_meta indclause.evd (clenv_value indclause) then error "Need a fully applied argument."; (* We lose the possibility of coercions in with-bindings *) let (sigma, c) = pose_all_metas_as_evars env indclause.evd (clenv_value indclause) in - Sigma.Unsafe.of_pair (EConstr.Unsafe.to_constr c, sigma) + Sigma.Unsafe.of_pair (c, sigma) with e when catchable_exception e -> try find_clause (try_red_product env sigma (EConstr.of_constr typ)) with Redelimination -> raise e in @@ -4337,8 +4399,6 @@ let use_bindings env sigma elim must_be_closed (c,lbind) typ = let check_expected_type env sigma (elimc,bl) elimt = (* Compute the expected template type of the term in case a using clause is given *) - let open EConstr in - let elimt = EConstr.of_constr elimt in let sign,_ = splay_prod env sigma elimt in let n = List.length sign in if n == 0 then error "Scheme cannot be applied."; @@ -4354,11 +4414,11 @@ let check_enough_applied env sigma elim = | None -> (* No eliminator given *) fun u -> - let t,_ = decompose_app (whd_all env sigma u) in isInd t + let t,_ = decompose_app sigma (EConstr.of_constr (whd_all env sigma u)) in isInd sigma t | Some elimc -> - let elimt = Retyping.get_type_of env sigma (EConstr.of_constr (fst elimc)) in - let scheme = compute_elim_sig ~elimc elimt in - let elimc = Miscops.map_with_bindings EConstr.of_constr elimc in + let elimt = Retyping.get_type_of env sigma (fst elimc) in + let elimt = EConstr.of_constr elimt in + let scheme = compute_elim_sig sigma ~elimc elimt in match scheme.indref with | None -> (* in the absence of information, do not assume it may be @@ -4381,11 +4441,9 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim let store = Proofview.Goal.extra gl in let check = check_enough_applied env sigma elim in let Sigma (c, sigma', p) = use_bindings env sigma elim false (c0,lbind) t0 in - let c = EConstr.of_constr c in let abs = AbstractPattern (from_prefix,check,Name id,(pending,c),cls,false) in let ccl = EConstr.of_constr ccl in let (id,sign,_,lastlhyp,ccl,res) = make_abstraction env sigma' ccl abs in - let ccl = EConstr.Unsafe.to_constr ccl in match res with | None -> (* pattern not found *) @@ -4393,9 +4451,7 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim (* we restart using bindings after having tried type-class resolution etc. on the term given by the user *) let flags = tactic_infer_flags (with_evars && (* do not give a success semantics to edestruct on an open term yet *) false) in - let c0 = EConstr.of_constr c0 in let Sigma (c0, sigma, q) = finish_evar_resolution ~flags env sigma (pending,c0) in - let c0 = EConstr.Unsafe.to_constr c0 in let tac = (if isrec then (* Historically, induction has side conditions last *) @@ -4407,13 +4463,14 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim Refine.refine ~unsafe:true { run = begin fun sigma -> let b = not with_evars && with_eq != None in let Sigma (c, sigma, p) = use_bindings env sigma elim b (c0,lbind) t0 in - let t = Retyping.get_type_of env (Sigma.to_evar_map sigma) (EConstr.of_constr c) in + let t = Retyping.get_type_of env (Sigma.to_evar_map sigma) c in + let t = EConstr.of_constr t in let Sigma (ans, sigma, q) = mkletin_goal env sigma store with_eq false (id,lastlhyp,ccl,c) (Some t) in Sigma (ans, sigma, p +> q) end }; if with_evars then Proofview.shelve_unifiable else guard_no_unifiable; if is_arg_pure_hyp - then Tacticals.New.tclTRY (clear [destVar c0]) + then Proofview.tclEVARMAP >>= fun sigma -> Tacticals.New.tclTRY (clear [destVar sigma c0]) else Proofview.tclUNIT (); if isrec then Proofview.cycle (-1) else Proofview.tclUNIT () ]) @@ -4422,7 +4479,6 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim Sigma (tac, sigma, q) | Some (Sigma (c, sigma', q)) -> - let c = EConstr.Unsafe.to_constr c in (* pattern found *) let with_eq = Option.map (fun eq -> (false,eq)) eqname in (* TODO: if ind has predicate parameters, use JMeq instead of eq *) @@ -4451,14 +4507,15 @@ let induction_gen clear_flag isrec with_evars elim Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in + let evd = Sigma.to_evar_map sigma in let ccl = Proofview.Goal.raw_concl gl in let cls = Option.default allHypsAndConcl cls in - let t = typ_of env sigma (EConstr.of_constr c) in + let t = typ_of env sigma c in let is_arg_pure_hyp = - isVar c && not (mem_named_context_val (destVar c) (Global.named_context_val ())) + isVar evd c && not (mem_named_context_val (destVar evd c) (Global.named_context_val ())) && lbind == NoBindings && not with_evars && Option.is_empty eqname && clear_flag == None - && has_generic_occurrences_but_goal cls (destVar c) env (Sigma.to_evar_map sigma) ccl in + && has_generic_occurrences_but_goal cls (destVar evd c) env evd ccl in let enough_applied = check_enough_applied env sigma elim (EConstr.of_constr t) in if is_arg_pure_hyp && enough_applied then (* First case: induction on a variable already in an inductive type and @@ -4466,7 +4523,7 @@ let induction_gen clear_flag isrec with_evars elim This is a situation where the induction argument is a clearable variable of the goal w/o occurrence selection and w/o equality kept: no need to generalize *) - let id = destVar c in + let id = destVar evd c in Tacticals.New.tclTHEN (clear_unselected_context id inhyps cls) (induction_with_atomization_of_ind_arg @@ -4501,7 +4558,8 @@ let induction_gen_l isrec with_evars elim names lc = match l with | [] -> Proofview.tclUNIT () | c::l' -> - match kind_of_term c with + Proofview.tclEVARMAP >>= fun sigma -> + match EConstr.kind sigma c with | Var id when not (mem_named_context_val id (Global.named_context_val ())) && not with_evars -> let _ = newlc:= id::!newlc in @@ -4512,10 +4570,10 @@ let induction_gen_l isrec with_evars elim names lc = let type_of = Tacmach.New.pf_unsafe_type_of gl in let sigma = Tacmach.New.project gl in let x = - id_of_name_using_hdchar (Global.env()) (type_of (EConstr.of_constr c)) Anonymous in + id_of_name_using_hdchar (Global.env()) (type_of c) Anonymous in let id = new_fresh_id [] x gl in - let newl' = List.map (fun r -> replace_term sigma (EConstr.of_constr c) (EConstr.mkVar id) (EConstr.of_constr r)) l' in + let newl' = List.map (fun r -> EConstr.of_constr (replace_term sigma c (mkVar id) r)) l' in let _ = newlc:=id::!newlc in Tacticals.New.tclTHEN (letin_tac None (Name id) c None allHypsAndConcl) @@ -4639,13 +4697,12 @@ let simple_destruct = function let elim_scheme_type elim t = Proofview.Goal.nf_enter { enter = begin fun gl -> - let elim = EConstr.of_constr elim in let clause = Tacmach.New.of_old (fun gl -> mk_clenv_type_of gl elim) gl in - match kind_of_term (last_arg (EConstr.Unsafe.to_constr clause.templval.rebus)) with + match EConstr.kind clause.evd (last_arg clause.evd clause.templval.rebus) with | Meta mv -> let clause' = (* t is inductive, then CUMUL or CONV is irrelevant *) - clenv_unify ~flags:(elim_flags ()) Reduction.CUMUL (EConstr.of_constr 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") @@ -4653,7 +4710,6 @@ let elim_scheme_type elim t = let elim_type t = Proofview.Goal.s_enter { s_enter = begin fun gl -> - let t = EConstr.of_constr t in let (ind,t) = Tacmach.New.pf_apply reduce_to_atomic_ind gl t in let evd, elimc = find_ind_eliminator (fst ind) (Tacticals.New.elimination_sort_of_goal gl) gl in Sigma.Unsafe.of_pair (elim_scheme_type elimc t, evd) @@ -4661,12 +4717,12 @@ let elim_type t = let case_type t = Proofview.Goal.s_enter { s_enter = begin fun gl -> - let t = EConstr.of_constr t in let sigma = Proofview.Goal.sigma gl in let env = Tacmach.New.pf_env gl in let (ind,t) = reduce_to_atomic_ind env (Sigma.to_evar_map sigma) t in let s = Tacticals.New.elimination_sort_of_goal gl in let Sigma (elimc, evd, p) = build_case_analysis_scheme_default env sigma ind s in + let elimc = EConstr.of_constr elimc in Sigma (elim_scheme_type elimc t, evd, p) end } @@ -4722,12 +4778,10 @@ let (forward_setoid_symmetry, setoid_symmetry) = Hook.make () (* This is probably not very useful any longer *) let prove_symmetry hdcncl eq_kind = let symc = - let open EConstr in match eq_kind with | MonomorphicLeibnizEq (c1,c2) -> mkApp(hdcncl,[|c2;c1|]) | PolymorphicLeibnizEq (typ,c1,c2) -> mkApp(hdcncl,[|typ;c2;c1|]) | HeterogenousEq (t1,c1,t2,c2) -> mkApp(hdcncl,[|t2;c2;t1;c1|]) in - let symc = EConstr.Unsafe.to_constr symc in Tacticals.New.tclTHENFIRST (cut symc) (Tacticals.New.tclTHENLIST [ intro; @@ -4748,12 +4802,13 @@ let symmetry_red allowred = inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *) let sigma = Tacmach.New.project gl in let concl = maybe_betadeltaiota_concl allowred gl in - match_with_equation sigma (EConstr.of_constr concl) >>= fun with_eqn -> + let concl = EConstr.of_constr concl in + match_with_equation sigma concl >>= fun with_eqn -> match with_eqn with | 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 (EConstr.of_constr %> apply)) | None,eq,eq_kind -> prove_symmetry eq eq_kind end } @@ -4771,20 +4826,18 @@ let (forward_setoid_symmetry_in, setoid_symmetry_in) = Hook.make () let symmetry_in id = Proofview.Goal.enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in - let ctype = Tacmach.New.pf_unsafe_type_of gl (EConstr.mkVar id) in - let sign,t = decompose_prod_assum ctype in - let t = EConstr.of_constr t in + let ctype = Tacmach.New.pf_unsafe_type_of gl (mkVar id) in + let ctype = EConstr.of_constr ctype in + let sign,t = decompose_prod_assum sigma ctype in Proofview.tclORELSE begin match_with_equation sigma t >>= fun (_,hdcncl,eq) -> let symccl = - let open EConstr in match eq with | MonomorphicLeibnizEq (c1,c2) -> mkApp (hdcncl, [| c2; c1 |]) | PolymorphicLeibnizEq (typ,c1,c2) -> mkApp (hdcncl, [| typ; c2; c1 |]) | HeterogenousEq (t1,c1,t2,c2) -> mkApp (hdcncl, [| t2; c2; t1; c1 |]) in - let symccl = EConstr.Unsafe.to_constr symccl in - Tacticals.New.tclTHENS (cut (it_mkProd_or_LetIn symccl sign)) + Tacticals.New.tclTHENS (cut (EConstr.it_mkProd_or_LetIn symccl sign)) [ intro_replacing id; Tacticals.New.tclTHENLIST [ intros; symmetry; apply (mkVar id); assumption ] ] end @@ -4818,8 +4871,6 @@ let (forward_setoid_transitivity, setoid_transitivity) = Hook.make () (* This is probably not very useful any longer *) let prove_transitivity hdcncl eq_kind t = Proofview.Goal.enter { enter = begin fun gl -> - let t = EConstr.of_constr t in - let open EConstr in let (eq1,eq2) = match eq_kind with | MonomorphicLeibnizEq (c1,c2) -> mkApp (hdcncl, [| c1; t|]), mkApp (hdcncl, [| t; c2 |]) @@ -4834,8 +4885,6 @@ let prove_transitivity hdcncl eq_kind t = (mkApp(hdcncl, [| typ1; c1; typt ;t |]), mkApp(hdcncl, [| typt; t; typ2; c2 |])) in - let eq1 = EConstr.Unsafe.to_constr eq1 in - let eq2 = EConstr.Unsafe.to_constr eq2 in Tacticals.New.tclTHENFIRST (cut eq2) (Tacticals.New.tclTHENFIRST (cut eq1) (Tacticals.New.tclTHENLIST @@ -4851,14 +4900,15 @@ let transitivity_red allowred t = inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *) let sigma = Tacmach.New.project gl in let concl = maybe_betadeltaiota_concl allowred gl in - match_with_equation sigma (EConstr.of_constr concl) >>= fun with_eqn -> + let concl = EConstr.of_constr concl in + match_with_equation sigma concl >>= fun with_eqn -> match with_eqn with | Some eq_data,_,_ -> 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 (EConstr.of_constr %> eapply) + | Some t -> Tacticals.New.pf_constr_of_global eq_data.trans (fun trans -> apply_list [EConstr.of_constr trans;t])) | None,eq,eq_kind -> match t with | None -> Tacticals.New.tclZEROMSG (str"etransitivity not supported for this relation.") @@ -4902,6 +4952,8 @@ let rec decompose len c t accu = | _ -> assert false let rec shrink ctx sign c t accu = + let open Term in + let open CVars in match ctx, sign with | [], [] -> (c, t, accu) | p :: ctx, decl :: sign -> @@ -4984,6 +5036,7 @@ let abstract_subproof id gk tac = if !shrink_abstract then shrink_entry sign const else (const, List.rev (Context.Named.to_instance sign)) in + let args = List.map EConstr.of_constr args in let cd = Entries.DefinitionEntry const in let decl = (cd, IsProof Lemma) in let cst () = @@ -4995,6 +5048,7 @@ let abstract_subproof id gk tac = let cst = Impargs.with_implicit_protection cst () in (* let evd, lem = Evd.fresh_global (Global.env ()) evd (ConstRef cst) in *) let lem, ctx = Universes.unsafe_constr_of_global (ConstRef cst) in + let lem = EConstr.of_constr lem in let evd = Evd.set_universe_context evd ectx in let open Safe_typing in let eff = private_con_of_con (Global.safe_env ()) cst in @@ -5026,8 +5080,6 @@ let tclABSTRACT name_op tac = abstract_subproof s gk tac let unify ?(state=full_transparent_state) x y = - let x = EConstr.of_constr x in - let y = EConstr.of_constr y in Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in try @@ -5081,10 +5133,6 @@ module New = struct {onhyps=None; concl_occs=AllOccurrences } let refine ?unsafe c = - let c = { run = begin fun sigma -> - let Sigma (c, sigma, p) = c.run sigma in - Sigma (EConstr.of_constr c, sigma, p) - end } in Refine.refine ?unsafe c <*> reduce_after_refine end diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 368a1df76f..630c660a15 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -9,6 +9,7 @@ open Loc open Names open Term +open EConstr open Environ open Proof_type open Evd @@ -128,7 +129,7 @@ val exact_proof : Constrexpr.constr_expr -> unit Proofview.tactic (** {6 Reduction tactics. } *) -type tactic_reduction = env -> evar_map -> EConstr.t -> constr +type tactic_reduction = env -> evar_map -> constr -> Constr.constr type change_arg = patvar_map -> constr Sigma.run @@ -259,7 +260,7 @@ type elim_scheme = { farg_in_concl: bool; (** true if (f...) appears at the end of conclusion *) } -val compute_elim_sig : ?elimc: constr with_bindings -> types -> elim_scheme +val compute_elim_sig : evar_map -> ?elimc:constr with_bindings -> types -> elim_scheme (** elim principle with the index of its inductive arg *) type eliminator = { @@ -413,7 +414,7 @@ val subst_one : val declare_intro_decomp_eq : ((int -> unit Proofview.tactic) -> Coqlib.coq_eq_data * types * - (EConstr.types * EConstr.constr * EConstr.constr) -> + (types * constr * constr) -> constr * types -> unit Proofview.tactic) -> unit (** {6 Simple form of basic tactics. } *) diff --git a/tactics/term_dnet.ml b/tactics/term_dnet.ml index 6294f9fdc2..38342b64dc 100644 --- a/tactics/term_dnet.ml +++ b/tactics/term_dnet.ml @@ -355,7 +355,7 @@ struct with Invalid_argument _ -> [],c_id in let wc,whole_c = if Opt.direction then whole_c,wc else wc,whole_c in try - let _ = Termops.filtering ctx Reduction.CUMUL wc whole_c in + let _ = Termops.filtering Evd.empty ctx Reduction.CUMUL wc whole_c in id :: acc with Termops.CannotFilter -> (* msgnl(str"recon "++Termops.print_constr_env (Global.env()) wc); *) acc ) (TDnet.find_match dpat dn) [] -- cgit v1.2.3 From 8b660087beb2209e52bc4412dc82c6727963c6a5 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 18 Nov 2016 20:26:15 +0100 Subject: Elim API using EConstr. --- tactics/elim.ml | 19 ++++++++++--------- tactics/elim.mli | 1 + tactics/tacticals.ml | 3 ++- tactics/tacticals.mli | 4 ++-- 4 files changed, 15 insertions(+), 12 deletions(-) (limited to 'tactics') diff --git a/tactics/elim.ml b/tactics/elim.ml index e641f970aa..ef848c2e13 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -10,6 +10,7 @@ open Util open Names open Term open Termops +open EConstr open Inductiveops open Hipattern open Tacmach.New @@ -55,7 +56,7 @@ Another example : *) let elimHypThen tac id = - elimination_then tac (EConstr.mkVar id) + elimination_then tac (mkVar id) let rec general_decompose_on_hyp recognizer = ifOnHyp recognizer (general_decompose_aux recognizer) (fun _ -> Proofview.tclUNIT()) @@ -77,7 +78,6 @@ let tmphyp_name = Id.of_string "_TmpHyp" let up_to_delta = ref false (* true *) let general_decompose recognizer c = - let c = EConstr.of_constr c in Proofview.Goal.enter { enter = begin fun gl -> let type_of = pf_unsafe_type_of gl in let sigma = project gl in @@ -105,17 +105,17 @@ let head_in indl t gl = let decompose_these c l = Proofview.Goal.enter { enter = begin fun gl -> let indl = List.map (fun x -> x, Univ.Instance.empty) l in - general_decompose (fun sigma (_,t) -> head_in indl (EConstr.of_constr t) gl) c + general_decompose (fun sigma (_,t) -> head_in indl t gl) c end } let decompose_and c = general_decompose - (fun sigma (_,t) -> is_record sigma (EConstr.of_constr t)) + (fun sigma (_,t) -> is_record sigma t) c let decompose_or c = general_decompose - (fun sigma (_,t) -> is_disjunction sigma (EConstr.of_constr t)) + (fun sigma (_,t) -> is_disjunction sigma t) c let h_decompose l c = decompose_these c l @@ -127,7 +127,7 @@ let h_decompose_and = decompose_and (* The tactic Double performs a double induction *) let simple_elimination c = - elimination_then (fun _ -> tclIDTAC) (EConstr.of_constr c) + elimination_then (fun _ -> tclIDTAC) c let induction_trailer abs_i abs_j bargs = tclTHEN @@ -135,8 +135,9 @@ let induction_trailer abs_i abs_j bargs = (onLastHypId (fun id -> Proofview.Goal.nf_enter { enter = begin fun gl -> - let idty = pf_unsafe_type_of gl (EConstr.mkVar id) in - let fvty = global_vars (pf_env gl) (project gl) (EConstr.of_constr idty) in + let idty = pf_unsafe_type_of gl (mkVar id) in + let idty = EConstr.of_constr idty in + let fvty = global_vars (pf_env gl) (project gl) idty in let possible_bring_hyps = (List.tl (nLastDecls gl (abs_j - abs_i))) @ bargs.Tacticals.assums in @@ -168,7 +169,7 @@ let double_ind h1 h2 = (onLastHypId (fun id -> elimination_then - (introElimAssumsThen (induction_trailer abs_i abs_j)) (EConstr.mkVar id)))) + (introElimAssumsThen (induction_trailer abs_i abs_j)) (mkVar id)))) end } let h_double_induction = double_ind diff --git a/tactics/elim.mli b/tactics/elim.mli index 29c4414636..dc1af79ba0 100644 --- a/tactics/elim.mli +++ b/tactics/elim.mli @@ -8,6 +8,7 @@ open Names open Term +open EConstr open Tacticals open Misctypes open Tactypes diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index e15ee149d1..e440f1dc51 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -128,7 +128,7 @@ let onClauseLR tac cl gls = tclMAP tac (List.rev (Locusops.simple_clause_of hyps cl)) gls let ifOnHyp pred tac1 tac2 id gl = - if pred (id,pf_get_hyp_typ gl id) then + if pred (id,EConstr.of_constr (pf_get_hyp_typ gl id)) then tac1 id gl else tac2 id gl @@ -583,6 +583,7 @@ module New = struct let ifOnHyp pred tac1 tac2 id = Proofview.Goal.nf_enter { enter = begin fun gl -> let typ = Tacmach.New.pf_get_hyp_typ id gl in + let typ = EConstr.of_constr typ in if pred (id,typ) then tac1 id else diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index 2c3e512806..e4f110722b 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -76,7 +76,7 @@ val nLastDecls : int -> goal sigma -> Context.Named.t val afterHyp : Id.t -> goal sigma -> Context.Named.t -val ifOnHyp : (Id.t * types -> bool) -> +val ifOnHyp : (Id.t * EConstr.types -> bool) -> (Id.t -> tactic) -> (Id.t -> tactic) -> Id.t -> tactic @@ -230,7 +230,7 @@ module New : sig val nLastDecls : ([ `NF ], 'r) Proofview.Goal.t -> int -> Context.Named.t - val ifOnHyp : (identifier * types -> bool) -> + val ifOnHyp : (identifier * EConstr.types -> bool) -> (identifier -> unit Proofview.tactic) -> (identifier -> unit Proofview.tactic) -> identifier -> unit Proofview.tactic -- cgit v1.2.3 From 3f9e56fcbf479999325a86bbdaeefd6a0be13c65 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 18 Nov 2016 20:35:01 +0100 Subject: Equality API using EConstr. --- tactics/autorewrite.ml | 4 +- tactics/class_tactics.ml | 4 +- tactics/eqdecide.ml | 2 +- tactics/equality.ml | 304 ++++++++++++++++++++++++----------------------- tactics/equality.mli | 21 ++-- tactics/hints.ml | 2 +- tactics/inv.ml | 10 +- 7 files changed, 180 insertions(+), 167 deletions(-) (limited to 'tactics') diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index b567344c99..d656206d65 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -122,7 +122,7 @@ let autorewrite ?(conds=Naive) tac_main lbas = Tacticals.New.tclTHEN tac (one_base (fun dir c tac -> let tac = (tac, conds) in - general_rewrite dir AllOccurrences true false ~tac c) + general_rewrite dir AllOccurrences true false ~tac (EConstr.of_constr c)) tac_main bas)) (Proofview.tclUNIT()) lbas)) @@ -165,7 +165,7 @@ let autorewrite_multi_in ?(conds=Naive) idl tac_main lbas = | _ -> assert false) (* there must be at least an hypothesis *) | _ -> assert false (* rewriting cannot complete a proof *) in - let general_rewrite_in x y z w = Proofview.V82.tactic (general_rewrite_in x y z w) in + let general_rewrite_in x y z w = Proofview.V82.tactic (general_rewrite_in x y (EConstr.of_constr z) w) in Tacticals.New.tclMAP (fun id -> Tacticals.New.tclREPEAT_MAIN (Proofview.tclPROGRESS (List.fold_left (fun tac bas -> diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 7d8fc79f4b..02211efd6e 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -1315,8 +1315,8 @@ module Intpart = Unionfind.Make(Evar.Set)(Evar.Map) let deps_of_constraints cstrs evm p = List.iter (fun (_, _, x, y) -> - let evx = Evarutil.undefined_evars_of_term evm x in - let evy = Evarutil.undefined_evars_of_term evm y in + let evx = Evarutil.undefined_evars_of_term evm (EConstr.of_constr x) in + let evy = Evarutil.undefined_evars_of_term evm (EConstr.of_constr y) in Intpart.union_set (Evar.Set.union evx evy) p) cstrs diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml index eb75cbf7dc..be9a342391 100644 --- a/tactics/eqdecide.ml +++ b/tactics/eqdecide.ml @@ -116,7 +116,7 @@ let rec rewrite_and_clear hyps = match hyps with | [] -> Proofview.tclUNIT () | id :: hyps -> tclTHENLIST [ - Equality.rewriteLR (mkVar id); + Equality.rewriteLR (EConstr.mkVar id); clear [id]; rewrite_and_clear hyps; ] diff --git a/tactics/equality.ml b/tactics/equality.ml index 80f83f19bf..4c79a61999 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -12,8 +12,9 @@ open Util open Names open Nameops open Term -open Vars open Termops +open EConstr +open Vars open Namegen open Inductive open Inductiveops @@ -46,6 +47,10 @@ open Context.Named.Declaration module NamedDecl = Context.Named.Declaration +let nlocal_assum (na, t) = + let inj = EConstr.Unsafe.to_constr in + NamedDecl.LocalAssum (na, inj t) + (* Options *) let discriminate_introduction = ref true @@ -144,7 +149,7 @@ let freeze_initial_evars sigma flags clause = (* We take evars of the type: this may include old evars! For excluding *) (* all old evars, including the ones occurring in the rewriting lemma, *) (* we would have to take the clenv_value *) - let newevars = Evd.evars_of_term (EConstr.Unsafe.to_constr (clenv_type clause)) in + let newevars = Evarutil.undefined_evars_of_term sigma (clenv_type clause) in let evars = fold_undefined (fun evk _ evars -> if Evar.Set.mem evk newevars then evars @@ -165,11 +170,9 @@ let side_tac tac sidetac = let instantiate_lemma_all frzevars gl c ty l l2r concl = let env = Proofview.Goal.env gl in - let c = EConstr.of_constr c in - let ty = EConstr.of_constr ty in - let l = Miscops.map_bindings EConstr.of_constr l in + let sigma = project gl in let eqclause = pf_apply Clenv.make_clenv_binding gl (c,ty) l in - let (equiv, args) = decompose_appvect (EConstr.Unsafe.to_constr (Clenv.clenv_type eqclause)) in + let (equiv, args) = decompose_app_vect sigma (Clenv.clenv_type eqclause) in let arglen = Array.length args in let () = if arglen < 2 then error "The term provided is not an applied relation." in let c1 = args.(arglen - 2) in @@ -184,11 +187,9 @@ let instantiate_lemma_all frzevars gl c ty l l2r concl = in List.map try_occ occs let instantiate_lemma gl c ty l l2r concl = - let c = EConstr.of_constr c in let sigma, ct = pf_type_of gl c in let ct = EConstr.of_constr ct in let t = try snd (reduce_to_quantified_ind (pf_env gl) sigma ct) with UserError _ -> ct in - let l = Miscops.map_bindings EConstr.of_constr l in let eqclause = Clenv.make_clenv_binding (pf_env gl) sigma (c,t) l in [eqclause] @@ -332,9 +333,9 @@ let (forward_general_setoid_rewrite_clause, general_setoid_rewrite_clause) = Hoo let jmeq_same_dom gl = function | None -> true (* already checked in Hipattern.find_eq_data_decompose *) | Some t -> - let rels, t = decompose_prod_assum t in + let rels, t = decompose_prod_assum (project gl) t in let env = Environ.push_rel_context rels (Proofview.Goal.env gl) in - match EConstr.decompose_app (project gl) (EConstr.of_constr t) with + match decompose_app (project gl) t with | _, [dom1; _; dom2;_] -> is_conv env (Tacmach.New.project gl) dom1 dom2 | _ -> false @@ -342,6 +343,8 @@ let jmeq_same_dom gl = function eliminate lbeq on sort_of_gl. *) let find_elim hdcncl lft2rgt dep cls ot gl = + let sigma = project gl in + let is_global gr c = Termops.is_global sigma gr c in let inccl = Option.is_empty cls in if (is_global Coqlib.glob_eq hdcncl || (is_global Coqlib.glob_jmeq hdcncl && @@ -349,7 +352,7 @@ let find_elim hdcncl lft2rgt dep cls ot gl = || Flags.version_less_or_equal Flags.V8_2 then let c = - match kind_of_term hdcncl with + match EConstr.kind sigma hdcncl with | Ind (ind_sp,u) -> let pr1 = lookup_eliminator ind_sp (elimination_sort_of_clause cls gl) @@ -377,6 +380,7 @@ let find_elim hdcncl lft2rgt dep cls ot gl = assert false in let Sigma (elim, sigma, p) = Sigma.fresh_global (Global.env ()) (Proofview.Goal.sigma gl) (ConstRef c) in + let elim = EConstr.of_constr elim in Sigma ((elim, Safe_typing.empty_private_constants), sigma, p) else let scheme_name = match dep, lft2rgt, inccl with @@ -391,13 +395,14 @@ let find_elim hdcncl lft2rgt dep cls ot gl = | true, _, true -> rew_r2l_dep_scheme_kind | true, _, false -> rew_r2l_forward_dep_scheme_kind in - match kind_of_term hdcncl with + match EConstr.kind sigma hdcncl with | Ind (ind,u) -> let c, eff = find_scheme scheme_name ind in (* MS: cannot use pf_constr_of_global as the eliminator might be generated by side-effect *) let Sigma (elim, sigma, p) = Sigma.fresh_global (Global.env ()) (Proofview.Goal.sigma gl) (ConstRef c) in + let elim = EConstr.of_constr elim in Sigma ((elim, eff), sigma, p) | _ -> assert false @@ -408,12 +413,12 @@ let type_of_clause cls gl = match cls with let leibniz_rewrite_ebindings_clause cls lft2rgt tac c t l with_evars frzevars dep_proof_ok hdcncl = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let evd = Sigma.to_evar_map (Proofview.Goal.sigma gl) in - let isatomic = isProd (whd_zeta evd (EConstr.of_constr hdcncl)) in + let isatomic = isProd evd (EConstr.of_constr (whd_zeta evd hdcncl)) in let dep_fun = if isatomic then dependent else dependent_no_evar in let type_of_cls = type_of_clause cls gl in - let dep = dep_proof_ok && dep_fun evd (EConstr.of_constr c) (EConstr.of_constr type_of_cls) in + let type_of_cls = EConstr.of_constr type_of_cls in + let dep = dep_proof_ok && dep_fun evd c type_of_cls in let Sigma ((elim, effs), sigma, p) = find_elim hdcncl lft2rgt dep cls (Some t) gl in - let elim = EConstr.of_constr elim in let tac = Proofview.tclEFFECTS effs <*> general_elim_clause with_evars frzevars tac cls c t l @@ -447,11 +452,11 @@ let general_rewrite_ebindings_clause cls lft2rgt occs frzevars dep_proof_ok ?tac Proofview.Goal.enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in - let ctype = get_type_of env sigma (EConstr.of_constr c) in - let rels, t = decompose_prod_assum (whd_betaiotazeta sigma (EConstr.of_constr ctype)) in - match match_with_equality_type sigma (EConstr.of_constr t) with + let ctype = get_type_of env sigma c in + let ctype = EConstr.of_constr ctype in + let rels, t = decompose_prod_assum sigma (EConstr.of_constr (whd_betaiotazeta sigma ctype)) in + match match_with_equality_type sigma t with | Some (hdcncl,args) -> (* Fast path: direct leibniz-like rewrite *) - let hdcncl = EConstr.Unsafe.to_constr hdcncl in let lft2rgt = adjust_rewriting_direction args lft2rgt in leibniz_rewrite_ebindings_clause cls lft2rgt tac c (it_mkProd_or_LetIn t rels) l with_evars frzevars dep_proof_ok hdcncl @@ -465,10 +470,10 @@ let general_rewrite_ebindings_clause cls lft2rgt occs frzevars dep_proof_ok ?tac | (e, info) -> Proofview.tclEVARMAP >>= fun sigma -> let env' = push_rel_context rels env in - let rels',t' = splay_prod_assum env' sigma (EConstr.of_constr t) in (* Search for underlying eq *) - match match_with_equality_type sigma (EConstr.of_constr t') with + let rels',t' = splay_prod_assum env' sigma t in (* Search for underlying eq *) + let t' = EConstr.of_constr t' in + match match_with_equality_type sigma t' with | Some (hdcncl,args) -> - let hdcncl = EConstr.Unsafe.to_constr hdcncl in let lft2rgt = adjust_rewriting_direction args lft2rgt in leibniz_rewrite_ebindings_clause cls lft2rgt tac c (it_mkProd_or_LetIn t' (rels' @ rels)) l with_evars frzevars dep_proof_ok hdcncl @@ -533,7 +538,7 @@ let general_rewrite_clause l2r with_evars ?tac c cl = let do_hyps = (* If the term to rewrite uses an hypothesis H, don't rewrite in H *) let ids gl = - let ids_in_c = Environ.global_vars_set (Global.env()) (fst c) in + let ids_in_c = Termops.global_vars_set (Global.env()) (project gl) (fst c) in let ids_of_hyps = pf_ids_of_hyps gl in Id.Set.fold (fun id l -> List.remove Id.equal id l) ids_in_c ids_of_hyps in @@ -563,7 +568,6 @@ let general_multi_rewrite with_evars l cl tac = let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let (c, sigma) = run_delayed env sigma f in - let c = Miscops.map_with_bindings EConstr.Unsafe.to_constr c in tclWITHHOLES with_evars (general_rewrite_clause l2r with_evars ?tac c cl) sigma end } @@ -631,12 +635,14 @@ let replace_using_leibniz clause c1 c2 l2r unsafe try_prove_eq_opt = in Proofview.Goal.enter { enter = begin fun gl -> let get_type_of = pf_apply get_type_of gl in - let t1 = get_type_of (EConstr.of_constr c1) - and t2 = get_type_of (EConstr.of_constr c2) in + let t1 = get_type_of c1 + and t2 = get_type_of c2 in + let t1 = EConstr.of_constr t1 in + let t2 = EConstr.of_constr t2 in let evd = if unsafe then Some (Tacmach.New.project gl) else - try Some (Evarconv.the_conv_x (Proofview.Goal.env gl) (EConstr.of_constr t1) (EConstr.of_constr t2) (Tacmach.New.project gl)) + try Some (Evarconv.the_conv_x (Proofview.Goal.env gl) t1 t2 (Tacmach.New.project gl)) with Evarconv.UnableToUnify _ -> None in match evd with @@ -647,9 +653,9 @@ let replace_using_leibniz clause c1 c2 l2r unsafe try_prove_eq_opt = 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 -> + let e = EConstr.of_constr e in let eq = applist (e, [t1;c1;c2]) in let sym = EConstr.of_constr sym in - let eq = EConstr.of_constr eq in tclTHENLAST (replace_core clause l2r eq) (tclFIRST @@ -727,12 +733,10 @@ let _ = optwrite = (fun b -> keep_proof_equalities_for_injection := b) } let find_positions env sigma t1 t2 = - let open EConstr in let project env sorts posn t1 t2 = - let t1 = EConstr.Unsafe.to_constr t1 in - let t2 = EConstr.Unsafe.to_constr t2 in - let ty1 = get_type_of env sigma (EConstr.of_constr t1) in - let s = get_sort_family_of env sigma (EConstr.of_constr ty1) in + let ty1 = get_type_of env sigma t1 in + let ty1 = EConstr.of_constr ty1 in + let s = get_sort_family_of env sigma ty1 in if Sorts.List.mem s sorts then [(List.rev posn,t1,t2)] else [] in @@ -854,7 +858,7 @@ let injectable env sigma t1 t2 = let descend_then env sigma head dirn = let IndType (indf,_) = - try find_rectype env sigma (EConstr.of_constr (get_type_of env sigma (EConstr.of_constr head))) + try find_rectype env sigma (EConstr.of_constr (get_type_of env sigma head)) with Not_found -> error "Cannot project on an inductive type derived from a dependency." in let indp,_ = (dest_ind_family indf) in @@ -871,12 +875,12 @@ let descend_then env sigma head dirn = it_mkLambda_or_LetIn (lift (mip.mind_nrealargs+1) resty) deparsign in let build_branch i = let result = if Int.equal i dirn then dirnval else dfltval in - it_mkLambda_or_LetIn_name env result cstr.(i-1).cs_args in + it_mkLambda_or_LetIn result (name_context env cstr.(i-1).cs_args) in let brl = List.map build_branch (List.interval 1 (Array.length mip.mind_consnames)) in let ci = make_case_info env ind RegularStyle in - EConstr.Unsafe.to_constr (Inductiveops.make_case_or_project env sigma indf ci (EConstr.of_constr p) (EConstr.of_constr head) (Array.map_of_list EConstr.of_constr brl)))) + 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: @@ -897,7 +901,7 @@ let descend_then env sigma head dirn = let build_selector env sigma dirn c ind special default = let IndType(indf,_) = - try find_rectype env sigma (EConstr.of_constr ind) + try find_rectype env sigma ind with Not_found -> (* one can find Rel(k) in case of dependent constructors like T := c : (A:Set)A->T and a discrimination @@ -909,7 +913,8 @@ let build_selector env sigma dirn c ind special default = dependent types.") in let (indp,_) = dest_ind_family indf in let ind, _ = check_privacy env indp in - let typ = Retyping.get_type_of env sigma (EConstr.of_constr default) in + let typ = Retyping.get_type_of env sigma default in + let typ = EConstr.of_constr typ in let (mib,mip) = lookup_mind_specif env ind in let deparsign = make_arity_signature env true indf in let p = it_mkLambda_or_LetIn typ deparsign in @@ -922,9 +927,14 @@ let build_selector env sigma dirn c ind special default = let ci = make_case_info env ind RegularStyle in mkCase (ci, p, c, Array.of_list brl) +let build_coq_False () = EConstr.of_constr (build_coq_False ()) +let build_coq_True () = EConstr.of_constr (build_coq_True ()) +let build_coq_I () = EConstr.of_constr (build_coq_I ()) + let rec build_discriminator env sigma dirn c = function | [] -> - let ind = get_type_of env sigma (EConstr.of_constr c) in + let ind = get_type_of env sigma c in + let ind = EConstr.of_constr ind in let true_0,false_0 = build_coq_True(),build_coq_False() in build_selector env sigma dirn c ind true_0 false_0 @@ -952,7 +962,7 @@ let gen_absurdity id = let hyp_typ = EConstr.of_constr hyp_typ in if is_empty_type sigma hyp_typ then - simplest_elim (EConstr.mkVar id) + simplest_elim (mkVar id) else tclZEROMSG (str "Not the negation of an equality.") end } @@ -980,6 +990,7 @@ let discrimination_pf env sigma e (t,t1,t2) discriminator lbeq = let absurd_term = build_coq_False () 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), eff @@ -987,8 +998,6 @@ let eq_baseid = Id.of_string "e" let apply_on_clause (f,t) clause = let sigma = clause.evd in - let f = EConstr.of_constr f in - let t = EConstr.of_constr t in let f_clause = mk_clenv_from_env clause.env sigma None (f,t) in let argmv = (match EConstr.kind sigma (last_arg f_clause.evd f_clause.templval.Evd.rebus) with @@ -997,19 +1006,14 @@ let apply_on_clause (f,t) clause = clenv_fchain ~with_univs:false argmv f_clause clause let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn = - let t = EConstr.Unsafe.to_constr t in - let t1 = EConstr.Unsafe.to_constr t1 in - let t2 = EConstr.Unsafe.to_constr t2 in - let eqn = EConstr.Unsafe.to_constr eqn in 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 e_env = push_named (nlocal_assum (e, t)) env in let 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 let pf_ty = mkArrow eqn absurd_term in let absurd_clause = apply_on_clause (pf,pf_ty) eq_clause in - let absurd_term = EConstr.of_constr absurd_term in let pf = Clenvtac.clenv_value_cast_meta absurd_clause in Proofview.Unsafe.tclEVARS sigma <*> Proofview.tclEFFECTS eff <*> @@ -1047,19 +1051,20 @@ let onNegatedEquality with_evars tac = Proofview.Goal.nf_enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in let ccl = Proofview.Goal.concl gl in + let ccl = EConstr.of_constr ccl in let env = Proofview.Goal.env gl in - match kind_of_term (hnf_constr env sigma (EConstr.of_constr ccl)) with - | Prod (_,t,u) when is_empty_type sigma (EConstr.of_constr u) -> + match EConstr.kind sigma (EConstr.of_constr (hnf_constr env sigma ccl)) with + | Prod (_,t,u) when is_empty_type sigma u -> tclTHEN introf (onLastHypId (fun id -> - onEquality with_evars tac (EConstr.mkVar id,NoBindings))) + onEquality with_evars tac (mkVar id,NoBindings))) | _ -> tclZEROMSG (str "Not a negated primitive equality.") end } let discrSimpleClause with_evars = function | None -> onNegatedEquality with_evars discrEq - | Some id -> onEquality with_evars discrEq (EConstr.mkVar id,NoBindings) + | Some id -> onEquality with_evars discrEq (mkVar id,NoBindings) let discr with_evars = onEquality with_evars discrEq @@ -1073,7 +1078,7 @@ let discrEverywhere with_evars = (tclTHEN (tclREPEAT introf) (tryAllHyps - (fun id -> tclCOMPLETE (discr with_evars (EConstr.mkVar id,NoBindings))))) + (fun id -> tclCOMPLETE (discr with_evars (mkVar id,NoBindings))))) else (* <= 8.2 compat *) tryAllHypsAndConcl (discrSimpleClause with_evars)) (* (fun gls -> @@ -1103,9 +1108,10 @@ let find_sigma_data env s = build_sigma_type () *) let make_tuple env sigma (rterm,rty) lind = - assert (not (EConstr.Vars.noccurn sigma lind (EConstr.of_constr rty))); - let sigdata = find_sigma_data env (get_sort_of env sigma (EConstr.of_constr rty)) in - let sigma, a = type_of ~refresh:true env sigma (EConstr.mkRel lind) in + assert (not (noccurn sigma lind rty)); + let sigdata = find_sigma_data env (get_sort_of env sigma rty) in + let sigma, a = type_of ~refresh:true env sigma (mkRel lind) in + let a = EConstr.of_constr a in let na = Context.Rel.Declaration.get_name (lookup_rel lind env) in (* We move [lind] to [1] and lift other rels > [lind] by 1 *) let rty = lift (1-lind) (liftn lind (lind+1) rty) in @@ -1113,6 +1119,8 @@ let make_tuple env sigma (rterm,rty) lind = let p = mkLambda (na, a, rty) in let sigma, exist_term = Evd.fresh_global env sigma sigdata.intro in let sigma, sig_term = Evd.fresh_global env sigma sigdata.typ in + let exist_term = EConstr.of_constr exist_term in + let sig_term = EConstr.of_constr sig_term in sigma, (applist(exist_term,[a;p;(mkRel lind);rterm]), applist(sig_term,[a;p])) @@ -1125,9 +1133,10 @@ let make_tuple env sigma (rterm,rty) lind = normalization *) let minimal_free_rels env sigma (c,cty) = - let cty_rels = free_rels sigma (EConstr.of_constr cty) in - let cty' = simpl env sigma (EConstr.of_constr cty) in - let rels' = free_rels sigma (EConstr.of_constr cty') in + let cty_rels = free_rels sigma cty in + let cty' = simpl env sigma cty in + let cty' = EConstr.of_constr cty' in + let rels' = free_rels sigma cty' in if Int.Set.subset cty_rels rels' then (cty,cty_rels) else @@ -1139,7 +1148,7 @@ let minimal_free_rels_rec env sigma = let rec minimalrec_free_rels_rec prev_rels (c,cty) = let (cty,direct_rels) = minimal_free_rels env sigma (c,cty) in let combined_rels = Int.Set.union prev_rels direct_rels in - let folder rels i = snd (minimalrec_free_rels_rec rels (c, unsafe_type_of env sigma (EConstr.mkRel i))) + let folder rels i = snd (minimalrec_free_rels_rec rels (c, EConstr.of_constr (unsafe_type_of env sigma (mkRel i)))) in (cty, List.fold_left folder combined_rels (Int.Set.elements (Int.Set.diff direct_rels prev_rels))) in minimalrec_free_rels_rec Int.Set.empty @@ -1185,27 +1194,30 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt = let rec sigrec_clausal_form siglen p_i = if Int.equal siglen 0 then (* is the default value typable with the expected type *) - let dflt_typ = unsafe_type_of env sigma (EConstr.of_constr dflt) in + let dflt_typ = unsafe_type_of env sigma dflt in try - let () = evdref := Evarconv.the_conv_x_leq env (EConstr.of_constr dflt_typ) (EConstr.of_constr p_i) !evdref in + let () = evdref := Evarconv.the_conv_x_leq env (EConstr.of_constr dflt_typ) p_i !evdref in let () = evdref := Evarconv.consider_remaining_unif_problems env !evdref in dflt with Evarconv.UnableToUnify _ -> error "Cannot solve a unification problem." else - let (a,p_i_minus_1) = match whd_beta_stack !evdref (EConstr.of_constr p_i) with - | (_sigS,[a;p]) -> (EConstr.Unsafe.to_constr a, EConstr.Unsafe.to_constr p) + 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 - let ev = Evarutil.e_new_evar env evdref (EConstr.of_constr a) in - let rty = beta_applist sigma (EConstr.of_constr p_i_minus_1,[ev]) in + let ev = Evarutil.e_new_evar env evdref a in + let rty = beta_applist sigma (p_i_minus_1,[ev]) in + let rty = EConstr.of_constr rty in let tuple_tail = sigrec_clausal_form (siglen-1) rty in let evopt = match EConstr.kind !evdref ev with Evar _ -> None | _ -> Some ev in match evopt with | Some w -> let w_type = unsafe_type_of env !evdref w in - if Evarconv.e_cumul env evdref (EConstr.of_constr w_type) (EConstr.of_constr a) then + let w_type = EConstr.of_constr w_type in + if Evarconv.e_cumul env evdref w_type a then let exist_term = Evarutil.evd_comb1 (Evd.fresh_global env) evdref sigdata.intro in - applist(exist_term,[a;p_i_minus_1;EConstr.Unsafe.to_constr w;tuple_tail]) + let exist_term = EConstr.of_constr exist_term in + applist(exist_term,[a;p_i_minus_1;w;tuple_tail]) else error "Cannot solve a unification problem." | None -> @@ -1218,7 +1230,7 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt = error "Cannot solve a unification problem." in let scf = sigrec_clausal_form siglen ty in - !evdref, Evarutil.nf_evar !evdref scf + !evdref, EConstr.of_constr (Evarutil.nf_evar !evdref (EConstr.Unsafe.to_constr scf)) (* The problem is to build a destructor (a generalization of the predecessor) which, when applied to a term made of constructors @@ -1280,18 +1292,18 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt = let make_iterated_tuple env sigma dflt (z,zty) = let (zty,rels) = minimal_free_rels_rec env sigma (z,zty) in - let sort_of_zty = get_sort_of env sigma (EConstr.of_constr zty) in + let sort_of_zty = get_sort_of env sigma zty in let sorted_rels = Int.Set.elements rels in let sigma, (tuple,tuplety) = List.fold_left (fun (sigma, t) -> make_tuple env sigma t) (sigma, (z,zty)) sorted_rels in - assert (closed0 tuplety); + assert (closed0 sigma tuplety); let n = List.length sorted_rels in let sigma, dfltval = sig_clausal_form env sigma sort_of_zty n tuplety dflt in sigma, (tuple,tuplety,dfltval) let rec build_injrec env sigma dflt c = function - | [] -> make_iterated_tuple env sigma dflt (c,unsafe_type_of env sigma (EConstr.of_constr c)) + | [] -> make_iterated_tuple env sigma dflt (c,EConstr.of_constr (unsafe_type_of env sigma c)) | ((sp,cnum),argnum)::l -> try let (cnum_nlams,cnum_env,kont) = descend_then env sigma c cnum in @@ -1326,40 +1338,44 @@ let inject_if_homogenous_dependent_pair ty = try let sigma = Tacmach.New.project gl in let eq,u,(t,t1,t2) = find_this_eq_data_decompose gl ty in - let t = EConstr.Unsafe.to_constr t 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 *) - let eqTypeDest = fst (decompose_app t) in - if not (Globnames.is_global (sigTconstr()) eqTypeDest) then raise Exit; + let eqTypeDest = fst (decompose_app sigma t) in + if not (Termops.is_global sigma (sigTconstr()) eqTypeDest) then raise Exit; let hd1,ar1 = decompose_app_vect sigma t1 and hd2,ar2 = decompose_app_vect sigma t2 in - if not (Globnames.is_global (existTconstr()) hd1) then raise Exit; - if not (Globnames.is_global (existTconstr()) hd2) then raise Exit; - let ind,_ = try pf_apply find_mrectype gl (EConstr.of_constr ar1.(0)) with Not_found -> raise Exit in + let hd1 = EConstr.of_constr hd1 in + let hd2 = EConstr.of_constr hd2 in + let ar1 = Array.map EConstr.of_constr ar1 in + let ar2 = Array.map EConstr.of_constr ar2 in + if not (Termops.is_global sigma (existTconstr()) hd1) then raise Exit; + if not (Termops.is_global sigma (existTconstr()) hd2) then raise Exit; + let ind,_ = try pf_apply find_mrectype gl ar1.(0) with Not_found -> raise Exit in (* check if the user has declared the dec principle *) (* and compare the fst arguments of the dep pair *) (* Note: should work even if not an inductive type, but the table only *) (* knows inductive types *) if not (Ind_tables.check_scheme (!eq_dec_scheme_kind_name()) (fst ind) && - pf_apply is_conv gl (EConstr.of_constr ar1.(2)) (EConstr.of_constr ar2.(2))) then raise Exit; + 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 (EConstr.of_constr ar1.(3));ar1.(3);ar2.(3)|] in + let new_eq_args = [|EConstr.of_constr (pf_unsafe_type_of gl ar1.(3));ar1.(3);ar2.(3)|] in let inj2 = Coqlib.coq_constant "inj_pair2_eq_dec is missing" ["Logic";"Eqdep_dec"] "inj_pair2_eq_dec" in + let inj2 = EConstr.of_constr inj2 in let c, eff = find_scheme (!eq_dec_scheme_kind_name()) (Univ.out_punivs ind) in (* cut with the good equality and prove the requested goal *) tclTHENLIST [Proofview.tclEFFECTS eff; intro; onLastHyp (fun hyp -> - let hyp = EConstr.Unsafe.to_constr hyp in - tclTHENS (cut (EConstr.of_constr (mkApp (ceq,new_eq_args)))) - [clear [destVar hyp]; + tclTHENS (cut (mkApp (ceq,new_eq_args))) + [clear [destVar sigma hyp]; Proofview.V82.tactic (Tacmach.refine - (EConstr.of_constr (mkApp(inj2,[|ar1.(0);mkConst c;ar1.(1);ar1.(2);ar1.(3);ar2.(3);hyp|])))) + (mkApp(inj2,[|ar1.(0);mkConst c;ar1.(1);ar1.(2);ar1.(3);ar2.(3);hyp|]))) ])] with Exit -> Proofview.tclUNIT () @@ -1371,17 +1387,15 @@ let inject_if_homogenous_dependent_pair ty = let simplify_args env sigma t = (* Quick hack to reduce in arguments of eq only *) - match decompose_app t with - | eq, [t;c1;c2] -> applist (eq,[t;simpl env sigma (EConstr.of_constr c1);simpl env sigma (EConstr.of_constr c2)]) - | eq, [t1;c1;t2;c2] -> applist (eq,[t1;simpl env sigma (EConstr.of_constr c1);t2;simpl env sigma (EConstr.of_constr c2)]) + let simpl env sigma c = EConstr.of_constr (simpl env sigma c) in + match decompose_app sigma t with + | eq, [t;c1;c2] -> applist (eq,[t;simpl env sigma c1;simpl env sigma c2]) + | eq, [t1;c1;t2;c2] -> applist (eq,[t1;simpl env sigma c1;t2;simpl env sigma c2]) | _ -> t let inject_at_positions env sigma l2r (eq,_,(t,t1,t2)) eq_clause posns tac = - let t = EConstr.Unsafe.to_constr t in - let t1 = EConstr.Unsafe.to_constr t1 in - let t2 = EConstr.Unsafe.to_constr t2 in let e = next_ident_away eq_baseid (ids_of_context env) in - let e_env = push_named (LocalAssum (e,t)) env in + let e_env = push_named (nlocal_assum (e,t)) env in let evdref = ref sigma in let filter (cpath, t1', t2') = try @@ -1389,12 +1403,13 @@ let inject_at_positions env sigma l2r (eq,_,(t,t1,t2)) eq_clause posns tac = let sigma, (injbody,resty) = build_injector e_env !evdref t1' (mkVar e) cpath in let injfun = mkNamedLambda e t injbody in let sigma,congr = Evd.fresh_global env sigma eq.congr in + let congr = EConstr.of_constr congr in let pf = applist(congr,[t;resty;injfun;t1;t2]) in - let sigma, pf_typ = Typing.type_of env sigma (EConstr.of_constr pf) in + let sigma, pf_typ = Typing.type_of env sigma pf in + let pf_typ = EConstr.of_constr pf_typ in let inj_clause = apply_on_clause (pf,pf_typ) eq_clause in let pf = Clenvtac.clenv_value_cast_meta inj_clause in - let ty = simplify_args env sigma (EConstr.Unsafe.to_constr (clenv_type inj_clause)) in - let pf = EConstr.Unsafe.to_constr pf in + let ty = simplify_args env sigma (clenv_type inj_clause) in evdref := sigma; Some (pf, ty) with Failure _ -> None @@ -1406,9 +1421,9 @@ let inject_at_positions env sigma l2r (eq,_,(t,t1,t2)) eq_clause posns tac = Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (Tacticals.New.tclTHENFIRST (Proofview.tclIGNORE (Proofview.Monad.List.map - (fun (pf,ty) -> tclTHENS (cut (EConstr.of_constr ty)) - [inject_if_homogenous_dependent_pair (EConstr.of_constr ty); - Proofview.V82.tactic (Tacmach.refine (EConstr.of_constr pf))]) + (fun (pf,ty) -> tclTHENS (cut ty) + [inject_if_homogenous_dependent_pair ty; + Proofview.V82.tactic (Tacmach.refine pf)]) (if l2r then List.rev injectors else injectors))) (tac (List.length injectors))) @@ -1428,7 +1443,7 @@ let injEqThen tac l2r (eq,_,(t,t1,t2) as u) eq_clause = tclZEROMSG (str"Nothing to inject.") | Inr posns -> inject_at_positions env sigma l2r u eq_clause posns - (tac (EConstr.Unsafe.to_constr (clenv_value eq_clause))) + (tac (clenv_value eq_clause)) let get_previous_hyp_position id gl = let rec aux dest = function @@ -1451,10 +1466,10 @@ let injEq ?(old=false) with_evars clear_flag ipats = match ipats_style with | Some ipats -> Proofview.Goal.enter { enter = begin fun gl -> - let destopt = match kind_of_term c with + let sigma = project gl in + let destopt = match EConstr.kind sigma c with | Var id -> get_previous_hyp_position id gl | _ -> MoveLast in - let c = EConstr.of_constr c in let clear_tac = tclTRY (apply_clear_request clear_flag dft_clear_flag c) in (* Try should be removal if dependency were treated *) @@ -1488,10 +1503,10 @@ let decompEqThen ntac (lbeq,_,(t,t1,t2) as u) clause = | Inl (cpath, (_,dirn), _) -> discr_positions env sigma u clause cpath dirn | Inr [] -> (* Change: do not fail, simplify clear this trivial hyp *) - ntac (EConstr.Unsafe.to_constr (clenv_value clause)) 0 + ntac (clenv_value clause) 0 | Inr posns -> inject_at_positions env sigma true u clause posns - (ntac (EConstr.Unsafe.to_constr (clenv_value clause))) + (ntac (clenv_value clause)) end } let dEqThen with_evars ntac = function @@ -1500,7 +1515,6 @@ let dEqThen with_evars ntac = function let dEq with_evars = dEqThen with_evars (fun clear_flag c x -> - let c = EConstr.of_constr c in (apply_clear_request clear_flag (use_clear_hyp_by_default ()) c)) let intro_decomp_eq tac data (c, t) = @@ -1547,26 +1561,24 @@ let decomp_tuple_term env sigma c t = let rec decomprec inner_code ex exty = let iterated_decomp = try - let ex = EConstr.of_constr ex in let ({proj1=p1; proj2=p2}),(i,a,p,car,cdr) = find_sigma_data_decompose sigma ex in - let a = EConstr.Unsafe.to_constr a in - let p = EConstr.Unsafe.to_constr p in - let car = EConstr.Unsafe.to_constr car in - let cdr = EConstr.Unsafe.to_constr cdr in let car_code = applist (mkConstU (destConstRef p1,i),[a;p;inner_code]) and cdr_code = applist (mkConstU (destConstRef p2,i),[a;p;inner_code]) in - let cdrtyp = beta_applist sigma (EConstr.of_constr p,[EConstr.of_constr car]) in + let cdrtyp = beta_applist sigma (p,[car]) in + let cdrtyp = EConstr.of_constr cdrtyp in List.map (fun l -> ((car,a),car_code)::l) (decomprec cdr_code cdr cdrtyp) with Constr_matching.PatternMatchingFailure -> [] in [((ex,exty),inner_code)]::iterated_decomp in decomprec (mkRel 1) c t +let lambda_create env (a,b) = + mkLambda (named_hd env (EConstr.Unsafe.to_constr a) Anonymous, a, b) + let subst_tuple_term env sigma dep_pair1 dep_pair2 b = - let dep_pair1 = EConstr.Unsafe.to_constr dep_pair1 in - let dep_pair2 = EConstr.Unsafe.to_constr dep_pair2 in let sigma = Sigma.to_evar_map sigma in - let typ = get_type_of env sigma (EConstr.of_constr dep_pair1) in + let typ = get_type_of env sigma dep_pair1 in + let typ = EConstr.of_constr typ in (* We find all possible decompositions *) let decomps1 = decomp_tuple_term env sigma dep_pair1 typ in let decomps2 = decomp_tuple_term env sigma dep_pair2 typ in @@ -1581,15 +1593,18 @@ let subst_tuple_term env sigma dep_pair1 dep_pair2 b = (* We build the expected goal *) let abst_B = List.fold_right - (fun (e,t) body -> lambda_create env (t,subst_term sigma (EConstr.of_constr e) (EConstr.of_constr body))) e1_list b in - let pred_body = beta_applist sigma (EConstr.of_constr abst_B, List.map EConstr.of_constr proj_list) in + (fun (e,t) body -> lambda_create env (t,EConstr.of_constr (subst_term sigma e body))) e1_list b in + let pred_body = beta_applist sigma (abst_B,proj_list) in + let pred_body = EConstr.of_constr pred_body in let body = mkApp (lambda_create env (typ,pred_body),[|dep_pair1|]) in - let expected_goal = beta_applist sigma (EConstr.of_constr abst_B,List.map (fst %> EConstr.of_constr) e2_list) in + let expected_goal = beta_applist sigma (abst_B,List.map fst e2_list) in (* Simulate now the normalisation treatment made by Logic.mk_refgoals *) - let expected_goal = nf_betaiota sigma (EConstr.of_constr expected_goal) in + let expected_goal = EConstr.of_constr expected_goal in + let expected_goal = nf_betaiota sigma expected_goal in + let expected_goal = EConstr.of_constr expected_goal in (* Retype to get universes right *) - let sigma, expected_goal_ty = Typing.type_of env sigma (EConstr.of_constr expected_goal) in - let sigma, _ = Typing.type_of env sigma (EConstr.of_constr body) in + let sigma, expected_goal_ty = Typing.type_of env sigma expected_goal in + let sigma, _ = Typing.type_of env sigma body in Sigma.Unsafe.of_pair ((body, expected_goal), sigma) (* Like "replace" but decompose dependent equalities *) @@ -1598,16 +1613,14 @@ let subst_tuple_term env sigma dep_pair1 dep_pair2 b = (* on for further iterated sigma-tuples *) let cutSubstInConcl l2r eqn = - let eqn = EConstr.of_constr eqn in Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let (lbeq,u,(t,e1,e2)) = find_eq_data_decompose gl eqn in let typ = pf_concl gl in + let typ = EConstr.of_constr typ in let (e1,e2) = if l2r then (e1,e2) else (e2,e1) in let Sigma ((typ, expected), sigma, p) = subst_tuple_term env sigma e1 e2 typ in - let typ = EConstr.of_constr typ in - let expected = EConstr.of_constr expected in let tac = tclTHENFIRST (tclTHENLIST [ @@ -1620,16 +1633,14 @@ let cutSubstInConcl l2r eqn = end } let cutSubstInHyp l2r eqn id = - let eqn = EConstr.of_constr eqn in Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let (lbeq,u,(t,e1,e2)) = find_eq_data_decompose gl eqn in let typ = pf_get_hyp_typ id gl in + let typ = EConstr.of_constr typ in let (e1,e2) = if l2r then (e1,e2) else (e2,e1) in let Sigma ((typ, expected), sigma, p) = subst_tuple_term env sigma e1 e2 typ in - let typ = EConstr.of_constr typ in - let expected = EConstr.of_constr expected in let tac = tclTHENFIRST (tclTHENLIST [ @@ -1661,9 +1672,9 @@ let cutRewriteInHyp l2r eqn id = cutRewriteClause l2r eqn (Some id) let cutRewriteInConcl l2r eqn = cutRewriteClause l2r eqn None let substClause l2r c cls = - let c = EConstr.of_constr c in Proofview.Goal.enter { enter = begin fun gl -> let eq = pf_apply get_type_of gl c in + let eq = EConstr.of_constr eq in tclTHENS (cutSubstClause l2r eq cls) [Proofview.tclUNIT (); exact_no_check c] end } @@ -1707,7 +1718,7 @@ let restrict_to_eq_and_identity eq = (* compatibility *) not (is_global glob_identity eq) then raise Constr_matching.PatternMatchingFailure -exception FoundHyp of (Id.t * EConstr.constr * bool) +exception FoundHyp of (Id.t * constr * bool) (* tests whether hyp [c] is [x = t] or [t = x], [x] not occurring in [t] *) let is_eq_x gl x d = @@ -1779,7 +1790,7 @@ let subst_one_var dep_proof_ok x = user_err ~hdr:"Subst" (str "Cannot find any non-recursive equality over " ++ pr_id x ++ str".") - with FoundHyp (id, c, b) -> (id, EConstr.Unsafe.to_constr c, b) in + with FoundHyp res -> res in subst_one dep_proof_ok x res end } @@ -1811,15 +1822,14 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () = let find_equations gl = let gl = Proofview.Goal.assume gl in let env = Proofview.Goal.env gl in + let sigma = project gl in let find_eq_data_decompose = find_eq_data_decompose gl in let select_equation_name decl = try let lbeq,u,(_,x,y) = find_eq_data_decompose (EConstr.of_constr (NamedDecl.get_type decl)) in - let x = EConstr.Unsafe.to_constr x in - let y = EConstr.Unsafe.to_constr y in let eq = Universes.constr_of_global_univ (lbeq.eq,u) in if flags.only_leibniz then restrict_to_eq_and_identity eq; - match kind_of_term x, kind_of_term y with + match EConstr.kind sigma x, EConstr.kind sigma y with | Var z, _ when not (is_evaluable env (EvalVarRef z)) -> Some (NamedDecl.get_id decl) | _, Var z when not (is_evaluable env (EvalVarRef z)) -> @@ -1842,14 +1852,12 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () = let c = pf_get_hyp hyp gl |> NamedDecl.get_type in let c = EConstr.of_constr c in let _,_,(_,x,y) = find_eq_data_decompose c in - let x = EConstr.Unsafe.to_constr x in - let y = EConstr.Unsafe.to_constr y in (* J.F.: added to prevent failure on goal containing x=x as an hyp *) - if Term.eq_constr x y then Proofview.tclUNIT () else - match kind_of_term x, kind_of_term y with - | Var x', _ when not (occur_term sigma (EConstr.of_constr x) (EConstr.of_constr y)) && not (is_evaluable env (EvalVarRef x')) -> + 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 (occur_term sigma x y) && not (is_evaluable env (EvalVarRef x')) -> subst_one flags.rewrite_dependent_proof x' (hyp,y,true) - | _, Var y' when not (occur_term sigma (EConstr.of_constr y) (EConstr.of_constr x)) && not (is_evaluable env (EvalVarRef y')) -> + | _, Var y' when not (occur_term sigma y x) && not (is_evaluable env (EvalVarRef y')) -> subst_one flags.rewrite_dependent_proof y' (hyp,x,false) | _ -> Proofview.tclUNIT () @@ -1866,19 +1874,18 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () = or situations like "a = S b, b = S a", or also accidentally unfolding let-ins *) Proofview.Goal.nf_enter { enter = begin fun gl -> + let sigma = project gl in let find_eq_data_decompose = find_eq_data_decompose gl in let test (_,c) = try let c = EConstr.of_constr c in let lbeq,u,(_,x,y) = find_eq_data_decompose c in - let x = EConstr.Unsafe.to_constr x in - let y = EConstr.Unsafe.to_constr y in let eq = Universes.constr_of_global_univ (lbeq.eq,u) in if flags.only_leibniz then restrict_to_eq_and_identity eq; (* J.F.: added to prevent failure on goal containing x=x as an hyp *) - if Term.eq_constr x y then failwith "caught"; - match kind_of_term x with Var x -> x | _ -> - match kind_of_term y with Var y -> y | _ -> failwith "caught" + if EConstr.eq_constr sigma x y then failwith "caught"; + match EConstr.kind sigma x with Var x -> x | _ -> + match EConstr.kind sigma y with Var y -> y | _ -> failwith "caught" with Constr_matching.PatternMatchingFailure -> failwith "caught" in let test p = try Some (test p) with Failure _ -> None in let hyps = pf_hyps_types gl in @@ -1892,24 +1899,21 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () = let cond_eq_term_left c t gl = try - let t = EConstr.of_constr t in let (_,x,_) = pi3 (find_eq_data_decompose gl t) in - if pf_conv_x gl (EConstr.of_constr c) x then true else failwith "not convertible" + if pf_conv_x gl c x then true else failwith "not convertible" with Constr_matching.PatternMatchingFailure -> failwith "not an equality" let cond_eq_term_right c t gl = try - let t = EConstr.of_constr t in let (_,_,x) = pi3 (find_eq_data_decompose gl t) in - if pf_conv_x gl (EConstr.of_constr c) x then false else failwith "not convertible" + if pf_conv_x gl c x then false else failwith "not convertible" with Constr_matching.PatternMatchingFailure -> failwith "not an equality" let cond_eq_term c t gl = try - let t = EConstr.of_constr t in let (_,x,y) = pi3 (find_eq_data_decompose gl t) in - if pf_conv_x gl (EConstr.of_constr c) x then true - else if pf_conv_x gl (EConstr.of_constr c) y then false + if pf_conv_x gl c x then true + else if pf_conv_x gl c y then false else failwith "not convertible" with Constr_matching.PatternMatchingFailure -> failwith "not an equality" @@ -1920,7 +1924,7 @@ let rewrite_assumption_cond cond_eq_term cl = let id = NamedDecl.get_id hyp in begin try - let dir = cond_eq_term (NamedDecl.get_type hyp) gl in + let dir = cond_eq_term (EConstr.of_constr (NamedDecl.get_type hyp)) gl in general_rewrite_clause dir false (mkVar id,NoBindings) cl with | Failure _ | UserError _ -> arec rest gl end @@ -1946,7 +1950,7 @@ let replace_term dir_opt c = (* Declare rewriting tactic for intro patterns "<-" and "->" *) let _ = - let gmr l2r with_evars tac c = general_rewrite_clause l2r with_evars (Miscops.map_with_bindings EConstr.Unsafe.to_constr tac) c in + let gmr l2r with_evars tac c = general_rewrite_clause l2r with_evars tac c in Hook.set Tactics.general_rewrite_clause gmr let _ = Hook.set Tactics.subst_one subst_one diff --git a/tactics/equality.mli b/tactics/equality.mli index 97f51ae202..5467b4af25 100644 --- a/tactics/equality.mli +++ b/tactics/equality.mli @@ -10,6 +10,7 @@ open Names open Term open Evd +open EConstr open Environ open Ind_tables open Locus @@ -60,30 +61,30 @@ val general_rewrite_clause : orientation -> evars_flag -> ?tac:(unit Proofview.tactic * conditions) -> constr with_bindings -> clause -> unit Proofview.tactic val general_multi_rewrite : - evars_flag -> (bool * multi * clear_flag * EConstr.constr with_bindings delayed_open) list -> + evars_flag -> (bool * multi * clear_flag * delayed_open_constr_with_bindings) list -> clause -> (unit Proofview.tactic * conditions) option -> unit Proofview.tactic val replace_in_clause_maybe_by : constr -> constr -> clause -> unit Proofview.tactic option -> unit Proofview.tactic val replace : constr -> constr -> unit Proofview.tactic val replace_by : constr -> constr -> unit Proofview.tactic -> unit Proofview.tactic -val discr : evars_flag -> EConstr.constr with_bindings -> unit Proofview.tactic +val discr : evars_flag -> constr with_bindings -> unit Proofview.tactic val discrConcl : unit Proofview.tactic val discrHyp : Id.t -> unit Proofview.tactic val discrEverywhere : evars_flag -> unit Proofview.tactic val discr_tac : evars_flag -> - EConstr.constr with_bindings destruction_arg option -> unit Proofview.tactic + constr with_bindings destruction_arg option -> unit Proofview.tactic val inj : intro_patterns option -> evars_flag -> - clear_flag -> EConstr.constr with_bindings -> unit Proofview.tactic + clear_flag -> constr with_bindings -> unit Proofview.tactic val injClause : intro_patterns option -> evars_flag -> - EConstr.constr with_bindings destruction_arg option -> unit Proofview.tactic + constr with_bindings destruction_arg option -> unit Proofview.tactic val injHyp : clear_flag -> Id.t -> unit Proofview.tactic val injConcl : unit Proofview.tactic val simpleInjClause : evars_flag -> - EConstr.constr with_bindings destruction_arg option -> unit Proofview.tactic + constr with_bindings destruction_arg option -> unit Proofview.tactic -val dEq : evars_flag -> EConstr.constr with_bindings destruction_arg option -> unit Proofview.tactic -val dEqThen : evars_flag -> (clear_flag -> constr -> int -> unit Proofview.tactic) -> EConstr.constr with_bindings destruction_arg option -> unit Proofview.tactic +val dEq : evars_flag -> constr with_bindings destruction_arg option -> unit Proofview.tactic +val dEqThen : evars_flag -> (clear_flag -> constr -> int -> unit Proofview.tactic) -> constr with_bindings destruction_arg option -> unit Proofview.tactic val make_iterated_tuple : env -> evar_map -> constr -> (constr * types) -> evar_map * (constr * constr * constr) @@ -96,8 +97,8 @@ val cutRewriteInConcl : bool -> constr -> unit Proofview.tactic val rewriteInHyp : bool -> constr -> Id.t -> unit Proofview.tactic val rewriteInConcl : bool -> constr -> unit Proofview.tactic -val discriminable : env -> evar_map -> EConstr.constr -> EConstr.constr -> bool -val injectable : env -> evar_map -> EConstr.constr -> EConstr.constr -> bool +val discriminable : env -> evar_map -> constr -> constr -> bool +val injectable : env -> evar_map -> constr -> constr -> bool (* Subst *) diff --git a/tactics/hints.ml b/tactics/hints.ml index 560e7e43da..c31e863830 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -737,7 +737,7 @@ let secvars_of_idset s = else p) s Id.Pred.empty let secvars_of_constr env c = - secvars_of_idset (global_vars_set env c) + secvars_of_idset (Environ.global_vars_set env c) let secvars_of_global env gr = secvars_of_idset (vars_of_global_reference env gr) diff --git a/tactics/inv.ml b/tactics/inv.ml index c66b356c7d..ad2e2fa3b0 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -113,7 +113,15 @@ let make_inv_predicate env evd indf realargs id status concl = if closed0 ti then (xi,ti,ai) else + let xi = EConstr.of_constr xi in + let ti = EConstr.of_constr ti in + let ai = EConstr.of_constr ai in let sigma, res = make_iterated_tuple env' !evd ai (xi,ti) in + let (xi, ti, ai) = res in + let xi = EConstr.Unsafe.to_constr xi in + let ti = EConstr.Unsafe.to_constr ti in + let ai = EConstr.Unsafe.to_constr ai in + let res = (xi, ti, ai) in evd := sigma; res in let eq_term = eqdata.Coqlib.eq in @@ -334,7 +342,7 @@ let remember_first_eq id x = if !x == MoveLast then x := MoveAfter id let projectAndApply as_mode thin avoid id eqname names depids = let subst_hyp l2r id = - tclTHEN (tclTRY(rewriteInConcl l2r (mkVar id))) + tclTHEN (tclTRY(rewriteInConcl l2r (EConstr.mkVar id))) (if thin then clear [id] else (remember_first_eq id eqname; tclIDTAC)) in let substHypIfVariable tac id = -- cgit v1.2.3 From 118ae18590dbc7d01cf34e0cd6133b1e34ef9090 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 19 Nov 2016 00:20:30 +0100 Subject: Contradiction API using EConstr. --- tactics/contradiction.ml | 49 ++++++++++++++++++++++++++--------------------- tactics/contradiction.mli | 3 ++- 2 files changed, 29 insertions(+), 23 deletions(-) (limited to 'tactics') diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index a92b14dbe9..596f1a7599 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -7,6 +7,7 @@ (************************************************************************) open Term +open EConstr open Hipattern open Tactics open Coqlib @@ -19,6 +20,7 @@ module NamedDecl = Context.Named.Declaration (* Absurd *) let mk_absurd_proof t = + let build_coq_not () = EConstr.of_constr (build_coq_not ()) in let id = Namegen.default_dependent_ident in mkLambda (Names.Name id,mkApp(build_coq_not (),[|t|]), mkLambda (Names.Name id,t,mkApp (mkRel 2,[|mkRel 1|]))) @@ -28,13 +30,13 @@ let absurd c = let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let sigma = Sigma.to_evar_map sigma in - let j = Retyping.get_judgment_of env sigma (EConstr.of_constr c) in + let j = Retyping.get_judgment_of env sigma c in let sigma, j = Coercion.inh_coerce_to_sort Loc.ghost env sigma j in - let t = EConstr.Unsafe.to_constr j.Environ.utj_val in + let t = j.Environ.utj_val in let tac = Tacticals.New.tclTHENLIST [ elim_type (EConstr.of_constr (build_coq_False ())); - Simple.apply (EConstr.of_constr (mk_absurd_proof t)) + Simple.apply (mk_absurd_proof t) ] in Sigma.Unsafe.of_pair (tac, sigma) end } @@ -49,7 +51,7 @@ let use_negated_unit_or_eq_type () = Flags.version_strictly_greater Flags.V8_5 let filter_hyp f tac = let rec seek = function | [] -> Proofview.tclZERO Not_found - | d::rest when f (NamedDecl.get_type d) -> tac (NamedDecl.get_id d) + | d::rest when f (EConstr.of_constr (NamedDecl.get_type d)) -> tac (NamedDecl.get_id d) | _::rest -> seek rest in Proofview.Goal.enter { enter = begin fun gl -> let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in @@ -65,31 +67,33 @@ let contradiction_context = | d :: rest -> let id = NamedDecl.get_id d in let typ = nf_evar sigma (NamedDecl.get_type d) in - let typ = whd_all env sigma (EConstr.of_constr typ) in - if is_empty_type sigma (EConstr.of_constr typ) then - simplest_elim (EConstr.mkVar id) - else match kind_of_term typ with - | Prod (na,t,u) when is_empty_type sigma (EConstr.of_constr u) -> + let typ = EConstr.of_constr typ in + let typ = whd_all env sigma typ in + let typ = EConstr.of_constr typ in + if is_empty_type sigma typ then + simplest_elim (mkVar id) + else match EConstr.kind sigma typ with + | Prod (na,t,u) when is_empty_type sigma u -> let is_unit_or_eq = - if use_negated_unit_or_eq_type () then match_with_unit_or_eq_type sigma (EConstr.of_constr t) + if use_negated_unit_or_eq_type () then match_with_unit_or_eq_type sigma t else None in Tacticals.New.tclORELSE (match is_unit_or_eq with | Some _ -> - let hd,args = decompose_app t in - let (ind,_ as indu) = destInd hd in + let hd,args = decompose_app sigma t in + let (ind,_ as indu) = destInd sigma hd in let nparams = Inductiveops.inductive_nparams_env env ind in let params = Util.List.firstn nparams args in let p = applist ((mkConstructUi (indu,1)), params) in (* Checking on the fly that it type-checks *) - simplest_elim (EConstr.mkApp (EConstr.mkVar id,[|EConstr.of_constr p|])) + simplest_elim (mkApp (mkVar id,[|p|])) | None -> Tacticals.New.tclZEROMSG (Pp.str"Not a negated unit type.")) (Proofview.tclORELSE (Proofview.Goal.enter { enter = begin fun gl -> let is_conv_leq = Tacmach.New.pf_apply is_conv_leq gl in - filter_hyp (fun typ -> is_conv_leq (EConstr.of_constr typ) (EConstr.of_constr t)) - (fun id' -> simplest_elim (EConstr.mkApp (EConstr.mkVar id,[|EConstr.mkVar id'|]))) + filter_hyp (fun typ -> is_conv_leq typ t) + (fun id' -> simplest_elim (mkApp (mkVar id,[|mkVar id'|]))) end }) begin function (e, info) -> match e with | Not_found -> seek_neg rest @@ -102,10 +106,9 @@ let contradiction_context = end } let is_negation_of env sigma typ t = - match kind_of_term (whd_all env sigma t) with + match EConstr.kind sigma (EConstr.of_constr (whd_all env sigma t)) with | Prod (na,t,u) -> - let u = nf_evar sigma u in - is_empty_type sigma (EConstr.of_constr u) && is_conv_leq env sigma (EConstr.of_constr typ) (EConstr.of_constr t) + is_empty_type sigma u && is_conv_leq env sigma typ t | _ -> false let contradiction_term (c,lbind as cl) = @@ -114,8 +117,10 @@ let contradiction_term (c,lbind as cl) = let env = Proofview.Goal.env gl in let type_of = Tacmach.New.pf_unsafe_type_of gl in let typ = type_of c in - let _, ccl = splay_prod env sigma (EConstr.of_constr typ) in - if is_empty_type sigma (EConstr.of_constr ccl) then + let typ = EConstr.of_constr typ in + let _, ccl = splay_prod env sigma typ in + let ccl = EConstr.of_constr ccl in + if is_empty_type sigma ccl then Tacticals.New.tclTHEN (elim false None cl None) (Tacticals.New.tclTRY assumption) @@ -123,8 +128,8 @@ let contradiction_term (c,lbind as cl) = Proofview.tclORELSE begin if lbind = NoBindings then - filter_hyp (fun c -> is_negation_of env sigma typ (EConstr.of_constr c)) - (fun id -> simplest_elim (EConstr.mkApp (EConstr.mkVar id,[|c|]))) + filter_hyp (fun c -> is_negation_of env sigma typ c) + (fun id -> simplest_elim (mkApp (mkVar id,[|c|]))) else Proofview.tclZERO Not_found end diff --git a/tactics/contradiction.mli b/tactics/contradiction.mli index 5cc4b2e013..510b135b0a 100644 --- a/tactics/contradiction.mli +++ b/tactics/contradiction.mli @@ -7,7 +7,8 @@ (************************************************************************) open Term +open EConstr open Misctypes val absurd : constr -> unit Proofview.tactic -val contradiction : EConstr.constr with_bindings option -> unit Proofview.tactic +val contradiction : constr with_bindings option -> unit Proofview.tactic -- cgit v1.2.3 From db252cb87e9c63f400fd4fddd2d771df3160d592 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 19 Nov 2016 01:07:35 +0100 Subject: Inv API using EConstr. --- tactics/contradiction.ml | 1 - tactics/hipattern.ml | 3 ++- tactics/hipattern.mli | 2 +- tactics/inv.ml | 55 +++++++++++++++++++++++------------------------- tactics/inv.mli | 3 ++- tactics/tactics.ml | 6 +++--- 6 files changed, 34 insertions(+), 36 deletions(-) (limited to 'tactics') diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index 596f1a7599..2d5c28eba1 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -119,7 +119,6 @@ let contradiction_term (c,lbind as cl) = let typ = type_of c in let typ = EConstr.of_constr typ in let _, ccl = splay_prod env sigma typ in - let ccl = EConstr.of_constr ccl in if is_empty_type sigma ccl then Tacticals.New.tclTHEN (elim false None cl None) diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml index 6681e5e491..36ed589b99 100644 --- a/tactics/hipattern.ml +++ b/tactics/hipattern.ml @@ -470,10 +470,11 @@ let match_eq_nf gls eqn (ref, hetero) = let n = if hetero then 4 else 3 in let args = List.init n (fun i -> mkGPatVar ("X" ^ string_of_int (i + 1))) in let pat = mkPattern (mkGAppRef ref args) in + let pf_whd_all gls c = EConstr.of_constr (pf_whd_all gls (EConstr.of_constr c)) in match Id.Map.bindings (pf_matches gls pat eqn) with | [(m1,t);(m2,x);(m3,y)] -> assert (Id.equal m1 meta1 && Id.equal m2 meta2 && Id.equal m3 meta3); - (t,pf_whd_all gls (EConstr.of_constr x),pf_whd_all gls (EConstr.of_constr y)) + (EConstr.of_constr t,pf_whd_all gls x,pf_whd_all gls y) | _ -> anomaly ~label:"match_eq" (Pp.str "an eq pattern should match 3 terms") let dest_nf_eq gls eqn = diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli index 094d62df65..c061c50f0b 100644 --- a/tactics/hipattern.mli +++ b/tactics/hipattern.mli @@ -146,7 +146,7 @@ val is_matching_sigma : evar_map -> constr -> bool val match_eqdec : evar_map -> constr -> bool * Constr.constr * Constr.constr * Constr.constr * Constr.constr (** Match an equality up to conversion; returns [(eq,t1,t2)] in normal form *) -val dest_nf_eq : ([ `NF ], 'r) Proofview.Goal.t -> constr -> (Constr.constr * Constr.constr * Constr.constr) +val dest_nf_eq : ([ `NF ], 'r) Proofview.Goal.t -> constr -> (constr * constr * constr) (** Match a negation *) val is_matching_not : evar_map -> constr -> bool diff --git a/tactics/inv.ml b/tactics/inv.ml index ad2e2fa3b0..37c82ff646 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -12,8 +12,9 @@ open Util open Names open Nameops open Term -open Vars open Termops +open EConstr +open Vars open Namegen open Environ open Inductiveops @@ -62,10 +63,10 @@ let var_occurs_in_pf gl id = *) -type inversion_status = Dep of constr option | NoDep +type inversion_status = Dep of EConstr.constr option | NoDep let compute_eqn env sigma n i ai = - (mkRel (n-i),get_type_of env sigma (EConstr.of_constr (mkRel (n-i)))) + (mkRel (n-i),EConstr.of_constr (get_type_of env sigma (mkRel (n-i)))) let make_inv_predicate env evd indf realargs id status concl = let nrealargs = List.length realargs in @@ -76,7 +77,7 @@ let make_inv_predicate env evd indf realargs id status concl = let hyps_arity,_ = get_arity env indf in (hyps_arity,concl) | Dep dflt_concl -> - if not (occur_var env !evd id (EConstr.of_constr concl)) then + if not (occur_var env !evd id concl) then user_err ~hdr:"make_inv_predicate" (str "Current goal does not depend on " ++ pr_id id ++ str"."); (* We abstract the conclusion of goal with respect to @@ -86,13 +87,14 @@ let make_inv_predicate env evd indf realargs id status concl = match dflt_concl with | Some concl -> concl (*assumed it's some [x1..xn,H:I(x1..xn)]C*) | None -> - let sort = get_sort_family_of env !evd (EConstr.of_constr concl) in + let sort = get_sort_family_of env !evd concl in let sort = Evarutil.evd_comb1 (Evd.fresh_sort_in_family env) evd sort in let p = make_arity env true indf sort in + let p = EConstr.of_constr p in let evd',(p,ptyp) = Unification.abstract_list_all env - !evd (EConstr.of_constr p) (EConstr.of_constr concl) (List.map EConstr.of_constr realargs@[EConstr.mkVar id]) - in evd := evd'; EConstr.Unsafe.to_constr p in - let hyps,bodypred = decompose_lam_n_assum (nrealargs+1) pred in + !evd p concl (realargs@[mkVar id]) + in evd := evd'; p in + let hyps,bodypred = decompose_lam_n_assum !evd (nrealargs+1) pred in (* We lift to make room for the equations *) (hyps,lift nrealargs bodypred) in @@ -110,34 +112,28 @@ let make_inv_predicate env evd indf realargs id status concl = let ai = lift nhyps ai in let (xi, ti) = compute_eqn env' !evd nhyps n ai in let (lhs,eqnty,rhs) = - if closed0 ti then + if closed0 !evd ti then (xi,ti,ai) else - let xi = EConstr.of_constr xi in - let ti = EConstr.of_constr ti in - let ai = EConstr.of_constr ai in let sigma, res = make_iterated_tuple env' !evd ai (xi,ti) in - let (xi, ti, ai) = res in - let xi = EConstr.Unsafe.to_constr xi in - let ti = EConstr.Unsafe.to_constr ti in - let ai = EConstr.Unsafe.to_constr ai in - let res = (xi, ti, ai) in evd := sigma; res in let eq_term = eqdata.Coqlib.eq in let eq = Evarutil.evd_comb1 (Evd.fresh_global env) evd eq_term in + let eq = EConstr.of_constr eq in let eqn = applist (eq,[eqnty;lhs;rhs]) in let eqns = (Anonymous, lift n eqn) :: eqns in let refl_term = eqdata.Coqlib.refl in let refl_term = Evarutil.evd_comb1 (Evd.fresh_global env) evd refl_term in + let refl_term = EConstr.of_constr refl_term in let refl = mkApp (refl_term, [|eqnty; rhs|]) in - let _ = Evarutil.evd_comb1 (Typing.type_of env) evd (EConstr.of_constr refl) in + let _ = Evarutil.evd_comb1 (Typing.type_of env) evd refl in let args = refl :: args in build_concl eqns args (succ n) restlist in let (newconcl, args) = build_concl [] [] 0 realargs in - let predicate = it_mkLambda_or_LetIn_name env newconcl hyps in - let _ = Evarutil.evd_comb1 (Typing.type_of env) evd (EConstr.of_constr predicate) in + let predicate = it_mkLambda_or_LetIn newconcl (name_context env hyps) in + let _ = Evarutil.evd_comb1 (Typing.type_of env) evd predicate in (* OK - this predicate should now be usable by res_elimination_then to do elimination on the conclusion. *) predicate, args @@ -347,10 +343,11 @@ let projectAndApply as_mode thin avoid id eqname names depids = in let substHypIfVariable tac id = Proofview.Goal.nf_enter { enter = begin fun gl -> + let sigma = project gl in (** We only look at the type of hypothesis "id" *) let hyp = pf_nf_evar gl (pf_get_hyp_typ id (Proofview.Goal.assume gl)) in let (t,t1,t2) = Hipattern.dest_nf_eq gl (EConstr.of_constr hyp) in - match (kind_of_term t1, kind_of_term t2) with + match (EConstr.kind sigma t1, EConstr.kind sigma t2) with | Var id1, _ -> generalizeRewriteIntros as_mode (subst_hyp true id) depids id1 | _, Var id2 -> generalizeRewriteIntros as_mode (subst_hyp false id) depids id2 | _ -> tac id @@ -444,42 +441,42 @@ let raw_inversion inv_kind id status names = let sigma = Sigma.to_evar_map sigma in let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl gl in + let concl = EConstr.of_constr concl in let c = mkVar id in let (ind, t) = - try pf_apply Tacred.reduce_to_atomic_ind gl (EConstr.of_constr (pf_unsafe_type_of gl (EConstr.of_constr c))) + try pf_apply Tacred.reduce_to_atomic_ind gl (EConstr.of_constr (pf_unsafe_type_of gl c)) with UserError _ -> let msg = str "The type of " ++ pr_id id ++ str " is not inductive." in CErrors.user_err msg in let IndType (indf,realargs) = find_rectype env sigma t in + let realargs = List.map EConstr.of_constr realargs in let evdref = ref sigma in let (elim_predicate, args) = 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 (EConstr.of_constr c) (EConstr.of_constr concl)) then - Reduction.beta_appvect elim_predicate (Array.of_list (realargs@[c])), + if status != NoDep && (dependent sigma c concl) then + Reductionops.beta_applist sigma (elim_predicate, realargs@[c]), case_then_using else - Reduction.beta_appvect elim_predicate (Array.of_list realargs), + Reductionops.beta_applist sigma (elim_predicate, realargs), case_nodep_then_using in let cut_concl = EConstr.of_constr cut_concl in let refined id = let prf = mkApp (mkVar id, args) in - let prf = EConstr.of_constr prf in Refine.refine { run = fun h -> Sigma (prf, h, Sigma.refl) } in let neqns = List.length realargs in let as_mode = names != None in - let elim_predicate = EConstr.of_constr elim_predicate in let tac = (tclTHENS (assert_before Anonymous cut_concl) [case_tac names (introCaseAssumsThen false (* ApplyOn not supported by inversion *) (rewrite_equations_tac as_mode inv_kind id neqns)) - (Some elim_predicate) ind (EConstr.of_constr c,t); + (Some elim_predicate) ind (c,t); onLastHypId (fun id -> tclTHEN (refined id) reflexivity)]) in Sigma.Unsafe.of_pair (tac, sigma) @@ -513,7 +510,7 @@ let inv k = inv_gen k NoDep let inv_tac id = inv FullInversion None (NamedHyp id) let inv_clear_tac id = inv FullInversionClear None (NamedHyp id) -let dinv k c = inv_gen k (Dep (Option.map EConstr.Unsafe.to_constr c)) +let dinv k c = inv_gen k (Dep c) let dinv_tac id = dinv FullInversion None None (NamedHyp id) let dinv_clear_tac id = dinv FullInversionClear None None (NamedHyp id) diff --git a/tactics/inv.mli b/tactics/inv.mli index 6bb2b72829..446a62f6db 100644 --- a/tactics/inv.mli +++ b/tactics/inv.mli @@ -8,6 +8,7 @@ open Names open Term +open EConstr open Misctypes open Tactypes @@ -20,7 +21,7 @@ val inv_clause : val inv : inversion_kind -> or_and_intro_pattern option -> quantified_hypothesis -> unit Proofview.tactic -val dinv : inversion_kind -> EConstr.constr option -> +val dinv : inversion_kind -> constr option -> or_and_intro_pattern option -> quantified_hypothesis -> unit Proofview.tactic val inv_tac : Id.t -> unit Proofview.tactic diff --git a/tactics/tactics.ml b/tactics/tactics.ml index b9da110210..bae1ad48cf 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -4367,6 +4367,7 @@ let clear_unselected_context id inhyps cls = let use_bindings env sigma elim must_be_closed (c,lbind) typ = let sigma = Sigma.to_evar_map sigma in + let typ = EConstr.of_constr typ in let typ = if elim == None then (* w/o an scheme, the term has to be applied at least until @@ -4374,7 +4375,7 @@ let use_bindings env sigma elim must_be_closed (c,lbind) typ = known only by pattern-matching, as in the case of a term of the form "nat_rect ?A ?o ?s n", with ?A to be inferred by matching. *) - let sign,t = splay_prod env sigma (EConstr.of_constr typ) in it_mkProd t sign + let sign,t = splay_prod env sigma typ in it_mkProd t sign else (* Otherwise, we exclude the case of an induction argument in an explicitly functional type. Henceforth, we can complete the @@ -4384,7 +4385,6 @@ let use_bindings env sigma elim must_be_closed (c,lbind) typ = typ in let rec find_clause typ = try - let typ = EConstr.of_constr typ in let indclause = make_clenv_binding env sigma (c,typ) lbind in if must_be_closed && occur_meta indclause.evd (clenv_value indclause) then error "Need a fully applied argument."; @@ -4392,7 +4392,7 @@ let use_bindings env sigma elim must_be_closed (c,lbind) typ = let (sigma, c) = pose_all_metas_as_evars env indclause.evd (clenv_value indclause) in Sigma.Unsafe.of_pair (c, sigma) with e when catchable_exception e -> - try find_clause (try_red_product env sigma (EConstr.of_constr typ)) + try find_clause (EConstr.of_constr (try_red_product env sigma typ)) with Redelimination -> raise e in find_clause typ -- cgit v1.2.3 From 7b43de20a4acd7c9da290f038d9a16fe67eccd59 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 19 Nov 2016 01:59:07 +0100 Subject: Leminv API using EConstr. --- tactics/inv.ml | 1 - tactics/leminv.ml | 50 +++++++++++++++++++++++++++++++++----------------- tactics/tactics.ml | 9 ++++----- 3 files changed, 37 insertions(+), 23 deletions(-) (limited to 'tactics') diff --git a/tactics/inv.ml b/tactics/inv.ml index 37c82ff646..5c296b343f 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -450,7 +450,6 @@ let raw_inversion inv_kind id status names = CErrors.user_err msg in let IndType (indf,realargs) = find_rectype env sigma t in - let realargs = List.map EConstr.of_constr realargs in let evdref = ref sigma in let (elim_predicate, args) = make_inv_predicate env evdref indf realargs id status concl in diff --git a/tactics/leminv.ml b/tactics/leminv.ml index a942384184..62e78b5886 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -11,8 +11,9 @@ open CErrors open Util open Names open Term -open Vars open Termops +open EConstr +open Vars open Namegen open Evd open Printer @@ -31,9 +32,17 @@ open Context.Named.Declaration module NamedDecl = Context.Named.Declaration +let nlocal_assum (na, t) = + let inj = EConstr.Unsafe.to_constr in + NamedDecl.LocalAssum (na, inj t) + +let nlocal_def (na, b, t) = + let inj = EConstr.Unsafe.to_constr in + NamedDecl.LocalDef (na, inj b, inj t) + let no_inductive_inconstr env sigma constr = (str "Cannot recognize an inductive predicate in " ++ - pr_lconstr_env env sigma constr ++ + pr_lconstr_env env sigma (EConstr.Unsafe.to_constr constr) ++ str "." ++ spc () ++ str "If there is one, may be the structure of the arity" ++ spc () ++ str "or of the type of constructors" ++ spc () ++ str "is hidden by constant definitions.") @@ -116,15 +125,15 @@ let max_prefix_sign lid sign = | id::l -> snd (max_rec (id, sign_prefix id sign) l) *) let rec add_prods_sign env sigma t = - match kind_of_term (whd_all env sigma (EConstr.of_constr t)) with + match EConstr.kind sigma (EConstr.of_constr (whd_all env sigma t)) with | Prod (na,c1,b) -> - let id = id_of_name_using_hdchar env t na in + let id = id_of_name_using_hdchar env (EConstr.Unsafe.to_constr t) na in let b'= subst1 (mkVar id) b in - add_prods_sign (push_named (LocalAssum (id,c1)) env) sigma b' + add_prods_sign (push_named (nlocal_assum (id,c1)) env) sigma b' | LetIn (na,c1,t1,b) -> - let id = id_of_name_using_hdchar env t na in + let id = id_of_name_using_hdchar env (EConstr.Unsafe.to_constr t) na in let b'= subst1 (mkVar id) b in - add_prods_sign (push_named (LocalDef (id,c1,t1)) env) sigma b' + add_prods_sign (push_named (nlocal_def (id,c1,t1)) env) sigma b' | _ -> (env,t) (* [dep_option] indicates whether the inversion lemma is dependent or not. @@ -147,6 +156,7 @@ let compute_first_inversion_scheme env sigma ind sort dep_option = let pty,goal = if dep_option then let pty = make_arity env true indf sort in + let pty = EConstr.of_constr pty in let goal = mkProd (Anonymous, mkAppliedInd ind, applist(mkVar p,realargs@[mkRel 1])) @@ -154,7 +164,7 @@ let compute_first_inversion_scheme env sigma ind sort dep_option = pty,goal else let i = mkAppliedInd ind in - let ivars = global_vars env sigma (EConstr.of_constr i) in + let ivars = global_vars env sigma i in let revargs,ownsign = fold_named_context (fun env d (revargs,hyps) -> @@ -169,7 +179,7 @@ let compute_first_inversion_scheme env sigma ind sort dep_option = let goal = mkArrow i (applist(mkVar p, List.rev revargs)) in (pty,goal) in - let npty = nf_all env sigma (EConstr.of_constr pty) in + let npty = nf_all env sigma pty in let extenv = push_named (LocalAssum (p,npty)) env in extenv, goal @@ -183,7 +193,7 @@ let compute_first_inversion_scheme env sigma ind sort dep_option = let inversion_scheme env sigma t sort dep_option inv_op = let (env,i) = add_prods_sign env sigma t in let ind = - try find_rectype env sigma (EConstr.of_constr i) + try find_rectype env sigma i with Not_found -> user_err ~hdr:"inversion_scheme" (no_inductive_inconstr env sigma i) in @@ -192,18 +202,20 @@ let inversion_scheme env sigma t sort dep_option inv_op = in assert (List.subset - (global_vars env sigma (EConstr.of_constr invGoal)) + (global_vars env sigma invGoal) (ids_of_named_context (named_context invEnv))); (* user_err ~hdr:"lemma_inversion" (str"Computed inversion goal was not closed in initial signature."); *) + let invGoal = EConstr.Unsafe.to_constr invGoal in let pf = Proof.start (Evd.from_ctx (evar_universe_context sigma)) [invEnv,invGoal] in let pf = fst (Proof.run_tactic env ( tclTHEN intro (onLastHypId inv_op)) pf) in let pfterm = List.hd (Proof.partial_proof pf) in + let pfterm = EConstr.of_constr pfterm in let global_named_context = Global.named_context_val () in let ownSign = ref begin fold_named_context @@ -216,18 +228,19 @@ let inversion_scheme env sigma t sort dep_option inv_op = let { sigma=sigma } = Proof.V82.subgoals pf in let sigma = Evd.nf_constraints sigma in let rec fill_holes c = - match kind_of_term c with + match EConstr.kind sigma c with | Evar (e,args) -> let h = next_ident_away (Id.of_string "H") !avoid in let ty,inst = Evarutil.generalize_evar_over_rels sigma (e,args) in avoid := h::!avoid; - ownSign := Context.Named.add (LocalAssum (h,ty)) !ownSign; + ownSign := Context.Named.add (nlocal_assum (h,ty)) !ownSign; applist (mkVar h, inst) - | _ -> Constr.map fill_holes c + | _ -> EConstr.map sigma fill_holes c in 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, Evd.universe_context sigma @@ -245,6 +258,7 @@ let add_inversion_lemma_exn na com comsort bool tac = let env = Global.env () in let evd = ref (Evd.from_env env) in let c = Constrintern.interp_type_evars env evd com in + let c = EConstr.of_constr c in let sigma, sort = Pretyping.interp_sort !evd comsort in try add_inversion_lemma na env sigma c sort bool tac @@ -258,14 +272,16 @@ let add_inversion_lemma_exn na com comsort bool tac = let lemInv id c gls = try - let clause = mk_clenv_type_of gls (EConstr.of_constr c) in + let clause = mk_clenv_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 with | NoSuchBinding -> + let c = EConstr.Unsafe.to_constr c in user_err (hov 0 (pr_constr c ++ spc () ++ str "does not refer to an inversion lemma.")) | UserError (a,b) -> + let c = EConstr.Unsafe.to_constr c in user_err ~hdr:"LemInv" (str "Cannot refine current goal with the lemma " ++ pr_lconstr_env (Refiner.pf_env gls) (Refiner.project gls) c) @@ -291,5 +307,5 @@ let lemInvIn id c ids = let lemInvIn_gen id c l = try_intros_until (fun id -> lemInvIn id c l) id let lemInv_clause id c = function - | [] -> lemInv_gen id (EConstr.Unsafe.to_constr c) - | l -> lemInvIn_gen id (EConstr.Unsafe.to_constr c) l + | [] -> lemInv_gen id c + | l -> lemInvIn_gen id c l diff --git a/tactics/tactics.ml b/tactics/tactics.ml index bae1ad48cf..59ffd8b626 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -2896,8 +2896,7 @@ 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' = EConstr.of_constr cl' in + let cl' = it_mkNamedProd_or_LetIn (EConstr.of_constr (Tacmach.pf_concl gl)) to_quantify in let body = if with_let then match EConstr.kind sigma c with @@ -4256,11 +4255,11 @@ let apply_induction_in_context with_evars hyp0 inhyps elim indvars names induct_ let env = Proofview.Goal.env gl in let sigma = Sigma.to_evar_map sigma in let concl = Tacmach.New.pf_nf_concl gl in + let concl = EConstr.of_constr concl in let statuslists,lhyp0,toclear,deps,avoid,dep_in_hyps = cook_sign hyp0 inhyps indvars env sigma in - let dep_in_concl = Option.cata (fun id -> occur_var env sigma id (EConstr.of_constr concl)) false hyp0 in + let dep_in_concl = Option.cata (fun id -> occur_var env sigma id concl) false hyp0 in let dep = dep_in_hyps || dep_in_concl in let tmpcl = it_mkNamedProd_or_LetIn concl deps in - let tmpcl = EConstr.of_constr tmpcl in let s = Retyping.get_sort_family_of env sigma tmpcl in let deps_cstr = List.fold_left @@ -5008,7 +5007,7 @@ let abstract_subproof id gk tac = else (Context.Named.add d s1,s2)) global_sign (Context.Named.empty, empty_named_context_val) in let id = next_global_ident_away id (pf_ids_of_hyps gl) in - let concl = it_mkNamedProd_or_LetIn (Proofview.Goal.concl gl) sign in + let concl = it_mkNamedProd_or_LetIn (EConstr.of_constr (Proofview.Goal.concl gl)) sign in let concl = try flush_and_check_evars !evdref concl with Uninstantiated_evar _ -> -- cgit v1.2.3 From 34e86e839be251717db96f1f5969d7724ab43097 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 19 Nov 2016 02:45:54 +0100 Subject: Hints API using EConstr. --- tactics/auto.ml | 33 ++++----- tactics/auto.mli | 4 +- tactics/class_tactics.ml | 51 +++++++------- tactics/class_tactics.mli | 2 +- tactics/eauto.ml | 32 ++++----- tactics/eauto.mli | 2 +- tactics/hints.ml | 173 +++++++++++++++++++++++++--------------------- tactics/hints.mli | 9 +-- 8 files changed, 162 insertions(+), 144 deletions(-) (limited to 'tactics') diff --git a/tactics/auto.ml b/tactics/auto.ml index 41b56bd3d0..2423ea8788 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -93,7 +93,7 @@ let connect_hint_clenv poly (c, _, ctx) clenv gl = evd = Evd.map_metas map evd; env = Proofview.Goal.env gl; } in - clenv, map c + clenv, emap c else let evd = Evd.merge_context_set Evd.univ_flexible evd ctx in { clenv with evd = evd ; env = Proofview.Goal.env gl }, c @@ -115,7 +115,6 @@ let unify_resolve_gen poly = function let exact poly (c,clenv) = Proofview.Goal.enter { enter = begin fun gl -> let clenv', c = connect_hint_clenv poly c clenv gl in - let c = EConstr.of_constr c in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARUNIVCONTEXT (Evd.evar_universe_context clenv'.evd)) (exact_check c) @@ -141,7 +140,7 @@ let conclPattern concl pat tac = | None -> Proofview.tclUNIT Id.Map.empty | Some pat -> try - Proofview.tclUNIT (Constr_matching.matches env sigma pat (EConstr.of_constr concl)) + Proofview.tclUNIT (Constr_matching.matches env sigma pat concl) with Constr_matching.PatternMatchingFailure -> Tacticals.New.tclZEROMSG (str "conclPattern") in @@ -300,13 +299,13 @@ let flags_of_state st = let auto_flags_of_state st = auto_unif_flags_of full_transparent_state st false -let hintmap_of secvars hdc concl = +let hintmap_of sigma secvars hdc concl = match hdc with | None -> Hint_db.map_none ~secvars | Some hdc -> - if occur_existential Evd.empty (EConstr.of_constr concl) then (** FIXME *) - Hint_db.map_existential ~secvars hdc concl - else Hint_db.map_auto ~secvars hdc concl + if occur_existential sigma concl then + Hint_db.map_existential sigma ~secvars hdc concl + else Hint_db.map_auto sigma ~secvars hdc concl let exists_evaluable_reference env = function | EvalConstRef _ -> true @@ -331,6 +330,7 @@ let rec trivial_fail_db dbg mod_delta db_list local_db = in Proofview.Goal.enter { enter = begin fun gl -> let concl = Tacmach.New.pf_nf_concl gl in + let concl = EConstr.of_constr concl in let sigma = Tacmach.New.project gl in let secvars = compute_secvars gl in Tacticals.New.tclFIRST @@ -339,17 +339,17 @@ let rec trivial_fail_db dbg mod_delta db_list local_db = (trivial_resolve sigma dbg mod_delta db_list local_db secvars concl))) end } -and my_find_search_nodelta db_list local_db secvars hdc concl = +and my_find_search_nodelta sigma db_list local_db secvars hdc concl = List.map (fun hint -> (None,hint)) - (List.map_append (hintmap_of secvars hdc concl) (local_db::db_list)) + (List.map_append (hintmap_of sigma secvars hdc concl) (local_db::db_list)) and my_find_search mod_delta = if mod_delta then my_find_search_delta else my_find_search_nodelta -and my_find_search_delta db_list local_db secvars hdc concl = - let f = hintmap_of secvars hdc concl in - if occur_existential Evd.empty (EConstr.of_constr concl) (** FIXME *) then +and my_find_search_delta sigma db_list local_db secvars hdc concl = + let f = hintmap_of sigma secvars hdc concl in + if occur_existential sigma concl then List.map_append (fun db -> if Hint_db.use_dn db then @@ -371,8 +371,8 @@ and my_find_search_delta db_list local_db secvars hdc concl = match hdc with None -> Hint_db.map_none ~secvars db | Some hdc -> if (Id.Pred.is_empty ids && Cpred.is_empty csts) - then Hint_db.map_auto ~secvars hdc concl db - else Hint_db.map_existential ~secvars hdc concl db + then Hint_db.map_auto sigma ~secvars hdc concl db + else Hint_db.map_existential sigma ~secvars hdc concl db in auto_flags_of_state st, l in List.map (fun x -> (Some flags,x)) l) (local_db::db_list) @@ -414,7 +414,7 @@ and trivial_resolve sigma dbg mod_delta db_list local_db secvars cl = in List.map (tac_of_hint dbg db_list local_db cl) (priority - (my_find_search mod_delta db_list local_db secvars head cl)) + (my_find_search mod_delta sigma db_list local_db secvars head cl)) with Not_found -> [] (** The use of the "core" database can be de-activated by passing @@ -460,7 +460,7 @@ let possible_resolve sigma dbg mod_delta db_list local_db secvars cl = with Bound -> None in List.map (tac_of_hint dbg db_list local_db cl) - (my_find_search mod_delta db_list local_db secvars head cl) + (my_find_search mod_delta sigma db_list local_db secvars head cl) with Not_found -> [] let extend_local_db decl db gl = @@ -491,6 +491,7 @@ let search d n mod_delta db_list local_db = (Tacticals.New.tclORELSE0 (intro_register d (search d n) local_db) ( Proofview.Goal.enter { enter = begin fun gl -> let concl = Tacmach.New.pf_nf_concl gl in + let concl = EConstr.of_constr concl in let sigma = Tacmach.New.project gl in let secvars = compute_secvars gl in let d' = incr_dbg d in diff --git a/tactics/auto.mli b/tactics/auto.mli index 06048ac1c5..403be9e1cc 100644 --- a/tactics/auto.mli +++ b/tactics/auto.mli @@ -23,7 +23,7 @@ val default_search_depth : int ref val auto_flags_of_state : transparent_state -> Unification.unify_flags val connect_hint_clenv : polymorphic -> raw_hint -> clausenv -> - ('a, 'r) Proofview.Goal.t -> clausenv * constr + ('a, 'r) Proofview.Goal.t -> clausenv * EConstr.constr (** Try unification with the precompiled clause, then use registered Apply *) val unify_resolve : polymorphic -> Unification.unify_flags -> (raw_hint * clausenv) -> unit Proofview.tactic @@ -33,7 +33,7 @@ val unify_resolve : polymorphic -> Unification.unify_flags -> (raw_hint * clause [Pattern.somatches], then replace [?1] [?2] metavars in tacast by the right values to build a tactic *) -val conclPattern : constr -> constr_pattern option -> Genarg.glob_generic_argument -> unit Proofview.tactic +val conclPattern : EConstr.constr -> constr_pattern option -> Genarg.glob_generic_argument -> unit Proofview.tactic (** The Auto tactic *) diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 02211efd6e..8ecdd01f23 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -217,6 +217,7 @@ let auto_unif_flags freeze st = } let e_give_exact flags poly (c,clenv) gl = + let open EConstr in let (c, _, _) = c in let c, gl = if poly then @@ -226,7 +227,6 @@ let e_give_exact flags poly (c,clenv) gl = c, {gl with sigma = evd} else c, gl in - let c = EConstr.of_constr c in let t1 = pf_unsafe_type_of gl c in let t1 = EConstr.of_constr t1 in Proofview.V82.of_tactic (Clenvtac.unify ~flags t1 <*> exact_no_check c) gl @@ -245,6 +245,7 @@ let unify_resolve poly flags = { enter = begin fun gls (c,_,clenv) -> (** Application of a lemma using [refine] instead of the old [w_unify] *) let unify_resolve_refine poly flags = + let open EConstr in let open Clenv in { enter = begin fun gls ((c, t, ctx),n,clenv) -> let env = Proofview.Goal.env gls in @@ -262,9 +263,6 @@ let unify_resolve_refine poly flags = let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in sigma, c, t in - let open EConstr in - let ty = EConstr.of_constr ty in - let term = EConstr.of_constr term in let sigma', cl = Clenv.make_evar_clause env sigma ?len:n ty in let term = applist (term, List.map (fun x -> x.hole_evar) cl.cl_holes) in let sigma' = @@ -285,7 +283,6 @@ let clenv_of_prods poly nprods (c, clenv) gl = let (c, _, _) = c in if poly || Int.equal nprods 0 then Some (None, clenv) else - let c = EConstr.of_constr c in let sigma = Tacmach.New.project gl in let ty = Retyping.get_type_of (Proofview.Goal.env gl) sigma c in let ty = EConstr.of_constr ty in @@ -313,7 +310,7 @@ let matches_pattern concl pat = | None -> Proofview.tclUNIT () | Some pat -> let sigma = Sigma.to_evar_map sigma in - if Constr_matching.is_matching env sigma pat (EConstr.of_constr concl) then + if Constr_matching.is_matching env sigma pat concl then Proofview.tclUNIT () else Tacticals.New.tclZEROMSG (str "conclPattern") @@ -367,7 +364,7 @@ let rec e_trivial_fail_db only_classes db_list local_db secvars = Proofview.Goal.nf_enter { enter = begin fun gl -> let tacs = e_trivial_resolve db_list local_db secvars only_classes - (project gl) (pf_concl gl) in + (project gl) (EConstr.of_constr (pf_concl gl)) in tclFIRST (List.map (fun (x,_,_,_,_) -> x) tacs) end} in @@ -379,13 +376,13 @@ let rec e_trivial_fail_db only_classes db_list local_db secvars = and e_my_find_search db_list local_db secvars hdc complete only_classes sigma concl = let open Proofview.Notations in - let prods, concl = decompose_prod_assum concl in + let prods, concl = EConstr.decompose_prod_assum sigma concl in let nprods = List.length prods in let freeze = try let cl = Typeclasses.class_info (fst hdc) in if cl.cl_strict then - Evd.evars_of_term concl + Evarutil.undefined_evars_of_term sigma concl else Evar.Set.empty with e when CErrors.noncritical e -> Evar.Set.empty in @@ -394,8 +391,8 @@ and e_my_find_search db_list local_db secvars hdc complete only_classes sigma co (fun db -> let tacs = if Hint_db.use_dn db then (* Using dnet *) - Hint_db.map_eauto secvars hdc concl db - else Hint_db.map_existential secvars hdc concl db + Hint_db.map_eauto sigma secvars hdc concl db + else Hint_db.map_existential sigma secvars hdc concl db in let flags = auto_unif_flags freeze (Hint_db.transparent_state db) in List.map (fun x -> (flags, x)) tacs) @@ -481,7 +478,7 @@ let catchable = function let pr_depth l = prlist_with_sep (fun () -> str ".") int (List.rev l) let is_Prop env sigma concl = - let ty = Retyping.get_type_of env sigma (EConstr.of_constr concl) in + let ty = Retyping.get_type_of env sigma concl in match kind_of_term ty with | Sort (Prop Null) -> true | _ -> false @@ -542,9 +539,10 @@ let make_resolve_hyp env sigma st flags only_classes pri decl = else false in let is_class = iscl env cty in + let cty = EConstr.of_constr cty in let keep = not only_classes || is_class in if keep then - let c = mkVar id in + let c = EConstr.mkVar id in let name = PathHints [VarRef id] in let hints = if is_class then @@ -552,7 +550,7 @@ let make_resolve_hyp env sigma st flags only_classes pri decl = (List.map_append (fun (path,pri, c) -> make_resolves env sigma ~name:(PathHints path) (true,false,Flags.is_verbose()) pri false - (IsConstr (c,Univ.ContextSet.empty))) + (IsConstr (EConstr.of_constr c,Univ.ContextSet.empty))) hints) else [] in @@ -674,17 +672,16 @@ module V85 = struct let needs_backtrack env evd oev concl = if Option.is_empty oev || is_Prop env evd concl then - occur_existential evd (EConstr.of_constr concl) + occur_existential evd concl else true let hints_tac hints sk fk {it = gl,info; sigma = s} = let env = Goal.V82.env s gl in let concl = Goal.V82.concl s gl in - let concl = EConstr.Unsafe.to_constr concl in let tacgl = {it = gl; sigma = s;} in let secvars = secvars_of_hyps (Environ.named_context_of_val (Goal.V82.hyps s gl)) in let poss = e_possible_resolve hints info.hints secvars info.only_classes s concl in - let unique = is_unique env s (EConstr.of_constr concl) in + let unique = is_unique env s concl in let rec aux i foundone = function | (tac, _, extern, name, pp) :: tl -> let derivs = path_derivate info.auto_cut name in @@ -749,7 +746,7 @@ module V85 = struct let fk' = (fun e -> let do_backtrack = - if unique then occur_existential s' (EConstr.of_constr concl) + if unique then occur_existential s' concl else if info.unique then true else if List.is_empty gls' then needs_backtrack env s' info.is_evar concl @@ -770,7 +767,7 @@ module V85 = struct if foundone == None && !typeclasses_debug > 0 then Feedback.msg_debug (pr_depth info.auto_depth ++ str": no match for " ++ - Printer.pr_constr_env (Goal.V82.env s gl) s concl ++ + Printer.pr_constr_env (Goal.V82.env s gl) s (EConstr.Unsafe.to_constr concl) ++ spc () ++ str ", " ++ int (List.length poss) ++ str" possibilities"); match foundone with @@ -793,7 +790,7 @@ module V85 = struct let fk'' = if not info.unique && List.is_empty gls' && not (needs_backtrack (Goal.V82.env s gl) s - info.is_evar (EConstr.Unsafe.to_constr (Goal.V82.concl s gl))) + info.is_evar (Goal.V82.concl s gl)) then fk else fk' in @@ -984,7 +981,7 @@ module Search = struct NOT backtrack. *) let needs_backtrack env evd unique concl = if unique || is_Prop env evd concl then - occur_existential evd (EConstr.of_constr concl) + occur_existential evd concl else true let mark_unresolvables sigma goals = @@ -1004,14 +1001,15 @@ module Search = struct let open Proofview.Notations in let env = Goal.env gl in let concl = Goal.concl gl in + let concl = EConstr.of_constr concl in let sigma = Goal.sigma gl in let s = Sigma.to_evar_map sigma in - let unique = not info.search_dep || is_unique env s (EConstr.of_constr concl) in + let unique = not info.search_dep || is_unique env s concl in let backtrack = needs_backtrack env s unique concl in if !typeclasses_debug > 0 then Feedback.msg_debug (pr_depth info.search_depth ++ str": looking for " ++ - Printer.pr_constr_env (Goal.env gl) s concl ++ + Printer.pr_constr_env (Goal.env gl) s (EConstr.Unsafe.to_constr concl) ++ (if backtrack then str" with backtracking" else str" without backtracking")); let secvars = compute_secvars gl in @@ -1126,7 +1124,7 @@ module Search = struct if !foundone == false && !typeclasses_debug > 0 then Feedback.msg_debug (pr_depth info.search_depth ++ str": no match for " ++ - Printer.pr_constr_env (Goal.env gl) s concl ++ + Printer.pr_constr_env (Goal.env gl) s (EConstr.Unsafe.to_constr concl) ++ spc () ++ str ", " ++ int (List.length poss) ++ str" possibilities"); match e with @@ -1523,8 +1521,9 @@ let is_ground c gl = let autoapply c i gl = let flags = auto_unif_flags Evar.Set.empty (Hints.Hint_db.transparent_state (Hints.searchtable_map i)) in - let cty = pf_unsafe_type_of gl (EConstr.of_constr c) in - let ce = mk_clenv_from gl (EConstr.of_constr c,EConstr.of_constr cty) in + let cty = pf_unsafe_type_of gl c in + let cty = EConstr.of_constr cty in + let ce = mk_clenv_from gl (c,cty) in let tac = { enter = fun gl -> (unify_e_resolve false flags).enter gl ((c,cty,Univ.ContextSet.empty),0,ce) } in Proofview.V82.of_tactic (Proofview.Goal.nf_enter tac) gl diff --git a/tactics/class_tactics.mli b/tactics/class_tactics.mli index 8db264ad95..027b7dcd76 100644 --- a/tactics/class_tactics.mli +++ b/tactics/class_tactics.mli @@ -30,7 +30,7 @@ val not_evar : constr -> unit Proofview.tactic val is_ground : constr -> tactic -val autoapply : constr -> Hints.hint_db_name -> tactic +val autoapply : EConstr.constr -> Hints.hint_db_name -> tactic module Search : sig val eauto_tac : diff --git a/tactics/eauto.ml b/tactics/eauto.ml index 24e4de7506..5d42ed2d55 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -29,7 +29,6 @@ open Proofview.Notations let eauto_unif_flags = auto_flags_of_state full_transparent_state let e_give_exact ?(flags=eauto_unif_flags) c = - let c = EConstr.of_constr c in Proofview.Goal.enter { enter = begin fun gl -> let t1 = Tacmach.New.pf_unsafe_type_of gl c in let t1 = EConstr.of_constr t1 in @@ -40,7 +39,7 @@ let e_give_exact ?(flags=eauto_unif_flags) c = else exact_check c end } -let assumption id = e_give_exact (mkVar id) +let assumption id = e_give_exact (EConstr.mkVar id) let e_assumption = Proofview.Goal.enter { enter = begin fun gl -> @@ -49,7 +48,7 @@ let e_assumption = let registered_e_assumption = Proofview.Goal.enter { enter = begin fun gl -> - Tacticals.New.tclFIRST (List.map (fun id -> e_give_exact (mkVar id)) + Tacticals.New.tclFIRST (List.map (fun id -> e_give_exact (EConstr.mkVar id)) (Tacmach.New.pf_ids_of_hyps gl)) end } @@ -89,15 +88,14 @@ let rec prolog l n gl = let out_term = function | IsConstr (c, _) -> c - | IsGlobRef gr -> fst (Universes.fresh_global_instance (Global.env ()) gr) + | IsGlobRef gr -> EConstr.of_constr (fst (Universes.fresh_global_instance (Global.env ()) gr)) let prolog_tac l n = Proofview.V82.tactic begin fun gl -> let map c = let (c, sigma) = Tactics.run_delayed (pf_env gl) (project gl) c in - let c = EConstr.Unsafe.to_constr c in let c = pf_apply (prepare_hint false (false,true)) gl (sigma, c) in - EConstr.of_constr (out_term c) + out_term c in let l = List.map map l in try (prolog l n gl) @@ -116,7 +114,6 @@ let priority l = List.map snd (List.filter (fun (pr,_) -> Int.equal pr 0) l) let unify_e_resolve poly flags (c,clenv) = Proofview.Goal.nf_enter { enter = begin fun gl -> let clenv', c = connect_hint_clenv poly c clenv gl in - let c = EConstr.of_constr c in Proofview.V82.tactic (fun gls -> let clenv' = clenv_unique_resolver ~flags clenv' gls in @@ -124,13 +121,13 @@ let unify_e_resolve poly flags (c,clenv) = (Proofview.V82.of_tactic (Tactics.Simple.eapply c)) gls) end } -let hintmap_of secvars hdc concl = +let hintmap_of sigma secvars hdc concl = match hdc with | None -> fun db -> Hint_db.map_none ~secvars db | Some hdc -> - if occur_existential Evd.empty (EConstr.of_constr concl) then (** FIXME *) - (fun db -> Hint_db.map_existential ~secvars hdc concl db) - else (fun db -> Hint_db.map_auto ~secvars hdc concl db) + if occur_existential sigma concl then + (fun db -> Hint_db.map_existential sigma ~secvars hdc concl db) + else (fun db -> Hint_db.map_auto sigma ~secvars hdc concl db) (* FIXME: should be (Hint_db.map_eauto hdc concl db) *) let e_exact poly flags (c,clenv) = @@ -152,13 +149,13 @@ let rec e_trivial_fail_db db_list local_db = let tacl = registered_e_assumption :: (Tacticals.New.tclTHEN Tactics.intro next) :: - (List.map fst (e_trivial_resolve (Tacmach.New.project gl) db_list local_db secvars (Tacmach.New.pf_nf_concl gl))) + (List.map fst (e_trivial_resolve (Tacmach.New.project gl) db_list local_db secvars (EConstr.of_constr (Tacmach.New.pf_nf_concl gl)))) in Tacticals.New.tclFIRST (List.map Tacticals.New.tclCOMPLETE tacl) end } -and e_my_find_search db_list local_db secvars hdc concl = - let hint_of_db = hintmap_of secvars hdc concl in +and e_my_find_search sigma db_list local_db secvars hdc concl = + let hint_of_db = hintmap_of sigma secvars hdc concl in let hintl = List.map_append (fun db -> let flags = auto_flags_of_state (Hint_db.transparent_state db) in @@ -188,13 +185,13 @@ and e_my_find_search db_list local_db secvars hdc concl = and e_trivial_resolve sigma db_list local_db secvars gl = let hd = try Some (decompose_app_bound sigma gl) with Bound -> None in - try priority (e_my_find_search db_list local_db secvars hd gl) + try priority (e_my_find_search sigma db_list local_db secvars hd gl) with Not_found -> [] let e_possible_resolve sigma db_list local_db secvars gl = let hd = try Some (decompose_app_bound sigma gl) with Bound -> None in try List.map (fun (b, (tac, pp)) -> (tac, b, pp)) - (e_my_find_search db_list local_db secvars hd gl) + (e_my_find_search sigma db_list local_db secvars hd gl) with Not_found -> [] let find_first_goal gls = @@ -265,7 +262,7 @@ module SearchProblem = struct let g = find_first_goal lg in let hyps = pf_ids_of_hyps g in let secvars = secvars_of_hyps (pf_hyps g) in - let map_assum id = (e_give_exact (mkVar id), (-1), lazy (str "exact" ++ spc () ++ pr_id id)) in + let map_assum id = (e_give_exact (EConstr.mkVar id), (-1), lazy (str "exact" ++ spc () ++ pr_id id)) in let assumption_tacs = let tacs = List.map map_assum hyps in let l = filter_tactics s.tacres tacs in @@ -293,6 +290,7 @@ module SearchProblem = struct let rec_tacs = let l = let concl = Reductionops.nf_evar (project g)(pf_concl g) in + let concl = EConstr.of_constr concl in filter_tactics s.tacres (e_possible_resolve (project g) s.dblist (List.hd s.localdb) secvars concl) in diff --git a/tactics/eauto.mli b/tactics/eauto.mli index 1f69e4ab3c..defa34d9c6 100644 --- a/tactics/eauto.mli +++ b/tactics/eauto.mli @@ -15,7 +15,7 @@ val e_assumption : unit Proofview.tactic val registered_e_assumption : unit Proofview.tactic -val e_give_exact : ?flags:Unification.unify_flags -> constr -> unit Proofview.tactic +val e_give_exact : ?flags:Unification.unify_flags -> EConstr.constr -> unit Proofview.tactic val prolog_tac : delayed_open_constr list -> int -> unit Proofview.tactic diff --git a/tactics/hints.ml b/tactics/hints.ml index c31e863830..cd5fc79f5e 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -6,12 +6,16 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +module CVars = Vars + open Pp open Util open CErrors open Names -open Vars open Term +open Evd +open EConstr +open Vars open Environ open Mod_subst open Globnames @@ -21,7 +25,6 @@ open Libnames open Smartlocate open Misctypes open Tactypes -open Evd open Termops open Inductiveops open Typing @@ -46,22 +49,29 @@ type debug = Debug | Info | Off exception Bound let head_constr_bound sigma t = - let t = strip_outer_cast sigma (EConstr.of_constr t) in - let _,ccl = decompose_prod_assum t in - let hd,args = decompose_app ccl in - match kind_of_term hd with - | Const _ | Ind _ | Construct _ | Var _ -> hd - | Proj (p, _) -> mkConst (Projection.constant p) - | _ -> raise Bound + let t = strip_outer_cast sigma t in + let t = EConstr.of_constr t in + let _,ccl = decompose_prod_assum sigma t in + let hd,args = decompose_app sigma ccl in + match EConstr.kind sigma hd with + | Const (c, _) -> ConstRef c + | Ind (i, _) -> IndRef i + | Construct (c, _) -> ConstructRef c + | Var id -> VarRef id + | Proj (p, _) -> ConstRef (Projection.constant p) + | _ -> raise Bound let head_constr sigma c = try head_constr_bound sigma c with Bound -> error "Bound head variable." let decompose_app_bound sigma t = - let t = strip_outer_cast sigma (EConstr.of_constr t) in - let _,ccl = decompose_prod_assum t in - let hd,args = decompose_app_vect sigma (EConstr.of_constr ccl) in - match kind_of_term hd with + let t = strip_outer_cast sigma t in + let t = EConstr.of_constr t in + let _,ccl = decompose_prod_assum sigma t in + let hd,args = decompose_app_vect sigma ccl in + let hd = EConstr.of_constr hd in + let args = Array.map EConstr.of_constr args in + match EConstr.kind sigma hd with | Const (c,u) -> ConstRef c, args | Ind (i,u) -> IndRef i, args | Construct (c,u) -> ConstructRef c, args @@ -245,6 +255,7 @@ let rebuild_dn st se = { se with sentry_bnet = dn' } let lookup_tacs concl st se = + let concl = EConstr.Unsafe.to_constr concl in let l' = Bounded_net.lookup st se.sentry_bnet concl in let sl' = List.stable_sort pri_order_int l' in List.merge pri_order_int se.sentry_nopat sl' @@ -256,10 +267,10 @@ let is_transparent_gr (ids, csts) = function | ConstRef cst -> Cpred.mem cst csts | IndRef _ | ConstructRef _ -> false -let strip_params env c = - match kind_of_term c with +let strip_params env sigma c = + match EConstr.kind sigma c with | App (f, args) -> - (match kind_of_term f with + (match EConstr.kind sigma f with | Const (p,_) -> let cb = lookup_constant p env in (match cb.Declarations.const_proj with @@ -276,11 +287,9 @@ let strip_params env c = let instantiate_hint env sigma p = let mk_clenv (c, cty, ctx) = let sigma = Evd.merge_context_set univ_flexible sigma ctx in - let c = EConstr.of_constr c in - let cty = EConstr.of_constr cty in let cl = mk_clenv_from_env env sigma None (c,cty) in {cl with templval = - { cl.templval with rebus = EConstr.of_constr (strip_params env (EConstr.Unsafe.to_constr cl.templval.rebus)) }; + { cl.templval with rebus = strip_params env sigma cl.templval.rebus }; env = empty_env} in let code = match p.code.obj with @@ -445,11 +454,11 @@ val empty : ?name:hint_db_name -> transparent_state -> bool -> t val find : global_reference -> t -> search_entry val map_none : secvars:Id.Pred.t -> t -> full_hint list val map_all : secvars:Id.Pred.t -> global_reference -> t -> full_hint list -val map_existential : secvars:Id.Pred.t -> +val map_existential : evar_map -> secvars:Id.Pred.t -> (global_reference * constr array) -> constr -> t -> full_hint list -val map_eauto : secvars:Id.Pred.t -> +val map_eauto : evar_map -> secvars:Id.Pred.t -> (global_reference * constr array) -> constr -> t -> full_hint list -val map_auto : secvars:Id.Pred.t -> +val map_auto : evar_map -> secvars:Id.Pred.t -> (global_reference * constr array) -> constr -> t -> full_hint list val add_one : env -> evar_map -> hint_entry -> t -> t val add_list : env -> evar_map -> hint_entry list -> t -> t @@ -505,21 +514,21 @@ struct (** Warn about no longer typable hint? *) None - let match_mode m arg = + let match_mode sigma m arg = match m with - | ModeInput -> not (occur_existential Evd.empty (EConstr.of_constr arg)) (** FIXME *) + | ModeInput -> not (occur_existential sigma arg) | ModeNoHeadEvar -> - Evarutil.(try ignore(head_evar arg); false + Evarutil.(try ignore(head_evar sigma arg); false with NoHeadEvar -> true) | ModeOutput -> true - let matches_mode args mode = + let matches_mode sigma args mode = Array.length mode == Array.length args && - Array.for_all2 match_mode mode args + Array.for_all2 (match_mode sigma) mode args - let matches_modes args modes = + let matches_modes sigma args modes = if List.is_empty modes then true - else List.exists (matches_mode args) modes + else List.exists (matches_mode sigma args) modes let merge_entry secvars db nopat pat = let h = List.sort pri_order_int (List.map snd db.hintdb_nopat) in @@ -535,22 +544,22 @@ struct merge_entry secvars db se.sentry_nopat se.sentry_pat (** Precondition: concl has no existentials *) - let map_auto ~secvars (k,args) concl db = + let map_auto sigma ~secvars (k,args) concl db = let se = find k db in let st = if db.use_dn then (Some db.hintdb_state) else None in let pat = lookup_tacs concl st se in merge_entry secvars db [] pat - let map_existential ~secvars (k,args) concl db = + let map_existential sigma ~secvars (k,args) concl db = let se = find k db in - if matches_modes args se.sentry_mode then + if matches_modes sigma args se.sentry_mode then merge_entry secvars db se.sentry_nopat se.sentry_pat else merge_entry secvars db [] [] (* [c] contains an existential *) - let map_eauto ~secvars (k,args) concl db = + let map_eauto sigma ~secvars (k,args) concl db = let se = find k db in - if matches_modes args se.sentry_mode then + if matches_modes sigma args se.sentry_mode then let st = if db.use_dn then Some db.hintdb_state else None in let pat = lookup_tacs concl st se in merge_entry secvars db [] pat @@ -718,8 +727,8 @@ let _ = Summary.declare_summary "search" (* Auxiliary functions to prepare AUTOHINT objects *) (**************************************************************************) -let rec nb_hyp c = match kind_of_term c with - | Prod(_,_,c2) -> if noccurn 1 c2 then 1+(nb_hyp c2) else nb_hyp c2 +let rec nb_hyp sigma c = match EConstr.kind sigma c with + | Prod(_,_,c2) -> if noccurn sigma 1 c2 then 1+(nb_hyp sigma c2) else nb_hyp sigma c2 | _ -> 0 (* adding and removing tactics in the search table *) @@ -736,19 +745,20 @@ let secvars_of_idset s = Id.Pred.add id p else p) s Id.Pred.empty -let secvars_of_constr env c = - secvars_of_idset (Environ.global_vars_set env c) +let secvars_of_constr env sigma c = + secvars_of_idset (Termops.global_vars_set env sigma c) let secvars_of_global env gr = secvars_of_idset (vars_of_global_reference env gr) let make_exact_entry env sigma pri poly ?(name=PathAny) (c, cty, ctx) = - let secvars = secvars_of_constr env c in - let cty = strip_outer_cast sigma (EConstr.of_constr cty) in - match kind_of_term cty with + let secvars = secvars_of_constr env sigma c in + let cty = strip_outer_cast sigma cty in + let cty = EConstr.of_constr cty in + match EConstr.kind sigma cty with | Prod _ -> failwith "make_exact_entry" | _ -> - let pat = Patternops.pattern_of_constr env sigma (EConstr.of_constr cty) in + let pat = Patternops.pattern_of_constr env sigma cty in let hd = try head_pattern_bound pat with BoundPattern -> failwith "make_exact_entry" @@ -763,21 +773,21 @@ let make_exact_entry env sigma pri poly ?(name=PathAny) (c, cty, ctx) = code = with_uid (Give_exact (c, cty, ctx)); }) let make_apply_entry env sigma (eapply,hnf,verbose) pri poly ?(name=PathAny) (c, cty, ctx) = - let cty = if hnf then hnf_constr env sigma (EConstr.of_constr cty) else cty in - match kind_of_term cty with + let cty = if hnf then EConstr.of_constr (hnf_constr env sigma cty) else cty in + match EConstr.kind sigma cty with | Prod _ -> let sigma' = Evd.merge_context_set univ_flexible sigma ctx in - let ce = mk_clenv_from_env env sigma' None (EConstr.of_constr c,EConstr.of_constr cty) in + let ce = mk_clenv_from_env env sigma' None (c,cty) in let c' = clenv_type (* ~reduce:false *) ce in let pat = Patternops.pattern_of_constr env ce.evd c' in let hd = try head_pattern_bound pat with BoundPattern -> failwith "make_apply_entry" in let nmiss = List.length (clenv_missing ce) in - let secvars = secvars_of_constr env c in + let secvars = secvars_of_constr env sigma c in if Int.equal nmiss 0 then (Some hd, - { pri = (match pri with None -> nb_hyp cty | Some p -> p); + { pri = (match pri with None -> nb_hyp sigma' cty | Some p -> p); poly = poly; pat = Some pat; name = name; @@ -787,10 +797,10 @@ let make_apply_entry env sigma (eapply,hnf,verbose) pri poly ?(name=PathAny) (c, else begin if not eapply then failwith "make_apply_entry"; if verbose then - Feedback.msg_info (str "the hint: eapply " ++ pr_lconstr c ++ + Feedback.msg_info (str "the hint: eapply " ++ pr_lconstr (EConstr.Unsafe.to_constr c) ++ str " will only be used by eauto"); (Some hd, - { pri = (match pri with None -> nb_hyp cty + nmiss | Some p -> p); + { pri = (match pri with None -> nb_hyp sigma' cty + nmiss | Some p -> p); poly = poly; pat = Some pat; name = name; @@ -808,7 +818,7 @@ let pr_hint_term env sigma ctx = function | IsGlobRef gr -> pr_global gr | IsConstr (c, ctx) -> let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in - pr_constr_env env sigma c + pr_constr_env env sigma (EConstr.Unsafe.to_constr c) (** We need an object to record the side-effect of registering global universes associated with a hint. *) @@ -834,7 +844,8 @@ let fresh_global_or_constr env sigma poly cr = let isgr, (c, ctx) = match cr with | IsGlobRef gr -> - true, Universes.fresh_global_instance env gr + let (c, ctx) = Universes.fresh_global_instance env gr in + true, (EConstr.of_constr c, ctx) | IsConstr (c, ctx) -> false, (c, ctx) in if poly then (c, ctx) @@ -848,7 +859,8 @@ let fresh_global_or_constr env sigma poly cr = let make_resolves env sigma flags pri poly ?name cr = let c, ctx = fresh_global_or_constr env sigma poly cr in - let cty = Retyping.get_type_of env sigma (EConstr.of_constr c) in + let cty = Retyping.get_type_of env sigma c in + let cty = EConstr.of_constr cty in let try_apply f = try Some (f (c, cty, ctx)) with Failure _ -> None in let ents = List.map_filter try_apply @@ -857,7 +869,7 @@ let make_resolves env sigma flags pri poly ?name cr = in if List.is_empty ents then user_err ~hdr:"Hint" - (pr_lconstr c ++ spc() ++ + (pr_lconstr (EConstr.Unsafe.to_constr c) ++ spc() ++ (if pi1 flags then str"cannot be used as a hint." else str "can be used as a hint only for eauto.")); ents @@ -869,7 +881,7 @@ let make_resolve_hyp env sigma decl = try [make_apply_entry env sigma (true, true, false) None false ~name:(PathHints [VarRef hname]) - (c, NamedDecl.get_type decl, Univ.ContextSet.empty)] + (c, EConstr.of_constr (NamedDecl.get_type decl), Univ.ContextSet.empty)] with | Failure _ -> [] | e when Logic.catchable_exception e -> anomaly (Pp.str "make_resolve_hyp") @@ -899,6 +911,7 @@ let make_extern pri pat tacast = code = with_uid (Extern tacast) }) let make_mode ref m = + let open Term in let ty = Global.type_of_global_unsafe ref in let ctx, t = decompose_prod ty in let n = List.length ctx in @@ -912,15 +925,16 @@ let make_mode ref m = let make_trivial env sigma poly ?(name=PathAny) r = let c,ctx = fresh_global_or_constr env sigma poly r in let sigma = Evd.merge_context_set univ_flexible sigma ctx in - let t = hnf_constr env sigma (EConstr.of_constr (unsafe_type_of env sigma (EConstr.of_constr c))) in - let hd = head_of_constr_reference sigma (EConstr.of_constr (head_constr sigma t)) in - let ce = mk_clenv_from_env env sigma None (EConstr.of_constr c,EConstr.of_constr t) in + let t = hnf_constr env sigma (EConstr.of_constr (unsafe_type_of env sigma c)) in + let t = EConstr.of_constr t in + let hd = head_constr sigma t in + let ce = mk_clenv_from_env env sigma None (c,t) in (Some hd, { pri=1; poly = poly; pat = Some (Patternops.pattern_of_constr env ce.evd (clenv_type ce)); name = name; db = None; - secvars = secvars_of_constr env c; + secvars = secvars_of_constr env sigma c; code= with_uid (Res_pf_THEN_trivial_fail(c,t,ctx)) }) @@ -1014,14 +1028,16 @@ let cache_autohint (kn, obj) = let subst_autohint (subst, obj) = let subst_key gr = let (lab'', elab') = subst_global subst gr in + let elab' = EConstr.of_constr elab' in let gr' = - (try head_of_constr_reference Evd.empty (EConstr.of_constr (head_constr_bound Evd.empty (** FIXME *) elab')) + (try head_constr_bound Evd.empty elab' with Bound -> lab'') in if gr' == gr then gr else gr' in let subst_hint (k,data as hint) = let k' = Option.smartmap subst_key k in let pat' = Option.smartmap (subst_pattern subst) data.pat in + let subst_mps subst c = EConstr.of_constr (subst_mps subst (EConstr.Unsafe.to_constr c)) in let code' = match data.code.obj with | Res_pf (c,t,ctx) -> let c' = subst_mps subst c in @@ -1191,31 +1207,33 @@ let prepare_hint check (poly,local) env init (sigma,c) = It is actually a bit stupid to generalize over evars since the first thing make_resolves will do is to re-instantiate the products *) let sigma, subst = Evd.nf_univ_variables sigma in - let c = Vars.subst_univs_constr subst (Evarutil.nf_evar sigma c) in - let c = drop_extra_implicit_args sigma (EConstr.of_constr c) in - let vars = ref (collect_vars sigma (EConstr.of_constr c)) in + let c = Evarutil.nf_evar sigma (EConstr.Unsafe.to_constr c) in + let c = CVars.subst_univs_constr subst c in + let c = EConstr.of_constr c in + let c = drop_extra_implicit_args sigma c in + let vars = ref (collect_vars sigma c) in let subst = ref [] in - let rec find_next_evar c = match kind_of_term c with + let rec find_next_evar c = match EConstr.kind sigma c with | Evar (evk,args as ev) -> (* We skip the test whether args is the identity or not *) - let t = Evarutil.nf_evar sigma (existential_type sigma ev) in - let t = List.fold_right (fun (e,id) c -> replace_term sigma (EConstr.of_constr e) (EConstr.of_constr id) (EConstr.of_constr c)) !subst t in - if not (closed0 c) then + let t = existential_type sigma ev in + let t = List.fold_right (fun (e,id) c -> EConstr.of_constr (replace_term sigma e id c)) !subst t in + if not (closed0 sigma c) then error "Hints with holes dependent on a bound variable not supported."; - if occur_existential sigma (EConstr.of_constr t) then + if occur_existential sigma t then (* Not clever enough to construct dependency graph of evars *) error "Not clever enough to deal with evars dependent in other evars."; raise (Found (c,t)) - | _ -> Constr.iter find_next_evar c in + | _ -> EConstr.iter sigma find_next_evar c in let rec iter c = try find_next_evar c; c with Found (evar,t) -> let id = next_ident_away_from default_prepare_hint_ident (fun id -> Id.Set.mem id !vars) in vars := Id.Set.add id !vars; subst := (evar,mkVar id)::!subst; - mkNamedLambda id t (iter (replace_term sigma (EConstr.of_constr evar) (EConstr.mkVar id) (EConstr.of_constr c))) in + mkNamedLambda id t (iter (EConstr.of_constr (replace_term sigma evar (mkVar id) c))) in let c' = iter c in - if check then Pretyping.check_evars (Global.env()) Evd.empty sigma (EConstr.of_constr c'); + if check then Pretyping.check_evars (Global.env()) Evd.empty sigma c'; let diff = Univ.ContextSet.diff (Evd.universe_context_set sigma) (Evd.universe_context_set init) in if poly then IsConstr (c', diff) else if local then IsConstr (c', diff) @@ -1228,6 +1246,7 @@ let interp_hints poly = let sigma = Evd.from_env env in let f poly c = let evd,c = Constrintern.interp_open_constr env sigma c in + let c = EConstr.of_constr c in prepare_hint true (poly,false) (Global.env()) Evd.empty (evd,c) in let fref r = let gr = global_with_alias r in @@ -1293,7 +1312,7 @@ let add_hints local dbnames0 h = let expand_constructor_hints env sigma lems = List.map_append (fun (evd,lem) -> - match kind_of_term lem with + match EConstr.kind sigma lem with | Ind (ind,u) -> List.init (nconstructors ind) (fun i -> @@ -1320,7 +1339,7 @@ let make_local_hint_db env sigma ts eapply lems = let map c = let sigma = Sigma.Unsafe.of_evar_map sigma in let Sigma (c, sigma, _) = c.delayed env sigma in - (Sigma.to_evar_map sigma, EConstr.Unsafe.to_constr c) + (Sigma.to_evar_map sigma, c) in let lems = List.map map lems in let sign = Environ.named_context env in @@ -1348,7 +1367,7 @@ let make_db_list dbnames = (* Functions for printing the hints *) (**************************************************************************) -let pr_hint_elt (c, _, _) = pr_constr c +let pr_hint_elt (c, _, _) = pr_constr (EConstr.Unsafe.to_constr c) let pr_hint h = match h.obj with | Res_pf (c, _) -> (str"simple apply " ++ pr_hint_elt c) @@ -1402,9 +1421,9 @@ let pr_hint_term sigma cl = let valid_dbs = let fn = try let hdc = decompose_app_bound sigma cl in - if occur_existential sigma (EConstr.of_constr cl) then - Hint_db.map_existential ~secvars:Id.Pred.full hdc cl - else Hint_db.map_auto ~secvars:Id.Pred.full hdc cl + if occur_existential sigma cl then + Hint_db.map_existential sigma ~secvars:Id.Pred.full hdc cl + else Hint_db.map_auto sigma ~secvars:Id.Pred.full hdc cl with Bound -> Hint_db.map_none ~secvars:Id.Pred.full in let fn db = List.map (fun x -> 0, x) (fn db) in @@ -1425,7 +1444,7 @@ let pr_applicable_hint () = match glss.Evd.it with | [] -> CErrors.error "No focused goal." | g::_ -> - pr_hint_term glss.Evd.sigma (EConstr.Unsafe.to_constr (Goal.V82.concl glss.Evd.sigma g)) + pr_hint_term glss.Evd.sigma (Goal.V82.concl glss.Evd.sigma g) let pp_hint_mode = function | ModeInput -> str"+" diff --git a/tactics/hints.mli b/tactics/hints.mli index c0eb2c3b86..344827e03e 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -10,6 +10,7 @@ open Pp open Util open Names open Term +open EConstr open Environ open Globnames open Decl_kinds @@ -99,16 +100,16 @@ module Hint_db : (** All hints associated to the reference, respecting modes if evars appear in the arguments, _not_ using the discrimination net. *) - val map_existential : secvars:Id.Pred.t -> + val map_existential : evar_map -> secvars:Id.Pred.t -> (global_reference * constr array) -> constr -> t -> full_hint list (** All hints associated to the reference, respecting modes if evars appear in the arguments and using the discrimination net. *) - val map_eauto : secvars:Id.Pred.t -> (global_reference * constr array) -> constr -> t -> full_hint list + val map_eauto : evar_map -> secvars:Id.Pred.t -> (global_reference * constr array) -> constr -> t -> full_hint list (** All hints associated to the reference, respecting modes if evars appear in the arguments. *) - val map_auto : secvars:Id.Pred.t -> + val map_auto : evar_map -> secvars:Id.Pred.t -> (global_reference * constr array) -> constr -> t -> full_hint list val add_one : env -> evar_map -> hint_entry -> t -> t @@ -170,7 +171,7 @@ val add_hints : locality_flag -> hint_db_name list -> hints_entry -> unit val prepare_hint : bool (* Check no remaining evars *) -> (bool * bool) (* polymorphic or monomorphic, local or global *) -> - env -> evar_map -> open_constr -> hint_term + env -> evar_map -> evar_map * constr -> hint_term (** [make_exact_entry pri (c, ctyp, ctx, secvars)]. [c] is the term given as an exact proof to solve the goal; -- cgit v1.2.3 From 372b092aea6d077fe0a82eac74d742da8998c7ad Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Nov 2016 00:27:08 +0100 Subject: Auto API using EConstr. --- tactics/auto.ml | 9 +++++---- tactics/auto.mli | 5 +++-- 2 files changed, 8 insertions(+), 6 deletions(-) (limited to 'tactics') diff --git a/tactics/auto.ml b/tactics/auto.ml index 2423ea8788..c34f9dd923 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -6,14 +6,15 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -(* -*) +module CVars = Vars + open Pp open Util open CErrors open Names open Vars open Termops +open EConstr open Environ open Tacmach open Genredexpr @@ -83,8 +84,8 @@ let connect_hint_clenv poly (c, _, ctx) clenv gl = if poly then (** Refresh the instance of the hint *) let (subst, ctx) = Universes.fresh_universe_context_set_instance ctx in - let map c = Vars.subst_univs_level_constr subst c in - let emap c = EConstr.Vars.subst_univs_level_constr subst c in + let map c = CVars.subst_univs_level_constr subst c in + let emap c = Vars.subst_univs_level_constr subst c in let evd = Evd.merge_context_set Evd.univ_flexible evd ctx in (** Only metas are mentioning the old universes. *) let clenv = { diff --git a/tactics/auto.mli b/tactics/auto.mli index 403be9e1cc..b0ecb4660b 100644 --- a/tactics/auto.mli +++ b/tactics/auto.mli @@ -10,6 +10,7 @@ open Names open Term +open EConstr open Clenv open Pattern open Decl_kinds @@ -23,7 +24,7 @@ val default_search_depth : int ref val auto_flags_of_state : transparent_state -> Unification.unify_flags val connect_hint_clenv : polymorphic -> raw_hint -> clausenv -> - ('a, 'r) Proofview.Goal.t -> clausenv * EConstr.constr + ('a, 'r) Proofview.Goal.t -> clausenv * constr (** Try unification with the precompiled clause, then use registered Apply *) val unify_resolve : polymorphic -> Unification.unify_flags -> (raw_hint * clausenv) -> unit Proofview.tactic @@ -33,7 +34,7 @@ val unify_resolve : polymorphic -> Unification.unify_flags -> (raw_hint * clause [Pattern.somatches], then replace [?1] [?2] metavars in tacast by the right values to build a tactic *) -val conclPattern : EConstr.constr -> constr_pattern option -> Genarg.glob_generic_argument -> unit Proofview.tactic +val conclPattern : constr -> constr_pattern option -> Genarg.glob_generic_argument -> unit Proofview.tactic (** The Auto tactic *) -- cgit v1.2.3 From e71f6d24465ea7812e9b893ed8e0deb2a44ce4f8 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Nov 2016 00:28:38 +0100 Subject: Eauto API using EConstr. --- tactics/eauto.ml | 31 +++++++++++++++++-------------- tactics/eauto.mli | 3 ++- 2 files changed, 19 insertions(+), 15 deletions(-) (limited to 'tactics') diff --git a/tactics/eauto.ml b/tactics/eauto.ml index 5d42ed2d55..986d1a624e 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -13,6 +13,7 @@ open Names open Nameops open Term open Termops +open EConstr open Proof_type open Tacticals open Tacmach @@ -33,13 +34,14 @@ let e_give_exact ?(flags=eauto_unif_flags) c = let t1 = Tacmach.New.pf_unsafe_type_of gl c in let t1 = EConstr.of_constr t1 in let t2 = Tacmach.New.pf_concl (Proofview.Goal.assume gl) in + let t2 = EConstr.of_constr t2 in let sigma = Tacmach.New.project gl in - if occur_existential sigma t1 || occur_existential sigma (EConstr.of_constr t2) then + if occur_existential sigma t1 || occur_existential sigma t2 then Tacticals.New.tclTHEN (Clenvtac.unify ~flags t1) (exact_no_check c) else exact_check c end } -let assumption id = e_give_exact (EConstr.mkVar id) +let assumption id = e_give_exact (mkVar id) let e_assumption = Proofview.Goal.enter { enter = begin fun gl -> @@ -48,7 +50,7 @@ let e_assumption = let registered_e_assumption = Proofview.Goal.enter { enter = begin fun gl -> - Tacticals.New.tclFIRST (List.map (fun id -> e_give_exact (EConstr.mkVar id)) + Tacticals.New.tclFIRST (List.map (fun id -> e_give_exact (mkVar id)) (Tacmach.New.pf_ids_of_hyps gl)) end } @@ -77,7 +79,7 @@ let apply_tac_list tac glls = let one_step l gl = [Proofview.V82.of_tactic Tactics.intro] - @ (List.map (fun c -> Proofview.V82.of_tactic (Tactics.Simple.eapply c)) (List.map EConstr.mkVar (pf_ids_of_hyps gl))) + @ (List.map (fun c -> Proofview.V82.of_tactic (Tactics.Simple.eapply c)) (List.map mkVar (pf_ids_of_hyps gl))) @ (List.map (fun c -> Proofview.V82.of_tactic (Tactics.Simple.eapply c)) l) @ (List.map (fun c -> Proofview.V82.of_tactic (assumption c)) (pf_ids_of_hyps gl)) @@ -262,7 +264,7 @@ module SearchProblem = struct let g = find_first_goal lg in let hyps = pf_ids_of_hyps g in let secvars = secvars_of_hyps (pf_hyps g) in - let map_assum id = (e_give_exact (EConstr.mkVar id), (-1), lazy (str "exact" ++ spc () ++ pr_id id)) in + let map_assum id = (e_give_exact (mkVar id), (-1), lazy (str "exact" ++ spc () ++ pr_id id)) in let assumption_tacs = let tacs = List.map map_assum hyps in let l = filter_tactics s.tacres tacs in @@ -469,18 +471,18 @@ let autounfold_tac db cls = in autounfold dbs cls -let unfold_head env (ids, csts) c = +let unfold_head env sigma (ids, csts) c = let rec aux c = - match kind_of_term c with + match EConstr.kind sigma c with | Var id when Id.Set.mem id ids -> (match Environ.named_body id env with - | Some b -> true, b + | Some b -> true, EConstr.of_constr b | None -> false, c) | Const (cst,u as c) when Cset.mem cst csts -> - true, Environ.constant_value_in env c + true, EConstr.of_constr (Environ.constant_value_in env c) | App (f, args) -> (match aux f with - | true, f' -> true, Reductionops.whd_betaiota Evd.empty (EConstr.of_constr (mkApp (f', args))) + | true, f' -> true, EConstr.of_constr (Reductionops.whd_betaiota sigma (mkApp (f', args))) | false, _ -> let done_, args' = Array.fold_left_i (fun i (done_, acc) arg -> @@ -494,7 +496,7 @@ let unfold_head env (ids, csts) c = else false, c) | _ -> let done_ = ref false in - let c' = map_constr (fun c -> + let c' = EConstr.map sigma (fun c -> if !done_ then c else let x, c' = aux c in done_ := x; c') c @@ -504,7 +506,9 @@ let unfold_head env (ids, csts) c = let autounfold_one db cl = Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl gl in + let concl = EConstr.of_constr concl in let st = List.fold_left (fun (i,c) dbname -> let db = try searchtable_map dbname @@ -513,10 +517,9 @@ let autounfold_one db cl = let (ids, csts) = Hint_db.unfolds db in (Id.Set.union ids i, Cset.union csts c)) (Id.Set.empty, Cset.empty) db in - let did, c' = unfold_head env st - (match cl with Some (id, _) -> Tacmach.New.pf_get_hyp_typ id gl | None -> concl) + let did, c' = unfold_head env sigma st + (match cl with Some (id, _) -> EConstr.of_constr (Tacmach.New.pf_get_hyp_typ id gl) | None -> concl) in - let c' = EConstr.of_constr c' in if did then match cl with | Some hyp -> change_in_hyp None (make_change_arg c') hyp diff --git a/tactics/eauto.mli b/tactics/eauto.mli index defa34d9c6..e2006ac1e3 100644 --- a/tactics/eauto.mli +++ b/tactics/eauto.mli @@ -7,6 +7,7 @@ (************************************************************************) open Term +open EConstr open Proof_type open Hints open Tactypes @@ -15,7 +16,7 @@ val e_assumption : unit Proofview.tactic val registered_e_assumption : unit Proofview.tactic -val e_give_exact : ?flags:Unification.unify_flags -> EConstr.constr -> unit Proofview.tactic +val e_give_exact : ?flags:Unification.unify_flags -> constr -> unit Proofview.tactic val prolog_tac : delayed_open_constr list -> int -> unit Proofview.tactic -- cgit v1.2.3 From 67507df457be05ee5b651a423031a8cd584934ef Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Nov 2016 00:35:43 +0100 Subject: Class_tactics API using EConstr. --- tactics/class_tactics.ml | 38 +++++++++++++++++++------------------- tactics/class_tactics.mli | 5 +++-- tactics/tactics.ml | 1 - 3 files changed, 22 insertions(+), 22 deletions(-) (limited to 'tactics') diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 8ecdd01f23..0ca6615575 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -18,6 +18,7 @@ open Util open Names open Term open Termops +open EConstr open Reduction open Proof_type open Tacticals @@ -217,7 +218,6 @@ let auto_unif_flags freeze st = } let e_give_exact flags poly (c,clenv) gl = - let open EConstr in let (c, _, _) = c in let c, gl = if poly then @@ -245,7 +245,6 @@ let unify_resolve poly flags = { enter = begin fun gls (c,_,clenv) -> (** Application of a lemma using [refine] instead of the old [w_unify] *) let unify_resolve_refine poly flags = - let open EConstr in let open Clenv in { enter = begin fun gls ((c, t, ctx),n,clenv) -> let env = Proofview.Goal.env gls in @@ -479,7 +478,8 @@ let pr_depth l = prlist_with_sep (fun () -> str ".") int (List.rev l) let is_Prop env sigma concl = let ty = Retyping.get_type_of env sigma concl in - match kind_of_term ty with + let ty = EConstr.of_constr ty in + match EConstr.kind sigma ty with | Sort (Prop Null) -> true | _ -> false @@ -527,22 +527,23 @@ let evars_to_goals p evm = let make_resolve_hyp env sigma st flags only_classes pri decl = let id = NamedDecl.get_id decl in let cty = Evarutil.nf_evar sigma (NamedDecl.get_type decl) in + let cty = EConstr.of_constr cty in let rec iscl env ty = - let ctx, ar = decompose_prod_assum ty in - match kind_of_term (fst (decompose_app ar)) with + let ctx, ar = decompose_prod_assum sigma ty in + match EConstr.kind sigma (fst (decompose_app sigma ar)) with | Const (c,_) -> is_class (ConstRef c) | Ind (i,_) -> is_class (IndRef i) | _ -> let env' = Environ.push_rel_context ctx env in - let ty' = whd_all env' ar in - if not (Term.eq_constr ty' ar) then iscl env' ty' + let ty' = Reductionops.whd_all env' sigma ar in + let ty' = EConstr.of_constr ty' in + if not (EConstr.eq_constr sigma ty' ar) then iscl env' ty' else false in let is_class = iscl env cty in - let cty = EConstr.of_constr cty in let keep = not only_classes || is_class in if keep then - let c = EConstr.mkVar id in + let c = mkVar id in let name = PathHints [VarRef id] in let hints = if is_class then @@ -1466,6 +1467,7 @@ let resolve_one_typeclass env ?(sigma=Evd.empty) gl unique = let nc, gl, subst, _, _ = Evarutil.push_rel_context_to_named_context env gl in let (gl,t,sigma) = Goal.V82.mk_goal sigma nc gl Store.empty in + let (ev, _) = destEvar sigma t in let gls = { it = gl ; sigma = sigma; } in let hints = searchtable_map typeclasses_db in let st = Hint_db.transparent_state hints in @@ -1480,11 +1482,9 @@ let resolve_one_typeclass env ?(sigma=Evd.empty) gl unique = with Refiner.FailError _ -> raise Not_found in let evd = sig_sig gls' in - let t = EConstr.Unsafe.to_constr t in - let t' = let (ev, inst) = destEvar t in - mkEvar (ev, Array.map_of_list EConstr.Unsafe.to_constr subst) - in - let term = Evarutil.nf_evar evd t' in + let t' = mkEvar (ev, Array.of_list subst) in + let term = Evarutil.nf_evar evd (EConstr.Unsafe.to_constr t') in + let term = EConstr.of_constr term in evd, term let _ = @@ -1495,8 +1495,9 @@ let _ = Used in the partial application tactic. *) let rec head_of_constr sigma t = - let t = strip_outer_cast sigma (EConstr.of_constr (collapse_appl sigma (EConstr.of_constr t))) in - match kind_of_term t with + let t = strip_outer_cast sigma (EConstr.of_constr (collapse_appl sigma t)) in + let t = EConstr.of_constr t in + match EConstr.kind sigma t with | Prod (_,_,c2) -> head_of_constr sigma c2 | LetIn (_,_,_,c2) -> head_of_constr sigma c2 | App (f,args) -> head_of_constr sigma f @@ -1505,17 +1506,16 @@ let rec head_of_constr sigma t = let head_of_constr h c = Proofview.tclEVARMAP >>= fun sigma -> let c = head_of_constr sigma c in - let c = EConstr.of_constr c in letin_tac None (Name h) c None Locusops.allHyps let not_evar c = Proofview.tclEVARMAP >>= fun sigma -> - match Evarutil.kind_of_term_upto sigma c with + match EConstr.kind sigma c with | Evar _ -> Tacticals.New.tclFAIL 0 (str"Evar") | _ -> Proofview.tclUNIT () let is_ground c gl = - if Evarutil.is_ground_term (project gl) (EConstr.of_constr c) then tclIDTAC gl + if Evarutil.is_ground_term (project gl) c then tclIDTAC gl else tclFAIL 0 (str"Not ground") gl let autoapply c i gl = diff --git a/tactics/class_tactics.mli b/tactics/class_tactics.mli index 027b7dcd76..171b5c4ea9 100644 --- a/tactics/class_tactics.mli +++ b/tactics/class_tactics.mli @@ -10,6 +10,7 @@ open Names open Constr +open EConstr open Tacmach val catchable : exn -> bool @@ -24,13 +25,13 @@ val typeclasses_eauto : ?only_classes:bool -> ?st:transparent_state -> depth:(Int.t option) -> Hints.hint_db_name list -> unit Proofview.tactic -val head_of_constr : Id.t -> Term.constr -> unit Proofview.tactic +val head_of_constr : Id.t -> constr -> unit Proofview.tactic val not_evar : constr -> unit Proofview.tactic val is_ground : constr -> tactic -val autoapply : EConstr.constr -> Hints.hint_db_name -> tactic +val autoapply : constr -> Hints.hint_db_name -> tactic module Search : sig val eauto_tac : diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 59ffd8b626..c025ca9b54 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1734,7 +1734,6 @@ let solve_remaining_apply_goals = let concl = EConstr.of_constr concl in if Typeclasses.is_class_type evd concl then let evd', c' = Typeclasses.resolve_one_typeclass env evd concl in - let c' = EConstr.of_constr c' in let tac = Refine.refine ~unsafe:true { run = fun h -> Sigma.here c' h } in Sigma.Unsafe.of_pair (tac, evd') else Sigma.here (Proofview.tclUNIT ()) sigma -- cgit v1.2.3 From c72bf7330bb32970616be4dddc7571f3b91c1562 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Nov 2016 01:08:53 +0100 Subject: Eqdecide API using EConstr. --- tactics/eqdecide.ml | 35 ++++++++++++++++++----------------- tactics/eqdecide.mli | 2 +- tactics/hipattern.ml | 5 ++++- tactics/hipattern.mli | 2 +- 4 files changed, 24 insertions(+), 20 deletions(-) (limited to 'tactics') diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml index be9a342391..a96656d3ae 100644 --- a/tactics/eqdecide.ml +++ b/tactics/eqdecide.ml @@ -16,6 +16,7 @@ open Util open Names open Namegen open Term +open EConstr open Declarations open Tactics open Tacticals.New @@ -52,7 +53,6 @@ open Coqlib *) let clear_last = - let open EConstr in Proofview.tclEVARMAP >>= fun sigma -> (onLastHyp (fun c -> (clear [destVar sigma c]))) @@ -70,14 +70,14 @@ let choose_noteq eqonleft = let mkBranches c1 c2 = tclTHENLIST [generalize [c2]; - Simple.elim (EConstr.of_constr c1); + Simple.elim c1; intros; onLastHyp Simple.case; clear_last; intros] let discrHyp id = - let c = { delayed = fun env sigma -> Sigma.here (EConstr.mkVar id, NoBindings) sigma } in + let c = { delayed = fun env sigma -> Sigma.here (mkVar id, NoBindings) sigma } in let tac c = Equality.discr_tac false (Some (None, ElimOnConstr c)) in Tacticals.New.tclDELAYEDWITHHOLES false c tac @@ -89,7 +89,9 @@ let solveNoteqBranch side = (* Constructs the type {c1=c2}+{~c1=c2} *) let make_eq () = -(*FIXME*) Universes.constr_of_global (Coqlib.build_coq_eq ()) +(*FIXME*) EConstr.of_constr (Universes.constr_of_global (Coqlib.build_coq_eq ())) +let build_coq_not () = EConstr.of_constr (build_coq_not ()) +let build_coq_sumbool () = EConstr.of_constr (build_coq_sumbool ()) let mkDecideEqGoal eqonleft op rectype c1 c2 = let equality = mkApp(make_eq(), [|rectype; c1; c2|]) in @@ -116,7 +118,7 @@ let rec rewrite_and_clear hyps = match hyps with | [] -> Proofview.tclUNIT () | id :: hyps -> tclTHENLIST [ - Equality.rewriteLR (EConstr.mkVar id); + Equality.rewriteLR (mkVar id); clear [id]; rewrite_and_clear hyps; ] @@ -125,7 +127,7 @@ let eqCase tac = tclTHEN intro (onLastHypId tac) let injHyp id = - let c = { delayed = fun env sigma -> Sigma.here (EConstr.mkVar id, NoBindings) sigma } in + let c = { delayed = fun env sigma -> Sigma.here (mkVar id, NoBindings) sigma } in let tac c = Equality.injClause None false (Some (None, ElimOnConstr c)) in Tacticals.New.tclDELAYEDWITHHOLES false c tac @@ -137,7 +139,7 @@ let diseqCase hyps eqonleft = (tclTHEN (rewrite_and_clear (List.rev hyps)) (tclTHEN (red_in_concl) (tclTHEN (intro_using absurd) - (tclTHEN (Simple.apply (EConstr.mkVar diseq)) + (tclTHEN (Simple.apply (mkVar diseq)) (tclTHEN (injHyp absurd) (full_trivial [])))))))) @@ -160,9 +162,9 @@ let rec solveArg hyps eqonleft op largs rargs = match largs, rargs with ] | a1 :: largs, a2 :: rargs -> Proofview.Goal.enter { enter = begin fun gl -> - let rectype = pf_unsafe_type_of gl (EConstr.of_constr a1) in + let rectype = pf_unsafe_type_of gl a1 in + let rectype = EConstr.of_constr rectype in let decide = mkDecideEqGoal eqonleft op rectype a1 a2 in - let decide = EConstr.of_constr decide in let tac hyp = solveArg (hyp :: hyps) eqonleft op largs rargs in let subtacs = if eqonleft then [eqCase tac;diseqCase hyps eqonleft;default_auto] @@ -181,7 +183,7 @@ let solveEqBranch rectype = match_eqdec sigma concl >>= fun (eqonleft,op,lhs,rhs,_) -> let (mib,mip) = Global.lookup_inductive rectype in let nparams = mib.mind_nparams in - let getargs l = List.skipn nparams (snd (decompose_app l)) in + let getargs l = List.skipn nparams (snd (decompose_app sigma l)) in let rargs = getargs rhs and largs = getargs lhs in solveArg [] eqonleft op largs rargs @@ -194,7 +196,7 @@ let solveEqBranch rectype = (* The tactic Decide Equality *) -let hd_app c = match kind_of_term c with +let hd_app sigma c = match EConstr.kind sigma c with | App (h,_) -> h | _ -> c @@ -206,13 +208,13 @@ let decideGralEquality = let concl = EConstr.of_constr concl in let sigma = project gl in match_eqdec sigma concl >>= fun (eqonleft,_,c1,c2,typ) -> - let headtyp = hd_app (pf_compute gl (EConstr.of_constr typ)) in - begin match kind_of_term headtyp with + let headtyp = hd_app sigma (pf_compute gl typ) in + begin match EConstr.kind sigma headtyp with | Ind (mi,_) -> Proofview.tclUNIT mi | _ -> tclZEROMSG (Pp.str"This decision procedure only works for inductive objects.") end >>= fun rectype -> (tclTHEN - (mkBranches c1 (EConstr.of_constr c2)) + (mkBranches c1 c2) (tclORELSE (solveNoteqBranch eqonleft) (solveEqBranch rectype))) end } end @@ -227,7 +229,6 @@ let decideEqualityGoal = tclTHEN intros decideGralEquality let decideEquality rectype = Proofview.Goal.enter { enter = begin fun gl -> let decide = mkGenDecideEqGoal rectype gl in - let decide = EConstr.of_constr decide in (tclTHENS (cut decide) [default_auto;decideEqualityGoal]) end } @@ -236,9 +237,9 @@ let decideEquality rectype = let compare c1 c2 = Proofview.Goal.enter { enter = begin fun gl -> - let rectype = pf_unsafe_type_of gl (EConstr.of_constr c1) in + let rectype = pf_unsafe_type_of gl c1 in + let rectype = EConstr.of_constr rectype in let decide = mkDecideEqGoal true (build_coq_sumbool ()) rectype c1 c2 in - let decide = EConstr.of_constr decide in (tclTHENS (cut decide) [(tclTHEN intro (tclTHEN (onLastHyp simplest_case) clear_last)); diff --git a/tactics/eqdecide.mli b/tactics/eqdecide.mli index cb48a5bcc8..dca1780b76 100644 --- a/tactics/eqdecide.mli +++ b/tactics/eqdecide.mli @@ -14,4 +14,4 @@ val decideEqualityGoal : unit Proofview.tactic -val compare : Constr.t -> Constr.t -> unit Proofview.tactic +val compare : EConstr.t -> EConstr.t -> unit Proofview.tactic diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml index 36ed589b99..9e78ff3237 100644 --- a/tactics/hipattern.ml +++ b/tactics/hipattern.ml @@ -548,7 +548,10 @@ 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, Universes.constr_of_global (Lazy.force op), c1, c2, typ + let typ = EConstr.of_constr typ in + let c1 = EConstr.of_constr c1 in + let c2 = EConstr.of_constr c2 in + eqonleft, EConstr.of_constr (Universes.constr_of_global (Lazy.force op)), c1, c2, typ | _ -> anomaly (Pp.str "Unexpected pattern") (* Patterns "~ ?" and "? -> False" *) diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli index c061c50f0b..65ba0aad04 100644 --- a/tactics/hipattern.mli +++ b/tactics/hipattern.mli @@ -143,7 +143,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 * Constr.constr * Constr.constr +val match_eqdec : evar_map -> constr -> bool * constr * constr * constr * constr (** Match an equality up to conversion; returns [(eq,t1,t2)] in normal form *) val dest_nf_eq : ([ `NF ], 'r) Proofview.Goal.t -> constr -> (constr * constr * constr) -- cgit v1.2.3 From e6a8ab0f428c26fff2bd7e636126974f167101bf Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Nov 2016 01:35:54 +0100 Subject: Tactic_matching API using EConstr. --- tactics/auto.ml | 2 +- tactics/hipattern.ml | 11 +++-------- tactics/tactics.ml | 1 - 3 files changed, 4 insertions(+), 10 deletions(-) (limited to 'tactics') diff --git a/tactics/auto.ml b/tactics/auto.ml index c34f9dd923..21fe9667bd 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -152,7 +152,7 @@ let conclPattern concl pat tac = let open Genarg in let open Geninterp in let inj c = match val_tag (topwit Stdarg.wit_constr) with - | Val.Base tag -> Val.Dyn (tag, c) + | Val.Base tag -> Val.Dyn (tag, EConstr.Unsafe.to_constr c) | _ -> assert false in let fold id c accu = Id.Map.add id (inj c) accu in diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml index 9e78ff3237..b92d659087 100644 --- a/tactics/hipattern.ml +++ b/tactics/hipattern.ml @@ -353,8 +353,6 @@ let is_imp_term sigma c = op2bool (match_with_imp_term sigma c) let match_with_nottype sigma t = try let (arg,mind) = match_arrow_pattern sigma t in - let arg = EConstr.of_constr arg in - let mind = EConstr.of_constr mind in if is_empty_type sigma mind then Some (mind,arg) else None with PatternMatchingFailure -> None @@ -470,11 +468,11 @@ let match_eq_nf gls eqn (ref, hetero) = let n = if hetero then 4 else 3 in let args = List.init n (fun i -> mkGPatVar ("X" ^ string_of_int (i + 1))) in let pat = mkPattern (mkGAppRef ref args) in - let pf_whd_all gls c = EConstr.of_constr (pf_whd_all gls (EConstr.of_constr c)) in + let pf_whd_all gls c = EConstr.of_constr (pf_whd_all gls c) in match Id.Map.bindings (pf_matches gls pat eqn) with | [(m1,t);(m2,x);(m3,y)] -> assert (Id.equal m1 meta1 && Id.equal m2 meta2 && Id.equal m3 meta3); - (EConstr.of_constr t,pf_whd_all gls x,pf_whd_all gls y) + (t,pf_whd_all gls x,pf_whd_all gls y) | _ -> anomaly ~label:"match_eq" (Pp.str "an eq pattern should match 3 terms") let dest_nf_eq gls eqn = @@ -502,7 +500,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)] -> (EConstr.of_constr a,EConstr.of_constr p) + | [(_,a); (_,p)] -> (a,p) | _ -> anomaly (Pp.str "Unexpected pattern") let is_matching_sigma sigma t = is_matching sigma (Lazy.force coq_sig_pattern) t @@ -548,9 +546,6 @@ 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)] -> - let typ = EConstr.of_constr typ in - let c1 = EConstr.of_constr c1 in - let c2 = EConstr.of_constr c2 in eqonleft, EConstr.of_constr (Universes.constr_of_global (Lazy.force op)), c1, c2, typ | _ -> anomaly (Pp.str "Unexpected pattern") diff --git a/tactics/tactics.ml b/tactics/tactics.ml index c025ca9b54..606eb27b9a 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -816,7 +816,6 @@ let e_change_in_hyp redfun (id,where) = type change_arg = Pattern.patvar_map -> EConstr.constr Sigma.run let make_change_arg c pats = - let pats = Id.Map.map EConstr.of_constr pats in { run = fun sigma -> Sigma.here (replace_vars (Id.Map.bindings pats) c) sigma } let check_types env sigma mayneedglobalcheck deep newc origc = -- cgit v1.2.3 From d4b344acb23f19b089098b7788f37ea22bc07b81 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Nov 2016 20:09:26 +0100 Subject: Eliminating parts of the right-hand side compatibility layer --- tactics/class_tactics.ml | 1 - tactics/equality.ml | 13 +++---------- tactics/hints.ml | 5 ----- tactics/inv.ml | 1 - tactics/tactics.ml | 6 ++---- 5 files changed, 5 insertions(+), 21 deletions(-) (limited to 'tactics') diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 0ca6615575..6c45bef1c6 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -1496,7 +1496,6 @@ let _ = let rec head_of_constr sigma t = let t = strip_outer_cast sigma (EConstr.of_constr (collapse_appl sigma t)) in - let t = EConstr.of_constr t in match EConstr.kind sigma t with | Prod (_,_,c2) -> head_of_constr sigma c2 | LetIn (_,_,_,c2) -> head_of_constr sigma c2 diff --git a/tactics/equality.ml b/tactics/equality.ml index 4c79a61999..2eead2d22b 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -183,7 +183,7 @@ let instantiate_lemma_all frzevars gl c ty l l2r concl = let flags = make_flags frzevars (Tacmach.New.project gl) rewrite_unif_flags eqclause in let occs = w_unify_to_subterm_all ~flags env eqclause.evd - (EConstr.of_constr (if l2r then c1 else c2),EConstr.of_constr concl) + ((if l2r then c1 else c2),concl) in List.map try_occ occs let instantiate_lemma gl c ty l l2r concl = @@ -314,6 +314,7 @@ let general_elim_clause with_evars frzevars tac cls c t l l2r elim = | None -> pf_nf_concl gl | Some id -> pf_get_hyp_typ id (Proofview.Goal.assume gl) in + let typ = EConstr.of_constr typ in let cs = instantiate_lemma typ in if firstonly then tclFIRST (List.map try_clause cs) else tclMAP try_clause cs @@ -1207,7 +1208,6 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt = | _ -> 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 rty = EConstr.of_constr rty in let tuple_tail = sigrec_clausal_form (siglen-1) rty in let evopt = match EConstr.kind !evdref ev with Evar _ -> None | _ -> Some ev in match evopt with @@ -1348,10 +1348,6 @@ let inject_if_homogenous_dependent_pair ty = if not (Termops.is_global sigma (sigTconstr()) eqTypeDest) then raise Exit; let hd1,ar1 = decompose_app_vect sigma t1 and hd2,ar2 = decompose_app_vect sigma t2 in - let hd1 = EConstr.of_constr hd1 in - let hd2 = EConstr.of_constr hd2 in - let ar1 = Array.map EConstr.of_constr ar1 in - let ar2 = Array.map EConstr.of_constr ar2 in if not (Termops.is_global sigma (existTconstr()) hd1) then raise Exit; if not (Termops.is_global sigma (existTconstr()) hd2) then raise Exit; let ind,_ = try pf_apply find_mrectype gl ar1.(0) with Not_found -> raise Exit in @@ -1565,7 +1561,6 @@ let decomp_tuple_term env sigma c t = let car_code = applist (mkConstU (destConstRef p1,i),[a;p;inner_code]) and cdr_code = applist (mkConstU (destConstRef p2,i),[a;p;inner_code]) in let cdrtyp = beta_applist sigma (p,[car]) in - let cdrtyp = EConstr.of_constr cdrtyp in List.map (fun l -> ((car,a),car_code)::l) (decomprec cdr_code cdr cdrtyp) with Constr_matching.PatternMatchingFailure -> [] @@ -1593,13 +1588,11 @@ let subst_tuple_term env sigma dep_pair1 dep_pair2 b = (* We build the expected goal *) let abst_B = List.fold_right - (fun (e,t) body -> lambda_create env (t,EConstr.of_constr (subst_term sigma e body))) e1_list b in + (fun (e,t) body -> lambda_create env (t,subst_term sigma e body)) e1_list b in let pred_body = beta_applist sigma (abst_B,proj_list) in - let pred_body = EConstr.of_constr pred_body in let body = mkApp (lambda_create env (typ,pred_body),[|dep_pair1|]) in let expected_goal = beta_applist sigma (abst_B,List.map fst e2_list) in (* Simulate now the normalisation treatment made by Logic.mk_refgoals *) - let expected_goal = EConstr.of_constr expected_goal in let expected_goal = nf_betaiota sigma expected_goal in let expected_goal = EConstr.of_constr expected_goal in (* Retype to get universes right *) diff --git a/tactics/hints.ml b/tactics/hints.ml index cd5fc79f5e..2b310033c3 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -50,7 +50,6 @@ exception Bound let head_constr_bound sigma t = let t = strip_outer_cast sigma t in - let t = EConstr.of_constr t in let _,ccl = decompose_prod_assum sigma t in let hd,args = decompose_app sigma ccl in match EConstr.kind sigma hd with @@ -66,11 +65,8 @@ let head_constr sigma c = let decompose_app_bound sigma t = let t = strip_outer_cast sigma t in - let t = EConstr.of_constr t in let _,ccl = decompose_prod_assum sigma t in let hd,args = decompose_app_vect sigma ccl in - let hd = EConstr.of_constr hd in - let args = Array.map EConstr.of_constr args in match EConstr.kind sigma hd with | Const (c,u) -> ConstRef c, args | Ind (i,u) -> IndRef i, args @@ -754,7 +750,6 @@ let secvars_of_global env gr = let make_exact_entry env sigma pri poly ?(name=PathAny) (c, cty, ctx) = let secvars = secvars_of_constr env sigma c in let cty = strip_outer_cast sigma cty in - let cty = EConstr.of_constr cty in match EConstr.kind sigma cty with | Prod _ -> failwith "make_exact_entry" | _ -> diff --git a/tactics/inv.ml b/tactics/inv.ml index 5c296b343f..ac9a564e58 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -462,7 +462,6 @@ let raw_inversion inv_kind id status names = Reductionops.beta_applist sigma (elim_predicate, realargs), case_nodep_then_using in - let cut_concl = EConstr.of_constr cut_concl in let refined id = let prf = mkApp (mkVar id, args) in Refine.refine { run = fun h -> Sigma (prf, h, Sigma.refl) } diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 606eb27b9a..03f81773b1 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -528,7 +528,7 @@ fun env sigma p -> function let Sigma (rem, sigma, r) = mk_holes env sigma (p +> q) rem in Sigma (arg :: rem, sigma, r) -let rec check_mutind env sigma k cl = match EConstr.kind sigma (EConstr.of_constr (strip_outer_cast sigma cl)) with +let rec check_mutind env sigma k cl = match EConstr.kind sigma (strip_outer_cast sigma cl) with | Prod (na, c1, b) -> if Int.equal k 1 then try @@ -1647,10 +1647,8 @@ let make_projection env sigma params cstr sign elim i n c u = then let t = lift (i+1-n) t in let abselim = beta_applist sigma (elim, params@[t;branch]) in - let abselim = EConstr.of_constr abselim in let args = Array.map EConstr.of_constr (Context.Rel.to_extended_vect 0 sign) in let c = beta_applist sigma (abselim, [mkApp (c, args)]) in - let c = EConstr.of_constr c in Some (it_mkLambda_or_LetIn c sign, it_mkProd_or_LetIn t sign) else None @@ -2856,7 +2854,7 @@ let generalize_goal_gen env sigma ids i ((occs,c,b),na) t cl = let open Context.Rel.Declaration in let decls,cl = decompose_prod_n_assum sigma i cl in let dummy_prod = it_mkProd_or_LetIn mkProp decls in - let newdecls,_ = decompose_prod_n_assum sigma i (EConstr.of_constr (subst_term_gen sigma EConstr.eq_constr_nounivs c dummy_prod)) in + let newdecls,_ = decompose_prod_n_assum sigma i (subst_term_gen sigma EConstr.eq_constr_nounivs c dummy_prod) in let cl',sigma' = subst_closed_term_occ env sigma (AtOccs occs) c (it_mkProd_or_LetIn cl newdecls) in let cl' = EConstr.of_constr cl' in let na = generalized_name sigma c t ids cl' na in -- cgit v1.2.3 From e09f3b44bb381854b647a6d9debdeddbfc49177e Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sun, 20 Nov 2016 22:16:08 +0100 Subject: Proofview.Goal primitive now return EConstrs. --- tactics/auto.ml | 2 -- tactics/class_tactics.ml | 4 +-- tactics/eauto.ml | 4 +-- tactics/eqdecide.ml | 2 -- tactics/equality.ml | 10 ++----- tactics/hipattern.ml | 1 - tactics/inv.ml | 7 ++--- tactics/leminv.ml | 2 +- tactics/tacticals.ml | 2 +- tactics/tactics.ml | 75 +++++++++++++++++------------------------------- 10 files changed, 36 insertions(+), 73 deletions(-) (limited to 'tactics') diff --git a/tactics/auto.ml b/tactics/auto.ml index 21fe9667bd..4218be0bbd 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -331,7 +331,6 @@ let rec trivial_fail_db dbg mod_delta db_list local_db = in Proofview.Goal.enter { enter = begin fun gl -> let concl = Tacmach.New.pf_nf_concl gl in - let concl = EConstr.of_constr concl in let sigma = Tacmach.New.project gl in let secvars = compute_secvars gl in Tacticals.New.tclFIRST @@ -492,7 +491,6 @@ let search d n mod_delta db_list local_db = (Tacticals.New.tclORELSE0 (intro_register d (search d n) local_db) ( Proofview.Goal.enter { enter = begin fun gl -> let concl = Tacmach.New.pf_nf_concl gl in - let concl = EConstr.of_constr concl in let sigma = Tacmach.New.project gl in let secvars = compute_secvars gl in let d' = incr_dbg d in diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 6c45bef1c6..bf4e53b103 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -249,7 +249,6 @@ let unify_resolve_refine poly flags = { enter = begin fun gls ((c, t, ctx),n,clenv) -> let env = Proofview.Goal.env gls in let concl = Proofview.Goal.concl gls in - let concl = EConstr.of_constr concl in Refine.refine ~unsafe:true { Sigma.run = fun sigma -> let sigma = Sigma.to_evar_map sigma in let sigma, term, ty = @@ -363,7 +362,7 @@ let rec e_trivial_fail_db only_classes db_list local_db secvars = Proofview.Goal.nf_enter { enter = begin fun gl -> let tacs = e_trivial_resolve db_list local_db secvars only_classes - (project gl) (EConstr.of_constr (pf_concl gl)) in + (project gl) (pf_concl gl) in tclFIRST (List.map (fun (x,_,_,_,_) -> x) tacs) end} in @@ -1002,7 +1001,6 @@ module Search = struct let open Proofview.Notations in let env = Goal.env gl in let concl = Goal.concl gl in - let concl = EConstr.of_constr concl in let sigma = Goal.sigma gl in let s = Sigma.to_evar_map sigma in let unique = not info.search_dep || is_unique env s concl in diff --git a/tactics/eauto.ml b/tactics/eauto.ml index 986d1a624e..57400d3340 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -34,7 +34,6 @@ let e_give_exact ?(flags=eauto_unif_flags) c = let t1 = Tacmach.New.pf_unsafe_type_of gl c in let t1 = EConstr.of_constr t1 in let t2 = Tacmach.New.pf_concl (Proofview.Goal.assume gl) in - let t2 = EConstr.of_constr t2 in let sigma = Tacmach.New.project gl in if occur_existential sigma t1 || occur_existential sigma t2 then Tacticals.New.tclTHEN (Clenvtac.unify ~flags t1) (exact_no_check c) @@ -151,7 +150,7 @@ let rec e_trivial_fail_db db_list local_db = let tacl = registered_e_assumption :: (Tacticals.New.tclTHEN Tactics.intro next) :: - (List.map fst (e_trivial_resolve (Tacmach.New.project gl) db_list local_db secvars (EConstr.of_constr (Tacmach.New.pf_nf_concl gl)))) + (List.map fst (e_trivial_resolve (Tacmach.New.project gl) db_list local_db secvars (Tacmach.New.pf_nf_concl gl))) in Tacticals.New.tclFIRST (List.map Tacticals.New.tclCOMPLETE tacl) end } @@ -508,7 +507,6 @@ let autounfold_one db cl = let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl gl in - let concl = EConstr.of_constr concl in let st = List.fold_left (fun (i,c) dbname -> let db = try searchtable_map dbname diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml index a96656d3ae..16e0d96848 100644 --- a/tactics/eqdecide.ml +++ b/tactics/eqdecide.ml @@ -178,7 +178,6 @@ let solveEqBranch rectype = begin Proofview.Goal.enter { enter = begin fun gl -> let concl = pf_nf_concl gl in - let concl = EConstr.of_constr concl in let sigma = project gl in match_eqdec sigma concl >>= fun (eqonleft,op,lhs,rhs,_) -> let (mib,mip) = Global.lookup_inductive rectype in @@ -205,7 +204,6 @@ let decideGralEquality = begin Proofview.Goal.enter { enter = begin fun gl -> let concl = pf_nf_concl gl in - let concl = EConstr.of_constr concl in let sigma = project gl in match_eqdec sigma concl >>= fun (eqonleft,_,c1,c2,typ) -> let headtyp = hd_app sigma (pf_compute gl typ) in diff --git a/tactics/equality.ml b/tactics/equality.ml index 2eead2d22b..209c9eb662 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -312,9 +312,8 @@ let general_elim_clause with_evars frzevars tac cls c t l l2r elim = in let typ = match cls with | None -> pf_nf_concl gl - | Some id -> pf_get_hyp_typ id (Proofview.Goal.assume gl) + | Some id -> EConstr.of_constr (pf_get_hyp_typ id (Proofview.Goal.assume gl)) in - let typ = EConstr.of_constr typ in let cs = instantiate_lemma typ in if firstonly then tclFIRST (List.map try_clause cs) else tclMAP try_clause cs @@ -409,7 +408,7 @@ let find_elim hdcncl lft2rgt dep cls ot gl = let type_of_clause cls gl = match cls with | None -> Proofview.Goal.concl gl - | Some id -> pf_get_hyp_typ id gl + | Some id -> EConstr.of_constr (pf_get_hyp_typ id gl) let leibniz_rewrite_ebindings_clause cls lft2rgt tac c t l with_evars frzevars dep_proof_ok hdcncl = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> @@ -417,7 +416,6 @@ let leibniz_rewrite_ebindings_clause cls lft2rgt tac c t l with_evars frzevars d let isatomic = isProd evd (EConstr.of_constr (whd_zeta evd hdcncl)) in let dep_fun = if isatomic then dependent else dependent_no_evar in let type_of_cls = type_of_clause cls gl in - let type_of_cls = EConstr.of_constr type_of_cls in let dep = dep_proof_ok && dep_fun evd c type_of_cls in let Sigma ((elim, effs), sigma, p) = find_elim hdcncl lft2rgt dep cls (Some t) gl in let tac = @@ -1052,7 +1050,6 @@ let onNegatedEquality with_evars tac = Proofview.Goal.nf_enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in let ccl = Proofview.Goal.concl gl in - let ccl = EConstr.of_constr ccl in let env = Proofview.Goal.env gl in match EConstr.kind sigma (EConstr.of_constr (hnf_constr env sigma ccl)) with | Prod (_,t,u) when is_empty_type sigma u -> @@ -1611,7 +1608,6 @@ let cutSubstInConcl l2r eqn = let sigma = Proofview.Goal.sigma gl in let (lbeq,u,(t,e1,e2)) = find_eq_data_decompose gl eqn in let typ = pf_concl gl in - let typ = EConstr.of_constr typ in let (e1,e2) = if l2r then (e1,e2) else (e2,e1) in let Sigma ((typ, expected), sigma, p) = subst_tuple_term env sigma e1 e2 typ in let tac = @@ -1752,7 +1748,7 @@ let subst_one dep_proof_ok x (hyp,rhs,dir) = hyps (MoveBefore x,[x],[]))) in (* In practice, no dep hyps before x, so MoveBefore x is good enough *) (* Decides if x appears in conclusion *) - let depconcl = occur_var env sigma x (EConstr.of_constr concl) in + let depconcl = occur_var env sigma x concl in let need_rewrite = not (List.is_empty dephyps) || depconcl in tclTHENLIST ((if need_rewrite then diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml index b92d659087..fa114a3d34 100644 --- a/tactics/hipattern.ml +++ b/tactics/hipattern.ml @@ -468,7 +468,6 @@ let match_eq_nf gls eqn (ref, hetero) = let n = if hetero then 4 else 3 in let args = List.init n (fun i -> mkGPatVar ("X" ^ string_of_int (i + 1))) in let pat = mkPattern (mkGAppRef ref args) in - let pf_whd_all gls c = EConstr.of_constr (pf_whd_all gls c) in match Id.Map.bindings (pf_matches gls pat eqn) with | [(m1,t);(m2,x);(m3,y)] -> assert (Id.equal m1 meta1 && Id.equal m2 meta2 && Id.equal m3 meta3); diff --git a/tactics/inv.ml b/tactics/inv.ml index ac9a564e58..e45eb2a16a 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -34,7 +34,7 @@ module NamedDecl = Context.Named.Declaration let var_occurs_in_pf gl id = let env = Proofview.Goal.env gl in let sigma = project gl in - occur_var env sigma id (EConstr.of_constr (Proofview.Goal.concl gl)) || + occur_var env sigma id (Proofview.Goal.concl gl) || List.exists (occur_var_in_decl env sigma id) (Proofview.Goal.hyps gl) (* [make_inv_predicate (ity,args) C] @@ -441,7 +441,6 @@ let raw_inversion inv_kind id status names = let sigma = Sigma.to_evar_map sigma in let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl gl in - let concl = EConstr.of_constr concl in let c = mkVar id in let (ind, t) = try pf_apply Tacred.reduce_to_atomic_ind gl (EConstr.of_constr (pf_unsafe_type_of gl c)) @@ -522,13 +521,13 @@ let invIn k names ids id = let hyps = List.map (fun id -> pf_get_hyp id gl) ids in let concl = Proofview.Goal.concl gl in let sigma = project gl in - let nb_prod_init = nb_prod sigma (EConstr.of_constr concl) in + let nb_prod_init = nb_prod sigma concl in let intros_replace_ids = Proofview.Goal.enter { enter = begin fun gl -> let concl = pf_nf_concl gl in let sigma = project gl in let nb_of_new_hyp = - nb_prod sigma (EConstr.of_constr concl) - (List.length hyps + nb_prod_init) + nb_prod sigma concl - (List.length hyps + nb_prod_init) in if nb_of_new_hyp < 1 then intros_replacing ids diff --git a/tactics/leminv.ml b/tactics/leminv.ml index 62e78b5886..609fa1be83 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -294,7 +294,7 @@ let lemInvIn id c ids = let intros_replace_ids = let concl = Proofview.Goal.concl gl in let sigma = project gl in - let nb_of_new_hyp = nb_prod sigma (EConstr.of_constr concl) - List.length ids in + let nb_of_new_hyp = nb_prod sigma concl - List.length ids in if nb_of_new_hyp < 1 then intros_replacing ids else diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index e440f1dc51..d79a74b36e 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -710,7 +710,7 @@ module New = struct let elimination_sort_of_goal gl = (** Retyping will expand evars anyway. *) let c = Proofview.Goal.concl (Goal.assume gl) in - pf_apply Retyping.get_sort_family_of gl (EConstr.of_constr c) + pf_apply Retyping.get_sort_family_of gl c let elimination_sort_of_hyp id gl = (** Retyping will expand evars anyway. *) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 03f81773b1..dabe78b344 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -207,7 +207,6 @@ let introduction ?(check=true) id = Proofview.Goal.enter { enter = begin fun gl -> let gl = Proofview.Goal.assume gl in let concl = Proofview.Goal.concl gl in - let concl = EConstr.of_constr concl 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 @@ -230,7 +229,6 @@ let convert_concl ?(check=true) ty k = let env = Proofview.Goal.env gl in let store = Proofview.Goal.extra gl in let conclty = Proofview.Goal.raw_concl gl in - let conclty = EConstr.of_constr conclty in Refine.refine ~unsafe:true { run = begin fun sigma -> let Sigma ((), sigma, p) = if check then begin @@ -251,7 +249,6 @@ let convert_hyp ?(check=true) d = let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let ty = Proofview.Goal.raw_concl gl in - let ty = EConstr.of_constr ty in let store = Proofview.Goal.extra gl in let sign = convert_hyp check (named_context_val env) sigma d in let env = reset_with_named_context sign env in @@ -353,7 +350,6 @@ let move_hyp id dest = let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let ty = Proofview.Goal.raw_concl gl in - let ty = EConstr.of_constr ty in let store = Proofview.Goal.extra gl in let sign = named_context_val env in let sign' = move_hyp_in_named_context sigma id dest sign in @@ -409,6 +405,7 @@ let rename_hyp repl = |> NamedDecl.map_constr subst in let nhyps = List.map map hyps in + let concl = EConstr.Unsafe.to_constr concl in let nconcl = subst concl in let nconcl = EConstr.of_constr nconcl in let nctx = Environ.val_of_named_context nhyps in @@ -545,7 +542,6 @@ let mutual_fix f n rest j = Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl gl in - let concl = EConstr.of_constr concl in let (sp, u) = check_mutind env sigma n concl in let firsts, lasts = List.chop j rest in let all = firsts @ (f, n, concl) :: lasts in @@ -601,7 +597,6 @@ let mutual_cofix f others j = Proofview.Goal.nf_enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl gl in - let concl = EConstr.of_constr concl in let firsts,lasts = List.chop j others in let all = firsts @ (f, concl) :: lasts in List.iter (fun (_, c) -> check_is_mutcoind env sigma c) all; @@ -727,7 +722,7 @@ let bind_red_expr_occurrences occs nbcl redexp = let reduct_in_concl (redfun,sty) = Proofview.Goal.nf_enter { enter = begin fun gl -> - convert_concl_no_check (EConstr.of_constr (Tacmach.New.pf_apply redfun gl (EConstr.of_constr (Tacmach.New.pf_concl gl)))) sty + convert_concl_no_check (EConstr.of_constr (Tacmach.New.pf_apply redfun gl (Tacmach.New.pf_concl gl))) sty end } let reduct_in_hyp ?(check=false) redfun (id,where) = @@ -762,7 +757,7 @@ let pf_e_reduce_decl redfun where decl gl = let e_reduct_in_concl ~check (redfun, sty) = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in - let Sigma (c', sigma, p) = redfun.e_redfun (Tacmach.New.pf_env gl) sigma (EConstr.of_constr (Tacmach.New.pf_concl gl)) in + let Sigma (c', sigma, p) = redfun.e_redfun (Tacmach.New.pf_env gl) sigma (Tacmach.New.pf_concl gl) in let c' = EConstr.of_constr c' in Sigma (convert_concl ~check c' sty, sigma, p) end } @@ -783,7 +778,7 @@ let e_reduct_option ?(check=false) redfun = function let e_change_in_concl (redfun,sty) = Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in - let Sigma (c, sigma, p) = redfun.e_redfun (Proofview.Goal.env gl) sigma (EConstr.of_constr (Proofview.Goal.raw_concl gl)) in + let Sigma (c, sigma, p) = redfun.e_redfun (Proofview.Goal.env gl) sigma (Proofview.Goal.raw_concl gl) in let c = EConstr.of_constr c in Sigma (convert_concl_no_check c sty, sigma, p) end } @@ -976,7 +971,6 @@ let rec intro_then_gen name_flag move_flag force_flag dep_flag tac = Proofview.Goal.enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in - let concl = EConstr.of_constr concl in match EConstr.kind sigma concl with | Prod (name,t,u) when not dep_flag || not (noccurn sigma 1 u) -> let name = find_name false (local_assum (name,t)) name_flag gl in @@ -1120,7 +1114,7 @@ let lookup_hypothesis_as_renamed_gen red h gl = aux c | x -> x in - try aux (Proofview.Goal.concl gl) + try aux (EConstr.to_constr (Tacmach.New.project gl) (Proofview.Goal.concl gl)) with Redelimination -> None let is_quantified_hypothesis id gl = @@ -1261,7 +1255,6 @@ let cut c = let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let concl = Tacmach.New.pf_nf_concl gl in - let concl = EConstr.of_constr concl in let is_sort = try (** Backward compat: ensure that [c] is well-typed. *) @@ -1302,7 +1295,7 @@ let check_unresolved_evars_of_metas sigma clenv = (match kind_of_term c.rebus with | Evar (evk,_) when Evd.is_undefined clenv.evd evk && not (Evd.mem sigma evk) -> - error_uninstantiated_metas (EConstr.mkMeta mv) clenv + error_uninstantiated_metas (mkMeta mv) clenv | _ -> ()) | _ -> ()) (meta_list clenv.evd) @@ -1401,7 +1394,6 @@ let enforce_prop_bound_names rename tac = let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let t = Proofview.Goal.concl gl in - let t = EConstr.of_constr t in change_concl (aux env sigma i t) end } in (if isrec then Tacticals.New.tclTHENFIRSTn else Tacticals.New.tclTHENLASTn) @@ -1487,7 +1479,7 @@ let general_case_analysis_in_context with_evars clear_flag (c,lbindc) = let (mind,_) = reduce_to_quantified_ind env (Sigma.to_evar_map sigma) t in let sort = Tacticals.New.elimination_sort_of_goal gl in let Sigma (elim, sigma, p) = - if occur_term (Sigma.to_evar_map sigma) c (EConstr.of_constr concl) then + if occur_term (Sigma.to_evar_map sigma) c concl then build_case_analysis_scheme env sigma mind true sort else build_case_analysis_scheme_default env sigma mind sort in @@ -1728,7 +1720,6 @@ let solve_remaining_apply_goals = let env = Proofview.Goal.env gl in let evd = Sigma.to_evar_map sigma in let concl = Proofview.Goal.concl gl in - let concl = EConstr.of_constr concl in if Typeclasses.is_class_type evd concl then let evd', c' = Typeclasses.resolve_one_typeclass env evd concl in let tac = Refine.refine ~unsafe:true { run = fun h -> Sigma.here c' h } in @@ -1755,7 +1746,7 @@ let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind : (* 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. *) - let concl_nprod = nb_prod_modulo_zeta sigma (EConstr.of_constr concl) in + let concl_nprod = nb_prod_modulo_zeta sigma concl in let rec try_main_apply with_destruct c = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in @@ -1966,10 +1957,9 @@ let apply_in_delayed_once sidecond_first with_delta with_destruct with_evars nam let cut_and_apply c = Proofview.Goal.nf_enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in - match EConstr.kind sigma (EConstr.of_constr (Tacmach.New.pf_hnf_constr gl (EConstr.of_constr (Tacmach.New.pf_unsafe_type_of gl c)))) with + match EConstr.kind sigma (Tacmach.New.pf_hnf_constr gl (EConstr.of_constr (Tacmach.New.pf_unsafe_type_of gl c))) with | Prod (_,c1,c2) when Vars.noccurn sigma 1 c2 -> let concl = Proofview.Goal.concl gl in - let concl = EConstr.of_constr concl in let env = Tacmach.New.pf_env gl in Refine.refine { run = begin fun sigma -> let typ = mkProd (Anonymous, c2, concl) in @@ -1999,7 +1989,6 @@ let exact_check c = let sigma = Proofview.Goal.sigma gl in (** We do not need to normalize the goal because we just check convertibility *) let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in - let concl = EConstr.of_constr concl in let env = Proofview.Goal.env gl in let sigma = Sigma.to_evar_map sigma in let sigma, ct = Typing.type_of env sigma c in @@ -2013,8 +2002,7 @@ let exact_check c = let cast_no_check cast c = Proofview.Goal.enter { enter = begin fun gl -> let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in - let concl = EConstr.of_constr concl in - exact_no_check (EConstr.mkCast (c, cast, concl)) + exact_no_check (mkCast (c, cast, concl)) end } let vm_cast_no_check c = cast_no_check Term.VMcast c @@ -2025,7 +2013,7 @@ let exact_proof c = Proofview.Goal.nf_enter { enter = begin fun gl -> Refine.refine { run = begin fun sigma -> let sigma = Sigma.to_evar_map sigma in - let (c, ctx) = Constrintern.interp_casted_constr (pf_env gl) sigma c (pf_concl gl) in + let (c, ctx) = Constrintern.interp_casted_constr (pf_env gl) sigma c (EConstr.Unsafe.to_constr (pf_concl gl)) in let c = EConstr.of_constr c in let sigma = Evd.merge_universe_context sigma ctx in Sigma.Unsafe.of_pair (c, sigma) @@ -2041,13 +2029,14 @@ let assumption = else Tacticals.New.tclZEROMSG (str "No such assumption.") | decl::rest -> let t = NamedDecl.get_type decl in + let t = EConstr.of_constr t 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, Constr.equal t concl) + if only_eq then (sigma, EConstr.eq_constr sigma t concl) else let env = Proofview.Goal.env gl in - infer_conv env sigma (EConstr.of_constr t) (EConstr.of_constr concl) + infer_conv env sigma t concl in if is_same_type then (Proofview.Unsafe.tclEVARS sigma) <*> @@ -2099,7 +2088,6 @@ let clear_body ids = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in - let concl = EConstr.of_constr concl in let sigma = Tacmach.New.project gl in let ctx = named_context env in let map = function @@ -2173,7 +2161,7 @@ let keep hyps = let hyp = NamedDecl.get_id decl in if Id.List.mem hyp hyps || List.exists (occur_var_in_decl env sigma hyp) keep - || occur_var env sigma hyp (EConstr.of_constr ccl) + || occur_var env sigma hyp ccl then (clear,decl::keep) else (hyp::clear,keep)) ~init:([],[]) (Proofview.Goal.env gl) @@ -2213,7 +2201,6 @@ let bring_hyps hyps = let env = Proofview.Goal.env gl in let store = Proofview.Goal.extra gl in let concl = Tacmach.New.pf_nf_concl gl in - let concl = EConstr.of_constr concl in let newcl = List.fold_right mkNamedProd_or_LetIn hyps concl in let args = Array.map_of_list EConstr.of_constr (Context.Named.to_instance hyps) in Refine.refine { run = begin fun sigma -> @@ -2251,7 +2238,6 @@ let constructor_tac with_evars expctdnumopt i lbind = let reduce_to_quantified_ind = Tacmach.New.pf_apply Tacred.reduce_to_quantified_ind gl in - let cl = EConstr.of_constr cl in let (mind,redcl) = reduce_to_quantified_ind cl in let nconstr = Array.length (snd (Global.lookup_inductive (fst mind))).mind_consnames in @@ -2291,7 +2277,6 @@ let any_constructor with_evars tacopt = let reduce_to_quantified_ind = Tacmach.New.pf_apply Tacred.reduce_to_quantified_ind gl in - let cl = EConstr.of_constr cl in let mind = fst (reduce_to_quantified_ind cl) in let nconstr = Array.length (snd (Global.lookup_inductive (fst mind))).mind_consnames in @@ -2768,7 +2753,6 @@ let letin_tac with_eq id c ty occs = let env = Proofview.Goal.env gl in let ccl = Proofview.Goal.concl gl in let abs = AbstractExact (id,c,ty,occs,true) in - let ccl = EConstr.of_constr ccl in let (id,_,depdecls,lastlhyp,ccl,res) = make_abstraction env sigma ccl abs in (* We keep the original term to match but record the potential side-effects of unifying universes. *) @@ -2787,7 +2771,6 @@ let letin_pat_tac with_eq id c occs = let ccl = Proofview.Goal.concl gl in let check t = true in let abs = AbstractPattern (false,check,id,c,occs,false) in - let ccl = EConstr.of_constr ccl 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 @@ -2921,7 +2904,7 @@ let generalize_gen_let lconstr = Proofview.Goal.nf_s_enter { s_enter = begin fun let env = Proofview.Goal.env gl in let newcl, evd = List.fold_right_i (Tacmach.New.of_old generalize_goal gl) 0 lconstr - (EConstr.of_constr (Tacmach.New.pf_concl gl),Tacmach.New.project gl) + (Tacmach.New.pf_concl gl,Tacmach.New.project gl) in let (evd, _) = Typing.type_of env evd newcl in let map ((_, c, b),_) = if Option.is_empty b then Some c else None in @@ -2934,7 +2917,6 @@ let new_generalize_gen_let lconstr = let sigma = Proofview.Goal.sigma gl in let gl = Proofview.Goal.assume gl in let concl = Proofview.Goal.concl gl in - let concl = EConstr.of_constr concl in let sigma = Sigma.to_evar_map sigma in let env = Proofview.Goal.env gl in let ids = Tacmach.New.pf_ids_of_hyps gl in @@ -3475,8 +3457,8 @@ let cook_sign hyp0_opt inhyps indvars env sigma = (* [rel_contexts] and [rel_declaration] actually contain triples, and lists are actually in reverse order to fit [compose_prod]. *) type elim_scheme = { - elimc: EConstr.constr with_bindings option; - elimt: EConstr.types; + elimc: constr with_bindings option; + elimt: types; indref: global_reference option; params: Context.Rel.t; (* (prm1,tprm1);(prm2,tprm2)...(prmp,tprmp) *) nparams: int; (* number of parameters *) @@ -3488,7 +3470,7 @@ type elim_scheme = { nargs: int; (* number of arguments *) indarg: Context.Rel.Declaration.t option; (* Some (H,I prm1..prmp x1...xni) if HI is in premisses, None otherwise *) - concl: EConstr.types; (* Qi x1...xni HI (f...), HI and (f...) + concl: types; (* Qi x1...xni HI (f...), HI and (f...) are optional and mutually exclusive *) indarg_in_concl: bool; (* true if HI appears at the end of conclusion *) farg_in_concl: bool; (* true if (f...) appears at the end of conclusion *) @@ -3497,7 +3479,7 @@ type elim_scheme = { let empty_scheme = { elimc = None; - elimt = EConstr.mkProp; + elimt = mkProp; indref = None; params = []; nparams = 0; @@ -3508,7 +3490,7 @@ let empty_scheme = args = []; nargs = 0; indarg = None; - concl = EConstr.mkProp; + concl = mkProp; indarg_in_concl = false; farg_in_concl = false; } @@ -3582,7 +3564,7 @@ let lift_togethern n l = l ([], n) in l' -let lift_list l = List.map (EConstr.Vars.lift 1) l +let lift_list l = List.map (lift 1) l let ids_of_constr sigma ?(all=false) vars c = let rec aux vars c = @@ -4251,7 +4233,6 @@ let apply_induction_in_context with_evars hyp0 inhyps elim indvars names induct_ let env = Proofview.Goal.env gl in let sigma = Sigma.to_evar_map sigma in let concl = Tacmach.New.pf_nf_concl gl in - let concl = EConstr.of_constr concl in let statuslists,lhyp0,toclear,deps,avoid,dep_in_hyps = cook_sign hyp0 inhyps indvars env sigma in let dep_in_concl = Option.cata (fun id -> occur_var env sigma id concl) false hyp0 in let dep = dep_in_hyps || dep_in_concl in @@ -4341,7 +4322,7 @@ let induction_without_atomization isrec with_evars elim names lid = (* assume that no occurrences are selected *) let clear_unselected_context id inhyps cls = Proofview.Goal.nf_enter { enter = begin fun gl -> - if occur_var (Tacmach.New.pf_env gl) (Tacmach.New.project gl) id (EConstr.of_constr (Tacmach.New.pf_concl gl)) && + if occur_var (Tacmach.New.pf_env gl) (Tacmach.New.project gl) id (Tacmach.New.pf_concl gl) && cls.concl_occs == NoOccurrences then user_err (str "Conclusion must be mentioned: it depends on " ++ pr_id id @@ -4437,7 +4418,6 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim let check = check_enough_applied env sigma elim in let Sigma (c, sigma', p) = use_bindings env sigma elim false (c0,lbind) t0 in let abs = AbstractPattern (from_prefix,check,Name id,(pending,c),cls,false) in - let ccl = EConstr.of_constr ccl in let (id,sign,_,lastlhyp,ccl,res) = make_abstraction env sigma' ccl abs in match res with | None -> @@ -4492,7 +4472,7 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim let has_generic_occurrences_but_goal cls id env sigma ccl = clause_with_generic_context_selection cls && (* TODO: whd_evar of goal *) - (cls.concl_occs != NoOccurrences || not (occur_var env sigma id (EConstr.of_constr ccl))) + (cls.concl_occs != NoOccurrences || not (occur_var env sigma id ccl)) let induction_gen clear_flag isrec with_evars elim ((_pending,(c,lbind)),(eqname,names) as arg) cls = @@ -4736,7 +4716,7 @@ let maybe_betadeltaiota_concl allowred gl = if not allowred then concl else let env = Proofview.Goal.env gl in - whd_all env sigma (EConstr.of_constr concl) + EConstr.of_constr (whd_all env sigma concl) let reflexivity_red allowred = Proofview.Goal.enter { enter = begin fun gl -> @@ -4745,7 +4725,6 @@ let reflexivity_red allowred = inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *) let sigma = Tacmach.New.project gl in let concl = maybe_betadeltaiota_concl allowred gl in - let concl = EConstr.of_constr concl in match match_with_equality_type sigma concl with | None -> Proofview.tclZERO NoEquationFound | Some _ -> one_constructor 1 NoBindings @@ -4797,7 +4776,6 @@ let symmetry_red allowred = inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *) let sigma = Tacmach.New.project gl in let concl = maybe_betadeltaiota_concl allowred gl in - let concl = EConstr.of_constr concl in match_with_equation sigma concl >>= fun with_eqn -> match with_eqn with | Some eq_data,_,_ -> @@ -4895,7 +4873,6 @@ let transitivity_red allowred t = inside setoid_reflexivity (see Optimize cases in setoid_replace.ml). *) let sigma = Tacmach.New.project gl in let concl = maybe_betadeltaiota_concl allowred gl in - let concl = EConstr.of_constr concl in match_with_equation sigma concl >>= fun with_eqn -> match with_eqn with | Some eq_data,_,_ -> @@ -5003,7 +4980,7 @@ let abstract_subproof id gk tac = else (Context.Named.add d s1,s2)) global_sign (Context.Named.empty, empty_named_context_val) in let id = next_global_ident_away id (pf_ids_of_hyps gl) in - let concl = it_mkNamedProd_or_LetIn (EConstr.of_constr (Proofview.Goal.concl gl)) sign in + let concl = it_mkNamedProd_or_LetIn (Proofview.Goal.concl gl) sign in let concl = try flush_and_check_evars !evdref concl with Uninstantiated_evar _ -> -- cgit v1.2.3 From 0cdb7e42f64674e246d4e24e3c725e23ceeec6bd Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Mon, 21 Nov 2016 12:13:05 +0100 Subject: Reductionops now return EConstrs. --- tactics/autorewrite.ml | 1 + tactics/class_tactics.ml | 1 - tactics/contradiction.ml | 3 +- tactics/eauto.ml | 2 +- tactics/eqschemes.ml | 4 +-- tactics/equality.ml | 10 ++----- tactics/hints.ml | 3 +- tactics/leminv.ml | 4 +-- tactics/tactics.ml | 74 +++++++++++++++++++++++------------------------- tactics/tactics.mli | 2 +- 10 files changed, 47 insertions(+), 57 deletions(-) (limited to 'tactics') diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index d656206d65..0293842975 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -285,6 +285,7 @@ let decompose_applied_relation metas env sigma c ctype left2right = | Some c -> Some c | None -> let ctx,t' = Reductionops.splay_prod_assum env sigma (EConstr.of_constr ctype) in (* Search for underlying eq *) + let t' = EConstr.Unsafe.to_constr t' in match find_rel (it_mkProd_or_LetIn t' ctx) with | Some c -> Some c | None -> None diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index bf4e53b103..3a5347bbfc 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -535,7 +535,6 @@ let make_resolve_hyp env sigma st flags only_classes pri decl = | _ -> let env' = Environ.push_rel_context ctx env in let ty' = Reductionops.whd_all env' sigma ar in - let ty' = EConstr.of_constr ty' in if not (EConstr.eq_constr sigma ty' ar) then iscl env' ty' else false in diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index 2d5c28eba1..afc7e1547b 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -69,7 +69,6 @@ let contradiction_context = let typ = nf_evar sigma (NamedDecl.get_type d) in let typ = EConstr.of_constr typ in let typ = whd_all env sigma typ in - let typ = EConstr.of_constr typ in if is_empty_type sigma typ then simplest_elim (mkVar id) else match EConstr.kind sigma typ with @@ -106,7 +105,7 @@ let contradiction_context = end } let is_negation_of env sigma typ t = - match EConstr.kind sigma (EConstr.of_constr (whd_all env sigma t)) with + match EConstr.kind sigma (whd_all env sigma t) with | Prod (na,t,u) -> is_empty_type sigma u && is_conv_leq env sigma typ t | _ -> false diff --git a/tactics/eauto.ml b/tactics/eauto.ml index 57400d3340..92e59c5ce4 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -481,7 +481,7 @@ let unfold_head env sigma (ids, csts) c = true, EConstr.of_constr (Environ.constant_value_in env c) | App (f, args) -> (match aux f with - | true, f' -> true, EConstr.of_constr (Reductionops.whd_betaiota sigma (mkApp (f', args))) + | true, f' -> true, Reductionops.whd_betaiota sigma (mkApp (f', args)) | false, _ -> let done_, args' = Array.fold_left_i (fun i (done_, acc) arg -> diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml index 57bac25b90..a8ea7446fc 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -605,9 +605,9 @@ let fix_r2l_forward_rew_scheme (c, ctx') = (mkLambda_or_LetIn (RelDecl.map_constr (liftn (-1) 1) p) (mkLambda_or_LetIn (RelDecl.map_constr (liftn (-1) 2) hp) (mkLambda_or_LetIn (RelDecl.map_constr (lift 2) ind) - (Reductionops.whd_beta Evd.empty + (EConstr.Unsafe.to_constr (Reductionops.whd_beta Evd.empty (EConstr.of_constr (applist (c, - Context.Rel.to_extended_list 3 indargs @ [mkRel 1;mkRel 3;mkRel 2]))))))) + Context.Rel.to_extended_list 3 indargs @ [mkRel 1;mkRel 3;mkRel 2])))))))) in c', ctx' | _ -> anomaly (Pp.str "Ill-formed non-dependent left-to-right rewriting scheme") diff --git a/tactics/equality.ml b/tactics/equality.ml index 209c9eb662..494f36d7d9 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -413,7 +413,7 @@ let type_of_clause cls gl = match cls with let leibniz_rewrite_ebindings_clause cls lft2rgt tac c t l with_evars frzevars dep_proof_ok hdcncl = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let evd = Sigma.to_evar_map (Proofview.Goal.sigma gl) in - let isatomic = isProd evd (EConstr.of_constr (whd_zeta evd hdcncl)) in + let isatomic = isProd evd (whd_zeta evd hdcncl) in let dep_fun = if isatomic then dependent else dependent_no_evar in let type_of_cls = type_of_clause cls gl in let dep = dep_proof_ok && dep_fun evd c type_of_cls in @@ -453,7 +453,7 @@ let general_rewrite_ebindings_clause cls lft2rgt occs frzevars dep_proof_ok ?tac let env = Proofview.Goal.env gl in let ctype = get_type_of env sigma c in let ctype = EConstr.of_constr ctype in - let rels, t = decompose_prod_assum sigma (EConstr.of_constr (whd_betaiotazeta sigma ctype)) in + let rels, t = decompose_prod_assum sigma (whd_betaiotazeta sigma ctype) in match match_with_equality_type sigma t with | Some (hdcncl,args) -> (* Fast path: direct leibniz-like rewrite *) let lft2rgt = adjust_rewriting_direction args lft2rgt in @@ -470,7 +470,6 @@ let general_rewrite_ebindings_clause cls lft2rgt occs frzevars dep_proof_ok ?tac Proofview.tclEVARMAP >>= fun sigma -> let env' = push_rel_context rels env in let rels',t' = splay_prod_assum env' sigma t in (* Search for underlying eq *) - let t' = EConstr.of_constr t' in match match_with_equality_type sigma t' with | Some (hdcncl,args) -> let lft2rgt = adjust_rewriting_direction args lft2rgt in @@ -1051,7 +1050,7 @@ let onNegatedEquality with_evars tac = let sigma = Tacmach.New.project gl in let ccl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in - match EConstr.kind sigma (EConstr.of_constr (hnf_constr env sigma ccl)) with + match EConstr.kind sigma (hnf_constr env sigma ccl) with | Prod (_,t,u) when is_empty_type sigma u -> tclTHEN introf (onLastHypId (fun id -> @@ -1133,7 +1132,6 @@ let make_tuple env sigma (rterm,rty) lind = let minimal_free_rels env sigma (c,cty) = let cty_rels = free_rels sigma cty in let cty' = simpl env sigma cty in - let cty' = EConstr.of_constr cty' in let rels' = free_rels sigma cty' in if Int.Set.subset cty_rels rels' then (cty,cty_rels) @@ -1380,7 +1378,6 @@ let inject_if_homogenous_dependent_pair ty = let simplify_args env sigma t = (* Quick hack to reduce in arguments of eq only *) - let simpl env sigma c = EConstr.of_constr (simpl env sigma c) in match decompose_app sigma t with | eq, [t;c1;c2] -> applist (eq,[t;simpl env sigma c1;simpl env sigma c2]) | eq, [t1;c1;t2;c2] -> applist (eq,[t1;simpl env sigma c1;t2;simpl env sigma c2]) @@ -1591,7 +1588,6 @@ let subst_tuple_term env sigma dep_pair1 dep_pair2 b = let expected_goal = beta_applist sigma (abst_B,List.map fst e2_list) in (* Simulate now the normalisation treatment made by Logic.mk_refgoals *) let expected_goal = nf_betaiota sigma expected_goal in - let expected_goal = EConstr.of_constr expected_goal in (* Retype to get universes right *) let sigma, expected_goal_ty = Typing.type_of env sigma expected_goal in let sigma, _ = Typing.type_of env sigma body in diff --git a/tactics/hints.ml b/tactics/hints.ml index 2b310033c3..231695c35a 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -768,7 +768,7 @@ let make_exact_entry env sigma pri poly ?(name=PathAny) (c, cty, ctx) = code = with_uid (Give_exact (c, cty, ctx)); }) let make_apply_entry env sigma (eapply,hnf,verbose) pri poly ?(name=PathAny) (c, cty, ctx) = - let cty = if hnf then EConstr.of_constr (hnf_constr env sigma cty) else cty in + let cty = if hnf then hnf_constr env sigma cty else cty in match EConstr.kind sigma cty with | Prod _ -> let sigma' = Evd.merge_context_set univ_flexible sigma ctx in @@ -921,7 +921,6 @@ let make_trivial env sigma poly ?(name=PathAny) r = let c,ctx = fresh_global_or_constr env sigma poly r in let sigma = Evd.merge_context_set univ_flexible sigma ctx in let t = hnf_constr env sigma (EConstr.of_constr (unsafe_type_of env sigma c)) in - let t = EConstr.of_constr t in let hd = head_constr sigma t in let ce = mk_clenv_from_env env sigma None (c,t) in (Some hd, { pri=1; diff --git a/tactics/leminv.ml b/tactics/leminv.ml index 609fa1be83..ef3bfc9d05 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -125,7 +125,7 @@ let max_prefix_sign lid sign = | id::l -> snd (max_rec (id, sign_prefix id sign) l) *) let rec add_prods_sign env sigma t = - match EConstr.kind sigma (EConstr.of_constr (whd_all env sigma t)) with + match EConstr.kind sigma (whd_all env sigma t) with | Prod (na,c1,b) -> let id = id_of_name_using_hdchar env (EConstr.Unsafe.to_constr t) na in let b'= subst1 (mkVar id) b in @@ -180,7 +180,7 @@ let compute_first_inversion_scheme env sigma ind sort dep_option = (pty,goal) in let npty = nf_all env sigma pty in - let extenv = push_named (LocalAssum (p,npty)) env in + let extenv = push_named (nlocal_assum (p,npty)) env in extenv, goal (* [inversion_scheme sign I] diff --git a/tactics/tactics.ml b/tactics/tactics.ml index dabe78b344..5ee29c0897 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -582,7 +582,6 @@ let fix ido n = match ido with let rec check_is_mutcoind env sigma cl = let b = whd_all env sigma cl in - let b = EConstr.of_constr b in match EConstr.kind sigma b with | Prod (na, c1, b) -> check_is_mutcoind (push_rel (local_assum (na,c1)) env) sigma b @@ -634,11 +633,11 @@ let cofix ido = match ido with (* Reduction and conversion tactics *) (**************************************************************) -type tactic_reduction = env -> evar_map -> constr -> Constr.constr +type tactic_reduction = env -> evar_map -> constr -> constr let pf_reduce_decl redfun where decl gl = let open Context.Named.Declaration in - let redfun' c = EConstr.of_constr (Tacmach.New.pf_apply redfun gl c) in + let redfun' c = Tacmach.New.pf_apply redfun gl c in match decl with | LocalAssum (id,ty) -> let ty = EConstr.of_constr ty in @@ -722,7 +721,7 @@ let bind_red_expr_occurrences occs nbcl redexp = let reduct_in_concl (redfun,sty) = Proofview.Goal.nf_enter { enter = begin fun gl -> - convert_concl_no_check (EConstr.of_constr (Tacmach.New.pf_apply redfun gl (Tacmach.New.pf_concl gl))) sty + convert_concl_no_check (Tacmach.New.pf_apply redfun gl (Tacmach.New.pf_concl gl)) sty end } let reduct_in_hyp ?(check=false) redfun (id,where) = @@ -742,23 +741,25 @@ let reduct_option ?(check=false) redfun = function let pf_e_reduce_decl redfun where decl gl = let open Context.Named.Declaration in let sigma = Proofview.Goal.sigma gl in - let redfun sigma c = redfun.e_redfun (Tacmach.New.pf_env gl) sigma (EConstr.of_constr c) in + let redfun sigma c = redfun.e_redfun (Tacmach.New.pf_env gl) sigma c in match decl with | LocalAssum (id,ty) -> + let ty = EConstr.of_constr ty in if where == InHypValueOnly then user_err (pr_id id ++ str " has no value."); let Sigma (ty', sigma, p) = redfun sigma ty in - Sigma (LocalAssum (id, ty'), sigma, p) + Sigma (nlocal_assum (id, ty'), sigma, p) | LocalDef (id,b,ty) -> + let b = EConstr.of_constr b in + let ty = EConstr.of_constr ty in let Sigma (b', sigma, p) = if where != InHypTypeOnly then redfun sigma b else Sigma.here b sigma in let Sigma (ty', sigma, q) = if where != InHypValueOnly then redfun sigma ty else Sigma.here ty sigma in - Sigma (LocalDef (id, b', ty'), sigma, p +> q) + Sigma (nlocal_def (id, b', ty'), sigma, p +> q) let e_reduct_in_concl ~check (redfun, sty) = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let Sigma (c', sigma, p) = redfun.e_redfun (Tacmach.New.pf_env gl) sigma (Tacmach.New.pf_concl gl) in - let c' = EConstr.of_constr c' in Sigma (convert_concl ~check c' sty, sigma, p) end } @@ -779,7 +780,6 @@ let e_change_in_concl (redfun,sty) = Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let Sigma (c, sigma, p) = redfun.e_redfun (Proofview.Goal.env gl) sigma (Proofview.Goal.raw_concl gl) in - let c = EConstr.of_constr c in Sigma (convert_concl_no_check c sty, sigma, p) end } @@ -787,18 +787,21 @@ let e_pf_change_decl (redfun : bool -> e_reduction_function) where decl env sigm let open Context.Named.Declaration in match decl with | LocalAssum (id,ty) -> + let ty = EConstr.of_constr ty in if where == InHypValueOnly then user_err (pr_id id ++ str " has no value."); - let Sigma (ty', sigma, p) = (redfun false).e_redfun env sigma (EConstr.of_constr ty) in - Sigma (LocalAssum (id, ty'), sigma, p) + let Sigma (ty', sigma, p) = (redfun false).e_redfun env sigma ty in + Sigma (nlocal_assum (id, ty'), sigma, p) | LocalDef (id,b,ty) -> + let b = EConstr.of_constr b in + let ty = EConstr.of_constr ty in let Sigma (b', sigma, p) = - if where != InHypTypeOnly then (redfun true).e_redfun env sigma (EConstr.of_constr b) else Sigma.here b sigma + if where != InHypTypeOnly then (redfun true).e_redfun env sigma b else Sigma.here b sigma in let Sigma (ty', sigma, q) = - if where != InHypValueOnly then (redfun false).e_redfun env sigma (EConstr.of_constr ty) else Sigma.here ty sigma + if where != InHypValueOnly then (redfun false).e_redfun env sigma ty else Sigma.here ty sigma in - Sigma (LocalDef (id,b',ty'), sigma, p +> q) + Sigma (nlocal_def (id,b',ty'), sigma, p +> q) let e_change_in_hyp redfun (id,where) = Proofview.Goal.s_enter { s_enter = begin fun gl -> @@ -818,21 +821,22 @@ let check_types env sigma mayneedglobalcheck deep newc origc = let t1 = EConstr.of_constr t1 in if deep then begin let t2 = Retyping.get_type_of env sigma origc in + let t2 = EConstr.of_constr t2 in let sigma, t2 = Evarsolve.refresh_universes - ~onlyalg:true (Some false) env sigma (EConstr.of_constr t2) in + ~onlyalg:true (Some false) env sigma t2 in let t2 = EConstr.of_constr t2 in let sigma, b = infer_conv ~pb:Reduction.CUMUL env sigma t1 t2 in if not b then if - isSort sigma (EConstr.of_constr (whd_all env sigma t1)) && - isSort sigma (EConstr.of_constr (whd_all env sigma t2)) + 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 end else - if not (isSort sigma (EConstr.of_constr (whd_all env sigma t1))) then + if not (isSort sigma (whd_all env sigma t1)) then user_err ~hdr:"convert-check-hyp" (str "Not a type.") else sigma @@ -843,7 +847,7 @@ let change_and_check cv_pb mayneedglobalcheck deep t = { e_redfun = begin fun en 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.Unsafe.of_pair (EConstr.Unsafe.to_constr t', sigma) + Sigma.Unsafe.of_pair (t', sigma) end } (* Use cumulativity only if changing the conclusion not a subterm *) @@ -858,7 +862,7 @@ let change_on_subterm cv_pb deep t where = { e_redfun = begin fun env sigma c -> env sigma c in if !mayneedglobalcheck then begin - try ignore (Typing.unsafe_type_of env (Sigma.to_evar_map sigma) (EConstr.of_constr c)) + try ignore (Typing.unsafe_type_of env (Sigma.to_evar_map sigma) c) with e when catchable_exception e -> error "Replacement would lead to an ill-typed term." end; @@ -1101,8 +1105,8 @@ let intros_replacing ids = (* User-level introduction tactics *) let lookup_hypothesis_as_renamed env ccl = function - | AnonHyp n -> Detyping.lookup_index_as_renamed env ccl n - | NamedHyp id -> Detyping.lookup_name_as_displayed env ccl id + | AnonHyp n -> Detyping.lookup_index_as_renamed env (EConstr.Unsafe.to_constr ccl) n + | NamedHyp id -> Detyping.lookup_name_as_displayed env (EConstr.Unsafe.to_constr ccl) id let lookup_hypothesis_as_renamed_gen red h gl = let env = Proofview.Goal.env gl in @@ -1110,11 +1114,11 @@ let lookup_hypothesis_as_renamed_gen red h gl = match lookup_hypothesis_as_renamed env ccl h with | None when red -> let (redfun, _) = Redexpr.reduction_of_red_expr env (Red true) in - let Sigma (c, _, _) = redfun.e_redfun env (Proofview.Goal.sigma gl) (EConstr.of_constr ccl) in + let Sigma (c, _, _) = redfun.e_redfun env (Proofview.Goal.sigma gl) ccl in aux c | x -> x in - try aux (EConstr.to_constr (Tacmach.New.project gl) (Proofview.Goal.concl gl)) + try aux (Proofview.Goal.concl gl) with Redelimination -> None let is_quantified_hypothesis id gl = @@ -1261,7 +1265,6 @@ let cut c = let typ = Typing.unsafe_type_of env sigma c in let typ = EConstr.of_constr typ in let typ = whd_all env sigma typ in - let typ = EConstr.of_constr typ in match EConstr.kind sigma typ with | Sort _ -> true | _ -> false @@ -1270,7 +1273,7 @@ let cut c = if is_sort then let id = next_name_away_with_default "H" Anonymous (Tacmach.New.pf_ids_of_hyps gl) in (** Backward compat: normalize [c]. *) - let c = if normalize_cut then EConstr.of_constr (local_strong whd_betaiota sigma c) else c in + let c = if normalize_cut then local_strong whd_betaiota sigma c else c in Refine.refine ~unsafe:true { run = begin fun h -> let Sigma (f, h, p) = Evarutil.new_evar ~principal:true env h (mkArrow c (Vars.lift 1 concl)) in let Sigma (x, h, q) = Evarutil.new_evar env h c in @@ -1755,7 +1758,6 @@ let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind : let thm_ty0 = nf_betaiota sigma (EConstr.of_constr (Retyping.get_type_of env sigma c)) in let try_apply thm_ty nprod = try - let thm_ty = EConstr.of_constr thm_ty in let n = nb_prod_modulo_zeta sigma thm_ty - nprod in if n<0 then error "Applied theorem has not enough premisses."; let clause = make_clenv_binding_apply env sigma (Some n) (c,thm_ty) lbind in @@ -1766,7 +1768,7 @@ let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind : let rec try_red_apply thm_ty (exn0, info) = try (* Try to head-reduce the conclusion of the theorem *) - let red_thm = try_red_product env sigma (EConstr.of_constr thm_ty) in + let red_thm = try_red_product env sigma thm_ty in tclORELSEOPT (try_apply red_thm concl_nprod) (function (e, info) -> match e with @@ -1880,7 +1882,6 @@ let progress_with_clause flags innerclause clause = let apply_in_once_main flags innerclause env sigma (d,lbind) = let thm = nf_betaiota sigma (EConstr.of_constr (Retyping.get_type_of env sigma d)) in - let thm = EConstr.of_constr thm in let rec aux clause = try progress_with_clause flags innerclause clause with e when CErrors.noncritical e -> @@ -2183,7 +2184,6 @@ let apply_type newcl args = let store = Proofview.Goal.extra gl in Refine.refine { run = begin fun sigma -> let newcl = nf_betaiota (Sigma.to_evar_map sigma) newcl (* As in former Logic.refine *) in - let newcl = EConstr.of_constr newcl in let Sigma (ev, sigma, p) = Evarutil.new_evar env sigma ~principal:true ~store newcl in Sigma (applist (ev, args), sigma, p) @@ -2377,7 +2377,6 @@ let rewrite_hyp_then assert_style with_evars thin l2r id tac = let type_of = Tacmach.New.pf_unsafe_type_of gl in let whd_all = Tacmach.New.pf_apply whd_all gl in let t = whd_all (EConstr.of_constr (type_of (mkVar id))) in - let t = EConstr.of_constr t in let eqtac, thin = match match_with_equality_type sigma t with | Some (hdcncl,[_;lhs;rhs]) -> if l2r && isVar sigma lhs && not (occur_var env sigma (destVar sigma lhs) rhs) then @@ -3039,7 +3038,7 @@ let unfold_body x = let xval = EConstr.of_constr xval in Tacticals.New.afterHyp x begin fun aft -> let hl = List.fold_right (fun decl cl -> (NamedDecl.get_id decl, InHyp) :: cl) aft [] in - let rfun _ _ c = EConstr.Unsafe.to_constr (replace_vars [x, xval] c) in + let rfun _ _ c = replace_vars [x, xval] c in let reducth h = reduct_in_hyp rfun h in let reductc = reduct_in_concl (rfun, DEFAULTcast) in Tacticals.New.tclTHENLIST [Tacticals.New.tclMAP reducth hl; reductc] @@ -3692,7 +3691,6 @@ let abstract_args gl generalize_vars dep id defined f args = let aux (prod, ctx, ctxenv, c, args, eqs, refls, nongenvars, vars, env) arg = let name, ty, arity = let rel, c = Reductionops.splay_prod_n env !sigma 1 prod in - let c = EConstr.of_constr c in let decl = List.hd rel in RelDecl.get_name decl, RelDecl.get_type decl, c in @@ -3855,9 +3853,7 @@ let specialize_eqs id gl = let acc' = it_mkLambda_or_LetIn acc ctx'' in let ty' = Tacred.whd_simpl env !evars ty' and acc' = Tacred.whd_simpl env !evars acc' in - let acc' = EConstr.of_constr acc' in - let ty' = Evarutil.nf_evar !evars ty' in - let ty' = EConstr.of_constr ty' in + let ty' = EConstr.of_constr (Evarutil.nf_evar !evars (EConstr.Unsafe.to_constr ty')) in if worked then tclTHENFIRST (Tacmach.internal_cut true id ty') (Proofview.V82.of_tactic (exact_no_check ((* refresh_universes_strict *) acc'))) gl @@ -4368,7 +4364,7 @@ let use_bindings env sigma elim must_be_closed (c,lbind) typ = let (sigma, c) = pose_all_metas_as_evars env indclause.evd (clenv_value indclause) in Sigma.Unsafe.of_pair (c, sigma) with e when catchable_exception e -> - try find_clause (EConstr.of_constr (try_red_product env sigma typ)) + try find_clause (try_red_product env sigma typ) with Redelimination -> raise e in find_clause typ @@ -4390,7 +4386,7 @@ let check_enough_applied env sigma elim = | None -> (* No eliminator given *) fun u -> - let t,_ = decompose_app sigma (EConstr.of_constr (whd_all env sigma u)) in isInd sigma t + let t,_ = decompose_app sigma (whd_all env sigma u) in isInd sigma t | Some elimc -> let elimt = Retyping.get_type_of env sigma (fst elimc) in let elimt = EConstr.of_constr elimt in @@ -4716,7 +4712,7 @@ let maybe_betadeltaiota_concl allowred gl = if not allowred then concl else let env = Proofview.Goal.env gl in - EConstr.of_constr (whd_all env sigma concl) + whd_all env sigma concl let reflexivity_red allowred = Proofview.Goal.enter { enter = begin fun gl -> diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 630c660a15..b0d9dcb1ce 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -129,7 +129,7 @@ val exact_proof : Constrexpr.constr_expr -> unit Proofview.tactic (** {6 Reduction tactics. } *) -type tactic_reduction = env -> evar_map -> constr -> Constr.constr +type tactic_reduction = env -> evar_map -> constr -> constr type change_arg = patvar_map -> constr Sigma.run -- cgit v1.2.3 From b36adb2124d3ba8a5547605e7f89bb0835d0ab10 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 24 Nov 2016 15:50:17 +0100 Subject: Removing some return type compatibility layers in Termops. --- tactics/autorewrite.ml | 2 +- tactics/class_tactics.ml | 2 +- tactics/eqschemes.ml | 2 +- tactics/hints.ml | 4 ++-- tactics/tactics.ml | 2 +- tactics/term_dnet.ml | 4 +++- 6 files changed, 9 insertions(+), 7 deletions(-) (limited to 'tactics') diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index 0293842975..f2e98ee011 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -286,7 +286,7 @@ let decompose_applied_relation metas env sigma c ctype left2right = | None -> let ctx,t' = Reductionops.splay_prod_assum env sigma (EConstr.of_constr ctype) in (* Search for underlying eq *) let t' = EConstr.Unsafe.to_constr t' in - match find_rel (it_mkProd_or_LetIn t' ctx) with + match find_rel (Term.it_mkProd_or_LetIn t' ctx) with | Some c -> Some c | None -> None diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 3a5347bbfc..b1d5d81350 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -1492,7 +1492,7 @@ let _ = Used in the partial application tactic. *) let rec head_of_constr sigma t = - let t = strip_outer_cast sigma (EConstr.of_constr (collapse_appl sigma t)) in + let t = strip_outer_cast sigma (collapse_appl sigma t) in match EConstr.kind sigma t with | Prod (_,_,c2) -> head_of_constr sigma c2 | LetIn (_,_,_,c2) -> head_of_constr sigma c2 diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml index a8ea7446fc..e682675843 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -77,7 +77,7 @@ let build_dependent_inductive ind (mib,mip) = @ Context.Rel.to_extended_list 0 realargs) let my_it_mkLambda_or_LetIn s c = it_mkLambda_or_LetIn c s -let my_it_mkProd_or_LetIn s c = it_mkProd_or_LetIn c s +let my_it_mkProd_or_LetIn s c = Term.it_mkProd_or_LetIn c s let my_it_mkLambda_or_LetIn_name s c = it_mkLambda_or_LetIn_name (Global.env()) c s diff --git a/tactics/hints.ml b/tactics/hints.ml index 231695c35a..d4b73706ce 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -1211,7 +1211,7 @@ let prepare_hint check (poly,local) env init (sigma,c) = | Evar (evk,args as ev) -> (* We skip the test whether args is the identity or not *) let t = existential_type sigma ev in - let t = List.fold_right (fun (e,id) c -> EConstr.of_constr (replace_term sigma e id c)) !subst t in + let t = List.fold_right (fun (e,id) c -> replace_term sigma e id c) !subst t in if not (closed0 sigma c) then error "Hints with holes dependent on a bound variable not supported."; if occur_existential sigma t then @@ -1225,7 +1225,7 @@ let prepare_hint check (poly,local) env init (sigma,c) = let id = next_ident_away_from default_prepare_hint_ident (fun id -> Id.Set.mem id !vars) in vars := Id.Set.add id !vars; subst := (evar,mkVar id)::!subst; - mkNamedLambda id t (iter (EConstr.of_constr (replace_term sigma evar (mkVar id) c))) in + mkNamedLambda id t (iter (replace_term sigma evar (mkVar id) c)) in let c' = iter c in if check then Pretyping.check_evars (Global.env()) Evd.empty sigma c'; let diff = Univ.ContextSet.diff (Evd.universe_context_set sigma) (Evd.universe_context_set init) in diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 5ee29c0897..b2f2797a63 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -4544,7 +4544,7 @@ let induction_gen_l isrec with_evars elim names lc = id_of_name_using_hdchar (Global.env()) (type_of c) Anonymous in let id = new_fresh_id [] x gl in - let newl' = List.map (fun r -> EConstr.of_constr (replace_term sigma c (mkVar id) r)) l' in + let newl' = List.map (fun r -> replace_term sigma c (mkVar id) r) l' in let _ = newlc:=id::!newlc in Tacticals.New.tclTHEN (letin_tac None (Name id) c None allHypsAndConcl) diff --git a/tactics/term_dnet.ml b/tactics/term_dnet.ml index 38342b64dc..219abb7fdd 100644 --- a/tactics/term_dnet.ml +++ b/tactics/term_dnet.ml @@ -350,9 +350,11 @@ struct TDnet.Idset.fold (fun id acc -> let c_id = Opt.reduce (Ident.constr_of id) in + let c_id = EConstr.of_constr c_id in let (ctx,wc) = - try Termops.align_prod_letin Evd.empty (EConstr.of_constr whole_c) (EConstr.of_constr c_id) (** FIXME *) + try Termops.align_prod_letin Evd.empty (EConstr.of_constr whole_c) c_id (** FIXME *) with Invalid_argument _ -> [],c_id in + let wc = EConstr.Unsafe.to_constr wc in let wc,whole_c = if Opt.direction then whole_c,wc else wc,whole_c in try let _ = Termops.filtering Evd.empty ctx Reduction.CUMUL wc whole_c in -- cgit v1.2.3 From 531590c223af42c07a93142ab0cea470a98964e6 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 24 Nov 2016 17:15:15 +0100 Subject: Removing compatibility layers in Retyping --- tactics/class_tactics.ml | 2 -- tactics/eqschemes.ml | 1 + tactics/equality.ml | 13 +------------ tactics/hints.ml | 1 - tactics/inv.ml | 4 ++-- tactics/tactics.ml | 32 +++++++------------------------- 6 files changed, 11 insertions(+), 42 deletions(-) (limited to 'tactics') diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index b1d5d81350..2f8af6b449 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -283,7 +283,6 @@ let clenv_of_prods poly nprods (c, clenv) gl = else let sigma = Tacmach.New.project gl in let ty = Retyping.get_type_of (Proofview.Goal.env gl) sigma c in - let ty = EConstr.of_constr ty in let diff = nb_prod sigma ty - nprods in if Pervasives.(>=) diff 0 then (* Was Some clenv... *) @@ -477,7 +476,6 @@ let pr_depth l = prlist_with_sep (fun () -> str ".") int (List.rev l) let is_Prop env sigma concl = let ty = Retyping.get_type_of env sigma concl in - let ty = EConstr.of_constr ty in match EConstr.kind sigma ty with | Sort (Prop Null) -> true | _ -> false diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml index e682675843..855273d3bf 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -597,6 +597,7 @@ let build_r2l_forward_rew_scheme dep env ind kind = let fix_r2l_forward_rew_scheme (c, ctx') = let t = Retyping.get_type_of (Global.env()) Evd.empty (EConstr.of_constr c) in + let t = EConstr.Unsafe.to_constr t in let ctx,_ = decompose_prod_assum t in match ctx with | hp :: p :: ind :: indargs -> diff --git a/tactics/equality.ml b/tactics/equality.ml index 494f36d7d9..e1c39bb34e 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -188,7 +188,6 @@ let instantiate_lemma_all frzevars gl c ty l l2r concl = let instantiate_lemma gl c ty l l2r concl = let sigma, ct = pf_type_of gl c in - let ct = EConstr.of_constr ct in let t = try snd (reduce_to_quantified_ind (pf_env gl) sigma ct) with UserError _ -> ct in let eqclause = Clenv.make_clenv_binding (pf_env gl) sigma (c,t) l in [eqclause] @@ -452,7 +451,6 @@ let general_rewrite_ebindings_clause cls lft2rgt occs frzevars dep_proof_ok ?tac let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let ctype = get_type_of env sigma c in - let ctype = EConstr.of_constr ctype in let rels, t = decompose_prod_assum sigma (whd_betaiotazeta sigma ctype) in match match_with_equality_type sigma t with | Some (hdcncl,args) -> (* Fast path: direct leibniz-like rewrite *) @@ -635,8 +633,6 @@ let replace_using_leibniz clause c1 c2 l2r unsafe try_prove_eq_opt = let get_type_of = pf_apply get_type_of gl in let t1 = get_type_of c1 and t2 = get_type_of c2 in - let t1 = EConstr.of_constr t1 in - let t2 = EConstr.of_constr t2 in let evd = if unsafe then Some (Tacmach.New.project gl) else @@ -733,7 +729,6 @@ let _ = let find_positions env sigma t1 t2 = let project env sorts posn t1 t2 = let ty1 = get_type_of env sigma t1 in - let ty1 = EConstr.of_constr ty1 in let s = get_sort_family_of env sigma ty1 in if Sorts.List.mem s sorts then [(List.rev posn,t1,t2)] else [] @@ -856,7 +851,7 @@ let injectable env sigma t1 t2 = let descend_then env sigma head dirn = let IndType (indf,_) = - try find_rectype env sigma (EConstr.of_constr (get_type_of env sigma head)) + try find_rectype env sigma (get_type_of env sigma head) with Not_found -> error "Cannot project on an inductive type derived from a dependency." in let indp,_ = (dest_ind_family indf) in @@ -912,7 +907,6 @@ let build_selector env sigma dirn c ind special default = let (indp,_) = dest_ind_family indf in let ind, _ = check_privacy env indp in let typ = Retyping.get_type_of env sigma default in - let typ = EConstr.of_constr typ in let (mib,mip) = lookup_mind_specif env ind in let deparsign = make_arity_signature env true indf in let p = it_mkLambda_or_LetIn typ deparsign in @@ -932,7 +926,6 @@ let build_coq_I () = EConstr.of_constr (build_coq_I ()) let rec build_discriminator env sigma dirn c = function | [] -> let ind = get_type_of env sigma c in - let ind = EConstr.of_constr ind in let true_0,false_0 = build_coq_True(),build_coq_False() in build_selector env sigma dirn c ind true_0 false_0 @@ -1108,7 +1101,6 @@ let make_tuple env sigma (rterm,rty) lind = assert (not (noccurn sigma lind rty)); let sigdata = find_sigma_data env (get_sort_of env sigma rty) in let sigma, a = type_of ~refresh:true env sigma (mkRel lind) in - let a = EConstr.of_constr a in let na = Context.Rel.Declaration.get_name (lookup_rel lind env) in (* We move [lind] to [1] and lift other rels > [lind] by 1 *) let rty = lift (1-lind) (liftn lind (lind+1) rty) in @@ -1396,7 +1388,6 @@ let inject_at_positions env sigma l2r (eq,_,(t,t1,t2)) eq_clause posns tac = let congr = EConstr.of_constr congr in let pf = applist(congr,[t;resty;injfun;t1;t2]) in let sigma, pf_typ = Typing.type_of env sigma pf in - let pf_typ = EConstr.of_constr pf_typ in let inj_clause = apply_on_clause (pf,pf_typ) eq_clause in let pf = Clenvtac.clenv_value_cast_meta inj_clause in let ty = simplify_args env sigma (clenv_type inj_clause) in @@ -1567,7 +1558,6 @@ let lambda_create env (a,b) = let subst_tuple_term env sigma dep_pair1 dep_pair2 b = let sigma = Sigma.to_evar_map sigma in let typ = get_type_of env sigma dep_pair1 in - let typ = EConstr.of_constr typ in (* We find all possible decompositions *) let decomps1 = decomp_tuple_term env sigma dep_pair1 typ in let decomps2 = decomp_tuple_term env sigma dep_pair2 typ in @@ -1659,7 +1649,6 @@ let cutRewriteInConcl l2r eqn = cutRewriteClause l2r eqn None let substClause l2r c cls = Proofview.Goal.enter { enter = begin fun gl -> let eq = pf_apply get_type_of gl c in - let eq = EConstr.of_constr eq in tclTHENS (cutSubstClause l2r eq cls) [Proofview.tclUNIT (); exact_no_check c] end } diff --git a/tactics/hints.ml b/tactics/hints.ml index d4b73706ce..9e9635e8ab 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -855,7 +855,6 @@ let fresh_global_or_constr env sigma poly cr = let make_resolves env sigma flags pri poly ?name cr = let c, ctx = fresh_global_or_constr env sigma poly cr in let cty = Retyping.get_type_of env sigma c in - let cty = EConstr.of_constr cty in let try_apply f = try Some (f (c, cty, ctx)) with Failure _ -> None in let ents = List.map_filter try_apply diff --git a/tactics/inv.ml b/tactics/inv.ml index e45eb2a16a..a398e04dda 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -63,10 +63,10 @@ let var_occurs_in_pf gl id = *) -type inversion_status = Dep of EConstr.constr option | NoDep +type inversion_status = Dep of constr option | NoDep let compute_eqn env sigma n i ai = - (mkRel (n-i),EConstr.of_constr (get_type_of env sigma (mkRel (n-i)))) + (mkRel (n-i),get_type_of env sigma (mkRel (n-i))) let make_inv_predicate env evd indf realargs id status concl = let nrealargs = List.length realargs in diff --git a/tactics/tactics.ml b/tactics/tactics.ml index b2f2797a63..574f1c6f3c 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -818,13 +818,10 @@ let make_change_arg c pats = let check_types env sigma mayneedglobalcheck deep newc origc = let t1 = Retyping.get_type_of env sigma newc in - let t1 = EConstr.of_constr t1 in if deep then begin let t2 = Retyping.get_type_of env sigma origc in - let t2 = EConstr.of_constr t2 in let sigma, t2 = Evarsolve.refresh_universes ~onlyalg:true (Some false) env sigma t2 in - let t2 = EConstr.of_constr t2 in let sigma, b = infer_conv ~pb:Reduction.CUMUL env sigma t1 t2 in if not b then if @@ -1448,7 +1445,6 @@ let general_elim_clause_gen elimtac indclause elim = let sigma = Tacmach.New.project gl in let (elimc,lbindelimc) = elim.elimbody in let elimt = Retyping.get_type_of env sigma elimc in - let elimt = EConstr.of_constr elimt in let i = match elim.elimindex with None -> index_of_ind_arg sigma elimt | Some i -> i in elimtac elim.elimrename i (elimc, elimt, lbindelimc) indclause @@ -1459,7 +1455,6 @@ let general_elim with_evars clear_flag (c, lbindc) elim = let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let ct = Retyping.get_type_of env sigma c in - let ct = EConstr.of_constr ct in let t = try snd (reduce_to_quantified_ind env sigma ct) with UserError _ -> ct in let elimtac = elimination_clause_scheme with_evars in let indclause = make_clenv_binding env sigma (c, t) lbindc in @@ -1478,7 +1473,6 @@ let general_case_analysis_in_context with_evars clear_flag (c,lbindc) = let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl gl in let t = Retyping.get_type_of env (Sigma.to_evar_map sigma) c in - let t = EConstr.of_constr t in let (mind,_) = reduce_to_quantified_ind env (Sigma.to_evar_map sigma) t in let sort = Tacticals.New.elimination_sort_of_goal gl in let Sigma (elim, sigma, p) = @@ -1598,7 +1592,6 @@ let elimination_in_clause_scheme with_evars ?(flags=elim_flags ()) let elimclause' = clenv_fchain ~flags indmv elimclause indclause in let hyp = mkVar id in let hyp_typ = Retyping.get_type_of env sigma hyp in - let hyp_typ = EConstr.of_constr hyp_typ in let hypclause = mk_clenv_from_env env sigma (Some 0) (hyp, hyp_typ) in let elimclause'' = clenv_fchain_in id ~flags hypmv elimclause' hypclause in let new_hyp_typ = clenv_type elimclause'' in @@ -1662,7 +1655,6 @@ let make_projection env sigma params cstr sign elim i n c u = in let app = it_mkLambda_or_LetIn proj sign in let t = Retyping.get_type_of env sigma app in - let t = EConstr.of_constr t in Some (app, t) | None -> None in elim @@ -1673,7 +1665,6 @@ let descend_in_conjunctions avoid tac (err, info) c = let sigma = Tacmach.New.project gl in try let t = Retyping.get_type_of env sigma c in - let t = EConstr.of_constr t in let ((ind,u),t) = reduce_to_quantified_ind env sigma t in let sign,ccl = EConstr.decompose_prod_assum sigma t in match match_with_tuple sigma ccl with @@ -1755,7 +1746,7 @@ let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind : let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in - let thm_ty0 = nf_betaiota sigma (EConstr.of_constr (Retyping.get_type_of env sigma c)) in + let thm_ty0 = nf_betaiota sigma (Retyping.get_type_of env sigma c) in let try_apply thm_ty nprod = try let n = nb_prod_modulo_zeta sigma thm_ty - nprod in @@ -1881,7 +1872,7 @@ let progress_with_clause flags innerclause clause = with Not_found -> error "Unable to unify." let apply_in_once_main flags innerclause env sigma (d,lbind) = - let thm = nf_betaiota sigma (EConstr.of_constr (Retyping.get_type_of env sigma d)) in + let thm = nf_betaiota sigma (Retyping.get_type_of env sigma d) in let rec aux clause = try progress_with_clause flags innerclause clause with e when CErrors.noncritical e -> @@ -1993,7 +1984,6 @@ let exact_check c = let env = Proofview.Goal.env gl in let sigma = Sigma.to_evar_map sigma in let sigma, ct = Typing.type_of env sigma c in - let ct = EConstr.of_constr ct in let tac = Tacticals.New.tclTHEN (convert_leq ct concl) (exact_no_check c) in @@ -2662,9 +2652,7 @@ let letin_tac_gen with_eq (id,depdecls,lastlhyp,ccl,c) ty = | Some t -> Sigma.here t sigma | None -> let t = typ_of env sigma c in - let t = EConstr.of_constr t in let sigma, c = Evarsolve.refresh_universes ~onlyalg:true (Some false) env (Sigma.to_evar_map sigma) t in - let c = EConstr.of_constr c in Sigma.Unsafe.of_pair (c, sigma) in let Sigma ((newcl, eq_tac), sigma, q) = match with_eq with @@ -2717,7 +2705,7 @@ let insert_before decls lasthyp env = let mkletin_goal env sigma store with_eq dep (id,lastlhyp,ccl,c) ty = let open Context.Named.Declaration in - let t = match ty with Some t -> t | _ -> EConstr.of_constr (typ_of env sigma c) in + let t = match ty with Some t -> t | _ -> typ_of env sigma c in let decl = if dep then nlocal_def (id,c,t) else nlocal_assum (id,t) in @@ -2850,7 +2838,6 @@ 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 - let t = EConstr.of_constr t in generalize_goal_gen env sigma ids i o t cl let old_generalize_dep ?(with_let=false) c gl = @@ -2923,7 +2910,6 @@ let new_generalize_gen_let lconstr = List.fold_right_i (fun i ((_,c,b),_ as o) (cl, sigma, args) -> let sigma, t = Typing.type_of env sigma c in - let t = EConstr.of_constr t in let args = if Option.is_empty b then c :: args else args in let cl, sigma = generalize_goal_gen env sigma ids i o t cl in (cl, sigma, args)) @@ -2974,7 +2960,7 @@ let specialize (c,lbind) ipat = let sigma = Typeclasses.resolve_typeclasses env sigma in sigma, nf_evar sigma c else - let clause = make_clenv_binding env sigma (c,EConstr.of_constr (Retyping.get_type_of env sigma c)) lbind in + let clause = make_clenv_binding env sigma (c,Retyping.get_type_of env sigma 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 @@ -2991,7 +2977,6 @@ let specialize (c,lbind) ipat = str "."); clause.evd, term in let typ = Retyping.get_type_of env sigma term in - let typ = EConstr.of_constr typ in let tac = match EConstr.kind sigma (fst(EConstr.decompose_app sigma (snd(EConstr.decompose_lam_assum sigma c)))) with | Var id when Id.List.mem id (Tacmach.New.pf_ids_of_hyps gl) -> @@ -3699,7 +3684,6 @@ let abstract_args gl generalize_vars dep id defined f args = let argty = EConstr.of_constr argty in let sigma', ty = Evarsolve.refresh_universes (Some true) env !sigma ty in let () = sigma := sigma' in - let ty = EConstr.of_constr ty in let lenctx = List.length ctx in let liftargty = lift lenctx argty in let leq = constr_cmp !sigma Reduction.CUMUL liftargty ty in @@ -3751,7 +3735,7 @@ let abstract_args gl generalize_vars dep id defined f args = else [] in let body, c' = - if defined then Some c', EConstr.of_constr (Retyping.get_type_of ctxenv !sigma c') + if defined then Some c', Retyping.get_type_of ctxenv !sigma c' else None, c' in let typ = Tacmach.pf_get_hyp_typ gl id in @@ -4339,7 +4323,6 @@ let clear_unselected_context id inhyps cls = let use_bindings env sigma elim must_be_closed (c,lbind) typ = let sigma = Sigma.to_evar_map sigma in - let typ = EConstr.of_constr typ in let typ = if elim == None then (* w/o an scheme, the term has to be applied at least until @@ -4389,7 +4372,6 @@ let check_enough_applied env sigma elim = let t,_ = decompose_app sigma (whd_all env sigma u) in isInd sigma t | Some elimc -> let elimt = Retyping.get_type_of env sigma (fst elimc) in - let elimt = EConstr.of_constr elimt in let scheme = compute_elim_sig sigma ~elimc elimt in match scheme.indref with | None -> @@ -4435,7 +4417,6 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim let b = not with_evars && with_eq != None in let Sigma (c, sigma, p) = use_bindings env sigma elim b (c0,lbind) t0 in let t = Retyping.get_type_of env (Sigma.to_evar_map sigma) c in - let t = EConstr.of_constr t in let Sigma (ans, sigma, q) = mkletin_goal env sigma store with_eq false (id,lastlhyp,ccl,c) (Some t) in Sigma (ans, sigma, p +> q) end }; @@ -4487,7 +4468,7 @@ let induction_gen clear_flag isrec with_evars elim && lbind == NoBindings && not with_evars && Option.is_empty eqname && clear_flag == None && has_generic_occurrences_but_goal cls (destVar evd c) env evd ccl in - let enough_applied = check_enough_applied env sigma elim (EConstr.of_constr t) in + let enough_applied = check_enough_applied env sigma elim t in if is_arg_pure_hyp && enough_applied then (* First case: induction on a variable already in an inductive type and with maximal abstraction over the variable. @@ -4504,6 +4485,7 @@ let induction_gen clear_flag isrec with_evars elim declaring the induction argument as a new local variable *) let id = (* Type not the right one if partially applied but anyway for internal use*) + let t = EConstr.Unsafe.to_constr t in let x = id_of_name_using_hdchar (Global.env()) t Anonymous in new_fresh_id [] x gl in let info_arg = (is_arg_pure_hyp, not enough_applied) in -- cgit v1.2.3 From 05afd04095e35d77ca135bd2c1cb8d303ea2d6a8 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 24 Nov 2016 18:18:17 +0100 Subject: Ltac now uses evar-based constrs. --- tactics/auto.ml | 2 +- tactics/tactics.ml | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) (limited to 'tactics') diff --git a/tactics/auto.ml b/tactics/auto.ml index 4218be0bbd..b548f8b928 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -152,7 +152,7 @@ let conclPattern concl pat tac = let open Genarg in let open Geninterp in let inj c = match val_tag (topwit Stdarg.wit_constr) with - | Val.Base tag -> Val.Dyn (tag, EConstr.Unsafe.to_constr c) + | Val.Base tag -> Val.Dyn (tag, c) | _ -> assert false in let fold id c accu = Id.Map.add id (inj c) accu in diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 574f1c6f3c..4e833eb556 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -51,7 +51,7 @@ open Context.Named.Declaration module RelDecl = Context.Rel.Declaration module NamedDecl = Context.Named.Declaration -let inj_with_occurrences e = (AllOccurrences,EConstr.Unsafe.to_constr e) +let inj_with_occurrences e = (AllOccurrences,e) let dloc = Loc.ghost @@ -922,7 +922,7 @@ let reduction_clause redexp cl = let reduce redexp cl = let trace () = let open Printer in - let pr = (pr_constr, pr_lconstr, pr_evaluable_reference, pr_constr_pattern) in + let pr = (pr_econstr, pr_leconstr, pr_evaluable_reference, pr_constr_pattern) in Pp.(hov 2 (Pputils.pr_red_expr pr str redexp)) in Proofview.Trace.name_tactic trace begin -- cgit v1.2.3 From 778e863b77bcafc8ed339dd02226e85e5fee2532 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 25 Nov 2016 11:36:09 +0100 Subject: Removing compatibility layers related to printing. --- tactics/class_tactics.ml | 9 ++++----- tactics/hints.ml | 8 ++++---- tactics/leminv.ml | 8 +++----- tactics/tactics.ml | 2 +- 4 files changed, 12 insertions(+), 15 deletions(-) (limited to 'tactics') diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 2f8af6b449..84ca0aa8f2 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -185,8 +185,7 @@ let set_typeclasses_depth = optwrite = set_typeclasses_depth; } let pr_ev evs ev = - Printer.pr_constr_env (Goal.V82.env evs ev) evs - (Evarutil.nf_evar evs (EConstr.Unsafe.to_constr (Goal.V82.concl evs ev))) + Printer.pr_econstr_env (Goal.V82.env evs ev) evs (Goal.V82.concl evs ev) (** Typeclasses instance search tactic / eauto *) @@ -764,7 +763,7 @@ module V85 = struct if foundone == None && !typeclasses_debug > 0 then Feedback.msg_debug (pr_depth info.auto_depth ++ str": no match for " ++ - Printer.pr_constr_env (Goal.V82.env s gl) s (EConstr.Unsafe.to_constr concl) ++ + Printer.pr_econstr_env (Goal.V82.env s gl) s concl ++ spc () ++ str ", " ++ int (List.length poss) ++ str" possibilities"); match foundone with @@ -1005,7 +1004,7 @@ module Search = struct if !typeclasses_debug > 0 then Feedback.msg_debug (pr_depth info.search_depth ++ str": looking for " ++ - Printer.pr_constr_env (Goal.env gl) s (EConstr.Unsafe.to_constr concl) ++ + Printer.pr_econstr_env (Goal.env gl) s concl ++ (if backtrack then str" with backtracking" else str" without backtracking")); let secvars = compute_secvars gl in @@ -1120,7 +1119,7 @@ module Search = struct if !foundone == false && !typeclasses_debug > 0 then Feedback.msg_debug (pr_depth info.search_depth ++ str": no match for " ++ - Printer.pr_constr_env (Goal.env gl) s (EConstr.Unsafe.to_constr concl) ++ + Printer.pr_econstr_env (Goal.env gl) s concl ++ spc () ++ str ", " ++ int (List.length poss) ++ str" possibilities"); match e with diff --git a/tactics/hints.ml b/tactics/hints.ml index 9e9635e8ab..2446b6996b 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -792,7 +792,7 @@ let make_apply_entry env sigma (eapply,hnf,verbose) pri poly ?(name=PathAny) (c, else begin if not eapply then failwith "make_apply_entry"; if verbose then - Feedback.msg_info (str "the hint: eapply " ++ pr_lconstr (EConstr.Unsafe.to_constr c) ++ + Feedback.msg_info (str "the hint: eapply " ++ pr_leconstr_env env sigma' c ++ str " will only be used by eauto"); (Some hd, { pri = (match pri with None -> nb_hyp sigma' cty + nmiss | Some p -> p); @@ -813,7 +813,7 @@ let pr_hint_term env sigma ctx = function | IsGlobRef gr -> pr_global gr | IsConstr (c, ctx) -> let sigma = Evd.merge_context_set Evd.univ_flexible sigma ctx in - pr_constr_env env sigma (EConstr.Unsafe.to_constr c) + pr_econstr_env env sigma c (** We need an object to record the side-effect of registering global universes associated with a hint. *) @@ -863,7 +863,7 @@ let make_resolves env sigma flags pri poly ?name cr = in if List.is_empty ents then user_err ~hdr:"Hint" - (pr_lconstr (EConstr.Unsafe.to_constr c) ++ spc() ++ + (pr_leconstr_env env sigma c ++ spc() ++ (if pi1 flags then str"cannot be used as a hint." else str "can be used as a hint only for eauto.")); ents @@ -1360,7 +1360,7 @@ let make_db_list dbnames = (* Functions for printing the hints *) (**************************************************************************) -let pr_hint_elt (c, _, _) = pr_constr (EConstr.Unsafe.to_constr c) +let pr_hint_elt (c, _, _) = pr_econstr c let pr_hint h = match h.obj with | Res_pf (c, _) -> (str"simple apply " ++ pr_hint_elt c) diff --git a/tactics/leminv.ml b/tactics/leminv.ml index ef3bfc9d05..2d59285e66 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -42,7 +42,7 @@ let nlocal_def (na, b, t) = let no_inductive_inconstr env sigma constr = (str "Cannot recognize an inductive predicate in " ++ - pr_lconstr_env env sigma (EConstr.Unsafe.to_constr constr) ++ + pr_leconstr_env env sigma constr ++ str "." ++ spc () ++ str "If there is one, may be the structure of the arity" ++ spc () ++ str "or of the type of constructors" ++ spc () ++ str "is hidden by constant definitions.") @@ -277,14 +277,12 @@ let lemInv id c gls = Proofview.V82.of_tactic (Clenvtac.res_pf clause ~flags:(Unification.elim_flags ()) ~with_evars:false) gls with | NoSuchBinding -> - let c = EConstr.Unsafe.to_constr c in user_err - (hov 0 (pr_constr c ++ spc () ++ str "does not refer to an inversion lemma.")) + (hov 0 (pr_econstr_env (Refiner.pf_env gls) (Refiner.project gls) c ++ spc () ++ str "does not refer to an inversion lemma.")) | UserError (a,b) -> - let c = EConstr.Unsafe.to_constr c in user_err ~hdr:"LemInv" (str "Cannot refine current goal with the lemma " ++ - pr_lconstr_env (Refiner.pf_env gls) (Refiner.project gls) c) + pr_leconstr_env (Refiner.pf_env gls) (Refiner.project gls) c) let lemInv_gen id c = try_intros_until (fun id -> Proofview.V82.tactic (lemInv id c)) id diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 4e833eb556..dcaa15fd8f 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -3073,7 +3073,7 @@ let warn_unused_intro_pattern = strbrk"Unused introduction " ++ str (String.plural (List.length names) "pattern") ++ str": " ++ prlist_with_sep spc (Miscprint.pr_intro_pattern - (fun c -> Printer.pr_constr (EConstr.Unsafe.to_constr (fst (run_delayed (Global.env()) Evd.empty c))))) names) + (fun c -> Printer.pr_econstr (fst (run_delayed (Global.env()) Evd.empty c)))) names) let check_unused_names names = if not (List.is_empty names) && Flags.is_verbose () then -- cgit v1.2.3 From 02dd160233adc784eac732d97a88356d1f0eaf9b Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 25 Nov 2016 18:34:53 +0100 Subject: Removing various compatibility layers of tactics. --- tactics/autorewrite.ml | 11 ++++++----- tactics/class_tactics.ml | 2 -- tactics/contradiction.ml | 1 - tactics/eauto.ml | 5 ++--- tactics/elim.ml | 2 -- tactics/eqdecide.ml | 2 -- tactics/equality.ml | 20 +++++++------------- tactics/hints.ml | 3 +-- tactics/hipattern.ml | 2 +- tactics/inv.ml | 4 ++-- tactics/leminv.ml | 1 - tactics/tacticals.ml | 22 +++++++++++----------- tactics/tactics.ml | 34 ++++++++-------------------------- 13 files changed, 38 insertions(+), 71 deletions(-) (limited to 'tactics') diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index f2e98ee011..f43f4b2502 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -257,7 +257,7 @@ type hypinfo = { let decompose_applied_relation metas env sigma c ctype left2right = let find_rel ty = - let eqclause = Clenv.mk_clenv_from_env env sigma None (EConstr.of_constr c,EConstr.of_constr ty) in + let eqclause = Clenv.mk_clenv_from_env env sigma None (EConstr.of_constr c,ty) in let eqclause = if metas then eqclause else clenv_pose_metas_as_evars eqclause (Evd.undefined_metas eqclause.evd) @@ -274,6 +274,8 @@ let decompose_applied_relation metas env sigma c ctype left2right = 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 (* 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; @@ -284,9 +286,8 @@ let decompose_applied_relation metas env sigma c ctype left2right = match find_rel ctype with | Some c -> Some c | None -> - let ctx,t' = Reductionops.splay_prod_assum env sigma (EConstr.of_constr ctype) in (* Search for underlying eq *) - let t' = EConstr.Unsafe.to_constr t' in - match find_rel (Term.it_mkProd_or_LetIn t' ctx) with + let ctx,t' = Reductionops.splay_prod_assum env sigma ctype in (* Search for underlying eq *) + match find_rel (it_mkProd_or_LetIn t' ctx) with | Some c -> Some c | None -> None @@ -296,7 +297,7 @@ let find_applied_relation metas loc env sigma c left2right = | Some c -> c | None -> user_err ~loc ~hdr:"decompose_applied_relation" - (str"The type" ++ spc () ++ Printer.pr_constr_env env sigma ctype ++ + (str"The type" ++ spc () ++ Printer.pr_econstr_env env sigma ctype ++ spc () ++ str"of this term does not end with an applied relation.") (* To add rewriting rules to a base *) diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 84ca0aa8f2..fa2c21ac31 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -227,7 +227,6 @@ let e_give_exact flags poly (c,clenv) gl = else c, gl in let t1 = pf_unsafe_type_of gl c in - let t1 = EConstr.of_constr t1 in Proofview.V82.of_tactic (Clenvtac.unify ~flags t1 <*> exact_no_check c) gl let unify_e_resolve poly flags = { enter = begin fun gls (c,_,clenv) -> @@ -1515,7 +1514,6 @@ let autoapply c i gl = let flags = auto_unif_flags Evar.Set.empty (Hints.Hint_db.transparent_state (Hints.searchtable_map i)) in let cty = pf_unsafe_type_of gl c in - let cty = EConstr.of_constr cty in let ce = mk_clenv_from gl (c,cty) in let tac = { enter = fun gl -> (unify_e_resolve false flags).enter gl ((c,cty,Univ.ContextSet.empty),0,ce) } in diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index afc7e1547b..a3a448aadc 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -116,7 +116,6 @@ let contradiction_term (c,lbind as cl) = let env = Proofview.Goal.env gl in let type_of = Tacmach.New.pf_unsafe_type_of gl in let typ = type_of c in - let typ = EConstr.of_constr typ in let _, ccl = splay_prod env sigma typ in if is_empty_type sigma ccl then Tacticals.New.tclTHEN diff --git a/tactics/eauto.ml b/tactics/eauto.ml index 92e59c5ce4..01f21910cf 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -32,7 +32,6 @@ let eauto_unif_flags = auto_flags_of_state full_transparent_state let e_give_exact ?(flags=eauto_unif_flags) c = Proofview.Goal.enter { enter = begin fun gl -> let t1 = Tacmach.New.pf_unsafe_type_of gl c in - let t1 = EConstr.of_constr t1 in let t2 = Tacmach.New.pf_concl (Proofview.Goal.assume gl) in let sigma = Tacmach.New.project gl in if occur_existential sigma t1 || occur_existential sigma t2 then @@ -290,7 +289,7 @@ module SearchProblem = struct in let rec_tacs = let l = - let concl = Reductionops.nf_evar (project g)(pf_concl g) in + let concl = Reductionops.nf_evar (project g) (EConstr.Unsafe.to_constr (pf_concl g)) in let concl = EConstr.of_constr concl in filter_tactics s.tacres (e_possible_resolve (project g) s.dblist (List.hd s.localdb) secvars concl) @@ -516,7 +515,7 @@ let autounfold_one db cl = (Id.Set.union ids i, Cset.union csts c)) (Id.Set.empty, Cset.empty) db in let did, c' = unfold_head env sigma st - (match cl with Some (id, _) -> EConstr.of_constr (Tacmach.New.pf_get_hyp_typ id gl) | None -> concl) + (match cl with Some (id, _) -> Tacmach.New.pf_get_hyp_typ id gl | None -> concl) in if did then match cl with diff --git a/tactics/elim.ml b/tactics/elim.ml index ef848c2e13..a4158f8218 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -82,7 +82,6 @@ let general_decompose recognizer c = let type_of = pf_unsafe_type_of gl in let sigma = project gl in let typc = type_of c in - let typc = EConstr.of_constr typc in tclTHENS (cut typc) [ tclTHEN (intro_using tmphyp_name) (onLastHypId @@ -136,7 +135,6 @@ let induction_trailer abs_i abs_j bargs = (fun id -> Proofview.Goal.nf_enter { enter = begin fun gl -> let idty = pf_unsafe_type_of gl (mkVar id) in - let idty = EConstr.of_constr idty in let fvty = global_vars (pf_env gl) (project gl) idty in let possible_bring_hyps = (List.tl (nLastDecls gl (abs_j - abs_i))) @ bargs.Tacticals.assums diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml index 16e0d96848..df60f2c66c 100644 --- a/tactics/eqdecide.ml +++ b/tactics/eqdecide.ml @@ -163,7 +163,6 @@ let rec solveArg hyps eqonleft op largs rargs = match largs, rargs with | a1 :: largs, a2 :: rargs -> Proofview.Goal.enter { enter = begin fun gl -> let rectype = pf_unsafe_type_of gl a1 in - let rectype = EConstr.of_constr rectype in let decide = mkDecideEqGoal eqonleft op rectype a1 a2 in let tac hyp = solveArg (hyp :: hyps) eqonleft op largs rargs in let subtacs = @@ -236,7 +235,6 @@ let decideEquality rectype = let compare c1 c2 = Proofview.Goal.enter { enter = begin fun gl -> let rectype = pf_unsafe_type_of gl c1 in - let rectype = EConstr.of_constr rectype in let decide = mkDecideEqGoal true (build_coq_sumbool ()) rectype c1 c2 in (tclTHENS (cut decide) [(tclTHEN intro diff --git a/tactics/equality.ml b/tactics/equality.ml index e1c39bb34e..7dcfd419e7 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -311,7 +311,7 @@ let general_elim_clause with_evars frzevars tac cls c t l l2r elim = in let typ = match cls with | None -> pf_nf_concl gl - | Some id -> EConstr.of_constr (pf_get_hyp_typ id (Proofview.Goal.assume gl)) + | Some id -> pf_get_hyp_typ id (Proofview.Goal.assume gl) in let cs = instantiate_lemma typ in if firstonly then tclFIRST (List.map try_clause cs) @@ -407,7 +407,7 @@ let find_elim hdcncl lft2rgt dep cls ot gl = let type_of_clause cls gl = match cls with | None -> Proofview.Goal.concl gl - | Some id -> EConstr.of_constr (pf_get_hyp_typ id gl) + | Some id -> pf_get_hyp_typ id gl let leibniz_rewrite_ebindings_clause cls lft2rgt tac c t l with_evars frzevars dep_proof_ok hdcncl = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> @@ -950,7 +950,6 @@ let gen_absurdity id = Proofview.Goal.enter { enter = begin fun gl -> let sigma = project gl in let hyp_typ = pf_get_hyp_typ id (Proofview.Goal.assume gl) in - let hyp_typ = EConstr.of_constr hyp_typ in if is_empty_type sigma hyp_typ then simplest_elim (mkVar id) @@ -1027,7 +1026,6 @@ let onEquality with_evars tac (c,lbindc) = let type_of = pf_unsafe_type_of gl in let reduce_to_quantified_ind = pf_apply Tacred.reduce_to_quantified_ind gl in let t = type_of c in - let t = EConstr.of_constr t in let t' = try snd (reduce_to_quantified_ind t) with UserError _ -> t in let eq_clause = pf_apply make_clenv_binding gl (c,t') lbindc in let eq_clause' = Clenvtac.clenv_pose_dependent_evars with_evars eq_clause in @@ -1136,7 +1134,7 @@ let minimal_free_rels_rec env sigma = let rec minimalrec_free_rels_rec prev_rels (c,cty) = let (cty,direct_rels) = minimal_free_rels env sigma (c,cty) in let combined_rels = Int.Set.union prev_rels direct_rels in - let folder rels i = snd (minimalrec_free_rels_rec rels (c, EConstr.of_constr (unsafe_type_of env sigma (mkRel i)))) + let folder rels i = snd (minimalrec_free_rels_rec rels (c, unsafe_type_of env sigma (mkRel i))) in (cty, List.fold_left folder combined_rels (Int.Set.elements (Int.Set.diff direct_rels prev_rels))) in minimalrec_free_rels_rec Int.Set.empty @@ -1184,7 +1182,7 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt = (* is the default value typable with the expected type *) let dflt_typ = unsafe_type_of env sigma dflt in try - let () = evdref := Evarconv.the_conv_x_leq env (EConstr.of_constr dflt_typ) p_i !evdref in + let () = evdref := Evarconv.the_conv_x_leq env dflt_typ p_i !evdref in let () = evdref := Evarconv.consider_remaining_unif_problems env !evdref in dflt with Evarconv.UnableToUnify _ -> @@ -1200,7 +1198,6 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt = match evopt with | Some w -> let w_type = unsafe_type_of env !evdref w in - let w_type = EConstr.of_constr w_type in if Evarconv.e_cumul env evdref w_type a then let exist_term = Evarutil.evd_comb1 (Evd.fresh_global env) evdref sigdata.intro in let exist_term = EConstr.of_constr exist_term in @@ -1290,7 +1287,7 @@ let make_iterated_tuple env sigma dflt (z,zty) = sigma, (tuple,tuplety,dfltval) let rec build_injrec env sigma dflt c = function - | [] -> make_iterated_tuple env sigma dflt (c,EConstr.of_constr (unsafe_type_of env sigma c)) + | [] -> make_iterated_tuple env sigma dflt (c,unsafe_type_of env sigma c) | ((sp,cnum),argnum)::l -> try let (cnum_nlams,cnum_env,kont) = descend_then env sigma c cnum in @@ -1345,7 +1342,7 @@ let inject_if_homogenous_dependent_pair ty = if not (Ind_tables.check_scheme (!eq_dec_scheme_kind_name()) (fst ind) && pf_apply is_conv gl ar1.(2) ar2.(2)) then raise Exit; Coqlib.check_required_library ["Coq";"Logic";"Eqdep_dec"]; - let new_eq_args = [|EConstr.of_constr (pf_unsafe_type_of gl ar1.(3));ar1.(3);ar2.(3)|] in + let new_eq_args = [|pf_unsafe_type_of gl ar1.(3);ar1.(3);ar2.(3)|] in let inj2 = Coqlib.coq_constant "inj_pair2_eq_dec is missing" ["Logic";"Eqdep_dec"] "inj_pair2_eq_dec" in let inj2 = EConstr.of_constr inj2 in @@ -1613,7 +1610,6 @@ let cutSubstInHyp l2r eqn id = let sigma = Proofview.Goal.sigma gl in let (lbeq,u,(t,e1,e2)) = find_eq_data_decompose gl eqn in let typ = pf_get_hyp_typ id gl in - let typ = EConstr.of_constr typ in let (e1,e2) = if l2r then (e1,e2) else (e2,e1) in let Sigma ((typ, expected), sigma, p) = subst_tuple_term env sigma e1 e2 typ in let tac = @@ -1702,8 +1698,7 @@ let is_eq_x gl x d = | Var id' -> Id.equal id id' | _ -> false in - let c = pf_nf_evar gl (NamedDecl.get_type d) in - let c = EConstr.of_constr c in + let c = pf_nf_evar gl (EConstr.of_constr (NamedDecl.get_type d)) in let (_,lhs,rhs) = pi3 (find_eq_data_decompose gl c) in if (is_var x lhs) && not (local_occur_var (project gl) x rhs) then raise (FoundHyp (id,rhs,true)); if (is_var x rhs) && not (local_occur_var (project gl) x lhs) then raise (FoundHyp (id,lhs,false)) @@ -1852,7 +1847,6 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () = let find_eq_data_decompose = find_eq_data_decompose gl in let test (_,c) = try - let c = EConstr.of_constr c in let lbeq,u,(_,x,y) = find_eq_data_decompose c in let eq = Universes.constr_of_global_univ (lbeq.eq,u) in if flags.only_leibniz then restrict_to_eq_and_identity eq; diff --git a/tactics/hints.ml b/tactics/hints.ml index 2446b6996b..851e9f01fb 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -919,7 +919,7 @@ let make_mode ref m = let make_trivial env sigma poly ?(name=PathAny) r = let c,ctx = fresh_global_or_constr env sigma poly r in let sigma = Evd.merge_context_set univ_flexible sigma ctx in - let t = hnf_constr env sigma (EConstr.of_constr (unsafe_type_of env sigma c)) in + let t = hnf_constr env sigma (unsafe_type_of env sigma c) in let hd = head_constr sigma t in let ce = mk_clenv_from_env env sigma None (c,t) in (Some hd, { pri=1; @@ -1239,7 +1239,6 @@ let interp_hints poly = let sigma = Evd.from_env env in let f poly c = let evd,c = Constrintern.interp_open_constr env sigma c in - let c = EConstr.of_constr c in prepare_hint true (poly,false) (Global.env()) Evd.empty (evd,c) in let fref r = let gr = global_with_alias r in diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml index fa114a3d34..607d6d2a91 100644 --- a/tactics/hipattern.ml +++ b/tactics/hipattern.ml @@ -442,7 +442,7 @@ let find_eq_data sigma eqn = (* fails with PatternMatchingFailure *) let extract_eq_args gl = function | MonomorphicLeibnizEq (e1,e2) -> - let t = pf_unsafe_type_of gl e1 in (EConstr.of_constr t,e1,e2) + let t = pf_unsafe_type_of gl e1 in (t,e1,e2) | PolymorphicLeibnizEq (t,e1,e2) -> (t,e1,e2) | HeterogenousEq (t1,e1,t2,e2) -> if pf_conv_x gl t1 t2 then (t1,e1,e2) diff --git a/tactics/inv.ml b/tactics/inv.ml index a398e04dda..426749a758 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -346,7 +346,7 @@ let projectAndApply as_mode thin avoid id eqname names depids = let sigma = project gl in (** We only look at the type of hypothesis "id" *) let hyp = pf_nf_evar gl (pf_get_hyp_typ id (Proofview.Goal.assume gl)) in - let (t,t1,t2) = Hipattern.dest_nf_eq gl (EConstr.of_constr hyp) in + let (t,t1,t2) = Hipattern.dest_nf_eq gl hyp in match (EConstr.kind sigma t1, EConstr.kind sigma t2) with | Var id1, _ -> generalizeRewriteIntros as_mode (subst_hyp true id) depids id1 | _, Var id2 -> generalizeRewriteIntros as_mode (subst_hyp false id) depids id2 @@ -443,7 +443,7 @@ let raw_inversion inv_kind id status names = let concl = Proofview.Goal.concl gl in let c = mkVar id in let (ind, t) = - try pf_apply Tacred.reduce_to_atomic_ind gl (EConstr.of_constr (pf_unsafe_type_of gl c)) + try pf_apply Tacred.reduce_to_atomic_ind gl (pf_unsafe_type_of gl c) with UserError _ -> let msg = str "The type of " ++ pr_id id ++ str " is not inductive." in CErrors.user_err msg diff --git a/tactics/leminv.ml b/tactics/leminv.ml index 2d59285e66..3199623e72 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -258,7 +258,6 @@ let add_inversion_lemma_exn na com comsort bool tac = let env = Global.env () in let evd = ref (Evd.from_env env) in let c = Constrintern.interp_type_evars env evd com in - let c = EConstr.of_constr c in let sigma, sort = Pretyping.interp_sort !evd comsort in try add_inversion_lemma na env sigma c sort bool tac diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index d79a74b36e..89acc149c3 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -128,7 +128,7 @@ let onClauseLR tac cl gls = tclMAP tac (List.rev (Locusops.simple_clause_of hyps cl)) gls let ifOnHyp pred tac1 tac2 id gl = - if pred (id,EConstr.of_constr (pf_get_hyp_typ gl id)) then + if pred (id,pf_get_hyp_typ gl id) then tac1 id gl else tac2 id gl @@ -248,10 +248,10 @@ let compute_constructor_signatures isrec ((_,k as ity),u) = Array.map2 analrec lc lrecargs let elimination_sort_of_goal gl = - pf_apply Retyping.get_sort_family_of gl (EConstr.of_constr (pf_concl gl)) + pf_apply Retyping.get_sort_family_of gl (pf_concl gl) let elimination_sort_of_hyp id gl = - pf_apply Retyping.get_sort_family_of gl (EConstr.of_constr (pf_get_hyp_typ gl id)) + pf_apply Retyping.get_sort_family_of gl (pf_get_hyp_typ gl id) let elimination_sort_of_clause = function | None -> elimination_sort_of_goal @@ -269,21 +269,22 @@ let pf_constr_of_global gr k = let gl_make_elim ind gl = let gr = Indrec.lookup_eliminator (fst ind) (elimination_sort_of_goal gl) in - pf_apply Evd.fresh_global gl gr + let (sigma, c) = pf_apply Evd.fresh_global gl gr in + (sigma, EConstr.of_constr c) let gl_make_case_dep ind gl = let sigma = Sigma.Unsafe.of_evar_map (Tacmach.project gl) in let Sigma (r, sigma, _) = Indrec.build_case_analysis_scheme (pf_env gl) sigma ind true (elimination_sort_of_goal gl) in - (Sigma.to_evar_map sigma, r) + (Sigma.to_evar_map sigma, EConstr.of_constr r) let gl_make_case_nodep ind gl = let sigma = Sigma.Unsafe.of_evar_map (Tacmach.project gl) in let Sigma (r, sigma, _) = Indrec.build_case_analysis_scheme (pf_env gl) sigma ind false (elimination_sort_of_goal gl) in - (Sigma.to_evar_map sigma, r) + (Sigma.to_evar_map sigma, EConstr.of_constr r) let make_elim_branch_assumptions ba gl = let assums = @@ -583,7 +584,6 @@ module New = struct let ifOnHyp pred tac1 tac2 id = Proofview.Goal.nf_enter { enter = begin fun gl -> let typ = Tacmach.New.pf_get_hyp_typ id gl in - let typ = EConstr.of_constr typ in if pred (id,typ) then tac1 id else @@ -630,7 +630,7 @@ module New = struct (Proofview.Goal.nf_enter { enter = begin fun gl -> let indclause = Tacmach.New.of_old (fun gl -> mk_clenv_from gl (c, t)) gl in (* applying elimination_scheme just a little modified *) - let elimclause = Tacmach.New.of_old (fun gls -> mk_clenv_from gls (EConstr.of_constr elim,EConstr.of_constr (Tacmach.New.pf_unsafe_type_of gl (EConstr.of_constr elim)))) gl in + let elimclause = Tacmach.New.of_old (fun gls -> mk_clenv_from gls (elim,Tacmach.New.pf_unsafe_type_of gl elim)) gl in let indmv = match EConstr.kind elimclause.evd (last_arg elimclause.evd elimclause.templval.Evd.rebus) with | Meta mv -> mv @@ -642,7 +642,7 @@ module New = struct | Meta p -> p | _ -> let name_elim = - match kind_of_term elim with + match EConstr.kind sigma elim with | Const (kn, _) -> string_of_con kn | Var id -> string_of_id id | _ -> "\b" @@ -680,7 +680,7 @@ module New = struct let elimination_then tac c = Proofview.Goal.nf_enter { enter = begin fun gl -> - let (ind,t) = pf_reduce_to_quantified_ind gl (EConstr.of_constr (pf_unsafe_type_of gl c)) in + let (ind,t) = pf_reduce_to_quantified_ind gl (pf_unsafe_type_of gl c) in let isrec,mkelim = match (Global.lookup_mind (fst (fst ind))).mind_record with | None -> true,gl_make_elim @@ -715,7 +715,7 @@ module New = struct let elimination_sort_of_hyp id gl = (** Retyping will expand evars anyway. *) let c = pf_get_hyp_typ id (Goal.assume gl) in - pf_apply Retyping.get_sort_family_of gl (EConstr.of_constr c) + pf_apply Retyping.get_sort_family_of gl c let elimination_sort_of_clause id gl = match id with | None -> elimination_sort_of_goal gl diff --git a/tactics/tactics.ml b/tactics/tactics.ml index dcaa15fd8f..f79f7f1a82 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1260,7 +1260,6 @@ let cut c = try (** Backward compat: ensure that [c] is well-typed. *) let typ = Typing.unsafe_type_of env sigma c in - let typ = EConstr.of_constr typ in let typ = whd_all env sigma typ in match EConstr.kind sigma typ with | Sort _ -> true @@ -1515,7 +1514,7 @@ let find_ind_eliminator ind s gl = evd, c let find_eliminator c gl = - let ((ind,u),t) = Tacmach.New.pf_reduce_to_quantified_ind gl (EConstr.of_constr (Tacmach.New.pf_unsafe_type_of gl c)) in + let ((ind,u),t) = Tacmach.New.pf_reduce_to_quantified_ind gl (Tacmach.New.pf_unsafe_type_of gl c) in if is_nonrec ind then raise IsNonrec; let evd, c = find_ind_eliminator ind (Tacticals.New.elimination_sort_of_goal gl) gl in evd, {elimindex = None; elimbody = (c,NoBindings); @@ -1891,7 +1890,6 @@ let apply_in_once sidecond_first with_delta with_destruct with_evars naming 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 t' = EConstr.of_constr t' in let innerclause = mk_clenv_from_env env sigma (Some 0) (mkVar id,t') in let targetid = find_name true (local_assum (Anonymous,t')) naming gl in let rec aux idstoclear with_destruct c = @@ -1949,7 +1947,7 @@ let apply_in_delayed_once sidecond_first with_delta with_destruct with_evars nam let cut_and_apply c = Proofview.Goal.nf_enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in - match EConstr.kind sigma (Tacmach.New.pf_hnf_constr gl (EConstr.of_constr (Tacmach.New.pf_unsafe_type_of gl c))) with + match EConstr.kind sigma (Tacmach.New.pf_hnf_constr gl (Tacmach.New.pf_unsafe_type_of gl c)) with | Prod (_,c1,c2) when Vars.noccurn sigma 1 c2 -> let concl = Proofview.Goal.concl gl in let env = Tacmach.New.pf_env gl in @@ -2004,7 +2002,7 @@ let exact_proof c = Proofview.Goal.nf_enter { enter = begin fun gl -> Refine.refine { run = begin fun sigma -> let sigma = Sigma.to_evar_map sigma in - let (c, ctx) = Constrintern.interp_casted_constr (pf_env gl) sigma c (EConstr.Unsafe.to_constr (pf_concl gl)) in + let (c, ctx) = Constrintern.interp_casted_constr (pf_env gl) sigma c (pf_concl gl) in let c = EConstr.of_constr c in let sigma = Evd.merge_universe_context sigma ctx in Sigma.Unsafe.of_pair (c, sigma) @@ -2326,7 +2324,6 @@ let intro_decomp_eq loc l thin tac id = Proofview.Goal.nf_enter { enter = begin fun gl -> let c = mkVar id in let t = Tacmach.New.pf_unsafe_type_of gl c in - let t = EConstr.of_constr t in let _,t = Tacmach.New.pf_reduce_to_quantified_ind gl t in match my_find_eq_data_decompose gl t with | Some (eq,u,eq_args) -> @@ -2341,7 +2338,6 @@ let intro_or_and_pattern loc with_evars bracketed ll thin tac id = Proofview.Goal.enter { enter = begin fun gl -> let c = mkVar id in let t = Tacmach.New.pf_unsafe_type_of gl c in - let t = EConstr.of_constr t in let (ind,t) = Tacmach.New.pf_reduce_to_quantified_ind gl t in let branchsigns = compute_constructor_signatures false ind in let nv_with_let = Array.map List.length branchsigns in @@ -2366,7 +2362,7 @@ let rewrite_hyp_then assert_style with_evars thin l2r id tac = let sigma = Tacmach.New.project gl in let type_of = Tacmach.New.pf_unsafe_type_of gl in let whd_all = Tacmach.New.pf_apply whd_all gl in - let t = whd_all (EConstr.of_constr (type_of (mkVar id))) in + let t = whd_all (type_of (mkVar id)) in let eqtac, thin = match match_with_equality_type sigma t with | Some (hdcncl,[_;lhs;rhs]) -> if l2r && isVar sigma lhs && not (occur_var env sigma (destVar sigma lhs) rhs) then @@ -2774,7 +2770,6 @@ let forward b usetac ipat c = | None -> Proofview.Goal.enter { enter = begin fun gl -> let t = Tacmach.New.pf_unsafe_type_of gl c in - let t = EConstr.of_constr t in let sigma = Tacmach.New.project gl in let hd = head_ident sigma c in Tacticals.New.tclTHENFIRST (assert_as true hd ipat t) (exact_no_check c) @@ -2861,7 +2856,7 @@ let old_generalize_dep ?(with_let=false) c gl = -> id::tothin | _ -> tothin in - let cl' = it_mkNamedProd_or_LetIn (EConstr.of_constr (Tacmach.pf_concl gl)) to_quantify in + let cl' = it_mkNamedProd_or_LetIn (Tacmach.pf_concl gl) to_quantify in let body = if with_let then match EConstr.kind sigma c with @@ -3222,7 +3217,6 @@ let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let tmptyp0 = Tacmach.New.pf_get_hyp_typ hyp0 (Proofview.Goal.assume gl) in - let tmptyp0 = EConstr.of_constr tmptyp0 in let reduce_to_quantified_ref = Tacmach.New.pf_apply reduce_to_quantified_ref gl in let typ0 = reduce_to_quantified_ref indref tmptyp0 in let prods, indtyp = decompose_prod_assum sigma typ0 in @@ -3266,7 +3260,7 @@ let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = | Var id -> id | _ -> let type_of = Tacmach.New.pf_unsafe_type_of gl in - id_of_name_using_hdchar (Global.env()) (type_of c) Anonymous in + id_of_name_using_hdchar (Global.env()) (EConstr.Unsafe.to_constr (type_of c)) Anonymous in let x = fresh_id_in_env avoid id env in Tacticals.New.tclTHEN (letin_tac None (Name x) c None allHypsAndConcl) @@ -3660,7 +3654,6 @@ let abstract_args gl generalize_vars dep id defined f args = let sigma = ref (Tacmach.project gl) in let env = Tacmach.pf_env gl in let concl = Tacmach.pf_concl gl in - let concl = EConstr.of_constr concl in let dep = dep || local_occur_var !sigma id concl in let avoid = ref [] in let get_id name = @@ -3681,7 +3674,6 @@ let abstract_args gl generalize_vars dep id defined f args = in let ty = EConstr.of_constr ty in let argty = Tacmach.pf_unsafe_type_of gl arg in - let argty = EConstr.of_constr argty in let sigma', ty = Evarsolve.refresh_universes (Some true) env !sigma ty in let () = sigma := sigma' in let lenctx = List.length ctx in @@ -3723,7 +3715,6 @@ let abstract_args gl generalize_vars dep id defined f args = in if dogen then let tyf' = Tacmach.pf_unsafe_type_of gl f' in - let tyf' = EConstr.of_constr tyf' in let arity, ctx, ctxenv, c', args, eqs, refls, nogen, vars, env = Array.fold_left aux (tyf',[],env,f',[],[],[],Id.Set.empty,Id.Set.empty,env) args' in @@ -3739,7 +3730,6 @@ let abstract_args gl generalize_vars dep id defined f args = else None, c' in let typ = Tacmach.pf_get_hyp_typ gl id in - let typ = EConstr.of_constr typ in let tac = make_abstract_generalize (pf_env gl) id typ concl dep ctx body c' eqs args refls in let tac = Proofview.Unsafe.tclEVARS !sigma <*> tac in Some (tac, dep, succ (List.length ctx), vars) @@ -3797,7 +3787,6 @@ let specialize_eqs id gl = let open Context.Rel.Declaration in let env = Tacmach.pf_env gl in let ty = Tacmach.pf_get_hyp_typ gl id in - let ty = EConstr.of_constr ty in let evars = ref (project gl) in let unif env evars c1 c2 = compare_upto_variables !evars c1 c2 && Evarconv.e_conv env evars c1 c2 @@ -4062,7 +4051,6 @@ let compute_elim_signature (evd,(elimc,elimt),ind_type_guess) names_info = let guess_elim isrec dep s hyp0 gl = let tmptyp0 = Tacmach.New.pf_get_hyp_typ hyp0 gl in - let tmptyp0 = EConstr.of_constr tmptyp0 in let mind,_ = Tacmach.New.pf_reduce_to_quantified_ind gl tmptyp0 in let evd, elimc = if isrec && not (is_nonrec (fst mind)) then find_ind_eliminator (fst mind) s gl @@ -4080,16 +4068,13 @@ let guess_elim isrec dep s hyp0 gl = (Sigma.to_evar_map sigma, ind) in let elimt = Tacmach.New.pf_unsafe_type_of gl elimc in - let elimt = EConstr.of_constr elimt in evd, ((elimc, NoBindings), elimt), mkIndU mind let given_elim hyp0 (elimc,lbind as e) gl = let sigma = Tacmach.New.project gl in let tmptyp0 = Tacmach.New.pf_get_hyp_typ hyp0 gl in - let tmptyp0 = EConstr.of_constr tmptyp0 in let ind_type_guess,_ = decompose_app sigma (snd (decompose_prod sigma tmptyp0)) in let elimt = Tacmach.New.pf_unsafe_type_of gl elimc in - let elimt = EConstr.of_constr elimt in Tacmach.New.project gl, (e, elimt), ind_type_guess type scheme_signature = @@ -4127,7 +4112,7 @@ let get_elim_signature elim hyp0 gl = let is_functional_induction elimc gl = let sigma = Tacmach.New.project gl in - let scheme = compute_elim_sig sigma ~elimc (EConstr.of_constr (Tacmach.New.pf_unsafe_type_of gl (fst elimc))) in + let scheme = compute_elim_sig sigma ~elimc (Tacmach.New.pf_unsafe_type_of gl (fst elimc)) in (* The test is not safe: with non-functional induction on non-standard induction scheme, this may fail *) Option.is_empty scheme.indarg @@ -4162,7 +4147,6 @@ let recolle_clenv i params args elimclause gl = arr in let k = match i with -1 -> Array.length lindmv - List.length args | _ -> i in (* parameters correspond to first elts of lid. *) - let pf_get_hyp_typ id gl = EConstr.of_constr (pf_get_hyp_typ id gl) in let clauses_params = List.map_i (fun i id -> mkVar id , pf_get_hyp_typ id gl, lindmv.(i)) 0 params in @@ -4523,7 +4507,7 @@ let induction_gen_l isrec with_evars elim names lc = let type_of = Tacmach.New.pf_unsafe_type_of gl in let sigma = Tacmach.New.project gl in let x = - id_of_name_using_hdchar (Global.env()) (type_of c) Anonymous in + id_of_name_using_hdchar (Global.env()) (EConstr.Unsafe.to_constr (type_of c)) Anonymous in let id = new_fresh_id [] x gl in let newl' = List.map (fun r -> replace_term sigma c (mkVar id) r) l' in @@ -4778,7 +4762,6 @@ let symmetry_in id = Proofview.Goal.enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in let ctype = Tacmach.New.pf_unsafe_type_of gl (mkVar id) in - let ctype = EConstr.of_constr ctype in let sign,t = decompose_prod_assum sigma ctype in Proofview.tclORELSE begin @@ -4832,7 +4815,6 @@ let prove_transitivity hdcncl eq_kind t = let sigma = Tacmach.New.project gl in let type_of = Typing.unsafe_type_of env sigma in let typt = type_of t in - let typt = EConstr.of_constr typt in (mkApp(hdcncl, [| typ1; c1; typt ;t |]), mkApp(hdcncl, [| typt; t; typ2; c2 |])) in -- cgit v1.2.3 From 8beca748d992cd08e2dd7448c8b28dadbcea4a16 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 26 Nov 2016 01:09:11 +0100 Subject: Cleaning up interfaces. We make mli files look to what they were looking before the move to EConstr by opening this module. --- tactics/leminv.mli | 3 ++- tactics/tacticals.mli | 31 ++++++++++++++++--------------- tactics/tactics.ml | 1 - 3 files changed, 18 insertions(+), 17 deletions(-) (limited to 'tactics') diff --git a/tactics/leminv.mli b/tactics/leminv.mli index 58b82002da..26d4ac994b 100644 --- a/tactics/leminv.mli +++ b/tactics/leminv.mli @@ -8,11 +8,12 @@ open Names open Term +open EConstr open Constrexpr open Misctypes val lemInv_clause : - quantified_hypothesis -> EConstr.constr -> Id.t list -> unit Proofview.tactic + quantified_hypothesis -> constr -> Id.t list -> unit Proofview.tactic val add_inversion_lemma_exn : Id.t -> constr_expr -> glob_sort -> bool -> (Id.t -> unit Proofview.tactic) -> diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index e4f110722b..ba5452e33f 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -9,6 +9,7 @@ open Pp open Names open Term +open EConstr open Tacmach open Proof_type open Locus @@ -58,25 +59,25 @@ val tclIFTHENTRYELSEMUST : tactic -> tactic -> tactic (** {6 Tacticals applying to hypotheses } *) val onNthHypId : int -> (Id.t -> tactic) -> tactic -val onNthHyp : int -> (EConstr.constr -> tactic) -> tactic +val onNthHyp : int -> (constr -> tactic) -> tactic val onNthDecl : int -> (Context.Named.Declaration.t -> tactic) -> tactic val onLastHypId : (Id.t -> tactic) -> tactic -val onLastHyp : (EConstr.constr -> tactic) -> tactic +val onLastHyp : (constr -> tactic) -> tactic val onLastDecl : (Context.Named.Declaration.t -> tactic) -> tactic val onNLastHypsId : int -> (Id.t list -> tactic) -> tactic -val onNLastHyps : int -> (constr list -> tactic) -> tactic +val onNLastHyps : int -> (Constr.constr list -> tactic) -> tactic val onNLastDecls : int -> (Context.Named.t -> tactic) -> tactic val lastHypId : goal sigma -> Id.t -val lastHyp : goal sigma -> EConstr.constr +val lastHyp : goal sigma -> constr val lastDecl : goal sigma -> Context.Named.Declaration.t val nLastHypsId : int -> goal sigma -> Id.t list -val nLastHyps : int -> goal sigma -> constr list +val nLastHyps : int -> goal sigma -> Constr.constr list val nLastDecls : int -> goal sigma -> Context.Named.t val afterHyp : Id.t -> goal sigma -> Context.Named.t -val ifOnHyp : (Id.t * EConstr.types -> bool) -> +val ifOnHyp : (Id.t * types -> bool) -> (Id.t -> tactic) -> (Id.t -> tactic) -> Id.t -> tactic @@ -99,9 +100,9 @@ val onClauseLR : (Id.t option -> tactic) -> clause -> tactic type branch_args = private { ity : pinductive; (** the type we were eliminating on *) - largs : EConstr.constr list; (** its arguments *) + largs : constr list; (** its arguments *) branchnum : int; (** the branch number *) - pred : EConstr.constr; (** the predicate we used *) + pred : constr; (** the predicate we used *) nassums : int; (** number of assumptions/letin to be introduced *) branchsign : bool list; (** the signature of the branch. true=assumption, false=let-in *) @@ -134,7 +135,7 @@ val elimination_sort_of_hyp : Id.t -> goal sigma -> sorts_family val elimination_sort_of_clause : Id.t option -> goal sigma -> sorts_family val pf_with_evars : (goal sigma -> Evd.evar_map * 'a) -> ('a -> tactic) -> tactic -val pf_constr_of_global : Globnames.global_reference -> (constr -> tactic) -> tactic +val pf_constr_of_global : Globnames.global_reference -> (Constr.constr -> tactic) -> tactic val elim_on_ba : (branch_assumptions -> tactic) -> branch_args -> tactic val case_on_ba : (branch_assumptions -> tactic) -> branch_args -> tactic @@ -230,13 +231,13 @@ module New : sig val nLastDecls : ([ `NF ], 'r) Proofview.Goal.t -> int -> Context.Named.t - val ifOnHyp : (identifier * EConstr.types -> bool) -> + val ifOnHyp : (identifier * types -> bool) -> (identifier -> unit Proofview.tactic) -> (identifier -> unit Proofview.tactic) -> identifier -> unit Proofview.tactic val onNthHypId : int -> (identifier -> unit tactic) -> unit tactic val onLastHypId : (identifier -> unit tactic) -> unit tactic - val onLastHyp : (EConstr.constr -> unit tactic) -> unit tactic + val onLastHyp : (constr -> unit tactic) -> unit tactic val onLastDecl : (Context.Named.Declaration.t -> unit tactic) -> unit tactic val onHyps : ([ `NF ], Context.Named.t) Proofview.Goal.enter -> @@ -253,18 +254,18 @@ module New : sig val elimination_then : (branch_args -> unit Proofview.tactic) -> - EConstr.constr -> unit Proofview.tactic + constr -> unit Proofview.tactic val case_then_using : or_and_intro_pattern option -> (branch_args -> unit Proofview.tactic) -> - EConstr.constr option -> pinductive -> EConstr.constr * EConstr.types -> unit Proofview.tactic + constr option -> pinductive -> constr * types -> unit Proofview.tactic val case_nodep_then_using : or_and_intro_pattern option -> (branch_args -> unit Proofview.tactic) -> - EConstr.constr option -> pinductive -> EConstr.constr * EConstr.types -> unit Proofview.tactic + constr option -> pinductive -> constr * types -> unit Proofview.tactic 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.constr -> unit Proofview.tactic) -> unit Proofview.tactic end diff --git a/tactics/tactics.ml b/tactics/tactics.ml index f79f7f1a82..e4dd9eea26 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -2821,7 +2821,6 @@ let generalize_goal_gen env sigma ids i ((occs,c,b),na) t cl = let dummy_prod = it_mkProd_or_LetIn mkProp decls in let newdecls,_ = decompose_prod_n_assum sigma i (subst_term_gen sigma EConstr.eq_constr_nounivs c dummy_prod) in let cl',sigma' = subst_closed_term_occ env sigma (AtOccs occs) c (it_mkProd_or_LetIn cl newdecls) in - let cl' = EConstr.of_constr cl' in let na = generalized_name sigma c t ids cl' na in let decl = match b with | None -> local_assum (na,t) -- cgit v1.2.3 From 01849481fbabc3a3fa6c483e703996b01e37fca5 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 26 Nov 2016 01:25:11 +0100 Subject: Removing compatibility layers from Tacticals --- tactics/equality.ml | 2 -- tactics/tacticals.ml | 17 ++++++++++------- tactics/tacticals.mli | 8 ++++---- tactics/tactics.ml | 6 +++--- 4 files changed, 17 insertions(+), 16 deletions(-) (limited to 'tactics') diff --git a/tactics/equality.ml b/tactics/equality.ml index 7dcfd419e7..c80cf4416c 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -647,9 +647,7 @@ let replace_using_leibniz clause c1 c2 l2r unsafe try_prove_eq_opt = 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 -> - let e = EConstr.of_constr e in let eq = applist (e, [t1;c1;c2]) in - let sym = EConstr.of_constr sym in tclTHENLAST (replace_core clause l2r eq) (tclFIRST diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index 89acc149c3..9cf3c41876 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -11,6 +11,7 @@ open CErrors open Util open Names open Term +open EConstr open Termops open Declarations open Tacmach @@ -73,7 +74,7 @@ let nthDecl m gl = with Failure _ -> error "No such assumption." let nthHypId m gl = nthDecl m gl |> NamedDecl.get_id -let nthHyp m gl = EConstr.mkVar (nthHypId m gl) +let nthHyp m gl = mkVar (nthHypId m gl) let lastDecl gl = nthDecl 1 gl let lastHypId gl = nthHypId 1 gl @@ -83,7 +84,7 @@ let nLastDecls n gl = try List.firstn n (pf_hyps gl) with Failure _ -> error "Not enough hypotheses in the goal." -let nLastHypsId n gl = List.map NamedDecl.get_id (nLastDecls n gl) +let nLastHypsId n gl = List.map (NamedDecl.get_id) (nLastDecls n gl) let nLastHyps n gl = List.map mkVar (nLastHypsId n gl) let onNthDecl m tac gl = tac (nthDecl m gl) gl @@ -147,9 +148,9 @@ let ifOnHyp pred tac1 tac2 id gl = type branch_args = { ity : pinductive; (* the type we were eliminating on *) - largs : EConstr.constr list; (* its arguments *) + largs : constr list; (* its arguments *) branchnum : int; (* the branch number *) - pred : EConstr.constr; (* the predicate we used *) + pred : constr; (* the predicate we used *) nassums : int; (* number of assumptions/letin to be introduced *) branchsign : bool list; (* the signature of the branch. true=assumption, false=let-in *) @@ -226,6 +227,7 @@ let compute_induction_names = compute_induction_names_gen true (* Compute the let-in signature of case analysis or standard induction scheme *) let compute_constructor_signatures isrec ((_,k as ity),u) = + let open Term in let rec analrec c recargs = match kind_of_term c, recargs with | Prod (_,_,c), recarg::rest -> @@ -263,7 +265,7 @@ let pf_with_evars glsev k gls = tclTHEN (Refiner.tclEVARS evd) (k a) gls let pf_constr_of_global gr k = - pf_with_evars (fun gls -> pf_apply Evd.fresh_global gls gr) k + pf_with_evars (fun gls -> on_snd EConstr.of_constr (pf_apply Evd.fresh_global gls gr)) k (* computing the case/elim combinators *) @@ -565,7 +567,7 @@ module New = struct let gl = Proofview.Goal.assume gl in nthDecl m gl |> NamedDecl.get_id let nthHyp m gl = - EConstr.mkVar (nthHypId m gl) + mkVar (nthHypId m gl) let onNthHypId m tac = Proofview.Goal.enter { enter = begin fun gl -> tac (nthHypId m gl) end } @@ -657,7 +659,7 @@ module New = struct let elimclause' = match predicate with | None -> elimclause' - | Some p -> clenv_unify ~flags Reduction.CONV (EConstr.mkMeta pmv) p elimclause' + | Some p -> clenv_unify ~flags Reduction.CONV (mkMeta pmv) p elimclause' in let clenv' = Tacmach.New.of_old (clenv_unique_resolver ~flags elimclause') gl in let after_tac i = @@ -726,6 +728,7 @@ module New = struct 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 } diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index ba5452e33f..2b07d937ed 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -65,14 +65,14 @@ val onLastHypId : (Id.t -> tactic) -> tactic val onLastHyp : (constr -> tactic) -> tactic val onLastDecl : (Context.Named.Declaration.t -> tactic) -> tactic val onNLastHypsId : int -> (Id.t list -> tactic) -> tactic -val onNLastHyps : int -> (Constr.constr list -> tactic) -> tactic +val onNLastHyps : int -> (constr list -> tactic) -> tactic val onNLastDecls : int -> (Context.Named.t -> tactic) -> tactic val lastHypId : goal sigma -> Id.t val lastHyp : goal sigma -> constr val lastDecl : goal sigma -> Context.Named.Declaration.t val nLastHypsId : int -> goal sigma -> Id.t list -val nLastHyps : int -> goal sigma -> Constr.constr list +val nLastHyps : int -> goal sigma -> constr list val nLastDecls : int -> goal sigma -> Context.Named.t val afterHyp : Id.t -> goal sigma -> Context.Named.t @@ -135,7 +135,7 @@ val elimination_sort_of_hyp : Id.t -> goal sigma -> sorts_family val elimination_sort_of_clause : Id.t option -> goal sigma -> sorts_family val pf_with_evars : (goal sigma -> Evd.evar_map * 'a) -> ('a -> tactic) -> tactic -val pf_constr_of_global : Globnames.global_reference -> (Constr.constr -> tactic) -> tactic +val pf_constr_of_global : Globnames.global_reference -> (constr -> tactic) -> tactic val elim_on_ba : (branch_assumptions -> tactic) -> branch_args -> tactic val case_on_ba : (branch_assumptions -> tactic) -> branch_args -> tactic @@ -267,5 +267,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.constr -> unit Proofview.tactic) -> unit Proofview.tactic + val pf_constr_of_global : Globnames.global_reference -> (constr -> unit Proofview.tactic) -> unit Proofview.tactic end diff --git a/tactics/tactics.ml b/tactics/tactics.ml index e4dd9eea26..10582288c7 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -4742,7 +4742,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 (EConstr.of_constr %> apply)) + (Tacticals.New.pf_constr_of_global eq_data.sym apply) | None,eq,eq_kind -> prove_symmetry eq eq_kind end } @@ -4838,8 +4838,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 (EConstr.of_constr %> eapply) - | Some t -> Tacticals.New.pf_constr_of_global eq_data.trans (fun trans -> apply_list [EConstr.of_constr 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.") -- cgit v1.2.3 From c8c8ccdaaffefdbd3d78c844552a08bcb7b4f915 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 26 Nov 2016 02:12:40 +0100 Subject: Evar-normalizing functions now act on EConstrs. --- tactics/auto.ml | 2 +- tactics/class_tactics.ml | 6 ++---- tactics/contradiction.ml | 3 +-- tactics/eauto.ml | 3 +-- tactics/equality.ml | 2 +- tactics/hints.ml | 3 ++- tactics/leminv.ml | 2 -- tactics/tactics.ml | 4 ++-- 8 files changed, 10 insertions(+), 15 deletions(-) (limited to 'tactics') diff --git a/tactics/auto.ml b/tactics/auto.ml index b548f8b928..17a488ddb6 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -321,7 +321,7 @@ let rec trivial_fail_db dbg mod_delta db_list local_db = ( Proofview.Goal.enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in - let nf c = Evarutil.nf_evar sigma c in + let nf c = EConstr.Unsafe.to_constr (Evarutil.nf_evar sigma (EConstr.of_constr c)) in let decl = Tacmach.New.pf_last_hyp (Proofview.Goal.assume gl) in let hyp = Context.Named.Declaration.map_constr nf decl in let hintl = make_resolve_hyp env sigma hyp diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index fa2c21ac31..a4b6cb53b7 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -521,8 +521,7 @@ let evars_to_goals p evm = (** Making local hints *) let make_resolve_hyp env sigma st flags only_classes pri decl = let id = NamedDecl.get_id decl in - let cty = Evarutil.nf_evar sigma (NamedDecl.get_type decl) in - let cty = EConstr.of_constr cty in + let cty = Evarutil.nf_evar sigma (EConstr.of_constr (NamedDecl.get_type decl)) in let rec iscl env ty = let ctx, ar = decompose_prod_assum sigma ty in match EConstr.kind sigma (fst (decompose_app sigma ar)) with @@ -1476,8 +1475,7 @@ let resolve_one_typeclass env ?(sigma=Evd.empty) gl unique = in let evd = sig_sig gls' in let t' = mkEvar (ev, Array.of_list subst) in - let term = Evarutil.nf_evar evd (EConstr.Unsafe.to_constr t') in - let term = EConstr.of_constr term in + let term = Evarutil.nf_evar evd t' in evd, term let _ = diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index a3a448aadc..7173fb4fd7 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -66,8 +66,7 @@ let contradiction_context = | [] -> Tacticals.New.tclZEROMSG (Pp.str"No such contradiction") | d :: rest -> let id = NamedDecl.get_id d in - let typ = nf_evar sigma (NamedDecl.get_type d) in - let typ = EConstr.of_constr typ in + let typ = nf_evar sigma (EConstr.of_constr (NamedDecl.get_type d)) in let typ = whd_all env sigma typ in if is_empty_type sigma typ then simplest_elim (mkVar id) diff --git a/tactics/eauto.ml b/tactics/eauto.ml index 01f21910cf..7453fff5c3 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -289,8 +289,7 @@ module SearchProblem = struct in let rec_tacs = let l = - let concl = Reductionops.nf_evar (project g) (EConstr.Unsafe.to_constr (pf_concl g)) in - let concl = EConstr.of_constr concl in + let concl = Reductionops.nf_evar (project g) (pf_concl g) in filter_tactics s.tacres (e_possible_resolve (project g) s.dblist (List.hd s.localdb) secvars concl) in diff --git a/tactics/equality.ml b/tactics/equality.ml index c80cf4416c..072da995db 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -1212,7 +1212,7 @@ let sig_clausal_form env sigma sort_of_ty siglen ty dflt = error "Cannot solve a unification problem." in let scf = sigrec_clausal_form siglen ty in - !evdref, EConstr.of_constr (Evarutil.nf_evar !evdref (EConstr.Unsafe.to_constr scf)) + !evdref, Evarutil.nf_evar !evdref scf (* The problem is to build a destructor (a generalization of the predecessor) which, when applied to a term made of constructors diff --git a/tactics/hints.ml b/tactics/hints.ml index 851e9f01fb..ef97b0b330 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -1200,7 +1200,8 @@ let prepare_hint check (poly,local) env init (sigma,c) = It is actually a bit stupid to generalize over evars since the first thing make_resolves will do is to re-instantiate the products *) let sigma, subst = Evd.nf_univ_variables sigma in - let c = Evarutil.nf_evar sigma (EConstr.Unsafe.to_constr c) in + let c = Evarutil.nf_evar sigma c in + let c = EConstr.Unsafe.to_constr c in let c = CVars.subst_univs_constr subst c in let c = EConstr.of_constr c in let c = drop_extra_implicit_args sigma c in diff --git a/tactics/leminv.ml b/tactics/leminv.ml index 3199623e72..a05b4fbf3b 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -208,14 +208,12 @@ let inversion_scheme env sigma t sort dep_option inv_op = user_err ~hdr:"lemma_inversion" (str"Computed inversion goal was not closed in initial signature."); *) - let invGoal = EConstr.Unsafe.to_constr invGoal in let pf = Proof.start (Evd.from_ctx (evar_universe_context sigma)) [invEnv,invGoal] in let pf = fst (Proof.run_tactic env ( tclTHEN intro (onLastHypId inv_op)) pf) in let pfterm = List.hd (Proof.partial_proof pf) in - let pfterm = EConstr.of_constr pfterm in let global_named_context = Global.named_context_val () in let ownSign = ref begin fold_named_context diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 10582288c7..0ecccd5c02 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -2945,7 +2945,6 @@ let quantify lconstr = (* Modifying/Adding an hypothesis *) let specialize (c,lbind) ipat = - let nf_evar sigma c = EConstr.of_constr (nf_evar sigma (EConstr.Unsafe.to_constr c)) in Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in @@ -3825,7 +3824,7 @@ let specialize_eqs id gl = let acc' = it_mkLambda_or_LetIn acc ctx'' in let ty' = Tacred.whd_simpl env !evars ty' and acc' = Tacred.whd_simpl env !evars acc' in - let ty' = EConstr.of_constr (Evarutil.nf_evar !evars (EConstr.Unsafe.to_constr ty')) in + let ty' = Evarutil.nf_evar !evars ty' in if worked then tclTHENFIRST (Tacmach.internal_cut true id ty') (Proofview.V82.of_tactic (exact_no_check ((* refresh_universes_strict *) acc'))) gl @@ -4951,6 +4950,7 @@ let abstract_subproof id gk tac = let ctx = Evd.universe_context_set evd in evd, ctx, nf concl in + let concl = EConstr.of_constr concl in let solve_tac = tclCOMPLETE (tclTHEN (tclDO (List.length sign) intro) tac) in let ectx = Evd.evar_universe_context evd in let (const, safe, ectx) = -- cgit v1.2.3 From 78a8d59b39dfcb07b94721fdcfd9241d404905d2 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 26 Nov 2016 15:30:02 +0100 Subject: Introducing contexts parameterized by the inner term type. This allows the decoupling of the notions of context containing kernel terms and context containing tactic-level terms. --- tactics/class_tactics.ml | 4 ++-- tactics/eqschemes.ml | 58 ++++++++++++++++++++++++------------------------ tactics/tactics.ml | 14 +++++------- 3 files changed, 37 insertions(+), 39 deletions(-) (limited to 'tactics') diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index a4b6cb53b7..ef67d28f9c 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -939,7 +939,7 @@ module Search = struct let cwd = Lib.cwd () in if DirPath.equal cwd dir && (onlyc == only_classes) && - Context.Named.equal sign sign' && + Context.Named.equal Constr.equal sign sign' && Hint_db.transparent_state cached_hints == st then cached_hints else @@ -1034,7 +1034,7 @@ module Search = struct (pr_depth (succ j :: i :: info.search_depth) ++ str" : " ++ pr_ev s' (Proofview.Goal.goal gl')); let hints' = - if b && not (Context.Named.equal (Goal.hyps gl') (Goal.hyps gl)) + if b && not (Context.Named.equal Constr.equal (Goal.hyps gl') (Goal.hyps gl)) then let st = Hint_db.transparent_state info.search_hints in make_autogoal_hints info.search_only_classes ~st gl' diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml index 855273d3bf..188e215a5d 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -73,8 +73,8 @@ let build_dependent_inductive ind (mib,mip) = let realargs,_ = List.chop mip.mind_nrealdecls mip.mind_arity_ctxt in applist (mkIndU ind, - Context.Rel.to_extended_list mip.mind_nrealdecls mib.mind_params_ctxt - @ Context.Rel.to_extended_list 0 realargs) + Context.Rel.to_extended_list mkRel mip.mind_nrealdecls mib.mind_params_ctxt + @ Context.Rel.to_extended_list mkRel 0 realargs) let my_it_mkLambda_or_LetIn s c = it_mkLambda_or_LetIn c s let my_it_mkProd_or_LetIn s c = Term.it_mkProd_or_LetIn c s @@ -172,7 +172,7 @@ let build_sym_scheme env ind = let (mib,mip as specif),nrealargs,realsign,paramsctxt,paramsctxt1 = get_sym_eq_data env indu in let cstr n = - mkApp (mkConstructUi(indu,1),Context.Rel.to_extended_vect n mib.mind_params_ctxt) in + mkApp (mkConstructUi(indu,1),Context.Rel.to_extended_vect mkRel n mib.mind_params_ctxt) in let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in let applied_ind = build_dependent_inductive indu specif in let realsign_ind = @@ -185,7 +185,7 @@ let build_sym_scheme env ind = my_it_mkLambda_or_LetIn_name (lift_rel_context (nrealargs+1) realsign_ind) (mkApp (mkIndU indu,Array.concat - [Context.Rel.to_extended_vect (3*nrealargs+2) paramsctxt1; + [Context.Rel.to_extended_vect mkRel (3*nrealargs+2) paramsctxt1; rel_vect 1 nrealargs; rel_vect (2*nrealargs+2) nrealargs])), mkRel 1 (* varH *), @@ -226,13 +226,13 @@ let build_sym_involutive_scheme env ind = get_sym_eq_data env indu in let eq,eqrefl,ctx = get_coq_eq ctx in let sym, ctx, eff = const_of_scheme sym_scheme_kind env ind ctx in - let cstr n = mkApp (mkConstructUi (indu,1),Context.Rel.to_extended_vect n paramsctxt) in + let cstr n = mkApp (mkConstructUi (indu,1),Context.Rel.to_extended_vect mkRel n paramsctxt) in let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in let applied_ind = build_dependent_inductive indu specif in let applied_ind_C = mkApp (mkIndU indu, Array.append - (Context.Rel.to_extended_vect (nrealargs+1) mib.mind_params_ctxt) + (Context.Rel.to_extended_vect mkRel (nrealargs+1) mib.mind_params_ctxt) (rel_vect (nrealargs+1) nrealargs)) in let realsign_ind = name_context env ((LocalAssum (Name varH,applied_ind))::realsign) in @@ -246,15 +246,15 @@ let build_sym_involutive_scheme env ind = (mkApp (eq,[| mkApp (mkIndU indu, Array.concat - [Context.Rel.to_extended_vect (3*nrealargs+2) paramsctxt1; + [Context.Rel.to_extended_vect mkRel (3*nrealargs+2) paramsctxt1; rel_vect (2*nrealargs+2) nrealargs; rel_vect 1 nrealargs]); mkApp (sym,Array.concat - [Context.Rel.to_extended_vect (3*nrealargs+2) paramsctxt1; + [Context.Rel.to_extended_vect mkRel (3*nrealargs+2) paramsctxt1; rel_vect 1 nrealargs; rel_vect (2*nrealargs+2) nrealargs; [|mkApp (sym,Array.concat - [Context.Rel.to_extended_vect (3*nrealargs+2) paramsctxt1; + [Context.Rel.to_extended_vect mkRel (3*nrealargs+2) paramsctxt1; rel_vect (2*nrealargs+2) nrealargs; rel_vect 1 nrealargs; [|mkRel 1|]])|]]); @@ -337,7 +337,7 @@ let build_l2r_rew_scheme dep env ind kind = let eq,eqrefl,ctx = get_coq_eq ctx in let cstr n p = mkApp (mkConstructUi(indu,1), - Array.concat [Context.Rel.to_extended_vect n paramsctxt1; + Array.concat [Context.Rel.to_extended_vect mkRel n paramsctxt1; rel_vect p nrealargs]) in let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in let varHC = fresh env (Id.of_string "HC") in @@ -345,12 +345,12 @@ let build_l2r_rew_scheme dep env ind kind = let applied_ind = build_dependent_inductive indu specif in let applied_ind_P = mkApp (mkIndU indu, Array.concat - [Context.Rel.to_extended_vect (3*nrealargs) paramsctxt1; + [Context.Rel.to_extended_vect mkRel (3*nrealargs) paramsctxt1; rel_vect 0 nrealargs; rel_vect nrealargs nrealargs]) in let applied_ind_G = mkApp (mkIndU indu, Array.concat - [Context.Rel.to_extended_vect (3*nrealargs+3) paramsctxt1; + [Context.Rel.to_extended_vect mkRel (3*nrealargs+3) paramsctxt1; rel_vect (nrealargs+3) nrealargs; rel_vect 0 nrealargs]) in let realsign_P = lift_rel_context nrealargs realsign in @@ -361,10 +361,10 @@ let build_l2r_rew_scheme dep env ind kind = lift_rel_context (nrealargs+3) realsign) in let applied_sym_C n = mkApp(sym, - Array.append (Context.Rel.to_extended_vect n mip.mind_arity_ctxt) [|mkVar varH|]) in + Array.append (Context.Rel.to_extended_vect mkRel n mip.mind_arity_ctxt) [|mkVar varH|]) in let applied_sym_G = mkApp(sym, - Array.concat [Context.Rel.to_extended_vect (nrealargs*3+4) paramsctxt1; + Array.concat [Context.Rel.to_extended_vect mkRel (nrealargs*3+4) paramsctxt1; rel_vect (nrealargs+4) nrealargs; rel_vect 1 nrealargs; [|mkRel 1|]]) in @@ -374,7 +374,7 @@ let build_l2r_rew_scheme dep env ind kind = let ci = make_case_info (Global.env()) ind RegularStyle in let cieq = make_case_info (Global.env()) (fst (destInd eq)) RegularStyle in let applied_PC = - mkApp (mkVar varP,Array.append (Context.Rel.to_extended_vect 1 realsign) + mkApp (mkVar varP,Array.append (Context.Rel.to_extended_vect mkRel 1 realsign) (if dep then [|cstr (2*nrealargs+1) 1|] else [||])) in let applied_PG = mkApp (mkVar varP,Array.append (rel_vect 1 nrealargs) @@ -384,11 +384,11 @@ let build_l2r_rew_scheme dep env ind kind = (if dep then [|mkRel 2|] else [||])) in let applied_sym_sym = mkApp (sym,Array.concat - [Context.Rel.to_extended_vect (2*nrealargs+4) paramsctxt1; + [Context.Rel.to_extended_vect mkRel (2*nrealargs+4) paramsctxt1; rel_vect 4 nrealargs; rel_vect (nrealargs+4) nrealargs; [|mkApp (sym,Array.concat - [Context.Rel.to_extended_vect (2*nrealargs+4) paramsctxt1; + [Context.Rel.to_extended_vect mkRel (2*nrealargs+4) paramsctxt1; rel_vect (nrealargs+4) nrealargs; rel_vect 4 nrealargs; [|mkRel 2|]])|]]) in @@ -411,7 +411,7 @@ let build_l2r_rew_scheme dep env ind kind = mkApp (eq,[|lift 4 applied_ind;applied_sym_sym;mkRel 1|]), applied_PR)), mkApp (sym_involutive, - Array.append (Context.Rel.to_extended_vect 3 mip.mind_arity_ctxt) [|mkVar varH|]), + Array.append (Context.Rel.to_extended_vect mkRel 3 mip.mind_arity_ctxt) [|mkVar varH|]), [|main_body|]) else main_body)))))) @@ -450,7 +450,7 @@ let build_l2r_forward_rew_scheme dep env ind kind = get_sym_eq_data env indu in let cstr n p = mkApp (mkConstructUi(indu,1), - Array.concat [Context.Rel.to_extended_vect n paramsctxt1; + Array.concat [Context.Rel.to_extended_vect mkRel n paramsctxt1; rel_vect p nrealargs]) in let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in let varHC = fresh env (Id.of_string "HC") in @@ -458,12 +458,12 @@ let build_l2r_forward_rew_scheme dep env ind kind = let applied_ind = build_dependent_inductive indu specif in let applied_ind_P = mkApp (mkIndU indu, Array.concat - [Context.Rel.to_extended_vect (4*nrealargs+2) paramsctxt1; + [Context.Rel.to_extended_vect mkRel (4*nrealargs+2) paramsctxt1; rel_vect 0 nrealargs; rel_vect (nrealargs+1) nrealargs]) in let applied_ind_P' = mkApp (mkIndU indu, Array.concat - [Context.Rel.to_extended_vect (3*nrealargs+1) paramsctxt1; + [Context.Rel.to_extended_vect mkRel (3*nrealargs+1) paramsctxt1; rel_vect 0 nrealargs; rel_vect (2*nrealargs+1) nrealargs]) in let realsign_P n = lift_rel_context (nrealargs*n+n) realsign in @@ -541,7 +541,7 @@ let build_r2l_forward_rew_scheme dep env ind kind = let ((mib,mip as specif),constrargs,realsign,paramsctxt,nrealargs) = get_non_sym_eq_data env indu in let cstr n = - mkApp (mkConstructUi(indu,1),Context.Rel.to_extended_vect n mib.mind_params_ctxt) in + mkApp (mkConstructUi(indu,1),Context.Rel.to_extended_vect mkRel n mib.mind_params_ctxt) in let constrargs_cstr = constrargs@[cstr 0] in let varH = fresh env (default_id_of_sort (snd (mind_arity mip))) in let varHC = fresh env (Id.of_string "HC") in @@ -557,8 +557,8 @@ let build_r2l_forward_rew_scheme dep env ind kind = applist (mkVar varP,if dep then constrargs_cstr else constrargs) in let applied_PG = mkApp (mkVar varP, - if dep then Context.Rel.to_extended_vect 0 realsign_ind - else Context.Rel.to_extended_vect 1 realsign) in + if dep then Context.Rel.to_extended_vect mkRel 0 realsign_ind + else Context.Rel.to_extended_vect mkRel 1 realsign) in let c = (my_it_mkLambda_or_LetIn paramsctxt (my_it_mkLambda_or_LetIn_name realsign_ind @@ -608,7 +608,7 @@ let fix_r2l_forward_rew_scheme (c, ctx') = (mkLambda_or_LetIn (RelDecl.map_constr (lift 2) ind) (EConstr.Unsafe.to_constr (Reductionops.whd_beta Evd.empty (EConstr.of_constr (applist (c, - Context.Rel.to_extended_list 3 indargs @ [mkRel 1;mkRel 3;mkRel 2])))))))) + 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") @@ -763,8 +763,8 @@ let build_congr env (eq,refl,ctx) ind = (mkNamedLambda varH (applist (mkIndU indu, - Context.Rel.to_extended_list (mip.mind_nrealargs+2) paramsctxt @ - Context.Rel.to_extended_list 0 realsign)) + Context.Rel.to_extended_list mkRel (mip.mind_nrealargs+2) paramsctxt @ + Context.Rel.to_extended_list mkRel 0 realsign)) (mkCase (ci, my_it_mkLambda_or_LetIn_name (lift_rel_context (mip.mind_nrealargs+3) realsign) @@ -772,9 +772,9 @@ let build_congr env (eq,refl,ctx) ind = (Anonymous, applist (mkIndU indu, - Context.Rel.to_extended_list (2*mip.mind_nrealdecls+3) + Context.Rel.to_extended_list mkRel (2*mip.mind_nrealdecls+3) paramsctxt - @ Context.Rel.to_extended_list 0 realsign), + @ Context.Rel.to_extended_list mkRel 0 realsign), mkApp (eq, [|mkVar varB; mkApp (mkVar varf, [|lift (2*mip.mind_nrealdecls+4) b|]); diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 0ecccd5c02..8260c14ad4 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1634,7 +1634,7 @@ let make_projection env sigma params cstr sign elim i n c u = then let t = lift (i+1-n) t in let abselim = beta_applist sigma (elim, params@[t;branch]) in - let args = Array.map EConstr.of_constr (Context.Rel.to_extended_vect 0 sign) in + let args = Context.Rel.to_extended_vect mkRel 0 sign in let c = beta_applist sigma (abselim, [mkApp (c, args)]) in Some (it_mkLambda_or_LetIn c sign, it_mkProd_or_LetIn t sign) else @@ -1643,8 +1643,7 @@ let make_projection env sigma params cstr sign elim i n c u = (* goes from left to right when i increases! *) match List.nth l i with | Some proj -> - let args = Context.Rel.to_extended_vect 0 sign in - let args = Array.map EConstr.of_constr args in + let args = Context.Rel.to_extended_vect mkRel 0 sign in let proj = if Environ.is_projection proj env then mkProj (Projection.make proj false, mkApp (c, args)) @@ -2190,7 +2189,7 @@ let bring_hyps hyps = let store = Proofview.Goal.extra gl in let concl = Tacmach.New.pf_nf_concl gl in let newcl = List.fold_right mkNamedProd_or_LetIn hyps concl in - let args = Array.map_of_list EConstr.of_constr (Context.Named.to_instance hyps) in + let args = Array.of_list (Context.Named.to_instance mkVar hyps) in Refine.refine { run = begin fun sigma -> let Sigma (ev, sigma, p) = Evarutil.new_evar env sigma ~principal:true ~store newcl in @@ -2868,8 +2867,7 @@ let old_generalize_dep ?(with_let=false) c gl = (cl',project gl) in (** Check that the generalization is indeed well-typed *) let (evd, _) = Typing.type_of env evd cl'' in - let args = Context.Named.to_instance to_quantify_rev in - let args = List.map EConstr.of_constr args 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)); @@ -3994,7 +3992,7 @@ let compute_scheme_signature evd scheme names_info ind_type_guess = let ind_is_ok = List.equal (fun c1 c2 -> EConstr.eq_constr evd c1 c2) (List.lastn scheme.nargs indargs) - (List.map EConstr.of_constr (Context.Rel.to_extended_list 0 scheme.args)) in + (Context.Rel.to_extended_list mkRel 0 scheme.args) in if not (ccl_arg_ok && ind_is_ok) then error_ind_scheme "the conclusion of" in (cond, check_concl) @@ -4965,7 +4963,7 @@ let abstract_subproof id gk tac = in let const, args = if !shrink_abstract then shrink_entry sign const - else (const, List.rev (Context.Named.to_instance sign)) + else (const, List.rev (Context.Named.to_instance Constr.mkVar sign)) in let args = List.map EConstr.of_constr args in let cd = Entries.DefinitionEntry const in -- cgit v1.2.3 From b4b90c5d2e8c413e1981c456c933f35679386f09 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 26 Nov 2016 16:18:47 +0100 Subject: Definining EConstr-based contexts. This removes quite a few unsafe casts. Unluckily, I had to reintroduce the old non-module based names for these data structures, because I could not reproduce easily the same hierarchy in EConstr. --- tactics/auto.ml | 2 +- tactics/class_tactics.ml | 16 ++--- tactics/contradiction.ml | 4 +- tactics/equality.ml | 30 ++++----- tactics/hints.ml | 4 +- tactics/hints.mli | 4 +- tactics/hipattern.ml | 5 +- tactics/inv.ml | 7 ++- tactics/leminv.ml | 20 +++--- tactics/tacticals.ml | 3 +- tactics/tacticals.mli | 28 ++++----- tactics/tactics.ml | 161 +++++++++++++++++++---------------------------- tactics/tactics.mli | 18 +++--- tactics/term_dnet.ml | 5 +- 14 files changed, 138 insertions(+), 169 deletions(-) (limited to 'tactics') diff --git a/tactics/auto.ml b/tactics/auto.ml index 17a488ddb6..b548f8b928 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -321,7 +321,7 @@ let rec trivial_fail_db dbg mod_delta db_list local_db = ( Proofview.Goal.enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in - let nf c = EConstr.Unsafe.to_constr (Evarutil.nf_evar sigma (EConstr.of_constr c)) in + let nf c = Evarutil.nf_evar sigma c in let decl = Tacmach.New.pf_last_hyp (Proofview.Goal.assume gl) in let hyp = Context.Named.Declaration.map_constr nf decl in let hintl = make_resolve_hyp env sigma hyp diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index ef67d28f9c..55fda1c7db 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -521,14 +521,14 @@ let evars_to_goals p evm = (** Making local hints *) let make_resolve_hyp env sigma st flags only_classes pri decl = let id = NamedDecl.get_id decl in - let cty = Evarutil.nf_evar sigma (EConstr.of_constr (NamedDecl.get_type decl)) in + let cty = Evarutil.nf_evar sigma (NamedDecl.get_type decl) in let rec iscl env ty = let ctx, ar = decompose_prod_assum sigma ty in match EConstr.kind sigma (fst (decompose_app sigma ar)) with | Const (c,_) -> is_class (ConstRef c) | Ind (i,_) -> is_class (IndRef i) | _ -> - let env' = Environ.push_rel_context ctx env in + let env' = push_rel_context ctx env in let ty' = Reductionops.whd_all env' sigma ar in if not (EConstr.eq_constr sigma ty' ar) then iscl env' ty' else false @@ -562,7 +562,7 @@ let make_hints g st only_classes sign = let consider = try let t = hyp |> NamedDecl.get_id |> Global.lookup_named |> NamedDecl.get_type in (* Section variable, reindex only if the type changed *) - not (Term.eq_constr t (NamedDecl.get_type hyp)) + not (EConstr.eq_constr (project g) (EConstr.of_constr t) (NamedDecl.get_type hyp)) with Not_found -> true in if consider then @@ -617,7 +617,7 @@ module V85 = struct then cached_hints else - let hints = make_hints g st only_classes (Environ.named_context_of_val sign) + let hints = make_hints g st only_classes (EConstr.named_context_of_val sign) in cache := (only_classes, sign, hints); hints @@ -634,7 +634,7 @@ module V85 = struct let gls' = List.map (fun g' -> let env = Goal.V82.env s g' in - let context = Environ.named_context_of_val (Goal.V82.hyps s g') in + let context = EConstr.named_context_of_val (Goal.V82.hyps s g') in let hint = make_resolve_hyp env s (Hint_db.transparent_state info.hints) (true,false,false) info.only_classes None (List.hd context) in let ldb = Hint_db.add_list env s hint info.hints in @@ -937,9 +937,10 @@ module Search = struct let sign = Goal.hyps g in let (dir, onlyc, sign', cached_hints) = !autogoal_cache in let cwd = Lib.cwd () in + let eq c1 c2 = EConstr.eq_constr (project g) c1 c2 in if DirPath.equal cwd dir && (onlyc == only_classes) && - Context.Named.equal Constr.equal sign sign' && + Context.Named.equal eq sign sign' && Hint_db.transparent_state cached_hints == st then cached_hints else @@ -1033,8 +1034,9 @@ module Search = struct Feedback.msg_debug (pr_depth (succ j :: i :: info.search_depth) ++ str" : " ++ pr_ev s' (Proofview.Goal.goal gl')); + let eq c1 c2 = EConstr.eq_constr s' c1 c2 in let hints' = - if b && not (Context.Named.equal Constr.equal (Goal.hyps gl') (Goal.hyps gl)) + if b && not (Context.Named.equal eq (Goal.hyps gl') (Goal.hyps gl)) then let st = Hint_db.transparent_state info.search_hints in make_autogoal_hints info.search_only_classes ~st gl' diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index 7173fb4fd7..0e28aa9800 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -51,7 +51,7 @@ let use_negated_unit_or_eq_type () = Flags.version_strictly_greater Flags.V8_5 let filter_hyp f tac = let rec seek = function | [] -> Proofview.tclZERO Not_found - | d::rest when f (EConstr.of_constr (NamedDecl.get_type d)) -> tac (NamedDecl.get_id d) + | d::rest when f (NamedDecl.get_type d) -> tac (NamedDecl.get_id d) | _::rest -> seek rest in Proofview.Goal.enter { enter = begin fun gl -> let hyps = Proofview.Goal.hyps (Proofview.Goal.assume gl) in @@ -66,7 +66,7 @@ let contradiction_context = | [] -> Tacticals.New.tclZEROMSG (Pp.str"No such contradiction") | d :: rest -> let id = NamedDecl.get_id d in - let typ = nf_evar sigma (EConstr.of_constr (NamedDecl.get_type d)) in + let typ = nf_evar sigma (NamedDecl.get_type d) in let typ = whd_all env sigma typ in if is_empty_type sigma typ then simplest_elim (mkVar id) diff --git a/tactics/equality.ml b/tactics/equality.ml index 072da995db..122b64777e 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -13,12 +13,12 @@ open Names open Nameops open Term open Termops +open Environ open EConstr open Vars open Namegen open Inductive open Inductiveops -open Environ open Libnames open Globnames open Reductionops @@ -47,10 +47,6 @@ open Context.Named.Declaration module NamedDecl = Context.Named.Declaration -let nlocal_assum (na, t) = - let inj = EConstr.Unsafe.to_constr in - NamedDecl.LocalAssum (na, inj t) - (* Options *) let discriminate_introduction = ref true @@ -333,7 +329,7 @@ let jmeq_same_dom gl = function | None -> true (* already checked in Hipattern.find_eq_data_decompose *) | Some t -> let rels, t = decompose_prod_assum (project gl) t in - let env = Environ.push_rel_context rels (Proofview.Goal.env gl) in + let env = push_rel_context rels (Proofview.Goal.env gl) in match decompose_app (project gl) t with | _, [dom1; _; dom2;_] -> is_conv env (Tacmach.New.project gl) dom1 dom2 | _ -> false @@ -857,16 +853,19 @@ let descend_then env sigma head dirn = let (mib,mip) = lookup_mind_specif env ind in let cstr = get_constructors env indf in let dirn_nlams = cstr.(dirn-1).cs_nargs in - let dirn_env = push_rel_context cstr.(dirn-1).cs_args env in + let dirn_env = Environ.push_rel_context cstr.(dirn-1).cs_args env in (dirn_nlams, dirn_env, (fun dirnval (dfltval,resty) -> let deparsign = make_arity_signature env true indf in + let deparsign = List.map (fun d -> map_rel_decl EConstr.of_constr d) deparsign in let p = it_mkLambda_or_LetIn (lift (mip.mind_nrealargs+1) resty) deparsign in let build_branch i = let result = if Int.equal i dirn then dirnval else dfltval in - it_mkLambda_or_LetIn result (name_context env cstr.(i-1).cs_args) in + let args = name_context env cstr.(i-1).cs_args in + let args = List.map (fun d -> map_rel_decl EConstr.of_constr d) args in + it_mkLambda_or_LetIn result args in let brl = List.map build_branch (List.interval 1 (Array.length mip.mind_consnames)) in @@ -907,11 +906,13 @@ let build_selector env sigma dirn c ind special default = let typ = Retyping.get_type_of env sigma default in let (mib,mip) = lookup_mind_specif env ind in let deparsign = make_arity_signature env true indf in + let deparsign = List.map (fun d -> map_rel_decl EConstr.of_constr d) deparsign in let p = it_mkLambda_or_LetIn typ deparsign in let cstrs = get_constructors env indf in let build_branch i = let endpt = if Int.equal i dirn then special else default in - it_mkLambda_or_LetIn endpt cstrs.(i-1).cs_args in + let args = List.map (fun d -> map_rel_decl EConstr.of_constr d) cstrs.(i-1).cs_args in + it_mkLambda_or_LetIn endpt args in let brl = List.map build_branch(List.interval 1 (Array.length mip.mind_consnames)) in let ci = make_case_info env ind RegularStyle in @@ -995,7 +996,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 (nlocal_assum (e, t)) env in + let e_env = push_named (Context.Named.Declaration.LocalAssum (e,t)) env in let discriminator = build_discriminator e_env sigma dirn (mkVar e) cpath in let sigma,(pf, absurd_term), eff = @@ -1372,7 +1373,7 @@ let simplify_args env sigma t = let inject_at_positions env sigma l2r (eq,_,(t,t1,t2)) eq_clause posns tac = let e = next_ident_away eq_baseid (ids_of_context env) in - let e_env = push_named (nlocal_assum (e,t)) env in + let e_env = push_named (LocalAssum (e,t)) env in let evdref = ref sigma in let filter (cpath, t1', t2') = try @@ -1696,7 +1697,7 @@ let is_eq_x gl x d = | Var id' -> Id.equal id id' | _ -> false in - let c = pf_nf_evar gl (EConstr.of_constr (NamedDecl.get_type d)) in + let c = pf_nf_evar gl (NamedDecl.get_type d) in let (_,lhs,rhs) = pi3 (find_eq_data_decompose gl c) in if (is_var x lhs) && not (local_occur_var (project gl) x rhs) then raise (FoundHyp (id,rhs,true)); if (is_var x rhs) && not (local_occur_var (project gl) x lhs) then raise (FoundHyp (id,lhs,false)) @@ -1793,7 +1794,7 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () = let find_eq_data_decompose = find_eq_data_decompose gl in let select_equation_name decl = try - let lbeq,u,(_,x,y) = find_eq_data_decompose (EConstr.of_constr (NamedDecl.get_type decl)) in + let lbeq,u,(_,x,y) = find_eq_data_decompose (NamedDecl.get_type decl) in let eq = Universes.constr_of_global_univ (lbeq.eq,u) in if flags.only_leibniz then restrict_to_eq_and_identity eq; match EConstr.kind sigma x, EConstr.kind sigma y with @@ -1817,7 +1818,6 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () = let env = Proofview.Goal.env gl in let find_eq_data_decompose = find_eq_data_decompose gl in let c = pf_get_hyp hyp gl |> NamedDecl.get_type in - let c = EConstr.of_constr c in let _,_,(_,x,y) = find_eq_data_decompose c in (* 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 @@ -1890,7 +1890,7 @@ let rewrite_assumption_cond cond_eq_term cl = let id = NamedDecl.get_id hyp in begin try - let dir = cond_eq_term (EConstr.of_constr (NamedDecl.get_type hyp)) gl in + let dir = cond_eq_term (NamedDecl.get_type hyp) gl in general_rewrite_clause dir false (mkVar id,NoBindings) cl with | Failure _ | UserError _ -> arec rest gl end diff --git a/tactics/hints.ml b/tactics/hints.ml index ef97b0b330..ffd19ac6e0 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -875,7 +875,7 @@ let make_resolve_hyp env sigma decl = try [make_apply_entry env sigma (true, true, false) None false ~name:(PathHints [VarRef hname]) - (c, EConstr.of_constr (NamedDecl.get_type decl), Univ.ContextSet.empty)] + (c, NamedDecl.get_type decl, Univ.ContextSet.empty)] with | Failure _ -> [] | e when Logic.catchable_exception e -> anomaly (Pp.str "make_resolve_hyp") @@ -1335,7 +1335,7 @@ let make_local_hint_db env sigma ts eapply lems = (Sigma.to_evar_map sigma, c) in let lems = List.map map lems in - let sign = Environ.named_context env in + let sign = EConstr.named_context env in let ts = match ts with | None -> Hint_db.transparent_state (searchtable_map "core") | Some ts -> ts diff --git a/tactics/hints.mli b/tactics/hints.mli index 344827e03e..0d6dd434e9 100644 --- a/tactics/hints.mli +++ b/tactics/hints.mli @@ -29,7 +29,7 @@ val decompose_app_bound : evar_map -> constr -> global_reference * constr array type debug = Debug | Info | Off -val secvars_of_hyps : Context.Named.t -> Id.Pred.t +val secvars_of_hyps : ('c, 't) Context.Named.pt -> Id.Pred.t (** Pre-created hint databases *) @@ -209,7 +209,7 @@ val make_resolves : If the hyp cannot be used as a Hint, the empty list is returned. *) val make_resolve_hyp : - env -> evar_map -> Context.Named.Declaration.t -> hint_entry list + env -> evar_map -> named_declaration -> hint_entry list (** [make_extern pri pattern tactic_expr] *) diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml index 607d6d2a91..8e4654c02b 100644 --- a/tactics/hipattern.ml +++ b/tactics/hipattern.ml @@ -107,8 +107,8 @@ let match_with_one_constructor sigma style onlybinary allow_rec t = List.for_all (fun decl -> let c = RelDecl.get_type decl in is_local_assum decl && - Term.isRel c && - Int.equal (Term.destRel c) mib.mind_nparams) ctx + isRel sigma c && + Int.equal (destRel sigma c) mib.mind_nparams) ctx then Some (hdapp,args) else None @@ -117,7 +117,6 @@ let match_with_one_constructor sigma style onlybinary allow_rec t = let cargs = List.map RelDecl.get_type (prod_assum sigma ctyp) in if not (is_lax_conjunction style) || has_nodep_prod sigma ctyp then (* Record or non strict conjunction *) - let cargs = List.map EConstr.of_constr cargs in Some (hdapp,List.rev cargs) else None diff --git a/tactics/inv.ml b/tactics/inv.ml index 426749a758..ecb8eedaca 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -13,10 +13,10 @@ open Names open Nameops open Term open Termops +open Environ open EConstr open Vars open Namegen -open Environ open Inductiveops open Printer open Retyping @@ -75,6 +75,7 @@ let make_inv_predicate env evd indf realargs id status concl = | NoDep -> (* We push the arity and leave concl unchanged *) let hyps_arity,_ = get_arity env indf in + let hyps_arity = List.map (fun d -> map_rel_decl EConstr.of_constr d) hyps_arity in (hyps_arity,concl) | Dep dflt_concl -> if not (occur_var env !evd id concl) then @@ -132,6 +133,10 @@ let make_inv_predicate env evd indf realargs id status concl = build_concl eqns args (succ n) restlist in let (newconcl, args) = build_concl [] [] 0 realargs in + let name_context env ctx = + let map f c = List.map (fun d -> Termops.map_rel_decl f d) c in + map EConstr.of_constr (name_context env (map EConstr.Unsafe.to_constr ctx)) + in let predicate = it_mkLambda_or_LetIn newconcl (name_context env hyps) in let _ = Evarutil.evd_comb1 (Typing.type_of env) evd predicate in (* OK - this predicate should now be usable by res_elimination_then to diff --git a/tactics/leminv.ml b/tactics/leminv.ml index a05b4fbf3b..d7c396179f 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -12,6 +12,7 @@ open Util open Names open Term open Termops +open Environ open EConstr open Vars open Namegen @@ -20,7 +21,6 @@ open Printer open Reductionops open Entries open Inductiveops -open Environ open Tacmach.New open Clenv open Declare @@ -32,14 +32,6 @@ open Context.Named.Declaration module NamedDecl = Context.Named.Declaration -let nlocal_assum (na, t) = - let inj = EConstr.Unsafe.to_constr in - NamedDecl.LocalAssum (na, inj t) - -let nlocal_def (na, b, t) = - let inj = EConstr.Unsafe.to_constr in - NamedDecl.LocalDef (na, inj b, inj t) - let no_inductive_inconstr env sigma constr = (str "Cannot recognize an inductive predicate in " ++ pr_leconstr_env env sigma constr ++ @@ -129,11 +121,11 @@ let rec add_prods_sign env sigma t = | Prod (na,c1,b) -> let id = id_of_name_using_hdchar env (EConstr.Unsafe.to_constr t) na in let b'= subst1 (mkVar id) b in - add_prods_sign (push_named (nlocal_assum (id,c1)) env) sigma b' + add_prods_sign (push_named (LocalAssum (id,c1)) env) sigma b' | LetIn (na,c1,t1,b) -> let id = id_of_name_using_hdchar env (EConstr.Unsafe.to_constr t) na in let b'= subst1 (mkVar id) b in - add_prods_sign (push_named (nlocal_def (id,c1,t1)) env) sigma b' + add_prods_sign (push_named (LocalDef (id,c1,t1)) env) sigma b' | _ -> (env,t) (* [dep_option] indicates whether the inversion lemma is dependent or not. @@ -168,6 +160,7 @@ let compute_first_inversion_scheme env sigma ind sort dep_option = let revargs,ownsign = fold_named_context (fun env d (revargs,hyps) -> + let d = map_named_decl EConstr.of_constr d in let id = NamedDecl.get_id d in if Id.List.mem id ivars then ((mkVar id)::revargs, Context.Named.add d hyps) @@ -180,7 +173,7 @@ let compute_first_inversion_scheme env sigma ind sort dep_option = (pty,goal) in let npty = nf_all env sigma pty in - let extenv = push_named (nlocal_assum (p,npty)) env in + let extenv = push_named (LocalAssum (p,npty)) env in extenv, goal (* [inversion_scheme sign I] @@ -218,6 +211,7 @@ let inversion_scheme env sigma t sort dep_option inv_op = let ownSign = ref begin fold_named_context (fun env d sign -> + let d = map_named_decl EConstr.of_constr d in if mem_named_context_val (NamedDecl.get_id d) global_named_context then sign else Context.Named.add d sign) invEnv ~init:Context.Named.empty @@ -231,7 +225,7 @@ let inversion_scheme env sigma t sort dep_option inv_op = let h = next_ident_away (Id.of_string "H") !avoid in let ty,inst = Evarutil.generalize_evar_over_rels sigma (e,args) in avoid := h::!avoid; - ownSign := Context.Named.add (nlocal_assum (h,ty)) !ownSign; + ownSign := Context.Named.add (LocalAssum (h,ty)) !ownSign; applist (mkVar h, inst) | _ -> EConstr.map sigma fill_holes c in diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index 9cf3c41876..94f22f9039 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -158,7 +158,7 @@ type branch_args = { type branch_assumptions = { ba : branch_args; (* the branch args *) - assums : Context.Named.t} (* the list of assumptions introduced *) + assums : named_context} (* the list of assumptions introduced *) open Misctypes @@ -625,7 +625,6 @@ module New = struct (* c should be of type A1->.. An->B with B an inductive definition *) let general_elim_then_using mk_elim isrec allnames tac predicate ind (c, t) = - let open EConstr in Proofview.Goal.nf_enter { enter = begin fun gl -> let sigma, elim = Tacmach.New.of_old (mk_elim ind) gl in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index 2b07d937ed..e9f6231002 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -60,29 +60,29 @@ val tclIFTHENTRYELSEMUST : tactic -> tactic -> tactic val onNthHypId : int -> (Id.t -> tactic) -> tactic val onNthHyp : int -> (constr -> tactic) -> tactic -val onNthDecl : int -> (Context.Named.Declaration.t -> tactic) -> tactic +val onNthDecl : int -> (named_declaration -> tactic) -> tactic val onLastHypId : (Id.t -> tactic) -> tactic val onLastHyp : (constr -> tactic) -> tactic -val onLastDecl : (Context.Named.Declaration.t -> tactic) -> tactic +val onLastDecl : (named_declaration -> tactic) -> tactic val onNLastHypsId : int -> (Id.t list -> tactic) -> tactic val onNLastHyps : int -> (constr list -> tactic) -> tactic -val onNLastDecls : int -> (Context.Named.t -> tactic) -> tactic +val onNLastDecls : int -> (named_context -> tactic) -> tactic val lastHypId : goal sigma -> Id.t val lastHyp : goal sigma -> constr -val lastDecl : goal sigma -> Context.Named.Declaration.t +val lastDecl : goal sigma -> named_declaration val nLastHypsId : int -> goal sigma -> Id.t list val nLastHyps : int -> goal sigma -> constr list -val nLastDecls : int -> goal sigma -> Context.Named.t +val nLastDecls : int -> goal sigma -> named_context -val afterHyp : Id.t -> goal sigma -> Context.Named.t +val afterHyp : Id.t -> goal sigma -> named_context val ifOnHyp : (Id.t * types -> bool) -> (Id.t -> tactic) -> (Id.t -> tactic) -> Id.t -> tactic -val onHyps : (goal sigma -> Context.Named.t) -> - (Context.Named.t -> tactic) -> tactic +val onHyps : (goal sigma -> named_context) -> + (named_context -> tactic) -> tactic (** {6 Tacticals applying to goal components } *) @@ -110,7 +110,7 @@ type branch_args = private { type branch_assumptions = private { ba : branch_args; (** the branch args *) - assums : Context.Named.t} (** the list of assumptions introduced *) + assums : named_context} (** the list of assumptions introduced *) (** [get_and_check_or_and_pattern loc pats branchsign] returns an appropriate error message if |pats| <> |branchsign|; extends them if no pattern is given @@ -229,7 +229,7 @@ module New : sig val tclTIMEOUT : int -> unit tactic -> unit tactic val tclTIME : string option -> 'a tactic -> 'a tactic - val nLastDecls : ([ `NF ], 'r) Proofview.Goal.t -> int -> Context.Named.t + val nLastDecls : ([ `NF ], 'r) Proofview.Goal.t -> int -> named_context val ifOnHyp : (identifier * types -> bool) -> (identifier -> unit Proofview.tactic) -> (identifier -> unit Proofview.tactic) -> @@ -238,11 +238,11 @@ module New : sig val onNthHypId : int -> (identifier -> unit tactic) -> unit tactic val onLastHypId : (identifier -> unit tactic) -> unit tactic val onLastHyp : (constr -> unit tactic) -> unit tactic - val onLastDecl : (Context.Named.Declaration.t -> unit tactic) -> unit tactic + val onLastDecl : (named_declaration -> unit tactic) -> unit tactic - val onHyps : ([ `NF ], Context.Named.t) Proofview.Goal.enter -> - (Context.Named.t -> unit tactic) -> unit tactic - val afterHyp : Id.t -> (Context.Named.t -> unit tactic) -> unit tactic + val onHyps : ([ `NF ], named_context) Proofview.Goal.enter -> + (named_context -> unit tactic) -> unit tactic + val afterHyp : Id.t -> (named_context -> unit tactic) -> unit tactic val tryAllHyps : (identifier -> unit tactic) -> unit tactic val tryAllHypsAndConcl : (identifier option -> unit tactic) -> unit tactic diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 8260c14ad4..4bf848a9c3 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -15,6 +15,7 @@ open Names open Nameops open Term open Termops +open Environ open EConstr open Vars open Find_subterm @@ -22,7 +23,6 @@ open Namegen open Declarations open Inductiveops open Reductionops -open Environ open Globnames open Evd open Pfedit @@ -170,26 +170,6 @@ let _ = (* Primitive tactics *) (******************************************) -let local_assum (na, t) = - let open Context.Rel.Declaration in - let inj = EConstr.Unsafe.to_constr in - LocalAssum (na, inj t) - -let local_def (na, b, t) = - let open Context.Rel.Declaration in - let inj = EConstr.Unsafe.to_constr in - LocalDef (na, inj b, inj t) - -let nlocal_assum (na, t) = - let open Context.Named.Declaration in - let inj = EConstr.Unsafe.to_constr in - LocalAssum (na, inj t) - -let nlocal_def (na, b, t) = - let open Context.Named.Declaration in - let inj = EConstr.Unsafe.to_constr in - LocalDef (na, inj b, inj t) - (** This tactic creates a partial proof realizing the introduction rule, but does not check anything. *) let unsafe_intro env store decl b = @@ -217,8 +197,8 @@ let introduction ?(check=true) id = in let open Context.Named.Declaration in match EConstr.kind sigma concl with - | Prod (_, t, b) -> unsafe_intro env store (nlocal_assum (id, t)) b - | LetIn (_, c, t, b) -> unsafe_intro env store (nlocal_def (id, c, t)) b + | Prod (_, t, b) -> unsafe_intro env store (LocalAssum (id, t)) b + | LetIn (_, c, t, b) -> unsafe_intro env store (LocalDef (id, c, t)) b | _ -> raise (RefinerError IntroNeedsProduct) end } @@ -321,7 +301,6 @@ let clear_gen fail = function try clear_hyps_in_evi env evdref (named_context_val env) concl ids with Evarutil.ClearDependencyError (id,err) -> fail env sigma id err in - let concl = EConstr.of_constr concl in let env = reset_with_named_context hyps env in let tac = Refine.refine ~unsafe:true { run = fun sigma -> Evarutil.new_evar env sigma ~principal:true concl @@ -397,18 +376,16 @@ let rename_hyp repl = with Not_found -> () in (** All is well *) - let make_subst (src, dst) = (src, Constr.mkVar dst) in + let make_subst (src, dst) = (src, mkVar dst) in let subst = List.map make_subst repl in - let subst c = CVars.replace_vars subst c in + let subst c = Vars.replace_vars subst c in let map decl = decl |> NamedDecl.map_id (fun id -> try List.assoc_f Id.equal id repl with Not_found -> id) |> NamedDecl.map_constr subst in let nhyps = List.map map hyps in - let concl = EConstr.Unsafe.to_constr concl in let nconcl = subst concl in - let nconcl = EConstr.of_constr nconcl in - let nctx = Environ.val_of_named_context nhyps in + let nctx = val_of_named_context nhyps in let instance = List.map (NamedDecl.get_id %> mkVar) hyps in Refine.refine ~unsafe:true { run = begin fun sigma -> Evarutil.new_evar_instance nctx sigma nconcl ~principal:true ~store instance @@ -435,11 +412,14 @@ let id_of_name_with_default id = function let default_id_of_sort s = if Sorts.is_small s then default_small_ident else default_type_ident +let id_of_name_using_hdchar env c name = + id_of_name_using_hdchar env (EConstr.Unsafe.to_constr c) name + let default_id env sigma decl = let open Context.Rel.Declaration in match decl with | LocalAssum (name,t) -> - let dft = default_id_of_sort (Retyping.get_sort_of env sigma (EConstr.of_constr t)) in + let dft = default_id_of_sort (Retyping.get_sort_of env sigma t) in id_of_name_with_default dft name | LocalDef (name,b,_) -> id_of_name_using_hdchar env b name @@ -478,7 +458,7 @@ let find_name mayrepl decl naming gl = match naming with let assert_before_then_gen b naming t tac = let open Context.Rel.Declaration in Proofview.Goal.enter { enter = begin fun gl -> - let id = find_name b (local_assum (Anonymous,t)) naming gl in + let id = find_name b (LocalAssum (Anonymous,t)) naming gl in Tacticals.New.tclTHENLAST (Proofview.V82.tactic (fun gl -> @@ -497,7 +477,7 @@ let assert_before_replacing id = assert_before_gen true (NamingMustBe (dloc,id)) let assert_after_then_gen b naming t tac = let open Context.Rel.Declaration in Proofview.Goal.enter { enter = begin fun gl -> - let id = find_name b (local_assum (Anonymous,t)) naming gl in + let id = find_name b (LocalAssum (Anonymous,t)) naming gl in Tacticals.New.tclTHENFIRST (Proofview.V82.tactic (fun gl -> @@ -534,7 +514,7 @@ let rec check_mutind env sigma k cl = match EConstr.kind sigma (strip_outer_cast with Not_found -> error "Cannot do a fixpoint on a non inductive type." else let open Context.Rel.Declaration in - check_mutind (push_rel (local_assum (na, c1)) env) sigma (pred k) b + check_mutind (push_rel (LocalAssum (na, c1)) env) sigma (pred k) b | _ -> error "Not enough products." (* Refine as a fixpoint *) @@ -548,13 +528,14 @@ let mutual_fix f n rest j = Proofview.Goal.nf_enter { enter = begin fun gl -> let rec mk_sign sign = function | [] -> sign | (f, n, ar) :: oth -> + let open Context.Named.Declaration in let (sp', u') = check_mutind env sigma n ar in if not (eq_mind sp sp') then error "Fixpoints should be on the same mutual inductive declaration."; if mem_named_context_val f sign then user_err ~hdr:"Logic.prim_refiner" (str "Name " ++ pr_id f ++ str " already used in the environment"); - mk_sign (push_named_context_val (nlocal_assum (f, ar)) sign) oth + mk_sign (push_named_context_val (LocalAssum (f, ar)) sign) oth in let nenv = reset_with_named_context (mk_sign (named_context_val env) all) env in Refine.refine { run = begin fun sigma -> @@ -584,7 +565,8 @@ let rec check_is_mutcoind env sigma cl = let b = whd_all env sigma cl in match EConstr.kind sigma b with | Prod (na, c1, b) -> - check_is_mutcoind (push_rel (local_assum (na,c1)) env) sigma b + let open Context.Rel.Declaration in + check_is_mutcoind (push_rel (LocalAssum (na,c1)) env) sigma b | _ -> try let _ = find_coinductive env sigma b in () @@ -602,9 +584,10 @@ let mutual_cofix f others j = Proofview.Goal.nf_enter { enter = begin fun gl -> let rec mk_sign sign = function | [] -> sign | (f, ar) :: oth -> + let open Context.Named.Declaration in if mem_named_context_val f sign then error "Name already used in the environment."; - mk_sign (push_named_context_val (nlocal_assum (f, ar)) sign) oth + mk_sign (push_named_context_val (LocalAssum (f, ar)) sign) oth in let nenv = reset_with_named_context (mk_sign (named_context_val env) all) env in Refine.refine { run = begin fun sigma -> @@ -640,16 +623,13 @@ let pf_reduce_decl redfun where decl gl = let redfun' c = Tacmach.New.pf_apply redfun gl c in match decl with | LocalAssum (id,ty) -> - let ty = EConstr.of_constr ty in if where == InHypValueOnly then user_err (pr_id id ++ str " has no value."); - nlocal_assum (id,redfun' ty) + LocalAssum (id,redfun' ty) | LocalDef (id,b,ty) -> - let b = EConstr.of_constr b in - let ty = EConstr.of_constr ty in let b' = if where != InHypTypeOnly then redfun' b else b in let ty' = if where != InHypValueOnly then redfun' ty else ty in - nlocal_def (id,b',ty') + LocalDef (id,b',ty') (* Possibly equip a reduction with the occurrences mentioned in an occurrence clause *) @@ -744,17 +724,14 @@ let pf_e_reduce_decl redfun where decl gl = let redfun sigma c = redfun.e_redfun (Tacmach.New.pf_env gl) sigma c in match decl with | LocalAssum (id,ty) -> - let ty = EConstr.of_constr ty in if where == InHypValueOnly then user_err (pr_id id ++ str " has no value."); let Sigma (ty', sigma, p) = redfun sigma ty in - Sigma (nlocal_assum (id, ty'), sigma, p) + Sigma (LocalAssum (id, ty'), sigma, p) | LocalDef (id,b,ty) -> - let b = EConstr.of_constr b in - let ty = EConstr.of_constr ty in let Sigma (b', sigma, p) = if where != InHypTypeOnly then redfun sigma b else Sigma.here b sigma in let Sigma (ty', sigma, q) = if where != InHypValueOnly then redfun sigma ty else Sigma.here ty sigma in - Sigma (nlocal_def (id, b', ty'), sigma, p +> q) + Sigma (LocalDef (id, b', ty'), sigma, p +> q) let e_reduct_in_concl ~check (redfun, sty) = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> @@ -787,21 +764,18 @@ let e_pf_change_decl (redfun : bool -> e_reduction_function) where decl env sigm let open Context.Named.Declaration in match decl with | LocalAssum (id,ty) -> - let ty = EConstr.of_constr ty in if where == InHypValueOnly then user_err (pr_id id ++ str " has no value."); let Sigma (ty', sigma, p) = (redfun false).e_redfun env sigma ty in - Sigma (nlocal_assum (id, ty'), sigma, p) + Sigma (LocalAssum (id, ty'), sigma, p) | LocalDef (id,b,ty) -> - let b = EConstr.of_constr b in - let ty = EConstr.of_constr ty in let Sigma (b', sigma, p) = if where != InHypTypeOnly then (redfun true).e_redfun env sigma b else Sigma.here b sigma in let Sigma (ty', sigma, q) = if where != InHypValueOnly then (redfun false).e_redfun env sigma ty else Sigma.here ty sigma in - Sigma (nlocal_def (id,b',ty'), sigma, p +> q) + Sigma (LocalDef (id,b',ty'), sigma, p +> q) let e_change_in_hyp redfun (id,where) = Proofview.Goal.s_enter { s_enter = begin fun gl -> @@ -974,10 +948,10 @@ let rec intro_then_gen name_flag move_flag force_flag dep_flag tac = let concl = Proofview.Goal.concl (Proofview.Goal.assume gl) in match EConstr.kind sigma concl with | Prod (name,t,u) when not dep_flag || not (noccurn sigma 1 u) -> - let name = find_name false (local_assum (name,t)) name_flag gl in + let name = find_name false (LocalAssum (name,t)) name_flag gl in build_intro_tac name move_flag tac | LetIn (name,b,t,u) when not dep_flag || not (noccurn sigma 1 u) -> - let name = find_name false (local_def (name,b,t)) name_flag gl in + let name = find_name false (LocalDef (name,b,t)) name_flag gl in build_intro_tac name move_flag tac | _ -> begin if not force_flag then Proofview.tclZERO (RefinerError IntroNeedsProduct) @@ -1382,11 +1356,11 @@ let enforce_prop_bound_names rename tac = Name (add_suffix Namegen.default_prop_ident s) else na in - mkProd (na,t,aux (push_rel (local_assum (na,t)) env) sigma (i-1) t') + mkProd (na,t,aux (push_rel (LocalAssum (na,t)) env) sigma (i-1) t') | Prod (Anonymous,t,t') -> - mkProd (Anonymous,t,aux (push_rel (local_assum (Anonymous,t)) env) sigma (i-1) t') + mkProd (Anonymous,t,aux (push_rel (LocalAssum (Anonymous,t)) env) sigma (i-1) t') | LetIn (na,c,t,t') -> - mkLetIn (na,c,t,aux (push_rel (local_def (na,c,t)) env) sigma (i-1) t') + mkLetIn (na,c,t,aux (push_rel (LocalDef (na,c,t)) env) sigma (i-1) t') | _ -> assert false in let rename_branch i = Proofview.Goal.nf_enter { enter = begin fun gl -> @@ -1619,11 +1593,11 @@ let make_projection env sigma params cstr sign elim i n c u = let elim = match elim with | NotADefinedRecordUseScheme elim -> (* bugs: goes from right to left when i increases! *) - let decl = List.nth cstr.cs_args i in + let cs_args = List.map (fun d -> map_rel_decl EConstr.of_constr d) cstr.cs_args in + let decl = List.nth cs_args i in let t = RelDecl.get_type decl in - let t = EConstr.of_constr t in - let b = match decl with LocalAssum _ -> mkRel (i+1) | LocalDef (_,b,_) -> EConstr.of_constr b in - let branch = it_mkLambda_or_LetIn b cstr.cs_args in + let b = match decl with LocalAssum _ -> mkRel (i+1) | LocalDef (_,b,_) -> b in + let branch = it_mkLambda_or_LetIn b cs_args in if (* excludes dependent projection types *) noccur_between sigma 1 (n-i-1) t @@ -1890,7 +1864,7 @@ let apply_in_once sidecond_first with_delta with_destruct with_evars naming 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 (local_assum (Anonymous,t')) naming gl in + let targetid = find_name true (LocalAssum (Anonymous,t')) naming gl in let rec aux idstoclear with_destruct c = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in @@ -2017,7 +1991,6 @@ let assumption = else Tacticals.New.tclZEROMSG (str "No such assumption.") | decl::rest -> let t = NamedDecl.get_type decl in - let t = EConstr.of_constr t in let concl = Proofview.Goal.concl gl in let sigma = Tacmach.New.project gl in let (sigma, is_same_type) = @@ -2058,13 +2031,13 @@ let check_is_type env sigma ty = let check_decl env sigma decl = let open Context.Named.Declaration in - let ty = EConstr.of_constr (NamedDecl.get_type decl) in + let ty = NamedDecl.get_type decl in let evdref = ref sigma in try let _ = Typing.e_sort_of env evdref ty in let _ = match decl with | LocalAssum _ -> () - | LocalDef (_,c,_) -> Typing.e_check env evdref (EConstr.of_constr c) ty + | LocalDef (_,c,_) -> Typing.e_check env evdref c ty in !evdref with e when CErrors.noncritical e -> @@ -2146,6 +2119,7 @@ let keep hyps = let sigma = Tacmach.New.project gl in let cl,_ = fold_named_context_reverse (fun (clear,keep) decl -> + let decl = map_named_decl EConstr.of_constr decl in let hyp = NamedDecl.get_id decl in if Id.List.mem hyp hyps || List.exists (occur_var_in_decl env sigma hyp) keep @@ -2692,6 +2666,7 @@ let insert_before decls lasthyp env = | Some id -> Environ.fold_named_context (fun _ d env -> + let d = map_named_decl EConstr.of_constr d in let env = if Id.equal id (NamedDecl.get_id d) then push_named_context decls env else env in push_named d env) ~init:(reset_context env) env @@ -2701,8 +2676,8 @@ let insert_before decls lasthyp env = let mkletin_goal env sigma store with_eq dep (id,lastlhyp,ccl,c) ty = let open Context.Named.Declaration in let t = match ty with Some t -> t | _ -> typ_of env sigma c in - let decl = if dep then nlocal_def (id,c,t) - else nlocal_assum (id,t) + let decl = if dep then LocalDef (id,c,t) + else LocalAssum (id,t) in match with_eq with | Some (lr,(loc,ido)) -> @@ -2721,7 +2696,7 @@ let mkletin_goal env sigma store with_eq dep (id,lastlhyp,ccl,c) ty = let refl = EConstr.of_constr refl in let eq = applist (eq,args) in let refl = applist (refl, [t;mkVar id]) in - let newenv = insert_before [nlocal_assum (heq,eq); decl] lastlhyp env in + let newenv = insert_before [LocalAssum (heq,eq); decl] lastlhyp env in let Sigma (x, sigma, r) = new_evar newenv sigma ~principal:true ~store ccl in Sigma (mkNamedLetIn id c t (mkNamedLetIn heq refl eq x), sigma, p +> q +> r) | None -> @@ -2822,8 +2797,8 @@ let generalize_goal_gen env sigma ids i ((occs,c,b),na) t cl = let cl',sigma' = subst_closed_term_occ env sigma (AtOccs occs) c (it_mkProd_or_LetIn cl newdecls) in let na = generalized_name sigma c t ids cl' na in let decl = match b with - | None -> local_assum (na,t) - | Some b -> local_def (na,b,t) + | None -> LocalAssum (na,t) + | Some b -> LocalDef (na,b,t) in mkProd_or_LetIn decl cl', sigma' @@ -2838,7 +2813,7 @@ let old_generalize_dep ?(with_let=false) c gl = let sign = pf_hyps gl in let sigma = project gl in let init_ids = ids_of_named_context (Global.named_context()) in - let seek (d:Context.Named.Declaration.t) (toquant:Context.Named.t) = + let seek (d:named_declaration) (toquant:named_context) = if List.exists (fun d' -> occur_var_in_decl env sigma (NamedDecl.get_id d') d) toquant || dependent_in_decl sigma c d then d::toquant @@ -2862,7 +2837,6 @@ let old_generalize_dep ?(with_let=false) c gl = | _ -> None else None in - let body = Option.map EConstr.of_constr body in let cl'',evd = generalize_goal gl 0 ((AllOccurrences,c,body),Anonymous) (cl',project gl) in (** Check that the generalization is indeed well-typed *) @@ -3256,7 +3230,7 @@ let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = | Var id -> id | _ -> let type_of = Tacmach.New.pf_unsafe_type_of gl in - id_of_name_using_hdchar (Global.env()) (EConstr.Unsafe.to_constr (type_of c)) Anonymous in + id_of_name_using_hdchar (Global.env()) (type_of c) Anonymous in let x = fresh_id_in_env avoid id env in Tacticals.New.tclTHEN (letin_tac None (Name x) c None allHypsAndConcl) @@ -3342,6 +3316,7 @@ let cook_sign hyp0_opt inhyps indvars env sigma = let before = ref true in let maindep = ref false in let seek_deps env decl rhyp = + let decl = map_named_decl EConstr.of_constr decl in let hyp = NamedDecl.get_id decl in if (match hyp0_opt with Some hyp0 -> Id.equal hyp hyp0 | _ -> false) then begin @@ -3434,15 +3409,15 @@ type elim_scheme = { elimc: constr with_bindings option; elimt: types; indref: global_reference option; - params: Context.Rel.t; (* (prm1,tprm1);(prm2,tprm2)...(prmp,tprmp) *) + params: rel_context; (* (prm1,tprm1);(prm2,tprm2)...(prmp,tprmp) *) nparams: int; (* number of parameters *) - predicates: Context.Rel.t; (* (Qq, (Tq_1 -> Tq_2 ->...-> Tq_nq)), (Q1,...) *) + predicates: rel_context; (* (Qq, (Tq_1 -> Tq_2 ->...-> Tq_nq)), (Q1,...) *) npredicates: int; (* Number of predicates *) - branches: Context.Rel.t; (* branchr,...,branch1 *) + branches: rel_context; (* branchr,...,branch1 *) nbranches: int; (* Number of branches *) - args: Context.Rel.t; (* (xni, Ti_ni) ... (x1, Ti_1) *) + args: rel_context; (* (xni, Ti_ni) ... (x1, Ti_1) *) nargs: int; (* number of arguments *) - indarg: Context.Rel.Declaration.t option; (* Some (H,I prm1..prmp x1...xni) + indarg: rel_declaration option; (* Some (H,I prm1..prmp x1...xni) if HI is in premisses, None otherwise *) concl: types; (* Qi x1...xni HI (f...), HI and (f...) are optional and mutually exclusive *) @@ -3586,10 +3561,10 @@ let make_abstract_generalize env id typ concl dep ctx body c eqs args refls = in (* Abstract by equalities *) let eqs = lift_togethern 1 eqs in (* lift together and past genarg *) - let abseqs = it_mkProd_or_LetIn (lift eqslen abshypeq) (List.map (fun x -> local_assum (Anonymous, x)) eqs) in + let abseqs = it_mkProd_or_LetIn (lift eqslen abshypeq) (List.map (fun x -> LocalAssum (Anonymous, x)) eqs) in let decl = match body with - | None -> local_assum (Name id, c) - | Some body -> local_def (Name id, body, c) + | None -> LocalAssum (Name id, c) + | Some body -> LocalDef (Name id, body, c) in (* Abstract by the "generalized" hypothesis. *) let genarg = mkProd_or_LetIn decl abseqs in @@ -3668,7 +3643,6 @@ let abstract_args gl generalize_vars dep id defined f args = let decl = List.hd rel in RelDecl.get_name decl, RelDecl.get_type decl, c in - let ty = EConstr.of_constr ty in let argty = Tacmach.pf_unsafe_type_of gl arg in let sigma', ty = Evarsolve.refresh_universes (Some true) env !sigma ty in let () = sigma := sigma' in @@ -3681,7 +3655,7 @@ let abstract_args gl generalize_vars dep id defined f args = Id.Set.add id nongenvars, Id.Set.remove id vars, env) | _ -> let name = get_id name in - let decl = local_assum (Name name, ty) in + let decl = LocalAssum (Name name, ty) in let ctx = decl :: ctx in let c' = mkApp (lift 1 c, [|mkRel 1|]) in let args = arg :: args in @@ -3739,10 +3713,9 @@ let abstract_generalize ?(generalize_vars=true) ?(force_dep=false) id = let (f, args, def, id, oldid) = let oldid = Tacmach.New.pf_get_new_id id gl in match Tacmach.New.pf_get_hyp id gl with - | LocalAssum (_,t) -> let f, args = decompose_app sigma (EConstr.of_constr t) in + | LocalAssum (_,t) -> let f, args = decompose_app sigma t in (f, args, false, id, oldid) | LocalDef (_,t,_) -> - let t = EConstr.of_constr t in let f, args = decompose_app sigma t in (f, args, true, id, oldid) in @@ -3809,13 +3782,13 @@ let specialize_eqs id gl = if in_eqs then acc, in_eqs, ctx, ty else let e = e_new_evar (push_rel_context ctx env) evars t in - aux false (local_def (na,e,t) :: ctx) (mkApp (lift 1 acc, [| mkRel 1 |])) b) + aux false (LocalDef (na,e,t) :: ctx) (mkApp (lift 1 acc, [| mkRel 1 |])) b) | t -> acc, in_eqs, ctx, ty in let acc, worked, ctx, ty = aux false [] (mkVar id) ty in let ctx' = nf_rel_context_evar !evars ctx in let ctx'' = List.map (function - | LocalDef (n,k,t) when isEvar !evars (EConstr.of_constr k) -> LocalAssum (n,t) + | LocalDef (n,k,t) when isEvar !evars k -> LocalAssum (n,t) | decl -> decl) ctx' in let ty' = it_mkProd_or_LetIn ty ctx'' in @@ -3855,13 +3828,13 @@ let decompose_paramspred_branch_args sigma elimt = | Prod(nme,tpe,elimt') -> let hd_tpe,_ = decompose_app sigma (snd (decompose_prod_assum sigma tpe)) in if not (occur_rel sigma 1 elimt') && isRel sigma hd_tpe - then cut_noccur elimt' (local_assum (nme,tpe)::acc2) + then cut_noccur elimt' (LocalAssum (nme,tpe)::acc2) else let acc3,ccl = decompose_prod_assum sigma elimt in acc2 , acc3 , ccl | App(_, _) | Rel _ -> acc2 , [] , elimt | _ -> error_ind_scheme "" in let rec cut_occur elimt acc1 = match EConstr.kind sigma elimt with - | Prod(nme,tpe,c) when occur_rel sigma 1 c -> cut_occur c (local_assum (nme,tpe)::acc1) + | Prod(nme,tpe,c) when occur_rel sigma 1 c -> cut_occur c (LocalAssum (nme,tpe)::acc1) | Prod(nme,tpe,c) -> let acc2,acc3,ccl = cut_noccur elimt [] in acc1,acc2,acc3,ccl | App(_, _) | Rel _ -> acc1,[],[],elimt | _ -> error_ind_scheme "" in @@ -3939,7 +3912,6 @@ let compute_elim_sig sigma ?elimc elimt = match List.hd args_indargs with | LocalDef (hiname,_,hi) -> error_ind_scheme "" | LocalAssum (hiname,hi) -> - let hi = EConstr.of_constr hi in let hi_ind, hi_args = decompose_app sigma hi in let hi_is_ind = (* hi est d'un type globalisable *) match EConstr.kind sigma hi_ind with @@ -3965,7 +3937,6 @@ let compute_elim_sig sigma ?elimc elimt = | None -> !res (* No indref *) | Some (LocalDef _) -> error_ind_scheme "" | Some (LocalAssum (_,ind)) -> - let ind = EConstr.of_constr ind in let indhd,indargs = decompose_app sigma ind in try {!res with indref = Some (fst (Termops.global_of_constr sigma indhd)) } with e when CErrors.noncritical e -> @@ -3983,7 +3954,6 @@ let compute_scheme_signature evd scheme names_info ind_type_guess = let cond hd = EConstr.eq_constr evd hd ind_type_guess && not scheme.farg_in_concl in (cond, fun _ _ -> ()) | Some (LocalAssum (_,ind)) -> (* Standard scheme from an inductive type *) - let ind = EConstr.of_constr ind in let indhd,indargs = decompose_app evd ind in let cond hd = EConstr.eq_constr evd hd indhd in let check_concl is_pred p = @@ -4016,7 +3986,6 @@ let compute_scheme_signature evd scheme names_info ind_type_guess = let rec find_branches p lbrch = match lbrch with | LocalAssum (_,t) :: brs -> - let t = EConstr.of_constr t in (try let lchck_brch = check_branch p t in let n = List.fold_left @@ -4123,7 +4092,7 @@ let get_eliminator elim dep s gl = | ElimOver (isrec,id) -> let evd, (elimc,elimt),_ as elims = guess_elim isrec dep s id gl in let _, (l, s) = compute_elim_signature elims id in - let branchlengthes = List.map (fun d -> assert (RelDecl.is_local_assum d); pi1 (decompose_prod_letin (Tacmach.New.project gl) (EConstr.of_constr (RelDecl.get_type d)))) + let branchlengthes = List.map (fun d -> assert (RelDecl.is_local_assum d); pi1 (decompose_prod_letin (Tacmach.New.project gl) (RelDecl.get_type d))) (List.rev s.branches) in evd, isrec, ({elimindex = None; elimbody = elimc; elimrename = Some (isrec,Array.of_list branchlengthes)}, elimt), l @@ -4465,7 +4434,6 @@ let induction_gen clear_flag isrec with_evars elim declaring the induction argument as a new local variable *) let id = (* Type not the right one if partially applied but anyway for internal use*) - let t = EConstr.Unsafe.to_constr t in let x = id_of_name_using_hdchar (Global.env()) t Anonymous in new_fresh_id [] x gl in let info_arg = (is_arg_pure_hyp, not enough_applied) in @@ -4503,7 +4471,7 @@ let induction_gen_l isrec with_evars elim names lc = let type_of = Tacmach.New.pf_unsafe_type_of gl in let sigma = Tacmach.New.project gl in let x = - id_of_name_using_hdchar (Global.env()) (EConstr.Unsafe.to_constr (type_of c)) Anonymous in + id_of_name_using_hdchar (Global.env()) (type_of c) Anonymous in let id = new_fresh_id [] x gl in let newl' = List.map (fun r -> replace_term sigma c (mkVar id) r) l' in @@ -4863,6 +4831,9 @@ let intros_transitivity n = Tacticals.New.tclTHEN intros (transitivity_gen n) (** d1 is the section variable in the global context, d2 in the goal context *) let interpretable_as_section_decl evd d1 d2 = let open Context.Named.Declaration in + let e_eq_constr_univs sigma c1 c2 = + e_eq_constr_univs sigma (EConstr.Unsafe.to_constr c1) (EConstr.Unsafe.to_constr c2) + in match d2, d1 with | LocalDef _, LocalAssum _ -> false | LocalDef (_,b1,t1), LocalDef (_,b2,t2) -> diff --git a/tactics/tactics.mli b/tactics/tactics.mli index b0d9dcb1ce..0087d607db 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -35,9 +35,9 @@ val is_quantified_hypothesis : Id.t -> ([`NF],'b) Proofview.Goal.t -> bool val introduction : ?check:bool -> Id.t -> unit Proofview.tactic val convert_concl : ?check:bool -> types -> cast_kind -> unit Proofview.tactic -val convert_hyp : ?check:bool -> Context.Named.Declaration.t -> unit Proofview.tactic +val convert_hyp : ?check:bool -> named_declaration -> unit Proofview.tactic val convert_concl_no_check : types -> cast_kind -> unit Proofview.tactic -val convert_hyp_no_check : Context.Named.Declaration.t -> unit Proofview.tactic +val convert_hyp_no_check : named_declaration -> unit Proofview.tactic val mutual_fix : Id.t -> int -> (Id.t * int * constr) list -> int -> unit Proofview.tactic val fix : Id.t option -> int -> unit Proofview.tactic @@ -51,7 +51,7 @@ val convert_leq : constr -> constr -> unit Proofview.tactic val fresh_id_in_env : Id.t list -> Id.t -> env -> Id.t val fresh_id : Id.t list -> Id.t -> goal sigma -> Id.t -val find_intro_names : Context.Rel.t -> goal sigma -> Id.t list +val find_intro_names : rel_context -> goal sigma -> Id.t list val intro : unit Proofview.tactic val introf : unit Proofview.tactic @@ -185,7 +185,7 @@ val revert : Id.t list -> unit Proofview.tactic (** {6 Resolution tactics. } *) val apply_type : constr -> constr list -> unit Proofview.tactic -val bring_hyps : Context.Named.t -> unit Proofview.tactic +val bring_hyps : named_context -> unit Proofview.tactic val apply : constr -> unit Proofview.tactic val eapply : constr -> unit Proofview.tactic @@ -244,15 +244,15 @@ type elim_scheme = { elimc: constr with_bindings option; elimt: types; indref: global_reference option; - params: Context.Rel.t; (** (prm1,tprm1);(prm2,tprm2)...(prmp,tprmp) *) + params: rel_context; (** (prm1,tprm1);(prm2,tprm2)...(prmp,tprmp) *) nparams: int; (** number of parameters *) - predicates: Context.Rel.t; (** (Qq, (Tq_1 -> Tq_2 ->...-> Tq_nq)), (Q1,...) *) + predicates: rel_context; (** (Qq, (Tq_1 -> Tq_2 ->...-> Tq_nq)), (Q1,...) *) npredicates: int; (** Number of predicates *) - branches: Context.Rel.t; (** branchr,...,branch1 *) + branches: rel_context; (** branchr,...,branch1 *) nbranches: int; (** Number of branches *) - args: Context.Rel.t; (** (xni, Ti_ni) ... (x1, Ti_1) *) + args: rel_context; (** (xni, Ti_ni) ... (x1, Ti_1) *) nargs: int; (** number of arguments *) - indarg: Context.Rel.Declaration.t option; (** Some (H,I prm1..prmp x1...xni) + indarg: rel_declaration option; (** Some (H,I prm1..prmp x1...xni) if HI is in premisses, None otherwise *) concl: types; (** Qi x1...xni HI (f...), HI and (f...) are optional and mutually exclusive *) diff --git a/tactics/term_dnet.ml b/tactics/term_dnet.ml index 219abb7fdd..2c863c42a6 100644 --- a/tactics/term_dnet.ml +++ b/tactics/term_dnet.ml @@ -344,7 +344,7 @@ struct ) (pr_dconstr pr_term_pattern) p*) let search_pat cpat dpat dn = - let whole_c = cpat in + let whole_c = EConstr.of_constr cpat in (* if we are at the root, add an empty context *) let dpat = under_prod (empty_ctx dpat) in TDnet.Idset.fold @@ -352,9 +352,8 @@ struct let c_id = Opt.reduce (Ident.constr_of id) in let c_id = EConstr.of_constr c_id in let (ctx,wc) = - try Termops.align_prod_letin Evd.empty (EConstr.of_constr whole_c) c_id (** FIXME *) + try Termops.align_prod_letin Evd.empty whole_c c_id (** FIXME *) with Invalid_argument _ -> [],c_id in - let wc = EConstr.Unsafe.to_constr wc in let wc,whole_c = if Opt.direction then whole_c,wc else wc,whole_c in try let _ = Termops.filtering Evd.empty ctx Reduction.CUMUL wc whole_c in -- cgit v1.2.3 From d549d9d3d169fbfc5f555e3e4f22f46301161d53 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 29 Nov 2016 16:30:00 +0100 Subject: Do not ask for a normalized goal to get hypotheses and conclusions. This is now useless as this returns evar-constrs, so that all functions acting on them should be insensitive to evar-normalization. --- tactics/hipattern.mli | 6 +++--- tactics/tacticals.mli | 2 +- tactics/tactics.ml | 12 ++++++------ 3 files changed, 10 insertions(+), 10 deletions(-) (limited to 'tactics') diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli index 65ba0aad04..c46817f505 100644 --- a/tactics/hipattern.mli +++ b/tactics/hipattern.mli @@ -121,11 +121,11 @@ val match_with_equation: (** Match terms [eq A t u], [identity A t u] or [JMeq A t A u] Returns associated lemmas and [A,t,u] or fails PatternMatchingFailure *) -val find_eq_data_decompose : ([ `NF ], 'r) Proofview.Goal.t -> constr -> +val find_eq_data_decompose : ('a, 'r) Proofview.Goal.t -> constr -> coq_eq_data * Univ.universe_instance * (types * constr * constr) (** Idem but fails with an error message instead of PatternMatchingFailure *) -val find_this_eq_data_decompose : ([ `NF ], 'r) Proofview.Goal.t -> constr -> +val find_this_eq_data_decompose : ('a, 'r) Proofview.Goal.t -> constr -> coq_eq_data * Univ.universe_instance * (types * constr * constr) (** A variant that returns more informative structure on the equality found *) @@ -146,7 +146,7 @@ val is_matching_sigma : evar_map -> constr -> bool val match_eqdec : evar_map -> constr -> bool * constr * constr * constr * constr (** Match an equality up to conversion; returns [(eq,t1,t2)] in normal form *) -val dest_nf_eq : ([ `NF ], 'r) Proofview.Goal.t -> constr -> (constr * constr * constr) +val dest_nf_eq : ('a, 'r) Proofview.Goal.t -> constr -> (constr * constr * constr) (** Match a negation *) val is_matching_not : evar_map -> constr -> bool diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index e9f6231002..4bb745875b 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -229,7 +229,7 @@ module New : sig val tclTIMEOUT : int -> unit tactic -> unit tactic val tclTIME : string option -> 'a tactic -> 'a tactic - val nLastDecls : ([ `NF ], 'r) Proofview.Goal.t -> int -> named_context + val nLastDecls : ('a, 'r) Proofview.Goal.t -> int -> named_context val ifOnHyp : (identifier * types -> bool) -> (identifier -> unit Proofview.tactic) -> (identifier -> unit Proofview.tactic) -> diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 4bf848a9c3..de35721555 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -208,7 +208,7 @@ let convert_concl ?(check=true) ty k = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let store = Proofview.Goal.extra gl in - let conclty = Proofview.Goal.raw_concl gl in + let conclty = Proofview.Goal.concl gl in Refine.refine ~unsafe:true { run = begin fun sigma -> let Sigma ((), sigma, p) = if check then begin @@ -228,7 +228,7 @@ let convert_hyp ?(check=true) d = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in - let ty = Proofview.Goal.raw_concl gl in + let ty = Proofview.Goal.concl gl in let store = Proofview.Goal.extra gl in let sign = convert_hyp check (named_context_val env) sigma d in let env = reset_with_named_context sign env in @@ -328,7 +328,7 @@ let move_hyp id dest = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in - let ty = Proofview.Goal.raw_concl gl in + let ty = Proofview.Goal.concl gl in let store = Proofview.Goal.extra gl in let sign = named_context_val env in let sign' = move_hyp_in_named_context sigma id dest sign in @@ -756,7 +756,7 @@ let e_reduct_option ?(check=false) redfun = function let e_change_in_concl (redfun,sty) = Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in - let Sigma (c, sigma, p) = redfun.e_redfun (Proofview.Goal.env gl) sigma (Proofview.Goal.raw_concl gl) in + let Sigma (c, sigma, p) = redfun.e_redfun (Proofview.Goal.env gl) sigma (Proofview.Goal.concl gl) in Sigma (convert_concl_no_check c sty, sigma, p) end } @@ -4340,7 +4340,7 @@ let pose_induction_arg_then isrec with_evars (is_arg_pure_hyp,from_prefix) elim Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in - let ccl = Proofview.Goal.raw_concl gl in + let ccl = Proofview.Goal.concl gl in let store = Proofview.Goal.extra gl in let check = check_enough_applied env sigma elim in let Sigma (c, sigma', p) = use_bindings env sigma elim false (c0,lbind) t0 in @@ -4409,7 +4409,7 @@ let induction_gen clear_flag isrec with_evars elim let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let evd = Sigma.to_evar_map sigma in - let ccl = Proofview.Goal.raw_concl gl in + let ccl = Proofview.Goal.concl gl in let cls = Option.default allHypsAndConcl cls in let t = typ_of env sigma c in let is_arg_pure_hyp = -- cgit v1.2.3 From 390fd4ac0a969103caeb5db3e5138e26f9a533de Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 29 Nov 2016 17:49:11 +0100 Subject: Chasing a few unsafe constr coercions. --- tactics/btermdn.ml | 33 +++++++++++++++++---------------- tactics/btermdn.mli | 2 +- tactics/equality.ml | 13 ------------- tactics/hints.ml | 20 +++++++++++++++----- tactics/tactics.ml | 7 +++++-- 5 files changed, 38 insertions(+), 37 deletions(-) (limited to 'tactics') diff --git a/tactics/btermdn.ml b/tactics/btermdn.ml index 491bc8b4ab..b4a235ba8c 100644 --- a/tactics/btermdn.ml +++ b/tactics/btermdn.ml @@ -8,6 +8,7 @@ open Util open Term +open EConstr open Names open Pattern open Globnames @@ -38,18 +39,18 @@ let decomp_pat = in decrec [] -let decomp = - let rec decrec acc c = match kind_of_term c with +let decomp sigma t = + let rec decrec acc c = match EConstr.kind sigma c with | App (f,l) -> decrec (Array.fold_right (fun a l -> a::l) l acc) f | Proj (p, c) -> (mkConst (Projection.constant p), c :: acc) | Cast (c1,_,_) -> decrec acc c1 | _ -> (c,acc) in - decrec [] + decrec [] t -let constr_val_discr t = - let c, l = decomp t in - match kind_of_term c with +let constr_val_discr sigma t = + let c, l = decomp sigma t in + match EConstr.kind sigma c with | Ind (ind_sp,u) -> Label(GRLabel (IndRef ind_sp),l) | Construct (cstr_sp,u) -> Label(GRLabel (ConstructRef cstr_sp),l) | Var id -> Label(GRLabel (VarRef id),l) @@ -66,9 +67,9 @@ let constr_pat_discr t = | PRef ((VarRef v) as ref), args -> Some(GRLabel ref,args) | _ -> None -let constr_val_discr_st (idpred,cpred) t = - let c, l = decomp t in - match kind_of_term c with +let constr_val_discr_st sigma (idpred,cpred) t = + let c, l = decomp sigma t in + match EConstr.kind sigma c with | Const (c,u) -> if Cpred.mem c cpred then Everything else Label(GRLabel (ConstRef c),l) | Ind (ind_sp,u) -> Label(GRLabel (IndRef ind_sp),l) | Construct (cstr_sp,u) -> Label(GRLabel (ConstructRef cstr_sp),l) @@ -105,11 +106,11 @@ let bounded_constr_pat_discr_st st (t,depth) = | None -> None | Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l) -let bounded_constr_val_discr_st st (t,depth) = +let bounded_constr_val_discr_st sigma st (t,depth) = if Int.equal depth 0 then Nothing else - match constr_val_discr_st st t with + match constr_val_discr_st sigma st t with | Label (c,l) -> Label(c,List.map (fun c -> (c,depth-1)) l) | Nothing -> Nothing | Everything -> Everything @@ -122,11 +123,11 @@ let bounded_constr_pat_discr (t,depth) = | None -> None | Some (c,l) -> Some(c,List.map (fun c -> (c,depth-1)) l) -let bounded_constr_val_discr (t,depth) = +let bounded_constr_val_discr sigma (t,depth) = if Int.equal depth 0 then Nothing else - match constr_val_discr t with + match constr_val_discr sigma t with | Label (c,l) -> Label(c,List.map (fun c -> (c,depth-1)) l) | Nothing -> Nothing | Everything -> Everything @@ -162,13 +163,13 @@ struct (fun dn (c,v) -> Dn.rmv dn (bounded_constr_pat_discr_st st) ((c,!dnet_depth),v)) - let lookup = function + let lookup sigma = function | None -> (fun dn t -> - Dn.lookup dn bounded_constr_val_discr (t,!dnet_depth)) + Dn.lookup dn (bounded_constr_val_discr sigma) (t,!dnet_depth)) | Some st -> (fun dn t -> - Dn.lookup dn (bounded_constr_val_discr_st st) (t,!dnet_depth)) + Dn.lookup dn (bounded_constr_val_discr_st sigma st) (t,!dnet_depth)) let app f dn = Dn.app f dn diff --git a/tactics/btermdn.mli b/tactics/btermdn.mli index 8ca5549b88..2a5e7c3458 100644 --- a/tactics/btermdn.mli +++ b/tactics/btermdn.mli @@ -33,7 +33,7 @@ sig val add : transparent_state option -> t -> (constr_pattern * Z.t) -> t val rmv : transparent_state option -> t -> (constr_pattern * Z.t) -> t - val lookup : transparent_state option -> t -> constr -> Z.t list + val lookup : Evd.evar_map -> transparent_state option -> t -> EConstr.constr -> Z.t list val app : (Z.t -> unit) -> t -> unit end diff --git a/tactics/equality.ml b/tactics/equality.ml index 122b64777e..7f7a07b8fe 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -1300,19 +1300,6 @@ let build_injector env sigma dflt c cpath = let sigma, (injcode,resty,_) = build_injrec env sigma dflt c cpath in sigma, (injcode,resty) -(* -let try_delta_expand env sigma t = - let whdt = whd_all env sigma t in - let rec hd_rec c = - match kind_of_term c with - | Construct _ -> whdt - | App (f,_) -> hd_rec f - | Cast (c,_,_) -> hd_rec c - | _ -> t - in - hd_rec whdt -*) - let eq_dec_scheme_kind_name = ref (fun _ -> failwith "eq_dec_scheme undefined") let set_eq_dec_scheme_kind k = eq_dec_scheme_kind_name := (fun _ -> k) diff --git a/tactics/hints.ml b/tactics/hints.ml index ffd19ac6e0..17c81064d7 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -250,9 +250,8 @@ let rebuild_dn st se = in { se with sentry_bnet = dn' } -let lookup_tacs concl st se = - let concl = EConstr.Unsafe.to_constr concl in - let l' = Bounded_net.lookup st se.sentry_bnet concl in +let lookup_tacs sigma concl st se = + let l' = Bounded_net.lookup sigma st se.sentry_bnet concl in let sl' = List.stable_sort pri_order_int l' in List.merge pri_order_int se.sentry_nopat sl' @@ -510,6 +509,17 @@ struct (** Warn about no longer typable hint? *) None + let head_evar sigma c = + let rec hrec c = match EConstr.kind sigma c with + | Evar (evk,_) -> evk + | Case (_,_,c,_) -> hrec c + | App (c,_) -> hrec c + | Cast (c,_,_) -> hrec c + | Proj (p, c) -> hrec c + | _ -> raise Evarutil.NoHeadEvar + in + hrec c + let match_mode sigma m arg = match m with | ModeInput -> not (occur_existential sigma arg) @@ -543,7 +553,7 @@ struct let map_auto sigma ~secvars (k,args) concl db = let se = find k db in let st = if db.use_dn then (Some db.hintdb_state) else None in - let pat = lookup_tacs concl st se in + let pat = lookup_tacs sigma concl st se in merge_entry secvars db [] pat let map_existential sigma ~secvars (k,args) concl db = @@ -557,7 +567,7 @@ struct let se = find k db in if matches_modes sigma args se.sentry_mode then let st = if db.use_dn then Some db.hintdb_state else None in - let pat = lookup_tacs concl st se in + let pat = lookup_tacs sigma concl st se in merge_entry secvars db [] pat else merge_entry secvars db [] [] diff --git a/tactics/tactics.ml b/tactics/tactics.ml index de35721555..a29803251e 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -4831,8 +4831,11 @@ let intros_transitivity n = Tacticals.New.tclTHEN intros (transitivity_gen n) (** d1 is the section variable in the global context, d2 in the goal context *) let interpretable_as_section_decl evd d1 d2 = let open Context.Named.Declaration in - let e_eq_constr_univs sigma c1 c2 = - e_eq_constr_univs sigma (EConstr.Unsafe.to_constr c1) (EConstr.Unsafe.to_constr c2) + let e_eq_constr_univs sigma c1 c2 = match eq_constr_universes !sigma c1 c2 with + | None -> false + | Some cstr -> + try ignore (Evd.add_universe_constraints !sigma cstr); true + with UniversesDiffer -> false in match d2, d1 with | LocalDef _, LocalAssum _ -> false -- cgit v1.2.3 From be51c33a6bf91a00fdd5f3638ddb5b3cc3a2c626 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Wed, 30 Nov 2016 00:41:31 +0100 Subject: Namegen primitives now apply on evar constrs. Incidentally, this fixes a printing bug in output/inference.v where the displayed name of an evar was the wrong one because its type was not evar-expanded enough. --- tactics/class_tactics.ml | 2 +- tactics/eqschemes.ml | 16 +++++++++++++++- tactics/equality.ml | 17 ++++++----------- tactics/inv.ml | 9 ++------- tactics/leminv.ml | 7 +++---- tactics/tactics.ml | 27 ++++++++++++--------------- 6 files changed, 39 insertions(+), 39 deletions(-) (limited to 'tactics') diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 55fda1c7db..669d808140 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -1458,7 +1458,7 @@ let _ = Hook.set Typeclasses.solve_all_instances_hook solve_inst let resolve_one_typeclass env ?(sigma=Evd.empty) gl unique = - let nc, gl, subst, _, _ = Evarutil.push_rel_context_to_named_context env gl in + let nc, gl, subst, _, _ = Evarutil.push_rel_context_to_named_context env sigma gl in let (gl,t,sigma) = Goal.V82.mk_goal sigma nc gl Store.empty in let (ev, _) = destEvar sigma t in diff --git a/tactics/eqschemes.ml b/tactics/eqschemes.ml index 188e215a5d..b08456f2f1 100644 --- a/tactics/eqschemes.ml +++ b/tactics/eqschemes.ml @@ -76,10 +76,24 @@ let build_dependent_inductive ind (mib,mip) = Context.Rel.to_extended_list mkRel mip.mind_nrealdecls mib.mind_params_ctxt @ Context.Rel.to_extended_list mkRel 0 realargs) +let named_hd env t na = named_hd env Evd.empty (EConstr.of_constr t) na +let name_assumption env = function +| LocalAssum (na,t) -> LocalAssum (named_hd env t na, t) +| LocalDef (na,c,t) -> LocalDef (named_hd env c na, c, t) + +let name_context env hyps = + snd + (List.fold_left + (fun (env,hyps) d -> + let d' = name_assumption env d in (push_rel d' env, d' :: hyps)) + (env,[]) (List.rev hyps)) + let my_it_mkLambda_or_LetIn s c = it_mkLambda_or_LetIn c s let my_it_mkProd_or_LetIn s c = Term.it_mkProd_or_LetIn c s let my_it_mkLambda_or_LetIn_name s c = - it_mkLambda_or_LetIn_name (Global.env()) c s + let env = Global.env () in + let mkLambda_or_LetIn_name d b = mkLambda_or_LetIn (name_assumption env d) b in + List.fold_left (fun c d -> mkLambda_or_LetIn_name d c) c s let get_coq_eq ctx = try diff --git a/tactics/equality.ml b/tactics/equality.ml index 7f7a07b8fe..d9b6685179 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -857,14 +857,13 @@ let descend_then env sigma head dirn = (dirn_nlams, dirn_env, (fun dirnval (dfltval,resty) -> - let deparsign = make_arity_signature env true indf in - let deparsign = List.map (fun d -> map_rel_decl EConstr.of_constr d) deparsign in + let deparsign = make_arity_signature env sigma true indf in let p = it_mkLambda_or_LetIn (lift (mip.mind_nrealargs+1) resty) deparsign in let build_branch i = let result = if Int.equal i dirn then dirnval else dfltval in - let args = name_context env cstr.(i-1).cs_args in - let args = List.map (fun d -> map_rel_decl EConstr.of_constr d) args in + let cs_args = List.map (fun d -> map_rel_decl EConstr.of_constr d) cstr.(i-1).cs_args in + let args = name_context env sigma cs_args in it_mkLambda_or_LetIn result args in let brl = List.map build_branch @@ -905,8 +904,7 @@ let build_selector env sigma dirn c ind special default = let ind, _ = check_privacy env indp in let typ = Retyping.get_type_of env sigma default in let (mib,mip) = lookup_mind_specif env ind in - let deparsign = make_arity_signature env true indf in - let deparsign = List.map (fun d -> map_rel_decl EConstr.of_constr d) deparsign in + let deparsign = make_arity_signature env sigma true indf in let p = it_mkLambda_or_LetIn typ deparsign in let cstrs = get_constructors env indf in let build_branch i = @@ -1535,9 +1533,6 @@ let decomp_tuple_term env sigma c t = in [((ex,exty),inner_code)]::iterated_decomp in decomprec (mkRel 1) c t -let lambda_create env (a,b) = - mkLambda (named_hd env (EConstr.Unsafe.to_constr a) Anonymous, a, b) - let subst_tuple_term env sigma dep_pair1 dep_pair2 b = let sigma = Sigma.to_evar_map sigma in let typ = get_type_of env sigma dep_pair1 in @@ -1555,9 +1550,9 @@ let subst_tuple_term env sigma dep_pair1 dep_pair2 b = (* We build the expected goal *) let abst_B = List.fold_right - (fun (e,t) body -> lambda_create env (t,subst_term sigma e body)) e1_list b in + (fun (e,t) body -> lambda_create env sigma (t,subst_term sigma e body)) e1_list b in let pred_body = beta_applist sigma (abst_B,proj_list) in - let body = mkApp (lambda_create env (typ,pred_body),[|dep_pair1|]) in + let body = mkApp (lambda_create env sigma (typ,pred_body),[|dep_pair1|]) in let expected_goal = beta_applist sigma (abst_B,List.map fst e2_list) in (* Simulate now the normalisation treatment made by Logic.mk_refgoals *) let expected_goal = nf_betaiota sigma expected_goal in diff --git a/tactics/inv.ml b/tactics/inv.ml index ecb8eedaca..632a297211 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -90,8 +90,7 @@ let make_inv_predicate env evd indf realargs id status concl = | None -> let sort = get_sort_family_of env !evd concl in let sort = Evarutil.evd_comb1 (Evd.fresh_sort_in_family env) evd sort in - let p = make_arity env true indf sort in - let p = EConstr.of_constr p in + let p = make_arity env !evd true indf sort in let evd',(p,ptyp) = Unification.abstract_list_all env !evd p concl (realargs@[mkVar id]) in evd := evd'; p in @@ -133,11 +132,7 @@ let make_inv_predicate env evd indf realargs id status concl = build_concl eqns args (succ n) restlist in let (newconcl, args) = build_concl [] [] 0 realargs in - let name_context env ctx = - let map f c = List.map (fun d -> Termops.map_rel_decl f d) c in - map EConstr.of_constr (name_context env (map EConstr.Unsafe.to_constr ctx)) - in - let predicate = it_mkLambda_or_LetIn newconcl (name_context env hyps) in + let predicate = it_mkLambda_or_LetIn newconcl (name_context env !evd hyps) in let _ = Evarutil.evd_comb1 (Typing.type_of env) evd predicate in (* OK - this predicate should now be usable by res_elimination_then to do elimination on the conclusion. *) diff --git a/tactics/leminv.ml b/tactics/leminv.ml index d7c396179f..d864e547c5 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -119,11 +119,11 @@ let max_prefix_sign lid sign = let rec add_prods_sign env sigma t = match EConstr.kind sigma (whd_all env sigma t) with | Prod (na,c1,b) -> - let id = id_of_name_using_hdchar env (EConstr.Unsafe.to_constr t) na in + let id = id_of_name_using_hdchar env sigma t na in let b'= subst1 (mkVar id) b in add_prods_sign (push_named (LocalAssum (id,c1)) env) sigma b' | LetIn (na,c1,t1,b) -> - let id = id_of_name_using_hdchar env (EConstr.Unsafe.to_constr t) na in + let id = id_of_name_using_hdchar env sigma t na in let b'= subst1 (mkVar id) b in add_prods_sign (push_named (LocalDef (id,c1,t1)) env) sigma b' | _ -> (env,t) @@ -147,8 +147,7 @@ let compute_first_inversion_scheme env sigma ind sort dep_option = let p = next_ident_away (Id.of_string "P") allvars in let pty,goal = if dep_option then - let pty = make_arity env true indf sort in - let pty = EConstr.of_constr pty in + let pty = make_arity env sigma true indf sort in let goal = mkProd (Anonymous, mkAppliedInd ind, applist(mkVar p,realargs@[mkRel 1])) diff --git a/tactics/tactics.ml b/tactics/tactics.ml index a29803251e..13ffbc52fe 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -412,16 +412,13 @@ let id_of_name_with_default id = function let default_id_of_sort s = if Sorts.is_small s then default_small_ident else default_type_ident -let id_of_name_using_hdchar env c name = - id_of_name_using_hdchar env (EConstr.Unsafe.to_constr c) name - let default_id env sigma decl = let open Context.Rel.Declaration in match decl with | LocalAssum (name,t) -> let dft = default_id_of_sort (Retyping.get_sort_of env sigma t) in id_of_name_with_default dft name - | LocalDef (name,b,_) -> id_of_name_using_hdchar env b name + | LocalDef (name,b,_) -> id_of_name_using_hdchar env sigma b name (* Non primitive introduction tactics are treated by intro_then_gen There is possibly renaming, with possibly names to avoid and @@ -1075,14 +1072,14 @@ let intros_replacing ids = (* User-level introduction tactics *) -let lookup_hypothesis_as_renamed env ccl = function - | AnonHyp n -> Detyping.lookup_index_as_renamed env (EConstr.Unsafe.to_constr ccl) n - | NamedHyp id -> Detyping.lookup_name_as_displayed env (EConstr.Unsafe.to_constr ccl) id +let lookup_hypothesis_as_renamed env sigma ccl = function + | AnonHyp n -> Detyping.lookup_index_as_renamed env sigma ccl n + | NamedHyp id -> Detyping.lookup_name_as_displayed env sigma ccl id let lookup_hypothesis_as_renamed_gen red h gl = let env = Proofview.Goal.env gl in let rec aux ccl = - match lookup_hypothesis_as_renamed env ccl h with + match lookup_hypothesis_as_renamed env (Tacmach.New.project gl) ccl h with | None when red -> let (redfun, _) = Redexpr.reduction_of_red_expr env (Red true) in let Sigma (c, _, _) = redfun.e_redfun env (Proofview.Goal.sigma gl) ccl in @@ -1350,7 +1347,7 @@ let enforce_prop_bound_names rename tac = if Retyping.get_sort_family_of env sigma t = InProp then (* "very_standard" says that we should have "H" names only, but this would break compatibility even more... *) - let s = match Namegen.head_name (EConstr.Unsafe.to_constr t) with + let s = match Namegen.head_name sigma t with | Some id when not very_standard -> string_of_id id | _ -> "" in Name (add_suffix Namegen.default_prop_ident s) @@ -2768,7 +2765,7 @@ let enough_by na t tac = forward false (Some (Some tac)) (ipat_of_name na) t (* Compute a name for a generalization *) -let generalized_name sigma c t ids cl = function +let generalized_name env sigma c t ids cl = function | Name id as na -> if Id.List.mem id ids then user_err (pr_id id ++ str " is already used."); @@ -2783,7 +2780,7 @@ let generalized_name sigma c t ids cl = function (* On ne s'etait pas casse la tete : on avait pris pour nom de variable la premiere lettre du type, meme si "c" avait ete une constante dont on aurait pu prendre directement le nom *) - named_hd (Global.env()) (EConstr.Unsafe.to_constr t) Anonymous + named_hd env sigma t Anonymous (* Abstract over [c] in [forall x1:A1(c)..xi:Ai(c).T(c)] producing [forall x, x1:A1(x1), .., xi:Ai(x). T(x)] with all [c] abtracted in [Ai] @@ -2795,7 +2792,7 @@ let generalize_goal_gen env sigma ids i ((occs,c,b),na) t cl = let dummy_prod = it_mkProd_or_LetIn mkProp decls in let newdecls,_ = decompose_prod_n_assum sigma i (subst_term_gen sigma EConstr.eq_constr_nounivs c dummy_prod) in let cl',sigma' = subst_closed_term_occ env sigma (AtOccs occs) c (it_mkProd_or_LetIn cl newdecls) in - let na = generalized_name sigma c t ids cl' na in + let na = generalized_name env sigma c t ids cl' na in let decl = match b with | None -> LocalAssum (na,t) | Some b -> LocalDef (na,b,t) @@ -3230,7 +3227,7 @@ let atomize_param_of_ind_then (indref,nparams,_) hyp0 tac = | Var id -> id | _ -> let type_of = Tacmach.New.pf_unsafe_type_of gl in - id_of_name_using_hdchar (Global.env()) (type_of c) Anonymous in + id_of_name_using_hdchar (Global.env()) sigma (type_of c) Anonymous in let x = fresh_id_in_env avoid id env in Tacticals.New.tclTHEN (letin_tac None (Name x) c None allHypsAndConcl) @@ -4434,7 +4431,7 @@ let induction_gen clear_flag isrec with_evars elim declaring the induction argument as a new local variable *) let id = (* Type not the right one if partially applied but anyway for internal use*) - let x = id_of_name_using_hdchar (Global.env()) t Anonymous in + let x = id_of_name_using_hdchar (Global.env()) evd t Anonymous in new_fresh_id [] x gl in let info_arg = (is_arg_pure_hyp, not enough_applied) in pose_induction_arg_then @@ -4471,7 +4468,7 @@ let induction_gen_l isrec with_evars elim names lc = let type_of = Tacmach.New.pf_unsafe_type_of gl in let sigma = Tacmach.New.project gl in let x = - id_of_name_using_hdchar (Global.env()) (type_of c) Anonymous in + id_of_name_using_hdchar (Global.env()) sigma (type_of c) Anonymous in let id = new_fresh_id [] x gl in let newl' = List.map (fun r -> replace_term sigma c (mkVar id) r) l' in -- cgit v1.2.3 From 3c1cd2338fcddc4a6c0e97b0af53eb2b2f238c4a Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Thu, 15 Dec 2016 10:45:19 +0100 Subject: Removing most nf_enter in tactics. Now they are useless because all of the primitives are (should?) be evar-insensitive. --- tactics/auto.ml | 16 +++--- tactics/autorewrite.ml | 2 +- tactics/class_tactics.ml | 42 +++++++------- tactics/class_tactics.mli | 2 +- tactics/contradiction.ml | 2 +- tactics/eauto.ml | 17 +++--- tactics/elim.ml | 4 +- tactics/eqdecide.ml | 4 +- tactics/equality.ml | 24 ++++---- tactics/inv.ml | 14 ++--- tactics/leminv.ml | 5 +- tactics/tacticals.ml | 140 ++++++++++++++++++++++------------------------ tactics/tacticals.mli | 5 +- tactics/tactics.ml | 107 ++++++++++++++++++----------------- tactics/tactics.mli | 4 +- 15 files changed, 194 insertions(+), 194 deletions(-) (limited to 'tactics') diff --git a/tactics/auto.ml b/tactics/auto.ml index b548f8b928..c8c119aee1 100644 --- a/tactics/auto.ml +++ b/tactics/auto.ml @@ -101,9 +101,9 @@ let connect_hint_clenv poly (c, _, ctx) clenv gl = in clenv, c let unify_resolve poly flags ((c : raw_hint), clenv) = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let clenv, c = connect_hint_clenv poly c clenv gl in - let clenv = Tacmach.New.of_old (fun gl -> clenv_unique_resolver ~flags clenv gl) gl in + let clenv = clenv_unique_resolver ~flags clenv gl in Clenvtac.clenv_refine false clenv end } @@ -330,7 +330,7 @@ let rec trivial_fail_db dbg mod_delta db_list local_db = end }) in Proofview.Goal.enter { enter = begin fun gl -> - let concl = Tacmach.New.pf_nf_concl gl in + let concl = Tacmach.New.pf_concl gl in let sigma = Tacmach.New.project gl in let secvars = compute_secvars gl in Tacticals.New.tclFIRST @@ -421,7 +421,7 @@ and trivial_resolve sigma dbg mod_delta db_list local_db secvars cl = "nocore" amongst the databases. *) let trivial ?(debug=Off) lems dbnames = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let db_list = make_db_list dbnames in @@ -432,7 +432,7 @@ let trivial ?(debug=Off) lems dbnames = end } let full_trivial ?(debug=Off) lems = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let db_list = current_pure_db () in @@ -490,7 +490,7 @@ let search d n mod_delta db_list local_db = Tacticals.New.tclORELSE0 (dbg_assumption d) (Tacticals.New.tclORELSE0 (intro_register d (search d n) local_db) ( Proofview.Goal.enter { enter = begin fun gl -> - let concl = Tacmach.New.pf_nf_concl gl in + let concl = Tacmach.New.pf_concl gl in let sigma = Tacmach.New.project gl in let secvars = compute_secvars gl in let d' = incr_dbg d in @@ -506,7 +506,7 @@ let search d n mod_delta db_list local_db = let default_search_depth = ref 5 let delta_auto debug mod_delta n lems dbnames = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let db_list = make_db_list dbnames in @@ -529,7 +529,7 @@ let new_auto ?(debug=Off) n = delta_auto debug true n let default_auto = auto !default_search_depth [] [] let delta_full_auto ?(debug=Off) mod_delta n lems = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let db_list = current_pure_db () in diff --git a/tactics/autorewrite.ml b/tactics/autorewrite.ml index f43f4b2502..e58ec5a31f 100644 --- a/tactics/autorewrite.ml +++ b/tactics/autorewrite.ml @@ -92,7 +92,7 @@ type raw_rew_rule = Loc.t * constr Univ.in_universe_context_set * bool * Genarg. let one_base general_rewrite_maybe_in tac_main bas = let lrul = find_rewrites bas in let try_rewrite dir ctx c tc = - Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let subst, ctx' = Universes.fresh_universe_context_set_instance ctx in let c' = Vars.subst_univs_level_constr subst c in diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 669d808140..8ada9e6a71 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -231,13 +231,13 @@ let e_give_exact flags poly (c,clenv) gl = 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' = Tacmach.New.of_old (clenv_unique_resolver ~flags clenv') gls in + let clenv' = clenv_unique_resolver ~flags clenv' gls in Clenvtac.clenv_refine true ~with_classes:false 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' = Tacmach.New.of_old (clenv_unique_resolver ~flags clenv') gls in + let clenv' = clenv_unique_resolver ~flags clenv' gls in Clenvtac.clenv_refine false ~with_classes:false clenv' end } @@ -285,16 +285,16 @@ let clenv_of_prods poly nprods (c, clenv) gl = if Pervasives.(>=) diff 0 then (* Was Some clenv... *) Some (Some diff, - Tacmach.New.of_old (fun gls -> mk_clenv_from_n gls (Some diff) (c,ty)) gl) + mk_clenv_from_n gl (Some diff) (c,ty)) else None let with_prods nprods poly (c, clenv) f = if get_typeclasses_limit_intros () then - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> match clenv_of_prods poly nprods (c, clenv) gl with | None -> Tacticals.New.tclZEROMSG (str"Not enough premisses") | Some (diff, clenv') -> f.enter gl (c, diff, clenv') end } - else Proofview.Goal.nf_enter + else Proofview.Goal.enter { enter = begin fun gl -> if Int.equal nprods 0 then f.enter gl (c, None, clenv) else Tacticals.New.tclZEROMSG (str"Not enough premisses") end } @@ -345,7 +345,7 @@ let rec e_trivial_fail_db only_classes db_list local_db secvars = let open Tacticals.New in let open Tacmach.New in let trivial_fail = - Proofview.Goal.nf_enter { enter = + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in @@ -356,7 +356,7 @@ let rec e_trivial_fail_db only_classes db_list local_db secvars = end } in let trivial_resolve = - Proofview.Goal.nf_enter { enter = + Proofview.Goal.enter { enter = begin fun gl -> let tacs = e_trivial_resolve db_list local_db secvars only_classes (project gl) (pf_concl gl) in @@ -944,7 +944,7 @@ module Search = struct Hint_db.transparent_state cached_hints == st then cached_hints else - let hints = make_hints {it = Goal.goal g; sigma = project g} + let hints = make_hints {it = Goal.goal (Proofview.Goal.assume g); sigma = project g} st only_classes sign in autogoal_cache := (cwd, only_classes, sign, hints); hints @@ -1024,16 +1024,16 @@ module Search = struct (pr_depth (!idx :: info.search_depth) ++ str": trying " ++ Lazy.force pp ++ (if !foundone != true then - str" on" ++ spc () ++ pr_ev s (Proofview.Goal.goal gl) + str" on" ++ spc () ++ pr_ev s (Proofview.Goal.goal (Proofview.Goal.assume gl)) else mt ()))); - let tac_of gls i j = Goal.nf_enter { enter = fun gl' -> + let tac_of gls i j = Goal.enter { enter = fun gl' -> let sigma' = Goal.sigma gl' in let s' = Sigma.to_evar_map sigma' in let _concl = Goal.concl gl' in if !typeclasses_debug > 0 then Feedback.msg_debug (pr_depth (succ j :: i :: info.search_depth) ++ str" : " ++ - pr_ev s' (Proofview.Goal.goal gl')); + pr_ev s' (Proofview.Goal.goal (Proofview.Goal.assume gl'))); let eq c1 c2 = EConstr.eq_constr s' c1 c2 in let hints' = if b && not (Context.Named.equal eq (Goal.hyps gl') (Goal.hyps gl)) @@ -1042,7 +1042,7 @@ module Search = struct make_autogoal_hints info.search_only_classes ~st gl' else info.search_hints in - let dep' = info.search_dep || Proofview.unifiable s' (Goal.goal gl') gls in + let dep' = info.search_dep || Proofview.unifiable s' (Goal.goal (Proofview.Goal.assume gl')) gls in let info' = { search_depth = succ j :: i :: info.search_depth; last_tac = pp; @@ -1059,7 +1059,7 @@ module Search = struct (if !typeclasses_debug > 0 then Feedback.msg_debug (pr_depth (i :: info.search_depth) ++ str": " ++ Lazy.force pp - ++ str" on" ++ spc () ++ pr_ev s (Proofview.Goal.goal gl) + ++ str" on" ++ spc () ++ pr_ev s (Proofview.Goal.goal (Proofview.Goal.assume gl)) ++ str", " ++ int j ++ str" subgoal(s)" ++ (Option.cata (fun k -> str " in addition to the first " ++ int k) (mt()) k))); @@ -1130,7 +1130,7 @@ module Search = struct else tclONCE (aux (NotApplicableEx,Exninfo.null) poss) let hints_tac hints info kont : unit Proofview.tactic = - Proofview.Goal.nf_enter + Proofview.Goal.enter { enter = fun gl -> hints_tac_gl hints info kont gl } let intro_tac info kont gl = @@ -1150,7 +1150,7 @@ module Search = struct let intro info kont = Proofview.tclBIND Tactics.intro - (fun _ -> Proofview.Goal.nf_enter { enter = fun gl -> intro_tac info kont gl }) + (fun _ -> Proofview.Goal.enter { enter = fun gl -> intro_tac info kont gl }) let rec search_tac hints limit depth = let kont info = @@ -1173,7 +1173,7 @@ module Search = struct unit Proofview.tactic = let open Proofview in let open Proofview.Notations in - let dep = dep || Proofview.unifiable sigma (Goal.goal gl) gls in + let dep = dep || Proofview.unifiable sigma (Goal.goal (Proofview.Goal.assume gl)) gls in let info = make_autogoal ?st only_classes dep (cut_of_hints hints) i gl in search_tac hints depth 1 info @@ -1510,11 +1510,11 @@ let is_ground c gl = if Evarutil.is_ground_term (project gl) c then tclIDTAC gl else tclFAIL 0 (str"Not ground") gl -let autoapply c i gl = +let autoapply c i = Proofview.Goal.enter { enter = begin fun gl -> let flags = auto_unif_flags Evar.Set.empty (Hints.Hint_db.transparent_state (Hints.searchtable_map i)) in - let cty = pf_unsafe_type_of gl c in + let cty = Tacmach.New.pf_unsafe_type_of gl c in let ce = mk_clenv_from gl (c,cty) in - let tac = { enter = fun gl -> (unify_e_resolve false flags).enter gl - ((c,cty,Univ.ContextSet.empty),0,ce) } in - Proofview.V82.of_tactic (Proofview.Goal.nf_enter tac) gl + (unify_e_resolve false flags).enter gl + ((c,cty,Univ.ContextSet.empty),0,ce) +end } diff --git a/tactics/class_tactics.mli b/tactics/class_tactics.mli index 171b5c4ea9..8855093ee9 100644 --- a/tactics/class_tactics.mli +++ b/tactics/class_tactics.mli @@ -31,7 +31,7 @@ val not_evar : constr -> unit Proofview.tactic val is_ground : constr -> tactic -val autoapply : constr -> Hints.hint_db_name -> tactic +val autoapply : constr -> Hints.hint_db_name -> unit Proofview.tactic module Search : sig val eauto_tac : diff --git a/tactics/contradiction.ml b/tactics/contradiction.ml index 0e28aa9800..63f923dfd3 100644 --- a/tactics/contradiction.ml +++ b/tactics/contradiction.ml @@ -110,7 +110,7 @@ let is_negation_of env sigma typ t = | _ -> false let contradiction_term (c,lbind as cl) = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in let type_of = Tacmach.New.pf_unsafe_type_of gl in diff --git a/tactics/eauto.ml b/tactics/eauto.ml index 7453fff5c3..14082bb8dc 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -112,13 +112,12 @@ open Auto let priority l = List.map snd (List.filter (fun (pr,_) -> Int.equal pr 0) l) let unify_e_resolve poly flags (c,clenv) = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let clenv', c = connect_hint_clenv poly c clenv gl in - Proofview.V82.tactic - (fun gls -> - let clenv' = clenv_unique_resolver ~flags clenv' gls in - tclTHEN (Refiner.tclEVARUNIVCONTEXT (Evd.evar_universe_context clenv'.evd)) - (Proofview.V82.of_tactic (Tactics.Simple.eapply c)) gls) + let clenv' = clenv_unique_resolver ~flags clenv' gl in + Proofview.tclTHEN + (Proofview.Unsafe.tclEVARUNIVCONTEXT (Evd.evar_universe_context clenv'.evd)) + (Tactics.Simple.eapply c) end } let hintmap_of sigma secvars hdc concl = @@ -139,7 +138,7 @@ let e_exact poly flags (c,clenv) = end } let rec e_trivial_fail_db db_list local_db = - let next = Proofview.Goal.nf_enter { enter = begin fun gl -> + let next = Proofview.Goal.enter { enter = begin fun gl -> let d = Tacmach.New.pf_last_hyp gl in let hintl = make_resolve_hyp (Tacmach.New.pf_env gl) (Tacmach.New.project gl) d in e_trivial_fail_db db_list (Hint_db.add_list (Tacmach.New.pf_env gl) (Tacmach.New.project gl) hintl local_db) @@ -149,7 +148,7 @@ let rec e_trivial_fail_db db_list local_db = let tacl = registered_e_assumption :: (Tacticals.New.tclTHEN Tactics.intro next) :: - (List.map fst (e_trivial_resolve (Tacmach.New.project gl) db_list local_db secvars (Tacmach.New.pf_nf_concl gl))) + (List.map fst (e_trivial_resolve (Tacmach.New.project gl) db_list local_db secvars (Tacmach.New.pf_concl gl))) in Tacticals.New.tclFIRST (List.map Tacticals.New.tclCOMPLETE tacl) end } @@ -501,7 +500,7 @@ let unfold_head env sigma (ids, csts) c = in aux c let autounfold_one db cl = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl gl in diff --git a/tactics/elim.ml b/tactics/elim.ml index a4158f8218..e37ec6bce2 100644 --- a/tactics/elim.ml +++ b/tactics/elim.ml @@ -133,7 +133,7 @@ let induction_trailer abs_i abs_j bargs = (tclDO (abs_j - abs_i) intro) (onLastHypId (fun id -> - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let idty = pf_unsafe_type_of gl (mkVar id) in let fvty = global_vars (pf_env gl) (project gl) idty in let possible_bring_hyps = @@ -155,7 +155,7 @@ let induction_trailer abs_i abs_j bargs = )) let double_ind h1 h2 = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let abs_i = depth_of_quantified_hypothesis true h1 gl in let abs_j = depth_of_quantified_hypothesis true h2 gl in let abs = diff --git a/tactics/eqdecide.ml b/tactics/eqdecide.ml index df60f2c66c..bac3980d2b 100644 --- a/tactics/eqdecide.ml +++ b/tactics/eqdecide.ml @@ -176,7 +176,7 @@ let solveEqBranch rectype = Proofview.tclORELSE begin Proofview.Goal.enter { enter = begin fun gl -> - let concl = pf_nf_concl gl in + let concl = pf_concl gl in let sigma = project gl in match_eqdec sigma concl >>= fun (eqonleft,op,lhs,rhs,_) -> let (mib,mip) = Global.lookup_inductive rectype in @@ -202,7 +202,7 @@ let decideGralEquality = Proofview.tclORELSE begin Proofview.Goal.enter { enter = begin fun gl -> - let concl = pf_nf_concl gl in + let concl = pf_concl gl in let sigma = project gl in match_eqdec sigma concl >>= fun (eqonleft,_,c1,c2,typ) -> let headtyp = hd_app sigma (pf_compute gl typ) in diff --git a/tactics/equality.ml b/tactics/equality.ml index d9b6685179..6fcf529c28 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -306,7 +306,7 @@ let general_elim_clause with_evars frzevars tac cls c t l l2r elim = else instantiate_lemma_all frzevars gl c t l l2r concl in let typ = match cls with - | None -> pf_nf_concl gl + | None -> pf_concl gl | Some id -> pf_get_hyp_typ id (Proofview.Goal.assume gl) in let cs = instantiate_lemma typ in @@ -406,7 +406,7 @@ let type_of_clause cls gl = match cls with | Some id -> pf_get_hyp_typ id gl let leibniz_rewrite_ebindings_clause cls lft2rgt tac c t l with_evars frzevars dep_proof_ok hdcncl = - Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> let evd = Sigma.to_evar_map (Proofview.Goal.sigma gl) in let isatomic = isProd evd (whd_zeta evd hdcncl) in let dep_fun = if isatomic then dependent else dependent_no_evar in @@ -1009,7 +1009,7 @@ let discr_positions env sigma (lbeq,eqn,(t,t1,t2)) eq_clause cpath dirn = let discrEq (lbeq,_,(t,t1,t2) as u) eq_clause = let sigma = eq_clause.evd in - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in match find_positions env sigma t1 t2 with | Inr _ -> @@ -1019,7 +1019,7 @@ let discrEq (lbeq,_,(t,t1,t2) as u) eq_clause = end } let onEquality with_evars tac (c,lbindc) = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let type_of = pf_unsafe_type_of gl in let reduce_to_quantified_ind = pf_apply Tacred.reduce_to_quantified_ind gl in let t = type_of c in @@ -1034,7 +1034,7 @@ let onEquality with_evars tac (c,lbindc) = end } let onNegatedEquality with_evars tac = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in let ccl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in @@ -1302,7 +1302,7 @@ let eq_dec_scheme_kind_name = ref (fun _ -> failwith "eq_dec_scheme undefined") let set_eq_dec_scheme_kind k = eq_dec_scheme_kind_name := (fun _ -> k) let inject_if_homogenous_dependent_pair ty = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> try let sigma = Tacmach.New.project gl in let eq,u,(t,t1,t2) = find_this_eq_data_decompose gl ty in @@ -1458,7 +1458,7 @@ let injConcl = injClause None false None let injHyp clear_flag id = injClause None false (Some (clear_flag,ElimOnIdent (Loc.ghost,id))) let decompEqThen ntac (lbeq,_,(t,t1,t2) as u) clause = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let sigma = clause.evd in let env = Proofview.Goal.env gl in match find_positions env sigma t1 t2 with @@ -1567,7 +1567,7 @@ let subst_tuple_term env sigma dep_pair1 dep_pair2 b = (* on for further iterated sigma-tuples *) let cutSubstInConcl l2r eqn = - Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let (lbeq,u,(t,e1,e2)) = find_eq_data_decompose gl eqn in @@ -1586,7 +1586,7 @@ let cutSubstInConcl l2r eqn = end } let cutSubstInHyp l2r eqn id = - Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let (lbeq,u,(t,e1,e2)) = find_eq_data_decompose gl eqn in @@ -1812,7 +1812,7 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () = Proofview.tclUNIT () end } in - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let ids = find_equations gl in tclMAP process ids end } @@ -1822,7 +1822,7 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () = (* Old implementation, not able to manage configurations like a=b, a=t, or situations like "a = S b, b = S a", or also accidentally unfolding let-ins *) - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let sigma = project gl in let find_eq_data_decompose = find_eq_data_decompose gl in let test (_,c) = @@ -1877,7 +1877,7 @@ let rewrite_assumption_cond cond_eq_term cl = with | Failure _ | UserError _ -> arec rest gl end in - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let gl = Proofview.Goal.lift gl Sigma.Unsafe.le in let hyps = Proofview.Goal.hyps gl in arec hyps gl diff --git a/tactics/inv.ml b/tactics/inv.ml index 632a297211..904a17417a 100644 --- a/tactics/inv.ml +++ b/tactics/inv.ml @@ -273,7 +273,7 @@ Nota: with Inversion_clear, only four useless hypotheses let generalizeRewriteIntros as_mode tac depids id = Proofview.tclENV >>= fun env -> - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let dids = dependent_hyps env id depids gl in let reintros = if as_mode then intros_replacing else intros_possibly_replacing in (tclTHENLIST @@ -342,7 +342,7 @@ let projectAndApply as_mode thin avoid id eqname names depids = (if thin then clear [id] else (remember_first_eq id eqname; tclIDTAC)) in let substHypIfVariable tac id = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let sigma = project gl in (** We only look at the type of hypothesis "id" *) let hyp = pf_nf_evar gl (pf_get_hyp_typ id (Proofview.Goal.assume gl)) in @@ -378,7 +378,7 @@ let projectAndApply as_mode thin avoid id eqname names depids = id let nLastDecls i tac = - Proofview.Goal.nf_enter { enter = begin fun gl -> tac (nLastDecls gl i) end } + Proofview.Goal.enter { enter = begin fun gl -> tac (nLastDecls gl i) end } (* Introduction of the equations on arguments othin: discriminates Simple Inversion, Inversion and Inversion_clear @@ -386,7 +386,7 @@ let nLastDecls i tac = Some thin: the equations are rewritten, and cleared if thin is true *) let rewrite_equations as_mode othin neqns names ba = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let (depids,nodepids) = split_dep_and_nodep ba.Tacticals.assums gl in let first_eq = ref MoveLast in let avoid = if as_mode then List.map NamedDecl.get_id nodepids else [] in @@ -436,7 +436,7 @@ let rewrite_equations_tac as_mode othin id neqns names ba = tac let raw_inversion inv_kind id status names = - Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let sigma = Sigma.to_evar_map sigma in let env = Proofview.Goal.env gl in @@ -517,14 +517,14 @@ let dinv_clear_tac id = dinv FullInversionClear None None (NamedHyp id) * back to their places in the hyp-list. *) let invIn k names ids id = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let hyps = List.map (fun id -> pf_get_hyp id gl) ids in let concl = Proofview.Goal.concl gl in let sigma = project gl in let nb_prod_init = nb_prod sigma concl in let intros_replace_ids = Proofview.Goal.enter { enter = begin fun gl -> - let concl = pf_nf_concl gl in + let concl = pf_concl gl in let sigma = project gl in let nb_of_new_hyp = nb_prod sigma concl - (List.length hyps + nb_prod_init) diff --git a/tactics/leminv.ml b/tactics/leminv.ml index d864e547c5..daa962f1d6 100644 --- a/tactics/leminv.ml +++ b/tactics/leminv.ml @@ -262,7 +262,8 @@ let add_inversion_lemma_exn na com comsort bool tac = let lemInv id c gls = try - let clause = mk_clenv_type_of gls c in + 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 with @@ -277,7 +278,7 @@ let lemInv id c gls = let lemInv_gen id c = try_intros_until (fun id -> Proofview.V82.tactic (lemInv id c)) id let lemInvIn id c ids = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let hyps = List.map (fun id -> pf_get_hyp id gl) ids in let intros_replace_ids = let concl = Proofview.Goal.concl gl in diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index 94f22f9039..27c1987a06 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -267,40 +267,6 @@ let pf_with_evars glsev k gls = let pf_constr_of_global gr k = pf_with_evars (fun gls -> on_snd EConstr.of_constr (pf_apply Evd.fresh_global gls gr)) k -(* computing the case/elim combinators *) - -let gl_make_elim ind gl = - let gr = Indrec.lookup_eliminator (fst ind) (elimination_sort_of_goal gl) in - let (sigma, c) = pf_apply Evd.fresh_global gl gr in - (sigma, EConstr.of_constr c) - -let gl_make_case_dep ind gl = - let sigma = Sigma.Unsafe.of_evar_map (Tacmach.project gl) in - let Sigma (r, sigma, _) = Indrec.build_case_analysis_scheme (pf_env gl) sigma ind true - (elimination_sort_of_goal gl) - in - (Sigma.to_evar_map sigma, EConstr.of_constr r) - -let gl_make_case_nodep ind gl = - let sigma = Sigma.Unsafe.of_evar_map (Tacmach.project gl) in - let Sigma (r, sigma, _) = Indrec.build_case_analysis_scheme (pf_env gl) sigma ind false - (elimination_sort_of_goal gl) - in - (Sigma.to_evar_map sigma, EConstr.of_constr r) - -let make_elim_branch_assumptions ba gl = - let assums = - try List.rev (List.firstn ba.nassums (pf_hyps gl)) - with Failure _ -> anomaly (Pp.str "make_elim_branch_assumptions") in - { ba = ba; assums = assums } - -let elim_on_ba tac ba gl = tac (make_elim_branch_assumptions ba gl) gl - -let make_case_branch_assumptions = make_elim_branch_assumptions - -let case_on_ba tac ba gl = tac (make_case_branch_assumptions ba gl) gl - - (** Tacticals of Ltac defined directly in term of Proofview *) module New = struct open Proofview @@ -534,7 +500,7 @@ module New = struct Proofview.Unsafe.tclEVARS sigma <*> tac >>= check_evars_if let tclDELAYEDWITHHOLES check x tac = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let Sigma (x, sigma, _) = x.delayed env sigma in @@ -578,13 +544,13 @@ module New = struct let onLastHyp = onNthHyp 1 let onNthDecl m tac = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> Proofview.tclUNIT (nthDecl m gl) >>= tac end } let onLastDecl = onNthDecl 1 let ifOnHyp pred tac1 tac2 id = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let typ = Tacmach.New.pf_get_hyp_typ id gl in if pred (id,typ) then tac1 id @@ -592,7 +558,7 @@ module New = struct tac2 id end } - let onHyps find tac = Proofview.Goal.nf_enter { enter = begin fun gl -> tac (find.enter gl) end } + let onHyps find tac = Proofview.Goal.enter { enter = begin fun gl -> tac (find.enter gl) end } let afterHyp id tac = Proofview.Goal.enter { enter = begin fun gl -> @@ -625,13 +591,13 @@ module New = struct (* c should be of type A1->.. An->B with B an inductive definition *) let general_elim_then_using mk_elim isrec allnames tac predicate ind (c, t) = - Proofview.Goal.nf_enter { enter = begin fun gl -> - let sigma, elim = Tacmach.New.of_old (mk_elim ind) gl in + Proofview.Goal.enter { enter = begin fun gl -> + let sigma, elim = (mk_elim ind).enter gl in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) - (Proofview.Goal.nf_enter { enter = begin fun gl -> - let indclause = Tacmach.New.of_old (fun gl -> mk_clenv_from gl (c, t)) gl in + (Proofview.Goal.enter { enter = begin fun gl -> + let indclause = mk_clenv_from gl (c, t) in (* applying elimination_scheme just a little modified *) - let elimclause = Tacmach.New.of_old (fun gls -> mk_clenv_from gls (elim,Tacmach.New.pf_unsafe_type_of gl elim)) gl in + let elimclause = mk_clenv_from gl (elim,Tacmach.New.pf_unsafe_type_of gl elim) in let indmv = match EConstr.kind elimclause.evd (last_arg elimclause.evd elimclause.templval.Evd.rebus) with | Meta mv -> mv @@ -660,7 +626,7 @@ module New = struct | None -> elimclause' | Some p -> clenv_unify ~flags Reduction.CONV (mkMeta pmv) p elimclause' in - let clenv' = Tacmach.New.of_old (clenv_unique_resolver ~flags elimclause') gl in + let clenv' = clenv_unique_resolver ~flags elimclause' gl in let after_tac i = let (hd,largs) = decompose_app clenv'.evd clenv'.templtyp.Evd.rebus in let ba = { branchsign = branchsigns.(i); @@ -679,8 +645,64 @@ module New = struct (Proofview.tclEXTEND [] tclIDTAC branchtacs) end }) end } + let elimination_sort_of_goal gl = + (** Retyping will expand evars anyway. *) + let c = Proofview.Goal.concl (Goal.assume gl) in + pf_apply Retyping.get_sort_family_of gl c + + let elimination_sort_of_hyp id gl = + (** Retyping will expand evars anyway. *) + let c = pf_get_hyp_typ id (Goal.assume gl) in + pf_apply Retyping.get_sort_family_of gl c + + let elimination_sort_of_clause id gl = match id with + | None -> elimination_sort_of_goal gl + | Some id -> elimination_sort_of_hyp id gl + + (* computing the case/elim combinators *) + + let gl_make_elim ind = { enter = begin fun gl -> + let gr = Indrec.lookup_eliminator (fst ind) (elimination_sort_of_goal gl) in + let (sigma, c) = pf_apply Evd.fresh_global gl gr in + (sigma, EConstr.of_constr c) + end } + + let gl_make_case_dep ind = { enter = begin fun gl -> + let sigma = Sigma.Unsafe.of_evar_map (project gl) in + let Sigma (r, sigma, _) = Indrec.build_case_analysis_scheme (pf_env gl) sigma ind true + (elimination_sort_of_goal gl) + in + (Sigma.to_evar_map sigma, EConstr.of_constr r) + end } + + let gl_make_case_nodep ind = { enter = begin fun gl -> + let sigma = Sigma.Unsafe.of_evar_map (project gl) in + let Sigma (r, sigma, _) = Indrec.build_case_analysis_scheme (pf_env gl) sigma ind false + (elimination_sort_of_goal gl) + in + (Sigma.to_evar_map sigma, EConstr.of_constr r) + end } + + 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 + { ba = ba; assums = assums } + + let elim_on_ba tac ba = + Proofview.Goal.enter { enter = begin fun gl -> + let branches = make_elim_branch_assumptions ba (Proofview.Goal.hyps gl) in + tac branches + end } + + let case_on_ba tac ba = + Proofview.Goal.enter { enter = begin fun gl -> + let branches = make_elim_branch_assumptions ba (Proofview.Goal.hyps gl) in + tac branches + end } + let elimination_then tac c = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let (ind,t) = pf_reduce_to_quantified_ind gl (pf_unsafe_type_of gl c) in let isrec,mkelim = match (Global.lookup_mind (fst (fst ind))).mind_record with @@ -696,34 +718,8 @@ module New = struct let case_nodep_then_using = general_elim_then_using gl_make_case_nodep false - let elim_on_ba tac ba = - Proofview.Goal.nf_enter { enter = begin fun gl -> - let branches = Tacmach.New.of_old (make_elim_branch_assumptions ba) gl in - tac branches - end } - - let case_on_ba tac ba = - Proofview.Goal.nf_enter { enter = begin fun gl -> - let branches = Tacmach.New.of_old (make_case_branch_assumptions ba) gl in - tac branches - end } - - let elimination_sort_of_goal gl = - (** Retyping will expand evars anyway. *) - let c = Proofview.Goal.concl (Goal.assume gl) in - pf_apply Retyping.get_sort_family_of gl c - - let elimination_sort_of_hyp id gl = - (** Retyping will expand evars anyway. *) - let c = pf_get_hyp_typ id (Goal.assume gl) in - pf_apply Retyping.get_sort_family_of gl c - - let elimination_sort_of_clause id gl = match id with - | None -> elimination_sort_of_goal gl - | Some id -> elimination_sort_of_hyp id gl - let pf_constr_of_global ref tac = - Proofview.Goal.nf_enter { enter = begin fun gl -> + 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 diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index 4bb745875b..c9ff777164 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -137,9 +137,6 @@ val elimination_sort_of_clause : Id.t option -> goal sigma -> sorts_family val pf_with_evars : (goal sigma -> Evd.evar_map * 'a) -> ('a -> tactic) -> tactic val pf_constr_of_global : Globnames.global_reference -> (constr -> tactic) -> tactic -val elim_on_ba : (branch_assumptions -> tactic) -> branch_args -> tactic -val case_on_ba : (branch_assumptions -> tactic) -> branch_args -> tactic - (** Tacticals defined directly in term of Proofview *) (** The tacticals in the module [New] are the tactical of Ltac. Their @@ -240,7 +237,7 @@ module New : sig val onLastHyp : (constr -> unit tactic) -> unit tactic val onLastDecl : (named_declaration -> unit tactic) -> unit tactic - val onHyps : ([ `NF ], named_context) Proofview.Goal.enter -> + val onHyps : ([ `LZ ], named_context) Proofview.Goal.enter -> (named_context -> unit tactic) -> unit tactic val afterHyp : Id.t -> (named_context -> unit tactic) -> unit tactic diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 13ffbc52fe..5ad43a7d60 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -515,7 +515,7 @@ let rec check_mutind env sigma k cl = match EConstr.kind sigma (strip_outer_cast | _ -> error "Not enough products." (* Refine as a fixpoint *) -let mutual_fix f n rest j = Proofview.Goal.nf_enter { enter = begin fun gl -> +let mutual_fix f n rest j = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl gl in @@ -571,7 +571,7 @@ let rec check_is_mutcoind env sigma cl = error "All methods must construct elements in coinductive types." (* Refine as a cofixpoint *) -let mutual_cofix f others j = Proofview.Goal.nf_enter { enter = begin fun gl -> +let mutual_cofix f others j = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let concl = Proofview.Goal.concl gl in @@ -697,12 +697,12 @@ let bind_red_expr_occurrences occs nbcl redexp = certain hypothesis *) let reduct_in_concl (redfun,sty) = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> convert_concl_no_check (Tacmach.New.pf_apply redfun gl (Tacmach.New.pf_concl gl)) sty end } let reduct_in_hyp ?(check=false) redfun (id,where) = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> convert_hyp ~check (pf_reduce_decl redfun where (Tacmach.New.pf_get_hyp id gl) gl) end } @@ -731,14 +731,14 @@ let pf_e_reduce_decl redfun where decl gl = Sigma (LocalDef (id, b', ty'), sigma, p +> q) let e_reduct_in_concl ~check (redfun, sty) = - Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let Sigma (c', sigma, p) = redfun.e_redfun (Tacmach.New.pf_env gl) sigma (Tacmach.New.pf_concl gl) in Sigma (convert_concl ~check c' sty, sigma, p) end } let e_reduct_in_hyp ?(check=false) redfun (id, where) = - Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> let Sigma (decl', sigma, p) = pf_e_reduce_decl redfun where (Tacmach.New.pf_get_hyp id gl) gl in Sigma (convert_hyp ~check decl', sigma, p) end } @@ -1112,7 +1112,7 @@ let depth_of_quantified_hypothesis red h gl = str".") let intros_until_gen red h = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let n = depth_of_quantified_hypothesis red h gl in Tacticals.New.tclDO n (if red then introf else intro) end } @@ -1226,7 +1226,7 @@ let cut c = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in - let concl = Tacmach.New.pf_nf_concl gl in + let concl = Proofview.Goal.concl gl in let is_sort = try (** Backward compat: ensure that [c] is well-typed. *) @@ -1360,7 +1360,7 @@ let enforce_prop_bound_names rename tac = mkLetIn (na,c,t,aux (push_rel (LocalDef (na,c,t)) env) sigma (i-1) t') | _ -> assert false in let rename_branch i = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let t = Proofview.Goal.concl gl in @@ -1438,7 +1438,7 @@ let general_elim with_evars clear_flag (c, lbindc) elim = (* Case analysis tactics *) let general_case_analysis_in_context with_evars clear_flag (c,lbindc) = - Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl gl in @@ -1629,7 +1629,7 @@ let make_projection env sigma params cstr sign elim i n c u = in elim let descend_in_conjunctions avoid tac (err, info) c = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in try @@ -1676,7 +1676,7 @@ let descend_in_conjunctions avoid tac (err, info) c = (****************************************************) let solve_remaining_apply_goals = - Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in if !apply_solve_class_goals then try @@ -1701,7 +1701,7 @@ let tclORELSEOPT t k = | Some tac -> tac) let general_apply with_delta with_destruct with_evars clear_flag (loc,(c,lbind : EConstr.constr with_bindings)) = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in let sigma = Tacmach.New.project gl in let flags = @@ -1854,7 +1854,7 @@ let apply_in_once_main flags innerclause env sigma (d,lbind) = let apply_in_once sidecond_first with_delta with_destruct with_evars naming id (clear_flag,(loc,(d,lbind))) tac = let open Context.Rel.Declaration in - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in let flags = @@ -1915,7 +1915,7 @@ let apply_in_delayed_once sidecond_first with_delta with_destruct with_evars nam *) let cut_and_apply c = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in match EConstr.kind sigma (Tacmach.New.pf_hnf_constr gl (Tacmach.New.pf_unsafe_type_of gl c)) with | Prod (_,c1,c2) when Vars.noccurn sigma 1 c2 -> @@ -1969,7 +1969,7 @@ let native_cast_no_check c = cast_no_check Term.NATIVEcast c let exact_proof c = let open Tacmach.New in - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> Refine.refine { run = begin fun sigma -> let sigma = Sigma.to_evar_map sigma in let (c, ctx) = Constrintern.interp_casted_constr (pf_env gl) sigma c (pf_concl gl) in @@ -2005,7 +2005,7 @@ let assumption = let hyps = Proofview.Goal.hyps gl in arec gl true hyps end } in - Proofview.Goal.nf_enter assumption_tac + Proofview.Goal.enter assumption_tac (*****************************************************************) (* Modification of a local context *) @@ -2110,7 +2110,7 @@ let rec intros_clearing = function (* Keeping only a few hypotheses *) let keep hyps = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> Proofview.tclENV >>= fun env -> let ccl = Proofview.Goal.concl gl in let sigma = Tacmach.New.project gl in @@ -2158,7 +2158,7 @@ let bring_hyps hyps = Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let store = Proofview.Goal.extra gl in - let concl = Tacmach.New.pf_nf_concl gl in + let concl = Tacmach.New.pf_concl gl in let newcl = List.fold_right mkNamedProd_or_LetIn hyps concl in let args = Array.of_list (Context.Named.to_instance mkVar hyps) in Refine.refine { run = begin fun sigma -> @@ -2192,7 +2192,7 @@ let check_number_of_constructors expctdnumopt i nconstr = let constructor_tac with_evars expctdnumopt i lbind = Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in - let cl = Tacmach.New.pf_nf_concl gl in + let cl = Tacmach.New.pf_concl gl in let reduce_to_quantified_ind = Tacmach.New.pf_apply Tacred.reduce_to_quantified_ind gl in @@ -2231,7 +2231,7 @@ let any_constructor with_evars tacopt = let t = match tacopt with None -> Proofview.tclUNIT () | Some t -> t in let tac i = Tacticals.New.tclTHEN (constructor_tac with_evars None i NoBindings) t in Proofview.Goal.enter { enter = begin fun gl -> - let cl = Tacmach.New.pf_nf_concl gl in + let cl = Tacmach.New.pf_concl gl in let reduce_to_quantified_ind = Tacmach.New.pf_apply Tacred.reduce_to_quantified_ind gl in @@ -2291,7 +2291,7 @@ let my_find_eq_data_decompose gl t = | Constr_matching.PatternMatchingFailure -> None let intro_decomp_eq loc l thin tac id = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let c = mkVar id in let t = Tacmach.New.pf_unsafe_type_of gl c in let _,t = Tacmach.New.pf_reduce_to_quantified_ind gl t in @@ -2702,7 +2702,7 @@ let mkletin_goal env sigma store with_eq dep (id,lastlhyp,ccl,c) ty = Sigma (mkNamedLetIn id c t x, sigma, p) let letin_tac with_eq id c ty occs = - Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let ccl = Proofview.Goal.concl gl in @@ -2719,7 +2719,7 @@ let letin_tac with_eq id c ty occs = end } let letin_pat_tac with_eq id c occs = - Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let ccl = Proofview.Goal.concl gl in @@ -2805,6 +2805,12 @@ let generalize_goal gl i ((occs,c,b),na as o) (cl,sigma) = 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 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 env = pf_env gl in let sign = pf_hyps gl in @@ -2849,10 +2855,10 @@ let generalize_dep ?(with_let = false) c = Proofview.V82.tactic (old_generalize_dep ~with_let c) (** *) -let generalize_gen_let lconstr = Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> +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 (Tacmach.New.of_old generalize_goal gl) 0 lconstr + List.fold_right_i (new_generalize_goal gl) 0 lconstr (Tacmach.New.pf_concl gl,Tacmach.New.project gl) in let (evd, _) = Typing.type_of env evd newcl in @@ -3618,14 +3624,15 @@ let is_defined_variable env id = env |> lookup_named id |> is_local_def let abstract_args gl generalize_vars dep id defined f args = + let open Tacmach.New in let open Context.Rel.Declaration in - let sigma = ref (Tacmach.project gl) in - let env = Tacmach.pf_env gl in - let concl = Tacmach.pf_concl gl in + let sigma = ref (Tacmach.New.project gl) in + let env = Tacmach.New.pf_env gl in + let concl = Tacmach.New.pf_concl gl in let dep = dep || local_occur_var !sigma id concl in let avoid = ref [] in let get_id name = - let id = fresh_id !avoid (match name with Name n -> n | Anonymous -> Id.of_string "gen_x") gl in + let id = new_fresh_id !avoid (match name with Name n -> n | Anonymous -> Id.of_string "gen_x") gl in avoid := id :: !avoid; id in (* Build application generalized w.r.t. the argument plus the necessary eqs. @@ -3640,7 +3647,7 @@ let abstract_args gl generalize_vars dep id defined f args = let decl = List.hd rel in RelDecl.get_name decl, RelDecl.get_type decl, c in - let argty = Tacmach.pf_unsafe_type_of gl arg in + let argty = Tacmach.New.pf_unsafe_type_of gl arg in let sigma', ty = Evarsolve.refresh_universes (Some true) env !sigma ty in let () = sigma := sigma' in let lenctx = List.length ctx in @@ -3681,7 +3688,7 @@ let abstract_args gl generalize_vars dep id defined f args = true, mkApp (f', before), after in if dogen then - let tyf' = Tacmach.pf_unsafe_type_of gl f' in + let tyf' = Tacmach.New.pf_unsafe_type_of gl f' in let arity, ctx, ctxenv, c', args, eqs, refls, nogen, vars, env = Array.fold_left aux (tyf',[],env,f',[],[],[],Id.Set.empty,Id.Set.empty,env) args' in @@ -3689,14 +3696,14 @@ let abstract_args gl generalize_vars dep id defined f args = let vars = if generalize_vars then let nogen = Id.Set.add id nogen in - hyps_of_vars (pf_env gl) (project gl) (pf_hyps gl) nogen vars + hyps_of_vars (pf_env gl) (project gl) (Proofview.Goal.hyps gl) nogen vars else [] in let body, c' = if defined then Some c', Retyping.get_type_of ctxenv !sigma c' else None, c' in - let typ = Tacmach.pf_get_hyp_typ gl id in + let typ = Tacmach.New.pf_get_hyp_typ id gl in let tac = make_abstract_generalize (pf_env gl) id typ concl dep ctx body c' eqs args refls in let tac = Proofview.Unsafe.tclEVARS !sigma <*> tac in Some (tac, dep, succ (List.length ctx), vars) @@ -3704,7 +3711,7 @@ let abstract_args gl generalize_vars dep id defined f args = let abstract_generalize ?(generalize_vars=true) ?(force_dep=false) id = let open Context.Named.Declaration in - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> Coqlib.check_required_library Coqlib.jmeq_module_name; let sigma = Tacmach.New.project gl in let (f, args, def, id, oldid) = @@ -3719,7 +3726,7 @@ let abstract_generalize ?(generalize_vars=true) ?(force_dep=false) id = if List.is_empty args then Proofview.tclUNIT () else let args = Array.of_list args in - let newc = Tacmach.New.of_old (fun gl -> abstract_args gl generalize_vars force_dep id def f args) gl in + let newc = abstract_args gl generalize_vars force_dep id def f args in match newc with | None -> Proofview.tclUNIT () | Some (tac, dep, n, vars) -> @@ -3799,7 +3806,7 @@ let specialize_eqs id gl = else tclFAIL 0 (str "Nothing to do in hypothesis " ++ pr_id id) gl -let specialize_eqs id = Proofview.Goal.nf_enter { enter = begin fun gl -> +let specialize_eqs id = Proofview.Goal.enter { enter = begin fun gl -> let msg = str "Specialization not allowed on dependent hypotheses" in Proofview.tclOR (clear [id]) (fun _ -> Tacticals.New.tclZEROMSG msg) >>= fun () -> @@ -4123,7 +4130,7 @@ let recolle_clenv i params args elimclause gl = (* from_n (Some 0) means that x should be taken "as is" without trying to unify (which would lead to trying to apply it to evars if y is a product). *) - let indclause = Tacmach.New.of_old (fun gl -> mk_clenv_from_n gl (Some 0) (x,y)) gl in + let indclause = mk_clenv_from_n gl (Some 0) (x,y) in let elimclause' = clenv_fchain ~with_univs:false i acc indclause in elimclause') (List.rev clauses) @@ -4134,18 +4141,18 @@ let recolle_clenv i params args elimclause gl = produce new ones). Then refine with the resulting term with holes. *) let induction_tac with_evars params indvars elim = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let sigma = Tacmach.New.project gl in let ({elimindex=i;elimbody=(elimc,lbindelimc);elimrename=rename},elimt) = elim in let i = match i with None -> index_of_ind_arg sigma elimt | Some i -> i in (* elimclause contains this: (elimc ?i ?j ?k...?l) *) let elimc = contract_letin_in_lam_header sigma elimc in let elimc = mkCast (elimc, DEFAULTcast, elimt) in - let elimclause = pf_apply make_clenv_binding gl (elimc,elimt) lbindelimc in + let elimclause = Tacmach.New.pf_apply make_clenv_binding gl (elimc,elimt) lbindelimc in (* elimclause' is built from elimclause by instanciating all args and params. *) let elimclause' = recolle_clenv i params indvars elimclause gl in (* one last resolution (useless?) *) - let resolved = Tacmach.New.of_old (clenv_unique_resolver ~flags:(elim_flags ()) elimclause') gl in + let resolved = clenv_unique_resolver ~flags:(elim_flags ()) elimclause' gl in enforce_prop_bound_names rename (Clenvtac.clenv_refine with_evars resolved) end } @@ -4158,7 +4165,7 @@ let apply_induction_in_context with_evars hyp0 inhyps elim indvars names induct_ let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in let sigma = Sigma.to_evar_map sigma in - let concl = Tacmach.New.pf_nf_concl gl in + let concl = Tacmach.New.pf_concl gl in let statuslists,lhyp0,toclear,deps,avoid,dep_in_hyps = cook_sign hyp0 inhyps indvars env sigma in let dep_in_concl = Option.cata (fun id -> occur_var env sigma id concl) false hyp0 in let dep = dep_in_hyps || dep_in_concl in @@ -4212,7 +4219,7 @@ let msg_not_right_number_induction_arguments scheme = must be given, so we help a bit the unifier by making the "pattern" by hand before calling induction_tac *) let induction_without_atomization isrec with_evars elim names lid = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let sigma, (indsign,scheme) = get_elim_signature elim (List.hd lid) gl in let nargs_indarg_farg = scheme.nargs + (if scheme.farg_in_concl then 1 else 0) in @@ -4247,7 +4254,7 @@ let induction_without_atomization isrec with_evars elim names lid = (* assume that no occurrences are selected *) let clear_unselected_context id inhyps cls = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> if occur_var (Tacmach.New.pf_env gl) (Tacmach.New.project gl) id (Tacmach.New.pf_concl gl) && cls.concl_occs == NoOccurrences then user_err @@ -4493,7 +4500,7 @@ let induction_destruct isrec with_evars (lc,elim) = match lc with | [] -> assert false (* ensured by syntax, but if called inside caml? *) | [c,(eqname,names as allnames),cls] -> - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Tacmach.New.project gl in match elim with @@ -4594,8 +4601,8 @@ let simple_destruct = function *) let elim_scheme_type elim t = - Proofview.Goal.nf_enter { enter = begin fun gl -> - let clause = Tacmach.New.of_old (fun gl -> mk_clenv_type_of gl elim) gl in + Proofview.Goal.enter { enter = begin fun gl -> + let clause = mk_clenv_type_of gl elim in match EConstr.kind clause.evd (last_arg clause.evd clause.templval.rebus) with | Meta mv -> let clause' = @@ -4634,7 +4641,7 @@ let case_type t = let (forward_setoid_reflexivity, setoid_reflexivity) = Hook.make () let maybe_betadeltaiota_concl allowred gl = - let concl = Tacmach.New.pf_nf_concl gl in + let concl = Tacmach.New.pf_concl gl in let sigma = Tacmach.New.project gl in if not allowred then concl else @@ -4891,7 +4898,7 @@ let abstract_subproof id gk tac = let open Tacticals.New in let open Tacmach.New in let open Proofview.Notations in - Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let current_sign = Global.named_context_val () and global_sign = Proofview.Goal.hyps gl in @@ -4980,7 +4987,7 @@ let tclABSTRACT name_op tac = abstract_subproof s gk tac let unify ?(state=full_transparent_state) x y = - Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in try let core_flags = diff --git a/tactics/tactics.mli b/tactics/tactics.mli index 0087d607db..67e29cf568 100644 --- a/tactics/tactics.mli +++ b/tactics/tactics.mli @@ -29,7 +29,7 @@ open Locus (** {6 General functions. } *) -val is_quantified_hypothesis : Id.t -> ([`NF],'b) Proofview.Goal.t -> bool +val is_quantified_hypothesis : Id.t -> ('a, 'r) Proofview.Goal.t -> bool (** {6 Primitive tactics. } *) @@ -75,7 +75,7 @@ val intros : unit Proofview.tactic (** [depth_of_quantified_hypothesis b h g] returns the index of [h] in the conclusion of goal [g], up to head-reduction if [b] is [true] *) val depth_of_quantified_hypothesis : - bool -> quantified_hypothesis -> ([`NF],'b) Proofview.Goal.t -> int + bool -> quantified_hypothesis -> ('a, 'r) Proofview.Goal.t -> int val intros_until : quantified_hypothesis -> unit Proofview.tactic -- cgit v1.2.3 From 594ac9654164e377e8598894019cc4445509d570 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 17 Dec 2016 18:36:59 +0100 Subject: Removing a subtle nf_enter in Class_tactics. The underlying hint mode implementation was not using the evar-insensitive API so that it resulted in strange bugs. --- tactics/class_tactics.ml | 2 +- tactics/hints.ml | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) (limited to 'tactics') diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 8ada9e6a71..8bbef39ad5 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -1180,7 +1180,7 @@ module Search = struct let search_tac ?(st=full_transparent_state) only_classes dep hints depth = let open Proofview in let tac sigma gls i = - Goal.nf_enter + Goal.enter { enter = fun gl -> search_tac_gl ~st only_classes dep hints depth (succ i) sigma gls gl } in diff --git a/tactics/hints.ml b/tactics/hints.ml index 17c81064d7..5aacafd6fa 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -524,8 +524,8 @@ struct match m with | ModeInput -> not (occur_existential sigma arg) | ModeNoHeadEvar -> - Evarutil.(try ignore(head_evar sigma arg); false - with NoHeadEvar -> true) + (try ignore(head_evar sigma arg); false + with Evarutil.NoHeadEvar -> true) | ModeOutput -> true let matches_mode sigma args mode = -- cgit v1.2.3 From 5db9588098f9f02d923c21f3914e3c671b10728f Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Tue, 24 Jan 2017 13:07:11 +0100 Subject: Quick hack to fix interpretation of patterns in Ltac. Interpretation of patterns in Ltac is essentially flawed. It does a roundtrip through the pretyper, and relies on suspicious flagging of evars in the evar source field to recognize original pattern holes. After the pattern_of_constr function was made evar-insensitive, it expanded evars that were solved by magical side-effects of the pretyper, even if it hadn't been asked to perform any heuristics. We backtrack on the insensitivity of the pattern_of_constr function. This may have a performance penalty in other dubious code, e.g. hints. In the long run we should get rid of the pattern_of_constr function. --- tactics/hints.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'tactics') diff --git a/tactics/hints.ml b/tactics/hints.ml index 5aacafd6fa..a1c99c341e 100644 --- a/tactics/hints.ml +++ b/tactics/hints.ml @@ -763,7 +763,7 @@ let make_exact_entry env sigma pri poly ?(name=PathAny) (c, cty, ctx) = match EConstr.kind sigma cty with | Prod _ -> failwith "make_exact_entry" | _ -> - let pat = Patternops.pattern_of_constr env sigma cty in + let pat = Patternops.pattern_of_constr env sigma (EConstr.to_constr sigma cty) in let hd = try head_pattern_bound pat with BoundPattern -> failwith "make_exact_entry" @@ -784,7 +784,7 @@ let make_apply_entry env sigma (eapply,hnf,verbose) pri poly ?(name=PathAny) (c, let sigma' = Evd.merge_context_set univ_flexible sigma ctx in let ce = mk_clenv_from_env env sigma' None (c,cty) in let c' = clenv_type (* ~reduce:false *) ce in - let pat = Patternops.pattern_of_constr env ce.evd c' in + let pat = Patternops.pattern_of_constr env ce.evd (EConstr.to_constr sigma c') in let hd = try head_pattern_bound pat with BoundPattern -> failwith "make_apply_entry" in @@ -934,7 +934,7 @@ let make_trivial env sigma poly ?(name=PathAny) r = let ce = mk_clenv_from_env env sigma None (c,t) in (Some hd, { pri=1; poly = poly; - pat = Some (Patternops.pattern_of_constr env ce.evd (clenv_type ce)); + pat = Some (Patternops.pattern_of_constr env ce.evd (EConstr.to_constr sigma (clenv_type ce))); name = name; db = None; secvars = secvars_of_constr env sigma c; -- cgit v1.2.3 From 3df2431a80f9817ce051334cb9c3b1f465bffb60 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Fri, 31 Mar 2017 23:20:25 +0200 Subject: Actually exporting delayed universes in the EConstr implementation. For now we only normalize sorts, and we leave instances for the next commit. --- tactics/class_tactics.ml | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) (limited to 'tactics') diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index c53e47d928..7eadde78d5 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -512,7 +512,11 @@ let pr_depth l = prlist_with_sep (next_sep debug_seps) int (List.rev l) let is_Prop env sigma concl = let ty = Retyping.get_type_of env sigma concl in match EConstr.kind sigma ty with - | Sort (Prop Null) -> true + | Sort s -> + begin match ESorts.kind sigma s with + | Prop Null -> true + | _ -> false + end | _ -> false let is_unique env sigma concl = -- cgit v1.2.3 From 7babf0d42af11f5830bc157a671bd81b478a4f02 Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 1 Apr 2017 02:36:16 +0200 Subject: Using delayed universe instances in EConstr. The transition has been done a bit brutally. I think we can still save a lot of useless normalizations here and there by providing the right API in EConstr. Nonetheless, this is a first step. --- tactics/eauto.ml | 5 +++-- tactics/equality.ml | 9 ++++++--- tactics/hipattern.ml | 17 +++++++++-------- tactics/hipattern.mli | 8 ++++---- tactics/tacticals.ml | 11 +++++++---- tactics/tacticals.mli | 6 +++--- tactics/tactics.ml | 22 +++++++++++++--------- 7 files changed, 45 insertions(+), 33 deletions(-) (limited to 'tactics') diff --git a/tactics/eauto.ml b/tactics/eauto.ml index e0dff3739d..8d1e0e507a 100644 --- a/tactics/eauto.ml +++ b/tactics/eauto.ml @@ -472,8 +472,9 @@ let unfold_head env sigma (ids, csts) c = (match Environ.named_body id env with | Some b -> true, EConstr.of_constr b | None -> false, c) - | Const (cst,u as c) when Cset.mem cst csts -> - true, EConstr.of_constr (Environ.constant_value_in env c) + | Const (cst, u) when Cset.mem cst csts -> + let u = EInstance.kind sigma u in + true, EConstr.of_constr (Environ.constant_value_in env (cst, u)) | App (f, args) -> (match aux f with | true, f' -> true, Reductionops.whd_betaiota sigma (mkApp (f', args)) diff --git a/tactics/equality.ml b/tactics/equality.ml index 53b468bff7..7ae7446c82 100644 --- a/tactics/equality.ml +++ b/tactics/equality.ml @@ -746,6 +746,7 @@ let find_positions env sigma t1 t2 = let _,rargs2 = List.chop nparams args2 in let (mib,mip) = lookup_mind_specif env ind1 in let params1 = List.map EConstr.Unsafe.to_constr params1 in + let u1 = EInstance.kind sigma u1 in let ctxt = (get_constructor ((ind1,u1),mib,mip,params1) i1).cs_args in let adjust i = CVars.adjust_rel_to_rel_context ctxt (i+1) - 1 in List.flatten @@ -1324,19 +1325,19 @@ let inject_if_homogenous_dependent_pair ty = hd2,ar2 = decompose_app_vect sigma t2 in if not (Termops.is_global sigma (existTconstr()) hd1) then raise Exit; if not (Termops.is_global sigma (existTconstr()) hd2) then raise Exit; - let ind,_ = try pf_apply find_mrectype gl ar1.(0) with Not_found -> raise Exit in + let (ind, _), _ = try pf_apply find_mrectype gl ar1.(0) with Not_found -> raise Exit in (* check if the user has declared the dec principle *) (* and compare the fst arguments of the dep pair *) (* Note: should work even if not an inductive type, but the table only *) (* knows inductive types *) - if not (Ind_tables.check_scheme (!eq_dec_scheme_kind_name()) (fst ind) && + if not (Ind_tables.check_scheme (!eq_dec_scheme_kind_name()) ind && 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 = Coqlib.coq_constant "inj_pair2_eq_dec is missing" ["Logic";"Eqdep_dec"] "inj_pair2_eq_dec" in let inj2 = EConstr.of_constr inj2 in - let c, eff = find_scheme (!eq_dec_scheme_kind_name()) (Univ.out_punivs ind) 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; @@ -1783,6 +1784,7 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () = let select_equation_name decl = try let lbeq,u,(_,x,y) = find_eq_data_decompose (NamedDecl.get_type decl) in + let u = EInstance.kind sigma u in let eq = Universes.constr_of_global_univ (lbeq.eq,u) in if flags.only_leibniz then restrict_to_eq_and_identity eq; match EConstr.kind sigma x, EConstr.kind sigma y with @@ -1834,6 +1836,7 @@ let subst_all ?(flags=default_subst_tactic_flags ()) () = let test (_,c) = try let lbeq,u,(_,x,y) = find_eq_data_decompose c in + let u = EInstance.kind sigma u in let eq = Universes.constr_of_global_univ (lbeq.eq,u) in if flags.only_leibniz then restrict_to_eq_and_identity eq; (* J.F.: added to prevent failure on goal containing x=x as an hyp *) diff --git a/tactics/hipattern.ml b/tactics/hipattern.ml index 8e4654c02b..851554b832 100644 --- a/tactics/hipattern.ml +++ b/tactics/hipattern.ml @@ -144,6 +144,7 @@ let match_with_tuple sigma t = let t = match_with_one_constructor sigma None false true t in Option.map (fun (hd,l) -> let ind = destInd sigma hd in + let ind = on_snd (fun u -> EInstance.kind sigma u) ind in let (mib,mip) = Global.lookup_pinductive ind in let isrec = mis_is_recursive (fst ind,mib,mip) in (hd,l,isrec)) t @@ -200,8 +201,8 @@ let is_disjunction ?(strict=false) ?(onlybinary=false) sigma t = let match_with_empty_type sigma t = let (hdapp,args) = decompose_app sigma t in match EConstr.kind sigma hdapp with - | Ind ind -> - let (mib,mip) = Global.lookup_pinductive ind in + | Ind (ind, _) -> + let (mib,mip) = Global.lookup_inductive ind in let nconstr = Array.length mip.mind_consnames in if Int.equal nconstr 0 then Some hdapp else None | _ -> None @@ -214,8 +215,8 @@ let is_empty_type sigma t = op2bool (match_with_empty_type sigma t) let match_with_unit_or_eq_type sigma t = let (hdapp,args) = decompose_app sigma t in match EConstr.kind sigma hdapp with - | Ind ind -> - let (mib,mip) = Global.lookup_pinductive ind in + | Ind (ind , _) -> + let (mib,mip) = Global.lookup_inductive ind in let constr_types = mip.mind_nf_lc in let nconstr = Array.length mip.mind_consnames in let zero_args c = Int.equal (nb_prod sigma (EConstr.of_constr c)) mib.mind_nparams in @@ -369,8 +370,8 @@ let is_forall_term sigma c = op2bool (match_with_forall_term sigma c) let match_with_nodep_ind sigma t = let (hdapp,args) = decompose_app sigma t in match EConstr.kind sigma hdapp with - | Ind ind -> - let (mib,mip) = Global.lookup_pinductive ind in + | Ind (ind, _) -> + let (mib,mip) = Global.lookup_inductive ind in if Array.length (mib.mind_packets)>1 then None else let nodep_constr c = has_nodep_prod_after mib.mind_nparams sigma (EConstr.of_constr c) in if Array.for_all nodep_constr mip.mind_nf_lc then @@ -387,8 +388,8 @@ let is_nodep_ind sigma t = op2bool (match_with_nodep_ind sigma t) let match_with_sigma_type sigma t = let (hdapp,args) = decompose_app sigma t in match EConstr.kind sigma hdapp with - | Ind ind -> - let (mib,mip) = Global.lookup_pinductive ind in + | Ind (ind, _) -> + let (mib,mip) = Global.lookup_inductive ind in if Int.equal (Array.length (mib.mind_packets)) 1 && (Int.equal mip.mind_nrealargs 0) && (Int.equal (Array.length mip.mind_consnames)1) && diff --git a/tactics/hipattern.mli b/tactics/hipattern.mli index c46817f505..dd09c3a4d7 100644 --- a/tactics/hipattern.mli +++ b/tactics/hipattern.mli @@ -122,19 +122,19 @@ val match_with_equation: (** Match terms [eq A t u], [identity A t u] or [JMeq A t A u] Returns associated lemmas and [A,t,u] or fails PatternMatchingFailure *) val find_eq_data_decompose : ('a, 'r) Proofview.Goal.t -> constr -> - coq_eq_data * Univ.universe_instance * (types * constr * constr) + coq_eq_data * EInstance.t * (types * constr * constr) (** Idem but fails with an error message instead of PatternMatchingFailure *) val find_this_eq_data_decompose : ('a, 'r) Proofview.Goal.t -> constr -> - coq_eq_data * Univ.universe_instance * (types * constr * constr) + coq_eq_data * EInstance.t * (types * constr * constr) (** A variant that returns more informative structure on the equality found *) -val find_eq_data : evar_map -> constr -> coq_eq_data * Univ.universe_instance * equation_kind +val find_eq_data : evar_map -> constr -> coq_eq_data * EInstance.t * equation_kind (** Match a term of the form [(existT A P t p)] Returns associated lemmas and [A,P,t,p] *) val find_sigma_data_decompose : evar_map -> constr -> - coq_sigma_data * (Univ.universe_instance * constr * constr * constr * constr) + coq_sigma_data * (EInstance.t * constr * constr * constr * constr) (** Match a term of the form [{x:A|P}], returns [A] and [P] *) val match_sigma : evar_map -> constr -> constr * constr diff --git a/tactics/tacticals.ml b/tactics/tacticals.ml index a1cd510475..90b7d6581a 100644 --- a/tactics/tacticals.ml +++ b/tactics/tacticals.ml @@ -606,6 +606,7 @@ module New = struct isrec allnames tac predicate ind (c, t) = Proofview.Goal.enter { enter = begin fun gl -> let sigma, elim = (mk_elim ind).enter gl in + let ind = on_snd (fun u -> EInstance.kind sigma u) ind in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS sigma) (Proofview.Goal.enter { enter = begin fun gl -> let indclause = mk_clenv_from gl (c, t) in @@ -680,17 +681,19 @@ module New = struct (sigma, EConstr.of_constr c) end } - let gl_make_case_dep ind = { enter = begin fun gl -> + let gl_make_case_dep (ind, u) = { enter = begin fun gl -> let sigma = Sigma.Unsafe.of_evar_map (project gl) in - let Sigma (r, sigma, _) = Indrec.build_case_analysis_scheme (pf_env gl) sigma ind true + let u = EInstance.kind (project gl) u in + let Sigma (r, sigma, _) = Indrec.build_case_analysis_scheme (pf_env gl) sigma (ind, u) true (elimination_sort_of_goal gl) in (Sigma.to_evar_map sigma, EConstr.of_constr r) end } - let gl_make_case_nodep ind = { enter = begin fun gl -> + let gl_make_case_nodep (ind, u) = { enter = begin fun gl -> let sigma = Sigma.Unsafe.of_evar_map (project gl) in - let Sigma (r, sigma, _) = Indrec.build_case_analysis_scheme (pf_env gl) sigma ind false + let u = EInstance.kind (project gl) u in + let Sigma (r, sigma, _) = Indrec.build_case_analysis_scheme (pf_env gl) sigma (ind, u) false (elimination_sort_of_goal gl) in (Sigma.to_evar_map sigma, EConstr.of_constr r) diff --git a/tactics/tacticals.mli b/tactics/tacticals.mli index 5839666a73..3b90ec514a 100644 --- a/tactics/tacticals.mli +++ b/tactics/tacticals.mli @@ -124,7 +124,7 @@ val fix_empty_or_and_pattern : int -> delayed_open_constr or_and_intro_pattern_expr -> delayed_open_constr or_and_intro_pattern_expr -val compute_constructor_signatures : rec_flag -> pinductive -> bool list array +val compute_constructor_signatures : rec_flag -> inductive * 'a -> bool list array (** Useful for [as intro_pattern] modifier *) val compute_induction_names : @@ -256,11 +256,11 @@ module New : sig val case_then_using : or_and_intro_pattern option -> (branch_args -> unit Proofview.tactic) -> - constr option -> pinductive -> constr * types -> unit Proofview.tactic + constr option -> inductive * EInstance.t -> constr * types -> unit Proofview.tactic val case_nodep_then_using : or_and_intro_pattern option -> (branch_args -> unit Proofview.tactic) -> - constr option -> pinductive -> constr * types -> unit Proofview.tactic + constr option -> inductive * EInstance.t -> constr * types -> unit Proofview.tactic 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 diff --git a/tactics/tactics.ml b/tactics/tactics.ml index 55d6df6596..8306ac1740 100644 --- a/tactics/tactics.ml +++ b/tactics/tactics.ml @@ -1445,6 +1445,7 @@ let general_case_analysis_in_context with_evars clear_flag (c,lbindc) = let t = Retyping.get_type_of env (Sigma.to_evar_map sigma) c in let (mind,_) = reduce_to_quantified_ind env (Sigma.to_evar_map sigma) t in let sort = Tacticals.New.elimination_sort_of_goal gl in + let mind = on_snd (fun u -> EInstance.kind (Sigma.to_evar_map sigma) u) mind in let Sigma (elim, sigma, p) = if occur_term (Sigma.to_evar_map sigma) c concl then build_case_analysis_scheme env sigma mind true sort @@ -1647,6 +1648,7 @@ let descend_in_conjunctions avoid tac (err, info) c = let elim = try DefinedRecord (Recordops.lookup_projections ind) with Not_found -> + let u = EInstance.kind sigma u in let sigma = Sigma.Unsafe.of_evar_map sigma in let Sigma (elim, _, _) = build_case_analysis_scheme env sigma (ind,u) false sort in let elim = EConstr.of_constr elim in @@ -2214,9 +2216,9 @@ let constructor_tac with_evars expctdnumopt i lbind = Array.length (snd (Global.lookup_inductive (fst mind))).mind_consnames in check_number_of_constructors expctdnumopt i nconstr; - let Sigma (cons, sigma, p) = Sigma.fresh_constructor_instance + let Sigma ((cons, u), sigma, p) = Sigma.fresh_constructor_instance (Proofview.Goal.env gl) sigma (fst mind, i) in - let cons = mkConstructU cons in + let cons = mkConstructU (cons, EInstance.make u) in let apply_tac = general_apply true false with_evars None (dloc,(cons,lbind)) in let tac = @@ -4033,24 +4035,25 @@ let compute_elim_signature (evd,(elimc,elimt),ind_type_guess) names_info = let guess_elim isrec dep s hyp0 gl = let tmptyp0 = Tacmach.New.pf_get_hyp_typ hyp0 gl in - let mind,_ = Tacmach.New.pf_reduce_to_quantified_ind gl tmptyp0 in + let (mind, u), _ = Tacmach.New.pf_reduce_to_quantified_ind gl tmptyp0 in let evd, elimc = - if isrec && not (is_nonrec (fst mind)) then find_ind_eliminator (fst mind) s gl + if isrec && not (is_nonrec mind) then find_ind_eliminator mind s gl else let env = Tacmach.New.pf_env gl in let sigma = Sigma.Unsafe.of_evar_map (Tacmach.New.project gl) in + let u = EInstance.kind (Tacmach.New.project gl) u in if use_dependent_propositions_elimination () && dep then - let Sigma (ind, sigma, _) = build_case_analysis_scheme env sigma mind true s in + let Sigma (ind, sigma, _) = build_case_analysis_scheme env sigma (mind, u) true s in let ind = EConstr.of_constr ind in (Sigma.to_evar_map sigma, ind) else - let Sigma (ind, sigma, _) = build_case_analysis_scheme_default env sigma mind s in + let Sigma (ind, sigma, _) = build_case_analysis_scheme_default env sigma (mind, u) s in let ind = EConstr.of_constr ind in (Sigma.to_evar_map sigma, ind) in let elimt = Tacmach.New.pf_unsafe_type_of gl elimc in - evd, ((elimc, NoBindings), elimt), mkIndU mind + evd, ((elimc, NoBindings), elimt), mkIndU (mind, u) let given_elim hyp0 (elimc,lbind as e) gl = let sigma = Tacmach.New.project gl in @@ -4637,9 +4640,10 @@ let case_type t = Proofview.Goal.s_enter { s_enter = begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Tacmach.New.pf_env gl in - let (ind,t) = reduce_to_atomic_ind env (Sigma.to_evar_map sigma) t in + let ((ind, u), t) = reduce_to_atomic_ind env (Sigma.to_evar_map sigma) t in + let u = EInstance.kind (Sigma.to_evar_map sigma) u in let s = Tacticals.New.elimination_sort_of_goal gl in - let Sigma (elimc, evd, p) = build_case_analysis_scheme_default env sigma ind s in + let Sigma (elimc, evd, p) = build_case_analysis_scheme_default env sigma (ind, u) s in let elimc = EConstr.of_constr elimc in Sigma (elim_scheme_type elimc t, evd, p) end } -- cgit v1.2.3 From 9d1230d484a2cf519f9cd76dc0f37815f3c6339b Mon Sep 17 00:00:00 2001 From: Pierre-Marie Pédrot Date: Sat, 8 Apr 2017 01:42:19 +0200 Subject: Fix a heuristic used by legacy typeclass resolution. The evarmap used by the heuristic could contain resolved evars, which could lead to a failure of backtracking in the EConstr branch. This is experimental and may be to costly. --- tactics/class_tactics.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) (limited to 'tactics') diff --git a/tactics/class_tactics.ml b/tactics/class_tactics.ml index 7eadde78d5..ea19660931 100644 --- a/tactics/class_tactics.ml +++ b/tactics/class_tactics.ml @@ -787,10 +787,10 @@ module V85 = struct let fk' = (fun e -> let do_backtrack = - if unique then occur_existential s' concl + if unique then occur_existential tacgl.sigma concl else if info.unique then true else if List.is_empty gls' then - needs_backtrack env s' info.is_evar concl + needs_backtrack env tacgl.sigma info.is_evar concl else true in let e' = match foundone with None -> e -- cgit v1.2.3