diff options
79 files changed, 998 insertions, 812 deletions
diff --git a/engine/eConstr.ml b/engine/eConstr.ml index 7bd708e31..9e0a55a0d 100644 --- a/engine/eConstr.ml +++ b/engine/eConstr.ml @@ -98,6 +98,7 @@ let mkCase (ci, c, r, p) = of_kind (Case (ci, c, r, p)) let mkFix f = of_kind (Fix f) let mkCoFix f = of_kind (CoFix f) let mkProj (p, c) = of_kind (Proj (p, c)) +let mkArrow t1 t2 = of_kind (Prod (Anonymous, t1, t2)) let applist (f, arg) = mkApp (f, Array.of_list arg) @@ -466,6 +467,11 @@ let eq_constr_nounivs sigma c1 c2 = in eq_constr (unsafe_to_constr c1) (unsafe_to_constr c2) +let compare_constr sigma cmp c1 c2 = + let kind c = kind_upto sigma c in + let cmp c1 c2 = cmp (of_constr c1) (of_constr c2) in + compare_gen kind (fun _ -> Univ.Instance.equal) Sorts.equal cmp (unsafe_to_constr c1) (unsafe_to_constr c2) + (** TODO: factorize with universes.ml *) let test_constr_universes sigma leq m n = let open Universes in @@ -608,6 +614,22 @@ let mkLambda_or_LetIn decl c = | LocalAssum (na,t) -> mkLambda (na, of_constr t, c) | LocalDef (na,b,t) -> mkLetIn (na, of_constr b, of_constr t, c) +let mkNamedProd id typ c = mkProd (Name id, typ, Vars.subst_var id c) +let mkNamedLambda id typ c = mkLambda (Name id, typ, Vars.subst_var id c) +let mkNamedLetIn id c1 t c2 = mkLetIn (Name id, c1, t, Vars.subst_var id c2) + +let mkNamedProd_or_LetIn decl c = + let open Context.Named.Declaration in + match decl with + | LocalAssum (id,t) -> mkNamedProd id (of_constr t) c + | LocalDef (id,b,t) -> mkNamedLetIn id (of_constr b) (of_constr t) c + +let mkNamedLambda_or_LetIn decl c = + let open Context.Named.Declaration in + match decl with + | LocalAssum (id,t) -> mkNamedLambda id (of_constr t) c + | LocalDef (id,b,t) -> mkNamedLetIn id (of_constr b) (of_constr t) c + let it_mkProd_or_LetIn t ctx = List.fold_left (fun c d -> mkProd_or_LetIn d c) t ctx let it_mkLambda_or_LetIn t ctx = List.fold_left (fun c d -> mkLambda_or_LetIn d c) t ctx diff --git a/engine/eConstr.mli b/engine/eConstr.mli index e4136a612..15463a8f6 100644 --- a/engine/eConstr.mli +++ b/engine/eConstr.mli @@ -73,6 +73,7 @@ val mkConstructU : pconstructor -> t val mkCase : case_info * t * t * t array -> t val mkFix : (t, t) pfixpoint -> t val mkCoFix : (t, t) pcofixpoint -> t +val mkArrow : t -> t -> t val applist : t * t list -> t @@ -81,6 +82,12 @@ val mkLambda_or_LetIn : Rel.Declaration.t -> t -> t val it_mkProd_or_LetIn : t -> Rel.t -> t val it_mkLambda_or_LetIn : t -> Rel.t -> t +val mkNamedLambda : Id.t -> types -> constr -> constr +val mkNamedLetIn : Id.t -> constr -> types -> constr -> constr +val mkNamedProd : Id.t -> types -> types -> types +val mkNamedLambda_or_LetIn : Named.Declaration.t -> types -> types +val mkNamedProd_or_LetIn : Named.Declaration.t -> types -> types + (** {6 Simple case analysis} *) val isRel : Evd.evar_map -> t -> bool @@ -141,6 +148,7 @@ val eq_constr_nounivs : Evd.evar_map -> t -> t -> bool val eq_constr_universes : Evd.evar_map -> t -> t -> Universes.universe_constraints option val leq_constr_universes : Evd.evar_map -> t -> t -> Universes.universe_constraints option val eq_constr_universes_proj : Environ.env -> Evd.evar_map -> t -> t -> Universes.universe_constraints option +val compare_constr : Evd.evar_map -> (t -> t -> bool) -> t -> t -> bool (** {6 Iterators} *) diff --git a/engine/evarutil.ml b/engine/evarutil.ml index 7ccf9d810..4f40499d0 100644 --- a/engine/evarutil.ml +++ b/engine/evarutil.ml @@ -367,6 +367,7 @@ let push_rel_decl_to_named_context decl (subst, vsubst, avoid, nc) = let push_rel_context_to_named_context env typ = (* compute the instances relative to the named context and rel_context *) let open Context.Named.Declaration in + let open EConstr in let ids = List.map get_id (named_context env) in let inst_vars = List.map mkVar ids in if List.is_empty (Environ.rel_context env) then @@ -421,6 +422,7 @@ let new_pure_evar sign evd ?(src=default_source) ?(filter = Filter.identity) ?ca Sigma.Unsafe.of_pair (newevk, evd) let new_evar_instance sign evd typ ?src ?filter ?candidates ?store ?naming ?principal instance = + let open EConstr in assert (not !Flags.debug || List.distinct (ids_of_named_context (named_context_of_val sign))); let Sigma (newevk, evd, p) = new_pure_evar sign evd ?src ?filter ?candidates ?store ?naming ?principal typ in diff --git a/engine/evarutil.mli b/engine/evarutil.mli index 431d98083..6620bbaed 100644 --- a/engine/evarutil.mli +++ b/engine/evarutil.mli @@ -24,7 +24,7 @@ val new_evar : env -> 'r Sigma.t -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> ?candidates:constr list -> ?store:Store.t -> ?naming:Misctypes.intro_pattern_naming_expr -> - ?principal:bool -> EConstr.types -> (constr, 'r) Sigma.sigma + ?principal:bool -> EConstr.types -> (EConstr.constr, 'r) Sigma.sigma val new_pure_evar : named_context_val -> 'r Sigma.t -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> @@ -39,18 +39,18 @@ val e_new_evar : env -> evar_map ref -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> ?candidates:constr list -> ?store:Store.t -> ?naming:Misctypes.intro_pattern_naming_expr -> - ?principal:bool -> EConstr.types -> constr + ?principal:bool -> EConstr.types -> EConstr.constr (** Create a new Type existential variable, as we keep track of them during type-checking and unification. *) val new_type_evar : env -> 'r Sigma.t -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> rigid -> - (constr * sorts, 'r) Sigma.sigma + (EConstr.constr * sorts, 'r) Sigma.sigma val e_new_type_evar : env -> evar_map ref -> ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> - ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> rigid -> constr * sorts + ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> rigid -> EConstr.constr * sorts val new_Type : ?rigid:rigid -> env -> 'r Sigma.t -> (constr, 'r) Sigma.sigma val e_new_Type : ?rigid:rigid -> env -> evar_map ref -> constr @@ -74,7 +74,7 @@ val new_evar_instance : ?src:Loc.t * Evar_kinds.t -> ?filter:Filter.t -> ?candidates:constr list -> ?store:Store.t -> ?naming:Misctypes.intro_pattern_naming_expr -> ?principal:bool -> - constr list -> (constr, 'r) Sigma.sigma + EConstr.constr list -> (EConstr.constr, 'r) Sigma.sigma val make_pure_subst : evar_info -> 'a array -> (Id.t * 'a) list @@ -218,7 +218,7 @@ val push_rel_decl_to_named_context : Context.Rel.Declaration.t -> ext_named_context -> ext_named_context val push_rel_context_to_named_context : Environ.env -> EConstr.types -> - named_context_val * EConstr.types * constr list * csubst * (identifier*EConstr.constr) list + named_context_val * EConstr.types * EConstr.constr list * csubst * (identifier*EConstr.constr) list val generalize_evar_over_rels : evar_map -> existential -> types * constr list diff --git a/engine/proofview.ml b/engine/proofview.ml index b0f6d463b..9adf94744 100644 --- a/engine/proofview.ml +++ b/engine/proofview.ml @@ -72,6 +72,7 @@ let dependent_init = | TCons (env, sigma, typ, t) -> let sigma = Sigma.Unsafe.of_evar_map sigma in let Sigma (econstr, sigma, _) = Evarutil.new_evar env sigma ~src ~store (EConstr.of_constr typ) in + let econstr = EConstr.Unsafe.to_constr econstr in let sigma = Sigma.to_evar_map sigma in let ret, { solution = sol; comb = comb } = aux (t sigma econstr) in let (gl, _) = Term.destEvar econstr in diff --git a/engine/termops.ml b/engine/termops.ml index 59dbb73f5..b7932665a 100644 --- a/engine/termops.ml +++ b/engine/termops.ml @@ -159,6 +159,7 @@ let print_env env = let rel_vect n m = Array.init m (fun i -> mkRel(n+m-i)) let rel_list n m = + let open EConstr in let rec reln l p = if p>m then l else reln (mkRel(n+p)::l) (p+1) in @@ -857,16 +858,18 @@ let base_sort_cmp pb s0 s1 = | _ -> false (* eq_constr extended with universe erasure *) -let compare_constr_univ f cv_pb t1 t2 = - match kind_of_term t1, kind_of_term t2 with +let compare_constr_univ sigma f cv_pb t1 t2 = + match EConstr.kind sigma t1, EConstr.kind sigma t2 with Sort s1, Sort s2 -> base_sort_cmp cv_pb s1 s2 | Prod (_,t1,c1), Prod (_,t2,c2) -> f Reduction.CONV t1 t2 && f cv_pb c1 c2 - | _ -> compare_constr (fun t1 t2 -> f Reduction.CONV t1 t2) t1 t2 + | _ -> EConstr.compare_constr sigma (fun t1 t2 -> f Reduction.CONV t1 t2) t1 t2 -let rec constr_cmp cv_pb t1 t2 = compare_constr_univ constr_cmp cv_pb t1 t2 +let constr_cmp sigma cv_pb t1 t2 = + let rec compare cv_pb t1 t2 = compare_constr_univ sigma compare cv_pb t1 t2 in + compare cv_pb t1 t2 -let eq_constr t1 t2 = constr_cmp Reduction.CONV t1 t2 +let eq_constr sigma t1 t2 = constr_cmp sigma Reduction.CONV t1 t2 (* App(c,[t1,...tn]) -> ([c,t1,...,tn-1],tn) App(c,[||]) -> ([],c) *) @@ -883,12 +886,12 @@ type subst = (Context.Rel.t * constr) Evar.Map.t exception CannotFilter -let filtering env cv_pb c1 c2 = +let filtering sigma env cv_pb c1 c2 = let evm = ref Evar.Map.empty in let define cv_pb e1 ev c1 = try let (e2,c2) = Evar.Map.find ev !evm in let shift = List.length e1 - List.length e2 in - if constr_cmp cv_pb c1 (lift shift c2) then () else raise CannotFilter + if constr_cmp sigma cv_pb (EConstr.of_constr c1) (EConstr.of_constr (lift shift c2)) then () else raise CannotFilter with Not_found -> evm := Evar.Map.add ev (e1,c1) !evm in @@ -909,8 +912,9 @@ let filtering env cv_pb c1 c2 = | _, Evar (ev,_) -> define cv_pb env ev c1 | Evar (ev,_), _ -> define cv_pb env ev c2 | _ -> - if compare_constr_univ - (fun pb c1 c2 -> aux env pb c1 c2; true) cv_pb c1 c2 then () + let inj = EConstr.Unsafe.to_constr in + if compare_constr_univ sigma + (fun pb c1 c2 -> aux env pb (inj c1) (inj c2); true) cv_pb (EConstr.of_constr c1) (EConstr.of_constr c2) then () else raise CannotFilter (* TODO: le reste des binders *) in diff --git a/engine/termops.mli b/engine/termops.mli index abc9caa98..7758a57ee 100644 --- a/engine/termops.mli +++ b/engine/termops.mli @@ -41,7 +41,7 @@ val lookup_rel_id : Id.t -> Context.Rel.t -> int * constr option * types [rel_vect n m] builds [|Rel (n+m);...;Rel(n+1)|] *) val rel_vect : int -> int -> constr array -val rel_list : int -> int -> constr list +val rel_list : int -> int -> EConstr.constr list (** iterators/destructors on terms *) val mkProd_or_LetIn : Context.Rel.Declaration.t -> types -> types @@ -160,10 +160,10 @@ val replace_term : Evd.evar_map -> EConstr.t -> EConstr.t -> EConstr.t -> constr (** Alternative term equalities *) val base_sort_cmp : Reduction.conv_pb -> sorts -> sorts -> bool -val compare_constr_univ : (Reduction.conv_pb -> constr -> constr -> bool) -> - Reduction.conv_pb -> constr -> constr -> bool -val constr_cmp : Reduction.conv_pb -> constr -> constr -> bool -val eq_constr : constr -> constr -> bool (* FIXME rename: erases universes*) +val compare_constr_univ : Evd.evar_map -> (Reduction.conv_pb -> EConstr.constr -> EConstr.constr -> bool) -> + Reduction.conv_pb -> EConstr.constr -> EConstr.constr -> bool +val constr_cmp : Evd.evar_map -> Reduction.conv_pb -> EConstr.constr -> EConstr.constr -> bool +val eq_constr : Evd.evar_map -> EConstr.constr -> EConstr.constr -> bool (* FIXME rename: erases universes*) val eta_reduce_head : constr -> constr @@ -185,7 +185,7 @@ exception CannotFilter Warning: Outer-kernel sort subtyping are taken into account: c1 has to be smaller than c2 wrt. sorts. *) type subst = (Context.Rel.t * constr) Evar.Map.t -val filtering : Context.Rel.t -> Reduction.conv_pb -> constr -> constr -> subst +val filtering : Evd.evar_map -> Context.Rel.t -> Reduction.conv_pb -> constr -> constr -> subst val decompose_prod_letin : Evd.evar_map -> EConstr.t -> int * Context.Rel.t * constr val align_prod_letin : Evd.evar_map -> EConstr.t -> EConstr.t -> Context.Rel.t * constr diff --git a/interp/stdarg.mli b/interp/stdarg.mli index af3a73462..3047d2bce 100644 --- a/interp/stdarg.mli +++ b/interp/stdarg.mli @@ -57,12 +57,12 @@ val wit_open_constr : val wit_constr_with_bindings : (constr_expr with_bindings, glob_constr_and_expr with_bindings, - constr with_bindings delayed_open) genarg_type + EConstr.constr with_bindings delayed_open) genarg_type val wit_bindings : (constr_expr bindings, glob_constr_and_expr bindings, - constr bindings delayed_open) genarg_type + EConstr.constr bindings delayed_open) genarg_type val wit_red_expr : ((constr_expr,reference or_by_notation,constr_expr) red_expr_gen, diff --git a/intf/tactypes.mli b/intf/tactypes.mli index b96cb67df..02cfc44e2 100644 --- a/intf/tactypes.mli +++ b/intf/tactypes.mli @@ -26,8 +26,8 @@ type glob_constr_pattern_and_expr = Id.Set.t * glob_constr_and_expr * constr_pat type 'a delayed_open = { delayed : 'r. Environ.env -> 'r Sigma.t -> ('a, 'r) Sigma.sigma } -type delayed_open_constr = Term.constr delayed_open -type delayed_open_constr_with_bindings = Term.constr with_bindings delayed_open +type delayed_open_constr = EConstr.constr delayed_open +type delayed_open_constr_with_bindings = EConstr.constr with_bindings delayed_open type intro_pattern = delayed_open_constr intro_pattern_expr located type intro_patterns = delayed_open_constr intro_pattern_expr located list diff --git a/ltac/coretactics.ml4 b/ltac/coretactics.ml4 index 28ff6df83..20d9640fc 100644 --- a/ltac/coretactics.ml4 +++ b/ltac/coretactics.ml4 @@ -27,7 +27,7 @@ TACTIC EXTEND reflexivity END TACTIC EXTEND exact - [ "exact" casted_constr(c) ] -> [ Tactics.exact_no_check c ] + [ "exact" casted_constr(c) ] -> [ Tactics.exact_no_check (EConstr.of_constr c) ] END TACTIC EXTEND assumption @@ -39,35 +39,35 @@ TACTIC EXTEND etransitivity END TACTIC EXTEND cut - [ "cut" constr(c) ] -> [ Tactics.cut c ] + [ "cut" constr(c) ] -> [ Tactics.cut (EConstr.of_constr c) ] END TACTIC EXTEND exact_no_check - [ "exact_no_check" constr(c) ] -> [ Tactics.exact_no_check c ] + [ "exact_no_check" constr(c) ] -> [ Tactics.exact_no_check (EConstr.of_constr c) ] END TACTIC EXTEND vm_cast_no_check - [ "vm_cast_no_check" constr(c) ] -> [ Tactics.vm_cast_no_check c ] + [ "vm_cast_no_check" constr(c) ] -> [ Tactics.vm_cast_no_check (EConstr.of_constr c) ] END TACTIC EXTEND native_cast_no_check - [ "native_cast_no_check" constr(c) ] -> [ Tactics.native_cast_no_check c ] + [ "native_cast_no_check" constr(c) ] -> [ Tactics.native_cast_no_check (EConstr.of_constr c) ] END TACTIC EXTEND casetype - [ "casetype" constr(c) ] -> [ Tactics.case_type c ] + [ "casetype" constr(c) ] -> [ Tactics.case_type (EConstr.of_constr c) ] END TACTIC EXTEND elimtype - [ "elimtype" constr(c) ] -> [ Tactics.elim_type c ] + [ "elimtype" constr(c) ] -> [ Tactics.elim_type (EConstr.of_constr c) ] END TACTIC EXTEND lapply - [ "lapply" constr(c) ] -> [ Tactics.cut_and_apply c ] + [ "lapply" constr(c) ] -> [ Tactics.cut_and_apply (EConstr.of_constr c) ] END TACTIC EXTEND transitivity - [ "transitivity" constr(c) ] -> [ Tactics.intros_transitivity (Some c) ] + [ "transitivity" constr(c) ] -> [ Tactics.intros_transitivity (Some (EConstr.of_constr c)) ] END (** Left *) @@ -297,7 +297,7 @@ END (* Generalize dependent *) TACTIC EXTEND generalize_dependent - [ "generalize" "dependent" constr(c) ] -> [ Tactics.generalize_dep c ] + [ "generalize" "dependent" constr(c) ] -> [ Tactics.generalize_dep (EConstr.of_constr c) ] END (* Table of "pervasives" macros tactics (e.g. auto, simpl, etc.) *) diff --git a/ltac/extratactics.ml4 b/ltac/extratactics.ml4 index 3e7cf5d13..c39b1a0e9 100644 --- a/ltac/extratactics.ml4 +++ b/ltac/extratactics.ml4 @@ -118,7 +118,7 @@ END let discrHyp id = Proofview.tclEVARMAP >>= fun sigma -> - discr_main { delayed = fun env sigma -> Sigma.here (Term.mkVar id, NoBindings) sigma } + discr_main { delayed = fun env sigma -> Sigma.here (EConstr.mkVar id, NoBindings) sigma } let injection_main with_evars c = elimOnConstrWithHoles (injClause None) with_evars c @@ -150,7 +150,7 @@ END let injHyp id = Proofview.tclEVARMAP >>= fun sigma -> - injection_main false { delayed = fun env sigma -> Sigma.here (Term.mkVar id, NoBindings) sigma } + injection_main false { delayed = fun env sigma -> Sigma.here (EConstr.mkVar id, NoBindings) sigma } TACTIC EXTEND dependent_rewrite | [ "dependent" "rewrite" orient(b) constr(c) ] -> [ rewriteInConcl b c ] @@ -301,6 +301,7 @@ let project_hint pri l2r r = let t = Retyping.get_type_of env sigma (EConstr.of_constr c) in let t = Tacred.reduce_to_quantified_ref env sigma (Lazy.force coq_iff_ref) (EConstr.of_constr t) in + let t = EConstr.Unsafe.to_constr t in let sign,ccl = decompose_prod_assum t in let (a,b) = match snd (decompose_app ccl) with | [a;b] -> (a,b) @@ -475,6 +476,7 @@ let transitivity_left_table = Summary.ref [] ~name:"transitivity-steps-l" let step left x tac = let l = List.map (fun lem -> + let lem = EConstr.of_constr lem in Tacticals.New.tclTHENLAST (apply_with_bindings (lem, ImplicitBindings [x])) tac) @@ -510,13 +512,13 @@ let add_transitivity_lemma left lem = (* Vernacular syntax *) TACTIC EXTEND stepl -| ["stepl" constr(c) "by" tactic(tac) ] -> [ step true c (Tacinterp.tactic_of_value ist tac) ] -| ["stepl" constr(c) ] -> [ step true c (Proofview.tclUNIT ()) ] +| ["stepl" constr(c) "by" tactic(tac) ] -> [ step true (EConstr.of_constr c) (Tacinterp.tactic_of_value ist tac) ] +| ["stepl" constr(c) ] -> [ step true (EConstr.of_constr c) (Proofview.tclUNIT ()) ] END TACTIC EXTEND stepr -| ["stepr" constr(c) "by" tactic(tac) ] -> [ step false c (Tacinterp.tactic_of_value ist tac) ] -| ["stepr" constr(c) ] -> [ step false c (Proofview.tclUNIT ()) ] +| ["stepr" constr(c) "by" tactic(tac) ] -> [ step false (EConstr.of_constr c) (Tacinterp.tactic_of_value ist tac) ] +| ["stepr" constr(c) ] -> [ step false (EConstr.of_constr c) (Proofview.tclUNIT ()) ] END VERNAC COMMAND EXTEND AddStepl CLASSIFIED AS SIDEFF @@ -660,7 +662,7 @@ let hResolve id c occ t = let sigma = Evd.merge_universe_context sigma ctx in let t_constr_type = Retyping.get_type_of env sigma (EConstr.of_constr t_constr) in let tac = - (change_concl (mkLetIn (Anonymous,t_constr,t_constr_type,concl))) + (change_concl (EConstr.of_constr (mkLetIn (Anonymous,t_constr,t_constr_type,concl)))) in Sigma.Unsafe.of_pair (tac, sigma) end } @@ -694,7 +696,7 @@ let hget_evar n = if n <= 0 then error "Incorrect existential variable index."; let ev = List.nth evl (n-1) in let ev_type = existential_type sigma ev in - change_concl (mkLetIn (Anonymous,mkEvar ev,ev_type,concl)) + change_concl (EConstr.of_constr (mkLetIn (Anonymous,mkEvar ev,ev_type,concl))) end } TACTIC EXTEND hget_evar @@ -736,15 +738,16 @@ let mkCaseEq a : unit Proofview.tactic = Proofview.Goal.nf_enter { enter = begin fun gl -> let type_of_a = Tacmach.New.of_old (fun g -> Tacmach.pf_unsafe_type_of g (EConstr.of_constr a)) gl in Tacticals.New.tclTHENLIST - [Tactics.generalize [mkApp(delayed_force refl_equal, [| type_of_a; a|])]; + [Tactics.generalize [EConstr.of_constr (mkApp(delayed_force refl_equal, [| type_of_a; a|]))]; Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in let env = Proofview.Goal.env gl in (** FIXME: this looks really wrong. Does anybody really use this tactic? *) let Sigma (c, _, _) = (Tacred.pattern_occs [Locus.OnlyOccurrences [1], EConstr.of_constr a]).Reductionops.e_redfun env (Sigma.Unsafe.of_evar_map Evd.empty) (EConstr.of_constr concl) in + let c = EConstr.of_constr c in change_concl c end }; - simplest_case a] + simplest_case (EConstr.of_constr a)] end } diff --git a/ltac/g_auto.ml4 b/ltac/g_auto.ml4 index 82ba63871..c6395d7e2 100644 --- a/ltac/g_auto.ml4 +++ b/ltac/g_auto.ml4 @@ -48,7 +48,11 @@ let eval_uconstrs ist cs = fail_evar = false; expand_evars = true } in - List.map (fun c -> Pretyping.type_uconstr ~flags ist c) cs + let map c = { delayed = fun env sigma -> + let Sigma.Sigma (c, sigma, p) = c.delayed env sigma in + Sigma.Sigma (EConstr.of_constr c, sigma, p) + } in + List.map (fun c -> map (Pretyping.type_uconstr ~flags ist c)) cs let pr_auto_using _ _ _ = Pptactic.pr_auto_using (fun _ -> mt ()) @@ -153,7 +157,7 @@ TACTIC EXTEND autounfoldify END TACTIC EXTEND unify -| ["unify" constr(x) constr(y) ] -> [ Tactics.unify x y ] +| ["unify" constr(x) constr(y) ] -> [ Tactics.unify (EConstr.of_constr x) (EConstr.of_constr y) ] | ["unify" constr(x) constr(y) "with" preident(base) ] -> [ let table = try Some (Hints.searchtable_map base) with Not_found -> None in match table with @@ -162,13 +166,13 @@ TACTIC EXTEND unify Tacticals.New.tclZEROMSG msg | Some t -> let state = Hints.Hint_db.transparent_state t in - Tactics.unify ~state x y + Tactics.unify ~state (EConstr.of_constr x) (EConstr.of_constr y) ] END TACTIC EXTEND convert_concl_no_check -| ["convert_concl_no_check" constr(x) ] -> [ Tactics.convert_concl_no_check x Term.DEFAULTcast ] +| ["convert_concl_no_check" constr(x) ] -> [ Tactics.convert_concl_no_check (EConstr.of_constr x) Term.DEFAULTcast ] END let pr_hints_path_atom _ _ _ = Hints.pp_hints_path_atom diff --git a/ltac/g_rewrite.ml4 b/ltac/g_rewrite.ml4 index b1c4f58eb..bae5a516c 100644 --- a/ltac/g_rewrite.ml4 +++ b/ltac/g_rewrite.ml4 @@ -265,7 +265,7 @@ TACTIC EXTEND setoid_reflexivity END TACTIC EXTEND setoid_transitivity - [ "setoid_transitivity" constr(t) ] -> [ setoid_transitivity (Some t) ] + [ "setoid_transitivity" constr(t) ] -> [ setoid_transitivity (Some (EConstr.of_constr t)) ] | [ "setoid_etransitivity" ] -> [ setoid_transitivity None ] END diff --git a/ltac/pptactic.ml b/ltac/pptactic.ml index 6230fa060..934830f4d 100644 --- a/ltac/pptactic.ml +++ b/ltac/pptactic.ml @@ -1158,11 +1158,12 @@ module Make let pr_glob_tactic env = pr_glob_tactic_level env ltop let strip_prod_binders_constr n ty = + let ty = EConstr.Unsafe.to_constr ty in let rec strip_ty acc n ty = - if n=0 then (List.rev acc, ty) else + if n=0 then (List.rev acc, EConstr.of_constr ty) else match Term.kind_of_term ty with Term.Prod(na,a,b) -> - strip_ty (([Loc.ghost,na],a)::acc) (n-1) b + strip_ty (([Loc.ghost,na],EConstr.of_constr a)::acc) (n-1) b | _ -> error "Cannot translate fix tactic: not enough products" in strip_ty [] n ty @@ -1170,9 +1171,9 @@ module Make let prtac n (t:atomic_tactic_expr) = let pr = { pr_tactic = (fun _ _ -> str "<tactic>"); - pr_constr = pr_constr_env env Evd.empty; + pr_constr = (fun c -> pr_constr_env env Evd.empty (EConstr.Unsafe.to_constr c)); pr_dconstr = pr_and_constr_expr (pr_glob_constr_env env); - pr_lconstr = pr_lconstr_env env Evd.empty; + pr_lconstr = (fun c -> pr_lconstr_env env Evd.empty (EConstr.Unsafe.to_constr c)); pr_pattern = pr_constr_pattern_env env Evd.empty; pr_lpattern = pr_lconstr_pattern_env env Evd.empty; pr_constant = pr_evaluable_reference_env env; @@ -1284,7 +1285,7 @@ let () = wit_intro_pattern (Miscprint.pr_intro_pattern pr_constr_expr) (Miscprint.pr_intro_pattern (fun (c,_) -> pr_glob_constr c)) - (Miscprint.pr_intro_pattern (fun c -> pr_constr (fst (run_delayed c)))); + (Miscprint.pr_intro_pattern (fun c -> pr_constr (EConstr.Unsafe.to_constr (fst (run_delayed c))))); Genprint.register_print0 wit_clause_dft_concl (pr_clauses (Some true) pr_lident) @@ -1317,15 +1318,15 @@ let () = Genprint.register_print0 wit_bindings (pr_bindings_no_with pr_constr_expr pr_lconstr_expr) (pr_bindings_no_with (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr)) - (fun it -> pr_bindings_no_with pr_constr pr_lconstr (fst (run_delayed it))); + (fun it -> pr_bindings_no_with (EConstr.Unsafe.to_constr %> pr_constr) (EConstr.Unsafe.to_constr %> pr_lconstr) (fst (run_delayed it))); Genprint.register_print0 wit_constr_with_bindings (pr_with_bindings pr_constr_expr pr_lconstr_expr) (pr_with_bindings (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr)) - (fun it -> pr_with_bindings pr_constr pr_lconstr (fst (run_delayed it))); + (fun it -> pr_with_bindings (EConstr.Unsafe.to_constr %> pr_constr) (EConstr.Unsafe.to_constr %> pr_lconstr) (fst (run_delayed it))); Genprint.register_print0 Tacarg.wit_destruction_arg (pr_destruction_arg pr_constr_expr pr_lconstr_expr) (pr_destruction_arg (pr_and_constr_expr pr_glob_constr) (pr_and_constr_expr pr_lglob_constr)) - (fun it -> pr_destruction_arg pr_constr pr_lconstr (run_delayed_destruction_arg it)); + (fun it -> pr_destruction_arg (EConstr.Unsafe.to_constr %> pr_constr) (EConstr.Unsafe.to_constr %> pr_lconstr) (run_delayed_destruction_arg it)); Genprint.register_print0 Stdarg.wit_int int int int; Genprint.register_print0 Stdarg.wit_bool pr_bool pr_bool pr_bool; Genprint.register_print0 Stdarg.wit_unit pr_unit pr_unit pr_unit; diff --git a/ltac/rewrite.ml b/ltac/rewrite.ml index 52cf1ff35..ef2ab0917 100644 --- a/ltac/rewrite.ml +++ b/ltac/rewrite.ml @@ -97,8 +97,8 @@ let new_cstr_evar (evd,cstrs) env t = let evd = Sigma.Unsafe.of_evar_map evd in let Sigma (t, evd', _) = Evarutil.new_evar ~store:s env evd (EConstr.of_constr t) in let evd' = Sigma.to_evar_map evd' in - let ev, _ = destEvar t in - (evd', Evar.Set.add ev cstrs), t + let ev, _ = EConstr.destEvar evd' t in + (evd', Evar.Set.add ev cstrs), EConstr.Unsafe.to_constr t (** Building or looking up instances. *) let e_new_cstr_evar env evars t = @@ -363,6 +363,7 @@ end) = struct let env' = Environ.push_rel_context rels env in let sigma = Sigma.Unsafe.of_evar_map sigma in let Sigma ((evar, _), evars, _) = Evarutil.new_type_evar env' sigma Evd.univ_flexible in + let evar = EConstr.Unsafe.to_constr evar in let evars = Sigma.to_evar_map evars in let evars, inst = app_poly env (evars,Evar.Set.empty) @@ -774,7 +775,7 @@ let poly_subrelation sort = if sort then PropGlobal.subrelation else TypeGlobal.subrelation let resolve_subrelation env avoid car rel sort prf rel' res = - if eq_constr rel rel' then res + if Termops.eq_constr (fst res.rew_evars) (EConstr.of_constr rel) (EConstr.of_constr rel') then res else let evars, app = app_poly_check env res.rew_evars (poly_subrelation sort) [|car; rel; rel'|] in let evars, subrel = new_cstr_evar evars env app in @@ -872,7 +873,7 @@ let apply_rule unify loccs : int pure_strategy = | Some rew -> let occ = succ occ in if not (is_occ occ) then (occ, Fail) - else if eq_constr t rew.rew_to then (occ, Identity) + else if Termops.eq_constr (fst rew.rew_evars) (EConstr.of_constr t) (EConstr.of_constr rew.rew_to) then (occ, Identity) else let res = { rew with rew_car = ty } in let rel, prf = get_rew_prf res in @@ -1111,7 +1112,7 @@ let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = | Prod (n, dom, codom) -> let lam = mkLambda (n, dom, codom) in let (evars', app), unfold = - if eq_constr ty mkProp then + if eq_constr (fst evars) (EConstr.of_constr ty) EConstr.mkProp then (app_poly_sort prop env evars coq_all [| dom; lam |]), TypeGlobal.unfold_all else let forall = if prop then PropGlobal.coq_forall else TypeGlobal.coq_forall in @@ -1409,7 +1410,7 @@ module Strategies = let sigma = Sigma.Unsafe.of_evar_map (goalevars evars) in let Sigma (t', sigma, _) = rfn.Reductionops.e_redfun env sigma (EConstr.of_constr t) in let evars' = Sigma.to_evar_map sigma in - if eq_constr t' t then + if Termops.eq_constr evars' (EConstr.of_constr t') (EConstr.of_constr t) then state, Identity else state, Success { rew_car = ty; rew_from = t; rew_to = t'; @@ -1553,14 +1554,15 @@ let assert_replacing id newt tac = in let env' = Environ.reset_with_named_context (val_of_named_context nc) env in Refine.refine ~unsafe:false { run = begin fun sigma -> + let open EConstr in let Sigma (ev, sigma, p) = Evarutil.new_evar env' sigma (EConstr.of_constr concl) in let Sigma (ev', sigma, q) = Evarutil.new_evar env sigma (EConstr.of_constr newt) in let map d = let n = NamedDecl.get_id d in - if Id.equal n id then ev' else mkVar n + if Id.equal n id then ev' else EConstr.mkVar n in - let (e, _) = destEvar ev in - Sigma (EConstr.of_constr (mkEvar (e, Array.map_of_list map nc)), sigma, p +> q) + let (e, _) = EConstr.destEvar (Sigma.to_evar_map sigma) ev in + Sigma (mkEvar (e, Array.map_of_list map nc), sigma, p +> q) end } end } in Proofview.tclTHEN prf (Proofview.tclFOCUS 2 2 tac) @@ -1596,16 +1598,18 @@ let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = convert_hyp_no_check (LocalAssum (id, newt)) <*> beta_hyp id | None, Some p -> + let p = EConstr.of_constr p in Proofview.Unsafe.tclEVARS undef <*> Proofview.Goal.enter { enter = begin fun gl -> let env = Proofview.Goal.env gl in let make = { run = begin fun sigma -> let Sigma (ev, sigma, q) = Evarutil.new_evar env sigma (EConstr.of_constr newt) in - Sigma (EConstr.of_constr (mkApp (p, [| ev |])), sigma, q) + Sigma (EConstr.mkApp (p, [| ev |]), sigma, q) end } in Refine.refine ~unsafe:false make <*> Proofview.Unsafe.tclNEWGOALS gls end } | None, None -> + let newt = EConstr.of_constr newt in Proofview.Unsafe.tclEVARS undef <*> convert_concl_no_check newt DEFAULTcast in @@ -2168,7 +2172,7 @@ let setoid_reflexivity = tac_open (poly_proof PropGlobal.get_reflexive_proof TypeGlobal.get_reflexive_proof env evm car rel) - (fun c -> tclCOMPLETE (apply c))) + (fun c -> tclCOMPLETE (apply (EConstr.of_constr c)))) (reflexivity_red true) let setoid_symmetry = @@ -2177,7 +2181,7 @@ let setoid_symmetry = tac_open (poly_proof PropGlobal.get_symmetric_proof TypeGlobal.get_symmetric_proof env evm car rel) - (fun c -> apply c)) + (fun c -> apply (EConstr.of_constr c))) (symmetry_red true) let setoid_transitivity c = @@ -2186,8 +2190,8 @@ let setoid_transitivity c = tac_open (poly_proof PropGlobal.get_transitive_proof TypeGlobal.get_transitive_proof env evm car rel) (fun proof -> match c with - | None -> eapply proof - | Some c -> apply_with_bindings (proof,ImplicitBindings [ c ]))) + | None -> eapply (EConstr.of_constr proof) + | Some c -> apply_with_bindings (EConstr.of_constr proof,ImplicitBindings [ c ]))) (transitivity_red true c) let setoid_symmetry_in id = @@ -2204,10 +2208,11 @@ let setoid_symmetry_in id = let he,c1,c2 = mkApp (equiv, Array.of_list others),c1,c2 in let new_hyp' = mkApp (he, [| c2 ; c1 |]) in let new_hyp = it_mkProd_or_LetIn new_hyp' binders in + let new_hyp = EConstr.of_constr new_hyp in Proofview.V82.of_tactic (tclTHENLAST (Tactics.assert_after_replacing id new_hyp) - (tclTHENLIST [ intros; setoid_symmetry; apply (mkVar id); Tactics.assumption ])) + (tclTHENLIST [ intros; setoid_symmetry; apply (EConstr.mkVar id); Tactics.assumption ])) gl) let _ = Hook.set Tactics.setoid_reflexivity setoid_reflexivity diff --git a/ltac/rewrite.mli b/ltac/rewrite.mli index 35c448351..bf56eec10 100644 --- a/ltac/rewrite.mli +++ b/ltac/rewrite.mli @@ -105,7 +105,7 @@ val setoid_symmetry_in : Id.t -> unit Proofview.tactic val setoid_reflexivity : unit Proofview.tactic -val setoid_transitivity : constr option -> unit Proofview.tactic +val setoid_transitivity : EConstr.constr option -> unit Proofview.tactic val apply_strategy : diff --git a/ltac/tacexpr.mli b/ltac/tacexpr.mli index 9c25a1645..b8d2d42b7 100644 --- a/ltac/tacexpr.mli +++ b/ltac/tacexpr.mli @@ -120,9 +120,9 @@ type glob_constr_pattern_and_expr = binding_bound_vars * glob_constr_and_expr * type 'a delayed_open = 'a Tactypes.delayed_open = { delayed : 'r. Environ.env -> 'r Sigma.t -> ('a, 'r) Sigma.sigma } -type delayed_open_constr_with_bindings = Term.constr with_bindings delayed_open +type delayed_open_constr_with_bindings = EConstr.constr with_bindings delayed_open -type delayed_open_constr = Term.constr delayed_open +type delayed_open_constr = EConstr.constr delayed_open type intro_pattern = delayed_open_constr intro_pattern_expr located type intro_patterns = delayed_open_constr intro_pattern_expr located list @@ -354,7 +354,7 @@ type raw_tactic_arg = (** Interpreted tactics *) -type t_trm = Term.constr +type t_trm = EConstr.constr type t_pat = constr_pattern type t_cst = evaluable_global_reference type t_ref = ltac_constant located diff --git a/ltac/tacinterp.ml b/ltac/tacinterp.ml index 142f061b5..553565639 100644 --- a/ltac/tacinterp.ml +++ b/ltac/tacinterp.ml @@ -746,11 +746,12 @@ let interp_closed_typed_pattern_with_occurrences ist env sigma (occs, a) = let interp_constr_with_occurrences_and_name_as_list = interp_constr_in_compound_list - (fun c -> ((AllOccurrences,c),Anonymous)) + (fun c -> ((AllOccurrences,EConstr.of_constr c),Anonymous)) (function ((occs,c),Anonymous) when occs == AllOccurrences -> c | _ -> raise Not_found) (fun ist env sigma (occ_c,na) -> let (sigma,c_interp) = interp_constr_with_occurrences ist env sigma occ_c in + let c_interp = (fst c_interp, EConstr.of_constr (snd c_interp)) in sigma, (c_interp, interp_name ist env sigma na)) @@ -853,7 +854,7 @@ let rec message_of_value v = Ftactic.return (int (out_gen (topwit wit_int) v)) else if has_type v (topwit wit_intro_pattern) then let p = out_gen (topwit wit_intro_pattern) v in - let print env sigma c = pr_constr_env env sigma (fst (Tactics.run_delayed env Evd.empty c)) in + let print env sigma c = pr_constr_env env sigma (EConstr.Unsafe.to_constr (fst (Tactics.run_delayed env Evd.empty c))) in Ftactic.nf_enter { enter = begin fun gl -> Ftactic.return (Miscprint.pr_intro_pattern (fun c -> print (pf_env gl) (project gl) c) p) end } @@ -917,6 +918,7 @@ and interp_intro_pattern_action ist env sigma = function let c = { delayed = fun env sigma -> let sigma = Sigma.to_evar_map sigma in let (sigma, c) = interp_open_constr ist env sigma c in + let c = EConstr.of_constr c in Sigma.Unsafe.of_pair (c, sigma) } in let sigma,ipat = interp_intro_pattern ist env sigma ipat in @@ -1002,6 +1004,8 @@ let interp_bindings ist env sigma = function let interp_constr_with_bindings ist env sigma (c,bl) = let sigma, bl = interp_bindings ist env sigma bl in let sigma, c = interp_open_constr ist env sigma c in + let c = EConstr.of_constr c in + let bl = Miscops.map_bindings EConstr.of_constr bl in sigma, (c,bl) let interp_open_constr_with_bindings ist env sigma (c,bl) = @@ -1021,6 +1025,7 @@ let interp_open_constr_with_bindings_loc ist ((c,_),bl as cb) = let f = { delayed = fun env sigma -> let sigma = Sigma.to_evar_map sigma in let (sigma, c) = interp_open_constr_with_bindings ist env sigma cb in + let c = Miscops.map_with_bindings EConstr.of_constr c in Sigma.Unsafe.of_pair (c, sigma) } in (loc,f) @@ -1044,7 +1049,7 @@ let interp_destruction_arg ist gl arg = then keep,ElimOnIdent (loc,id') else (keep, ElimOnConstr { delayed = begin fun env sigma -> - try Sigma.here (constr_of_id env id', NoBindings) sigma + try Sigma.here (EConstr.of_constr (constr_of_id env id'), NoBindings) sigma with Not_found -> user_err ~loc ~hdr:"interp_destruction_arg" ( pr_id id ++ strbrk " binds to " ++ pr_id id' ++ strbrk " which is neither a declared nor a quantified hypothesis.") @@ -1066,7 +1071,7 @@ let interp_destruction_arg ist gl arg = keep,ElimOnAnonHyp (out_gen (topwit wit_int) v) else match Value.to_constr v with | None -> error () - | Some c -> keep,ElimOnConstr { delayed = fun env sigma -> Sigma ((c,NoBindings), sigma, Sigma.refl) } + | Some c -> keep,ElimOnConstr { delayed = fun env sigma -> Sigma ((EConstr.of_constr c,NoBindings), sigma, Sigma.refl) } with Not_found -> (* We were in non strict (interactive) mode *) if Tactics.is_quantified_hypothesis id gl then @@ -1076,6 +1081,7 @@ let interp_destruction_arg ist gl arg = let f = { delayed = fun env sigma -> let sigma = Sigma.to_evar_map sigma in let (sigma,c) = interp_open_constr ist env sigma c in + let c = EConstr.of_constr c in Sigma.Unsafe.of_pair ((c,NoBindings), sigma) } in keep,ElimOnConstr f @@ -1701,7 +1707,7 @@ and interp_atomic ist tac : unit Proofview.tactic = let env = pf_env gl in let f sigma (id,n,c) = let (sigma,c_interp) = interp_type ist env sigma c in - sigma , (interp_ident ist env sigma id,n,c_interp) in + sigma , (interp_ident ist env sigma id,n,EConstr.of_constr c_interp) in let (sigma,l_interp) = Evd.MonadR.List.map_right (fun c sigma -> f sigma c) l (project gl) in @@ -1716,7 +1722,7 @@ and interp_atomic ist tac : unit Proofview.tactic = let env = pf_env gl in let f sigma (id,c) = let (sigma,c_interp) = interp_type ist env sigma c in - sigma , (interp_ident ist env sigma id,c_interp) in + sigma , (interp_ident ist env sigma id,EConstr.of_constr c_interp) in let (sigma,l_interp) = Evd.MonadR.List.map_right (fun c sigma -> f sigma c) l (project gl) in @@ -1731,6 +1737,7 @@ and interp_atomic ist tac : unit Proofview.tactic = let (sigma,c) = (if Option.is_empty t then interp_constr else interp_type) ist env sigma c in + let c = EConstr.of_constr c in let sigma, ipat' = interp_intro_pattern_option ist env sigma ipat in let tac = Option.map (Option.map (interp_tactic ist)) t in Tacticals.New.tclWITHHOLES false @@ -1758,6 +1765,7 @@ and interp_atomic ist tac : unit Proofview.tactic = if Locusops.is_nowhere clp then (* We try to fully-typecheck the term *) let (sigma,c_interp) = interp_constr ist env sigma c in + let c_interp = EConstr.of_constr c_interp in let let_tac b na c cl eqpat = let id = Option.default (Loc.ghost,IntroAnonymous) eqpat in let with_eq = if b then None else Some (true,id) in @@ -1776,11 +1784,12 @@ and interp_atomic ist tac : unit Proofview.tactic = Tactics.letin_pat_tac with_eq na c cl in let (sigma',c) = interp_pure_open_constr ist env sigma c in + let c = EConstr.of_constr c in name_atomic ~env (TacLetTac(na,c,clp,b,eqpat)) (Tacticals.New.tclWITHHOLES false (*in hope of a future "eset/epose"*) (let_pat_tac b (interp_name ist env sigma na) - ((sigma,sigma'),EConstr.of_constr c) clp eqpat) sigma') + ((sigma,sigma'),c) clp eqpat) sigma') end } (* Derived basic tactics *) @@ -1845,6 +1854,7 @@ and interp_atomic ist tac : unit Proofview.tactic = then interp_type ist (pf_env gl) sigma c else interp_constr ist (pf_env gl) sigma c in + let c = EConstr.of_constr c in Sigma.Unsafe.of_pair (c, sigma) end } in Tactics.change None c_interp (interp_clause ist (pf_env gl) (project gl) cl) @@ -1868,6 +1878,7 @@ and interp_atomic ist tac : unit Proofview.tactic = try let sigma = Sigma.to_evar_map sigma in let (sigma, c) = interp_constr ist env sigma c in + let c = EConstr.of_constr c in Sigma.Unsafe.of_pair (c, sigma) with e when to_catch e (* Hack *) -> user_err (strbrk "Failed to get enough information from the left-hand side to type the right-hand side.") @@ -1884,6 +1895,7 @@ and interp_atomic ist tac : unit Proofview.tactic = let f = { delayed = fun env sigma -> let sigma = Sigma.to_evar_map sigma in let (sigma, c) = interp_open_constr_with_bindings ist env sigma c in + let c = Miscops.map_with_bindings EConstr.of_constr c in Sigma.Unsafe.of_pair (c, sigma) } in (b,m,keep,f)) l in @@ -1906,6 +1918,7 @@ and interp_atomic ist tac : unit Proofview.tactic = | None -> sigma , None | Some c -> let (sigma,c_interp) = interp_constr ist env sigma c in + let c_interp = EConstr.of_constr c_interp in sigma , Some c_interp in let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in @@ -1932,6 +1945,7 @@ and interp_atomic ist tac : unit Proofview.tactic = let env = Proofview.Goal.env gl in let sigma = project gl in let (sigma,c_interp) = interp_constr ist env sigma c in + let c_interp = EConstr.of_constr c_interp in let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in let hyps = interp_hyp_list ist env sigma idl in let tac = name_atomic ~env @@ -2041,6 +2055,7 @@ end } let interp_bindings' ist bl = Ftactic.return { delayed = fun env sigma -> let (sigma, bl) = interp_bindings ist env (Sigma.to_evar_map sigma) bl in + let bl = Miscops.map_bindings EConstr.of_constr bl in Sigma.Unsafe.of_pair (bl, sigma) } diff --git a/ltac/tauto.ml b/ltac/tauto.ml index 11996af73..e3f5342de 100644 --- a/ltac/tauto.ml +++ b/ltac/tauto.ml @@ -161,8 +161,9 @@ let flatten_contravariant_conj _ ist = | Some (_,args) -> let args = List.map EConstr.Unsafe.to_constr args in let newtyp = List.fold_right mkArrow args c in + let newtyp = EConstr.of_constr newtyp in let intros = tclMAP (fun _ -> intro) args in - let by = tclTHENLIST [intros; apply hyp; split; assumption] in + let by = tclTHENLIST [intros; apply (EConstr.of_constr hyp); split; assumption] in tclTHENLIST [assert_ ~by newtyp; clear (destVar hyp)] | _ -> fail @@ -186,17 +187,17 @@ let flatten_contravariant_disj _ ist = let typ = assoc_var "X1" ist in let typ = EConstr.of_constr typ in let c = assoc_var "X2" ist in + let c = EConstr.of_constr c in let hyp = assoc_var "id" ist in match match_with_disjunction sigma ~strict:flags.strict_in_contravariant_hyp ~onlybinary:flags.binary_mode typ with | Some (_,args) -> - let args = List.map EConstr.Unsafe.to_constr args in let map i arg = - let typ = mkArrow arg c in + let typ = EConstr.mkArrow arg c in let ci = Tactics.constructor_tac false None (succ i) Misctypes.NoBindings in - let by = tclTHENLIST [intro; apply hyp; ci; assumption] in + let by = tclTHENLIST [intro; apply (EConstr.of_constr hyp); ci; assumption] in assert_ ~by typ in let tacs = List.mapi map args in @@ -231,6 +232,7 @@ let apply_nnpp _ ist = (Proofview.tclUNIT ()) begin fun () -> try let nnpp = Universes.constr_of_global (Nametab.global_of_path coq_nnpp_path) in + let nnpp = EConstr.of_constr nnpp in apply nnpp with Not_found -> tclFAIL 0 (Pp.mt ()) end diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml index 1e49d8cad..27398cf65 100644 --- a/plugins/btauto/refl_btauto.ml +++ b/plugins/btauto/refl_btauto.ml @@ -249,9 +249,10 @@ module Btauto = struct let fl = reify env fl in let fr = reify env fr in let changed_gl = Term.mkApp (c, [|typ; fl; fr|]) in + let changed_gl = EConstr.of_constr changed_gl in Tacticals.New.tclTHENLIST [ Tactics.change_concl changed_gl; - Tactics.apply (Lazy.force soundness); + Tactics.apply (EConstr.of_constr (Lazy.force soundness)); Tactics.normalise_vm_in_concl; try_unification env ] diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index 7c78f3a17..7b023413d 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -238,17 +238,17 @@ let build_projection intype (cstr:pconstructor) special default gls= let _M =mkMeta let app_global f args k = - Tacticals.pf_constr_of_global (Lazy.force f) (fun fc -> k (mkApp (fc, args))) + Tacticals.pf_constr_of_global (Lazy.force f) (fun fc -> k (EConstr.of_constr (mkApp (fc, args)))) let new_app_global f args k = - Tacticals.New.pf_constr_of_global (Lazy.force f) (fun fc -> k (mkApp (fc, args))) + Tacticals.New.pf_constr_of_global (Lazy.force f) (fun fc -> k (EConstr.of_constr (mkApp (fc, args)))) -let new_refine c = Proofview.V82.tactic (refine (EConstr.of_constr c)) -let refine c = refine (EConstr.of_constr c) +let new_refine c = Proofview.V82.tactic (refine c) +let refine c = refine c let assert_before n c = Proofview.Goal.enter { enter = begin fun gl -> - let evm, _ = Tacmach.New.pf_apply type_of gl (EConstr.of_constr c) in + let evm, _ = Tacmach.New.pf_apply type_of gl c in Tacticals.New.tclTHEN (Proofview.V82.tactic (Refiner.tclEVARS evm)) (assert_before n c) end } @@ -269,7 +269,7 @@ let rec proof_tac p : unit Proofview.tactic = let type_of t = Tacmach.New.pf_unsafe_type_of gl (EConstr.of_constr t) in try (* type_of can raise exceptions *) match p.p_rule with - Ax c -> exact_check c + Ax c -> exact_check (EConstr.of_constr c) | SymAx c -> let l=constr_of_term p.p_lhs and r=constr_of_term p.p_rhs in @@ -333,6 +333,7 @@ let refute_tac c t1 t2 p = let tt1=constr_of_term t1 and tt2=constr_of_term t2 in let hid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "Heq")) gl in let false_t=mkApp (c,[|mkVar hid|]) in + let false_t = EConstr.of_constr false_t in let k intype = let neweq= new_app_global _eq [|intype;tt1;tt2|] in Tacticals.New.tclTHENS (neweq (assert_before (Name hid))) @@ -341,7 +342,7 @@ let refute_tac c t1 t2 p = end } let refine_exact_check c gl = - let evm, _ = pf_apply type_of gl (EConstr.of_constr c) in + let evm, _ = pf_apply type_of gl c in Tacticals.tclTHEN (Refiner.tclEVARS evm) (Proofview.V82.of_tactic (exact_check c)) gl let convert_to_goal_tac c t1 t2 p = @@ -363,6 +364,8 @@ let convert_to_hyp_tac c1 t1 c2 t2 p = let tt2=constr_of_term t2 in let h = Tacmach.New.of_old (pf_get_new_id (Id.of_string "H")) gl in let false_t=mkApp (c2,[|mkVar h|]) in + let false_t = EConstr.of_constr false_t in + let tt2 = EConstr.of_constr tt2 in Tacticals.New.tclTHENS (assert_before (Name h) tt2) [convert_to_goal_tac c1 t1 t2 p; simplest_elim false_t] @@ -387,6 +390,7 @@ let discriminate_tac (cstr,u as cstru) p = [|intype;outtype;proj;t1;t2;mkVar hid|] in let endt k = injt (fun injt -> + let injt = EConstr.Unsafe.to_constr injt in app_global _eq_rect [|outtype;trivial;pred;identity;concl;injt|] k) in let neweq=new_app_global _eq [|intype;t1;t2|] in @@ -486,7 +490,7 @@ let mk_eq f c1 c2 k = let term = mkApp (fc, [| ty; c1; c2 |]) in let evm, _ = type_of (pf_env gl) evm (EConstr.of_constr term) in Tacticals.New.tclTHEN (Proofview.V82.tactic (Refiner.tclEVARS evm)) - (k term) + (k (EConstr.of_constr term)) end }) let f_equal = diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml index 031a6253a..54206aa95 100644 --- a/plugins/decl_mode/decl_proof_instr.ml +++ b/plugins/decl_mode/decl_proof_instr.ml @@ -130,7 +130,7 @@ let clean_tmp gls = clean_all (tmp_ids gls) gls let assert_postpone id t = - assert_before (Name id) t + assert_before (Name id) (EConstr.of_constr t) (* start a proof *) @@ -268,6 +268,7 @@ let add_justification_hyps keep items gls = | _ -> let id=pf_get_new_id local_hyp_prefix gls in keep:=Id.Set.add id !keep; + let c = EConstr.of_constr c in tclTHEN (Proofview.V82.of_tactic (letin_tac None (Names.Name id) c None Locusops.nowhere)) (Proofview.V82.of_tactic (clear_body [id])) gls in tclMAP add_aux items gls @@ -488,6 +489,7 @@ let thus_tac c ctyp submetas gls = with Not_found -> error "I could not relate this statement to the thesis." in if List.is_empty list then + let proof = EConstr.of_constr proof in Proofview.V82.of_tactic (exact_check proof) gls else let refiner = concl_refiner list proof gls in @@ -546,7 +548,7 @@ let decompose_eq id gls = let whd = (special_whd gls typ) in match kind_of_term whd with App (f,args)-> - if eq_constr f (Lazy.force _eq) && Int.equal (Array.length args) 3 + if Term.eq_constr f (Lazy.force _eq) && Int.equal (Array.length args) 3 then (args.(0), args.(1), args.(2)) @@ -584,15 +586,15 @@ let instr_rew _thus rew_side cut gls0 = let new_eq = mkApp(Lazy.force _eq,[|typ;cut.cut_stat.st_it;rhs|]) in tclTHENS (Proofview.V82.of_tactic (assert_postpone c_id new_eq)) [tclTHEN tcl_erase_info - (tclTHENS (Proofview.V82.of_tactic (transitivity lhs)) - [just_tac;Proofview.V82.of_tactic (exact_check (mkVar last_id))]); + (tclTHENS (Proofview.V82.of_tactic (transitivity (EConstr.of_constr lhs))) + [just_tac;Proofview.V82.of_tactic (exact_check (EConstr.mkVar last_id))]); thus_tac new_eq] gls0 | Rhs -> let new_eq = mkApp(Lazy.force _eq,[|typ;lhs;cut.cut_stat.st_it|]) in tclTHENS (Proofview.V82.of_tactic (assert_postpone c_id new_eq)) [tclTHEN tcl_erase_info - (tclTHENS (Proofview.V82.of_tactic (transitivity rhs)) - [Proofview.V82.of_tactic (exact_check (mkVar last_id));just_tac]); + (tclTHENS (Proofview.V82.of_tactic (transitivity (EConstr.of_constr rhs))) + [Proofview.V82.of_tactic (exact_check (EConstr.mkVar last_id));just_tac]); thus_tac new_eq] gls0 @@ -772,7 +774,7 @@ let rec consider_match may_intro introduced available expected gls = try conjunction_arity id gls with Not_found -> error "Matching hypothesis not found." in tclTHENLIST - [Proofview.V82.of_tactic (simplest_case (mkVar id)); + [Proofview.V82.of_tactic (simplest_case (EConstr.mkVar id)); intron_then nhyps [] (fun l -> consider_match may_intro introduced (List.rev_append l rest_ids) expected)] gls) @@ -780,7 +782,8 @@ let rec consider_match may_intro introduced available expected gls = gls let consider_tac c hyps gls = - match kind_of_term (strip_outer_cast (project gls) (EConstr.of_constr c)) with + let c = EConstr.of_constr c in + match kind_of_term (strip_outer_cast (project gls) c) with Var id -> consider_match false [] [id] hyps gls | _ -> @@ -817,6 +820,7 @@ let rec build_function sigma args body = let define_tac id args body gls = let t = build_function (project gls) args body in + let t = EConstr.of_constr t in Proofview.V82.of_tactic (letin_tac None (Name id) t None Locusops.nowhere) gls (* tactics for reconsider *) @@ -828,6 +832,7 @@ let cast_tac id_or_thesis typ gls = | Thesis (For _ ) -> error "\"thesis for ...\" is not applicable here." | Thesis Plain -> + let typ = EConstr.of_constr typ in Proofview.V82.of_tactic (convert_concl typ DEFAULTcast) gls (* per cases *) @@ -1087,7 +1092,7 @@ let thesis_for obj typ per_info env= ((Printer.pr_constr_env env Evd.empty obj) ++ spc () ++ str"cannot give an induction hypothesis (wrong inductive type).") in let params,args = List.chop per_info.per_nparams all_args in - let _ = if not (List.for_all2 eq_constr params per_info.per_params) then + let _ = if not (List.for_all2 Term.eq_constr params per_info.per_params) then user_err ~hdr:"thesis_for" ((Printer.pr_constr_env env Evd.empty obj) ++ spc () ++ str "cannot give an induction hypothesis (wrong parameters).") in @@ -1219,10 +1224,10 @@ let hrec_for fix_id per_info gls obj_id = let ind,u = destInd cind in assert (eq_ind ind per_info.per_ind); let params,args= List.chop per_info.per_nparams all_args in assert begin - try List.for_all2 eq_constr params per_info.per_params with + try List.for_all2 Term.eq_constr params per_info.per_params with Invalid_argument _ -> false end; let hd2 = applist (mkVar fix_id,args@[obj]) in - compose_lam rc (Reductionops.whd_beta gls.sigma (EConstr.of_constr hd2)) + EConstr.of_constr (compose_lam rc (Reductionops.whd_beta gls.sigma (EConstr.of_constr hd2))) let warn_missing_case = CWarnings.create ~name:"declmode-missing-case" ~category:"declmode" @@ -1336,7 +1341,7 @@ let my_refine c gls = let oc = { run = begin fun sigma -> let sigma = Sigma.to_evar_map sigma in let (sigma, c) = understand_my_constr (pf_env gls) sigma c (pf_concl gls) in - Sigma.Unsafe.of_pair (c, sigma) + Sigma.Unsafe.of_pair (EConstr.of_constr c, sigma) end } in Proofview.V82.of_tactic (Tactics.New.refine oc) gls @@ -1366,14 +1371,14 @@ let end_tac et2 gls = begin match et,ek with _,EK_unknown -> - tclSOLVE [Proofview.V82.of_tactic (simplest_elim pi.per_casee)] + tclSOLVE [Proofview.V82.of_tactic (simplest_elim (EConstr.of_constr pi.per_casee))] | ET_Case_analysis,EK_nodep -> tclTHEN - (Proofview.V82.of_tactic (simplest_case pi.per_casee)) + (Proofview.V82.of_tactic (simplest_case (EConstr.of_constr pi.per_casee))) (default_justification (List.map mkVar clauses)) | ET_Induction,EK_nodep -> tclTHENLIST - [Proofview.V82.of_tactic (generalize (pi.per_args@[pi.per_casee])); + [Proofview.V82.of_tactic (generalize (List.map EConstr.of_constr (pi.per_args@[pi.per_casee]))); Proofview.V82.of_tactic (simple_induct (AnonHyp (succ (List.length pi.per_args)))); default_justification (List.map mkVar clauses)] | ET_Case_analysis,EK_dep tree -> @@ -1385,7 +1390,7 @@ let end_tac et2 gls = (initial_instance_stack clauses) [pi.per_casee] 0 tree | ET_Induction,EK_dep tree -> let nargs = (List.length pi.per_args) in - tclTHEN (Proofview.V82.of_tactic (generalize (pi.per_args@[pi.per_casee]))) + tclTHEN (Proofview.V82.of_tactic (generalize (List.map EConstr.of_constr (pi.per_args@[pi.per_casee])))) begin fun gls0 -> let fix_id = diff --git a/plugins/decl_mode/decl_proof_instr.mli b/plugins/decl_mode/decl_proof_instr.mli index 325969dad..ba196ff01 100644 --- a/plugins/decl_mode/decl_proof_instr.mli +++ b/plugins/decl_mode/decl_proof_instr.mli @@ -89,7 +89,7 @@ val push_arg : Term.constr -> val hrec_for: Id.t -> Decl_mode.per_info -> Proof_type.goal Tacmach.sigma -> - Id.t -> Term.constr + Id.t -> EConstr.constr val consider_match : bool -> diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index 6c245063c..a320b47aa 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -117,6 +117,7 @@ let mk_open_instance id idc gl m t= let nid=(fresh_id avoid var_id gl) in let evmap = Sigma.Unsafe.of_evar_map evmap in let Sigma ((c, _), evmap, _) = Evarutil.new_type_evar env evmap Evd.univ_flexible in + let c = EConstr.Unsafe.to_constr c in let evmap = Sigma.to_evar_map evmap in let decl = LocalAssum (Name nid, c) in aux (n-1) (nid::avoid) (Environ.push_rel decl env) evmap (decl::decls) in @@ -131,13 +132,13 @@ let left_instance_tac (inst,id) continue seq= if lookup (id,None) seq then tclFAIL 0 (Pp.str "already done") else - tclTHENS (Proofview.V82.of_tactic (cut dom)) + tclTHENS (Proofview.V82.of_tactic (cut (EConstr.of_constr dom))) [tclTHENLIST [Proofview.V82.of_tactic introf; pf_constr_of_global id (fun idc -> (fun gls-> Proofview.V82.of_tactic (generalize - [mkApp(idc, - [|mkVar (Tacmach.pf_nth_hyp_id gls 1)|])]) gls)); + [EConstr.of_constr (mkApp(idc, + [|mkVar (Tacmach.pf_nth_hyp_id gls 1)|]))]) gls)); Proofview.V82.of_tactic introf; tclSOLVE [wrap 1 false continue (deepen (record (id,None) seq))]]; @@ -154,14 +155,15 @@ let left_instance_tac (inst,id) continue seq= let gt= it_mkLambda_or_LetIn (mkApp(idc,[|ot|])) rc in + let gt = EConstr.of_constr gt in let evmap, _ = - try Typing.type_of (pf_env gl) evmap (EConstr.of_constr gt) + try Typing.type_of (pf_env gl) evmap gt with e when CErrors.noncritical e -> error "Untypable instance, maybe higher-order non-prenex quantification" in tclTHEN (Refiner.tclEVARS evmap) (Proofview.V82.of_tactic (generalize [gt])) gl) else pf_constr_of_global id (fun idc -> - Proofview.V82.of_tactic (generalize [mkApp(idc,[|t|])])) + Proofview.V82.of_tactic (generalize [EConstr.of_constr (mkApp(idc,[|t|]))])) in tclTHENLIST [special_generalize; @@ -172,16 +174,16 @@ let left_instance_tac (inst,id) continue seq= let right_instance_tac inst continue seq= match inst with Phantom dom -> - tclTHENS (Proofview.V82.of_tactic (cut dom)) + tclTHENS (Proofview.V82.of_tactic (cut (EConstr.of_constr dom))) [tclTHENLIST [Proofview.V82.of_tactic introf; (fun gls-> Proofview.V82.of_tactic (split (ImplicitBindings - [mkVar (Tacmach.pf_nth_hyp_id gls 1)])) gls); + [EConstr.mkVar (Tacmach.pf_nth_hyp_id gls 1)])) gls); tclSOLVE [wrap 0 true continue (deepen seq)]]; tclTRY (Proofview.V82.of_tactic assumption)] | Real ((0,t),_) -> - (tclTHEN (Proofview.V82.of_tactic (split (ImplicitBindings [t]))) + (tclTHEN (Proofview.V82.of_tactic (split (ImplicitBindings [EConstr.of_constr t]))) (tclSOLVE [wrap 0 true continue (deepen seq)])) | Real ((m,t),_) -> tclFAIL 0 (Pp.str "not implemented ... yet") diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml index 1d107e9af..bed7a727f 100644 --- a/plugins/firstorder/rules.ml +++ b/plugins/firstorder/rules.ml @@ -59,7 +59,7 @@ let clear_global=function (* connection rules *) let axiom_tac t seq= - try pf_constr_of_global (find_left t seq) (fun c -> Proofview.V82.of_tactic (exact_no_check c)) + try pf_constr_of_global (find_left t seq) (fun c -> Proofview.V82.of_tactic (exact_no_check (EConstr.of_constr c))) with Not_found->tclFAIL 0 (Pp.str "No axiom link") let ll_atom_tac a backtrack id continue seq= @@ -68,7 +68,7 @@ let ll_atom_tac a backtrack id continue seq= tclTHENLIST [pf_constr_of_global (find_left a seq) (fun left -> pf_constr_of_global id (fun id -> - Proofview.V82.of_tactic (generalize [mkApp(id, [|left|])]))); + Proofview.V82.of_tactic (generalize [EConstr.of_constr (mkApp(id, [|left|]))]))); clear_global id; Proofview.V82.of_tactic intro] with Not_found->tclFAIL 0 (Pp.str "No link")) @@ -95,7 +95,7 @@ let left_and_tac ind backtrack id continue seq gls= let n=(construct_nhyps ind gls).(0) in tclIFTHENELSE (tclTHENLIST - [Proofview.V82.of_tactic (Tacticals.New.pf_constr_of_global id simplest_elim); + [Proofview.V82.of_tactic (Tacticals.New.pf_constr_of_global id (EConstr.of_constr %> simplest_elim)); clear_global id; tclDO n (Proofview.V82.of_tactic intro)]) (wrap n false continue seq) @@ -109,12 +109,12 @@ let left_or_tac ind backtrack id continue seq gls= tclDO n (Proofview.V82.of_tactic intro); wrap n false continue seq] in tclIFTHENSVELSE - (Proofview.V82.of_tactic (Tacticals.New.pf_constr_of_global id simplest_elim)) + (Proofview.V82.of_tactic (Tacticals.New.pf_constr_of_global id (EConstr.of_constr %> simplest_elim))) (Array.map f v) backtrack gls let left_false_tac id= - Proofview.V82.of_tactic (Tacticals.New.pf_constr_of_global id simplest_elim) + Proofview.V82.of_tactic (Tacticals.New.pf_constr_of_global id (EConstr.of_constr %> simplest_elim)) (* left arrow connective rules *) @@ -131,7 +131,7 @@ let ll_ind_tac (ind,u as indu) largs backtrack id continue seq gl= let vars=Array.init p (fun j->mkRel (p-j)) in let capply=mkApp ((lift p cstr),vars) in let head=mkApp ((lift p idc),[|capply|]) in - it_mkLambda_or_LetIn head rc in + EConstr.of_constr (it_mkLambda_or_LetIn head rc) in let lp=Array.length rcs in let newhyps idc =List.init lp (myterm idc) in tclIFTHENELSE @@ -143,16 +143,16 @@ let ll_ind_tac (ind,u as indu) largs backtrack id continue seq gl= let ll_arrow_tac a b c backtrack id continue seq= let cc=mkProd(Anonymous,a,(lift 1 b)) in - let d idc =mkLambda (Anonymous,b, - mkApp (idc, [|mkLambda (Anonymous,(lift 1 a),(mkRel 2))|])) in + let d idc =EConstr.of_constr (mkLambda (Anonymous,b, + mkApp (idc, [|mkLambda (Anonymous,(lift 1 a),(mkRel 2))|]))) in tclORELSE - (tclTHENS (Proofview.V82.of_tactic (cut c)) + (tclTHENS (Proofview.V82.of_tactic (cut (EConstr.of_constr c))) [tclTHENLIST [Proofview.V82.of_tactic introf; clear_global id; wrap 1 false continue seq]; - tclTHENS (Proofview.V82.of_tactic (cut cc)) - [pf_constr_of_global id (fun c -> Proofview.V82.of_tactic (exact_no_check c)); + tclTHENS (Proofview.V82.of_tactic (cut (EConstr.of_constr cc))) + [pf_constr_of_global id (fun c -> Proofview.V82.of_tactic (exact_no_check (EConstr.of_constr c))); tclTHENLIST [pf_constr_of_global id (fun idc -> Proofview.V82.of_tactic (generalize [d idc])); clear_global id; @@ -177,7 +177,7 @@ let forall_tac backtrack continue seq= let left_exists_tac ind backtrack id continue seq gls= let n=(construct_nhyps ind gls).(0) in tclIFTHENELSE - (Proofview.V82.of_tactic (Tacticals.New.pf_constr_of_global id simplest_elim)) + (Proofview.V82.of_tactic (Tacticals.New.pf_constr_of_global id (EConstr.of_constr %> simplest_elim))) (tclTHENLIST [clear_global id; tclDO n (Proofview.V82.of_tactic intro); (wrap (n-1) false continue seq)]) @@ -186,13 +186,14 @@ let left_exists_tac ind backtrack id continue seq gls= let ll_forall_tac prod backtrack id continue seq= tclORELSE - (tclTHENS (Proofview.V82.of_tactic (cut prod)) + (tclTHENS (Proofview.V82.of_tactic (cut (EConstr.of_constr prod))) [tclTHENLIST [Proofview.V82.of_tactic intro; pf_constr_of_global id (fun idc -> (fun gls-> let id0=pf_nth_hyp_id gls 1 in let term=mkApp(idc,[|mkVar(id0)|]) in + let term = EConstr.of_constr term in tclTHEN (Proofview.V82.of_tactic (generalize [term])) (Proofview.V82.of_tactic (clear [id0])) gls)); clear_global id; Proofview.V82.of_tactic intro; diff --git a/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml index a14ec8a2c..fa64b276c 100644 --- a/plugins/fourier/fourierR.ml +++ b/plugins/fourier/fourierR.ml @@ -281,6 +281,8 @@ let fourier_lineq lineq1 = (* Defined constants *) let get = Lazy.force +let cget = get +let eget c = EConstr.of_constr (Lazy.force c) let constant = Coqlib.gen_constant "Fourier" (* Standard library *) @@ -373,6 +375,7 @@ let rational_to_real x = (* preuve que 0<n*1/d *) let tac_zero_inf_pos gl (n,d) = + let get = eget in let tacn=ref (apply (get coq_Rlt_zero_1)) in let tacd=ref (apply (get coq_Rlt_zero_1)) in for _i = 1 to n - 1 do @@ -385,6 +388,7 @@ let tac_zero_inf_pos gl (n,d) = (* preuve que 0<=n*1/d *) let tac_zero_infeq_pos gl (n,d)= + let get = eget in let tacn=ref (if n=0 then (apply (get coq_Rle_zero_zero)) else (apply (get coq_Rle_zero_1))) in @@ -399,7 +403,8 @@ let tac_zero_infeq_pos gl (n,d)= (* preuve que 0<(-n)*(1/d) => False *) let tac_zero_inf_false gl (n,d) = - if n=0 then (apply (get coq_Rnot_lt0)) + let get = eget in +if n=0 then (apply (get coq_Rnot_lt0)) else (Tacticals.New.tclTHEN (apply (get coq_Rle_not_lt)) (tac_zero_infeq_pos gl (-n,d))) @@ -408,6 +413,7 @@ let tac_zero_inf_false gl (n,d) = (* preuve que 0<=(-n)*(1/d) => False *) let tac_zero_infeq_false gl (n,d) = + let get = eget in (Tacticals.New.tclTHEN (apply (get coq_Rlt_not_le_frac_opp)) (tac_zero_inf_pos gl (-n,d))) ;; @@ -415,7 +421,8 @@ let tac_zero_infeq_false gl (n,d) = let exact = exact_check;; let tac_use h = - let tac = exact h.hname in + let get = eget in + let tac = exact (EConstr.of_constr h.hname) in match h.htype with "Rlt" -> tac |"Rle" -> tac @@ -470,6 +477,7 @@ let rec fourier () = try match (kind_of_term goal) with App (f,args) -> + let get = eget in (match (string_of_R_constr f) with "Rlt" -> (Tacticals.New.tclTHEN @@ -548,6 +556,7 @@ let rec fourier () = !t2 |] in let tc=rational_to_real cres in (* puis sa preuve *) + let get = eget in let tac1=ref (if h1.hstrict then (Tacticals.New.tclTHENS (apply (get coq_Rfourier_lt)) [tac_use h1; @@ -584,29 +593,29 @@ let rec fourier () = then tac_zero_inf_false gl (rational_to_fraction cres) else tac_zero_infeq_false gl (rational_to_fraction cres) in - tac:=(Tacticals.New.tclTHENS (cut ineq) + tac:=(Tacticals.New.tclTHENS (cut (EConstr.of_constr ineq)) [Tacticals.New.tclTHEN (change_concl - (mkAppL [| get coq_not; ineq|] - )) + (EConstr.of_constr (mkAppL [| cget coq_not; ineq|] + ))) (Tacticals.New.tclTHEN (apply (if sres then get coq_Rnot_lt_lt else get coq_Rnot_le_le)) (Tacticals.New.tclTHENS (Equality.replace - (mkAppL [|get coq_Rminus;!t2;!t1|] + (mkAppL [|cget coq_Rminus;!t2;!t1|] ) tc) [tac2; (Tacticals.New.tclTHENS (Equality.replace - (mkApp (get coq_Rinv, - [|get coq_R1|])) - (get coq_R1)) + (mkApp (cget coq_Rinv, + [|cget coq_R1|])) + (cget coq_R1)) (* en attendant Field, ça peut aider Ring de remplacer 1/1 par 1 ... *) [Tacticals.New.tclORELSE (* TODO : Ring.polynom []*) (Proofview.tclUNIT ()) (Proofview.tclUNIT ()); - Tacticals.New.pf_constr_of_global (get coq_sym_eqT) (fun symeq -> - (Tacticals.New.tclTHEN (apply symeq) + Tacticals.New.pf_constr_of_global (cget coq_sym_eqT) (fun symeq -> + (Tacticals.New.tclTHEN (apply (EConstr.of_constr symeq)) (apply (get coq_Rinv_1))))] ) diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index b674f40e9..503cafdd5 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -175,6 +175,7 @@ let is_incompatible_eq t = res let change_hyp_with_using msg hyp_id t tac : tactic = + let t = EConstr.of_constr t in fun g -> let prov_id = pf_get_new_id hyp_id g in tclTHENS @@ -451,6 +452,7 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = ) in let to_refine = EConstr.of_constr to_refine in + let t_x = EConstr.of_constr t_x in (* observe_tac "rec hyp " *) (tclTHENS (Proofview.V82.of_tactic (assert_before (Name rec_pte_id) t_x)) @@ -644,7 +646,8 @@ let instanciate_hyps_with_args (do_prove:Id.t list -> tactic) hyps args_id = fun g -> let prov_hid = pf_get_new_id hid g in let c = mkApp(mkVar hid,args) in - let evm, _ = pf_apply Typing.type_of g (EConstr.of_constr c) in + let c = EConstr.of_constr c in + let evm, _ = pf_apply Typing.type_of g c in tclTHENLIST[ Refiner.tclEVARS evm; Proofview.V82.of_tactic (pose_proof (Name prov_hid) c); @@ -709,13 +712,14 @@ let build_proof let term_eq = make_refl_eq (Lazy.force refl_equal) type_of_term t in + let term_eq = EConstr.of_constr term_eq in tclTHENSEQ [ - Proofview.V82.of_tactic (generalize (term_eq::(List.map mkVar dyn_infos.rec_hyps))); + Proofview.V82.of_tactic (generalize (term_eq::(List.map EConstr.mkVar dyn_infos.rec_hyps))); thin dyn_infos.rec_hyps; - Proofview.V82.of_tactic (pattern_option [Locus.AllOccurrencesBut [1],t] None); + Proofview.V82.of_tactic (pattern_option [Locus.AllOccurrencesBut [1],EConstr.of_constr t] None); (fun g -> observe_tac "toto" ( - tclTHENSEQ [Proofview.V82.of_tactic (Simple.case t); + tclTHENSEQ [Proofview.V82.of_tactic (Simple.case (EConstr.of_constr t)); (fun g' -> let g'_nb_prod = nb_prod (project g') (EConstr.of_constr (pf_concl g')) in let nb_instanciate_partial = g'_nb_prod - g_nb_prod in @@ -942,7 +946,7 @@ let generalize_non_dep hyp g = in (* observe (str "to_revert := " ++ prlist_with_sep spc Ppconstr.pr_id to_revert); *) tclTHEN - ((* observe_tac "h_generalize" *) (Proofview.V82.of_tactic (generalize (List.map mkVar to_revert) ))) + ((* observe_tac "h_generalize" *) (Proofview.V82.of_tactic (generalize (List.map EConstr.mkVar to_revert) ))) ((* observe_tac "thin" *) (thin to_revert)) g @@ -950,7 +954,7 @@ let id_of_decl = RelDecl.get_name %> Nameops.out_name let var_of_decl = id_of_decl %> mkVar let revert idl = tclTHEN - (Proofview.V82.of_tactic (generalize (List.map mkVar idl))) + (Proofview.V82.of_tactic (generalize (List.map EConstr.mkVar idl))) (thin idl) let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num = @@ -991,7 +995,7 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num let rec_id = pf_nth_hyp_id g 1 in tclTHENSEQ [observe_tac "generalize_non_dep in generate_equation_lemma" (generalize_non_dep rec_id); - observe_tac "h_case" (Proofview.V82.of_tactic (simplest_case (mkVar rec_id))); + observe_tac "h_case" (Proofview.V82.of_tactic (simplest_case (EConstr.mkVar rec_id))); (Proofview.V82.of_tactic intros_reflexivity)] g ) ] @@ -1064,10 +1068,11 @@ let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num a let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnames all_funs _nparams : tactic = fun g -> let princ_type = pf_concl g in + let princ_type = EConstr.of_constr princ_type in (* Pp.msgnl (str "princ_type " ++ Printer.pr_lconstr princ_type); *) (* Pp.msgnl (str "all_funs "); *) (* Array.iter (fun c -> Pp.msgnl (Printer.pr_lconstr c)) all_funs; *) - let princ_info = compute_elim_sig princ_type in + let princ_info = compute_elim_sig (project g) princ_type in let fresh_id = let avoid = ref (pf_ids_of_hyps g) in (fun na -> @@ -1227,7 +1232,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam | _, this_fix_info::others_infos -> let other_fix_infos = List.map - (fun fi -> fi.name,fi.idx + 1 ,fi.types) + (fun fi -> fi.name,fi.idx + 1 ,EConstr.of_constr fi.types) (pre_info@others_infos) in if List.is_empty other_fix_infos @@ -1462,11 +1467,11 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = backtrack_eqs_until_hrec hrec eqs; (* observe_tac ("new_prove_with_tcc ( applying "^(Id.to_string hrec)^" )" ) *) (tclTHENS (* We must have exactly ONE subgoal !*) - (Proofview.V82.of_tactic (apply (mkVar hrec))) + (Proofview.V82.of_tactic (apply (EConstr.mkVar hrec))) [ tclTHENSEQ [ (Proofview.V82.of_tactic (keep (tcc_hyps@eqs))); - (Proofview.V82.of_tactic (apply (Lazy.force acc_inv))); + (Proofview.V82.of_tactic (apply (EConstr.of_constr (Lazy.force acc_inv)))); (fun g -> if is_mes then @@ -1482,7 +1487,7 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = tclCOMPLETE( Eauto.eauto_with_bases (true,5) - [{ Tacexpr.delayed = fun _ sigma -> Sigma.here (Lazy.force refl_equal) sigma}] + [{ Tacexpr.delayed = fun _ sigma -> Sigma.here (EConstr.of_constr (Lazy.force refl_equal)) sigma}] [Hints.Hint_db.empty empty_transparent_state false] ) ) @@ -1518,7 +1523,8 @@ let prove_principle_for_gen (f_ref,functional_ref,eq_ref) tcc_lemma_ref is_mes rec_arg_num rec_arg_type relation gl = let princ_type = pf_concl gl in - let princ_info = compute_elim_sig princ_type in + let princ_type = EConstr.of_constr princ_type in + let princ_info = compute_elim_sig (project gl) princ_type in let fresh_id = let avoid = ref (pf_ids_of_hyps gl) in fun na -> @@ -1572,7 +1578,7 @@ let prove_principle_for_gen Nameops.out_name (fresh_id (Name (Id.of_string ("Acc_"^(Id.to_string rec_arg_id))))) in let revert l = - tclTHEN (Proofview.V82.of_tactic (Tactics.generalize (List.map mkVar l))) (Proofview.V82.of_tactic (clear l)) + tclTHEN (Proofview.V82.of_tactic (Tactics.generalize (List.map EConstr.mkVar l))) (Proofview.V82.of_tactic (clear l)) in let fix_id = Nameops.out_name (fresh_id (Name hrec_id)) in let prove_rec_arg_acc g = @@ -1580,12 +1586,12 @@ let prove_principle_for_gen (tclCOMPLETE (tclTHEN (Proofview.V82.of_tactic (assert_by (Name wf_thm_id) - (mkApp (delayed_force well_founded,[|input_type;relation|])) + (EConstr.of_constr (mkApp (delayed_force well_founded,[|input_type;relation|]))) (Proofview.V82.tactic (fun g -> (* observe_tac "prove wf" *) (tclCOMPLETE (wf_tac is_mes)) g)))) ( (* observe_tac *) (* "apply wf_thm" *) - Proofview.V82.of_tactic (Tactics.Simple.apply (mkApp(mkVar wf_thm_id,[|mkVar rec_arg_id|]))) + Proofview.V82.of_tactic (Tactics.Simple.apply (EConstr.of_constr (mkApp(mkVar wf_thm_id,[|mkVar rec_arg_id|])))) ) ) ) @@ -1596,7 +1602,7 @@ let prove_principle_for_gen let lemma = match !tcc_lemma_ref with | None -> error "No tcc proof !!" - | Some lemma -> lemma + | Some lemma -> EConstr.of_constr lemma in (* let rec list_diff del_list check_list = *) (* match del_list with *) @@ -1644,7 +1650,7 @@ let prove_principle_for_gen ); (* observe_tac "" *) Proofview.V82.of_tactic (assert_by (Name acc_rec_arg_id) - (mkApp (delayed_force acc_rel,[|input_type;relation;mkVar rec_arg_id|])) + (EConstr.of_constr (mkApp (delayed_force acc_rel,[|input_type;relation;mkVar rec_arg_id|]))) (Proofview.V82.tactic prove_rec_arg_acc) ); (* observe_tac "reverting" *) (revert (List.rev (acc_rec_arg_id::args_ids))); diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index 4b47b83af..4d88f9f91 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -28,7 +28,8 @@ let observe s = a functional one *) let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = - let princ_type_info = compute_elim_sig princ_type in + let princ_type = EConstr.of_constr princ_type in + let princ_type_info = compute_elim_sig Evd.empty princ_type (** FIXME *) in let env = Global.env () in let env_with_params = Environ.push_rel_context princ_type_info.params env in let tbl = Hashtbl.create 792 in @@ -89,7 +90,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = (Option.fold_right mkProd_or_LetIn princ_type_info.indarg - princ_type_info.concl + (EConstr.Unsafe.to_constr princ_type_info.concl) ) princ_type_info.args ) @@ -243,7 +244,8 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let change_property_sort evd toSort princ princName = let open Context.Rel.Declaration in - let princ_info = compute_elim_sig princ in + let princ = EConstr.of_constr princ in + let princ_info = compute_elim_sig evd princ in let change_sort_in_predicate decl = LocalAssum (get_name decl, @@ -270,7 +272,7 @@ let change_property_sort evd toSort princ princName = let build_functional_principle (evd:Evd.evar_map ref) interactive_proof old_princ_type sorts funs i proof_tac hook = (* First we get the type of the old graph principle *) - let mutr_nparams = (compute_elim_sig old_princ_type).nparams in + let mutr_nparams = (compute_elim_sig !evd (EConstr.of_constr old_princ_type)).nparams in (* let time1 = System.get_time () in *) let new_principle_type = compute_new_princ_type_from_rel diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index 6603a95a8..a6f971703 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -58,7 +58,7 @@ let pr_fun_ind_using_typed prc prlc _ opt_c = | None -> mt () | Some b -> let (b, _) = Tactics.run_delayed (Global.env ()) Evd.empty b in - spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings_typed prc prlc b) + spc () ++ hov 2 (str "using" ++ spc () ++ pr_with_bindings_typed (EConstr.Unsafe.to_constr %> prc) (EConstr.Unsafe.to_constr %> prlc) b) ARGUMENT EXTEND fun_ind_using @@ -97,7 +97,9 @@ ARGUMENT EXTEND with_names TYPED AS intropattern_opt PRINTED BY pr_intro_as_pat | [] ->[ None ] END - +let functional_induction b c x pat = + let x = Option.map (Miscops.map_with_bindings EConstr.Unsafe.to_constr) x in + Proofview.V82.tactic (functional_induction true c x (Option.map out_disjunctive pat)) TACTIC EXTEND newfunind @@ -108,7 +110,7 @@ TACTIC EXTEND newfunind | [c] -> c | c::cl -> applist(c,cl) in - Extratactics.onSomeWithHoles (fun x -> Proofview.V82.tactic (functional_induction true c x (Option.map out_disjunctive pat))) princl ] + Extratactics.onSomeWithHoles (fun x -> functional_induction true c x pat) princl ] END (***** debug only ***) TACTIC EXTEND snewfunind @@ -119,7 +121,7 @@ TACTIC EXTEND snewfunind | [c] -> c | c::cl -> applist(c,cl) in - Extratactics.onSomeWithHoles (fun x -> Proofview.V82.tactic (functional_induction false c x (Option.map out_disjunctive pat))) princl ] + Extratactics.onSomeWithHoles (fun x -> functional_induction false c x pat) princl ] END diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index e3ba52246..37a76bec1 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -81,7 +81,8 @@ let functional_induction with_clean c princl pat = | Some ((princ,binding)) -> princ,binding,Tacmach.pf_unsafe_type_of g (EConstr.of_constr princ),g in - let princ_infos = Tactics.compute_elim_sig princ_type in + let princ_type = EConstr.of_constr princ_type in + let princ_infos = Tactics.compute_elim_sig (Tacmach.project g') princ_type in let args_as_induction_constr = let c_list = if princ_infos.Tactics.farg_in_concl @@ -89,9 +90,11 @@ let functional_induction with_clean c princl pat = in let encoded_pat_as_patlist = List.make (List.length args + List.length c_list - 1) None @ [pat] in - List.map2 (fun c pat -> ((None,Tacexpr.ElimOnConstr ({ Tacexpr.delayed = fun env sigma -> Sigma ((c,NoBindings), sigma, Sigma.refl) })),(None,pat),None)) + List.map2 (fun c pat -> ((None,Tacexpr.ElimOnConstr ({ Tacexpr.delayed = fun env sigma -> Sigma ((EConstr.of_constr c,NoBindings), sigma, Sigma.refl) })),(None,pat),None)) (args@c_list) encoded_pat_as_patlist in + let princ = EConstr.of_constr princ in + let bindings = Miscops.map_bindings EConstr.of_constr bindings in let princ' = Some (princ,bindings) in let princ_vars = List.fold_right diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index b2419b1a5..36fb6dad3 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -252,7 +252,8 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes (* and the principle to use in this lemma in $\zeta$ normal form *) let f_principle,princ_type = schemes.(i) in let princ_type = nf_zeta (EConstr.of_constr princ_type) in - let princ_infos = Tactics.compute_elim_sig princ_type in + let princ_type = EConstr.of_constr princ_type in + let princ_infos = Tactics.compute_elim_sig evd princ_type in (* The number of args of the function is then easily computable *) let nb_fun_args = nb_prod (project g) (EConstr.of_constr (pf_concl g)) - 2 in let args_names = generate_fresh_id (Id.of_string "x") [] nb_fun_args in @@ -315,7 +316,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes match kind_of_term t'',kind_of_term t''' with | App(eq,args), App(graph',_) when - (eq_constr eq eq_ind) && + (Term.eq_constr eq eq_ind) && Array.exists (Constr.eq_constr_nounivs graph') graphs_constr -> (args.(2)::(mkApp(mkVar hid,[|args.(2);(mkApp(eq_construct,[|args.(0);args.(2)|]))|])) ::acc) @@ -387,7 +388,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes observe_tac "rewriting res value" (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar hres))); (* Conclusion *) observe_tac "exact" (fun g -> - Proofview.V82.of_tactic (exact_check (app_constructor g)) g) + Proofview.V82.of_tactic (exact_check (EConstr.of_constr (app_constructor g))) g) ] ) g @@ -440,7 +441,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes observe_tac "principle" (Proofview.V82.of_tactic (assert_by (Name principle_id) princ_type - (exact_check f_principle))); + (exact_check (EConstr.of_constr f_principle)))); observe_tac "intro args_names" (tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) args_names); (* observe_tac "titi" (pose_proof (Name (Id.of_string "__")) (Reductionops.nf_beta Evd.empty ((mkApp (mkVar principle_id,Array.of_list bindings))))); *) observe_tac "idtac" tclIDTAC; @@ -450,7 +451,7 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes (fun gl -> let term = mkApp (mkVar principle_id,Array.of_list bindings) in let gl', _ty = pf_eapply (Typing.type_of ~refresh:true) gl (EConstr.of_constr term) in - Proofview.V82.of_tactic (apply term) gl') + Proofview.V82.of_tactic (apply (EConstr.of_constr term)) gl') )) (fun i g -> observe_tac ("proving branche "^string_of_int i) (prove_branche i) g ) ] @@ -467,7 +468,7 @@ let generalize_dependent_of x hyp g = tclMAP (function | LocalAssum (id,t) when not (Id.equal id hyp) && - (Termops.occur_var (pf_env g) (project g) x (EConstr.of_constr t)) -> tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [mkVar id])) (thin [id]) + (Termops.occur_var (pf_env g) (project g) x (EConstr.of_constr t)) -> tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [EConstr.mkVar id])) (thin [id]) | _ -> tclIDTAC ) (pf_hyps g) @@ -495,7 +496,7 @@ and intros_with_rewrite_aux : tactic = | Prod(_,t,t') -> begin match kind_of_term t with - | App(eq,args) when (eq_constr eq eq_ind) -> + | App(eq,args) when (Term.eq_constr eq eq_ind) -> if Reductionops.is_conv (pf_env g) (project g) (EConstr.of_constr args.(1)) (EConstr.of_constr args.(2)) then let id = pf_get_new_id (Id.of_string "y") g in @@ -541,11 +542,11 @@ and intros_with_rewrite_aux : tactic = intros_with_rewrite ] g end - | Ind _ when eq_constr t (Coqlib.build_coq_False ()) -> + | Ind _ when Term.eq_constr t (Coqlib.build_coq_False ()) -> Proofview.V82.of_tactic tauto g | Case(_,_,v,_) -> tclTHENSEQ[ - Proofview.V82.of_tactic (simplest_case v); + Proofview.V82.of_tactic (simplest_case (EConstr.of_constr v)); intros_with_rewrite ] g | LetIn _ -> @@ -582,7 +583,7 @@ let rec reflexivity_with_destruct_cases g = match kind_of_term (snd (destApp (pf_concl g))).(2) with | Case(_,_,v,_) -> tclTHENSEQ[ - Proofview.V82.of_tactic (simplest_case v); + Proofview.V82.of_tactic (simplest_case (EConstr.of_constr v)); Proofview.V82.of_tactic intros; observe_tac "reflexivity_with_destruct_cases" reflexivity_with_destruct_cases ] @@ -597,7 +598,7 @@ let rec reflexivity_with_destruct_cases g = None -> tclIDTAC g | Some id -> match kind_of_term (pf_unsafe_type_of g (EConstr.mkVar id)) with - | App(eq,[|_;t1;t2|]) when eq_constr eq eq_ind -> + | App(eq,[|_;t1;t2|]) when Term.eq_constr eq eq_ind -> if Equality.discriminable (pf_env g) (project g) (EConstr.of_constr t1) (EConstr.of_constr t2) then Proofview.V82.of_tactic (Equality.discrHyp id) g else if Equality.injectable (pf_env g) (project g) (EConstr.of_constr t1) (EConstr.of_constr t2) @@ -662,7 +663,8 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = let f = funcs.(i) in let graph_principle = nf_zeta (EConstr.of_constr schemes.(i)) in let princ_type = pf_unsafe_type_of g (EConstr.of_constr graph_principle) in - let princ_infos = Tactics.compute_elim_sig princ_type in + let princ_type = EConstr.of_constr princ_type in + let princ_infos = Tactics.compute_elim_sig (project g) princ_type in (* Then we get the number of argument of the function and compute a fresh name for each of them *) @@ -717,7 +719,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = }) Locusops.onConcl) ; - Proofview.V82.of_tactic (generalize (List.map mkVar ids)); + Proofview.V82.of_tactic (generalize (List.map EConstr.mkVar ids)); thin ids ] else @@ -756,10 +758,10 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = tclTHENSEQ [ tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) (args_names@[res;hres]); observe_tac "h_generalize" - (Proofview.V82.of_tactic (generalize [mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas)])); + (Proofview.V82.of_tactic (generalize [EConstr.of_constr (mkApp(applist(graph_principle,params),Array.map (fun c -> applist(c,params)) lemmas))])); Proofview.V82.of_tactic (Simple.intro graph_principle_id); observe_tac "" (tclTHEN_i - (observe_tac "elim" (Proofview.V82.of_tactic (elim false None (mkVar hres,NoBindings) (Some (mkVar graph_principle_id,NoBindings))))) + (observe_tac "elim" (Proofview.V82.of_tactic (elim false None (EConstr.mkVar hres,NoBindings) (Some (EConstr.mkVar graph_principle_id,NoBindings))))) (fun i g -> observe_tac "prove_branche" (prove_branche i) g )) ] g @@ -939,7 +941,7 @@ let revert_graph kn post_tac hid g = let f_args,res = Array.chop (Array.length args - 1) args in tclTHENSEQ [ - Proofview.V82.of_tactic (generalize [applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid])]); + Proofview.V82.of_tactic (generalize [EConstr.of_constr (applist(mkConst f_complete,(Array.to_list f_args)@[res.(0);mkVar hid]))]); thin [hid]; Proofview.V82.of_tactic (Simple.intro hid); post_tac hid @@ -972,18 +974,18 @@ let functional_inversion kn hid fconst f_correct : tactic = let old_ids = List.fold_right Id.Set.add (pf_ids_of_hyps g) Id.Set.empty in let type_of_h = pf_unsafe_type_of g (EConstr.mkVar hid) in match kind_of_term type_of_h with - | App(eq,args) when eq_constr eq (make_eq ()) -> + | App(eq,args) when Term.eq_constr eq (make_eq ()) -> let pre_tac,f_args,res = match kind_of_term args.(1),kind_of_term args.(2) with - | App(f,f_args),_ when eq_constr f fconst -> + | App(f,f_args),_ when Term.eq_constr f fconst -> ((fun hid -> Proofview.V82.of_tactic (intros_symmetry (Locusops.onHyp hid))),f_args,args.(2)) - |_,App(f,f_args) when eq_constr f fconst -> + |_,App(f,f_args) when Term.eq_constr f fconst -> ((fun hid -> tclIDTAC),f_args,args.(1)) | _ -> (fun hid -> tclFAIL 1 (mt ())),[||],args.(2) in tclTHENSEQ[ pre_tac hid; - Proofview.V82.of_tactic (generalize [applist(f_correct,(Array.to_list f_args)@[res;mkVar hid])]); + Proofview.V82.of_tactic (generalize [EConstr.of_constr (applist(f_correct,(Array.to_list f_args)@[res;mkVar hid]))]); thin [hid]; Proofview.V82.of_tactic (Simple.intro hid); Proofview.V82.of_tactic (Inv.inv FullInversion None (NamedHyp hid)); @@ -1024,7 +1026,7 @@ let invfun qhyp f g = (fun hid -> Proofview.V82.tactic begin fun g -> let hyp_typ = pf_unsafe_type_of g (EConstr.mkVar hid) in match kind_of_term hyp_typ with - | App(eq,args) when eq_constr eq (make_eq ()) -> + | App(eq,args) when Term.eq_constr eq (make_eq ()) -> begin let f1,_ = decompose_app args.(1) in try diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml index 222c0c804..3688b8c15 100644 --- a/plugins/funind/merge.ml +++ b/plugins/funind/merge.ml @@ -32,7 +32,7 @@ module RelDecl = Context.Rel.Declaration (** {2 Useful operations on constr and glob_constr} *) -let rec popn i c = if i<=0 then c else pop (EConstr.of_constr (popn (i-1) c)) +let rec popn i c = if i<=0 then c else EConstr.of_constr (pop (popn (i-1) c)) (** Substitutions in constr *) let compare_constr_nosub t1 t2 = @@ -979,19 +979,20 @@ let funify_branches relinfo nfuns branch = let relprinctype_to_funprinctype relprinctype nfuns = - let relinfo = compute_elim_sig relprinctype in + let relprinctype = EConstr.of_constr relprinctype in + let relinfo = compute_elim_sig Evd.empty (** FIXME*) relprinctype in assert (not relinfo.farg_in_concl); assert (relinfo.indarg_in_concl); (* first remove indarg and indarg_in_concl *) let relinfo_noindarg = { relinfo with indarg_in_concl = false; indarg = None; - concl = remove_last_arg (pop (EConstr.of_constr relinfo.concl)); } in + concl = EConstr.of_constr (remove_last_arg (pop relinfo.concl)); } in (* the nfuns last induction arguments are functional ones: remove them *) let relinfo_argsok = { relinfo_noindarg with nargs = relinfo_noindarg.nargs - nfuns; (* args is in reverse order, so remove fst *) args = remove_n_fst_list nfuns relinfo_noindarg.args; - concl = popn nfuns relinfo_noindarg.concl + concl = popn nfuns relinfo_noindarg.concl; } in let new_branches = List.map (funify_branches relinfo_argsok nfuns) relinfo_argsok.branches in diff --git a/plugins/funind/recdef.ml b/plugins/funind/recdef.ml index b2c93a754..d5ee42af8 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -286,7 +286,7 @@ let tclUSER tac is_mes l g = let tclUSER_if_not_mes concl_tac is_mes names_to_suppress = if is_mes - then tclCOMPLETE (fun gl -> Proofview.V82.of_tactic (Simple.apply (delayed_force well_founded_ltof)) gl) + then tclCOMPLETE (fun gl -> Proofview.V82.of_tactic (Simple.apply (EConstr.of_constr (delayed_force well_founded_ltof))) gl) else (* tclTHEN (Simple.apply (delayed_force acc_intro_generator_function) ) *) (tclUSER concl_tac is_mes names_to_suppress) @@ -465,7 +465,7 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) = end | App _ -> let f,args = decompose_app expr_info.info in - if eq_constr f (expr_info.f_constr) + if Term.eq_constr f (expr_info.f_constr) then jinfo.app_reC (f,args) expr_info continuation_tac expr_info else begin @@ -517,21 +517,21 @@ let rec prove_lt hyple g = let h = List.find (fun id -> match decompose_app (pf_unsafe_type_of g (EConstr.mkVar id)) with - | _, t::_ -> eq_constr t varx + | _, t::_ -> Term.eq_constr t varx | _ -> false ) hyple in let y = List.hd (List.tl (snd (decompose_app (pf_unsafe_type_of g (EConstr.mkVar h))))) in observe_tclTHENLIST (str "prove_lt1")[ - Proofview.V82.of_tactic (apply (mkApp(le_lt_trans (),[|varx;y;varz;mkVar h|]))); + Proofview.V82.of_tactic (apply (EConstr.of_constr (mkApp(le_lt_trans (),[|varx;y;varz;mkVar h|])))); observe_tac (str "prove_lt") (prove_lt hyple) ] with Not_found -> ( ( observe_tclTHENLIST (str "prove_lt2")[ - Proofview.V82.of_tactic (apply (delayed_force lt_S_n)); + Proofview.V82.of_tactic (apply (EConstr.of_constr (delayed_force lt_S_n))); (observe_tac (str "assumption: " ++ Printer.pr_goal g) (Proofview.V82.of_tactic assumption)) ]) ) @@ -549,15 +549,15 @@ let rec destruct_bounds_aux infos (bound,hyple,rechyps) lbounds g = let ids = h'::ids in let def = next_ident_away_in_goal def_id ids in observe_tclTHENLIST (str "destruct_bounds_aux1")[ - Proofview.V82.of_tactic (split (ImplicitBindings [s_max])); + Proofview.V82.of_tactic (split (ImplicitBindings [EConstr.of_constr s_max])); Proofview.V82.of_tactic (intro_then (fun id -> Proofview.V82.tactic begin observe_tac (str "destruct_bounds_aux") - (tclTHENS (Proofview.V82.of_tactic (simplest_case (mkVar id))) + (tclTHENS (Proofview.V82.of_tactic (simplest_case (EConstr.mkVar id))) [ observe_tclTHENLIST (str "")[Proofview.V82.of_tactic (intro_using h_id); - Proofview.V82.of_tactic (simplest_elim(mkApp(delayed_force lt_n_O,[|s_max|]))); + Proofview.V82.of_tactic (simplest_elim(EConstr.of_constr (mkApp(delayed_force lt_n_O,[|s_max|])))); Proofview.V82.of_tactic default_full_auto]; observe_tclTHENLIST (str "destruct_bounds_aux2")[ observe_tac (str "clearing k ") (Proofview.V82.of_tactic (clear [id])); @@ -588,7 +588,7 @@ let rec destruct_bounds_aux infos (bound,hyple,rechyps) lbounds g = ] g | (_,v_bound)::l -> observe_tclTHENLIST (str "destruct_bounds_aux3")[ - Proofview.V82.of_tactic (simplest_elim (mkVar v_bound)); + Proofview.V82.of_tactic (simplest_elim (EConstr.mkVar v_bound)); Proofview.V82.of_tactic (clear [v_bound]); tclDO 2 (Proofview.V82.of_tactic intro); onNthHypId 1 @@ -597,7 +597,7 @@ let rec destruct_bounds_aux infos (bound,hyple,rechyps) lbounds g = (fun p -> observe_tclTHENLIST (str "destruct_bounds_aux4")[ Proofview.V82.of_tactic (simplest_elim - (mkApp(delayed_force max_constr, [| bound; mkVar p|]))); + (EConstr.of_constr (mkApp(delayed_force max_constr, [| bound; mkVar p|])))); tclDO 3 (Proofview.V82.of_tactic intro); onNLastHypsId 3 (fun lids -> match lids with @@ -622,7 +622,7 @@ let terminate_app f_and_args expr_info continuation_tac infos = observe_tclTHENLIST (str "terminate_app1")[ continuation_tac infos; observe_tac (str "first split") - (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))); + (Proofview.V82.of_tactic (split (ImplicitBindings [EConstr.of_constr infos.info]))); observe_tac (str "destruct_bounds (1)") (destruct_bounds infos) ] else continuation_tac infos @@ -633,7 +633,7 @@ let terminate_others _ expr_info continuation_tac infos = observe_tclTHENLIST (str "terminate_others")[ continuation_tac infos; observe_tac (str "first split") - (Proofview.V82.of_tactic (split (ImplicitBindings [infos.info]))); + (Proofview.V82.of_tactic (split (ImplicitBindings [EConstr.of_constr infos.info]))); observe_tac (str "destruct_bounds") (destruct_bounds infos) ] else continuation_tac infos @@ -657,7 +657,7 @@ let terminate_letin (na,b,t,e) expr_info continuation_tac info = continuation_tac {info with info = new_e; forbidden_ids = new_forbidden} let pf_type c tac gl = - let evars, ty = Typing.type_of (pf_env gl) (project gl) (EConstr.of_constr c) in + let evars, ty = Typing.type_of (pf_env gl) (project gl) c in tclTHEN (Refiner.tclEVARS evars) (tac ty) gl let pf_typel l tac = @@ -687,16 +687,18 @@ let mkDestructEq : let type_of_expr = pf_unsafe_type_of g (EConstr.of_constr expr) in let new_hyps = mkApp(Lazy.force refl_equal, [|type_of_expr; expr|]):: to_revert_constr in + let new_hyps = List.map EConstr.of_constr new_hyps in pf_typel new_hyps (fun _ -> observe_tclTHENLIST (str "mkDestructEq") [Proofview.V82.of_tactic (generalize new_hyps); (fun g2 -> let changefun patvars = { run = fun sigma -> let redfun = pattern_occs [Locus.AllOccurrencesBut [1], EConstr.of_constr expr] in - redfun.Reductionops.e_redfun (pf_env g2) sigma (EConstr.of_constr (pf_concl g2)) + let Sigma (c, sigma, p) = redfun.Reductionops.e_redfun (pf_env g2) sigma (EConstr.of_constr (pf_concl g2)) in + Sigma (EConstr.of_constr c, sigma, p) } in Proofview.V82.of_tactic (change_in_concl None changefun) g2); - Proofview.V82.of_tactic (simplest_case expr)]), to_revert + Proofview.V82.of_tactic (simplest_case (EConstr.of_constr expr))]), to_revert let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = @@ -742,7 +744,7 @@ let terminate_app_rec (f,args) expr_info continuation_tac _ = then observe_tclTHENLIST (str "terminate_app_rec1")[ observe_tac (str "first split") - (Proofview.V82.of_tactic (split (ImplicitBindings [new_infos.info]))); + (Proofview.V82.of_tactic (split (ImplicitBindings [EConstr.of_constr new_infos.info]))); observe_tac (str "destruct_bounds (3)") (destruct_bounds new_infos) ] @@ -751,7 +753,7 @@ let terminate_app_rec (f,args) expr_info continuation_tac _ = ] with Not_found -> observe_tac (str "terminate_app_rec not found") (tclTHENS - (Proofview.V82.of_tactic (simplest_elim (mkApp(mkVar expr_info.ih,Array.of_list args)))) + (Proofview.V82.of_tactic (simplest_elim (EConstr.of_constr (mkApp(mkVar expr_info.ih,Array.of_list args))))) [ observe_tclTHENLIST (str "terminate_app_rec2")[ Proofview.V82.of_tactic (intro_using rec_res_id); @@ -772,7 +774,7 @@ let terminate_app_rec (f,args) expr_info continuation_tac _ = then observe_tclTHENLIST (str "terminate_app_rec4")[ observe_tac (str "first split") - (Proofview.V82.of_tactic (split (ImplicitBindings [new_infos.info]))); + (Proofview.V82.of_tactic (split (ImplicitBindings [EConstr.of_constr new_infos.info]))); observe_tac (str "destruct_bounds (2)") (destruct_bounds new_infos) ] @@ -785,7 +787,7 @@ let terminate_app_rec (f,args) expr_info continuation_tac _ = ]; observe_tac (str "proving decreasing") ( tclTHENS (* proof of args < formal args *) - (Proofview.V82.of_tactic (apply (Lazy.force expr_info.acc_inv))) + (Proofview.V82.of_tactic (apply (EConstr.of_constr (Lazy.force expr_info.acc_inv)))) [ observe_tac (str "assumption") (Proofview.V82.of_tactic assumption); observe_tclTHENLIST (str "terminate_app_rec5") @@ -833,7 +835,7 @@ let rec prove_le g = in tclFIRST[ Proofview.V82.of_tactic assumption; - Proofview.V82.of_tactic (apply (delayed_force le_n)); + Proofview.V82.of_tactic (apply (EConstr.of_constr (delayed_force le_n))); begin try let matching_fun = @@ -846,7 +848,7 @@ let rec prove_le g = List.hd (List.tl args) in observe_tclTHENLIST (str "prove_le")[ - Proofview.V82.of_tactic (apply(mkApp(le_trans (),[|x;y;z;mkVar h|]))); + Proofview.V82.of_tactic (apply(EConstr.of_constr (mkApp(le_trans (),[|x;y;z;mkVar h|])))); observe_tac (str "prove_le (rec)") (prove_le) ] with Not_found -> tclFAIL 0 (mt()) @@ -876,7 +878,7 @@ let rec make_rewrite_list expr_info max = function ) [make_rewrite_list expr_info max l; observe_tclTHENLIST (str "make_rewrite_list")[ (* x < S max proof *) - Proofview.V82.of_tactic (apply (delayed_force le_lt_n_Sm)); + Proofview.V82.of_tactic (apply (EConstr.of_constr (delayed_force le_lt_n_Sm))); observe_tac (str "prove_le(2)") prove_le ] ] ) @@ -916,7 +918,7 @@ let make_rewrite expr_info l hp max = ])) ; observe_tclTHENLIST (str "make_rewrite1")[ (* x < S (S max) proof *) - Proofview.V82.of_tactic (apply (delayed_force le_lt_SS)); + Proofview.V82.of_tactic (apply (EConstr.of_constr (delayed_force le_lt_SS))); observe_tac (str "prove_le (3)") prove_le ] ]) @@ -928,7 +930,7 @@ let rec compute_max rew_tac max l = | (_,p,_)::l -> observe_tclTHENLIST (str "compute_max")[ Proofview.V82.of_tactic (simplest_elim - (mkApp(delayed_force max_constr, [| max; mkVar p|]))); + (EConstr.of_constr (mkApp(delayed_force max_constr, [| max; mkVar p|])))); tclDO 3 (Proofview.V82.of_tactic intro); onNLastHypsId 3 (fun lids -> match lids with @@ -947,7 +949,7 @@ let rec destruct_hex expr_info acc l = end | (v,hex)::l -> observe_tclTHENLIST (str "destruct_hex")[ - Proofview.V82.of_tactic (simplest_case (mkVar hex)); + Proofview.V82.of_tactic (simplest_case (EConstr.mkVar hex)); Proofview.V82.of_tactic (clear [hex]); tclDO 2 (Proofview.V82.of_tactic intro); onNthHypId 1 (fun hp -> @@ -995,13 +997,13 @@ let equation_app_rec (f,args) expr_info continuation_tac info = if expr_info.is_final && expr_info.is_main_branch then observe_tclTHENLIST (str "equation_app_rec") - [ Proofview.V82.of_tactic (simplest_case (mkApp (expr_info.f_terminate,Array.of_list args))); + [ Proofview.V82.of_tactic (simplest_case (EConstr.of_constr (mkApp (expr_info.f_terminate,Array.of_list args)))); continuation_tac {expr_info with args_assoc = (args,delayed_force coq_O)::expr_info.args_assoc}; observe_tac (str "app_rec intros_values_eq") (intros_values_eq expr_info []) ] else observe_tclTHENLIST (str "equation_app_rec1")[ - Proofview.V82.of_tactic (simplest_case (mkApp (expr_info.f_terminate,Array.of_list args))); + Proofview.V82.of_tactic (simplest_case (EConstr.of_constr (mkApp (expr_info.f_terminate,Array.of_list args)))); observe_tac (str "app_rec not_found") (continuation_tac {expr_info with args_assoc = (args,delayed_force coq_O)::expr_info.args_assoc}) ] end @@ -1086,9 +1088,9 @@ let termination_proof_header is_mes input_type ids args_id relation (str "first assert") (Proofview.V82.of_tactic (assert_before (Name wf_rec_arg) - (mkApp (delayed_force acc_rel, + (EConstr.of_constr (mkApp (delayed_force acc_rel, [|input_type;relation;mkVar rec_arg_id|]) - ) + )) )) ) [ @@ -1098,7 +1100,7 @@ let termination_proof_header is_mes input_type ids args_id relation (str "second assert") (Proofview.V82.of_tactic (assert_before (Name wf_thm) - (mkApp (delayed_force well_founded,[|input_type;relation|])) + (EConstr.of_constr (mkApp (delayed_force well_founded,[|input_type;relation|]))) )) ) [ @@ -1107,7 +1109,7 @@ let termination_proof_header is_mes input_type ids args_id relation (* this gives the accessibility argument *) observe_tac (str "apply wf_thm") - (Proofview.V82.of_tactic (Simple.apply (mkApp(mkVar wf_thm,[|mkVar rec_arg_id|]))) + (Proofview.V82.of_tactic (Simple.apply (EConstr.of_constr (mkApp(mkVar wf_thm,[|mkVar rec_arg_id|])))) ) ] ; @@ -1116,7 +1118,7 @@ let termination_proof_header is_mes input_type ids args_id relation [observe_tac (str "generalize") (onNLastHypsId (nargs+1) (tclMAP (fun id -> - tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [mkVar id])) (Proofview.V82.of_tactic (clear [id]))) + tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [EConstr.mkVar id])) (Proofview.V82.of_tactic (clear [id]))) )) ; observe_tac (str "fix") (Proofview.V82.of_tactic (fix (Some hrec) (nargs+1))); @@ -1214,7 +1216,7 @@ let build_and_l l = | Prod(_,_,t') -> is_well_founded t' | App(_,_) -> let (f,_) = decompose_app t in - eq_constr f (well_founded ()) + Term.eq_constr f (well_founded ()) | _ -> false in @@ -1231,7 +1233,7 @@ let build_and_l l = let c,tac,nb = f pl in mk_and p1 c, tclTHENS - (Proofview.V82.of_tactic (apply (constr_of_global conj_constr))) + (Proofview.V82.of_tactic (apply (EConstr.of_constr (constr_of_global conj_constr)))) [tclIDTAC; tac ],nb+1 @@ -1297,6 +1299,7 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp in let lemma = mkConst (Names.Constant.make1 (Lib.make_kn na)) in ref_ := Some lemma ; + let lemma = EConstr.of_constr lemma in let lid = ref [] in let h_num = ref (-1) in let env = Global.env () in @@ -1323,7 +1326,7 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp ] gls) (fun g -> match kind_of_term (pf_concl g) with - | App(f,_) when eq_constr f (well_founded ()) -> + | App(f,_) when Term.eq_constr f (well_founded ()) -> Proofview.V82.of_tactic (Auto.h_auto None [] (Some [])) g | _ -> incr h_num; @@ -1332,11 +1335,11 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp tclCOMPLETE( tclFIRST[ tclTHEN - (Proofview.V82.of_tactic (eapply_with_bindings (mkVar (List.nth !lid !h_num), NoBindings))) + (Proofview.V82.of_tactic (eapply_with_bindings (EConstr.mkVar (List.nth !lid !h_num), NoBindings))) (Proofview.V82.of_tactic e_assumption); Eauto.eauto_with_bases (true,5) - [{ Tacexpr.delayed = fun _ sigma -> Sigma.here (Lazy.force refl_equal) sigma}] + [{ Tacexpr.delayed = fun _ sigma -> Sigma.here (EConstr.of_constr (Lazy.force refl_equal)) sigma}] [Hints.Hint_db.empty empty_transparent_state false] ] ) @@ -1366,7 +1369,7 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp (fun c -> Proofview.V82.of_tactic (Tacticals.New.tclTHENLIST [intros; - Simple.apply (fst (interp_constr (Global.env()) Evd.empty c)) (*FIXME*); + Simple.apply (EConstr.of_constr (fst (interp_constr (Global.env()) Evd.empty c))) (*FIXME*); Tacticals.New.tclCOMPLETE Auto.default_auto ]) ) @@ -1428,8 +1431,8 @@ let start_equation (f:global_reference) (term_f:global_reference) h_intros x; Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, evaluable_of_global_reference f)]); observe_tac (str "simplest_case") - (Proofview.V82.of_tactic (simplest_case (mkApp (terminate_constr, - Array.of_list (List.map mkVar x))))); + (Proofview.V82.of_tactic (simplest_case (EConstr.of_constr (mkApp (terminate_constr, + Array.of_list (List.map mkVar x)))))); observe_tac (str "prove_eq") (cont_tactic x)]) g;; let (com_eqn : int -> Id.t -> diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index a943ef2b0..f96b189c5 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -1461,7 +1461,7 @@ let rec make_goal_of_formula dexpr form = xset (Term.mkNamedLetIn (Names.Id.of_string name) expr typ acc) l in - xset concl l + EConstr.of_constr (xset concl l) end (** * MODULE END: M @@ -2000,12 +2000,12 @@ let micromega_gen (Tacticals.New.tclTHEN tac_arith tac)) in Tacticals.New.tclTHENS - (Tactics.forward true (Some None) (ipat_of_name goal_name) arith_goal) + (Tactics.forward true (Some None) (ipat_of_name goal_name) (EConstr.of_constr arith_goal)) [ kill_arith; (Tacticals.New.tclTHENLIST - [(Tactics.generalize (List.map Term.mkVar ids)); - Tactics.exact_check (Term.applist (Term.mkVar goal_name, arith_args)) + [(Tactics.generalize (List.map EConstr.mkVar ids)); + Tactics.exact_check (EConstr.of_constr (Term.applist (Term.mkVar goal_name, arith_args))) ] ) ] with @@ -2114,12 +2114,12 @@ let micromega_genr prover tac = (Tacticals.New.tclTHEN tac_arith tac)) in Tacticals.New.tclTHENS - (Tactics.forward true (Some None) (ipat_of_name goal_name) arith_goal) + (Tactics.forward true (Some None) (ipat_of_name goal_name) (EConstr.of_constr arith_goal)) [ kill_arith; (Tacticals.New.tclTHENLIST - [(Tactics.generalize (List.map Term.mkVar ids)); - Tactics.exact_check (Term.applist (Term.mkVar goal_name, arith_args)) + [(Tactics.generalize (List.map EConstr.mkVar ids)); + Tactics.exact_check (EConstr.of_constr (Term.applist (Term.mkVar goal_name, arith_args))) ] ) ] diff --git a/plugins/nsatz/nsatz.ml b/plugins/nsatz/nsatz.ml index 36bce780b..cc0c4277e 100644 --- a/plugins/nsatz/nsatz.ml +++ b/plugins/nsatz/nsatz.ml @@ -625,6 +625,7 @@ let nsatz lpol = let return_term t = let a = mkApp(gen_constant "CC" ["Init";"Logic"] "refl_equal",[|tllp ();t|]) in + let a = EConstr.of_constr a in generalize [a] let nsatz_compute t = diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index b832250a5..35d763ccc 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -38,9 +38,9 @@ open OmegaSolver let elim_id id = Proofview.Goal.nf_enter { enter = begin fun gl -> - simplest_elim (Tacmach.New.pf_global id gl) + simplest_elim (EConstr.of_constr (Tacmach.New.pf_global id gl)) end } -let resolve_id id gl = Proofview.V82.of_tactic (apply (pf_global gl id)) gl +let resolve_id id gl = Proofview.V82.of_tactic (apply (EConstr.of_constr (pf_global gl id))) gl let timing timer_name f arg = f arg @@ -149,7 +149,7 @@ let mk_then = tclTHENLIST let exists_tac c = constructor_tac false (Some 1) 1 (ImplicitBindings [c]) -let generalize_tac t = generalize t +let generalize_tac t = generalize (List.map EConstr.of_constr t) let elim t = simplest_elim t let exact t = Tacmach.refine t let unfold s = Tactics.unfold_in_concl [Locus.AllOccurrences, Lazy.force s] @@ -373,7 +373,7 @@ let mk_minus t1 t2 = mkApp (Lazy.force coq_Zminus, [| t1;t2 |]) let mk_eq t1 t2 = mkApp (Universes.constr_of_global (build_coq_eq ()), [| Lazy.force coq_Z; t1; t2 |]) let mk_le t1 t2 = mkApp (Lazy.force coq_Zle, [| t1; t2 |]) -let mk_gt t1 t2 = mkApp (Lazy.force coq_Zgt, [| t1; t2 |]) +let mk_gt t1 t2 = EConstr.of_constr (mkApp (Lazy.force coq_Zgt, [| t1; t2 |])) let mk_inv t = mkApp (Lazy.force coq_Zopp, [| t |]) let mk_and t1 t2 = mkApp (build_coq_and (), [| t1; t2 |]) let mk_or t1 t2 = mkApp (build_coq_or (), [| t1; t2 |]) @@ -569,6 +569,7 @@ let abstract_path typ path t = let focused_simpl path gl = let newc = context (fun i t -> pf_nf gl (EConstr.of_constr t)) (List.rev path) (pf_concl gl) in + let newc = EConstr.of_constr newc in Proofview.V82.of_tactic (convert_concl_no_check newc DEFAULTcast) gl let focused_simpl path = focused_simpl path @@ -1116,7 +1117,7 @@ let replay_history tactic_normalisation = let state_eg = mk_eq eq1 rhs in let tac = scalar_norm_add [P_APP 3] e2.body in Tacticals.New.tclTHENS - (cut state_eg) + (cut (EConstr.of_constr state_eg)) [ Tacticals.New.tclTHENS (Tacticals.New.tclTHENLIST [ (intros_using [aux]); @@ -1185,7 +1186,7 @@ let replay_history tactic_normalisation = if e1.kind == DISE then let tac = scalar_norm [P_APP 3] e2.body in Tacticals.New.tclTHENS - (cut state_eq) + (cut (EConstr.of_constr state_eq)) [Tacticals.New.tclTHENLIST [ (intros_using [aux1]); (generalize_tac @@ -1197,7 +1198,7 @@ let replay_history tactic_normalisation = Tacticals.New.tclTHEN (Proofview.V82.tactic (mk_then tac)) reflexivity ] else let tac = scalar_norm [P_APP 3] e2.body in - Tacticals.New.tclTHENS (cut state_eq) + Tacticals.New.tclTHENS (cut (EConstr.of_constr state_eq)) [ Tacticals.New.tclTHENS (cut (mk_gt kk izero)) @@ -1227,7 +1228,7 @@ let replay_history tactic_normalisation = scalar_norm [P_APP 3] e1.body in Tacticals.New.tclTHENS - (cut (mk_eq eq1 (mk_inv eq2))) + (cut (EConstr.of_constr (mk_eq eq1 (mk_inv eq2)))) [Tacticals.New.tclTHENLIST [ (intros_using [aux]); (generalize_tac [mkApp (Lazy.force coq_OMEGA8, @@ -1260,7 +1261,7 @@ let replay_history tactic_normalisation = shuffle_mult_right p_initial orig.body m ({c= negone;v= v}::def.body) in Tacticals.New.tclTHENS - (cut theorem) + (cut (EConstr.of_constr theorem)) [Tacticals.New.tclTHENLIST [ (intros_using [aux]); (elim_id aux); @@ -1273,7 +1274,7 @@ let replay_history tactic_normalisation = (clear [aux]); (intros_using [id]); (loop l) ]; - Tacticals.New.tclTHEN (exists_tac eq1) reflexivity ] + Tacticals.New.tclTHEN (exists_tac (EConstr.of_constr eq1)) reflexivity ] | SPLIT_INEQ(e,(e1,act1),(e2,act2)) :: l -> let id1 = new_identifier () and id2 = new_identifier () in @@ -1283,7 +1284,7 @@ let replay_history tactic_normalisation = let tac2 = scalar_norm_add [P_APP 2;P_TYPE] e.body in let eq = val_of(decompile e) in Tacticals.New.tclTHENS - (simplest_elim (applist (Lazy.force coq_OMEGA19, [eq; mkVar id]))) + (simplest_elim (EConstr.of_constr (applist (Lazy.force coq_OMEGA19, [eq; mkVar id])))) [Tacticals.New.tclTHENLIST [ Proofview.V82.tactic (mk_then tac1); (intros_using [id1]); (loop act1) ]; Tacticals.New.tclTHENLIST [ Proofview.V82.tactic (mk_then tac2); (intros_using [id2]); (loop act2) ]] | SUM(e3,(k1,e1),(k2,e2)) :: l -> @@ -1433,7 +1434,7 @@ let coq_omega = let i = new_id () in tag_hypothesis id i; (Tacticals.New.tclTHENLIST [ - (simplest_elim (applist (Lazy.force coq_intro_Z, [t]))); + (simplest_elim (EConstr.of_constr (applist (Lazy.force coq_intro_Z, [t])))); (intros_using [v; id]); (elim_id id); (clear [id]); @@ -1444,7 +1445,7 @@ let coq_omega = constant = zero; id = i} :: sys else (Tacticals.New.tclTHENLIST [ - (simplest_elim (applist (Lazy.force coq_new_var, [t]))); + (simplest_elim (EConstr.of_constr (applist (Lazy.force coq_new_var, [t])))); (intros_using [v;th]); tac ]), sys) @@ -1494,7 +1495,7 @@ let nat_inject = let id = new_identifier () in Tacticals.New.tclTHENS (Tacticals.New.tclTHEN - (simplest_elim (applist (Lazy.force coq_le_gt_dec, [t2;t1]))) + (simplest_elim (EConstr.of_constr (applist (Lazy.force coq_le_gt_dec, [t2;t1])))) (intros_using [id])) [ Tacticals.New.tclTHENLIST [ @@ -1793,15 +1794,15 @@ let destructure_hyps = | Kapp(Nat,_) -> Tacticals.New.tclTHENLIST [ (simplest_elim - (mkApp - (Lazy.force coq_not_eq, [|t1;t2;mkVar i|]))); + (EConstr.of_constr (mkApp + (Lazy.force coq_not_eq, [|t1;t2;mkVar i|])))); (onClearedName i (fun _ -> loop lit)) ] | Kapp(Z,_) -> Tacticals.New.tclTHENLIST [ (simplest_elim - (mkApp - (Lazy.force coq_not_Zeq, [|t1;t2;mkVar i|]))); + (EConstr.of_constr (mkApp + (Lazy.force coq_not_Zeq, [|t1;t2;mkVar i|])))); (onClearedName i (fun _ -> loop lit)) ] | _ -> loop lit @@ -1851,7 +1852,7 @@ let destructure_goal = (Proofview.V82.tactic (Tacmach.refine (EConstr.of_constr (mkApp (Lazy.force coq_dec_not_not, [| t; dec; mkNewMeta () |]))))) intro - with Undecidable -> Tactics.elim_type (build_coq_False ()) + with Undecidable -> Tactics.elim_type (EConstr.of_constr (build_coq_False ())) in Tacticals.New.tclTHEN goal_tac destructure_hyps in diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml index 7b6d502b5..2cc402e28 100644 --- a/plugins/quote/quote.ml +++ b/plugins/quote/quote.ml @@ -458,8 +458,8 @@ let quote f lid = | _ -> assert false in match ivs.variable_lhs with - | None -> Tactics.convert_concl (mkApp (f, [| p |])) DEFAULTcast - | Some _ -> Tactics.convert_concl (mkApp (f, [| vm; p |])) DEFAULTcast + | None -> Tactics.convert_concl (EConstr.of_constr (mkApp (f, [| p |]))) DEFAULTcast + | Some _ -> Tactics.convert_concl (EConstr.of_constr (mkApp (f, [| vm; p |]))) DEFAULTcast end } let gen_quote cont c f lid = diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml index ba882e39a..ab5033601 100644 --- a/plugins/romega/refl_omega.ml +++ b/plugins/romega/refl_omega.ml @@ -1222,7 +1222,7 @@ let resolution env full_reified_goal systems_list = (* variables a introduire *) let to_introduce = add_stated_equations env solution_tree in let stated_vars = List.map (fun (v,_,_,_) -> v) to_introduce in - let l_generalize_arg = List.map (fun (_,t,_,_) -> t) to_introduce in + let l_generalize_arg = List.map (fun (_,t,_,_) -> EConstr.of_constr t) to_introduce in let hyp_stated_vars = List.map (fun (_,_,_,id) -> CCEqua id) to_introduce in (* L'environnement de base se construit en deux morceaux : - les variables des équations utiles (et de la conclusion) @@ -1258,6 +1258,7 @@ let resolution env full_reified_goal systems_list = let reified = app coq_interp_sequent [| reified_concl;env_props_reified;env_terms_reified;reified_goal|] in + let reified = EConstr.of_constr reified in let normalize_equation e = let rec loop = function [] -> app (if e.e_negated then coq_p_invert else coq_p_step) @@ -1281,9 +1282,9 @@ let resolution env full_reified_goal systems_list = let decompose_tactic = decompose_tree env context solution_tree in Proofview.V82.of_tactic (Tactics.generalize - (l_generalize_arg @ List.map Term.mkVar (List.tl l_hyps))) >> + (l_generalize_arg @ List.map EConstr.mkVar (List.tl l_hyps))) >> Proofview.V82.of_tactic (Tactics.change_concl reified) >> - Proofview.V82.of_tactic (Tactics.apply (app coq_do_omega [|decompose_tactic; normalization_trace|])) >> + Proofview.V82.of_tactic (Tactics.apply (EConstr.of_constr (app coq_do_omega [|decompose_tactic; normalization_trace|]))) >> show_goal >> Proofview.V82.of_tactic (Tactics.normalise_vm_in_concl) >> (*i Alternatives to the previous line: @@ -1292,7 +1293,7 @@ let resolution env full_reified_goal systems_list = - Skip the conversion check and rely directly on the QED: Tacmach.convert_concl_no_check (Lazy.force coq_True) Term.VMcast >> i*) - Proofview.V82.of_tactic (Tactics.apply (Lazy.force coq_I)) + Proofview.V82.of_tactic (Tactics.apply (EConstr.of_constr (Lazy.force coq_I))) let total_reflexive_omega_tactic gl = Coqlib.check_required_library ["Coq";"romega";"ROmega"]; diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml index f88b3a700..981ce2a61 100644 --- a/plugins/rtauto/refl_tauto.ml +++ b/plugins/rtauto/refl_tauto.ml @@ -312,6 +312,7 @@ let rtauto_tac gls= str "Giving proof term to Coq ... ") end in let tac_start_time = System.get_time () in + let term = EConstr.of_constr term in let result= if !check then Proofview.V82.of_tactic (Tactics.exact_check term) gls diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4 index ace557a52..aa91494eb 100644 --- a/plugins/ssrmatching/ssrmatching.ml4 +++ b/plugins/ssrmatching/ssrmatching.ml4 @@ -1392,6 +1392,7 @@ let ssrpatterntac _ist (arg_ist,arg) gl = fill_occ_pattern (Global.env()) sigma0 concl0 pat noindex 1 in let gl, tty = pf_type_of gl (EConstr.of_constr t) in let concl = mkLetIn (Name (id_of_string "selected"), t, tty, concl_x) in + let concl = EConstr.of_constr concl in Proofview.V82.of_tactic (convert_concl concl DEFAULTcast) gl (* Register "ssrpattern" tactic *) diff --git a/pretyping/cases.ml b/pretyping/cases.ml index 57d12a19f..360199fec 100644 --- a/pretyping/cases.ml +++ b/pretyping/cases.ml @@ -297,7 +297,7 @@ let inductive_template evdref env tmloc ind = | LocalAssum (na,ty) -> let ty = EConstr.of_constr ty in let ty' = substl subst ty in - let e = EConstr.of_constr (e_new_evar env evdref ~src:(hole_source n) ty') in + let e = e_new_evar env evdref ~src:(hole_source n) ty' in (e::subst,e::evarl,n+1) | LocalDef (na,b,ty) -> let b = EConstr.of_constr b in @@ -380,7 +380,7 @@ let coerce_to_indtype typing_fun evdref env matx tomatchl = (* Utils *) let mkExistential env ?(src=(Loc.ghost,Evar_kinds.InternalHole)) evdref = - let e, u = e_new_type_evar env evdref univ_flexible_alg ~src:src in EConstr.of_constr e + let e, u = e_new_type_evar env evdref univ_flexible_alg ~src:src in e let evd_comb2 f evdref x y = let (evd',y) = f !evdref x y in @@ -1663,7 +1663,6 @@ let abstract_tycon loc env evdref subst tycon extenv t = 1 (rel_context env) in let ty = EConstr.of_constr ty in let ev' = e_new_evar env evdref ~src ty in - let ev' = EConstr.of_constr ev' in begin match solve_simple_eqn (evar_conv_x full_transparent_state) env !evdref (None,ev,substl inst ev') with | Success evd -> evdref := evd | UnifFailure _ -> assert false @@ -1698,7 +1697,6 @@ let abstract_tycon loc env evdref subst tycon extenv t = let candidates = u :: List.map mkRel vl in let candidates = List.map EConstr.Unsafe.to_constr candidates in let ev = e_new_evar extenv evdref ~src ~filter ~candidates ty in - let ev = EConstr.of_constr ev in lift k ev in aux (0,extenv,subst0) t0 @@ -1712,7 +1710,6 @@ let build_tycon loc env tycon_env s subst tycon extenv evdref t = let n' = Context.Rel.length (rel_context tycon_env) in let impossible_case_type, u = e_new_type_evar (reset_context env) evdref univ_flexible_alg ~src:(loc,Evar_kinds.ImpossibleCase) in - let impossible_case_type = EConstr.of_constr impossible_case_type in (lift (n'-n) impossible_case_type, mkSort u) | Some t -> let t = abstract_tycon loc tycon_env evdref subst tycon extenv t in @@ -2010,7 +2007,7 @@ let prepare_predicate loc typing_fun env sigma tomatchs arsign tycon pred = let Sigma ((t, _), sigma, _) = new_type_evar env sigma univ_flexible_alg ~src:(loc, Evar_kinds.CasesType false) in let sigma = Sigma.to_evar_map sigma in - sigma, EConstr.of_constr t + sigma, t in (* First strategy: we build an "inversion" predicate *) let sigma1,pred1 = build_inversion_problem loc env sigma tomatchs t in diff --git a/pretyping/classops.ml b/pretyping/classops.ml index 9011186a3..23d20dad3 100644 --- a/pretyping/classops.ml +++ b/pretyping/classops.ml @@ -51,6 +51,7 @@ type coe_info_typ = { coe_param : int } let coe_info_typ_equal c1 c2 = + let eq_constr c1 c2 = Termops.eq_constr Evd.empty (EConstr.of_constr c1) (EConstr.of_constr c2) in eq_constr c1.coe_value c2.coe_value && eq_constr c1.coe_type c2.coe_type && c1.coe_local == c2.coe_local && diff --git a/pretyping/coercion.ml b/pretyping/coercion.ml index e7279df7a..d67976232 100644 --- a/pretyping/coercion.ml +++ b/pretyping/coercion.ml @@ -93,7 +93,7 @@ open Program let make_existential loc ?(opaque = not (get_proofs_transparency ())) env evdref c = let src = (loc, Evar_kinds.QuestionMark (Evar_kinds.Define opaque)) in - EConstr.of_constr (Evarutil.e_new_evar env evdref ~src c) + Evarutil.e_new_evar env evdref ~src c let app_opt env evdref f t = EConstr.of_constr (whd_betaiota !evdref (app_opt f t)) diff --git a/pretyping/detyping.ml b/pretyping/detyping.ml index 4756ec30e..ec8945e85 100644 --- a/pretyping/detyping.ml +++ b/pretyping/detyping.ml @@ -294,7 +294,7 @@ and align_tree nal isgoal (e,c as rhs) sigma = match nal with | na::nal -> match kind_of_term c with | Case (ci,p,c,cl) when - eq_constr c (mkRel (List.index Name.equal na (fst (snd e)))) + eq_constr sigma (EConstr.of_constr c) (EConstr.mkRel (List.index Name.equal na (fst (snd e)))) && not (Int.equal (Array.length cl) 0) && (* don't contract if p dependent *) computable p (List.length ci.ci_pp_info.ind_tags) (* FIXME: can do better *) -> diff --git a/pretyping/evarconv.ml b/pretyping/evarconv.ml index ee6355736..a968af7ff 100644 --- a/pretyping/evarconv.ml +++ b/pretyping/evarconv.ml @@ -890,7 +890,7 @@ and conv_record trs env evd (ctx,(h,h2),c,bs,(params,params1),(us,us2),(sk1,sk2) let i = Sigma.Unsafe.of_evar_map i in let Sigma (ev, i', _) = Evarutil.new_evar env i ~src:dloc (substl ks b) in let i' = Sigma.to_evar_map i' in - (i', EConstr.of_constr ev :: ks, m - 1,test)) + (i', ev :: ks, m - 1,test)) (evd,[],List.length bs,fun i -> Success i) bs in let app = mkApp (c, Array.rev_of_list ks) in @@ -1066,13 +1066,13 @@ let second_order_matching ts env_rhs evd (evk,args) argoccs rhs = | Some _ -> error "Selection of specific occurrences not supported" | None -> let evty = set_holes evdref cty subst in - let instance = List.map EConstr.Unsafe.to_constr (Filter.filter_list filter instance) in + let instance = Filter.filter_list filter instance in let evd = Sigma.Unsafe.of_evar_map !evdref in let Sigma (ev, evd, _) = new_evar_instance sign evd evty ~filter instance in let evd = Sigma.to_evar_map evd in evdref := evd; - evsref := (fst (destEvar !evdref (EConstr.of_constr ev)),evty)::!evsref; - EConstr.of_constr ev in + evsref := (fst (destEvar !evdref ev),evty)::!evsref; + ev in set_holes evdref (apply_on_subterm env_rhs evdref set_var c rhs) subst | [] -> rhs in diff --git a/pretyping/evardefine.ml b/pretyping/evardefine.ml index fa3b9ca0b..3babc48a7 100644 --- a/pretyping/evardefine.ml +++ b/pretyping/evardefine.ml @@ -22,6 +22,11 @@ open Sigma.Notations module RelDecl = Context.Rel.Declaration +let nlocal_assum (na, t) = + let open Context.Named.Declaration in + let inj = EConstr.Unsafe.to_constr in + LocalAssum (na, inj t) + let new_evar_unsafe env evd ?src ?filter ?candidates ?store ?naming ?principal typ = let evd = Sigma.Unsafe.of_evar_map evd in let Sigma (evk, evd, _) = new_evar env evd ?src ?filter ?candidates ?store ?naming ?principal typ in @@ -88,7 +93,7 @@ let define_pure_evar_as_product evd evk = (Sigma.to_evar_map evd1, e) in let evd2,rng = - let newenv = push_named (LocalAssum (id, dom)) evenv in + let newenv = push_named (nlocal_assum (id, dom)) evenv in let src = evar_source evk evd1 in let filter = Filter.extend 1 (evar_filter evi) in if is_prop_sort s then @@ -105,8 +110,7 @@ let define_pure_evar_as_product evd evk = let evd3 = Evd.set_leq_sort evenv evd3 (Type prods) s in evd3, rng in - let rng = EConstr.of_constr rng in - let prod = mkProd (Name id, EConstr.of_constr dom, subst_var id rng) in + let prod = mkProd (Name id, dom, subst_var id rng) in let evd3 = Evd.define evk (EConstr.Unsafe.to_constr prod) evd2 in evd3,prod @@ -140,14 +144,13 @@ let define_pure_evar_as_lambda env evd evk = | Evar ev' -> let evd,typ = define_evar_as_product evd ev' in evd,destProd evd typ | _ -> error_not_product env evd typ in let avoid = ids_of_named_context (evar_context evi) in - let dom = EConstr.Unsafe.to_constr dom in let id = - next_name_away_with_default_using_types "x" na avoid (Reductionops.whd_evar evd dom) in - let newenv = push_named (LocalAssum (id, dom)) evenv in + next_name_away_with_default_using_types "x" na avoid (Reductionops.whd_evar evd (EConstr.Unsafe.to_constr dom)) in + let newenv = push_named (nlocal_assum (id, dom)) evenv in let filter = Filter.extend 1 (evar_filter evi) in let src = evar_source evk evd1 in let evd2,body = new_evar_unsafe newenv evd1 ~src (subst1 (mkVar id) rng) ~filter in - let lam = mkLambda (Name id, EConstr.of_constr dom, subst_var id (EConstr.of_constr body)) in + let lam = mkLambda (Name id, dom, subst_var id body) in Evd.define evk (EConstr.Unsafe.to_constr lam) evd2, lam let define_evar_as_lambda env evd (evk,args) = diff --git a/pretyping/evarsolve.ml b/pretyping/evarsolve.ml index b7db51d5c..4ce8a44ad 100644 --- a/pretyping/evarsolve.ml +++ b/pretyping/evarsolve.ml @@ -518,15 +518,15 @@ let is_unification_pattern (env,nb) evd f l t = let solve_pattern_eqn env sigma l c = let c' = List.fold_right (fun a c -> let c' = subst_term sigma (lift 1 a) (lift 1 c) in + let c' = EConstr.of_constr c' in match EConstr.kind sigma a with (* Rem: if [a] links to a let-in, do as if it were an assumption *) | Rel n -> let open Context.Rel.Declaration in let d = map_constr (CVars.lift n) (lookup_rel n env) in - let c' = EConstr.of_constr c' in mkLambda_or_LetIn d c' | Var id -> - let d = lookup_named id env in EConstr.of_constr (mkNamedLambda_or_LetIn d c') + let d = lookup_named id env in mkNamedLambda_or_LetIn d c' | _ -> assert false) l c in (* Warning: we may miss some opportunity to eta-reduce more since c' @@ -592,10 +592,9 @@ let make_projectable_subst aliases sigma evi args = let define_evar_from_virtual_equation define_fun env evd src t_in_env ty_t_in_sign sign filter inst_in_env = let evd = Sigma.Unsafe.of_evar_map evd in - let Sigma (evar_in_env, evd, _) = new_evar_instance sign evd (EConstr.of_constr ty_t_in_sign) ~filter ~src (List.map EConstr.Unsafe.to_constr inst_in_env) in + let Sigma (evar_in_env, evd, _) = new_evar_instance sign evd (EConstr.of_constr ty_t_in_sign) ~filter ~src inst_in_env in let evd = Sigma.to_evar_map evd in let t_in_env = EConstr.of_constr (whd_evar evd (EConstr.Unsafe.to_constr t_in_env)) in - let evar_in_env = EConstr.of_constr evar_in_env in let (evk, _) = destEvar evd evar_in_env in let evd = define_fun env evd None (EConstr.destEvar evd evar_in_env) t_in_env in let ctxt = named_context_of_val sign in @@ -669,10 +668,10 @@ let materialize_evar define_fun env evd k (evk1,args1) ty_in_env = let evd = Sigma.Unsafe.of_evar_map evd in let ev2ty_in_sign = EConstr.of_constr ev2ty_in_sign in let Sigma (ev2_in_sign, evd, _) = - new_evar_instance sign2 evd ev2ty_in_sign ~filter:filter2 ~src (List.map EConstr.Unsafe.to_constr inst2_in_sign) in + new_evar_instance sign2 evd ev2ty_in_sign ~filter:filter2 ~src inst2_in_sign in let evd = Sigma.to_evar_map evd in - let ev2_in_env = (fst (destEvar evd (EConstr.of_constr ev2_in_sign)), Array.of_list inst2_in_env) in - (evd, EConstr.of_constr ev2_in_sign, ev2_in_env) + let ev2_in_env = (fst (destEvar evd ev2_in_sign), Array.of_list inst2_in_env) in + (evd, ev2_in_sign, ev2_in_env) let restrict_upon_filter evd evk p args = let oldfullfilter = evar_filter (Evd.find_undefined evd evk) in diff --git a/pretyping/inductiveops.ml b/pretyping/inductiveops.ml index e30ba21fd..98b267cfd 100644 --- a/pretyping/inductiveops.ml +++ b/pretyping/inductiveops.ml @@ -556,6 +556,7 @@ let set_pattern_names env ind brv = let type_case_branches_with_names env sigma indspec p c = let (ind,args) = indspec in + let args = List.map EConstr.Unsafe.to_constr args in let (mib,mip as specif) = Inductive.lookup_mind_specif env (fst ind) in let nparams = mib.mind_nparams in let (params,realargs) = List.chop nparams args in diff --git a/pretyping/inductiveops.mli b/pretyping/inductiveops.mli index cf5523a50..7af9731f9 100644 --- a/pretyping/inductiveops.mli +++ b/pretyping/inductiveops.mli @@ -175,7 +175,7 @@ val arity_of_case_predicate : env -> inductive_family -> bool -> sorts -> types val type_case_branches_with_names : - env -> evar_map -> pinductive * constr list -> constr -> constr -> types array * types + env -> evar_map -> pinductive * EConstr.constr list -> constr -> constr -> types array * types (** Annotation for cases *) val make_case_info : env -> inductive -> case_style -> case_info diff --git a/pretyping/pretyping.ml b/pretyping/pretyping.ml index 49a0bccee..7586b54ba 100644 --- a/pretyping/pretyping.ml +++ b/pretyping/pretyping.ml @@ -116,7 +116,7 @@ let lookup_named id env = lookup_named id env.env let e_new_evar env evdref ?src ?naming typ = let subst2 subst vsubst c = csubst_subst subst (replace_vars vsubst c) in let open Context.Named.Declaration in - let inst_vars = List.map (get_id %> Constr.mkVar) (named_context env.env) in + let inst_vars = List.map (get_id %> EConstr.mkVar) (named_context env.env) in let inst_rels = List.rev (rel_list 0 (nb_rel env.env)) in let (subst, vsubst, _, nc) = Lazy.force env.extra in let typ' = subst2 subst vsubst typ in @@ -125,7 +125,7 @@ let e_new_evar env evdref ?src ?naming typ = let sigma = Sigma.Unsafe.of_evar_map !evdref in let Sigma (e, sigma, _) = new_evar_instance sign sigma typ' ?src ?naming instance in evdref := Sigma.to_evar_map sigma; - EConstr.of_constr e + e let push_rec_types (lna,typarray,_) env = let ctxt = Array.map2_i (fun i na t -> local_assum (na, lift i t)) lna typarray in @@ -546,7 +546,7 @@ let new_type_evar env evdref loc = univ_flexible_alg ~src:(loc,Evar_kinds.InternalHole) in evdref := Sigma.to_evar_map sigma; - EConstr.of_constr e + e let (f_genarg_interp, genarg_interp_hook) = Hook.make () diff --git a/pretyping/tacred.ml b/pretyping/tacred.ml index 24d4af89a..1ec8deb1b 100644 --- a/pretyping/tacred.ml +++ b/pretyping/tacred.ml @@ -1196,7 +1196,7 @@ let reduce_to_ind_gen allow_product env sigma t = let t = hnf_constr env sigma t in let t = EConstr.of_constr t in match EConstr.kind sigma (EConstr.of_constr (fst (decompose_app_vect sigma t))) with - | Ind ind-> (check_privacy env ind, EConstr.Unsafe.to_constr (it_mkProd_or_LetIn t l)) + | Ind ind-> (check_privacy env ind, it_mkProd_or_LetIn t l) | Prod (n,ty,t') -> let open Context.Rel.Declaration in if allow_product then @@ -1209,7 +1209,7 @@ let reduce_to_ind_gen allow_product env sigma t = let t' = whd_all env sigma t in let t' = EConstr.of_constr t' in match EConstr.kind sigma (EConstr.of_constr (fst (decompose_app_vect sigma t'))) with - | Ind ind-> (check_privacy env ind, EConstr.Unsafe.to_constr (it_mkProd_or_LetIn t' l)) + | Ind ind-> (check_privacy env ind, it_mkProd_or_LetIn t' l) | _ -> user_err (str"Not an inductive product.") in elimrec env t [] @@ -1219,7 +1219,7 @@ let reduce_to_atomic_ind env sigma c = reduce_to_ind_gen false env sigma c let find_hnf_rectype env sigma t = let ind,t = reduce_to_atomic_ind env sigma t in - ind, snd (Term.decompose_app t) + ind, snd (decompose_app sigma t) (* Reduce the weak-head redex [beta,iota/fix/cofix[all],cast,zeta,simpl/delta] or raise [NotStepReducible] if not a weak-head redex *) @@ -1295,7 +1295,7 @@ let reduce_to_ref_gen allow_product env sigma ref t = elimrec env t' l with NotStepReducible -> error_cannot_recognize ref in - EConstr.Unsafe.to_constr (elimrec env t []) + elimrec env t [] let reduce_to_quantified_ref = reduce_to_ref_gen true let reduce_to_atomic_ref = reduce_to_ref_gen false diff --git a/pretyping/tacred.mli b/pretyping/tacred.mli index 3587ae281..15b4e990d 100644 --- a/pretyping/tacred.mli +++ b/pretyping/tacred.mli @@ -75,23 +75,23 @@ val cbv_norm_flags : CClosure.RedFlags.reds -> reduction_function (** [reduce_to_atomic_ind env sigma t] puts [t] in the form [t'=(I args)] with [I] an inductive definition; returns [I] and [t'] or fails with a user error *) -val reduce_to_atomic_ind : env -> evar_map -> EConstr.types -> pinductive * types +val reduce_to_atomic_ind : env -> evar_map -> EConstr.types -> pinductive * EConstr.types (** [reduce_to_quantified_ind env sigma t] puts [t] in the form [t'=(x1:A1)..(xn:An)(I args)] with [I] an inductive definition; returns [I] and [t'] or fails with a user error *) -val reduce_to_quantified_ind : env -> evar_map -> EConstr.types -> pinductive * types +val reduce_to_quantified_ind : env -> evar_map -> EConstr.types -> pinductive * EConstr.types (** [reduce_to_quantified_ref env sigma ref t] try to put [t] in the form [t'=(x1:A1)..(xn:An)(ref args)] and fails with user error if not possible *) val reduce_to_quantified_ref : - env -> evar_map -> global_reference -> EConstr.types -> types + env -> evar_map -> global_reference -> EConstr.types -> EConstr.types val reduce_to_atomic_ref : - env -> evar_map -> global_reference -> EConstr.types -> types + env -> evar_map -> global_reference -> EConstr.types -> EConstr.types val find_hnf_rectype : - env -> evar_map -> EConstr.types -> pinductive * constr list + env -> evar_map -> EConstr.types -> pinductive * EConstr.constr list val contextually : bool -> occurrences * constr_pattern -> (patvar_map -> reduction_function) -> reduction_function diff --git a/pretyping/unification.ml b/pretyping/unification.ml index 2b2069ec4..bc59a4108 100644 --- a/pretyping/unification.ml +++ b/pretyping/unification.ml @@ -133,14 +133,14 @@ let abstract_list_all_with_dependencies env evd typ c l = let evd = Sigma.Unsafe.of_evar_map evd in let Sigma (ev, evd, _) = new_evar env evd typ in let evd = Sigma.to_evar_map evd in - let evd,ev' = evar_absorb_arguments env evd (destEvar evd (EConstr.of_constr ev)) l in + let evd,ev' = evar_absorb_arguments env evd (destEvar evd ev) l in let n = List.length l in let argoccs = set_occurrences_of_last_arg (Array.sub (snd ev') 0 n) in let evd,b = Evarconv.second_order_matching empty_transparent_state env evd ev' argoccs c in if b then - let p = nf_evar evd ev in + let p = nf_evar evd (EConstr.Unsafe.to_constr ev) in evd, p else error_cannot_find_well_typed_abstraction env evd c l None @@ -184,8 +184,8 @@ let pose_all_metas_as_evars env evd t = let ty = if Evd.Metaset.is_empty mvs then ty else aux ty in let src = Evd.evar_source_of_meta mv !evdref in let ev = Evarutil.e_new_evar env evdref ~src ty in - evdref := meta_assign mv (ev,(Conv,TypeNotProcessed)) !evdref; - EConstr.of_constr ev) + evdref := meta_assign mv (EConstr.Unsafe.to_constr ev,(Conv,TypeNotProcessed)) !evdref; + ev) | _ -> EConstr.map !evdref aux t in let c = aux t in @@ -1236,7 +1236,6 @@ let applyHead env (type r) (evd : r Sigma.t) n c = match EConstr.kind sigma (EConstr.of_constr (whd_all env sigma cty)) with | Prod (_,c1,c2) -> let Sigma (evar, evd', q) = Evarutil.new_evar env evd ~src:(Loc.ghost,Evar_kinds.GoalEvar) c1 in - let evar = EConstr.of_constr evar in apprec (n-1) (mkApp(c,[|evar|])) (subst1 evar c2) (p +> q) evd' | _ -> error "Apply_Head_Then" in diff --git a/proofs/clenv.ml b/proofs/clenv.ml index fd88e3c51..514fc27e8 100644 --- a/proofs/clenv.ml +++ b/proofs/clenv.ml @@ -337,7 +337,6 @@ let clenv_pose_metas_as_evars clenv dep_mvs = let evd = Sigma.Unsafe.of_evar_map clenv.evd in let Sigma (evar, evd, _) = new_evar (cl_env clenv) evd ~src ty in let evd = Sigma.to_evar_map evd in - let evar = EConstr.of_constr evar in let clenv = clenv_assign mv evar {clenv with evd=evd} in fold clenv mvs in fold clenv dep_mvs @@ -619,7 +618,6 @@ let make_evar_clause env sigma ?len t = let sigma = Sigma.Unsafe.of_evar_map sigma in let Sigma (ev, sigma, _) = new_evar ~store env sigma t1 in let sigma = Sigma.to_evar_map sigma in - let ev = EConstr.of_constr ev in let dep = not (noccurn sigma 1 t2) in let hole = { hole_evar = ev; diff --git a/proofs/tacmach.mli b/proofs/tacmach.mli index 07d02212c..cfbfe12b1 100644 --- a/proofs/tacmach.mli +++ b/proofs/tacmach.mli @@ -67,8 +67,8 @@ val pf_whd_all : goal sigma -> EConstr.constr -> constr val pf_hnf_constr : goal sigma -> EConstr.constr -> constr val pf_nf : goal sigma -> EConstr.constr -> constr val pf_nf_betaiota : goal sigma -> EConstr.constr -> constr -val pf_reduce_to_quantified_ind : goal sigma -> EConstr.types -> pinductive * types -val pf_reduce_to_atomic_ind : goal sigma -> EConstr.types -> pinductive * types +val pf_reduce_to_quantified_ind : goal sigma -> EConstr.types -> pinductive * EConstr.types +val pf_reduce_to_atomic_ind : goal sigma -> EConstr.types -> pinductive * EConstr.types val pf_compute : goal sigma -> EConstr.constr -> constr val pf_unfoldn : (occurrences * evaluable_global_reference) list -> goal sigma -> EConstr.constr -> constr @@ -121,7 +121,7 @@ module New : sig val pf_last_hyp : ([ `NF ], 'r) Proofview.Goal.t -> Context.Named.Declaration.t val pf_nf_concl : ([ `LZ ], 'r) Proofview.Goal.t -> types - val pf_reduce_to_quantified_ind : ('a, 'r) Proofview.Goal.t -> EConstr.types -> pinductive * types + val pf_reduce_to_quantified_ind : ('a, 'r) Proofview.Goal.t -> EConstr.types -> pinductive * EConstr.types val pf_hnf_constr : ('a, 'r) Proofview.Goal.t -> EConstr.constr -> types val pf_hnf_type_of : ('a, 'r) Proofview.Goal.t -> EConstr.constr -> types diff --git a/stm/lemmas.ml b/stm/lemmas.ml index 9896d5a93..04f888a84 100644 --- a/stm/lemmas.ml +++ b/stm/lemmas.ml @@ -393,7 +393,7 @@ let start_proof_univs id ?pl kind sigma ?terminator ?sign c ?init_tac ?(compute_ let rec_tac_initializer finite guard thms snl = if finite then - match List.map (fun ((id,_),(t,_)) -> (id,t)) thms with + match List.map (fun ((id,_),(t,_)) -> (id,EConstr.of_constr t)) thms with | (id,_)::l -> Tactics.mutual_cofix id l 0 | _ -> assert false else @@ -401,7 +401,7 @@ let rec_tac_initializer finite guard thms snl = let nl = match snl with | None -> List.map succ (List.map List.last guard) | Some nl -> nl - in match List.map2 (fun ((id,_),(t,_)) n -> (id,n,t)) thms nl with + in match List.map2 (fun ((id,_),(t,_)) n -> (id,n, EConstr.of_constr t)) thms nl with | (id,n,_)::l -> Tactics.mutual_fix id n l 0 | _ -> assert false diff --git a/stm/stm.ml b/stm/stm.ml index 6012e3d2d..d60412c0c 100644 --- a/stm/stm.ml +++ b/stm/stm.ml @@ -1792,7 +1792,7 @@ end = struct (* {{{ *) str"uc=" ++ Evd.pr_evar_universe_context uc))); (if abstract then Tactics.tclABSTRACT None else (fun x -> x)) (V82.tactic (Refiner.tclPUSHEVARUNIVCONTEXT uc) <*> - Tactics.exact_no_check pt) + Tactics.exact_no_check (EConstr.of_constr pt)) with TacTask.NoProgress -> if solve then Tacticals.New.tclSOLVE [] else tclUNIT () }) diff --git a/tactics/auto.ml b/tactics/auto.ml index 2b654f563..41b56bd3d 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 a8768b6ed..7d8fc79f4 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 a8be704b2..a92b14dbe 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 b876aee90..5cc4b2e01 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 7b07c9309..24e4de750 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 d00e504ff..e641f970a 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 ed81d748a..eb75cbf7d 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 92480e253..57bac25b9 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 e1a8d2bdb..80f83f19b 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 779d1e9b2..97f51ae20 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 ea95fb1ad..560e7e43d 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 a971b9356..c66b356c7 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 df629e7c9..6bb2b7282 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 16a048af8..a94238418 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 c6ed9606f..58b82002d 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 0546132c1..e15ee149d 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 974bf83a3..2c3e51280 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 a04fb7ca2..b9da11021 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 368a1df76..630c660a1 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 6294f9fdc..38342b64d 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) [] diff --git a/toplevel/auto_ind_decl.ml b/toplevel/auto_ind_decl.ml index 6561627f6..7759c400c 100644 --- a/toplevel/auto_ind_decl.ml +++ b/toplevel/auto_ind_decl.ml @@ -386,9 +386,10 @@ let do_replace_lb mode lb_scheme_key aavoid narg p q = (Array.map (fun x -> x) v) (Array.map (fun x -> do_arg x 1) v)) (Array.map (fun x -> do_arg x 2) v) - in let app = if Array.equal eq_constr lb_args [||] + in let app = if Array.equal Term.eq_constr lb_args [||] then lb_type_of_p else mkApp (lb_type_of_p,lb_args) in + let app = EConstr.of_constr app in Tacticals.New.tclTHENLIST [ Proofview.tclEFFECTS eff; Equality.replace p q ; apply app ; Auto.default_auto] @@ -426,7 +427,7 @@ let do_replace_bl mode bl_scheme_key (ind,u as indu) aavoid narg lft rgt = | (t1::q1,t2::q2) -> Proofview.Goal.enter { enter = begin fun gl -> let tt1 = Tacmach.New.pf_unsafe_type_of gl (EConstr.of_constr t1) in - if eq_constr t1 t2 then aux q1 q2 + if Term.eq_constr t1 t2 then aux q1 q2 else ( let u,v = try destruct_ind tt1 (* trick so that the good sequence is returned*) @@ -455,9 +456,10 @@ let do_replace_bl mode bl_scheme_key (ind,u as indu) aavoid narg lft rgt = (Array.map (fun x -> do_arg x 1) v)) (Array.map (fun x -> do_arg x 2) v ) in - let app = if Array.equal eq_constr bl_args [||] + let app = if Array.equal Term.eq_constr bl_args [||] then bl_t1 else mkApp (bl_t1,bl_args) in + let app = EConstr.of_constr app in Tacticals.New.tclTHENLIST [ Proofview.tclEFFECTS eff; Equality.replace_by t1 t2 @@ -515,7 +517,7 @@ let eqI ind l = try let c, eff = find_scheme beq_scheme_kind ind in mkConst c, eff with Not_found -> user_err ~hdr:"AutoIndDecl.eqI" (str "The boolean equality on " ++ pr_mind (fst ind) ++ str " is needed."); - in (if Array.equal eq_constr eA [||] then e else mkApp(e,eA)), eff + in (if Array.equal Term.eq_constr eA [||] then e else mkApp(e,eA)), eff (**********************************************************************) (* Boolean->Leibniz *) @@ -580,9 +582,9 @@ let compute_bl_tact mode bl_scheme_key ind lnamesparrec nparrec = (* try with *) Tacticals.New.tclTHENLIST [ intros_using fresh_first_intros; intro_using freshn ; - induct_on (mkVar freshn); + induct_on (EConstr.mkVar freshn); intro_using freshm; - destruct_on (mkVar freshm); + destruct_on (EConstr.mkVar freshm); intro_using freshz; intros; Tacticals.New.tclTRY ( @@ -594,10 +596,10 @@ repeat ( apply andb_prop in z;let z1:= fresh "Z" in destruct z as [z1 z]). *) Tacticals.New.tclREPEAT ( Tacticals.New.tclTHENLIST [ - Simple.apply_in freshz (andb_prop()); + Simple.apply_in freshz (EConstr.of_constr (andb_prop())); Proofview.Goal.nf_enter { enter = begin fun gl -> let fresht = fresh_id (Id.of_string "Z") gl in - destruct_on_as (mkVar freshz) + destruct_on_as (EConstr.mkVar freshz) (IntroOrPattern [[dl,IntroNaming (IntroIdentifier fresht); dl,IntroNaming (IntroIdentifier freshz)]]) end } @@ -723,19 +725,19 @@ let compute_lb_tact mode lb_scheme_key ind lnamesparrec nparrec = (* try with *) Tacticals.New.tclTHENLIST [ intros_using fresh_first_intros; intro_using freshn ; - induct_on (mkVar freshn); + induct_on (EConstr.mkVar freshn); intro_using freshm; - destruct_on (mkVar freshm); + destruct_on (EConstr.mkVar freshm); intro_using freshz; intros; Tacticals.New.tclTRY ( Tacticals.New.tclORELSE reflexivity (Equality.discr_tac false None) ); - Equality.inj None false None (mkVar freshz,NoBindings); + Equality.inj None false None (EConstr.mkVar freshz,NoBindings); intros; simpl_in_concl; Auto.default_auto; Tacticals.New.tclREPEAT ( - Tacticals.New.tclTHENLIST [apply (andb_true_intro()); + Tacticals.New.tclTHENLIST [apply (EConstr.of_constr (andb_true_intro())); simplest_split ;Auto.default_auto ] ); Proofview.Goal.nf_enter { enter = begin fun gls -> @@ -888,18 +890,18 @@ let compute_dec_tact ind lnamesparrec nparrec = intros_using fresh_first_intros; intros_using [freshn;freshm]; (*we do this so we don't have to prove the same goal twice *) - assert_by (Name freshH) ( + assert_by (Name freshH) (EConstr.of_constr ( mkApp(sumbool(),[|eqtrue eqbnm; eqfalse eqbnm|]) - ) - (Tacticals.New.tclTHEN (destruct_on eqbnm) Auto.default_auto); + )) + (Tacticals.New.tclTHEN (destruct_on (EConstr.of_constr eqbnm)) Auto.default_auto); Proofview.Goal.nf_enter { enter = begin fun gl -> let freshH2 = fresh_id (Id.of_string "H") gl in - Tacticals.New.tclTHENS (destruct_on_using (mkVar freshH) freshH2) [ + Tacticals.New.tclTHENS (destruct_on_using (EConstr.mkVar freshH) freshH2) [ (* left *) Tacticals.New.tclTHENLIST [ simplest_left; - apply (mkApp(blI,Array.map(fun x->mkVar x) xargs)); + apply (EConstr.of_constr (mkApp(blI,Array.map(fun x->mkVar x) xargs))); Auto.default_auto ] ; @@ -913,9 +915,9 @@ let compute_dec_tact ind lnamesparrec nparrec = intro; Equality.subst_all (); assert_by (Name freshH3) - (mkApp(eq,[|bb;mkApp(eqI,[|mkVar freshm;mkVar freshm|]);tt|])) + (EConstr.of_constr (mkApp(eq,[|bb;mkApp(eqI,[|mkVar freshm;mkVar freshm|]);tt|]))) (Tacticals.New.tclTHENLIST [ - apply (mkApp(lbI,Array.map (fun x->mkVar x) xargs)); + apply (EConstr.of_constr (mkApp(lbI,Array.map (fun x->mkVar x) xargs))); Auto.default_auto ]); Equality.general_rewrite_bindings_in true diff --git a/toplevel/command.ml b/toplevel/command.ml index 80f3b26e4..08f3ad4a7 100644 --- a/toplevel/command.ml +++ b/toplevel/command.ml @@ -1030,8 +1030,8 @@ let build_wellfounded (recname,pl,n,bl,arityc,body) poly r measure notation = let def = mkApp (Universes.constr_of_global (delayed_force fix_sub_ref), [| argtyp ; wf_rel ; - Evarutil.e_new_evar env evdref - ~src:(Loc.ghost, Evar_kinds.QuestionMark (Evar_kinds.Define false)) (EConstr.of_constr wf_proof); + EConstr.Unsafe.to_constr (Evarutil.e_new_evar env evdref + ~src:(Loc.ghost, Evar_kinds.QuestionMark (Evar_kinds.Define false)) (EConstr.of_constr wf_proof)); prop |]) in let def = Typing.e_solve_evars env evdref (EConstr.of_constr def) in |