diff options
Diffstat (limited to 'plugins')
136 files changed, 17600 insertions, 5774 deletions
diff --git a/plugins/btauto/g_btauto.ml4 b/plugins/btauto/g_btauto.ml4 index f3e2c99f4..298027448 100644 --- a/plugins/btauto/g_btauto.ml4 +++ b/plugins/btauto/g_btauto.ml4 @@ -8,6 +8,8 @@ (*i camlp4deps: "grammar/grammar.cma" i*) +open Ltac_plugin + DECLARE PLUGIN "btauto_plugin" TACTIC EXTEND btauto diff --git a/plugins/btauto/refl_btauto.ml b/plugins/btauto/refl_btauto.ml index 2c5b108e5..a0b04ce3b 100644 --- a/plugins/btauto/refl_btauto.ml +++ b/plugins/btauto/refl_btauto.ml @@ -14,8 +14,8 @@ let get_inductive dir s = let glob_ref () = Coqlib.find_reference contrib_name ("Coq" :: dir) s in Lazy.from_fun (fun () -> Globnames.destIndRef (glob_ref ())) -let decomp_term (c : Term.constr) = - Term.kind_of_term (Termops.strip_outer_cast c) +let decomp_term sigma (c : Term.constr) = + Term.kind_of_term (EConstr.Unsafe.to_constr (Termops.strip_outer_cast sigma (EConstr.of_constr c))) let lapp c v = Term.mkApp (Lazy.force c, v) @@ -105,7 +105,7 @@ module Bool = struct | Negb of t | Ifb of t * t * t - let quote (env : Env.t) (c : Term.constr) : t = + let quote (env : Env.t) sigma (c : Term.constr) : t = let trueb = Lazy.force trueb in let falseb = Lazy.force falseb in let andb = Lazy.force andb in @@ -113,7 +113,7 @@ module Bool = struct let xorb = Lazy.force xorb in let negb = Lazy.force negb in - let rec aux c = match decomp_term c with + let rec aux c = match decomp_term sigma c with | Term.App (head, args) -> if head === andb && Array.length args = 2 then Andb (aux args.(0), aux args.(1)) @@ -179,9 +179,11 @@ module Btauto = struct let print_counterexample p env gl = let var = lapp witness [|p|] in + let var = EConstr.of_constr var in (* Compute an assignment that dissatisfies the goal *) let _, var = Tacmach.pf_reduction_of_red_expr gl (Genredexpr.CbvVm None) var in - let rec to_list l = match decomp_term l with + let var = EConstr.Unsafe.to_constr var in + let rec to_list l = match decomp_term (Tacmach.project gl) l with | Term.App (c, _) when c === (Lazy.force CoqList._nil) -> [] | Term.App (c, [|_; h; t|]) @@ -220,7 +222,8 @@ module Btauto = struct Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in let eq = Lazy.force eq in - let t = decomp_term concl in + let concl = EConstr.Unsafe.to_constr concl in + let t = decomp_term (Tacmach.New.project gl) concl in match t with | Term.App (c, [|typ; p; _|]) when c === eq -> (* should be an equality [@eq poly ?p (Cst false)] *) @@ -234,22 +237,25 @@ module Btauto = struct let tac = Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in + let concl = EConstr.Unsafe.to_constr concl in + let sigma = Tacmach.New.project gl in let eq = Lazy.force eq in let bool = Lazy.force Bool.typ in - let t = decomp_term concl in + let t = decomp_term sigma concl in match t with | Term.App (c, [|typ; tl; tr|]) when typ === bool && c === eq -> let env = Env.empty () in - let fl = Bool.quote env tl in - let fr = Bool.quote env tr in + let fl = Bool.quote env sigma tl in + let fr = Bool.quote env sigma tr in let env = Env.to_list env in 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/ccalgo.ml b/plugins/cc/ccalgo.ml index bc53b113d..aa71a4565 100644 --- a/plugins/cc/ccalgo.ml +++ b/plugins/cc/ccalgo.ml @@ -444,7 +444,7 @@ and applist_projection c l = let p = Projection.make (fst c) false in (match l with | [] -> (* Expand the projection *) - let ty,_ = Typeops.type_of_constant (Global.env ()) c in + let ty = Typeops.type_of_constant_in (Global.env ()) c in (* FIXME constraints *) let pb = Environ.lookup_projection p (Global.env()) in let ctx,_ = Term.decompose_prod_n_assum (pb.Declarations.proj_npars + 1) ty in it_mkLambda_or_LetIn (mkProj(p,mkRel 1)) ctx @@ -452,8 +452,9 @@ and applist_projection c l = applistc (mkProj (p, hd)) tl) | _ -> applistc c l -let rec canonize_name c = - let func = canonize_name in +let rec canonize_name sigma c = + let c = EConstr.Unsafe.to_constr c in + let func c = canonize_name sigma (EConstr.of_constr c) in match kind_of_term c with | Const (kn,u) -> let canon_const = constant_of_kn (canonical_con kn) in @@ -497,10 +498,10 @@ let rec inst_pattern subst = function args t let pr_idx_term uf i = str "[" ++ int i ++ str ":=" ++ - Termops.print_constr (constr_of_term (term uf i)) ++ str "]" + Termops.print_constr (EConstr.of_constr (constr_of_term (term uf i))) ++ str "]" let pr_term t = str "[" ++ - Termops.print_constr (constr_of_term t) ++ str "]" + Termops.print_constr (EConstr.of_constr (constr_of_term t)) ++ str "]" let rec add_term state t= let uf=state.uf in @@ -508,8 +509,8 @@ let rec add_term state t= Not_found -> let b=next uf in let trm = constr_of_term t in - let typ = pf_unsafe_type_of state.gls trm in - let typ = canonize_name typ in + let typ = pf_unsafe_type_of state.gls (EConstr.of_constr trm) in + let typ = canonize_name (project state.gls) typ in let new_node= match t with Symb _ | Product (_,_) -> @@ -615,7 +616,7 @@ let add_inst state (inst,int_subst) = begin debug (fun () -> (str "Adding new equality, depth="++ int state.rew_depth) ++ fnl () ++ - (str " [" ++ Termops.print_constr prf ++ str " : " ++ + (str " [" ++ Termops.print_constr (EConstr.of_constr prf) ++ str " : " ++ pr_term s ++ str " == " ++ pr_term t ++ str "]")); add_equality state prf s t end @@ -623,7 +624,7 @@ let add_inst state (inst,int_subst) = begin debug (fun () -> (str "Adding new disequality, depth="++ int state.rew_depth) ++ fnl () ++ - (str " [" ++ Termops.print_constr prf ++ str " : " ++ + (str " [" ++ Termops.print_constr (EConstr.of_constr prf) ++ str " : " ++ pr_term s ++ str " <> " ++ pr_term t ++ str "]")); add_disequality state (Hyp prf) s t end @@ -832,7 +833,8 @@ let complete_one_class state i= let id = new_state_var etyp state in app (Appli(t,Eps id)) (substl [mkVar id] rest) (n-1) in let _c = pf_unsafe_type_of state.gls - (constr_of_term (term state.uf pac.cnode)) in + (EConstr.of_constr (constr_of_term (term state.uf pac.cnode))) in + let _c = EConstr.Unsafe.to_constr _c in let _args = List.map (fun i -> constr_of_term (term state.uf i)) pac.args in diff --git a/plugins/cc/cctac.ml b/plugins/cc/cctac.ml index b5ca2f50f..00b31ccce 100644 --- a/plugins/cc/cctac.ml +++ b/plugins/cc/cctac.ml @@ -13,6 +13,7 @@ open Names open Inductiveops open Declarations open Term +open EConstr open Vars open Tacmach open Tactics @@ -39,13 +40,11 @@ let _False = reference ["Init";"Logic"] "False" let _True = reference ["Init";"Logic"] "True" let _I = reference ["Init";"Logic"] "I" -let whd env= - let infos=CClosure.create_clos_infos CClosure.betaiotazeta env in - (fun t -> CClosure.whd_val infos (CClosure.inject t)) +let whd env sigma t = + Reductionops.clos_whd_flags CClosure.betaiotazeta env sigma t -let whd_delta env= - let infos=CClosure.create_clos_infos CClosure.all env in - (fun t -> CClosure.whd_val infos (CClosure.inject t)) +let whd_delta env sigma t = + Reductionops.clos_whd_flags CClosure.all env sigma t (* decompose member of equality in an applicative format *) @@ -53,12 +52,12 @@ let whd_delta env= let sf_of env sigma c = e_sort_of env (ref sigma) c let rec decompose_term env sigma t= - match kind_of_term (whd env t) with + match EConstr.kind sigma (whd env sigma t) with App (f,args)-> let tf=decompose_term env sigma f in let targs=Array.map (decompose_term env sigma) args in Array.fold_left (fun s t->Appli (s,t)) tf targs - | Prod (_,a,_b) when not (Termops.dependent (mkRel 1) _b) -> + | Prod (_,a,_b) when noccurn sigma 1 _b -> let b = Termops.pop _b in let sort_b = sf_of env sigma b in let sort_a = sf_of env sigma a in @@ -67,6 +66,7 @@ let rec decompose_term env sigma t= decompose_term env sigma b) | Construct c -> let (((mind,i_ind),i_con),u)= c in + let u = EInstance.kind sigma u in let canon_mind = mind_of_kn (canonical_mind mind) in let canon_ind = canon_mind,i_ind in let (oib,_)=Global.lookup_inductive (canon_ind) in @@ -76,28 +76,30 @@ let rec decompose_term env sigma t= ci_nhyps=nargs-oib.mind_nparams} | Ind c -> let (mind,i_ind),u = c in + let u = EInstance.kind sigma u in let canon_mind = mind_of_kn (canonical_mind mind) in - let canon_ind = canon_mind,i_ind in (Symb (mkIndU (canon_ind,u))) + let canon_ind = canon_mind,i_ind in (Symb (Constr.mkIndU (canon_ind,u))) | Const (c,u) -> + let u = EInstance.kind sigma u in let canon_const = constant_of_kn (canonical_con c) in - (Symb (mkConstU (canon_const,u))) + (Symb (Constr.mkConstU (canon_const,u))) | Proj (p, c) -> let canon_const kn = constant_of_kn (canonical_con kn) in let p' = Projection.map canon_const p in - (Appli (Symb (mkConst (Projection.constant p')), decompose_term env sigma c)) + (Appli (Symb (Constr.mkConst (Projection.constant p')), decompose_term env sigma c)) | _ -> - let t = Termops.strip_outer_cast t in - if closed0 t then Symb t else raise Not_found + let t = Termops.strip_outer_cast sigma t in + if closed0 sigma t then Symb (EConstr.to_constr sigma t) else raise Not_found (* decompose equality in members and type *) -open Globnames +open Termops let atom_of_constr env sigma term = - let wh = (whd_delta env term) in - let kot = kind_of_term wh in + let wh = whd_delta env sigma term in + let kot = EConstr.kind sigma wh in match kot with App (f,args)-> - if is_global (Lazy.force _eq) f && Int.equal (Array.length args) 3 + if is_global sigma (Lazy.force _eq) f && Int.equal (Array.length args) 3 then `Eq (args.(0), decompose_term env sigma args.(1), decompose_term env sigma args.(2)) @@ -105,14 +107,14 @@ let atom_of_constr env sigma term = | _ -> `Other (decompose_term env sigma term) let rec pattern_of_constr env sigma c = - match kind_of_term (whd env c) with + match EConstr.kind sigma (whd env sigma c) with App (f,args)-> let pf = decompose_term env sigma f in let pargs,lrels = List.split (Array.map_to_list (pattern_of_constr env sigma) args) in PApp (pf,List.rev pargs), List.fold_left Int.Set.union Int.Set.empty lrels - | Prod (_,a,_b) when not (Termops.dependent (mkRel 1) _b) -> + | Prod (_,a,_b) when noccurn sigma 1 _b -> let b = Termops.pop _b in let pa,sa = pattern_of_constr env sigma a in let pb,sb = pattern_of_constr env sigma b in @@ -131,19 +133,19 @@ let non_trivial = function let patterns_of_constr env sigma nrels term= let f,args= - try destApp (whd_delta env term) with DestKO -> raise Not_found in - if is_global (Lazy.force _eq) f && Int.equal (Array.length args) 3 + try destApp sigma (whd_delta env sigma term) with DestKO -> raise Not_found in + if is_global sigma (Lazy.force _eq) f && Int.equal (Array.length args) 3 then let patt1,rels1 = pattern_of_constr env sigma args.(1) and patt2,rels2 = pattern_of_constr env sigma args.(2) in let valid1 = if not (Int.equal (Int.Set.cardinal rels1) nrels) then Creates_variables else if non_trivial patt1 then Normal - else Trivial args.(0) + else Trivial (EConstr.to_constr sigma args.(0)) and valid2 = if not (Int.equal (Int.Set.cardinal rels2) nrels) then Creates_variables else if non_trivial patt2 then Normal - else Trivial args.(0) in + else Trivial (EConstr.to_constr sigma args.(0)) in if valid1 != Creates_variables || valid2 != Creates_variables then nrels,valid1,patt1,valid2,patt2 @@ -151,28 +153,28 @@ let patterns_of_constr env sigma nrels term= else raise Not_found let rec quantified_atom_of_constr env sigma nrels term = - match kind_of_term (whd_delta env term) with + match EConstr.kind sigma (whd_delta env sigma term) with Prod (id,atom,ff) -> - if is_global (Lazy.force _False) ff then + if is_global sigma (Lazy.force _False) ff then let patts=patterns_of_constr env sigma nrels atom in `Nrule patts else - quantified_atom_of_constr (Environ.push_rel (RelDecl.LocalAssum (id,atom)) env) sigma (succ nrels) ff + quantified_atom_of_constr (EConstr.push_rel (RelDecl.LocalAssum (id,atom)) env) sigma (succ nrels) ff | _ -> let patts=patterns_of_constr env sigma nrels term in `Rule patts let litteral_of_constr env sigma term= - match kind_of_term (whd_delta env term) with + match EConstr.kind sigma (whd_delta env sigma term) with | Prod (id,atom,ff) -> - if is_global (Lazy.force _False) ff then + if is_global sigma (Lazy.force _False) ff then match (atom_of_constr env sigma atom) with `Eq(t,a,b) -> `Neq(t,a,b) | `Other(p) -> `Nother(p) else begin try - quantified_atom_of_constr (Environ.push_rel (RelDecl.LocalAssum (id,atom)) env) sigma 1 ff + quantified_atom_of_constr (EConstr.push_rel (RelDecl.LocalAssum (id,atom)) env) sigma 1 ff with Not_found -> `Other (decompose_term env sigma term) end @@ -183,9 +185,10 @@ let litteral_of_constr env sigma term= (* store all equalities from the context *) let make_prb gls depth additionnal_terms = + let open Tacmach.New in let env=pf_env gls in - let sigma=sig_sig gls in - let state = empty depth gls in + let sigma=project gls in + let state = empty depth {it = Proofview.Goal.goal (Proofview.Goal.assume gls); sigma } in let pos_hyps = ref [] in let neg_hyps =ref [] in List.iter @@ -196,7 +199,7 @@ let make_prb gls depth additionnal_terms = (fun decl -> let id = NamedDecl.get_id decl in begin - let cid=mkVar id in + let cid=Constr.mkVar id in match litteral_of_constr env sigma (NamedDecl.get_type decl) with `Eq (t,a,b) -> add_equality state cid a b | `Neq (t,a,b) -> add_disequality state (Hyp cid) a b @@ -214,9 +217,9 @@ let make_prb gls depth additionnal_terms = neg_hyps:=(cid,nh):: !neg_hyps | `Rule patts -> add_quant state id true patts | `Nrule patts -> add_quant state id false patts - end) (Environ.named_context_of_val (Goal.V82.nf_hyps gls.sigma gls.it)); + end) (Proofview.Goal.hyps gls); begin - match atom_of_constr env sigma (Evarutil.nf_evar sigma (pf_concl gls)) with + match atom_of_constr env sigma (pf_concl gls) with `Eq (t,a,b) -> add_disequality state Goal a b | `Other g -> List.iter @@ -228,6 +231,7 @@ let make_prb gls depth additionnal_terms = (* indhyps builds the array of arrays of constructor hyps for (ind largs) *) let build_projection intype (cstr:pconstructor) special default gls= + let open Tacmach.New in let ci= (snd(fst cstr)) in let body=Equality.build_selector (pf_env gls) (project gls) ci (mkRel 1) intype special default in let id=pf_get_new_id (Id.of_string "t") gls in @@ -235,20 +239,43 @@ let build_projection intype (cstr:pconstructor) special default gls= (* generate an adhoc tactic following the proof tree *) -let _M =mkMeta - let app_global f args k = - Tacticals.pf_constr_of_global (Lazy.force f) (fun fc -> k (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))) - -let new_refine c = Proofview.V82.tactic (refine c) + Tacticals.New.pf_constr_of_global (Lazy.force f) >>= fun fc -> k (mkApp (fc, args)) + +let rec gen_holes env sigma t n accu = + let open Sigma in + if Int.equal n 0 then (sigma, List.rev accu) + else match EConstr.kind sigma t with + | Prod (_, u, t) -> + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma (ev, sigma, _) = Evarutil.new_evar env sigma u in + let sigma = Sigma.to_evar_map sigma in + let t = EConstr.Vars.subst1 ev t in + gen_holes env sigma t (pred n) (ev :: accu) + | _ -> assert false + +let app_global_with_holes f args n = + Proofview.Goal.enter { enter = begin fun gl -> + Tacticals.New.pf_constr_of_global (Lazy.force f) >>= fun fc -> + let env = Proofview.Goal.env gl in + let concl = Proofview.Goal.concl gl in + Refine.refine { Sigma.run = begin fun sigma -> + let sigma = Sigma.to_evar_map sigma in + let t = Tacmach.New.pf_get_type_of gl fc in + let t = Termops.prod_applist sigma t (Array.to_list args) in + let ans = mkApp (fc, args) in + let (sigma, holes) = gen_holes env sigma t n [] in + let ans = applist (ans, holes) in + let evdref = ref sigma in + let () = Typing.e_check env evdref ans concl in + Sigma.Unsafe.of_pair (ans, !evdref) + end } + end } let assert_before n c = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> let evm, _ = Tacmach.New.pf_apply type_of gl c in - Tacticals.New.tclTHEN (Proofview.V82.tactic (Refiner.tclEVARS evm)) (assert_before n c) + Sigma.Unsafe.of_pair (assert_before n c, evm) end } let refresh_type env evm ty = @@ -256,35 +283,38 @@ let refresh_type env evm ty = (Some false) env evm ty let refresh_universes ty k = - Proofview.Goal.enter { enter = begin fun gl -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> let env = Proofview.Goal.env gl in let evm = Tacmach.New.project gl in let evm, ty = refresh_type env evm ty in - Tacticals.New.tclTHEN (Proofview.V82.tactic (Refiner.tclEVARS evm)) (k ty) + Sigma.Unsafe.of_pair (k ty, evm) end } +let constr_of_term c = EConstr.of_constr (constr_of_term c) + let rec proof_tac p : unit Proofview.tactic = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let type_of t = Tacmach.New.pf_unsafe_type_of gl 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 c = EConstr.of_constr c in let l=constr_of_term p.p_lhs and r=constr_of_term p.p_rhs in refresh_universes (type_of l) (fun typ -> - new_app_global _sym_eq [|typ;r;l;c|] exact_check) + app_global _sym_eq [|typ;r;l;c|] exact_check) | Refl t -> let lr = constr_of_term t in refresh_universes (type_of lr) (fun typ -> - new_app_global _refl_equal [|typ;constr_of_term t|] exact_check) + app_global _refl_equal [|typ;constr_of_term t|] exact_check) | Trans (p1,p2)-> let t1 = constr_of_term p1.p_lhs and t2 = constr_of_term p1.p_rhs and t3 = constr_of_term p2.p_rhs in refresh_universes (type_of t2) (fun typ -> - let prf = new_app_global _trans_eq [|typ;t1;t2;t3;_M 1;_M 2|] in - Tacticals.New.tclTHENS (prf new_refine) [(proof_tac p1);(proof_tac p2)]) + let prf = app_global_with_holes _trans_eq [|typ;t1;t2;t3;|] 2 in + Tacticals.New.tclTHENS prf [(proof_tac p1);(proof_tac p2)]) | Congr (p1,p2)-> let tf1=constr_of_term p1.p_lhs and tx1=constr_of_term p2.p_lhs @@ -293,20 +323,20 @@ let rec proof_tac p : unit Proofview.tactic = refresh_universes (type_of tf1) (fun typf -> refresh_universes (type_of tx1) (fun typx -> refresh_universes (type_of (mkApp (tf1,[|tx1|]))) (fun typfx -> - let id = Tacmach.New.of_old (fun gls -> pf_get_new_id (Id.of_string "f") gls) gl in + let id = Tacmach.New.pf_get_new_id (Id.of_string "f") gl in let appx1 = mkLambda(Name id,typf,mkApp(mkRel 1,[|tx1|])) in - let lemma1 = app_global _f_equal [|typf;typfx;appx1;tf1;tf2;_M 1|] in - let lemma2 = app_global _f_equal [|typx;typfx;tf2;tx1;tx2;_M 1|] in + let lemma1 = app_global_with_holes _f_equal [|typf;typfx;appx1;tf1;tf2|] 1 in + let lemma2 = app_global_with_holes _f_equal [|typx;typfx;tf2;tx1;tx2|] 1 in let prf = - app_global _trans_eq + app_global_with_holes _trans_eq [|typfx; mkApp(tf1,[|tx1|]); mkApp(tf2,[|tx1|]); - mkApp(tf2,[|tx2|]);_M 2;_M 3|] in - Tacticals.New.tclTHENS (Proofview.V82.tactic (prf refine)) - [Tacticals.New.tclTHEN (Proofview.V82.tactic (lemma1 refine)) (proof_tac p1); + mkApp(tf2,[|tx2|])|] 2 in + Tacticals.New.tclTHENS prf + [Tacticals.New.tclTHEN lemma1 (proof_tac p1); Tacticals.New.tclFIRST - [Tacticals.New.tclTHEN (Proofview.V82.tactic (lemma2 refine)) (proof_tac p2); + [Tacticals.New.tclTHEN lemma2 (proof_tac p2); reflexivity; Tacticals.New.tclZEROMSG (Pp.str @@ -319,48 +349,50 @@ let rec proof_tac p : unit Proofview.tactic = refresh_universes (type_of ti) (fun intype -> refresh_universes (type_of default) (fun outtype -> let proj = - Tacmach.New.of_old (build_projection intype cstr special default) gl + build_projection intype cstr special default gl in let injt= - app_global _f_equal [|intype;outtype;proj;ti;tj;_M 1|] in - Tacticals.New.tclTHEN (Proofview.V82.tactic (injt refine)) (proof_tac prf))) + app_global_with_holes _f_equal [|intype;outtype;proj;ti;tj|] 1 in + Tacticals.New.tclTHEN injt (proof_tac prf))) with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e end } let refute_tac c t1 t2 p = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> 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 hid = Tacmach.New.pf_get_new_id (Id.of_string "Heq") gl in let false_t=mkApp (c,[|mkVar hid|]) in let k intype = - let neweq= new_app_global _eq [|intype;tt1;tt2|] in + let neweq= app_global _eq [|intype;tt1;tt2|] in Tacticals.New.tclTHENS (neweq (assert_before (Name hid))) [proof_tac p; simplest_elim false_t] in refresh_universes (Tacmach.New.pf_unsafe_type_of gl tt1) k end } -let refine_exact_check c gl = - let evm, _ = pf_apply type_of gl c in - Tacticals.tclTHEN (Refiner.tclEVARS evm) (Proofview.V82.of_tactic (exact_check c)) gl +let refine_exact_check c = + Proofview.Goal.s_enter { s_enter = begin fun gl -> + let evm, _ = Tacmach.New.pf_apply type_of gl c in + Sigma.Unsafe.of_pair (exact_check c, evm) + end } let convert_to_goal_tac c t1 t2 p = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let tt1=constr_of_term t1 and tt2=constr_of_term t2 in let k sort = - let neweq= new_app_global _eq [|sort;tt1;tt2|] in - let e = Tacmach.New.of_old (pf_get_new_id (Id.of_string "e")) gl in - let x = Tacmach.New.of_old (pf_get_new_id (Id.of_string "X")) gl in + let neweq= app_global _eq [|sort;tt1;tt2|] in + let e = Tacmach.New.pf_get_new_id (Id.of_string "e") gl in + let x = Tacmach.New.pf_get_new_id (Id.of_string "X") gl in let identity=mkLambda (Name x,sort,mkRel 1) in - let endt=app_global _eq_rect [|sort;tt1;identity;c;tt2;mkVar e|] in + let endt = app_global _eq_rect [|sort;tt1;identity;c;tt2;mkVar e|] in Tacticals.New.tclTHENS (neweq (assert_before (Name e))) - [proof_tac p; Proofview.V82.tactic (endt refine_exact_check)] + [proof_tac p; endt refine_exact_check] in refresh_universes (Tacmach.New.pf_unsafe_type_of gl tt2) k end } let convert_to_hyp_tac c1 t1 c2 t2 p = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let tt2=constr_of_term t2 in - let h = Tacmach.New.of_old (pf_get_new_id (Id.of_string "H")) gl in + let h = Tacmach.New.pf_get_new_id (Id.of_string "H") gl in let false_t=mkApp (c2,[|mkVar h|]) in Tacticals.New.tclTHENS (assert_before (Name h) tt2) [convert_to_goal_tac c1 t1 t2 p; @@ -368,46 +400,48 @@ let convert_to_hyp_tac c1 t1 c2 t2 p = end } let discriminate_tac (cstr,u as cstru) p = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let t1=constr_of_term p.p_lhs and t2=constr_of_term p.p_rhs in let env = Proofview.Goal.env gl in let concl = Proofview.Goal.concl gl in - let xid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "X")) gl in + let xid = Tacmach.New.pf_get_new_id (Id.of_string "X") gl in let identity = Universes.constr_of_global (Lazy.force _I) in + let identity = EConstr.of_constr identity in let trivial = Universes.constr_of_global (Lazy.force _True) in + let trivial = EConstr.of_constr trivial in let evm = Tacmach.New.project gl in let evm, intype = refresh_type env evm (Tacmach.New.pf_unsafe_type_of gl t1) in let evm, outtype = Evd.new_sort_variable Evd.univ_flexible evm in let outtype = mkSort outtype in let pred = mkLambda(Name xid,outtype,mkRel 1) in - let hid = Tacmach.New.of_old (pf_get_new_id (Id.of_string "Heq")) gl in - let proj = Tacmach.New.of_old (build_projection intype cstru trivial concl) gl in - let injt=app_global _f_equal + let hid = Tacmach.New.pf_get_new_id (Id.of_string "Heq") gl in + let proj = build_projection intype cstru trivial concl gl in + let injt = app_global _f_equal [|intype;outtype;proj;t1;t2;mkVar hid|] in let endt k = injt (fun injt -> app_global _eq_rect [|outtype;trivial;pred;identity;concl;injt|] k) in - let neweq=new_app_global _eq [|intype;t1;t2|] in + let neweq = app_global _eq [|intype;t1;t2|] in Tacticals.New.tclTHEN (Proofview.Unsafe.tclEVARS evm) (Tacticals.New.tclTHENS (neweq (assert_before (Name hid))) - [proof_tac p; Proofview.V82.tactic (endt refine_exact_check)]) + [proof_tac p; endt refine_exact_check]) end } (* wrap everything *) -let build_term_to_complete uf meta pac = +let build_term_to_complete uf pac = let cinfo = get_constructor_info uf pac.cnode in - let real_args = List.map (fun i -> constr_of_term (term uf i)) pac.args in - let dummy_args = List.rev (List.init pac.arity meta) in - let all_args = List.rev_append real_args dummy_args in - applistc (mkConstructU cinfo.ci_constr) all_args + let real_args = List.rev_map (fun i -> constr_of_term (term uf i)) pac.args in + let (kn, u) = cinfo.ci_constr in + (applist (mkConstructU (kn, EInstance.make u), real_args), pac.arity) let cc_tactic depth additionnal_terms = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> + let sigma = Tacmach.New.project gl in Coqlib.check_required_library Coqlib.logic_module_name; let _ = debug (fun () -> Pp.str "Reading subgoal ...") in - let state = Tacmach.New.of_old (fun gls -> make_prb gls depth additionnal_terms) gl in + let state = make_prb gl depth additionnal_terms in let _ = debug (fun () -> Pp.str "Problem built, solving ...") in let sol = execute true state in let _ = debug (fun () -> Pp.str "Computation completed.") in @@ -422,16 +456,17 @@ let cc_tactic depth additionnal_terms = let cstr=(get_constructor_info uf ipac.cnode).ci_constr in discriminate_tac cstr p | Incomplete -> + let open Glob_term in let env = Proofview.Goal.env gl in - let metacnt = ref 0 in - let newmeta _ = incr metacnt; _M !metacnt in - let terms_to_complete = - List.map - (build_term_to_complete uf newmeta) - (epsilons uf) in + let terms_to_complete = List.map (build_term_to_complete uf) (epsilons uf) in + let hole = GHole (Loc.ghost, Evar_kinds.InternalHole, Misctypes.IntroAnonymous, None) in + let pr_missing (c, missing) = + let c = Detyping.detype ~lax:true false [] env sigma c in + let holes = List.init missing (fun _ -> hole) in + Printer.pr_glob_constr_env env (GApp (Loc.ghost, c, holes)) + in Feedback.msg_info - (Pp.str "Goal is solvable by congruence but \ - some arguments are missing."); + (Pp.str "Goal is solvable by congruence but some arguments are missing."); Feedback.msg_info (Pp.str " Try " ++ hov 8 @@ -439,7 +474,7 @@ let cc_tactic depth additionnal_terms = str "\"congruence with (" ++ prlist_with_sep (fun () -> str ")" ++ spc () ++ str "(") - (Termops.print_constr_env env) + pr_missing terms_to_complete ++ str ")\"," end ++ @@ -450,20 +485,23 @@ let cc_tactic depth additionnal_terms = let ta=term uf dis.lhs and tb=term uf dis.rhs in match dis.rule with Goal -> proof_tac p - | Hyp id -> refute_tac id ta tb p + | Hyp id -> refute_tac (EConstr.of_constr id) ta tb p | HeqG id -> + let id = EConstr.of_constr id in convert_to_goal_tac id ta tb p | HeqnH (ida,idb) -> + let ida = EConstr.of_constr ida in + let idb = EConstr.of_constr idb in convert_to_hyp_tac ida ta idb tb p end } -let cc_fail gls = - user_err ~hdr:"Congruence" (Pp.str "congruence failed.") +let cc_fail = + Tacticals.New.tclZEROMSG (Pp.str "congruence failed.") let congruence_tac depth l = Tacticals.New.tclORELSE (Tacticals.New.tclTHEN (Tacticals.New.tclREPEAT introf) (cc_tactic depth l)) - (Proofview.V82.tactic cc_fail) + cc_fail (* Beware: reflexivity = constructor 1 = apply refl_equal might be slow now, let's rather do something equivalent @@ -477,31 +515,31 @@ let congruence_tac depth l = *) let mk_eq f c1 c2 k = - Tacticals.New.pf_constr_of_global (Lazy.force f) (fun fc -> - Proofview.Goal.enter { enter = begin fun gl -> + Tacticals.New.pf_constr_of_global (Lazy.force f) >>= fun fc -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> let open Tacmach.New in let evm, ty = pf_apply type_of gl c1 in let evm, ty = Evarsolve.refresh_universes (Some false) (pf_env gl) evm ty in let term = mkApp (fc, [| ty; c1; c2 |]) in let evm, _ = type_of (pf_env gl) evm term in - Tacticals.New.tclTHEN (Proofview.V82.tactic (Refiner.tclEVARS evm)) - (k term) - end }) + Sigma.Unsafe.of_pair (k term, evm) + end } let f_equal = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in + let sigma = Tacmach.New.project gl in let cut_eq c1 c2 = try (* type_of can raise an exception *) Tacticals.New.tclTHENS (mk_eq _eq c1 c2 Tactics.cut) - [Proofview.tclUNIT ();Tacticals.New.tclTRY ((new_app_global _refl_equal [||]) apply)] + [Proofview.tclUNIT ();Tacticals.New.tclTRY ((app_global _refl_equal [||]) apply)] with e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e in Proofview.tclORELSE - begin match kind_of_term concl with - | App (r,[|_;t;t'|]) when Globnames.is_global (Lazy.force _eq) r -> - begin match kind_of_term t, kind_of_term t' with + begin match EConstr.kind sigma concl with + | App (r,[|_;t;t'|]) when is_global sigma (Lazy.force _eq) r -> + begin match EConstr.kind sigma t, EConstr.kind sigma t' with | App (f,v), App (f',v') when Int.equal (Array.length v) (Array.length v') -> let rec cuts i = if i < 0 then Tacticals.New.tclTRY (congruence_tac 1000 []) @@ -512,7 +550,7 @@ let f_equal = | _ -> Proofview.tclUNIT () end begin function (e, info) -> match e with - | Type_errors.TypeError _ -> Proofview.tclUNIT () + | Pretype_errors.PretypeError _ | Type_errors.TypeError _ -> Proofview.tclUNIT () | e -> Proofview.tclZERO ~info e end end } diff --git a/plugins/cc/cctac.mli b/plugins/cc/cctac.mli index 7c1d9f1c0..5099d847b 100644 --- a/plugins/cc/cctac.mli +++ b/plugins/cc/cctac.mli @@ -7,14 +7,14 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Term +open EConstr open Proof_type val proof_tac: Ccproof.proof -> unit Proofview.tactic val cc_tactic : int -> constr list -> unit Proofview.tactic -val cc_fail : tactic +val cc_fail : unit Proofview.tactic val congruence_tac : int -> constr list -> unit Proofview.tactic diff --git a/plugins/cc/g_congruence.ml4 b/plugins/cc/g_congruence.ml4 index 6f6811334..7e76854b1 100644 --- a/plugins/cc/g_congruence.ml4 +++ b/plugins/cc/g_congruence.ml4 @@ -8,6 +8,7 @@ (*i camlp4deps: "grammar/grammar.cma" i*) +open Ltac_plugin open Cctac open Stdarg diff --git a/plugins/decl_mode/decl_expr.mli b/plugins/decl_mode/decl_expr.mli deleted file mode 100644 index 29ecb94ca..000000000 --- a/plugins/decl_mode/decl_expr.mli +++ /dev/null @@ -1,102 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -open Names -open Tacexpr - -type 'it statement = - {st_label:Name.t; - st_it:'it} - -type thesis_kind = - Plain - | For of Id.t - -type 'this or_thesis = - This of 'this - | Thesis of thesis_kind - -type side = Lhs | Rhs - -type elim_type = - ET_Case_analysis - | ET_Induction - -type block_type = - B_proof - | B_claim - | B_focus - | B_elim of elim_type - -type ('it,'constr,'tac) cut = - {cut_stat: 'it; - cut_by: 'constr list option; - cut_using: 'tac option} - -type ('var,'constr) hyp = - Hvar of 'var - | Hprop of 'constr statement - -type ('constr,'tac) casee = - Real of 'constr - | Virtual of ('constr statement,'constr,'tac) cut - -type ('var,'constr,'pat,'tac) bare_proof_instr = - | Pthen of ('var,'constr,'pat,'tac) bare_proof_instr - | Pthus of ('var,'constr,'pat,'tac) bare_proof_instr - | Phence of ('var,'constr,'pat,'tac) bare_proof_instr - | Pcut of ('constr or_thesis statement,'constr,'tac) cut - | Prew of side * ('constr statement,'constr,'tac) cut - | Psuffices of ((('var,'constr) hyp list * 'constr or_thesis),'constr,'tac) cut - | Passume of ('var,'constr) hyp list - | Plet of ('var,'constr) hyp list - | Pgiven of ('var,'constr) hyp list - | Pconsider of 'constr*('var,'constr) hyp list - | Pclaim of 'constr statement - | Pfocus of 'constr statement - | Pdefine of Id.t * 'var list * 'constr - | Pcast of Id.t or_thesis * 'constr - | Psuppose of ('var,'constr) hyp list - | Pcase of 'var list*'pat*(('var,'constr or_thesis) hyp list) - | Ptake of 'constr list - | Pper of elim_type * ('constr,'tac) casee - | Pend of block_type - | Pescape - -type emphasis = int - -type ('var,'constr,'pat,'tac) gen_proof_instr= - {emph: emphasis; - instr: ('var,'constr,'pat,'tac) bare_proof_instr } - - -type raw_proof_instr = - ((Id.t * (Constrexpr.constr_expr option)) Loc.located, - Constrexpr.constr_expr, - Constrexpr.cases_pattern_expr, - raw_tactic_expr) gen_proof_instr - -type glob_proof_instr = - ((Id.t * (Tacexpr.glob_constr_and_expr option)) Loc.located, - Tacexpr.glob_constr_and_expr, - Constrexpr.cases_pattern_expr, - Tacexpr.glob_tactic_expr) gen_proof_instr - -type proof_pattern = - {pat_vars: Term.types statement list; - pat_aliases: (Term.constr*Term.types) statement list; - pat_constr: Term.constr; - pat_typ: Term.types; - pat_pat: Glob_term.cases_pattern; - pat_expr: Constrexpr.cases_pattern_expr} - -type proof_instr = - (Term.constr statement, - Term.constr, - proof_pattern, - Geninterp.Val.t) gen_proof_instr diff --git a/plugins/decl_mode/decl_interp.ml b/plugins/decl_mode/decl_interp.ml deleted file mode 100644 index f68c01b18..000000000 --- a/plugins/decl_mode/decl_interp.ml +++ /dev/null @@ -1,473 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -open CErrors -open Util -open Names -open Constrexpr -open Tacintern -open Decl_expr -open Decl_mode -open Pretyping -open Glob_term -open Term -open Vars -open Pp -open Decl_kinds -open Misctypes - -(* INTERN *) - -let glob_app (loc,hd,args) = if List.is_empty args then hd else GApp(loc,hd,args) - -let intern_justification_items globs = - Option.map (List.map (intern_constr globs)) - -let intern_justification_method globs = - Option.map (intern_pure_tactic globs) - -let intern_statement intern_it globs st = - {st_label=st.st_label; - st_it=intern_it globs st.st_it} - -let intern_no_bind intern_it globs x = - globs,intern_it globs x - -let intern_constr_or_thesis globs = function - Thesis n -> Thesis n - | This c -> This (intern_constr globs c) - -let add_var id globs= - {globs with ltacvars = Id.Set.add id globs.ltacvars} - -let add_name nam globs= - match nam with - Anonymous -> globs - | Name id -> add_var id globs - -let intern_hyp iconstr globs = function - Hvar (loc,(id,topt)) -> add_var id globs, - Hvar (loc,(id,Option.map (intern_constr globs) topt)) - | Hprop st -> add_name st.st_label globs, - Hprop (intern_statement iconstr globs st) - -let intern_hyps iconstr globs hyps = - snd (List.fold_map (intern_hyp iconstr) globs hyps) - -let intern_cut intern_it globs cut= - let nglobs,nstat=intern_it globs cut.cut_stat in - {cut_stat=nstat; - cut_by=intern_justification_items nglobs cut.cut_by; - cut_using=intern_justification_method nglobs cut.cut_using} - -let intern_casee globs = function - Real c -> Real (intern_constr globs c) - | Virtual cut -> Virtual - (intern_cut (intern_no_bind (intern_statement intern_constr)) globs cut) - -let intern_hyp_list args globs = - let intern_one globs (loc,(id,opttyp)) = - (add_var id globs), - (loc,(id,Option.map (intern_constr globs) opttyp)) in - List.fold_map intern_one globs args - -let intern_suffices_clause globs (hyps,c) = - let nglobs,nhyps = List.fold_map (intern_hyp intern_constr) globs hyps in - nglobs,(nhyps,intern_constr_or_thesis nglobs c) - -let intern_fundecl args body globs= - let nglobs,nargs = intern_hyp_list args globs in - nargs,intern_constr nglobs body - -let rec add_vars_of_simple_pattern globs = function - CPatAlias (loc,p,id) -> - add_vars_of_simple_pattern (add_var id globs) p -(* Loc.raise loc - (UserError ("simple_pattern",str "\"as\" is not allowed here"))*) - | CPatOr (loc, _)-> - Loc.raise ~loc - (UserError (Some "simple_pattern",str "\"(_ | _)\" is not allowed here")) - | CPatDelimiters (_,_,p) -> - add_vars_of_simple_pattern globs p - | CPatCstr (_,_,pl1,pl2) -> - List.fold_left add_vars_of_simple_pattern - (Option.fold_left (List.fold_left add_vars_of_simple_pattern) globs pl1) pl2 - | CPatNotation(_,_,(pl,pll),pl') -> - List.fold_left add_vars_of_simple_pattern globs (List.flatten (pl::pl'::pll)) - | CPatAtom (_,Some (Libnames.Ident (_,id))) -> add_var id globs - | _ -> globs - -let rec intern_bare_proof_instr globs = function - Pthus i -> Pthus (intern_bare_proof_instr globs i) - | Pthen i -> Pthen (intern_bare_proof_instr globs i) - | Phence i -> Phence (intern_bare_proof_instr globs i) - | Pcut c -> Pcut - (intern_cut - (intern_no_bind (intern_statement intern_constr_or_thesis)) globs c) - | Psuffices c -> - Psuffices (intern_cut intern_suffices_clause globs c) - | Prew (s,c) -> Prew - (s,intern_cut - (intern_no_bind (intern_statement intern_constr)) globs c) - | Psuppose hyps -> Psuppose (intern_hyps intern_constr globs hyps) - | Pcase (params,pat,hyps) -> - let nglobs,nparams = intern_hyp_list params globs in - let nnglobs= add_vars_of_simple_pattern nglobs pat in - let nhyps = intern_hyps intern_constr_or_thesis nnglobs hyps in - Pcase (nparams,pat,nhyps) - | Ptake witl -> Ptake (List.map (intern_constr globs) witl) - | Pconsider (c,hyps) -> Pconsider (intern_constr globs c, - intern_hyps intern_constr globs hyps) - | Pper (et,c) -> Pper (et,intern_casee globs c) - | Pend bt -> Pend bt - | Pescape -> Pescape - | Passume hyps -> Passume (intern_hyps intern_constr globs hyps) - | Pgiven hyps -> Pgiven (intern_hyps intern_constr globs hyps) - | Plet hyps -> Plet (intern_hyps intern_constr globs hyps) - | Pclaim st -> Pclaim (intern_statement intern_constr globs st) - | Pfocus st -> Pfocus (intern_statement intern_constr globs st) - | Pdefine (id,args,body) -> - let nargs,nbody = intern_fundecl args body globs in - Pdefine (id,nargs,nbody) - | Pcast (id,typ) -> - Pcast (id,intern_constr globs typ) - -let intern_proof_instr globs instr= - {emph = instr.emph; - instr = intern_bare_proof_instr globs instr.instr} - -(* INTERP *) - -let interp_justification_items env sigma = - Option.map (List.map (fun c -> fst (*FIXME*)(understand env sigma (fst c)))) - -let interp_constr check_sort env sigma c = - if check_sort then - fst (understand env sigma ~expected_type:IsType (fst c) (* FIXME *)) - else - fst (understand env sigma (fst c)) - -let special_whd env = - let infos=CClosure.create_clos_infos CClosure.all env in - (fun t -> CClosure.whd_val infos (CClosure.inject t)) - -let _eq = lazy (Universes.constr_of_global (Coqlib.glob_eq)) - -let decompose_eq env id = - let typ = Environ.named_type id env in - let whd = special_whd env typ in - match kind_of_term whd with - App (f,args)-> - if eq_constr f (Lazy.force _eq) && Int.equal (Array.length args) 3 - then args.(0) - else error "Previous step is not an equality." - | _ -> error "Previous step is not an equality." - -let get_eq_typ info env = - let typ = decompose_eq env (get_last env) in - typ - -let interp_constr_in_type typ env sigma c = - fst (understand env sigma (fst c) ~expected_type:(OfType typ))(*FIXME*) - -let interp_statement interp_it env sigma st = - {st_label=st.st_label; - st_it=interp_it env sigma st.st_it} - -let interp_constr_or_thesis check_sort env sigma = function - Thesis n -> Thesis n - | This c -> This (interp_constr check_sort env sigma c) - -let abstract_one_hyp inject h glob = - match h with - Hvar (loc,(id,None)) -> - GProd (Loc.ghost,Name id, Explicit, GHole (loc,Evar_kinds.BinderType (Name id), Misctypes.IntroAnonymous, None), glob) - | Hvar (loc,(id,Some typ)) -> - GProd (Loc.ghost,Name id, Explicit, fst typ, glob) - | Hprop st -> - GProd (Loc.ghost,st.st_label, Explicit, inject st.st_it, glob) - -let glob_constr_of_hyps inject hyps head = - List.fold_right (abstract_one_hyp inject) hyps head - -let glob_prop = GSort (Loc.ghost,GProp) - -let rec match_hyps blend names constr = function - [] -> [],substl names constr - | hyp::q -> - let (name,typ,body)=destProd constr in - let st= {st_label=name;st_it=substl names typ} in - let qnames= - match name with - Anonymous -> mkMeta 0 :: names - | Name id -> mkVar id :: names in - let qhyp = match hyp with - Hprop st' -> Hprop (blend st st') - | Hvar _ -> Hvar st in - let rhyps,head = match_hyps blend qnames body q in - qhyp::rhyps,head - -let interp_hyps_gen inject blend env sigma hyps head = - let constr= fst(*FIXME*) (understand env sigma (glob_constr_of_hyps inject hyps head)) in - match_hyps blend [] constr hyps - -let interp_hyps env sigma hyps = fst (interp_hyps_gen fst (fun x _ -> x) env sigma hyps glob_prop) - -let dummy_prefix= Id.of_string "__" - -let rec deanonymize ids = - function - PatVar (loc,Anonymous) -> - let (found,known) = !ids in - let new_id=Namegen.next_ident_away dummy_prefix known in - let _= ids:= (loc,new_id) :: found , new_id :: known in - PatVar (loc,Name new_id) - | PatVar (loc,Name id) as pat -> - let (found,known) = !ids in - let _= ids:= (loc,id) :: found , known in - pat - | PatCstr(loc,cstr,lpat,nam) -> - PatCstr(loc,cstr,List.map (deanonymize ids) lpat,nam) - -let rec glob_of_pat = - function - PatVar (loc,Anonymous) -> anomaly (Pp.str "Anonymous pattern variable") - | PatVar (loc,Name id) -> - GVar (loc,id) - | PatCstr(loc,((ind,_) as cstr),lpat,_) -> - let mind= fst (Global.lookup_inductive ind) in - let rec add_params n q = - if n<=0 then q else - add_params (pred n) (GHole(Loc.ghost, - Evar_kinds.TomatchTypeParameter(ind,n), Misctypes.IntroAnonymous, None)::q) in - let args = List.map glob_of_pat lpat in - glob_app(loc,GRef(Loc.ghost,Globnames.ConstructRef cstr,None), - add_params mind.Declarations.mind_nparams args) - -let prod_one_hyp = function - (loc,(id,None)) -> - (fun glob -> - GProd (Loc.ghost,Name id, Explicit, - GHole (loc,Evar_kinds.BinderType (Name id), Misctypes.IntroAnonymous, None), glob)) - | (loc,(id,Some typ)) -> - (fun glob -> - GProd (Loc.ghost,Name id, Explicit, fst typ, glob)) - -let prod_one_id (loc,id) glob = - GProd (Loc.ghost,Name id, Explicit, - GHole (loc,Evar_kinds.BinderType (Name id), Misctypes.IntroAnonymous, None), glob) - -let let_in_one_alias (id,pat) glob = - GLetIn (Loc.ghost,Name id, glob_of_pat pat, glob) - -let rec bind_primary_aliases map pat = - match pat with - PatVar (_,_) -> map - | PatCstr(loc,_,lpat,nam) -> - let map1 = - match nam with - Anonymous -> map - | Name id -> (id,pat)::map - in - List.fold_left bind_primary_aliases map1 lpat - -let bind_secondary_aliases map subst = - Id.Map.fold (fun ids idp map -> (ids,Id.List.assoc idp map)::map) subst map - -let bind_aliases patvars subst patt = - let map = bind_primary_aliases [] patt in - let map1 = bind_secondary_aliases map subst in - List.rev map1 - -let interp_pattern env pat_expr = - let patvars,pats = Constrintern.intern_pattern env pat_expr in - match pats with - [] -> anomaly (Pp.str "empty pattern list") - | [subst,patt] -> - (patvars,bind_aliases patvars subst patt,patt) - | _ -> anomaly (Pp.str "undetected disjunctive pattern") - -let rec match_args dest names constr = function - [] -> [],names,substl names constr - | _::q -> - let (name,typ,body)=dest constr in - let st={st_label=name;st_it=substl names typ} in - let qnames= - match name with - Anonymous -> assert false - | Name id -> mkVar id :: names in - let args,bnames,body = match_args dest qnames body q in - st::args,bnames,body - -let rec match_aliases names constr = function - [] -> [],names,substl names constr - | _::q -> - let (name,c,typ,body)=destLetIn constr in - let st={st_label=name;st_it=(substl names c,substl names typ)} in - let qnames= - match name with - Anonymous -> assert false - | Name id -> mkVar id :: names in - let args,bnames,body = match_aliases qnames body q in - st::args,bnames,body - -let detype_ground env c = Detyping.detype false [] env Evd.empty c - -let interp_cases info env sigma params (pat:cases_pattern_expr) hyps = - let et,pinfo = - match info.pm_stack with - Per(et,pi,_,_)::_ -> et,pi - | _ -> error "No proof per cases/induction/inversion in progress." in - let mib,oib=Global.lookup_inductive pinfo.per_ind in - let num_params = pinfo.per_nparams in - let _ = - let expected = mib.Declarations.mind_nparams - num_params in - if not (Int.equal (List.length params) expected) then - user_err ~hdr:"suppose it is" - (str "Wrong number of extra arguments: " ++ - (if Int.equal expected 0 then str "none" else int expected) ++ spc () ++ - str "expected.") in - let app_ind = - let rind = GRef (Loc.ghost,Globnames.IndRef pinfo.per_ind,None) in - let rparams = List.map (detype_ground env) pinfo.per_params in - let rparams_rec = - List.map - (fun (loc,(id,_)) -> - GVar (loc,id)) params in - let dum_args= - List.init oib.Declarations.mind_nrealargs - (fun _ -> GHole (Loc.ghost,Evar_kinds.QuestionMark (Evar_kinds.Define false),Misctypes.IntroAnonymous, None)) in - glob_app(Loc.ghost,rind,rparams@rparams_rec@dum_args) in - let pat_vars,aliases,patt = interp_pattern env pat in - let inject = function - Thesis (Plain) -> Glob_term.GSort(Loc.ghost,GProp) - | Thesis (For rec_occ) -> - if not (Id.List.mem rec_occ pat_vars) then - user_err ~hdr:"suppose it is" - (str "Variable " ++ Nameops.pr_id rec_occ ++ - str " does not occur in pattern."); - Glob_term.GSort(Loc.ghost,GProp) - | This (c,_) -> c in - let term1 = glob_constr_of_hyps inject hyps glob_prop in - let loc_ids,npatt = - let rids=ref ([],pat_vars) in - let npatt= deanonymize rids patt in - List.rev (fst !rids),npatt in - let term2 = - GLetIn(Loc.ghost,Anonymous, - GCast(Loc.ghost,glob_of_pat npatt, - CastConv app_ind),term1) in - let term3=List.fold_right let_in_one_alias aliases term2 in - let term4=List.fold_right prod_one_id loc_ids term3 in - let term5=List.fold_right prod_one_hyp params term4 in - let constr = fst (understand env sigma term5)(*FIXME*) in - let tparams,nam4,rest4 = match_args destProd [] constr params in - let tpatvars,nam3,rest3 = match_args destProd nam4 rest4 loc_ids in - let taliases,nam2,rest2 = match_aliases nam3 rest3 aliases in - let (_,pat_pat,pat_typ,rest1) = destLetIn rest2 in - let blend st st' = - match st'.st_it with - Thesis nam -> {st_it=Thesis nam;st_label=st'.st_label} - | This _ -> {st_it = This st.st_it;st_label=st.st_label} in - let thyps = fst (match_hyps blend nam2 (Termops.pop rest1) hyps) in - tparams,{pat_vars=tpatvars; - pat_aliases=taliases; - pat_constr=pat_pat; - pat_typ=pat_typ; - pat_pat=patt; - pat_expr=pat},thyps - -let interp_cut interp_it env sigma cut= - let nenv,nstat = interp_it env sigma cut.cut_stat in - { cut_using=Option.map (Tacinterp.Value.of_closure (Tacinterp.default_ist ())) cut.cut_using; - cut_stat=nstat; - cut_by=interp_justification_items nenv sigma cut.cut_by} - -let interp_no_bind interp_it env sigma x = - env,interp_it env sigma x - -let interp_suffices_clause env sigma (hyps,cot)= - let (locvars,_) as res = - match cot with - This (c,_) -> - let nhyps,nc = interp_hyps_gen fst (fun x _ -> x) env sigma hyps c in - nhyps,This nc - | Thesis Plain as th -> interp_hyps env sigma hyps,th - | Thesis (For n) -> error "\"thesis for\" is not applicable here." in - let push_one hyp env0 = - match hyp with - (Hprop st | Hvar st) -> - match st.st_label with - Name id -> Environ.push_named (Context.Named.Declaration.LocalAssum (id,st.st_it)) env0 - | _ -> env in - let nenv = List.fold_right push_one locvars env in - nenv,res - -let interp_casee env sigma = function - Real c -> Real (fst (understand env sigma (fst c)))(*FIXME*) - | Virtual cut -> Virtual (interp_cut (interp_no_bind (interp_statement (interp_constr true))) env sigma cut) - -let abstract_one_arg = function - (loc,(id,None)) -> - (fun glob -> - GLambda (Loc.ghost,Name id, Explicit, - GHole (loc,Evar_kinds.BinderType (Name id),Misctypes.IntroAnonymous,None), glob)) - | (loc,(id,Some typ)) -> - (fun glob -> - GLambda (Loc.ghost,Name id, Explicit, fst typ, glob)) - -let glob_constr_of_fun args body = - List.fold_right abstract_one_arg args (fst body) - -let interp_fun env sigma args body = - let constr=fst (*FIXME*) (understand env sigma (glob_constr_of_fun args body)) in - match_args destLambda [] constr args - -let rec interp_bare_proof_instr info env sigma = function - Pthus i -> Pthus (interp_bare_proof_instr info env sigma i) - | Pthen i -> Pthen (interp_bare_proof_instr info env sigma i) - | Phence i -> Phence (interp_bare_proof_instr info env sigma i) - | Pcut c -> Pcut (interp_cut - (interp_no_bind (interp_statement - (interp_constr_or_thesis true))) - env sigma c) - | Psuffices c -> - Psuffices (interp_cut interp_suffices_clause env sigma c) - | Prew (s,c) -> Prew (s,interp_cut - (interp_no_bind (interp_statement - (interp_constr_in_type (get_eq_typ info env)))) - env sigma c) - - | Psuppose hyps -> Psuppose (interp_hyps env sigma hyps) - | Pcase (params,pat,hyps) -> - let tparams,tpat,thyps = interp_cases info env sigma params pat hyps in - Pcase (tparams,tpat,thyps) - | Ptake witl -> - Ptake (List.map (fun c -> fst (*FIXME*) (understand env sigma (fst c))) witl) - | Pconsider (c,hyps) -> Pconsider (interp_constr false env sigma c, - interp_hyps env sigma hyps) - | Pper (et,c) -> Pper (et,interp_casee env sigma c) - | Pend bt -> Pend bt - | Pescape -> Pescape - | Passume hyps -> Passume (interp_hyps env sigma hyps) - | Pgiven hyps -> Pgiven (interp_hyps env sigma hyps) - | Plet hyps -> Plet (interp_hyps env sigma hyps) - | Pclaim st -> Pclaim (interp_statement (interp_constr true) env sigma st) - | Pfocus st -> Pfocus (interp_statement (interp_constr true) env sigma st) - | Pdefine (id,args,body) -> - let nargs,_,nbody = interp_fun env sigma args body in - Pdefine (id,nargs,nbody) - | Pcast (id,typ) -> - Pcast(id,interp_constr true env sigma typ) - -let interp_proof_instr info env sigma instr= - {emph = instr.emph; - instr = interp_bare_proof_instr info env sigma instr.instr} - - - diff --git a/plugins/decl_mode/decl_mode.ml b/plugins/decl_mode/decl_mode.ml deleted file mode 100644 index 92d408901..000000000 --- a/plugins/decl_mode/decl_mode.ml +++ /dev/null @@ -1,136 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -open Names -open Term -open Evd -open CErrors -open Util - -let daimon_flag = ref false - -let set_daimon_flag () = daimon_flag:=true -let clear_daimon_flag () = daimon_flag:=false -let get_daimon_flag () = !daimon_flag - - - - -type split_tree= - Skip_patt of Id.Set.t * split_tree - | Split_patt of Id.Set.t * inductive * - (bool array * (Id.Set.t * split_tree) option) array - | Close_patt of split_tree - | End_patt of (Id.t * (int * int)) - -type elim_kind = - EK_dep of split_tree - | EK_nodep - | EK_unknown - -type recpath = int option*Declarations.wf_paths - -type per_info = - {per_casee:constr; - per_ctype:types; - per_ind:inductive; - per_pred:constr; - per_args:constr list; - per_params:constr list; - per_nparams:int; - per_wf:recpath} - -type stack_info = - Per of Decl_expr.elim_type * per_info * elim_kind * Id.t list - | Suppose_case - | Claim - | Focus_claim - -type pm_info = - { pm_stack : stack_info list} -let info = Store.field () - - -(* Current proof mode *) - -type command_mode = - Mode_tactic - | Mode_proof - | Mode_none - -let mode_of_pftreestate pts = - (* spiwack: it used to be "top_goal_..." but this should be fine *) - let { it = goals ; sigma = sigma } = Proof.V82.subgoals pts in - let goal = List.hd goals in - match Store.get (Goal.V82.extra sigma goal) info with - | None -> Mode_tactic - | Some _ -> Mode_proof - -let get_current_mode () = - try - mode_of_pftreestate (Pfedit.get_pftreestate ()) - with Proof_global.NoCurrentProof -> Mode_none - -let check_not_proof_mode str = - match get_current_mode () with - | Mode_proof -> error str - | _ -> () - -let get_info sigma gl= - match Store.get (Goal.V82.extra sigma gl) info with - | None -> invalid_arg "get_info" - | Some pm -> pm - -let try_get_info sigma gl = - Store.get (Goal.V82.extra sigma gl) info - -let get_goal_stack pts = - let { it = goals ; sigma = sigma } = Proof.V82.subgoals pts in - let info = get_info sigma (List.hd goals) in - info.pm_stack - - -let proof_focus = Proof.new_focus_kind () -let proof_cond = Proof.done_cond proof_focus - -let focus p = - let inf = get_goal_stack p in - Proof_global.simple_with_current_proof (fun _ -> Proof.focus proof_cond inf 1) - -let unfocus () = - Proof_global.simple_with_current_proof (fun _ p -> Proof.unfocus proof_focus p ()) - -let get_top_stack pts = - try - Proof.get_at_focus proof_focus pts - with Proof.NoSuchFocus -> - let { it = gl ; sigma = sigma } = Proof.V82.top_goal pts in - let info = get_info sigma gl in - info.pm_stack - -let get_stack pts = Proof.get_at_focus proof_focus pts - -let get_last env = match Environ.named_context env with - | decl :: _ -> Context.Named.Declaration.get_id decl - | [] -> error "no previous statement to use" - - -let get_end_command pts = - match get_top_stack pts with - | [] -> "\"end proof\"" - | Claim::_ -> "\"end claim\"" - | Focus_claim::_-> "\"end focus\"" - | Suppose_case :: Per (et,_,_,_) :: _ | Per (et,_,_,_) :: _ -> - begin - match et with - Decl_expr.ET_Case_analysis -> - "\"end cases\" or start a new case" - | Decl_expr.ET_Induction -> - "\"end induction\" or start a new case" - end - | _ -> anomaly (Pp.str"lonely suppose") diff --git a/plugins/decl_mode/decl_mode.mli b/plugins/decl_mode/decl_mode.mli deleted file mode 100644 index dfeee833c..000000000 --- a/plugins/decl_mode/decl_mode.mli +++ /dev/null @@ -1,79 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -open Names -open Term -open Evd - -val set_daimon_flag : unit -> unit -val clear_daimon_flag : unit -> unit -val get_daimon_flag : unit -> bool - -type command_mode = - Mode_tactic - | Mode_proof - | Mode_none - -val mode_of_pftreestate : Proof.proof -> command_mode - -val get_current_mode : unit -> command_mode - -val check_not_proof_mode : string -> unit - -type split_tree= - Skip_patt of Id.Set.t * split_tree - | Split_patt of Id.Set.t * inductive * - (bool array * (Id.Set.t * split_tree) option) array - | Close_patt of split_tree - | End_patt of (Id.t * (int * int)) - -type elim_kind = - EK_dep of split_tree - | EK_nodep - | EK_unknown - -type recpath = int option*Declarations.wf_paths - -type per_info = - {per_casee:constr; - per_ctype:types; - per_ind:inductive; - per_pred:constr; - per_args:constr list; - per_params:constr list; - per_nparams:int; - per_wf:recpath} - -type stack_info = - Per of Decl_expr.elim_type * per_info * elim_kind * Names.Id.t list - | Suppose_case - | Claim - | Focus_claim - -type pm_info = - {pm_stack : stack_info list } - -val info : pm_info Store.field - -val get_info : Evd.evar_map -> Proof_type.goal -> pm_info - -val try_get_info : Evd.evar_map -> Proof_type.goal -> pm_info option - -val get_stack : Proof.proof -> stack_info list - -val get_top_stack : Proof.proof -> stack_info list - -val get_last: Environ.env -> Id.t -(** [get_last] raises a [UserError] when it cannot find a previous - statement in the environment. *) - -val get_end_command : Proof.proof -> string - -val focus : Proof.proof -> unit - -val unfocus : unit -> unit diff --git a/plugins/decl_mode/decl_mode_plugin.mlpack b/plugins/decl_mode/decl_mode_plugin.mlpack deleted file mode 100644 index 1b84a0790..000000000 --- a/plugins/decl_mode/decl_mode_plugin.mlpack +++ /dev/null @@ -1,5 +0,0 @@ -Decl_mode -Decl_interp -Decl_proof_instr -Ppdecl_proof -G_decl_mode diff --git a/plugins/decl_mode/decl_proof_instr.ml b/plugins/decl_mode/decl_proof_instr.ml deleted file mode 100644 index e19dc86c4..000000000 --- a/plugins/decl_mode/decl_proof_instr.ml +++ /dev/null @@ -1,1553 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -open CErrors -open Util -open Pp -open Evd - -open Tacmach -open Tacintern -open Decl_expr -open Decl_mode -open Decl_interp -open Glob_term -open Glob_ops -open Names -open Nameops -open Declarations -open Tactics -open Tacticals -open Term -open Vars -open Termops -open Namegen -open Goptions -open Misctypes -open Sigma.Notations -open Context.Named.Declaration - -module RelDecl = Context.Rel.Declaration -module NamedDecl = Context.Named.Declaration - -(* Strictness option *) - -let clear ids { it = goal; sigma } = - let ids = List.fold_left (fun accu x -> Id.Set.add x accu) Id.Set.empty ids in - let env = Goal.V82.env sigma goal in - let sign = Goal.V82.hyps sigma goal in - let cl = Goal.V82.concl sigma goal in - let evdref = ref (Evd.clear_metas sigma) in - let (hyps, concl) = - try Evarutil.clear_hyps_in_evi env evdref sign cl ids - with Evarutil.ClearDependencyError (id, _) -> - user_err (str "Cannot clear " ++ pr_id id) - in - let sigma = !evdref in - let (gl,ev,sigma) = Goal.V82.mk_goal sigma hyps concl (Goal.V82.extra sigma goal) in - let sigma = Goal.V82.partial_solution_to sigma goal gl ev in - { it = [gl]; sigma } - -let get_its_info gls = get_info gls.sigma gls.it - -let get_strictness,set_strictness = - let strictness = ref false in - (fun () -> (!strictness)),(fun b -> strictness:=b) - -let _ = - declare_bool_option - { optsync = true; - optdepr = false; - optname = "strict proofs"; - optkey = ["Strict";"Proofs"]; - optread = get_strictness; - optwrite = set_strictness } - -let tcl_change_info_gen info_gen = - (fun gls -> - let it = sig_it gls in - let concl = pf_concl gls in - let hyps = Goal.V82.hyps (project gls) it in - let extra = Goal.V82.extra (project gls) it in - let (gl,ev,sigma) = Goal.V82.mk_goal (project gls) hyps concl (info_gen extra) in - let sigma = Goal.V82.partial_solution sigma it ev in - { it = [gl] ; sigma= sigma; } ) - -let tcl_change_info info gls = - let info_gen s = Store.set s Decl_mode.info info in - tcl_change_info_gen info_gen gls - -let tcl_erase_info gls = - let info_gen s = Store.remove s Decl_mode.info in - tcl_change_info_gen info_gen gls - -let special_whd gl= - let infos=CClosure.create_clos_infos CClosure.all (pf_env gl) in - (fun t -> CClosure.whd_val infos (CClosure.inject t)) - -let special_nf gl= - let infos=CClosure.create_clos_infos CClosure.betaiotazeta (pf_env gl) in - (fun t -> CClosure.norm_val infos (CClosure.inject t)) - -let is_good_inductive env ind = - let mib,oib = Inductive.lookup_mind_specif env ind in - Int.equal oib.mind_nrealargs 0 && not (Inductiveops.mis_is_recursive (ind,mib,oib)) - -let check_not_per pts = - if not (Proof.is_done pts) then - match get_stack pts with - Per (_,_,_,_)::_ -> - error "You are inside a proof per cases/induction.\n\ -Please \"suppose\" something or \"end\" it now." - | _ -> () - -let mk_evd metalist gls = - let evd0= clear_metas (sig_sig gls) in - let add_one (meta,typ) evd = - meta_declare meta typ evd in - List.fold_right add_one metalist evd0 - -let is_tmp id = (Id.to_string id).[0] == '_' - -let tmp_ids gls = - let ctx = pf_hyps gls in - match ctx with - [] -> [] - | _::q -> List.filter is_tmp (ids_of_named_context q) - -let clean_tmp gls = - let clean_id id0 gls0 = - tclTRY (clear [id0]) gls0 in - let rec clean_all = function - [] -> tclIDTAC - | id :: rest -> tclTHEN (clean_id id) (clean_all rest) - in - clean_all (tmp_ids gls) gls - -let assert_postpone id t = - assert_before (Name id) t - -(* start a proof *) - - -let start_proof_tac gls= - let info={pm_stack=[]} in - tcl_change_info info gls - -let go_to_proof_mode () = - ignore (Pfedit.by (Proofview.V82.tactic start_proof_tac)); - let p = Proof_global.give_me_the_proof () in - Decl_mode.focus p - -(* closing gaps *) - -(* spiwack: should use [Proofview.give_up] but that would require - moving the whole declarative mode into the new proof engine. It - will eventually have to be done. - - As far as I can tell, [daimon_tac] is used after a [thus thesis], - it will leave uninstantiated variables instead of giving a relevant - message at [Qed]. *) -let daimon_tac gls = - set_daimon_flag (); - {it=[];sigma=sig_sig gls;} - -let daimon_instr env p = - let (p,(status,_)) = - Proof.run_tactic env begin - Proofview.tclINDEPENDENT Proofview.give_up - end p - in - p,status - -let do_daimon () = - let env = Global.env () in - let status = - Proof_global.with_current_proof begin fun _ p -> - daimon_instr env p - end - in - if not status then Feedback.feedback Feedback.AddedAxiom else () - -(* post-instruction focus management *) - -let goto_current_focus () = - Decl_mode.unfocus () - -(* spiwack: used to catch errors indicating lack of "focusing command" - in the proof tree. In the current implementation, however, entering - the declarative mode puts a focus first, there should, therefore, - never be exception raised here. *) -let goto_current_focus_or_top () = - goto_current_focus () - -(* return *) - -let close_tactic_mode () = - try do_daimon ();goto_current_focus () - with Not_found -> - error "\"return\" cannot be used outside of Declarative Proof Mode." - -let return_from_tactic_mode () = - close_tactic_mode () - -(* end proof/claim *) - -let close_block bt pts = - if Proof.no_focused_goal pts then - goto_current_focus () - else - let stack = - if Proof.is_done pts then - get_top_stack pts - else - get_stack pts - in - match bt,stack with - B_claim, Claim::_ | B_focus, Focus_claim::_ | B_proof, [] -> - do_daimon ();goto_current_focus () - | _, Claim::_ -> - error "\"end claim\" expected." - | _, Focus_claim::_ -> - error "\"end focus\" expected." - | _, [] -> - error "\"end proof\" expected." - | _, (Per (et,_,_,_)::_|Suppose_case::Per (et,_,_,_)::_) -> - begin - match et with - ET_Case_analysis -> error "\"end cases\" expected." - | ET_Induction -> error "\"end induction\" expected." - end - | _,_ -> anomaly (Pp.str "Lonely suppose on stack.") - - -(* utility for suppose / suppose it is *) - -let close_previous_case pts = - if - Proof.is_done pts - then - match get_top_stack pts with - Per (et,_,_,_) :: _ -> anomaly (Pp.str "Weird case occurred ...") - | Suppose_case :: Per (et,_,_,_) :: _ -> - goto_current_focus () - | _ -> error "Not inside a proof per cases or induction." - else - match get_stack pts with - Per (et,_,_,_) :: _ -> () - | Suppose_case :: Per (et,_,_,_) :: _ -> - do_daimon ();goto_current_focus () - | _ -> error "Not inside a proof per cases or induction." - -(* Proof instructions *) - -(* automation *) - -let filter_hyps f gls = - let filter_aux id = - let id = NamedDecl.get_id id in - if f id then - tclIDTAC - else - tclTRY (clear [id]) in - tclMAP filter_aux (pf_hyps gls) gls - -let local_hyp_prefix = Id.of_string "___" - -let add_justification_hyps keep items gls = - let add_aux c gls= - match kind_of_term c with - Var id -> - keep:=Id.Set.add id !keep; - tclIDTAC gls - | _ -> - let id=pf_get_new_id local_hyp_prefix gls in - keep:=Id.Set.add id !keep; - 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 - -let prepare_goal items gls = - let tokeep = ref Id.Set.empty in - let auxres = add_justification_hyps tokeep items gls in - tclTHENLIST - [ (fun _ -> auxres); - filter_hyps (let keep = !tokeep in fun id -> Id.Set.mem id keep)] gls - -let my_automation_tac = ref - (Proofview.tclZERO (CErrors.make_anomaly (Pp.str"No automation registered"))) - -let register_automation_tac tac = my_automation_tac:= tac - -let automation_tac = Proofview.tclBIND (Proofview.tclUNIT ()) (fun () -> !my_automation_tac) - -let warn_insufficient_justification = - CWarnings.create ~name:"declmode-insufficient-justification" ~category:"declmode" - (fun () -> strbrk "Insufficient justification.") - -let justification tac gls= - tclORELSE - (tclSOLVE [tclTHEN tac (Proofview.V82.of_tactic assumption)]) - (fun gls -> - if get_strictness () then - error "Insufficient justification." - else - begin - warn_insufficient_justification (); - daimon_tac gls - end) gls - -let default_justification elems gls= - justification (tclTHEN (prepare_goal elems) (Proofview.V82.of_tactic automation_tac)) gls - -(* code for conclusion refining *) - -let constant dir s = lazy (Coqlib.gen_constant "Declarative" dir s) - -let _and = constant ["Init";"Logic"] "and" - -let _and_rect = constant ["Init";"Logic"] "and_rect" - -let _prod = constant ["Init";"Datatypes"] "prod" - -let _prod_rect = constant ["Init";"Datatypes"] "prod_rect" - -let _ex = constant ["Init";"Logic"] "ex" - -let _ex_ind = constant ["Init";"Logic"] "ex_ind" - -let _sig = constant ["Init";"Specif"] "sig" - -let _sig_rect = constant ["Init";"Specif"] "sig_rect" - -let _sigT = constant ["Init";"Specif"] "sigT" - -let _sigT_rect = constant ["Init";"Specif"] "sigT_rect" - -type stackd_elt = -{se_meta:metavariable; - se_type:types; - se_last_meta:metavariable; - se_meta_list:(metavariable*types) list; - se_evd: evar_map} - -let rec replace_in_list m l = function - [] -> raise Not_found - | c::q -> if Int.equal m (fst c) then l@q else c::replace_in_list m l q - -let enstack_subsubgoals env se stack gls= - let hd,params = decompose_app (special_whd gls se.se_type) in - match kind_of_term hd with - Ind (ind,u as indu) when is_good_inductive env ind -> (* MS: FIXME *) - let mib,oib= - Inductive.lookup_mind_specif env ind in - let gentypes= - Inductive.arities_of_constructors indu (mib,oib) in - let process i gentyp = - let constructor = mkConstructU ((ind,succ i),u) - (* constructors numbering*) in - let appterm = applist (constructor,params) in - let apptype = prod_applist gentyp params in - let rc,_ = Reduction.dest_prod env apptype in - let rec meta_aux last lenv = function - [] -> (last,lenv,[]) - | decl::q -> - let nlast=succ last in - let (llast,holes,metas) = - meta_aux nlast (mkMeta nlast :: lenv) q in - (llast,holes,(nlast,special_nf gls (substl lenv (RelDecl.get_type decl)))::metas) in - let (nlast,holes,nmetas) = - meta_aux se.se_last_meta [] (List.rev rc) in - let refiner = applist (appterm,List.rev holes) in - let evd = meta_assign se.se_meta - (refiner,(Conv,TypeProcessed (* ? *))) se.se_evd in - let ncreated = replace_in_list - se.se_meta nmetas se.se_meta_list in - let evd0 = List.fold_left - (fun evd (m,typ) -> meta_declare m typ evd) evd nmetas in - List.iter (fun (m,typ) -> - Stack.push - {se_meta=m; - se_type=typ; - se_evd=evd0; - se_meta_list=ncreated; - se_last_meta=nlast} stack) (List.rev nmetas) - in - Array.iteri process gentypes - | _ -> () - -let rec nf_list evd = - function - [] -> [] - | (m,typ)::others -> - if meta_defined evd m then - nf_list evd others - else - (m,Reductionops.nf_meta evd typ)::nf_list evd others - -let find_subsubgoal c ctyp skip submetas gls = - let env= pf_env gls in - let concl = pf_concl gls in - let evd = mk_evd ((0,concl)::submetas) gls in - let stack = Stack.create () in - let max_meta = - List.fold_left (fun a (m,_) -> max a m) 0 submetas in - let _ = Stack.push - {se_meta=0; - se_type=concl; - se_last_meta=max_meta; - se_meta_list=[0,concl]; - se_evd=evd} stack in - let rec dfs n = - let se = Stack.pop stack in - try - let unifier = - Unification.w_unify env se.se_evd Reduction.CUMUL - ~flags:(Unification.elim_flags ()) ctyp se.se_type in - if n <= 0 then - {se with - se_evd=meta_assign se.se_meta - (c,(Conv,TypeNotProcessed (* ?? *))) unifier; - se_meta_list=replace_in_list - se.se_meta submetas se.se_meta_list} - else - dfs (pred n) - with e when CErrors.noncritical e -> - begin - enstack_subsubgoals env se stack gls; - dfs n - end in - let nse= try dfs skip with Stack.Empty -> raise Not_found in - nf_list nse.se_evd nse.se_meta_list,Reductionops.nf_meta nse.se_evd (mkMeta 0) - -let concl_refiner metas body gls = - let concl = pf_concl gls in - let evd = sig_sig gls in - let env = pf_env gls in - let sort = family_of_sort (Typing.e_sort_of env (ref evd) concl) in - let rec aux env avoid subst = function - [] -> anomaly ~label:"concl_refiner" (Pp.str "cannot happen") - | (n,typ)::rest -> - let _A = subst_meta subst typ in - let x = id_of_name_using_hdchar env _A Anonymous in - let _x = fresh_id avoid x gls in - let nenv = Environ.push_named (LocalAssum (_x,_A)) env in - let asort = family_of_sort (Typing.e_sort_of nenv (ref evd) _A) in - let nsubst = (n,mkVar _x)::subst in - if List.is_empty rest then - asort,_A,mkNamedLambda _x _A (subst_meta nsubst body) - else - let bsort,_B,nbody = - aux nenv (_x::avoid) ((n,mkVar _x)::subst) rest in - let body = mkNamedLambda _x _A nbody in - if occur_term (mkVar _x) _B then - begin - let _P = mkNamedLambda _x _A _B in - match bsort,sort with - InProp,InProp -> - let _AxB = mkApp(Lazy.force _ex,[|_A;_P|]) in - InProp,_AxB, - mkApp(Lazy.force _ex_ind,[|_A;_P;concl;body|]) - | InProp,_ -> - let _AxB = mkApp(Lazy.force _sig,[|_A;_P|]) in - let _P0 = mkLambda(Anonymous,_AxB,concl) in - InType,_AxB, - mkApp(Lazy.force _sig_rect,[|_A;_P;_P0;body|]) - | _,_ -> - let _AxB = mkApp(Lazy.force _sigT,[|_A;_P|]) in - let _P0 = mkLambda(Anonymous,_AxB,concl) in - InType,_AxB, - mkApp(Lazy.force _sigT_rect,[|_A;_P;_P0;body|]) - end - else - begin - match asort,bsort with - InProp,InProp -> - let _AxB = mkApp(Lazy.force _and,[|_A;_B|]) in - InProp,_AxB, - mkApp(Lazy.force _and_rect,[|_A;_B;concl;body|]) - |_,_ -> - let _AxB = mkApp(Lazy.force _prod,[|_A;_B|]) in - let _P0 = mkLambda(Anonymous,_AxB,concl) in - InType,_AxB, - mkApp(Lazy.force _prod_rect,[|_A;_B;_P0;body|]) - end - in - let (_,_,prf) = aux env [] [] metas in - mkApp(prf,[|mkMeta 1|]) - -let thus_tac c ctyp submetas gls = - let list,proof = - try - find_subsubgoal c ctyp 0 submetas gls - with Not_found -> - error "I could not relate this statement to the thesis." in - if List.is_empty list then - Proofview.V82.of_tactic (exact_check proof) gls - else - let refiner = concl_refiner list proof gls in - Tacmach.refine refiner gls - -(* general forward step *) - -let mk_stat_or_thesis info gls = function - This c -> c - | Thesis (For _ ) -> - error "\"thesis for ...\" is not applicable here." - | Thesis Plain -> pf_concl gls - -let just_tac _then cut info gls0 = - let last_item = - if _then then - try [mkVar (get_last (pf_env gls0))] - with UserError _ -> - error "\"then\" and \"hence\" require at least one previous fact" - else [] - in - let items_tac gls = - match cut.cut_by with - None -> tclIDTAC gls - | Some items -> prepare_goal (last_item@items) gls in - let method_tac gls = - match cut.cut_using with - None -> - Proofview.V82.of_tactic automation_tac gls - | Some tac -> - Proofview.V82.of_tactic (Tacinterp.tactic_of_value (Tacinterp.default_ist ()) tac) gls in - justification (tclTHEN items_tac method_tac) gls0 - -let instr_cut mkstat _thus _then cut gls0 = - let info = get_its_info gls0 in - let stat = cut.cut_stat in - let (c_id,_) = match stat.st_label with - Anonymous -> - pf_get_new_id (Id.of_string "_fact") gls0,false - | Name id -> id,true in - let c_stat = mkstat info gls0 stat.st_it in - let thus_tac gls= - if _thus then - thus_tac (mkVar c_id) c_stat [] gls - else tclIDTAC gls in - tclTHENS (Proofview.V82.of_tactic (assert_postpone c_id c_stat)) - [tclTHEN tcl_erase_info (just_tac _then cut info); - thus_tac] gls0 - - -(* iterated equality *) -let _eq = lazy (Universes.constr_of_global (Coqlib.glob_eq)) - -let decompose_eq id gls = - let typ = pf_get_hyp_typ gls id in - 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 - then (args.(0), - args.(1), - args.(2)) - else error "Previous step is not an equality." - | _ -> error "Previous step is not an equality." - -let instr_rew _thus rew_side cut gls0 = - let last_id = - try get_last (pf_env gls0) - with UserError _ -> error "No previous equality." - in - let typ,lhs,rhs = decompose_eq last_id gls0 in - let items_tac gls = - match cut.cut_by with - None -> tclIDTAC gls - | Some items -> prepare_goal items gls in - let method_tac gls = - match cut.cut_using with - None -> - Proofview.V82.of_tactic automation_tac gls - | Some tac -> - Proofview.V82.of_tactic (Tacinterp.tactic_of_value (Tacinterp.default_ist ()) tac) gls in - let just_tac gls = - justification (tclTHEN items_tac method_tac) gls in - let (c_id,_) = match cut.cut_stat.st_label with - Anonymous -> - pf_get_new_id (Id.of_string "_eq") gls0,false - | Name id -> id,true in - let thus_tac new_eq gls= - if _thus then - thus_tac (mkVar c_id) new_eq [] gls - else tclIDTAC gls in - match rew_side with - Lhs -> - 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))]); - 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]); - thus_tac new_eq] gls0 - - -(* tactics for claim/focus *) - -let instr_claim _thus st gls0 = - let info = get_its_info gls0 in - let (id,_) = match st.st_label with - Anonymous -> pf_get_new_id (Id.of_string "_claim") gls0,false - | Name id -> id,true in - let thus_tac gls= - if _thus then - thus_tac (mkVar id) st.st_it [] gls - else tclIDTAC gls in - let ninfo1 = {pm_stack= - (if _thus then Focus_claim else Claim)::info.pm_stack} in - tclTHENS (Proofview.V82.of_tactic (assert_postpone id st.st_it)) - [thus_tac; - tcl_change_info ninfo1] gls0 - -(* tactics for assume *) - -let push_intro_tac coerce nam gls = - let (hid,_) = - match nam with - Anonymous -> pf_get_new_id (Id.of_string "_hyp") gls,false - | Name id -> id,true in - tclTHENLIST - [Proofview.V82.of_tactic (intro_mustbe_force hid); - coerce hid] - gls - -let assume_tac hyps gls = - List.fold_right - (fun (Hvar st | Hprop st) -> - tclTHEN - (push_intro_tac - (fun id -> - Proofview.V82.of_tactic (convert_hyp (LocalAssum (id,st.st_it)))) st.st_label)) - hyps tclIDTAC gls - -let assume_hyps_or_theses hyps gls = - List.fold_right - (function - (Hvar {st_label=nam;st_it=c} | Hprop {st_label=nam;st_it=This c}) -> - tclTHEN - (push_intro_tac - (fun id -> - Proofview.V82.of_tactic (convert_hyp (LocalAssum (id,c)))) nam) - | Hprop {st_label=nam;st_it=Thesis (tk)} -> - tclTHEN - (push_intro_tac - (fun id -> tclIDTAC) nam)) - hyps tclIDTAC gls - -let assume_st hyps gls = - List.fold_right - (fun st -> - tclTHEN - (push_intro_tac - (fun id -> Proofview.V82.of_tactic (convert_hyp (LocalAssum (id,st.st_it)))) st.st_label)) - hyps tclIDTAC gls - -let assume_st_letin hyps gls = - List.fold_right - (fun st -> - tclTHEN - (push_intro_tac - (fun id -> - Proofview.V82.of_tactic (convert_hyp (LocalDef (id, fst st.st_it, snd st.st_it)))) st.st_label)) - hyps tclIDTAC gls - -(* suffices *) - -let rec metas_from n hyps = - match hyps with - _ :: q -> n :: metas_from (succ n) q - | [] -> [] - -let rec build_product args body = - match args with - (Hprop st| Hvar st )::rest -> - let pprod= lift 1 (build_product rest body) in - let lbody = - match st.st_label with - Anonymous -> pprod - | Name id -> subst_term (mkVar id) pprod in - mkProd (st.st_label, st.st_it, lbody) - | [] -> body - -let rec build_applist prod = function - [] -> [],prod - | n::q -> - let (_,typ,_) = destProd prod in - let ctx,head = build_applist (prod_applist prod [mkMeta n]) q in - (n,typ)::ctx,head - -let instr_suffices _then cut gls0 = - let info = get_its_info gls0 in - let c_id = pf_get_new_id (Id.of_string "_cofact") gls0 in - let ctx,hd = cut.cut_stat in - let c_stat = build_product ctx (mk_stat_or_thesis info gls0 hd) in - let metas = metas_from 1 ctx in - let c_ctx,c_head = build_applist c_stat metas in - let c_term = applist (mkVar c_id,List.map mkMeta metas) in - let thus_tac gls= - thus_tac c_term c_head c_ctx gls in - tclTHENS (Proofview.V82.of_tactic (assert_postpone c_id c_stat)) - [tclTHENLIST - [ assume_tac ctx; - tcl_erase_info; - just_tac _then cut info]; - thus_tac] gls0 - -(* tactics for consider/given *) - -let conjunction_arity id gls = - let typ = pf_get_hyp_typ gls id in - let hd,params = decompose_app (special_whd gls typ) in - let env =pf_env gls in - match kind_of_term hd with - Ind (ind,u as indu) when is_good_inductive env ind -> - let mib,oib= - Inductive.lookup_mind_specif env ind in - let gentypes= - Inductive.arities_of_constructors indu (mib,oib) in - let _ = if not (Int.equal (Array.length gentypes) 1) then raise Not_found in - let apptype = prod_applist gentypes.(0) params in - let rc,_ = Reduction.dest_prod env apptype in - List.length rc - | _ -> raise Not_found - -let rec intron_then n ids ltac gls = - if n<=0 then - ltac ids gls - else - let id = pf_get_new_id (Id.of_string "_tmp") gls in - tclTHEN - (Proofview.V82.of_tactic (intro_mustbe_force id)) - (intron_then (pred n) (id::ids) ltac) gls - - -let rec consider_match may_intro introduced available expected gls = - match available,expected with - [],[] -> - tclIDTAC gls - | _,[] -> error "Last statements do not match a complete hypothesis." - (* should tell which ones *) - | [],hyps -> - if may_intro then - begin - let id = pf_get_new_id (Id.of_string "_tmp") gls in - tclIFTHENELSE - (Proofview.V82.of_tactic (intro_mustbe_force id)) - (consider_match true [] [id] hyps) - (fun _ -> - error "Not enough sub-hypotheses to match statements.") - gls - end - else - error "Not enough sub-hypotheses to match statements." - (* should tell which ones *) - | id::rest_ids,(Hvar st | Hprop st)::rest -> - tclIFTHENELSE (Proofview.V82.of_tactic (convert_hyp (LocalAssum (id,st.st_it)))) - begin - match st.st_label with - Anonymous -> - consider_match may_intro ((id,false)::introduced) rest_ids rest - | Name hid -> - tclTHENLIST - [Proofview.V82.of_tactic (rename_hyp [id,hid]); - consider_match may_intro ((hid,true)::introduced) rest_ids rest] - end - begin - (fun gls -> - let nhyps = - try conjunction_arity id gls with - Not_found -> error "Matching hypothesis not found." in - tclTHENLIST - [Proofview.V82.of_tactic (simplest_case (mkVar id)); - intron_then nhyps [] - (fun l -> consider_match may_intro introduced - (List.rev_append l rest_ids) expected)] gls) - end - gls - -let consider_tac c hyps gls = - match kind_of_term (strip_outer_cast c) with - Var id -> - consider_match false [] [id] hyps gls - | _ -> - let id = pf_get_new_id (Id.of_string "_tmp") gls in - tclTHEN - (Proofview.V82.of_tactic (pose_proof (Name id) c)) - (consider_match false [] [id] hyps) gls - - -let given_tac hyps gls = - consider_match true [] [] hyps gls - -(* tactics for take *) - -let rec take_tac wits gls = - match wits with - [] -> tclIDTAC gls - | wit::rest -> - let typ = pf_unsafe_type_of gls wit in - tclTHEN (thus_tac wit typ []) (take_tac rest) gls - - -(* tactics for define *) - -let rec build_function args body = - match args with - st::rest -> - let pfun= lift 1 (build_function rest body) in - let id = match st.st_label with - Anonymous -> assert false - | Name id -> id in - mkLambda (Name id, st.st_it, subst_term (mkVar id) pfun) - | [] -> body - -let define_tac id args body gls = - let t = build_function args body in - Proofview.V82.of_tactic (letin_tac None (Name id) t None Locusops.nowhere) gls - -(* tactics for reconsider *) - -let cast_tac id_or_thesis typ gls = - match id_or_thesis with - | This id -> - Proofview.V82.of_tactic (id |> pf_get_hyp gls |> NamedDecl.set_id id |> NamedDecl.set_type typ |> convert_hyp) gls - | Thesis (For _ ) -> - error "\"thesis for ...\" is not applicable here." - | Thesis Plain -> - Proofview.V82.of_tactic (convert_concl typ DEFAULTcast) gls - -(* per cases *) - -let is_rec_pos (main_ind,wft) = - match main_ind with - None -> false - | Some index -> - match fst (Rtree.dest_node wft) with - Mrec (_,i) when Int.equal i index -> true - | _ -> false - -let rec constr_trees (main_ind,wft) ind = - match Rtree.dest_node wft with - Norec,_ -> - let itree = - (snd (Global.lookup_inductive ind)).mind_recargs in - constr_trees (None,itree) ind - | _,constrs -> main_ind,constrs - -let ind_args rp ind = - let main_ind,constrs = constr_trees rp ind in - let args ctree = - Array.map (fun t -> main_ind,t) (snd (Rtree.dest_node ctree)) in - Array.map args constrs - -let init_tree ids ind rp nexti = - let indargs = ind_args rp ind in - let do_i i arp = (Array.map is_rec_pos arp),nexti i arp in - Split_patt (ids,ind,Array.mapi do_i indargs) - -let map_tree_rp rp id_fun mapi = function - Split_patt (ids,ind,branches) -> - let indargs = ind_args rp ind in - let do_i i (recargs,bri) = recargs,mapi i indargs.(i) bri in - Split_patt (id_fun ids,ind,Array.mapi do_i branches) - | _ -> failwith "map_tree_rp: not a splitting node" - -let map_tree id_fun mapi = function - Split_patt (ids,ind,branches) -> - let do_i i (recargs,bri) = recargs,mapi i bri in - Split_patt (id_fun ids,ind,Array.mapi do_i branches) - | _ -> failwith "map_tree: not a splitting node" - - -let start_tree env ind rp = - init_tree Id.Set.empty ind rp (fun _ _ -> None) - -let build_per_info etype casee gls = - let concl=pf_concl gls in - let env=pf_env gls in - let ctyp=pf_unsafe_type_of gls casee in - let is_dep = dependent casee concl in - let hd,args = decompose_app (special_whd gls ctyp) in - let (ind,u) = - try - destInd hd - with DestKO -> - error "Case analysis must be done on an inductive object." in - let mind,oind = Global.lookup_inductive ind in - let nparams,index = - match etype with - ET_Induction -> mind.mind_nparams_rec,Some (snd ind) - | _ -> mind.mind_nparams,None in - let params,real_args = List.chop nparams args in - let abstract_obj c body = - let typ=pf_unsafe_type_of gls c in - lambda_create env (typ,subst_term c body) in - let pred= List.fold_right abstract_obj - real_args (lambda_create env (ctyp,subst_term casee concl)) in - is_dep, - {per_casee=casee; - per_ctype=ctyp; - per_ind=ind; - per_pred=pred; - per_args=real_args; - per_params=params; - per_nparams=nparams; - per_wf=index,oind.mind_recargs} - -let per_tac etype casee gls= - let env=pf_env gls in - let info = get_its_info gls in - match casee with - Real c -> - let is_dep,per_info = build_per_info etype c gls in - let ek = - if is_dep then - EK_dep (start_tree env per_info.per_ind per_info.per_wf) - else EK_unknown in - tcl_change_info - {pm_stack= - Per(etype,per_info,ek,[])::info.pm_stack} gls - | Virtual cut -> - assert (cut.cut_stat.st_label == Anonymous); - let id = pf_get_new_id (Id.of_string "anonymous_matched") gls in - let c = mkVar id in - let modified_cut = - {cut with cut_stat={cut.cut_stat with st_label=Name id}} in - tclTHEN - (instr_cut (fun _ _ c -> c) false false modified_cut) - (fun gls0 -> - let is_dep,per_info = build_per_info etype c gls0 in - assert (not is_dep); - tcl_change_info - {pm_stack= - Per(etype,per_info,EK_unknown,[])::info.pm_stack} gls0) - gls - -(* suppose *) - -let register_nodep_subcase id= function - Per(et,pi,ek,clauses)::s -> - begin - match ek with - EK_unknown -> clauses,Per(et,pi,EK_nodep,id::clauses)::s - | EK_nodep -> clauses,Per(et,pi,EK_nodep,id::clauses)::s - | EK_dep _ -> error "Do not mix \"suppose\" with \"suppose it is\"." - end - | _ -> anomaly (Pp.str "wrong stack state") - -let suppose_tac hyps gls0 = - let info = get_its_info gls0 in - let thesis = pf_concl gls0 in - let id = pf_get_new_id (Id.of_string "subcase_") gls0 in - let clause = build_product hyps thesis in - let ninfo1 = {pm_stack=Suppose_case::info.pm_stack} in - let old_clauses,stack = register_nodep_subcase id info.pm_stack in - let ninfo2 = {pm_stack=stack} in - tclTHENS (Proofview.V82.of_tactic (assert_postpone id clause)) - [tclTHENLIST [tcl_change_info ninfo1; - assume_tac hyps; - clear old_clauses]; - tcl_change_info ninfo2] gls0 - -(* suppose it is ... *) - -(* pattern matching compiling *) - -let rec skip_args rest ids n = - if n <= 0 then - Close_patt rest - else - Skip_patt (ids,skip_args rest ids (pred n)) - -let rec tree_of_pats ((id,_) as cpl) pats = - match pats with - [] -> End_patt cpl - | args::stack -> - match args with - [] -> Close_patt (tree_of_pats cpl stack) - | (patt,rp) :: rest_args -> - match patt with - PatVar (_,v) -> - Skip_patt (Id.Set.singleton id, - tree_of_pats cpl (rest_args::stack)) - | PatCstr (_,(ind,cnum),args,nam) -> - let nexti i ati = - if Int.equal i (pred cnum) then - let nargs = - List.map_i (fun j a -> (a,ati.(j))) 0 args in - Some (Id.Set.singleton id, - tree_of_pats cpl (nargs::rest_args::stack)) - else None - in init_tree Id.Set.empty ind rp nexti - -let rec add_branch ((id,_) as cpl) pats tree= - match pats with - [] -> - begin - match tree with - End_patt cpl0 -> End_patt cpl0 - (* this ensures precedence for overlapping patterns *) - | _ -> anomaly (Pp.str "tree is expected to end here") - end - | args::stack -> - match args with - [] -> - begin - match tree with - Close_patt t -> - Close_patt (add_branch cpl stack t) - | _ -> anomaly (Pp.str "we should pop here") - end - | (patt,rp) :: rest_args -> - match patt with - PatVar (_,v) -> - begin - match tree with - Skip_patt (ids,t) -> - Skip_patt (Id.Set.add id ids, - add_branch cpl (rest_args::stack) t) - | Split_patt (_,_,_) -> - map_tree (Id.Set.add id) - (fun i bri -> - append_branch cpl 1 (rest_args::stack) bri) - tree - | _ -> anomaly (Pp.str "No pop/stop expected here") - end - | PatCstr (_,(ind,cnum),args,nam) -> - match tree with - Skip_patt (ids,t) -> - let nexti i ati = - if Int.equal i (pred cnum) then - let nargs = - List.map_i (fun j a -> (a,ati.(j))) 0 args in - Some (Id.Set.add id ids, - add_branch cpl (nargs::rest_args::stack) - (skip_args t ids (Array.length ati))) - else - Some (ids, - skip_args t ids (Array.length ati)) - in init_tree ids ind rp nexti - | Split_patt (_,ind0,_) -> - if (not (eq_ind ind ind0)) then error - (* this can happen with coercions *) - "Case pattern belongs to wrong inductive type."; - let mapi i ati bri = - if Int.equal i (pred cnum) then - let nargs = - List.map_i (fun j a -> (a,ati.(j))) 0 args in - append_branch cpl 0 - (nargs::rest_args::stack) bri - else bri in - map_tree_rp rp (fun ids -> ids) mapi tree - | _ -> anomaly (Pp.str "No pop/stop expected here") -and append_branch ((id,_) as cpl) depth pats = function - Some (ids,tree) -> - Some (Id.Set.add id ids,append_tree cpl depth pats tree) - | None -> - Some (Id.Set.singleton id,tree_of_pats cpl pats) -and append_tree ((id,_) as cpl) depth pats tree = - if depth<=0 then add_branch cpl pats tree - else match tree with - Close_patt t -> - Close_patt (append_tree cpl (pred depth) pats t) - | Skip_patt (ids,t) -> - Skip_patt (Id.Set.add id ids,append_tree cpl depth pats t) - | End_patt _ -> anomaly (Pp.str "Premature end of branch") - | Split_patt (_,_,_) -> - map_tree (Id.Set.add id) - (fun i bri -> append_branch cpl (succ depth) pats bri) tree - -(* suppose it is *) - -let rec st_assoc id = function - [] -> raise Not_found - | st::_ when Name.equal st.st_label id -> st.st_it - | _ :: rest -> st_assoc id rest - -let thesis_for obj typ per_info env= - let rc,hd1=decompose_prod typ in - let cind,all_args=decompose_app typ in - let ind,u = destInd cind in - let _ = if not (eq_ind ind per_info.per_ind) then - user_err ~hdr:"thesis_for" - ((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 - user_err ~hdr:"thesis_for" - ((Printer.pr_constr_env env Evd.empty obj) ++ spc () ++ - str "cannot give an induction hypothesis (wrong parameters).") in - let hd2 = (applist ((lift (List.length rc) per_info.per_pred),args@[obj])) in - compose_prod rc (Reductionops.whd_beta Evd.empty hd2) - -let rec build_product_dep pat_info per_info args body gls = - match args with - (Hprop {st_label=nam;st_it=This c} - | Hvar {st_label=nam;st_it=c})::rest -> - let pprod= - lift 1 (build_product_dep pat_info per_info rest body gls) in - let lbody = - match nam with - Anonymous -> body - | Name id -> subst_var id pprod in - mkProd (nam,c,lbody) - | Hprop ({st_it=Thesis tk} as st)::rest -> - let pprod= - lift 1 (build_product_dep pat_info per_info rest body gls) in - let lbody = - match st.st_label with - Anonymous -> body - | Name id -> subst_var id pprod in - let ptyp = - match tk with - For id -> - let obj = mkVar id in - let typ = - try st_assoc (Name id) pat_info.pat_vars - with Not_found -> - snd (st_assoc (Name id) pat_info.pat_aliases) in - thesis_for obj typ per_info (pf_env gls) - | Plain -> pf_concl gls in - mkProd (st.st_label,ptyp,lbody) - | [] -> body - -let build_dep_clause params pat_info per_info hyps gls = - let concl= - thesis_for pat_info.pat_constr pat_info.pat_typ per_info (pf_env gls) in - let open_clause = - build_product_dep pat_info per_info hyps concl gls in - let prod_one st body = - match st.st_label with - Anonymous -> mkProd(Anonymous,st.st_it,lift 1 body) - | Name id -> mkNamedProd id st.st_it (lift 1 body) in - let let_one_in st body = - match st.st_label with - Anonymous -> mkLetIn(Anonymous,fst st.st_it,snd st.st_it,lift 1 body) - | Name id -> - mkNamedLetIn id (fst st.st_it) (snd st.st_it) (lift 1 body) in - let aliased_clause = - List.fold_right let_one_in pat_info.pat_aliases open_clause in - List.fold_right prod_one (params@pat_info.pat_vars) aliased_clause - -let rec register_dep_subcase id env per_info pat = function - EK_nodep -> error "Only \"suppose it is\" can be used here." - | EK_unknown -> - register_dep_subcase id env per_info pat - (EK_dep (start_tree env per_info.per_ind per_info.per_wf)) - | EK_dep tree -> EK_dep (add_branch id [[pat,per_info.per_wf]] tree) - -let case_tac params pat_info hyps gls0 = - let info = get_its_info gls0 in - let id = pf_get_new_id (Id.of_string "subcase_") gls0 in - let et,per_info,ek,old_clauses,rest = - match info.pm_stack with - Per (et,pi,ek,old_clauses)::rest -> (et,pi,ek,old_clauses,rest) - | _ -> anomaly (Pp.str "wrong place for cases") in - let clause = build_dep_clause params pat_info per_info hyps gls0 in - let ninfo1 = {pm_stack=Suppose_case::info.pm_stack} in - let nek = - register_dep_subcase (id,(List.length params,List.length hyps)) - (pf_env gls0) per_info pat_info.pat_pat ek in - let ninfo2 = {pm_stack=Per(et,per_info,nek,id::old_clauses)::rest} in - tclTHENS (Proofview.V82.of_tactic (assert_postpone id clause)) - [tclTHENLIST - [tcl_change_info ninfo1; - assume_st (params@pat_info.pat_vars); - assume_st_letin pat_info.pat_aliases; - assume_hyps_or_theses hyps; - clear old_clauses]; - tcl_change_info ninfo2] gls0 - -(* end cases *) - -type ('a, 'b) instance_stack = - ('b * (('a option * constr list) list)) list - -let initial_instance_stack ids : (_, _) instance_stack = - List.map (fun id -> id,[None,[]]) ids - -let push_one_arg arg = function - [] -> anomaly (Pp.str "impossible") - | (head,args) :: ctx -> - ((head,(arg::args)) :: ctx) - -let push_arg arg stacks = - List.map (fun (id,stack) -> (id,push_one_arg arg stack)) stacks - - -let push_one_head c ids (id,stack) = - let head = if Id.Set.mem id ids then Some c else None in - id,(head,[]) :: stack - -let push_head c ids stacks = - List.map (push_one_head c ids) stacks - -let pop_one (id,stack) = - let nstack= - match stack with - [] -> anomaly (Pp.str "impossible") - | [c] as l -> l - | (Some head,args)::(head0,args0)::ctx -> - let arg = applist (head,(List.rev args)) in - (head0,(arg::args0))::ctx - | (None,args)::(head0,args0)::ctx -> - (head0,(args@args0))::ctx - in id,nstack - -let pop_stacks stacks = - List.map pop_one stacks - -let hrec_for fix_id per_info gls obj_id = - let obj=mkVar obj_id in - let typ=pf_get_hyp_typ gls obj_id in - let rc,hd1=decompose_prod typ in - let cind,all_args=decompose_app typ in - 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 - Invalid_argument _ -> false end; - let hd2 = applist (mkVar fix_id,args@[obj]) in - compose_lam rc (Reductionops.whd_beta gls.sigma hd2) - -let warn_missing_case = - CWarnings.create ~name:"declmode-missing-case" ~category:"declmode" - (fun () -> strbrk "missing case") - -let rec execute_cases fix_name per_info tacnext args objs nhrec tree gls = - match tree, objs with - Close_patt t,_ -> - let args0 = pop_stacks args in - execute_cases fix_name per_info tacnext args0 objs nhrec t gls - | Skip_patt (_,t),skipped::next_objs -> - let args0 = push_arg skipped args in - execute_cases fix_name per_info tacnext args0 next_objs nhrec t gls - | End_patt (id,(nparams,nhyps)),[] -> - begin - match Id.List.assoc id args with - [None,br_args] -> - let all_metas = - List.init (nparams + nhyps) (fun n -> mkMeta (succ n)) in - let param_metas,hyp_metas = List.chop nparams all_metas in - tclTHEN - (tclDO nhrec (Proofview.V82.of_tactic introf)) - (tacnext - (applist (mkVar id, - List.append param_metas - (List.rev_append br_args hyp_metas)))) gls - | _ -> anomaly (Pp.str "wrong stack size") - end - | Split_patt (ids,ind,br), casee::next_objs -> - let (mind,oind) as spec = Global.lookup_inductive ind in - let nparams = mind.mind_nparams in - let concl=pf_concl gls in - let env=pf_env gls in - let ctyp=pf_unsafe_type_of gls casee in - let hd,all_args = decompose_app (special_whd gls ctyp) in - let ind', u = destInd hd in - let _ = assert (eq_ind ind' ind) in (* just in case *) - let params,real_args = List.chop nparams all_args in - let abstract_obj c body = - let typ=pf_unsafe_type_of gls c in - lambda_create env (typ,subst_term c body) in - let elim_pred = List.fold_right abstract_obj - real_args (lambda_create env (ctyp,subst_term casee concl)) in - let case_info = Inductiveops.make_case_info env ind RegularStyle in - let gen_arities = Inductive.arities_of_constructors (ind,u) spec in - let f_ids typ = - let sign = - (prod_assum (prod_applist typ params)) in - find_intro_names sign gls in - let constr_args_ids = Array.map f_ids gen_arities in - let case_term = - mkCase(case_info,elim_pred,casee, - Array.mapi (fun i _ -> mkMeta (succ i)) constr_args_ids) in - let branch_tac i (recargs,bro) gls0 = - let args_ids = constr_args_ids.(i) in - let rec aux n = function - [] -> - assert (Int.equal n (Array.length recargs)); - next_objs,[],nhrec - | id :: q -> - let objs,recs,nrec = aux (succ n) q in - if recargs.(n) - then (mkVar id::objs),(id::recs),succ nrec - else (mkVar id::objs),recs,nrec in - let objs,recs,nhrec = aux 0 args_ids in - tclTHENLIST - [tclMAP (fun id -> Proofview.V82.of_tactic (intro_mustbe_force id)) args_ids; - begin - fun gls1 -> - let hrecs = - List.map - (fun id -> - hrec_for (out_name fix_name) per_info gls1 id) - recs in - Proofview.V82.of_tactic (generalize hrecs) gls1 - end; - match bro with - None -> - warn_missing_case (); - tacnext (mkMeta 1) - | Some (sub_ids,tree) -> - let br_args = - List.filter - (fun (id,_) -> Id.Set.mem id sub_ids) args in - let construct = - applist (mkConstruct(ind,succ i),params) in - let p_args = - push_head construct ids br_args in - execute_cases fix_name per_info tacnext - p_args objs nhrec tree] gls0 in - tclTHENSV - (refine case_term) - (Array.mapi branch_tac br) gls - | Split_patt (_, _, _) , [] -> - anomaly ~label:"execute_cases " (Pp.str "Nothing to split") - | Skip_patt _ , [] -> - anomaly ~label:"execute_cases " (Pp.str "Nothing to skip") - | End_patt (_,_) , _ :: _ -> - anomaly ~label:"execute_cases " (Pp.str "End of branch with garbage left") - -let understand_my_constr env sigma c concl = - let env = env in - let rawc = Detyping.detype false [] env Evd.empty c in - let rec frob = function - | GEvar _ -> GHole (Loc.ghost,Evar_kinds.QuestionMark Evar_kinds.Expand,Misctypes.IntroAnonymous,None) - | rc -> map_glob_constr frob rc - in - Pretyping.understand_tcc env sigma ~expected_type:(Pretyping.OfType concl) (frob rawc) - -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) - end } in - Proofview.V82.of_tactic (Tactics.New.refine oc) gls - -(* end focus/claim *) - -let end_tac et2 gls = - let info = get_its_info gls in - let et1,pi,ek,clauses = - match info.pm_stack with - Suppose_case::_ -> - anomaly (Pp.str "This case should already be trapped") - | Claim::_ -> - error "\"end claim\" expected." - | Focus_claim::_ -> - error "\"end focus\" expected." - | Per(et',pi,ek,clauses)::_ -> (et',pi,ek,clauses) - | [] -> - anomaly (Pp.str "This case should already be trapped") in - let et = match et1, et2 with - | ET_Case_analysis, ET_Case_analysis -> et1 - | ET_Induction, ET_Induction -> et1 - | ET_Case_analysis, _ -> error "\"end cases\" expected." - | ET_Induction, _ -> error "\"end induction\" expected." - in - tclTHEN - tcl_erase_info - begin - match et,ek with - _,EK_unknown -> - tclSOLVE [Proofview.V82.of_tactic (simplest_elim pi.per_casee)] - | ET_Case_analysis,EK_nodep -> - tclTHEN - (Proofview.V82.of_tactic (simplest_case 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 (simple_induct (AnonHyp (succ (List.length pi.per_args)))); - default_justification (List.map mkVar clauses)] - | ET_Case_analysis,EK_dep tree -> - execute_cases Anonymous pi - (fun c -> tclTHENLIST - [my_refine c; - clear clauses; - justification (Proofview.V82.of_tactic assumption)]) - (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]))) - begin - fun gls0 -> - let fix_id = - pf_get_new_id (Id.of_string "_fix") gls0 in - let c_id = - pf_get_new_id (Id.of_string "_main_arg") gls0 in - tclTHENLIST - [Proofview.V82.of_tactic (fix (Some fix_id) (succ nargs)); - tclDO nargs (Proofview.V82.of_tactic introf); - Proofview.V82.of_tactic (intro_mustbe_force c_id); - execute_cases (Name fix_id) pi - (fun c -> - tclTHENLIST - [clear [fix_id]; - my_refine c; - clear clauses; - justification (Proofview.V82.of_tactic assumption)]) - (initial_instance_stack clauses) - [mkVar c_id] 0 tree] gls0 - end - end gls - -(* escape *) - -let escape_tac gls = - (* spiwack: sets an empty info stack to avoid interferences. - We could erase the info altogether, but that doesn't play - well with the Decl_mode.focus (used in post_processing). *) - let info={pm_stack=[]} in - tcl_change_info info gls - -(* General instruction engine *) - -let rec do_proof_instr_gen _thus _then instr = - match instr with - Pthus i -> - assert (not _thus); - do_proof_instr_gen true _then i - | Pthen i -> - assert (not _then); - do_proof_instr_gen _thus true i - | Phence i -> - assert (not (_then || _thus)); - do_proof_instr_gen true true i - | Pcut c -> - instr_cut mk_stat_or_thesis _thus _then c - | Psuffices c -> - instr_suffices _then c - | Prew (s,c) -> - assert (not _then); - instr_rew _thus s c - | Pconsider (c,hyps) -> consider_tac c hyps - | Pgiven hyps -> given_tac hyps - | Passume hyps -> assume_tac hyps - | Plet hyps -> assume_tac hyps - | Pclaim st -> instr_claim false st - | Pfocus st -> instr_claim true st - | Ptake witl -> take_tac witl - | Pdefine (id,args,body) -> define_tac id args body - | Pcast (id,typ) -> cast_tac id typ - | Pper (et,cs) -> per_tac et cs - | Psuppose hyps -> suppose_tac hyps - | Pcase (params,pat_info,hyps) -> case_tac params pat_info hyps - | Pend (B_elim et) -> end_tac et - | Pend _ -> anomaly (Pp.str "Not applicable") - | Pescape -> escape_tac - -let eval_instr {instr=instr} = - do_proof_instr_gen false false instr - -let rec preprocess pts instr = - match instr with - Phence i |Pthus i | Pthen i -> preprocess pts i - | Psuffices _ | Pcut _ | Passume _ | Plet _ | Pclaim _ | Pfocus _ - | Pconsider (_,_) | Pcast (_,_) | Pgiven _ | Ptake _ - | Pdefine (_,_,_) | Pper _ | Prew _ -> - check_not_per pts; - true - | Pescape -> - check_not_per pts; - true - | Pcase _ | Psuppose _ | Pend (B_elim _) -> - close_previous_case pts ; - true - | Pend bt -> - close_block bt pts ; - false - -let rec postprocess pts instr = - match instr with - Phence i | Pthus i | Pthen i -> postprocess pts i - | Pcut _ | Psuffices _ | Passume _ | Plet _ | Pconsider (_,_) | Pcast (_,_) - | Pgiven _ | Ptake _ | Pdefine (_,_,_) | Prew (_,_) -> () - | Pclaim _ | Pfocus _ | Psuppose _ | Pcase _ | Pper _ -> - Decl_mode.focus pts - | Pescape -> - Decl_mode.focus pts; - Proof_global.set_proof_mode "Classic" - | Pend (B_elim ET_Induction) -> - begin - let pfterm = List.hd (Proof.partial_proof pts) in - let { it = gls ; sigma = sigma } = Proof.V82.subgoals pts in - let env = try - Goal.V82.env sigma (List.hd gls) - with Failure "hd" -> - Global.env () - in - try - Inductiveops.control_only_guard env pfterm; - goto_current_focus_or_top () - with - Type_errors.TypeError(env, - Type_errors.IllFormedRecBody(_,_,_,_,_)) -> - anomaly (Pp.str "\"end induction\" generated an ill-formed fixpoint") - end - | Pend (B_elim ET_Case_analysis) -> goto_current_focus () - | Pend B_proof -> Proof_global.set_proof_mode "Classic" - | Pend _ -> () - -let do_instr raw_instr pts = - let has_tactic = preprocess pts raw_instr.instr in - (* spiwack: hack! [preprocess] assumes that the [pts] is indeed the - current proof (and, actually so does [do_instr] later one, so - it's ok to do the same here. Ideally the proof should be properly - threaded through the commands here, but since the are interleaved - with actions on the proof mode, which is attached to the global - proof environment, it is not possible without heavy lifting. *) - let pts = Proof_global.give_me_the_proof () in - let pts = - if has_tactic then - let { it=gls ; sigma=sigma; } = Proof.V82.subgoals pts in - let gl = { it=List.hd gls ; sigma=sigma; } in - let env= pf_env gl in - let ist = {ltacvars = Id.Set.empty; genv = env} in - let glob_instr = intern_proof_instr ist raw_instr in - let instr = - interp_proof_instr (get_its_info gl) env sigma glob_instr in - let (pts',_) = Proof.run_tactic (Global.env()) - (Proofview.V82.tactic (tclTHEN (eval_instr instr) clean_tmp)) pts in - pts' - else pts - in - Proof_global.simple_with_current_proof (fun _ _ -> pts); - postprocess pts raw_instr.instr - -let proof_instr raw_instr = - let p = Proof_global.give_me_the_proof () in - do_instr raw_instr p - -(* - -(* STUFF FOR ITERATED RELATIONS *) -let decompose_bin_app t= - let hd,args = destApp - -let identify_transitivity_lemma c = - let varx,tx,c1 = destProd c in - let vary,ty,c2 = destProd (pop c1) in - let varz,tz,c3 = destProd (pop c2) in - let _,p1,c4 = destProd (pop c3) in - let _,lp2,lp3 = destProd (pop c4) in - let p2=pop lp2 in - let p3=pop lp3 in -*) - diff --git a/plugins/decl_mode/decl_proof_instr.mli b/plugins/decl_mode/decl_proof_instr.mli deleted file mode 100644 index 325969dad..000000000 --- a/plugins/decl_mode/decl_proof_instr.mli +++ /dev/null @@ -1,108 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -open Names -open Term -open Tacmach -open Decl_mode - -val go_to_proof_mode: unit -> unit -val return_from_tactic_mode: unit -> unit - -val register_automation_tac: unit Proofview.tactic -> unit - -val automation_tac : unit Proofview.tactic - -val concl_refiner: - Termops.meta_type_map -> constr -> Proof_type.goal sigma -> constr - -val do_instr: Decl_expr.raw_proof_instr -> Proof.proof -> unit -val proof_instr: Decl_expr.raw_proof_instr -> unit - -val tcl_change_info : Decl_mode.pm_info -> tactic - -val execute_cases : - Name.t -> - Decl_mode.per_info -> - (Term.constr -> Proof_type.tactic) -> - (Id.Set.elt * (Term.constr option * Term.constr list) list) list -> - Term.constr list -> int -> Decl_mode.split_tree -> Proof_type.tactic - -val tree_of_pats : - Id.t * (int * int) -> (Glob_term.cases_pattern*recpath) list list -> - split_tree - -val add_branch : - Id.t * (int * int) -> (Glob_term.cases_pattern*recpath) list list -> - split_tree -> split_tree - -val append_branch : - Id.t *(int * int) -> int -> (Glob_term.cases_pattern*recpath) list list -> - (Id.Set.t * Decl_mode.split_tree) option -> - (Id.Set.t * Decl_mode.split_tree) option - -val append_tree : - Id.t * (int * int) -> int -> (Glob_term.cases_pattern*recpath) list list -> - split_tree -> split_tree - -val build_dep_clause : Term.types Decl_expr.statement list -> - Decl_expr.proof_pattern -> - Decl_mode.per_info -> - (Term.types Decl_expr.statement, Term.types Decl_expr.or_thesis) - Decl_expr.hyp list -> Proof_type.goal Tacmach.sigma -> Term.types - -val register_dep_subcase : - Id.t * (int * int) -> - Environ.env -> - Decl_mode.per_info -> - Glob_term.cases_pattern -> Decl_mode.elim_kind -> Decl_mode.elim_kind - -val thesis_for : Term.constr -> - Term.constr -> Decl_mode.per_info -> Environ.env -> Term.constr - -val close_previous_case : Proof.proof -> unit - -val pop_stacks : - (Id.t * - (Term.constr option * Term.constr list) list) list -> - (Id.t * - (Term.constr option * Term.constr list) list) list - -val push_head : Term.constr -> - Id.Set.t -> - (Id.t * - (Term.constr option * Term.constr list) list) list -> - (Id.t * - (Term.constr option * Term.constr list) list) list - -val push_arg : Term.constr -> - (Id.t * - (Term.constr option * Term.constr list) list) list -> - (Id.t * - (Term.constr option * Term.constr list) list) list - -val hrec_for: - Id.t -> - Decl_mode.per_info -> Proof_type.goal Tacmach.sigma -> - Id.t -> Term.constr - -val consider_match : - bool -> - (Id.Set.elt*bool) list -> - Id.Set.elt list -> - (Term.types Decl_expr.statement, Term.types) Decl_expr.hyp list -> - Proof_type.tactic - -val init_tree: - Id.Set.t -> - inductive -> - int option * Declarations.wf_paths -> - (int -> - (int option * Declarations.recarg Rtree.t) array -> - (Id.Set.t * Decl_mode.split_tree) option) -> - Decl_mode.split_tree diff --git a/plugins/decl_mode/g_decl_mode.ml4 b/plugins/decl_mode/g_decl_mode.ml4 deleted file mode 100644 index 18a35c6cf..000000000 --- a/plugins/decl_mode/g_decl_mode.ml4 +++ /dev/null @@ -1,386 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -(*i camlp4deps: "grammar/grammar.cma" i*) - -DECLARE PLUGIN "decl_mode_plugin" - -open Compat -open Pp -open Decl_expr -open Names -open Pcoq -open Vernacexpr -open Tok (* necessary for camlp4 *) - -open Pcoq.Constr -open Pltac -open Ppdecl_proof - -let pr_goal gs = - let (g,sigma) = Goal.V82.nf_evar (Tacmach.project gs) (Evd.sig_it gs) in - let env = Goal.V82.env sigma g in - let concl = Goal.V82.concl sigma g in - let goal = - Printer.pr_context_of env sigma ++ cut () ++ - str "============================" ++ cut () ++ - str "thesis :=" ++ cut () ++ - Printer.pr_goal_concl_style_env env sigma concl in - str " *** Declarative Mode ***" ++ fnl () ++ fnl () ++ - str " " ++ v 0 goal - -let pr_subgoals ?(pr_first=true) _ sigma _ _ _ gll = - match gll with - | [goal] when pr_first -> - pr_goal { Evd.it = goal ; sigma = sigma } - | _ -> - (* spiwack: it's not very nice to have to call proof global - here, a more robust solution would be to add a hook for - [Printer.pr_open_subgoals] in proof modes, in order to - compute the end command. Yet a more robust solution would be - to have focuses give explanations of their unfocusing - behaviour. *) - let p = Proof_global.give_me_the_proof () in - let close_cmd = Decl_mode.get_end_command p in - str "Subproof completed, now type " ++ str close_cmd ++ str "." - -let interp_proof_instr _ { Evd.it = gl ; sigma = sigma }= - Decl_interp.interp_proof_instr - (Decl_mode.get_info sigma gl) - (Goal.V82.env sigma gl) - (sigma) - -let vernac_decl_proof () = - let pf = Proof_global.give_me_the_proof () in - if Proof.is_done pf then - CErrors.error "Nothing left to prove here." - else - begin - Decl_proof_instr.go_to_proof_mode () ; - Proof_global.set_proof_mode "Declarative" - end - -(* spiwack: some bureaucracy is not performed here *) -let vernac_return () = - begin - Decl_proof_instr.return_from_tactic_mode () ; - Proof_global.set_proof_mode "Declarative" - end - -let vernac_proof_instr instr = - Decl_proof_instr.proof_instr instr - -(* Before we can write an new toplevel command (see below) - which takes a [proof_instr] as argument, we need to declare - how to parse it, print it, globalise it and interprete it. - Normally we could do that easily through ARGUMENT EXTEND, - but as the parsing is fairly complicated we will do it manually to - indirect through the [proof_instr] grammar entry. *) -(* spiwack: proposal: doing that directly from argextend.ml4, maybe ? *) - -(* Only declared at raw level, because only used in vernac commands. *) -let wit_proof_instr : (raw_proof_instr, glob_proof_instr, proof_instr) Genarg.genarg_type = - Genarg.make0 "proof_instr" - -(* We create a new parser entry [proof_mode]. The Declarative proof mode - will replace the normal parser entry for tactics with this one. *) -let proof_mode : vernac_expr Gram.entry = - Gram.entry_create "vernac:proof_command" -(* Auxiliary grammar entry. *) -let proof_instr : raw_proof_instr Gram.entry = - Pcoq.create_generic_entry Pcoq.utactic "proof_instr" (Genarg.rawwit wit_proof_instr) - -let _ = Pptactic.declare_extra_genarg_pprule wit_proof_instr - pr_raw_proof_instr pr_glob_proof_instr pr_proof_instr - -let classify_proof_instr = function - | { instr = Pescape |Pend B_proof } -> VtProofMode "Classic", VtNow - | _ -> Vernac_classifier.classify_as_proofstep - -(* We use the VERNAC EXTEND facility with a custom non-terminal - to populate [proof_mode] with a new toplevel interpreter. - The "-" indicates that the rule does not start with a distinguished - string. *) -VERNAC proof_mode EXTEND ProofInstr - [ - proof_instr(instr) ] => [classify_proof_instr instr] -> [ vernac_proof_instr instr ] -END - -(* It is useful to use GEXTEND directly to call grammar entries that have been - defined previously VERNAC EXTEND. In this case we allow, in proof mode, - the use of commands like Check or Print. VERNAC EXTEND does quite a bit of - bureaucracy for us, but it is not needed in this sort of case, and it would require - to have an ARGUMENT EXTEND version of the "proof_mode" grammar entry. *) -GEXTEND Gram - GLOBAL: proof_mode ; - - proof_mode: LAST - [ [ c=G_vernac.subgoal_command -> c (Some (Vernacexpr.SelectNth 1)) ] ] - ; -END - -(* We register a new proof mode here *) - -let _ = - Proof_global.register_proof_mode { Proof_global. - name = "Declarative" ; (* name for identifying and printing *) - (* function [set] goes from No Proof Mode to - Declarative Proof Mode performing side effects *) - set = begin fun () -> - (* We set the command non terminal to - [proof_mode] (which we just defined). *) - Pcoq.set_command_entry proof_mode ; - (* We substitute the goal printer, by the one we built - for the proof mode. *) - Printer.set_printer_pr { Printer.default_printer_pr with - Printer.pr_goal = pr_goal; - pr_subgoals = pr_subgoals; } - end ; - (* function [reset] goes back to No Proof Mode from - Declarative Proof Mode *) - reset = begin fun () -> - (* We restore the command non terminal to - [noedit_mode]. *) - Pcoq.set_command_entry Pcoq.Vernac_.noedit_mode ; - (* We restore the goal printer to default *) - Printer.set_printer_pr Printer.default_printer_pr - end - } - -VERNAC COMMAND EXTEND DeclProof -[ "proof" ] => [ VtProofMode "Declarative", VtNow ] -> [ vernac_decl_proof () ] -END -VERNAC COMMAND EXTEND DeclReturn -[ "return" ] => [ VtProofMode "Declarative", VtNow ] -> [ vernac_return () ] -END - -let none_is_empty = function - None -> [] - | Some l -> l - -GEXTEND Gram -GLOBAL: proof_instr; - thesis : - [[ "thesis" -> Plain - | "thesis"; "for"; i=ident -> (For i) - ]]; - statement : - [[ i=ident ; ":" ; c=constr -> {st_label=Name i;st_it=c} - | i=ident -> {st_label=Anonymous; - st_it=Constrexpr.CRef (Libnames.Ident (!@loc, i), None)} - | c=constr -> {st_label=Anonymous;st_it=c} - ]]; - constr_or_thesis : - [[ t=thesis -> Thesis t ] | - [ c=constr -> This c - ]]; - statement_or_thesis : - [ - [ t=thesis -> {st_label=Anonymous;st_it=Thesis t} ] - | - [ i=ident ; ":" ; cot=constr_or_thesis -> {st_label=Name i;st_it=cot} - | i=ident -> {st_label=Anonymous; - st_it=This (Constrexpr.CRef (Libnames.Ident (!@loc, i), None))} - | c=constr -> {st_label=Anonymous;st_it=This c} - ] - ]; - justification_items : - [[ -> Some [] - | "by"; l=LIST1 constr SEP "," -> Some l - | "by"; "*" -> None ]] - ; - justification_method : - [[ -> None - | "using"; tac = tactic -> Some tac ]] - ; - simple_cut_or_thesis : - [[ ls = statement_or_thesis; - j = justification_items; - taco = justification_method - -> {cut_stat=ls;cut_by=j;cut_using=taco} ]] - ; - simple_cut : - [[ ls = statement; - j = justification_items; - taco = justification_method - -> {cut_stat=ls;cut_by=j;cut_using=taco} ]] - ; - elim_type: - [[ IDENT "induction" -> ET_Induction - | IDENT "cases" -> ET_Case_analysis ]] - ; - block_type : - [[ IDENT "claim" -> B_claim - | IDENT "focus" -> B_focus - | IDENT "proof" -> B_proof - | et=elim_type -> B_elim et ]] - ; - elim_obj: - [[ IDENT "on"; c=constr -> Real c - | IDENT "of"; c=simple_cut -> Virtual c ]] - ; - elim_step: - [[ IDENT "consider" ; - h=consider_vars ; IDENT "from" ; c=constr -> Pconsider (c,h) - | IDENT "per"; et=elim_type; obj=elim_obj -> Pper (et,obj) - | IDENT "suffices"; ls=suff_clause; - j = justification_items; - taco = justification_method - -> Psuffices {cut_stat=ls;cut_by=j;cut_using=taco} ]] - ; - rew_step : - [[ "~=" ; c=simple_cut -> (Rhs,c) - | "=~" ; c=simple_cut -> (Lhs,c)]] - ; - cut_step: - [[ "then"; tt=elim_step -> Pthen tt - | "then"; c=simple_cut_or_thesis -> Pthen (Pcut c) - | IDENT "thus"; tt=rew_step -> Pthus (let s,c=tt in Prew (s,c)) - | IDENT "thus"; c=simple_cut_or_thesis -> Pthus (Pcut c) - | IDENT "hence"; c=simple_cut_or_thesis -> Phence (Pcut c) - | tt=elim_step -> tt - | tt=rew_step -> let s,c=tt in Prew (s,c); - | IDENT "have"; c=simple_cut_or_thesis -> Pcut c; - | IDENT "claim"; c=statement -> Pclaim c; - | IDENT "focus"; IDENT "on"; c=statement -> Pfocus c; - | "end"; bt = block_type -> Pend bt; - | IDENT "escape" -> Pescape ]] - ; - (* examiner s'il est possible de faire R _ et _ R pour R une relation qcq*) - loc_id: - [[ id=ident -> fun x -> (!@loc,(id,x)) ]]; - hyp: - [[ id=loc_id -> id None ; - | id=loc_id ; ":" ; c=constr -> id (Some c)]] - ; - consider_vars: - [[ name=hyp -> [Hvar name] - | name=hyp; ","; v=consider_vars -> (Hvar name) :: v - | name=hyp; - IDENT "such"; IDENT "that"; h=consider_hyps -> (Hvar name)::h - ]] - ; - consider_hyps: - [[ st=statement; IDENT "and"; h=consider_hyps -> Hprop st::h - | st=statement; IDENT "and"; - IDENT "consider" ; v=consider_vars -> Hprop st::v - | st=statement -> [Hprop st] - ]] - ; - assume_vars: - [[ name=hyp -> [Hvar name] - | name=hyp; ","; v=assume_vars -> (Hvar name) :: v - | name=hyp; - IDENT "such"; IDENT "that"; h=assume_hyps -> (Hvar name)::h - ]] - ; - assume_hyps: - [[ st=statement; IDENT "and"; h=assume_hyps -> Hprop st::h - | st=statement; IDENT "and"; - IDENT "we"; IDENT "have" ; v=assume_vars -> Hprop st::v - | st=statement -> [Hprop st] - ]] - ; - assume_clause: - [[ IDENT "we" ; IDENT "have" ; v=assume_vars -> v - | h=assume_hyps -> h ]] - ; - suff_vars: - [[ name=hyp; IDENT "to"; IDENT "show" ; c = constr_or_thesis -> - [Hvar name],c - | name=hyp; ","; v=suff_vars -> - let (q,c) = v in ((Hvar name) :: q),c - | name=hyp; - IDENT "such"; IDENT "that"; h=suff_hyps -> - let (q,c) = h in ((Hvar name) :: q),c - ]]; - suff_hyps: - [[ st=statement; IDENT "and"; h=suff_hyps -> - let (q,c) = h in (Hprop st::q),c - | st=statement; IDENT "and"; - IDENT "to" ; IDENT "have" ; v=suff_vars -> - let (q,c) = v in (Hprop st::q),c - | st=statement; IDENT "to"; IDENT "show" ; c = constr_or_thesis -> - [Hprop st],c - ]] - ; - suff_clause: - [[ IDENT "to" ; IDENT "have" ; v=suff_vars -> v - | h=suff_hyps -> h ]] - ; - let_vars: - [[ name=hyp -> [Hvar name] - | name=hyp; ","; v=let_vars -> (Hvar name) :: v - | name=hyp; IDENT "be"; - IDENT "such"; IDENT "that"; h=let_hyps -> (Hvar name)::h - ]] - ; - let_hyps: - [[ st=statement; IDENT "and"; h=let_hyps -> Hprop st::h - | st=statement; IDENT "and"; "let"; v=let_vars -> Hprop st::v - | st=statement -> [Hprop st] - ]]; - given_vars: - [[ name=hyp -> [Hvar name] - | name=hyp; ","; v=given_vars -> (Hvar name) :: v - | name=hyp; IDENT "such"; IDENT "that"; h=given_hyps -> (Hvar name)::h - ]] - ; - given_hyps: - [[ st=statement; IDENT "and"; h=given_hyps -> Hprop st::h - | st=statement; IDENT "and"; IDENT "given"; v=given_vars -> Hprop st::v - | st=statement -> [Hprop st] - ]]; - suppose_vars: - [[name=hyp -> [Hvar name] - |name=hyp; ","; v=suppose_vars -> (Hvar name) :: v - |name=hyp; OPT[IDENT "be"]; - IDENT "such"; IDENT "that"; h=suppose_hyps -> (Hvar name)::h - ]] - ; - suppose_hyps: - [[ st=statement_or_thesis; IDENT "and"; h=suppose_hyps -> Hprop st::h - | st=statement_or_thesis; IDENT "and"; IDENT "we"; IDENT "have"; - v=suppose_vars -> Hprop st::v - | st=statement_or_thesis -> [Hprop st] - ]] - ; - suppose_clause: - [[ IDENT "we"; IDENT "have"; v=suppose_vars -> v; - | h=suppose_hyps -> h ]] - ; - intro_step: - [[ IDENT "suppose" ; h=assume_clause -> Psuppose h - | IDENT "suppose" ; IDENT "it"; IDENT "is" ; c=pattern LEVEL "0" ; - po=OPT[ "with"; p=LIST1 hyp SEP ","-> p ] ; - ho=OPT[ IDENT "and" ; h=suppose_clause -> h ] -> - Pcase (none_is_empty po,c,none_is_empty ho) - | "let" ; v=let_vars -> Plet v - | IDENT "take"; witnesses = LIST1 constr SEP "," -> Ptake witnesses - | IDENT "assume"; h=assume_clause -> Passume h - | IDENT "given"; h=given_vars -> Pgiven h - | IDENT "define"; id=ident; args=LIST0 hyp; - "as"; body=constr -> Pdefine(id,args,body) - | IDENT "reconsider"; id=ident; "as" ; typ=constr -> Pcast (This id,typ) - | IDENT "reconsider"; t=thesis; "as" ; typ=constr -> Pcast (Thesis t ,typ) - ]] - ; - emphasis : - [[ -> 0 - | "*" -> 1 - | "**" -> 2 - | "***" -> 3 - ]] - ; - bare_proof_instr: - [[ c = cut_step -> c ; - | i = intro_step -> i ]] - ; - proof_instr : - [[ e=emphasis;i=bare_proof_instr;"." -> {emph=e;instr=i}]] - ; -END;; diff --git a/plugins/decl_mode/ppdecl_proof.ml b/plugins/decl_mode/ppdecl_proof.ml deleted file mode 100644 index 59a0bb5a2..000000000 --- a/plugins/decl_mode/ppdecl_proof.ml +++ /dev/null @@ -1,215 +0,0 @@ -(************************************************************************) -(* v * The Coq Proof Assistant / The Coq Development Team *) -(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) -(* \VV/ **************************************************************) -(* // * This file is distributed under the terms of the *) -(* * GNU Lesser General Public License Version 2.1 *) -(************************************************************************) - -open CErrors -open Pp -open Decl_expr -open Names -open Nameops - -let pr_label = function - Anonymous -> mt () - | Name id -> pr_id id ++ spc () ++ str ":" ++ spc () - -let pr_justification_items pr_constr = function - Some [] -> mt () - | Some (_::_ as l) -> - spc () ++ str "by" ++ spc () ++ - prlist_with_sep (fun () -> str ",") pr_constr l - | None -> spc () ++ str "by *" - -let pr_justification_method pr_tac = function - None -> mt () - | Some tac -> - spc () ++ str "using" ++ spc () ++ pr_tac tac - -let pr_statement pr_constr st = - pr_label st.st_label ++ pr_constr st.st_it - -let pr_or_thesis pr_this = function - Thesis Plain -> str "thesis" - | Thesis (For id) -> - str "thesis" ++ spc() ++ str "for" ++ spc () ++ pr_id id - | This c -> pr_this c - -let pr_cut pr_constr pr_tac pr_it c = - hov 1 (pr_it c.cut_stat) ++ - pr_justification_items pr_constr c.cut_by ++ - pr_justification_method pr_tac c.cut_using - -let type_or_thesis = function - Thesis _ -> Term.mkProp - | This c -> c - -let _I x = x - -let rec pr_hyps pr_var pr_constr gtyp sep _be _have hyps = - let pr_sep = if sep then str "and" ++ spc () else mt () in - match hyps with - (Hvar _ ::_) as rest -> - spc () ++ pr_sep ++ str _have ++ - pr_vars pr_var pr_constr gtyp false _be _have rest - | Hprop st :: rest -> - begin - (* let npr_constr env = pr_constr (Environ.push_named (id,None,gtyp st.st_it) env)*) - spc() ++ pr_sep ++ pr_statement pr_constr st ++ - pr_hyps pr_var pr_constr gtyp true _be _have rest - end - | [] -> mt () - -and pr_vars pr_var pr_constr gtyp sep _be _have vars = - match vars with - Hvar st :: rest -> - begin - (* let npr_constr env = pr_constr (Environ.push_named (id,None,gtyp st.st_it) env)*) - let pr_sep = if sep then pr_comma () else mt () in - spc() ++ pr_sep ++ - pr_var st ++ - pr_vars pr_var pr_constr gtyp true _be _have rest - end - | (Hprop _ :: _) as rest -> - let _st = if _be then - str "be such that" - else - str "such that" in - spc() ++ _st ++ pr_hyps pr_var pr_constr gtyp false _be _have rest - | [] -> mt () - -let pr_suffices_clause pr_var pr_constr (hyps,c) = - pr_hyps pr_var pr_constr _I false false "to have" hyps ++ spc () ++ - str "to show" ++ spc () ++ pr_or_thesis pr_constr c - -let pr_elim_type = function - ET_Case_analysis -> str "cases" - | ET_Induction -> str "induction" - -let pr_block_type = function - B_elim et -> pr_elim_type et - | B_proof -> str "proof" - | B_claim -> str "claim" - | B_focus -> str "focus" - -let pr_casee pr_constr pr_tac =function - Real c -> str "on" ++ spc () ++ pr_constr c - | Virtual cut -> str "of" ++ spc () ++ pr_cut pr_constr pr_tac (pr_statement pr_constr) cut - -let pr_side = function - Lhs -> str "=~" - | Rhs -> str "~=" - -let rec pr_bare_proof_instr pr_var pr_constr pr_pat pr_tac _then _thus = function - | Pescape -> str "escape" - | Pthen i -> pr_bare_proof_instr pr_var pr_constr pr_pat pr_tac true _thus i - | Pthus i -> pr_bare_proof_instr pr_var pr_constr pr_pat pr_tac _then true i - | Phence i -> pr_bare_proof_instr pr_var pr_constr pr_pat pr_tac true true i - | Pcut c -> - begin - match _then,_thus with - false,false -> str "have" ++ spc () ++ - pr_cut pr_constr pr_tac (pr_statement (pr_or_thesis pr_constr)) c - | false,true -> str "thus" ++ spc () ++ - pr_cut pr_constr pr_tac (pr_statement (pr_or_thesis pr_constr)) c - | true,false -> str "then" ++ spc () ++ - pr_cut pr_constr pr_tac (pr_statement (pr_or_thesis pr_constr)) c - | true,true -> str "hence" ++ spc () ++ - pr_cut pr_constr pr_tac (pr_statement (pr_or_thesis pr_constr)) c - end - | Psuffices c -> - str "suffices" ++ pr_cut pr_constr pr_tac (pr_suffices_clause pr_var pr_constr) c - | Prew (sid,c) -> - (if _thus then str "thus" else str " ") ++ spc () ++ - pr_side sid ++ spc () ++ pr_cut pr_constr pr_tac (pr_statement pr_constr) c - | Passume hyps -> - str "assume" ++ pr_hyps pr_var pr_constr _I false false "we have" hyps - | Plet hyps -> - str "let" ++ pr_vars pr_var pr_constr _I false true "let" hyps - | Pclaim st -> - str "claim" ++ spc () ++ pr_statement pr_constr st - | Pfocus st -> - str "focus on" ++ spc () ++ pr_statement pr_constr st - | Pconsider (id,hyps) -> - str "consider" ++ pr_vars pr_var pr_constr _I false false "consider" hyps - ++ spc () ++ str "from " ++ pr_constr id - | Pgiven hyps -> - str "given" ++ pr_vars pr_var pr_constr _I false false "given" hyps - | Ptake witl -> - str "take" ++ spc () ++ - prlist_with_sep pr_comma pr_constr witl - | Pdefine (id,args,body) -> - str "define" ++ spc () ++ pr_id id ++ spc () ++ - prlist_with_sep spc - (fun st -> str "(" ++ - pr_var st ++ str ")") args ++ spc () ++ - str "as" ++ (pr_constr body) - | Pcast (id,typ) -> - str "reconsider" ++ spc () ++ - pr_or_thesis pr_id id ++ spc () ++ - str "as" ++ spc () ++ (pr_constr typ) - | Psuppose hyps -> - str "suppose" ++ - pr_hyps pr_var pr_constr _I false false "we have" hyps - | Pcase (params,pat,hyps) -> - str "suppose it is" ++ spc () ++ pr_pat pat ++ - (if params = [] then mt () else - (spc () ++ str "with" ++ spc () ++ - prlist_with_sep spc - (fun st -> str "(" ++ - pr_var st ++ str ")") params ++ spc ())) - ++ - (if hyps = [] then mt () else - (spc () ++ str "and" ++ - pr_hyps pr_var (pr_or_thesis pr_constr) type_or_thesis - false false "we have" hyps)) - | Pper (et,c) -> - str "per" ++ spc () ++ pr_elim_type et ++ spc () ++ - pr_casee pr_constr pr_tac c - | Pend blk -> str "end" ++ spc () ++ pr_block_type blk - -let pr_emph = function - 0 -> str " " - | 1 -> str "* " - | 2 -> str "** " - | 3 -> str "*** " - | _ -> anomaly (Pp.str "unknown emphasis") - -let pr_gen_proof_instr pr_var pr_constr pr_pat pr_tac instr = - pr_emph instr.emph ++ spc () ++ - pr_bare_proof_instr pr_var pr_constr pr_pat pr_tac false false instr.instr - - -let pr_raw_proof_instr pconstr1 pconstr2 ptac (instr : raw_proof_instr) = - pr_gen_proof_instr - (fun (_,(id,otyp)) -> - match otyp with - None -> pr_id id - | Some typ -> str "(" ++ pr_id id ++ str ":" ++ pconstr1 typ ++str ")" - ) - pconstr2 - Ppconstr.pr_cases_pattern_expr - (ptac Pptactic.ltop) - instr - -let pr_glob_proof_instr pconstr1 pconstr2 ptac (instr : glob_proof_instr) = - pr_gen_proof_instr - (fun (_,(id,otyp)) -> - match otyp with - None -> pr_id id - | Some typ -> str "(" ++ pr_id id ++ str ":" ++ pconstr1 typ ++str ")") - pconstr2 - Ppconstr.pr_cases_pattern_expr - (ptac Pptactic.ltop) - instr - -let pr_proof_instr pconstr1 pconstr2 ptac (instr : proof_instr) = - pr_gen_proof_instr - (fun st -> pr_statement pconstr1 st) - pconstr2 - (fun mpat -> Ppconstr.pr_cases_pattern_expr mpat.pat_expr) - (ptac Pptactic.ltop) - instr - diff --git a/plugins/decl_mode/ppdecl_proof.mli b/plugins/decl_mode/ppdecl_proof.mli deleted file mode 100644 index 678fc0768..000000000 --- a/plugins/decl_mode/ppdecl_proof.mli +++ /dev/null @@ -1,14 +0,0 @@ - -open Decl_expr -open Pptactic - -val pr_gen_proof_instr : - ('var -> Pp.std_ppcmds) -> - ('constr -> Pp.std_ppcmds) -> - ('pat -> Pp.std_ppcmds) -> - ('tac -> Pp.std_ppcmds) -> - ('var,'constr,'pat,'tac) gen_proof_instr -> Pp.std_ppcmds - -val pr_raw_proof_instr : raw_proof_instr raw_extra_genarg_printer -val pr_glob_proof_instr : glob_proof_instr glob_extra_genarg_printer -val pr_proof_instr : proof_instr extra_genarg_printer diff --git a/plugins/derive/derive.ml b/plugins/derive/derive.ml index e39d17b52..12d7f0660 100644 --- a/plugins/derive/derive.ml +++ b/plugins/derive/derive.ml @@ -28,12 +28,14 @@ let start_deriving f suchthat lemma = (* spiwack: I don't know what the rigidity flag does, picked the one that looked the most general. *) let (sigma,f_type_sort) = Evd.new_sort_variable Evd.univ_flexible_alg sigma in - let f_type_type = Term.mkSort f_type_sort in + let f_type_type = EConstr.mkSort f_type_sort in (** create the initial goals for the proof: |- Type ; |- ?1 ; f:=?2 |- suchthat *) let goals = let open Proofview in TCons ( env , sigma , f_type_type , (fun sigma f_type -> TCons ( env , sigma , f_type , (fun sigma ef -> + let f_type = EConstr.Unsafe.to_constr f_type in + let ef = EConstr.Unsafe.to_constr ef in let env' = Environ.push_named (LocalDef (f, ef, f_type)) env in let evdref = ref sigma in let suchthat = Constrintern.interp_type_evars env' evdref suchthat in diff --git a/plugins/extraction/common.ml b/plugins/extraction/common.ml index 9446cf667..fc8d5356c 100644 --- a/plugins/extraction/common.ml +++ b/plugins/extraction/common.ml @@ -67,7 +67,9 @@ let pp_boxed_tuple f = function blocks is less that a line length. To avoid this awkward situation, we attach a big virtual size to [fnl] newlines. *) -let fnl () = stras (1000000,"") ++ fnl () +(* EG: This looks quite suspicious... but beware of bugs *) +(* let fnl () = stras (1000000,"") ++ fnl () *) +let fnl () = fnl () let fnl2 () = fnl () ++ fnl () @@ -91,10 +93,7 @@ let begins_with_CoqXX s = let unquote s = if lang () != Scheme then s - else - let s = String.copy s in - for i=0 to String.length s - 1 do if s.[i] == '\'' then s.[i] <- '~' done; - s + else String.map (fun c -> if c == '\'' then '~' else c) s let rec qualify delim = function | [] -> assert false @@ -308,15 +307,16 @@ end module DupMap = Map.Make(DupOrd) -let add_duplicate, check_duplicate = +let add_duplicate, get_duplicate = let index = ref 0 and dups = ref DupMap.empty in register_cleanup (fun () -> index := 0; dups := DupMap.empty); let add mp l = incr index; let ren = "Coq__" ^ string_of_int !index in dups := DupMap.add (mp,l) ren !dups - and check mp l = DupMap.find (mp, l) !dups - in (add,check) + and get mp l = + try Some (DupMap.find (mp, l) !dups) with Not_found -> None + in (add,get) type reset_kind = AllButExternal | Everything @@ -510,10 +510,11 @@ let pp_duplicate k' prefix mp rls olab = (* Here rls=s::rls', we search the label for s inside mp *) List.tl rls, get_nth_label_mp (mp_length mp - mp_length prefix) mp in - try dottify (check_duplicate prefix lbl :: rls') - with Not_found -> - assert (get_phase () == Pre); (* otherwise it's too late *) - add_duplicate prefix lbl; dottify rls + match get_duplicate prefix lbl with + | Some ren -> dottify (ren :: rls') + | None -> + assert (get_phase () == Pre); (* otherwise it's too late *) + add_duplicate prefix lbl; dottify rls let fstlev_ks k = function | [] -> assert false diff --git a/plugins/extraction/common.mli b/plugins/extraction/common.mli index 2f5601964..b8e95afb3 100644 --- a/plugins/extraction/common.mli +++ b/plugins/extraction/common.mli @@ -62,7 +62,7 @@ val top_visible_mp : unit -> module_path val push_visible : module_path -> module_path list -> unit val pop_visible : unit -> unit -val check_duplicate : module_path -> Label.t -> string +val get_duplicate : module_path -> Label.t -> string option type reset_kind = AllButExternal | Everything diff --git a/plugins/extraction/extract_env.ml b/plugins/extraction/extract_env.ml index 52f22ee60..2b12462ad 100644 --- a/plugins/extraction/extract_env.ml +++ b/plugins/extraction/extract_env.ml @@ -472,13 +472,14 @@ let formatter dry file = if dry then Format.make_formatter (fun _ _ _ -> ()) (fun _ -> ()) else match file with - | Some f -> Pp_control.with_output_to f + | Some f -> Topfmt.with_output_to f | None -> Format.formatter_of_buffer buf in + (* XXX: Fixme, this shouldn't depend on Topfmt *) (* We never want to see ellipsis ... in extracted code *) Format.pp_set_max_boxes ft max_int; (* We reuse the width information given via "Set Printing Width" *) - (match Pp_control.get_margin () with + (match Topfmt.get_margin () with | None -> () | Some i -> Format.pp_set_margin ft i; @@ -507,8 +508,7 @@ let print_structure_to_file (fn,si,mo) dry struc = in (* First, a dry run, for computing objects to rename or duplicate *) set_phase Pre; - let devnull = formatter true None in - pp_with devnull (d.pp_struct struc); + ignore (d.pp_struct struc); let opened = opened_libraries () in (* Print the implementation *) let cout = if dry then None else Option.map open_out fn in @@ -519,8 +519,10 @@ let print_structure_to_file (fn,si,mo) dry struc = set_phase Impl; pp_with ft (d.preamble mo comment opened unsafe_needs); pp_with ft (d.pp_struct struc); + Format.pp_print_flush ft (); Option.iter close_out cout; with reraise -> + Format.pp_print_flush ft (); Option.iter close_out cout; raise reraise end; if not dry then Option.iter info_file fn; @@ -533,8 +535,10 @@ let print_structure_to_file (fn,si,mo) dry struc = set_phase Intf; pp_with ft (d.sig_preamble mo comment opened unsafe_needs); pp_with ft (d.pp_sig (signature_of_structure struc)); + Format.pp_print_flush ft (); close_out cout; with reraise -> + Format.pp_print_flush ft (); close_out cout; raise reraise end; info_file si) diff --git a/plugins/extraction/extraction.ml b/plugins/extraction/extraction.ml index a980a43f5..92ece7ccf 100644 --- a/plugins/extraction/extraction.ml +++ b/plugins/extraction/extraction.ml @@ -42,11 +42,11 @@ let none = Evd.empty let type_of env c = let polyprop = (lang() == Haskell) in - Retyping.get_type_of ~polyprop env none (strip_outer_cast c) + EConstr.Unsafe.to_constr (Retyping.get_type_of ~polyprop env none (strip_outer_cast none (EConstr.of_constr c))) let sort_of env c = let polyprop = (lang() == Haskell) in - Retyping.get_sort_family_of ~polyprop env none (strip_outer_cast c) + Retyping.get_sort_family_of ~polyprop env none (strip_outer_cast none (EConstr.of_constr c)) (*S Generation of flags and signatures. *) @@ -70,11 +70,17 @@ type scheme = TypeScheme | Default type flag = info * scheme +let whd_all env t = + EConstr.Unsafe.to_constr (whd_all env none (EConstr.of_constr t)) + +let whd_betaiotazeta t = + EConstr.Unsafe.to_constr (whd_betaiotazeta none (EConstr.of_constr t)) + (*s [flag_of_type] transforms a type [t] into a [flag]. Really important function. *) let rec flag_of_type env t : flag = - let t = whd_all env none t in + let t = whd_all env t in match kind_of_term t with | Prod (x,t,c) -> flag_of_type (push_rel (LocalAssum (x,t)) env) c | Sort s when Sorts.is_prop s -> (Logic,TypeScheme) @@ -99,17 +105,20 @@ let is_info_scheme env t = match flag_of_type env t with | (Info, TypeScheme) -> true | _ -> false +let push_rel_assum (n, t) env = + Environ.push_rel (LocalAssum (n, t)) env + (*s [type_sign] gernerates a signature aimed at treating a type application. *) let rec type_sign env c = - match kind_of_term (whd_all env none c) with + match kind_of_term (whd_all env c) with | Prod (n,t,d) -> (if is_info_scheme env t then Keep else Kill Kprop) :: (type_sign (push_rel_assum (n,t) env) d) | _ -> [] let rec type_scheme_nb_args env c = - match kind_of_term (whd_all env none c) with + match kind_of_term (whd_all env c) with | Prod (n,t,d) -> let n = type_scheme_nb_args (push_rel_assum (n,t) env) d in if is_info_scheme env t then n+1 else n @@ -135,7 +144,7 @@ let make_typvar n vl = next_ident_away id' vl let rec type_sign_vl env c = - match kind_of_term (whd_all env none c) with + match kind_of_term (whd_all env c) with | Prod (n,t,d) -> let s,vl = type_sign_vl (push_rel_assum (n,t) env) d in if not (is_info_scheme env t) then Kill Kprop::s, vl @@ -143,7 +152,7 @@ let rec type_sign_vl env c = | _ -> [],[] let rec nb_default_params env c = - match kind_of_term (whd_all env none c) with + match kind_of_term (whd_all env c) with | Prod (n,t,d) -> let n = nb_default_params (push_rel_assum (n,t) env) d in if is_default env t then n+1 else n @@ -214,7 +223,7 @@ let parse_ind_args si args relmax = let rec extract_type env db j c args = - match kind_of_term (whd_betaiotazeta Evd.empty c) with + match kind_of_term (whd_betaiotazeta c) with | App (d, args') -> (* We just accumulate the arguments. *) extract_type env db j d (Array.to_list args' @ args) @@ -258,7 +267,7 @@ let rec extract_type env db j c args = | Const (kn,u as c) -> let r = ConstRef kn in let cb = lookup_constant kn env in - let typ,_ = Typeops.type_of_constant env c in + let typ = Typeops.type_of_constant_in env c in (match flag_of_type env typ with | (Logic,_) -> assert false (* Cf. logical cases above *) | (Info, TypeScheme) -> @@ -297,7 +306,7 @@ and extract_type_app env db (r,s) args = let ml_args = List.fold_right (fun (b,c) a -> if b == Keep then - let p = List.length (fst (splay_prod env none (type_of env c))) in + let p = List.length (fst (splay_prod env none (EConstr.of_constr (type_of env c)))) in let db = iterate (fun l -> 0 :: l) p db in (extract_type_scheme env db c p) :: a else a) @@ -316,12 +325,13 @@ and extract_type_app env db (r,s) args = and extract_type_scheme env db c p = if Int.equal p 0 then extract_type env db 0 c [] else - let c = whd_betaiotazeta Evd.empty c in + let c = whd_betaiotazeta c in match kind_of_term c with | Lambda (n,t,d) -> extract_type_scheme (push_rel_assum (n,t) env) db d (p-1) | _ -> - let rels = fst (splay_prod env none (type_of env c)) in + let rels = fst (splay_prod env none (EConstr.of_constr (type_of env c))) in + let rels = List.map (on_snd EConstr.Unsafe.to_constr) rels in let env = push_rels_assum rels env in let eta_args = List.rev_map mkRel (List.interval 1 p) in extract_type env db 0 (lift p c) eta_args @@ -488,7 +498,7 @@ and extract_really_ind env kn mib = *) and extract_type_cons env db dbmap c i = - match kind_of_term (whd_all env none c) with + match kind_of_term (whd_all env c) with | Prod (n,t,d) -> let env' = push_rel_assum (n,t) env in let db' = (try Int.Map.find i dbmap with Not_found -> 0) :: db in @@ -595,7 +605,8 @@ let rec extract_term env mle mlt c args = | Construct (cp,_) -> extract_cons_app env mle mlt cp args | Proj (p, c) -> - let term = Retyping.expand_projection env (Evd.from_env env) p c [] in + let term = Retyping.expand_projection env (Evd.from_env env) p (EConstr.of_constr c) [] in + let term = EConstr.Unsafe.to_constr term in extract_term env mle mlt term args | Rel n -> (* As soon as the expected [mlt] for the head is known, *) @@ -846,8 +857,8 @@ and extract_fix env mle i (fi,ti,ci as recd) mlt = and decompose the term [c] in [n] lambdas, with eta-expansion if needed. *) let decomp_lams_eta_n n m env c t = - let rels = fst (splay_prod_n env none n t) in - let rels = List.map (fun (LocalAssum (id,c) | LocalDef (id,_,c)) -> (id,c)) rels in + let rels = fst (splay_prod_n env none n (EConstr.of_constr t)) in + let rels = List.map (fun (LocalAssum (id,c) | LocalDef (id,_,c)) -> (id,EConstr.Unsafe.to_constr c)) rels in let rels',c = decompose_lam c in let d = n - m in (* we'd better keep rels' as long as possible. *) @@ -887,7 +898,7 @@ let extract_std_constant env kn body typ = break user's clever let-ins and partial applications). *) let rels, c = let n = List.length s - and m = nb_lam body in + and m = nb_lam Evd.empty (EConstr.of_constr body) (** FIXME *) in if n <= m then decompose_lam_n n body else let s,s' = List.chop m s in diff --git a/plugins/extraction/g_extraction.ml4 b/plugins/extraction/g_extraction.ml4 index e1d6bb4a8..3ed959cf2 100644 --- a/plugins/extraction/g_extraction.ml4 +++ b/plugins/extraction/g_extraction.ml4 @@ -12,6 +12,7 @@ DECLARE PLUGIN "extraction_plugin" (* ML names *) +open Ltac_plugin open Genarg open Stdarg open Pcoq.Prim diff --git a/plugins/extraction/ocaml.ml b/plugins/extraction/ocaml.ml index 1c29a9bc2..d8e382155 100644 --- a/plugins/extraction/ocaml.ml +++ b/plugins/extraction/ocaml.ml @@ -66,7 +66,7 @@ let pp_header_comment = function | None -> mt () | Some com -> pp_comment com ++ fnl2 () -let then_nl pp = if Pp.is_empty pp then mt () else pp ++ fnl () +let then_nl pp = if Pp.ismt pp then mt () else pp ++ fnl () let pp_tdummy usf = if usf.tdummy || usf.tunknown then str "type __ = Obj.t" ++ fnl () else mt () @@ -555,24 +555,6 @@ let pp_decl = function | Dfix (rv,defs,typs) -> pp_Dfix (rv,defs,typs) -let pp_alias_decl ren = function - | Dind (kn,i) -> pp_mind kn { i with ind_equiv = RenEquiv ren } - | Dtype (r, l, _) -> - let name = pp_global Type r in - let l = rename_tvars keywords l in - let ids = pp_parameters l in - hov 2 (str "type " ++ ids ++ name ++ str " =" ++ spc () ++ ids ++ - str (ren^".") ++ name) - | Dterm (r, a, t) -> - let name = pp_global Term r in - hov 2 (str "let " ++ name ++ str (" = "^ren^".") ++ name) - | Dfix (rv, _, _) -> - prvecti (fun i r -> if is_inline_custom r then mt () else - let name = pp_global Term r in - hov 2 (str "let " ++ name ++ str (" = "^ren^".") ++ name) ++ - fnl ()) - rv - let pp_spec = function | Sval (r,_) when is_inline_custom r -> mt () | Stype (r,_,_) when is_inline_custom r -> mt () @@ -597,42 +579,32 @@ let pp_spec = function in hov 2 (str "type " ++ ids ++ name ++ def) -let pp_alias_spec ren = function - | Sind (kn,i) -> pp_mind kn { i with ind_equiv = RenEquiv ren } - | Stype (r,l,_) -> - let name = pp_global Type r in - let l = rename_tvars keywords l in - let ids = pp_parameters l in - hov 2 (str "type " ++ ids ++ name ++ str " =" ++ spc () ++ ids ++ - str (ren^".") ++ name) - | Sval _ -> assert false - let rec pp_specif = function | (_,Spec (Sval _ as s)) -> pp_spec s | (l,Spec s) -> - (try - let ren = Common.check_duplicate (top_visible_mp ()) l in + (match Common.get_duplicate (top_visible_mp ()) l with + | None -> pp_spec s + | Some ren -> hov 1 (str ("module "^ren^" : sig") ++ fnl () ++ pp_spec s) ++ fnl () ++ str "end" ++ fnl () ++ - pp_alias_spec ren s - with Not_found -> pp_spec s) + str ("include module type of struct include "^ren^" end")) | (l,Smodule mt) -> let def = pp_module_type [] mt in - let def' = pp_module_type [] mt in let name = pp_modname (MPdot (top_visible_mp (), l)) in hov 1 (str "module " ++ name ++ str " :" ++ fnl () ++ def) ++ - (try - let ren = Common.check_duplicate (top_visible_mp ()) l in - fnl () ++ hov 1 (str ("module "^ren^" :") ++ fnl () ++ def') - with Not_found -> Pp.mt ()) + (match Common.get_duplicate (top_visible_mp ()) l with + | None -> Pp.mt () + | Some ren -> + fnl () ++ + hov 1 (str ("module "^ren^" :") ++ spc () ++ + str "module type of struct include " ++ name ++ str " end")) | (l,Smodtype mt) -> let def = pp_module_type [] mt in let name = pp_modname (MPdot (top_visible_mp (), l)) in hov 1 (str "module type " ++ name ++ str " =" ++ fnl () ++ def) ++ - (try - let ren = Common.check_duplicate (top_visible_mp ()) l in - fnl () ++ str ("module type "^ren^" = ") ++ name - with Not_found -> Pp.mt ()) + (match Common.get_duplicate (top_visible_mp ()) l with + | None -> Pp.mt () + | Some ren -> fnl () ++ str ("module type "^ren^" = ") ++ name) and pp_module_type params = function | MTident kn -> @@ -646,15 +618,17 @@ and pp_module_type params = function push_visible mp params; let try_pp_specif l x = let px = pp_specif x in - if Pp.is_empty px then l else px::l + if Pp.ismt px then l else px::l in (* We cannot use fold_right here due to side effects in pp_specif *) let l = List.fold_left try_pp_specif [] sign in let l = List.rev l in pop_visible (); str "sig" ++ fnl () ++ - v 1 (str " " ++ prlist_with_sep cut2 identity l) ++ - fnl () ++ str "end" + (if List.is_empty l then mt () + else + v 1 (str " " ++ prlist_with_sep cut2 identity l) ++ fnl ()) + ++ str "end" | MTwith(mt,ML_With_type(idl,vl,typ)) -> let ids = pp_parameters (rename_tvars keywords vl) in let mp_mt = msid_of_mt mt in @@ -681,12 +655,11 @@ let is_short = function MEident _ | MEapply _ -> true | _ -> false let rec pp_structure_elem = function | (l,SEdecl d) -> - (try - let ren = Common.check_duplicate (top_visible_mp ()) l in + (match Common.get_duplicate (top_visible_mp ()) l with + | None -> pp_decl d + | Some ren -> hov 1 (str ("module "^ren^" = struct") ++ fnl () ++ pp_decl d) ++ - fnl () ++ str "end" ++ fnl () ++ - pp_alias_decl ren d - with Not_found -> pp_decl d) + fnl () ++ str "end" ++ fnl () ++ str ("include "^ren)) | (l,SEmodule m) -> let typ = (* virtual printing of the type, in order to have a correct mli later*) @@ -699,18 +672,16 @@ let rec pp_structure_elem = function hov 1 (str "module " ++ name ++ typ ++ str " =" ++ (if is_short m.ml_mod_expr then spc () else fnl ()) ++ def) ++ - (try - let ren = Common.check_duplicate (top_visible_mp ()) l in - fnl () ++ str ("module "^ren^" = ") ++ name - with Not_found -> mt ()) + (match Common.get_duplicate (top_visible_mp ()) l with + | Some ren -> fnl () ++ str ("module "^ren^" = ") ++ name + | None -> mt ()) | (l,SEmodtype m) -> let def = pp_module_type [] m in let name = pp_modname (MPdot (top_visible_mp (), l)) in hov 1 (str "module type " ++ name ++ str " =" ++ fnl () ++ def) ++ - (try - let ren = Common.check_duplicate (top_visible_mp ()) l in - fnl () ++ str ("module type "^ren^" = ") ++ name - with Not_found -> mt ()) + (match Common.get_duplicate (top_visible_mp ()) l with + | None -> mt () + | Some ren -> fnl () ++ str ("module type "^ren^" = ") ++ name) and pp_module_expr params = function | MEident mp -> pp_modname mp @@ -725,15 +696,17 @@ and pp_module_expr params = function push_visible mp params; let try_pp_structure_elem l x = let px = pp_structure_elem x in - if Pp.is_empty px then l else px::l + if Pp.ismt px then l else px::l in (* We cannot use fold_right here due to side effects in pp_structure_elem *) let l = List.fold_left try_pp_structure_elem [] sel in let l = List.rev l in pop_visible (); str "struct" ++ fnl () ++ - v 1 (str " " ++ prlist_with_sep cut2 identity l) ++ - fnl () ++ str "end" + (if List.is_empty l then mt () + else + v 1 (str " " ++ prlist_with_sep cut2 identity l) ++ fnl ()) + ++ str "end" let rec prlist_sep_nonempty sep f = function | [] -> mt () @@ -741,7 +714,7 @@ let rec prlist_sep_nonempty sep f = function | h::t -> let e = f h in let r = prlist_sep_nonempty sep f t in - if Pp.is_empty e then r + if Pp.ismt e then r else e ++ sep () ++ r let do_struct f s = diff --git a/plugins/extraction/scheme.ml b/plugins/extraction/scheme.ml index a6309e61f..8d0cc4a0d 100644 --- a/plugins/extraction/scheme.ml +++ b/plugins/extraction/scheme.ml @@ -40,11 +40,7 @@ let preamble _ comment _ usf = (if usf.mldummy then str "(define __ (lambda (_) __))\n\n" else mt ()) let pr_id id = - let s = Id.to_string id in - for i = 0 to String.length s - 1 do - if s.[i] == '\'' then s.[i] <- '~' - done; - str s + str @@ String.map (fun c -> if c == '\'' then '~' else c) (Id.to_string id) let paren = pp_par true diff --git a/plugins/extraction/table.ml b/plugins/extraction/table.ml index 5e7d810c9..d6a334c5f 100644 --- a/plugins/extraction/table.ml +++ b/plugins/extraction/table.ml @@ -773,9 +773,7 @@ let file_of_modfile mp = | MPfile f -> Id.to_string (List.hd (DirPath.repr f)) | _ -> assert false in - let s = String.copy (string_of_modfile mp) in - if s.[0] != s0.[0] then s.[0] <- s0.[0]; - s + String.mapi (fun i c -> if i = 0 then s0.[0] else c) (string_of_modfile mp) let add_blacklist_entries l = blacklist_table := diff --git a/plugins/firstorder/formula.ml b/plugins/firstorder/formula.ml index b34a36492..ade94e98e 100644 --- a/plugins/firstorder/formula.ml +++ b/plugins/firstorder/formula.ml @@ -9,6 +9,7 @@ open Hipattern open Names open Term +open EConstr open Vars open Termops open Tacmach @@ -44,28 +45,27 @@ let rec nb_prod_after n c= 1+(nb_prod_after 0 b) | _ -> 0 -let construct_nhyps ind gls = +let construct_nhyps env ind = let nparams = (fst (Global.lookup_inductive (fst ind))).mind_nparams in - let constr_types = Inductiveops.arities_of_constructors (pf_env gls) ind in + let constr_types = Inductiveops.arities_of_constructors env ind in let hyp = nb_prod_after nparams in Array.map hyp constr_types (* indhyps builds the array of arrays of constructor hyps for (ind largs)*) -let ind_hyps nevar ind largs gls= - let types= Inductiveops.arities_of_constructors (pf_env gls) ind in +let ind_hyps env sigma nevar ind largs = + let types= Inductiveops.arities_of_constructors env ind in let myhyps t = - let t1=prod_applist t largs in - let t2=snd (decompose_prod_n_assum nevar t1) in - fst (decompose_prod_assum t2) in + let t = EConstr.of_constr t in + let t1=Termops.prod_applist sigma t largs in + let t2=snd (decompose_prod_n_assum sigma nevar t1) in + fst (decompose_prod_assum sigma t2) in Array.map myhyps types -let special_nf gl= - let infos=CClosure.create_clos_infos !red_flags (pf_env gl) in - (fun t -> CClosure.norm_val infos (CClosure.inject t)) +let special_nf env sigma t = + Reductionops.clos_norm_flags !red_flags env sigma t -let special_whd gl= - let infos=CClosure.create_clos_infos !red_flags (pf_env gl) in - (fun t -> CClosure.whd_val infos (CClosure.inject t)) +let special_whd env sigma t = + Reductionops.clos_whd_flags !red_flags env sigma t type kind_of_formula= Arrow of constr*constr @@ -76,18 +76,21 @@ type kind_of_formula= | Forall of constr*constr | Atom of constr -let kind_of_formula gl term = - let normalize=special_nf gl in - let cciterm=special_whd gl term in - match match_with_imp_term cciterm with - Some (a,b)-> Arrow(a,(pop b)) +let pop t = Vars.lift (-1) t + +let kind_of_formula env sigma term = + let normalize = special_nf env sigma in + let cciterm = special_whd env sigma term in + match match_with_imp_term sigma cciterm with + Some (a,b)-> Arrow (a, pop b) |_-> - match match_with_forall_term cciterm with - Some (_,a,b)-> Forall(a,b) + match match_with_forall_term sigma cciterm with + Some (_,a,b)-> Forall (a, b) |_-> - match match_with_nodep_ind cciterm with + match match_with_nodep_ind sigma cciterm with Some (i,l,n)-> - let ind,u=destInd i in + let ind,u=EConstr.destInd sigma i in + let u = EConstr.EInstance.kind sigma u in let (mib,mip) = Global.lookup_inductive ind in let nconstr=Array.length mip.mind_consnames in if Int.equal nconstr 0 then @@ -96,7 +99,7 @@ let kind_of_formula gl term = let has_realargs=(n>0) in let is_trivial= let is_constant c = - Int.equal (nb_prod c) mib.mind_nparams in + Int.equal (nb_prod sigma (EConstr.of_constr c)) mib.mind_nparams in Array.exists is_constant mip.mind_nf_lc in if Inductiveops.mis_is_recursive (ind,mib,mip) || (has_realargs && not is_trivial) @@ -108,8 +111,11 @@ let kind_of_formula gl term = else Or((ind,u),l,is_trivial) | _ -> - match match_with_sigma_type cciterm with - Some (i,l)-> Exists((destInd i),l) + match match_with_sigma_type sigma cciterm with + Some (i,l)-> + let (ind, u) = EConstr.destInd sigma i in + let u = EConstr.EInstance.kind sigma u in + Exists((ind, u), l) |_-> Atom (normalize cciterm) type atoms = {positive:constr list;negative:constr list} @@ -120,29 +126,29 @@ let no_atoms = (false,{positive=[];negative=[]}) let dummy_id=VarRef (Id.of_string "_") (* "_" cannot be parsed *) -let build_atoms gl metagen side cciterm = +let build_atoms env sigma metagen side cciterm = let trivial =ref false and positive=ref [] and negative=ref [] in - let normalize=special_nf gl in - let rec build_rec env polarity cciterm= - match kind_of_formula gl cciterm with + let normalize=special_nf env sigma in + let rec build_rec subst polarity cciterm= + match kind_of_formula env sigma cciterm with False(_,_)->if not polarity then trivial:=true | Arrow (a,b)-> - build_rec env (not polarity) a; - build_rec env polarity b + build_rec subst (not polarity) a; + build_rec subst polarity b | And(i,l,b) | Or(i,l,b)-> if b then begin - let unsigned=normalize (substnl env 0 cciterm) in + let unsigned=normalize (substnl subst 0 cciterm) in if polarity then positive:= unsigned :: !positive else negative:= unsigned :: !negative end; - let v = ind_hyps 0 i l gl in + let v = ind_hyps env sigma 0 i l in let g i _ decl = - build_rec env polarity (lift i (RelDecl.get_type decl)) in + build_rec subst polarity (lift i (RelDecl.get_type decl)) in let f l = List.fold_left_i g (1-(List.length l)) () l in if polarity && (* we have a constant constructor *) @@ -151,16 +157,16 @@ let build_atoms gl metagen side cciterm = Array.iter f v | Exists(i,l)-> let var=mkMeta (metagen true) in - let v =(ind_hyps 1 i l gl).(0) in + let v =(ind_hyps env sigma 1 i l).(0) in let g i _ decl = - build_rec (var::env) polarity (lift i (RelDecl.get_type decl)) in + build_rec (var::subst) polarity (lift i (RelDecl.get_type decl)) in List.fold_left_i g (2-(List.length l)) () v | Forall(_,b)-> let var=mkMeta (metagen true) in - build_rec (var::env) polarity b + build_rec (var::subst) polarity b | Atom t-> - let unsigned=substnl env 0 t in - if not (isMeta unsigned) then (* discarding wildcard atoms *) + let unsigned=substnl subst 0 t in + if not (isMeta sigma unsigned) then (* discarding wildcard atoms *) if polarity then positive:= unsigned :: !positive else @@ -170,9 +176,9 @@ let build_atoms gl metagen side cciterm = Concl -> build_rec [] true cciterm | Hyp -> build_rec [] false cciterm | Hint -> - let rels,head=decompose_prod cciterm in - let env=List.rev_map (fun _->mkMeta (metagen true)) rels in - build_rec env false head;trivial:=false (* special for hints *) + let rels,head=decompose_prod sigma cciterm in + let subst=List.rev_map (fun _->mkMeta (metagen true)) rels in + build_rec subst false head;trivial:=false (* special for hints *) end; (!trivial, {positive= !positive; @@ -208,32 +214,32 @@ type t={id:global_reference; pat:(left_pattern,right_pattern) sum; atoms:atoms} -let build_formula side nam typ gl metagen= - let normalize = special_nf gl in +let build_formula env sigma side nam typ metagen= + let normalize = special_nf env sigma in try let m=meta_succ(metagen false) in let trivial,atoms= if !qflag then - build_atoms gl metagen side typ + build_atoms env sigma metagen side typ else no_atoms in let pattern= match side with Concl -> let pat= - match kind_of_formula gl typ with + match kind_of_formula env sigma typ with False(_,_) -> Rfalse | Atom a -> raise (Is_atom a) | And(_,_,_) -> Rand | Or(_,_,_) -> Ror | Exists (i,l) -> - let d = RelDecl.get_type (List.last (ind_hyps 0 i l gl).(0)) in + let d = RelDecl.get_type (List.last (ind_hyps env sigma 0 i l).(0)) in Rexists(m,d,trivial) | Forall (_,a) -> Rforall | Arrow (a,b) -> Rarrow in Right pat | _ -> let pat= - match kind_of_formula gl typ with + match kind_of_formula env sigma typ with False(i,_) -> Lfalse | Atom a -> raise (Is_atom a) | And(i,_,b) -> @@ -250,7 +256,7 @@ let build_formula side nam typ gl metagen= | Arrow (a,b) -> let nfa=normalize a in LA (nfa, - match kind_of_formula gl a with + match kind_of_formula env sigma a with False(i,l)-> LLfalse(i,l) | Atom t-> LLatom | And(i,l,_)-> LLand(i,l) diff --git a/plugins/firstorder/formula.mli b/plugins/firstorder/formula.mli index 5db8ff59a..3f438c04a 100644 --- a/plugins/firstorder/formula.mli +++ b/plugins/firstorder/formula.mli @@ -7,6 +7,7 @@ (************************************************************************) open Term +open EConstr open Globnames val qflag : bool ref @@ -23,10 +24,10 @@ type ('a,'b) sum = Left of 'a | Right of 'b type counter = bool -> metavariable -val construct_nhyps : pinductive -> Proof_type.goal Tacmach.sigma -> int array +val construct_nhyps : Environ.env -> pinductive -> int array -val ind_hyps : int -> pinductive -> constr list -> - Proof_type.goal Tacmach.sigma -> Context.Rel.t array +val ind_hyps : Environ.env -> Evd.evar_map -> int -> pinductive -> + constr list -> EConstr.rel_context array type atoms = {positive:constr list;negative:constr list} @@ -34,7 +35,7 @@ type side = Hyp | Concl | Hint val dummy_id: global_reference -val build_atoms : Proof_type.goal Tacmach.sigma -> counter -> +val build_atoms : Environ.env -> Evd.evar_map -> counter -> side -> constr -> bool * atoms type right_pattern = @@ -69,6 +70,6 @@ type t={id: global_reference; (*exception Is_atom of constr*) -val build_formula : side -> global_reference -> types -> - Proof_type.goal Tacmach.sigma -> counter -> (t,types) sum +val build_formula : Environ.env -> Evd.evar_map -> side -> global_reference -> types -> + counter -> (t,types) sum diff --git a/plugins/firstorder/g_ground.ml4 b/plugins/firstorder/g_ground.ml4 index 260e86ad6..8ef6a09d0 100644 --- a/plugins/firstorder/g_ground.ml4 +++ b/plugins/firstorder/g_ground.ml4 @@ -8,11 +8,14 @@ (*i camlp4deps: "grammar/grammar.cma" i*) +open Ltac_plugin open Formula open Sequent open Ground open Goptions -open Tacticals +open Tacmach.New +open Tacticals.New +open Proofview.Notations open Tacinterp open Libnames open Stdarg @@ -80,21 +83,29 @@ END let fail_solver=tclFAIL 0 (Pp.str "GTauto failed") -let gen_ground_tac flag taco ids bases gl= +let gen_ground_tac flag taco ids bases = let backup= !qflag in - try + Proofview.tclOR begin + Proofview.Goal.enter { enter = begin fun gl -> qflag:=flag; let solver= match taco with Some tac-> tac | None-> snd (default_solver ()) in - let startseq gl= + let startseq k = + Proofview.Goal.s_enter { s_enter = begin fun gl -> let seq=empty_seq !ground_depth in - let seq,gl = extend_with_ref_list ids seq gl in - extend_with_auto_hints bases seq gl in - let result=ground_tac (Proofview.V82.of_tactic solver) startseq gl in - qflag:=backup;result - with reraise -> qflag:=backup;raise reraise + let seq, sigma = extend_with_ref_list (pf_env gl) (project gl) ids seq in + let seq, sigma = extend_with_auto_hints (pf_env gl) (project gl) bases seq in + Sigma.Unsafe.of_pair (k seq, sigma) + end } + in + let result=ground_tac solver startseq in + qflag := backup; + result + end } + end + (fun (e, info) -> qflag := backup; Proofview.tclZERO ~info e) (* special for compatibility with Intuition @@ -143,36 +154,15 @@ END TACTIC EXTEND firstorder [ "firstorder" tactic_opt(t) firstorder_using(l) ] -> - [ Proofview.V82.tactic (gen_ground_tac true (Option.map (tactic_of_value ist) t) l []) ] + [ gen_ground_tac true (Option.map (tactic_of_value ist) t) l [] ] | [ "firstorder" tactic_opt(t) "with" ne_preident_list(l) ] -> - [ Proofview.V82.tactic (gen_ground_tac true (Option.map (tactic_of_value ist) t) [] l) ] + [ gen_ground_tac true (Option.map (tactic_of_value ist) t) [] l ] | [ "firstorder" tactic_opt(t) firstorder_using(l) "with" ne_preident_list(l') ] -> - [ Proofview.V82.tactic (gen_ground_tac true (Option.map (tactic_of_value ist) t) l l') ] + [ gen_ground_tac true (Option.map (tactic_of_value ist) t) l l' ] END TACTIC EXTEND gintuition [ "gintuition" tactic_opt(t) ] -> - [ Proofview.V82.tactic (gen_ground_tac false (Option.map (tactic_of_value ist) t) [] []) ] + [ gen_ground_tac false (Option.map (tactic_of_value ist) t) [] [] ] END - -open Proofview.Notations -open Cc_plugin -open Decl_mode_plugin - -let default_declarative_automation = - Proofview.tclUNIT () >>= fun () -> (* delay for [congruence_depth] *) - Tacticals.New.tclORELSE - (Tacticals.New.tclORELSE (Auto.h_trivial [] None) - (Cctac.congruence_tac !congruence_depth [])) - (Proofview.V82.tactic (gen_ground_tac true - (Some (Tacticals.New.tclTHEN - (snd (default_solver ())) - (Cctac.congruence_tac !congruence_depth []))) - [] [])) - - - -let () = - Decl_proof_instr.register_automation_tac default_declarative_automation - diff --git a/plugins/firstorder/ground.ml b/plugins/firstorder/ground.ml index 628af4e71..ab1dd07c1 100644 --- a/plugins/firstorder/ground.ml +++ b/plugins/firstorder/ground.ml @@ -6,13 +6,15 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Ltac_plugin open Formula open Sequent open Rules open Instances open Term -open Tacmach -open Tacticals +open Tacmach.New +open Tacticals.New +open Proofview.Notations let update_flags ()= let predref=ref Names.Cpred.empty in @@ -28,18 +30,24 @@ let update_flags ()= CClosure.betaiotazeta (Names.Id.Pred.full,Names.Cpred.complement !predref) -let ground_tac solver startseq gl= +let ground_tac solver startseq = + Proofview.Goal.enter { enter = begin fun gl -> update_flags (); - let rec toptac skipped seq gl= - if Tacinterp.get_debug()=Tactic_debug.DebugOn 0 - then Feedback.msg_debug (Printer.pr_goal gl); + let rec toptac skipped seq = + Proofview.Goal.enter { enter = begin fun gl -> + let () = + if Tacinterp.get_debug()=Tactic_debug.DebugOn 0 + then + let gl = { Evd.it = Proofview.Goal.goal (Proofview.Goal.assume gl); sigma = project gl } in + Feedback.msg_debug (Printer.pr_goal gl) + in tclORELSE (axiom_tac seq.gl seq) begin try - let (hd,seq1)=take_formula seq - and re_add s=re_add_formula_list skipped s in + let (hd,seq1)=take_formula (project gl) seq + and re_add s=re_add_formula_list (project gl) skipped s in let continue=toptac [] - and backtrack gl=toptac (hd::skipped) seq1 gl in + and backtrack =toptac (hd::skipped) seq1 in match hd.pat with Right rpat-> begin @@ -59,7 +67,7 @@ let ground_tac solver startseq gl= or_tac backtrack continue (re_add seq1) | Rfalse->backtrack | Rexists(i,dom,triv)-> - let (lfp,seq2)=collect_quantified seq in + let (lfp,seq2)=collect_quantified (project gl) seq in let backtrack2=toptac (lfp@skipped) seq2 in if !qflag && seq.depth>0 then quantified_tac lfp backtrack2 @@ -79,7 +87,7 @@ let ground_tac solver startseq gl= left_or_tac ind backtrack hd.id continue (re_add seq1) | Lforall (_,_,_)-> - let (lfp,seq2)=collect_quantified seq in + let (lfp,seq2)=collect_quantified (project gl) seq in let backtrack2=toptac (lfp@skipped) seq2 in if !qflag && seq.depth>0 then quantified_tac lfp backtrack2 @@ -118,7 +126,8 @@ let ground_tac solver startseq gl= ll_atom_tac typ la_tac hd.id continue (re_add seq1) end with Heap.EmptyHeap->solver - end gl in - let seq, gl' = startseq gl in - wrap (List.length (pf_hyps gl)) true (toptac []) seq gl' - + end + end } in + let n = List.length (Proofview.Goal.hyps gl) in + startseq (fun seq -> wrap n true (toptac []) seq) + end } diff --git a/plugins/firstorder/ground.mli b/plugins/firstorder/ground.mli index b5669463c..4fd1e38a2 100644 --- a/plugins/firstorder/ground.mli +++ b/plugins/firstorder/ground.mli @@ -6,6 +6,6 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -val ground_tac: Tacmach.tactic -> - (Proof_type.goal Tacmach.sigma -> Sequent.t * Proof_type.goal Tacmach.sigma) -> Tacmach.tactic +val ground_tac: unit Proofview.tactic -> + ((Sequent.t -> unit Proofview.tactic) -> unit Proofview.tactic) -> unit Proofview.tactic diff --git a/plugins/firstorder/instances.ml b/plugins/firstorder/instances.ml index eebd974ea..62f811546 100644 --- a/plugins/firstorder/instances.ml +++ b/plugins/firstorder/instances.ml @@ -11,10 +11,12 @@ open Rules open CErrors open Util open Term +open EConstr open Vars -open Tacmach +open Tacmach.New open Tactics -open Tacticals +open Tacticals.New +open Proofview.Notations open Termops open Reductionops open Formula @@ -25,11 +27,12 @@ open Sigma.Notations open Context.Rel.Declaration let compare_instance inst1 inst2= + let cmp c1 c2 = OrderedConstr.compare (EConstr.Unsafe.to_constr c1) (EConstr.Unsafe.to_constr c2) in match inst1,inst2 with Phantom(d1),Phantom(d2)-> - (OrderedConstr.compare d1 d2) + (cmp d1 d2) | Real((m1,c1),n1),Real((m2,c2),n2)-> - ((-) =? (-) ==? OrderedConstr.compare) m2 m1 n1 n2 c1 c2 + ((-) =? (-) ==? cmp) m2 m1 n1 n2 c1 c2 | Phantom(_),Real((m,_),_)-> if Int.equal m 0 then -1 else 1 | Real((m,_),_),Phantom(_)-> if Int.equal m 0 then 1 else -1 @@ -56,12 +59,12 @@ let make_simple_atoms seq= | None->[] in {negative=seq.latoms;positive=ratoms} -let do_sequent setref triv id seq i dom atoms= +let do_sequent sigma setref triv id seq i dom atoms= let flag=ref true in let phref=ref triv in let do_atoms a1 a2 = let do_pair t1 t2 = - match unif_atoms i dom t1 t2 with + match unif_atoms sigma i dom t1 t2 with None->() | Some (Phantom _) ->phref:=true | Some c ->flag:=false;setref:=IS.add (c,id) !setref in @@ -71,26 +74,26 @@ let do_sequent setref triv id seq i dom atoms= do_atoms atoms (make_simple_atoms seq); !flag && !phref -let match_one_quantified_hyp setref seq lf= +let match_one_quantified_hyp sigma setref seq lf= match lf.pat with Left(Lforall(i,dom,triv))|Right(Rexists(i,dom,triv))-> - if do_sequent setref triv lf.id seq i dom lf.atoms then + if do_sequent sigma setref triv lf.id seq i dom lf.atoms then setref:=IS.add ((Phantom dom),lf.id) !setref | _ -> anomaly (Pp.str "can't happen") -let give_instances lf seq= +let give_instances sigma lf seq= let setref=ref IS.empty in - List.iter (match_one_quantified_hyp setref seq) lf; + List.iter (match_one_quantified_hyp sigma setref seq) lf; IS.elements !setref (* collector for the engine *) -let rec collect_quantified seq= +let rec collect_quantified sigma seq= try - let hd,seq1=take_formula seq in + let hd,seq1=take_formula sigma seq in (match hd.pat with Left(Lforall(_,_,_)) | Right(Rexists(_,_,_)) -> - let (q,seq2)=collect_quantified seq1 in + let (q,seq2)=collect_quantified sigma seq1 in ((hd::q),seq2) | _->[],seq) with Heap.EmptyHeap -> [],seq @@ -99,58 +102,61 @@ let rec collect_quantified seq= let dummy_bvid=Id.of_string "x" -let mk_open_instance id idc gl m t= - let env=pf_env gl in - let evmap=Refiner.project gl in +let mk_open_instance env evmap id idc m t = let var_id= if id==dummy_id then dummy_bvid else - let typ=pf_unsafe_type_of gl idc in + let typ=Typing.unsafe_type_of env evmap idc in (* since we know we will get a product, reduction is not too expensive *) - let (nam,_,_)=destProd (whd_all env evmap typ) in + let (nam,_,_)=destProd evmap (whd_all env evmap typ) in match nam with Name id -> id | Anonymous -> dummy_bvid in let revt=substl (List.init m (fun i->mkRel (m-i))) t in let rec aux n avoid env evmap decls = if Int.equal n 0 then evmap, decls else - let nid=(fresh_id avoid var_id gl) in + let nid=(fresh_id_in_env avoid var_id env) 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 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 + aux (n-1) (nid::avoid) (EConstr.push_rel decl env) evmap (decl::decls) in let evmap, decls = aux m [] env evmap [] in - evmap, decls, revt + (evmap, decls, revt) (* tactics *) let left_instance_tac (inst,id) continue seq= + let open EConstr in + Proofview.Goal.enter { enter = begin fun gl -> + let sigma = project gl in match inst with Phantom dom-> - if lookup (id,None) seq then + if lookup sigma (id,None) seq then tclFAIL 0 (Pp.str "already done") else - tclTHENS (Proofview.V82.of_tactic (cut dom)) + tclTHENS (cut 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)); - Proofview.V82.of_tactic introf; + [introf; + (pf_constr_of_global id >>= fun idc -> + Proofview.Goal.enter { enter = begin fun gl -> + let id0 = List.nth (pf_ids_of_hyps gl) 0 in + generalize [mkApp(idc, [|mkVar id0|])] + end }); + introf; tclSOLVE [wrap 1 false continue (deepen (record (id,None) seq))]]; - tclTRY (Proofview.V82.of_tactic assumption)] - | Real((m,t) as c,_)-> - if lookup (id,Some c) seq then + tclTRY assumption] + | Real((m,t),_)-> + let c = (m, EConstr.to_constr sigma t) in + if lookup sigma (id,Some c) seq then tclFAIL 0 (Pp.str "already done") else let special_generalize= if m>0 then - pf_constr_of_global id (fun idc -> - fun gl-> - let evmap,rc,ot = mk_open_instance id idc gl m t in + (pf_constr_of_global id >>= fun idc -> + Proofview.Goal.s_enter { s_enter = begin fun gl-> + let (evmap, rc, ot) = mk_open_instance (pf_env gl) (project gl) id idc m t in let gt= it_mkLambda_or_LetIn (mkApp(idc,[|ot|])) rc in @@ -158,33 +164,38 @@ let left_instance_tac (inst,id) continue seq= 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) + Sigma.Unsafe.of_pair (generalize [gt], evmap) + end }) else - pf_constr_of_global id (fun idc -> - Proofview.V82.of_tactic (generalize [mkApp(idc,[|t|])])) + pf_constr_of_global id >>= fun idc -> generalize [mkApp(idc,[|t|])] in tclTHENLIST [special_generalize; - Proofview.V82.of_tactic introf; + introf; tclSOLVE [wrap 1 false continue (deepen (record (id,Some c) seq))]] + end } let right_instance_tac inst continue seq= + let open EConstr in + Proofview.Goal.enter { enter = begin fun gl -> match inst with Phantom dom -> - tclTHENS (Proofview.V82.of_tactic (cut dom)) + tclTHENS (cut dom) [tclTHENLIST - [Proofview.V82.of_tactic introf; - (fun gls-> - Proofview.V82.of_tactic (split (ImplicitBindings - [mkVar (Tacmach.pf_nth_hyp_id gls 1)])) gls); + [introf; + Proofview.Goal.enter { enter = begin fun gl -> + let id0 = List.nth (pf_ids_of_hyps gl) 0 in + split (ImplicitBindings [mkVar id0]) + end }; tclSOLVE [wrap 0 true continue (deepen seq)]]; - tclTRY (Proofview.V82.of_tactic assumption)] + tclTRY assumption] | Real ((0,t),_) -> - (tclTHEN (Proofview.V82.of_tactic (split (ImplicitBindings [t]))) + (tclTHEN (split (ImplicitBindings [t])) (tclSOLVE [wrap 0 true continue (deepen seq)])) | Real ((m,t),_) -> tclFAIL 0 (Pp.str "not implemented ... yet") + end } let instance_tac inst= if (snd inst)==dummy_id then @@ -192,10 +203,10 @@ let instance_tac inst= else left_instance_tac inst -let quantified_tac lf backtrack continue seq gl= - let insts=give_instances lf seq in +let quantified_tac lf backtrack continue seq = + Proofview.Goal.enter { enter = begin fun gl -> + let insts=give_instances (project gl) lf seq in tclORELSE (tclFIRST (List.map (fun inst->instance_tac inst continue seq) insts)) - backtrack gl - - + backtrack + end } diff --git a/plugins/firstorder/instances.mli b/plugins/firstorder/instances.mli index ce711f3f9..47550f314 100644 --- a/plugins/firstorder/instances.mli +++ b/plugins/firstorder/instances.mli @@ -9,9 +9,9 @@ open Globnames open Rules -val collect_quantified : Sequent.t -> Formula.t list * Sequent.t +val collect_quantified : Evd.evar_map -> Sequent.t -> Formula.t list * Sequent.t -val give_instances : Formula.t list -> Sequent.t -> +val give_instances : Evd.evar_map -> Formula.t list -> Sequent.t -> (Unify.instance * global_reference) list val quantified_tac : Formula.t list -> seqtac with_backtracking diff --git a/plugins/firstorder/rules.ml b/plugins/firstorder/rules.ml index 7ffc78928..e0d2c38a7 100644 --- a/plugins/firstorder/rules.ml +++ b/plugins/firstorder/rules.ml @@ -10,10 +10,12 @@ open CErrors open Util open Names open Term +open EConstr open Vars -open Tacmach +open Tacmach.New open Tactics -open Tacticals +open Tacticals.New +open Proofview.Notations open Termops open Formula open Sequent @@ -22,142 +24,165 @@ open Locus module NamedDecl = Context.Named.Declaration +type tactic = unit Proofview.tactic + type seqtac= (Sequent.t -> tactic) -> Sequent.t -> tactic type lseqtac= global_reference -> seqtac type 'a with_backtracking = tactic -> 'a -let wrap n b continue seq gls= +let wrap n b continue seq = + Proofview.Goal.nf_enter { enter = begin fun gls -> Control.check_for_interrupt (); - let nc=pf_hyps gls in + let nc = Proofview.Goal.hyps gls in let env=pf_env gls in + let sigma = project gls in let rec aux i nc ctx= if i<=0 then seq else match nc with []->anomaly (Pp.str "Not the expected number of hyps") | nd::q-> let id = NamedDecl.get_id nd in - if occur_var env id (pf_concl gls) || - List.exists (occur_var_in_decl env id) ctx then + if occur_var env sigma id (pf_concl gls) || + List.exists (occur_var_in_decl env sigma id) ctx then (aux (i-1) q (nd::ctx)) else - add_formula Hyp (VarRef id) (NamedDecl.get_type nd) (aux (i-1) q (nd::ctx)) gls in + add_formula env sigma Hyp (VarRef id) (NamedDecl.get_type nd) (aux (i-1) q (nd::ctx)) in let seq1=aux n nc [] in let seq2=if b then - add_formula Concl dummy_id (pf_concl gls) seq1 gls else seq1 in - continue seq2 gls + add_formula env sigma Concl dummy_id (pf_concl gls) seq1 else seq1 in + continue seq2 + end } let basename_of_global=function VarRef id->id | _->assert false let clear_global=function - VarRef id-> Proofview.V82.of_tactic (clear [id]) + VarRef id-> clear [id] | _->tclIDTAC (* 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)) - with Not_found->tclFAIL 0 (Pp.str "No axiom link") +let axiom_tac t seq = + Proofview.Goal.enter { enter = begin fun gl -> + try + pf_constr_of_global (find_left (project gl) t seq) >>= fun c -> + exact_no_check c + with Not_found -> tclFAIL 0 (Pp.str "No axiom link") + end } -let ll_atom_tac a backtrack id continue seq= +let ll_atom_tac a backtrack id continue seq = + let open EConstr in tclIFTHENELSE - (try - 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|])]))); + (tclTHENLIST + [(Proofview.tclEVARMAP >>= fun sigma -> + let gr = + try Proofview.tclUNIT (find_left sigma a seq) + with Not_found -> tclFAIL 0 (Pp.str "No link") + in + gr >>= fun gr -> + pf_constr_of_global gr >>= fun left -> + pf_constr_of_global id >>= fun id -> + generalize [(mkApp(id, [|left|]))]); clear_global id; - Proofview.V82.of_tactic intro] - with Not_found->tclFAIL 0 (Pp.str "No link")) + intro]) (wrap 1 false continue seq) backtrack (* right connectives rules *) let and_tac backtrack continue seq= - tclIFTHENELSE (Proofview.V82.of_tactic simplest_split) (wrap 0 true continue seq) backtrack + tclIFTHENELSE simplest_split (wrap 0 true continue seq) backtrack let or_tac backtrack continue seq= tclORELSE - (Proofview.V82.of_tactic (any_constructor false (Some (Proofview.V82.tactic (tclCOMPLETE (wrap 0 true continue seq)))))) + (any_constructor false (Some (tclCOMPLETE (wrap 0 true continue seq)))) backtrack let arrow_tac backtrack continue seq= - tclIFTHENELSE (Proofview.V82.of_tactic intro) (wrap 1 true continue seq) + tclIFTHENELSE intro (wrap 1 true continue seq) (tclORELSE - (tclTHEN (Proofview.V82.of_tactic introf) (tclCOMPLETE (wrap 1 true continue seq))) + (tclTHEN introf (tclCOMPLETE (wrap 1 true continue seq))) backtrack) (* left connectives rules *) -let left_and_tac ind backtrack id continue seq gls= - let n=(construct_nhyps ind gls).(0) in +let left_and_tac ind backtrack id continue seq = + Proofview.Goal.enter { enter = begin fun gl -> + let n=(construct_nhyps (pf_env gl) ind).(0) in tclIFTHENELSE (tclTHENLIST - [Proofview.V82.of_tactic (Tacticals.New.pf_constr_of_global id simplest_elim); + [(pf_constr_of_global id >>= simplest_elim); clear_global id; - tclDO n (Proofview.V82.of_tactic intro)]) + tclDO n intro]) (wrap n false continue seq) - backtrack gls + backtrack + end } -let left_or_tac ind backtrack id continue seq gls= - let v=construct_nhyps ind gls in +let left_or_tac ind backtrack id continue seq = + Proofview.Goal.enter { enter = begin fun gl -> + let v=construct_nhyps (pf_env gl) ind in let f n= tclTHENLIST [clear_global id; - tclDO n (Proofview.V82.of_tactic intro); + tclDO n intro; wrap n false continue seq] in tclIFTHENSVELSE - (Proofview.V82.of_tactic (Tacticals.New.pf_constr_of_global id simplest_elim)) + (pf_constr_of_global id >>= simplest_elim) (Array.map f v) - backtrack gls + backtrack + end } let left_false_tac id= - Proofview.V82.of_tactic (Tacticals.New.pf_constr_of_global id simplest_elim) + Tacticals.New.pf_constr_of_global id >>= simplest_elim (* left arrow connective rules *) (* We use this function for false, and, or, exists *) -let ll_ind_tac (ind,u as indu) largs backtrack id continue seq gl= - let rcs=ind_hyps 0 indu largs gl in +let ll_ind_tac (ind,u as indu) largs backtrack id continue seq = + Proofview.Goal.enter { enter = begin fun gl -> + let rcs=ind_hyps (pf_env gl) (project gl) 0 indu largs in let vargs=Array.of_list largs in (* construire le terme H->B, le generaliser etc *) let myterm idc i= let rc=rcs.(i) in let p=List.length rc in + let u = EInstance.make u in let cstr=mkApp ((mkConstructU ((ind,(i+1)),u)),vargs) in 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.it_mkLambda_or_LetIn head rc in let lp=Array.length rcs in let newhyps idc =List.init lp (myterm idc) in tclIFTHENELSE (tclTHENLIST - [pf_constr_of_global id (fun idc -> Proofview.V82.of_tactic (generalize (newhyps idc))); + [(pf_constr_of_global id >>= fun idc -> generalize (newhyps idc)); clear_global id; - tclDO lp (Proofview.V82.of_tactic intro)]) - (wrap lp false continue seq) backtrack gl + tclDO lp intro]) + (wrap lp false continue seq) backtrack + end } let ll_arrow_tac a b c backtrack id continue seq= + let open EConstr in + let open Vars in let cc=mkProd(Anonymous,a,(lift 1 b)) in - let d idc =mkLambda (Anonymous,b, + let d idc = mkLambda (Anonymous,b, mkApp (idc, [|mkLambda (Anonymous,(lift 1 a),(mkRel 2))|])) in tclORELSE - (tclTHENS (Proofview.V82.of_tactic (cut c)) + (tclTHENS (cut c) [tclTHENLIST - [Proofview.V82.of_tactic introf; + [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 (cut cc) + [(pf_constr_of_global id >>= fun c -> exact_no_check c); tclTHENLIST - [pf_constr_of_global id (fun idc -> Proofview.V82.of_tactic (generalize [d idc])); + [(pf_constr_of_global id >>= fun idc -> generalize [d idc]); clear_global id; - Proofview.V82.of_tactic introf; - Proofview.V82.of_tactic introf; + introf; + introf; tclCOMPLETE (wrap 2 true continue seq)]]]) backtrack @@ -165,37 +190,40 @@ let ll_arrow_tac a b c backtrack id continue seq= let forall_tac backtrack continue seq= tclORELSE - (tclIFTHENELSE (Proofview.V82.of_tactic intro) (wrap 0 true continue seq) + (tclIFTHENELSE intro (wrap 0 true continue seq) (tclORELSE - (tclTHEN (Proofview.V82.of_tactic introf) (tclCOMPLETE (wrap 0 true continue seq))) + (tclTHEN introf (tclCOMPLETE (wrap 0 true continue seq))) backtrack)) (if !qflag then tclFAIL 0 (Pp.str "reversible in 1st order mode") else backtrack) -let left_exists_tac ind backtrack id continue seq gls= - let n=(construct_nhyps ind gls).(0) in +let left_exists_tac ind backtrack id continue seq = + Proofview.Goal.enter { enter = begin fun gl -> + let n=(construct_nhyps (pf_env gl) ind).(0) in tclIFTHENELSE - (Proofview.V82.of_tactic (Tacticals.New.pf_constr_of_global id simplest_elim)) + (Tacticals.New.pf_constr_of_global id >>= simplest_elim) (tclTHENLIST [clear_global id; - tclDO n (Proofview.V82.of_tactic intro); + tclDO n intro; (wrap (n-1) false continue seq)]) backtrack - gls + end } let ll_forall_tac prod backtrack id continue seq= tclORELSE - (tclTHENS (Proofview.V82.of_tactic (cut prod)) + (tclTHENS (cut 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 + [intro; + (pf_constr_of_global id >>= fun idc -> + Proofview.Goal.enter { enter = begin fun gls-> + let open EConstr in + let id0 = List.nth (pf_ids_of_hyps gls) 0 in let term=mkApp(idc,[|mkVar(id0)|]) in - tclTHEN (Proofview.V82.of_tactic (generalize [term])) (Proofview.V82.of_tactic (clear [id0])) gls)); + tclTHEN (generalize [term]) (clear [id0]) + end }); clear_global id; - Proofview.V82.of_tactic intro; + intro; tclCOMPLETE (wrap 1 false continue (deepen seq))]; tclCOMPLETE (wrap 0 true continue (deepen seq))]) backtrack @@ -207,12 +235,13 @@ let ll_forall_tac prod backtrack id continue seq= let constant str = Coqlib.gen_constant "User" ["Init";"Logic"] str let defined_connectives=lazy - [AllOccurrences,EvalConstRef (fst (destConst (constant "not"))); - AllOccurrences,EvalConstRef (fst (destConst (constant "iff")))] + [AllOccurrences,EvalConstRef (fst (Term.destConst (constant "not"))); + AllOccurrences,EvalConstRef (fst (Term.destConst (constant "iff")))] let normalize_evaluables= - onAllHypsAndConcl - (function - None-> Proofview.V82.of_tactic (unfold_in_concl (Lazy.force defined_connectives)) - | Some id -> - Proofview.V82.of_tactic (unfold_in_hyp (Lazy.force defined_connectives) (id,InHypTypeOnly))) + Proofview.Goal.enter { enter = begin fun gl -> + unfold_in_concl (Lazy.force defined_connectives) <*> + tclMAP + (fun id -> unfold_in_hyp (Lazy.force defined_connectives) (id,InHypTypeOnly)) + (pf_ids_of_hyps gl) + end } diff --git a/plugins/firstorder/rules.mli b/plugins/firstorder/rules.mli index 381b7cd87..80a7ae2c2 100644 --- a/plugins/firstorder/rules.mli +++ b/plugins/firstorder/rules.mli @@ -7,10 +7,13 @@ (************************************************************************) open Term +open EConstr open Tacmach open Names open Globnames +type tactic = unit Proofview.tactic + type seqtac= (Sequent.t -> tactic) -> Sequent.t -> tactic type lseqtac= global_reference -> seqtac diff --git a/plugins/firstorder/sequent.ml b/plugins/firstorder/sequent.ml index 1248b60a7..59b842c82 100644 --- a/plugins/firstorder/sequent.ml +++ b/plugins/firstorder/sequent.ml @@ -7,6 +7,7 @@ (************************************************************************) open Term +open EConstr open CErrors open Util open Formula @@ -57,11 +58,11 @@ end module OrderedConstr= struct - type t=constr + type t=Constr.t let compare=constr_ord end -type h_item = global_reference * (int*constr) option +type h_item = global_reference * (int*Constr.t) option module Hitem= struct @@ -81,13 +82,15 @@ module CM=Map.Make(OrderedConstr) module History=Set.Make(Hitem) -let cm_add typ nam cm= +let cm_add sigma typ nam cm= + let typ = EConstr.to_constr sigma typ in try let l=CM.find typ cm in CM.add typ (nam::l) cm with Not_found->CM.add typ [nam] cm -let cm_remove typ nam cm= +let cm_remove sigma typ nam cm= + let typ = EConstr.to_constr sigma typ in try let l=CM.find typ cm in let l0=List.filter (fun id-> not (Globnames.eq_gr id nam)) l in @@ -112,19 +115,19 @@ let deepen seq={seq with depth=seq.depth-1} let record item seq={seq with history=History.add item seq.history} -let lookup item seq= +let lookup sigma item seq= History.mem item seq.history || match item with (_,None)->false - | (id,Some ((m,t) as c))-> + | (id,Some (m, t))-> let p (id2,o)= match o with None -> false - | Some ((m2,t2) as c2)-> Globnames.eq_gr id id2 && m2>m && more_general c2 c in + | Some (m2, t2)-> Globnames.eq_gr id id2 && m2>m && more_general sigma (m2, EConstr.of_constr t2) (m, EConstr.of_constr t) in History.exists p seq.history -let add_formula side nam t seq gl= - match build_formula side nam t gl seq.cnt with +let add_formula env sigma side nam t seq = + match build_formula env sigma side nam t seq.cnt with Left f-> begin match side with @@ -136,7 +139,7 @@ let add_formula side nam t seq gl= | _ -> {seq with redexes=HP.add f seq.redexes; - context=cm_add f.constr nam seq.context} + context=cm_add sigma f.constr nam seq.context} end | Right t-> match side with @@ -144,18 +147,18 @@ let add_formula side nam t seq gl= {seq with gl=t;glatom=Some t} | _ -> {seq with - context=cm_add t nam seq.context; + context=cm_add sigma t nam seq.context; latoms=t::seq.latoms} -let re_add_formula_list lf seq= +let re_add_formula_list sigma lf seq= let do_one f cm= if f.id == dummy_id then cm - else cm_add f.constr f.id cm in + else cm_add sigma f.constr f.id cm in {seq with redexes=List.fold_right HP.add lf seq.redexes; context=List.fold_right do_one lf seq.context} -let find_left t seq=List.hd (CM.find t seq.context) +let find_left sigma t seq=List.hd (CM.find (EConstr.to_constr sigma t) seq.context) (*let rev_left seq= try @@ -164,7 +167,7 @@ let find_left t seq=List.hd (CM.find t seq.context) with Heap.EmptyHeap -> false *) -let rec take_formula seq= +let rec take_formula sigma seq= let hd=HP.maximum seq.redexes and hp=HP.remove seq.redexes in if hd.id == dummy_id then @@ -172,11 +175,11 @@ let rec take_formula seq= if seq.gl==hd.constr then hd,nseq else - take_formula nseq (* discarding deprecated goal *) + take_formula sigma nseq (* discarding deprecated goal *) else hd,{seq with redexes=hp; - context=cm_remove hd.constr hd.id seq.context} + context=cm_remove sigma hd.constr hd.id seq.context} let empty_seq depth= {redexes=HP.empty; @@ -196,17 +199,17 @@ let expand_constructor_hints = | gr -> [gr]) -let extend_with_ref_list l seq gl = +let extend_with_ref_list env sigma l seq = let l = expand_constructor_hints l in - let f gr (seq,gl) = - let gl, c = pf_eapply Evd.fresh_global gl gr in - let typ=(pf_unsafe_type_of gl c) in - (add_formula Hyp gr typ seq gl,gl) in - List.fold_right f l (seq,gl) + let f gr (seq, sigma) = + let sigma, c = Evd.fresh_global env sigma gr in + let sigma, typ= Typing.type_of env sigma (EConstr.of_constr c) in + (add_formula env sigma Hyp gr typ seq, sigma) in + List.fold_right f l (seq, sigma) open Hints -let extend_with_auto_hints l seq gl= +let extend_with_auto_hints env sigma l seq = let seqref=ref seq in let f p_a_t = match repr_hint p_a_t.code with @@ -214,9 +217,9 @@ let extend_with_auto_hints l seq gl= | Res_pf_THEN_trivial_fail (c,_) -> let (c, _, _) = c in (try - let gr = global_of_constr c in - let typ=(pf_unsafe_type_of gl c) in - seqref:=add_formula Hint gr typ !seqref gl + let (gr, _) = Termops.global_of_constr sigma c in + let typ=(Typing.unsafe_type_of env sigma c) in + seqref:=add_formula env sigma Hint gr typ !seqref with Not_found->()) | _-> () in let g _ _ l = List.iter f l in @@ -228,7 +231,7 @@ let extend_with_auto_hints l seq gl= error ("Firstorder: "^dbname^" : No such Hint database") in Hint_db.iter g hdb in List.iter h l; - !seqref, gl (*FIXME: forgetting about universes*) + !seqref, sigma (*FIXME: forgetting about universes*) let print_cmap map= let print_entry c l s= diff --git a/plugins/firstorder/sequent.mli b/plugins/firstorder/sequent.mli index 06c9251e7..18d68f54f 100644 --- a/plugins/firstorder/sequent.mli +++ b/plugins/firstorder/sequent.mli @@ -7,22 +7,23 @@ (************************************************************************) open Term +open EConstr open Formula open Tacmach open Globnames -module OrderedConstr: Set.OrderedType with type t=constr +module OrderedConstr: Set.OrderedType with type t=Constr.t -module CM: CSig.MapS with type key=constr +module CM: CSig.MapS with type key=Constr.t -type h_item = global_reference * (int*constr) option +type h_item = global_reference * (int*Constr.t) option module History: Set.S with type elt = h_item -val cm_add : constr -> global_reference -> global_reference list CM.t -> +val cm_add : Evd.evar_map -> constr -> global_reference -> global_reference list CM.t -> global_reference list CM.t -val cm_remove : constr -> global_reference -> global_reference list CM.t -> +val cm_remove : Evd.evar_map -> constr -> global_reference -> global_reference list CM.t -> global_reference list CM.t module HP: Heap.S with type elt=Formula.t @@ -40,23 +41,22 @@ val deepen: t -> t val record: h_item -> t -> t -val lookup: h_item -> t -> bool +val lookup: Evd.evar_map -> h_item -> t -> bool -val add_formula : side -> global_reference -> constr -> t -> - Proof_type.goal sigma -> t +val add_formula : Environ.env -> Evd.evar_map -> side -> global_reference -> constr -> t -> t -val re_add_formula_list : Formula.t list -> t -> t +val re_add_formula_list : Evd.evar_map -> Formula.t list -> t -> t -val find_left : constr -> t -> global_reference +val find_left : Evd.evar_map -> constr -> t -> global_reference -val take_formula : t -> Formula.t * t +val take_formula : Evd.evar_map -> t -> Formula.t * t val empty_seq : int -> t -val extend_with_ref_list : global_reference list -> - t -> Proof_type.goal sigma -> t * Proof_type.goal sigma +val extend_with_ref_list : Environ.env -> Evd.evar_map -> global_reference list -> + t -> t * Evd.evar_map -val extend_with_auto_hints : Hints.hint_db_name list -> - t -> Proof_type.goal sigma -> t * Proof_type.goal sigma +val extend_with_auto_hints : Environ.env -> Evd.evar_map -> Hints.hint_db_name list -> + t -> t * Evd.evar_map val print_cmap: global_reference list CM.t -> Pp.std_ppcmds diff --git a/plugins/firstorder/unify.ml b/plugins/firstorder/unify.ml index d9ab36ad6..49bf07155 100644 --- a/plugins/firstorder/unify.ml +++ b/plugins/firstorder/unify.ml @@ -8,6 +8,7 @@ open Util open Term +open EConstr open Vars open Termops open Reductionops @@ -21,7 +22,12 @@ exception UFAIL of constr*constr to the equation set. Raises UFAIL with a pair of terms *) -let unif t1 t2= +let pop t = Vars.lift (-1) t +let subst_meta subst t = + let subst = List.map (fun (m, c) -> (m, EConstr.Unsafe.to_constr c)) subst in + EConstr.of_constr (subst_meta subst (EConstr.Unsafe.to_constr t)) + +let unif evd t1 t2= let bige=Queue.create () and sigma=ref [] in let bind i t= @@ -29,7 +35,7 @@ let unif t1 t2= (List.map (function (n,tn)->(n,subst_meta [i,t] tn)) !sigma) in let rec head_reduce t= (* forbids non-sigma-normal meta in head position*) - match kind_of_term t with + match EConstr.kind evd t with Meta i-> (try head_reduce (Int.List.assoc i !sigma) @@ -38,25 +44,25 @@ let unif t1 t2= Queue.add (t1,t2) bige; try while true do let t1,t2=Queue.take bige in - let nt1=head_reduce (whd_betaiotazeta Evd.empty t1) - and nt2=head_reduce (whd_betaiotazeta Evd.empty t2) in - match (kind_of_term nt1),(kind_of_term nt2) with + let nt1=head_reduce (whd_betaiotazeta evd t1) + and nt2=head_reduce (whd_betaiotazeta evd t2) in + match (EConstr.kind evd nt1),(EConstr.kind evd nt2) with Meta i,Meta j-> if not (Int.equal i j) then if i<j then bind j nt1 else bind i nt2 | Meta i,_ -> let t=subst_meta !sigma nt2 in - if Int.Set.is_empty (free_rels t) && - not (occur_term (mkMeta i) t) then + if Int.Set.is_empty (free_rels evd t) && + not (occur_term evd (EConstr.mkMeta i) t) then bind i t else raise (UFAIL(nt1,nt2)) | _,Meta i -> let t=subst_meta !sigma nt1 in - if Int.Set.is_empty (free_rels t) && - not (occur_term (mkMeta i) t) then + if Int.Set.is_empty (free_rels evd t) && + not (occur_term evd (EConstr.mkMeta i) t) then bind i t else raise (UFAIL(nt1,nt2)) - | Cast(_,_,_),_->Queue.add (strip_outer_cast nt1,nt2) bige - | _,Cast(_,_,_)->Queue.add (nt1,strip_outer_cast nt2) bige + | Cast(_,_,_),_->Queue.add (strip_outer_cast evd nt1,nt2) bige + | _,Cast(_,_,_)->Queue.add (nt1,strip_outer_cast evd nt2) bige | (Prod(_,a,b),Prod(_,c,d))|(Lambda(_,a,b),Lambda(_,c,d))-> Queue.add (a,c) bige;Queue.add (pop b,pop d) bige | Case (_,pa,ca,va),Case (_,pb,cb,vb)-> @@ -78,19 +84,19 @@ let unif t1 t2= for i=0 to l-1 do Queue.add (va.(i),vb.(i)) bige done - | _->if not (eq_constr_nounivs nt1 nt2) then raise (UFAIL (nt1,nt2)) + | _->if not (eq_constr_nounivs evd nt1 nt2) then raise (UFAIL (nt1,nt2)) done; assert false (* this place is unreachable but needed for the sake of typing *) with Queue.Empty-> !sigma -let value i t= +let value evd i t= let add x y= if x<0 then y else if y<0 then x else x+y in let rec vaux term= - if isMeta term && Int.equal (destMeta term) i then 0 else + if isMeta evd term && Int.equal (destMeta evd term) i then 0 else let f v t=add v (vaux t) in - let vr=fold_constr f (-1) term in + let vr=EConstr.fold evd f (-1) term in if vr<0 then -1 else vr+1 in vaux t @@ -98,11 +104,11 @@ type instance= Real of (int*constr)*int | Phantom of constr -let mk_rel_inst t= +let mk_rel_inst evd t= let new_rel=ref 1 in let rel_env=ref [] in let rec renum_rec d t= - match kind_of_term t with + match EConstr.kind evd t with Meta n-> (try mkRel (d+(Int.List.assoc n !rel_env)) @@ -111,15 +117,15 @@ let mk_rel_inst t= incr new_rel; rel_env:=(n,m) :: !rel_env; mkRel (m+d)) - | _ -> map_constr_with_binders succ renum_rec d t + | _ -> EConstr.map_with_binders evd succ renum_rec d t in let nt=renum_rec 0 t in (!new_rel - 1,nt) -let unif_atoms i dom t1 t2= +let unif_atoms evd i dom t1 t2= try - let t=Int.List.assoc i (unif t1 t2) in - if isMeta t then Some (Phantom dom) - else Some (Real(mk_rel_inst t,value i t1)) + let t=Int.List.assoc i (unif evd t1 t2) in + if isMeta evd t then Some (Phantom dom) + else Some (Real(mk_rel_inst evd t,value evd i t1)) with UFAIL(_,_) ->None | Not_found ->Some (Phantom dom) @@ -128,11 +134,11 @@ let renum_metas_from k n t= (* requires n = max (free_rels t) *) let l=List.init n (fun i->mkMeta (k+i)) in substl l t -let more_general (m1,t1) (m2,t2)= +let more_general evd (m1,t1) (m2,t2)= let mt1=renum_metas_from 0 m1 t1 and mt2=renum_metas_from m1 m2 t2 in try - let sigma=unif mt1 mt2 in - let p (n,t)= n<m1 || isMeta t in + let sigma=unif evd mt1 mt2 in + let p (n,t)= n<m1 || isMeta evd t in List.for_all p sigma with UFAIL(_,_)->false diff --git a/plugins/firstorder/unify.mli b/plugins/firstorder/unify.mli index 4fe9ad38d..c9cca9bd8 100644 --- a/plugins/firstorder/unify.mli +++ b/plugins/firstorder/unify.mli @@ -7,15 +7,16 @@ (************************************************************************) open Term +open EConstr exception UFAIL of constr*constr -val unif : constr -> constr -> (int*constr) list +val unif : Evd.evar_map -> constr -> constr -> (int*constr) list type instance= Real of (int*constr)*int (* nb trous*terme*valeur heuristique *) | Phantom of constr (* domaine de quantification *) -val unif_atoms : metavariable -> constr -> constr -> constr -> instance option +val unif_atoms : Evd.evar_map -> metavariable -> constr -> constr -> constr -> instance option -val more_general : (int*constr) -> (int*constr) -> bool +val more_general : Evd.evar_map -> (int*constr) -> (int*constr) -> bool diff --git a/plugins/fourier/Fourier.v b/plugins/fourier/Fourier.v index 1d7ee93ea..a96254713 100644 --- a/plugins/fourier/Fourier.v +++ b/plugins/fourier/Fourier.v @@ -13,6 +13,6 @@ Require Export DiscrR. Require Export Fourier_util. Declare ML Module "fourier_plugin". -Ltac fourier := abstract (fourierz; field; discrR). +Ltac fourier := abstract (compute [IZR IPR IPR_2] in *; fourierz; field; discrR). Ltac fourier_eq := apply Rge_antisym; fourier. diff --git a/plugins/fourier/fourierR.ml b/plugins/fourier/fourierR.ml index 8e193c753..25d8f8c83 100644 --- a/plugins/fourier/fourierR.ml +++ b/plugins/fourier/fourierR.ml @@ -190,6 +190,8 @@ type hineq={hname:constr; (* le nom de l'hypothèse *) exception NoIneq let ineq1_of_constr (h,t) = + let h = EConstr.Unsafe.to_constr h in + let t = EConstr.Unsafe.to_constr t in match (kind_of_term t) with | App (f,args) -> (match kind_of_term f with @@ -281,6 +283,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 +377,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 +390,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 +405,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 +415,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 +423,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 @@ -461,14 +470,17 @@ exception GoalDone let rec fourier () = Proofview.Goal.nf_enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in + let sigma = Tacmach.New.project gl in Coqlib.check_required_library ["Coq";"fourier";"Fourier"]; - let goal = Termops.strip_outer_cast concl in + let goal = Termops.strip_outer_cast sigma concl in + let goal = EConstr.Unsafe.to_constr goal in let fhyp=Id.of_string "new_hyp_for_fourier" in (* si le but est une inéquation, on introduit son contraire, et le but à prouver devient False *) 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 @@ -494,7 +506,7 @@ let rec fourier () = |_-> raise GoalDone with GoalDone -> (* les hypothèses *) - let hyps = List.map (fun (h,t)-> (mkVar h,t)) + let hyps = List.map (fun (h,t)-> (EConstr.mkVar h,t)) (list_of_sign (Proofview.Goal.hyps gl)) in let lineq =ref [] in List.iter (fun h -> try (lineq:=(ineq1_of_constr h)@(!lineq)) @@ -547,6 +559,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; @@ -583,30 +596,30 @@ 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|] - ) - tc) + (EConstr.of_constr (mkAppL [|cget coq_Rminus;!t2;!t1|] + )) + (EConstr.of_constr tc)) [tac2; (Tacticals.New.tclTHENS (Equality.replace - (mkApp (get coq_Rinv, - [|get coq_R1|])) + (EConstr.of_constr (mkApp (cget coq_Rinv, + [|cget coq_R1|]))) (get 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.pf_constr_of_global (cget coq_sym_eqT) >>= fun symeq -> (Tacticals.New.tclTHEN (apply symeq) - (apply (get coq_Rinv_1))))] + (apply (get coq_Rinv_1)))] ) ])); diff --git a/plugins/fourier/g_fourier.ml4 b/plugins/fourier/g_fourier.ml4 index 7c665ae7b..1960fa835 100644 --- a/plugins/fourier/g_fourier.ml4 +++ b/plugins/fourier/g_fourier.ml4 @@ -8,6 +8,7 @@ (*i camlp4deps: "grammar/grammar.cma" i*) +open Ltac_plugin open FourierR DECLARE PLUGIN "fourier_plugin" diff --git a/plugins/funind/functional_principles_proofs.ml b/plugins/funind/functional_principles_proofs.ml index 527f4f0b1..8dae17d69 100644 --- a/plugins/funind/functional_principles_proofs.ml +++ b/plugins/funind/functional_principles_proofs.ml @@ -2,6 +2,7 @@ open Printer open CErrors open Util open Term +open EConstr open Vars open Namegen open Names @@ -18,6 +19,12 @@ open Context.Rel.Declaration module RelDecl = Context.Rel.Declaration +let local_assum (na, t) = + RelDecl.LocalAssum (na, EConstr.Unsafe.to_constr t) + +let local_def (na, b, t) = + RelDecl.LocalDef (na, EConstr.Unsafe.to_constr b, EConstr.Unsafe.to_constr t) + (* let msgnl = Pp.msgnl *) (* @@ -95,6 +102,7 @@ let list_chop ?(msg="") n l = with Failure (msg') -> failwith (msg ^ msg') +let pop t = Vars.lift (-1) t let make_refl_eq constructor type_of_t t = (* let refl_equal_term = Lazy.force refl_equal in *) @@ -131,16 +139,16 @@ let refine c = let thin l = Proofview.V82.of_tactic (Tactics.clear l) -let eq_constr u v = eq_constr_nounivs u v +let eq_constr sigma u v = EConstr.eq_constr_nounivs sigma u v -let is_trivial_eq t = +let is_trivial_eq sigma t = let res = try begin - match kind_of_term t with - | App(f,[|_;t1;t2|]) when eq_constr f (Lazy.force eq) -> - eq_constr t1 t2 - | App(f,[|t1;a1;t2;a2|]) when eq_constr f (jmeq ()) -> - eq_constr t1 t2 && eq_constr a1 a2 + match EConstr.kind sigma t with + | App(f,[|_;t1;t2|]) when eq_constr sigma f (Lazy.force eq) -> + eq_constr sigma t1 t2 + | App(f,[|t1;a1;t2;a2|]) when eq_constr sigma f (jmeq ()) -> + eq_constr sigma t1 t2 && eq_constr sigma a1 a2 | _ -> false end with e when CErrors.noncritical e -> false @@ -148,30 +156,30 @@ let is_trivial_eq t = (* observe (str "is_trivial_eq " ++ Printer.pr_lconstr t ++ (if res then str " true" else str " false")); *) res -let rec incompatible_constructor_terms t1 t2 = - let c1,arg1 = decompose_app t1 - and c2,arg2 = decompose_app t2 +let rec incompatible_constructor_terms sigma t1 t2 = + let c1,arg1 = decompose_app sigma t1 + and c2,arg2 = decompose_app sigma t2 in - (not (eq_constr t1 t2)) && - isConstruct c1 && isConstruct c2 && + (not (eq_constr sigma t1 t2)) && + isConstruct sigma c1 && isConstruct sigma c2 && ( - not (eq_constr c1 c2) || - List.exists2 incompatible_constructor_terms arg1 arg2 + not (eq_constr sigma c1 c2) || + List.exists2 (incompatible_constructor_terms sigma) arg1 arg2 ) -let is_incompatible_eq t = +let is_incompatible_eq sigma t = let res = try - match kind_of_term t with - | App(f,[|_;t1;t2|]) when eq_constr f (Lazy.force eq) -> - incompatible_constructor_terms t1 t2 - | App(f,[|u1;t1;u2;t2|]) when eq_constr f (jmeq ()) -> - (eq_constr u1 u2 && - incompatible_constructor_terms t1 t2) + match EConstr.kind sigma t with + | App(f,[|_;t1;t2|]) when eq_constr sigma f (Lazy.force eq) -> + incompatible_constructor_terms sigma t1 t2 + | App(f,[|u1;t1;u2;t2|]) when eq_constr sigma f (jmeq ()) -> + (eq_constr sigma u1 u2 && + incompatible_constructor_terms sigma t1 t2) | _ -> false with e when CErrors.noncritical e -> false in - if res then observe (str "is_incompatible_eq " ++ Printer.pr_lconstr t); + if res then observe (str "is_incompatible_eq " ++ Printer.pr_leconstr t); res let change_hyp_with_using msg hyp_id t tac : tactic = @@ -208,40 +216,38 @@ let prove_trivial_eq h_id context (constructor,type_of_term,term) = -let find_rectype env c = - let (t, l) = decompose_app (Reduction.whd_betaiotazeta env c) in - match kind_of_term t with +let find_rectype env sigma c = + let (t, l) = decompose_app sigma (Reductionops.whd_betaiotazeta sigma c) in + match EConstr.kind sigma t with | Ind ind -> (t, l) | Construct _ -> (t,l) | _ -> raise Not_found -let isAppConstruct ?(env=Global.env ()) t = +let isAppConstruct ?(env=Global.env ()) sigma t = try - let t',l = find_rectype (Global.env ()) t in - observe (str "isAppConstruct : " ++ Printer.pr_lconstr t ++ str " -> " ++ Printer.pr_lconstr (applist (t',l))); + let t',l = find_rectype env sigma t in + observe (str "isAppConstruct : " ++ Printer.pr_leconstr t ++ str " -> " ++ Printer.pr_leconstr (applist (t',l))); true with Not_found -> false let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta *) - let clos_norm_flags flgs env sigma t = - CClosure.norm_val (CClosure.create_clos_infos flgs env) (CClosure.inject (Reductionops.nf_evar sigma t)) in - clos_norm_flags CClosure.betaiotazeta Environ.empty_env Evd.empty + Reductionops.clos_norm_flags CClosure.betaiotazeta Environ.empty_env Evd.empty -let change_eq env sigma hyp_id (context:Context.Rel.t) x t end_of_type = +let change_eq env sigma hyp_id (context:rel_context) x t end_of_type = let nochange ?t' msg = begin - observe (str ("Not treating ( "^msg^" )") ++ pr_lconstr t ++ str " " ++ match t' with None -> str "" | Some t -> Printer.pr_lconstr t ); + observe (str ("Not treating ( "^msg^" )") ++ pr_leconstr t ++ str " " ++ match t' with None -> str "" | Some t -> Printer.pr_leconstr t ); failwith "NoChange"; end in - let eq_constr = Evarconv.e_conv env (ref sigma) in - if not (noccurn 1 end_of_type) + let eq_constr c1 c2 = Evarconv.e_conv env (ref sigma) c1 c2 in + if not (noccurn sigma 1 end_of_type) then nochange "dependent"; (* if end_of_type depends on this term we don't touch it *) - if not (isApp t) then nochange "not an equality"; - let f_eq,args = destApp t in + if not (isApp sigma t) then nochange "not an equality"; + let f_eq,args = destApp sigma t in let constructor,t1,t2,t1_typ = try if (eq_constr f_eq (Lazy.force eq)) @@ -258,42 +264,42 @@ let change_eq env sigma hyp_id (context:Context.Rel.t) x t end_of_type = else nochange "not an equality" with e when CErrors.noncritical e -> nochange "not an equality" in - if not ((closed0 (fst t1)) && (closed0 (snd t1)))then nochange "not a closed lhs"; + if not ((closed0 sigma (fst t1)) && (closed0 sigma (snd t1)))then nochange "not a closed lhs"; let rec compute_substitution sub t1 t2 = (* observe (str "compute_substitution : " ++ pr_lconstr t1 ++ str " === " ++ pr_lconstr t2); *) - if isRel t2 + if isRel sigma t2 then - let t2 = destRel t2 in + let t2 = destRel sigma t2 in begin try let t1' = Int.Map.find t2 sub in if not (eq_constr t1 t1') then nochange "twice bound variable"; sub with Not_found -> - assert (closed0 t1); + assert (closed0 sigma t1); Int.Map.add t2 t1 sub end - else if isAppConstruct t1 && isAppConstruct t2 + else if isAppConstruct sigma t1 && isAppConstruct sigma t2 then begin - let c1,args1 = find_rectype env t1 - and c2,args2 = find_rectype env t2 + let c1,args1 = find_rectype env sigma t1 + and c2,args2 = find_rectype env sigma t2 in if not (eq_constr c1 c2) then nochange "cannot solve (diff)"; List.fold_left2 compute_substitution sub args1 args2 end else - if (eq_constr t1 t2) then sub else nochange ~t':(make_refl_eq constructor (Reduction.whd_all env t1) t2) "cannot solve (diff)" + if (eq_constr t1 t2) then sub else nochange ~t':(make_refl_eq constructor (Reductionops.whd_all env sigma t1) t2) "cannot solve (diff)" in let sub = compute_substitution Int.Map.empty (snd t1) (snd t2) in let sub = compute_substitution sub (fst t1) (fst t2) in - let end_of_type_with_pop = Termops.pop end_of_type in (*the equation will be removed *) + let end_of_type_with_pop = pop end_of_type in (*the equation will be removed *) let new_end_of_type = (* Ugly hack to prevent Map.fold order change between ocaml-3.08.3 and ocaml-3.08.4 Can be safely replaced by the next comment for Ocaml >= 3.08.4 *) let sub = Int.Map.bindings sub in - List.fold_left (fun end_of_type (i,t) -> lift 1 (substnl [t] (i-1) end_of_type)) + List.fold_left (fun end_of_type (i,t) -> liftn 1 i (substnl [t] (i-1) end_of_type)) end_of_type_with_pop sub in @@ -309,7 +315,7 @@ let change_eq env sigma hyp_id (context:Context.Rel.t) x t end_of_type = try let witness = Int.Map.find i sub in if is_local_def decl then anomaly (Pp.str "can not redefine a rel!"); - (Termops.pop end_of_type,ctxt_size,mkLetIn (RelDecl.get_name decl, witness, RelDecl.get_type decl, witness_fun)) + (pop end_of_type,ctxt_size,mkLetIn (RelDecl.get_name decl, witness, RelDecl.get_type decl, witness_fun)) with Not_found -> (mkProd_or_LetIn decl end_of_type, ctxt_size + 1, mkLambda_or_LetIn decl witness_fun) ) @@ -318,9 +324,9 @@ let change_eq env sigma hyp_id (context:Context.Rel.t) x t end_of_type = context in let new_type_of_hyp = - Reductionops.nf_betaiota Evd.empty new_type_of_hyp in + Reductionops.nf_betaiota sigma new_type_of_hyp in let new_ctxt,new_end_of_type = - decompose_prod_n_assum ctxt_size new_type_of_hyp + decompose_prod_n_assum sigma ctxt_size new_type_of_hyp in let prove_new_hyp : tactic = tclTHEN @@ -353,21 +359,21 @@ let change_eq env sigma hyp_id (context:Context.Rel.t) x t end_of_type = new_ctxt,new_end_of_type,simpl_eq_tac -let is_property (ptes_info:ptes_info) t_x full_type_of_hyp = - if isApp t_x +let is_property sigma (ptes_info:ptes_info) t_x full_type_of_hyp = + if isApp sigma t_x then - let pte,args = destApp t_x in - if isVar pte && Array.for_all closed0 args + let pte,args = destApp sigma t_x in + if isVar sigma pte && Array.for_all (closed0 sigma) args then try - let info = Id.Map.find (destVar pte) ptes_info in + let info = Id.Map.find (destVar sigma pte) ptes_info in info.is_valid full_type_of_hyp with Not_found -> false else false else false -let isLetIn t = - match kind_of_term t with +let isLetIn sigma t = + match EConstr.kind sigma t with | LetIn _ -> true | _ -> false @@ -387,8 +393,9 @@ let rewrite_until_var arg_num eq_ids : tactic = will break the Guard when trying to save the Lemma. *) let test_var g = - let _,args = destApp (pf_concl g) in - not ((isConstruct args.(arg_num)) || isAppConstruct args.(arg_num)) + let sigma = project g in + let _,args = destApp sigma (pf_concl g) in + not ((isConstruct sigma args.(arg_num)) || isAppConstruct sigma args.(arg_num)) in let rec do_rewrite eq_ids g = if test_var g @@ -407,30 +414,30 @@ let rewrite_until_var arg_num eq_ids : tactic = let rec_pte_id = Id.of_string "Hrec" let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = - let coq_False = Coqlib.build_coq_False () in - let coq_True = Coqlib.build_coq_True () in - let coq_I = Coqlib.build_coq_I () in + let coq_False = EConstr.of_constr (Coqlib.build_coq_False ()) in + let coq_True = EConstr.of_constr (Coqlib.build_coq_True ()) in + let coq_I = EConstr.of_constr (Coqlib.build_coq_I ()) in let rec scan_type context type_of_hyp : tactic = - if isLetIn type_of_hyp then + if isLetIn sigma type_of_hyp then let real_type_of_hyp = it_mkProd_or_LetIn type_of_hyp context in let reduced_type_of_hyp = nf_betaiotazeta real_type_of_hyp in (* length of context didn't change ? *) let new_context,new_typ_of_hyp = - decompose_prod_n_assum (List.length context) reduced_type_of_hyp + decompose_prod_n_assum sigma (List.length context) reduced_type_of_hyp in tclTHENLIST [ h_reduce_with_zeta (Locusops.onHyp hyp_id); scan_type new_context new_typ_of_hyp ] - else if isProd type_of_hyp + else if isProd sigma type_of_hyp then begin - let (x,t_x,t') = destProd type_of_hyp in + let (x,t_x,t') = destProd sigma type_of_hyp in let actual_real_type_of_hyp = it_mkProd_or_LetIn t' context in - if is_property ptes_infos t_x actual_real_type_of_hyp then + if is_property sigma ptes_infos t_x actual_real_type_of_hyp then begin - let pte,pte_args = (destApp t_x) in - let (* fix_info *) prove_rec_hyp = (Id.Map.find (destVar pte) ptes_infos).proving_tac in - let popped_t' = Termops.pop t' in + let pte,pte_args = (destApp sigma t_x) in + let (* fix_info *) prove_rec_hyp = (Id.Map.find (destVar sigma pte) ptes_infos).proving_tac in + let popped_t' = pop t' in let real_type_of_hyp = it_mkProd_or_LetIn popped_t' context in let prove_new_type_of_hyp = let context_length = List.length context in @@ -467,20 +474,20 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = scan_type context popped_t' ] end - else if eq_constr t_x coq_False then + else if eq_constr sigma t_x coq_False then begin (* observe (str "Removing : "++ Ppconstr.pr_id hyp_id++ *) (* str " since it has False in its preconds " *) (* ); *) raise TOREMOVE; (* False -> .. useless *) end - else if is_incompatible_eq t_x then raise TOREMOVE (* t_x := C1 ... = C2 ... *) - else if eq_constr t_x coq_True (* Trivial => we remove this precons *) + else if is_incompatible_eq sigma t_x then raise TOREMOVE (* t_x := C1 ... = C2 ... *) + else if eq_constr sigma t_x coq_True (* Trivial => we remove this precons *) then (* observe (str "In "++Ppconstr.pr_id hyp_id++ *) (* str " removing useless precond True" *) (* ); *) - let popped_t' = Termops.pop t' in + let popped_t' = pop t' in let real_type_of_hyp = it_mkProd_or_LetIn popped_t' context in @@ -506,15 +513,15 @@ let clean_hyp_with_heq ptes_infos eq_hyps hyp_id env sigma = ((* observe_tac "prove_trivial" *) prove_trivial); scan_type context popped_t' ] - else if is_trivial_eq t_x + else if is_trivial_eq sigma t_x then (* t_x := t = t => we remove this precond *) - let popped_t' = Termops.pop t' in + let popped_t' = pop t' in let real_type_of_hyp = it_mkProd_or_LetIn popped_t' context in - let hd,args = destApp t_x in + let hd,args = destApp sigma t_x in let get_args hd args = - if eq_constr hd (Lazy.force eq) + if eq_constr sigma hd (Lazy.force eq) then (Lazy.force refl_equal,args.(0),args.(1)) else (jmeq_refl (),args.(0),args.(1)) in @@ -597,18 +604,18 @@ let treat_new_case ptes_infos nb_prod continue_tac term dyn_infos = let new_term_value_eq = pf_unsafe_type_of g' (mkVar heq_id) in (* compute the new value of the body *) let new_term_value = - match kind_of_term new_term_value_eq with + match EConstr.kind (project g') new_term_value_eq with | App(f,[| _;_;args2 |]) -> args2 | _ -> observe (str "cannot compute new term value : " ++ pr_gls g' ++ fnl () ++ str "last hyp is" ++ - pr_lconstr_env (pf_env g') Evd.empty new_term_value_eq + pr_leconstr_env (pf_env g') (project g') new_term_value_eq ); anomaly (Pp.str "cannot compute new term value") in let fun_body = mkLambda(Anonymous, pf_unsafe_type_of g' term, - Termops.replace_term term (mkRel 1) dyn_infos.info + Termops.replace_term (project g') term (mkRel 1) dyn_infos.info ) in let new_body = pf_nf_betaiota g' (mkApp(fun_body,[| new_term_value |])) in @@ -691,15 +698,16 @@ let build_proof : tactic = let rec build_proof_aux do_finalize dyn_infos : tactic = fun g -> + let sigma = project g in (* observe (str "proving on " ++ Printer.pr_lconstr_env (pf_env g) term);*) - match kind_of_term dyn_infos.info with + match EConstr.kind sigma dyn_infos.info with | Case(ci,ct,t,cb) -> let do_finalize_t dyn_info' = fun g -> let t = dyn_info'.info in let dyn_infos = {dyn_info' with info = mkCase(ci,ct,t,cb)} in - let g_nb_prod = nb_prod (pf_concl g) in + let g_nb_prod = nb_prod (project g) (pf_concl g) in let type_of_term = pf_unsafe_type_of g t in let term_eq = make_refl_eq (Lazy.force refl_equal) type_of_term t @@ -712,7 +720,7 @@ let build_proof (fun g -> observe_tac "toto" ( tclTHENSEQ [Proofview.V82.of_tactic (Simple.case t); (fun g' -> - let g'_nb_prod = nb_prod (pf_concl g') in + let g'_nb_prod = nb_prod (project g') (pf_concl g') in let nb_instanciate_partial = g'_nb_prod - g_nb_prod in observe_tac "treat_new_case" (treat_new_case @@ -732,7 +740,7 @@ let build_proof build_proof do_finalize_t {dyn_infos with info = t} g | Lambda(n,t,b) -> begin - match kind_of_term( pf_concl g) with + match EConstr.kind sigma (pf_concl g) with | Prod _ -> tclTHEN (Proofview.V82.of_tactic intro) @@ -762,9 +770,9 @@ let build_proof | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ -> do_finalize dyn_infos g | App(_,_) -> - let f,args = decompose_app dyn_infos.info in + let f,args = decompose_app sigma dyn_infos.info in begin - match kind_of_term f with + match EConstr.kind sigma f with | App _ -> assert false (* we have collected all the app in decompose_app *) | Proj _ -> assert false (*FIXME*) | Var _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ | Sort _ | Prod _ -> @@ -786,7 +794,7 @@ let build_proof do_finalize dyn_infos g | Lambda _ -> let new_term = - Reductionops.nf_beta Evd.empty dyn_infos.info in + Reductionops.nf_beta sigma dyn_infos.info in build_proof do_finalize {dyn_infos with info = new_term} g | LetIn _ -> @@ -838,7 +846,7 @@ let build_proof | Rel _ -> anomaly (Pp.str "Free var in goal conclusion !") and build_proof do_finalize dyn_infos g = (* observe (str "proving with "++Printer.pr_lconstr dyn_infos.info++ str " on goal " ++ pr_gls g); *) - observe_tac_stream (str "build_proof with " ++ Printer.pr_lconstr dyn_infos.info ) (build_proof_aux do_finalize dyn_infos) g + observe_tac_stream (str "build_proof with " ++ Printer.pr_leconstr dyn_infos.info ) (build_proof_aux do_finalize dyn_infos) g and build_proof_args do_finalize dyn_infos (* f_args' args *) :tactic = fun g -> let (f_args',args) = dyn_infos.info in @@ -904,7 +912,7 @@ let prove_rec_hyp_for_struct fix_info = (fun eq_hyps -> tclTHEN (rewrite_until_var (fix_info.idx) eq_hyps) (fun g -> - let _,pte_args = destApp (pf_concl g) in + let _,pte_args = destApp (project g) (pf_concl g) in let rec_hyp_proof = mkApp(mkVar fix_info.name,array_get_start pte_args) in @@ -925,10 +933,11 @@ let generalize_non_dep hyp g = let to_revert,_ = let open Context.Named.Declaration in Environ.fold_named_context_reverse (fun (clear,keep) decl -> + let decl = map_named_decl EConstr.of_constr decl in let hyp = get_id decl in if Id.List.mem hyp hyps - || List.exists (Termops.occur_var_in_decl env hyp) keep - || Termops.occur_var env hyp hyp_typ + || List.exists (Termops.occur_var_in_decl env (project g) hyp) keep + || Termops.occur_var env (project g) hyp hyp_typ || Termops.is_section_variable hyp (* should be dangerous *) then (clear,decl::keep) else (hyp::clear,keep)) @@ -951,11 +960,12 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num (* observe (str "nb_args := " ++ str (string_of_int nb_args)); *) (* observe (str "nb_params := " ++ str (string_of_int nb_params)); *) (* observe (str "rec_args_num := " ++ str (string_of_int (rec_args_num + 1) )); *) - let f_def = Global.lookup_constant (fst (destConst f)) in + let f_def = Global.lookup_constant (fst (destConst evd f)) in let eq_lhs = mkApp(f,Array.init (nb_params + nb_args) (fun i -> mkRel(nb_params + nb_args - i))) in let f_body = Option.get (Global.body_of_constant_body f_def) in - let params,f_body_with_params = decompose_lam_n nb_params f_body in - let (_,num),(_,_,bodies) = destFix f_body_with_params in + let f_body = EConstr.of_constr f_body in + let params,f_body_with_params = decompose_lam_n evd nb_params f_body in + let (_,num),(_,_,bodies) = destFix evd f_body_with_params in let fnames_with_params = let params = Array.init nb_params (fun i -> mkRel(nb_params - i)) in let fnames = List.rev (Array.to_list (Array.map (fun f -> mkApp(f,params)) fnames)) in @@ -970,13 +980,13 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num let (type_ctxt,type_of_f),evd = let evd,t = Typing.type_of ~refresh:true (Global.env ()) evd f in - decompose_prod_n_assum + decompose_prod_n_assum evd (nb_params + nb_args) t,evd in let eqn = mkApp(Lazy.force eq,[|type_of_f;eq_lhs;eq_rhs|]) in let lemma_type = it_mkProd_or_LetIn eqn type_ctxt in (* Pp.msgnl (str "lemma type " ++ Printer.pr_lconstr lemma_type ++ fnl () ++ str "f_body " ++ Printer.pr_lconstr f_body); *) - let f_id = Label.to_id (con_label (fst (destConst f))) in + let f_id = Label.to_id (con_label (fst (destConst evd f))) in let prove_replacement = tclTHENSEQ [ @@ -1010,10 +1020,10 @@ let generate_equation_lemma evd fnames f fun_num nb_params nb_args rec_args_num let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num all_funs g = let equation_lemma = try - let finfos = find_Function_infos (fst (destConst f)) (*FIXME*) in + let finfos = find_Function_infos (fst (destConst !evd f)) (*FIXME*) in mkConst (Option.get finfos.equation_lemma) with (Not_found | Option.IsNone as e) -> - let f_id = Label.to_id (con_label (fst (destConst f))) in + let f_id = Label.to_id (con_label (fst (destConst !evd f))) in (*i The next call to mk_equation_id is valid since we will construct the lemma Ensures by: obvious i*) @@ -1022,7 +1032,7 @@ let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num a let _ = match e with | Option.IsNone -> - let finfos = find_Function_infos (fst (destConst f)) in + let finfos = find_Function_infos (fst (destConst !evd f)) in update_Function {finfos with equation_lemma = Some (match Nametab.locate (qualid_of_ident equation_lemma_id) with @@ -1038,11 +1048,12 @@ let do_replace (evd:Evd.evar_map ref) params rec_arg_num rev_args_id f fun_num a (Global.env ()) !evd (Constrintern.locate_reference (qualid_of_ident equation_lemma_id)) in + let res = EConstr.of_constr res in evd:=evd'; let _ = Typing.e_type_of ~refresh:true (Global.env ()) evd res in res in - let nb_intro_to_do = nb_prod (pf_concl g) in + let nb_intro_to_do = nb_prod (project g) (pf_concl g) in tclTHEN (tclDO nb_intro_to_do (Proofview.V82.of_tactic intro)) ( @@ -1061,7 +1072,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam (* 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 -> @@ -1090,11 +1101,11 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) (Global.env ()) (Evd.empty) - body + (EConstr.of_constr body) | None -> error ( "Cannot define a principle over an axiom ") in let fbody = get_body fnames.(fun_num) in - let f_ctxt,f_body = decompose_lam fbody in + let f_ctxt,f_body = decompose_lam (project g) fbody in let f_ctxt_length = List.length f_ctxt in let diff_params = princ_info.nparams - f_ctxt_length in let full_params,princ_params,fbody_with_full_params = @@ -1129,19 +1140,19 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam princ_params ); observe (str "fbody_with_full_params := " ++ - pr_lconstr fbody_with_full_params + pr_leconstr fbody_with_full_params ); let all_funs_with_full_params = Array.map (fun f -> applist(f, List.rev_map var_of_decl full_params)) all_funs in let fix_offset = List.length princ_params in let ptes_to_fix,infos = - match kind_of_term fbody_with_full_params with + match EConstr.kind (project g) fbody_with_full_params with | Fix((idxs,i),(names,typess,bodies)) -> let bodies_with_all_params = Array.map (fun body -> - Reductionops.nf_betaiota Evd.empty + Reductionops.nf_betaiota (project g) (applist(substl (List.rev (Array.to_list all_funs_with_full_params)) body, List.rev_map var_of_decl princ_params)) ) @@ -1150,14 +1161,14 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam let info_array = Array.mapi (fun i types -> - let types = prod_applist types (List.rev_map var_of_decl princ_params) in + let types = prod_applist (project g) types (List.rev_map var_of_decl princ_params) in { idx = idxs.(i) - fix_offset; name = Nameops.out_name (fresh_id names.(i)); types = types; offset = fix_offset; nb_realargs = List.length - (fst (decompose_lam bodies.(i))) - fix_offset; + (fst (decompose_lam (project g) bodies.(i))) - fix_offset; body_with_param = bodies_with_all_params.(i); num_in_block = i } @@ -1169,7 +1180,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam (fun i (acc_map,acc_info) decl -> let pte = RelDecl.get_name decl in let infos = info_array.(i) in - let type_args,_ = decompose_prod infos.types in + let type_args,_ = decompose_prod (project g) infos.types in let nargs = List.length type_args in let f = applist(mkConst fnames.(i), List.rev_map var_of_decl princ_info.params) in let first_args = Array.init nargs (fun i -> mkRel (nargs -i)) in @@ -1179,12 +1190,12 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam let body_with_param,num = let body = get_body fnames.(i) in let body_with_full_params = - Reductionops.nf_betaiota Evd.empty ( + Reductionops.nf_betaiota (project g) ( applist(body,List.rev_map var_of_decl full_params)) in - match kind_of_term body_with_full_params with + match EConstr.kind (project g) body_with_full_params with | Fix((_,num),(_,_,bs)) -> - Reductionops.nf_betaiota Evd.empty + Reductionops.nf_betaiota (project g) ( (applist (substl @@ -1217,7 +1228,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam let mk_fixes : tactic = let pre_info,infos = list_chop fun_num infos in match pre_info,infos with - | [],[] -> tclIDTAC + | _,[] -> tclIDTAC | _, this_fix_info::others_infos -> let other_fix_infos = List.map @@ -1233,7 +1244,6 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam else Proofview.V82.of_tactic (Tactics.mutual_fix this_fix_info.name (this_fix_info.idx + 1) other_fix_infos 0) - | _ -> anomaly (Pp.str "Not a valid information") in let first_tac : tactic = (* every operations until fix creations *) tclTHENSEQ @@ -1245,11 +1255,11 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam in let intros_after_fixes : tactic = fun gl -> - let ctxt,pte_app = (decompose_prod_assum (pf_concl gl)) in - let pte,pte_args = (decompose_app pte_app) in + let ctxt,pte_app = (decompose_prod_assum (project gl) (pf_concl gl)) in + let pte,pte_args = (decompose_app (project gl) pte_app) in try let pte = - try destVar pte + try destVar (project gl) pte with DestKO -> anomaly (Pp.str "Property is not a variable") in let fix_info = Id.Map.find pte ptes_to_fix in @@ -1268,7 +1278,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam nb_rec_hyps = -100; rec_hyps = []; info = - Reductionops.nf_betaiota Evd.empty + Reductionops.nf_betaiota (project g) (applist(fix_body,List.rev_map mkVar args_id)); eq_hyps = [] } @@ -1336,7 +1346,7 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam eq_hyps = [] } in - let fname = destConst (fst (decompose_app (List.hd (List.rev pte_args)))) in + let fname = destConst (project g) (fst (decompose_app (project g) (List.hd (List.rev pte_args)))) in tclTHENSEQ [Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst fname))]); let do_prove = @@ -1391,8 +1401,8 @@ let prove_princ_for_struct (evd:Evd.evar_map ref) interactive_proof fun_num fnam let prove_with_tcc tcc_lemma_constr eqs : tactic = match !tcc_lemma_constr with - | None -> anomaly (Pp.str "No tcc proof !!") - | Some lemma -> + | Undefined -> anomaly (Pp.str "No tcc proof !!") + | Value lemma -> fun gls -> (* let hid = next_ident_away_in_goal h_id (pf_ids_of_hyps gls) in *) (* let ids = hid::pf_ids_of_hyps gls in *) @@ -1410,7 +1420,7 @@ let prove_with_tcc tcc_lemma_constr eqs : tactic = Proofview.V82.of_tactic (Eauto.gen_eauto (false,5) [] (Some [])) ] gls - + | Not_needed -> tclIDTAC let backtrack_eqs_until_hrec hrec eqs : tactic = fun gls -> @@ -1418,14 +1428,14 @@ let backtrack_eqs_until_hrec hrec eqs : tactic = let rewrite = tclFIRST (List.map (fun x -> Proofview.V82.of_tactic (Equality.rewriteRL x)) eqs ) in - let _,hrec_concl = decompose_prod (pf_unsafe_type_of gls (mkVar hrec)) in - let f_app = Array.last (snd (destApp hrec_concl)) in - let f = (fst (destApp f_app)) in + let _,hrec_concl = decompose_prod (project gls) (pf_unsafe_type_of gls (mkVar hrec)) in + let f_app = Array.last (snd (destApp (project gls) hrec_concl)) in + let f = (fst (destApp (project gls) f_app)) in let rec backtrack : tactic = fun g -> - let f_app = Array.last (snd (destApp (pf_concl g))) in - match kind_of_term f_app with - | App(f',_) when eq_constr f' f -> tclIDTAC g + let f_app = Array.last (snd (destApp (project g) (pf_concl g))) in + match EConstr.kind (project g) f_app with + | App(f',_) when eq_constr (project g) f' f -> tclIDTAC g | _ -> tclTHEN rewrite backtrack g in backtrack gls @@ -1489,20 +1499,20 @@ let new_prove_with_tcc is_mes acc_inv hrec tcc_hyps eqs : tactic = gls -let is_valid_hypothesis predicates_name = +let is_valid_hypothesis sigma predicates_name = let predicates_name = List.fold_right Id.Set.add predicates_name Id.Set.empty in let is_pte typ = - if isApp typ + if isApp sigma typ then - let pte,_ = destApp typ in - if isVar pte - then Id.Set.mem (destVar pte) predicates_name + let pte,_ = destApp sigma typ in + if isVar sigma pte + then Id.Set.mem (destVar sigma pte) predicates_name else false else false in let rec is_valid_hypothesis typ = is_pte typ || - match kind_of_term typ with + match EConstr.kind sigma typ with | Prod(_,pte,typ') -> is_pte pte && is_valid_hypothesis typ' | _ -> false in @@ -1512,7 +1522,7 @@ 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_info = compute_elim_sig (project gl) princ_type in let fresh_id = let avoid = ref (pf_ids_of_hyps gl) in fun na -> @@ -1589,8 +1599,9 @@ let prove_principle_for_gen let args_ids = List.map (get_name %> Nameops.out_name) princ_info.args in let lemma = match !tcc_lemma_ref with - | None -> error "No tcc proof !!" - | Some lemma -> lemma + | Undefined -> error "No tcc proof !!" + | Value lemma -> EConstr.of_constr lemma + | Not_needed -> EConstr.of_constr (Coqlib.build_coq_I ()) in (* let rec list_diff del_list check_list = *) (* match del_list with *) @@ -1650,7 +1661,7 @@ let prove_principle_for_gen Proofview.V82.of_tactic (Equality.rewriteLR (mkConst eq_ref)); (* observe_tac "finish" *) (fun gl' -> let body = - let _,args = destApp (pf_concl gl') in + let _,args = destApp (project gl') (pf_concl gl') in Array.last args in let body_info rec_hyps = @@ -1693,7 +1704,7 @@ let prove_principle_for_gen ) ); - is_valid = is_valid_hypothesis predicates_names + is_valid = is_valid_hypothesis (project gl') predicates_names } in let ptes_info : pte_info Id.Map.t = diff --git a/plugins/funind/functional_principles_proofs.mli b/plugins/funind/functional_principles_proofs.mli index 34ce66967..7ddc84d01 100644 --- a/plugins/funind/functional_principles_proofs.mli +++ b/plugins/funind/functional_principles_proofs.mli @@ -4,16 +4,16 @@ open Term val prove_princ_for_struct : Evd.evar_map ref -> bool -> - int -> constant array -> constr array -> int -> Tacmach.tactic + int -> constant array -> EConstr.constr array -> int -> Tacmach.tactic val prove_principle_for_gen : constant*constant*constant -> (* name of the function, the functional and the fixpoint equation *) - constr option ref -> (* a pointer to the obligation proofs lemma *) + Indfun_common.tcc_lemma_value ref -> (* a pointer to the obligation proofs lemma *) bool -> (* is that function uses measure *) int -> (* the number of recursive argument *) - types -> (* the type of the recursive argument *) - constr -> (* the wf relation used to prove the function *) + EConstr.types -> (* the type of the recursive argument *) + EConstr.constr -> (* the wf relation used to prove the function *) Tacmach.tactic diff --git a/plugins/funind/functional_principles_types.ml b/plugins/funind/functional_principles_types.ml index cc699e5d3..529b91c4c 100644 --- a/plugins/funind/functional_principles_types.ml +++ b/plugins/funind/functional_principles_types.ml @@ -23,16 +23,19 @@ let observe s = if do_observe () then Feedback.msg_debug s +let pop t = Vars.lift (-1) t + (* Transform an inductive induction principle into 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 env_with_params = EConstr.push_rel_context princ_type_info.params env in let tbl = Hashtbl.create 792 in - let rec change_predicates_names (avoid:Id.t list) (predicates:Context.Rel.t) : Context.Rel.t = + let rec change_predicates_names (avoid:Id.t list) (predicates:EConstr.rel_context) : EConstr.rel_context = match predicates with | [] -> [] | decl :: predicates -> @@ -53,14 +56,14 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = (* observe (str "princ_infos : " ++ pr_elim_scheme princ_type_info); *) let change_predicate_sort i decl = let new_sort = sorts.(i) in - let args,_ = decompose_prod (RelDecl.get_type decl) in + let args,_ = decompose_prod (EConstr.Unsafe.to_constr (RelDecl.get_type decl)) in let real_args = if princ_type_info.indarg_in_concl then List.tl args else args in Context.Named.Declaration.LocalAssum (Nameops.out_name (Context.Rel.Declaration.get_name decl), - compose_prod real_args (mkSort new_sort)) + Term.compose_prod real_args (mkSort new_sort)) in let new_predicates = List.map_i @@ -84,6 +87,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = | _ -> false in let pre_princ = + let open EConstr in it_mkProd_or_LetIn (it_mkProd_or_LetIn (Option.fold_right @@ -95,6 +99,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = ) princ_type_info.branches in + let pre_princ = EConstr.Unsafe.to_constr pre_princ in let pre_princ = substl (List.map mkVar ptes_vars) pre_princ in let is_dom c = match kind_of_term c with @@ -110,7 +115,7 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = in let dummy_var = mkVar (Id.of_string "________") in let mk_replacement c i args = - let res = mkApp(rel_to_fun.(i), Array.map Termops.pop (array_get_start args)) in + let res = mkApp(rel_to_fun.(i), Array.map pop (array_get_start args)) in observe (str "replacing " ++ pr_lconstr c ++ str " by " ++ pr_lconstr res); res in @@ -168,25 +173,25 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let new_env = Environ.push_rel (LocalAssum (x,t)) env in let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b - then (Termops.pop new_b), filter_map (eq_constr (mkRel 1)) Termops.pop binders_to_remove_from_b + then (pop new_b), filter_map (eq_constr (mkRel 1)) pop binders_to_remove_from_b else ( bind_fun(new_x,new_t,new_b), list_union_eq eq_constr binders_to_remove_from_t - (List.map Termops.pop binders_to_remove_from_b) + (List.map pop binders_to_remove_from_b) ) with | Toberemoved -> (* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b) in - new_b, List.map Termops.pop binders_to_remove_from_b + new_b, List.map pop binders_to_remove_from_b | Toberemoved_with_rel (n,c) -> (* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b) in - new_b, list_add_set_eq eq_constr (mkRel n) (List.map Termops.pop binders_to_remove_from_b) + new_b, list_add_set_eq eq_constr (mkRel n) (List.map pop binders_to_remove_from_b) end and compute_new_princ_type_for_letin remove env x v t b = begin @@ -197,25 +202,25 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = let new_env = Environ.push_rel (LocalDef (x,v,t)) env in let new_b,binders_to_remove_from_b = compute_new_princ_type remove new_env b in if List.exists (eq_constr (mkRel 1)) binders_to_remove_from_b - then (Termops.pop new_b),filter_map (eq_constr (mkRel 1)) Termops.pop binders_to_remove_from_b + then (pop new_b),filter_map (eq_constr (mkRel 1)) pop binders_to_remove_from_b else ( mkLetIn(new_x,new_v,new_t,new_b), list_union_eq eq_constr (list_union_eq eq_constr binders_to_remove_from_t binders_to_remove_from_v) - (List.map Termops.pop binders_to_remove_from_b) + (List.map pop binders_to_remove_from_b) ) with | Toberemoved -> (* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [dummy_var] 1 b) in - new_b, List.map Termops.pop binders_to_remove_from_b + new_b, List.map pop binders_to_remove_from_b | Toberemoved_with_rel (n,c) -> (* observe (str "Decl of "++Ppconstr.pr_name x ++ str " is removed "); *) let new_b,binders_to_remove_from_b = compute_new_princ_type remove env (substnl [c] n b) in - new_b, list_add_set_eq eq_constr (mkRel n) (List.map Termops.pop binders_to_remove_from_b) + new_b, list_add_set_eq eq_constr (mkRel n) (List.map pop binders_to_remove_from_b) end and compute_new_princ_type_with_acc remove env e (c_acc,to_remove_acc) = let new_e,to_remove_from_e = compute_new_princ_type remove env e @@ -237,20 +242,21 @@ let compute_new_princ_type_from_rel rel_to_fun sorts princ_type = | Context.Named.Declaration.LocalDef (id,t,b) -> LocalDef (Name (Hashtbl.find tbl id), t, b)) new_predicates) ) - princ_type_info.params + (List.map (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) princ_type_info.params) 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, - let args,ty = decompose_prod (get_type decl) in + let args,ty = decompose_prod (EConstr.Unsafe.to_constr (get_type decl)) in let s = destSort ty in Global.add_constraints (Univ.enforce_leq (univ_of_sort toSort) (univ_of_sort s) Univ.Constraint.empty); - compose_prod args (mkSort toSort) + Term.compose_prod args (mkSort toSort) ) in let evd,princName_as_constr = @@ -266,11 +272,11 @@ let change_property_sort evd toSort princ princName = (it_mkLambda_or_LetIn init (List.map change_sort_in_predicate princ_info.predicates) ) - princ_info.params + (List.map (fun d -> Termops.map_rel_decl EConstr.Unsafe.to_constr d) princ_info.params) 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 @@ -283,18 +289,19 @@ let build_functional_principle (evd:Evd.evar_map ref) interactive_proof old_prin let new_princ_name = next_ident_away_in_goal (Id.of_string "___________princ_________") [] in - let _ = Typing.e_type_of ~refresh:true (Global.env ()) evd new_principle_type in + let _ = Typing.e_type_of ~refresh:true (Global.env ()) evd (EConstr.of_constr new_principle_type) in let hook = Lemmas.mk_hook (hook new_principle_type) in begin Lemmas.start_proof new_princ_name (Decl_kinds.Global,Flags.is_universe_polymorphism (),(Decl_kinds.Proof Decl_kinds.Theorem)) !evd - new_principle_type + (EConstr.of_constr new_principle_type) hook ; (* let _tim1 = System.get_time () in *) - ignore (Pfedit.by (Proofview.V82.tactic (proof_tac (Array.map mkConstU funs) mutr_nparams))); + let map (c, u) = EConstr.mkConstU (c, EConstr.EInstance.make u) in + ignore (Pfedit.by (Proofview.V82.tactic (proof_tac (Array.map map funs) mutr_nparams))); (* let _tim2 = System.get_time () in *) (* begin *) (* let dur1 = System.time_difference tim1 tim2 in *) @@ -337,7 +344,7 @@ let generate_functional_principle (evd: Evd.evar_map ref) let evd',s = Evd.fresh_sort_in_family env evd' fam_sort in let name = Indrec.make_elimination_ident base_new_princ_name fam_sort in let evd',value = change_property_sort evd' s new_principle_type new_princ_name in - let evd' = fst (Typing.type_of ~refresh:true (Global.env ()) evd' value) in + let evd' = fst (Typing.type_of ~refresh:true (Global.env ()) evd' (EConstr.of_constr value)) in (* Pp.msgnl (str "new principle := " ++ pr_lconstr value); *) let ce = Declare.definition_entry ~poly:(Flags.is_universe_polymorphism ()) ~univs:(snd (Evd.universe_context evd')) value in ignore( @@ -405,8 +412,9 @@ let get_funs_constant mp dp = (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) (Global.env ()) (Evd.from_env (Global.env ())) - body + (EConstr.of_constr body) in + let body = EConstr.Unsafe.to_constr body in body | None -> error ( "Cannot define a principle over an axiom ") in @@ -488,7 +496,7 @@ let make_scheme evd (fas : (pconstant*glob_sort) list) : Safe_typing.private_con in let _ = evd := sigma in let l_schemes = - List.map (Typing.unsafe_type_of env sigma) schemes + List.map (EConstr.of_constr %> Typing.unsafe_type_of env sigma %> EConstr.Unsafe.to_constr) schemes in let i = ref (-1) in let sorts = @@ -616,7 +624,7 @@ let build_scheme fas = in let evd',f = Evd.fresh_global (Global.env ()) !evd f_as_constant in let _ = evd := evd' in - let _ = Typing.e_type_of ~refresh:true (Global.env ()) evd f in + let _ = Typing.e_type_of ~refresh:true (Global.env ()) evd (EConstr.of_constr f) in (destConst f,sort) ) fas @@ -666,7 +674,7 @@ let build_case_scheme fa = Indrec.build_case_analysis_scheme_default env sigma ind sf in let sigma = Sigma.to_evar_map sigma in - let scheme_type = (Typing.unsafe_type_of env sigma ) scheme in + let scheme_type = EConstr.Unsafe.to_constr ((Typing.unsafe_type_of env sigma) (EConstr.of_constr scheme)) in let sorts = (fun (_,_,x) -> Universes.new_sort_in_family (Pretyping.interp_elimination_sort x) diff --git a/plugins/funind/functional_principles_types.mli b/plugins/funind/functional_principles_types.mli index 3fa2644ca..45ad332fc 100644 --- a/plugins/funind/functional_principles_types.mli +++ b/plugins/funind/functional_principles_types.mli @@ -27,7 +27,7 @@ val generate_functional_principle : (* The tactic to use to make the proof w.r the number of params *) - (constr array -> int -> Tacmach.tactic) -> + (EConstr.constr array -> int -> Tacmach.tactic) -> unit val compute_new_princ_type_from_rel : constr array -> sorts array -> diff --git a/plugins/funind/g_indfun.ml4 b/plugins/funind/g_indfun.ml4 index 6603a95a8..0dccd25d7 100644 --- a/plugins/funind/g_indfun.ml4 +++ b/plugins/funind/g_indfun.ml4 @@ -6,7 +6,7 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) (*i camlp4deps: "grammar/grammar.cma" i*) -open Compat +open Ltac_plugin open Util open Term open Pp @@ -16,6 +16,7 @@ open Indfun open Genarg open Stdarg open Misctypes +open Pcoq open Pcoq.Prim open Pcoq.Constr open Pltac @@ -97,7 +98,8 @@ ARGUMENT EXTEND with_names TYPED AS intropattern_opt PRINTED BY pr_intro_as_pat | [] ->[ None ] END - +let functional_induction b c x pat = + Proofview.V82.tactic (functional_induction true c x (Option.map out_disjunctive pat)) TACTIC EXTEND newfunind @@ -106,9 +108,9 @@ TACTIC EXTEND newfunind let c = match cl with | [] -> assert false | [c] -> c - | c::cl -> applist(c,cl) + | c::cl -> EConstr.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 @@ -117,9 +119,9 @@ TACTIC EXTEND snewfunind let c = match cl with | [] -> assert false | [c] -> c - | c::cl -> applist(c,cl) + | c::cl -> EConstr.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/glob_term_to_relation.ml b/plugins/funind/glob_term_to_relation.ml index de2e5ea4e..7dc869131 100644 --- a/plugins/funind/glob_term_to_relation.ml +++ b/plugins/funind/glob_term_to_relation.ml @@ -42,7 +42,7 @@ let compose_glob_context = match bt with | Lambda n -> mkGLambda(n,t,acc) | Prod n -> mkGProd(n,t,acc) - | LetIn n -> mkGLetIn(n,t,acc) + | LetIn n -> mkGLetIn(n,t,None,acc) in List.fold_right compose_binder @@ -352,7 +352,7 @@ let add_pat_variables pat typ env : Environ.env = | PatVar(_,na) -> Environ.push_rel (RelDecl.LocalAssum (na,typ)) env | PatCstr(_,c,patl,na) -> let Inductiveops.IndType(indf,indargs) = - try Inductiveops.find_rectype env (Evd.from_env env) typ + try Inductiveops.find_rectype env (Evd.from_env env) (EConstr.of_constr typ) with Not_found -> assert false in let constructors = Inductiveops.get_constructors env indf in @@ -409,7 +409,7 @@ let rec pattern_to_term_and_type env typ = function constr in let Inductiveops.IndType(indf,indargs) = - try Inductiveops.find_rectype env (Evd.from_env env) typ + try Inductiveops.find_rectype env (Evd.from_env env) (EConstr.of_constr typ) with Not_found -> assert false in let constructors = Inductiveops.get_constructors env indf in @@ -421,7 +421,7 @@ let rec pattern_to_term_and_type env typ = function Array.to_list (Array.init (cst_narg - List.length patternl) - (fun i -> Detyping.detype false [] env (Evd.from_env env) csta.(i)) + (fun i -> Detyping.detype false [] env (Evd.from_env env) (EConstr.of_constr csta.(i))) ) in let patl_as_term = @@ -489,7 +489,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = | u::l -> match t with | GLambda(loc,na,_,nat,b) -> - GLetIn(Loc.ghost,na,u,aux b l) + GLetIn(Loc.ghost,na,u,None,aux b l) | _ -> GApp(Loc.ghost,t,l) in @@ -503,7 +503,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = The "value" of this branch is then simply [res] *) let rt_as_constr,ctx = Pretyping.understand env (Evd.from_env env) rt in - let rt_typ = Typing.unsafe_type_of env (Evd.from_env env) rt_as_constr in + let rt_typ = Typing.unsafe_type_of env (Evd.from_env env) (EConstr.of_constr rt_as_constr) in let res_raw_type = Detyping.detype false [] env (Evd.from_env env) rt_typ in let res = fresh_id args_res.to_avoid "_res" in let new_avoid = res::args_res.to_avoid in @@ -535,7 +535,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = args_res.result } | GApp _ -> assert false (* we have collected all the app in [glob_decompose_app] *) - | GLetIn(_,n,t,b) -> + | GLetIn(_,n,v,t,b) -> (* if we have [(let x := v in b) t1 ... tn] , we discard our work and compute the list of constructor for [let x = v in (b t1 ... tn)] up to alpha conversion @@ -559,7 +559,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = env funnames avoid - (mkGLetIn(new_n,t,mkGApp(new_b,args))) + (mkGLetIn(new_n,v,t,mkGApp(new_b,args))) | GCases _ | GIf _ | GLetTuple _ -> (* we have [(match e1, ...., en with ..... end) t1 tn] we first compute the result from the case and @@ -603,15 +603,17 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = let new_env = raw_push_named (n,None,t) env in let b_res = build_entry_lc new_env funnames avoid b in combine_results (combine_prod n) t_res b_res - | GLetIn(_,n,v,b) -> + | GLetIn(loc,n,v,typ,b) -> (* we first compute the list of constructor corresponding to the body of the function, then the one corresponding to the value [t] and combine the two result *) + let v = match typ with None -> v | Some t -> GCast (loc,v,CastConv t) in let v_res = build_entry_lc env funnames avoid v in let v_as_constr,ctx = Pretyping.understand env (Evd.from_env env) v in - let v_type = Typing.unsafe_type_of env (Evd.from_env env) v_as_constr in + let v_type = Typing.unsafe_type_of env (Evd.from_env env) (EConstr.of_constr v_as_constr) in + let v_type = EConstr.Unsafe.to_constr v_type in let new_env = match n with Anonymous -> env @@ -627,7 +629,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = build_entry_lc_from_case env funnames make_discr el brl avoid | GIf(_,b,(na,e_option),lhs,rhs) -> let b_as_constr,ctx = Pretyping.understand env (Evd.from_env env) b in - let b_typ = Typing.unsafe_type_of env (Evd.from_env env) b_as_constr in + let b_typ = Typing.unsafe_type_of env (Evd.from_env env) (EConstr.of_constr b_as_constr) in let (ind,_) = try Inductiveops.find_inductive env (Evd.from_env env) b_typ with Not_found -> @@ -659,7 +661,7 @@ let rec build_entry_lc env funnames avoid rt : glob_constr build_entry_return = nal in let b_as_constr,ctx = Pretyping.understand env (Evd.from_env env) b in - let b_typ = Typing.unsafe_type_of env (Evd.from_env env) b_as_constr in + let b_typ = Typing.unsafe_type_of env (Evd.from_env env) (EConstr.of_constr b_as_constr) in let (ind,_) = try Inductiveops.find_inductive env (Evd.from_env env) b_typ with Not_found -> @@ -706,7 +708,7 @@ and build_entry_lc_from_case env funname make_discr let types = List.map (fun (case_arg,_) -> let case_arg_as_constr,ctx = Pretyping.understand env (Evd.from_env env) case_arg in - Typing.unsafe_type_of env (Evd.from_env env) case_arg_as_constr + EConstr.Unsafe.to_constr (Typing.unsafe_type_of env (Evd.from_env env) (EConstr.of_constr case_arg_as_constr)) ) el in (****** The next works only if the match is not dependent ****) @@ -753,7 +755,7 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve List.fold_right (fun id acc -> let typ_of_id = - Typing.unsafe_type_of env_with_pat_ids (Evd.from_env env) (mkVar id) + Typing.unsafe_type_of env_with_pat_ids (Evd.from_env env) (EConstr.mkVar id) in let raw_typ_of_id = Detyping.detype false [] @@ -801,13 +803,14 @@ and build_entry_lc_from_case_term env types funname make_discr patterns_to_preve List.map3 (fun pat e typ_as_constr -> let this_pat_ids = ids_of_pat pat in + let typ_as_constr = EConstr.of_constr typ_as_constr in let typ = Detyping.detype false [] new_env (Evd.from_env env) typ_as_constr in let pat_as_term = pattern_to_term pat in List.fold_right (fun id acc -> if Id.Set.mem id this_pat_ids then (Prod (Name id), - let typ_of_id = Typing.unsafe_type_of new_env (Evd.from_env env) (mkVar id) in + let typ_of_id = Typing.unsafe_type_of new_env (Evd.from_env env) (EConstr.mkVar id) in let raw_typ_of_id = Detyping.detype false [] new_env (Evd.from_env env) typ_of_id in @@ -952,7 +955,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = in mkGProd(n,t,new_b),id_to_exclude with Continue -> - let jmeq = Globnames.IndRef (fst (destInd (jmeq ()))) in + let jmeq = Globnames.IndRef (fst (EConstr.destInd Evd.empty (jmeq ()))) in let ty',ctx = Pretyping.understand env (Evd.from_env env) ty in let ind,args' = Inductive.find_inductive env ty' in let mib,_ = Global.lookup_inductive (fst ind) in @@ -966,7 +969,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = (List.map (fun p -> Detyping.detype false [] env (Evd.from_env env) - p) params)@(Array.to_list + (EConstr.of_constr p)) params)@(Array.to_list (Array.make (List.length args' - nparam) (mkGHole ())))) @@ -984,6 +987,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = let ty' = snd (Util.List.chop nparam ty) in List.fold_left2 (fun acc var_as_constr arg -> + let arg = EConstr.of_constr arg in if isRel var_as_constr then let na = RelDecl.get_name (Environ.lookup_rel (destRel var_as_constr) env) in @@ -1115,13 +1119,15 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = (* We have renamed all the anonymous functions during alpha_renaming phase *) end - | GLetIn(_,n,t,b) -> + | GLetIn(loc,n,v,t,b) -> begin + let t = match t with None -> v | Some t -> GCast (loc,v,CastConv t) in let not_free_in_t id = not (is_free_in id t) in let evd = (Evd.from_env env) in let t',ctx = Pretyping.understand env evd t in let evd = Evd.from_ctx ctx in - let type_t' = Typing.unsafe_type_of env evd t' in + let type_t' = Typing.unsafe_type_of env evd (EConstr.of_constr t') in + let type_t' = EConstr.Unsafe.to_constr type_t' in let new_env = Environ.push_rel (LocalDef (n,t',type_t')) env in let new_b,id_to_exclude = rebuild_cons new_env @@ -1131,7 +1137,7 @@ let rec rebuild_cons env nb_args relname args crossed_types depth rt = match n with | Name id when Id.Set.mem id id_to_exclude && depth >= nb_args -> new_b,Id.Set.remove id (Id.Set.filter not_free_in_t id_to_exclude) - | _ -> GLetIn(Loc.ghost,n,t,new_b), + | _ -> GLetIn(Loc.ghost,n,t,None,new_b), (* HOPING IT WOULD WORK *) Id.Set.filter not_free_in_t id_to_exclude end | GLetTuple(_,nal,(na,rto),t,b) -> @@ -1189,9 +1195,13 @@ let rec compute_cst_params relnames params = function compute_cst_params_from_app [] (params,rtl) | GApp(_,f,args) -> List.fold_left (compute_cst_params relnames) params (f::args) - | GLambda(_,_,_,t,b) | GProd(_,_,_,t,b) | GLetIn(_,_,t,b) | GLetTuple(_,_,_,t,b) -> + | GLambda(_,_,_,t,b) | GProd(_,_,_,t,b) | GLetTuple(_,_,_,t,b) -> let t_params = compute_cst_params relnames params t in compute_cst_params relnames t_params b + | GLetIn(_,_,v,t,b) -> + let v_params = compute_cst_params relnames params v in + let t_params = Option.fold_left (compute_cst_params relnames) v_params t in + compute_cst_params relnames t_params b | GCases _ -> params (* If there is still cases at this point they can only be discrimination ones *) @@ -1202,12 +1212,12 @@ let rec compute_cst_params relnames params = function and compute_cst_params_from_app acc (params,rtl) = match params,rtl with | _::_,[] -> assert false (* the rel has at least nargs + 1 arguments ! *) - | ((Name id,_,is_defined) as param)::params',(GVar(_,id'))::rtl' - when Id.compare id id' == 0 && not is_defined -> + | ((Name id,_,None) as param)::params',(GVar(_,id'))::rtl' + when Id.compare id id' == 0 -> compute_cst_params_from_app (param::acc) (params',rtl') | _ -> List.rev acc -let compute_params_name relnames (args : (Name.t * Glob_term.glob_constr * bool) list array) csts = +let compute_params_name relnames (args : (Name.t * Glob_term.glob_constr * glob_constr option) list array) csts = let rels_params = Array.mapi (fun i args -> @@ -1222,11 +1232,11 @@ let compute_params_name relnames (args : (Name.t * Glob_term.glob_constr * bool) let _ = try List.iteri - (fun i ((n,nt,is_defined) as param) -> + (fun i ((n,nt,typ) as param) -> if Array.for_all (fun l -> - let (n',nt',is_defined') = List.nth l i in - Name.equal n n' && glob_constr_eq nt nt' && (is_defined : bool) == is_defined') + let (n',nt',typ') = List.nth l i in + Name.equal n n' && glob_constr_eq nt nt' && Option.equal glob_constr_eq typ typ') rels_params then l := param::!l @@ -1241,15 +1251,15 @@ let rec rebuild_return_type rt = match rt with | Constrexpr.CProdN(loc,n,t') -> Constrexpr.CProdN(loc,n,rebuild_return_type t') - | Constrexpr.CLetIn(loc,na,t,t') -> - Constrexpr.CLetIn(loc,na,t,rebuild_return_type t') + | Constrexpr.CLetIn(loc,na,v,t,t') -> + Constrexpr.CLetIn(loc,na,v,t,rebuild_return_type t') | _ -> Constrexpr.CProdN(Loc.ghost,[[Loc.ghost,Anonymous], Constrexpr.Default Decl_kinds.Explicit,rt], Constrexpr.CSort(Loc.ghost,GType [])) let do_build_inductive - evd (funconstants: Term.pconstant list) (funsargs: (Name.t * glob_constr * bool) list list) + evd (funconstants: Term.pconstant list) (funsargs: (Name.t * glob_constr * glob_constr option) list list) returned_types (rtl:glob_constr list) = let _time1 = System.get_time () in @@ -1271,8 +1281,10 @@ let do_build_inductive let open Context.Named.Declaration in let evd,env = Array.fold_right2 - (fun id c (evd,env) -> - let evd,t = Typing.type_of env evd (mkConstU c) in + (fun id (c, u) (evd,env) -> + let u = EConstr.EInstance.make u in + let evd,t = Typing.type_of env evd (EConstr.mkConstU (c, u)) in + let t = EConstr.Unsafe.to_constr t in evd, Environ.push_named (LocalAssum (id,t)) (* try *) @@ -1288,16 +1300,17 @@ let do_build_inductive let resa = Array.map (build_entry_lc env funnames_as_set []) rta in let env_with_graphs = let rel_arity i funargs = (* Rebuilding arities (with parameters) *) - let rel_first_args :(Name.t * Glob_term.glob_constr * bool ) list = + let rel_first_args :(Name.t * Glob_term.glob_constr * Glob_term.glob_constr option ) list = funargs in List.fold_right - (fun (n,t,is_defined) acc -> - if is_defined - then + (fun (n,t,typ) acc -> + match typ with + | Some typ -> Constrexpr.CLetIn(Loc.ghost,(Loc.ghost, n),with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t, + Some (with_full_print (Constrextern.extern_glob_constr Id.Set.empty) typ), acc) - else + | None -> Constrexpr.CProdN (Loc.ghost, [[(Loc.ghost,n)],Constrexpr_ops.default_binder_kind,with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t], @@ -1355,16 +1368,17 @@ let do_build_inductive rel_constructors in let rel_arity i funargs = (* Reduilding arities (with parameters) *) - let rel_first_args :(Name.t * Glob_term.glob_constr * bool ) list = + let rel_first_args :(Name.t * Glob_term.glob_constr * Glob_term.glob_constr option ) list = (snd (List.chop nrel_params funargs)) in List.fold_right - (fun (n,t,is_defined) acc -> - if is_defined - then + (fun (n,t,typ) acc -> + match typ with + | Some typ -> Constrexpr.CLetIn(Loc.ghost,(Loc.ghost, n),with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t, + Some (with_full_print (Constrextern.extern_glob_constr Id.Set.empty) typ), acc) - else + | None -> Constrexpr.CProdN (Loc.ghost, [[(Loc.ghost,n)],Constrexpr_ops.default_binder_kind,with_full_print (Constrextern.extern_glob_constr Id.Set.empty) t], @@ -1391,12 +1405,13 @@ let do_build_inductive in let rel_params = List.map - (fun (n,t,is_defined) -> - if is_defined - then - Constrexpr.LocalRawDef((Loc.ghost,n), Constrextern.extern_glob_constr Id.Set.empty t) - else - Constrexpr.LocalRawAssum + (fun (n,t,typ) -> + match typ with + | Some typ -> + Constrexpr.CLocalDef((Loc.ghost,n), Constrextern.extern_glob_constr Id.Set.empty t, + Some (with_full_print (Constrextern.extern_glob_constr Id.Set.empty) typ)) + | None -> + Constrexpr.CLocalAssum ([(Loc.ghost,n)], Constrexpr_ops.default_binder_kind, Constrextern.extern_glob_constr Id.Set.empty t) ) rels_params diff --git a/plugins/funind/glob_term_to_relation.mli b/plugins/funind/glob_term_to_relation.mli index 5bb1376e2..0cab5a6d3 100644 --- a/plugins/funind/glob_term_to_relation.mli +++ b/plugins/funind/glob_term_to_relation.mli @@ -12,7 +12,7 @@ val build_inductive : *) Evd.evar_map -> Term.pconstant list -> - (Name.t*Glob_term.glob_constr*bool) list list -> (* The list of function args *) + (Name.t*Glob_term.glob_constr*Glob_term.glob_constr option) list list -> (* The list of function args *) Constrexpr.constr_expr list -> (* The list of function returned type *) Glob_term.glob_constr list -> (* the list of body *) unit diff --git a/plugins/funind/glob_termops.ml b/plugins/funind/glob_termops.ml index 4e561fc7e..99f50437b 100644 --- a/plugins/funind/glob_termops.ml +++ b/plugins/funind/glob_termops.ml @@ -15,7 +15,7 @@ let mkGVar id = GVar(Loc.ghost,id) let mkGApp(rt,rtl) = GApp(Loc.ghost,rt,rtl) let mkGLambda(n,t,b) = GLambda(Loc.ghost,n,Explicit,t,b) let mkGProd(n,t,b) = GProd(Loc.ghost,n,Explicit,t,b) -let mkGLetIn(n,t,b) = GLetIn(Loc.ghost,n,t,b) +let mkGLetIn(n,b,t,c) = GLetIn(Loc.ghost,n,b,t,c) let mkGCases(rto,l,brl) = GCases(Loc.ghost,Term.RegularStyle,rto,l,brl) let mkGSort s = GSort(Loc.ghost,s) let mkGHole () = GHole(Loc.ghost,Evar_kinds.BinderType Anonymous,Misctypes.IntroAnonymous,None) @@ -37,8 +37,8 @@ let glob_decompose_prod_or_letin = let rec glob_decompose_prod args = function | GProd(_,n,k,t,b) -> glob_decompose_prod ((n,None,Some t)::args) b - | GLetIn(_,n,t,b) -> - glob_decompose_prod ((n,Some t,None)::args) b + | GLetIn(_,n,b,t,c) -> + glob_decompose_prod ((n,Some b,t)::args) c | rt -> args,rt in glob_decompose_prod [] @@ -51,7 +51,7 @@ let glob_compose_prod_or_letin = fun concl decl -> match decl with | (n,None,Some t) -> mkGProd(n,t,concl) - | (n,Some bdy,None) -> mkGLetIn(n,bdy,concl) + | (n,Some bdy,t) -> mkGLetIn(n,bdy,t,concl) | _ -> assert false) let glob_decompose_prod_n n = @@ -73,8 +73,8 @@ let glob_decompose_prod_or_letin_n n = match c with | GProd(_,n,_,t,b) -> glob_decompose_prod (i-1) ((n,None,Some t)::args) b - | GLetIn(_,n,t,b) -> - glob_decompose_prod (i-1) ((n,Some t,None)::args) b + | GLetIn(_,n,b,t,c) -> + glob_decompose_prod (i-1) ((n,Some b,t)::args) c | rt -> args,rt in glob_decompose_prod n [] @@ -150,10 +150,11 @@ let change_vars = change_vars mapping t, change_vars (remove_name_from_mapping mapping name) b ) - | GLetIn(loc,name,def,b) -> + | GLetIn(loc,name,def,typ,b) -> GLetIn(loc, name, change_vars mapping def, + Option.map (change_vars mapping) typ, change_vars (remove_name_from_mapping mapping name) b ) | GLetTuple(loc,nal,(na,rto),b,e) -> @@ -272,10 +273,11 @@ let rec alpha_rt excluded rt = let new_t = alpha_rt excluded t in let new_b = alpha_rt excluded b in GProd(loc,Anonymous,k,new_t,new_b) - | GLetIn(loc,Anonymous,t,b) -> - let new_t = alpha_rt excluded t in + | GLetIn(loc,Anonymous,b,t,c) -> let new_b = alpha_rt excluded b in - GLetIn(loc,Anonymous,new_t,new_b) + let new_t = Option.map (alpha_rt excluded) t in + let new_c = alpha_rt excluded c in + GLetIn(loc,Anonymous,new_b,new_t,new_c) | GLambda(loc,Name id,k,t,b) -> let new_id = Namegen.next_ident_away id excluded in let t,b = @@ -302,19 +304,17 @@ let rec alpha_rt excluded rt = let new_t = alpha_rt new_excluded t in let new_b = alpha_rt new_excluded b in GProd(loc,Name new_id,k,new_t,new_b) - | GLetIn(loc,Name id,t,b) -> + | GLetIn(loc,Name id,b,t,c) -> let new_id = Namegen.next_ident_away id excluded in - let t,b = - if Id.equal new_id id - then t,b - else - let replace = change_vars (Id.Map.add id new_id Id.Map.empty) in - (t,replace b) + let c = + if Id.equal new_id id then c + else change_vars (Id.Map.add id new_id Id.Map.empty) c in let new_excluded = new_id::excluded in - let new_t = alpha_rt new_excluded t in let new_b = alpha_rt new_excluded b in - GLetIn(loc,Name new_id,new_t,new_b) + let new_t = Option.map (alpha_rt new_excluded) t in + let new_c = alpha_rt new_excluded c in + GLetIn(loc,Name new_id,new_b,new_t,new_c) | GLetTuple(loc,nal,(na,rto),t,b) -> @@ -388,13 +388,20 @@ let is_free_in id = | GEvar _ -> false | GPatVar _ -> false | GApp(_,rt,rtl) -> List.exists is_free_in (rt::rtl) - | GLambda(_,n,_,t,b) | GProd(_,n,_,t,b) | GLetIn(_,n,t,b) -> + | GLambda(_,n,_,t,b) | GProd(_,n,_,t,b) -> let check_in_b = match n with | Name id' -> not (Id.equal id' id) | _ -> true in is_free_in t || (check_in_b && is_free_in b) + | GLetIn(_,n,b,t,c) -> + let check_in_c = + match n with + | Name id' -> not (Id.equal id' id) + | _ -> true + in + is_free_in b || Option.cata is_free_in true t || (check_in_c && is_free_in c) | GCases(_,_,_,el,brl) -> (List.exists (fun (e,_) -> is_free_in e) el) || List.exists is_free_in_br brl @@ -473,11 +480,12 @@ let replace_var_by_term x_id term = replace_var_by_pattern t, replace_var_by_pattern b ) - | GLetIn(_,Name id,_,_) when Id.compare id x_id == 0 -> rt - | GLetIn(loc,name,def,b) -> + | GLetIn(_,Name id,_,_,_) when Id.compare id x_id == 0 -> rt + | GLetIn(loc,name,def,typ,b) -> GLetIn(loc, name, replace_var_by_pattern def, + Option.map (replace_var_by_pattern) typ, replace_var_by_pattern b ) | GLetTuple(_,nal,_,_,_) @@ -589,7 +597,7 @@ let ids_of_glob_constr c = ids_of_glob_constr [] g @ List.flatten (List.map (ids_of_glob_constr []) args) @ acc | GLambda (loc,na,k,ty,c) -> idof na :: ids_of_glob_constr [] ty @ ids_of_glob_constr [] c @ acc | GProd (loc,na,k,ty,c) -> idof na :: ids_of_glob_constr [] ty @ ids_of_glob_constr [] c @ acc - | GLetIn (loc,na,b,c) -> idof na :: ids_of_glob_constr [] b @ ids_of_glob_constr [] c @ acc + | GLetIn (loc,na,b,t,c) -> idof na :: ids_of_glob_constr [] b @ Option.cata (ids_of_glob_constr []) [] t @ ids_of_glob_constr [] c @ acc | GCast (loc,c,(CastConv t|CastVM t|CastNative t)) -> ids_of_glob_constr [] c @ ids_of_glob_constr [] t @ acc | GCast (loc,c,CastCoerce) -> ids_of_glob_constr [] c @ acc | GIf (loc,c,(na,po),b1,b2) -> ids_of_glob_constr [] c @ ids_of_glob_constr [] b1 @ ids_of_glob_constr [] b2 @ acc @@ -633,9 +641,9 @@ let zeta_normalize = zeta_normalize_term t, zeta_normalize_term b ) - | GLetIn(_,Name id,def,b) -> + | GLetIn(_,Name id,def,typ,b) -> zeta_normalize_term (replace_var_by_term id def b) - | GLetIn(loc,Anonymous,def,b) -> zeta_normalize_term b + | GLetIn(loc,Anonymous,def,typ,b) -> zeta_normalize_term b | GLetTuple(loc,nal,(na,rto),def,b) -> GLetTuple(loc, nal, @@ -690,7 +698,7 @@ let expand_as = | GApp(loc,f,args) -> GApp(loc,expand_as map f,List.map (expand_as map) args) | GLambda(loc,na,k,t,b) -> GLambda(loc,na,k,expand_as map t, expand_as map b) | GProd(loc,na,k,t,b) -> GProd(loc,na,k,expand_as map t, expand_as map b) - | GLetIn(loc,na,v,b) -> GLetIn(loc,na, expand_as map v,expand_as map b) + | GLetIn(loc,na,v,typ,b) -> GLetIn(loc,na, expand_as map v,Option.map (expand_as map) typ,expand_as map b) | GLetTuple(loc,nal,(na,po),v,b) -> GLetTuple(loc,nal,(na,Option.map (expand_as map) po), expand_as map v, expand_as map b) diff --git a/plugins/funind/glob_termops.mli b/plugins/funind/glob_termops.mli index 179e8fe8d..84359a36b 100644 --- a/plugins/funind/glob_termops.mli +++ b/plugins/funind/glob_termops.mli @@ -19,7 +19,7 @@ val mkGVar : Id.t -> glob_constr val mkGApp : glob_constr*(glob_constr list) -> glob_constr val mkGLambda : Name.t * glob_constr * glob_constr -> glob_constr val mkGProd : Name.t * glob_constr * glob_constr -> glob_constr -val mkGLetIn : Name.t * glob_constr * glob_constr -> glob_constr +val mkGLetIn : Name.t * glob_constr * glob_constr option * glob_constr -> glob_constr val mkGCases : glob_constr option * tomatch_tuples * cases_clauses -> glob_constr val mkGSort : glob_sort -> glob_constr val mkGHole : unit -> glob_constr (* we only build Evd.BinderType Anonymous holes *) diff --git a/plugins/funind/indfun.ml b/plugins/funind/indfun.ml index 99b04898b..d335836df 100644 --- a/plugins/funind/indfun.ml +++ b/plugins/funind/indfun.ml @@ -2,6 +2,7 @@ open CErrors open Util open Names open Term +open EConstr open Pp open Indfun_common open Libnames @@ -14,37 +15,39 @@ open Sigma.Notations module RelDecl = Context.Rel.Declaration -let is_rec_info scheme_info = +let is_rec_info sigma scheme_info = let test_branche min acc decl = acc || ( let new_branche = - it_mkProd_or_LetIn mkProp (fst (decompose_prod_assum (RelDecl.get_type decl))) in - let free_rels_in_br = Termops.free_rels new_branche in + it_mkProd_or_LetIn mkProp (fst (decompose_prod_assum sigma (RelDecl.get_type decl))) in + let free_rels_in_br = Termops.free_rels sigma new_branche in let max = min + scheme_info.Tactics.npredicates in Int.Set.exists (fun i -> i >= min && i< max) free_rels_in_br ) in List.fold_left_i test_branche 1 false (List.rev scheme_info.Tactics.branches) -let choose_dest_or_ind scheme_info = - Tactics.induction_destruct (is_rec_info scheme_info) false +let choose_dest_or_ind scheme_info args = + Proofview.tclBIND Proofview.tclEVARMAP (fun sigma -> + Tactics.induction_destruct (is_rec_info sigma scheme_info) false args) let functional_induction with_clean c princl pat = let res = - let f,args = decompose_app c in fun g -> + let sigma = Tacmach.project g in + let f,args = decompose_app sigma c in let princ,bindings, princ_type,g' = match princl with | None -> (* No principle is given let's find the good one *) begin - match kind_of_term f with + match EConstr.kind sigma f with | Const (c',u) -> let princ_option = let finfo = (* we first try to find out a graph on f *) try find_Function_infos c' with Not_found -> user_err (str "Cannot find induction information on "++ - Printer.pr_lconstr (mkConst c') ) + Printer.pr_leconstr (mkConst c') ) in match Tacticals.elimination_sort_of_goal g with | InProp -> finfo.prop_lemma @@ -72,15 +75,17 @@ let functional_induction with_clean c princl pat = (* mkConst(const_of_id princ_name ),g (\* FIXME *\) *) with Not_found -> (* This one is neither defined ! *) user_err (str "Cannot find induction principle for " - ++Printer.pr_lconstr (mkConst c') ) + ++Printer.pr_leconstr (mkConst c') ) in - (princ,NoBindings, Tacmach.pf_unsafe_type_of g' princ,g') + let princ = EConstr.of_constr princ in + (princ,NoBindings,Tacmach.pf_unsafe_type_of g' princ,g') | _ -> raise (UserError(None,str "functional induction must be used with a function" )) end | Some ((princ,binding)) -> princ,binding,Tacmach.pf_unsafe_type_of g princ,g in - let princ_infos = Tactics.compute_elim_sig princ_type in + let sigma = Tacmach.project g' 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 @@ -94,7 +99,7 @@ let functional_induction with_clean c princl pat = let princ' = Some (princ,bindings) in let princ_vars = List.fold_right - (fun a acc -> try Id.Set.add (destVar a) acc with DestKO -> acc) + (fun a acc -> try Id.Set.add (destVar sigma a) acc with DestKO -> acc) args Id.Set.empty in @@ -129,11 +134,11 @@ let functional_induction with_clean c princl pat = let rec abstract_glob_constr c = function | [] -> c - | Constrexpr.LocalRawDef (x,b)::bl -> Constrexpr_ops.mkLetInC(x,b,abstract_glob_constr c bl) - | Constrexpr.LocalRawAssum (idl,k,t)::bl -> + | Constrexpr.CLocalDef (x,b,t)::bl -> Constrexpr_ops.mkLetInC(x,b,t,abstract_glob_constr c bl) + | Constrexpr.CLocalAssum (idl,k,t)::bl -> List.fold_right (fun x b -> Constrexpr_ops.mkLambdaC([x],k,t,b)) idl (abstract_glob_constr c bl) - | Constrexpr.LocalPattern _::bl -> assert false + | Constrexpr.CLocalPattern _::bl -> assert false let interp_casted_constr_with_implicits env sigma impls c = Constrintern.intern_gen Pretyping.WithoutTypeConstraint env ~impls @@ -151,7 +156,7 @@ let build_newrecursive let (rec_sign,rec_impls) = List.fold_left (fun (env,impls) (((_,recname),_),bl,arityc,_) -> - let arityc = Constrexpr_ops.prod_constr_expr arityc bl in + let arityc = Constrexpr_ops.mkCProdN Loc.ghost bl arityc in let arity,ctx = Constrintern.interp_type env0 sigma arityc in let evdref = ref (Evd.from_env env0) in let _, (_, impls') = Constrintern.interp_context_evars env evdref bl in @@ -192,8 +197,10 @@ let is_rec names = | GRec _ -> error "GRec not handled" | GIf(_,b,_,lhs,rhs) -> (lookup names b) || (lookup names lhs) || (lookup names rhs) - | GLetIn(_,na,t,b) | GLambda(_,na,_,t,b) | GProd(_,na,_,t,b) -> + | GProd(_,na,_,t,b) | GLambda(_,na,_,t,b) -> lookup names t || lookup (Nameops.name_fold Id.Set.remove na names) b + | GLetIn(_,na,b,t,c) -> + lookup names b || Option.cata (lookup names) true t || lookup (Nameops.name_fold Id.Set.remove na names) c | GLetTuple(_,nal,_,t,b) -> lookup names t || lookup (List.fold_left @@ -215,9 +222,9 @@ let is_rec names = let rec local_binders_length = function (* Assume that no `{ ... } contexts occur *) | [] -> 0 - | Constrexpr.LocalRawDef _::bl -> 1 + local_binders_length bl - | Constrexpr.LocalRawAssum (idl,_,_)::bl -> List.length idl + local_binders_length bl - | Constrexpr.LocalPattern _::bl -> assert false + | Constrexpr.CLocalDef _::bl -> 1 + local_binders_length bl + | Constrexpr.CLocalAssum (idl,_,_)::bl -> List.length idl + local_binders_length bl + | Constrexpr.CLocalPattern _::bl -> assert false let prepare_body ((name,_,args,types,_),_) rt = let n = local_binders_length args in @@ -243,7 +250,9 @@ let derive_inversion fix_names = let evd,c = Evd.fresh_global (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident id)) in - evd, destConst c::l + let c = EConstr.of_constr c in + let (cst, u) = destConst evd c in + evd, (cst, EInstance.kind evd u) :: l ) fix_names (evd',[]) @@ -263,7 +272,8 @@ let derive_inversion fix_names = (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident (mk_rel_id id))) in - evd,(fst (destInd id))::l + let id = EConstr.of_constr id in + evd,(fst (destInd evd id))::l ) fix_names (evd',[]) @@ -330,7 +340,7 @@ let error_error names e = let generate_principle (evd:Evd.evar_map ref) pconstants on_error is_general do_built (fix_rec_l:(Vernacexpr.fixpoint_expr * Vernacexpr.decl_notation list) list) recdefs interactive_proof - (continue_proof : int -> Names.constant array -> Term.constr array -> int -> + (continue_proof : int -> Names.constant array -> EConstr.constr array -> int -> Tacmach.tactic) : unit = let names = List.map (function (((_, name),_),_,_,_,_),_ -> name) fix_rec_l in let fun_bodies = List.map2 prepare_body fix_rec_l recdefs in @@ -368,7 +378,8 @@ let generate_principle (evd:Evd.evar_map ref) pconstants on_error let evd = ref (Evd.from_env env) in let evd',uprinc = Evd.fresh_global env !evd princ in let _ = evd := evd' in - let princ_type = Typing.e_type_of ~refresh:true env evd uprinc in + let princ_type = Typing.e_type_of ~refresh:true env evd (EConstr.of_constr uprinc) in + let princ_type = EConstr.Unsafe.to_constr princ_type in Functional_principles_types.generate_functional_principle evd interactive_proof @@ -403,7 +414,10 @@ let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexp let evd,c = Evd.fresh_global (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname)) in - evd,((destConst c)::l) + let c = EConstr.of_constr c in + let (cst, u) = destConst evd c in + let u = EInstance.kind evd u in + evd,((cst, u) :: l) ) (Evd.from_env (Global.env ()),[]) fixpoint_exprl @@ -417,7 +431,10 @@ let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexp let evd,c = Evd.fresh_global (Global.env ()) evd (Constrintern.locate_reference (Libnames.qualid_of_ident fname)) in - evd,((destConst c)::l) + let c = EConstr.of_constr c in + let (cst, u) = destConst evd c in + let u = EInstance.kind evd u in + evd,((cst, u) :: l) ) (Evd.from_env (Global.env ()),[]) fixpoint_exprl @@ -427,7 +444,7 @@ let register_struct is_rec (fixpoint_exprl:(Vernacexpr.fixpoint_expr * Vernacexp let generate_correction_proof_wf f_ref tcc_lemma_ref is_mes functional_ref eq_ref rec_arg_num rec_arg_type nb_args relation - (_: int) (_:Names.constant array) (_:Term.constr array) (_:int) : Tacmach.tactic = + (_: int) (_:Names.constant array) (_:EConstr.constr array) (_:int) : Tacmach.tactic = Functional_principles_proofs.prove_principle_for_gen (f_ref,functional_ref,eq_ref) tcc_lemma_ref is_mes rec_arg_num rec_arg_type relation @@ -436,7 +453,7 @@ let generate_correction_proof_wf f_ref tcc_lemma_ref let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas args ret_type body pre_hook = - let type_of_f = Constrexpr_ops.prod_constr_expr ret_type args in + let type_of_f = Constrexpr_ops.mkCProdN Loc.ghost args ret_type in let rec_arg_num = let names = List.map @@ -467,7 +484,7 @@ let register_wf ?(is_mes=false) fname rec_impls wf_rel_expr wf_arg using_lemmas Constrexpr.CApp (Loc.ghost,(None,Constrexpr_ops.mkRefC (Qualid (Loc.ghost,(qualid_of_string "Logic.eq")))), [(f_app_args,None);(body,None)]) in - let eq = Constrexpr_ops.prod_constr_expr unbounded_eq args in + let eq = Constrexpr_ops.mkCProdN Loc.ghost args unbounded_eq in let hook ((f_ref,_) as fconst) tcc_lemma_ref (functional_ref,_) (eq_ref,_) rec_arg_num rec_arg_type nb_args relation = try @@ -496,7 +513,7 @@ let register_mes fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas | None -> begin match args with - | [Constrexpr.LocalRawAssum ([(_,Name x)],k,t)] -> t,x + | [Constrexpr.CLocalAssum ([(_,Name x)],k,t)] -> t,x | _ -> error "Recursive argument must be specified" end | Some wf_args -> @@ -504,7 +521,7 @@ let register_mes fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas match List.find (function - | Constrexpr.LocalRawAssum(l,k,t) -> + | Constrexpr.CLocalAssum(l,k,t) -> List.exists (function (_,Name id) -> Id.equal id wf_args | _ -> false) l @@ -512,7 +529,7 @@ let register_mes fname rec_impls wf_mes_expr wf_rel_expr_opt wf_arg using_lemmas ) args with - | Constrexpr.LocalRawAssum(_,k,t) -> t,wf_args + | Constrexpr.CLocalAssum(_,k,t) -> t,wf_args | _ -> assert false with Not_found -> assert false in @@ -570,10 +587,10 @@ let make_assoc assoc l1 l2 = let rec rebuild_bl (aux,assoc) bl typ = match bl,typ with | [], _ -> (List.rev aux,replace_vars_constr_expr assoc typ,assoc) - | (Constrexpr.LocalRawAssum(nal,bk,_))::bl',typ -> + | (Constrexpr.CLocalAssum(nal,bk,_))::bl',typ -> rebuild_nal (aux,assoc) bk bl' nal (List.length nal) typ - | (Constrexpr.LocalRawDef(na,_))::bl',Constrexpr.CLetIn(_,_,nat,typ') -> - rebuild_bl ((Constrexpr.LocalRawDef(na,replace_vars_constr_expr assoc nat)::aux),assoc) + | (Constrexpr.CLocalDef(na,_,_))::bl',Constrexpr.CLetIn(_,_,nat,ty,typ') -> + rebuild_bl ((Constrexpr.CLocalDef(na,replace_vars_constr_expr assoc nat,Option.map (replace_vars_constr_expr assoc) ty (* ??? *))::aux),assoc) bl' typ' | _ -> assert false and rebuild_nal (aux,assoc) bk bl' nal lnal typ = @@ -586,7 +603,7 @@ let rec rebuild_bl (aux,assoc) bl typ = then let old_nal',new_nal' = List.chop lnal nal' in let nassoc = make_assoc assoc old_nal' nal in - let assum = LocalRawAssum(nal,bk,replace_vars_constr_expr assoc nal't) in + let assum = CLocalAssum(nal,bk,replace_vars_constr_expr assoc nal't) in rebuild_bl ((assum :: aux), nassoc) bl' (if List.is_empty new_nal' && List.is_empty rest then typ' @@ -596,7 +613,7 @@ let rec rebuild_bl (aux,assoc) bl typ = else let captured_nal,non_captured_nal = List.chop lnal' nal in let nassoc = make_assoc assoc nal' captured_nal in - let assum = LocalRawAssum(captured_nal,bk,replace_vars_constr_expr assoc nal't) in + let assum = CLocalAssum(captured_nal,bk,replace_vars_constr_expr assoc nal't) in rebuild_nal ((assum :: aux), nassoc) bk bl' non_captured_nal (lnal - lnal') (CProdN(Loc.ghost,rest,typ')) | _ -> assert false @@ -726,8 +743,8 @@ let rec add_args id new_args b = CLambdaN(loc, List.map (fun (nal,k,b2) -> (nal,k,add_args id new_args b2)) nal, add_args id new_args b1) - | CLetIn(loc,na,b1,b2) -> - CLetIn(loc,na,add_args id new_args b1,add_args id new_args b2) + | CLetIn(loc,na,b1,t,b2) -> + CLetIn(loc,na,add_args id new_args b1,Option.map (add_args id new_args) t,add_args id new_args b2) | CAppExpl(loc,(pf,r,us),exprl) -> begin match r with @@ -813,7 +830,7 @@ let rec chop_n_arrow n t = | _ -> anomaly (Pp.str "Not enough products") -let rec get_args b t : Constrexpr.local_binder list * +let rec get_args b t : Constrexpr.local_binder_expr list * Constrexpr.constr_expr * Constrexpr.constr_expr = match b with | Constrexpr.CLambdaN (loc, (nal_ta), b') -> @@ -824,7 +841,7 @@ let rec get_args b t : Constrexpr.local_binder list * in let nal_tas,b'',t'' = get_args b' (chop_n_arrow n t) in (List.map (fun (nal,k,ta) -> - (Constrexpr.LocalRawAssum (nal,k,ta))) nal_ta)@nal_tas, b'',t'' + (Constrexpr.CLocalAssum (nal,k,ta))) nal_ta)@nal_tas, b'',t'' end | _ -> [],b,t @@ -835,7 +852,7 @@ let make_graph (f_ref:global_reference) = | ConstRef c -> begin try c,Global.lookup_constant c with Not_found -> - raise (UserError (None,str "Cannot find " ++ Printer.pr_lconstr (mkConst c)) ) + raise (UserError (None,str "Cannot find " ++ Printer.pr_leconstr (mkConst c)) ) end | _ -> raise (UserError (None, str "Not a function reference") ) in @@ -865,13 +882,13 @@ let make_graph (f_ref:global_reference) = List.flatten (List.map (function - | Constrexpr.LocalRawDef (na,_)-> [] - | Constrexpr.LocalRawAssum (nal,_,_) -> + | Constrexpr.CLocalDef (na,_,_)-> [] + | Constrexpr.CLocalAssum (nal,_,_) -> List.map (fun (loc,n) -> CRef(Libnames.Ident(loc, Nameops.out_name n),None)) nal - | Constrexpr.LocalPattern _ -> assert false + | Constrexpr.CLocalPattern _ -> assert false ) nal_tas ) diff --git a/plugins/funind/indfun.mli b/plugins/funind/indfun.mli index 1c27bdfac..ba89fe4a7 100644 --- a/plugins/funind/indfun.mli +++ b/plugins/funind/indfun.mli @@ -12,8 +12,8 @@ val do_generate_principle : val functional_induction : bool -> - Term.constr -> - (Term.constr * Term.constr bindings) option -> + EConstr.constr -> + (EConstr.constr * EConstr.constr bindings) option -> Tacexpr.or_and_intro_pattern option -> Proof_type.goal Tacmach.sigma -> Proof_type.goal list Evd.sigma diff --git a/plugins/funind/indfun_common.ml b/plugins/funind/indfun_common.ml index a45effb16..7b0d7d27d 100644 --- a/plugins/funind/indfun_common.ml +++ b/plugins/funind/indfun_common.ml @@ -70,8 +70,8 @@ let chop_rlambda_n = then List.rev acc,rt else match rt with - | Glob_term.GLambda(_,name,k,t,b) -> chop_lambda_n ((name,t,false)::acc) (n-1) b - | Glob_term.GLetIn(_,name,v,b) -> chop_lambda_n ((name,v,true)::acc) (n-1) b + | Glob_term.GLambda(_,name,k,t,b) -> chop_lambda_n ((name,t,None)::acc) (n-1) b + | Glob_term.GLetIn(_,name,v,t,b) -> chop_lambda_n ((name,v,t)::acc) (n-1) b | _ -> raise (CErrors.UserError(Some "chop_rlambda_n", str "chop_rlambda_n: Not enough Lambdas")) @@ -130,8 +130,8 @@ let find_reference sl s = let dp = Names.DirPath.make (List.rev_map Id.of_string sl) in Nametab.locate (make_qualid dp (Id.of_string s)) -let eq = lazy(coq_constant "eq") -let refl_equal = lazy(coq_constant "eq_refl") +let eq = lazy(EConstr.of_constr (coq_constant "eq")) +let refl_equal = lazy(EConstr.of_constr (coq_constant "eq_refl")) (*****************************************************************) (* Copy of the standart save mechanism but without the much too *) @@ -475,13 +475,13 @@ exception ToShow of exn let jmeq () = try Coqlib.check_required_library Coqlib.jmeq_module_name; - Coqlib.gen_constant "Function" ["Logic";"JMeq"] "JMeq" + EConstr.of_constr (Coqlib.gen_constant "Function" ["Logic";"JMeq"] "JMeq") with e when CErrors.noncritical e -> raise (ToShow e) let jmeq_refl () = try Coqlib.check_required_library Coqlib.jmeq_module_name; - Coqlib.gen_constant "Function" ["Logic";"JMeq"] "JMeq_refl" + EConstr.of_constr (Coqlib.gen_constant "Function" ["Logic";"JMeq"] "JMeq_refl") with e when CErrors.noncritical e -> raise (ToShow e) let h_intros l = @@ -489,10 +489,10 @@ let h_intros l = let h_id = Id.of_string "h" let hrec_id = Id.of_string "hrec" -let well_founded = function () -> (coq_constant "well_founded") -let acc_rel = function () -> (coq_constant "Acc") -let acc_inv_id = function () -> (coq_constant "Acc_inv") -let well_founded_ltof = function () -> (Coqlib.coq_constant "" ["Arith";"Wf_nat"] "well_founded_ltof") +let well_founded = function () -> EConstr.of_constr (coq_constant "well_founded") +let acc_rel = function () -> EConstr.of_constr (coq_constant "Acc") +let acc_inv_id = function () -> EConstr.of_constr (coq_constant "Acc_inv") +let well_founded_ltof = function () -> EConstr.of_constr (Coqlib.coq_constant "" ["Arith";"Wf_nat"] "well_founded_ltof") let ltof_ref = function () -> (find_reference ["Coq";"Arith";"Wf_nat"] "ltof") let evaluable_of_global_reference r = (* Tacred.evaluable_of_global_reference (Global.env ()) *) @@ -501,8 +501,50 @@ let evaluable_of_global_reference r = (* Tacred.evaluable_of_global_reference (G | VarRef id -> EvalVarRef id | _ -> assert false;; -let list_rewrite (rev:bool) (eqs: (constr*bool) list) = +let list_rewrite (rev:bool) (eqs: (EConstr.constr*bool) list) = tclREPEAT (List.fold_right (fun (eq,b) i -> tclORELSE (Proofview.V82.of_tactic ((if b then Equality.rewriteLR else Equality.rewriteRL) eq)) i) (if rev then (List.rev eqs) else eqs) (tclFAIL 0 (mt())));; + +let decompose_lam_n sigma n = + let open EConstr in + if n < 0 then CErrors.error "decompose_lam_n: integer parameter must be positive"; + let rec lamdec_rec l n c = + if Int.equal n 0 then l,c + else match EConstr.kind sigma c with + | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) (n-1) c + | Cast (c,_,_) -> lamdec_rec l n c + | _ -> CErrors.error "decompose_lam_n: not enough abstractions" + in + lamdec_rec [] n + +let lamn n env b = + let open EConstr in + let rec lamrec = function + | (0, env, b) -> b + | (n, ((v,t)::l), b) -> lamrec (n-1, l, mkLambda (v,t,b)) + | _ -> assert false + in + lamrec (n,env,b) + +(* compose_lam [xn:Tn;..;x1:T1] b = [x1:T1]..[xn:Tn]b *) +let compose_lam l b = lamn (List.length l) l b + +(* prodn n [xn:Tn;..;x1:T1;Gamma] b = (x1:T1)..(xn:Tn)b *) +let prodn n env b = + let open EConstr in + let rec prodrec = function + | (0, env, b) -> b + | (n, ((v,t)::l), b) -> prodrec (n-1, l, mkProd (v,t,b)) + | _ -> assert false + in + prodrec (n,env,b) + +(* compose_prod [xn:Tn;..;x1:T1] b = (x1:T1)..(xn:Tn)b *) +let compose_prod l b = prodn (List.length l) l b + +type tcc_lemma_value = + | Undefined + | Value of Constr.constr + | Not_needed diff --git a/plugins/funind/indfun_common.mli b/plugins/funind/indfun_common.mli index e5c756f56..5ef8f05bb 100644 --- a/plugins/funind/indfun_common.mli +++ b/plugins/funind/indfun_common.mli @@ -34,17 +34,17 @@ val list_add_set_eq : ('a -> 'a -> bool) -> 'a -> 'a list -> 'a list val chop_rlambda_n : int -> Glob_term.glob_constr -> - (Name.t*Glob_term.glob_constr*bool) list * Glob_term.glob_constr + (Name.t*Glob_term.glob_constr*Glob_term.glob_constr option) list * Glob_term.glob_constr val chop_rprod_n : int -> Glob_term.glob_constr -> (Name.t*Glob_term.glob_constr) list * Glob_term.glob_constr val def_of_const : Term.constr -> Term.constr -val eq : Term.constr Lazy.t -val refl_equal : Term.constr Lazy.t +val eq : EConstr.constr Lazy.t +val refl_equal : EConstr.constr Lazy.t val const_of_id: Id.t -> Globnames.global_reference(* constantyes *) -val jmeq : unit -> Term.constr -val jmeq_refl : unit -> Term.constr +val jmeq : unit -> EConstr.constr +val jmeq_refl : unit -> EConstr.constr val save : bool -> Id.t -> Safe_typing.private_constants Entries.definition_entry -> Decl_kinds.goal_kind -> unit Lemmas.declaration_hook CEphemeron.key -> unit @@ -107,10 +107,20 @@ val is_strict_tcc : unit -> bool val h_intros: Names.Id.t list -> Proof_type.tactic val h_id : Names.Id.t val hrec_id : Names.Id.t -val acc_inv_id : Term.constr Util.delayed +val acc_inv_id : EConstr.constr Util.delayed val ltof_ref : Globnames.global_reference Util.delayed -val well_founded_ltof : Term.constr Util.delayed -val acc_rel : Term.constr Util.delayed -val well_founded : Term.constr Util.delayed +val well_founded_ltof : EConstr.constr Util.delayed +val acc_rel : EConstr.constr Util.delayed +val well_founded : EConstr.constr Util.delayed val evaluable_of_global_reference : Globnames.global_reference -> Names.evaluable_global_reference -val list_rewrite : bool -> (Term.constr*bool) list -> Proof_type.tactic +val list_rewrite : bool -> (EConstr.constr*bool) list -> Proof_type.tactic + +val decompose_lam_n : Evd.evar_map -> int -> EConstr.t -> + (Names.Name.t * EConstr.t) list * EConstr.t +val compose_lam : (Names.Name.t * EConstr.t) list -> EConstr.t -> EConstr.t +val compose_prod : (Names.Name.t * EConstr.t) list -> EConstr.t -> EConstr.t + +type tcc_lemma_value = + | Undefined + | Value of Constr.constr + | Not_needed diff --git a/plugins/funind/invfun.ml b/plugins/funind/invfun.ml index c8b4e4833..94ec0a898 100644 --- a/plugins/funind/invfun.ml +++ b/plugins/funind/invfun.ml @@ -6,12 +6,14 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Ltac_plugin open Tacexpr open Declarations open CErrors open Util open Names open Term +open EConstr open Vars open Pp open Globnames @@ -108,11 +110,11 @@ let thin ids gl = Proofview.V82.of_tactic (Tactics.clear ids) gl let make_eq () = try - Universes.constr_of_global (Coqlib.build_coq_eq ()) + EConstr.of_constr (Universes.constr_of_global (Coqlib.build_coq_eq ())) with _ -> assert false let make_eq_refl () = try - Universes.constr_of_global (Coqlib.build_coq_eq_refl ()) + EConstr.of_constr (Universes.constr_of_global (Coqlib.build_coq_eq_refl ())) with _ -> assert false @@ -131,11 +133,12 @@ let make_eq_refl () = let generate_type evd g_to_f f graph i = (*i we deduce the number of arguments of the function and its returned type from the graph i*) let evd',graph = - Evd.fresh_global (Global.env ()) !evd (Globnames.IndRef (fst (destInd graph))) + Evd.fresh_global (Global.env ()) !evd (Globnames.IndRef (fst (destInd !evd graph))) in + let graph = EConstr.of_constr graph in evd:=evd'; let graph_arity = Typing.e_type_of (Global.env ()) evd graph in - let ctxt,_ = decompose_prod_assum graph_arity in + let ctxt,_ = decompose_prod_assum !evd graph_arity in let fun_ctxt,res_type = match ctxt with | [] | [_] -> anomaly (Pp.str "Not a valid context") @@ -193,7 +196,7 @@ let generate_type evd g_to_f f graph i = WARNING: while convertible, [type_of body] and [type] can be non equal *) let find_induction_principle evd f = - let f_as_constant,u = match kind_of_term f with + let f_as_constant,u = match EConstr.kind !evd f with | Const c' -> c' | _ -> error "Must be used with a function" in @@ -202,6 +205,7 @@ let find_induction_principle evd f = | None -> raise Not_found | Some rect_lemma -> let evd',rect_lemma = Evd.fresh_global (Global.env ()) !evd (Globnames.ConstRef rect_lemma) in + let rect_lemma = EConstr.of_constr rect_lemma in let evd',typ = Typing.type_of ~refresh:true (Global.env ()) evd' rect_lemma in evd:=evd'; rect_lemma,typ @@ -246,15 +250,15 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes \[fun (x_1:t_1)\ldots(x_n:t_n)=> fun fv => fun res => res = fv \rightarrow graph\ x_1\ldots x_n\ res\] *) (* we the get the definition of the graphs block *) - let graph_ind,u = destInd graphs_constr.(i) in + let graph_ind,u = destInd evd graphs_constr.(i) in let kn = fst graph_ind in let mib,_ = Global.lookup_inductive graph_ind in (* 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 princ_type in - let princ_infos = Tactics.compute_elim_sig 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 (pf_concl g) - 2 in + let nb_fun_args = nb_prod (project g) (pf_concl g) - 2 in let args_names = generate_fresh_id (Id.of_string "x") [] nb_fun_args in let ids = args_names@(pf_ids_of_hyps g) in (* Since we cannot ensure that the functional principle is defined in the @@ -271,13 +275,13 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes (fun decl -> List.map (fun id -> Loc.ghost, IntroNaming (IntroIdentifier id)) - (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum (RelDecl.get_type decl))))) + (generate_fresh_id (Id.of_string "y") ids (List.length (fst (decompose_prod_assum evd (RelDecl.get_type decl))))) ) branches in (* before building the full intro pattern for the principle *) let eq_ind = make_eq () in - let eq_construct = mkConstructUi (destInd eq_ind, 1) in + let eq_construct = mkConstructUi (destInd evd eq_ind, 1) in (* The next to referencies will be used to find out which constructor to apply in each branch *) let ind_number = ref 0 and min_constr_number = ref 0 in @@ -306,17 +310,18 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes List.fold_right (fun hid acc -> let type_of_hid = pf_unsafe_type_of g (mkVar hid) in - match kind_of_term type_of_hid with + let sigma = project g in + match EConstr.kind sigma type_of_hid with | Prod(_,_,t') -> begin - match kind_of_term t' with + match EConstr.kind sigma t' with | Prod(_,t'',t''') -> begin - match kind_of_term t'',kind_of_term t''' with + match EConstr.kind sigma t'',EConstr.kind sigma t''' with | App(eq,args), App(graph',_) when - (eq_constr eq eq_ind) && - Array.exists (Constr.eq_constr_nounivs graph') graphs_constr -> + (EConstr.eq_constr sigma eq eq_ind) && + Array.exists (EConstr.eq_constr_nounivs sigma graph') graphs_constr -> (args.(2)::(mkApp(mkVar hid,[|args.(2);(mkApp(eq_construct,[|args.(0);args.(2)|]))|])) ::acc) | _ -> mkVar hid :: acc @@ -399,8 +404,8 @@ let prove_fun_correct evd functional_induction funs_constr graphs_constr schemes match ctxt with | [] | [_] | [_;_] -> anomaly (Pp.str "bad context") | hres::res::decl::ctxt -> - let res = Termops.it_mkLambda_or_LetIn - (Termops.it_mkProd_or_LetIn concl [hres;res]) + let res = EConstr.it_mkLambda_or_LetIn + (EConstr.it_mkProd_or_LetIn concl [hres;res]) (LocalAssum (RelDecl.get_name decl, RelDecl.get_type decl) :: ctxt) in res @@ -467,7 +472,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) x t) -> tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [mkVar id])) (thin [id]) + (Termops.occur_var (pf_env g) (project g) x t) -> tclTHEN (Proofview.V82.of_tactic (Tactics.generalize [mkVar id])) (thin [id]) | _ -> tclIDTAC ) (pf_hyps g) @@ -491,43 +496,44 @@ let rec intros_with_rewrite g = and intros_with_rewrite_aux : tactic = fun g -> let eq_ind = make_eq () in - match kind_of_term (pf_concl g) with + let sigma = project g in + match EConstr.kind sigma (pf_concl g) with | Prod(_,t,t') -> begin - match kind_of_term t with - | App(eq,args) when (eq_constr eq eq_ind) -> + match EConstr.kind sigma t with + | App(eq,args) when (EConstr.eq_constr sigma eq eq_ind) -> if Reductionops.is_conv (pf_env g) (project g) args.(1) args.(2) then let id = pf_get_new_id (Id.of_string "y") g in tclTHENSEQ [ Proofview.V82.of_tactic (Simple.intro id); thin [id]; intros_with_rewrite ] g - else if isVar args.(1) && (Environ.evaluable_named (destVar args.(1)) (pf_env g)) + else if isVar sigma args.(1) && (Environ.evaluable_named (destVar sigma args.(1)) (pf_env g)) then tclTHENSEQ[ - Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(1)))]); - tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(1)))] ((destVar args.(1)),Locus.InHyp) ))) + Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(1)))]); + tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(1)))] ((destVar sigma args.(1)),Locus.InHyp) ))) (pf_ids_of_hyps g); intros_with_rewrite ] g - else if isVar args.(2) && (Environ.evaluable_named (destVar args.(2)) (pf_env g)) + else if isVar sigma args.(2) && (Environ.evaluable_named (destVar sigma args.(2)) (pf_env g)) then tclTHENSEQ[ - Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(2)))]); - tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar args.(2)))] ((destVar args.(2)),Locus.InHyp) ))) + Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(2)))]); + tclMAP (fun id -> tclTRY(Proofview.V82.of_tactic (unfold_in_hyp [(Locus.AllOccurrences, Names.EvalVarRef (destVar sigma args.(2)))] ((destVar sigma args.(2)),Locus.InHyp) ))) (pf_ids_of_hyps g); intros_with_rewrite ] g - else if isVar args.(1) + else if isVar sigma args.(1) then let id = pf_get_new_id (Id.of_string "y") g in tclTHENSEQ [ Proofview.V82.of_tactic (Simple.intro id); - generalize_dependent_of (destVar args.(1)) id; + generalize_dependent_of (destVar sigma args.(1)) id; tclTRY (Proofview.V82.of_tactic (Equality.rewriteLR (mkVar id))); intros_with_rewrite ] g - else if isVar args.(2) + else if isVar sigma args.(2) then let id = pf_get_new_id (Id.of_string "y") g in tclTHENSEQ [ Proofview.V82.of_tactic (Simple.intro id); - generalize_dependent_of (destVar args.(2)) id; + generalize_dependent_of (destVar sigma args.(2)) id; tclTRY (Proofview.V82.of_tactic (Equality.rewriteRL (mkVar id))); intros_with_rewrite ] @@ -541,7 +547,7 @@ and intros_with_rewrite_aux : tactic = intros_with_rewrite ] g end - | Ind _ when eq_constr t (Coqlib.build_coq_False ()) -> + | Ind _ when EConstr.eq_constr sigma t (EConstr.of_constr (Coqlib.build_coq_False ())) -> Proofview.V82.of_tactic tauto g | Case(_,_,v,_) -> tclTHENSEQ[ @@ -579,7 +585,7 @@ and intros_with_rewrite_aux : tactic = let rec reflexivity_with_destruct_cases g = let destruct_case () = try - match kind_of_term (snd (destApp (pf_concl g))).(2) with + match EConstr.kind (project g) (snd (destApp (project g) (pf_concl g))).(2) with | Case(_,_,v,_) -> tclTHENSEQ[ Proofview.V82.of_tactic (simplest_case v); @@ -596,8 +602,8 @@ let rec reflexivity_with_destruct_cases g = match sc with None -> tclIDTAC g | Some id -> - match kind_of_term (pf_unsafe_type_of g (mkVar id)) with - | App(eq,[|_;t1;t2|]) when eq_constr eq eq_ind -> + match EConstr.kind (project g) (pf_unsafe_type_of g (mkVar id)) with + | App(eq,[|_;t1;t2|]) when EConstr.eq_constr (project g) eq eq_ind -> if Equality.discriminable (pf_env g) (project g) t1 t2 then Proofview.V82.of_tactic (Equality.discrHyp id) g else if Equality.injectable (pf_env g) (project g) t1 t2 @@ -655,18 +661,18 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = *) let lemmas = Array.map - (fun (_,(ctxt,concl)) -> nf_zeta (Termops.it_mkLambda_or_LetIn concl ctxt)) + (fun (_,(ctxt,concl)) -> nf_zeta (EConstr.it_mkLambda_or_LetIn concl ctxt)) lemmas_types_infos in (* We get the constant and the principle corresponding to this lemma *) let f = funcs.(i) in - let graph_principle = nf_zeta schemes.(i) in + let graph_principle = nf_zeta (EConstr.of_constr schemes.(i)) in let princ_type = pf_unsafe_type_of g graph_principle in - let princ_infos = Tactics.compute_elim_sig 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 *) - let nb_fun_args = nb_prod (pf_concl g) - 2 in + let nb_fun_args = nb_prod (project g) (pf_concl g) - 2 in let args_names = generate_fresh_id (Id.of_string "x") [] nb_fun_args in let ids = args_names@(pf_ids_of_hyps g) in (* and fresh names for res H and the principle (cf bug bug #1174) *) @@ -684,7 +690,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = (fun decl -> List.map (fun id -> id) - (generate_fresh_id (Id.of_string "y") ids (nb_prod (RelDecl.get_type decl))) + (generate_fresh_id (Id.of_string "y") ids (nb_prod (project g) (RelDecl.get_type decl))) ) branches in @@ -695,7 +701,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = let rewrite_tac j ids : tactic = let graph_def = graphs.(j) in let infos = - try find_Function_infos (fst (destConst funcs.(j))) + try find_Function_infos (fst (destConst (project g) funcs.(j))) with Not_found -> error "No graph found" in if infos.is_general @@ -721,7 +727,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = thin ids ] else - Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst (destConst f)))]) + Proofview.V82.of_tactic (unfold_in_concl [(Locus.AllOccurrences, Names.EvalConstRef (fst (destConst (project g) f)))]) in (* The proof of each branche itself *) let ind_number = ref 0 in @@ -752,6 +758,7 @@ let prove_fun_complete funcs graphs schemes lemmas_types_infos i : tactic = g in let params_names = fst (List.chop princ_infos.nparams args_names) in + let open EConstr in let params = List.map mkVar params_names in tclTHENSEQ [ tclMAP (fun id -> Proofview.V82.of_tactic (Simple.intro id)) (args_names@[res;hres]); @@ -776,7 +783,8 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( assert (funs <> []); assert (graphs <> []); let funs = Array.of_list funs and graphs = Array.of_list graphs in - let funs_constr = Array.map mkConstU funs in + let map (c, u) = mkConstU (c, EInstance.make u) in + let funs_constr = Array.map map funs in States.with_state_protection_on_exception (fun () -> let env = Global.env () in @@ -791,10 +799,10 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( in let type_info = (type_of_lemma_ctxt,type_of_lemma_concl) in graphs_constr.(i) <- graph; - let type_of_lemma = Termops.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in + let type_of_lemma = EConstr.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in let _ = Typing.e_type_of (Global.env ()) evd type_of_lemma in let type_of_lemma = nf_zeta type_of_lemma in - observe (str "type_of_lemma := " ++ Printer.pr_lconstr_env (Global.env ()) !evd type_of_lemma); + observe (str "type_of_lemma := " ++ Printer.pr_leconstr_env (Global.env ()) !evd type_of_lemma); type_of_lemma,type_info ) funs_constr @@ -813,7 +821,7 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( Array.of_list (List.map (fun entry -> - (fst (fst(Future.force entry.Entries.const_entry_body)), Option.get entry.Entries.const_entry_type ) + (EConstr.of_constr (fst (fst(Future.force entry.Entries.const_entry_body))), EConstr.of_constr (Option.get entry.Entries.const_entry_type )) ) (make_scheme evd (Array.map_to_list (fun const -> const,GType []) funs)) ) @@ -844,7 +852,8 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( (* let lem_cst = fst (destConst (Constrintern.global_reference lem_id)) in *) let _,lem_cst_constr = Evd.fresh_global (Global.env ()) !evd (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) in - let (lem_cst,_) = destConst lem_cst_constr in + let lem_cst_constr = EConstr.of_constr lem_cst_constr in + let (lem_cst,_) = destConst !evd lem_cst_constr in update_Function {finfo with correctness_lemma = Some lem_cst}; ) @@ -858,23 +867,23 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( let type_info = (type_of_lemma_ctxt,type_of_lemma_concl) in graphs_constr.(i) <- graph; let type_of_lemma = - Termops.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt + EConstr.it_mkProd_or_LetIn type_of_lemma_concl type_of_lemma_ctxt in let type_of_lemma = nf_zeta type_of_lemma in - observe (str "type_of_lemma := " ++ Printer.pr_lconstr type_of_lemma); + observe (str "type_of_lemma := " ++ Printer.pr_leconstr type_of_lemma); type_of_lemma,type_info ) funs_constr graphs_constr in - let (kn,_) as graph_ind,u = (destInd graphs_constr.(0)) in + let (kn,_) as graph_ind,u = (destInd !evd graphs_constr.(0)) in let mib,mip = Global.lookup_inductive graph_ind in let sigma, scheme = (Indrec.build_mutual_induction_scheme (Global.env ()) !evd (Array.to_list (Array.mapi - (fun i _ -> ((kn,i),u(* Univ.Instance.empty *)),true,InType) + (fun i _ -> ((kn,i), EInstance.kind !evd u),true,InType) mib.Declarations.mind_packets ) ) @@ -904,7 +913,8 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( let finfo = find_Function_infos (fst f_as_constant) in let _,lem_cst_constr = Evd.fresh_global (Global.env ()) !evd (Constrintern.locate_reference (Libnames.qualid_of_ident lem_id)) in - let (lem_cst,_) = destConst lem_cst_constr in + let lem_cst_constr = EConstr.of_constr lem_cst_constr in + let (lem_cst,_) = destConst !evd lem_cst_constr in update_Function {finfo with completeness_lemma = Some lem_cst} ) funs) @@ -919,10 +929,11 @@ let derive_correctness make_scheme functional_induction (funs: pconstant list) ( if the type of hypothesis has not this form or if we cannot find the completeness lemma then we do nothing *) let revert_graph kn post_tac hid g = + let sigma = project g in let typ = pf_unsafe_type_of g (mkVar hid) in - match kind_of_term typ with - | App(i,args) when isInd i -> - let ((kn',num) as ind'),u = destInd i in + match EConstr.kind sigma typ with + | App(i,args) when isInd sigma i -> + let ((kn',num) as ind'),u = destInd sigma i in if MutInd.equal kn kn' then (* We have generated a graph hypothesis so that we must change it if we can *) let info = @@ -970,14 +981,15 @@ let revert_graph kn post_tac hid g = let functional_inversion kn hid fconst f_correct : tactic = fun g -> let old_ids = List.fold_right Id.Set.add (pf_ids_of_hyps g) Id.Set.empty in + let sigma = project g in let type_of_h = pf_unsafe_type_of g (mkVar hid) in - match kind_of_term type_of_h with - | App(eq,args) when eq_constr eq (make_eq ()) -> + match EConstr.kind sigma type_of_h with + | App(eq,args) when EConstr.eq_constr sigma 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 -> + match EConstr.kind sigma args.(1),EConstr.kind sigma args.(2) with + | App(f,f_args),_ when EConstr.eq_constr sigma 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 EConstr.eq_constr sigma f fconst -> ((fun hid -> tclIDTAC),f_args,args.(1)) | _ -> (fun hid -> tclFAIL 1 (mt ())),[||],args.(2) in @@ -1022,23 +1034,24 @@ let invfun qhyp f g = Proofview.V82.of_tactic begin Tactics.try_intros_until (fun hid -> Proofview.V82.tactic begin fun g -> + let sigma = project g in let hyp_typ = pf_unsafe_type_of g (mkVar hid) in - match kind_of_term hyp_typ with - | App(eq,args) when eq_constr eq (make_eq ()) -> + match EConstr.kind sigma hyp_typ with + | App(eq,args) when EConstr.eq_constr sigma eq (make_eq ()) -> begin - let f1,_ = decompose_app args.(1) in + let f1,_ = decompose_app sigma args.(1) in try - if not (isConst f1) then failwith ""; - let finfos = find_Function_infos (fst (destConst f1)) in + if not (isConst sigma f1) then failwith ""; + let finfos = find_Function_infos (fst (destConst sigma f1)) in let f_correct = mkConst(Option.get finfos.correctness_lemma) and kn = fst finfos.graph_ind in functional_inversion kn hid f1 f_correct g with | Failure "" | Option.IsNone | Not_found -> try - let f2,_ = decompose_app args.(2) in - if not (isConst f2) then failwith ""; - let finfos = find_Function_infos (fst (destConst f2)) in + let f2,_ = decompose_app sigma args.(2) in + if not (isConst sigma f2) then failwith ""; + let finfos = find_Function_infos (fst (destConst sigma f2)) in let f_correct = mkConst(Option.get finfos.correctness_lemma) and kn = fst finfos.graph_ind in diff --git a/plugins/funind/merge.ml b/plugins/funind/merge.ml index 19c2ed417..f1ca57585 100644 --- a/plugins/funind/merge.ml +++ b/plugins/funind/merge.ml @@ -32,6 +32,7 @@ module RelDecl = Context.Rel.Declaration (** {2 Useful operations on constr and glob_constr} *) +let pop c = Vars.lift (-1) c let rec popn i c = if i<=0 then c else pop (popn (i-1) c) (** Substitutions in constr *) @@ -135,13 +136,14 @@ let prNamedRLDecl s lc = let showind (id:Id.t) = let cstrid = Constrintern.global_reference id in - let ind1,cstrlist = Inductiveops.find_inductive (Global.env()) Evd.empty cstrid in - let mib1,ib1 = Inductive.lookup_mind_specif (Global.env()) (fst ind1) in + let (ind1, u),cstrlist = Inductiveops.find_inductive (Global.env()) Evd.empty (EConstr.of_constr cstrid) in + let mib1,ib1 = Inductive.lookup_mind_specif (Global.env()) ind1 in + let u = EConstr.Unsafe.to_instance u in List.iter (fun decl -> print_string (string_of_name (Context.Rel.Declaration.get_name decl) ^ ":"); prconstr (RelDecl.get_type decl); print_string "\n") ib1.mind_arity_ctxt; - Printf.printf "arity :"; prconstr (Inductiveops.type_of_inductive (Global.env ()) ind1); + Printf.printf "arity :"; prconstr (Inductiveops.type_of_inductive (Global.env ()) (ind1, u)); Array.iteri (fun i x -> Printf.printf"type constr %d :" i ; prconstr x) ib1.mind_user_lc @@ -510,14 +512,14 @@ let rec merge_app c1 c2 id1 id2 shift filter_shift_stable = let args = filter_shift_stable lnk (arr1 @ arr2) in GApp (Loc.ghost,GVar (Loc.ghost,shift.ident) , args) | GApp(_,f1, arr1), GApp(_,f2,arr2) -> raise NoMerge - | GLetIn(_,nme,bdy,trm) , _ -> + | GLetIn(_,nme,bdy,typ,trm) , _ -> let _ = prstr "\nICI2!\n" in let newtrm = merge_app trm c2 id1 id2 shift filter_shift_stable in - GLetIn(Loc.ghost,nme,bdy,newtrm) - | _, GLetIn(_,nme,bdy,trm) -> + GLetIn(Loc.ghost,nme,bdy,typ,newtrm) + | _, GLetIn(_,nme,bdy,typ,trm) -> let _ = prstr "\nICI3!\n" in let newtrm = merge_app c1 trm id1 id2 shift filter_shift_stable in - GLetIn(Loc.ghost,nme,bdy,newtrm) + GLetIn(Loc.ghost,nme,bdy,typ,newtrm) | _ -> let _ = prstr "\nICI4!\n" in raise NoMerge @@ -528,14 +530,14 @@ let rec merge_app_unsafe c1 c2 shift filter_shift_stable = let args = filter_shift_stable lnk (arr1 @ arr2) in GApp (Loc.ghost,GVar(Loc.ghost,shift.ident) , args) (* FIXME: what if the function appears in the body of the let? *) - | GLetIn(_,nme,bdy,trm) , _ -> + | GLetIn(_,nme,bdy,typ,trm) , _ -> let _ = prstr "\nICI2 '!\n" in let newtrm = merge_app_unsafe trm c2 shift filter_shift_stable in - GLetIn(Loc.ghost,nme,bdy,newtrm) - | _, GLetIn(_,nme,bdy,trm) -> + GLetIn(Loc.ghost,nme,bdy,typ,newtrm) + | _, GLetIn(_,nme,bdy,typ,trm) -> let _ = prstr "\nICI3 '!\n" in let newtrm = merge_app_unsafe c1 trm shift filter_shift_stable in - GLetIn(Loc.ghost,nme,bdy,newtrm) + GLetIn(Loc.ghost,nme,bdy,typ,newtrm) | _ -> let _ = prstr "\nICI4 '!\n" in raise NoMerge @@ -776,6 +778,7 @@ let merge_inductive_body (shift:merge_infos) avoid (oib1:one_inductive_body) let mkrawcor nme avoid typ = (* first replace rel 1 by a varname *) let substindtyp = substitterm 0 (mkRel 1) (mkVar nme) typ in + let substindtyp = EConstr.of_constr substindtyp in Detyping.detype false (Id.Set.elements avoid) (Global.env()) Evd.empty substindtyp in let lcstr1: glob_constr list = Array.to_list (Array.map (mkrawcor ind1name avoid) oib1.mind_user_lc) in @@ -822,7 +825,7 @@ let merge_rec_params_and_arity prms1 prms2 shift (concl:constr) = let _ = prNamedRConstr (string_of_name nme) tp in let _ = prstr " ; " in let typ = glob_constr_to_constr_expr tp in - LocalRawAssum ([(Loc.ghost,nme)], Constrexpr_ops.default_binder_kind, typ) :: acc) + CLocalAssum ([(Loc.ghost,nme)], Constrexpr_ops.default_binder_kind, typ) :: acc) [] params in let concl = Constrextern.extern_constr false (Global.env()) Evd.empty concl in let arity,_ = @@ -859,6 +862,7 @@ let glob_constr_list_to_inductive_expr prms1 prms2 mib1 mib2 shift let mkProd_reldecl (rdecl:Context.Rel.Declaration.t) (t2:glob_constr) = match rdecl with | LocalAssum (nme,t) -> + let t = EConstr.of_constr t in let traw = Detyping.detype false [] (Global.env()) Evd.empty t in GProd (Loc.ghost,nme,Explicit,traw,t2) | LocalDef _ -> assert false @@ -975,23 +979,24 @@ let funify_branches relinfo nfuns branch = | Rel i -> let reali = i-shift in (reali>=0 && reali<relinfo.nbranches) | _ -> false in (* FIXME: *) - LocalDef (Anonymous,mkProp,mkProp) + LocalDef (Anonymous,EConstr.mkProp,EConstr.mkProp) 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 relinfo.concl); } in + concl = EConstr.of_constr (remove_last_arg (pop (EConstr.Unsafe.to_constr 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 = EConstr.of_constr (popn nfuns (EConstr.Unsafe.to_constr 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 54066edfb..1e405d2c9 100644 --- a/plugins/funind/recdef.ml +++ b/plugins/funind/recdef.ml @@ -6,7 +6,10 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +module CVars = Vars + open Term +open EConstr open Vars open Namegen open Environ @@ -42,17 +45,16 @@ open Indfun_common open Sigma.Notations open Context.Rel.Declaration - (* Ugly things which should not be here *) let coq_constant m s = - Coqlib.coq_constant "RecursiveDefinition" m s + EConstr.of_constr (Coqlib.coq_constant "RecursiveDefinition" m s) let arith_Nat = ["Arith";"PeanoNat";"Nat"] let arith_Lt = ["Arith";"Lt"] let coq_init_constant s = - Coqlib.gen_constant_in_modules "RecursiveDefinition" Coqlib.init_modules s + EConstr.of_constr (Coqlib.gen_constant_in_modules "RecursiveDefinition" Coqlib.init_modules s) let find_reference sl s = let dp = Names.DirPath.make (List.rev_map Id.of_string sl) in @@ -76,9 +78,12 @@ let def_of_const t = ) |_ -> assert false -let type_of_const t = - match (kind_of_term t) with - Const sp -> Typeops.type_of_constant (Global.env()) sp +let type_of_const sigma t = + match (EConstr.kind sigma t) with + | Const (sp, u) -> + let u = EInstance.kind sigma u in + (* FIXME discarding universe constraints *) + Typeops.type_of_constant_in (Global.env()) (sp, u) |_ -> assert false let constr_of_global x = @@ -98,9 +103,7 @@ let nf_zeta env = let nf_betaiotazeta = (* Reductionops.local_strong Reductionops.whd_betaiotazeta *) - let clos_norm_flags flgs env sigma t = - CClosure.norm_val (CClosure.create_clos_infos flgs env) (CClosure.inject (Reductionops.nf_evar sigma t)) in - clos_norm_flags CClosure.betaiotazeta Environ.empty_env Evd.empty + Reductionops.clos_norm_flags CClosure.betaiotazeta Environ.empty_env Evd.empty @@ -116,7 +119,7 @@ let pf_get_new_ids idl g = [] let compute_renamed_type gls c = - rename_bound_vars_as_displayed (*no avoid*) [] (*no rels*) [] + rename_bound_vars_as_displayed (project gls) (*no avoid*) [] (*no rels*) [] (pf_unsafe_type_of gls c) let h'_id = Id.of_string "h'" let teq_id = Id.of_string "teq" @@ -147,7 +150,7 @@ let coq_O = function () -> (coq_init_constant "O") let coq_S = function () -> (coq_init_constant "S") let lt_n_O = function () -> (coq_constant arith_Nat "nlt_0_r") let max_ref = function () -> (find_reference ["Recdef"] "max") -let max_constr = function () -> (constr_of_global (delayed_force max_ref)) +let max_constr = function () -> EConstr.of_constr (constr_of_global (delayed_force max_ref)) let coq_conj = function () -> find_reference Coqlib.logic_module_name "conj" let f_S t = mkApp(delayed_force coq_S, [|t|]);; @@ -166,7 +169,8 @@ let simpl_iter clause = clause (* Others ugly things ... *) -let (value_f:constr list -> global_reference -> constr) = +let (value_f:Constr.constr list -> global_reference -> Constr.constr) = + let open Term in fun al fterm -> let d0 = Loc.ghost in let rev_x_id_l = @@ -199,7 +203,7 @@ let (value_f:constr list -> global_reference -> constr) = let body = fst (understand env (Evd.from_env env) glob_body)(*FIXME*) in it_mkLambda_or_LetIn body context -let (declare_f : Id.t -> logical_kind -> constr list -> global_reference -> global_reference) = +let (declare_f : Id.t -> logical_kind -> Constr.constr list -> global_reference -> global_reference) = fun f_id kind input_type fterm_ref -> declare_fun f_id kind (value_f input_type fterm_ref);; @@ -301,9 +305,9 @@ let tclUSER_if_not_mes concl_tac is_mes names_to_suppress = (* [check_not_nested forbidden e] checks that [e] does not contains any variable of [forbidden] *) -let check_not_nested forbidden e = +let check_not_nested sigma forbidden e = let rec check_not_nested e = - match kind_of_term e with + match EConstr.kind sigma e with | Rel _ -> () | Var x -> if Id.List.mem x forbidden @@ -327,7 +331,7 @@ let check_not_nested forbidden e = try check_not_nested e with UserError(_,p) -> - user_err ~hdr:"_" (str "on expr : " ++ Printer.pr_lconstr e ++ str " " ++ p) + user_err ~hdr:"_" (str "on expr : " ++ Printer.pr_leconstr e ++ str " " ++ p) (* ['a info] contains the local information for traveling *) type 'a infos = @@ -374,15 +378,17 @@ type journey_info = -let rec add_vars forbidden e = - match kind_of_term e with +let add_vars sigma forbidden e = + let rec aux forbidden e = + match EConstr.kind sigma e with | Var x -> x::forbidden - | _ -> Term.fold_constr add_vars forbidden e - + | _ -> EConstr.fold sigma aux forbidden e + in + aux forbidden e let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic = fun g -> - let rev_context,b = decompose_lam_n nb_lam e in + let rev_context,b = decompose_lam_n (project g) nb_lam e in let ids = List.fold_left (fun acc (na,_) -> let pre_id = match na with @@ -404,17 +410,17 @@ let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic = (fun g' -> let ty_teq = pf_unsafe_type_of g' (mkVar heq) in let teq_lhs,teq_rhs = - let _,args = try destApp ty_teq with DestKO -> assert false in + let _,args = try destApp (project g') ty_teq with DestKO -> assert false in args.(1),args.(2) in - let new_b' = Termops.replace_term teq_lhs teq_rhs new_b in + let new_b' = Termops.replace_term (project g') teq_lhs teq_rhs new_b in let new_infos = { infos with info = new_b'; eqs = heq::infos.eqs; forbidden_ids = if forbid_new_ids - then add_vars infos.forbidden_ids new_b' + then add_vars (project g') infos.forbidden_ids new_b' else infos.forbidden_ids } in finalize_tac new_infos g' @@ -423,8 +429,9 @@ let treat_case forbid_new_ids to_intros finalize_tac nb_lam e infos : tactic = ) ] g -let rec travel_aux jinfo continuation_tac (expr_info:constr infos) = - match kind_of_term expr_info.info with +let rec travel_aux jinfo continuation_tac (expr_info:constr infos) g = + let sigma = project g in + match EConstr.kind sigma expr_info.info with | CoFix _ | Fix _ -> error "Function cannot treat local fixpoint or cofixpoint" | Proj _ -> error "Function cannot treat projections" | LetIn(na,b,t,e) -> @@ -433,24 +440,24 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) = jinfo.letiN (na,b,t,e) expr_info continuation_tac in travel jinfo new_continuation_tac - {expr_info with info = b; is_final=false} + {expr_info with info = b; is_final=false} g end | Rel _ -> anomaly (Pp.str "Free var in goal conclusion !") | Prod _ -> begin try - check_not_nested (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; - jinfo.otherS () expr_info continuation_tac expr_info + check_not_nested sigma (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; + jinfo.otherS () expr_info continuation_tac expr_info g with e when CErrors.noncritical e -> - user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain a recursive call to " ++ pr_id expr_info.f_id) + user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr expr_info.info ++ str " can not contain a recursive call to " ++ pr_id expr_info.f_id) end | Lambda(n,t,b) -> begin try - check_not_nested (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; - jinfo.otherS () expr_info continuation_tac expr_info + check_not_nested sigma (expr_info.f_id::expr_info.forbidden_ids) expr_info.info; + jinfo.otherS () expr_info continuation_tac expr_info g with e when CErrors.noncritical e -> - user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain a recursive call to " ++ pr_id expr_info.f_id) + user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr expr_info.info ++ str " can not contain a recursive call to " ++ pr_id expr_info.f_id) end | Case(ci,t,a,l) -> begin @@ -461,15 +468,15 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) = travel jinfo continuation_tac_a {expr_info with info = a; is_main_branch = false; - is_final = false} + is_final = false} g end | App _ -> - let f,args = decompose_app expr_info.info in - if eq_constr f (expr_info.f_constr) - then jinfo.app_reC (f,args) expr_info continuation_tac expr_info + let f,args = decompose_app sigma expr_info.info in + if EConstr.eq_constr sigma f (expr_info.f_constr) + then jinfo.app_reC (f,args) expr_info continuation_tac expr_info g else begin - match kind_of_term f with + match EConstr.kind sigma f with | App _ -> assert false (* f is coming from a decompose_app *) | Const _ | Construct _ | Rel _ | Evar _ | Meta _ | Ind _ | Sort _ | Prod _ | Var _ -> @@ -477,15 +484,15 @@ let rec travel_aux jinfo continuation_tac (expr_info:constr infos) = let new_continuation_tac = jinfo.apP (f,args) expr_info continuation_tac in travel_args jinfo - expr_info.is_main_branch new_continuation_tac new_infos - | Case _ -> user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_lconstr expr_info.info ++ str " can not contain an applied match (See Limitation in Section 2.3 of refman)") - | _ -> anomaly (Pp.str "travel_aux : unexpected "++ Printer.pr_lconstr expr_info.info) + expr_info.is_main_branch new_continuation_tac new_infos g + | Case _ -> user_err ~hdr:"Recdef.travel" (str "the term " ++ Printer.pr_leconstr expr_info.info ++ str " can not contain an applied match (See Limitation in Section 2.3 of refman)") + | _ -> anomaly (Pp.str "travel_aux : unexpected "++ Printer.pr_leconstr expr_info.info) end - | Cast(t,_,_) -> travel jinfo continuation_tac {expr_info with info=t} + | Cast(t,_,_) -> travel jinfo continuation_tac {expr_info with info=t} g | Const _ | Var _ | Meta _ | Evar _ | Sort _ | Construct _ | Ind _ -> let new_continuation_tac = jinfo.otherS () expr_info continuation_tac in - new_continuation_tac expr_info + new_continuation_tac expr_info g and travel_args jinfo is_final continuation_tac infos = let (f_args',args) = infos.info in match args with @@ -502,27 +509,28 @@ and travel_args jinfo is_final continuation_tac infos = {infos with info=arg;is_final=false} and travel jinfo continuation_tac expr_info = observe_tac - (str jinfo.message ++ Printer.pr_lconstr expr_info.info) + (str jinfo.message ++ Printer.pr_leconstr expr_info.info) (travel_aux jinfo continuation_tac expr_info) (* Termination proof *) let rec prove_lt hyple g = + let sigma = project g in begin try - let (varx,varz) = match decompose_app (pf_concl g) with - | _, x::z::_ when isVar x && isVar z -> x, z + let (varx,varz) = match decompose_app sigma (pf_concl g) with + | _, x::z::_ when isVar sigma x && isVar sigma z -> x, z | _ -> assert false in let h = List.find (fun id -> - match decompose_app (pf_unsafe_type_of g (mkVar id)) with - | _, t::_ -> eq_constr t varx + match decompose_app sigma (pf_unsafe_type_of g (mkVar id)) with + | _, t::_ -> EConstr.eq_constr sigma t varx | _ -> false ) hyple in let y = - List.hd (List.tl (snd (decompose_app (pf_unsafe_type_of g (mkVar h))))) in + List.hd (List.tl (snd (decompose_app sigma (pf_unsafe_type_of g (mkVar h))))) in observe_tclTHENLIST (str "prove_lt1")[ Proofview.V82.of_tactic (apply (mkApp(le_lt_trans (),[|varx;y;varz;mkVar h|]))); observe_tac (str "prove_lt") (prove_lt hyple) @@ -638,12 +646,13 @@ let terminate_others _ expr_info continuation_tac infos = ] else continuation_tac infos -let terminate_letin (na,b,t,e) expr_info continuation_tac info = +let terminate_letin (na,b,t,e) expr_info continuation_tac info g = + let sigma = project g in let new_e = subst1 info.info e in let new_forbidden = let forbid = try - check_not_nested (expr_info.f_id::expr_info.forbidden_ids) b; + check_not_nested sigma (expr_info.f_id::expr_info.forbidden_ids) b; true with e when CErrors.noncritical e -> false in @@ -654,7 +663,7 @@ let terminate_letin (na,b,t,e) expr_info continuation_tac info = | Name id -> id::info.forbidden_ids else info.forbidden_ids in - continuation_tac {info with info = new_e; forbidden_ids = new_forbidden} + continuation_tac {info with info = new_e; forbidden_ids = new_forbidden} g let pf_type c tac gl = let evars, ty = Typing.type_of (pf_env gl) (project gl) c in @@ -681,7 +690,7 @@ let mkDestructEq : (fun decl -> let open Context.Named.Declaration in let id = get_id decl in - if Id.List.mem id not_on_hyp || not (Termops.occur_term expr (get_type decl)) + if Id.List.mem id not_on_hyp || not (Termops.occur_term (project g) expr (get_type decl)) then None else Some id) hyps in let to_revert_constr = List.rev_map mkVar to_revert in let type_of_expr = pf_unsafe_type_of g expr in @@ -693,16 +702,18 @@ let mkDestructEq : (fun g2 -> let changefun patvars = { run = fun sigma -> let redfun = pattern_occs [Locus.AllOccurrencesBut [1], expr] in - redfun.Reductionops.e_redfun (pf_env g2) sigma (pf_concl g2) + let Sigma (c, sigma, p) = redfun.Reductionops.e_redfun (pf_env g2) sigma (pf_concl g2) in + Sigma (c, sigma, p) } in Proofview.V82.of_tactic (change_in_concl None changefun) g2); Proofview.V82.of_tactic (simplest_case expr)]), to_revert let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = + let sigma = project g in let f_is_present = try - check_not_nested (expr_info.f_id::expr_info.forbidden_ids) a; + check_not_nested sigma (expr_info.f_id::expr_info.forbidden_ids) a; false with e when CErrors.noncritical e -> true @@ -716,7 +727,7 @@ let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = let destruct_tac,rev_to_thin_intro = mkDestructEq [expr_info.rec_arg_id] a' g in let to_thin_intro = List.rev rev_to_thin_intro in - observe_tac (str "treating cases (" ++ int (Array.length l) ++ str")" ++ spc () ++ Printer.pr_lconstr a') + observe_tac (str "treating cases (" ++ int (Array.length l) ++ str")" ++ spc () ++ Printer.pr_leconstr a') (try (tclTHENS destruct_tac @@ -725,16 +736,17 @@ let terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos g = with | UserError(Some "Refiner.thensn_tac3",_) | UserError(Some "Refiner.tclFAIL_s",_) -> - (observe_tac (str "is computable " ++ Printer.pr_lconstr new_info.info) (next_step continuation_tac {new_info with info = nf_betaiotazeta new_info.info} ) + (observe_tac (str "is computable " ++ Printer.pr_leconstr new_info.info) (next_step continuation_tac {new_info with info = nf_betaiotazeta new_info.info} ) )) g -let terminate_app_rec (f,args) expr_info continuation_tac _ = - List.iter (check_not_nested (expr_info.f_id::expr_info.forbidden_ids)) +let terminate_app_rec (f,args) expr_info continuation_tac _ g = + let sigma = project g in + List.iter (check_not_nested sigma (expr_info.f_id::expr_info.forbidden_ids)) args; begin try - let v = List.assoc_f (List.equal Constr.equal) args expr_info.args_assoc in + let v = List.assoc_f (List.equal (EConstr.eq_constr sigma)) args expr_info.args_assoc in let new_infos = {expr_info with info = v} in observe_tclTHENLIST (str "terminate_app_rec")[ continuation_tac new_infos; @@ -748,7 +760,7 @@ let terminate_app_rec (f,args) expr_info continuation_tac _ = ] else tclIDTAC - ] + ] g 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)))) @@ -805,7 +817,7 @@ let terminate_app_rec (f,args) expr_info continuation_tac _ = ); ] ]) - ]) + ]) g end let terminate_info = @@ -827,8 +839,9 @@ let equation_case next_step (ci,a,t,l) expr_info continuation_tac infos = observe_tac (str "equation case") (terminate_case next_step (ci,a,t,l) expr_info continuation_tac infos) let rec prove_le g = + let sigma = project g in let x,z = - let _,args = decompose_app (pf_concl g) in + let _,args = decompose_app sigma (pf_concl g) in (List.hd args,List.hd (List.tl args)) in tclFIRST[ @@ -838,11 +851,11 @@ let rec prove_le g = try let matching_fun = pf_is_matching g - (Pattern.PApp(Pattern.PRef (reference_of_constr (le ())),[|Pattern.PVar (destVar x);Pattern.PMeta None|])) in + (Pattern.PApp(Pattern.PRef (reference_of_constr (EConstr.Unsafe.to_constr (le ()))),[|Pattern.PVar (destVar sigma x);Pattern.PMeta None|])) in let (h,t) = List.find (fun (_,t) -> matching_fun t) (pf_hyps_types g) in let y = - let _,args = decompose_app t in + let _,args = decompose_app sigma t in List.hd (List.tl args) in observe_tclTHENLIST (str "prove_le")[ @@ -860,11 +873,12 @@ let rec make_rewrite_list expr_info max = function observe_tac (str "make_rewrite_list") (tclTHENS (observe_tac (str "rewrite heq on " ++ pr_id p ) ( (fun g -> + let sigma = project g in let t_eq = compute_renamed_type g (mkVar hp) in let k,def = - let k_na,_,t = destProd t_eq in - let _,_,t = destProd t in - let def_na,_,_ = destProd t in + let k_na,_,t = destProd sigma t_eq in + let _,_,t = destProd sigma t in + let def_na,_,_ = destProd sigma t in Nameops.out_name k_na,Nameops.out_name def_na in Proofview.V82.of_tactic (general_rewrite_bindings false Locus.AllOccurrences @@ -872,7 +886,7 @@ let rec make_rewrite_list expr_info max = function (mkVar hp, ExplicitBindings[Loc.ghost,NamedHyp def, expr_info.f_constr;Loc.ghost,NamedHyp k, - (f_S max)]) false) g) ) + f_S max]) false) g) ) ) [make_rewrite_list expr_info max l; observe_tclTHENLIST (str "make_rewrite_list")[ (* x < S max proof *) @@ -886,11 +900,12 @@ let make_rewrite expr_info l hp max = (observe_tac (str "make_rewrite") (make_rewrite_list expr_info max l)) (observe_tac (str "make_rewrite") (tclTHENS (fun g -> + let sigma = project g in let t_eq = compute_renamed_type g (mkVar hp) in let k,def = - let k_na,_,t = destProd t_eq in - let _,_,t = destProd t in - let def_na,_,_ = destProd t in + let k_na,_,t = destProd sigma t_eq in + let _,_,t = destProd sigma t in + let def_na,_,_ = destProd sigma t in Nameops.out_name k_na,Nameops.out_name def_na in observe_tac (str "general_rewrite_bindings") @@ -899,7 +914,7 @@ let make_rewrite expr_info l hp max = (mkVar hp, ExplicitBindings[Loc.ghost,NamedHyp def, expr_info.f_constr;Loc.ghost,NamedHyp k, - (f_S (f_S max))]) false)) g) + f_S (f_S max)]) false)) g) [observe_tac(str "make_rewrite finalize") ( (* tclORELSE( h_reflexivity) *) (observe_tclTHENLIST (str "make_rewrite")[ @@ -916,7 +931,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 ] ]) @@ -974,23 +989,24 @@ let rec intros_values_eq expr_info acc = let equation_others _ expr_info continuation_tac infos = if expr_info.is_final && expr_info.is_main_branch then - observe_tac (str "equation_others (cont_tac +intros) " ++ Printer.pr_lconstr expr_info.info) + observe_tac (str "equation_others (cont_tac +intros) " ++ Printer.pr_leconstr expr_info.info) (tclTHEN (continuation_tac infos) - (observe_tac (str "intros_values_eq equation_others " ++ Printer.pr_lconstr expr_info.info) (intros_values_eq expr_info []))) - else observe_tac (str "equation_others (cont_tac) " ++ Printer.pr_lconstr expr_info.info) (continuation_tac infos) + (observe_tac (str "intros_values_eq equation_others " ++ Printer.pr_leconstr expr_info.info) (intros_values_eq expr_info []))) + else observe_tac (str "equation_others (cont_tac) " ++ Printer.pr_leconstr expr_info.info) (continuation_tac infos) let equation_app f_and_args expr_info continuation_tac infos = if expr_info.is_final && expr_info.is_main_branch then ((observe_tac (str "intros_values_eq equation_app") (intros_values_eq expr_info []))) else continuation_tac infos -let equation_app_rec (f,args) expr_info continuation_tac info = +let equation_app_rec (f,args) expr_info continuation_tac info g = + let sigma = project g in begin try - let v = List.assoc_f (List.equal Constr.equal) args expr_info.args_assoc in + let v = List.assoc_f (List.equal (EConstr.eq_constr sigma)) args expr_info.args_assoc in let new_infos = {expr_info with info = v} in - observe_tac (str "app_rec found") (continuation_tac new_infos) + observe_tac (str "app_rec found") (continuation_tac new_infos) g with Not_found -> if expr_info.is_final && expr_info.is_main_branch then @@ -998,12 +1014,12 @@ let equation_app_rec (f,args) expr_info continuation_tac info = [ Proofview.V82.of_tactic (simplest_case (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 []) - ] + ] g else observe_tclTHENLIST (str "equation_app_rec1")[ Proofview.V82.of_tactic (simplest_case (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}) - ] + ] g end let equation_info = @@ -1022,6 +1038,8 @@ let prove_eq = travel equation_info (* [compute_terminate_type] computes the type of the Definition f_terminate from the type of f_F *) let compute_terminate_type nb_args func = + let open Term in + let open CVars in let _,a_arrow_b,_ = destLambda(def_of_const (constr_of_global func)) in let rev_args,b = decompose_prod_n nb_args a_arrow_b in let left = @@ -1034,6 +1052,7 @@ let compute_terminate_type nb_args func = ) in let right = mkRel 5 in + let delayed_force c = EConstr.Unsafe.to_constr (delayed_force c) in let equality = mkApp(delayed_force eq, [|lift 5 b; left; right|]) in let result = (mkProd ((Name def_id) , lift 4 a_arrow_b, equality)) in let cond = mkApp(delayed_force lt, [|(mkRel 2); (mkRel 1)|]) in @@ -1046,7 +1065,7 @@ let compute_terminate_type nb_args func = delayed_force nat, (mkProd (Name k_id, delayed_force nat, mkArrow cond result))))|])in - let value = mkApp(constr_of_global (delayed_force coq_sig_ref), + let value = mkApp(constr_of_global (Util.delayed_force coq_sig_ref), [|b; (mkLambda (Name v_id, b, nb_iter))|]) in compose_prod rev_args value @@ -1130,25 +1149,27 @@ let termination_proof_header is_mes input_type ids args_id relation -let rec instantiate_lambda t l = +let rec instantiate_lambda sigma t l = match l with | [] -> t | a::l -> - let (_, _, body) = destLambda t in - instantiate_lambda (subst1 a body) l + let (_, _, body) = destLambda sigma t in + instantiate_lambda sigma (subst1 a body) l let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_arg_num : tactic = begin fun g -> + let sigma = project g in let ids = Termops.ids_of_named_context (pf_hyps g) in let func_body = (def_of_const (constr_of_global func)) in - let (f_name, _, body1) = destLambda func_body in + let func_body = EConstr.of_constr func_body in + let (f_name, _, body1) = destLambda sigma func_body in let f_id = match f_name with | Name f_id -> next_ident_away_in_goal f_id ids | Anonymous -> anomaly (Pp.str "Anonymous function") in - let n_names_types,_ = decompose_lam_n nb_args body1 in + let n_names_types,_ = decompose_lam_n sigma nb_args body1 in let n_ids,ids = List.fold_left (fun (n_ids,ids) (n_name,_) -> @@ -1162,7 +1183,7 @@ let whole_start (concl_tac:tactic) nb_args is_mes func input_type relation rec_a n_names_types in let rec_arg_id = List.nth n_ids (rec_arg_num - 1) in - let expr = instantiate_lambda func_body (mkVar f_id::(List.map mkVar n_ids)) in + let expr = instantiate_lambda sigma func_body (mkVar f_id::(List.map mkVar n_ids)) in termination_proof_header is_mes input_type @@ -1204,17 +1225,17 @@ let get_current_subgoals_types () = let { Evd.it=sgs ; sigma=sigma } = Proof.V82.subgoals p in sigma, List.map (Goal.V82.abstract_type sigma) sgs -let build_and_l l = +let build_and_l sigma l = let and_constr = Coqlib.build_coq_and () in let conj_constr = coq_conj () in let mk_and p1 p2 = - Term.mkApp(and_constr,[|p1;p2|]) in + mkApp(EConstr.of_constr and_constr,[|p1;p2|]) in let rec is_well_founded t = - match kind_of_term t with + match EConstr.kind sigma t with | Prod(_,_,t') -> is_well_founded t' | App(_,_) -> - let (f,_) = decompose_app t in - eq_constr f (well_founded ()) + let (f,_) = decompose_app sigma t in + EConstr.eq_constr sigma f (well_founded ()) | _ -> false in @@ -1231,7 +1252,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 @@ -1245,16 +1266,16 @@ let is_rec_res id = String.equal (String.sub id_name 0 (String.length rec_res_name)) rec_res_name with Invalid_argument _ -> false -let clear_goals = +let clear_goals sigma = let rec clear_goal t = - match kind_of_term t with + match EConstr.kind sigma t with | Prod(Name id as na,t',b) -> let b' = clear_goal b in - if noccurn 1 b' && (is_rec_res id) - then Termops.pop b' + if noccurn sigma 1 b' && (is_rec_res id) + then Vars.lift (-1) b' else if b' == b then t else mkProd(na,t',b') - | _ -> Term.map_constr clear_goal t + | _ -> EConstr.map sigma clear_goal t in List.map clear_goal @@ -1262,9 +1283,9 @@ let clear_goals = let build_new_goal_type () = let sigma, sub_gls_types = get_current_subgoals_types () in (* Pp.msgnl (str "sub_gls_types1 := " ++ Util.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *) - let sub_gls_types = clear_goals sub_gls_types in + let sub_gls_types = clear_goals sigma sub_gls_types in (* Pp.msgnl (str "sub_gls_types2 := " ++ Pp.prlist_with_sep (fun () -> Pp.fnl () ++ Pp.fnl ()) Printer.pr_lconstr sub_gls_types); *) - let res = build_and_l sub_gls_types in + let res = build_and_l sigma sub_gls_types in sigma, res let is_opaque_constant c = @@ -1285,7 +1306,7 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp anomaly (Pp.str "open_new_goal with an unamed theorem") in let na = next_global_ident_away name [] in - if Termops.occur_existential gls_type then + if Termops.occur_existential sigma gls_type then CErrors.error "\"abstract\" cannot handle existentials"; let hook _ _ = let opacity = @@ -1296,7 +1317,7 @@ let open_new_goal build_proof sigma using_lemmas ref_ goal_name (gls_type,decomp | _ -> anomaly ~label:"equation_lemma" (Pp.str "not a constant") in let lemma = mkConst (Names.Constant.make1 (Lib.make_kn na)) in - ref_ := Some lemma ; + ref_ := Value (EConstr.Unsafe.to_constr lemma); let lid = ref [] in let h_num = ref (-1) in let env = Global.env () in @@ -1322,8 +1343,9 @@ 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 ()) -> + let sigma = project g in + match EConstr.kind sigma (pf_concl g) with + | App(f,_) when EConstr.eq_constr sigma f (well_founded ()) -> Proofview.V82.of_tactic (Auto.h_auto None [] (Some [])) g | _ -> incr h_num; @@ -1366,7 +1388,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 ]) ) @@ -1396,7 +1418,7 @@ let com_terminate let (evmap, env) = Lemmas.get_current_context() in Lemmas.start_proof thm_name (Global, false (* FIXME *), Proof Lemma) ~sign:(Environ.named_context_val env) - ctx (compute_terminate_type nb_args fonctional_ref) hook; + ctx (EConstr.of_constr (compute_terminate_type nb_args fonctional_ref)) hook; ignore (by (Proofview.V82.tactic (observe_tac (str "starting_tac") tac_start))); ignore (by (Proofview.V82.tactic (observe_tac (str "whole_start") (whole_start tac_end nb_args is_mes fonctional_ref @@ -1412,6 +1434,7 @@ let com_terminate (new_goal_type); with Failure "empty list of subgoals!" -> (* a non recursive function declared with measure ! *) + tcc_lemma_ref := Not_needed; defined () @@ -1420,9 +1443,11 @@ let com_terminate let start_equation (f:global_reference) (term_f:global_reference) (cont_tactic:Id.t list -> tactic) g = + let sigma = project g in let ids = pf_ids_of_hyps g in let terminate_constr = constr_of_global term_f in - let nargs = nb_prod (fst (type_of_const terminate_constr)) (*FIXME*) in + let terminate_constr = EConstr.of_constr terminate_constr in + let nargs = nb_prod (project g) (EConstr.of_constr (type_of_const sigma terminate_constr)) in let x = n_x_id ids nargs in observe_tac (str "start_equation") (observe_tclTHENLIST (str "start_equation") [ h_intros x; @@ -1434,8 +1459,9 @@ let start_equation (f:global_reference) (term_f:global_reference) let (com_eqn : int -> Id.t -> global_reference -> global_reference -> global_reference - -> constr -> unit) = + -> Constr.constr -> unit) = fun nb_arg eq_name functional_ref f_ref terminate_ref equation_lemma_type -> + let open CVars in let opacity = match terminate_ref with | ConstRef c -> is_opaque_constant c @@ -1448,20 +1474,20 @@ let (com_eqn : int -> Id.t -> (Lemmas.start_proof eq_name (Global, false, Proof Lemma) ~sign:(Environ.named_context_val env) evmap - equation_lemma_type + (EConstr.of_constr equation_lemma_type) (Lemmas.mk_hook (fun _ _ -> ())); ignore (by (Proofview.V82.tactic (start_equation f_ref terminate_ref (fun x -> prove_eq (fun _ -> tclIDTAC) {nb_arg=nb_arg; - f_terminate = constr_of_global terminate_ref; - f_constr = f_constr; + f_terminate = EConstr.of_constr (constr_of_global terminate_ref); + f_constr = EConstr.of_constr f_constr; concl_tac = tclIDTAC; func=functional_ref; - info=(instantiate_lambda - (def_of_const (constr_of_global functional_ref)) - (f_constr::List.map mkVar x) + info=(instantiate_lambda Evd.empty + (EConstr.of_constr (def_of_const (constr_of_global functional_ref))) + (EConstr.of_constr f_constr::List.map mkVar x) ); is_main_branch = true; is_final = true; @@ -1484,22 +1510,27 @@ let (com_eqn : int -> Id.t -> (* Pp.msgnl (str "eqn finished"); *) );; - let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num eq generate_induction_principle using_lemmas : unit = + let open Term in + let open CVars in let env = Global.env() in let evd = ref (Evd.from_env env) in let function_type = interp_type_evars env evd type_of_f in + let function_type = EConstr.Unsafe.to_constr function_type in let env = push_named (Context.Named.Declaration.LocalAssum (function_name,function_type)) env in (* Pp.msgnl (str "function type := " ++ Printer.pr_lconstr function_type); *) let ty = interp_type_evars env evd ~impls:rec_impls eq in + let ty = EConstr.Unsafe.to_constr ty in let evm, nf = Evarutil.nf_evars_and_universes !evd in - let equation_lemma_type = nf_betaiotazeta (nf ty) in + let equation_lemma_type = nf_betaiotazeta (EConstr.of_constr (nf ty)) in let function_type = nf function_type in + let equation_lemma_type = EConstr.Unsafe.to_constr equation_lemma_type in (* Pp.msgnl (str "lemma type := " ++ Printer.pr_lconstr equation_lemma_type ++ fnl ()); *) let res_vars,eq' = decompose_prod equation_lemma_type in let env_eq' = Environ.push_rel_context (List.map (fun (x,y) -> LocalAssum (x,y)) res_vars) env in - let eq' = nf_zeta env_eq' eq' in + let eq' = nf_zeta env_eq' (EConstr.of_constr eq') in + let eq' = EConstr.Unsafe.to_constr eq' in let res = (* Pp.msgnl (str "res_var :=" ++ Printer.pr_lconstr_env (push_rel_context (List.map (function (x,t) -> (x,None,t)) res_vars) env) eq'); *) (* Pp.msgnl (str "rec_arg_num := " ++ str (string_of_int rec_arg_num)); *) @@ -1524,7 +1555,7 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num in let evm = Evd.from_ctx evuctx in let tcc_lemma_name = add_suffix function_name "_tcc" in - let tcc_lemma_constr = ref None in + let tcc_lemma_constr = ref Undefined in (* let _ = Pp.msgnl (str "relation := " ++ Printer.pr_lconstr_env env_with_pre_rec_args relation) in *) let hook _ _ = let term_ref = Nametab.locate (qualid_of_ident term_id) in @@ -1552,9 +1583,9 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num and functional_ref = destConst (constr_of_global functional_ref) and eq_ref = destConst (constr_of_global eq_ref) in generate_induction_principle f_ref tcc_lemma_constr - functional_ref eq_ref rec_arg_num rec_arg_type (nb_prod res) relation; - if Flags.is_verbose () - then msgnl (h 1 (Ppconstr.pr_id function_name ++ + functional_ref eq_ref rec_arg_num (EConstr.of_constr rec_arg_type) (nb_prod evm (EConstr.of_constr res)) (EConstr.of_constr relation); + Flags.if_verbose + msgnl (h 1 (Ppconstr.pr_id function_name ++ spc () ++ str"is defined" )++ fnl () ++ h 1 (Ppconstr.pr_id equation_id ++ spc () ++ str"is defined" ) @@ -1565,8 +1596,8 @@ let recursive_definition is_mes function_name rec_impls type_of_f r rec_arg_num tcc_lemma_name tcc_lemma_constr is_mes functional_ref - rec_arg_type - relation rec_arg_num + (EConstr.of_constr rec_arg_type) + (EConstr.of_constr relation) rec_arg_num term_id using_lemmas (List.length res_vars) diff --git a/plugins/funind/recdef.mli b/plugins/funind/recdef.mli index f60eedbe6..80f02e01c 100644 --- a/plugins/funind/recdef.mli +++ b/plugins/funind/recdef.mli @@ -13,8 +13,8 @@ bool -> Constrexpr.constr_expr -> Constrexpr.constr_expr -> int -> Constrexpr.constr_expr -> (Term.pconstant -> - Term.constr option ref -> + Indfun_common.tcc_lemma_value ref -> Term.pconstant -> - Term.pconstant -> int -> Term.types -> int -> Term.constr -> 'a) -> Constrexpr.constr_expr list -> unit + Term.pconstant -> int -> EConstr.types -> int -> EConstr.constr -> 'a) -> Constrexpr.constr_expr list -> unit diff --git a/plugins/ltac/Ltac.v b/plugins/ltac/Ltac.v new file mode 100644 index 000000000..e69de29bb --- /dev/null +++ b/plugins/ltac/Ltac.v diff --git a/plugins/ltac/coretactics.ml4 b/plugins/ltac/coretactics.ml4 new file mode 100644 index 000000000..28ff6df83 --- /dev/null +++ b/plugins/ltac/coretactics.ml4 @@ -0,0 +1,329 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i camlp4deps: "grammar/grammar.cma" i*) + +open Util +open Names +open Locus +open Misctypes +open Genredexpr +open Stdarg +open Extraargs + +open Sigma.Notations + +DECLARE PLUGIN "coretactics" + +(** Basic tactics *) + +TACTIC EXTEND reflexivity + [ "reflexivity" ] -> [ Tactics.intros_reflexivity ] +END + +TACTIC EXTEND exact + [ "exact" casted_constr(c) ] -> [ Tactics.exact_no_check c ] +END + +TACTIC EXTEND assumption + [ "assumption" ] -> [ Tactics.assumption ] +END + +TACTIC EXTEND etransitivity + [ "etransitivity" ] -> [ Tactics.intros_transitivity None ] +END + +TACTIC EXTEND cut + [ "cut" constr(c) ] -> [ Tactics.cut c ] +END + +TACTIC EXTEND exact_no_check + [ "exact_no_check" constr(c) ] -> [ Tactics.exact_no_check c ] +END + +TACTIC EXTEND vm_cast_no_check + [ "vm_cast_no_check" constr(c) ] -> [ Tactics.vm_cast_no_check c ] +END + +TACTIC EXTEND native_cast_no_check + [ "native_cast_no_check" constr(c) ] -> [ Tactics.native_cast_no_check c ] +END + +TACTIC EXTEND casetype + [ "casetype" constr(c) ] -> [ Tactics.case_type c ] +END + +TACTIC EXTEND elimtype + [ "elimtype" constr(c) ] -> [ Tactics.elim_type c ] +END + +TACTIC EXTEND lapply + [ "lapply" constr(c) ] -> [ Tactics.cut_and_apply c ] +END + +TACTIC EXTEND transitivity + [ "transitivity" constr(c) ] -> [ Tactics.intros_transitivity (Some c) ] +END + +(** Left *) + +TACTIC EXTEND left + [ "left" ] -> [ Tactics.left_with_bindings false NoBindings ] +END + +TACTIC EXTEND eleft + [ "eleft" ] -> [ Tactics.left_with_bindings true NoBindings ] +END + +TACTIC EXTEND left_with + [ "left" "with" bindings(bl) ] -> [ + Tacticals.New.tclDELAYEDWITHHOLES false bl (fun bl -> Tactics.left_with_bindings false bl) + ] +END + +TACTIC EXTEND eleft_with + [ "eleft" "with" bindings(bl) ] -> [ + Tacticals.New.tclDELAYEDWITHHOLES true bl (fun bl -> Tactics.left_with_bindings true bl) + ] +END + +(** Right *) + +TACTIC EXTEND right + [ "right" ] -> [ Tactics.right_with_bindings false NoBindings ] +END + +TACTIC EXTEND eright + [ "eright" ] -> [ Tactics.right_with_bindings true NoBindings ] +END + +TACTIC EXTEND right_with + [ "right" "with" bindings(bl) ] -> [ + Tacticals.New.tclDELAYEDWITHHOLES false bl (fun bl -> Tactics.right_with_bindings false bl) + ] +END + +TACTIC EXTEND eright_with + [ "eright" "with" bindings(bl) ] -> [ + Tacticals.New.tclDELAYEDWITHHOLES true bl (fun bl -> Tactics.right_with_bindings true bl) + ] +END + +(** Constructor *) + +TACTIC EXTEND constructor + [ "constructor" ] -> [ Tactics.any_constructor false None ] +| [ "constructor" int_or_var(i) ] -> [ + Tactics.constructor_tac false None i NoBindings + ] +| [ "constructor" int_or_var(i) "with" bindings(bl) ] -> [ + let tac bl = Tactics.constructor_tac false None i bl in + Tacticals.New.tclDELAYEDWITHHOLES false bl tac + ] +END + +TACTIC EXTEND econstructor + [ "econstructor" ] -> [ Tactics.any_constructor true None ] +| [ "econstructor" int_or_var(i) ] -> [ + Tactics.constructor_tac true None i NoBindings + ] +| [ "econstructor" int_or_var(i) "with" bindings(bl) ] -> [ + let tac bl = Tactics.constructor_tac true None i bl in + Tacticals.New.tclDELAYEDWITHHOLES true bl tac + ] +END + +(** Specialize *) + +TACTIC EXTEND specialize + [ "specialize" constr_with_bindings(c) ] -> [ + Tacticals.New.tclDELAYEDWITHHOLES false c (fun c -> Tactics.specialize c None) + ] +| [ "specialize" constr_with_bindings(c) "as" intropattern(ipat) ] -> [ + Tacticals.New.tclDELAYEDWITHHOLES false c (fun c -> Tactics.specialize c (Some ipat)) + ] +END + +TACTIC EXTEND symmetry + [ "symmetry" ] -> [ Tactics.intros_symmetry {onhyps=Some[];concl_occs=AllOccurrences} ] +END + +TACTIC EXTEND symmetry_in +| [ "symmetry" "in" in_clause(cl) ] -> [ Tactics.intros_symmetry cl ] +END + +(** Split *) + +let rec delayed_list = function +| [] -> { Tacexpr.delayed = fun _ sigma -> Sigma.here [] sigma } +| x :: l -> + { Tacexpr.delayed = fun env sigma -> + let Sigma (x, sigma, p) = x.Tacexpr.delayed env sigma in + let Sigma (l, sigma, q) = (delayed_list l).Tacexpr.delayed env sigma in + Sigma (x :: l, sigma, p +> q) } + +TACTIC EXTEND split + [ "split" ] -> [ Tactics.split_with_bindings false [NoBindings] ] +END + +TACTIC EXTEND esplit + [ "esplit" ] -> [ Tactics.split_with_bindings true [NoBindings] ] +END + +TACTIC EXTEND split_with + [ "split" "with" bindings(bl) ] -> [ + Tacticals.New.tclDELAYEDWITHHOLES false bl (fun bl -> Tactics.split_with_bindings false [bl]) + ] +END + +TACTIC EXTEND esplit_with + [ "esplit" "with" bindings(bl) ] -> [ + Tacticals.New.tclDELAYEDWITHHOLES true bl (fun bl -> Tactics.split_with_bindings true [bl]) + ] +END + +TACTIC EXTEND exists + [ "exists" ] -> [ Tactics.split_with_bindings false [NoBindings] ] +| [ "exists" ne_bindings_list_sep(bll, ",") ] -> [ + Tacticals.New.tclDELAYEDWITHHOLES false (delayed_list bll) (fun bll -> Tactics.split_with_bindings false bll) + ] +END + +TACTIC EXTEND eexists + [ "eexists" ] -> [ Tactics.split_with_bindings true [NoBindings] ] +| [ "eexists" ne_bindings_list_sep(bll, ",") ] -> [ + Tacticals.New.tclDELAYEDWITHHOLES true (delayed_list bll) (fun bll -> Tactics.split_with_bindings true bll) + ] +END + +(** Intro *) + +TACTIC EXTEND intros_until + [ "intros" "until" quantified_hypothesis(h) ] -> [ Tactics.intros_until h ] +END + +TACTIC EXTEND intro +| [ "intro" ] -> [ Tactics.intro_move None MoveLast ] +| [ "intro" ident(id) ] -> [ Tactics.intro_move (Some id) MoveLast ] +| [ "intro" ident(id) "at" "top" ] -> [ Tactics.intro_move (Some id) MoveFirst ] +| [ "intro" ident(id) "at" "bottom" ] -> [ Tactics.intro_move (Some id) MoveLast ] +| [ "intro" ident(id) "after" hyp(h) ] -> [ Tactics.intro_move (Some id) (MoveAfter h) ] +| [ "intro" ident(id) "before" hyp(h) ] -> [ Tactics.intro_move (Some id) (MoveBefore h) ] +| [ "intro" "at" "top" ] -> [ Tactics.intro_move None MoveFirst ] +| [ "intro" "at" "bottom" ] -> [ Tactics.intro_move None MoveLast ] +| [ "intro" "after" hyp(h) ] -> [ Tactics.intro_move None (MoveAfter h) ] +| [ "intro" "before" hyp(h) ] -> [ Tactics.intro_move None (MoveBefore h) ] +END + +(** Move *) + +TACTIC EXTEND move + [ "move" hyp(id) "at" "top" ] -> [ Tactics.move_hyp id MoveFirst ] +| [ "move" hyp(id) "at" "bottom" ] -> [ Tactics.move_hyp id MoveLast ] +| [ "move" hyp(id) "after" hyp(h) ] -> [ Tactics.move_hyp id (MoveAfter h) ] +| [ "move" hyp(id) "before" hyp(h) ] -> [ Tactics.move_hyp id (MoveBefore h) ] +END + +(** Rename *) + +TACTIC EXTEND rename +| [ "rename" ne_rename_list_sep(ids, ",") ] -> [ Tactics.rename_hyp ids ] +END + +(** Revert *) + +TACTIC EXTEND revert + [ "revert" ne_hyp_list(hl) ] -> [ Tactics.revert hl ] +END + +(** Simple induction / destruct *) + +TACTIC EXTEND simple_induction + [ "simple" "induction" quantified_hypothesis(h) ] -> [ Tactics.simple_induct h ] +END + +TACTIC EXTEND simple_destruct + [ "simple" "destruct" quantified_hypothesis(h) ] -> [ Tactics.simple_destruct h ] +END + +(** Double induction *) + +TACTIC EXTEND double_induction + [ "double" "induction" quantified_hypothesis(h1) quantified_hypothesis(h2) ] -> + [ Elim.h_double_induction h1 h2 ] +END + +(* Admit *) + +TACTIC EXTEND admit + [ "admit" ] -> [ Proofview.give_up ] +END + +(* Fix *) + +TACTIC EXTEND fix + [ "fix" natural(n) ] -> [ Tactics.fix None n ] +| [ "fix" ident(id) natural(n) ] -> [ Tactics.fix (Some id) n ] +END + +(* Cofix *) + +TACTIC EXTEND cofix + [ "cofix" ] -> [ Tactics.cofix None ] +| [ "cofix" ident(id) ] -> [ Tactics.cofix (Some id) ] +END + +(* Clear *) + +TACTIC EXTEND clear + [ "clear" hyp_list(ids) ] -> [ + if List.is_empty ids then Tactics.keep [] + else Tactics.clear ids + ] +| [ "clear" "-" ne_hyp_list(ids) ] -> [ Tactics.keep ids ] +END + +(* Clearbody *) + +TACTIC EXTEND clearbody + [ "clearbody" ne_hyp_list(ids) ] -> [ Tactics.clear_body ids ] +END + +(* Generalize dependent *) + +TACTIC EXTEND generalize_dependent + [ "generalize" "dependent" constr(c) ] -> [ Tactics.generalize_dep c ] +END + +(* Table of "pervasives" macros tactics (e.g. auto, simpl, etc.) *) + +open Tacexpr + +let initial_atomic () = + let dloc = Loc.ghost in + let nocl = {onhyps=Some[];concl_occs=AllOccurrences} in + let iter (s, t) = + let body = TacAtom (dloc, t) in + Tacenv.register_ltac false false (Id.of_string s) body + in + let () = List.iter iter + [ "red", TacReduce(Red false,nocl); + "hnf", TacReduce(Hnf,nocl); + "simpl", TacReduce(Simpl (Redops.all_flags,None),nocl); + "compute", TacReduce(Cbv Redops.all_flags,nocl); + "intros", TacIntroPattern (false,[]); + ] + in + let iter (s, t) = Tacenv.register_ltac false false (Id.of_string s) t in + List.iter iter + [ "idtac",TacId []; + "fail", TacFail(TacLocal,ArgArg 0,[]); + "fresh", TacArg(dloc,TacFreshId []) + ] + +let () = Mltop.declare_cache_obj initial_atomic "coretactics" diff --git a/plugins/ltac/evar_tactics.ml b/plugins/ltac/evar_tactics.ml new file mode 100644 index 000000000..5d3f6df03 --- /dev/null +++ b/plugins/ltac/evar_tactics.ml @@ -0,0 +1,119 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Util +open Names +open Term +open EConstr +open CErrors +open Evar_refiner +open Tacmach +open Tacexpr +open Refiner +open Evd +open Locus +open Sigma.Notations +open Proofview.Notations +open Context.Named.Declaration + +module NamedDecl = Context.Named.Declaration + +(* The instantiate tactic *) + +let instantiate_evar evk (ist,rawc) sigma = + let evi = Evd.find sigma evk in + let filtered = Evd.evar_filtered_env evi in + let constrvars = Tacinterp.extract_ltac_constr_values ist filtered in + let lvar = { + Pretyping.ltac_constrs = constrvars; + ltac_uconstrs = Names.Id.Map.empty; + ltac_idents = Names.Id.Map.empty; + ltac_genargs = ist.Geninterp.lfun; + } in + let sigma' = w_refine (evk,evi) (lvar ,rawc) sigma in + tclEVARS sigma' + +let evar_list sigma c = + let rec evrec acc c = + match EConstr.kind sigma c with + | Evar (evk, _ as ev) -> ev :: acc + | _ -> EConstr.fold sigma evrec acc c in + evrec [] c + +let instantiate_tac n c ido = + Proofview.V82.tactic begin fun gl -> + let sigma = gl.sigma in + let evl = + match ido with + ConclLocation () -> evar_list sigma (pf_concl gl) + | HypLocation (id,hloc) -> + let decl = Environ.lookup_named_val id (Goal.V82.hyps sigma (sig_it gl)) in + match hloc with + InHyp -> + (match decl with + | LocalAssum (_,typ) -> evar_list sigma (EConstr.of_constr typ) + | _ -> error + "Please be more specific: in type or value?") + | InHypTypeOnly -> + evar_list sigma (EConstr.of_constr (NamedDecl.get_type decl)) + | InHypValueOnly -> + (match decl with + | LocalDef (_,body,_) -> evar_list sigma (EConstr.of_constr body) + | _ -> error "Not a defined hypothesis.") in + if List.length evl < n then + error "Not enough uninstantiated existential variables."; + if n <= 0 then error "Incorrect existential variable index."; + let evk,_ = List.nth evl (n-1) in + instantiate_evar evk c sigma gl + end + +let instantiate_tac_by_name id c = + Proofview.V82.tactic begin fun gl -> + let sigma = gl.sigma in + let evk = + try Evd.evar_key id sigma + with Not_found -> error "Unknown existential variable." in + instantiate_evar evk c sigma gl + end + +let let_evar name typ = + let src = (Loc.ghost,Evar_kinds.GoalEvar) in + Proofview.Goal.s_enter { s_enter = begin fun gl -> + let sigma = Tacmach.New.project gl in + let env = Proofview.Goal.env gl in + let sigma = ref sigma in + let _ = Typing.e_sort_of env sigma typ in + let sigma = !sigma in + let id = match name with + | Names.Anonymous -> + let id = Namegen.id_of_name_using_hdchar env sigma typ name in + Namegen.next_ident_away_in_goal id (Termops.ids_of_named_context (Environ.named_context env)) + | Names.Name id -> id + in + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma (evar, sigma, p) = Evarutil.new_evar env sigma ~src ~naming:(Misctypes.IntroFresh id) typ in + let tac = + (Tactics.letin_tac None (Names.Name id) evar None Locusops.nowhere) + in + Sigma (tac, sigma, p) + end } + +let hget_evar n = + let open EConstr in + Proofview.Goal.nf_enter { enter = begin fun gl -> + let sigma = Tacmach.New.project gl in + let concl = Proofview.Goal.concl gl in + let evl = evar_list sigma concl in + if List.length evl < n then + error "Not enough uninstantiated existential variables."; + if n <= 0 then error "Incorrect existential variable index."; + let ev = List.nth evl (n-1) in + let ev_type = EConstr.existential_type sigma ev in + Tactics.change_concl (mkLetIn (Anonymous,mkEvar ev,ev_type,concl)) + end } + diff --git a/plugins/ltac/evar_tactics.mli b/plugins/ltac/evar_tactics.mli new file mode 100644 index 000000000..cfe747665 --- /dev/null +++ b/plugins/ltac/evar_tactics.mli @@ -0,0 +1,21 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Names +open Tacexpr +open Locus + +val instantiate_tac : int -> Tacinterp.interp_sign * Glob_term.glob_constr -> + (Id.t * hyp_location_flag, unit) location -> unit Proofview.tactic + +val instantiate_tac_by_name : Id.t -> + Tacinterp.interp_sign * Glob_term.glob_constr -> unit Proofview.tactic + +val let_evar : Name.t -> EConstr.types -> unit Proofview.tactic + +val hget_evar : int -> unit Proofview.tactic diff --git a/plugins/ltac/extraargs.ml4 b/plugins/ltac/extraargs.ml4 new file mode 100644 index 000000000..53b726432 --- /dev/null +++ b/plugins/ltac/extraargs.ml4 @@ -0,0 +1,389 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i camlp4deps: "grammar/grammar.cma" i*) + +open Pp +open Genarg +open Stdarg +open Tacarg +open Pcoq.Prim +open Pcoq.Constr +open Names +open Tacmach +open Tacexpr +open Taccoerce +open Tacinterp +open Misctypes +open Locus + +(** Adding scopes for generic arguments not defined through ARGUMENT EXTEND *) + +let create_generic_quotation name e wit = + let inject (loc, v) = Tacexpr.TacGeneric (Genarg.in_gen (Genarg.rawwit wit) v) in + Tacentries.create_ltac_quotation name inject (e, None) + +let () = create_generic_quotation "integer" Pcoq.Prim.integer Stdarg.wit_int +let () = create_generic_quotation "string" Pcoq.Prim.string Stdarg.wit_string + +let () = create_generic_quotation "ident" Pcoq.Prim.ident Stdarg.wit_ident +let () = create_generic_quotation "reference" Pcoq.Prim.reference Stdarg.wit_ref +let () = create_generic_quotation "uconstr" Pcoq.Constr.lconstr Stdarg.wit_uconstr +let () = create_generic_quotation "constr" Pcoq.Constr.lconstr Stdarg.wit_constr +let () = create_generic_quotation "ipattern" Pltac.simple_intropattern Stdarg.wit_intro_pattern +let () = create_generic_quotation "open_constr" Pcoq.Constr.lconstr Stdarg.wit_open_constr +let () = + let inject (loc, v) = Tacexpr.Tacexp v in + Tacentries.create_ltac_quotation "ltac" inject (Pltac.tactic_expr, Some 5) + +(** Backward-compatible tactic notation entry names *) + +let () = + let register name entry = Tacentries.register_tactic_notation_entry name entry in + register "hyp" wit_var; + register "simple_intropattern" wit_intro_pattern; + register "integer" wit_integer; + register "reference" wit_ref; + () + +(* Rewriting orientation *) + +let _ = Metasyntax.add_token_obj "<-" +let _ = Metasyntax.add_token_obj "->" + +let pr_orient _prc _prlc _prt = function + | true -> Pp.mt () + | false -> Pp.str " <-" + +ARGUMENT EXTEND orient TYPED AS bool PRINTED BY pr_orient +| [ "->" ] -> [ true ] +| [ "<-" ] -> [ false ] +| [ ] -> [ true ] +END + +let pr_int _ _ _ i = Pp.int i + +let _natural = Pcoq.Prim.natural + +ARGUMENT EXTEND natural TYPED AS int PRINTED BY pr_int +| [ _natural(i) ] -> [ i ] +END + +let pr_orient = pr_orient () () () + + +let pr_int_list = Pp.pr_sequence Pp.int +let pr_int_list_full _prc _prlc _prt l = pr_int_list l + +let pr_occurrences _prc _prlc _prt l = + match l with + | ArgArg x -> pr_int_list x + | ArgVar (loc, id) -> Nameops.pr_id id + +let occurrences_of = function + | [] -> NoOccurrences + | n::_ as nl when n < 0 -> AllOccurrencesBut (List.map abs nl) + | nl -> + if List.exists (fun n -> n < 0) nl then + CErrors.error "Illegal negative occurrence number."; + OnlyOccurrences nl + +let coerce_to_int v = match Value.to_int v with + | None -> raise (CannotCoerceTo "an integer") + | Some n -> n + +let int_list_of_VList v = match Value.to_list v with +| Some l -> List.map (fun n -> coerce_to_int n) l +| _ -> raise (CannotCoerceTo "an integer") + +let interp_occs ist gl l = + match l with + | ArgArg x -> x + | ArgVar (_,id as locid) -> + (try int_list_of_VList (Id.Map.find id ist.lfun) + with Not_found | CannotCoerceTo _ -> [interp_int ist locid]) +let interp_occs ist gl l = + Tacmach.project gl , interp_occs ist gl l + +let glob_occs ist l = l + +let subst_occs evm l = l + +ARGUMENT EXTEND occurrences + TYPED AS int list + PRINTED BY pr_int_list_full + + INTERPRETED BY interp_occs + GLOBALIZED BY glob_occs + SUBSTITUTED BY subst_occs + + RAW_PRINTED BY pr_occurrences + GLOB_PRINTED BY pr_occurrences + +| [ ne_integer_list(l) ] -> [ ArgArg l ] +| [ var(id) ] -> [ ArgVar id ] +END + +let pr_occurrences = pr_occurrences () () () + +let pr_gen prc _prlc _prtac c = prc c + +let pr_globc _prc _prlc _prtac (_,glob) = Printer.pr_glob_constr glob + +let interp_glob ist gl (t,_) = Tacmach.project gl , (ist,t) + +let glob_glob = Tacintern.intern_constr + +let pr_lconstr _ prc _ c = prc c + +let subst_glob = Tacsubst.subst_glob_constr_and_expr + +ARGUMENT EXTEND glob + PRINTED BY pr_globc + + INTERPRETED BY interp_glob + GLOBALIZED BY glob_glob + SUBSTITUTED BY subst_glob + + RAW_PRINTED BY pr_gen + GLOB_PRINTED BY pr_gen + [ constr(c) ] -> [ c ] +END + +let l_constr = Pcoq.Constr.lconstr + +ARGUMENT EXTEND lconstr + TYPED AS constr + PRINTED BY pr_lconstr + [ l_constr(c) ] -> [ c ] +END + +ARGUMENT EXTEND lglob + TYPED AS glob + PRINTED BY pr_globc + + INTERPRETED BY interp_glob + GLOBALIZED BY glob_glob + SUBSTITUTED BY subst_glob + + RAW_PRINTED BY pr_gen + GLOB_PRINTED BY pr_gen + [ lconstr(c) ] -> [ c ] +END + +let interp_casted_constr ist gl c = + interp_constr_gen (Pretyping.OfType (pf_concl gl)) ist (pf_env gl) (project gl) c + +ARGUMENT EXTEND casted_constr + TYPED AS constr + PRINTED BY pr_gen + INTERPRETED BY interp_casted_constr + [ constr(c) ] -> [ c ] +END + +type 'id gen_place= ('id * hyp_location_flag,unit) location + +type loc_place = Id.t Loc.located gen_place +type place = Id.t gen_place + +let pr_gen_place pr_id = function + ConclLocation () -> Pp.mt () + | HypLocation (id,InHyp) -> str "in " ++ pr_id id + | HypLocation (id,InHypTypeOnly) -> + str "in (Type of " ++ pr_id id ++ str ")" + | HypLocation (id,InHypValueOnly) -> + str "in (Value of " ++ pr_id id ++ str ")" + +let pr_loc_place _ _ _ = pr_gen_place (fun (_,id) -> Nameops.pr_id id) +let pr_place _ _ _ = pr_gen_place Nameops.pr_id +let pr_hloc = pr_loc_place () () () + +let intern_place ist = function + ConclLocation () -> ConclLocation () + | HypLocation (id,hl) -> HypLocation (Tacintern.intern_hyp ist id,hl) + +let interp_place ist env sigma = function + ConclLocation () -> ConclLocation () + | HypLocation (id,hl) -> HypLocation (Tacinterp.interp_hyp ist env sigma id,hl) + +let interp_place ist gl p = + Tacmach.project gl , interp_place ist (Tacmach.pf_env gl) (Tacmach.project gl) p + +let subst_place subst pl = pl + +ARGUMENT EXTEND hloc + PRINTED BY pr_place + INTERPRETED BY interp_place + GLOBALIZED BY intern_place + SUBSTITUTED BY subst_place + RAW_PRINTED BY pr_loc_place + GLOB_PRINTED BY pr_loc_place + [ ] -> + [ ConclLocation () ] + | [ "in" "|-" "*" ] -> + [ ConclLocation () ] +| [ "in" ident(id) ] -> + [ HypLocation ((Loc.ghost,id),InHyp) ] +| [ "in" "(" "Type" "of" ident(id) ")" ] -> + [ HypLocation ((Loc.ghost,id),InHypTypeOnly) ] +| [ "in" "(" "Value" "of" ident(id) ")" ] -> + [ HypLocation ((Loc.ghost,id),InHypValueOnly) ] + + END + +let pr_rename _ _ _ (n, m) = Nameops.pr_id n ++ str " into " ++ Nameops.pr_id m + +ARGUMENT EXTEND rename + TYPED AS ident * ident + PRINTED BY pr_rename +| [ ident(n) "into" ident(m) ] -> [ (n, m) ] +END + +(* Julien: Mise en commun des differentes version de replace with in by *) + +let pr_by_arg_tac _prc _prlc prtac opt_c = + match opt_c with + | None -> mt () + | Some t -> hov 2 (str "by" ++ spc () ++ prtac (3,Ppextend.E) t) + +ARGUMENT EXTEND by_arg_tac + TYPED AS tactic_opt + PRINTED BY pr_by_arg_tac +| [ "by" tactic3(c) ] -> [ Some c ] +| [ ] -> [ None ] +END + +let pr_by_arg_tac prtac opt_c = pr_by_arg_tac () () prtac opt_c + +let pr_in_clause _ _ _ cl = Pptactic.pr_in_clause Ppconstr.pr_lident cl +let pr_in_top_clause _ _ _ cl = Pptactic.pr_in_clause Id.print cl +let in_clause' = Pltac.in_clause + +ARGUMENT EXTEND in_clause + TYPED AS clause_dft_concl + PRINTED BY pr_in_top_clause + RAW_TYPED AS clause_dft_concl + RAW_PRINTED BY pr_in_clause + GLOB_TYPED AS clause_dft_concl + GLOB_PRINTED BY pr_in_clause +| [ in_clause'(cl) ] -> [ cl ] +END + +(* spiwack: the print functions are incomplete, but I don't know what they are + used for *) +let pr_r_nat_field natf = + str "nat " ++ + match natf with + | Retroknowledge.NatType -> str "type" + | Retroknowledge.NatPlus -> str "plus" + | Retroknowledge.NatTimes -> str "times" + +let pr_r_n_field nf = + str "binary N " ++ + match nf with + | Retroknowledge.NPositive -> str "positive" + | Retroknowledge.NType -> str "type" + | Retroknowledge.NTwice -> str "twice" + | Retroknowledge.NTwicePlusOne -> str "twice plus one" + | Retroknowledge.NPhi -> str "phi" + | Retroknowledge.NPhiInv -> str "phi inv" + | Retroknowledge.NPlus -> str "plus" + | Retroknowledge.NTimes -> str "times" + +let pr_r_int31_field i31f = + str "int31 " ++ + match i31f with + | Retroknowledge.Int31Bits -> str "bits" + | Retroknowledge.Int31Type -> str "type" + | Retroknowledge.Int31Twice -> str "twice" + | Retroknowledge.Int31TwicePlusOne -> str "twice plus one" + | Retroknowledge.Int31Phi -> str "phi" + | Retroknowledge.Int31PhiInv -> str "phi inv" + | Retroknowledge.Int31Plus -> str "plus" + | Retroknowledge.Int31Times -> str "times" + | Retroknowledge.Int31Constructor -> assert false + | Retroknowledge.Int31PlusC -> str "plusc" + | Retroknowledge.Int31PlusCarryC -> str "pluscarryc" + | Retroknowledge.Int31Minus -> str "minus" + | Retroknowledge.Int31MinusC -> str "minusc" + | Retroknowledge.Int31MinusCarryC -> str "minuscarryc" + | Retroknowledge.Int31TimesC -> str "timesc" + | Retroknowledge.Int31Div21 -> str "div21" + | Retroknowledge.Int31Div -> str "div" + | Retroknowledge.Int31Diveucl -> str "diveucl" + | Retroknowledge.Int31AddMulDiv -> str "addmuldiv" + | Retroknowledge.Int31Compare -> str "compare" + | Retroknowledge.Int31Head0 -> str "head0" + | Retroknowledge.Int31Tail0 -> str "tail0" + | Retroknowledge.Int31Lor -> str "lor" + | Retroknowledge.Int31Land -> str "land" + | Retroknowledge.Int31Lxor -> str "lxor" + +let pr_retroknowledge_field f = + match f with + (* | Retroknowledge.KEq -> str "equality" + | Retroknowledge.KNat natf -> pr_r_nat_field () () () natf + | Retroknowledge.KN nf -> pr_r_n_field () () () nf *) + | Retroknowledge.KInt31 (group, i31f) -> (pr_r_int31_field i31f) ++ + spc () ++ str "in " ++ qs group + +VERNAC ARGUMENT EXTEND retroknowledge_nat +PRINTED BY pr_r_nat_field +| [ "nat" "type" ] -> [ Retroknowledge.NatType ] +| [ "nat" "plus" ] -> [ Retroknowledge.NatPlus ] +| [ "nat" "times" ] -> [ Retroknowledge.NatTimes ] +END + + +VERNAC ARGUMENT EXTEND retroknowledge_binary_n +PRINTED BY pr_r_n_field +| [ "binary" "N" "positive" ] -> [ Retroknowledge.NPositive ] +| [ "binary" "N" "type" ] -> [ Retroknowledge.NType ] +| [ "binary" "N" "twice" ] -> [ Retroknowledge.NTwice ] +| [ "binary" "N" "twice" "plus" "one" ] -> [ Retroknowledge.NTwicePlusOne ] +| [ "binary" "N" "phi" ] -> [ Retroknowledge.NPhi ] +| [ "binary" "N" "phi" "inv" ] -> [ Retroknowledge.NPhiInv ] +| [ "binary" "N" "plus" ] -> [ Retroknowledge.NPlus ] +| [ "binary" "N" "times" ] -> [ Retroknowledge.NTimes ] +END + +VERNAC ARGUMENT EXTEND retroknowledge_int31 +PRINTED BY pr_r_int31_field +| [ "int31" "bits" ] -> [ Retroknowledge.Int31Bits ] +| [ "int31" "type" ] -> [ Retroknowledge.Int31Type ] +| [ "int31" "twice" ] -> [ Retroknowledge.Int31Twice ] +| [ "int31" "twice" "plus" "one" ] -> [ Retroknowledge.Int31TwicePlusOne ] +| [ "int31" "phi" ] -> [ Retroknowledge.Int31Phi ] +| [ "int31" "phi" "inv" ] -> [ Retroknowledge.Int31PhiInv ] +| [ "int31" "plus" ] -> [ Retroknowledge.Int31Plus ] +| [ "int31" "plusc" ] -> [ Retroknowledge.Int31PlusC ] +| [ "int31" "pluscarryc" ] -> [ Retroknowledge.Int31PlusCarryC ] +| [ "int31" "minus" ] -> [ Retroknowledge.Int31Minus ] +| [ "int31" "minusc" ] -> [ Retroknowledge.Int31MinusC ] +| [ "int31" "minuscarryc" ] -> [ Retroknowledge.Int31MinusCarryC ] +| [ "int31" "times" ] -> [ Retroknowledge.Int31Times ] +| [ "int31" "timesc" ] -> [ Retroknowledge.Int31TimesC ] +| [ "int31" "div21" ] -> [ Retroknowledge.Int31Div21 ] +| [ "int31" "div" ] -> [ Retroknowledge.Int31Div ] +| [ "int31" "diveucl" ] -> [ Retroknowledge.Int31Diveucl ] +| [ "int31" "addmuldiv" ] -> [ Retroknowledge.Int31AddMulDiv ] +| [ "int31" "compare" ] -> [ Retroknowledge.Int31Compare ] +| [ "int31" "head0" ] -> [ Retroknowledge.Int31Head0 ] +| [ "int31" "tail0" ] -> [ Retroknowledge.Int31Tail0 ] +| [ "int31" "lor" ] -> [ Retroknowledge.Int31Lor ] +| [ "int31" "land" ] -> [ Retroknowledge.Int31Land ] +| [ "int31" "lxor" ] -> [ Retroknowledge.Int31Lxor ] +END + +VERNAC ARGUMENT EXTEND retroknowledge_field +PRINTED BY pr_retroknowledge_field +(*| [ "equality" ] -> [ Retroknowledge.KEq ] +| [ retroknowledge_nat(n)] -> [ Retroknowledge.KNat n ] +| [ retroknowledge_binary_n (n)] -> [ Retroknowledge.KN n ]*) +| [ retroknowledge_int31 (i) "in" string(g)] -> [ Retroknowledge.KInt31(g,i) ] +END diff --git a/plugins/ltac/extraargs.mli b/plugins/ltac/extraargs.mli new file mode 100644 index 000000000..7d4bccfad --- /dev/null +++ b/plugins/ltac/extraargs.mli @@ -0,0 +1,78 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Tacexpr +open Names +open Constrexpr +open Glob_term +open Misctypes + +val wit_orient : bool Genarg.uniform_genarg_type +val orient : bool Pcoq.Gram.entry +val pr_orient : bool -> Pp.std_ppcmds + +val wit_rename : (Id.t * Id.t) Genarg.uniform_genarg_type + +val occurrences : (int list or_var) Pcoq.Gram.entry +val wit_occurrences : (int list or_var, int list or_var, int list) Genarg.genarg_type +val pr_occurrences : int list or_var -> Pp.std_ppcmds +val occurrences_of : int list -> Locus.occurrences + +val wit_natural : int Genarg.uniform_genarg_type + +val wit_glob : + (constr_expr, + Tacexpr.glob_constr_and_expr, + Tacinterp.interp_sign * glob_constr) Genarg.genarg_type + +val wit_lglob : + (constr_expr, + Tacexpr.glob_constr_and_expr, + Tacinterp.interp_sign * glob_constr) Genarg.genarg_type + +val wit_lconstr : + (constr_expr, + Tacexpr.glob_constr_and_expr, + EConstr.t) Genarg.genarg_type + +val wit_casted_constr : + (constr_expr, + Tacexpr.glob_constr_and_expr, + EConstr.t) Genarg.genarg_type + +val glob : constr_expr Pcoq.Gram.entry +val lglob : constr_expr Pcoq.Gram.entry + +type 'id gen_place= ('id * Locus.hyp_location_flag,unit) location + +type loc_place = Id.t Loc.located gen_place +type place = Id.t gen_place + +val wit_hloc : (loc_place, loc_place, place) Genarg.genarg_type +val hloc : loc_place Pcoq.Gram.entry +val pr_hloc : loc_place -> Pp.std_ppcmds + +val by_arg_tac : Tacexpr.raw_tactic_expr option Pcoq.Gram.entry +val wit_by_arg_tac : + (raw_tactic_expr option, + glob_tactic_expr option, + Geninterp.Val.t option) Genarg.genarg_type + +val pr_by_arg_tac : + (int * Ppextend.parenRelation -> raw_tactic_expr -> Pp.std_ppcmds) -> + raw_tactic_expr option -> Pp.std_ppcmds + +(** Spiwack: Primitive for retroknowledge registration *) + +val retroknowledge_field : Retroknowledge.field Pcoq.Gram.entry +val wit_retroknowledge_field : (Retroknowledge.field, unit, unit) Genarg.genarg_type + +val wit_in_clause : + (Id.t Loc.located Locus.clause_expr, + Id.t Loc.located Locus.clause_expr, + Id.t Locus.clause_expr) Genarg.genarg_type diff --git a/plugins/ltac/extratactics.ml4 b/plugins/ltac/extratactics.ml4 new file mode 100644 index 000000000..38fdfb759 --- /dev/null +++ b/plugins/ltac/extratactics.ml4 @@ -0,0 +1,1113 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i camlp4deps: "grammar/grammar.cma" i*) + +open Pp +open Genarg +open Stdarg +open Tacarg +open Extraargs +open Pcoq.Prim +open Pltac +open Mod_subst +open Names +open Tacexpr +open Glob_ops +open CErrors +open Util +open Evd +open Termops +open Equality +open Misctypes +open Sigma.Notations +open Proofview.Notations + +DECLARE PLUGIN "extratactics" + +(**********************************************************************) +(* replace, discriminate, injection, simplify_eq *) +(* cutrewrite, dependent rewrite *) + +let with_delayed_uconstr ist c tac = + let flags = { + Pretyping.use_typeclasses = false; + solve_unification_constraints = true; + use_hook = Pfedit.solve_by_implicit_tactic (); + fail_evar = false; + expand_evars = true + } in + let c = Pretyping.type_uconstr ~flags ist c in + Tacticals.New.tclDELAYEDWITHHOLES false c tac + +let replace_in_clause_maybe_by ist c1 c2 cl tac = + with_delayed_uconstr ist c1 + (fun c1 -> replace_in_clause_maybe_by c1 c2 cl (Option.map (Tacinterp.tactic_of_value ist) tac)) + +let replace_term ist dir_opt c cl = + with_delayed_uconstr ist c (fun c -> replace_term dir_opt c cl) + +let clause = Pltac.clause_dft_concl + +TACTIC EXTEND replace + ["replace" uconstr(c1) "with" constr(c2) clause(cl) by_arg_tac(tac) ] +-> [ replace_in_clause_maybe_by ist c1 c2 cl tac ] +END + +TACTIC EXTEND replace_term_left + [ "replace" "->" uconstr(c) clause(cl) ] + -> [ replace_term ist (Some true) c cl ] +END + +TACTIC EXTEND replace_term_right + [ "replace" "<-" uconstr(c) clause(cl) ] + -> [ replace_term ist (Some false) c cl ] +END + +TACTIC EXTEND replace_term + [ "replace" uconstr(c) clause(cl) ] + -> [ replace_term ist None c cl ] +END + +let induction_arg_of_quantified_hyp = function + | AnonHyp n -> None,ElimOnAnonHyp n + | NamedHyp id -> None,ElimOnIdent (Loc.ghost,id) + +(* Versions *_main must come first!! so that "1" is interpreted as a + ElimOnAnonHyp and not as a "constr", and "id" is interpreted as a + ElimOnIdent and not as "constr" *) + +let mytclWithHoles tac with_evars c = + Proofview.Goal.enter { enter = begin fun gl -> + let env = Tacmach.New.pf_env gl in + let sigma = Tacmach.New.project gl in + let sigma',c = Tactics.force_destruction_arg with_evars env sigma c in + Tacticals.New.tclWITHHOLES with_evars (tac with_evars (Some c)) sigma' + end } + +let elimOnConstrWithHoles tac with_evars c = + Tacticals.New.tclDELAYEDWITHHOLES with_evars c + (fun c -> tac with_evars (Some (None,ElimOnConstr c))) + +TACTIC EXTEND simplify_eq + [ "simplify_eq" ] -> [ dEq false None ] +| [ "simplify_eq" destruction_arg(c) ] -> [ mytclWithHoles dEq false c ] +END +TACTIC EXTEND esimplify_eq +| [ "esimplify_eq" ] -> [ dEq true None ] +| [ "esimplify_eq" destruction_arg(c) ] -> [ mytclWithHoles dEq true c ] +END + +let discr_main c = elimOnConstrWithHoles discr_tac false c + +TACTIC EXTEND discriminate +| [ "discriminate" ] -> [ discr_tac false None ] +| [ "discriminate" destruction_arg(c) ] -> + [ mytclWithHoles discr_tac false c ] +END +TACTIC EXTEND ediscriminate +| [ "ediscriminate" ] -> [ discr_tac true None ] +| [ "ediscriminate" destruction_arg(c) ] -> + [ mytclWithHoles discr_tac true c ] +END + +let discrHyp id = + Proofview.tclEVARMAP >>= fun 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 + +TACTIC EXTEND injection +| [ "injection" ] -> [ injClause None false None ] +| [ "injection" destruction_arg(c) ] -> [ mytclWithHoles (injClause None) false c ] +END +TACTIC EXTEND einjection +| [ "einjection" ] -> [ injClause None true None ] +| [ "einjection" destruction_arg(c) ] -> [ mytclWithHoles (injClause None) true c ] +END +TACTIC EXTEND injection_as +| [ "injection" "as" intropattern_list(ipat)] -> + [ injClause (Some ipat) false None ] +| [ "injection" destruction_arg(c) "as" intropattern_list(ipat)] -> + [ mytclWithHoles (injClause (Some ipat)) false c ] +END +TACTIC EXTEND einjection_as +| [ "einjection" "as" intropattern_list(ipat)] -> + [ injClause (Some ipat) true None ] +| [ "einjection" destruction_arg(c) "as" intropattern_list(ipat)] -> + [ mytclWithHoles (injClause (Some ipat)) true c ] +END +TACTIC EXTEND simple_injection +| [ "simple" "injection" ] -> [ simpleInjClause false None ] +| [ "simple" "injection" destruction_arg(c) ] -> [ mytclWithHoles simpleInjClause false c ] +END + +let injHyp id = + Proofview.tclEVARMAP >>= fun 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 ] +| [ "dependent" "rewrite" orient(b) constr(c) "in" hyp(id) ] + -> [ rewriteInHyp b c id ] +END + +(** To be deprecated?, "cutrewrite (t=u) as <-" is equivalent to + "replace u with t" or "enough (t=u) as <-" and + "cutrewrite (t=u) as ->" is equivalent to "enough (t=u) as ->". *) + +TACTIC EXTEND cut_rewrite +| [ "cutrewrite" orient(b) constr(eqn) ] -> [ cutRewriteInConcl b eqn ] +| [ "cutrewrite" orient(b) constr(eqn) "in" hyp(id) ] + -> [ cutRewriteInHyp b eqn id ] +END + +(**********************************************************************) +(* Decompose *) + +TACTIC EXTEND decompose_sum +| [ "decompose" "sum" constr(c) ] -> [ Elim.h_decompose_or c ] +END + +TACTIC EXTEND decompose_record +| [ "decompose" "record" constr(c) ] -> [ Elim.h_decompose_and c ] +END + +(**********************************************************************) +(* Contradiction *) + +open Contradiction + +TACTIC EXTEND absurd + [ "absurd" constr(c) ] -> [ absurd c ] +END + +let onSomeWithHoles tac = function + | None -> tac None + | Some c -> Tacticals.New.tclDELAYEDWITHHOLES false c (fun c -> tac (Some c)) + +TACTIC EXTEND contradiction + [ "contradiction" constr_with_bindings_opt(c) ] -> + [ onSomeWithHoles contradiction c ] +END + +(**********************************************************************) +(* AutoRewrite *) + +open Autorewrite + +let pr_orient _prc _prlc _prt = function + | true -> Pp.mt () + | false -> Pp.str " <-" + +let pr_orient_string _prc _prlc _prt (orient, s) = + pr_orient _prc _prlc _prt orient ++ Pp.spc () ++ Pp.str s + +ARGUMENT EXTEND orient_string TYPED AS (bool * string) PRINTED BY pr_orient_string +| [ orient(r) preident(i) ] -> [ r, i ] +END + +TACTIC EXTEND autorewrite +| [ "autorewrite" "with" ne_preident_list(l) clause(cl) ] -> + [ auto_multi_rewrite l ( cl) ] +| [ "autorewrite" "with" ne_preident_list(l) clause(cl) "using" tactic(t) ] -> + [ + auto_multi_rewrite_with (Tacinterp.tactic_of_value ist t) l cl + ] +END + +TACTIC EXTEND autorewrite_star +| [ "autorewrite" "*" "with" ne_preident_list(l) clause(cl) ] -> + [ auto_multi_rewrite ~conds:AllMatches l cl ] +| [ "autorewrite" "*" "with" ne_preident_list(l) clause(cl) "using" tactic(t) ] -> + [ auto_multi_rewrite_with ~conds:AllMatches (Tacinterp.tactic_of_value ist t) l cl ] +END + +(**********************************************************************) +(* Rewrite star *) + +let rewrite_star ist clause orient occs c (tac : Geninterp.Val.t option) = + let tac' = Option.map (fun t -> Tacinterp.tactic_of_value ist t, FirstSolved) tac in + with_delayed_uconstr ist c + (fun c -> general_rewrite_ebindings_clause clause orient occs ?tac:tac' true true (c,NoBindings) true) + +TACTIC EXTEND rewrite_star +| [ "rewrite" "*" orient(o) uconstr(c) "in" hyp(id) "at" occurrences(occ) by_arg_tac(tac) ] -> + [ rewrite_star ist (Some id) o (occurrences_of occ) c tac ] +| [ "rewrite" "*" orient(o) uconstr(c) "at" occurrences(occ) "in" hyp(id) by_arg_tac(tac) ] -> + [ rewrite_star ist (Some id) o (occurrences_of occ) c tac ] +| [ "rewrite" "*" orient(o) uconstr(c) "in" hyp(id) by_arg_tac(tac) ] -> + [ rewrite_star ist (Some id) o Locus.AllOccurrences c tac ] +| [ "rewrite" "*" orient(o) uconstr(c) "at" occurrences(occ) by_arg_tac(tac) ] -> + [ rewrite_star ist None o (occurrences_of occ) c tac ] +| [ "rewrite" "*" orient(o) uconstr(c) by_arg_tac(tac) ] -> + [ rewrite_star ist None o Locus.AllOccurrences c tac ] + END + +(**********************************************************************) +(* Hint Rewrite *) + +let add_rewrite_hint bases ort t lcsr = + let env = Global.env() in + let sigma = Evd.from_env env in + let poly = Flags.use_polymorphic_flag () in + let f ce = + let c, ctx = Constrintern.interp_constr env sigma ce in + let ctx = + let ctx = UState.context_set ctx in + if poly then ctx + else (** This is a global universe context that shouldn't be + refreshed at every use of the hint, declare it globally. *) + (Declare.declare_universe_context false ctx; + Univ.ContextSet.empty) + in + Constrexpr_ops.constr_loc ce, (c, ctx), ort, Option.map (in_gen (rawwit wit_ltac)) t in + let eqs = List.map f lcsr in + let add_hints base = add_rew_rules base eqs in + List.iter add_hints bases + +let classify_hint _ = Vernacexpr.VtSideff [], Vernacexpr.VtLater + +VERNAC COMMAND EXTEND HintRewrite CLASSIFIED BY classify_hint + [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ":" preident_list(bl) ] -> + [ add_rewrite_hint bl o None l ] +| [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) + ":" preident_list(bl) ] -> + [ add_rewrite_hint bl o (Some t) l ] +| [ "Hint" "Rewrite" orient(o) ne_constr_list(l) ] -> + [ add_rewrite_hint ["core"] o None l ] +| [ "Hint" "Rewrite" orient(o) ne_constr_list(l) "using" tactic(t) ] -> + [ add_rewrite_hint ["core"] o (Some t) l ] +END + +(**********************************************************************) +(* Hint Resolve *) + +open Term +open EConstr +open Vars +open Coqlib + +let project_hint pri l2r r = + let gr = Smartlocate.global_with_alias r in + let env = Global.env() in + let sigma = Evd.from_env env in + let sigma, c = Evd.fresh_global env sigma gr in + let c = EConstr.of_constr c in + let t = Retyping.get_type_of env sigma c in + let t = + Tacred.reduce_to_quantified_ref env sigma (Lazy.force coq_iff_ref) t in + let sign,ccl = decompose_prod_assum sigma t in + let (a,b) = match snd (decompose_app sigma ccl) with + | [a;b] -> (a,b) + | _ -> assert false in + let p = + if l2r then build_coq_iff_left_proj () else build_coq_iff_right_proj () in + let p = EConstr.of_constr p in + let c = Reductionops.whd_beta sigma (mkApp (c, Context.Rel.to_extended_vect mkRel 0 sign)) in + let c = it_mkLambda_or_LetIn + (mkApp (p,[|mkArrow a (lift 1 b);mkArrow b (lift 1 a);c|])) sign in + let id = + Nameops.add_suffix (Nametab.basename_of_global gr) ("_proj_" ^ (if l2r then "l2r" else "r2l")) + in + let ctx = Evd.universe_context_set sigma in + let c = EConstr.to_constr sigma c in + let c = Declare.declare_definition ~internal:Declare.InternalTacticRequest id (c,ctx) in + let info = {Vernacexpr.hint_priority = pri; hint_pattern = None} in + (info,false,true,Hints.PathAny, Hints.IsGlobRef (Globnames.ConstRef c)) + +let add_hints_iff l2r lc n bl = + let l = Locality.LocalityFixme.consume () in + Hints.add_hints (Locality.make_module_locality l) bl + (Hints.HintsResolveEntry (List.map (project_hint n l2r) lc)) + +VERNAC COMMAND EXTEND HintResolveIffLR CLASSIFIED AS SIDEFF + [ "Hint" "Resolve" "->" ne_global_list(lc) natural_opt(n) + ":" preident_list(bl) ] -> + [ add_hints_iff true lc n bl ] +| [ "Hint" "Resolve" "->" ne_global_list(lc) natural_opt(n) ] -> + [ add_hints_iff true lc n ["core"] ] +END +VERNAC COMMAND EXTEND HintResolveIffRL CLASSIFIED AS SIDEFF + [ "Hint" "Resolve" "<-" ne_global_list(lc) natural_opt(n) + ":" preident_list(bl) ] -> + [ add_hints_iff false lc n bl ] +| [ "Hint" "Resolve" "<-" ne_global_list(lc) natural_opt(n) ] -> + [ add_hints_iff false lc n ["core"] ] +END + +(**********************************************************************) +(* Refine *) + +open EConstr +open Vars + +let constr_flags () = { + Pretyping.use_typeclasses = true; + Pretyping.solve_unification_constraints = true; + Pretyping.use_hook = Pfedit.solve_by_implicit_tactic (); + Pretyping.fail_evar = false; + Pretyping.expand_evars = true } + +let refine_tac ist simple with_classes c = + Proofview.Goal.enter { enter = begin fun gl -> + let concl = Proofview.Goal.concl gl in + let env = Proofview.Goal.env gl in + let flags = + { constr_flags () with Pretyping.use_typeclasses = with_classes } in + let expected_type = Pretyping.OfType concl in + let c = Pretyping.type_uconstr ~flags ~expected_type ist c in + let update = { run = fun sigma -> + let Sigma (c, sigma, p) = c.delayed env sigma in + Sigma (c, sigma, p) + } in + let refine = Refine.refine ~unsafe:true update in + if simple then refine + else refine <*> + Tactics.New.reduce_after_refine <*> + Proofview.shelve_unifiable + end } + +TACTIC EXTEND refine +| [ "refine" uconstr(c) ] -> + [ refine_tac ist false true c ] +END + +TACTIC EXTEND simple_refine +| [ "simple" "refine" uconstr(c) ] -> + [ refine_tac ist true true c ] +END + +TACTIC EXTEND notcs_refine +| [ "notypeclasses" "refine" uconstr(c) ] -> + [ refine_tac ist false false c ] +END + +TACTIC EXTEND notcs_simple_refine +| [ "simple" "notypeclasses" "refine" uconstr(c) ] -> + [ refine_tac ist true false c ] +END + +(* Solve unification constraints using heuristics or fail if any remain *) +TACTIC EXTEND solve_constraints +[ "solve_constraints" ] -> [ Refine.solve_constraints ] +END + +(**********************************************************************) +(* Inversion lemmas (Leminv) *) + +open Inv +open Leminv + +let seff id = Vernacexpr.VtSideff [id], Vernacexpr.VtLater + +VERNAC ARGUMENT EXTEND sort +| [ "Set" ] -> [ GSet ] +| [ "Prop" ] -> [ GProp ] +| [ "Type" ] -> [ GType [] ] +END + +VERNAC COMMAND EXTEND DeriveInversionClear +| [ "Derive" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort(s) ] + => [ seff na ] + -> [ add_inversion_lemma_exn na c s false inv_clear_tac ] + +| [ "Derive" "Inversion_clear" ident(na) "with" constr(c) ] => [ seff na ] + -> [ add_inversion_lemma_exn na c GProp false inv_clear_tac ] +END + +VERNAC COMMAND EXTEND DeriveInversion +| [ "Derive" "Inversion" ident(na) "with" constr(c) "Sort" sort(s) ] + => [ seff na ] + -> [ add_inversion_lemma_exn na c s false inv_tac ] + +| [ "Derive" "Inversion" ident(na) "with" constr(c) ] => [ seff na ] + -> [ add_inversion_lemma_exn na c GProp false inv_tac ] +END + +VERNAC COMMAND EXTEND DeriveDependentInversion +| [ "Derive" "Dependent" "Inversion" ident(na) "with" constr(c) "Sort" sort(s) ] + => [ seff na ] + -> [ add_inversion_lemma_exn na c s true dinv_tac ] +END + +VERNAC COMMAND EXTEND DeriveDependentInversionClear +| [ "Derive" "Dependent" "Inversion_clear" ident(na) "with" constr(c) "Sort" sort(s) ] + => [ seff na ] + -> [ add_inversion_lemma_exn na c s true dinv_clear_tac ] +END + +(**********************************************************************) +(* Subst *) + +TACTIC EXTEND subst +| [ "subst" ne_var_list(l) ] -> [ subst l ] +| [ "subst" ] -> [ subst_all () ] +END + +let simple_subst_tactic_flags = + { only_leibniz = true; rewrite_dependent_proof = false } + +TACTIC EXTEND simple_subst +| [ "simple" "subst" ] -> [ subst_all ~flags:simple_subst_tactic_flags () ] +END + +open Evar_tactics + +(**********************************************************************) +(* Evar creation *) + +(* TODO: add support for some test similar to g_constr.name_colon so that + expressions like "evar (list A)" do not raise a syntax error *) +TACTIC EXTEND evar + [ "evar" "(" ident(id) ":" lconstr(typ) ")" ] -> [ let_evar (Name id) typ ] +| [ "evar" constr(typ) ] -> [ let_evar Anonymous typ ] +END + +TACTIC EXTEND instantiate + [ "instantiate" "(" ident(id) ":=" lglob(c) ")" ] -> + [ Tacticals.New.tclTHEN (instantiate_tac_by_name id c) Proofview.V82.nf_evar_goals ] +| [ "instantiate" "(" integer(i) ":=" lglob(c) ")" hloc(hl) ] -> + [ Tacticals.New.tclTHEN (instantiate_tac i c hl) Proofview.V82.nf_evar_goals ] +| [ "instantiate" ] -> [ Proofview.V82.nf_evar_goals ] +END + +(**********************************************************************) +(** Nijmegen "step" tactic for setoid rewriting *) + +open Tactics +open Glob_term +open Libobject +open Lib + +(* Registered lemmas are expected to be of the form + x R y -> y == z -> x R z (in the right table) + x R y -> x == z -> z R y (in the left table) +*) + +let transitivity_right_table = Summary.ref [] ~name:"transitivity-steps-r" +let transitivity_left_table = Summary.ref [] ~name:"transitivity-steps-l" + +(* [step] tries to apply a rewriting lemma; then apply [tac] intended to + complete to proof of the last hypothesis (assumed to state an equality) *) + +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) + !(if left then transitivity_left_table else transitivity_right_table) + in + Tacticals.New.tclFIRST l + +(* Main function to push lemmas in persistent environment *) + +let cache_transitivity_lemma (_,(left,lem)) = + if left then + transitivity_left_table := lem :: !transitivity_left_table + else + transitivity_right_table := lem :: !transitivity_right_table + +let subst_transitivity_lemma (subst,(b,ref)) = (b,subst_mps subst ref) + +let inTransitivity : bool * Constr.constr -> obj = + declare_object {(default_object "TRANSITIVITY-STEPS") with + cache_function = cache_transitivity_lemma; + open_function = (fun i o -> if Int.equal i 1 then cache_transitivity_lemma o); + subst_function = subst_transitivity_lemma; + classify_function = (fun o -> Substitute o) } + +(* Main entry points *) + +let add_transitivity_lemma left lem = + let env = Global.env () in + let sigma = Evd.from_env env in + let lem',ctx (*FIXME*) = Constrintern.interp_constr env sigma lem in + add_anonymous_leaf (inTransitivity (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 ()) ] +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 ()) ] +END + +VERNAC COMMAND EXTEND AddStepl CLASSIFIED AS SIDEFF +| [ "Declare" "Left" "Step" constr(t) ] -> + [ add_transitivity_lemma true t ] +END + +VERNAC COMMAND EXTEND AddStepr CLASSIFIED AS SIDEFF +| [ "Declare" "Right" "Step" constr(t) ] -> + [ add_transitivity_lemma false t ] +END + +let cache_implicit_tactic (_,tac) = match tac with + | Some tac -> Pfedit.declare_implicit_tactic (Tacinterp.eval_tactic tac) + | None -> Pfedit.clear_implicit_tactic () + +let subst_implicit_tactic (subst,tac) = + Option.map (Tacsubst.subst_tactic subst) tac + +let inImplicitTactic : glob_tactic_expr option -> obj = + declare_object {(default_object "IMPLICIT-TACTIC") with + open_function = (fun i o -> if Int.equal i 1 then cache_implicit_tactic o); + cache_function = cache_implicit_tactic; + subst_function = subst_implicit_tactic; + classify_function = (fun o -> Dispose)} + +let declare_implicit_tactic tac = + Lib.add_anonymous_leaf (inImplicitTactic (Some (Tacintern.glob_tactic tac))) + +let clear_implicit_tactic () = + Lib.add_anonymous_leaf (inImplicitTactic None) + +VERNAC COMMAND EXTEND ImplicitTactic CLASSIFIED AS SIDEFF +| [ "Declare" "Implicit" "Tactic" tactic(tac) ] -> [ declare_implicit_tactic tac ] +| [ "Clear" "Implicit" "Tactic" ] -> [ clear_implicit_tactic () ] +END + + + + +(**********************************************************************) +(*spiwack : Vernac commands for retroknowledge *) + +VERNAC COMMAND EXTEND RetroknowledgeRegister CLASSIFIED AS SIDEFF + | [ "Register" constr(c) "as" retroknowledge_field(f) "by" constr(b)] -> + [ let tc,ctx = Constrintern.interp_constr (Global.env ()) Evd.empty c in + let tb,ctx(*FIXME*) = Constrintern.interp_constr (Global.env ()) Evd.empty b in + Global.register f tc tb ] +END + + + +(**********************************************************************) +(* sozeau: abs/gen for induction on instantiated dependent inductives, using "Ford" induction as + defined by Conor McBride *) +TACTIC EXTEND generalize_eqs +| ["generalize_eqs" hyp(id) ] -> [ abstract_generalize ~generalize_vars:false id ] +END +TACTIC EXTEND dep_generalize_eqs +| ["dependent" "generalize_eqs" hyp(id) ] -> [ abstract_generalize ~generalize_vars:false ~force_dep:true id ] +END +TACTIC EXTEND generalize_eqs_vars +| ["generalize_eqs_vars" hyp(id) ] -> [ abstract_generalize ~generalize_vars:true id ] +END +TACTIC EXTEND dep_generalize_eqs_vars +| ["dependent" "generalize_eqs_vars" hyp(id) ] -> [ abstract_generalize ~force_dep:true ~generalize_vars:true id ] +END + +(** Tactic to automatically simplify hypotheses of the form [ΠΔ, x_i = t_i -> T] + where [t_i] is closed w.r.t. Δ. Such hypotheses are automatically generated + during dependent induction. For internal use. *) + +TACTIC EXTEND specialize_eqs +[ "specialize_eqs" hyp(id) ] -> [ specialize_eqs id ] +END + +(**********************************************************************) +(* A tactic that considers a given occurrence of [c] in [t] and *) +(* abstract the minimal set of all the occurrences of [c] so that the *) +(* abstraction [fun x -> t[x/c]] is well-typed *) +(* *) +(* Contributed by Chung-Kil Hur (Winter 2009) *) +(**********************************************************************) + +let subst_var_with_hole occ tid t = + let occref = if occ > 0 then ref occ else Find_subterm.error_invalid_occurrence [occ] in + let locref = ref 0 in + let rec substrec = function + | GVar (_,id) as x -> + if Id.equal id tid + then + (decr occref; + if Int.equal !occref 0 then x + else + (incr locref; + GHole (Loc.make_loc (!locref,0), + Evar_kinds.QuestionMark(Evar_kinds.Define true), + Misctypes.IntroAnonymous, None))) + else x + | c -> map_glob_constr_left_to_right substrec c in + let t' = substrec t + in + if !occref > 0 then Find_subterm.error_invalid_occurrence [occ] else t' + +let subst_hole_with_term occ tc t = + let locref = ref 0 in + let occref = ref occ in + let rec substrec = function + | GHole (_,Evar_kinds.QuestionMark(Evar_kinds.Define true),Misctypes.IntroAnonymous,s) -> + decr occref; + if Int.equal !occref 0 then tc + else + (incr locref; + GHole (Loc.make_loc (!locref,0), + Evar_kinds.QuestionMark(Evar_kinds.Define true),Misctypes.IntroAnonymous,s)) + | c -> map_glob_constr_left_to_right substrec c + in + substrec t + +open Tacmach + +let hResolve id c occ t = + Proofview.Goal.s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let sigma = Sigma.to_evar_map sigma in + let env = Termops.clear_named_body id (Proofview.Goal.env gl) in + let concl = Proofview.Goal.concl gl in + let env_ids = Termops.ids_of_context env in + let c_raw = Detyping.detype true env_ids env sigma c in + let t_raw = Detyping.detype true env_ids env sigma t in + let rec resolve_hole t_hole = + try + Pretyping.understand env sigma t_hole + with + | Pretype_errors.PretypeError (_,_,Pretype_errors.UnsolvableImplicit _) as e -> + let (e, info) = CErrors.push e in + let loc = match Loc.get_loc info with None -> Loc.ghost | Some loc -> loc in + resolve_hole (subst_hole_with_term (fst (Loc.unloc loc)) c_raw t_hole) + in + let t_constr,ctx = resolve_hole (subst_var_with_hole occ id t_raw) in + let t_constr = EConstr.of_constr t_constr in + let sigma = Evd.merge_universe_context sigma ctx in + let t_constr_type = Retyping.get_type_of env sigma t_constr in + let tac = + (change_concl (mkLetIn (Anonymous,t_constr,t_constr_type,concl))) + in + Sigma.Unsafe.of_pair (tac, sigma) + end } + +let hResolve_auto id c t = + let rec resolve_auto n = + try + hResolve id c n t + with + | UserError _ as e -> raise e + | e when CErrors.noncritical e -> resolve_auto (n+1) + in + resolve_auto 1 + +TACTIC EXTEND hresolve_core +| [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "at" int_or_var(occ) "in" constr(t) ] -> [ hResolve id c occ t ] +| [ "hresolve_core" "(" ident(id) ":=" constr(c) ")" "in" constr(t) ] -> [ hResolve_auto id c t ] +END + +(** + hget_evar +*) + +TACTIC EXTEND hget_evar +| [ "hget_evar" int_or_var(n) ] -> [ Evar_tactics.hget_evar n ] +END + +(**********************************************************************) + +(**********************************************************************) +(* A tactic that reduces one match t with ... by doing destruct t. *) +(* if t is not a variable, the tactic does *) +(* case_eq t;intros ... heq;rewrite heq in *|-. (but heq itself is *) +(* preserved). *) +(* Contributed by Julien Forest and Pierre Courtieu (july 2010) *) +(**********************************************************************) + +exception Found of unit Proofview.tactic + +let rewrite_except h = + Proofview.Goal.enter { enter = begin fun gl -> + let hyps = Tacmach.New.pf_ids_of_hyps gl in + Tacticals.New.tclMAP (fun id -> if Id.equal id h then Proofview.tclUNIT () else + Tacticals.New.tclTRY (Equality.general_rewrite_in true Locus.AllOccurrences true true id (mkVar h) false)) + hyps + end } + + +let refl_equal = + let coq_base_constant s = + Coqlib.gen_constant_in_modules "RecursiveDefinition" + (Coqlib.init_modules @ [["Coq";"Arith";"Le"];["Coq";"Arith";"Lt"]]) s in + function () -> (coq_base_constant "eq_refl") + + +(* This is simply an implementation of the case_eq tactic. this code + should be replaced by a call to the tactic but I don't know how to + call it before it is defined. *) +let mkCaseEq a : unit Proofview.tactic = + Proofview.Goal.enter { enter = begin fun gl -> + let type_of_a = Tacmach.New.pf_unsafe_type_of gl a in + Tacticals.New.tclTHENLIST + [Tactics.generalize [(mkApp(EConstr.of_constr (delayed_force refl_equal), [| type_of_a; a|]))]; + Proofview.Goal.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], a]).Reductionops.e_redfun env (Sigma.Unsafe.of_evar_map Evd.empty) concl in + change_concl c + end }; + simplest_case a] + end } + + +let case_eq_intros_rewrite x = + Proofview.Goal.enter { enter = begin fun gl -> + let n = nb_prod (Tacmach.New.project gl) (Proofview.Goal.concl gl) in + (* Pp.msgnl (Printer.pr_lconstr x); *) + Tacticals.New.tclTHENLIST [ + mkCaseEq x; + Proofview.Goal.enter { enter = begin fun gl -> + let concl = Proofview.Goal.concl gl in + let hyps = Tacmach.New.pf_ids_of_hyps gl in + let n' = nb_prod (Tacmach.New.project gl) concl in + let h = fresh_id_in_env hyps (Id.of_string "heq") (Proofview.Goal.env gl) in + Tacticals.New.tclTHENLIST [ + Tacticals.New.tclDO (n'-n-1) intro; + introduction h; + rewrite_except h] + end } + ] + end } + +let rec find_a_destructable_match sigma t = + let cl = induction_arg_of_quantified_hyp (NamedHyp (Id.of_string "x")) in + let cl = [cl, (None, None), None], None in + let dest = TacAtom (Loc.ghost, TacInductionDestruct(false, false, cl)) in + match EConstr.kind sigma t with + | Case (_,_,x,_) when closed0 sigma x -> + if isVar sigma x then + (* TODO check there is no rel n. *) + raise (Found (Tacinterp.eval_tactic dest)) + else + (* let _ = Pp.msgnl (Printer.pr_lconstr x) in *) + raise (Found (case_eq_intros_rewrite x)) + | _ -> EConstr.iter sigma (fun c -> find_a_destructable_match sigma c) t + + +let destauto t = + Proofview.tclEVARMAP >>= fun sigma -> + try find_a_destructable_match sigma t; + Tacticals.New.tclZEROMSG (str "No destructable match found") + with Found tac -> tac + +let destauto_in id = + Proofview.Goal.enter { enter = begin fun gl -> + let ctype = Tacmach.New.pf_unsafe_type_of gl (mkVar id) in +(* Pp.msgnl (Printer.pr_lconstr (mkVar id)); *) +(* Pp.msgnl (Printer.pr_lconstr (ctype)); *) + destauto ctype + end } + +TACTIC EXTEND destauto +| [ "destauto" ] -> [ Proofview.Goal.enter { enter = begin fun gl -> destauto (Proofview.Goal.concl gl) end } ] +| [ "destauto" "in" hyp(id) ] -> [ destauto_in id ] +END + + +(* ********************************************************************* *) + +let eq_constr x y = + Proofview.Goal.enter { enter = begin fun gl -> + let evd = Tacmach.New.project gl in + match EConstr.eq_constr_universes evd x y with + | Some _ -> Proofview.tclUNIT () + | None -> Tacticals.New.tclFAIL 0 (str "Not equal") + end } + +TACTIC EXTEND constr_eq +| [ "constr_eq" constr(x) constr(y) ] -> [ eq_constr x y ] +END + +TACTIC EXTEND constr_eq_nounivs +| [ "constr_eq_nounivs" constr(x) constr(y) ] -> [ + Proofview.tclEVARMAP >>= fun sigma -> + if eq_constr_nounivs sigma x y then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (str "Not equal") ] +END + +TACTIC EXTEND is_evar +| [ "is_evar" constr(x) ] -> [ + Proofview.tclEVARMAP >>= fun sigma -> + match EConstr.kind sigma x with + | Evar _ -> Proofview.tclUNIT () + | _ -> Tacticals.New.tclFAIL 0 (str "Not an evar") + ] +END + +let has_evar sigma c = +let rec has_evar x = + match EConstr.kind sigma x with + | Evar _ -> true + | Rel _ | Var _ | Meta _ | Sort _ | Const _ | Ind _ | Construct _ -> + false + | Cast (t1, _, t2) | Prod (_, t1, t2) | Lambda (_, t1, t2) -> + has_evar t1 || has_evar t2 + | LetIn (_, t1, t2, t3) -> + has_evar t1 || has_evar t2 || has_evar t3 + | App (t1, ts) -> + has_evar t1 || has_evar_array ts + | Case (_, t1, t2, ts) -> + has_evar t1 || has_evar t2 || has_evar_array ts + | Fix ((_, tr)) | CoFix ((_, tr)) -> + has_evar_prec tr + | Proj (p, c) -> has_evar c +and has_evar_array x = + Array.exists has_evar x +and has_evar_prec (_, ts1, ts2) = + Array.exists has_evar ts1 || Array.exists has_evar ts2 +in +has_evar c + +TACTIC EXTEND has_evar +| [ "has_evar" constr(x) ] -> [ + Proofview.tclEVARMAP >>= fun sigma -> + if has_evar sigma x then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (str "No evars") +] +END + +TACTIC EXTEND is_hyp +| [ "is_var" constr(x) ] -> [ + Proofview.tclEVARMAP >>= fun sigma -> + match EConstr.kind sigma x with + | Var _ -> Proofview.tclUNIT () + | _ -> Tacticals.New.tclFAIL 0 (str "Not a variable or hypothesis") ] +END + +TACTIC EXTEND is_fix +| [ "is_fix" constr(x) ] -> [ + Proofview.tclEVARMAP >>= fun sigma -> + match EConstr.kind sigma x with + | Fix _ -> Proofview.tclUNIT () + | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a fix definition") ] +END;; + +TACTIC EXTEND is_cofix +| [ "is_cofix" constr(x) ] -> [ + Proofview.tclEVARMAP >>= fun sigma -> + match EConstr.kind sigma x with + | CoFix _ -> Proofview.tclUNIT () + | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a cofix definition") ] +END;; + +TACTIC EXTEND is_ind +| [ "is_ind" constr(x) ] -> [ + Proofview.tclEVARMAP >>= fun sigma -> + match EConstr.kind sigma x with + | Ind _ -> Proofview.tclUNIT () + | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not an (co)inductive datatype") ] +END;; + +TACTIC EXTEND is_constructor +| [ "is_constructor" constr(x) ] -> [ + Proofview.tclEVARMAP >>= fun sigma -> + match EConstr.kind sigma x with + | Construct _ -> Proofview.tclUNIT () + | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a constructor") ] +END;; + +TACTIC EXTEND is_proj +| [ "is_proj" constr(x) ] -> [ + Proofview.tclEVARMAP >>= fun sigma -> + match EConstr.kind sigma x with + | Proj _ -> Proofview.tclUNIT () + | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a primitive projection") ] +END;; + +TACTIC EXTEND is_const +| [ "is_const" constr(x) ] -> [ + Proofview.tclEVARMAP >>= fun sigma -> + match EConstr.kind sigma x with + | Const _ -> Proofview.tclUNIT () + | _ -> Tacticals.New.tclFAIL 0 (Pp.str "not a constant") ] +END;; + +(* Command to grab the evars left unresolved at the end of a proof. *) +(* spiwack: I put it in extratactics because it is somewhat tied with + the semantics of the LCF-style tactics, hence with the classic tactic + mode. *) +VERNAC COMMAND EXTEND GrabEvars +[ "Grab" "Existential" "Variables" ] + => [ Vernac_classifier.classify_as_proofstep ] + -> [ Proof_global.simple_with_current_proof (fun _ p -> Proof.V82.grab_evars p) ] +END + +(* Shelves all the goals under focus. *) +TACTIC EXTEND shelve +| [ "shelve" ] -> + [ Proofview.shelve ] +END + +(* Shelves the unifiable goals under focus, i.e. the goals which + appear in other goals under focus (the unfocused goals are not + considered). *) +TACTIC EXTEND shelve_unifiable +| [ "shelve_unifiable" ] -> + [ Proofview.shelve_unifiable ] +END + +(* Unshelves the goal shelved by the tactic. *) +TACTIC EXTEND unshelve +| [ "unshelve" tactic1(t) ] -> + [ + Proofview.with_shelf (Tacinterp.tactic_of_value ist t) >>= fun (gls, ()) -> + Proofview.Unsafe.tclGETGOALS >>= fun ogls -> + Proofview.Unsafe.tclSETGOALS (gls @ ogls) + ] +END + +(* Command to add every unshelved variables to the focus *) +VERNAC COMMAND EXTEND Unshelve +[ "Unshelve" ] + => [ Vernac_classifier.classify_as_proofstep ] + -> [ Proof_global.simple_with_current_proof (fun _ p -> Proof.unshelve p) ] +END + +(* Gives up on the goals under focus: the goals are considered solved, + but the proof cannot be closed until the user goes back and solve + these goals. *) +TACTIC EXTEND give_up +| [ "give_up" ] -> + [ Proofview.give_up ] +END + +(* cycles [n] goals *) +TACTIC EXTEND cycle +| [ "cycle" int_or_var(n) ] -> [ Proofview.cycle n ] +END + +(* swaps goals number [i] and [j] *) +TACTIC EXTEND swap +| [ "swap" int_or_var(i) int_or_var(j) ] -> [ Proofview.swap i j ] +END + +(* reverses the list of focused goals *) +TACTIC EXTEND revgoals +| [ "revgoals" ] -> [ Proofview.revgoals ] +END + +type cmp = + | Eq + | Lt | Le + | Gt | Ge + +type 'i test = + | Test of cmp * 'i * 'i + +let pr_cmp = function + | Eq -> Pp.str"=" + | Lt -> Pp.str"<" + | Le -> Pp.str"<=" + | Gt -> Pp.str">" + | Ge -> Pp.str">=" + +let pr_cmp' _prc _prlc _prt = pr_cmp + +let pr_test_gen f (Test(c,x,y)) = + Pp.(f x ++ pr_cmp c ++ f y) + +let pr_test = pr_test_gen (Pputils.pr_or_var Pp.int) + +let pr_test' _prc _prlc _prt = pr_test + +let pr_itest = pr_test_gen Pp.int + +let pr_itest' _prc _prlc _prt = pr_itest + + + +ARGUMENT EXTEND comparison PRINTED BY pr_cmp' +| [ "=" ] -> [ Eq ] +| [ "<" ] -> [ Lt ] +| [ "<=" ] -> [ Le ] +| [ ">" ] -> [ Gt ] +| [ ">=" ] -> [ Ge ] + END + +let interp_test ist gls = function + | Test (c,x,y) -> + project gls , + Test(c,Tacinterp.interp_int_or_var ist x,Tacinterp.interp_int_or_var ist y) + +ARGUMENT EXTEND test + PRINTED BY pr_itest' + INTERPRETED BY interp_test + RAW_PRINTED BY pr_test' + GLOB_PRINTED BY pr_test' +| [ int_or_var(x) comparison(c) int_or_var(y) ] -> [ Test(c,x,y) ] +END + +let interp_cmp = function + | Eq -> Int.equal + | Lt -> ((<):int->int->bool) + | Le -> ((<=):int->int->bool) + | Gt -> ((>):int->int->bool) + | Ge -> ((>=):int->int->bool) + +let run_test = function + | Test(c,x,y) -> interp_cmp c x y + +let guard tst = + if run_test tst then + Proofview.tclUNIT () + else + let msg = Pp.(str"Condition not satisfied:"++ws 1++(pr_itest tst)) in + Tacticals.New.tclZEROMSG msg + + +TACTIC EXTEND guard +| [ "guard" test(tst) ] -> [ guard tst ] +END + +let decompose l c = + Proofview.Goal.enter { enter = begin fun gl -> + let sigma = Tacmach.New.project gl in + let to_ind c = + if isInd sigma c then fst (destInd sigma c) + else error "not an inductive type" + in + let l = List.map to_ind l in + Elim.h_decompose l c + end } + +TACTIC EXTEND decompose +| [ "decompose" "[" ne_constr_list(l) "]" constr(c) ] -> [ decompose l c ] +END + +(** library/keys *) + +VERNAC COMMAND EXTEND Declare_keys CLASSIFIED AS SIDEFF +| [ "Declare" "Equivalent" "Keys" constr(c) constr(c') ] -> [ + let get_key c = + let (evd, c) = Constrintern.interp_open_constr (Global.env ()) Evd.empty c in + let kind c = EConstr.kind evd c in + Keys.constr_key kind c + in + let k1 = get_key c in + let k2 = get_key c' in + match k1, k2 with + | Some k1, Some k2 -> Keys.declare_equiv_keys k1 k2 + | _ -> () ] +END + +VERNAC COMMAND EXTEND Print_keys CLASSIFIED AS QUERY +| [ "Print" "Equivalent" "Keys" ] -> [ Feedback.msg_info (Keys.pr_keys Printer.pr_global) ] +END + + +VERNAC COMMAND EXTEND OptimizeProof +| [ "Optimize" "Proof" ] => [ Vernac_classifier.classify_as_proofstep ] -> + [ Proof_global.compact_the_proof () ] +| [ "Optimize" "Heap" ] => [ Vernac_classifier.classify_as_proofstep ] -> + [ Gc.compact () ] +END diff --git a/plugins/ltac/extratactics.mli b/plugins/ltac/extratactics.mli new file mode 100644 index 000000000..18334dafe --- /dev/null +++ b/plugins/ltac/extratactics.mli @@ -0,0 +1,14 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +val discrHyp : Names.Id.t -> unit Proofview.tactic +val injHyp : Names.Id.t -> unit Proofview.tactic + +(* val refine_tac : Evd.open_constr -> unit Proofview.tactic *) + +val onSomeWithHoles : ('a option -> unit Proofview.tactic) -> 'a Tacexpr.delayed_open option -> unit Proofview.tactic diff --git a/plugins/ltac/g_auto.ml4 b/plugins/ltac/g_auto.ml4 new file mode 100644 index 000000000..dfa8331ff --- /dev/null +++ b/plugins/ltac/g_auto.ml4 @@ -0,0 +1,225 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i camlp4deps: "grammar/grammar.cma" i*) + +open Pp +open Genarg +open Stdarg +open Pcoq.Prim +open Pcoq.Constr +open Pltac +open Hints +open Tacexpr +open Proofview.Notations +open Names + +DECLARE PLUGIN "g_auto" + +(* Hint bases *) + + +TACTIC EXTEND eassumption +| [ "eassumption" ] -> [ Eauto.e_assumption ] +END + +TACTIC EXTEND eexact +| [ "eexact" constr(c) ] -> [ Eauto.e_give_exact c ] +END + +let pr_hintbases _prc _prlc _prt = Pptactic.pr_hintbases + +ARGUMENT EXTEND hintbases + TYPED AS preident_list_opt + PRINTED BY pr_hintbases +| [ "with" "*" ] -> [ None ] +| [ "with" ne_preident_list(l) ] -> [ Some l ] +| [ ] -> [ Some [] ] +END + +let eval_uconstrs ist cs = + let flags = { + Pretyping.use_typeclasses = false; + solve_unification_constraints = true; + use_hook = Pfedit.solve_by_implicit_tactic (); + fail_evar = false; + expand_evars = true + } in + let map c = { delayed = fun env sigma -> + let Sigma.Sigma (c, sigma, p) = c.delayed env sigma in + Sigma.Sigma (c, sigma, p) + } in + List.map (fun c -> map (Pretyping.type_uconstr ~flags ist c)) cs + +let pr_auto_using_raw _ _ _ = Pptactic.pr_auto_using Ppconstr.pr_constr_expr +let pr_auto_using_glob _ _ _ = Pptactic.pr_auto_using (fun (c,_) -> Printer.pr_glob_constr c) +let pr_auto_using _ _ _ = Pptactic.pr_auto_using Printer.pr_closed_glob + +ARGUMENT EXTEND auto_using + TYPED AS uconstr_list + PRINTED BY pr_auto_using + RAW_TYPED AS uconstr_list + RAW_PRINTED BY pr_auto_using_raw + GLOB_TYPED AS uconstr_list + GLOB_PRINTED BY pr_auto_using_glob +| [ "using" ne_uconstr_list_sep(l, ",") ] -> [ l ] +| [ ] -> [ [] ] +END + +(** Auto *) + +TACTIC EXTEND trivial +| [ "trivial" auto_using(lems) hintbases(db) ] -> + [ Auto.h_trivial (eval_uconstrs ist lems) db ] +END + +TACTIC EXTEND info_trivial +| [ "info_trivial" auto_using(lems) hintbases(db) ] -> + [ Auto.h_trivial ~debug:Info (eval_uconstrs ist lems) db ] +END + +TACTIC EXTEND debug_trivial +| [ "debug" "trivial" auto_using(lems) hintbases(db) ] -> + [ Auto.h_trivial ~debug:Debug (eval_uconstrs ist lems) db ] +END + +TACTIC EXTEND auto +| [ "auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> + [ Auto.h_auto n (eval_uconstrs ist lems) db ] +END + +TACTIC EXTEND info_auto +| [ "info_auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> + [ Auto.h_auto ~debug:Info n (eval_uconstrs ist lems) db ] +END + +TACTIC EXTEND debug_auto +| [ "debug" "auto" int_or_var_opt(n) auto_using(lems) hintbases(db) ] -> + [ Auto.h_auto ~debug:Debug n (eval_uconstrs ist lems) db ] +END + +(** Eauto *) + +TACTIC EXTEND prolog +| [ "prolog" "[" uconstr_list(l) "]" int_or_var(n) ] -> + [ Eauto.prolog_tac (eval_uconstrs ist l) n ] +END + +let make_depth n = snd (Eauto.make_dimension n None) + +TACTIC EXTEND eauto +| [ "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) + hintbases(db) ] -> + [ Eauto.gen_eauto (Eauto.make_dimension n p) (eval_uconstrs ist lems) db ] +END + +TACTIC EXTEND new_eauto +| [ "new" "auto" int_or_var_opt(n) auto_using(lems) + hintbases(db) ] -> + [ match db with + | None -> Auto.new_full_auto (make_depth n) (eval_uconstrs ist lems) + | Some l -> Auto.new_auto (make_depth n) (eval_uconstrs ist lems) l ] +END + +TACTIC EXTEND debug_eauto +| [ "debug" "eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) + hintbases(db) ] -> + [ Eauto.gen_eauto ~debug:Debug (Eauto.make_dimension n p) (eval_uconstrs ist lems) db ] +END + +TACTIC EXTEND info_eauto +| [ "info_eauto" int_or_var_opt(n) int_or_var_opt(p) auto_using(lems) + hintbases(db) ] -> + [ Eauto.gen_eauto ~debug:Info (Eauto.make_dimension n p) (eval_uconstrs ist lems) db ] +END + +TACTIC EXTEND dfs_eauto +| [ "dfs" "eauto" int_or_var_opt(p) auto_using(lems) + hintbases(db) ] -> + [ Eauto.gen_eauto (Eauto.make_dimension p None) (eval_uconstrs ist lems) db ] +END + +TACTIC EXTEND autounfold +| [ "autounfold" hintbases(db) clause_dft_concl(cl) ] -> [ Eauto.autounfold_tac db cl ] +END + +TACTIC EXTEND autounfold_one +| [ "autounfold_one" hintbases(db) "in" hyp(id) ] -> + [ Eauto.autounfold_one (match db with None -> ["core"] | Some x -> "core"::x) (Some (id, Locus.InHyp)) ] +| [ "autounfold_one" hintbases(db) ] -> + [ Eauto.autounfold_one (match db with None -> ["core"] | Some x -> "core"::x) None ] + END + +TACTIC EXTEND unify +| ["unify" constr(x) constr(y) ] -> [ Tactics.unify x 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 + | None -> + let msg = str "Hint table " ++ str base ++ str " not found" in + Tacticals.New.tclZEROMSG msg + | Some t -> + let state = Hints.Hint_db.transparent_state t in + Tactics.unify ~state x y + ] +END + + +TACTIC EXTEND convert_concl_no_check +| ["convert_concl_no_check" constr(x) ] -> [ Tactics.convert_concl_no_check x Term.DEFAULTcast ] +END + +let pr_pre_hints_path_atom _ _ _ = Hints.pp_hints_path_atom Libnames.pr_reference +let pr_hints_path_atom _ _ _ = Hints.pp_hints_path_atom Printer.pr_global +let glob_hints_path_atom ist = Hints.glob_hints_path_atom + +ARGUMENT EXTEND hints_path_atom + PRINTED BY pr_hints_path_atom + + GLOBALIZED BY glob_hints_path_atom + + RAW_PRINTED BY pr_pre_hints_path_atom + GLOB_PRINTED BY pr_hints_path_atom +| [ ne_global_list(g) ] -> [ Hints.PathHints g ] +| [ "_" ] -> [ Hints.PathAny ] +END + +let pr_hints_path prc prx pry c = Hints.pp_hints_path c +let pr_pre_hints_path prc prx pry c = Hints.pp_hints_path_gen Libnames.pr_reference c +let glob_hints_path ist = Hints.glob_hints_path + +ARGUMENT EXTEND hints_path +PRINTED BY pr_hints_path + +GLOBALIZED BY glob_hints_path +RAW_PRINTED BY pr_pre_hints_path +GLOB_PRINTED BY pr_hints_path + +| [ "(" hints_path(p) ")" ] -> [ p ] +| [ hints_path(p) "*" ] -> [ Hints.PathStar p ] +| [ "emp" ] -> [ Hints.PathEmpty ] +| [ "eps" ] -> [ Hints.PathEpsilon ] +| [ hints_path(p) "|" hints_path(q) ] -> [ Hints.PathOr (p, q) ] +| [ hints_path_atom(a) ] -> [ Hints.PathAtom a ] +| [ hints_path(p) hints_path(q) ] -> [ Hints.PathSeq (p, q) ] +END + +ARGUMENT EXTEND opthints + TYPED AS preident_list_opt + PRINTED BY pr_hintbases +| [ ":" ne_preident_list(l) ] -> [ Some l ] +| [ ] -> [ None ] +END + +VERNAC COMMAND EXTEND HintCut CLASSIFIED AS SIDEFF +| [ "Hint" "Cut" "[" hints_path(p) "]" opthints(dbnames) ] -> [ + let entry = Hints.HintsCutEntry (Hints.glob_hints_path p) in + Hints.add_hints (Locality.make_section_locality (Locality.LocalityFixme.consume ())) + (match dbnames with None -> ["core"] | Some l -> l) entry ] +END + diff --git a/plugins/ltac/g_class.ml4 b/plugins/ltac/g_class.ml4 new file mode 100644 index 000000000..ff5e7d5ff --- /dev/null +++ b/plugins/ltac/g_class.ml4 @@ -0,0 +1,123 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i camlp4deps: "grammar/grammar.cma" i*) + +open Misctypes +open Class_tactics +open Pltac +open Stdarg +open Tacarg +open Names + +DECLARE PLUGIN "g_class" + +(** Options: depth, debug and transparency settings. *) + +let set_transparency cl b = + List.iter (fun r -> + let gr = Smartlocate.global_with_alias r in + let ev = Tacred.evaluable_of_global_reference (Global.env ()) gr in + Classes.set_typeclass_transparency ev false b) cl + +VERNAC COMMAND EXTEND Typeclasses_Unfold_Settings CLASSIFIED AS SIDEFF +| [ "Typeclasses" "Transparent" reference_list(cl) ] -> [ + set_transparency cl true ] +END + +VERNAC COMMAND EXTEND Typeclasses_Rigid_Settings CLASSIFIED AS SIDEFF +| [ "Typeclasses" "Opaque" reference_list(cl) ] -> [ + set_transparency cl false ] +END + +open Genarg + +let pr_debug _prc _prlc _prt b = + if b then Pp.str "debug" else Pp.mt() + +ARGUMENT EXTEND debug TYPED AS bool PRINTED BY pr_debug +| [ "debug" ] -> [ true ] +| [ ] -> [ false ] +END + +let pr_search_strategy _prc _prlc _prt = function + | Some Dfs -> Pp.str "dfs" + | Some Bfs -> Pp.str "bfs" + | None -> Pp.mt () + +ARGUMENT EXTEND eauto_search_strategy PRINTED BY pr_search_strategy +| [ "(bfs)" ] -> [ Some Bfs ] +| [ "(dfs)" ] -> [ Some Dfs ] +| [ ] -> [ None ] +END + +(* true = All transparent, false = Opaque if possible *) + +VERNAC COMMAND EXTEND Typeclasses_Settings CLASSIFIED AS SIDEFF + | [ "Typeclasses" "eauto" ":=" debug(d) eauto_search_strategy(s) int_opt(depth) ] -> [ + set_typeclasses_debug d; + Option.iter set_typeclasses_strategy s; + set_typeclasses_depth depth + ] +END + +(** Compatibility: typeclasses eauto has 8.5 and 8.6 modes *) +TACTIC EXTEND typeclasses_eauto + | [ "typeclasses" "eauto" "bfs" int_or_var_opt(d) "with" ne_preident_list(l) ] -> + [ typeclasses_eauto ~strategy:Bfs ~depth:d l ] + | [ "typeclasses" "eauto" int_or_var_opt(d) "with" ne_preident_list(l) ] -> + [ typeclasses_eauto ~depth:d l ] + | [ "typeclasses" "eauto" int_or_var_opt(d) ] -> [ + typeclasses_eauto ~only_classes:true ~depth:d [Hints.typeclasses_db] ] +END + +TACTIC EXTEND head_of_constr + [ "head_of_constr" ident(h) constr(c) ] -> [ head_of_constr h c ] +END + +TACTIC EXTEND not_evar + [ "not_evar" constr(ty) ] -> [ not_evar ty ] +END + +TACTIC EXTEND is_ground + [ "is_ground" constr(ty) ] -> [ is_ground ty ] +END + +TACTIC EXTEND autoapply + [ "autoapply" constr(c) "using" preident(i) ] -> [ autoapply c i ] +END + +(** TODO: DEPRECATE *) +(* A progress test that allows to see if the evars have changed *) +open Term +open Proofview.Goal +open Proofview.Notations + +let rec eq_constr_mod_evars sigma x y = + let open EConstr in + match EConstr.kind sigma x, EConstr.kind sigma y with + | Evar (e1, l1), Evar (e2, l2) when not (Evar.equal e1 e2) -> true + | _, _ -> compare_constr sigma (fun x y -> eq_constr_mod_evars sigma x y) x y + +let progress_evars t = + Proofview.Goal.enter { enter = begin fun gl -> + let concl = Proofview.Goal.concl gl in + let check = + Proofview.Goal.enter { enter = begin fun gl' -> + let sigma = Tacmach.New.project gl' in + let newconcl = Proofview.Goal.concl gl' in + if eq_constr_mod_evars sigma concl newconcl + then Tacticals.New.tclFAIL 0 (Pp.str"No progress made (modulo evars)") + else Proofview.tclUNIT () + end } + in t <*> check + end } + +TACTIC EXTEND progress_evars + [ "progress_evars" tactic(t) ] -> [ progress_evars (Tacinterp.tactic_of_value ist t) ] +END diff --git a/plugins/ltac/g_eqdecide.ml4 b/plugins/ltac/g_eqdecide.ml4 new file mode 100644 index 000000000..679aa1127 --- /dev/null +++ b/plugins/ltac/g_eqdecide.ml4 @@ -0,0 +1,28 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(************************************************************************) +(* EqDecide *) +(* A tactic for deciding propositional equality on inductive types *) +(* by Eduardo Gimenez *) +(************************************************************************) + +(*i camlp4deps: "grammar/grammar.cma" i*) + +open Eqdecide +open Names + +DECLARE PLUGIN "g_eqdecide" + +TACTIC EXTEND decide_equality +| [ "decide" "equality" ] -> [ decideEqualityGoal ] +END + +TACTIC EXTEND compare +| [ "compare" constr(c1) constr(c2) ] -> [ compare c1 c2 ] +END diff --git a/plugins/ltac/g_ltac.ml4 b/plugins/ltac/g_ltac.ml4 new file mode 100644 index 000000000..ca5d198c2 --- /dev/null +++ b/plugins/ltac/g_ltac.ml4 @@ -0,0 +1,528 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i camlp4deps: "grammar/grammar.cma" i*) + +DECLARE PLUGIN "ltac_plugin" + +open Util +open Pp +open Constrexpr +open Tacexpr +open Misctypes +open Genarg +open Genredexpr +open Tok (* necessary for camlp4 *) +open Names + +open Pcoq +open Pcoq.Constr +open Pcoq.Vernac_ +open Pcoq.Prim +open Pltac + +let fail_default_value = ArgArg 0 + +let arg_of_expr = function + TacArg (loc,a) -> a + | e -> Tacexp (e:raw_tactic_expr) + +let genarg_of_unit () = in_gen (rawwit Stdarg.wit_unit) () +let genarg_of_int n = in_gen (rawwit Stdarg.wit_int) n +let genarg_of_ipattern pat = in_gen (rawwit Stdarg.wit_intro_pattern) pat +let genarg_of_uconstr c = in_gen (rawwit Stdarg.wit_uconstr) c +let in_tac tac = in_gen (rawwit Tacarg.wit_ltac) tac + +let reference_to_id = function + | Libnames.Ident (loc, id) -> (loc, id) + | Libnames.Qualid (loc,_) -> + CErrors.user_err ~loc + (str "This expression should be a simple identifier.") + +let tactic_mode = Gram.entry_create "vernac:tactic_command" + +let new_entry name = + let e = Gram.entry_create name in + e + +let toplevel_selector = new_entry "vernac:toplevel_selector" +let tacdef_body = new_entry "tactic:tacdef_body" + +(* Registers the Classic Proof Mode (which uses [tactic_mode] as a parser for + proof editing and changes nothing else). Then sets it as the default proof mode. *) +let _ = + let mode = { + Proof_global.name = "Classic"; + set = (fun () -> set_command_entry tactic_mode); + reset = (fun () -> set_command_entry Pcoq.Vernac_.noedit_mode); + } in + Proof_global.register_proof_mode mode + +(* Hack to parse "[ id" without dropping [ *) +let test_bracket_ident = + Gram.Entry.of_parser "test_bracket_ident" + (fun strm -> + match stream_nth 0 strm with + | KEYWORD "[" -> + (match stream_nth 1 strm with + | IDENT _ -> () + | _ -> raise Stream.Failure) + | _ -> raise Stream.Failure) + +(* Tactics grammar rules *) + +let hint = G_proofs.hint + +let warn_deprecated_appcontext = + CWarnings.create ~name:"deprecated-appcontext" ~category:"deprecated" + (fun () -> strbrk "appcontext is deprecated and will be removed " ++ + strbrk "in a future version") + +GEXTEND Gram + GLOBAL: tactic tacdef_body tactic_expr binder_tactic tactic_arg command hint + tactic_mode constr_may_eval constr_eval toplevel_selector + operconstr; + + tactic_then_last: + [ [ "|"; lta = LIST0 OPT tactic_expr SEP "|" -> + Array.map (function None -> TacId [] | Some t -> t) (Array.of_list lta) + | -> [||] + ] ] + ; + tactic_then_gen: + [ [ ta = tactic_expr; "|"; (first,last) = tactic_then_gen -> (ta::first, last) + | ta = tactic_expr; ".."; l = tactic_then_last -> ([], Some (ta, l)) + | ".."; l = tactic_then_last -> ([], Some (TacId [], l)) + | ta = tactic_expr -> ([ta], None) + | "|"; (first,last) = tactic_then_gen -> (TacId [] :: first, last) + | -> ([TacId []], None) + ] ] + ; + tactic_then_locality: (* [true] for the local variant [TacThens] and [false] + for [TacExtend] *) + [ [ "[" ; l = OPT">" -> if Option.is_empty l then true else false ] ] + ; + tactic_expr: + [ "5" RIGHTA + [ te = binder_tactic -> te ] + | "4" LEFTA + [ ta0 = tactic_expr; ";"; ta1 = binder_tactic -> TacThen (ta0, ta1) + | ta0 = tactic_expr; ";"; ta1 = tactic_expr -> TacThen (ta0,ta1) + | ta0 = tactic_expr; ";"; l = tactic_then_locality; (first,tail) = tactic_then_gen; "]" -> + match l , tail with + | false , Some (t,last) -> TacThen (ta0,TacExtendTac (Array.of_list first, t, last)) + | true , Some (t,last) -> TacThens3parts (ta0, Array.of_list first, t, last) + | false , None -> TacThen (ta0,TacDispatch first) + | true , None -> TacThens (ta0,first) ] + | "3" RIGHTA + [ IDENT "try"; ta = tactic_expr -> TacTry ta + | IDENT "do"; n = int_or_var; ta = tactic_expr -> TacDo (n,ta) + | IDENT "timeout"; n = int_or_var; ta = tactic_expr -> TacTimeout (n,ta) + | IDENT "time"; s = OPT string; ta = tactic_expr -> TacTime (s,ta) + | IDENT "repeat"; ta = tactic_expr -> TacRepeat ta + | IDENT "progress"; ta = tactic_expr -> TacProgress ta + | IDENT "once"; ta = tactic_expr -> TacOnce ta + | IDENT "exactly_once"; ta = tactic_expr -> TacExactlyOnce ta + | IDENT "infoH"; ta = tactic_expr -> TacShowHyps ta +(*To do: put Abstract in Refiner*) + | IDENT "abstract"; tc = NEXT -> TacAbstract (tc,None) + | IDENT "abstract"; tc = NEXT; "using"; s = ident -> + TacAbstract (tc,Some s) + | sel = selector; ta = tactic_expr -> TacSelect (sel, ta) ] +(*End of To do*) + | "2" RIGHTA + [ ta0 = tactic_expr; "+"; ta1 = binder_tactic -> TacOr (ta0,ta1) + | ta0 = tactic_expr; "+"; ta1 = tactic_expr -> TacOr (ta0,ta1) + | IDENT "tryif" ; ta = tactic_expr ; + "then" ; tat = tactic_expr ; + "else" ; tae = tactic_expr -> TacIfThenCatch(ta,tat,tae) + | ta0 = tactic_expr; "||"; ta1 = binder_tactic -> TacOrelse (ta0,ta1) + | ta0 = tactic_expr; "||"; ta1 = tactic_expr -> TacOrelse (ta0,ta1) ] + | "1" RIGHTA + [ b = match_key; IDENT "goal"; "with"; mrl = match_context_list; "end" -> + TacMatchGoal (b,false,mrl) + | b = match_key; IDENT "reverse"; IDENT "goal"; "with"; + mrl = match_context_list; "end" -> + TacMatchGoal (b,true,mrl) + | b = match_key; c = tactic_expr; "with"; mrl = match_list; "end" -> + TacMatch (b,c,mrl) + | IDENT "first" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> + TacFirst l + | IDENT "solve" ; "["; l = LIST0 tactic_expr SEP "|"; "]" -> + TacSolve l + | IDENT "idtac"; l = LIST0 message_token -> TacId l + | g=failkw; n = [ n = int_or_var -> n | -> fail_default_value ]; + l = LIST0 message_token -> TacFail (g,n,l) + | st = simple_tactic -> st + | a = tactic_arg -> TacArg(!@loc,a) + | r = reference; la = LIST0 tactic_arg_compat -> + TacArg(!@loc,TacCall (!@loc,r,la)) ] + | "0" + [ "("; a = tactic_expr; ")" -> a + | "["; ">"; (tf,tail) = tactic_then_gen; "]" -> + begin match tail with + | Some (t,tl) -> TacExtendTac(Array.of_list tf,t,tl) + | None -> TacDispatch tf + end + | a = tactic_atom -> TacArg (!@loc,a) ] ] + ; + failkw: + [ [ IDENT "fail" -> TacLocal | IDENT "gfail" -> TacGlobal ] ] + ; + (* binder_tactic: level 5 of tactic_expr *) + binder_tactic: + [ RIGHTA + [ "fun"; it = LIST1 input_fun ; "=>"; body = tactic_expr LEVEL "5" -> + TacFun (it,body) + | "let"; isrec = [IDENT "rec" -> true | -> false]; + llc = LIST1 let_clause SEP "with"; "in"; + body = tactic_expr LEVEL "5" -> TacLetIn (isrec,llc,body) + | IDENT "info"; tc = tactic_expr LEVEL "5" -> TacInfo tc ] ] + ; + (* Tactic arguments to the right of an application *) + tactic_arg_compat: + [ [ a = tactic_arg -> a + | c = Constr.constr -> (match c with CRef (r,None) -> Reference r | c -> ConstrMayEval (ConstrTerm c)) + (* Unambiguous entries: tolerated w/o "ltac:" modifier *) + | "()" -> TacGeneric (genarg_of_unit ()) ] ] + ; + (* Can be used as argument and at toplevel in tactic expressions. *) + tactic_arg: + [ [ c = constr_eval -> ConstrMayEval c + | IDENT "fresh"; l = LIST0 fresh_id -> TacFreshId l + | IDENT "type_term"; c=uconstr -> TacPretype c + | IDENT "numgoals" -> TacNumgoals ] ] + ; + (* If a qualid is given, use its short name. TODO: have the shortest + non ambiguous name where dots are replaced by "_"? Probably too + verbose most of the time. *) + fresh_id: + [ [ s = STRING -> ArgArg s (*| id = ident -> ArgVar (!@loc,id)*) + | qid = qualid -> let (_pth,id) = Libnames.repr_qualid (snd qid) in ArgVar (!@loc,id) ] ] + ; + constr_eval: + [ [ IDENT "eval"; rtc = red_expr; "in"; c = Constr.constr -> + ConstrEval (rtc,c) + | IDENT "context"; id = identref; "["; c = Constr.lconstr; "]" -> + ConstrContext (id,c) + | IDENT "type"; IDENT "of"; c = Constr.constr -> + ConstrTypeOf c ] ] + ; + constr_may_eval: (* For extensions *) + [ [ c = constr_eval -> c + | c = Constr.constr -> ConstrTerm c ] ] + ; + tactic_atom: + [ [ n = integer -> TacGeneric (genarg_of_int n) + | r = reference -> TacCall (!@loc,r,[]) + | "()" -> TacGeneric (genarg_of_unit ()) ] ] + ; + match_key: + [ [ "match" -> Once + | "lazymatch" -> Select + | "multimatch" -> General ] ] + ; + input_fun: + [ [ "_" -> Anonymous + | l = ident -> Name l ] ] + ; + let_clause: + [ [ id = identref; ":="; te = tactic_expr -> + (id, arg_of_expr te) + | id = identref; args = LIST1 input_fun; ":="; te = tactic_expr -> + (id, arg_of_expr (TacFun(args,te))) ] ] + ; + match_pattern: + [ [ IDENT "context"; oid = OPT Constr.ident; + "["; pc = Constr.lconstr_pattern; "]" -> + let mode = not (!Flags.tactic_context_compat) in + Subterm (mode, oid, pc) + | IDENT "appcontext"; oid = OPT Constr.ident; + "["; pc = Constr.lconstr_pattern; "]" -> + warn_deprecated_appcontext ~loc:!@loc (); + Subterm (true,oid, pc) + | pc = Constr.lconstr_pattern -> Term pc ] ] + ; + match_hyps: + [ [ na = name; ":"; mp = match_pattern -> Hyp (na, mp) + | na = name; ":="; "["; mpv = match_pattern; "]"; ":"; mpt = match_pattern -> Def (na, mpv, mpt) + | na = name; ":="; mpv = match_pattern -> + let t, ty = + match mpv with + | Term t -> (match t with + | CCast (loc, t, (CastConv ty | CastVM ty | CastNative ty)) -> Term t, Some (Term ty) + | _ -> mpv, None) + | _ -> mpv, None + in Def (na, t, Option.default (Term (CHole (Loc.ghost, None, IntroAnonymous, None))) ty) + ] ] + ; + match_context_rule: + [ [ largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern; + "=>"; te = tactic_expr -> Pat (largs, mp, te) + | "["; largs = LIST0 match_hyps SEP ","; "|-"; mp = match_pattern; + "]"; "=>"; te = tactic_expr -> Pat (largs, mp, te) + | "_"; "=>"; te = tactic_expr -> All te ] ] + ; + match_context_list: + [ [ mrl = LIST1 match_context_rule SEP "|" -> mrl + | "|"; mrl = LIST1 match_context_rule SEP "|" -> mrl ] ] + ; + match_rule: + [ [ mp = match_pattern; "=>"; te = tactic_expr -> Pat ([],mp,te) + | "_"; "=>"; te = tactic_expr -> All te ] ] + ; + match_list: + [ [ mrl = LIST1 match_rule SEP "|" -> mrl + | "|"; mrl = LIST1 match_rule SEP "|" -> mrl ] ] + ; + message_token: + [ [ id = identref -> MsgIdent id + | s = STRING -> MsgString s + | n = integer -> MsgInt n ] ] + ; + + ltac_def_kind: + [ [ ":=" -> false + | "::=" -> true ] ] + ; + + (* Definitions for tactics *) + tacdef_body: + [ [ name = Constr.global; it=LIST1 input_fun; redef = ltac_def_kind; body = tactic_expr -> + if redef then Tacexpr.TacticRedefinition (name, TacFun (it, body)) + else + let id = reference_to_id name in + Tacexpr.TacticDefinition (id, TacFun (it, body)) + | name = Constr.global; redef = ltac_def_kind; body = tactic_expr -> + if redef then Tacexpr.TacticRedefinition (name, body) + else + let id = reference_to_id name in + Tacexpr.TacticDefinition (id, body) + ] ] + ; + tactic: + [ [ tac = tactic_expr -> tac ] ] + ; + + range_selector: + [ [ n = natural ; "-" ; m = natural -> (n, m) + | n = natural -> (n, n) ] ] + ; + (* We unfold a range selectors list once so that we can make a special case + * for a unique SelectNth selector. *) + range_selector_or_nth: + [ [ n = natural ; "-" ; m = natural; + l = OPT [","; l = LIST1 range_selector SEP "," -> l] -> + SelectList ((n, m) :: Option.default [] l) + | n = natural; + l = OPT [","; l = LIST1 range_selector SEP "," -> l] -> + Option.cata (fun l -> SelectList ((n, n) :: l)) (SelectNth n) l ] ] + ; + selector_body: + [ [ l = range_selector_or_nth -> l + | test_bracket_ident; "["; id = ident; "]" -> SelectId id ] ] + ; + selector: + [ [ IDENT "only"; sel = selector_body; ":" -> sel ] ] + ; + toplevel_selector: + [ [ sel = selector_body; ":" -> sel + | IDENT "all"; ":" -> SelectAll ] ] + ; + tactic_mode: + [ [ g = OPT toplevel_selector; tac = G_vernac.query_command -> tac g ] ] + ; + command: + [ [ IDENT "Proof"; "with"; ta = Pltac.tactic; + l = OPT [ "using"; l = G_vernac.section_subset_expr -> l ] -> + Vernacexpr.VernacProof (Some (in_tac ta), G_proofs.hint_proof_using G_vernac.section_subset_expr l) + | IDENT "Proof"; "using"; l = G_vernac.section_subset_expr; + ta = OPT [ "with"; ta = Pltac.tactic -> in_tac ta ] -> + Vernacexpr.VernacProof (ta,Some l) ] ] + ; + hint: + [ [ IDENT "Extern"; n = natural; c = OPT Constr.constr_pattern ; "=>"; + tac = Pltac.tactic -> + Vernacexpr.HintsExtern (n,c, in_tac tac) ] ] + ; + operconstr: LEVEL "0" + [ [ IDENT "ltac"; ":"; "("; tac = Pltac.tactic_expr; ")" -> + let arg = Genarg.in_gen (Genarg.rawwit Tacarg.wit_tactic) tac in + CHole (!@loc, None, IntroAnonymous, Some arg) ] ] + ; + END + +open Stdarg +open Tacarg +open Vernacexpr +open Vernac_classifier +open Goptions +open Libnames + +let print_info_trace = ref None + +let _ = declare_int_option { + optsync = true; + optdepr = false; + optname = "print info trace"; + optkey = ["Info" ; "Level"]; + optread = (fun () -> !print_info_trace); + optwrite = fun n -> print_info_trace := n; +} + +let vernac_solve n info tcom b = + let status = Proof_global.with_current_proof (fun etac p -> + let with_end_tac = if b then Some etac else None in + let global = match n with SelectAll | SelectList _ -> true | _ -> false in + let info = Option.append info !print_info_trace in + let (p,status) = + Pfedit.solve n info (Tacinterp.hide_interp global tcom None) ?with_end_tac p + in + (* in case a strict subtree was completed, + go back to the top of the prooftree *) + let p = Proof.maximal_unfocus Vernacentries.command_focus p in + p,status) in + if not status then Feedback.feedback Feedback.AddedAxiom + +let pr_range_selector (i, j) = + if Int.equal i j then int i + else int i ++ str "-" ++ int j + +let pr_ltac_selector = function +| SelectNth i -> int i ++ str ":" +| SelectList l -> str "[" ++ prlist_with_sep (fun () -> str ", ") pr_range_selector l ++ + str "]" ++ str ":" +| SelectId id -> str "[" ++ Nameops.pr_id id ++ str "]" ++ str ":" +| SelectAll -> str "all" ++ str ":" + +VERNAC ARGUMENT EXTEND ltac_selector PRINTED BY pr_ltac_selector +| [ toplevel_selector(s) ] -> [ s ] +END + +let pr_ltac_info n = str "Info" ++ spc () ++ int n + +VERNAC ARGUMENT EXTEND ltac_info PRINTED BY pr_ltac_info +| [ "Info" natural(n) ] -> [ n ] +END + +let pr_ltac_use_default b = + if b then (* Bug: a space is inserted before "..." *) str ".." else mt () + +VERNAC ARGUMENT EXTEND ltac_use_default PRINTED BY pr_ltac_use_default +| [ "." ] -> [ false ] +| [ "..." ] -> [ true ] +END + +let is_anonymous_abstract = function + | TacAbstract (_,None) -> true + | TacSolve [TacAbstract (_,None)] -> true + | _ -> false +let rm_abstract = function + | TacAbstract (t,_) -> t + | TacSolve [TacAbstract (t,_)] -> TacSolve [t] + | x -> x +let is_explicit_terminator = function TacSolve _ -> true | _ -> false + +VERNAC tactic_mode EXTEND VernacSolve +| [ - ltac_selector_opt(g) ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => + [ classify_as_proofstep ] -> [ + let g = Option.default (Proof_global.get_default_goal_selector ()) g in + vernac_solve g n t def + ] +| [ - "par" ":" ltac_info_opt(n) tactic(t) ltac_use_default(def) ] => + [ + let anon_abstracting_tac = is_anonymous_abstract t in + let solving_tac = is_explicit_terminator t in + let parallel = `Yes (solving_tac,anon_abstracting_tac) in + let pbr = if solving_tac then Some "par" else None in + VtProofStep{ parallel = parallel; proof_block_detection = pbr }, + VtLater + ] -> [ + let t = rm_abstract t in + vernac_solve SelectAll n t def + ] +END + +let pr_ltac_tactic_level n = str "(at level " ++ int n ++ str ")" + +VERNAC ARGUMENT EXTEND ltac_tactic_level PRINTED BY pr_ltac_tactic_level +| [ "(" "at" "level" natural(n) ")" ] -> [ n ] +END + +VERNAC ARGUMENT EXTEND ltac_production_sep +| [ "," string(sep) ] -> [ sep ] +END + +let pr_ltac_production_item = function +| Tacentries.TacTerm s -> quote (str s) +| Tacentries.TacNonTerm (_, (arg, sep), id) -> + let sep = match sep with + | None -> mt () + | Some sep -> str "," ++ spc () ++ quote (str sep) + in + str arg ++ str "(" ++ Nameops.pr_id id ++ sep ++ str ")" + +VERNAC ARGUMENT EXTEND ltac_production_item PRINTED BY pr_ltac_production_item +| [ string(s) ] -> [ Tacentries.TacTerm s ] +| [ ident(nt) "(" ident(p) ltac_production_sep_opt(sep) ")" ] -> + [ Tacentries.TacNonTerm (loc, (Names.Id.to_string nt, sep), p) ] +END + +VERNAC COMMAND EXTEND VernacTacticNotation +| [ "Tactic" "Notation" ltac_tactic_level_opt(n) ne_ltac_production_item_list(r) ":=" tactic(e) ] => + [ VtUnknown, VtNow ] -> + [ + let l = Locality.LocalityFixme.consume () in + let n = Option.default 0 n in + Tacentries.add_tactic_notation (Locality.make_module_locality l) n r e + ] +END + +VERNAC COMMAND EXTEND VernacPrintLtac CLASSIFIED AS QUERY +| [ "Print" "Ltac" reference(r) ] -> + [ Feedback.msg_notice (Tacintern.print_ltac (snd (Libnames.qualid_of_reference r))) ] +END + +let pr_ltac_ref = Libnames.pr_reference + +let pr_tacdef_body tacdef_body = + let id, redef, body = + match tacdef_body with + | TacticDefinition ((_,id), body) -> Nameops.pr_id id, false, body + | TacticRedefinition (id, body) -> pr_ltac_ref id, true, body + in + let idl, body = + match body with + | Tacexpr.TacFun (idl,b) -> idl,b + | _ -> [], body in + id ++ + prlist (function Anonymous -> str " _" + | Name id -> spc () ++ Nameops.pr_id id) idl + ++ (if redef then str" ::=" else str" :=") ++ brk(1,1) + ++ Pptactic.pr_raw_tactic body + +VERNAC ARGUMENT EXTEND ltac_tacdef_body +PRINTED BY pr_tacdef_body +| [ tacdef_body(t) ] -> [ t ] +END + +VERNAC COMMAND EXTEND VernacDeclareTacticDefinition +| [ "Ltac" ne_ltac_tacdef_body_list_sep(l, "with") ] => [ + VtSideff (List.map (function + | TacticDefinition ((_,r),_) -> r + | TacticRedefinition (Ident (_,r),_) -> r + | TacticRedefinition (Qualid (_,q),_) -> snd(repr_qualid q)) l), VtLater + ] -> [ + let lc = Locality.LocalityFixme.consume () in + Tacentries.register_ltac (Locality.make_module_locality lc) l + ] +END + +VERNAC COMMAND EXTEND VernacPrintLtacs CLASSIFIED AS QUERY +| [ "Print" "Ltac" "Signatures" ] -> [ Tacentries.print_ltacs () ] +END diff --git a/plugins/ltac/g_obligations.ml4 b/plugins/ltac/g_obligations.ml4 new file mode 100644 index 000000000..3e6e2db60 --- /dev/null +++ b/plugins/ltac/g_obligations.ml4 @@ -0,0 +1,161 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i camlp4deps: "grammar/grammar.cma" i*) + +(* + Syntax for the subtac terms and types. + Elaborated from correctness/psyntax.ml4 by Jean-Christophe Filliâtre *) + + +open Libnames +open Constrexpr +open Constrexpr_ops +open Stdarg +open Tacarg +open Extraargs + +let (set_default_tactic, get_default_tactic, print_default_tactic) = + Tactic_option.declare_tactic_option "Program tactic" + +let () = + (** Delay to recover the tactic imperatively *) + let tac = Proofview.tclBIND (Proofview.tclUNIT ()) begin fun () -> + snd (get_default_tactic ()) + end in + Obligations.default_tactic := tac + +let with_tac f tac = + let env = { Genintern.genv = Global.env (); ltacvars = Names.Id.Set.empty } in + let tac = match tac with + | None -> None + | Some tac -> + let tac = Genarg.in_gen (Genarg.rawwit wit_ltac) tac in + let _, tac = Genintern.generic_intern env tac in + Some tac + in + f tac + +(* We define new entries for programs, with the use of this module + * Subtac. These entries are named Subtac.<foo> + *) + +module Gram = Pcoq.Gram +module Tactic = Pltac + +open Pcoq + +let sigref = mkRefC (Qualid (Loc.ghost, Libnames.qualid_of_string "Coq.Init.Specif.sig")) + +type 'a withtac_argtype = (Tacexpr.raw_tactic_expr option, 'a) Genarg.abstract_argument_type + +let wit_withtac : Tacexpr.raw_tactic_expr option Genarg.uniform_genarg_type = + Genarg.create_arg "withtac" + +let withtac = Pcoq.create_generic_entry Pcoq.utactic "withtac" (Genarg.rawwit wit_withtac) + +GEXTEND Gram + GLOBAL: withtac; + + withtac: + [ [ "with"; t = Tactic.tactic -> Some t + | -> None ] ] + ; + + Constr.closed_binder: + [[ "("; id=Prim.name; ":"; t=Constr.lconstr; "|"; c=Constr.lconstr; ")" -> + let typ = mkAppC (sigref, [mkLambdaC ([id], default_binder_kind, t, c)]) in + [CLocalAssum ([id], default_binder_kind, typ)] + ] ]; + + END + +open Obligations + +let obligation obl tac = with_tac (fun t -> Obligations.obligation obl t) tac +let next_obligation obl tac = with_tac (fun t -> Obligations.next_obligation obl t) tac + +let classify_obbl _ = Vernacexpr.(VtStartProof ("Classic",Doesn'tGuaranteeOpacity,[]), VtLater) + +VERNAC COMMAND EXTEND Obligations CLASSIFIED BY classify_obbl +| [ "Obligation" integer(num) "of" ident(name) ":" lglob(t) withtac(tac) ] -> + [ obligation (num, Some name, Some t) tac ] +| [ "Obligation" integer(num) "of" ident(name) withtac(tac) ] -> + [ obligation (num, Some name, None) tac ] +| [ "Obligation" integer(num) ":" lglob(t) withtac(tac) ] -> + [ obligation (num, None, Some t) tac ] +| [ "Obligation" integer(num) withtac(tac) ] -> + [ obligation (num, None, None) tac ] +| [ "Next" "Obligation" "of" ident(name) withtac(tac) ] -> + [ next_obligation (Some name) tac ] +| [ "Next" "Obligation" withtac(tac) ] -> [ next_obligation None tac ] +END + +VERNAC COMMAND EXTEND Solve_Obligation CLASSIFIED AS SIDEFF +| [ "Solve" "Obligation" integer(num) "of" ident(name) "with" tactic(t) ] -> + [ try_solve_obligation num (Some name) (Some (Tacinterp.interp t)) ] +| [ "Solve" "Obligation" integer(num) "with" tactic(t) ] -> + [ try_solve_obligation num None (Some (Tacinterp.interp t)) ] +END + +VERNAC COMMAND EXTEND Solve_Obligations CLASSIFIED AS SIDEFF +| [ "Solve" "Obligations" "of" ident(name) "with" tactic(t) ] -> + [ try_solve_obligations (Some name) (Some (Tacinterp.interp t)) ] +| [ "Solve" "Obligations" "with" tactic(t) ] -> + [ try_solve_obligations None (Some (Tacinterp.interp t)) ] +| [ "Solve" "Obligations" ] -> + [ try_solve_obligations None None ] +END + +VERNAC COMMAND EXTEND Solve_All_Obligations CLASSIFIED AS SIDEFF +| [ "Solve" "All" "Obligations" "with" tactic(t) ] -> + [ solve_all_obligations (Some (Tacinterp.interp t)) ] +| [ "Solve" "All" "Obligations" ] -> + [ solve_all_obligations None ] +END + +VERNAC COMMAND EXTEND Admit_Obligations CLASSIFIED AS SIDEFF +| [ "Admit" "Obligations" "of" ident(name) ] -> [ admit_obligations (Some name) ] +| [ "Admit" "Obligations" ] -> [ admit_obligations None ] +END + +VERNAC COMMAND EXTEND Set_Solver CLASSIFIED AS SIDEFF +| [ "Obligation" "Tactic" ":=" tactic(t) ] -> [ + set_default_tactic + (Locality.make_section_locality (Locality.LocalityFixme.consume ())) + (Tacintern.glob_tactic t) ] +END + +open Pp + +VERNAC COMMAND EXTEND Show_Solver CLASSIFIED AS QUERY +| [ "Show" "Obligation" "Tactic" ] -> [ + Feedback.msg_info (str"Program obligation tactic is " ++ print_default_tactic ()) ] +END + +VERNAC COMMAND EXTEND Show_Obligations CLASSIFIED AS QUERY +| [ "Obligations" "of" ident(name) ] -> [ show_obligations (Some name) ] +| [ "Obligations" ] -> [ show_obligations None ] +END + +VERNAC COMMAND EXTEND Show_Preterm CLASSIFIED AS QUERY +| [ "Preterm" "of" ident(name) ] -> [ Feedback.msg_info (show_term (Some name)) ] +| [ "Preterm" ] -> [ Feedback.msg_info (show_term None) ] +END + +open Pp + +(* Declare a printer for the content of Program tactics *) +let () = + let printer _ _ _ = function + | None -> mt () + | Some tac -> str "with" ++ spc () ++ Pptactic.pr_raw_tactic tac + in + (* should not happen *) + let dummy _ _ _ expr = assert false in + Pptactic.declare_extra_genarg_pprule wit_withtac printer dummy dummy diff --git a/plugins/ltac/g_rewrite.ml4 b/plugins/ltac/g_rewrite.ml4 new file mode 100644 index 000000000..fdcaedab3 --- /dev/null +++ b/plugins/ltac/g_rewrite.ml4 @@ -0,0 +1,279 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i camlp4deps: "grammar/grammar.cma" i*) + +(* Syntax for rewriting with strategies *) + +open Names +open Misctypes +open Locus +open Constrexpr +open Glob_term +open Geninterp +open Extraargs +open Tacmach +open Tacticals +open Proofview.Notations +open Rewrite +open Stdarg +open Pcoq.Vernac_ +open Pcoq.Prim +open Pcoq.Constr +open Pltac + +DECLARE PLUGIN "g_rewrite" + +type constr_expr_with_bindings = constr_expr with_bindings +type glob_constr_with_bindings = Tacexpr.glob_constr_and_expr with_bindings +type glob_constr_with_bindings_sign = interp_sign * Tacexpr.glob_constr_and_expr with_bindings + +let pr_glob_constr_with_bindings_sign _ _ _ (ge : glob_constr_with_bindings_sign) = Printer.pr_glob_constr (fst (fst (snd ge))) +let pr_glob_constr_with_bindings _ _ _ (ge : glob_constr_with_bindings) = Printer.pr_glob_constr (fst (fst ge)) +let pr_constr_expr_with_bindings prc _ _ (ge : constr_expr_with_bindings) = prc (fst ge) +let interp_glob_constr_with_bindings ist gl c = Tacmach.project gl , (ist, c) +let glob_glob_constr_with_bindings ist l = Tacintern.intern_constr_with_bindings ist l +let subst_glob_constr_with_bindings s c = + Tacsubst.subst_glob_with_bindings s c + +ARGUMENT EXTEND glob_constr_with_bindings + PRINTED BY pr_glob_constr_with_bindings_sign + + INTERPRETED BY interp_glob_constr_with_bindings + GLOBALIZED BY glob_glob_constr_with_bindings + SUBSTITUTED BY subst_glob_constr_with_bindings + + RAW_PRINTED BY pr_constr_expr_with_bindings + GLOB_PRINTED BY pr_glob_constr_with_bindings + + [ constr_with_bindings(bl) ] -> [ bl ] +END + +type raw_strategy = (constr_expr, Tacexpr.raw_red_expr) strategy_ast +type glob_strategy = (Tacexpr.glob_constr_and_expr, Tacexpr.raw_red_expr) strategy_ast + +let interp_strategy ist gl s = + let sigma = project gl in + sigma, strategy_of_ast s +let glob_strategy ist s = map_strategy (Tacintern.intern_constr ist) (fun c -> c) s +let subst_strategy s str = str + +let pr_strategy _ _ _ (s : strategy) = Pp.str "<strategy>" +let pr_raw_strategy prc prlc _ (s : raw_strategy) = + let prr = Pptactic.pr_red_expr (prc, prlc, Pputils.pr_or_by_notation Libnames.pr_reference, prc) in + Rewrite.pr_strategy prc prr s +let pr_glob_strategy prc prlc _ (s : glob_strategy) = + let prr = Pptactic.pr_red_expr + (Ppconstr.pr_constr_expr, + Ppconstr.pr_lconstr_expr, + Pputils.pr_or_by_notation Libnames.pr_reference, + Ppconstr.pr_constr_expr) + in + Rewrite.pr_strategy prc prr s + +ARGUMENT EXTEND rewstrategy + PRINTED BY pr_strategy + + INTERPRETED BY interp_strategy + GLOBALIZED BY glob_strategy + SUBSTITUTED BY subst_strategy + + RAW_PRINTED BY pr_raw_strategy + GLOB_PRINTED BY pr_glob_strategy + + [ glob(c) ] -> [ StratConstr (c, true) ] + | [ "<-" constr(c) ] -> [ StratConstr (c, false) ] + | [ "subterms" rewstrategy(h) ] -> [ StratUnary (Subterms, h) ] + | [ "subterm" rewstrategy(h) ] -> [ StratUnary (Subterm, h) ] + | [ "innermost" rewstrategy(h) ] -> [ StratUnary(Innermost, h) ] + | [ "outermost" rewstrategy(h) ] -> [ StratUnary(Outermost, h) ] + | [ "bottomup" rewstrategy(h) ] -> [ StratUnary(Bottomup, h) ] + | [ "topdown" rewstrategy(h) ] -> [ StratUnary(Topdown, h) ] + | [ "id" ] -> [ StratId ] + | [ "fail" ] -> [ StratFail ] + | [ "refl" ] -> [ StratRefl ] + | [ "progress" rewstrategy(h) ] -> [ StratUnary (Progress, h) ] + | [ "try" rewstrategy(h) ] -> [ StratUnary (Try, h) ] + | [ "any" rewstrategy(h) ] -> [ StratUnary (Any, h) ] + | [ "repeat" rewstrategy(h) ] -> [ StratUnary (Repeat, h) ] + | [ rewstrategy(h) ";" rewstrategy(h') ] -> [ StratBinary (Compose, h, h') ] + | [ "(" rewstrategy(h) ")" ] -> [ h ] + | [ "choice" rewstrategy(h) rewstrategy(h') ] -> [ StratBinary (Choice, h, h') ] + | [ "old_hints" preident(h) ] -> [ StratHints (true, h) ] + | [ "hints" preident(h) ] -> [ StratHints (false, h) ] + | [ "terms" constr_list(h) ] -> [ StratTerms h ] + | [ "eval" red_expr(r) ] -> [ StratEval r ] + | [ "fold" constr(c) ] -> [ StratFold c ] +END + +(* By default the strategy for "rewrite_db" is top-down *) + +let db_strat db = StratUnary (Topdown, StratHints (false, db)) +let cl_rewrite_clause_db db = cl_rewrite_clause_strat (strategy_of_ast (db_strat db)) + +TACTIC EXTEND rewrite_strat +| [ "rewrite_strat" rewstrategy(s) "in" hyp(id) ] -> [ cl_rewrite_clause_strat s (Some id) ] +| [ "rewrite_strat" rewstrategy(s) ] -> [ cl_rewrite_clause_strat s None ] +| [ "rewrite_db" preident(db) "in" hyp(id) ] -> [ cl_rewrite_clause_db db (Some id) ] +| [ "rewrite_db" preident(db) ] -> [ cl_rewrite_clause_db db None ] +END + +let clsubstitute o c = + Proofview.Goal.enter { enter = begin fun gl -> + let is_tac id = match fst (fst (snd c)) with GVar (_, id') when Id.equal id' id -> true | _ -> false in + let hyps = Tacmach.New.pf_ids_of_hyps gl in + Tacticals.New.tclMAP + (fun cl -> + match cl with + | Some id when is_tac id -> Tacticals.New.tclIDTAC + | _ -> cl_rewrite_clause c o AllOccurrences cl) + (None :: List.map (fun id -> Some id) hyps) + end } + +TACTIC EXTEND substitute +| [ "substitute" orient(o) glob_constr_with_bindings(c) ] -> [ clsubstitute o c ] +END + + +(* Compatibility with old Setoids *) + +TACTIC EXTEND setoid_rewrite + [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) ] + -> [ cl_rewrite_clause c o AllOccurrences None ] + | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "in" hyp(id) ] -> + [ cl_rewrite_clause c o AllOccurrences (Some id) ] + | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) ] -> + [ cl_rewrite_clause c o (occurrences_of occ) None ] + | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "at" occurrences(occ) "in" hyp(id)] -> + [ cl_rewrite_clause c o (occurrences_of occ) (Some id) ] + | [ "setoid_rewrite" orient(o) glob_constr_with_bindings(c) "in" hyp(id) "at" occurrences(occ)] -> + [ cl_rewrite_clause c o (occurrences_of occ) (Some id) ] +END + +VERNAC COMMAND EXTEND AddRelation CLASSIFIED AS SIDEFF + | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> + [ declare_relation a aeq n (Some lemma1) (Some lemma2) None ] + + | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + "as" ident(n) ] -> + [ declare_relation a aeq n (Some lemma1) None None ] + | [ "Add" "Relation" constr(a) constr(aeq) "as" ident(n) ] -> + [ declare_relation a aeq n None None None ] +END + +VERNAC COMMAND EXTEND AddRelation2 CLASSIFIED AS SIDEFF + [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) + "as" ident(n) ] -> + [ declare_relation a aeq n None (Some lemma2) None ] + | [ "Add" "Relation" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> + [ declare_relation a aeq n None (Some lemma2) (Some lemma3) ] +END + +VERNAC COMMAND EXTEND AddRelation3 CLASSIFIED AS SIDEFF + [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> + [ declare_relation a aeq n (Some lemma1) None (Some lemma3) ] + | [ "Add" "Relation" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) + "as" ident(n) ] -> + [ declare_relation a aeq n (Some lemma1) (Some lemma2) (Some lemma3) ] + | [ "Add" "Relation" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) + "as" ident(n) ] -> + [ declare_relation a aeq n None None (Some lemma3) ] +END + +type binders_argtype = local_binder_expr list + +let wit_binders = + (Genarg.create_arg "binders" : binders_argtype Genarg.uniform_genarg_type) + +let binders = Pcoq.create_generic_entry Pcoq.utactic "binders" (Genarg.rawwit wit_binders) + +let () = + let raw_printer _ _ _ l = Pp.pr_non_empty_arg Ppconstr.pr_binders l in + let printer _ _ _ _ = Pp.str "<Unavailable printer for binders>" in + Pptactic.declare_extra_genarg_pprule wit_binders raw_printer printer printer + +open Pcoq + +GEXTEND Gram + GLOBAL: binders; + binders: + [ [ b = Pcoq.Constr.binders -> b ] ]; +END + +VERNAC COMMAND EXTEND AddParametricRelation CLASSIFIED AS SIDEFF + | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) + "reflexivity" "proved" "by" constr(lemma1) + "symmetry" "proved" "by" constr(lemma2) "as" ident(n) ] -> + [ declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) None ] + | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) + "reflexivity" "proved" "by" constr(lemma1) + "as" ident(n) ] -> + [ declare_relation ~binders:b a aeq n (Some lemma1) None None ] + | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "as" ident(n) ] -> + [ declare_relation ~binders:b a aeq n None None None ] +END + +VERNAC COMMAND EXTEND AddParametricRelation2 CLASSIFIED AS SIDEFF + [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) + "as" ident(n) ] -> + [ declare_relation ~binders:b a aeq n None (Some lemma2) None ] + | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> + [ declare_relation ~binders:b a aeq n None (Some lemma2) (Some lemma3) ] +END + +VERNAC COMMAND EXTEND AddParametricRelation3 CLASSIFIED AS SIDEFF + [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + "transitivity" "proved" "by" constr(lemma3) "as" ident(n) ] -> + [ declare_relation ~binders:b a aeq n (Some lemma1) None (Some lemma3) ] + | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "reflexivity" "proved" "by" constr(lemma1) + "symmetry" "proved" "by" constr(lemma2) "transitivity" "proved" "by" constr(lemma3) + "as" ident(n) ] -> + [ declare_relation ~binders:b a aeq n (Some lemma1) (Some lemma2) (Some lemma3) ] + | [ "Add" "Parametric" "Relation" binders(b) ":" constr(a) constr(aeq) "transitivity" "proved" "by" constr(lemma3) + "as" ident(n) ] -> + [ declare_relation ~binders:b a aeq n None None (Some lemma3) ] +END + +VERNAC COMMAND EXTEND AddSetoid1 CLASSIFIED AS SIDEFF + [ "Add" "Setoid" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> + [ add_setoid (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) [] a aeq t n ] + | [ "Add" "Parametric" "Setoid" binders(binders) ":" constr(a) constr(aeq) constr(t) "as" ident(n) ] -> + [ add_setoid (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) binders a aeq t n ] + | [ "Add" "Morphism" constr(m) ":" ident(n) ] + (* This command may or may not open a goal *) + => [ Vernacexpr.VtUnknown, Vernacexpr.VtNow ] + -> [ add_morphism_infer (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) m n ] + | [ "Add" "Morphism" constr(m) "with" "signature" lconstr(s) "as" ident(n) ] + => [ Vernacexpr.(VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater) ] + -> [ add_morphism (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) [] m s n ] + | [ "Add" "Parametric" "Morphism" binders(binders) ":" constr(m) + "with" "signature" lconstr(s) "as" ident(n) ] + => [ Vernacexpr.(VtStartProof("Classic",GuaranteesOpacity,[n]), VtLater) ] + -> [ add_morphism (not (Locality.make_section_locality (Locality.LocalityFixme.consume ()))) binders m s n ] +END + +TACTIC EXTEND setoid_symmetry + [ "setoid_symmetry" ] -> [ setoid_symmetry ] + | [ "setoid_symmetry" "in" hyp(n) ] -> [ setoid_symmetry_in n ] +END + +TACTIC EXTEND setoid_reflexivity +[ "setoid_reflexivity" ] -> [ setoid_reflexivity ] +END + +TACTIC EXTEND setoid_transitivity + [ "setoid_transitivity" constr(t) ] -> [ setoid_transitivity (Some t) ] +| [ "setoid_etransitivity" ] -> [ setoid_transitivity None ] +END + +VERNAC COMMAND EXTEND PrintRewriteHintDb CLASSIFIED AS QUERY + [ "Print" "Rewrite" "HintDb" preident(s) ] -> [ Feedback.msg_notice (Autorewrite.print_rewrite_hintdb s) ] +END diff --git a/plugins/ltac/g_tactic.ml4 b/plugins/ltac/g_tactic.ml4 new file mode 100644 index 000000000..4b3ca80af --- /dev/null +++ b/plugins/ltac/g_tactic.ml4 @@ -0,0 +1,665 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Pp +open CErrors +open Util +open Tacexpr +open Genredexpr +open Constrexpr +open Libnames +open Tok +open Misctypes +open Locus +open Decl_kinds + +open Pcoq + + +let all_with delta = Redops.make_red_flag [FBeta;FMatch;FFix;FCofix;FZeta;delta] + +let tactic_kw = [ "->"; "<-" ; "by" ] +let _ = List.iter CLexer.add_keyword tactic_kw + +let err () = raise Stream.Failure + +(* Hack to parse "(x:=t)" as an explicit argument without conflicts with the *) +(* admissible notation "(x t)" *) +let test_lpar_id_coloneq = + Gram.Entry.of_parser "lpar_id_coloneq" + (fun strm -> + match stream_nth 0 strm with + | KEYWORD "(" -> + (match stream_nth 1 strm with + | IDENT _ -> + (match stream_nth 2 strm with + | KEYWORD ":=" -> () + | _ -> err ()) + | _ -> err ()) + | _ -> err ()) + +(* Hack to recognize "(x)" *) +let test_lpar_id_rpar = + Gram.Entry.of_parser "lpar_id_coloneq" + (fun strm -> + match stream_nth 0 strm with + | KEYWORD "(" -> + (match stream_nth 1 strm with + | IDENT _ -> + (match stream_nth 2 strm with + | KEYWORD ")" -> () + | _ -> err ()) + | _ -> err ()) + | _ -> err ()) + +(* idem for (x:=t) and (1:=t) *) +let test_lpar_idnum_coloneq = + Gram.Entry.of_parser "test_lpar_idnum_coloneq" + (fun strm -> + match stream_nth 0 strm with + | KEYWORD "(" -> + (match stream_nth 1 strm with + | IDENT _ | INT _ -> + (match stream_nth 2 strm with + | KEYWORD ":=" -> () + | _ -> err ()) + | _ -> err ()) + | _ -> err ()) + +(* idem for (x:t) *) +let test_lpar_id_colon = + Gram.Entry.of_parser "lpar_id_colon" + (fun strm -> + match stream_nth 0 strm with + | KEYWORD "(" -> + (match stream_nth 1 strm with + | IDENT _ -> + (match stream_nth 2 strm with + | KEYWORD ":" -> () + | _ -> err ()) + | _ -> err ()) + | _ -> err ()) + +(* idem for (x1..xn:t) [n^2 complexity but exceptional use] *) +let check_for_coloneq = + Gram.Entry.of_parser "lpar_id_colon" + (fun strm -> + let rec skip_to_rpar p n = + match List.last (Stream.npeek n strm) with + | KEYWORD "(" -> skip_to_rpar (p+1) (n+1) + | KEYWORD ")" -> if Int.equal p 0 then n+1 else skip_to_rpar (p-1) (n+1) + | KEYWORD "." -> err () + | _ -> skip_to_rpar p (n+1) in + let rec skip_names n = + match List.last (Stream.npeek n strm) with + | IDENT _ | KEYWORD "_" -> skip_names (n+1) + | KEYWORD ":" -> skip_to_rpar 0 (n+1) (* skip a constr *) + | _ -> err () in + let rec skip_binders n = + match List.last (Stream.npeek n strm) with + | KEYWORD "(" -> skip_binders (skip_names (n+1)) + | IDENT _ | KEYWORD "_" -> skip_binders (n+1) + | KEYWORD ":=" -> () + | _ -> err () in + match stream_nth 0 strm with + | KEYWORD "(" -> skip_binders 2 + | _ -> err ()) + +let lookup_at_as_comma = + Gram.Entry.of_parser "lookup_at_as_comma" + (fun strm -> + match stream_nth 0 strm with + | KEYWORD (","|"at"|"as") -> () + | _ -> err ()) + +open Constr +open Prim +open Pltac + +let mk_fix_tac (loc,id,bl,ann,ty) = + let n = + match bl,ann with + [([_],_,_)], None -> 1 + | _, Some x -> + let ids = List.map snd (List.flatten (List.map pi1 bl)) in + (try List.index Names.Name.equal (snd x) ids + with Not_found -> error "No such fix variable.") + | _ -> error "Cannot guess decreasing argument of fix." in + (id,n,CProdN(loc,bl,ty)) + +let mk_cofix_tac (loc,id,bl,ann,ty) = + let _ = Option.map (fun (aloc,_) -> + user_err ~loc:aloc + ~hdr:"Constr:mk_cofix_tac" + (Pp.str"Annotation forbidden in cofix expression.")) ann in + (id,CProdN(loc,bl,ty)) + +(* Functions overloaded by quotifier *) +let destruction_arg_of_constr (c,lbind as clbind) = match lbind with + | NoBindings -> + begin + try ElimOnIdent (Constrexpr_ops.constr_loc c,snd(Constrexpr_ops.coerce_to_id c)) + with e when CErrors.noncritical e -> ElimOnConstr clbind + end + | _ -> ElimOnConstr clbind + +let mkTacCase with_evar = function + | [(clear,ElimOnConstr cl),(None,None),None],None -> + TacCase (with_evar,(clear,cl)) + (* Reinterpret numbers as a notation for terms *) + | [(clear,ElimOnAnonHyp n),(None,None),None],None -> + TacCase (with_evar, + (clear,(CPrim (Loc.ghost, Numeral (Bigint.of_int n)), + NoBindings))) + (* Reinterpret ident as notations for variables in the context *) + (* because we don't know if they are quantified or not *) + | [(clear,ElimOnIdent id),(None,None),None],None -> + TacCase (with_evar,(clear,(CRef (Ident id,None),NoBindings))) + | ic -> + if List.exists (function ((_, ElimOnAnonHyp _),_,_) -> true | _ -> false) (fst ic) + then + error "Use of numbers as direct arguments of 'case' is not supported."; + TacInductionDestruct (false,with_evar,ic) + +let rec mkCLambdaN_simple_loc loc bll c = + match bll with + | ((loc1,_)::_ as idl,bk,t) :: bll -> + CLambdaN (loc,[idl,bk,t],mkCLambdaN_simple_loc (Loc.merge loc1 loc) bll c) + | ([],_,_) :: bll -> mkCLambdaN_simple_loc loc bll c + | [] -> c + +let mkCLambdaN_simple bl c = match bl with + | [] -> c + | h :: _ -> + let loc = Loc.merge (fst (List.hd (pi1 h))) (Constrexpr_ops.constr_loc c) in + mkCLambdaN_simple_loc loc bl c + +let loc_of_ne_list l = Loc.merge (fst (List.hd l)) (fst (List.last l)) + +let map_int_or_var f = function + | ArgArg x -> ArgArg (f x) + | ArgVar _ as y -> y + +let all_concl_occs_clause = { onhyps=Some[]; concl_occs=AllOccurrences } + +let merge_occurrences loc cl = function + | None -> + if Locusops.clause_with_generic_occurrences cl then (None, cl) + else + user_err ~loc (str "Found an \"at\" clause without \"with\" clause.") + | Some (occs, p) -> + let ans = match occs with + | AllOccurrences -> cl + | _ -> + begin match cl with + | { onhyps = Some []; concl_occs = AllOccurrences } -> + { onhyps = Some []; concl_occs = occs } + | { onhyps = Some [(AllOccurrences, id), l]; concl_occs = NoOccurrences } -> + { cl with onhyps = Some [(occs, id), l] } + | _ -> + if Locusops.clause_with_generic_occurrences cl then + user_err ~loc (str "Unable to interpret the \"at\" clause; move it in the \"in\" clause.") + else + user_err ~loc (str "Cannot use clause \"at\" twice.") + end + in + (Some p, ans) + +let warn_deprecated_eqn_syntax = + CWarnings.create ~name:"deprecated-eqn-syntax" ~category:"deprecated" + (fun arg -> strbrk (Printf.sprintf "Syntax \"_eqn:%s\" is deprecated. Please use \"eqn:%s\" instead." arg arg)) + +(* Auxiliary grammar rules *) + +open Vernac_ + +GEXTEND Gram + GLOBAL: simple_tactic constr_with_bindings quantified_hypothesis + bindings red_expr int_or_var open_constr uconstr + simple_intropattern in_clause clause_dft_concl hypident destruction_arg; + + int_or_var: + [ [ n = integer -> ArgArg n + | id = identref -> ArgVar id ] ] + ; + nat_or_var: + [ [ n = natural -> ArgArg n + | id = identref -> ArgVar id ] ] + ; + (* An identifier or a quotation meta-variable *) + id_or_meta: + [ [ id = identref -> id ] ] + ; + open_constr: + [ [ c = constr -> c ] ] + ; + uconstr: + [ [ c = constr -> c ] ] + ; + destruction_arg: + [ [ n = natural -> (None,ElimOnAnonHyp n) + | test_lpar_id_rpar; c = constr_with_bindings -> + (Some false,destruction_arg_of_constr c) + | c = constr_with_bindings_arg -> on_snd destruction_arg_of_constr c + ] ] + ; + constr_with_bindings_arg: + [ [ ">"; c = constr_with_bindings -> (Some true,c) + | c = constr_with_bindings -> (None,c) ] ] + ; + quantified_hypothesis: + [ [ id = ident -> NamedHyp id + | n = natural -> AnonHyp n ] ] + ; + conversion: + [ [ c = constr -> (None, c) + | c1 = constr; "with"; c2 = constr -> (Some (AllOccurrences,c1),c2) + | c1 = constr; "at"; occs = occs_nums; "with"; c2 = constr -> + (Some (occs,c1), c2) ] ] + ; + occs_nums: + [ [ nl = LIST1 nat_or_var -> OnlyOccurrences nl + | "-"; n = nat_or_var; nl = LIST0 int_or_var -> + (* have used int_or_var instead of nat_or_var for compatibility *) + AllOccurrencesBut (List.map (map_int_or_var abs) (n::nl)) ] ] + ; + occs: + [ [ "at"; occs = occs_nums -> occs | -> AllOccurrences ] ] + ; + pattern_occ: + [ [ c = constr; nl = occs -> (nl,c) ] ] + ; + ref_or_pattern_occ: + (* If a string, it is interpreted as a ref + (anyway a Coq string does not reduce) *) + [ [ c = smart_global; nl = occs -> nl,Inl c + | c = constr; nl = occs -> nl,Inr c ] ] + ; + unfold_occ: + [ [ c = smart_global; nl = occs -> (nl,c) ] ] + ; + intropatterns: + [ [ l = LIST0 nonsimple_intropattern -> l ]] + ; + ne_intropatterns: + [ [ l = LIST1 nonsimple_intropattern -> l ]] + ; + or_and_intropattern: + [ [ "["; tc = LIST1 intropatterns SEP "|"; "]" -> IntroOrPattern tc + | "()" -> IntroAndPattern [] + | "("; si = simple_intropattern; ")" -> IntroAndPattern [si] + | "("; si = simple_intropattern; ","; + tc = LIST1 simple_intropattern SEP "," ; ")" -> + IntroAndPattern (si::tc) + | "("; si = simple_intropattern; "&"; + tc = LIST1 simple_intropattern SEP "&" ; ")" -> + (* (A & B & C) is translated into (A,(B,C)) *) + let rec pairify = function + | ([]|[_]|[_;_]) as l -> l + | t::q -> [t;(loc_of_ne_list q,IntroAction (IntroOrAndPattern (IntroAndPattern (pairify q))))] + in IntroAndPattern (pairify (si::tc)) ] ] + ; + equality_intropattern: + [ [ "->" -> IntroRewrite true + | "<-" -> IntroRewrite false + | "[="; tc = intropatterns; "]" -> IntroInjection tc ] ] + ; + naming_intropattern: + [ [ prefix = pattern_ident -> IntroFresh prefix + | "?" -> IntroAnonymous + | id = ident -> IntroIdentifier id ] ] + ; + nonsimple_intropattern: + [ [ l = simple_intropattern -> l + | "*" -> !@loc, IntroForthcoming true + | "**" -> !@loc, IntroForthcoming false ]] + ; + simple_intropattern: + [ [ pat = simple_intropattern_closed; + l = LIST0 ["%"; c = operconstr LEVEL "0" -> c] -> + let loc0,pat = pat in + let f c pat = + let loc1 = Constrexpr_ops.constr_loc c in + let loc = Loc.merge loc0 loc1 in + IntroAction (IntroApplyOn ((loc1,c),(loc,pat))) in + !@loc, List.fold_right f l pat ] ] + ; + simple_intropattern_closed: + [ [ pat = or_and_intropattern -> !@loc, IntroAction (IntroOrAndPattern pat) + | pat = equality_intropattern -> !@loc, IntroAction pat + | "_" -> !@loc, IntroAction IntroWildcard + | pat = naming_intropattern -> !@loc, IntroNaming pat ] ] + ; + simple_binding: + [ [ "("; id = ident; ":="; c = lconstr; ")" -> (!@loc, NamedHyp id, c) + | "("; n = natural; ":="; c = lconstr; ")" -> (!@loc, AnonHyp n, c) ] ] + ; + bindings: + [ [ test_lpar_idnum_coloneq; bl = LIST1 simple_binding -> + ExplicitBindings bl + | bl = LIST1 constr -> ImplicitBindings bl ] ] + ; + constr_with_bindings: + [ [ c = constr; l = with_bindings -> (c, l) ] ] + ; + with_bindings: + [ [ "with"; bl = bindings -> bl | -> NoBindings ] ] + ; + red_flags: + [ [ IDENT "beta" -> [FBeta] + | IDENT "iota" -> [FMatch;FFix;FCofix] + | IDENT "match" -> [FMatch] + | IDENT "fix" -> [FFix] + | IDENT "cofix" -> [FCofix] + | IDENT "zeta" -> [FZeta] + | IDENT "delta"; d = delta_flag -> [d] + ] ] + ; + delta_flag: + [ [ "-"; "["; idl = LIST1 smart_global; "]" -> FDeltaBut idl + | "["; idl = LIST1 smart_global; "]" -> FConst idl + | -> FDeltaBut [] + ] ] + ; + strategy_flag: + [ [ s = LIST1 red_flags -> Redops.make_red_flag (List.flatten s) + | d = delta_flag -> all_with d + ] ] + ; + red_expr: + [ [ IDENT "red" -> Red false + | IDENT "hnf" -> Hnf + | IDENT "simpl"; d = delta_flag; po = OPT ref_or_pattern_occ -> Simpl (all_with d,po) + | IDENT "cbv"; s = strategy_flag -> Cbv s + | IDENT "cbn"; s = strategy_flag -> Cbn s + | IDENT "lazy"; s = strategy_flag -> Lazy s + | IDENT "compute"; delta = delta_flag -> Cbv (all_with delta) + | IDENT "vm_compute"; po = OPT ref_or_pattern_occ -> CbvVm po + | IDENT "native_compute"; po = OPT ref_or_pattern_occ -> CbvNative po + | IDENT "unfold"; ul = LIST1 unfold_occ SEP "," -> Unfold ul + | IDENT "fold"; cl = LIST1 constr -> Fold cl + | IDENT "pattern"; pl = LIST1 pattern_occ SEP"," -> Pattern pl + | s = IDENT -> ExtraRedExpr s ] ] + ; + hypident: + [ [ id = id_or_meta -> + id,InHyp + | "("; IDENT "type"; IDENT "of"; id = id_or_meta; ")" -> + id,InHypTypeOnly + | "("; IDENT "value"; IDENT "of"; id = id_or_meta; ")" -> + id,InHypValueOnly + ] ] + ; + hypident_occ: + [ [ (id,l)=hypident; occs=occs -> ((occs,id),l) ] ] + ; + in_clause: + [ [ "*"; occs=occs -> + {onhyps=None; concl_occs=occs} + | "*"; "|-"; occs=concl_occ -> + {onhyps=None; concl_occs=occs} + | hl=LIST0 hypident_occ SEP","; "|-"; occs=concl_occ -> + {onhyps=Some hl; concl_occs=occs} + | hl=LIST0 hypident_occ SEP"," -> + {onhyps=Some hl; concl_occs=NoOccurrences} ] ] + ; + clause_dft_concl: + [ [ "in"; cl = in_clause -> cl + | occs=occs -> {onhyps=Some[]; concl_occs=occs} + | -> all_concl_occs_clause ] ] + ; + clause_dft_all: + [ [ "in"; cl = in_clause -> cl + | -> {onhyps=None; concl_occs=AllOccurrences} ] ] + ; + opt_clause: + [ [ "in"; cl = in_clause -> Some cl + | "at"; occs = occs_nums -> Some {onhyps=Some[]; concl_occs=occs} + | -> None ] ] + ; + concl_occ: + [ [ "*"; occs = occs -> occs + | -> NoOccurrences ] ] + ; + in_hyp_list: + [ [ "in"; idl = LIST1 id_or_meta -> idl + | -> [] ] ] + ; + in_hyp_as: + [ [ "in"; id = id_or_meta; ipat = as_ipat -> Some (id,ipat) + | -> None ] ] + ; + orient: + [ [ "->" -> true + | "<-" -> false + | -> true ]] + ; + simple_binder: + [ [ na=name -> ([na],Default Explicit,CHole (!@loc, Some (Evar_kinds.BinderType (snd na)), IntroAnonymous, None)) + | "("; nal=LIST1 name; ":"; c=lconstr; ")" -> (nal,Default Explicit,c) + ] ] + ; + fixdecl: + [ [ "("; id = ident; bl=LIST0 simple_binder; ann=fixannot; + ":"; ty=lconstr; ")" -> (!@loc, id, bl, ann, ty) ] ] + ; + fixannot: + [ [ "{"; IDENT "struct"; id=name; "}" -> Some id + | -> None ] ] + ; + cofixdecl: + [ [ "("; id = ident; bl=LIST0 simple_binder; ":"; ty=lconstr; ")" -> + (!@loc, id, bl, None, ty) ] ] + ; + bindings_with_parameters: + [ [ check_for_coloneq; "("; id = ident; bl = LIST0 simple_binder; + ":="; c = lconstr; ")" -> (id, mkCLambdaN_simple bl c) ] ] + ; + eliminator: + [ [ "using"; el = constr_with_bindings -> el ] ] + ; + as_ipat: + [ [ "as"; ipat = simple_intropattern -> Some ipat + | -> None ] ] + ; + or_and_intropattern_loc: + [ [ ipat = or_and_intropattern -> ArgArg (!@loc,ipat) + | locid = identref -> ArgVar locid ] ] + ; + as_or_and_ipat: + [ [ "as"; ipat = or_and_intropattern_loc -> Some ipat + | -> None ] ] + ; + eqn_ipat: + [ [ IDENT "eqn"; ":"; pat = naming_intropattern -> Some (!@loc, pat) + | IDENT "_eqn"; ":"; pat = naming_intropattern -> + let loc = !@loc in + warn_deprecated_eqn_syntax ~loc "H"; Some (loc, pat) + | IDENT "_eqn" -> + let loc = !@loc in + warn_deprecated_eqn_syntax ~loc "?"; Some (loc, IntroAnonymous) + | -> None ] ] + ; + as_name: + [ [ "as"; id = ident -> Names.Name id | -> Names.Anonymous ] ] + ; + by_tactic: + [ [ "by"; tac = tactic_expr LEVEL "3" -> Some tac + | -> None ] ] + ; + rewriter : + [ [ "!"; c = constr_with_bindings_arg -> (RepeatPlus,c) + | ["?"| LEFTQMARK]; c = constr_with_bindings_arg -> (RepeatStar,c) + | n = natural; "!"; c = constr_with_bindings_arg -> (Precisely n,c) + | n = natural; ["?" | LEFTQMARK]; c = constr_with_bindings_arg -> (UpTo n,c) + | n = natural; c = constr_with_bindings_arg -> (Precisely n,c) + | c = constr_with_bindings_arg -> (Precisely 1, c) + ] ] + ; + oriented_rewriter : + [ [ b = orient; p = rewriter -> let (m,c) = p in (b,m,c) ] ] + ; + induction_clause: + [ [ c = destruction_arg; pat = as_or_and_ipat; eq = eqn_ipat; + cl = opt_clause -> (c,(eq,pat),cl) ] ] + ; + induction_clause_list: + [ [ ic = LIST1 induction_clause SEP ","; el = OPT eliminator; + cl_tolerance = opt_clause -> + (* Condition for accepting "in" at the end by compatibility *) + match ic,el,cl_tolerance with + | [c,pat,None],Some _,Some _ -> ([c,pat,cl_tolerance],el) + | _,_,Some _ -> err () + | _,_,None -> (ic,el) ]] + ; + simple_tactic: + [ [ + (* Basic tactics *) + IDENT "intros"; pl = ne_intropatterns -> + TacAtom (!@loc, TacIntroPattern (false,pl)) + | IDENT "intros" -> + TacAtom (!@loc, TacIntroPattern (false,[!@loc,IntroForthcoming false])) + | IDENT "eintros"; pl = ne_intropatterns -> + TacAtom (!@loc, TacIntroPattern (true,pl)) + + | IDENT "apply"; cl = LIST1 constr_with_bindings_arg SEP ","; + inhyp = in_hyp_as -> TacAtom (!@loc, TacApply (true,false,cl,inhyp)) + | IDENT "eapply"; cl = LIST1 constr_with_bindings_arg SEP ","; + inhyp = in_hyp_as -> TacAtom (!@loc, TacApply (true,true,cl,inhyp)) + | IDENT "simple"; IDENT "apply"; + cl = LIST1 constr_with_bindings_arg SEP ","; + inhyp = in_hyp_as -> TacAtom (!@loc, TacApply (false,false,cl,inhyp)) + | IDENT "simple"; IDENT "eapply"; + cl = LIST1 constr_with_bindings_arg SEP","; + inhyp = in_hyp_as -> TacAtom (!@loc, TacApply (false,true,cl,inhyp)) + | IDENT "elim"; cl = constr_with_bindings_arg; el = OPT eliminator -> + TacAtom (!@loc, TacElim (false,cl,el)) + | IDENT "eelim"; cl = constr_with_bindings_arg; el = OPT eliminator -> + TacAtom (!@loc, TacElim (true,cl,el)) + | IDENT "case"; icl = induction_clause_list -> TacAtom (!@loc, mkTacCase false icl) + | IDENT "ecase"; icl = induction_clause_list -> TacAtom (!@loc, mkTacCase true icl) + | "fix"; id = ident; n = natural; "with"; fd = LIST1 fixdecl -> + TacAtom (!@loc, TacMutualFix (id,n,List.map mk_fix_tac fd)) + | "cofix"; id = ident; "with"; fd = LIST1 cofixdecl -> + TacAtom (!@loc, TacMutualCofix (id,List.map mk_cofix_tac fd)) + + | IDENT "pose"; (id,b) = bindings_with_parameters -> + TacAtom (!@loc, TacLetTac (Names.Name id,b,Locusops.nowhere,true,None)) + | IDENT "pose"; b = constr; na = as_name -> + TacAtom (!@loc, TacLetTac (na,b,Locusops.nowhere,true,None)) + | IDENT "set"; (id,c) = bindings_with_parameters; p = clause_dft_concl -> + TacAtom (!@loc, TacLetTac (Names.Name id,c,p,true,None)) + | IDENT "set"; c = constr; na = as_name; p = clause_dft_concl -> + TacAtom (!@loc, TacLetTac (na,c,p,true,None)) + | IDENT "remember"; c = constr; na = as_name; e = eqn_ipat; + p = clause_dft_all -> + TacAtom (!@loc, TacLetTac (na,c,p,false,e)) + + (* Alternative syntax for "pose proof c as id" *) + | IDENT "assert"; test_lpar_id_coloneq; "("; (loc,id) = identref; ":="; + c = lconstr; ")" -> + TacAtom (!@loc, TacAssert (true,None,Some (!@loc,IntroNaming (IntroIdentifier id)),c)) + + (* Alternative syntax for "assert c as id by tac" *) + | IDENT "assert"; test_lpar_id_colon; "("; (loc,id) = identref; ":"; + c = lconstr; ")"; tac=by_tactic -> + TacAtom (!@loc, TacAssert (true,Some tac,Some (!@loc,IntroNaming (IntroIdentifier id)),c)) + + (* Alternative syntax for "enough c as id by tac" *) + | IDENT "enough"; test_lpar_id_colon; "("; (loc,id) = identref; ":"; + c = lconstr; ")"; tac=by_tactic -> + TacAtom (!@loc, TacAssert (false,Some tac,Some (!@loc,IntroNaming (IntroIdentifier id)),c)) + + | IDENT "assert"; c = constr; ipat = as_ipat; tac = by_tactic -> + TacAtom (!@loc, TacAssert (true,Some tac,ipat,c)) + | IDENT "pose"; IDENT "proof"; c = lconstr; ipat = as_ipat -> + TacAtom (!@loc, TacAssert (true,None,ipat,c)) + | IDENT "enough"; c = constr; ipat = as_ipat; tac = by_tactic -> + TacAtom (!@loc, TacAssert (false,Some tac,ipat,c)) + + | IDENT "generalize"; c = constr -> + TacAtom (!@loc, TacGeneralize [((AllOccurrences,c),Names.Anonymous)]) + | IDENT "generalize"; c = constr; l = LIST1 constr -> + let gen_everywhere c = ((AllOccurrences,c),Names.Anonymous) in + TacAtom (!@loc, TacGeneralize (List.map gen_everywhere (c::l))) + | IDENT "generalize"; c = constr; lookup_at_as_comma; nl = occs; + na = as_name; + l = LIST0 [","; c = pattern_occ; na = as_name -> (c,na)] -> + TacAtom (!@loc, TacGeneralize (((nl,c),na)::l)) + + (* Derived basic tactics *) + | IDENT "induction"; ic = induction_clause_list -> + TacAtom (!@loc, TacInductionDestruct (true,false,ic)) + | IDENT "einduction"; ic = induction_clause_list -> + TacAtom (!@loc, TacInductionDestruct(true,true,ic)) + | IDENT "destruct"; icl = induction_clause_list -> + TacAtom (!@loc, TacInductionDestruct(false,false,icl)) + | IDENT "edestruct"; icl = induction_clause_list -> + TacAtom (!@loc, TacInductionDestruct(false,true,icl)) + + (* Equality and inversion *) + | IDENT "rewrite"; l = LIST1 oriented_rewriter SEP ","; + cl = clause_dft_concl; t=by_tactic -> TacAtom (!@loc, TacRewrite (false,l,cl,t)) + | IDENT "erewrite"; l = LIST1 oriented_rewriter SEP ","; + cl = clause_dft_concl; t=by_tactic -> TacAtom (!@loc, TacRewrite (true,l,cl,t)) + | IDENT "dependent"; k = + [ IDENT "simple"; IDENT "inversion" -> SimpleInversion + | IDENT "inversion" -> FullInversion + | IDENT "inversion_clear" -> FullInversionClear ]; + hyp = quantified_hypothesis; + ids = as_or_and_ipat; co = OPT ["with"; c = constr -> c] -> + TacAtom (!@loc, TacInversion (DepInversion (k,co,ids),hyp)) + | IDENT "simple"; IDENT "inversion"; + hyp = quantified_hypothesis; ids = as_or_and_ipat; + cl = in_hyp_list -> + TacAtom (!@loc, TacInversion (NonDepInversion (SimpleInversion, cl, ids), hyp)) + | IDENT "inversion"; + hyp = quantified_hypothesis; ids = as_or_and_ipat; + cl = in_hyp_list -> + TacAtom (!@loc, TacInversion (NonDepInversion (FullInversion, cl, ids), hyp)) + | IDENT "inversion_clear"; + hyp = quantified_hypothesis; ids = as_or_and_ipat; + cl = in_hyp_list -> + TacAtom (!@loc, TacInversion (NonDepInversion (FullInversionClear, cl, ids), hyp)) + | IDENT "inversion"; hyp = quantified_hypothesis; + "using"; c = constr; cl = in_hyp_list -> + TacAtom (!@loc, TacInversion (InversionUsing (c,cl), hyp)) + + (* Conversion *) + | IDENT "red"; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Red false, cl)) + | IDENT "hnf"; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Hnf, cl)) + | IDENT "simpl"; d = delta_flag; po = OPT ref_or_pattern_occ; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Simpl (all_with d, po), cl)) + | IDENT "cbv"; s = strategy_flag; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Cbv s, cl)) + | IDENT "cbn"; s = strategy_flag; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Cbn s, cl)) + | IDENT "lazy"; s = strategy_flag; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Lazy s, cl)) + | IDENT "compute"; delta = delta_flag; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Cbv (all_with delta), cl)) + | IDENT "vm_compute"; po = OPT ref_or_pattern_occ; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (CbvVm po, cl)) + | IDENT "native_compute"; po = OPT ref_or_pattern_occ; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (CbvNative po, cl)) + | IDENT "unfold"; ul = LIST1 unfold_occ SEP ","; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Unfold ul, cl)) + | IDENT "fold"; l = LIST1 constr; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Fold l, cl)) + | IDENT "pattern"; pl = LIST1 pattern_occ SEP","; cl = clause_dft_concl -> + TacAtom (!@loc, TacReduce (Pattern pl, cl)) + + (* Change ne doit pas s'appliquer dans un Definition t := Eval ... *) + | IDENT "change"; (oc,c) = conversion; cl = clause_dft_concl -> + let p,cl = merge_occurrences (!@loc) cl oc in + TacAtom (!@loc, TacChange (p,c,cl)) + ] ] + ; +END;; diff --git a/plugins/ltac/ltac_plugin.mlpack b/plugins/ltac/ltac_plugin.mlpack new file mode 100644 index 000000000..af1c7149d --- /dev/null +++ b/plugins/ltac/ltac_plugin.mlpack @@ -0,0 +1,27 @@ +Tacarg +Pptactic +Pltac +Taccoerce +Tacsubst +Tacenv +Tactic_debug +Tacintern +Tacentries +Profile_ltac +Tactic_matching +Tacinterp +Evar_tactics +Tactic_option +Extraargs +G_obligations +Coretactics +Extratactics +Profile_ltac_tactics +G_auto +G_class +Rewrite +G_rewrite +Tauto +G_eqdecide +G_tactic +G_ltac diff --git a/plugins/ltac/pltac.ml b/plugins/ltac/pltac.ml new file mode 100644 index 000000000..1d21118ae --- /dev/null +++ b/plugins/ltac/pltac.ml @@ -0,0 +1,65 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Names +open Pcoq + +(* Main entry for extensions *) +let simple_tactic = Gram.entry_create "tactic:simple_tactic" + +let make_gen_entry _ name = Gram.entry_create ("tactic:" ^ name) + +(* Entries that can be referred via the string -> Gram.entry table *) +(* Typically for tactic user extensions *) +let open_constr = + make_gen_entry utactic "open_constr" +let constr_with_bindings = + make_gen_entry utactic "constr_with_bindings" +let bindings = + make_gen_entry utactic "bindings" +let hypident = Gram.entry_create "hypident" +let constr_may_eval = make_gen_entry utactic "constr_may_eval" +let constr_eval = make_gen_entry utactic "constr_eval" +let uconstr = + make_gen_entry utactic "uconstr" +let quantified_hypothesis = + make_gen_entry utactic "quantified_hypothesis" +let destruction_arg = make_gen_entry utactic "destruction_arg" +let int_or_var = make_gen_entry utactic "int_or_var" +let simple_intropattern = + make_gen_entry utactic "simple_intropattern" +let in_clause = make_gen_entry utactic "in_clause" +let clause_dft_concl = + make_gen_entry utactic "clause" + + +(* Main entries for ltac *) +let tactic_arg = Gram.entry_create "tactic:tactic_arg" +let tactic_expr = make_gen_entry utactic "tactic_expr" +let binder_tactic = make_gen_entry utactic "binder_tactic" + +let tactic = make_gen_entry utactic "tactic" + +(* Main entry for quotations *) +let tactic_eoi = eoi_entry tactic + +let () = + let open Stdarg in + let open Tacarg in + register_grammar wit_int_or_var (int_or_var); + register_grammar wit_intro_pattern (simple_intropattern); + register_grammar wit_quant_hyp (quantified_hypothesis); + register_grammar wit_uconstr (uconstr); + register_grammar wit_open_constr (open_constr); + register_grammar wit_constr_with_bindings (constr_with_bindings); + register_grammar wit_bindings (bindings); + register_grammar wit_tactic (tactic); + register_grammar wit_ltac (tactic); + register_grammar wit_clause_dft_concl (clause_dft_concl); + register_grammar wit_destruction_arg (destruction_arg); + () diff --git a/plugins/ltac/pltac.mli b/plugins/ltac/pltac.mli new file mode 100644 index 000000000..810e1ec39 --- /dev/null +++ b/plugins/ltac/pltac.mli @@ -0,0 +1,38 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Ltac parsing entries *) + +open Loc +open Names +open Pcoq +open Libnames +open Constrexpr +open Tacexpr +open Genredexpr +open Misctypes + +val open_constr : constr_expr Gram.entry +val constr_with_bindings : constr_expr with_bindings Gram.entry +val bindings : constr_expr bindings Gram.entry +val hypident : (Id.t located * Locus.hyp_location_flag) Gram.entry +val constr_may_eval : (constr_expr,reference or_by_notation,constr_expr) may_eval Gram.entry +val constr_eval : (constr_expr,reference or_by_notation,constr_expr) may_eval Gram.entry +val uconstr : constr_expr Gram.entry +val quantified_hypothesis : quantified_hypothesis Gram.entry +val destruction_arg : constr_expr with_bindings destruction_arg Gram.entry +val int_or_var : int or_var Gram.entry +val simple_tactic : raw_tactic_expr Gram.entry +val simple_intropattern : constr_expr intro_pattern_expr located Gram.entry +val in_clause : Names.Id.t Loc.located Locus.clause_expr Gram.entry +val clause_dft_concl : Names.Id.t Loc.located Locus.clause_expr Gram.entry +val tactic_arg : raw_tactic_arg Gram.entry +val tactic_expr : raw_tactic_expr Gram.entry +val binder_tactic : raw_tactic_expr Gram.entry +val tactic : raw_tactic_expr Gram.entry +val tactic_eoi : raw_tactic_expr Gram.entry diff --git a/plugins/ltac/pptactic.ml b/plugins/ltac/pptactic.ml new file mode 100644 index 000000000..39ae1f41d --- /dev/null +++ b/plugins/ltac/pptactic.ml @@ -0,0 +1,1306 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Pp +open Names +open Namegen +open CErrors +open Util +open Constrexpr +open Tacexpr +open Genarg +open Geninterp +open Stdarg +open Tacarg +open Libnames +open Ppextend +open Misctypes +open Locus +open Decl_kinds +open Genredexpr +open Pputils +open Ppconstr +open Printer + +module Tag = +struct + + let keyword = "tactic.keyword" + let primitive = "tactic.primitive" + let string = "tactic.string" + +end + +let tag t s = Pp.tag t s +let do_not_tag _ x = x +let tag_keyword = tag Tag.keyword +let tag_primitive = tag Tag.primitive +let tag_string = tag Tag.string +let tag_glob_tactic_expr = do_not_tag +let tag_glob_atomic_tactic_expr = do_not_tag +let tag_raw_tactic_expr = do_not_tag +let tag_raw_atomic_tactic_expr = do_not_tag +let tag_atomic_tactic_expr = do_not_tag + +let pr_global x = Nametab.pr_global_env Id.Set.empty x + +type 'a grammar_tactic_prod_item_expr = +| TacTerm of string +| TacNonTerm of Loc.t * 'a * Names.Id.t + +type grammar_terminals = Genarg.ArgT.any Extend.user_symbol grammar_tactic_prod_item_expr list + +type pp_tactic = { + pptac_level : int; + pptac_prods : grammar_terminals; +} + +(* Tactic notations *) +let prnotation_tab = Summary.ref ~name:"pptactic-notation" KNmap.empty + +let declare_notation_tactic_pprule kn pt = + prnotation_tab := KNmap.add kn pt !prnotation_tab + +type 'a raw_extra_genarg_printer = + (constr_expr -> std_ppcmds) -> + (constr_expr -> std_ppcmds) -> + (tolerability -> raw_tactic_expr -> std_ppcmds) -> + 'a -> std_ppcmds + +type 'a glob_extra_genarg_printer = + (glob_constr_and_expr -> std_ppcmds) -> + (glob_constr_and_expr -> std_ppcmds) -> + (tolerability -> glob_tactic_expr -> std_ppcmds) -> + 'a -> std_ppcmds + +type 'a extra_genarg_printer = + (EConstr.constr -> std_ppcmds) -> + (EConstr.constr -> std_ppcmds) -> + (tolerability -> Val.t -> std_ppcmds) -> + 'a -> std_ppcmds + + let keyword x = tag_keyword (str x) + let primitive x = tag_primitive (str x) + + let has_type (Val.Dyn (tag, x)) t = match Val.eq tag t with + | None -> false + | Some _ -> true + + let unbox : type a. Val.t -> a Val.typ -> a= fun (Val.Dyn (tag, x)) t -> + match Val.eq tag t with + | None -> assert false + | Some Refl -> x + + let rec pr_value lev v : std_ppcmds = + if has_type v Val.typ_list then + pr_sequence (fun x -> pr_value lev x) (unbox v Val.typ_list) + else if has_type v Val.typ_opt then + pr_opt_no_spc (fun x -> pr_value lev x) (unbox v Val.typ_opt) + else if has_type v Val.typ_pair then + let (v1, v2) = unbox v Val.typ_pair in + str "(" ++ pr_value lev v1 ++ str ", " ++ pr_value lev v2 ++ str ")" + else + let Val.Dyn (tag, x) = v in + let name = Val.repr tag in + let default = str "<" ++ str name ++ str ">" in + match ArgT.name name with + | None -> default + | Some (ArgT.Any arg) -> + let wit = ExtraArg arg in + match val_tag (Topwit wit) with + | Val.Base t -> + begin match Val.eq t tag with + | None -> default + | Some Refl -> Genprint.generic_top_print (in_gen (Topwit wit) x) + end + | _ -> default + + let pr_with_occurrences pr c = pr_with_occurrences pr keyword c + let pr_red_expr pr c = pr_red_expr pr keyword c + + let pr_may_eval test prc prlc pr2 pr3 = function + | ConstrEval (r,c) -> + hov 0 + (keyword "eval" ++ brk (1,1) ++ + pr_red_expr (prc,prlc,pr2,pr3) r ++ spc () ++ + keyword "in" ++ spc() ++ prc c) + | ConstrContext ((_,id),c) -> + hov 0 + (keyword "context" ++ spc () ++ pr_id id ++ spc () ++ + str "[ " ++ prlc c ++ str " ]") + | ConstrTypeOf c -> + hov 1 (keyword "type of" ++ spc() ++ prc c) + | ConstrTerm c when test c -> + h 0 (str "(" ++ prc c ++ str ")") + | ConstrTerm c -> + prc c + + let pr_may_eval a = + pr_may_eval (fun _ -> false) a + + let pr_arg pr x = spc () ++ pr x + + let pr_and_short_name pr (c,_) = pr c + + let pr_or_by_notation f = function + | AN v -> f v + | ByNotation (_,s,sc) -> qs s ++ pr_opt (fun sc -> str "%" ++ str sc) sc + + let pr_located pr (loc,x) = pr x + + let pr_evaluable_reference = function + | EvalVarRef id -> pr_id id + | EvalConstRef sp -> pr_global (Globnames.ConstRef sp) + + let pr_quantified_hypothesis = function + | AnonHyp n -> int n + | NamedHyp id -> pr_id id + + let pr_binding prc = function + | loc, NamedHyp id, c -> hov 1 (pr_id id ++ str " := " ++ cut () ++ prc c) + | loc, AnonHyp n, c -> hov 1 (int n ++ str " := " ++ cut () ++ prc c) + + let pr_bindings prc prlc = function + | ImplicitBindings l -> + brk (1,1) ++ keyword "with" ++ brk (1,1) ++ + hv 0 (prlist_with_sep spc prc l) + | ExplicitBindings l -> + brk (1,1) ++ keyword "with" ++ brk (1,1) ++ + hv 0 (prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l) + | NoBindings -> mt () + + let pr_bindings_no_with prc prlc = function + | ImplicitBindings l -> + brk (0,1) ++ + prlist_with_sep spc prc l + | ExplicitBindings l -> + brk (0,1) ++ + prlist_with_sep spc (fun b -> str"(" ++ pr_binding prlc b ++ str")") l + | NoBindings -> mt () + + let pr_clear_flag clear_flag pp x = + match clear_flag with + | Some false -> surround (pp x) + | Some true -> str ">" ++ pp x + | None -> pp x + + let pr_with_bindings prc prlc (c,bl) = + prc c ++ pr_bindings prc prlc bl + + let pr_with_bindings_arg prc prlc (clear_flag,c) = + pr_clear_flag clear_flag (pr_with_bindings prc prlc) c + + let pr_with_constr prc = function + | None -> mt () + | Some c -> spc () ++ hov 1 (keyword "with" ++ spc () ++ prc c) + + let pr_message_token prid = function + | MsgString s -> tag_string (qs s) + | MsgInt n -> int n + | MsgIdent id -> prid id + + let pr_fresh_ids = + prlist (fun s -> spc() ++ pr_or_var (fun s -> tag_string (qs s)) s) + + let with_evars ev s = if ev then "e" ^ s else s + + let rec tacarg_using_rule_token pr_gen = function + | [] -> [] + | TacTerm s :: l -> keyword s :: tacarg_using_rule_token pr_gen l + | TacNonTerm (_, (symb, arg), _) :: l -> + pr_gen symb arg :: tacarg_using_rule_token pr_gen l + + let pr_tacarg_using_rule pr_gen l = + let l = match l with + | TacTerm s :: l -> + (** First terminal token should be considered as the name of the tactic, + so we tag it differently than the other terminal tokens. *) + primitive s :: tacarg_using_rule_token pr_gen l + | _ -> tacarg_using_rule_token pr_gen l + in + pr_sequence (fun x -> x) l + + let pr_extend_gen pr_gen lev { mltac_name = s; mltac_index = i } l = + let name = + str s.mltac_plugin ++ str "::" ++ str s.mltac_tactic ++ + str "@" ++ int i + in + let args = match l with + | [] -> mt () + | _ -> spc() ++ pr_sequence pr_gen l + in + str "<" ++ name ++ str ">" ++ args + + let rec pr_user_symbol = function + | Extend.Ulist1 tkn -> "ne_" ^ pr_user_symbol tkn ^ "_list" + | Extend.Ulist1sep (tkn, _) -> "ne_" ^ pr_user_symbol tkn ^ "_list" + | Extend.Ulist0 tkn -> pr_user_symbol tkn ^ "_list" + | Extend.Ulist0sep (tkn, _) -> pr_user_symbol tkn ^ "_list" + | Extend.Uopt tkn -> pr_user_symbol tkn ^ "_opt" + | Extend.Uentry tag -> + let ArgT.Any tag = tag in + ArgT.repr tag + | Extend.Uentryl (tkn, lvl) -> "tactic" ^ string_of_int lvl + + let pr_alias_key key = + try + let prods = (KNmap.find key !prnotation_tab).pptac_prods in + let rec pr = function + | TacTerm s -> primitive s + | TacNonTerm (_, symb, _) -> str (Printf.sprintf "(%s)" (pr_user_symbol symb)) + in + pr_sequence pr prods + with Not_found -> + KerName.print key + + let pr_alias_gen pr_gen lev key l = + try + let pp = KNmap.find key !prnotation_tab in + let rec pack prods args = match prods, args with + | [], [] -> [] + | TacTerm s :: prods, args -> TacTerm s :: pack prods args + | TacNonTerm (loc, symb, id) :: prods, arg :: args -> + TacNonTerm (loc, (symb, arg), id) :: pack prods args + | _ -> raise Not_found + in + let prods = pack pp.pptac_prods l in + let p = pr_tacarg_using_rule pr_gen prods in + if pp.pptac_level > lev then surround p else p + with Not_found -> + let pr arg = str "_" in + KerName.print key ++ spc() ++ pr_sequence pr l ++ str" (* Generic printer *)" + + let pr_farg prtac arg = prtac (1, Any) (TacArg (Loc.ghost, arg)) + + let is_genarg tag wit = + let ArgT.Any tag = tag in + argument_type_eq (ArgumentType (ExtraArg tag)) wit + + let get_list : type l. l generic_argument -> l generic_argument list option = + function (GenArg (wit, arg)) -> match wit with + | Rawwit (ListArg wit) -> Some (List.map (in_gen (rawwit wit)) arg) + | Glbwit (ListArg wit) -> Some (List.map (in_gen (glbwit wit)) arg) + | _ -> None + + let get_opt : type l. l generic_argument -> l generic_argument option option = + function (GenArg (wit, arg)) -> match wit with + | Rawwit (OptArg wit) -> Some (Option.map (in_gen (rawwit wit)) arg) + | Glbwit (OptArg wit) -> Some (Option.map (in_gen (glbwit wit)) arg) + | _ -> None + + let rec pr_any_arg : type l. (_ -> l generic_argument -> std_ppcmds) -> _ -> l generic_argument -> std_ppcmds = + fun prtac symb arg -> match symb with + | Extend.Uentry tag when is_genarg tag (genarg_tag arg) -> prtac (1, Any) arg + | Extend.Ulist1 s | Extend.Ulist0 s -> + begin match get_list arg with + | None -> str "ltac:(" ++ prtac (1, Any) arg ++ str ")" + | Some l -> pr_sequence (pr_any_arg prtac s) l + end + | Extend.Ulist1sep (s, sep) | Extend.Ulist0sep (s, sep) -> + begin match get_list arg with + | None -> str "ltac:(" ++ prtac (1, Any) arg ++ str ")" + | Some l -> prlist_with_sep (fun () -> str sep) (pr_any_arg prtac s) l + end + | Extend.Uopt s -> + begin match get_opt arg with + | None -> str "ltac:(" ++ prtac (1, Any) arg ++ str ")" + | Some l -> pr_opt (pr_any_arg prtac s) l + end + | Extend.Uentry _ | Extend.Uentryl _ -> + str "ltac:(" ++ prtac (1, Any) arg ++ str ")" + + let rec pr_targ prtac symb arg = match symb with + | Extend.Uentry tag when is_genarg tag (ArgumentType wit_tactic) -> + prtac (1, Any) arg + | Extend.Uentryl (_, l) -> prtac (l, Any) arg + | _ -> + match arg with + | TacGeneric arg -> + let pr l arg = prtac l (TacGeneric arg) in + pr_any_arg pr symb arg + | _ -> str "ltac:(" ++ prtac (1, Any) arg ++ str ")" + + let pr_raw_extend_rec prc prlc prtac prpat = + pr_extend_gen (pr_farg prtac) + let pr_glob_extend_rec prc prlc prtac prpat = + pr_extend_gen (pr_farg prtac) + + let pr_raw_alias prc prlc prtac prpat lev key args = + pr_alias_gen (pr_targ (fun l a -> prtac l (TacArg (Loc.ghost, a)))) lev key args + let pr_glob_alias prc prlc prtac prpat lev key args = + pr_alias_gen (pr_targ (fun l a -> prtac l (TacArg (Loc.ghost, a)))) lev key args + + (**********************************************************************) + (* The tactic printer *) + + let strip_prod_binders_expr n ty = + let rec strip_ty acc n ty = + match ty with + Constrexpr.CProdN(_,bll,a) -> + let nb = + List.fold_left (fun i (nal,_,_) -> i + List.length nal) 0 bll in + let bll = List.map (fun (x, _, y) -> x, y) bll in + if nb >= n then (List.rev (bll@acc)), a + else strip_ty (bll@acc) (n-nb) a + | _ -> error "Cannot translate fix tactic: not enough products" in + strip_ty [] n ty + + let pr_ltac_or_var pr = function + | ArgArg x -> pr x + | ArgVar (loc,id) -> pr_with_comments loc (pr_id id) + + let pr_ltac_constant kn = + if !Flags.in_debugger then pr_kn kn + else try + pr_qualid (Nametab.shortest_qualid_of_tactic kn) + with Not_found -> (* local tactic not accessible anymore *) + str "<" ++ pr_kn kn ++ str ">" + + let pr_evaluable_reference_env env = function + | EvalVarRef id -> pr_id id + | EvalConstRef sp -> + Nametab.pr_global_env (Termops.vars_of_env env) (Globnames.ConstRef sp) + + let pr_esubst prc l = + let pr_qhyp = function + (_,AnonHyp n,c) -> str "(" ++ int n ++ str" := " ++ prc c ++ str ")" + | (_,NamedHyp id,c) -> + str "(" ++ pr_id id ++ str" := " ++ prc c ++ str ")" + in + prlist_with_sep spc pr_qhyp l + + let pr_bindings_gen for_ex prc prlc = function + | ImplicitBindings l -> + spc () ++ + hv 2 ((if for_ex then mt() else keyword "with" ++ spc ()) ++ + prlist_with_sep spc prc l) + | ExplicitBindings l -> + spc () ++ + hv 2 ((if for_ex then mt() else keyword "with" ++ spc ()) ++ + pr_esubst prlc l) + | NoBindings -> mt () + + let pr_bindings prc prlc = pr_bindings_gen false prc prlc + + let pr_with_bindings prc prlc (c,bl) = + hov 1 (prc c ++ pr_bindings prc prlc bl) + + let pr_as_disjunctive_ipat prc ipatl = + keyword "as" ++ spc () ++ + pr_or_var (fun (loc,p) -> Miscprint.pr_or_and_intro_pattern prc p) ipatl + + let pr_eqn_ipat (_,ipat) = keyword "eqn:" ++ Miscprint.pr_intro_pattern_naming ipat + + let pr_with_induction_names prc = function + | None, None -> mt () + | Some eqpat, None -> hov 1 (pr_eqn_ipat eqpat) + | None, Some ipat -> hov 1 (pr_as_disjunctive_ipat prc ipat) + | Some eqpat, Some ipat -> + hov 1 (pr_as_disjunctive_ipat prc ipat ++ spc () ++ pr_eqn_ipat eqpat) + + let pr_as_intro_pattern prc ipat = + spc () ++ hov 1 (keyword "as" ++ spc () ++ Miscprint.pr_intro_pattern prc ipat) + + let pr_with_inversion_names prc = function + | None -> mt () + | Some ipat -> pr_as_disjunctive_ipat prc ipat + + let pr_as_ipat prc = function + | None -> mt () + | Some ipat -> pr_as_intro_pattern prc ipat + + let pr_as_name = function + | Anonymous -> mt () + | Name id -> spc () ++ keyword "as" ++ spc () ++ pr_lident (Loc.ghost,id) + + let pr_pose_as_style prc na c = + spc() ++ prc c ++ pr_as_name na + + let pr_pose prc prlc na c = match na with + | Anonymous -> spc() ++ prc c + | Name id -> spc() ++ surround (pr_id id ++ str " :=" ++ spc() ++ prlc c) + + let pr_assertion prc prdc _prlc ipat c = match ipat with + (* Use this "optimisation" or use only the general case ? + | IntroIdentifier id -> + spc() ++ surround (pr_intro_pattern ipat ++ str " :" ++ spc() ++ prlc c) + *) + | ipat -> + spc() ++ prc c ++ pr_as_ipat prdc ipat + + let pr_assumption prc prdc prlc ipat c = match ipat with + (* Use this "optimisation" or use only the general case ?*) + (* it seems that this "optimisation" is somehow more natural *) + | Some (_,IntroNaming (IntroIdentifier id)) -> + spc() ++ surround (pr_id id ++ str " :" ++ spc() ++ prlc c) + | ipat -> + spc() ++ prc c ++ pr_as_ipat prdc ipat + + let pr_by_tactic prt = function + | Some tac -> keyword "by" ++ spc () ++ prt tac + | None -> mt() + + let pr_hyp_location pr_id = function + | occs, InHyp -> pr_with_occurrences pr_id occs + | occs, InHypTypeOnly -> + pr_with_occurrences (fun id -> + str "(" ++ keyword "type of" ++ spc () ++ pr_id id ++ str ")" + ) occs + | occs, InHypValueOnly -> + pr_with_occurrences (fun id -> + str "(" ++ keyword "value of" ++ spc () ++ pr_id id ++ str ")" + ) occs + + let pr_in pp = hov 0 (keyword "in" ++ pp) + + let pr_simple_hyp_clause pr_id = function + | [] -> mt () + | l -> pr_in (spc () ++ prlist_with_sep spc pr_id l) + + let pr_in_hyp_as prc pr_id = function + | None -> mt () + | Some (id,ipat) -> pr_in (spc () ++ pr_id id) ++ pr_as_ipat prc ipat + + let pr_in_clause pr_id = function + | { onhyps=None; concl_occs=NoOccurrences } -> + (str "* |-") + | { onhyps=None; concl_occs=occs } -> + (pr_with_occurrences (fun () -> str "*") (occs,())) + | { onhyps=Some l; concl_occs=NoOccurrences } -> + prlist_with_sep (fun () -> str ", ") (pr_hyp_location pr_id) l + | { onhyps=Some l; concl_occs=occs } -> + let pr_occs = pr_with_occurrences (fun () -> str" |- *") (occs,()) in + (prlist_with_sep (fun () -> str", ") (pr_hyp_location pr_id) l ++ pr_occs) + + let pr_clauses default_is_concl pr_id = function + | { onhyps=Some []; concl_occs=occs } + when (match default_is_concl with Some true -> true | _ -> false) -> + pr_with_occurrences mt (occs,()) + | { onhyps=None; concl_occs=AllOccurrences } + when (match default_is_concl with Some false -> true | _ -> false) -> mt () + | { onhyps=None; concl_occs=NoOccurrences } -> + pr_in (str " * |-") + | { onhyps=None; concl_occs=occs } -> + pr_in (pr_with_occurrences (fun () -> str " *") (occs,())) + | { onhyps=Some l; concl_occs=occs } -> + let pr_occs = match occs with + | NoOccurrences -> mt () + | _ -> pr_with_occurrences (fun () -> str" |- *") (occs,()) + in + pr_in + (prlist_with_sep (fun () -> str",") + (fun id -> spc () ++ pr_hyp_location pr_id id) l ++ pr_occs) + + let pr_orient b = if b then mt () else str "<- " + + let pr_multi = function + | Precisely 1 -> mt () + | Precisely n -> int n ++ str "!" + | UpTo n -> int n ++ str "?" + | RepeatStar -> str "?" + | RepeatPlus -> str "!" + + let pr_core_destruction_arg prc prlc = function + | ElimOnConstr c -> pr_with_bindings prc prlc c + | ElimOnIdent (loc,id) -> pr_with_comments loc (pr_id id) + | ElimOnAnonHyp n -> int n + + let pr_destruction_arg prc prlc (clear_flag,h) = + pr_clear_flag clear_flag (pr_core_destruction_arg prc prlc) h + + let pr_inversion_kind = function + | SimpleInversion -> primitive "simple inversion" + | FullInversion -> primitive "inversion" + | FullInversionClear -> primitive "inversion_clear" + + let pr_range_selector (i, j) = + if Int.equal i j then int i + else int i ++ str "-" ++ int j + + let pr_goal_selector = function + | SelectNth i -> int i ++ str ":" + | SelectList l -> str "[" ++ prlist_with_sep (fun () -> str ", ") pr_range_selector l ++ + str "]" ++ str ":" + | SelectId id -> str "[" ++ Nameops.pr_id id ++ str "]" ++ str ":" + | SelectAll -> str "all" ++ str ":" + + let pr_lazy = function + | General -> keyword "multi" + | Select -> keyword "lazy" + | Once -> mt () + + let pr_match_pattern pr_pat = function + | Term a -> pr_pat a + | Subterm (b,None,a) -> + (** ppedrot: we don't make difference between [appcontext] and [context] + anymore, and the interpretation is governed by a flag instead. *) + keyword "context" ++ str" [ " ++ pr_pat a ++ str " ]" + | Subterm (b,Some id,a) -> + keyword "context" ++ spc () ++ pr_id id ++ str "[ " ++ pr_pat a ++ str " ]" + + let pr_match_hyps pr_pat = function + | Hyp (nal,mp) -> + pr_lname nal ++ str ":" ++ pr_match_pattern pr_pat mp + | Def (nal,mv,mp) -> + pr_lname nal ++ str ":=" ++ pr_match_pattern pr_pat mv + ++ str ":" ++ pr_match_pattern pr_pat mp + + let pr_match_rule m pr pr_pat = function + | Pat ([],mp,t) when m -> + pr_match_pattern pr_pat mp ++ + spc () ++ str "=>" ++ brk (1,4) ++ pr t + (* + | Pat (rl,mp,t) -> + hv 0 (prlist_with_sep pr_comma (pr_match_hyps pr_pat) rl ++ + (if rl <> [] then spc () else mt ()) ++ + hov 0 (str "|-" ++ spc () ++ pr_match_pattern pr_pat mp ++ spc () ++ + str "=>" ++ brk (1,4) ++ pr t)) + *) + | Pat (rl,mp,t) -> + hov 0 ( + hv 0 (prlist_with_sep pr_comma (pr_match_hyps pr_pat) rl) ++ + (if not (List.is_empty rl) then spc () else mt ()) ++ + hov 0 ( + str "|-" ++ spc () ++ pr_match_pattern pr_pat mp ++ spc () ++ + str "=>" ++ brk (1,4) ++ pr t)) + | All t -> str "_" ++ spc () ++ str "=>" ++ brk (1,4) ++ pr t + + let pr_funvar n = spc () ++ pr_name n + + let pr_let_clause k pr (id,(bl,t)) = + hov 0 (keyword k ++ spc () ++ pr_lident id ++ prlist pr_funvar bl ++ + str " :=" ++ brk (1,1) ++ pr (TacArg (Loc.ghost,t))) + + let pr_let_clauses recflag pr = function + | hd::tl -> + hv 0 + (pr_let_clause (if recflag then "let rec" else "let") pr hd ++ + prlist (fun t -> spc () ++ pr_let_clause "with" pr t) tl) + | [] -> anomaly (Pp.str "LetIn must declare at least one binding") + + let pr_seq_body pr tl = + hv 0 (str "[ " ++ + prlist_with_sep (fun () -> spc () ++ str "| ") pr tl ++ + str " ]") + + let pr_dispatch pr tl = + hv 0 (str "[>" ++ + prlist_with_sep (fun () -> spc () ++ str "| ") pr tl ++ + str " ]") + + let pr_opt_tactic pr = function + | TacId [] -> mt () + | t -> pr t + + let pr_tac_extend_gen pr tf tm tl = + prvect_with_sep mt (fun t -> pr t ++ spc () ++ str "| ") tf ++ + pr_opt_tactic pr tm ++ str ".." ++ + prvect_with_sep mt (fun t -> spc () ++ str "| " ++ pr t) tl + + let pr_then_gen pr tf tm tl = + hv 0 (str "[ " ++ + pr_tac_extend_gen pr tf tm tl ++ + str " ]") + + let pr_tac_extend pr tf tm tl = + hv 0 (str "[>" ++ + pr_tac_extend_gen pr tf tm tl ++ + str " ]") + + let pr_hintbases = function + | None -> keyword "with" ++ str" *" + | Some [] -> mt () + | Some l -> hov 2 (keyword "with" ++ prlist (fun s -> spc () ++ str s) l) + + let pr_auto_using prc = function + | [] -> mt () + | l -> hov 2 (keyword "using" ++ spc () ++ prlist_with_sep pr_comma prc l) + + let pr_then () = str ";" + + let ltop = (5,E) + let lseq = 4 + let ltactical = 3 + let lorelse = 2 + let llet = 5 + let lfun = 5 + let lcomplete = 1 + let labstract = 3 + let lmatch = 1 + let latom = 0 + let lcall = 1 + let leval = 1 + let ltatom = 1 + let linfo = 5 + + let level_of (n,p) = match p with E -> n | L -> n-1 | Prec n -> n | Any -> lseq + + (** A printer for tactics that polymorphically works on the three + "raw", "glob" and "typed" levels *) + + type 'a printer = { + pr_tactic : tolerability -> 'tacexpr -> std_ppcmds; + pr_constr : 'trm -> std_ppcmds; + pr_lconstr : 'trm -> std_ppcmds; + pr_dconstr : 'dtrm -> std_ppcmds; + pr_pattern : 'pat -> std_ppcmds; + pr_lpattern : 'pat -> std_ppcmds; + pr_constant : 'cst -> std_ppcmds; + pr_reference : 'ref -> std_ppcmds; + pr_name : 'nam -> std_ppcmds; + pr_generic : 'lev generic_argument -> std_ppcmds; + pr_extend : int -> ml_tactic_entry -> 'a gen_tactic_arg list -> std_ppcmds; + pr_alias : int -> KerName.t -> 'a gen_tactic_arg list -> std_ppcmds; + } + + constraint 'a = < + term :'trm; + dterm :'dtrm; + pattern :'pat; + constant :'cst; + reference :'ref; + name :'nam; + tacexpr :'tacexpr; + level :'lev + > + + let pr_atom pr strip_prod_binders tag_atom = + let pr_with_bindings = pr_with_bindings pr.pr_constr pr.pr_lconstr in + let pr_with_bindings_arg_full = pr_with_bindings_arg in + let pr_with_bindings_arg = pr_with_bindings_arg pr.pr_constr pr.pr_lconstr in + let pr_red_expr = pr_red_expr (pr.pr_constr,pr.pr_lconstr,pr.pr_constant,pr.pr_pattern) in + + let _pr_constrarg c = spc () ++ pr.pr_constr c in + let pr_lconstrarg c = spc () ++ pr.pr_lconstr c in + let pr_intarg n = spc () ++ int n in + + (* Some printing combinators *) + let pr_eliminator cb = keyword "using" ++ pr_arg pr_with_bindings cb in + + let pr_binder_fix (nal,t) = + (* match t with + | CHole _ -> spc() ++ prlist_with_sep spc (pr_lname) nal + | _ ->*) + let s = prlist_with_sep spc pr_lname nal ++ str ":" ++ pr.pr_lconstr t in + spc() ++ hov 1 (str"(" ++ s ++ str")") in + + let pr_fix_tac (id,n,c) = + let rec set_nth_name avoid n = function + (nal,ty)::bll -> + if n <= List.length nal then + match List.chop (n-1) nal with + _, (_,Name id) :: _ -> id, (nal,ty)::bll + | bef, (loc,Anonymous) :: aft -> + let id = next_ident_away (Id.of_string"y") avoid in + id, ((bef@(loc,Name id)::aft, ty)::bll) + | _ -> assert false + else + let (id,bll') = set_nth_name avoid (n-List.length nal) bll in + (id,(nal,ty)::bll') + | [] -> assert false in + let (bll,ty) = strip_prod_binders n c in + let names = + List.fold_left + (fun ln (nal,_) -> List.fold_left + (fun ln na -> match na with (_,Name id) -> id::ln | _ -> ln) + ln nal) + [] bll in + let idarg,bll = set_nth_name names n bll in + let annot = match names with + | [_] -> + mt () + | _ -> + spc() ++ str"{" + ++ keyword "struct" ++ spc () + ++ pr_id idarg ++ str"}" + in + hov 1 (str"(" ++ pr_id id ++ + prlist pr_binder_fix bll ++ annot ++ str" :" ++ + pr_lconstrarg ty ++ str")") in + (* spc() ++ + hov 0 (pr_id id ++ pr_intarg n ++ str":" ++ _pr_constrarg + c) + *) + let pr_cofix_tac (id,c) = + hov 1 (str"(" ++ pr_id id ++ str" :" ++ pr_lconstrarg c ++ str")") in + + (* Printing tactics as arguments *) + let rec pr_atom0 a = tag_atom a (match a with + | TacIntroPattern (false,[]) -> primitive "intros" + | TacIntroPattern (true,[]) -> primitive "eintros" + | t -> str "(" ++ pr_atom1 t ++ str ")" + ) + + (* Main tactic printer *) + and pr_atom1 a = tag_atom a (match a with + (* Basic tactics *) + | TacIntroPattern (ev,[]) as t -> + pr_atom0 t + | TacIntroPattern (ev,(_::_ as p)) -> + hov 1 (primitive (if ev then "eintros" else "intros") ++ spc () ++ + prlist_with_sep spc (Miscprint.pr_intro_pattern pr.pr_dconstr) p) + | TacApply (a,ev,cb,inhyp) -> + hov 1 ( + (if a then mt() else primitive "simple ") ++ + primitive (with_evars ev "apply") ++ spc () ++ + prlist_with_sep pr_comma pr_with_bindings_arg cb ++ + pr_non_empty_arg (pr_in_hyp_as pr.pr_dconstr pr.pr_name) inhyp + ) + | TacElim (ev,cb,cbo) -> + hov 1 ( + primitive (with_evars ev "elim") + ++ pr_arg pr_with_bindings_arg cb + ++ pr_opt pr_eliminator cbo) + | TacCase (ev,cb) -> + hov 1 (primitive (with_evars ev "case") ++ spc () ++ pr_with_bindings_arg cb) + | TacMutualFix (id,n,l) -> + hov 1 ( + primitive "fix" ++ spc () ++ pr_id id ++ pr_intarg n ++ spc() + ++ keyword "with" ++ spc () ++ prlist_with_sep spc pr_fix_tac l) + | TacMutualCofix (id,l) -> + hov 1 ( + primitive "cofix" ++ spc () ++ pr_id id ++ spc() + ++ keyword "with" ++ spc () ++ prlist_with_sep spc pr_cofix_tac l + ) + | TacAssert (b,Some tac,ipat,c) -> + hov 1 ( + primitive (if b then "assert" else "enough") ++ + pr_assumption pr.pr_constr pr.pr_dconstr pr.pr_lconstr ipat c ++ + pr_non_empty_arg (pr_by_tactic (pr.pr_tactic (ltactical,E))) tac + ) + | TacAssert (_,None,ipat,c) -> + hov 1 ( + primitive "pose proof" + ++ pr_assertion pr.pr_constr pr.pr_dconstr pr.pr_lconstr ipat c + ) + | TacGeneralize l -> + hov 1 ( + primitive "generalize" ++ spc () + ++ prlist_with_sep pr_comma (fun (cl,na) -> + pr_with_occurrences pr.pr_constr cl ++ pr_as_name na) + l + ) + | TacLetTac (na,c,cl,true,_) when Locusops.is_nowhere cl -> + hov 1 (primitive "pose" ++ pr_pose pr.pr_constr pr.pr_lconstr na c) + | TacLetTac (na,c,cl,b,e) -> + hov 1 ( + (if b then primitive "set" else primitive "remember") ++ + (if b then pr_pose pr.pr_constr pr.pr_lconstr na c + else pr_pose_as_style pr.pr_constr na c) ++ + pr_opt (fun p -> pr_eqn_ipat p ++ spc ()) e ++ + pr_non_empty_arg (pr_clauses (Some b) pr.pr_name) cl) + (* | TacInstantiate (n,c,ConclLocation ()) -> + hov 1 (str "instantiate" ++ spc() ++ + hov 1 (str"(" ++ pr_arg int n ++ str" :=" ++ + pr_lconstrarg c ++ str ")" )) + | TacInstantiate (n,c,HypLocation (id,hloc)) -> + hov 1 (str "instantiate" ++ spc() ++ + hov 1 (str"(" ++ pr_arg int n ++ str" :=" ++ + pr_lconstrarg c ++ str ")" ) + ++ str "in" ++ pr_hyp_location pr.pr_name (id,[],(hloc,ref None))) + *) + + (* Derived basic tactics *) + | TacInductionDestruct (isrec,ev,(l,el)) -> + hov 1 ( + primitive (with_evars ev (if isrec then "induction" else "destruct")) + ++ spc () + ++ prlist_with_sep pr_comma (fun (h,ids,cl) -> + pr_destruction_arg pr.pr_dconstr pr.pr_dconstr h ++ + pr_non_empty_arg (pr_with_induction_names pr.pr_dconstr) ids ++ + pr_opt (pr_clauses None pr.pr_name) cl) l ++ + pr_opt pr_eliminator el + ) + + (* Conversion *) + | TacReduce (r,h) -> + hov 1 ( + pr_red_expr r + ++ pr_non_empty_arg (pr_clauses (Some true) pr.pr_name) h + ) + | TacChange (op,c,h) -> + hov 1 ( + primitive "change" ++ brk (1,1) + ++ ( + match op with + None -> + mt () + | Some p -> + pr.pr_pattern p ++ spc () + ++ keyword "with" ++ spc () + ) ++ pr.pr_dconstr c ++ pr_non_empty_arg (pr_clauses (Some true) pr.pr_name) h + ) + + (* Equality and inversion *) + | TacRewrite (ev,l,cl,tac) -> + hov 1 ( + primitive (with_evars ev "rewrite") ++ spc () + ++ prlist_with_sep + (fun () -> str ","++spc()) + (fun (b,m,c) -> + pr_orient b ++ pr_multi m ++ + pr_with_bindings_arg_full pr.pr_dconstr pr.pr_dconstr c) + l + ++ pr_non_empty_arg (pr_clauses (Some true) pr.pr_name) cl + ++ pr_non_empty_arg (pr_by_tactic (pr.pr_tactic (ltactical,E))) tac + ) + | TacInversion (DepInversion (k,c,ids),hyp) -> + hov 1 ( + primitive "dependent " ++ pr_inversion_kind k ++ spc () + ++ pr_quantified_hypothesis hyp + ++ pr_with_inversion_names pr.pr_dconstr ids + ++ pr_with_constr pr.pr_constr c + ) + | TacInversion (NonDepInversion (k,cl,ids),hyp) -> + hov 1 ( + pr_inversion_kind k ++ spc () + ++ pr_quantified_hypothesis hyp + ++ pr_non_empty_arg (pr_with_inversion_names pr.pr_dconstr) ids + ++ pr_non_empty_arg (pr_simple_hyp_clause pr.pr_name) cl + ) + | TacInversion (InversionUsing (c,cl),hyp) -> + hov 1 ( + primitive "inversion" ++ spc() + ++ pr_quantified_hypothesis hyp ++ spc () + ++ keyword "using" ++ spc () ++ pr.pr_constr c + ++ pr_non_empty_arg (pr_simple_hyp_clause pr.pr_name) cl + ) + ) + in + pr_atom1 + + let make_pr_tac pr strip_prod_binders tag_atom tag = + + let extract_binders = function + | Tacexp (TacFun (lvar,body)) -> (lvar,Tacexp body) + | body -> ([],body) in + let rec pr_tac inherited tac = + let return (doc, l) = (tag tac doc, l) in + let (strm, prec) = return (match tac with + | TacAbstract (t,None) -> + keyword "abstract " ++ pr_tac (labstract,L) t, labstract + | TacAbstract (t,Some s) -> + hov 0 ( + keyword "abstract" + ++ str" (" ++ pr_tac (labstract,L) t ++ str")" ++ spc () + ++ keyword "using" ++ spc () ++ pr_id s), + labstract + | TacLetIn (recflag,llc,u) -> + let llc = List.map (fun (id,t) -> (id,extract_binders t)) llc in + v 0 + (hv 0 ( + pr_let_clauses recflag (pr_tac ltop) llc + ++ spc () ++ keyword "in" + ) ++ fnl () ++ pr_tac (llet,E) u), + llet + | TacMatch (lz,t,lrul) -> + hov 0 ( + pr_lazy lz ++ keyword "match" ++ spc () + ++ pr_tac ltop t ++ spc () ++ keyword "with" + ++ prlist (fun r -> + fnl () ++ str "| " + ++ pr_match_rule true (pr_tac ltop) pr.pr_lpattern r + ) lrul + ++ fnl() ++ keyword "end"), + lmatch + | TacMatchGoal (lz,lr,lrul) -> + hov 0 ( + pr_lazy lz + ++ keyword (if lr then "match reverse goal with" else "match goal with") + ++ prlist (fun r -> + fnl () ++ str "| " + ++ pr_match_rule false (pr_tac ltop) pr.pr_lpattern r + ) lrul ++ fnl() ++ keyword "end"), + lmatch + | TacFun (lvar,body) -> + hov 2 ( + keyword "fun" + ++ prlist pr_funvar lvar ++ str " =>" ++ spc () + ++ pr_tac (lfun,E) body), + lfun + | TacThens (t,tl) -> + hov 1 ( + pr_tac (lseq,E) t ++ pr_then () ++ spc () + ++ pr_seq_body (pr_opt_tactic (pr_tac ltop)) tl), + lseq + | TacThen (t1,t2) -> + hov 1 ( + pr_tac (lseq,E) t1 ++ pr_then () ++ spc () + ++ pr_tac (lseq,L) t2), + lseq + | TacDispatch tl -> + pr_dispatch (pr_tac ltop) tl, lseq + | TacExtendTac (tf,t,tr) -> + pr_tac_extend (pr_tac ltop) tf t tr , lseq + | TacThens3parts (t1,tf,t2,tl) -> + hov 1 ( + pr_tac (lseq,E) t1 ++ pr_then () ++ spc () + ++ pr_then_gen (pr_tac ltop) tf t2 tl), + lseq + | TacTry t -> + hov 1 ( + keyword "try" ++ spc () ++ pr_tac (ltactical,E) t), + ltactical + | TacDo (n,t) -> + hov 1 ( + str "do" ++ spc () + ++ pr_or_var int n ++ spc () + ++ pr_tac (ltactical,E) t), + ltactical + | TacTimeout (n,t) -> + hov 1 ( + keyword "timeout " + ++ pr_or_var int n ++ spc () + ++ pr_tac (ltactical,E) t), + ltactical + | TacTime (s,t) -> + hov 1 ( + keyword "time" + ++ pr_opt str s ++ spc () + ++ pr_tac (ltactical,E) t), + ltactical + | TacRepeat t -> + hov 1 ( + keyword "repeat" ++ spc () + ++ pr_tac (ltactical,E) t), + ltactical + | TacProgress t -> + hov 1 ( + keyword "progress" ++ spc () + ++ pr_tac (ltactical,E) t), + ltactical + | TacShowHyps t -> + hov 1 ( + keyword "infoH" ++ spc () + ++ pr_tac (ltactical,E) t), + ltactical + | TacInfo t -> + hov 1 ( + keyword "info" ++ spc () + ++ pr_tac (ltactical,E) t), + linfo + | TacOr (t1,t2) -> + hov 1 ( + pr_tac (lorelse,L) t1 ++ spc () + ++ str "+" ++ brk (1,1) + ++ pr_tac (lorelse,E) t2), + lorelse + | TacOnce t -> + hov 1 ( + keyword "once" ++ spc () + ++ pr_tac (ltactical,E) t), + ltactical + | TacExactlyOnce t -> + hov 1 ( + keyword "exactly_once" ++ spc () + ++ pr_tac (ltactical,E) t), + ltactical + | TacIfThenCatch (t,tt,te) -> + hov 1 ( + str"tryif" ++ spc() ++ pr_tac (ltactical,E) t ++ brk(1,1) ++ + str"then" ++ spc() ++ pr_tac (ltactical,E) tt ++ brk(1,1) ++ + str"else" ++ spc() ++ pr_tac (ltactical,E) te ++ brk(1,1)), + ltactical + | TacOrelse (t1,t2) -> + hov 1 ( + pr_tac (lorelse,L) t1 ++ spc () + ++ str "||" ++ brk (1,1) + ++ pr_tac (lorelse,E) t2), + lorelse + | TacFail (g,n,l) -> + let arg = + match n with + | ArgArg 0 -> mt () + | _ -> pr_arg (pr_or_var int) n + in + let name = + match g with + | TacGlobal -> keyword "gfail" + | TacLocal -> keyword "fail" + in + hov 1 ( + name ++ arg + ++ prlist (pr_arg (pr_message_token pr.pr_name)) l), + latom + | TacFirst tl -> + keyword "first" ++ spc () ++ pr_seq_body (pr_tac ltop) tl, llet + | TacSolve tl -> + keyword "solve" ++ spc () ++ pr_seq_body (pr_tac ltop) tl, llet + | TacComplete t -> + pr_tac (lcomplete,E) t, lcomplete + | TacSelect (s, tac) -> pr_goal_selector s ++ spc () ++ pr_tac ltop tac, latom + | TacId l -> + keyword "idtac" ++ prlist (pr_arg (pr_message_token pr.pr_name)) l, latom + | TacAtom (loc,t) -> + pr_with_comments loc (hov 1 (pr_atom pr strip_prod_binders tag_atom t)), ltatom + | TacArg(_,Tacexp e) -> + pr.pr_tactic (latom,E) e, latom + | TacArg(_,ConstrMayEval (ConstrTerm c)) -> + keyword "constr:" ++ pr.pr_constr c, latom + | TacArg(_,ConstrMayEval c) -> + pr_may_eval pr.pr_constr pr.pr_lconstr pr.pr_constant pr.pr_pattern c, leval + | TacArg(_,TacFreshId l) -> + primitive "fresh" ++ pr_fresh_ids l, latom + | TacArg(_,TacGeneric arg) -> + pr.pr_generic arg, latom + | TacArg(_,TacCall(loc,f,[])) -> + pr.pr_reference f, latom + | TacArg(_,TacCall(loc,f,l)) -> + pr_with_comments loc (hov 1 ( + pr.pr_reference f ++ spc () + ++ prlist_with_sep spc pr_tacarg l)), + lcall + | TacArg (_,a) -> + pr_tacarg a, latom + | TacML (loc,s,l) -> + pr_with_comments loc (pr.pr_extend 1 s l), lcall + | TacAlias (loc,kn,l) -> + pr_with_comments loc (pr.pr_alias (level_of inherited) kn l), latom + ) + in + if prec_less prec inherited then strm + else str"(" ++ strm ++ str")" + + and pr_tacarg = function + | Reference r -> + pr.pr_reference r + | ConstrMayEval c -> + pr_may_eval pr.pr_constr pr.pr_lconstr pr.pr_constant pr.pr_pattern c + | TacFreshId l -> + keyword "fresh" ++ pr_fresh_ids l + | TacPretype c -> + keyword "type_term" ++ pr.pr_constr c + | TacNumgoals -> + keyword "numgoals" + | (TacCall _|Tacexp _ | TacGeneric _) as a -> + hov 0 (keyword "ltac:" ++ surround (pr_tac ltop (TacArg (Loc.ghost,a)))) + + in pr_tac + + let strip_prod_binders_glob_constr n (ty,_) = + let rec strip_ty acc n ty = + if Int.equal n 0 then (List.rev acc, (ty,None)) else + match ty with + Glob_term.GProd(loc,na,Explicit,a,b) -> + strip_ty (([Loc.ghost,na],(a,None))::acc) (n-1) b + | _ -> error "Cannot translate fix tactic: not enough products" in + strip_ty [] n ty + + let raw_printers = + (strip_prod_binders_expr) + + let rec pr_raw_tactic_level n (t:raw_tactic_expr) = + let pr = { + pr_tactic = pr_raw_tactic_level; + pr_constr = pr_constr_expr; + pr_dconstr = pr_constr_expr; + pr_lconstr = pr_lconstr_expr; + pr_pattern = pr_constr_pattern_expr; + pr_lpattern = pr_lconstr_pattern_expr; + pr_constant = pr_or_by_notation pr_reference; + pr_reference = pr_reference; + pr_name = pr_lident; + pr_generic = (fun arg -> Pputils.pr_raw_generic (Global.env ()) arg); + pr_extend = pr_raw_extend_rec pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr; + pr_alias = pr_raw_alias pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr; + } in + make_pr_tac + pr raw_printers + tag_raw_atomic_tactic_expr tag_raw_tactic_expr + n t + + let pr_raw_tactic = pr_raw_tactic_level ltop + + let pr_and_constr_expr pr (c,_) = pr c + + let pr_pat_and_constr_expr pr (_,(c,_),_) = pr c + + let pr_glob_tactic_level env n t = + let glob_printers = + (strip_prod_binders_glob_constr) + in + let rec prtac n (t:glob_tactic_expr) = + let pr = { + pr_tactic = prtac; + pr_constr = pr_and_constr_expr (pr_glob_constr_env env); + pr_dconstr = pr_and_constr_expr (pr_glob_constr_env env); + pr_lconstr = pr_and_constr_expr (pr_lglob_constr_env env); + pr_pattern = pr_pat_and_constr_expr (pr_glob_constr_env env); + pr_lpattern = pr_pat_and_constr_expr (pr_lglob_constr_env env); + pr_constant = pr_or_var (pr_and_short_name (pr_evaluable_reference_env env)); + pr_reference = pr_ltac_or_var (pr_located pr_ltac_constant); + pr_name = pr_lident; + pr_generic = (fun arg -> Pputils.pr_glb_generic (Global.env ()) arg); + pr_extend = pr_glob_extend_rec + (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) + prtac (pr_pat_and_constr_expr (pr_glob_constr_env env)); + pr_alias = pr_glob_alias + (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) + prtac (pr_pat_and_constr_expr (pr_glob_constr_env env)); + } in + make_pr_tac + pr glob_printers + tag_glob_atomic_tactic_expr tag_glob_tactic_expr + n t + in + prtac n t + + 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, EConstr.of_constr ty) else + match Term.kind_of_term ty with + Term.Prod(na,a,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 + + let pr_atomic_tactic_level env sigma n t = + let prtac n (t:atomic_tactic_expr) = + let pr = { + pr_tactic = (fun _ _ -> str "<tactic>"); + pr_constr = (fun c -> pr_econstr_env env sigma c); + pr_dconstr = pr_and_constr_expr (pr_glob_constr_env env); + pr_lconstr = (fun c -> pr_leconstr_env env sigma c); + pr_pattern = pr_constr_pattern_env env sigma; + pr_lpattern = pr_lconstr_pattern_env env sigma; + pr_constant = pr_evaluable_reference_env env; + pr_reference = pr_located pr_ltac_constant; + pr_name = pr_id; + (** Those are not used by the atomic printer *) + pr_generic = (fun _ -> assert false); + pr_extend = (fun _ _ _ -> assert false); + pr_alias = (fun _ _ _ -> assert false); + } + in + pr_atom pr strip_prod_binders_constr tag_atomic_tactic_expr t + in + prtac n t + + let pr_raw_generic = Pputils.pr_raw_generic + + let pr_glb_generic = Pputils.pr_glb_generic + + let pr_raw_extend env = pr_raw_extend_rec + pr_constr_expr pr_lconstr_expr pr_raw_tactic_level pr_constr_pattern_expr + + let pr_glob_extend env = pr_glob_extend_rec + (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) + (pr_glob_tactic_level env) (pr_pat_and_constr_expr (pr_glob_constr_env env)) + + let pr_alias pr lev key args = + pr_alias_gen (fun _ arg -> pr arg) lev key args + + let pr_extend pr lev ml args = + pr_extend_gen pr lev ml args + + let pr_atomic_tactic env sigma c = pr_atomic_tactic_level env sigma ltop c + +let declare_extra_genarg_pprule wit + (f : 'a raw_extra_genarg_printer) + (g : 'b glob_extra_genarg_printer) + (h : 'c extra_genarg_printer) = + begin match wit with + | ExtraArg s -> () + | _ -> error "Can declare a pretty-printing rule only for extra argument types." + end; + let f x = f pr_constr_expr pr_lconstr_expr pr_raw_tactic_level x in + let g x = + let env = Global.env () in + g (pr_and_constr_expr (pr_glob_constr_env env)) (pr_and_constr_expr (pr_lglob_constr_env env)) (pr_glob_tactic_level env) x + in + let h x = + let env = Global.env () in + h (pr_econstr_env env Evd.empty) (pr_leconstr_env env Evd.empty) (fun _ _ -> str "<tactic>") x + in + Genprint.register_print0 wit f g h + +(** Registering *) + +let run_delayed c = + Sigma.run Evd.empty { Sigma.run = fun sigma -> c.delayed (Global.env ()) sigma } + +let run_delayed_destruction_arg = function (* HH: Using Evd.empty looks suspicious *) + | clear_flag,ElimOnConstr g -> clear_flag,ElimOnConstr (fst (run_delayed g)) + | clear_flag,ElimOnAnonHyp n as x -> x + | clear_flag,ElimOnIdent id as x -> x + +let () = + let pr_bool b = if b then str "true" else str "false" in + let pr_unit _ = str "()" in + let pr_string s = str "\"" ++ str s ++ str "\"" in + Genprint.register_print0 wit_int_or_var + (pr_or_var int) (pr_or_var int) int; + Genprint.register_print0 wit_ref + pr_reference (pr_or_var (pr_located pr_global)) pr_global; + Genprint.register_print0 wit_ident + pr_id pr_id pr_id; + Genprint.register_print0 wit_var + (pr_located pr_id) (pr_located pr_id) pr_id; + Genprint.register_print0 + 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_econstr (fst (run_delayed c)))); + Genprint.register_print0 + wit_clause_dft_concl + (pr_clauses (Some true) pr_lident) + (pr_clauses (Some true) pr_lident) + (pr_clauses (Some true) (fun id -> pr_lident (Loc.ghost,id))) + ; + Genprint.register_print0 + wit_constr + Ppconstr.pr_constr_expr + (fun (c, _) -> Printer.pr_glob_constr c) + Printer.pr_econstr + ; + Genprint.register_print0 + wit_uconstr + Ppconstr.pr_constr_expr + (fun (c,_) -> Printer.pr_glob_constr c) + Printer.pr_closed_glob + ; + Genprint.register_print0 + wit_open_constr + Ppconstr.pr_constr_expr + (fun (c, _) -> Printer.pr_glob_constr c) + Printer.pr_econstr + ; + Genprint.register_print0 wit_red_expr + (pr_red_expr (pr_constr_expr, pr_lconstr_expr, pr_or_by_notation pr_reference, pr_constr_pattern_expr)) + (pr_red_expr (pr_and_constr_expr pr_glob_constr, pr_and_constr_expr pr_lglob_constr, pr_or_var (pr_and_short_name pr_evaluable_reference), pr_pat_and_constr_expr pr_glob_constr)) + (pr_red_expr (pr_econstr, pr_leconstr, pr_evaluable_reference, pr_constr_pattern)); + Genprint.register_print0 wit_quant_hyp pr_quantified_hypothesis pr_quantified_hypothesis pr_quantified_hypothesis; + 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_econstr pr_leconstr (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_econstr pr_leconstr (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_econstr pr_leconstr (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; + Genprint.register_print0 Stdarg.wit_pre_ident str str str; + Genprint.register_print0 Stdarg.wit_string pr_string pr_string pr_string + +let () = + let printer _ _ prtac = prtac (0, E) in + declare_extra_genarg_pprule wit_tactic printer printer printer + +let () = + let pr_unit _ _ _ () = str "()" in + let printer _ _ prtac = prtac (0, E) in + declare_extra_genarg_pprule wit_ltac printer printer pr_unit diff --git a/plugins/ltac/pptactic.mli b/plugins/ltac/pptactic.mli new file mode 100644 index 000000000..729338fb9 --- /dev/null +++ b/plugins/ltac/pptactic.mli @@ -0,0 +1,121 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** This module implements pretty-printers for tactic_expr syntactic + objects and their subcomponents. *) + +open Pp +open Genarg +open Geninterp +open Names +open Misctypes +open Environ +open Constrexpr +open Tacexpr +open Ppextend + +type 'a grammar_tactic_prod_item_expr = +| TacTerm of string +| TacNonTerm of Loc.t * 'a * Names.Id.t + +type 'a raw_extra_genarg_printer = + (constr_expr -> std_ppcmds) -> + (constr_expr -> std_ppcmds) -> + (tolerability -> raw_tactic_expr -> std_ppcmds) -> + 'a -> std_ppcmds + +type 'a glob_extra_genarg_printer = + (glob_constr_and_expr -> std_ppcmds) -> + (glob_constr_and_expr -> std_ppcmds) -> + (tolerability -> glob_tactic_expr -> std_ppcmds) -> + 'a -> std_ppcmds + +type 'a extra_genarg_printer = + (EConstr.t -> std_ppcmds) -> + (EConstr.t -> std_ppcmds) -> + (tolerability -> Val.t -> std_ppcmds) -> + 'a -> std_ppcmds + +val declare_extra_genarg_pprule : + ('a, 'b, 'c) genarg_type -> + 'a raw_extra_genarg_printer -> + 'b glob_extra_genarg_printer -> + 'c extra_genarg_printer -> unit + +type grammar_terminals = Genarg.ArgT.any Extend.user_symbol grammar_tactic_prod_item_expr list + +type pp_tactic = { + pptac_level : int; + pptac_prods : grammar_terminals; +} + +val declare_notation_tactic_pprule : KerName.t -> pp_tactic -> unit + +val pr_with_occurrences : + ('a -> std_ppcmds) -> 'a Locus.with_occurrences -> std_ppcmds +val pr_red_expr : + ('a -> std_ppcmds) * ('a -> std_ppcmds) * ('b -> std_ppcmds) * ('c -> std_ppcmds) -> + ('a,'b,'c) Genredexpr.red_expr_gen -> std_ppcmds +val pr_may_eval : + ('a -> std_ppcmds) -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) -> + ('c -> std_ppcmds) -> ('a,'b,'c) Genredexpr.may_eval -> std_ppcmds + +val pr_and_short_name : ('a -> std_ppcmds) -> 'a and_short_name -> std_ppcmds +val pr_or_by_notation : ('a -> std_ppcmds) -> 'a or_by_notation -> std_ppcmds + +val pr_in_clause : + ('a -> Pp.std_ppcmds) -> 'a Locus.clause_expr -> Pp.std_ppcmds + +val pr_clauses : bool option -> + ('a -> Pp.std_ppcmds) -> 'a Locus.clause_expr -> Pp.std_ppcmds + +val pr_raw_generic : env -> rlevel generic_argument -> std_ppcmds + +val pr_glb_generic : env -> glevel generic_argument -> std_ppcmds + +val pr_raw_extend: env -> int -> + ml_tactic_entry -> raw_tactic_arg list -> std_ppcmds + +val pr_glob_extend: env -> int -> + ml_tactic_entry -> glob_tactic_arg list -> std_ppcmds + +val pr_extend : + (Val.t -> std_ppcmds) -> int -> ml_tactic_entry -> Val.t list -> std_ppcmds + +val pr_alias_key : Names.KerName.t -> std_ppcmds + +val pr_alias : (Val.t -> std_ppcmds) -> + int -> Names.KerName.t -> Val.t list -> std_ppcmds + +val pr_ltac_constant : Nametab.ltac_constant -> std_ppcmds + +val pr_raw_tactic : raw_tactic_expr -> std_ppcmds + +val pr_raw_tactic_level : tolerability -> raw_tactic_expr -> std_ppcmds + +val pr_glob_tactic : env -> glob_tactic_expr -> std_ppcmds + +val pr_atomic_tactic : env -> Evd.evar_map -> atomic_tactic_expr -> std_ppcmds + +val pr_hintbases : string list option -> std_ppcmds + +val pr_auto_using : ('constr -> std_ppcmds) -> 'constr list -> std_ppcmds + +val pr_bindings : + ('constr -> std_ppcmds) -> + ('constr -> std_ppcmds) -> 'constr bindings -> std_ppcmds + +val pr_match_pattern : ('a -> std_ppcmds) -> 'a match_pattern -> std_ppcmds + +val pr_match_rule : bool -> ('a -> std_ppcmds) -> ('b -> std_ppcmds) -> + ('b, 'a) match_rule -> std_ppcmds + +val pr_value : tolerability -> Val.t -> std_ppcmds + + +val ltop : tolerability diff --git a/plugins/ltac/profile_ltac.ml b/plugins/ltac/profile_ltac.ml new file mode 100644 index 000000000..bcb28f77c --- /dev/null +++ b/plugins/ltac/profile_ltac.ml @@ -0,0 +1,420 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Unicode +open Pp +open Printer +open Util + +module M = CString.Map + +(** [is_profiling] and the profiling info ([stack]) should be synchronized with + the document; the rest of the ref cells are either local to individual + tactic invocations, or global flags, and need not be synchronized, since no + document-level backtracking happens within tactics. We synchronize + is_profiling via an option. *) +let is_profiling = Flags.profile_ltac + +let set_profiling b = is_profiling := b +let get_profiling () = !is_profiling + +(** LtacProf cannot yet handle backtracking into multi-success tactics. + To properly support this, we'd have to somehow recreate our location in the + call-stack, and stop/restart the intervening timers. This is tricky and + possibly expensive, so instead we currently just emit a warning that + profiling results will be off. *) +let encountered_multi_success_backtracking = ref false + +let warn_profile_backtracking = + CWarnings.create ~name:"profile-backtracking" ~category:"ltac" + (fun () -> strbrk "Ltac Profiler cannot yet handle backtracking \ + into multi-success tactics; profiling results may be wildly inaccurate.") + +let warn_encountered_multi_success_backtracking () = + if !encountered_multi_success_backtracking then + warn_profile_backtracking () + +let encounter_multi_success_backtracking () = + if not !encountered_multi_success_backtracking + then begin + encountered_multi_success_backtracking := true; + warn_encountered_multi_success_backtracking () + end + + +(* *************** tree data structure for profiling ****************** *) + +type treenode = { + name : M.key; + total : float; + local : float; + ncalls : int; + max_total : float; + children : treenode M.t +} + +let empty_treenode name = { + name; + total = 0.0; + local = 0.0; + ncalls = 0; + max_total = 0.0; + children = M.empty; +} + +let root = "root" + +module Local = Summary.Local + +let stack = Local.ref ~name:"LtacProf-stack" [empty_treenode root] + +let reset_profile_tmp () = + Local.(stack := [empty_treenode root]); + encountered_multi_success_backtracking := false + +(* ************** XML Serialization ********************* *) + +let rec of_ltacprof_tactic (name, t) = + assert (String.equal name t.name); + let open Xml_datatype in + let total = string_of_float t.total in + let local = string_of_float t.local in + let ncalls = string_of_int t.ncalls in + let max_total = string_of_float t.max_total in + let children = List.map of_ltacprof_tactic (M.bindings t.children) in + Element ("ltacprof_tactic", + [ ("name", name); ("total",total); ("local",local); + ("ncalls",ncalls); ("max_total",max_total)], + children) + +let of_ltacprof_results t = + let open Xml_datatype in + assert(String.equal t.name root); + let children = List.map of_ltacprof_tactic (M.bindings t.children) in + Element ("ltacprof", [("total_time", string_of_float t.total)], children) + +let rec to_ltacprof_tactic m xml = + let open Xml_datatype in + match xml with + | Element ("ltacprof_tactic", + [("name", name); ("total",total); ("local",local); + ("ncalls",ncalls); ("max_total",max_total)], xs) -> + let node = { + name; + total = float_of_string total; + local = float_of_string local; + ncalls = int_of_string ncalls; + max_total = float_of_string max_total; + children = List.fold_left to_ltacprof_tactic M.empty xs; + } in + M.add name node m + | _ -> CErrors.anomaly Pp.(str "Malformed ltacprof_tactic XML") + +let to_ltacprof_results xml = + let open Xml_datatype in + match xml with + | Element ("ltacprof", [("total_time", t)], xs) -> + { name = root; + total = float_of_string t; + ncalls = 0; + max_total = 0.0; + local = 0.0; + children = List.fold_left to_ltacprof_tactic M.empty xs } + | _ -> CErrors.anomaly Pp.(str "Malformed ltacprof XML") + +let feedback_results results = + Feedback.(feedback + (Custom (Loc.dummy_loc, "ltacprof_results", of_ltacprof_results results))) + +(* ************** pretty printing ************************************* *) + +let format_sec x = (Printf.sprintf "%.3fs" x) +let format_ratio x = (Printf.sprintf "%.1f%%" (100. *. x)) +let padl n s = ws (max 0 (n - utf8_length s)) ++ str s +let padr n s = str s ++ ws (max 0 (n - utf8_length s)) +let padr_with c n s = + let ulength = utf8_length s in + str (utf8_sub s 0 n) ++ str (String.make (max 0 (n - ulength)) c) + +let rec list_iter_is_last f = function + | [] -> [] + | [x] -> [f true x] + | x :: xs -> f false x :: list_iter_is_last f xs + +let header = + str " tactic local total calls max " ++ + fnl () ++ + str "────────────────────────────────────────┴──────┴──────┴───────┴─────────┘" ++ + fnl () + +let rec print_node ~filter all_total indent prefix (s, e) = + h 0 ( + padr_with '-' 40 (prefix ^ s ^ " ") + ++ padl 7 (format_ratio (e.local /. all_total)) + ++ padl 7 (format_ratio (e.total /. all_total)) + ++ padl 8 (string_of_int e.ncalls) + ++ padl 10 (format_sec (e.max_total)) + ) ++ + fnl () ++ + print_table ~filter all_total indent false e.children + +and print_table ~filter all_total indent first_level table = + let fold _ n l = + let s, total = n.name, n.total in + if filter s total then (s, n) :: l else l in + let ls = M.fold fold table [] in + match ls with + | [s, n] when not first_level -> + v 0 (print_node ~filter all_total indent (indent ^ "â””") (s, n)) + | _ -> + let ls = + List.sort (fun (_, { total = s1 }) (_, { total = s2}) -> + compare s2 s1) ls in + let iter is_last = + let sep0 = if first_level then "" else if is_last then " " else " │" in + let sep1 = if first_level then "─" else if is_last then " └─" else " ├─" in + print_node ~filter all_total (indent ^ sep0) (indent ^ sep1) + in + prlist (fun pr -> pr) (list_iter_is_last iter ls) + +let to_string ~filter ?(cutoff=0.0) node = + let tree = node.children in + let all_total = M.fold (fun _ { total } a -> total +. a) node.children 0.0 in + let flat_tree = + let global = ref M.empty in + let find_tactic tname l = + try M.find tname !global + with Not_found -> + let e = empty_treenode tname in + global := M.add tname e !global; + e in + let add_tactic tname stats = global := M.add tname stats !global in + let sum_stats add_total + { name; total = t1; local = l1; ncalls = n1; max_total = m1 } + { total = t2; local = l2; ncalls = n2; max_total = m2 } = { + name; + total = if add_total then t1 +. t2 else t1; + local = l1 +. l2; + ncalls = n1 + n2; + max_total = if add_total then max m1 m2 else m1; + children = M.empty; + } in + let rec cumulate table = + let iter _ ({ name; children } as statistics) = + if filter name then begin + let stats' = find_tactic name global in + add_tactic name (sum_stats true stats' statistics); + end; + cumulate children + in + M.iter iter table + in + cumulate tree; + !global + in + warn_encountered_multi_success_backtracking (); + let filter s n = filter s && (all_total <= 0.0 || n /. all_total >= cutoff /. 100.0) in + let msg = + h 0 (str "total time: " ++ padl 11 (format_sec (all_total))) ++ + fnl () ++ + fnl () ++ + header ++ + print_table ~filter all_total "" true flat_tree ++ + fnl () ++ + header ++ + print_table ~filter all_total "" true tree + in + msg + +(* ******************** profiling code ************************************** *) + +let get_child name node = + try M.find name node.children + with Not_found -> empty_treenode name + +let time () = + let times = Unix.times () in + times.Unix.tms_utime +. times.Unix.tms_stime + +let string_of_call ck = + let s = + string_of_ppcmds + (match ck with + | Tacexpr.LtacNotationCall s -> Pptactic.pr_alias_key s + | Tacexpr.LtacNameCall cst -> Pptactic.pr_ltac_constant cst + | Tacexpr.LtacVarCall (id, t) -> Nameops.pr_id id + | Tacexpr.LtacAtomCall te -> + (Pptactic.pr_glob_tactic (Global.env ()) + (Tacexpr.TacAtom (Loc.ghost, te))) + | Tacexpr.LtacConstrInterp (c, _) -> + pr_glob_constr_env (Global.env ()) c + | Tacexpr.LtacMLCall te -> + (Pptactic.pr_glob_tactic (Global.env ()) + te) + ) in + let s = String.map (fun c -> if c = '\n' then ' ' else c) s in + let s = try String.sub s 0 (CString.string_index_from s 0 "(*") with Not_found -> s in + CString.strip s + +let rec merge_sub_tree name tree acc = + try + let t = M.find name acc in + let t = { + name; + total = t.total +. tree.total; + ncalls = t.ncalls + tree.ncalls; + local = t.local +. tree.local; + max_total = max t.max_total tree.max_total; + children = M.fold merge_sub_tree tree.children t.children; + } in + M.add name t acc + with Not_found -> M.add name tree acc + +let merge_roots ?(disjoint=true) t1 t2 = + assert(String.equal t1.name t2.name); + { name = t1.name; + ncalls = t1.ncalls + t2.ncalls; + local = if disjoint then t1.local +. t2.local else t1.local; + total = if disjoint then t1.total +. t2.total else t1.total; + max_total = if disjoint then max t1.max_total t2.max_total else t1.max_total; + children = + M.fold merge_sub_tree t2.children t1.children } + +let rec find_in_stack what acc = function + | [] -> None + | { name } as x :: rest when String.equal name what -> Some(acc, x, rest) + | { name } as x :: rest -> find_in_stack what (x :: acc) rest + +let exit_tactic start_time c = + let diff = time () -. start_time in + match Local.(!stack) with + | [] | [_] -> + (* oops, our stack is invalid *) + encounter_multi_success_backtracking (); + reset_profile_tmp () + | node :: (parent :: rest as full_stack) -> + let name = string_of_call c in + if not (String.equal name node.name) then + (* oops, our stack is invalid *) + encounter_multi_success_backtracking (); + let node = { node with + total = node.total +. diff; + local = node.local +. diff; + ncalls = node.ncalls + 1; + max_total = max node.max_total diff; + } in + (* updating the stack *) + let parent = + match find_in_stack node.name [] full_stack with + | None -> + (* no rec-call, we graft the subtree *) + let parent = { parent with + local = parent.local -. diff; + children = M.add node.name node parent.children } in + Local.(stack := parent :: rest); + parent + | Some(to_update, self, rest) -> + (* we coalesce the rec-call and update the lower stack *) + let self = merge_roots ~disjoint:false self node in + let updated_stack = + List.fold_left (fun s x -> + (try M.find x.name (List.hd s).children + with Not_found -> x) :: s) (self :: rest) to_update in + Local.(stack := updated_stack); + List.hd Local.(!stack) + in + (* Calls are over, we reset the stack and send back data *) + if rest == [] && get_profiling () then begin + assert(String.equal root parent.name); + reset_profile_tmp (); + feedback_results parent + end + +let tclFINALLY tac (finally : unit Proofview.tactic) = + let open Proofview.Notations in + Proofview.tclIFCATCH + tac + (fun v -> finally <*> Proofview.tclUNIT v) + (fun (exn, info) -> finally <*> Proofview.tclZERO ~info exn) + +let do_profile s call_trace tac = + let open Proofview.Notations in + Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> + if !is_profiling then + match call_trace, Local.(!stack) with + | (_, c) :: _, parent :: rest -> + let name = string_of_call c in + let node = get_child name parent in + Local.(stack := node :: parent :: rest); + Some (time ()) + | _ :: _, [] -> assert false + | _ -> None + else None)) >>= function + | Some start_time -> + tclFINALLY + tac + (Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> + (match call_trace with + | (_, c) :: _ -> exit_tactic start_time c + | [] -> ())))) + | None -> tac + +(* ************** Accumulation of data from workers ************************* *) + +let get_local_profiling_results () = List.hd Local.(!stack) + +module SM = Map.Make(Stateid.Self) + +let data = ref SM.empty + +let _ = + Feedback.(add_feeder (function + | { id = s; contents = Custom (_, "ltacprof_results", xml) } -> + let results = to_ltacprof_results xml in + let other_results = (* Multi success can cause this *) + try SM.find s !data + with Not_found -> empty_treenode root in + data := SM.add s (merge_roots results other_results) !data + | _ -> ())) + +let reset_profile () = + reset_profile_tmp (); + data := SM.empty + +(* ******************** *) + +let print_results_filter ~cutoff ~filter = + let valid id _ = Stm.state_of_id id <> `Expired in + data := SM.filter valid !data; + let results = + SM.fold (fun _ -> merge_roots ~disjoint:true) !data (empty_treenode root) in + let results = merge_roots results Local.(CList.last !stack) in + Feedback.msg_notice (to_string ~cutoff ~filter results) +;; + +let print_results ~cutoff = + print_results_filter ~cutoff ~filter:(fun _ -> true) + +let print_results_tactic tactic = + print_results_filter ~cutoff:!Flags.profile_ltac_cutoff ~filter:(fun s -> + String.(equal tactic (sub (s ^ ".") 0 (min (1+length s) (length tactic))))) + +let do_print_results_at_close () = + if get_profiling () then print_results ~cutoff:!Flags.profile_ltac_cutoff + +let _ = Declaremods.append_end_library_hook do_print_results_at_close + +let _ = + let open Goptions in + declare_bool_option + { optsync = true; + optdepr = false; + optname = "Ltac Profiling"; + optkey = ["Ltac"; "Profiling"]; + optread = get_profiling; + optwrite = set_profiling } diff --git a/plugins/ltac/profile_ltac.mli b/plugins/ltac/profile_ltac.mli new file mode 100644 index 000000000..e5e2e4197 --- /dev/null +++ b/plugins/ltac/profile_ltac.mli @@ -0,0 +1,48 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Ltac profiling primitives *) + +val do_profile : + string -> ('a * Tacexpr.ltac_call_kind) list -> + 'b Proofview.tactic -> 'b Proofview.tactic + +val set_profiling : bool -> unit + +(* Cut off results < than specified cutoff *) +val print_results : cutoff:float -> unit + +val print_results_tactic : string -> unit + +val reset_profile : unit -> unit + +val do_print_results_at_close : unit -> unit + +(* The collected statistics for a tactic. The timing data is collected over all + * instances of a given tactic from its parent. E.g. if tactic 'aaa' calls + * 'foo' twice, then 'aaa' will contain just one entry for 'foo' with the + * statistics of the two invocations combined, and also combined over all + * invocations of 'aaa'. + * total: time spent running this tactic and its subtactics (seconds) + * local: time spent running this tactic, minus its subtactics (seconds) + * ncalls: the number of invocations of this tactic that have been made + * max_total: the greatest running time of a single invocation (seconds) + *) +type treenode = { + name : CString.Map.key; + total : float; + local : float; + ncalls : int; + max_total : float; + children : treenode CString.Map.t +} + +(* Returns the profiling results known by the current process *) +val get_local_profiling_results : unit -> treenode +val feedback_results : treenode -> unit + diff --git a/plugins/ltac/profile_ltac_tactics.ml4 b/plugins/ltac/profile_ltac_tactics.ml4 new file mode 100644 index 000000000..8cb76d81c --- /dev/null +++ b/plugins/ltac/profile_ltac_tactics.ml4 @@ -0,0 +1,40 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(*i camlp4deps: "grammar/grammar.cma" i*) + +(** Ltac profiling entrypoints *) + +open Profile_ltac +open Stdarg + +DECLARE PLUGIN "profile_ltac_plugin" + +let tclSET_PROFILING b = + Proofview.tclLIFT (Proofview.NonLogical.make (fun () -> set_profiling b)) + +TACTIC EXTEND start_ltac_profiling +| [ "start" "ltac" "profiling" ] -> [ tclSET_PROFILING true ] +END + +TACTIC EXTEND stop_profiling +| [ "stop" "ltac" "profiling" ] -> [ tclSET_PROFILING false ] +END + +VERNAC COMMAND EXTEND ResetLtacProfiling CLASSIFIED AS SIDEFF + [ "Reset" "Ltac" "Profile" ] -> [ reset_profile() ] +END + +VERNAC COMMAND EXTEND ShowLtacProfile CLASSIFIED AS QUERY +| [ "Show" "Ltac" "Profile" ] -> [ print_results ~cutoff:!Flags.profile_ltac_cutoff ] +| [ "Show" "Ltac" "Profile" "CutOff" int(n) ] -> [ print_results ~cutoff:(float_of_int n) ] +END + +VERNAC COMMAND EXTEND ShowLtacProfileTactic CLASSIFIED AS QUERY + [ "Show" "Ltac" "Profile" string(s) ] -> [ print_results_tactic s ] +END diff --git a/plugins/ltac/rewrite.ml b/plugins/ltac/rewrite.ml new file mode 100644 index 000000000..12a1566e2 --- /dev/null +++ b/plugins/ltac/rewrite.ml @@ -0,0 +1,2237 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Names +open Pp +open CErrors +open Util +open Nameops +open Namegen +open Term +open EConstr +open Vars +open Reduction +open Tacticals.New +open Tacmach +open Tactics +open Pretype_errors +open Typeclasses +open Classes +open Constrexpr +open Globnames +open Evd +open Misctypes +open Locus +open Locusops +open Decl_kinds +open Elimschemes +open Environ +open Termops +open EConstr +open Libnames +open Sigma.Notations +open Proofview.Notations +open Context.Named.Declaration + +module NamedDecl = Context.Named.Declaration +module RelDecl = Context.Rel.Declaration + +(** Typeclass-based generalized rewriting. *) + +(** Constants used by the tactic. *) + +let classes_dirpath = + Names.DirPath.make (List.map Id.of_string ["Classes";"Coq"]) + +let init_relation_classes () = + if is_dirpath_prefix_of classes_dirpath (Lib.cwd ()) then () + else Coqlib.check_required_library ["Coq";"Classes";"RelationClasses"] + +let init_setoid () = + if is_dirpath_prefix_of classes_dirpath (Lib.cwd ()) then () + else Coqlib.check_required_library ["Coq";"Setoids";"Setoid"] + +let make_dir l = DirPath.make (List.rev_map Id.of_string l) + +let try_find_global_reference dir s = + let sp = Libnames.make_path (make_dir ("Coq"::dir)) (Id.of_string s) in + try Nametab.global_of_path sp + with Not_found -> + anomaly (str "Global reference " ++ str s ++ str " not found in generalized rewriting") + +let find_reference dir s = + let gr = lazy (try_find_global_reference dir s) in + fun () -> Lazy.force gr + +type evars = evar_map * Evar.Set.t (* goal evars, constraint evars *) + +let find_global dir s = + let gr = lazy (try_find_global_reference dir s) in + fun (evd,cstrs) -> + let sigma = Sigma.Unsafe.of_evar_map evd in + let Sigma (c, sigma, _) = Evarutil.new_global sigma (Lazy.force gr) in + let evd = Sigma.to_evar_map sigma in + (evd, cstrs), c + +(** Utility for dealing with polymorphic applications *) + +(** Global constants. *) + +let coq_eq_ref = find_reference ["Init"; "Logic"] "eq" +let coq_eq = find_global ["Init"; "Logic"] "eq" +let coq_f_equal = find_global ["Init"; "Logic"] "f_equal" +let coq_all = find_global ["Init"; "Logic"] "all" +let impl = find_global ["Program"; "Basics"] "impl" + +(** Bookkeeping which evars are constraints so that we can + remove them at the end of the tactic. *) + +let goalevars evars = fst evars +let cstrevars evars = snd evars + +let new_cstr_evar (evd,cstrs) env t = + let s = Typeclasses.set_resolvable Evd.Store.empty false in + let evd = Sigma.Unsafe.of_evar_map evd in + let Sigma (t, evd', _) = Evarutil.new_evar ~store:s env evd t in + let evd' = Sigma.to_evar_map evd' in + let ev, _ = destEvar evd' t in + (evd', Evar.Set.add ev cstrs), t + +(** Building or looking up instances. *) +let e_new_cstr_evar env evars t = + let evd', t = new_cstr_evar !evars env t in evars := evd'; t + +(** Building or looking up instances. *) + +let extends_undefined evars evars' = + let f ev evi found = found || not (Evd.mem evars ev) + in fold_undefined f evars' false + +let app_poly_check env evars f args = + let (evars, cstrs), fc = f evars in + let evdref = ref evars in + let t = Typing.e_solve_evars env evdref (mkApp (fc, args)) in + (!evdref, cstrs), t + +let app_poly_nocheck env evars f args = + let evars, fc = f evars in + evars, mkApp (fc, args) + +let app_poly_sort b = + if b then app_poly_nocheck + else app_poly_check + +let find_class_proof proof_type proof_method env evars carrier relation = + try + let evars, goal = app_poly_check env evars proof_type [| carrier ; relation |] in + let evars', c = Typeclasses.resolve_one_typeclass env (goalevars evars) goal in + if extends_undefined (goalevars evars) evars' then raise Not_found + else app_poly_check env (evars',cstrevars evars) proof_method [| carrier; relation; c |] + with e when Logic.catchable_exception e -> raise Not_found + +(** Utility functions *) + +module GlobalBindings (M : sig + val relation_classes : string list + val morphisms : string list + val relation : string list * string + val app_poly : env -> evars -> (evars -> evars * constr) -> constr array -> evars * constr + val arrow : evars -> evars * constr +end) = struct + open M + open Context.Rel.Declaration + let relation : evars -> evars * constr = find_global (fst relation) (snd relation) + + let reflexive_type = find_global relation_classes "Reflexive" + let reflexive_proof = find_global relation_classes "reflexivity" + + let symmetric_type = find_global relation_classes "Symmetric" + let symmetric_proof = find_global relation_classes "symmetry" + + let transitive_type = find_global relation_classes "Transitive" + let transitive_proof = find_global relation_classes "transitivity" + + let forall_relation = find_global morphisms "forall_relation" + let pointwise_relation = find_global morphisms "pointwise_relation" + + let forall_relation_ref = find_reference morphisms "forall_relation" + let pointwise_relation_ref = find_reference morphisms "pointwise_relation" + + let respectful = find_global morphisms "respectful" + let respectful_ref = find_reference morphisms "respectful" + + let default_relation = find_global ["Classes"; "SetoidTactics"] "DefaultRelation" + + let coq_forall = find_global morphisms "forall_def" + + let subrelation = find_global relation_classes "subrelation" + let do_subrelation = find_global morphisms "do_subrelation" + let apply_subrelation = find_global morphisms "apply_subrelation" + + let rewrite_relation_class = find_global relation_classes "RewriteRelation" + + let proper_class = lazy (class_info (try_find_global_reference morphisms "Proper")) + let proper_proxy_class = lazy (class_info (try_find_global_reference morphisms "ProperProxy")) + + let proper_proj = lazy (mkConst (Option.get (pi3 (List.hd (Lazy.force proper_class).cl_projs)))) + + let proper_type = + let l = lazy (Lazy.force proper_class).cl_impl in + fun (evd,cstrs) -> + let sigma = Sigma.Unsafe.of_evar_map evd in + let Sigma (c, sigma, _) = Evarutil.new_global sigma (Lazy.force l) in + let evd = Sigma.to_evar_map sigma in + (evd, cstrs), c + + let proper_proxy_type = + let l = lazy (Lazy.force proper_proxy_class).cl_impl in + fun (evd,cstrs) -> + let sigma = Sigma.Unsafe.of_evar_map evd in + let Sigma (c, sigma, _) = Evarutil.new_global sigma (Lazy.force l) in + let evd = Sigma.to_evar_map sigma in + (evd, cstrs), c + + let proper_proof env evars carrier relation x = + let evars, goal = app_poly env evars proper_proxy_type [| carrier ; relation; x |] in + new_cstr_evar evars env goal + + let get_reflexive_proof env = find_class_proof reflexive_type reflexive_proof env + let get_symmetric_proof env = find_class_proof symmetric_type symmetric_proof env + let get_transitive_proof env = find_class_proof transitive_type transitive_proof env + + let mk_relation env evd a = + app_poly env evd relation [| a |] + + (** Build an infered signature from constraints on the arguments and expected output + relation *) + + let build_signature evars env m (cstrs : (types * types option) option list) + (finalcstr : (types * types option) option) = + let mk_relty evars newenv ty obj = + match obj with + | None | Some (_, None) -> + let evars, relty = mk_relation env evars ty in + if closed0 (goalevars evars) ty then + let env' = Environ.reset_with_named_context (Environ.named_context_val env) env in + new_cstr_evar evars env' relty + else new_cstr_evar evars newenv relty + | Some (x, Some rel) -> evars, rel + in + let rec aux env evars ty l = + let t = Reductionops.whd_all env (goalevars evars) ty in + match EConstr.kind (goalevars evars) t, l with + | Prod (na, ty, b), obj :: cstrs -> + let b = Reductionops.nf_betaiota (goalevars evars) b in + if noccurn (goalevars evars) 1 b (* non-dependent product *) then + let ty = Reductionops.nf_betaiota (goalevars evars) ty in + let (evars, b', arg, cstrs) = aux env evars (subst1 mkProp b) cstrs in + let evars, relty = mk_relty evars env ty obj in + let evars, newarg = app_poly env evars respectful [| ty ; b' ; relty ; arg |] in + evars, mkProd(na, ty, b), newarg, (ty, Some relty) :: cstrs + else + let (evars, b, arg, cstrs) = + aux (push_rel (LocalAssum (na, ty)) env) evars b cstrs + in + let ty = Reductionops.nf_betaiota (goalevars evars) ty in + let pred = mkLambda (na, ty, b) in + let liftarg = mkLambda (na, ty, arg) in + let evars, arg' = app_poly env evars forall_relation [| ty ; pred ; liftarg |] in + if Option.is_empty obj then evars, mkProd(na, ty, b), arg', (ty, None) :: cstrs + else error "build_signature: no constraint can apply on a dependent argument" + | _, obj :: _ -> anomaly ~label:"build_signature" (Pp.str "not enough products") + | _, [] -> + (match finalcstr with + | None | Some (_, None) -> + let t = Reductionops.nf_betaiota (fst evars) ty in + let evars, rel = mk_relty evars env t None in + evars, t, rel, [t, Some rel] + | Some (t, Some rel) -> evars, t, rel, [t, Some rel]) + in aux env evars m cstrs + + (** Folding/unfolding of the tactic constants. *) + + let unfold_impl sigma t = + match EConstr.kind sigma t with + | App (arrow, [| a; b |])(* when eq_constr arrow (Lazy.force impl) *) -> + mkProd (Anonymous, a, lift 1 b) + | _ -> assert false + + let unfold_all sigma t = + match EConstr.kind sigma t with + | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) -> + (match EConstr.kind sigma b with + | Lambda (n, ty, b) -> mkProd (n, ty, b) + | _ -> assert false) + | _ -> assert false + + let unfold_forall sigma t = + match EConstr.kind sigma t with + | App (id, [| a; b |]) (* when eq_constr id (Lazy.force coq_all) *) -> + (match EConstr.kind sigma b with + | Lambda (n, ty, b) -> mkProd (n, ty, b) + | _ -> assert false) + | _ -> assert false + + let arrow_morphism env evd ta tb a b = + let ap = is_Prop (goalevars evd) ta and bp = is_Prop (goalevars evd) tb in + if ap && bp then app_poly env evd impl [| a; b |], unfold_impl + else if ap then (* Domain in Prop, CoDomain in Type *) + (app_poly env evd arrow [| a; b |]), unfold_impl + (* (evd, mkProd (Anonymous, a, b)), (fun x -> x) *) + else if bp then (* Dummy forall *) + (app_poly env evd coq_all [| a; mkLambda (Anonymous, a, lift 1 b) |]), unfold_forall + else (* None in Prop, use arrow *) + (app_poly env evd arrow [| a; b |]), unfold_impl + + let rec decomp_pointwise sigma n c = + if Int.equal n 0 then c + else + match EConstr.kind sigma c with + | App (f, [| a; b; relb |]) when Termops.is_global sigma (pointwise_relation_ref ()) f -> + decomp_pointwise sigma (pred n) relb + | App (f, [| a; b; arelb |]) when Termops.is_global sigma (forall_relation_ref ()) f -> + decomp_pointwise sigma (pred n) (Reductionops.beta_applist sigma (arelb, [mkRel 1])) + | _ -> invalid_arg "decomp_pointwise" + + let rec apply_pointwise sigma rel = function + | arg :: args -> + (match EConstr.kind sigma rel with + | App (f, [| a; b; relb |]) when Termops.is_global sigma (pointwise_relation_ref ()) f -> + apply_pointwise sigma relb args + | App (f, [| a; b; arelb |]) when Termops.is_global sigma (forall_relation_ref ()) f -> + apply_pointwise sigma (Reductionops.beta_applist sigma (arelb, [arg])) args + | _ -> invalid_arg "apply_pointwise") + | [] -> rel + + let pointwise_or_dep_relation env evd n t car rel = + if noccurn (goalevars evd) 1 car && noccurn (goalevars evd) 1 rel then + app_poly env evd pointwise_relation [| t; lift (-1) car; lift (-1) rel |] + else + app_poly env evd forall_relation + [| t; mkLambda (n, t, car); mkLambda (n, t, rel) |] + + let lift_cstr env evars (args : constr list) c ty cstr = + let start evars env car = + match cstr with + | None | Some (_, None) -> + let evars, rel = mk_relation env evars car in + new_cstr_evar evars env rel + | Some (ty, Some rel) -> evars, rel + in + let rec aux evars env prod n = + if Int.equal n 0 then start evars env prod + else + let sigma = goalevars evars in + match EConstr.kind sigma (Reductionops.whd_all env sigma prod) with + | Prod (na, ty, b) -> + if noccurn sigma 1 b then + let b' = lift (-1) b in + let evars, rb = aux evars env b' (pred n) in + app_poly env evars pointwise_relation [| ty; b'; rb |] + else + let evars, rb = aux evars (push_rel (LocalAssum (na, ty)) env) b (pred n) in + app_poly env evars forall_relation + [| ty; mkLambda (na, ty, b); mkLambda (na, ty, rb) |] + | _ -> raise Not_found + in + let rec find env c ty = function + | [] -> None + | arg :: args -> + try let evars, found = aux evars env ty (succ (List.length args)) in + Some (evars, found, c, ty, arg :: args) + with Not_found -> + let sigma = goalevars evars in + let ty = Reductionops.whd_all env sigma ty in + find env (mkApp (c, [| arg |])) (prod_applist sigma ty [arg]) args + in find env c ty args + + let unlift_cstr env sigma = function + | None -> None + | Some codom -> Some (decomp_pointwise (goalevars sigma) 1 codom) + + (** Looking up declared rewrite relations (instances of [RewriteRelation]) *) + let is_applied_rewrite_relation env sigma rels t = + match EConstr.kind sigma t with + | App (c, args) when Array.length args >= 2 -> + let head = if isApp sigma c then fst (destApp sigma c) else c in + if Termops.is_global sigma (coq_eq_ref ()) head then None + else + (try + let params, args = Array.chop (Array.length args - 2) args in + let env' = 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 evars = Sigma.to_evar_map evars in + let evars, inst = + app_poly env (evars,Evar.Set.empty) + rewrite_relation_class [| evar; mkApp (c, params) |] in + let _ = Typeclasses.resolve_one_typeclass env' (goalevars evars) inst in + Some (it_mkProd_or_LetIn t rels) + with e when CErrors.noncritical e -> None) + | _ -> None + + +end + +(* let my_type_of env evars c = Typing.e_type_of env evars c *) +(* let mytypeofkey = Profile.declare_profile "my_type_of";; *) +(* let my_type_of = Profile.profile3 mytypeofkey my_type_of *) + + +let type_app_poly env env evd f args = + let evars, c = app_poly_nocheck env evd f args in + let evd', t = Typing.type_of env (goalevars evars) c in + (evd', cstrevars evars), c + +module PropGlobal = struct + module Consts = + struct + let relation_classes = ["Classes"; "RelationClasses"] + let morphisms = ["Classes"; "Morphisms"] + let relation = ["Relations";"Relation_Definitions"], "relation" + let app_poly = app_poly_nocheck + let arrow = find_global ["Program"; "Basics"] "arrow" + let coq_inverse = find_global ["Program"; "Basics"] "flip" + end + + module G = GlobalBindings(Consts) + + include G + include Consts + let inverse env evd car rel = + type_app_poly env env evd coq_inverse [| car ; car; mkProp; rel |] + (* app_poly env evd coq_inverse [| car ; car; mkProp; rel |] *) + +end + +module TypeGlobal = struct + module Consts = + struct + let relation_classes = ["Classes"; "CRelationClasses"] + let morphisms = ["Classes"; "CMorphisms"] + let relation = relation_classes, "crelation" + let app_poly = app_poly_check + let arrow = find_global ["Classes"; "CRelationClasses"] "arrow" + let coq_inverse = find_global ["Classes"; "CRelationClasses"] "flip" + end + + module G = GlobalBindings(Consts) + include G + include Consts + + + let inverse env (evd,cstrs) car rel = + let sigma = Sigma.Unsafe.of_evar_map evd in + let Sigma (sort, sigma, _) = Evarutil.new_Type ~rigid:Evd.univ_flexible env sigma in + let evd = Sigma.to_evar_map sigma in + app_poly_check env (evd,cstrs) coq_inverse [| car ; car; sort; rel |] + +end + +let sort_of_rel env evm rel = + ESorts.kind evm (Reductionops.sort_of_arity env evm (Retyping.get_type_of env evm rel)) + +let is_applied_rewrite_relation = PropGlobal.is_applied_rewrite_relation + +(* let _ = *) +(* Hook.set Equality.is_applied_rewrite_relation is_applied_rewrite_relation *) + +let split_head = function + hd :: tl -> hd, tl + | [] -> assert(false) + +let eq_pb (ty, env, x, y as pb) (ty', env', x', y' as pb') = + pb == pb' || (ty == ty' && Constr.equal x x' && Constr.equal y y') + +let problem_inclusion x y = + List.for_all (fun pb -> List.exists (fun pb' -> eq_pb pb pb') y) x + +let evd_convertible env evd x y = + try + (* Unfortunately, the_conv_x might say they are unifiable even if some + unsolvable constraints remain, so we check that this unification + does not introduce any new problem. *) + let _, pbs = Evd.extract_all_conv_pbs evd in + let evd' = Evarconv.the_conv_x env x y evd in + let _, pbs' = Evd.extract_all_conv_pbs evd' in + if evd' == evd || problem_inclusion pbs' pbs then Some evd' + else None + with e when CErrors.noncritical e -> None + +let convertible env evd x y = + Reductionops.is_conv_leq env evd x y + +type hypinfo = { + prf : constr; + car : constr; + rel : constr; + sort : bool; (* true = Prop; false = Type *) + c1 : constr; + c2 : constr; + holes : Clenv.hole list; +} + +let get_symmetric_proof b = + if b then PropGlobal.get_symmetric_proof else TypeGlobal.get_symmetric_proof + +let error_no_relation () = error "Cannot find a relation to rewrite." + +let rec decompose_app_rel env evd t = + (** Head normalize for compatibility with the old meta mechanism *) + let t = Reductionops.whd_betaiota evd t in + match EConstr.kind evd t with + | App (f, [||]) -> assert false + | App (f, [|arg|]) -> + let (f', argl, argr) = decompose_app_rel env evd arg in + let ty = Typing.unsafe_type_of env evd argl in + let f'' = mkLambda (Name default_dependent_ident, ty, + mkLambda (Name (Id.of_string "y"), lift 1 ty, + mkApp (lift 2 f, [| mkApp (lift 2 f', [| mkRel 2; mkRel 1 |]) |]))) + in (f'', argl, argr) + | App (f, args) -> + let len = Array.length args in + let fargs = Array.sub args 0 (Array.length args - 2) in + let rel = mkApp (f, fargs) in + rel, args.(len - 2), args.(len - 1) + | _ -> error_no_relation () + +let decompose_app_rel env evd t = + let (rel, t1, t2) = decompose_app_rel env evd t in + let ty = Retyping.get_type_of env evd rel in + let () = if not (Reductionops.is_arity env evd ty) then error_no_relation () in + (rel, t1, t2) + +let decompose_applied_relation env sigma (c,l) = + let open Context.Rel.Declaration in + let ctype = Retyping.get_type_of env sigma c in + let find_rel ty = + let sigma, cl = Clenv.make_evar_clause env sigma ty in + let sigma = Clenv.solve_evar_clause env sigma true cl l in + let { Clenv.cl_holes = holes; Clenv.cl_concl = t } = cl in + let (equiv, c1, c2) = decompose_app_rel env sigma t in + let ty1 = Retyping.get_type_of env sigma c1 in + let ty2 = Retyping.get_type_of env sigma c2 in + match evd_convertible env sigma ty1 ty2 with + | None -> None + | Some sigma -> + let sort = sort_of_rel env sigma equiv in + let args = Array.map_of_list (fun h -> h.Clenv.hole_evar) holes in + let value = mkApp (c, args) in + Some (sigma, { prf=value; + car=ty1; rel = equiv; sort = Sorts.is_prop sort; + c1=c1; c2=c2; holes }) + in + match find_rel ctype with + | Some c -> c + | None -> + let ctx,t' = Reductionops.splay_prod env sigma ctype in (* Search for underlying eq *) + match find_rel (it_mkProd_or_LetIn t' (List.map (fun (n,t) -> LocalAssum (n, t)) ctx)) with + | Some c -> c + | None -> error "Cannot find an homogeneous relation to rewrite." + +let rewrite_db = "rewrite" + +let conv_transparent_state = (Id.Pred.empty, Cpred.full) + +let _ = + Hints.add_hints_init + (fun () -> + Hints.create_hint_db false rewrite_db conv_transparent_state true) + +let rewrite_transparent_state () = + Hints.Hint_db.transparent_state (Hints.searchtable_map rewrite_db) + +let rewrite_core_unif_flags = { + Unification.modulo_conv_on_closed_terms = None; + Unification.use_metas_eagerly_in_conv_on_closed_terms = true; + Unification.use_evars_eagerly_in_conv_on_closed_terms = true; + Unification.modulo_delta = empty_transparent_state; + Unification.modulo_delta_types = full_transparent_state; + Unification.check_applied_meta_types = true; + Unification.use_pattern_unification = true; + Unification.use_meta_bound_pattern_unification = true; + Unification.frozen_evars = Evar.Set.empty; + Unification.restrict_conv_on_strict_subterms = false; + Unification.modulo_betaiota = false; + Unification.modulo_eta = true; +} + +(* Flags used for the setoid variant of "rewrite" and for the strategies + "hints"/"old_hints"/"terms" of "rewrite_strat", and for solving pre-existing + evars in "rewrite" (see unify_abs) *) +let rewrite_unif_flags = + let flags = rewrite_core_unif_flags in { + Unification.core_unify_flags = flags; + Unification.merge_unify_flags = flags; + Unification.subterm_unify_flags = flags; + Unification.allow_K_in_toplevel_higher_order_unification = true; + Unification.resolve_evars = true + } + +let rewrite_core_conv_unif_flags = { + rewrite_core_unif_flags with + Unification.modulo_conv_on_closed_terms = Some conv_transparent_state; + Unification.modulo_delta_types = conv_transparent_state; + Unification.modulo_betaiota = true +} + +(* Fallback flags for the setoid variant of "rewrite" *) +let rewrite_conv_unif_flags = + let flags = rewrite_core_conv_unif_flags in { + Unification.core_unify_flags = flags; + Unification.merge_unify_flags = flags; + Unification.subterm_unify_flags = flags; + Unification.allow_K_in_toplevel_higher_order_unification = true; + Unification.resolve_evars = true + } + +(* Flags for "setoid_rewrite c"/"rewrite_strat -> c" *) +let general_rewrite_unif_flags () = + let ts = rewrite_transparent_state () in + let core_flags = + { rewrite_core_unif_flags with + Unification.modulo_conv_on_closed_terms = Some ts; + Unification.use_evars_eagerly_in_conv_on_closed_terms = true; + Unification.modulo_delta = ts; + Unification.modulo_delta_types = full_transparent_state; + Unification.modulo_betaiota = true } + in { + Unification.core_unify_flags = core_flags; + Unification.merge_unify_flags = core_flags; + Unification.subterm_unify_flags = { core_flags with Unification.modulo_delta = empty_transparent_state }; + Unification.allow_K_in_toplevel_higher_order_unification = true; + Unification.resolve_evars = true + } + +let refresh_hypinfo env sigma (is, cb) = + let sigma, cbl = Tacinterp.interp_open_constr_with_bindings is env sigma cb in + let sigma, hypinfo = decompose_applied_relation env sigma cbl in + let { c1; c2; car; rel; prf; sort; holes } = hypinfo in + sigma, (car, rel, prf, c1, c2, holes, sort) + +(** FIXME: write this in the new monad interface *) +let solve_remaining_by env sigma holes by = + match by with + | None -> sigma + | Some tac -> + let map h = + if h.Clenv.hole_deps then None + else match EConstr.kind sigma h.Clenv.hole_evar with + | Evar (evk, _) -> + Some evk + | _ -> None + in + (** Only solve independent holes *) + let indep = List.map_filter map holes in + let ist = { Geninterp.lfun = Id.Map.empty; extra = Geninterp.TacStore.empty } in + let solve_tac = match tac with + | Genarg.GenArg (Genarg.Glbwit tag, tac) -> + Ftactic.run (Geninterp.interp tag ist tac) (fun _ -> Proofview.tclUNIT ()) + in + let solve_tac = tclCOMPLETE solve_tac in + let solve sigma evk = + let evi = + try Some (Evd.find_undefined sigma evk) + with Not_found -> None + in + match evi with + | None -> sigma + (** Evar should not be defined, but just in case *) + | Some evi -> + let env = Environ.reset_with_named_context evi.evar_hyps env in + let ty = EConstr.of_constr evi.evar_concl in + let c, sigma = Pfedit.refine_by_tactic env sigma ty solve_tac in + Evd.define evk c sigma + in + List.fold_left solve sigma indep + +let no_constraints cstrs = + fun ev _ -> not (Evar.Set.mem ev cstrs) + +let all_constraints cstrs = + fun ev _ -> Evar.Set.mem ev cstrs + +let poly_inverse sort = + if sort then PropGlobal.inverse else TypeGlobal.inverse + +type rewrite_proof = + | RewPrf of constr * constr + (** A Relation (R : rew_car -> rew_car -> Prop) and a proof of R rew_from rew_to *) + | RewCast of cast_kind + (** A proof of convertibility (with casts) *) + +type rewrite_result_info = { + rew_car : constr ; + (** A type *) + rew_from : constr ; + (** A term of type rew_car *) + rew_to : constr ; + (** A term of type rew_car *) + rew_prf : rewrite_proof ; + (** A proof of rew_from == rew_to *) + rew_evars : evars; +} + +type rewrite_result = +| Fail +| Identity +| Success of rewrite_result_info + +type 'a strategy_input = { state : 'a ; (* a parameter: for instance, a state *) + env : Environ.env ; + unfresh : Id.t list ; (* Unfresh names *) + term1 : constr ; + ty1 : types ; (* first term and its type (convertible to rew_from) *) + cstr : (bool (* prop *) * constr option) ; + evars : evars } + +type 'a pure_strategy = { strategy : + 'a strategy_input -> + 'a * rewrite_result (* the updated state and the "result" *) } + +type strategy = unit pure_strategy + +let symmetry env sort rew = + let { rew_evars = evars; rew_car = car; } = rew in + let (rew_evars, rew_prf) = match rew.rew_prf with + | RewCast _ -> (rew.rew_evars, rew.rew_prf) + | RewPrf (rel, prf) -> + try + let evars, symprf = get_symmetric_proof sort env evars car rel in + let prf = mkApp (symprf, [| rew.rew_from ; rew.rew_to ; prf |]) in + (evars, RewPrf (rel, prf)) + with Not_found -> + let evars, rel = poly_inverse sort env evars car rel in + (evars, RewPrf (rel, prf)) + in + { rew with rew_from = rew.rew_to; rew_to = rew.rew_from; rew_prf; rew_evars; } + +(* Matching/unifying the rewriting rule against [t] *) +let unify_eqn (car, rel, prf, c1, c2, holes, sort) l2r flags env (sigma, cstrs) by t = + try + let left = if l2r then c1 else c2 in + let sigma = Unification.w_unify ~flags env sigma CONV left t in + let sigma = Typeclasses.resolve_typeclasses ~filter:(no_constraints cstrs) + ~fail:true env sigma in + let evd = solve_remaining_by env sigma holes by in + let nf c = Reductionops.nf_evar evd (Reductionops.nf_meta evd c) in + let c1 = nf c1 and c2 = nf c2 + and rew_car = nf car and rel = nf rel + and prf = nf prf in + let ty1 = Retyping.get_type_of env evd c1 in + let ty2 = Retyping.get_type_of env evd c2 in + let () = if not (convertible env evd ty2 ty1) then raise Reduction.NotConvertible in + let rew_evars = evd, cstrs in + let rew_prf = RewPrf (rel, prf) in + let rew = { rew_evars; rew_prf; rew_car; rew_from = c1; rew_to = c2; } in + let rew = if l2r then rew else symmetry env sort rew in + Some rew + with + | e when Class_tactics.catchable e -> None + | Reduction.NotConvertible -> None + +let unify_abs (car, rel, prf, c1, c2) l2r sort env (sigma, cstrs) t = + try + let left = if l2r then c1 else c2 in + (* The pattern is already instantiated, so the next w_unify is + basically an eq_constr, except when preexisting evars occur in + either the lemma or the goal, in which case the eq_constr also + solved this evars *) + let sigma = Unification.w_unify ~flags:rewrite_unif_flags env sigma CONV left t in + let rew_evars = sigma, cstrs in + let rew_prf = RewPrf (rel, prf) in + let rew = { rew_car = car; rew_from = c1; rew_to = c2; rew_prf; rew_evars; } in + let rew = if l2r then rew else symmetry env sort rew in + Some rew + with + | e when Class_tactics.catchable e -> None + | Reduction.NotConvertible -> None + +type rewrite_flags = { under_lambdas : bool; on_morphisms : bool } + +let default_flags = { under_lambdas = true; on_morphisms = true; } + +let get_opt_rew_rel = function RewPrf (rel, prf) -> Some rel | _ -> None + +let make_eq () = +(*FIXME*) EConstr.of_constr (Universes.constr_of_global (Coqlib.build_coq_eq ())) +let make_eq_refl () = +(*FIXME*) EConstr.of_constr (Universes.constr_of_global (Coqlib.build_coq_eq_refl ())) + +let get_rew_prf r = match r.rew_prf with + | RewPrf (rel, prf) -> rel, prf + | RewCast c -> + let rel = mkApp (make_eq (), [| r.rew_car |]) in + rel, mkCast (mkApp (make_eq_refl (), [| r.rew_car; r.rew_from |]), + c, mkApp (rel, [| r.rew_from; r.rew_to |])) + +let poly_subrelation sort = + if sort then PropGlobal.subrelation else TypeGlobal.subrelation + +let resolve_subrelation env avoid car rel sort prf rel' res = + if Termops.eq_constr (fst res.rew_evars) rel 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 + let appsub = mkApp (subrel, [| res.rew_from ; res.rew_to ; prf |]) in + { res with + rew_prf = RewPrf (rel', appsub); + rew_evars = evars } + +let resolve_morphism env avoid oldt m ?(fnewt=fun x -> x) args args' (b,cstr) evars = + let evars, morph_instance, proj, sigargs, m', args, args' = + let first = match (Array.findi (fun _ b -> not (Option.is_empty b)) args') with + | Some i -> i + | None -> invalid_arg "resolve_morphism" in + let morphargs, morphobjs = Array.chop first args in + let morphargs', morphobjs' = Array.chop first args' in + let appm = mkApp(m, morphargs) in + let appmtype = Typing.unsafe_type_of env (goalevars evars) appm in + let cstrs = List.map + (Option.map (fun r -> r.rew_car, get_opt_rew_rel r.rew_prf)) + (Array.to_list morphobjs') + in + (* Desired signature *) + let evars, appmtype', signature, sigargs = + if b then PropGlobal.build_signature evars env appmtype cstrs cstr + else TypeGlobal.build_signature evars env appmtype cstrs cstr + in + (* Actual signature found *) + let cl_args = [| appmtype' ; signature ; appm |] in + let evars, app = app_poly_sort b env evars (if b then PropGlobal.proper_type else TypeGlobal.proper_type) + cl_args in + let env' = + let dosub, appsub = + if b then PropGlobal.do_subrelation, PropGlobal.apply_subrelation + else TypeGlobal.do_subrelation, TypeGlobal.apply_subrelation + in + EConstr.push_named + (LocalDef (Id.of_string "do_subrelation", + snd (app_poly_sort b env evars dosub [||]), + snd (app_poly_nocheck env evars appsub [||]))) + env + in + let evars, morph = new_cstr_evar evars env' app in + evars, morph, morph, sigargs, appm, morphobjs, morphobjs' + in + let projargs, subst, evars, respars, typeargs = + Array.fold_left2 + (fun (acc, subst, evars, sigargs, typeargs') x y -> + let (carrier, relation), sigargs = split_head sigargs in + match relation with + | Some relation -> + let carrier = substl subst carrier + and relation = substl subst relation in + (match y with + | None -> + let evars, proof = + (if b then PropGlobal.proper_proof else TypeGlobal.proper_proof) + env evars carrier relation x in + [ proof ; x ; x ] @ acc, subst, evars, sigargs, x :: typeargs' + | Some r -> + [ snd (get_rew_prf r); r.rew_to; x ] @ acc, subst, evars, + sigargs, r.rew_to :: typeargs') + | None -> + if not (Option.is_empty y) then + error "Cannot rewrite inside dependent arguments of a function"; + x :: acc, x :: subst, evars, sigargs, x :: typeargs') + ([], [], evars, sigargs, []) args args' + in + let proof = applist (proj, List.rev projargs) in + let newt = applist (m', List.rev typeargs) in + match respars with + [ a, Some r ] -> evars, proof, substl subst a, substl subst r, oldt, fnewt newt + | _ -> assert(false) + +let apply_constraint env avoid car rel prf cstr res = + match snd cstr with + | None -> res + | Some r -> resolve_subrelation env avoid car rel (fst cstr) prf r res + +let coerce env avoid cstr res = + let rel, prf = get_rew_prf res in + apply_constraint env avoid res.rew_car rel prf cstr res + +let apply_rule unify loccs : int pure_strategy = + let (nowhere_except_in,occs) = convert_occs loccs in + let is_occ occ = + if nowhere_except_in + then List.mem occ occs + else not (List.mem occ occs) + in + { strategy = fun { state = occ ; env ; unfresh ; + term1 = t ; ty1 = ty ; cstr ; evars } -> + let unif = if isEvar (goalevars evars) t then None else unify env evars t in + match unif with + | None -> (occ, Fail) + | Some rew -> + let occ = succ occ in + if not (is_occ occ) then (occ, Fail) + else if Termops.eq_constr (fst rew.rew_evars) t rew.rew_to then (occ, Identity) + else + let res = { rew with rew_car = ty } in + let rel, prf = get_rew_prf res in + let res = Success (apply_constraint env unfresh rew.rew_car rel prf cstr res) in + (occ, res) + } + +let apply_lemma l2r flags oc by loccs : strategy = { strategy = + fun ({ state = () ; env ; term1 = t ; evars = (sigma, cstrs) } as input) -> + let sigma, c = oc sigma in + let sigma, hypinfo = decompose_applied_relation env sigma c in + let { c1; c2; car; rel; prf; sort; holes } = hypinfo in + let rew = (car, rel, prf, c1, c2, holes, sort) in + let evars = (sigma, cstrs) in + let unify env evars t = + let rew = unify_eqn rew l2r flags env evars by t in + match rew with + | None -> None + | Some rew -> Some rew + in + let _, res = (apply_rule unify loccs).strategy { input with + state = 0 ; + evars } in + (), res + } + +let e_app_poly env evars f args = + let evars', c = app_poly_nocheck env !evars f args in + evars := evars'; + c + +let make_leibniz_proof env c ty r = + let evars = ref r.rew_evars in + let prf = + match r.rew_prf with + | RewPrf (rel, prf) -> + let rel = e_app_poly env evars coq_eq [| ty |] in + let prf = + e_app_poly env evars coq_f_equal + [| r.rew_car; ty; + mkLambda (Anonymous, r.rew_car, c); + r.rew_from; r.rew_to; prf |] + in RewPrf (rel, prf) + | RewCast k -> r.rew_prf + in + { rew_car = ty; rew_evars = !evars; + rew_from = subst1 r.rew_from c; rew_to = subst1 r.rew_to c; rew_prf = prf } + +let reset_env env = + let env' = Global.env_of_context (Environ.named_context_val env) in + Environ.push_rel_context (Environ.rel_context env) env' + +let fold_match ?(force=false) env sigma c = + let (ci, p, c, brs) = destCase sigma c in + let cty = Retyping.get_type_of env sigma c in + let dep, pred, exists, (sk,eff) = + let env', ctx, body = + let ctx, pred = decompose_lam_assum sigma p in + let env' = push_rel_context ctx env in + env', ctx, pred + in + let sortp = Retyping.get_sort_family_of env' sigma body in + let sortc = Retyping.get_sort_family_of env sigma cty in + let dep = not (noccurn sigma 1 body) in + let pred = if dep then p else + it_mkProd_or_LetIn (subst1 mkProp body) (List.tl ctx) + in + let sk = + if sortp == InProp then + if sortc == InProp then + if dep then case_dep_scheme_kind_from_prop + else case_scheme_kind_from_prop + else ( + if dep + then case_dep_scheme_kind_from_type_in_prop + else case_scheme_kind_from_type) + else ((* sortc <> InProp by typing *) + if dep + then case_dep_scheme_kind_from_type + else case_scheme_kind_from_type) + in + let exists = Ind_tables.check_scheme sk ci.ci_ind in + if exists || force then + dep, pred, exists, Ind_tables.find_scheme sk ci.ci_ind + else raise Not_found + in + let app = + let ind, args = Inductiveops.find_mrectype env sigma cty in + let pars, args = List.chop ci.ci_npar args in + let meths = List.map (fun br -> br) (Array.to_list brs) in + applist (mkConst sk, pars @ [pred] @ meths @ args @ [c]) + in + sk, (if exists then env else reset_env env), app, eff + +let unfold_match env sigma sk app = + match EConstr.kind sigma app with + | App (f', args) when eq_constant (fst (destConst sigma f')) sk -> + let v = Environ.constant_value_in (Global.env ()) (sk,Univ.Instance.empty)(*FIXME*) in + let v = EConstr.of_constr v in + Reductionops.whd_beta sigma (mkApp (v, args)) + | _ -> app + +let is_rew_cast = function RewCast _ -> true | _ -> false + +let subterm all flags (s : 'a pure_strategy) : 'a pure_strategy = + let rec aux { state ; env ; unfresh ; + term1 = t ; ty1 = ty ; cstr = (prop, cstr) ; evars } = + let cstr' = Option.map (fun c -> (ty, Some c)) cstr in + match EConstr.kind (goalevars evars) t with + | App (m, args) -> + let rewrite_args state success = + let state, (args', evars', progress) = + Array.fold_left + (fun (state, (acc, evars, progress)) arg -> + if not (Option.is_empty progress) && not all then + state, (None :: acc, evars, progress) + else + let argty = Retyping.get_type_of env (goalevars evars) arg in + let state, res = s.strategy { state ; env ; + unfresh ; + term1 = arg ; ty1 = argty ; + cstr = (prop,None) ; + evars } in + let res' = + match res with + | Identity -> + let progress = if Option.is_empty progress then Some false else progress in + (None :: acc, evars, progress) + | Success r -> + (Some r :: acc, r.rew_evars, Some true) + | Fail -> (None :: acc, evars, progress) + in state, res') + (state, ([], evars, success)) args + in + let res = + match progress with + | None -> Fail + | Some false -> Identity + | Some true -> + let args' = Array.of_list (List.rev args') in + if Array.exists + (function + | None -> false + | Some r -> not (is_rew_cast r.rew_prf)) args' + then + let evars', prf, car, rel, c1, c2 = + resolve_morphism env unfresh t m args args' (prop, cstr') evars' + in + let res = { rew_car = ty; rew_from = c1; + rew_to = c2; rew_prf = RewPrf (rel, prf); + rew_evars = evars' } + in Success res + else + let args' = Array.map2 + (fun aorig anew -> + match anew with None -> aorig + | Some r -> r.rew_to) args args' + in + let res = { rew_car = ty; rew_from = t; + rew_to = mkApp (m, args'); rew_prf = RewCast DEFAULTcast; + rew_evars = evars' } + in Success res + in state, res + in + if flags.on_morphisms then + let mty = Retyping.get_type_of env (goalevars evars) m in + let evars, cstr', m, mty, argsl, args = + let argsl = Array.to_list args in + let lift = if prop then PropGlobal.lift_cstr else TypeGlobal.lift_cstr in + match lift env evars argsl m mty None with + | Some (evars, cstr', m, mty, args) -> + evars, Some cstr', m, mty, args, Array.of_list args + | None -> evars, None, m, mty, argsl, args + in + let state, m' = s.strategy { state ; env ; unfresh ; + term1 = m ; ty1 = mty ; + cstr = (prop, cstr') ; evars } in + match m' with + | Fail -> rewrite_args state None (* Standard path, try rewrite on arguments *) + | Identity -> rewrite_args state (Some false) + | Success r -> + (* We rewrote the function and get a proof of pointwise rel for the arguments. + We just apply it. *) + let prf = match r.rew_prf with + | RewPrf (rel, prf) -> + let app = if prop then PropGlobal.apply_pointwise + else TypeGlobal.apply_pointwise + in + RewPrf (app (goalevars evars) rel argsl, mkApp (prf, args)) + | x -> x + in + let res = + { rew_car = Reductionops.hnf_prod_appvect env (goalevars evars) r.rew_car args; + rew_from = mkApp(r.rew_from, args); rew_to = mkApp(r.rew_to, args); + rew_prf = prf; rew_evars = r.rew_evars } + in + let res = + match prf with + | RewPrf (rel, prf) -> + Success (apply_constraint env unfresh res.rew_car + rel prf (prop,cstr) res) + | _ -> Success res + in state, res + else rewrite_args state None + + | Prod (n, x, b) when noccurn (goalevars evars) 1 b -> + let b = subst1 mkProp b in + let tx = Retyping.get_type_of env (goalevars evars) x + and tb = Retyping.get_type_of env (goalevars evars) b in + let arr = if prop then PropGlobal.arrow_morphism + else TypeGlobal.arrow_morphism + in + let (evars', mor), unfold = arr env evars tx tb x b in + let state, res = aux { state ; env ; unfresh ; + term1 = mor ; ty1 = ty ; + cstr = (prop,cstr) ; evars = evars' } in + let res = + match res with + | Success r -> Success { r with rew_to = unfold (goalevars r.rew_evars) r.rew_to } + | Fail | Identity -> res + in state, res + + (* if x' = None && flags.under_lambdas then *) + (* let lam = mkLambda (n, x, b) in *) + (* let lam', occ = aux env lam occ None in *) + (* let res = *) + (* match lam' with *) + (* | None -> None *) + (* | Some (prf, (car, rel, c1, c2)) -> *) + (* Some (resolve_morphism env sigma t *) + (* ~fnewt:unfold_all *) + (* (Lazy.force coq_all) [| x ; lam |] [| None; lam' |] *) + (* cstr evars) *) + (* in res, occ *) + (* else *) + + | Prod (n, dom, codom) -> + let lam = mkLambda (n, dom, codom) in + let (evars', app), unfold = + if eq_constr (fst evars) ty 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 + (app_poly_sort prop env evars forall [| dom; lam |]), TypeGlobal.unfold_forall + in + let state, res = aux { state ; env ; unfresh ; + term1 = app ; ty1 = ty ; + cstr = (prop,cstr) ; evars = evars' } in + let res = + match res with + | Success r -> Success { r with rew_to = unfold (goalevars r.rew_evars) r.rew_to } + | Fail | Identity -> res + in state, res + +(* TODO: real rewriting under binders: introduce x x' (H : R x x') and rewrite with + H at any occurrence of x. Ask for (R ==> R') for the lambda. Formalize this. + B. Barras' idea is to have a context of relations, of length 1, with Σ for gluing + dependent relations and using projections to get them out. + *) + (* | Lambda (n, t, b) when flags.under_lambdas -> *) + (* let n' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n in *) + (* let n'' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n' in *) + (* let n''' = name_app (fun id -> Tactics.fresh_id_in_env avoid id env) n'' in *) + (* let rel = new_cstr_evar cstr env (mkApp (Lazy.force coq_relation, [|t|])) in *) + (* let env' = Environ.push_rel_context [(n'',None,lift 2 rel);(n'',None,lift 1 t);(n', None, t)] env in *) + (* let b' = s env' avoid b (Typing.type_of env' (goalevars evars) (lift 2 b)) (unlift_cstr env (goalevars evars) cstr) evars in *) + (* (match b' with *) + (* | Some (Some r) -> *) + (* let prf = match r.rew_prf with *) + (* | RewPrf (rel, prf) -> *) + (* let rel = pointwise_or_dep_relation n' t r.rew_car rel in *) + (* let prf = mkLambda (n', t, prf) in *) + (* RewPrf (rel, prf) *) + (* | x -> x *) + (* in *) + (* Some (Some { r with *) + (* rew_prf = prf; *) + (* rew_car = mkProd (n, t, r.rew_car); *) + (* rew_from = mkLambda(n, t, r.rew_from); *) + (* rew_to = mkLambda (n, t, r.rew_to) }) *) + (* | _ -> b') *) + + | Lambda (n, t, b) when flags.under_lambdas -> + let n' = name_app (fun id -> Tactics.fresh_id_in_env unfresh id env) n in + let open Context.Rel.Declaration in + let env' = EConstr.push_rel (LocalAssum (n', t)) env in + let bty = Retyping.get_type_of env' (goalevars evars) b in + let unlift = if prop then PropGlobal.unlift_cstr else TypeGlobal.unlift_cstr in + let state, b' = s.strategy { state ; env = env' ; unfresh ; + term1 = b ; ty1 = bty ; + cstr = (prop, unlift env evars cstr) ; + evars } in + let res = + match b' with + | Success r -> + let r = match r.rew_prf with + | RewPrf (rel, prf) -> + let point = if prop then PropGlobal.pointwise_or_dep_relation else + TypeGlobal.pointwise_or_dep_relation + in + let evars, rel = point env r.rew_evars n' t r.rew_car rel in + let prf = mkLambda (n', t, prf) in + { r with rew_prf = RewPrf (rel, prf); rew_evars = evars } + | x -> r + in + Success { r with + rew_car = mkProd (n, t, r.rew_car); + rew_from = mkLambda(n, t, r.rew_from); + rew_to = mkLambda (n, t, r.rew_to) } + | Fail | Identity -> b' + in state, res + + | Case (ci, p, c, brs) -> + let cty = Retyping.get_type_of env (goalevars evars) c in + let evars', eqty = app_poly_sort prop env evars coq_eq [| cty |] in + let cstr' = Some eqty in + let state, c' = s.strategy { state ; env ; unfresh ; + term1 = c ; ty1 = cty ; + cstr = (prop, cstr') ; evars = evars' } in + let state, res = + match c' with + | Success r -> + let case = mkCase (ci, lift 1 p, mkRel 1, Array.map (lift 1) brs) in + let res = make_leibniz_proof env case ty r in + state, Success (coerce env unfresh (prop,cstr) res) + | Fail | Identity -> + if Array.for_all (Int.equal 0) ci.ci_cstr_ndecls then + let evars', eqty = app_poly_sort prop env evars coq_eq [| ty |] in + let cstr = Some eqty in + let state, found, brs' = Array.fold_left + (fun (state, found, acc) br -> + if not (Option.is_empty found) then + (state, found, fun x -> lift 1 br :: acc x) + else + let state, res = s.strategy { state ; env ; unfresh ; + term1 = br ; ty1 = ty ; + cstr = (prop,cstr) ; evars } in + match res with + | Success r -> (state, Some r, fun x -> mkRel 1 :: acc x) + | Fail | Identity -> (state, None, fun x -> lift 1 br :: acc x)) + (state, None, fun x -> []) brs + in + match found with + | Some r -> + let ctxc = mkCase (ci, lift 1 p, lift 1 c, Array.of_list (List.rev (brs' c'))) in + state, Success (make_leibniz_proof env ctxc ty r) + | None -> state, c' + else + match try Some (fold_match env (goalevars evars) t) with Not_found -> None with + | None -> state, c' + | Some (cst, _, t', eff (*FIXME*)) -> + let state, res = aux { state ; env ; unfresh ; + term1 = t' ; ty1 = ty ; + cstr = (prop,cstr) ; evars } in + let res = + match res with + | Success prf -> + Success { prf with + rew_from = t; + rew_to = unfold_match env (goalevars evars) cst prf.rew_to } + | x' -> c' + in state, res + in + let res = + match res with + | Success r -> + let rel, prf = get_rew_prf r in + Success (apply_constraint env unfresh r.rew_car rel prf (prop,cstr) r) + | Fail | Identity -> res + in state, res + | _ -> state, Fail + in { strategy = aux } + +let all_subterms = subterm true default_flags +let one_subterm = subterm false default_flags + +(** Requires transitivity of the rewrite step, if not a reduction. + Not tail-recursive. *) + +let transitivity state env unfresh prop (res : rewrite_result_info) (next : 'a pure_strategy) : + 'a * rewrite_result = + let state, nextres = + next.strategy { state ; env ; unfresh ; + term1 = res.rew_to ; ty1 = res.rew_car ; + cstr = (prop, get_opt_rew_rel res.rew_prf) ; + evars = res.rew_evars } + in + let res = + match nextres with + | Fail -> Fail + | Identity -> Success res + | Success res' -> + match res.rew_prf with + | RewCast c -> Success { res' with rew_from = res.rew_from } + | RewPrf (rew_rel, rew_prf) -> + match res'.rew_prf with + | RewCast _ -> Success { res with rew_to = res'.rew_to } + | RewPrf (res'_rel, res'_prf) -> + let trans = + if prop then PropGlobal.transitive_type + else TypeGlobal.transitive_type + in + let evars, prfty = + app_poly_sort prop env res'.rew_evars trans [| res.rew_car; rew_rel |] + in + let evars, prf = new_cstr_evar evars env prfty in + let prf = mkApp (prf, [|res.rew_from; res'.rew_from; res'.rew_to; + rew_prf; res'_prf |]) + in Success { res' with rew_from = res.rew_from; + rew_evars = evars; rew_prf = RewPrf (res'_rel, prf) } + in state, res + +(** Rewriting strategies. + + Inspired by ELAN's rewriting strategies: + http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.21.4049 +*) + +module Strategies = + struct + + let fail : 'a pure_strategy = + { strategy = fun { state } -> state, Fail } + + let id : 'a pure_strategy = + { strategy = fun { state } -> state, Identity } + + let refl : 'a pure_strategy = + { strategy = + fun { state ; env ; + term1 = t ; ty1 = ty ; + cstr = (prop,cstr) ; evars } -> + let evars, rel = match cstr with + | None -> + let mkr = if prop then PropGlobal.mk_relation else TypeGlobal.mk_relation in + let evars, rty = mkr env evars ty in + new_cstr_evar evars env rty + | Some r -> evars, r + in + let evars, proof = + let proxy = + if prop then PropGlobal.proper_proxy_type + else TypeGlobal.proper_proxy_type + in + let evars, mty = app_poly_sort prop env evars proxy [| ty ; rel; t |] in + new_cstr_evar evars env mty + in + let res = Success { rew_car = ty; rew_from = t; rew_to = t; + rew_prf = RewPrf (rel, proof); rew_evars = evars } + in state, res + } + + let progress (s : 'a pure_strategy) : 'a pure_strategy = { strategy = + fun input -> + let state, res = s.strategy input in + match res with + | Fail -> state, Fail + | Identity -> state, Fail + | Success r -> state, Success r + } + + let seq first snd : 'a pure_strategy = { strategy = + fun ({ env ; unfresh ; cstr } as input) -> + let state, res = first.strategy input in + match res with + | Fail -> state, Fail + | Identity -> snd.strategy { input with state } + | Success res -> transitivity state env unfresh (fst cstr) res snd + } + + let choice fst snd : 'a pure_strategy = { strategy = + fun input -> + let state, res = fst.strategy input in + match res with + | Fail -> snd.strategy { input with state } + | Identity | Success _ -> state, res + } + + let try_ str : 'a pure_strategy = choice str id + + let check_interrupt str input = + Control.check_for_interrupt (); + str input + + let fix (f : 'a pure_strategy -> 'a pure_strategy) : 'a pure_strategy = + let rec aux input = (f { strategy = fun input -> check_interrupt aux input }).strategy input in + { strategy = aux } + + let any (s : 'a pure_strategy) : 'a pure_strategy = + fix (fun any -> try_ (seq s any)) + + let repeat (s : 'a pure_strategy) : 'a pure_strategy = + seq s (any s) + + let bu (s : 'a pure_strategy) : 'a pure_strategy = + fix (fun s' -> seq (choice (progress (all_subterms s')) s) (try_ s')) + + let td (s : 'a pure_strategy) : 'a pure_strategy = + fix (fun s' -> seq (choice s (progress (all_subterms s'))) (try_ s')) + + let innermost (s : 'a pure_strategy) : 'a pure_strategy = + fix (fun ins -> choice (one_subterm ins) s) + + let outermost (s : 'a pure_strategy) : 'a pure_strategy = + fix (fun out -> choice s (one_subterm out)) + + let lemmas cs : 'a pure_strategy = + List.fold_left (fun tac (l,l2r,by) -> + choice tac (apply_lemma l2r rewrite_unif_flags l by AllOccurrences)) + fail cs + + let inj_open hint = (); fun sigma -> + let ctx = Evd.evar_universe_context_of hint.Autorewrite.rew_ctx in + let sigma = Evd.merge_universe_context sigma ctx in + (sigma, (EConstr.of_constr hint.Autorewrite.rew_lemma, NoBindings)) + + let old_hints (db : string) : 'a pure_strategy = + let rules = Autorewrite.find_rewrites db in + lemmas + (List.map (fun hint -> (inj_open hint, hint.Autorewrite.rew_l2r, + hint.Autorewrite.rew_tac)) rules) + + let hints (db : string) : 'a pure_strategy = { strategy = + fun ({ term1 = t } as input) -> + let t = EConstr.Unsafe.to_constr t in + let rules = Autorewrite.find_matches db t in + let lemma hint = (inj_open hint, hint.Autorewrite.rew_l2r, + hint.Autorewrite.rew_tac) in + let lems = List.map lemma rules in + (lemmas lems).strategy input + } + + let reduce (r : Redexpr.red_expr) : 'a pure_strategy = { strategy = + fun { state = state ; env = env ; term1 = t ; ty1 = ty ; cstr = cstr ; evars = evars } -> + let rfn, ckind = Redexpr.reduction_of_red_expr env r in + let sigma = Sigma.Unsafe.of_evar_map (goalevars evars) in + let Sigma (t', sigma, _) = rfn.Reductionops.e_redfun env sigma t in + let evars' = Sigma.to_evar_map sigma in + if Termops.eq_constr evars' t' t then + state, Identity + else + state, Success { rew_car = ty; rew_from = t; rew_to = t'; + rew_prf = RewCast ckind; + rew_evars = evars', cstrevars evars } + } + + let fold_glob c : 'a pure_strategy = { strategy = + fun { state ; env ; term1 = t ; ty1 = ty ; cstr ; evars } -> +(* let sigma, (c,_) = Tacinterp.interp_open_constr_with_bindings is env (goalevars evars) c in *) + let sigma, c = Pretyping.understand_tcc env (goalevars evars) c in + let unfolded = + try Tacred.try_red_product env sigma c + with e when CErrors.noncritical e -> + error "fold: the term is not unfoldable !" + in + try + let sigma = Unification.w_unify env sigma CONV ~flags:(Unification.elim_flags ()) unfolded t in + let c' = Reductionops.nf_evar sigma c in + state, Success { rew_car = ty; rew_from = t; rew_to = c'; + rew_prf = RewCast DEFAULTcast; + rew_evars = (sigma, snd evars) } + with e when CErrors.noncritical e -> state, Fail + } + + +end + +(** The strategy for a single rewrite, dealing with occurrences. *) + +(** A dummy initial clauseenv to avoid generating initial evars before + even finding a first application of the rewriting lemma, in setoid_rewrite + mode *) + +let rewrite_with l2r flags c occs : strategy = { strategy = + fun ({ state = () } as input) -> + let unify env evars t = + let (sigma, cstrs) = evars in + let (sigma, rew) = refresh_hypinfo env sigma c in + unify_eqn rew l2r flags env (sigma, cstrs) None t + in + let app = apply_rule unify occs in + let strat = + Strategies.fix (fun aux -> + Strategies.choice app (subterm true default_flags aux)) + in + let _, res = strat.strategy { input with state = 0 } in + ((), res) + } + +let apply_strategy (s : strategy) env unfresh concl (prop, cstr) evars = + let ty = Retyping.get_type_of env (goalevars evars) concl in + let _, res = s.strategy { state = () ; env ; unfresh ; + term1 = concl ; ty1 = ty ; + cstr = (prop, Some cstr) ; evars } in + res + +let solve_constraints env (evars,cstrs) = + let filter = all_constraints cstrs in + Typeclasses.resolve_typeclasses env ~filter ~split:false ~fail:true + (Typeclasses.mark_resolvables ~filter evars) + +let nf_zeta = + Reductionops.clos_norm_flags (CClosure.RedFlags.mkflags [CClosure.RedFlags.fZETA]) + +exception RewriteFailure of Pp.std_ppcmds + +type result = (evar_map * constr option * types) option option + +let cl_rewrite_clause_aux ?(abs=None) strat env avoid sigma concl is_hyp : result = + let evdref = ref sigma in + let sort = Typing.e_sort_of env evdref concl in + let evars = (!evdref, Evar.Set.empty) in + let evars, cstr = + let prop, (evars, arrow) = + if is_prop_sort sort then true, app_poly_sort true env evars impl [||] + else false, app_poly_sort false env evars TypeGlobal.arrow [||] + in + match is_hyp with + | None -> + let evars, t = poly_inverse prop env evars (mkSort sort) arrow in + evars, (prop, t) + | Some _ -> evars, (prop, arrow) + in + let eq = apply_strategy strat env avoid concl cstr evars in + match eq with + | Fail -> None + | Identity -> Some None + | Success res -> + let (_, cstrs) = res.rew_evars in + let evars' = solve_constraints env res.rew_evars in + let newt = Reductionops.nf_evar evars' res.rew_to in + let evars = (* Keep only original evars (potentially instantiated) and goal evars, + the rest has been defined and substituted already. *) + Evar.Set.fold + (fun ev acc -> + if not (Evd.is_defined acc ev) then + user_err ~hdr:"rewrite" + (str "Unsolved constraint remaining: " ++ spc () ++ + Termops.pr_evar_info (Evd.find acc ev)) + else Evd.remove acc ev) + cstrs evars' + in + let res = match res.rew_prf with + | RewCast c -> None + | RewPrf (rel, p) -> + let p = nf_zeta env evars' (Reductionops.nf_evar evars' p) in + let term = + match abs with + | None -> p + | Some (t, ty) -> + let t = Reductionops.nf_evar evars' t in + let ty = Reductionops.nf_evar evars' ty in + mkApp (mkLambda (Name (Id.of_string "lemma"), ty, p), [| t |]) + in + let proof = match is_hyp with + | None -> term + | Some id -> mkApp (term, [| mkVar id |]) + in Some proof + in Some (Some (evars, res, newt)) + +(** Insert a declaration after the last declaration it depends on *) +let rec insert_dependent env sigma decl accu hyps = match hyps with +| [] -> List.rev_append accu [decl] +| ndecl :: rem -> + if occur_var_in_decl env sigma (NamedDecl.get_id ndecl) decl then + List.rev_append accu (decl :: hyps) + else + insert_dependent env sigma decl (ndecl :: accu) rem + +let assert_replacing id newt tac = + let prf = Proofview.Goal.enter { enter = begin fun gl -> + let concl = Proofview.Goal.concl gl in + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let ctx = named_context env in + let after, before = List.split_when (NamedDecl.get_id %> Id.equal id) ctx in + let nc = match before with + | [] -> assert false + | d :: rem -> insert_dependent env sigma (LocalAssum (NamedDecl.get_id d, newt)) [] after @ rem + in + let env' = Environ.reset_with_named_context (val_of_named_context nc) env in + Refine.refine ~unsafe:false { run = begin fun sigma -> + let Sigma (ev, sigma, p) = Evarutil.new_evar env' sigma concl in + let Sigma (ev', sigma, q) = Evarutil.new_evar env sigma newt in + let map d = + let n = NamedDecl.get_id d in + if Id.equal n id then ev' else mkVar n + in + let (e, _) = 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) + +let newfail n s = + Proofview.tclZERO (Refiner.FailError (n, lazy s)) + +let cl_rewrite_clause_newtac ?abs ?origsigma ~progress strat clause = + let open Proofview.Notations in + (** For compatibility *) + let beta_red _ sigma c = Reductionops.nf_betaiota sigma c in + let beta = Tactics.reduct_in_concl (beta_red, DEFAULTcast) in + let beta_hyp id = Tactics.reduct_in_hyp beta_red (id, InHyp) in + let treat sigma res = + match res with + | None -> newfail 0 (str "Nothing to rewrite") + | Some None -> if progress then newfail 0 (str"Failed to progress") + else Proofview.tclUNIT () + | Some (Some res) -> + let (undef, prf, newt) = res in + let fold ev _ accu = if Evd.mem sigma ev then accu else ev :: accu in + let gls = List.rev (Evd.fold_undefined fold undef []) in + match clause, prf with + | Some id, Some p -> + let tac = tclTHENLIST [ + Refine.refine ~unsafe:false { run = fun h -> Sigma.here p h }; + Proofview.Unsafe.tclNEWGOALS gls; + ] in + Proofview.Unsafe.tclEVARS undef <*> + tclTHENFIRST (assert_replacing id newt tac) (beta_hyp id) + | Some id, None -> + Proofview.Unsafe.tclEVARS undef <*> + convert_hyp_no_check (LocalAssum (id, newt)) <*> + beta_hyp id + | None, Some p -> + 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 newt in + Sigma (mkApp (p, [| ev |]), sigma, q) + end } in + Refine.refine ~unsafe:false make <*> Proofview.Unsafe.tclNEWGOALS gls + end } + | None, None -> + Proofview.Unsafe.tclEVARS undef <*> + convert_concl_no_check newt DEFAULTcast + in + Proofview.Goal.enter { enter = begin fun gl -> + let concl = Proofview.Goal.concl gl in + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let ty = match clause with + | None -> concl + | Some id -> EConstr.of_constr (Environ.named_type id env) + in + let env = match clause with + | None -> env + | Some id -> + (** Only consider variables not depending on [id] *) + let ctx = named_context env in + let filter decl = not (occur_var_in_decl env sigma id decl) in + let nctx = List.filter filter ctx in + Environ.reset_with_named_context (val_of_named_context nctx) env + in + try + let res = + cl_rewrite_clause_aux ?abs strat env [] sigma ty clause + in + let sigma = match origsigma with None -> sigma | Some sigma -> sigma in + treat sigma res <*> + (** For compatibility *) + beta <*> Proofview.shelve_unifiable + with + | PretypeError (env, evd, (UnsatisfiableConstraints _ as e)) -> + raise (RewriteFailure (Himsg.explain_pretype_error env evd e)) + end } + +let tactic_init_setoid () = + try init_setoid (); Proofview.tclUNIT () + with e when CErrors.noncritical e -> Tacticals.New.tclFAIL 0 (str"Setoid library not loaded") + +let cl_rewrite_clause_strat progress strat clause = + tactic_init_setoid () <*> + (if progress then Proofview.tclPROGRESS else fun x -> x) + (Proofview.tclOR + (cl_rewrite_clause_newtac ~progress strat clause) + (fun (e, info) -> match e with + | RewriteFailure e -> + tclZEROMSG (str"setoid rewrite failed: " ++ e) + | Refiner.FailError (n, pp) -> + tclFAIL n (str"setoid rewrite failed: " ++ Lazy.force pp) + | e -> Proofview.tclZERO ~info e)) + +(** Setoid rewriting when called with "setoid_rewrite" *) +let cl_rewrite_clause l left2right occs clause = + let strat = rewrite_with left2right (general_rewrite_unif_flags ()) l occs in + cl_rewrite_clause_strat true strat clause + +(** Setoid rewriting when called with "rewrite_strat" *) +let cl_rewrite_clause_strat strat clause = + cl_rewrite_clause_strat false strat clause + +let apply_glob_constr c l2r occs = (); fun ({ state = () ; env = env } as input) -> + let c sigma = + let (sigma, c) = Pretyping.understand_tcc env sigma c in + (sigma, (c, NoBindings)) + in + let flags = general_rewrite_unif_flags () in + (apply_lemma l2r flags c None occs).strategy input + +let interp_glob_constr_list env = + let make c = (); fun sigma -> + let sigma, c = Pretyping.understand_tcc env sigma c in + (sigma, (c, NoBindings)) + in + List.map (fun c -> make c, true, None) + +(* Syntax for rewriting with strategies *) + +type unary_strategy = + Subterms | Subterm | Innermost | Outermost + | Bottomup | Topdown | Progress | Try | Any | Repeat + +type binary_strategy = + | Compose | Choice + +type ('constr,'redexpr) strategy_ast = + | StratId | StratFail | StratRefl + | StratUnary of unary_strategy * ('constr,'redexpr) strategy_ast + | StratBinary of binary_strategy + * ('constr,'redexpr) strategy_ast * ('constr,'redexpr) strategy_ast + | StratConstr of 'constr * bool + | StratTerms of 'constr list + | StratHints of bool * string + | StratEval of 'redexpr + | StratFold of 'constr + +let rec map_strategy (f : 'a -> 'a2) (g : 'b -> 'b2) : ('a,'b) strategy_ast -> ('a2,'b2) strategy_ast = function + | StratId | StratFail | StratRefl as s -> s + | StratUnary (s, str) -> StratUnary (s, map_strategy f g str) + | StratBinary (s, str, str') -> StratBinary (s, map_strategy f g str, map_strategy f g str') + | StratConstr (c, b) -> StratConstr (f c, b) + | StratTerms l -> StratTerms (List.map f l) + | StratHints (b, id) -> StratHints (b, id) + | StratEval r -> StratEval (g r) + | StratFold c -> StratFold (f c) + +let pr_ustrategy = function +| Subterms -> str "subterms" +| Subterm -> str "subterm" +| Innermost -> str "innermost" +| Outermost -> str "outermost" +| Bottomup -> str "bottomup" +| Topdown -> str "topdown" +| Progress -> str "progress" +| Try -> str "try" +| Any -> str "any" +| Repeat -> str "repeat" + +let paren p = str "(" ++ p ++ str ")" + +let rec pr_strategy prc prr = function +| StratId -> str "id" +| StratFail -> str "fail" +| StratRefl -> str "refl" +| StratUnary (s, str) -> + pr_ustrategy s ++ spc () ++ paren (pr_strategy prc prr str) +| StratBinary (Choice, str1, str2) -> + str "choice" ++ spc () ++ paren (pr_strategy prc prr str1) ++ spc () ++ + paren (pr_strategy prc prr str2) +| StratBinary (Compose, str1, str2) -> + pr_strategy prc prr str1 ++ str ";" ++ spc () ++ pr_strategy prc prr str2 +| StratConstr (c, true) -> prc c +| StratConstr (c, false) -> str "<-" ++ spc () ++ prc c +| StratTerms cl -> str "terms" ++ spc () ++ pr_sequence prc cl +| StratHints (old, id) -> + let cmd = if old then "old_hints" else "hints" in + str cmd ++ spc () ++ str id +| StratEval r -> str "eval" ++ spc () ++ prr r +| StratFold c -> str "fold" ++ spc () ++ prc c + +let rec strategy_of_ast = function + | StratId -> Strategies.id + | StratFail -> Strategies.fail + | StratRefl -> Strategies.refl + | StratUnary (f, s) -> + let s' = strategy_of_ast s in + let f' = match f with + | Subterms -> all_subterms + | Subterm -> one_subterm + | Innermost -> Strategies.innermost + | Outermost -> Strategies.outermost + | Bottomup -> Strategies.bu + | Topdown -> Strategies.td + | Progress -> Strategies.progress + | Try -> Strategies.try_ + | Any -> Strategies.any + | Repeat -> Strategies.repeat + in f' s' + | StratBinary (f, s, t) -> + let s' = strategy_of_ast s in + let t' = strategy_of_ast t in + let f' = match f with + | Compose -> Strategies.seq + | Choice -> Strategies.choice + in f' s' t' + | StratConstr (c, b) -> { strategy = apply_glob_constr (fst c) b AllOccurrences } + | StratHints (old, id) -> if old then Strategies.old_hints id else Strategies.hints id + | StratTerms l -> { strategy = + (fun ({ state = () ; env } as input) -> + let l' = interp_glob_constr_list env (List.map fst l) in + (Strategies.lemmas l').strategy input) + } + | StratEval r -> { strategy = + (fun ({ state = () ; env ; evars } as input) -> + let (sigma,r_interp) = Tacinterp.interp_redexp env (goalevars evars) r in + (Strategies.reduce r_interp).strategy { input with + evars = (sigma,cstrevars evars) }) } + | StratFold c -> Strategies.fold_glob (fst c) + + +(* By default the strategy for "rewrite_db" is top-down *) + +let mkappc s l = CAppExpl (Loc.ghost,(None,(Libnames.Ident (Loc.ghost,Id.of_string s)),None),l) + +let declare_an_instance n s args = + (((Loc.ghost,Name n),None), Explicit, + CAppExpl (Loc.ghost, (None, Qualid (Loc.ghost, qualid_of_string s),None), + args)) + +let declare_instance a aeq n s = declare_an_instance n s [a;aeq] + +let anew_instance global binders instance fields = + new_instance (Flags.is_universe_polymorphism ()) + binders instance (Some (true, CRecord (Loc.ghost,fields))) + ~global ~generalize:false ~refine:false Hints.empty_hint_info + +let declare_instance_refl global binders a aeq n lemma = + let instance = declare_instance a aeq (add_suffix n "_Reflexive") "Coq.Classes.RelationClasses.Reflexive" + in anew_instance global binders instance + [(Ident (Loc.ghost,Id.of_string "reflexivity"),lemma)] + +let declare_instance_sym global binders a aeq n lemma = + let instance = declare_instance a aeq (add_suffix n "_Symmetric") "Coq.Classes.RelationClasses.Symmetric" + in anew_instance global binders instance + [(Ident (Loc.ghost,Id.of_string "symmetry"),lemma)] + +let declare_instance_trans global binders a aeq n lemma = + let instance = declare_instance a aeq (add_suffix n "_Transitive") "Coq.Classes.RelationClasses.Transitive" + in anew_instance global binders instance + [(Ident (Loc.ghost,Id.of_string "transitivity"),lemma)] + +let declare_relation ?(binders=[]) a aeq n refl symm trans = + init_setoid (); + let global = not (Locality.make_section_locality (Locality.LocalityFixme.consume ())) in + let instance = declare_instance a aeq (add_suffix n "_relation") "Coq.Classes.RelationClasses.RewriteRelation" + in ignore(anew_instance global binders instance []); + match (refl,symm,trans) with + (None, None, None) -> () + | (Some lemma1, None, None) -> + ignore (declare_instance_refl global binders a aeq n lemma1) + | (None, Some lemma2, None) -> + ignore (declare_instance_sym global binders a aeq n lemma2) + | (None, None, Some lemma3) -> + ignore (declare_instance_trans global binders a aeq n lemma3) + | (Some lemma1, Some lemma2, None) -> + ignore (declare_instance_refl global binders a aeq n lemma1); + ignore (declare_instance_sym global binders a aeq n lemma2) + | (Some lemma1, None, Some lemma3) -> + let _lemma_refl = declare_instance_refl global binders a aeq n lemma1 in + let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in + let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PreOrder" + in ignore( + anew_instance global binders instance + [(Ident (Loc.ghost,Id.of_string "PreOrder_Reflexive"), lemma1); + (Ident (Loc.ghost,Id.of_string "PreOrder_Transitive"),lemma3)]) + | (None, Some lemma2, Some lemma3) -> + let _lemma_sym = declare_instance_sym global binders a aeq n lemma2 in + let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in + let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.PER" + in ignore( + anew_instance global binders instance + [(Ident (Loc.ghost,Id.of_string "PER_Symmetric"), lemma2); + (Ident (Loc.ghost,Id.of_string "PER_Transitive"),lemma3)]) + | (Some lemma1, Some lemma2, Some lemma3) -> + let _lemma_refl = declare_instance_refl global binders a aeq n lemma1 in + let _lemma_sym = declare_instance_sym global binders a aeq n lemma2 in + let _lemma_trans = declare_instance_trans global binders a aeq n lemma3 in + let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" + in ignore( + anew_instance global binders instance + [(Ident (Loc.ghost,Id.of_string "Equivalence_Reflexive"), lemma1); + (Ident (Loc.ghost,Id.of_string "Equivalence_Symmetric"), lemma2); + (Ident (Loc.ghost,Id.of_string "Equivalence_Transitive"), lemma3)]) + +let cHole = CHole (Loc.ghost, None, Misctypes.IntroAnonymous, None) + +let proper_projection sigma r ty = + let rel_vect n m = Array.init m (fun i -> mkRel(n+m-i)) in + let ctx, inst = decompose_prod_assum sigma ty in + let mor, args = destApp sigma inst in + let instarg = mkApp (r, rel_vect 0 (List.length ctx)) in + let app = mkApp (Lazy.force PropGlobal.proper_proj, + Array.append args [| instarg |]) in + it_mkLambda_or_LetIn app ctx + +let declare_projection n instance_id r = + let poly = Global.is_polymorphic r in + let env = Global.env () in + let sigma = Evd.from_env env in + let sigma,c = Evd.fresh_global env sigma r in + let c = EConstr.of_constr c in + let ty = Retyping.get_type_of env sigma c in + let term = proper_projection sigma c ty in + let sigma, typ = Typing.type_of env sigma term in + let ctx, typ = decompose_prod_assum sigma typ in + let typ = + let n = + let rec aux t = + match EConstr.kind sigma t with + | App (f, [| a ; a' ; rel; rel' |]) + when Termops.is_global sigma (PropGlobal.respectful_ref ()) f -> + succ (aux rel') + | _ -> 0 + in + let init = + match EConstr.kind sigma typ with + App (f, args) when Termops.is_global sigma (PropGlobal.respectful_ref ()) f -> + mkApp (f, fst (Array.chop (Array.length args - 2) args)) + | _ -> typ + in aux init + in + let ctx,ccl = Reductionops.splay_prod_n env sigma (3 * n) typ + in it_mkProd_or_LetIn ccl ctx + in + let typ = it_mkProd_or_LetIn typ ctx in + let pl, ctx = Evd.universe_context sigma in + let typ = EConstr.to_constr sigma typ in + let term = EConstr.to_constr sigma term in + let cst = + Declare.definition_entry ~types:typ ~poly ~univs:ctx term + in + ignore(Declare.declare_constant n + (Entries.DefinitionEntry cst, Decl_kinds.IsDefinition Decl_kinds.Definition)) + +let build_morphism_signature env sigma m = + let m,ctx = Constrintern.interp_constr env sigma m in + let m = EConstr.of_constr m in + let sigma = Evd.from_ctx ctx in + let t = Typing.unsafe_type_of env sigma m in + let cstrs = + let rec aux t = + match EConstr.kind sigma t with + | Prod (na, a, b) -> + None :: aux b + | _ -> [] + in aux t + in + let evars, t', sig_, cstrs = + PropGlobal.build_signature (sigma, Evar.Set.empty) env t cstrs None in + let evd = ref evars in + let _ = List.iter + (fun (ty, rel) -> + Option.iter (fun rel -> + let default = e_app_poly env evd PropGlobal.default_relation [| ty; rel |] in + ignore(e_new_cstr_evar env evd default)) + rel) + cstrs + in + let morph = e_app_poly env evd PropGlobal.proper_type [| t; sig_; m |] in + let evd = solve_constraints env !evd in + let evd = Evd.nf_constraints evd in + let m = Evarutil.nf_evars_universes evd (EConstr.Unsafe.to_constr morph) in + Pretyping.check_evars env Evd.empty evd (EConstr.of_constr m); + Evd.evar_universe_context evd, m + +let default_morphism sign m = + let env = Global.env () in + let sigma = Evd.from_env env in + let t = Typing.unsafe_type_of env sigma m in + let evars, _, sign, cstrs = + PropGlobal.build_signature (sigma, Evar.Set.empty) env t (fst sign) (snd sign) + in + let evars, morph = app_poly_check env evars PropGlobal.proper_type [| t; sign; m |] in + let evars, mor = resolve_one_typeclass env (goalevars evars) morph in + mor, proper_projection sigma mor morph + +let add_setoid global binders a aeq t n = + init_setoid (); + let _lemma_refl = declare_instance_refl global binders a aeq n (mkappc "Seq_refl" [a;aeq;t]) in + let _lemma_sym = declare_instance_sym global binders a aeq n (mkappc "Seq_sym" [a;aeq;t]) in + let _lemma_trans = declare_instance_trans global binders a aeq n (mkappc "Seq_trans" [a;aeq;t]) in + let instance = declare_instance a aeq n "Coq.Classes.RelationClasses.Equivalence" + in ignore( + anew_instance global binders instance + [(Ident (Loc.ghost,Id.of_string "Equivalence_Reflexive"), mkappc "Seq_refl" [a;aeq;t]); + (Ident (Loc.ghost,Id.of_string "Equivalence_Symmetric"), mkappc "Seq_sym" [a;aeq;t]); + (Ident (Loc.ghost,Id.of_string "Equivalence_Transitive"), mkappc "Seq_trans" [a;aeq;t])]) + + +let make_tactic name = + let open Tacexpr in + let loc = Loc.ghost in + let tacpath = Libnames.qualid_of_string name in + let tacname = Qualid (loc, tacpath) in + TacArg (loc, TacCall (loc, tacname, [])) + +let add_morphism_infer glob m n = + init_setoid (); + let poly = Flags.is_universe_polymorphism () in + let instance_id = add_suffix n "_Proper" in + let env = Global.env () in + let evd = Evd.from_env env in + let uctx, instance = build_morphism_signature env evd m in + if Lib.is_modtype () then + let cst = Declare.declare_constant ~internal:Declare.InternalTacticRequest instance_id + (Entries.ParameterEntry + (None,poly,(instance,Evd.evar_context_universe_context uctx),None), + Decl_kinds.IsAssumption Decl_kinds.Logical) + in + add_instance (Typeclasses.new_instance + (Lazy.force PropGlobal.proper_class) Hints.empty_hint_info glob + poly (ConstRef cst)); + declare_projection n instance_id (ConstRef cst) + else + let kind = Decl_kinds.Global, poly, + Decl_kinds.DefinitionBody Decl_kinds.Instance + in + let tac = make_tactic "Coq.Classes.SetoidTactics.add_morphism_tactic" in + let hook _ = function + | Globnames.ConstRef cst -> + add_instance (Typeclasses.new_instance + (Lazy.force PropGlobal.proper_class) Hints.empty_hint_info + glob poly (ConstRef cst)); + declare_projection n instance_id (ConstRef cst) + | _ -> assert false + in + let hook = Lemmas.mk_hook hook in + Flags.silently + (fun () -> + Lemmas.start_proof instance_id kind (Evd.from_ctx uctx) (EConstr.of_constr instance) hook; + ignore (Pfedit.by (Tacinterp.interp tac))) () + +let add_morphism glob binders m s n = + init_setoid (); + let poly = Flags.is_universe_polymorphism () in + let instance_id = add_suffix n "_Proper" in + let instance = + (((Loc.ghost,Name instance_id),None), Explicit, + CAppExpl (Loc.ghost, + (None, Qualid (Loc.ghost, Libnames.qualid_of_string "Coq.Classes.Morphisms.Proper"),None), + [cHole; s; m])) + in + let tac = Tacinterp.interp (make_tactic "add_morphism_tactic") in + ignore(new_instance ~global:glob poly binders instance + (Some (true, CRecord (Loc.ghost,[]))) + ~generalize:false ~tac ~hook:(declare_projection n instance_id) Hints.empty_hint_info) + +(** Bind to "rewrite" too *) + +(** Taken from original setoid_replace, to emulate the old rewrite semantics where + lemmas are first instantiated and then rewrite proceeds. *) + +let check_evar_map_of_evars_defs evd = + let metas = Evd.meta_list evd in + let check_freemetas_is_empty rebus = + Evd.Metaset.iter + (fun m -> + if Evd.meta_defined evd m then () else + raise + (Logic.RefinerError (Logic.UnresolvedBindings [Evd.meta_name evd m]))) + in + List.iter + (fun (_,binding) -> + match binding with + Evd.Cltyp (_,{Evd.rebus=rebus; Evd.freemetas=freemetas}) -> + check_freemetas_is_empty rebus freemetas + | Evd.Clval (_,({Evd.rebus=rebus1; Evd.freemetas=freemetas1},_), + {Evd.rebus=rebus2; Evd.freemetas=freemetas2}) -> + check_freemetas_is_empty rebus1 freemetas1 ; + check_freemetas_is_empty rebus2 freemetas2 + ) metas + +(* Find a subterm which matches the pattern to rewrite for "rewrite" *) +let unification_rewrite l2r c1 c2 sigma prf car rel but env = + let (sigma,c') = + try + (* ~flags:(false,true) to allow to mark occurrences that must not be + rewritten simply by replacing them with let-defined definitions + in the context *) + Unification.w_unify_to_subterm + ~flags:rewrite_unif_flags + env sigma ((if l2r then c1 else c2),but) + with + | ex when Pretype_errors.precatchable_exception ex -> + (* ~flags:(true,true) to make Ring work (since it really + exploits conversion) *) + Unification.w_unify_to_subterm + ~flags:rewrite_conv_unif_flags + env sigma ((if l2r then c1 else c2),but) + in + let nf c = Reductionops.nf_evar sigma c in + let c1 = if l2r then nf c' else nf c1 + and c2 = if l2r then nf c2 else nf c' + and car = nf car and rel = nf rel in + check_evar_map_of_evars_defs sigma; + let prf = nf prf in + let prfty = nf (Retyping.get_type_of env sigma prf) in + let sort = sort_of_rel env sigma but in + let abs = prf, prfty in + let prf = mkRel 1 in + let res = (car, rel, prf, c1, c2) in + abs, sigma, res, Sorts.is_prop sort + +let get_hyp gl (c,l) clause l2r = + let evars = Tacmach.New.project gl in + let env = Tacmach.New.pf_env gl in + let sigma, hi = decompose_applied_relation env evars (c,l) in + let but = match clause with + | Some id -> Tacmach.New.pf_get_hyp_typ id gl + | None -> Reductionops.nf_evar evars (Tacmach.New.pf_concl gl) + in + unification_rewrite l2r hi.c1 hi.c2 sigma hi.prf hi.car hi.rel but env + +let general_rewrite_flags = { under_lambdas = false; on_morphisms = true } + +(* let rewriteclaustac_key = Profile.declare_profile "cl_rewrite_clause_tac";; *) +(* let cl_rewrite_clause_tac = Profile.profile5 rewriteclaustac_key cl_rewrite_clause_tac *) + +(** Setoid rewriting when called with "rewrite" *) +let general_s_rewrite cl l2r occs (c,l) ~new_goals = + Proofview.Goal.enter { enter = begin fun gl -> + let abs, evd, res, sort = get_hyp gl (c,l) cl l2r in + let unify env evars t = unify_abs res l2r sort env evars t in + let app = apply_rule unify occs in + let recstrat aux = Strategies.choice app (subterm true general_rewrite_flags aux) in + let substrat = Strategies.fix recstrat in + let strat = { strategy = fun ({ state = () } as input) -> + let _, res = substrat.strategy { input with state = 0 } in + (), res + } + in + let origsigma = Tacmach.New.project gl in + tactic_init_setoid () <*> + Proofview.tclOR + (tclPROGRESS + (tclTHEN + (Proofview.Unsafe.tclEVARS evd) + (cl_rewrite_clause_newtac ~progress:true ~abs:(Some abs) ~origsigma strat cl))) + (fun (e, info) -> match e with + | RewriteFailure e -> + tclFAIL 0 (str"setoid rewrite failed: " ++ e) + | e -> Proofview.tclZERO ~info e) + end } + +let _ = Hook.set Equality.general_setoid_rewrite_clause general_s_rewrite + +(** [setoid_]{reflexivity,symmetry,transitivity} tactics *) + +let not_declared env sigma ty rel = + tclFAIL 0 + (str" The relation " ++ Printer.pr_econstr_env env sigma rel ++ str" is not a declared " ++ + str ty ++ str" relation. Maybe you need to require the Coq.Classes.RelationClasses library") + +let setoid_proof ty fn fallback = + Proofview.Goal.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let concl = Proofview.Goal.concl gl in + Proofview.tclORELSE + begin + try + let rel, _, _ = decompose_app_rel env sigma concl in + let (sigma, t) = Typing.type_of env sigma rel in + let car = snd (List.hd (fst (Reductionops.splay_prod env sigma t))) in + (try init_relation_classes () with _ -> raise Not_found); + fn env sigma car rel + with e -> Proofview.tclZERO e + end + begin function + | e -> + Proofview.tclORELSE + fallback + begin function (e', info) -> match e' with + | Hipattern.NoEquationFound -> + begin match e with + | (Not_found, _) -> + let rel, _, _ = decompose_app_rel env sigma concl in + not_declared env sigma ty rel + | (e, info) -> Proofview.tclZERO ~info e + end + | e' -> Proofview.tclZERO ~info e' + end + end + end } + +let tac_open ((evm,_), c) tac = + (tclTHEN (Proofview.Unsafe.tclEVARS evm) (tac c)) + +let poly_proof getp gett env evm car rel = + if Sorts.is_prop (sort_of_rel env evm rel) then + getp env (evm,Evar.Set.empty) car rel + else gett env (evm,Evar.Set.empty) car rel + +let setoid_reflexivity = + setoid_proof "reflexive" + (fun env evm car rel -> + tac_open (poly_proof PropGlobal.get_reflexive_proof + TypeGlobal.get_reflexive_proof + env evm car rel) + (fun c -> tclCOMPLETE (apply c))) + (reflexivity_red true) + +let setoid_symmetry = + setoid_proof "symmetric" + (fun env evm car rel -> + tac_open + (poly_proof PropGlobal.get_symmetric_proof TypeGlobal.get_symmetric_proof + env evm car rel) + (fun c -> apply c)) + (symmetry_red true) + +let setoid_transitivity c = + setoid_proof "transitive" + (fun env evm car rel -> + 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 ]))) + (transitivity_red true c) + +let setoid_symmetry_in id = + let open Tacmach.New in + Proofview.Goal.enter { enter = begin fun gl -> + let sigma = project gl in + let ctype = pf_unsafe_type_of gl (mkVar id) in + let binders,concl = decompose_prod_assum sigma ctype in + let (equiv, args) = decompose_app sigma concl in + let rec split_last_two = function + | [c1;c2] -> [],(c1, c2) + | x::y::z -> let l,res = split_last_two (y::z) in x::l, res + | _ -> error "Cannot find an equivalence relation to rewrite." + in + let others,(c1,c2) = split_last_two args in + 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 + (tclTHENLAST + (Tactics.assert_after_replacing id new_hyp) + (tclTHENLIST [ intros; setoid_symmetry; apply (mkVar id); Tactics.assumption ])) + end } + +let _ = Hook.set Tactics.setoid_reflexivity setoid_reflexivity +let _ = Hook.set Tactics.setoid_symmetry setoid_symmetry +let _ = Hook.set Tactics.setoid_symmetry_in setoid_symmetry_in +let _ = Hook.set Tactics.setoid_transitivity setoid_transitivity + +let get_lemma_proof f env evm x y = + let (evm, _), c = f env (evm,Evar.Set.empty) x y in + evm, c + +let get_reflexive_proof = + get_lemma_proof PropGlobal.get_reflexive_proof + +let get_symmetric_proof = + get_lemma_proof PropGlobal.get_symmetric_proof + +let get_transitive_proof = + get_lemma_proof PropGlobal.get_transitive_proof + diff --git a/plugins/ltac/rewrite.mli b/plugins/ltac/rewrite.mli new file mode 100644 index 000000000..7a20838a2 --- /dev/null +++ b/plugins/ltac/rewrite.mli @@ -0,0 +1,118 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Names +open Constr +open Environ +open EConstr +open Constrexpr +open Tacexpr +open Misctypes +open Evd +open Proof_type +open Tacinterp + +(** TODO: document and clean me! *) + +type unary_strategy = + Subterms | Subterm | Innermost | Outermost + | Bottomup | Topdown | Progress | Try | Any | Repeat + +type binary_strategy = + | Compose | Choice + +type ('constr,'redexpr) strategy_ast = + | StratId | StratFail | StratRefl + | StratUnary of unary_strategy * ('constr,'redexpr) strategy_ast + | StratBinary of binary_strategy + * ('constr,'redexpr) strategy_ast * ('constr,'redexpr) strategy_ast + | StratConstr of 'constr * bool + | StratTerms of 'constr list + | StratHints of bool * string + | StratEval of 'redexpr + | StratFold of 'constr + +type rewrite_proof = + | RewPrf of constr * constr + | RewCast of cast_kind + +type evars = evar_map * Evar.Set.t (* goal evars, constraint evars *) + +type rewrite_result_info = { + rew_car : constr; + rew_from : constr; + rew_to : constr; + rew_prf : rewrite_proof; + rew_evars : evars; +} + +type rewrite_result = +| Fail +| Identity +| Success of rewrite_result_info + +type strategy + +val strategy_of_ast : (glob_constr_and_expr, raw_red_expr) strategy_ast -> strategy + +val map_strategy : ('a -> 'b) -> ('c -> 'd) -> + ('a, 'c) strategy_ast -> ('b, 'd) strategy_ast + +val pr_strategy : ('a -> Pp.std_ppcmds) -> ('b -> Pp.std_ppcmds) -> + ('a, 'b) strategy_ast -> Pp.std_ppcmds + +(** Entry point for user-level "rewrite_strat" *) +val cl_rewrite_clause_strat : strategy -> Id.t option -> unit Proofview.tactic + +(** Entry point for user-level "setoid_rewrite" *) +val cl_rewrite_clause : + interp_sign * (glob_constr_and_expr * glob_constr_and_expr bindings) -> + bool -> Locus.occurrences -> Id.t option -> unit Proofview.tactic + +val is_applied_rewrite_relation : + env -> evar_map -> rel_context -> constr -> types option + +val declare_relation : + ?binders:local_binder_expr list -> constr_expr -> constr_expr -> Id.t -> + constr_expr option -> constr_expr option -> constr_expr option -> unit + +val add_setoid : + bool -> local_binder_expr list -> constr_expr -> constr_expr -> constr_expr -> + Id.t -> unit + +val add_morphism_infer : bool -> constr_expr -> Id.t -> unit + +val add_morphism : + bool -> local_binder_expr list -> constr_expr -> constr_expr -> Id.t -> unit + +val get_reflexive_proof : env -> evar_map -> constr -> constr -> evar_map * constr + +val get_symmetric_proof : env -> evar_map -> constr -> constr -> evar_map * constr + +val get_transitive_proof : env -> evar_map -> constr -> constr -> evar_map * constr + +val default_morphism : + (types * constr option) option list * (types * types option) option -> + constr -> constr * constr + +val setoid_symmetry : unit Proofview.tactic + +val setoid_symmetry_in : Id.t -> unit Proofview.tactic + +val setoid_reflexivity : unit Proofview.tactic + +val setoid_transitivity : constr option -> unit Proofview.tactic + + +val apply_strategy : + strategy -> + Environ.env -> + Names.Id.t list -> + constr -> + bool * constr -> + evars -> rewrite_result diff --git a/plugins/ltac/tacarg.ml b/plugins/ltac/tacarg.ml new file mode 100644 index 000000000..42552c484 --- /dev/null +++ b/plugins/ltac/tacarg.ml @@ -0,0 +1,26 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Generic arguments based on Ltac. *) + +open Genarg +open Geninterp +open Tacexpr + +let make0 ?dyn name = + let wit = Genarg.make0 name in + let () = Geninterp.register_val0 wit dyn in + wit + +let wit_tactic : (raw_tactic_expr, glob_tactic_expr, Val.t) genarg_type = + make0 "tactic" + +let wit_ltac = make0 ~dyn:(val_tag (topwit Stdarg.wit_unit)) "ltac" + +let wit_destruction_arg = + make0 "destruction_arg" diff --git a/plugins/ltac/tacarg.mli b/plugins/ltac/tacarg.mli new file mode 100644 index 000000000..bfa423db2 --- /dev/null +++ b/plugins/ltac/tacarg.mli @@ -0,0 +1,27 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Genarg +open Tacexpr +open Constrexpr +open Misctypes + +(** Generic arguments based on Ltac. *) + +val wit_tactic : (raw_tactic_expr, glob_tactic_expr, Geninterp.Val.t) genarg_type + +(** [wit_ltac] is subtly different from [wit_tactic]: they only change for their + toplevel interpretation. The one of [wit_ltac] forces the tactic and + discards the result. *) +val wit_ltac : (raw_tactic_expr, glob_tactic_expr, unit) genarg_type + +val wit_destruction_arg : + (constr_expr with_bindings Tacexpr.destruction_arg, + glob_constr_and_expr with_bindings Tacexpr.destruction_arg, + delayed_open_constr_with_bindings Tacexpr.destruction_arg) genarg_type + diff --git a/plugins/ltac/taccoerce.ml b/plugins/ltac/taccoerce.ml new file mode 100644 index 000000000..b76009c99 --- /dev/null +++ b/plugins/ltac/taccoerce.ml @@ -0,0 +1,345 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Util +open Names +open Term +open EConstr +open Pattern +open Misctypes +open Genarg +open Stdarg +open Geninterp + +exception CannotCoerceTo of string + +let (wit_constr_context : (Empty.t, Empty.t, EConstr.constr) Genarg.genarg_type) = + let wit = Genarg.create_arg "constr_context" in + let () = register_val0 wit None in + wit + +(* includes idents known to be bound and references *) +let (wit_constr_under_binders : (Empty.t, Empty.t, constr_under_binders) Genarg.genarg_type) = + let wit = Genarg.create_arg "constr_under_binders" in + let () = register_val0 wit None in + wit + +(** All the types considered here are base types *) +let val_tag wit = match val_tag wit with +| Val.Base t -> t +| _ -> assert false + +let has_type : type a. Val.t -> a typed_abstract_argument_type -> bool = fun v wit -> + let Val.Dyn (t, _) = v in + match Val.eq t (val_tag wit) with + | None -> false + | Some Refl -> true + +let prj : type a. a Val.typ -> Val.t -> a option = fun t v -> + let Val.Dyn (t', x) = v in + match Val.eq t t' with + | None -> None + | Some Refl -> Some x + +let in_gen wit v = Val.Dyn (val_tag wit, v) +let out_gen wit v = match prj (val_tag wit) v with None -> assert false | Some x -> x + +module Value = +struct + +type t = Val.t + +let normalize v = v + +let of_constr c = in_gen (topwit wit_constr) c + +let to_constr v = + let v = normalize v in + if has_type v (topwit wit_constr) then + let c = out_gen (topwit wit_constr) v in + Some c + else if has_type v (topwit wit_constr_under_binders) then + let vars, c = out_gen (topwit wit_constr_under_binders) v in + match vars with [] -> Some c | _ -> None + else None + +let of_uconstr c = in_gen (topwit wit_uconstr) c + +let to_uconstr v = + let v = normalize v in + if has_type v (topwit wit_uconstr) then + Some (out_gen (topwit wit_uconstr) v) + else None + +let of_int i = in_gen (topwit wit_int) i + +let to_int v = + let v = normalize v in + if has_type v (topwit wit_int) then + Some (out_gen (topwit wit_int) v) + else None + +let to_list v = prj Val.typ_list v + +let to_option v = prj Val.typ_opt v + +let to_pair v = prj Val.typ_pair v + +end + +let is_variable env id = + Id.List.mem id (Termops.ids_of_named_context (Environ.named_context env)) + +(* Transforms an id into a constr if possible, or fails with Not_found *) +let constr_of_id env id = + EConstr.mkVar (let _ = Environ.lookup_named id env in id) + +(* Gives the constr corresponding to a Constr_context tactic_arg *) +let coerce_to_constr_context v = + let v = Value.normalize v in + if has_type v (topwit wit_constr_context) then + out_gen (topwit wit_constr_context) v + else raise (CannotCoerceTo "a term context") + +(* Interprets an identifier which must be fresh *) +let coerce_var_to_ident fresh env sigma v = + let v = Value.normalize v in + let fail () = raise (CannotCoerceTo "a fresh identifier") in + if has_type v (topwit wit_intro_pattern) then + match out_gen (topwit wit_intro_pattern) v with + | _, IntroNaming (IntroIdentifier id) -> id + | _ -> fail () + else if has_type v (topwit wit_var) then + out_gen (topwit wit_var) v + else match Value.to_constr v with + | None -> fail () + | Some c -> + (* We need it fresh for intro e.g. in "Tac H = clear H; intro H" *) + if isVar sigma c && not (fresh && is_variable env (destVar sigma c)) then + destVar sigma c + else fail () + + +(* Interprets, if possible, a constr to an identifier which may not + be fresh but suitable to be given to the fresh tactic. Works for + vars, constants, inductive, constructors and sorts. *) +let coerce_to_ident_not_fresh env sigma v = +let g = sigma in +let id_of_name = function + | Names.Anonymous -> Id.of_string "x" + | Names.Name x -> x in + let v = Value.normalize v in + let fail () = raise (CannotCoerceTo "an identifier") in + if has_type v (topwit wit_intro_pattern) then + match out_gen (topwit wit_intro_pattern) v with + | _, IntroNaming (IntroIdentifier id) -> id + | _ -> fail () + else if has_type v (topwit wit_var) then + out_gen (topwit wit_var) v + else + match Value.to_constr v with + | None -> fail () + | Some c -> + match EConstr.kind sigma c with + | Var id -> id + | Meta m -> id_of_name (Evd.meta_name g m) + | Evar (kn,_) -> + begin match Evd.evar_ident kn g with + | None -> fail () + | Some id -> id + end + | Const (cst,_) -> Label.to_id (Constant.label cst) + | Construct (cstr,_) -> + let ref = Globnames.ConstructRef cstr in + let basename = Nametab.basename_of_global ref in + basename + | Ind (ind,_) -> + let ref = Globnames.IndRef ind in + let basename = Nametab.basename_of_global ref in + basename + | Sort s -> + begin + match ESorts.kind sigma s with + | Prop _ -> Label.to_id (Label.make "Prop") + | Type _ -> Label.to_id (Label.make "Type") + end + | _ -> fail() + + +let coerce_to_intro_pattern env sigma v = + let v = Value.normalize v in + if has_type v (topwit wit_intro_pattern) then + snd (out_gen (topwit wit_intro_pattern) v) + else if has_type v (topwit wit_var) then + let id = out_gen (topwit wit_var) v in + IntroNaming (IntroIdentifier id) + else match Value.to_constr v with + | Some c when isVar sigma c -> + (* This happens e.g. in definitions like "Tac H = clear H; intro H" *) + (* but also in "destruct H as (H,H')" *) + IntroNaming (IntroIdentifier (destVar sigma c)) + | _ -> raise (CannotCoerceTo "an introduction pattern") + +let coerce_to_intro_pattern_naming env sigma v = + match coerce_to_intro_pattern env sigma v with + | IntroNaming pat -> pat + | _ -> raise (CannotCoerceTo "a naming introduction pattern") + +let coerce_to_hint_base v = + let v = Value.normalize v in + if has_type v (topwit wit_intro_pattern) then + match out_gen (topwit wit_intro_pattern) v with + | _, IntroNaming (IntroIdentifier id) -> Id.to_string id + | _ -> raise (CannotCoerceTo "a hint base name") + else raise (CannotCoerceTo "a hint base name") + +let coerce_to_int v = + let v = Value.normalize v in + if has_type v (topwit wit_int) then + out_gen (topwit wit_int) v + else raise (CannotCoerceTo "an integer") + +let coerce_to_constr env v = + let v = Value.normalize v in + let fail () = raise (CannotCoerceTo "a term") in + if has_type v (topwit wit_intro_pattern) then + match out_gen (topwit wit_intro_pattern) v with + | _, IntroNaming (IntroIdentifier id) -> + (try ([], constr_of_id env id) with Not_found -> fail ()) + | _ -> fail () + else if has_type v (topwit wit_constr) then + let c = out_gen (topwit wit_constr) v in + ([], c) + else if has_type v (topwit wit_constr_under_binders) then + out_gen (topwit wit_constr_under_binders) v + else if has_type v (topwit wit_var) then + let id = out_gen (topwit wit_var) v in + (try [], constr_of_id env id with Not_found -> fail ()) + else fail () + +let coerce_to_uconstr env v = + let v = Value.normalize v in + if has_type v (topwit wit_uconstr) then + out_gen (topwit wit_uconstr) v + else + raise (CannotCoerceTo "an untyped term") + +let coerce_to_closed_constr env v = + let ids,c = coerce_to_constr env v in + let () = if not (List.is_empty ids) then raise (CannotCoerceTo "a term") in + c + +let coerce_to_evaluable_ref env sigma v = + let fail () = raise (CannotCoerceTo "an evaluable reference") in + let v = Value.normalize v in + let ev = + if has_type v (topwit wit_intro_pattern) then + match out_gen (topwit wit_intro_pattern) v with + | _, IntroNaming (IntroIdentifier id) when is_variable env id -> EvalVarRef id + | _ -> fail () + else if has_type v (topwit wit_var) then + let id = out_gen (topwit wit_var) v in + if Id.List.mem id (Termops.ids_of_context env) then EvalVarRef id + else fail () + else if has_type v (topwit wit_ref) then + let open Globnames in + let r = out_gen (topwit wit_ref) v in + match r with + | VarRef var -> EvalVarRef var + | ConstRef c -> EvalConstRef c + | IndRef _ | ConstructRef _ -> fail () + else + match Value.to_constr v with + | Some c when isConst sigma c -> EvalConstRef (fst (destConst sigma c)) + | Some c when isVar sigma c -> EvalVarRef (destVar sigma c) + | _ -> fail () + in if Tacred.is_evaluable env ev then ev else fail () + +let coerce_to_constr_list env v = + let v = Value.to_list v in + match v with + | Some l -> + let map v = coerce_to_closed_constr env v in + List.map map l + | None -> raise (CannotCoerceTo "a term list") + +let coerce_to_intro_pattern_list loc env sigma v = + match Value.to_list v with + | None -> raise (CannotCoerceTo "an intro pattern list") + | Some l -> + let map v = (loc, coerce_to_intro_pattern env sigma v) in + List.map map l + +let coerce_to_hyp env sigma v = + let fail () = raise (CannotCoerceTo "a variable") in + let v = Value.normalize v in + if has_type v (topwit wit_intro_pattern) then + match out_gen (topwit wit_intro_pattern) v with + | _, IntroNaming (IntroIdentifier id) when is_variable env id -> id + | _ -> fail () + else if has_type v (topwit wit_var) then + let id = out_gen (topwit wit_var) v in + if is_variable env id then id else fail () + else match Value.to_constr v with + | Some c when isVar sigma c -> destVar sigma c + | _ -> fail () + +let coerce_to_hyp_list env sigma v = + let v = Value.to_list v in + match v with + | Some l -> + let map n = coerce_to_hyp env sigma n in + List.map map l + | None -> raise (CannotCoerceTo "a variable list") + +(* Interprets a qualified name *) +let coerce_to_reference env sigma v = + let v = Value.normalize v in + match Value.to_constr v with + | Some c -> + begin + try fst (Termops.global_of_constr sigma c) + with Not_found -> raise (CannotCoerceTo "a reference") + end + | None -> raise (CannotCoerceTo "a reference") + +(* Quantified named or numbered hypothesis or hypothesis in context *) +(* (as in Inversion) *) +let coerce_to_quantified_hypothesis sigma v = + let v = Value.normalize v in + if has_type v (topwit wit_intro_pattern) then + let v = out_gen (topwit wit_intro_pattern) v in + match v with + | _, IntroNaming (IntroIdentifier id) -> NamedHyp id + | _ -> raise (CannotCoerceTo "a quantified hypothesis") + else if has_type v (topwit wit_var) then + let id = out_gen (topwit wit_var) v in + NamedHyp id + else if has_type v (topwit wit_int) then + AnonHyp (out_gen (topwit wit_int) v) + else match Value.to_constr v with + | Some c when isVar sigma c -> NamedHyp (destVar sigma c) + | _ -> raise (CannotCoerceTo "a quantified hypothesis") + +(* Quantified named or numbered hypothesis or hypothesis in context *) +(* (as in Inversion) *) +let coerce_to_decl_or_quant_hyp env sigma v = + let v = Value.normalize v in + if has_type v (topwit wit_int) then + AnonHyp (out_gen (topwit wit_int) v) + else + try coerce_to_quantified_hypothesis sigma v + with CannotCoerceTo _ -> + raise (CannotCoerceTo "a declared or quantified hypothesis") + +let coerce_to_int_or_var_list v = + match Value.to_list v with + | None -> raise (CannotCoerceTo "an int list") + | Some l -> + let map n = ArgArg (coerce_to_int n) in + List.map map l diff --git a/plugins/ltac/taccoerce.mli b/plugins/ltac/taccoerce.mli new file mode 100644 index 000000000..9c4ac5265 --- /dev/null +++ b/plugins/ltac/taccoerce.mli @@ -0,0 +1,97 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Util +open Names +open Term +open EConstr +open Misctypes +open Pattern +open Genarg +open Geninterp + +(** Coercions from highest level generic arguments to actual data used by Ltac + interpretation. Those functions examinate dynamic types and try to return + something sensible according to the object content. *) + +exception CannotCoerceTo of string +(** Exception raised whenever a coercion failed. *) + +(** {5 High-level access to values} + + The [of_*] functions cast a given argument into a value. The [to_*] do the + converse, and return [None] if there is a type mismatch. + +*) + +module Value : +sig + type t = Val.t + + val normalize : t -> t + (** Eliminated the leading dynamic type casts. *) + + val of_constr : constr -> t + val to_constr : t -> constr option + val of_uconstr : Glob_term.closed_glob_constr -> t + val to_uconstr : t -> Glob_term.closed_glob_constr option + val of_int : int -> t + val to_int : t -> int option + val to_list : t -> t list option + val to_option : t -> t option option + val to_pair : t -> (t * t) option +end + +(** {5 Coercion functions} *) + +val coerce_to_constr_context : Value.t -> constr + +val coerce_var_to_ident : bool -> Environ.env -> Evd.evar_map -> Value.t -> Id.t + +val coerce_to_ident_not_fresh : Environ.env -> Evd.evar_map -> Value.t -> Id.t + +val coerce_to_intro_pattern : Environ.env -> Evd.evar_map -> Value.t -> Tacexpr.delayed_open_constr intro_pattern_expr + +val coerce_to_intro_pattern_naming : + Environ.env -> Evd.evar_map -> Value.t -> intro_pattern_naming_expr + +val coerce_to_hint_base : Value.t -> string + +val coerce_to_int : Value.t -> int + +val coerce_to_constr : Environ.env -> Value.t -> constr_under_binders + +val coerce_to_uconstr : Environ.env -> Value.t -> Glob_term.closed_glob_constr + +val coerce_to_closed_constr : Environ.env -> Value.t -> constr + +val coerce_to_evaluable_ref : + Environ.env -> Evd.evar_map -> Value.t -> evaluable_global_reference + +val coerce_to_constr_list : Environ.env -> Value.t -> constr list + +val coerce_to_intro_pattern_list : + Loc.t -> Environ.env -> Evd.evar_map -> Value.t -> Tacexpr.intro_patterns + +val coerce_to_hyp : Environ.env -> Evd.evar_map -> Value.t -> Id.t + +val coerce_to_hyp_list : Environ.env -> Evd.evar_map -> Value.t -> Id.t list + +val coerce_to_reference : Environ.env -> Evd.evar_map -> Value.t -> Globnames.global_reference + +val coerce_to_quantified_hypothesis : Evd.evar_map -> Value.t -> quantified_hypothesis + +val coerce_to_decl_or_quant_hyp : Environ.env -> Evd.evar_map -> Value.t -> quantified_hypothesis + +val coerce_to_int_or_var_list : Value.t -> int or_var list + +(** {5 Missing generic arguments} *) + +val wit_constr_context : (Empty.t, Empty.t, EConstr.constr) genarg_type + +val wit_constr_under_binders : (Empty.t, Empty.t, constr_under_binders) genarg_type diff --git a/plugins/ltac/tacentries.ml b/plugins/ltac/tacentries.ml new file mode 100644 index 000000000..cd8c9e471 --- /dev/null +++ b/plugins/ltac/tacentries.ml @@ -0,0 +1,524 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Pp +open CErrors +open Util +open Names +open Libobject +open Genarg +open Extend +open Pcoq +open Egramml +open Egramcoq +open Vernacexpr +open Libnames +open Nameops + +type 'a grammar_tactic_prod_item_expr = 'a Pptactic.grammar_tactic_prod_item_expr = +| TacTerm of string +| TacNonTerm of Loc.t * 'a * Names.Id.t + +type raw_argument = string * string option +type argument = Genarg.ArgT.any Extend.user_symbol + +(**********************************************************************) +(* Interpret entry names of the form "ne_constr_list" as entry keys *) + +let coincide s pat off = + let len = String.length pat in + let break = ref true in + let i = ref 0 in + while !break && !i < len do + let c = Char.code s.[off + !i] in + let d = Char.code pat.[!i] in + break := Int.equal c d; + incr i + done; + !break + +let atactic n = + if n = 5 then Aentry Pltac.binder_tactic + else Aentryl (Pltac.tactic_expr, n) + +type entry_name = EntryName : + 'a raw_abstract_argument_type * (Tacexpr.raw_tactic_expr, 'a) Extend.symbol -> entry_name + +(** Quite ad-hoc *) +let get_tacentry n m = + let check_lvl n = + Int.equal m n + && not (Int.equal m 5) (* Because tactic5 is at binder_tactic *) + && not (Int.equal m 0) (* Because tactic0 is at simple_tactic *) + in + if check_lvl n then EntryName (rawwit Tacarg.wit_tactic, Aself) + else if check_lvl (n + 1) then EntryName (rawwit Tacarg.wit_tactic, Anext) + else EntryName (rawwit Tacarg.wit_tactic, atactic n) + +let get_separator = function +| None -> error "Missing separator." +| Some sep -> sep + +let rec parse_user_entry s sep = + let l = String.length s in + if l > 8 && coincide s "ne_" 0 && coincide s "_list" (l - 5) then + let entry = parse_user_entry (String.sub s 3 (l-8)) None in + Ulist1 entry + else if l > 12 && coincide s "ne_" 0 && + coincide s "_list_sep" (l-9) then + let entry = parse_user_entry (String.sub s 3 (l-12)) None in + Ulist1sep (entry, get_separator sep) + else if l > 5 && coincide s "_list" (l-5) then + let entry = parse_user_entry (String.sub s 0 (l-5)) None in + Ulist0 entry + else if l > 9 && coincide s "_list_sep" (l-9) then + let entry = parse_user_entry (String.sub s 0 (l-9)) None in + Ulist0sep (entry, get_separator sep) + else if l > 4 && coincide s "_opt" (l-4) then + let entry = parse_user_entry (String.sub s 0 (l-4)) None in + Uopt entry + else if Int.equal l 7 && coincide s "tactic" 0 && '5' >= s.[6] && s.[6] >= '0' then + let n = Char.code s.[6] - 48 in + Uentryl ("tactic", n) + else + Uentry s + +let arg_list = function Rawwit t -> Rawwit (ListArg t) +let arg_opt = function Rawwit t -> Rawwit (OptArg t) + +let interp_entry_name interp symb = + let rec eval = function + | Ulist1 e -> Ulist1 (eval e) + | Ulist1sep (e, sep) -> Ulist1sep (eval e, sep) + | Ulist0 e -> Ulist0 (eval e) + | Ulist0sep (e, sep) -> Ulist0sep (eval e, sep) + | Uopt e -> Uopt (eval e) + | Uentry s -> Uentry (interp s None) + | Uentryl (s, n) -> Uentryl (interp s (Some n), n) + in + eval symb + +(**********************************************************************) +(** Grammar declaration for Tactic Notation (Coq level) *) + +let get_tactic_entry n = + if Int.equal n 0 then + Pltac.simple_tactic, None + else if Int.equal n 5 then + Pltac.binder_tactic, None + else if 1<=n && n<5 then + Pltac.tactic_expr, Some (Extend.Level (string_of_int n)) + else + error ("Invalid Tactic Notation level: "^(string_of_int n)^".") + +(**********************************************************************) +(** State of the grammar extensions *) + +type tactic_grammar = { + tacgram_level : int; + tacgram_prods : Pptactic.grammar_terminals; +} + +(* Declaration of the tactic grammar rule *) + +let head_is_ident tg = match tg.tacgram_prods with +| TacTerm _ :: _ -> true +| _ -> false + +let rec prod_item_of_symbol lev = function +| Extend.Ulist1 s -> + let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in + EntryName (Rawwit (ListArg typ), Alist1 e) +| Extend.Ulist0 s -> + let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in + EntryName (Rawwit (ListArg typ), Alist0 e) +| Extend.Ulist1sep (s, sep) -> + let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in + EntryName (Rawwit (ListArg typ), Alist1sep (e, Atoken (CLexer.terminal sep))) +| Extend.Ulist0sep (s, sep) -> + let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in + EntryName (Rawwit (ListArg typ), Alist0sep (e, Atoken (CLexer.terminal sep))) +| Extend.Uopt s -> + let EntryName (Rawwit typ, e) = prod_item_of_symbol lev s in + EntryName (Rawwit (OptArg typ), Aopt e) +| Extend.Uentry arg -> + let ArgT.Any tag = arg in + let wit = ExtraArg tag in + EntryName (Rawwit wit, Extend.Aentry (genarg_grammar wit)) +| Extend.Uentryl (s, n) -> + let ArgT.Any tag = s in + assert (coincide (ArgT.repr tag) "tactic" 0); + get_tacentry n lev + +(** Tactic grammar extensions *) + +let add_tactic_entry (kn, ml, tg) state = + let open Tacexpr in + let entry, pos = get_tactic_entry tg.tacgram_level in + let mkact loc l = + let map arg = + (** HACK to handle especially the tactic(...) entry *) + let wit = Genarg.rawwit Tacarg.wit_tactic in + if Genarg.has_type arg wit && not ml then + Tacexp (Genarg.out_gen wit arg) + else + TacGeneric arg + in + let l = List.map map l in + (TacAlias (loc,kn,l):raw_tactic_expr) + in + let () = + if Int.equal tg.tacgram_level 0 && not (head_is_ident tg) then + error "Notation for simple tactic must start with an identifier." + in + let map = function + | TacTerm s -> GramTerminal s + | TacNonTerm (loc, s, _) -> + let EntryName (typ, e) = prod_item_of_symbol tg.tacgram_level s in + GramNonTerminal (loc, typ, e) + in + let prods = List.map map tg.tacgram_prods in + let rules = make_rule mkact prods in + let r = ExtendRule (entry, None, (pos, [(None, None, [rules])])) in + ([r], state) + +let tactic_grammar = + create_grammar_command "TacticGrammar" add_tactic_entry + +let extend_tactic_grammar kn ml ntn = extend_grammar_command tactic_grammar (kn, ml, ntn) + +(**********************************************************************) +(* Tactic Notation *) + +let entry_names = ref String.Map.empty + +let register_tactic_notation_entry name entry = + let entry = match entry with + | ExtraArg arg -> ArgT.Any arg + | _ -> assert false + in + entry_names := String.Map.add name entry !entry_names + +let interp_prod_item = function + | TacTerm s -> TacTerm s + | TacNonTerm (loc, (nt, sep), id) -> + let symbol = parse_user_entry nt sep in + let interp s = function + | None -> + if String.Map.mem s !entry_names then String.Map.find s !entry_names + else begin match ArgT.name s with + | None -> error ("Unknown entry "^s^".") + | Some arg -> arg + end + | Some n -> + (** FIXME: do better someday *) + assert (String.equal s "tactic"); + begin match Tacarg.wit_tactic with + | ExtraArg tag -> ArgT.Any tag + | _ -> assert false + end + in + let symbol = interp_entry_name interp symbol in + TacNonTerm (loc, symbol, id) + +let make_fresh_key = + let id = Summary.ref ~name:"TACTIC-NOTATION-COUNTER" 0 in + fun prods -> + let cur = incr id; !id in + let map = function + | TacTerm s -> s + | TacNonTerm _ -> "#" + in + let prods = String.concat "_" (List.map map prods) in + (** We embed the hash of the kernel name in the label so that the identifier + should be mostly unique. This ensures that including two modules + together won't confuse the corresponding labels. *) + let hash = (cur lxor (ModPath.hash (Lib.current_mp ()))) land 0x7FFFFFFF in + let lbl = Id.of_string_soft (Printf.sprintf "%s_%08X" prods hash) in + Lib.make_kn lbl + +type tactic_grammar_obj = { + tacobj_key : KerName.t; + tacobj_local : locality_flag; + tacobj_tacgram : tactic_grammar; + tacobj_body : Id.t list * Tacexpr.glob_tactic_expr; + tacobj_forml : bool; +} + +let pprule pa = { + Pptactic.pptac_level = pa.tacgram_level; + pptac_prods = pa.tacgram_prods; +} + +let check_key key = + if Tacenv.check_alias key then + error "Conflicting tactic notations keys. This can happen when including \ + twice the same module." + +let cache_tactic_notation (_, tobj) = + let key = tobj.tacobj_key in + let () = check_key key in + Tacenv.register_alias key tobj.tacobj_body; + extend_tactic_grammar key tobj.tacobj_forml tobj.tacobj_tacgram; + Pptactic.declare_notation_tactic_pprule key (pprule tobj.tacobj_tacgram) + +let open_tactic_notation i (_, tobj) = + let key = tobj.tacobj_key in + if Int.equal i 1 && not tobj.tacobj_local then + extend_tactic_grammar key tobj.tacobj_forml tobj.tacobj_tacgram + +let load_tactic_notation i (_, tobj) = + let key = tobj.tacobj_key in + let () = check_key key in + (** Only add the printing and interpretation rules. *) + Tacenv.register_alias key tobj.tacobj_body; + Pptactic.declare_notation_tactic_pprule key (pprule tobj.tacobj_tacgram); + if Int.equal i 1 && not tobj.tacobj_local then + extend_tactic_grammar key tobj.tacobj_forml tobj.tacobj_tacgram + +let subst_tactic_notation (subst, tobj) = + let (ids, body) = tobj.tacobj_body in + { tobj with + tacobj_key = Mod_subst.subst_kn subst tobj.tacobj_key; + tacobj_body = (ids, Tacsubst.subst_tactic subst body); + } + +let classify_tactic_notation tacobj = Substitute tacobj + +let inTacticGrammar : tactic_grammar_obj -> obj = + declare_object {(default_object "TacticGrammar") with + open_function = open_tactic_notation; + load_function = load_tactic_notation; + cache_function = cache_tactic_notation; + subst_function = subst_tactic_notation; + classify_function = classify_tactic_notation} + +let cons_production_parameter = function +| TacTerm _ -> None +| TacNonTerm (_, _, id) -> Some id + +let add_glob_tactic_notation local ~level prods forml ids tac = + let parule = { + tacgram_level = level; + tacgram_prods = prods; + } in + let tacobj = { + tacobj_key = make_fresh_key prods; + tacobj_local = local; + tacobj_tacgram = parule; + tacobj_body = (ids, tac); + tacobj_forml = forml; + } in + Lib.add_anonymous_leaf (inTacticGrammar tacobj) + +let add_tactic_notation local n prods e = + let ids = List.map_filter cons_production_parameter prods in + let prods = List.map interp_prod_item prods in + let tac = Tacintern.glob_tactic_env ids (Global.env()) e in + add_glob_tactic_notation local n prods false ids tac + +(**********************************************************************) +(* ML Tactic entries *) + +exception NonEmptyArgument + +(** ML tactic notations whose use can be restricted to an identifier are added + as true Ltac entries. *) +let extend_atomic_tactic name entries = + let open Tacexpr in + let map_prod prods = + let (hd, rem) = match prods with + | TacTerm s :: rem -> (s, rem) + | _ -> assert false (** Not handled by the ML extension syntax *) + in + let empty_value = function + | TacTerm s -> raise NonEmptyArgument + | TacNonTerm (_, symb, _) -> + let EntryName (typ, e) = prod_item_of_symbol 0 symb in + let Genarg.Rawwit wit = typ in + let inj x = TacArg (Loc.ghost, TacGeneric (Genarg.in_gen typ x)) in + let default = epsilon_value inj e in + match default with + | None -> raise NonEmptyArgument + | Some def -> Tacintern.intern_tactic_or_tacarg Tacintern.fully_empty_glob_sign def + in + try Some (hd, List.map empty_value rem) with NonEmptyArgument -> None + in + let entries = List.map map_prod entries in + let add_atomic i args = match args with + | None -> () + | Some (id, args) -> + let args = List.map (fun a -> Tacexp a) args in + let entry = { mltac_name = name; mltac_index = i } in + let body = TacML (Loc.ghost, entry, args) in + Tacenv.register_ltac false false (Names.Id.of_string id) body + in + List.iteri add_atomic entries + +let add_ml_tactic_notation name ~level prods = + let len = List.length prods in + let iter i prods = + let open Tacexpr in + let get_id = function + | TacTerm s -> None + | TacNonTerm (_, _, id) -> Some id + in + let ids = List.map_filter get_id prods in + let entry = { mltac_name = name; mltac_index = len - i - 1 } in + let map id = Reference (Misctypes.ArgVar (Loc.ghost, id)) in + let tac = TacML (Loc.ghost, entry, List.map map ids) in + add_glob_tactic_notation false ~level prods true ids tac + in + List.iteri iter (List.rev prods); + (** We call [extend_atomic_tactic] only for "basic tactics" (the ones at + tactic_expr level 0) *) + if Int.equal level 0 then extend_atomic_tactic name prods + +(**********************************************************************) +(** Ltac quotations *) + +let ltac_quotations = ref String.Set.empty + +let create_ltac_quotation name cast (e, l) = + let () = + if String.Set.mem name !ltac_quotations then + failwith ("Ltac quotation " ^ name ^ " already registered") + in + let () = ltac_quotations := String.Set.add name !ltac_quotations in + let entry = match l with + | None -> Aentry e + | Some l -> Aentryl (e, l) + in +(* let level = Some "1" in *) + let level = None in + let assoc = None in + let rule = + Next (Next (Next (Next (Next (Stop, + Atoken (CLexer.terminal name)), + Atoken (CLexer.terminal ":")), + Atoken (CLexer.terminal "(")), + entry), + Atoken (CLexer.terminal ")")) + in + let action _ v _ _ _ loc = cast (loc, v) in + let gram = (level, assoc, [Rule (rule, action)]) in + Pcoq.grammar_extend Pltac.tactic_arg None (None, [gram]) + +(** Command *) + + +type tacdef_kind = + | NewTac of Id.t + | UpdateTac of Nametab.ltac_constant + +let is_defined_tac kn = + try ignore (Tacenv.interp_ltac kn); true with Not_found -> false + +let warn_unusable_identifier = + CWarnings.create ~name:"unusable-identifier" ~category:"parsing" + (fun id -> strbrk "The Ltac name" ++ spc () ++ pr_id id ++ spc () ++ + strbrk "may be unusable because of a conflict with a notation.") + +let register_ltac local tacl = + let map tactic_body = + match tactic_body with + | Tacexpr.TacticDefinition ((loc,id), body) -> + let kn = Lib.make_kn id in + let id_pp = pr_id id in + let () = if is_defined_tac kn then + CErrors.user_err ~loc + (str "There is already an Ltac named " ++ id_pp ++ str".") + in + let is_shadowed = + try + match Pcoq.parse_string Pltac.tactic (Id.to_string id) with + | Tacexpr.TacArg _ -> false + | _ -> true (* most probably TacAtom, i.e. a primitive tactic ident *) + with e when CErrors.noncritical e -> true (* prim tactics with args, e.g. "apply" *) + in + let () = if is_shadowed then warn_unusable_identifier id in + NewTac id, body + | Tacexpr.TacticRedefinition (ident, body) -> + let loc = loc_of_reference ident in + let kn = + try Nametab.locate_tactic (snd (qualid_of_reference ident)) + with Not_found -> + CErrors.user_err ~loc + (str "There is no Ltac named " ++ pr_reference ident ++ str ".") + in + UpdateTac kn, body + in + let rfun = List.map map tacl in + let recvars = + let fold accu (op, _) = match op with + | UpdateTac _ -> accu + | NewTac id -> (Lib.make_path id, Lib.make_kn id) :: accu + in + List.fold_left fold [] rfun + in + let ist = Tacintern.make_empty_glob_sign () in + let map (name, body) = + let body = Flags.with_option Tacintern.strict_check (Tacintern.intern_tactic_or_tacarg ist) body in + (name, body) + in + let defs () = + (** Register locally the tactic to handle recursivity. This function affects + the whole environment, so that we transactify it afterwards. *) + let iter_rec (sp, kn) = Nametab.push_tactic (Nametab.Until 1) sp kn in + let () = List.iter iter_rec recvars in + List.map map rfun + in + let defs = Future.transactify defs () in + let iter (def, tac) = match def with + | NewTac id -> + Tacenv.register_ltac false local id tac; + Flags.if_verbose Feedback.msg_info (Nameops.pr_id id ++ str " is defined") + | UpdateTac kn -> + Tacenv.redefine_ltac local kn tac; + let name = Nametab.shortest_qualid_of_tactic kn in + Flags.if_verbose Feedback.msg_info (Libnames.pr_qualid name ++ str " is redefined") + in + List.iter iter defs + +(** Queries *) + +let print_ltacs () = + let entries = KNmap.bindings (Tacenv.ltac_entries ()) in + let sort (kn1, _) (kn2, _) = KerName.compare kn1 kn2 in + let entries = List.sort sort entries in + let map (kn, entry) = + let qid = + try Some (Nametab.shortest_qualid_of_tactic kn) + with Not_found -> None + in + match qid with + | None -> None + | Some qid -> Some (qid, entry.Tacenv.tac_body) + in + let entries = List.map_filter map entries in + let pr_entry (qid, body) = + let (l, t) = match body with + | Tacexpr.TacFun (l, t) -> (l, t) + | _ -> ([], body) + in + let pr_ltac_fun_arg n = spc () ++ pr_name n in + hov 2 (pr_qualid qid ++ prlist pr_ltac_fun_arg l) + in + Feedback.msg_notice (prlist_with_sep fnl pr_entry entries) + +(** Grammar *) + +let () = + let open Metasyntax in + let entries = [ + AnyEntry Pltac.tactic_expr; + AnyEntry Pltac.binder_tactic; + AnyEntry Pltac.simple_tactic; + AnyEntry Pltac.tactic_arg; + ] in + register_grammar "tactic" entries diff --git a/plugins/ltac/tacentries.mli b/plugins/ltac/tacentries.mli new file mode 100644 index 000000000..069504473 --- /dev/null +++ b/plugins/ltac/tacentries.mli @@ -0,0 +1,64 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** Ltac toplevel command entries. *) + +open Vernacexpr +open Tacexpr + +(** {5 Tactic Definitions} *) + +val register_ltac : locality_flag -> Tacexpr.tacdef_body list -> unit +(** Adds new Ltac definitions to the environment. *) + +(** {5 Tactic Notations} *) + +type 'a grammar_tactic_prod_item_expr = 'a Pptactic.grammar_tactic_prod_item_expr = +| TacTerm of string +| TacNonTerm of Loc.t * 'a * Names.Id.t + +type raw_argument = string * string option +(** An argument type as provided in Tactic notations, i.e. a string like + "ne_foo_list_opt" together with a separator that only makes sense in the + "_sep" cases. *) + +type argument = Genarg.ArgT.any Extend.user_symbol +(** A fully resolved argument type given as an AST with generic arguments on the + leaves. *) + +val add_tactic_notation : + locality_flag -> int -> raw_argument grammar_tactic_prod_item_expr list -> + raw_tactic_expr -> unit +(** [add_tactic_notation local level prods expr] adds a tactic notation in the + environment at level [level] with locality [local] made of the grammar + productions [prods] and returning the body [expr] *) + +val register_tactic_notation_entry : string -> ('a, 'b, 'c) Genarg.genarg_type -> unit +(** Register an argument under a given entry name for tactic notations. When + translating [raw_argument] into [argument], atomic names will be first + looked up according to names registered through this function and fallback + to finding an argument by name (as in {!Genarg}) if there is none + matching. *) + +val add_ml_tactic_notation : ml_tactic_name -> level:int -> + argument grammar_tactic_prod_item_expr list list -> unit +(** A low-level variant of {!add_tactic_notation} used by the TACTIC EXTEND + ML-side macro. *) + +(** {5 Tactic Quotations} *) + +val create_ltac_quotation : string -> + ('grm Loc.located -> raw_tactic_arg) -> ('grm Pcoq.Gram.entry * int option) -> unit +(** [create_ltac_quotation name f e] adds a quotation rule to Ltac, that is, + Ltac grammar now accepts arguments of the form ["name" ":" "(" <e> ")"], and + generates an argument using [f] on the entry parsed by [e]. *) + +(** {5 Queries} *) + +val print_ltacs : unit -> unit +(** Display the list of ltac definitions currently available. *) diff --git a/plugins/ltac/tacenv.ml b/plugins/ltac/tacenv.ml new file mode 100644 index 000000000..e3c2b4ad5 --- /dev/null +++ b/plugins/ltac/tacenv.ml @@ -0,0 +1,143 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Util +open Pp +open Names +open Tacexpr + +(** Tactic notations (TacAlias) *) + +type alias = KerName.t +type alias_tactic = Id.t list * glob_tactic_expr + +let alias_map = Summary.ref ~name:"tactic-alias" + (KNmap.empty : alias_tactic KNmap.t) + +let register_alias key tac = + alias_map := KNmap.add key tac !alias_map + +let interp_alias key = + try KNmap.find key !alias_map + with Not_found -> CErrors.anomaly (str "Unknown tactic alias: " ++ KerName.print key) + +let check_alias key = KNmap.mem key !alias_map + +(** ML tactic extensions (TacML) *) + +type ml_tactic = + Geninterp.Val.t list -> Geninterp.interp_sign -> unit Proofview.tactic + +module MLName = +struct + type t = ml_tactic_name + let compare tac1 tac2 = + let c = String.compare tac1.mltac_tactic tac2.mltac_tactic in + if c = 0 then String.compare tac1.mltac_plugin tac2.mltac_plugin + else c +end + +module MLTacMap = Map.Make(MLName) + +let pr_tacname t = + str t.mltac_plugin ++ str "::" ++ str t.mltac_tactic + +let tac_tab = ref MLTacMap.empty + +let register_ml_tactic ?(overwrite = false) s (t : ml_tactic array) = + let () = + if MLTacMap.mem s !tac_tab then + if overwrite then + tac_tab := MLTacMap.remove s !tac_tab + else + CErrors.anomaly (str "Cannot redeclare tactic " ++ pr_tacname s ++ str ".") + in + tac_tab := MLTacMap.add s t !tac_tab + +let interp_ml_tactic { mltac_name = s; mltac_index = i } = + try + let tacs = MLTacMap.find s !tac_tab in + let () = if Array.length tacs <= i then raise Not_found in + tacs.(i) + with Not_found -> + CErrors.user_err + (str "The tactic " ++ pr_tacname s ++ str " is not installed.") + +(***************************************************************************) +(* Tactic registration *) + +(* Summary and Object declaration *) + +open Nametab +open Libobject + +type ltac_entry = { + tac_for_ml : bool; + tac_body : glob_tactic_expr; + tac_redef : ModPath.t list; +} + +let mactab = + Summary.ref (KNmap.empty : ltac_entry KNmap.t) + ~name:"tactic-definition" + +let ltac_entries () = !mactab + +let interp_ltac r = (KNmap.find r !mactab).tac_body + +let is_ltac_for_ml_tactic r = (KNmap.find r !mactab).tac_for_ml + +let add kn b t = + let entry = { tac_for_ml = b; tac_body = t; tac_redef = [] } in + mactab := KNmap.add kn entry !mactab + +let replace kn path t = + let (path, _, _) = KerName.repr path in + let entry _ e = { e with tac_body = t; tac_redef = path :: e.tac_redef } in + mactab := KNmap.modify kn entry !mactab + +let load_md i ((sp, kn), (local, id, b, t)) = match id with +| None -> + let () = if not local then Nametab.push_tactic (Until i) sp kn in + add kn b t +| Some kn0 -> replace kn0 kn t + +let open_md i ((sp, kn), (local, id, b, t)) = match id with +| None -> + let () = if not local then Nametab.push_tactic (Exactly i) sp kn in + add kn b t +| Some kn0 -> replace kn0 kn t + +let cache_md ((sp, kn), (local, id ,b, t)) = match id with +| None -> + let () = Nametab.push_tactic (Until 1) sp kn in + add kn b t +| Some kn0 -> replace kn0 kn t + +let subst_kind subst id = match id with +| None -> None +| Some kn -> Some (Mod_subst.subst_kn subst kn) + +let subst_md (subst, (local, id, b, t)) = + (local, subst_kind subst id, b, Tacsubst.subst_tactic subst t) + +let classify_md (local, _, _, _ as o) = Substitute o + +let inMD : bool * Nametab.ltac_constant option * bool * glob_tactic_expr -> obj = + declare_object {(default_object "TAC-DEFINITION") with + cache_function = cache_md; + load_function = load_md; + open_function = open_md; + subst_function = subst_md; + classify_function = classify_md} + +let register_ltac for_ml local id tac = + ignore (Lib.add_leaf id (inMD (local, None, for_ml, tac))) + +let redefine_ltac local kn tac = + Lib.add_anonymous_leaf (inMD (local, Some kn, false, tac)) diff --git a/plugins/ltac/tacenv.mli b/plugins/ltac/tacenv.mli new file mode 100644 index 000000000..94e14223a --- /dev/null +++ b/plugins/ltac/tacenv.mli @@ -0,0 +1,75 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Genarg +open Names +open Tacexpr +open Geninterp + +(** This module centralizes the various ways of registering tactics. *) + +(** {5 Tactic notations} *) + +type alias = KerName.t +(** Type of tactic alias, used in the [TacAlias] node. *) + +type alias_tactic = Id.t list * glob_tactic_expr +(** Contents of a tactic notation *) + +val register_alias : alias -> alias_tactic -> unit +(** Register a tactic alias. *) + +val interp_alias : alias -> alias_tactic +(** Recover the the body of an alias. Raises an anomaly if it does not exist. *) + +val check_alias : alias -> bool +(** Returns [true] if an alias is defined, false otherwise. *) + +(** {5 Coq tactic definitions} *) + +val register_ltac : bool -> bool -> Id.t -> glob_tactic_expr -> unit +(** Register a new Ltac with the given name and body. + + The first boolean indicates whether this is done from ML side, rather than + Coq side. If the second boolean flag is set to true, then this is a local + definition. It also puts the Ltac name in the nametab, so that it can be + used unqualified. *) + +val redefine_ltac : bool -> KerName.t -> glob_tactic_expr -> unit +(** Replace a Ltac with the given name and body. If the boolean flag is set + to true, then this is a local redefinition. *) + +val interp_ltac : KerName.t -> glob_tactic_expr +(** Find a user-defined tactic by name. Raise [Not_found] if it is absent. *) + +val is_ltac_for_ml_tactic : KerName.t -> bool +(** Whether the tactic is defined from ML-side *) + +type ltac_entry = { + tac_for_ml : bool; + (** Whether the tactic is defined from ML-side *) + tac_body : glob_tactic_expr; + (** The current body of the tactic *) + tac_redef : ModPath.t list; + (** List of modules redefining the tactic in reverse chronological order *) +} + +val ltac_entries : unit -> ltac_entry KNmap.t +(** Low-level access to all Ltac entries currently defined. *) + +(** {5 ML tactic extensions} *) + +type ml_tactic = + Val.t list -> Geninterp.interp_sign -> unit Proofview.tactic +(** Type of external tactics, used by [TacML]. *) + +val register_ml_tactic : ?overwrite:bool -> ml_tactic_name -> ml_tactic array -> unit +(** Register an external tactic. *) + +val interp_ml_tactic : ml_tactic_entry -> ml_tactic +(** Get the named tactic. Raises a user error if it does not exist. *) diff --git a/plugins/ltac/tacexpr.mli b/plugins/ltac/tacexpr.mli new file mode 100644 index 000000000..8aefe7605 --- /dev/null +++ b/plugins/ltac/tacexpr.mli @@ -0,0 +1,396 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Loc +open Names +open Constrexpr +open Libnames +open Nametab +open Genredexpr +open Genarg +open Pattern +open Misctypes +open Locus + +type direction_flag = bool (* true = Left-to-right false = right-to-right *) +type lazy_flag = + | General (* returns all possible successes *) + | Select (* returns all successes of the first matching branch *) + | Once (* returns the first success in a maching branch + (not necessarily the first) *) +type global_flag = (* [gfail] or [fail] *) + | TacGlobal + | TacLocal +type evars_flag = bool (* true = pose evars false = fail on evars *) +type rec_flag = bool (* true = recursive false = not recursive *) +type advanced_flag = bool (* true = advanced false = basic *) +type letin_flag = bool (* true = use local def false = use Leibniz *) +type clear_flag = bool option (* true = clear hyp, false = keep hyp, None = use default *) + +type goal_selector = Vernacexpr.goal_selector = + | SelectNth of int + | SelectList of (int * int) list + | SelectId of Id.t + | SelectAll + +type 'a core_destruction_arg = 'a Misctypes.core_destruction_arg = + | ElimOnConstr of 'a + | ElimOnIdent of Id.t located + | ElimOnAnonHyp of int + +type 'a destruction_arg = + clear_flag * 'a core_destruction_arg + +type inversion_kind = Misctypes.inversion_kind = + | SimpleInversion + | FullInversion + | FullInversionClear + +type ('c,'d,'id) inversion_strength = + | NonDepInversion of + inversion_kind * 'id list * 'd or_and_intro_pattern_expr located or_var option + | DepInversion of + inversion_kind * 'c option * 'd or_and_intro_pattern_expr located or_var option + | InversionUsing of 'c * 'id list + +type ('a,'b) location = HypLocation of 'a | ConclLocation of 'b + +type 'id message_token = + | MsgString of string + | MsgInt of int + | MsgIdent of 'id + +type ('dconstr,'id) induction_clause = + 'dconstr with_bindings destruction_arg * + (intro_pattern_naming_expr located option (* eqn:... *) + * 'dconstr or_and_intro_pattern_expr located or_var option) (* as ... *) + * 'id clause_expr option (* in ... *) + +type ('constr,'dconstr,'id) induction_clause_list = + ('dconstr,'id) induction_clause list + * 'constr with_bindings option (* using ... *) + +type 'a with_bindings_arg = clear_flag * 'a with_bindings + +(* Type of patterns *) +type 'a match_pattern = + | Term of 'a + | Subterm of bool * Id.t option * 'a + +(* Type of hypotheses for a Match Context rule *) +type 'a match_context_hyps = + | Hyp of Name.t located * 'a match_pattern + | Def of Name.t located * 'a match_pattern * 'a match_pattern + +(* Type of a Match rule for Match Context and Match *) +type ('a,'t) match_rule = + | Pat of 'a match_context_hyps list * 'a match_pattern * 't + | All of 't + +(** Extension indentifiers for the TACTIC EXTEND mechanism. *) +type ml_tactic_name = { + (** Name of the plugin where the tactic is defined, typically coming from a + DECLARE PLUGIN statement in the source. *) + mltac_plugin : string; + (** Name of the tactic entry where the tactic is defined, typically found + after the TACTIC EXTEND statement in the source. *) + mltac_tactic : string; +} + +type ml_tactic_entry = { + mltac_name : ml_tactic_name; + mltac_index : int; +} + +(** Composite types *) + +type glob_constr_and_expr = Tactypes.glob_constr_and_expr + +type open_constr_expr = unit * constr_expr +type open_glob_constr = unit * glob_constr_and_expr + +type binding_bound_vars = Constr_matching.binding_bound_vars +type glob_constr_pattern_and_expr = binding_bound_vars * glob_constr_and_expr * constr_pattern + +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 = EConstr.constr with_bindings 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 +type or_and_intro_pattern = delayed_open_constr or_and_intro_pattern_expr located +type intro_pattern_naming = intro_pattern_naming_expr located + +(** Generic expressions for atomic tactics *) + +type 'a gen_atomic_tactic_expr = + (* Basic tactics *) + | TacIntroPattern of evars_flag * 'dtrm intro_pattern_expr located list + | TacApply of advanced_flag * evars_flag * 'trm with_bindings_arg list * + ('nam * 'dtrm intro_pattern_expr located option) option + | TacElim of evars_flag * 'trm with_bindings_arg * 'trm with_bindings option + | TacCase of evars_flag * 'trm with_bindings_arg + | TacMutualFix of Id.t * int * (Id.t * int * 'trm) list + | TacMutualCofix of Id.t * (Id.t * 'trm) list + | TacAssert of + bool * 'tacexpr option option * + 'dtrm intro_pattern_expr located option * 'trm + | TacGeneralize of ('trm with_occurrences * Name.t) list + | TacLetTac of Name.t * 'trm * 'nam clause_expr * letin_flag * + intro_pattern_naming_expr located option + + (* Derived basic tactics *) + | TacInductionDestruct of + rec_flag * evars_flag * ('trm,'dtrm,'nam) induction_clause_list + + (* Conversion *) + | TacReduce of ('trm,'cst,'pat) red_expr_gen * 'nam clause_expr + | TacChange of 'pat option * 'dtrm * 'nam clause_expr + + (* Equality and inversion *) + | TacRewrite of evars_flag * + (bool * multi * 'dtrm with_bindings_arg) list * 'nam clause_expr * + (* spiwack: using ['dtrm] here is a small hack, may not be + stable by a change in the representation of delayed + terms. Because, in fact, it is the whole "with_bindings" + which is delayed. But because the "t" level for ['dtrm] is + uninterpreted, it works fine here too, and avoid more + disruption of this file. *) + 'tacexpr option + | TacInversion of ('trm,'dtrm,'nam) inversion_strength * quantified_hypothesis + +constraint 'a = < + term:'trm; + dterm: 'dtrm; + pattern:'pat; + constant:'cst; + reference:'ref; + name:'nam; + tacexpr:'tacexpr; + level:'lev +> + +(** Possible arguments of a tactic definition *) + +type 'a gen_tactic_arg = + | TacGeneric of 'lev generic_argument + | ConstrMayEval of ('trm,'cst,'pat) may_eval + | Reference of 'ref + | TacCall of Loc.t * 'ref * + 'a gen_tactic_arg list + | TacFreshId of string or_var list + | Tacexp of 'tacexpr + | TacPretype of 'trm + | TacNumgoals + +constraint 'a = < + term:'trm; + dterm: 'dtrm; + pattern:'pat; + constant:'cst; + reference:'ref; + name:'nam; + tacexpr:'tacexpr; + level:'lev +> + +(** Generic ltac expressions. + 't : terms, 'p : patterns, 'c : constants, 'i : inductive, + 'r : ltac refs, 'n : idents, 'l : levels *) + +and 'a gen_tactic_expr = + | TacAtom of Loc.t * 'a gen_atomic_tactic_expr + | TacThen of + 'a gen_tactic_expr * + 'a gen_tactic_expr + | TacDispatch of + 'a gen_tactic_expr list + | TacExtendTac of + 'a gen_tactic_expr array * + 'a gen_tactic_expr * + 'a gen_tactic_expr array + | TacThens of + 'a gen_tactic_expr * + 'a gen_tactic_expr list + | TacThens3parts of + 'a gen_tactic_expr * + 'a gen_tactic_expr array * + 'a gen_tactic_expr * + 'a gen_tactic_expr array + | TacFirst of 'a gen_tactic_expr list + | TacComplete of 'a gen_tactic_expr + | TacSolve of 'a gen_tactic_expr list + | TacTry of 'a gen_tactic_expr + | TacOr of + 'a gen_tactic_expr * + 'a gen_tactic_expr + | TacOnce of + 'a gen_tactic_expr + | TacExactlyOnce of + 'a gen_tactic_expr + | TacIfThenCatch of + 'a gen_tactic_expr * + 'a gen_tactic_expr * + 'a gen_tactic_expr + | TacOrelse of + 'a gen_tactic_expr * + 'a gen_tactic_expr + | TacDo of int or_var * 'a gen_tactic_expr + | TacTimeout of int or_var * 'a gen_tactic_expr + | TacTime of string option * 'a gen_tactic_expr + | TacRepeat of 'a gen_tactic_expr + | TacProgress of 'a gen_tactic_expr + | TacShowHyps of 'a gen_tactic_expr + | TacAbstract of + 'a gen_tactic_expr * Id.t option + | TacId of 'n message_token list + | TacFail of global_flag * int or_var * 'n message_token list + | TacInfo of 'a gen_tactic_expr + | TacLetIn of rec_flag * + (Id.t located * 'a gen_tactic_arg) list * + 'a gen_tactic_expr + | TacMatch of lazy_flag * + 'a gen_tactic_expr * + ('p,'a gen_tactic_expr) match_rule list + | TacMatchGoal of lazy_flag * direction_flag * + ('p,'a gen_tactic_expr) match_rule list + | TacFun of 'a gen_tactic_fun_ast + | TacArg of 'a gen_tactic_arg located + | TacSelect of goal_selector * 'a gen_tactic_expr + (* For ML extensions *) + | TacML of Loc.t * ml_tactic_entry * 'a gen_tactic_arg list + (* For syntax extensions *) + | TacAlias of Loc.t * KerName.t * 'a gen_tactic_arg list + +constraint 'a = < + term:'t; + dterm: 'dtrm; + pattern:'p; + constant:'c; + reference:'r; + name:'n; + tacexpr:'tacexpr; + level:'l +> + +and 'a gen_tactic_fun_ast = + Name.t list * 'a gen_tactic_expr + +constraint 'a = < + term:'t; + dterm: 'dtrm; + pattern:'p; + constant:'c; + reference:'r; + name:'n; + tacexpr:'te; + level:'l +> + +(** Globalized tactics *) + +type g_trm = glob_constr_and_expr +type g_pat = glob_constr_pattern_and_expr +type g_cst = evaluable_global_reference and_short_name or_var +type g_ref = ltac_constant located or_var +type g_nam = Id.t located + +type g_dispatch = < + term:g_trm; + dterm:g_trm; + pattern:g_pat; + constant:g_cst; + reference:g_ref; + name:g_nam; + tacexpr:glob_tactic_expr; + level:glevel +> + +and glob_tactic_expr = + g_dispatch gen_tactic_expr + +type glob_atomic_tactic_expr = + g_dispatch gen_atomic_tactic_expr + +type glob_tactic_arg = + g_dispatch gen_tactic_arg + +(** Raw tactics *) + +type r_trm = constr_expr +type r_pat = constr_pattern_expr +type r_cst = reference or_by_notation +type r_ref = reference +type r_nam = Id.t located +type r_lev = rlevel + +type r_dispatch = < + term:r_trm; + dterm:r_trm; + pattern:r_pat; + constant:r_cst; + reference:r_ref; + name:r_nam; + tacexpr:raw_tactic_expr; + level:rlevel +> + +and raw_tactic_expr = + r_dispatch gen_tactic_expr + +type raw_atomic_tactic_expr = + r_dispatch gen_atomic_tactic_expr + +type raw_tactic_arg = + r_dispatch gen_tactic_arg + +(** Interpreted tactics *) + +type t_trm = EConstr.constr +type t_pat = constr_pattern +type t_cst = evaluable_global_reference +type t_ref = ltac_constant located +type t_nam = Id.t + +type t_dispatch = < + term:t_trm; + dterm:g_trm; + pattern:t_pat; + constant:t_cst; + reference:t_ref; + name:t_nam; + tacexpr:unit; + level:tlevel +> + +type atomic_tactic_expr = + t_dispatch gen_atomic_tactic_expr + +(** Misc *) + +type raw_red_expr = (r_trm, r_cst, r_pat) red_expr_gen +type glob_red_expr = (g_trm, g_cst, g_pat) red_expr_gen + +(** Traces *) + +type ltac_call_kind = + | LtacMLCall of glob_tactic_expr + | LtacNotationCall of KerName.t + | LtacNameCall of ltac_constant + | LtacAtomCall of glob_atomic_tactic_expr + | LtacVarCall of Id.t * glob_tactic_expr + | LtacConstrInterp of Glob_term.glob_constr * Pretyping.ltac_var_map + +type ltac_trace = (Loc.t * ltac_call_kind) list + +type tacdef_body = + | TacticDefinition of Id.t Loc.located * raw_tactic_expr (* indicates that user employed ':=' in Ltac body *) + | TacticRedefinition of reference * raw_tactic_expr (* indicates that user employed '::=' in Ltac body *) diff --git a/plugins/ltac/tacintern.ml b/plugins/ltac/tacintern.ml new file mode 100644 index 000000000..3f83f104e --- /dev/null +++ b/plugins/ltac/tacintern.ml @@ -0,0 +1,811 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Pattern +open Pp +open Genredexpr +open Glob_term +open Tacred +open CErrors +open Util +open Names +open Nameops +open Libnames +open Globnames +open Nametab +open Smartlocate +open Constrexpr +open Termops +open Tacexpr +open Genarg +open Stdarg +open Tacarg +open Misctypes +open Locus + +(** Globalization of tactic expressions : + Conversion from [raw_tactic_expr] to [glob_tactic_expr] *) + +let dloc = Loc.ghost + +let error_tactic_expected ?loc = + user_err ?loc (str "Tactic expected.") + +(** Generic arguments *) + +type glob_sign = Genintern.glob_sign = { + ltacvars : Id.Set.t; + (* ltac variables and the subset of vars introduced by Intro/Let/... *) + genv : Environ.env } + +let fully_empty_glob_sign = + { ltacvars = Id.Set.empty; genv = Environ.empty_env } + +let make_empty_glob_sign () = + { fully_empty_glob_sign with genv = Global.env () } + +(* We have identifier <| global_reference <| constr *) + +let find_ident id ist = + Id.Set.mem id ist.ltacvars || + Id.List.mem id (ids_of_named_context (Environ.named_context ist.genv)) + +(* a "var" is a ltac var or a var introduced by an intro tactic *) +let find_var id ist = Id.Set.mem id ist.ltacvars + +let find_hyp id ist = + Id.List.mem id (ids_of_named_context (Environ.named_context ist.genv)) + +(* Globalize a name introduced by Intro/LetTac/... ; it is allowed to *) +(* be fresh in which case it is binding later on *) +let intern_ident s ist id = + (* We use identifier both for variables and new names; thus nothing to do *) + if not (find_ident id ist) then s := Id.Set.add id !s; + id + +let intern_name l ist = function + | Anonymous -> Anonymous + | Name id -> Name (intern_ident l ist id) + +let strict_check = ref false + +let adjust_loc loc = if !strict_check then dloc else loc + +(* Globalize a name which must be bound -- actually just check it is bound *) +let intern_hyp ist (loc,id as locid) = + if not !strict_check then + locid + else if find_ident id ist then + (dloc,id) + else + Pretype_errors.error_var_not_found ~loc id + +let intern_or_var f ist = function + | ArgVar locid -> ArgVar (intern_hyp ist locid) + | ArgArg x -> ArgArg (f x) + +let intern_int_or_var = intern_or_var (fun (n : int) -> n) +let intern_string_or_var = intern_or_var (fun (s : string) -> s) + +let intern_global_reference ist = function + | Ident (loc,id) when find_var id ist -> ArgVar (loc,id) + | r -> + let loc,_ as lqid = qualid_of_reference r in + try ArgArg (loc,locate_global_with_alias lqid) + with Not_found -> error_global_not_found (snd lqid) + +let intern_ltac_variable ist = function + | Ident (loc,id) -> + if find_var id ist then + (* A local variable of any type *) + ArgVar (loc,id) + else raise Not_found + | _ -> + raise Not_found + +let intern_constr_reference strict ist = function + | Ident (_,id) as r when not strict && find_hyp id ist -> + GVar (dloc,id), Some (CRef (r,None)) + | Ident (_,id) as r when find_var id ist -> + GVar (dloc,id), if strict then None else Some (CRef (r,None)) + | r -> + let loc,_ as lqid = qualid_of_reference r in + GRef (loc,locate_global_with_alias lqid,None), + if strict then None else Some (CRef (r,None)) + +let intern_move_location ist = function + | MoveAfter id -> MoveAfter (intern_hyp ist id) + | MoveBefore id -> MoveBefore (intern_hyp ist id) + | MoveFirst -> MoveFirst + | MoveLast -> MoveLast + +(* Internalize an isolated reference in position of tactic *) + +let intern_isolated_global_tactic_reference r = + let (loc,qid) = qualid_of_reference r in + TacCall (loc,ArgArg (loc,locate_tactic qid),[]) + +let intern_isolated_tactic_reference strict ist r = + (* An ltac reference *) + try Reference (intern_ltac_variable ist r) + with Not_found -> + (* A global tactic *) + try intern_isolated_global_tactic_reference r + with Not_found -> + (* Tolerance for compatibility, allow not to use "constr:" *) + try ConstrMayEval (ConstrTerm (intern_constr_reference strict ist r)) + with Not_found -> + (* Reference not found *) + error_global_not_found (snd (qualid_of_reference r)) + +(* Internalize an applied tactic reference *) + +let intern_applied_global_tactic_reference r = + let (loc,qid) = qualid_of_reference r in + ArgArg (loc,locate_tactic qid) + +let intern_applied_tactic_reference ist r = + (* An ltac reference *) + try intern_ltac_variable ist r + with Not_found -> + (* A global tactic *) + try intern_applied_global_tactic_reference r + with Not_found -> + (* Reference not found *) + error_global_not_found (snd (qualid_of_reference r)) + +(* Intern a reference parsed in a non-tactic entry *) + +let intern_non_tactic_reference strict ist r = + (* An ltac reference *) + try Reference (intern_ltac_variable ist r) + with Not_found -> + (* A constr reference *) + try ConstrMayEval (ConstrTerm (intern_constr_reference strict ist r)) + with Not_found -> + (* Tolerance for compatibility, allow not to use "ltac:" *) + try intern_isolated_global_tactic_reference r + with Not_found -> + (* By convention, use IntroIdentifier for unbound ident, when not in a def *) + match r with + | Ident (loc,id) when not strict -> + let ipat = in_gen (glbwit wit_intro_pattern) (loc, IntroNaming (IntroIdentifier id)) in + TacGeneric ipat + | _ -> + (* Reference not found *) + error_global_not_found (snd (qualid_of_reference r)) + +let intern_message_token ist = function + | (MsgString _ | MsgInt _ as x) -> x + | MsgIdent id -> MsgIdent (intern_hyp ist id) + +let intern_message ist = List.map (intern_message_token ist) + +let intern_quantified_hypothesis ist = function + | AnonHyp n -> AnonHyp n + | NamedHyp id -> + (* Uncomment to disallow "intros until n" in ltac when n is not bound *) + NamedHyp ((*snd (intern_hyp ist (dloc,*)id(* ))*)) + +let intern_binding_name ist x = + (* We use identifier both for variables and binding names *) + (* Todo: consider the body of the lemma to which the binding refer + and if a term w/o ltac vars, check the name is indeed quantified *) + x + +let intern_constr_gen allow_patvar isarity {ltacvars=lfun; genv=env} c = + let warn = if !strict_check then fun x -> x else Constrintern.for_grammar in + let scope = if isarity then Pretyping.IsType else Pretyping.WithoutTypeConstraint in + let ltacvars = { + Constrintern.ltac_vars = lfun; + ltac_bound = Id.Set.empty; + } in + let c' = + warn (Constrintern.intern_gen scope ~allow_patvar ~ltacvars env) c + in + (c',if !strict_check then None else Some c) + +let intern_constr = intern_constr_gen false false +let intern_type = intern_constr_gen false true + +(* Globalize bindings *) +let intern_binding ist (loc,b,c) = + (loc,intern_binding_name ist b,intern_constr ist c) + +let intern_bindings ist = function + | NoBindings -> NoBindings + | ImplicitBindings l -> ImplicitBindings (List.map (intern_constr ist) l) + | ExplicitBindings l -> ExplicitBindings (List.map (intern_binding ist) l) + +let intern_constr_with_bindings ist (c,bl) = + (intern_constr ist c, intern_bindings ist bl) + +let intern_constr_with_bindings_arg ist (clear,c) = + (clear,intern_constr_with_bindings ist c) + +let rec intern_intro_pattern lf ist = function + | loc, IntroNaming pat -> + loc, IntroNaming (intern_intro_pattern_naming lf ist pat) + | loc, IntroAction pat -> + loc, IntroAction (intern_intro_pattern_action lf ist pat) + | loc, IntroForthcoming _ as x -> x + +and intern_intro_pattern_naming lf ist = function + | IntroIdentifier id -> + IntroIdentifier (intern_ident lf ist id) + | IntroFresh id -> + IntroFresh (intern_ident lf ist id) + | IntroAnonymous as x -> x + +and intern_intro_pattern_action lf ist = function + | IntroOrAndPattern l -> + IntroOrAndPattern (intern_or_and_intro_pattern lf ist l) + | IntroInjection l -> + IntroInjection (List.map (intern_intro_pattern lf ist) l) + | IntroWildcard | IntroRewrite _ as x -> x + | IntroApplyOn ((loc,c),pat) -> + IntroApplyOn ((loc,intern_constr ist c), intern_intro_pattern lf ist pat) + +and intern_or_and_intro_pattern lf ist = function + | IntroAndPattern l -> + IntroAndPattern (List.map (intern_intro_pattern lf ist) l) + | IntroOrPattern ll -> + IntroOrPattern (List.map (List.map (intern_intro_pattern lf ist)) ll) + +let intern_or_and_intro_pattern_loc lf ist = function + | ArgVar (_,id) as x -> + if find_var id ist then x + else error "Disjunctive/conjunctive introduction pattern expected." + | ArgArg (loc,l) -> ArgArg (loc,intern_or_and_intro_pattern lf ist l) + +let intern_intro_pattern_naming_loc lf ist (loc,pat) = + (loc,intern_intro_pattern_naming lf ist pat) + + (* TODO: catch ltac vars *) +let intern_destruction_arg ist = function + | clear,ElimOnConstr c -> clear,ElimOnConstr (intern_constr_with_bindings ist c) + | clear,ElimOnAnonHyp n as x -> x + | clear,ElimOnIdent (loc,id) -> + if !strict_check then + (* If in a defined tactic, no intros-until *) + match intern_constr ist (CRef (Ident (dloc,id), None)) with + | GVar (loc,id),_ -> clear,ElimOnIdent (loc,id) + | c -> clear,ElimOnConstr (c,NoBindings) + else + clear,ElimOnIdent (loc,id) + +let short_name = function + | AN (Ident (loc,id)) when not !strict_check -> Some (loc,id) + | _ -> None + +let intern_evaluable_global_reference ist r = + let lqid = qualid_of_reference r in + try evaluable_of_global_reference ist.genv (locate_global_with_alias ~head:true lqid) + with Not_found -> + match r with + | Ident (loc,id) when not !strict_check -> EvalVarRef id + | _ -> error_global_not_found (snd lqid) + +let intern_evaluable_reference_or_by_notation ist = function + | AN r -> intern_evaluable_global_reference ist r + | ByNotation (loc,ntn,sc) -> + evaluable_of_global_reference ist.genv + (Notation.interp_notation_as_global_reference loc + (function ConstRef _ | VarRef _ -> true | _ -> false) ntn sc) + +(* Globalize a reduction expression *) +let intern_evaluable ist = function + | AN (Ident (loc,id)) when find_var id ist -> ArgVar (loc,id) + | AN (Ident (loc,id)) when not !strict_check && find_hyp id ist -> + ArgArg (EvalVarRef id, Some (loc,id)) + | r -> + let e = intern_evaluable_reference_or_by_notation ist r in + let na = short_name r in + ArgArg (e,na) + +let intern_unfold ist (l,qid) = (l,intern_evaluable ist qid) + +let intern_flag ist red = + { red with rConst = List.map (intern_evaluable ist) red.rConst } + +let intern_constr_with_occurrences ist (l,c) = (l,intern_constr ist c) + +let intern_constr_pattern ist ~as_type ~ltacvars pc = + let ltacvars = { + Constrintern.ltac_vars = ltacvars; + ltac_bound = Id.Set.empty; + } in + let metas,pat = Constrintern.intern_constr_pattern + ist.genv ~as_type ~ltacvars pc + in + let (glob,_ as c) = intern_constr_gen true false ist pc in + let bound_names = Glob_ops.bound_glob_vars glob in + metas,(bound_names,c,pat) + +let dummy_pat = PRel 0 + +let intern_typed_pattern ist p = + (* we cannot ensure in non strict mode that the pattern is closed *) + (* keeping a constr_expr copy is too complicated and we want anyway to *) + (* type it, so we remember the pattern as a glob_constr only *) + let (glob,_ as c) = intern_constr_gen true false ist p in + let bound_names = Glob_ops.bound_glob_vars glob in + (bound_names,c,dummy_pat) + +let intern_typed_pattern_or_ref_with_occurrences ist (l,p) = + let interp_ref r = + try Inl (intern_evaluable ist r) + with e when Logic.catchable_exception e -> + (* Compatibility. In practice, this means that the code above + is useless. Still the idea of having either an evaluable + ref or a pattern seems interesting, with "head" reduction + in case of an evaluable ref, and "strong" reduction in the + subterm matched when a pattern *) + let loc = loc_of_smart_reference r in + let r = match r with + | AN r -> r + | _ -> Qualid (loc,qualid_of_path (path_of_global (smart_global r))) in + let sign = { Constrintern.ltac_vars = ist.ltacvars; Constrintern.ltac_bound = Id.Set.empty } in + let c = Constrintern.interp_reference sign r in + match c with + | GRef (_,r,None) -> + Inl (ArgArg (evaluable_of_global_reference ist.genv r,None)) + | GVar (_,id) -> + let r = evaluable_of_global_reference ist.genv (VarRef id) in + Inl (ArgArg (r,None)) + | _ -> + let bound_names = Glob_ops.bound_glob_vars c in + Inr (bound_names,(c,None),dummy_pat) in + (l, match p with + | Inl r -> interp_ref r + | Inr (CAppExpl(_,(None,r,None),[])) -> + (* We interpret similarly @ref and ref *) + interp_ref (AN r) + | Inr c -> + Inr (intern_typed_pattern ist c)) + +(* This seems fairly hacky, but it's the first way I've found to get proper + globalization of [unfold]. --adamc *) +let dump_glob_red_expr = function + | Unfold occs -> List.iter (fun (_, r) -> + try + Dumpglob.add_glob (loc_of_or_by_notation Libnames.loc_of_reference r) + (Smartlocate.smart_global r) + with e when CErrors.noncritical e -> ()) occs + | Cbv grf | Lazy grf -> + List.iter (fun r -> + try + Dumpglob.add_glob (loc_of_or_by_notation Libnames.loc_of_reference r) + (Smartlocate.smart_global r) + with e when CErrors.noncritical e -> ()) grf.rConst + | _ -> () + +let intern_red_expr ist = function + | Unfold l -> Unfold (List.map (intern_unfold ist) l) + | Fold l -> Fold (List.map (intern_constr ist) l) + | Cbv f -> Cbv (intern_flag ist f) + | Cbn f -> Cbn (intern_flag ist f) + | Lazy f -> Lazy (intern_flag ist f) + | Pattern l -> Pattern (List.map (intern_constr_with_occurrences ist) l) + | Simpl (f,o) -> + Simpl (intern_flag ist f, + Option.map (intern_typed_pattern_or_ref_with_occurrences ist) o) + | CbvVm o -> CbvVm (Option.map (intern_typed_pattern_or_ref_with_occurrences ist) o) + | CbvNative o -> CbvNative (Option.map (intern_typed_pattern_or_ref_with_occurrences ist) o) + | (Red _ | Hnf | ExtraRedExpr _ as r ) -> r + +let intern_in_hyp_as ist lf (id,ipat) = + (intern_hyp ist id, Option.map (intern_intro_pattern lf ist) ipat) + +let intern_hyp_list ist = List.map (intern_hyp ist) + +let intern_inversion_strength lf ist = function + | NonDepInversion (k,idl,ids) -> + NonDepInversion (k,intern_hyp_list ist idl, + Option.map (intern_or_and_intro_pattern_loc lf ist) ids) + | DepInversion (k,copt,ids) -> + DepInversion (k, Option.map (intern_constr ist) copt, + Option.map (intern_or_and_intro_pattern_loc lf ist) ids) + | InversionUsing (c,idl) -> + InversionUsing (intern_constr ist c, intern_hyp_list ist idl) + +(* Interprets an hypothesis name *) +let intern_hyp_location ist ((occs,id),hl) = + ((Locusops.occurrences_map (List.map (intern_int_or_var ist)) occs, + intern_hyp ist id), hl) + +(* Reads a pattern *) +let intern_pattern ist ?(as_type=false) ltacvars = function + | Subterm (b,ido,pc) -> + let (metas,pc) = intern_constr_pattern ist ~as_type:false ~ltacvars pc in + ido, metas, Subterm (b,ido,pc) + | Term pc -> + let (metas,pc) = intern_constr_pattern ist ~as_type ~ltacvars pc in + None, metas, Term pc + +let intern_constr_may_eval ist = function + | ConstrEval (r,c) -> ConstrEval (intern_red_expr ist r,intern_constr ist c) + | ConstrContext (locid,c) -> + ConstrContext (intern_hyp ist locid,intern_constr ist c) + | ConstrTypeOf c -> ConstrTypeOf (intern_constr ist c) + | ConstrTerm c -> ConstrTerm (intern_constr ist c) + +let name_cons accu = function +| Anonymous -> accu +| Name id -> Id.Set.add id accu + +let opt_cons accu = function +| None -> accu +| Some id -> Id.Set.add id accu + +(* Reads the hypotheses of a "match goal" rule *) +let rec intern_match_goal_hyps ist ?(as_type=false) lfun = function + | (Hyp ((_,na) as locna,mp))::tl -> + let ido, metas1, pat = intern_pattern ist ~as_type:true lfun mp in + let lfun, metas2, hyps = intern_match_goal_hyps ist lfun tl in + let lfun' = name_cons (opt_cons lfun ido) na in + lfun', metas1@metas2, Hyp (locna,pat)::hyps + | (Def ((_,na) as locna,mv,mp))::tl -> + let ido, metas1, patv = intern_pattern ist ~as_type:false lfun mv in + let ido', metas2, patt = intern_pattern ist ~as_type:true lfun mp in + let lfun, metas3, hyps = intern_match_goal_hyps ist ~as_type lfun tl in + let lfun' = name_cons (opt_cons (opt_cons lfun ido) ido') na in + lfun', metas1@metas2@metas3, Def (locna,patv,patt)::hyps + | [] -> lfun, [], [] + +(* Utilities *) +let extract_let_names lrc = + let fold accu ((loc, name), _) = + if Id.Set.mem name accu then user_err ~loc + ~hdr:"glob_tactic" (str "This variable is bound several times.") + else Id.Set.add name accu + in + List.fold_left fold Id.Set.empty lrc + +let clause_app f = function + { onhyps=None; concl_occs=nl } -> + { onhyps=None; concl_occs=nl } + | { onhyps=Some l; concl_occs=nl } -> + { onhyps=Some(List.map f l); concl_occs=nl} + +(* Globalizes tactics : raw_tactic_expr -> glob_tactic_expr *) +let rec intern_atomic lf ist x = + match (x:raw_atomic_tactic_expr) with + (* Basic tactics *) + | TacIntroPattern (ev,l) -> + TacIntroPattern (ev,List.map (intern_intro_pattern lf ist) l) + | TacApply (a,ev,cb,inhyp) -> + TacApply (a,ev,List.map (intern_constr_with_bindings_arg ist) cb, + Option.map (intern_in_hyp_as ist lf) inhyp) + | TacElim (ev,cb,cbo) -> + TacElim (ev,intern_constr_with_bindings_arg ist cb, + Option.map (intern_constr_with_bindings ist) cbo) + | TacCase (ev,cb) -> TacCase (ev,intern_constr_with_bindings_arg ist cb) + | TacMutualFix (id,n,l) -> + let f (id,n,c) = (intern_ident lf ist id,n,intern_type ist c) in + TacMutualFix (intern_ident lf ist id, n, List.map f l) + | TacMutualCofix (id,l) -> + let f (id,c) = (intern_ident lf ist id,intern_type ist c) in + TacMutualCofix (intern_ident lf ist id, List.map f l) + | TacAssert (b,otac,ipat,c) -> + TacAssert (b,Option.map (Option.map (intern_pure_tactic ist)) otac, + Option.map (intern_intro_pattern lf ist) ipat, + intern_constr_gen false (not (Option.is_empty otac)) ist c) + | TacGeneralize cl -> + TacGeneralize (List.map (fun (c,na) -> + intern_constr_with_occurrences ist c, + intern_name lf ist na) cl) + | TacLetTac (na,c,cls,b,eqpat) -> + let na = intern_name lf ist na in + TacLetTac (na,intern_constr ist c, + (clause_app (intern_hyp_location ist) cls),b, + (Option.map (intern_intro_pattern_naming_loc lf ist) eqpat)) + + (* Derived basic tactics *) + | TacInductionDestruct (ev,isrec,(l,el)) -> + TacInductionDestruct (ev,isrec,(List.map (fun (c,(ipato,ipats),cls) -> + (intern_destruction_arg ist c, + (Option.map (intern_intro_pattern_naming_loc lf ist) ipato, + Option.map (intern_or_and_intro_pattern_loc lf ist) ipats), + Option.map (clause_app (intern_hyp_location ist)) cls)) l, + Option.map (intern_constr_with_bindings ist) el)) + (* Conversion *) + | TacReduce (r,cl) -> + dump_glob_red_expr r; + TacReduce (intern_red_expr ist r, clause_app (intern_hyp_location ist) cl) + | TacChange (None,c,cl) -> + let is_onhyps = match cl.onhyps with + | None | Some [] -> true + | _ -> false + in + let is_onconcl = match cl.concl_occs with + | AllOccurrences | NoOccurrences -> true + | _ -> false + in + TacChange (None, + (if is_onhyps && is_onconcl + then intern_type ist c else intern_constr ist c), + clause_app (intern_hyp_location ist) cl) + | TacChange (Some p,c,cl) -> + TacChange (Some (intern_typed_pattern ist p),intern_constr ist c, + clause_app (intern_hyp_location ist) cl) + + (* Equality and inversion *) + | TacRewrite (ev,l,cl,by) -> + TacRewrite + (ev, + List.map (fun (b,m,c) -> (b,m,intern_constr_with_bindings_arg ist c)) l, + clause_app (intern_hyp_location ist) cl, + Option.map (intern_pure_tactic ist) by) + | TacInversion (inv,hyp) -> + TacInversion (intern_inversion_strength lf ist inv, + intern_quantified_hypothesis ist hyp) + +and intern_tactic onlytac ist tac = snd (intern_tactic_seq onlytac ist tac) + +and intern_tactic_seq onlytac ist = function + | TacAtom (loc,t) -> + let lf = ref ist.ltacvars in + let t = intern_atomic lf ist t in + !lf, TacAtom (adjust_loc loc, t) + | TacFun tacfun -> ist.ltacvars, TacFun (intern_tactic_fun ist tacfun) + | TacLetIn (isrec,l,u) -> + let ltacvars = Id.Set.union (extract_let_names l) ist.ltacvars in + let ist' = { ist with ltacvars } in + let l = List.map (fun (n,b) -> + (n,intern_tacarg !strict_check false (if isrec then ist' else ist) b)) l in + ist.ltacvars, TacLetIn (isrec,l,intern_tactic onlytac ist' u) + + | TacMatchGoal (lz,lr,lmr) -> + ist.ltacvars, TacMatchGoal(lz,lr, intern_match_rule onlytac ist ~as_type:true lmr) + | TacMatch (lz,c,lmr) -> + ist.ltacvars, + TacMatch (lz,intern_tactic_or_tacarg ist c,intern_match_rule onlytac ist lmr) + | TacId l -> ist.ltacvars, TacId (intern_message ist l) + | TacFail (g,n,l) -> + ist.ltacvars, TacFail (g,intern_int_or_var ist n,intern_message ist l) + | TacProgress tac -> ist.ltacvars, TacProgress (intern_pure_tactic ist tac) + | TacShowHyps tac -> ist.ltacvars, TacShowHyps (intern_pure_tactic ist tac) + | TacAbstract (tac,s) -> + ist.ltacvars, TacAbstract (intern_pure_tactic ist tac,s) + | TacThen (t1,t2) -> + let lfun', t1 = intern_tactic_seq onlytac ist t1 in + let lfun'', t2 = intern_tactic_seq onlytac { ist with ltacvars = lfun' } t2 in + lfun'', TacThen (t1,t2) + | TacDispatch tl -> + ist.ltacvars , TacDispatch (List.map (intern_pure_tactic ist) tl) + | TacExtendTac (tf,t,tl) -> + ist.ltacvars , + TacExtendTac (Array.map (intern_pure_tactic ist) tf, + intern_pure_tactic ist t, + Array.map (intern_pure_tactic ist) tl) + | TacThens3parts (t1,tf,t2,tl) -> + let lfun', t1 = intern_tactic_seq onlytac ist t1 in + let ist' = { ist with ltacvars = lfun' } in + (* Que faire en cas de (tac complexe avec Match et Thens; tac2) ?? *) + lfun', TacThens3parts (t1,Array.map (intern_pure_tactic ist') tf,intern_pure_tactic ist' t2, + Array.map (intern_pure_tactic ist') tl) + | TacThens (t,tl) -> + let lfun', t = intern_tactic_seq true ist t in + let ist' = { ist with ltacvars = lfun' } in + (* Que faire en cas de (tac complexe avec Match et Thens; tac2) ?? *) + lfun', TacThens (t, List.map (intern_pure_tactic ist') tl) + | TacDo (n,tac) -> + ist.ltacvars, TacDo (intern_int_or_var ist n,intern_pure_tactic ist tac) + | TacTry tac -> ist.ltacvars, TacTry (intern_pure_tactic ist tac) + | TacInfo tac -> ist.ltacvars, TacInfo (intern_pure_tactic ist tac) + | TacRepeat tac -> ist.ltacvars, TacRepeat (intern_pure_tactic ist tac) + | TacTimeout (n,tac) -> + ist.ltacvars, TacTimeout (intern_int_or_var ist n,intern_tactic onlytac ist tac) + | TacTime (s,tac) -> + ist.ltacvars, TacTime (s,intern_tactic onlytac ist tac) + | TacOr (tac1,tac2) -> + ist.ltacvars, TacOr (intern_pure_tactic ist tac1,intern_pure_tactic ist tac2) + | TacOnce tac -> + ist.ltacvars, TacOnce (intern_pure_tactic ist tac) + | TacExactlyOnce tac -> + ist.ltacvars, TacExactlyOnce (intern_pure_tactic ist tac) + | TacIfThenCatch (tac,tact,tace) -> + ist.ltacvars, + TacIfThenCatch ( + intern_pure_tactic ist tac, + intern_pure_tactic ist tact, + intern_pure_tactic ist tace) + | TacOrelse (tac1,tac2) -> + ist.ltacvars, TacOrelse (intern_pure_tactic ist tac1,intern_pure_tactic ist tac2) + | TacFirst l -> ist.ltacvars, TacFirst (List.map (intern_pure_tactic ist) l) + | TacSolve l -> ist.ltacvars, TacSolve (List.map (intern_pure_tactic ist) l) + | TacComplete tac -> ist.ltacvars, TacComplete (intern_pure_tactic ist tac) + | TacArg (loc,a) -> ist.ltacvars, intern_tactic_as_arg loc onlytac ist a + | TacSelect (sel, tac) -> + ist.ltacvars, TacSelect (sel, intern_pure_tactic ist tac) + + (* For extensions *) + | TacAlias (loc,s,l) -> + let l = List.map (intern_tacarg !strict_check false ist) l in + ist.ltacvars, TacAlias (loc,s,l) + | TacML (loc,opn,l) -> + let _ignore = Tacenv.interp_ml_tactic opn in + ist.ltacvars, TacML (adjust_loc loc,opn,List.map (intern_tacarg !strict_check false ist) l) + +and intern_tactic_as_arg loc onlytac ist a = + match intern_tacarg !strict_check onlytac ist a with + | TacCall _ | Reference _ + | TacGeneric _ as a -> TacArg (loc,a) + | Tacexp a -> a + | ConstrMayEval _ | TacFreshId _ | TacPretype _ | TacNumgoals as a -> + if onlytac then error_tactic_expected ~loc else TacArg (loc,a) + +and intern_tactic_or_tacarg ist = intern_tactic false ist + +and intern_pure_tactic ist = intern_tactic true ist + +and intern_tactic_fun ist (var,body) = + let lfun = List.fold_left name_cons ist.ltacvars var in + (var,intern_tactic_or_tacarg { ist with ltacvars = lfun } body) + +and intern_tacarg strict onlytac ist = function + | Reference r -> intern_non_tactic_reference strict ist r + | ConstrMayEval c -> ConstrMayEval (intern_constr_may_eval ist c) + | TacCall (loc,f,[]) -> intern_isolated_tactic_reference strict ist f + | TacCall (loc,f,l) -> + TacCall (loc, + intern_applied_tactic_reference ist f, + List.map (intern_tacarg !strict_check false ist) l) + | TacFreshId x -> TacFreshId (List.map (intern_string_or_var ist) x) + | TacPretype c -> TacPretype (intern_constr ist c) + | TacNumgoals -> TacNumgoals + | Tacexp t -> Tacexp (intern_tactic onlytac ist t) + | TacGeneric arg -> + let arg = intern_genarg ist arg in + TacGeneric arg + +(* Reads the rules of a Match Context or a Match *) +and intern_match_rule onlytac ist ?(as_type=false) = function + | (All tc)::tl -> + All (intern_tactic onlytac ist tc) :: (intern_match_rule onlytac ist ~as_type tl) + | (Pat (rl,mp,tc))::tl -> + let {ltacvars=lfun; genv=env} = ist in + let lfun',metas1,hyps = intern_match_goal_hyps ist ~as_type lfun rl in + let ido,metas2,pat = intern_pattern ist ~as_type lfun mp in + let fold accu x = Id.Set.add x accu in + let ltacvars = List.fold_left fold (opt_cons lfun' ido) metas1 in + let ltacvars = List.fold_left fold ltacvars metas2 in + let ist' = { ist with ltacvars } in + Pat (hyps,pat,intern_tactic onlytac ist' tc) :: (intern_match_rule onlytac ist ~as_type tl) + | [] -> [] + +and intern_genarg ist (GenArg (Rawwit wit, x)) = + match wit with + | ListArg wit -> + let map x = + let ans = intern_genarg ist (in_gen (rawwit wit) x) in + out_gen (glbwit wit) ans + in + in_gen (glbwit (wit_list wit)) (List.map map x) + | OptArg wit -> + let ans = match x with + | None -> in_gen (glbwit (wit_opt wit)) None + | Some x -> + let s = out_gen (glbwit wit) (intern_genarg ist (in_gen (rawwit wit) x)) in + in_gen (glbwit (wit_opt wit)) (Some s) + in + ans + | PairArg (wit1, wit2) -> + let p, q = x in + let p = out_gen (glbwit wit1) (intern_genarg ist (in_gen (rawwit wit1) p)) in + let q = out_gen (glbwit wit2) (intern_genarg ist (in_gen (rawwit wit2) q)) in + in_gen (glbwit (wit_pair wit1 wit2)) (p, q) + | ExtraArg s -> + snd (Genintern.generic_intern ist (in_gen (rawwit wit) x)) + +(** Other entry points *) + +let glob_tactic x = + Flags.with_option strict_check + (intern_pure_tactic (make_empty_glob_sign ())) x + +let glob_tactic_env l env x = + let ltacvars = + List.fold_left (fun accu x -> Id.Set.add x accu) Id.Set.empty l in + Flags.with_option strict_check + (intern_pure_tactic + { ltacvars; genv = env }) + x + +let split_ltac_fun = function + | TacFun (l,t) -> (l,t) + | t -> ([],t) + +let pr_ltac_fun_arg n = spc () ++ pr_name n + +let print_ltac id = + try + let kn = Nametab.locate_tactic id in + let entries = Tacenv.ltac_entries () in + let tac = KNmap.find kn entries in + let filter mp = + try Some (Nametab.shortest_qualid_of_module mp) + with Not_found -> None + in + let mods = List.map_filter filter tac.Tacenv.tac_redef in + let redefined = match mods with + | [] -> mt () + | mods -> + let redef = prlist_with_sep fnl pr_qualid mods in + fnl () ++ str "Redefined by:" ++ fnl () ++ redef + in + let l,t = split_ltac_fun tac.Tacenv.tac_body in + hv 2 ( + hov 2 (str "Ltac" ++ spc() ++ pr_qualid id ++ + prlist pr_ltac_fun_arg l ++ spc () ++ str ":=") + ++ spc() ++ Pptactic.pr_glob_tactic (Global.env ()) t) ++ redefined + with + Not_found -> + user_err ~hdr:"print_ltac" + (pr_qualid id ++ spc() ++ str "is not a user defined tactic.") + +(** Registering *) + +let lift intern = (); fun ist x -> (ist, intern ist x) + +let () = + let intern_intro_pattern ist pat = + let lf = ref Id.Set.empty in + let ans = intern_intro_pattern lf ist pat in + let ist = { ist with ltacvars = !lf } in + (ist, ans) + in + Genintern.register_intern0 wit_intro_pattern intern_intro_pattern + +let () = + let intern_clause ist cl = + let ans = clause_app (intern_hyp_location ist) cl in + (ist, ans) + in + Genintern.register_intern0 wit_clause_dft_concl intern_clause + +let intern_ident' ist id = + let lf = ref Id.Set.empty in + (ist, intern_ident lf ist id) + +let intern_ltac ist tac = + Flags.with_option strict_check (fun () -> intern_pure_tactic ist tac) () + +let () = + Genintern.register_intern0 wit_int_or_var (lift intern_int_or_var); + Genintern.register_intern0 wit_ref (lift intern_global_reference); + Genintern.register_intern0 wit_pre_ident (fun ist c -> (ist,c)); + Genintern.register_intern0 wit_ident intern_ident'; + Genintern.register_intern0 wit_var (lift intern_hyp); + Genintern.register_intern0 wit_tactic (lift intern_tactic_or_tacarg); + Genintern.register_intern0 wit_ltac (lift intern_ltac); + Genintern.register_intern0 wit_quant_hyp (lift intern_quantified_hypothesis); + Genintern.register_intern0 wit_constr (fun ist c -> (ist,intern_constr ist c)); + Genintern.register_intern0 wit_uconstr (fun ist c -> (ist,intern_constr ist c)); + Genintern.register_intern0 wit_open_constr (fun ist c -> (ist,intern_constr ist c)); + Genintern.register_intern0 wit_red_expr (lift intern_red_expr); + Genintern.register_intern0 wit_bindings (lift intern_bindings); + Genintern.register_intern0 wit_constr_with_bindings (lift intern_constr_with_bindings); + Genintern.register_intern0 wit_destruction_arg (lift intern_destruction_arg); + () + +(** Substitution for notations containing tactic-in-terms *) + +let notation_subst bindings tac = + let fold id c accu = + let loc = Glob_ops.loc_of_glob_constr (fst c) in + let c = ConstrMayEval (ConstrTerm c) in + ((loc, id), c) :: accu + in + let bindings = Id.Map.fold fold bindings [] in + (** This is theoretically not correct due to potential variable capture, but + Ltac has no true variables so one cannot simply substitute *) + TacLetIn (false, bindings, tac) + +let () = Genintern.register_ntn_subst0 wit_tactic notation_subst diff --git a/plugins/ltac/tacintern.mli b/plugins/ltac/tacintern.mli new file mode 100644 index 000000000..71ca354fa --- /dev/null +++ b/plugins/ltac/tacintern.mli @@ -0,0 +1,64 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Pp +open Names +open Tacexpr +open Genarg +open Constrexpr +open Misctypes + +(** Globalization of tactic expressions : + Conversion from [raw_tactic_expr] to [glob_tactic_expr] *) + +type glob_sign = Genintern.glob_sign = { + ltacvars : Id.Set.t; + genv : Environ.env } + +val fully_empty_glob_sign : glob_sign + +val make_empty_glob_sign : unit -> glob_sign + (** same as [fully_empty_glob_sign], but with [Global.env()] as + environment *) + +(** Main globalization functions *) + +val glob_tactic : raw_tactic_expr -> glob_tactic_expr + +val glob_tactic_env : + Id.t list -> Environ.env -> raw_tactic_expr -> glob_tactic_expr + +(** Low-level variants *) + +val intern_pure_tactic : glob_sign -> raw_tactic_expr -> glob_tactic_expr + +val intern_tactic_or_tacarg : + glob_sign -> raw_tactic_expr -> Tacexpr.glob_tactic_expr + +val intern_constr : glob_sign -> constr_expr -> glob_constr_and_expr + +val intern_constr_with_bindings : + glob_sign -> constr_expr * constr_expr bindings -> + glob_constr_and_expr * glob_constr_and_expr bindings + +val intern_hyp : glob_sign -> Id.t Loc.located -> Id.t Loc.located + +(** Adds a globalization function for extra generic arguments *) + +val intern_genarg : glob_sign -> raw_generic_argument -> glob_generic_argument + +(** printing *) +val print_ltac : Libnames.qualid -> std_ppcmds + +(** Reduction expressions *) + +val intern_red_expr : glob_sign -> raw_red_expr -> glob_red_expr +val dump_glob_red_expr : raw_red_expr -> unit + +(* Hooks *) +val strict_check : bool ref diff --git a/plugins/ltac/tacinterp.ml b/plugins/ltac/tacinterp.ml new file mode 100644 index 000000000..50f43931e --- /dev/null +++ b/plugins/ltac/tacinterp.ml @@ -0,0 +1,2165 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Constrintern +open Patternops +open Pp +open Genredexpr +open Glob_term +open Glob_ops +open Tacred +open CErrors +open Util +open Names +open Nameops +open Libnames +open Globnames +open Nametab +open Pfedit +open Refiner +open Tacmach.New +open Tactic_debug +open Constrexpr +open Term +open Termops +open Tacexpr +open Genarg +open Geninterp +open Stdarg +open Tacarg +open Printer +open Pretyping +open Misctypes +open Locus +open Tacintern +open Taccoerce +open Sigma.Notations +open Proofview.Notations +open Context.Named.Declaration + +let ltac_trace_info = Tactic_debug.ltac_trace_info + +let has_type : type a. Val.t -> a typed_abstract_argument_type -> bool = fun v wit -> + let Val.Dyn (t, _) = v in + let t' = match val_tag wit with + | Val.Base t' -> t' + | _ -> assert false (** not used in this module *) + in + match Val.eq t t' with + | None -> false + | Some Refl -> true + +let prj : type a. a Val.typ -> Val.t -> a option = fun t v -> + let Val.Dyn (t', x) = v in + match Val.eq t t' with + | None -> None + | Some Refl -> Some x + +let in_list tag v = + let tag = match tag with Val.Base tag -> tag | _ -> assert false in + Val.Dyn (Val.typ_list, List.map (fun x -> Val.Dyn (tag, x)) v) +let in_gen wit v = + let t = match val_tag wit with + | Val.Base t -> t + | _ -> assert false (** not used in this module *) + in + Val.Dyn (t, v) +let out_gen wit v = + let t = match val_tag wit with + | Val.Base t -> t + | _ -> assert false (** not used in this module *) + in + match prj t v with None -> assert false | Some x -> x + +let val_tag wit = val_tag (topwit wit) + +let pr_argument_type arg = + let Val.Dyn (tag, _) = arg in + Val.pr tag + +let safe_msgnl s = + Proofview.NonLogical.catch + (Proofview.NonLogical.print_debug (s++fnl())) + (fun _ -> Proofview.NonLogical.print_warning (str "bug in the debugger: an exception is raised while printing debug information"++fnl())) + +type value = Val.t + +(** Abstract application, to print ltac functions *) +type appl = + | UnnamedAppl (** For generic applications: nothing is printed *) + | GlbAppl of (Names.kernel_name * Val.t list) list + (** For calls to global constants, some may alias other. *) +let push_appl appl args = + match appl with + | UnnamedAppl -> UnnamedAppl + | GlbAppl l -> GlbAppl (List.map (fun (h,vs) -> (h,vs@args)) l) +let pr_generic arg = + let Val.Dyn (tag, _) = arg in + str"<" ++ Val.pr tag ++ str ":(" ++ Pptactic.pr_value Pptactic.ltop arg ++ str ")>" +let pr_appl h vs = + Pptactic.pr_ltac_constant h ++ spc () ++ + Pp.prlist_with_sep spc pr_generic vs +let rec name_with_list appl t = + match appl with + | [] -> t + | (h,vs)::l -> Proofview.Trace.name_tactic (fun () -> pr_appl h vs) (name_with_list l t) +let name_if_glob appl t = + match appl with + | UnnamedAppl -> t + | GlbAppl l -> name_with_list l t +let combine_appl appl1 appl2 = + match appl1,appl2 with + | UnnamedAppl,a | a,UnnamedAppl -> a + | GlbAppl l1 , GlbAppl l2 -> GlbAppl (l2@l1) + +(* Values for interpretation *) +type tacvalue = + | VFun of appl*ltac_trace * value Id.Map.t * + Name.t list * glob_tactic_expr + | VRec of value Id.Map.t ref * glob_tactic_expr + +let (wit_tacvalue : (Empty.t, tacvalue, tacvalue) Genarg.genarg_type) = + let wit = Genarg.create_arg "tacvalue" in + let () = register_val0 wit None in + wit + +let of_tacvalue v = in_gen (topwit wit_tacvalue) v +let to_tacvalue v = out_gen (topwit wit_tacvalue) v + +(** More naming applications *) +let name_vfun appl vle = + let vle = Value.normalize vle in + if has_type vle (topwit wit_tacvalue) then + match to_tacvalue vle with + | VFun (appl0,trace,lfun,vars,t) -> of_tacvalue (VFun (combine_appl appl0 appl,trace,lfun,vars,t)) + | _ -> vle + else vle + +module TacStore = Geninterp.TacStore + +let f_avoid_ids : Id.t list TacStore.field = TacStore.field () +(* ids inherited from the call context (needed to get fresh ids) *) +let f_debug : debug_info TacStore.field = TacStore.field () +let f_trace : ltac_trace TacStore.field = TacStore.field () + +(* Signature for interpretation: val_interp and interpretation functions *) +type interp_sign = Geninterp.interp_sign = { + lfun : value Id.Map.t; + extra : TacStore.t } + +let extract_trace ist = match TacStore.get ist.extra f_trace with +| None -> [] +| Some l -> l + +module Value = struct + + include Taccoerce.Value + + let of_closure ist tac = + let closure = VFun (UnnamedAppl,extract_trace ist, ist.lfun, [], tac) in + of_tacvalue closure + + let cast_error wit v = + let pr_v = Pptactic.pr_value Pptactic.ltop v in + let Val.Dyn (tag, _) = v in + let tag = Val.pr tag in + user_err (str "Type error: value " ++ pr_v ++ str " is a " ++ tag + ++ str " while type " ++ Val.pr wit ++ str " was expected.") + + let unbox wit v ans = match ans with + | None -> cast_error wit v + | Some x -> x + + let rec prj : type a. a Val.tag -> Val.t -> a = fun tag v -> match tag with + | Val.List tag -> List.map (fun v -> prj tag v) (unbox Val.typ_list v (to_list v)) + | Val.Opt tag -> Option.map (fun v -> prj tag v) (unbox Val.typ_opt v (to_option v)) + | Val.Pair (tag1, tag2) -> + let (x, y) = unbox Val.typ_pair v (to_pair v) in + (prj tag1 x, prj tag2 y) + | Val.Base t -> + let Val.Dyn (t', x) = v in + match Val.eq t t' with + | None -> cast_error t v + | Some Refl -> x + + let rec tag_of_arg : type a b c. (a, b, c) genarg_type -> c Val.tag = fun wit -> match wit with + | ExtraArg _ -> val_tag wit + | ListArg t -> Val.List (tag_of_arg t) + | OptArg t -> Val.Opt (tag_of_arg t) + | PairArg (t1, t2) -> Val.Pair (tag_of_arg t1, tag_of_arg t2) + + let val_cast arg v = prj (tag_of_arg arg) v + + let cast (Topwit wit) v = val_cast wit v + +end + +let print_top_val env v = Pptactic.pr_value Pptactic.ltop v + +let dloc = Loc.ghost + +let catching_error call_trace fail (e, info) = + let inner_trace = + Option.default [] (Exninfo.get info ltac_trace_info) + in + if List.is_empty call_trace && List.is_empty inner_trace then fail (e, info) + else begin + assert (CErrors.noncritical e); (* preserved invariant *) + let new_trace = inner_trace @ call_trace in + let located_exc = (e, Exninfo.add info ltac_trace_info new_trace) in + fail located_exc + end + +let catch_error call_trace f x = + try f x + with e when CErrors.noncritical e -> + let e = CErrors.push e in + catching_error call_trace iraise e + +let catch_error_tac call_trace tac = + Proofview.tclORELSE + tac + (catching_error call_trace (fun (e, info) -> Proofview.tclZERO ~info e)) + +let curr_debug ist = match TacStore.get ist.extra f_debug with +| None -> DebugOff +| Some level -> level + +(** TODO: unify printing of generic Ltac values in case of coercion failure. *) + +(* Displays a value *) +let pr_value env v = + let v = Value.normalize v in + if has_type v (topwit wit_tacvalue) then str "a tactic" + else if has_type v (topwit wit_constr_context) then + let c = out_gen (topwit wit_constr_context) v in + match env with + | Some (env,sigma) -> pr_leconstr_env env sigma c + | _ -> str "a term" + else if has_type v (topwit wit_constr) then + let c = out_gen (topwit wit_constr) v in + match env with + | Some (env,sigma) -> pr_leconstr_env env sigma c + | _ -> str "a term" + else if has_type v (topwit wit_constr_under_binders) then + let c = out_gen (topwit wit_constr_under_binders) v in + match env with + | Some (env,sigma) -> pr_lconstr_under_binders_env env sigma c + | _ -> str "a term" + else + str "a value of type" ++ spc () ++ pr_argument_type v + +let pr_closure env ist body = + let pp_body = Pptactic.pr_glob_tactic env body in + let pr_sep () = fnl () in + let pr_iarg (id, arg) = + let arg = pr_argument_type arg in + hov 0 (pr_id id ++ spc () ++ str ":" ++ spc () ++ arg) + in + let pp_iargs = v 0 (prlist_with_sep pr_sep pr_iarg (Id.Map.bindings ist)) in + pp_body ++ fnl() ++ str "in environment " ++ fnl() ++ pp_iargs + +let pr_inspect env expr result = + let pp_expr = Pptactic.pr_glob_tactic env expr in + let pp_result = + if has_type result (topwit wit_tacvalue) then + match to_tacvalue result with + | VFun (_,_, ist, ul, b) -> + let body = if List.is_empty ul then b else (TacFun (ul, b)) in + str "a closure with body " ++ fnl() ++ pr_closure env ist body + | VRec (ist, body) -> + str "a recursive closure" ++ fnl () ++ pr_closure env !ist body + else + let pp_type = pr_argument_type result in + str "an object of type" ++ spc () ++ pp_type + in + pp_expr ++ fnl() ++ str "this is " ++ pp_result + +(* Transforms an id into a constr if possible, or fails with Not_found *) +let constr_of_id env id = + EConstr.mkVar (let _ = Environ.lookup_named id env in id) + +(** Generic arguments : table of interpretation functions *) + +(* Some of the code further down depends on the fact that push_trace does not modify sigma (the evar map) *) +let push_trace call ist = match TacStore.get ist.extra f_trace with +| None -> Proofview.tclUNIT [call] +| Some trace -> Proofview.tclUNIT (call :: trace) + +let propagate_trace ist loc id v = + let v = Value.normalize v in + if has_type v (topwit wit_tacvalue) then + let tacv = to_tacvalue v in + match tacv with + | VFun (appl,_,lfun,it,b) -> + let t = if List.is_empty it then b else TacFun (it,b) in + push_trace(loc,LtacVarCall (id,t)) ist >>= fun trace -> + let ans = VFun (appl,trace,lfun,it,b) in + Proofview.tclUNIT (of_tacvalue ans) + | _ -> Proofview.tclUNIT v + else Proofview.tclUNIT v + +let append_trace trace v = + let v = Value.normalize v in + if has_type v (topwit wit_tacvalue) then + match to_tacvalue v with + | VFun (appl,trace',lfun,it,b) -> of_tacvalue (VFun (appl,trace'@trace,lfun,it,b)) + | _ -> v + else v + +(* Dynamically check that an argument is a tactic *) +let coerce_to_tactic loc id v = + let v = Value.normalize v in + let fail () = user_err ~loc + (str "Variable " ++ pr_id id ++ str " should be bound to a tactic.") + in + let v = Value.normalize v in + if has_type v (topwit wit_tacvalue) then + let tacv = to_tacvalue v in + match tacv with + | VFun _ -> v + | _ -> fail () + else fail () + +let intro_pattern_of_ident id = (Loc.ghost, IntroNaming (IntroIdentifier id)) +let value_of_ident id = + in_gen (topwit wit_intro_pattern) (intro_pattern_of_ident id) + +let (+++) lfun1 lfun2 = Id.Map.fold Id.Map.add lfun1 lfun2 + +let extend_values_with_bindings (ln,lm) lfun = + let of_cub c = match c with + | [], c -> Value.of_constr c + | _ -> in_gen (topwit wit_constr_under_binders) c + in + (* For compatibility, bound variables are visible only if no other + binding of the same name exists *) + let accu = Id.Map.map value_of_ident ln in + let accu = lfun +++ accu in + Id.Map.fold (fun id c accu -> Id.Map.add id (of_cub c) accu) lm accu + +(***************************************************************************) +(* Evaluation/interpretation *) + +let is_variable env id = + Id.List.mem id (ids_of_named_context (Environ.named_context env)) + +(* Debug reference *) +let debug = ref DebugOff + +(* Sets the debugger mode *) +let set_debug pos = debug := pos + +(* Gives the state of debug *) +let get_debug () = !debug + +let debugging_step ist pp = match curr_debug ist with + | DebugOn lev -> + safe_msgnl (str "Level " ++ int lev ++ str": " ++ pp () ++ fnl()) + | _ -> Proofview.NonLogical.return () + +let debugging_exception_step ist signal_anomaly e pp = + let explain_exc = + if signal_anomaly then explain_logic_error + else explain_logic_error_no_anomaly in + debugging_step ist (fun () -> + pp() ++ spc() ++ str "raised the exception" ++ fnl() ++ explain_exc e) + +let error_ltac_variable loc id env v s = + user_err ~loc (str "Ltac variable " ++ pr_id id ++ + strbrk " is bound to" ++ spc () ++ pr_value env v ++ spc () ++ + strbrk "which cannot be coerced to " ++ str s ++ str".") + +(* Raise Not_found if not in interpretation sign *) +let try_interp_ltac_var coerce ist env (loc,id) = + let v = Id.Map.find id ist.lfun in + try coerce v with CannotCoerceTo s -> error_ltac_variable loc id env v s + +let interp_ltac_var coerce ist env locid = + try try_interp_ltac_var coerce ist env locid + with Not_found -> anomaly (str "Detected '" ++ Id.print (snd locid) ++ str "' as ltac var at interning time") + +let interp_ident ist env sigma id = + try try_interp_ltac_var (coerce_var_to_ident false env sigma) ist (Some (env,sigma)) (dloc,id) + with Not_found -> id + +(* Interprets an optional identifier, bound or fresh *) +let interp_name ist env sigma = function + | Anonymous -> Anonymous + | Name id -> Name (interp_ident ist env sigma id) + +let interp_intro_pattern_var loc ist env sigma id = + try try_interp_ltac_var (coerce_to_intro_pattern env sigma) ist (Some (env,sigma)) (loc,id) + with Not_found -> IntroNaming (IntroIdentifier id) + +let interp_intro_pattern_naming_var loc ist env sigma id = + try try_interp_ltac_var (coerce_to_intro_pattern_naming env sigma) ist (Some (env,sigma)) (loc,id) + with Not_found -> IntroIdentifier id + +let interp_int ist locid = + try try_interp_ltac_var coerce_to_int ist None locid + with Not_found -> + user_err ~loc:(fst locid) ~hdr:"interp_int" + (str "Unbound variable " ++ pr_id (snd locid) ++ str".") + +let interp_int_or_var ist = function + | ArgVar locid -> interp_int ist locid + | ArgArg n -> n + +let interp_int_or_var_as_list ist = function + | ArgVar (_,id as locid) -> + (try coerce_to_int_or_var_list (Id.Map.find id ist.lfun) + with Not_found | CannotCoerceTo _ -> [ArgArg (interp_int ist locid)]) + | ArgArg n as x -> [x] + +let interp_int_or_var_list ist l = + List.flatten (List.map (interp_int_or_var_as_list ist) l) + +(* Interprets a bound variable (especially an existing hypothesis) *) +let interp_hyp ist env sigma (loc,id as locid) = + (* Look first in lfun for a value coercible to a variable *) + try try_interp_ltac_var (coerce_to_hyp env sigma) ist (Some (env,sigma)) locid + with Not_found -> + (* Then look if bound in the proof context at calling time *) + if is_variable env id then id + else Loc.raise ~loc (Logic.RefinerError (Logic.NoSuchHyp id)) + +let interp_hyp_list_as_list ist env sigma (loc,id as x) = + try coerce_to_hyp_list env sigma (Id.Map.find id ist.lfun) + with Not_found | CannotCoerceTo _ -> [interp_hyp ist env sigma x] + +let interp_hyp_list ist env sigma l = + List.flatten (List.map (interp_hyp_list_as_list ist env sigma) l) + +let interp_move_location ist env sigma = function + | MoveAfter id -> MoveAfter (interp_hyp ist env sigma id) + | MoveBefore id -> MoveBefore (interp_hyp ist env sigma id) + | MoveFirst -> MoveFirst + | MoveLast -> MoveLast + +let interp_reference ist env sigma = function + | ArgArg (_,r) -> r + | ArgVar (loc, id) -> + try try_interp_ltac_var (coerce_to_reference env sigma) ist (Some (env,sigma)) (loc, id) + with Not_found -> + try + VarRef (get_id (Environ.lookup_named id env)) + with Not_found -> error_global_not_found ~loc (qualid_of_ident id) + +let try_interp_evaluable env (loc, id) = + let v = Environ.lookup_named id env in + match v with + | LocalDef _ -> EvalVarRef id + | _ -> error_not_evaluable (VarRef id) + +let interp_evaluable ist env sigma = function + | ArgArg (r,Some (loc,id)) -> + (* Maybe [id] has been introduced by Intro-like tactics *) + begin + try try_interp_evaluable env (loc, id) + with Not_found -> + match r with + | EvalConstRef _ -> r + | _ -> error_global_not_found ~loc (qualid_of_ident id) + end + | ArgArg (r,None) -> r + | ArgVar (loc, id) -> + try try_interp_ltac_var (coerce_to_evaluable_ref env sigma) ist (Some (env,sigma)) (loc, id) + with Not_found -> + try try_interp_evaluable env (loc, id) + with Not_found -> error_global_not_found ~loc (qualid_of_ident id) + +(* Interprets an hypothesis name *) +let interp_occurrences ist occs = + Locusops.occurrences_map (interp_int_or_var_list ist) occs + +let interp_hyp_location ist env sigma ((occs,id),hl) = + ((interp_occurrences ist occs,interp_hyp ist env sigma id),hl) + +let interp_hyp_location_list_as_list ist env sigma ((occs,id),hl as x) = + match occs,hl with + | AllOccurrences,InHyp -> + List.map (fun id -> ((AllOccurrences,id),InHyp)) + (interp_hyp_list_as_list ist env sigma id) + | _,_ -> [interp_hyp_location ist env sigma x] + +let interp_hyp_location_list ist env sigma l = + List.flatten (List.map (interp_hyp_location_list_as_list ist env sigma) l) + +let interp_clause ist env sigma { onhyps=ol; concl_occs=occs } : clause = + { onhyps=Option.map (interp_hyp_location_list ist env sigma) ol; + concl_occs=interp_occurrences ist occs } + +(* Interpretation of constructions *) + +(* Extract the constr list from lfun *) +let extract_ltac_constr_values ist env = + let fold id v accu = + try + let c = coerce_to_constr env v in + Id.Map.add id c accu + with CannotCoerceTo _ -> accu + in + Id.Map.fold fold ist.lfun Id.Map.empty +(** ppedrot: I have changed the semantics here. Before this patch, closure was + implemented as a list and a variable could be bound several times with + different types, resulting in its possible appearance on both sides. This + could barely be defined as a feature... *) + +(* Extract the identifier list from lfun: join all branches (what to do else?)*) +let rec intropattern_ids (loc,pat) = match pat with + | IntroNaming (IntroIdentifier id) -> [id] + | IntroAction (IntroOrAndPattern (IntroAndPattern l)) -> + List.flatten (List.map intropattern_ids l) + | IntroAction (IntroOrAndPattern (IntroOrPattern ll)) -> + List.flatten (List.map intropattern_ids (List.flatten ll)) + | IntroAction (IntroInjection l) -> + List.flatten (List.map intropattern_ids l) + | IntroAction (IntroApplyOn ((_,c),pat)) -> intropattern_ids pat + | IntroNaming (IntroAnonymous | IntroFresh _) + | IntroAction (IntroWildcard | IntroRewrite _) + | IntroForthcoming _ -> [] + +let extract_ids ids lfun = + let fold id v accu = + let v = Value.normalize v in + if has_type v (topwit wit_intro_pattern) then + let (_, ipat) = out_gen (topwit wit_intro_pattern) v in + if Id.List.mem id ids then accu + else accu @ intropattern_ids (dloc, ipat) + else accu + in + Id.Map.fold fold lfun [] + +let default_fresh_id = Id.of_string "H" + +let interp_fresh_id ist env sigma l = + let extract_ident ist env sigma id = + try try_interp_ltac_var (coerce_to_ident_not_fresh env sigma) + ist (Some (env,sigma)) (dloc,id) + with Not_found -> id in + let ids = List.map_filter (function ArgVar (_, id) -> Some id | _ -> None) l in + let avoid = match TacStore.get ist.extra f_avoid_ids with + | None -> [] + | Some l -> l + in + let avoid = (extract_ids ids ist.lfun) @ avoid in + let id = + if List.is_empty l then default_fresh_id + else + let s = + String.concat "" (List.map (function + | ArgArg s -> s + | ArgVar (_,id) -> Id.to_string (extract_ident ist env sigma id)) l) in + let s = if CLexer.is_keyword s then s^"0" else s in + Id.of_string s in + Tactics.fresh_id_in_env avoid id env + +(* Extract the uconstr list from lfun *) +let extract_ltac_constr_context ist env sigma = + let open Glob_term in + let add_uconstr id v map = + try Id.Map.add id (coerce_to_uconstr env v) map + with CannotCoerceTo _ -> map + in + let add_constr id v map = + try Id.Map.add id (coerce_to_constr env v) map + with CannotCoerceTo _ -> map + in + let add_ident id v map = + try Id.Map.add id (coerce_var_to_ident false env sigma v) map + with CannotCoerceTo _ -> map + in + let fold id v {idents;typed;untyped} = + let idents = add_ident id v idents in + let typed = add_constr id v typed in + let untyped = add_uconstr id v untyped in + { idents ; typed ; untyped } + in + let empty = { idents = Id.Map.empty ;typed = Id.Map.empty ; untyped = Id.Map.empty } in + Id.Map.fold fold ist.lfun empty + +(** Significantly simpler than [interp_constr], to interpret an + untyped constr, it suffices to adjoin a closure environment. *) +let interp_uconstr ist env sigma = function + | (term,None) -> + { closure = extract_ltac_constr_context ist env sigma; term } + | (_,Some ce) -> + let ( {typed ; untyped } as closure) = extract_ltac_constr_context ist env sigma in + let ltacvars = { + Constrintern.ltac_vars = Id.(Set.union (Map.domain typed) (Map.domain untyped)); + ltac_bound = Id.Map.domain ist.lfun; + } in + { closure ; term = intern_gen WithoutTypeConstraint ~ltacvars env ce } + +let interp_gen kind ist allow_patvar flags env sigma (c,ce) = + let constrvars = extract_ltac_constr_context ist env sigma in + let vars = { + Pretyping.ltac_constrs = constrvars.typed; + Pretyping.ltac_uconstrs = constrvars.untyped; + Pretyping.ltac_idents = constrvars.idents; + Pretyping.ltac_genargs = ist.lfun; + } in + let c = match ce with + | None -> c + (* If at toplevel (ce<>None), the error can be due to an incorrect + context at globalization time: we retype with the now known + intros/lettac/inversion hypothesis names *) + | Some c -> + let constr_context = + Id.Set.union + (Id.Map.domain constrvars.typed) + (Id.Set.union + (Id.Map.domain constrvars.untyped) + (Id.Map.domain constrvars.idents)) + in + let ltacvars = { + ltac_vars = constr_context; + ltac_bound = Id.Map.domain ist.lfun; + } in + let kind_for_intern = + match kind with OfType _ -> WithoutTypeConstraint | _ -> kind in + intern_gen kind_for_intern ~allow_patvar ~ltacvars env c + in + (* Jason Gross: To avoid unnecessary modifications to tacinterp, as + suggested by Arnaud Spiwack, we run push_trace immediately. We do + this with the kludge of an empty proofview, and rely on the + invariant that running the tactic returned by push_trace does + not modify sigma. *) + let (_, dummy_proofview) = Proofview.init sigma [] in + let (trace,_,_,_) = Proofview.apply env (push_trace (loc_of_glob_constr c,LtacConstrInterp (c,vars)) ist) dummy_proofview in + let (evd,c) = + catch_error trace (understand_ltac flags env sigma vars kind) c + in + (* spiwack: to avoid unnecessary modifications of tacinterp, as this + function already use effect, I call [run] hoping it doesn't mess + up with any assumption. *) + Proofview.NonLogical.run (db_constr (curr_debug ist) env evd c); + (evd,c) + +let constr_flags () = { + use_typeclasses = true; + solve_unification_constraints = true; + use_hook = solve_by_implicit_tactic (); + fail_evar = true; + expand_evars = true } + +(* Interprets a constr; expects evars to be solved *) +let interp_constr_gen kind ist env sigma c = + interp_gen kind ist false (constr_flags ()) env sigma c + +let interp_constr = interp_constr_gen WithoutTypeConstraint + +let interp_type = interp_constr_gen IsType + +let open_constr_use_classes_flags () = { + use_typeclasses = true; + solve_unification_constraints = true; + use_hook = solve_by_implicit_tactic (); + fail_evar = false; + expand_evars = true } + +let open_constr_no_classes_flags () = { + use_typeclasses = false; + solve_unification_constraints = true; + use_hook = solve_by_implicit_tactic (); + fail_evar = false; + expand_evars = true } + +let pure_open_constr_flags = { + use_typeclasses = false; + solve_unification_constraints = true; + use_hook = None; + fail_evar = false; + expand_evars = false } + +(* Interprets an open constr *) +let interp_open_constr ?(expected_type=WithoutTypeConstraint) ist env sigma c = + let flags = + if expected_type == WithoutTypeConstraint then open_constr_no_classes_flags () + else open_constr_use_classes_flags () in + interp_gen expected_type ist false flags env sigma c + +let interp_pure_open_constr ist = + interp_gen WithoutTypeConstraint ist false pure_open_constr_flags + +let interp_typed_pattern ist env sigma (_,c,_) = + let sigma, c = + interp_gen WithoutTypeConstraint ist true pure_open_constr_flags env sigma c in + (** FIXME: it is necessary to be unsafe here because of the way we handle + evars in the pretyper. Sometimes they get solved eagerly. *) + pattern_of_constr env sigma (EConstr.Unsafe.to_constr c) + +(* Interprets a constr expression *) +let interp_constr_in_compound_list inj_fun dest_fun interp_fun ist env sigma l = + let try_expand_ltac_var sigma x = + try match dest_fun x with + | GVar (_,id), _ -> + let v = Id.Map.find id ist.lfun in + sigma, List.map inj_fun (coerce_to_constr_list env v) + | _ -> + raise Not_found + with CannotCoerceTo _ | Not_found -> + (* dest_fun, List.assoc may raise Not_found *) + let sigma, c = interp_fun ist env sigma x in + sigma, [c] in + let sigma, l = List.fold_map try_expand_ltac_var sigma l in + sigma, List.flatten l + +let interp_constr_list ist env sigma c = + interp_constr_in_compound_list (fun x -> x) (fun x -> x) interp_constr ist env sigma c + +let interp_open_constr_list = + interp_constr_in_compound_list (fun x -> x) (fun x -> x) interp_open_constr + +(* Interprets a reduction expression *) +let interp_unfold ist env sigma (occs,qid) = + (interp_occurrences ist occs,interp_evaluable ist env sigma qid) + +let interp_flag ist env sigma red = + { red with rConst = List.map (interp_evaluable ist env sigma) red.rConst } + +let interp_constr_with_occurrences ist env sigma (occs,c) = + let (sigma,c_interp) = interp_constr ist env sigma c in + sigma , (interp_occurrences ist occs, c_interp) + +let interp_closed_typed_pattern_with_occurrences ist env sigma (occs, a) = + let p = match a with + | Inl (ArgVar (loc,id)) -> + (* This is the encoding of an ltac var supposed to be bound + prioritary to an evaluable reference and otherwise to a constr + (it is an encoding to satisfy the "union" type given to Simpl) *) + let coerce_eval_ref_or_constr x = + try Inl (coerce_to_evaluable_ref env sigma x) + with CannotCoerceTo _ -> + let c = coerce_to_closed_constr env x in + Inr (pattern_of_constr env sigma (EConstr.to_constr sigma c)) in + (try try_interp_ltac_var coerce_eval_ref_or_constr ist (Some (env,sigma)) (loc,id) + with Not_found -> + error_global_not_found ~loc (qualid_of_ident id)) + | Inl (ArgArg _ as b) -> Inl (interp_evaluable ist env sigma b) + | Inr c -> Inr (interp_typed_pattern ist env sigma c) in + interp_occurrences ist occs, p + +let interp_constr_with_occurrences_and_name_as_list = + interp_constr_in_compound_list + (fun c -> ((AllOccurrences,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 + sigma, (c_interp, + interp_name ist env sigma na)) + +let interp_red_expr ist env sigma = function + | Unfold l -> sigma , Unfold (List.map (interp_unfold ist env sigma) l) + | Fold l -> + let (sigma,l_interp) = interp_constr_list ist env sigma l in + sigma , Fold l_interp + | Cbv f -> sigma , Cbv (interp_flag ist env sigma f) + | Cbn f -> sigma , Cbn (interp_flag ist env sigma f) + | Lazy f -> sigma , Lazy (interp_flag ist env sigma f) + | Pattern l -> + let (sigma,l_interp) = + Evd.MonadR.List.map_right + (fun c sigma -> interp_constr_with_occurrences ist env sigma c) l sigma + in + sigma , Pattern l_interp + | Simpl (f,o) -> + sigma , Simpl (interp_flag ist env sigma f, + Option.map (interp_closed_typed_pattern_with_occurrences ist env sigma) o) + | CbvVm o -> + sigma , CbvVm (Option.map (interp_closed_typed_pattern_with_occurrences ist env sigma) o) + | CbvNative o -> + sigma , CbvNative (Option.map (interp_closed_typed_pattern_with_occurrences ist env sigma) o) + | (Red _ | Hnf | ExtraRedExpr _ as r) -> sigma , r + +let interp_may_eval f ist env sigma = function + | ConstrEval (r,c) -> + let (sigma,redexp) = interp_red_expr ist env sigma r in + let (sigma,c_interp) = f ist env sigma c in + let (redfun, _) = Redexpr.reduction_of_red_expr env redexp in + let sigma = Sigma.Unsafe.of_evar_map sigma in + let Sigma (c, sigma, _) = redfun.Reductionops.e_redfun env sigma c_interp in + (Sigma.to_evar_map sigma, c) + | ConstrContext ((loc,s),c) -> + (try + let (sigma,ic) = f ist env sigma c in + let ctxt = coerce_to_constr_context (Id.Map.find s ist.lfun) in + let ctxt = EConstr.Unsafe.to_constr ctxt in + let evdref = ref sigma in + let ic = EConstr.Unsafe.to_constr ic in + let c = subst_meta [Constr_matching.special_meta,ic] ctxt in + let c = Typing.e_solve_evars env evdref (EConstr.of_constr c) in + !evdref , c + with + | Not_found -> + user_err ~loc ~hdr:"interp_may_eval" + (str "Unbound context identifier" ++ pr_id s ++ str".")) + | ConstrTypeOf c -> + let (sigma,c_interp) = f ist env sigma c in + let (sigma, t) = Typing.type_of ~refresh:true env sigma c_interp in + (sigma, t) + | ConstrTerm c -> + try + f ist env sigma c + with reraise -> + let reraise = CErrors.push reraise in + (* spiwack: to avoid unnecessary modifications of tacinterp, as this + function already use effect, I call [run] hoping it doesn't mess + up with any assumption. *) + Proofview.NonLogical.run (debugging_exception_step ist false (fst reraise) (fun () -> + str"interpretation of term " ++ pr_glob_constr_env env (fst c))); + iraise reraise + +(* Interprets a constr expression possibly to first evaluate *) +let interp_constr_may_eval ist env sigma c = + let (sigma,csr) = + try + interp_may_eval interp_constr ist env sigma c + with reraise -> + let reraise = CErrors.push reraise in + (* spiwack: to avoid unnecessary modifications of tacinterp, as this + function already use effect, I call [run] hoping it doesn't mess + up with any assumption. *) + Proofview.NonLogical.run (debugging_exception_step ist false (fst reraise) (fun () -> str"evaluation of term")); + iraise reraise + in + begin + (* spiwack: to avoid unnecessary modifications of tacinterp, as this + function already use effect, I call [run] hoping it doesn't mess + up with any assumption. *) + Proofview.NonLogical.run (db_constr (curr_debug ist) env sigma csr); + sigma , csr + end + +(** TODO: should use dedicated printers *) +let rec message_of_value v = + let v = Value.normalize v in + let open Ftactic in + if has_type v (topwit wit_tacvalue) then + Ftactic.return (str "<tactic>") + else if has_type v (topwit wit_constr) then + let v = out_gen (topwit wit_constr) v in + Ftactic.enter {enter = begin fun gl -> Ftactic.return (pr_econstr_env (pf_env gl) (project gl) v) end } + else if has_type v (topwit wit_constr_under_binders) then + let c = out_gen (topwit wit_constr_under_binders) v in + Ftactic.enter { enter = begin fun gl -> + Ftactic.return (pr_constr_under_binders_env (pf_env gl) (project gl) c) + end } + else if has_type v (topwit wit_unit) then + Ftactic.return (str "()") + else if has_type v (topwit wit_int) then + 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 = + let (c, sigma) = Tactics.run_delayed env sigma c in + pr_econstr_env env sigma c + in + Ftactic.enter { enter = begin fun gl -> + Ftactic.return (Miscprint.pr_intro_pattern (fun c -> print (pf_env gl) (project gl) c) p) + end } + else if has_type v (topwit wit_constr_context) then + let c = out_gen (topwit wit_constr_context) v in + Ftactic.enter { enter = begin fun gl -> Ftactic.return (pr_econstr_env (pf_env gl) (project gl) c) end } + else if has_type v (topwit wit_uconstr) then + let c = out_gen (topwit wit_uconstr) v in + Ftactic.enter { enter = begin fun gl -> + Ftactic.return (pr_closed_glob_env (pf_env gl) + (project gl) c) + end } + else if has_type v (topwit wit_var) then + let id = out_gen (topwit wit_var) v in + Ftactic.enter { enter = begin fun gl -> Ftactic.return (pr_id id) end } + else match Value.to_list v with + | Some l -> + Ftactic.List.map message_of_value l >>= fun l -> + Ftactic.return (prlist_with_sep spc (fun x -> x) l) + | None -> + let tag = pr_argument_type v in + Ftactic.return (str "<" ++ tag ++ str ">") (** TODO *) + +let interp_message_token ist = function + | MsgString s -> Ftactic.return (str s) + | MsgInt n -> Ftactic.return (int n) + | MsgIdent (loc,id) -> + let v = try Some (Id.Map.find id ist.lfun) with Not_found -> None in + match v with + | None -> Ftactic.lift (Tacticals.New.tclZEROMSG (pr_id id ++ str" not found.")) + | Some v -> message_of_value v + +let interp_message ist l = + let open Ftactic in + Ftactic.List.map (interp_message_token ist) l >>= fun l -> + Ftactic.return (prlist_with_sep spc (fun x -> x) l) + +let rec interp_intro_pattern ist env sigma = function + | loc, IntroAction pat -> + let (sigma,pat) = interp_intro_pattern_action ist env sigma pat in + sigma, (loc, IntroAction pat) + | loc, IntroNaming (IntroIdentifier id) -> + sigma, (loc, interp_intro_pattern_var loc ist env sigma id) + | loc, IntroNaming pat -> + sigma, (loc, IntroNaming (interp_intro_pattern_naming loc ist env sigma pat)) + | loc, IntroForthcoming _ as x -> sigma, x + +and interp_intro_pattern_naming loc ist env sigma = function + | IntroFresh id -> IntroFresh (interp_ident ist env sigma id) + | IntroIdentifier id -> interp_intro_pattern_naming_var loc ist env sigma id + | IntroAnonymous as x -> x + +and interp_intro_pattern_action ist env sigma = function + | IntroOrAndPattern l -> + let (sigma,l) = interp_or_and_intro_pattern ist env sigma l in + sigma, IntroOrAndPattern l + | IntroInjection l -> + let sigma,l = interp_intro_pattern_list_as_list ist env sigma l in + sigma, IntroInjection l + | IntroApplyOn ((loc,c),ipat) -> + 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 + Sigma.Unsafe.of_pair (c, sigma) + } in + let sigma,ipat = interp_intro_pattern ist env sigma ipat in + sigma, IntroApplyOn ((loc,c),ipat) + | IntroWildcard | IntroRewrite _ as x -> sigma, x + +and interp_or_and_intro_pattern ist env sigma = function + | IntroAndPattern l -> + let sigma, l = List.fold_map (interp_intro_pattern ist env) sigma l in + sigma, IntroAndPattern l + | IntroOrPattern ll -> + let sigma, ll = List.fold_map (interp_intro_pattern_list_as_list ist env) sigma ll in + sigma, IntroOrPattern ll + +and interp_intro_pattern_list_as_list ist env sigma = function + | [loc,IntroNaming (IntroIdentifier id)] as l -> + (try sigma, coerce_to_intro_pattern_list loc env sigma (Id.Map.find id ist.lfun) + with Not_found | CannotCoerceTo _ -> + List.fold_map (interp_intro_pattern ist env) sigma l) + | l -> List.fold_map (interp_intro_pattern ist env) sigma l + +let interp_intro_pattern_naming_option ist env sigma = function + | None -> None + | Some (loc,pat) -> Some (loc, interp_intro_pattern_naming loc ist env sigma pat) + +let interp_or_and_intro_pattern_option ist env sigma = function + | None -> sigma, None + | Some (ArgVar (loc,id)) -> + (match coerce_to_intro_pattern env sigma (Id.Map.find id ist.lfun) with + | IntroAction (IntroOrAndPattern l) -> sigma, Some (loc,l) + | _ -> + user_err ~loc (str "Cannot coerce to a disjunctive/conjunctive pattern.")) + | Some (ArgArg (loc,l)) -> + let sigma,l = interp_or_and_intro_pattern ist env sigma l in + sigma, Some (loc,l) + +let interp_intro_pattern_option ist env sigma = function + | None -> sigma, None + | Some ipat -> + let sigma, ipat = interp_intro_pattern ist env sigma ipat in + sigma, Some ipat + +let interp_in_hyp_as ist env sigma (id,ipat) = + let sigma, ipat = interp_intro_pattern_option ist env sigma ipat in + sigma,(interp_hyp ist env sigma id,ipat) + +let interp_binding_name ist sigma = function + | AnonHyp n -> AnonHyp n + | NamedHyp id -> + (* If a name is bound, it has to be a quantified hypothesis *) + (* user has to use other names for variables if these ones clash with *) + (* a name intented to be used as a (non-variable) identifier *) + try try_interp_ltac_var (coerce_to_quantified_hypothesis sigma) ist None(dloc,id) + with Not_found -> NamedHyp id + +let interp_declared_or_quantified_hypothesis ist env sigma = function + | AnonHyp n -> AnonHyp n + | NamedHyp id -> + try try_interp_ltac_var + (coerce_to_decl_or_quant_hyp env sigma) ist (Some (env,sigma)) (dloc,id) + with Not_found -> NamedHyp id + +let interp_binding ist env sigma (loc,b,c) = + let sigma, c = interp_open_constr ist env sigma c in + sigma, (loc,interp_binding_name ist sigma b,c) + +let interp_bindings ist env sigma = function +| NoBindings -> + sigma, NoBindings +| ImplicitBindings l -> + let sigma, l = interp_open_constr_list ist env sigma l in + sigma, ImplicitBindings l +| ExplicitBindings l -> + let sigma, l = List.fold_map (interp_binding ist env) sigma l in + sigma, ExplicitBindings l + +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 + sigma, (c,bl) + +let interp_open_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 + sigma, (c, bl) + +let loc_of_bindings = function +| NoBindings -> Loc.ghost +| ImplicitBindings l -> loc_of_glob_constr (fst (List.last l)) +| ExplicitBindings l -> pi1 (List.last l) + +let interp_open_constr_with_bindings_loc ist ((c,_),bl as cb) = + let loc1 = loc_of_glob_constr c in + let loc2 = loc_of_bindings bl in + let loc = if Loc.is_ghost loc2 then loc1 else Loc.merge loc1 loc2 in + 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 + Sigma.Unsafe.of_pair (c, sigma) + } in + (loc,f) + +let interp_destruction_arg ist gl arg = + match arg with + | keep,ElimOnConstr c -> + keep,ElimOnConstr { delayed = fun env sigma -> + let sigma = Sigma.to_evar_map sigma in + let (sigma, c) = interp_constr_with_bindings ist env sigma c in + Sigma.Unsafe.of_pair (c, sigma) + } + | keep,ElimOnAnonHyp n as x -> x + | keep,ElimOnIdent (loc,id) -> + let error () = user_err ~loc + (strbrk "Cannot coerce " ++ pr_id id ++ + strbrk " neither to a quantified hypothesis nor to a term.") + in + let try_cast_id id' = + if Tactics.is_quantified_hypothesis id' gl + then keep,ElimOnIdent (loc,id') + else + (keep, ElimOnConstr { delayed = begin fun env sigma -> + try Sigma.here (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.") + end }) + in + try + (** FIXME: should be moved to taccoerce *) + let v = Id.Map.find id ist.lfun in + let v = Value.normalize v in + if has_type v (topwit wit_intro_pattern) then + let v = out_gen (topwit wit_intro_pattern) v in + match v with + | _, IntroNaming (IntroIdentifier id) -> try_cast_id id + | _ -> error () + else if has_type v (topwit wit_var) then + let id = out_gen (topwit wit_var) v in + try_cast_id id + else if has_type v (topwit wit_int) then + 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) } + with Not_found -> + (* We were in non strict (interactive) mode *) + if Tactics.is_quantified_hypothesis id gl then + keep,ElimOnIdent (loc,id) + else + let c = (GVar (loc,id),Some (CRef (Ident (loc,id),None))) in + 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 + Sigma.Unsafe.of_pair ((c,NoBindings), sigma) + } in + keep,ElimOnConstr f + +(* Associates variables with values and gives the remaining variables and + values *) +let head_with_value (lvar,lval) = + let rec head_with_value_rec lacc = function + | ([],[]) -> (lacc,[],[]) + | (vr::tvr,ve::tve) -> + (match vr with + | Anonymous -> head_with_value_rec lacc (tvr,tve) + | Name v -> head_with_value_rec ((v,ve)::lacc) (tvr,tve)) + | (vr,[]) -> (lacc,vr,[]) + | ([],ve) -> (lacc,[],ve) + in + head_with_value_rec [] (lvar,lval) + +(** [interp_context ctxt] interprets a context (as in + {!Matching.matching_result}) into a context value of Ltac. *) +let interp_context ctxt = in_gen (topwit wit_constr_context) ctxt + +(* Reads a pattern by substituting vars of lfun *) +let use_types = false + +let eval_pattern lfun ist env sigma (bvars,(glob,_),pat as c) = + if use_types then + (bvars,interp_typed_pattern ist env sigma c) + else + (bvars,instantiate_pattern env sigma lfun pat) + +let read_pattern lfun ist env sigma = function + | Subterm (b,ido,c) -> Subterm (b,ido,eval_pattern lfun ist env sigma c) + | Term c -> Term (eval_pattern lfun ist env sigma c) + +(* Reads the hypotheses of a Match Context rule *) +let cons_and_check_name id l = + if Id.List.mem id l then + user_err ~hdr:"read_match_goal_hyps" ( + str "Hypothesis pattern-matching variable " ++ pr_id id ++ + str " used twice in the same pattern.") + else id::l + +let rec read_match_goal_hyps lfun ist env sigma lidh = function + | (Hyp ((loc,na) as locna,mp))::tl -> + let lidh' = name_fold cons_and_check_name na lidh in + Hyp (locna,read_pattern lfun ist env sigma mp):: + (read_match_goal_hyps lfun ist env sigma lidh' tl) + | (Def ((loc,na) as locna,mv,mp))::tl -> + let lidh' = name_fold cons_and_check_name na lidh in + Def (locna,read_pattern lfun ist env sigma mv, read_pattern lfun ist env sigma mp):: + (read_match_goal_hyps lfun ist env sigma lidh' tl) + | [] -> [] + +(* Reads the rules of a Match Context or a Match *) +let rec read_match_rule lfun ist env sigma = function + | (All tc)::tl -> (All tc)::(read_match_rule lfun ist env sigma tl) + | (Pat (rl,mp,tc))::tl -> + Pat (read_match_goal_hyps lfun ist env sigma [] rl, read_pattern lfun ist env sigma mp,tc) + :: read_match_rule lfun ist env sigma tl + | [] -> [] + +let warn_deprecated_info = + CWarnings.create ~name:"deprecated-info-tactical" ~category:"deprecated" + (fun () -> + strbrk "The general \"info\" tactic is currently not working." ++ spc()++ + strbrk "There is an \"Info\" command to replace it." ++fnl () ++ + strbrk "Some specific verbose tactics may also exist, such as info_eauto.") + +(* Interprets an l-tac expression into a value *) +let rec val_interp ist ?(appl=UnnamedAppl) (tac:glob_tactic_expr) : Val.t Ftactic.t = + (* The name [appl] of applied top-level Ltac names is ignored in + [value_interp]. It is installed in the second step by a call to + [name_vfun], because it gives more opportunities to detect a + [VFun]. Otherwise a [Ltac t := let x := .. in tac] would never + register its name since it is syntactically a let, not a + function. *) + let value_interp ist = match tac with + | TacFun (it, body) -> + Ftactic.return (of_tacvalue (VFun (UnnamedAppl,extract_trace ist, ist.lfun, it, body))) + | TacLetIn (true,l,u) -> interp_letrec ist l u + | TacLetIn (false,l,u) -> interp_letin ist l u + | TacMatchGoal (lz,lr,lmr) -> interp_match_goal ist lz lr lmr + | TacMatch (lz,c,lmr) -> interp_match ist lz c lmr + | TacArg (loc,a) -> interp_tacarg ist a + | t -> + (** Delayed evaluation *) + Ftactic.return (of_tacvalue (VFun (UnnamedAppl,extract_trace ist, ist.lfun, [], t))) + in + let open Ftactic in + Control.check_for_interrupt (); + match curr_debug ist with + | DebugOn lev -> + let eval v = + let ist = { ist with extra = TacStore.set ist.extra f_debug v } in + value_interp ist >>= fun v -> return (name_vfun appl v) + in + Tactic_debug.debug_prompt lev tac eval + | _ -> value_interp ist >>= fun v -> return (name_vfun appl v) + + +and eval_tactic ist tac : unit Proofview.tactic = match tac with + | TacAtom (loc,t) -> + let call = LtacAtomCall t in + push_trace(loc,call) ist >>= fun trace -> + Profile_ltac.do_profile "eval_tactic:2" trace + (catch_error_tac trace (interp_atomic ist t)) + | TacFun _ | TacLetIn _ -> assert false + | TacMatchGoal _ | TacMatch _ -> assert false + | TacId [] -> Proofview.tclLIFT (db_breakpoint (curr_debug ist) []) + | TacId s -> + let msgnl = + let open Ftactic in + interp_message ist s >>= fun msg -> + return (hov 0 msg , hov 0 msg) + in + let print (_,msgnl) = Proofview.(tclLIFT (NonLogical.print_info msgnl)) in + let log (msg,_) = Proofview.Trace.log (fun () -> msg) in + let break = Proofview.tclLIFT (db_breakpoint (curr_debug ist) s) in + Ftactic.run msgnl begin fun msgnl -> + print msgnl <*> log msgnl <*> break + end + | TacFail (g,n,s) -> + let msg = interp_message ist s in + let tac l = Tacticals.New.tclFAIL (interp_int_or_var ist n) l in + let tac = + match g with + | TacLocal -> fun l -> Proofview.tclINDEPENDENT (tac l) + | TacGlobal -> tac + in + Ftactic.run msg tac + | TacProgress tac -> Tacticals.New.tclPROGRESS (interp_tactic ist tac) + | TacShowHyps tac -> + Proofview.V82.tactic begin + tclSHOWHYPS (Proofview.V82.of_tactic (interp_tactic ist tac)) + end + | TacAbstract (tac,ido) -> + Proofview.Goal.enter { enter = begin fun gl -> Tactics.tclABSTRACT + (Option.map (interp_ident ist (pf_env gl) (project gl)) ido) (interp_tactic ist tac) + end } + | TacThen (t1,t) -> + Tacticals.New.tclTHEN (interp_tactic ist t1) (interp_tactic ist t) + | TacDispatch tl -> + Proofview.tclDISPATCH (List.map (interp_tactic ist) tl) + | TacExtendTac (tf,t,tl) -> + Proofview.tclEXTEND (Array.map_to_list (interp_tactic ist) tf) + (interp_tactic ist t) + (Array.map_to_list (interp_tactic ist) tl) + | TacThens (t1,tl) -> Tacticals.New.tclTHENS (interp_tactic ist t1) (List.map (interp_tactic ist) tl) + | TacThens3parts (t1,tf,t,tl) -> + Tacticals.New.tclTHENS3PARTS (interp_tactic ist t1) + (Array.map (interp_tactic ist) tf) (interp_tactic ist t) (Array.map (interp_tactic ist) tl) + | TacDo (n,tac) -> Tacticals.New.tclDO (interp_int_or_var ist n) (interp_tactic ist tac) + | TacTimeout (n,tac) -> Tacticals.New.tclTIMEOUT (interp_int_or_var ist n) (interp_tactic ist tac) + | TacTime (s,tac) -> Tacticals.New.tclTIME s (interp_tactic ist tac) + | TacTry tac -> Tacticals.New.tclTRY (interp_tactic ist tac) + | TacRepeat tac -> Tacticals.New.tclREPEAT (interp_tactic ist tac) + | TacOr (tac1,tac2) -> + Tacticals.New.tclOR (interp_tactic ist tac1) (interp_tactic ist tac2) + | TacOnce tac -> + Tacticals.New.tclONCE (interp_tactic ist tac) + | TacExactlyOnce tac -> + Tacticals.New.tclEXACTLY_ONCE (interp_tactic ist tac) + | TacIfThenCatch (t,tt,te) -> + Tacticals.New.tclIFCATCH + (interp_tactic ist t) + (fun () -> interp_tactic ist tt) + (fun () -> interp_tactic ist te) + | TacOrelse (tac1,tac2) -> + Tacticals.New.tclORELSE (interp_tactic ist tac1) (interp_tactic ist tac2) + | TacFirst l -> Tacticals.New.tclFIRST (List.map (interp_tactic ist) l) + | TacSolve l -> Tacticals.New.tclSOLVE (List.map (interp_tactic ist) l) + | TacComplete tac -> Tacticals.New.tclCOMPLETE (interp_tactic ist tac) + | TacArg a -> interp_tactic ist (TacArg a) + | TacInfo tac -> + warn_deprecated_info (); + eval_tactic ist tac + | TacSelect (sel, tac) -> Tacticals.New.tclSELECT sel (interp_tactic ist tac) + (* For extensions *) + | TacAlias (loc,s,l) -> + let (ids, body) = Tacenv.interp_alias s in + let (>>=) = Ftactic.bind in + let interp_vars = Ftactic.List.map (fun v -> interp_tacarg ist v) l in + let tac l = + let addvar x v accu = Id.Map.add x v accu in + let lfun = List.fold_right2 addvar ids l ist.lfun in + Ftactic.lift (push_trace (loc,LtacNotationCall s) ist) >>= fun trace -> + let ist = { + lfun = lfun; + extra = TacStore.set ist.extra f_trace trace; } in + val_interp ist body >>= fun v -> + Ftactic.lift (tactic_of_value ist v) + in + let tac = + Ftactic.with_env interp_vars >>= fun (env, lr) -> + let name () = Pptactic.pr_alias (fun v -> print_top_val env v) 0 s lr in + Proofview.Trace.name_tactic name (tac lr) + (* spiwack: this use of name_tactic is not robust to a + change of implementation of [Ftactic]. In such a situation, + some more elaborate solution will have to be used. *) + in + let tac = + let len1 = List.length ids in + let len2 = List.length l in + if len1 = len2 then tac + else Tacticals.New.tclZEROMSG (str "Arguments length mismatch: \ + expected " ++ int len1 ++ str ", found " ++ int len2) + in + Ftactic.run tac (fun () -> Proofview.tclUNIT ()) + + | TacML (loc,opn,l) -> + push_trace (loc,LtacMLCall tac) ist >>= fun trace -> + let ist = { ist with extra = TacStore.set ist.extra f_trace trace; } in + let tac = Tacenv.interp_ml_tactic opn in + let args = Ftactic.List.map_right (fun a -> interp_tacarg ist a) l in + let tac args = + let name () = Pptactic.pr_extend (fun v -> print_top_val () v) 0 opn args in + Proofview.Trace.name_tactic name (catch_error_tac trace (tac args ist)) + in + Ftactic.run args tac + +and force_vrec ist v : Val.t Ftactic.t = + let v = Value.normalize v in + if has_type v (topwit wit_tacvalue) then + let v = to_tacvalue v in + match v with + | VRec (lfun,body) -> val_interp {ist with lfun = !lfun} body + | v -> Ftactic.return (of_tacvalue v) + else Ftactic.return v + +and interp_ltac_reference loc' mustbetac ist r : Val.t Ftactic.t = + match r with + | ArgVar (loc,id) -> + let v = + try Id.Map.find id ist.lfun + with Not_found -> in_gen (topwit wit_var) id + in + let open Ftactic in + force_vrec ist v >>= begin fun v -> + Ftactic.lift (propagate_trace ist loc id v) >>= fun v -> + if mustbetac then Ftactic.return (coerce_to_tactic loc id v) else Ftactic.return v + end + | ArgArg (loc,r) -> + let ids = extract_ids [] ist.lfun in + let loc_info = ((if Loc.is_ghost loc' then loc else loc'),LtacNameCall r) in + let extra = TacStore.set ist.extra f_avoid_ids ids in + push_trace loc_info ist >>= fun trace -> + let extra = TacStore.set extra f_trace trace in + let ist = { lfun = Id.Map.empty; extra = extra; } in + let appl = GlbAppl[r,[]] in + val_interp ~appl ist (Tacenv.interp_ltac r) + +and interp_tacarg ist arg : Val.t Ftactic.t = + match arg with + | TacGeneric arg -> interp_genarg ist arg + | Reference r -> interp_ltac_reference dloc false ist r + | ConstrMayEval c -> + Ftactic.s_enter { s_enter = begin fun gl -> + let sigma = project gl in + let env = Proofview.Goal.env gl in + let (sigma,c_interp) = interp_constr_may_eval ist env sigma c in + Sigma.Unsafe.of_pair (Ftactic.return (Value.of_constr c_interp), sigma) + end } + | TacCall (loc,r,[]) -> + interp_ltac_reference loc true ist r + | TacCall (loc,f,l) -> + let (>>=) = Ftactic.bind in + interp_ltac_reference loc true ist f >>= fun fv -> + Ftactic.List.map (fun a -> interp_tacarg ist a) l >>= fun largs -> + interp_app loc ist fv largs + | TacFreshId l -> + Ftactic.enter { enter = begin fun gl -> + let id = interp_fresh_id ist (pf_env gl) (project gl) l in + Ftactic.return (in_gen (topwit wit_intro_pattern) (dloc, IntroNaming (IntroIdentifier id))) + end } + | TacPretype c -> + Ftactic.s_enter { s_enter = begin fun gl -> + let sigma = Proofview.Goal.sigma gl in + let env = Proofview.Goal.env gl in + let c = interp_uconstr ist env (Sigma.to_evar_map sigma) c in + let Sigma (c, sigma, p) = (type_uconstr ist c).delayed env sigma in + Sigma (Ftactic.return (Value.of_constr c), sigma, p) + end } + | TacNumgoals -> + Ftactic.lift begin + let open Proofview.Notations in + Proofview.numgoals >>= fun i -> + Proofview.tclUNIT (Value.of_int i) + end + | Tacexp t -> val_interp ist t + +(* Interprets an application node *) +and interp_app loc ist fv largs : Val.t Ftactic.t = + let (>>=) = Ftactic.bind in + let fail = Tacticals.New.tclZEROMSG (str "Illegal tactic application.") in + let fv = Value.normalize fv in + if has_type fv (topwit wit_tacvalue) then + match to_tacvalue fv with + (* if var=[] and body has been delayed by val_interp, then body + is not a tactic that expects arguments. + Otherwise Ltac goes into an infinite loop (val_interp puts + a VFun back on body, and then interp_app is called again...) *) + | (VFun(appl,trace,olfun,(_::_ as var),body) + |VFun(appl,trace,olfun,([] as var), + (TacFun _|TacLetIn _|TacMatchGoal _|TacMatch _| TacArg _ as body))) -> + let (extfun,lvar,lval)=head_with_value (var,largs) in + let fold accu (id, v) = Id.Map.add id v accu in + let newlfun = List.fold_left fold olfun extfun in + if List.is_empty lvar then + begin Proofview.tclORELSE + begin + let ist = { + lfun = newlfun; + extra = TacStore.set ist.extra f_trace []; } in + catch_error_tac trace (val_interp ist body) >>= fun v -> + Ftactic.return (name_vfun (push_appl appl largs) v) + end + begin fun (e, info) -> + Proofview.tclLIFT (debugging_exception_step ist false e (fun () -> str "evaluation")) <*> + Proofview.tclZERO ~info e + end + end >>= fun v -> + (* No errors happened, we propagate the trace *) + let v = append_trace trace v in + Proofview.tclLIFT begin + debugging_step ist + (fun () -> + str"evaluation returns"++fnl()++pr_value None v) + end <*> + if List.is_empty lval then Ftactic.return v else interp_app loc ist v lval + else + Ftactic.return (of_tacvalue (VFun(push_appl appl largs,trace,newlfun,lvar,body))) + | _ -> fail + else fail + +(* Gives the tactic corresponding to the tactic value *) +and tactic_of_value ist vle = + let vle = Value.normalize vle in + if has_type vle (topwit wit_tacvalue) then + match to_tacvalue vle with + | VFun (appl,trace,lfun,[],t) -> + let ist = { + lfun = lfun; + extra = TacStore.set ist.extra f_trace []; } in + let tac = name_if_glob appl (eval_tactic ist t) in + Profile_ltac.do_profile "tactic_of_value" trace (catch_error_tac trace tac) + | VFun (_, _, _,vars,_) -> + let numargs = List.length vars in + Tacticals.New.tclZEROMSG + (str "A fully applied tactic is expected:" ++ spc() ++ Pp.str "missing " ++ + Pp.str (String.plural numargs "argument") ++ Pp.str " for " ++ + Pp.str (String.plural numargs "variable") ++ Pp.str " " ++ + pr_enum pr_name vars ++ Pp.str ".") + | VRec _ -> Tacticals.New.tclZEROMSG (str "A fully applied tactic is expected.") + else if has_type vle (topwit wit_tactic) then + let tac = out_gen (topwit wit_tactic) vle in + tactic_of_value ist tac + else Tacticals.New.tclZEROMSG (str "Expression does not evaluate to a tactic.") + +(* Interprets the clauses of a recursive LetIn *) +and interp_letrec ist llc u = + Proofview.tclUNIT () >>= fun () -> (* delay for the effects of [lref], just in case. *) + let lref = ref ist.lfun in + let fold accu ((_, id), b) = + let v = of_tacvalue (VRec (lref, TacArg (dloc, b))) in + Id.Map.add id v accu + in + let lfun = List.fold_left fold ist.lfun llc in + let () = lref := lfun in + let ist = { ist with lfun } in + val_interp ist u + +(* Interprets the clauses of a LetIn *) +and interp_letin ist llc u = + let rec fold lfun = function + | [] -> + let ist = { ist with lfun } in + val_interp ist u + | ((_, id), body) :: defs -> + Ftactic.bind (interp_tacarg ist body) (fun v -> + fold (Id.Map.add id v lfun) defs) + in + fold ist.lfun llc + +(** [interp_match_success lz ist succ] interprets a single matching success + (of type {!Tactic_matching.t}). *) +and interp_match_success ist { Tactic_matching.subst ; context ; terms ; lhs } = + let (>>=) = Ftactic.bind in + let lctxt = Id.Map.map interp_context context in + let hyp_subst = Id.Map.map Value.of_constr terms in + let lfun = extend_values_with_bindings subst (lctxt +++ hyp_subst +++ ist.lfun) in + let ist = { ist with lfun } in + val_interp ist lhs >>= fun v -> + if has_type v (topwit wit_tacvalue) then match to_tacvalue v with + | VFun (appl,trace,lfun,[],t) -> + let ist = { + lfun = lfun; + extra = TacStore.set ist.extra f_trace trace; } in + let tac = eval_tactic ist t in + let dummy = VFun (appl,extract_trace ist, Id.Map.empty, [], TacId []) in + catch_error_tac trace (tac <*> Ftactic.return (of_tacvalue dummy)) + | _ -> Ftactic.return v + else Ftactic.return v + + +(** [interp_match_successes lz ist s] interprets the stream of + matching of successes [s]. If [lz] is set to true, then only the + first success is considered, otherwise further successes are tried + if the left-hand side fails. *) +and interp_match_successes lz ist s = + let general = + let break (e, info) = match e with + | FailError (0, _) -> None + | FailError (n, s) -> Some (FailError (pred n, s), info) + | _ -> None + in + Proofview.tclBREAK break s >>= fun ans -> interp_match_success ist ans + in + match lz with + | General -> + general + | Select -> + begin + (** Only keep the first matching result, we don't backtrack on it *) + let s = Proofview.tclONCE s in + s >>= fun ans -> interp_match_success ist ans + end + | Once -> + (** Once a tactic has succeeded, do not backtrack anymore *) + Proofview.tclONCE general + +(* Interprets the Match expressions *) +and interp_match ist lz constr lmr = + let (>>=) = Ftactic.bind in + begin Proofview.tclORELSE + (interp_ltac_constr ist constr) + begin function + | (e, info) -> + Proofview.tclLIFT (debugging_exception_step ist true e + (fun () -> str "evaluation of the matched expression")) <*> + Proofview.tclZERO ~info e + end + end >>= fun constr -> + Ftactic.enter { enter = begin fun gl -> + let sigma = project gl in + let env = Proofview.Goal.env gl in + let ilr = read_match_rule (extract_ltac_constr_values ist env) ist env sigma lmr in + interp_match_successes lz ist (Tactic_matching.match_term env sigma constr ilr) + end } + +(* Interprets the Match Context expressions *) +and interp_match_goal ist lz lr lmr = + Ftactic.enter { enter = begin fun gl -> + let sigma = project gl in + let env = Proofview.Goal.env gl in + let hyps = Proofview.Goal.hyps gl in + let hyps = if lr then List.rev hyps else hyps in + let concl = Proofview.Goal.concl gl in + let ilr = read_match_rule (extract_ltac_constr_values ist env) ist env sigma lmr in + interp_match_successes lz ist (Tactic_matching.match_goal env sigma hyps concl ilr) + end } + +(* Interprets extended tactic generic arguments *) +and interp_genarg ist x : Val.t Ftactic.t = + let open Ftactic.Notations in + (** Ad-hoc handling of some types. *) + let tag = genarg_tag x in + if argument_type_eq tag (unquote (topwit (wit_list wit_var))) then + interp_genarg_var_list ist x + else if argument_type_eq tag (unquote (topwit (wit_list wit_constr))) then + interp_genarg_constr_list ist x + else + let GenArg (Glbwit wit, x) = x in + match wit with + | ListArg wit -> + let map x = interp_genarg ist (Genarg.in_gen (glbwit wit) x) in + Ftactic.List.map map x >>= fun l -> + Ftactic.return (Val.Dyn (Val.typ_list, l)) + | OptArg wit -> + begin match x with + | None -> Ftactic.return (Val.Dyn (Val.typ_opt, None)) + | Some x -> + interp_genarg ist (Genarg.in_gen (glbwit wit) x) >>= fun x -> + Ftactic.return (Val.Dyn (Val.typ_opt, Some x)) + end + | PairArg (wit1, wit2) -> + let (p, q) = x in + interp_genarg ist (Genarg.in_gen (glbwit wit1) p) >>= fun p -> + interp_genarg ist (Genarg.in_gen (glbwit wit2) q) >>= fun q -> + Ftactic.return (Val.Dyn (Val.typ_pair, (p, q))) + | ExtraArg s -> + Geninterp.interp wit ist x + +(** returns [true] for genargs which have the same meaning + independently of goals. *) + +and interp_genarg_constr_list ist x = + Ftactic.nf_s_enter { s_enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + let lc = Genarg.out_gen (glbwit (wit_list wit_constr)) x in + let (sigma,lc) = interp_constr_list ist env sigma lc in + let lc = in_list (val_tag wit_constr) lc in + Sigma.Unsafe.of_pair (Ftactic.return lc, sigma) + end } + +and interp_genarg_var_list ist x = + Ftactic.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + let lc = Genarg.out_gen (glbwit (wit_list wit_var)) x in + let lc = interp_hyp_list ist env sigma lc in + let lc = in_list (val_tag wit_var) lc in + Ftactic.return lc + end } + +(* Interprets tactic expressions : returns a "constr" *) +and interp_ltac_constr ist e : EConstr.t Ftactic.t = + let (>>=) = Ftactic.bind in + begin Proofview.tclORELSE + (val_interp ist e) + begin function (err, info) -> match err with + | Not_found -> + Ftactic.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + Proofview.tclLIFT begin + debugging_step ist (fun () -> + str "evaluation failed for" ++ fnl() ++ + Pptactic.pr_glob_tactic env e) + end + <*> Proofview.tclZERO Not_found + end } + | err -> Proofview.tclZERO ~info err + end + end >>= fun result -> + Ftactic.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = project gl in + let result = Value.normalize result in + try + let cresult = coerce_to_closed_constr env result in + Proofview.tclLIFT begin + debugging_step ist (fun () -> + Pptactic.pr_glob_tactic env e ++ fnl() ++ + str " has value " ++ fnl() ++ + pr_econstr_env env sigma cresult) + end <*> + Ftactic.return cresult + with CannotCoerceTo _ -> + let env = Proofview.Goal.env gl in + Tacticals.New.tclZEROMSG (str "Must evaluate to a closed term" ++ fnl() ++ + str "offending expression: " ++ fnl() ++ pr_inspect env e result) + end } + + +(* Interprets tactic expressions : returns a "tactic" *) +and interp_tactic ist tac : unit Proofview.tactic = + Ftactic.run (val_interp ist tac) (fun v -> tactic_of_value ist v) + +(* Provides a "name" for the trace to atomic tactics *) +and name_atomic ?env tacexpr tac : unit Proofview.tactic = + begin match env with + | Some e -> Proofview.tclUNIT e + | None -> Proofview.tclENV + end >>= fun env -> + Proofview.tclEVARMAP >>= fun sigma -> + let name () = Pptactic.pr_atomic_tactic env sigma tacexpr in + Proofview.Trace.name_tactic name tac + +(* Interprets a primitive tactic *) +and interp_atomic ist tac : unit Proofview.tactic = + match tac with + (* Basic tactics *) + | TacIntroPattern (ev,l) -> + Proofview.Goal.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = project gl in + let sigma,l' = interp_intro_pattern_list_as_list ist env sigma l in + Tacticals.New.tclWITHHOLES ev + (name_atomic ~env + (TacIntroPattern (ev,l)) + (* spiwack: print uninterpreted, not sure if it is the + expected behaviour. *) + (Tactics.intro_patterns ev l')) sigma + end } + | TacApply (a,ev,cb,cl) -> + (* spiwack: until the tactic is in the monad *) + Proofview.Trace.name_tactic (fun () -> Pp.str"<apply>") begin + Proofview.Goal.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = project gl in + let l = List.map (fun (k,c) -> + let loc, f = interp_open_constr_with_bindings_loc ist c in + (k,(loc,f))) cb + in + let sigma,tac = match cl with + | None -> sigma, Tactics.apply_with_delayed_bindings_gen a ev l + | Some cl -> + let sigma,(id,cl) = interp_in_hyp_as ist env sigma cl in + sigma, Tactics.apply_delayed_in a ev id l cl in + Tacticals.New.tclWITHHOLES ev tac sigma + end } + end + | TacElim (ev,(keep,cb),cbo) -> + Proofview.Goal.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = project gl in + let sigma, cb = interp_constr_with_bindings ist env sigma cb in + let sigma, cbo = Option.fold_map (interp_constr_with_bindings ist env) sigma cbo in + let named_tac = + let tac = Tactics.elim ev keep cb cbo in + name_atomic ~env (TacElim (ev,(keep,cb),cbo)) tac + in + Tacticals.New.tclWITHHOLES ev named_tac sigma + end } + | TacCase (ev,(keep,cb)) -> + Proofview.Goal.enter { enter = begin fun gl -> + let sigma = project gl in + let env = Proofview.Goal.env gl in + let sigma, cb = interp_constr_with_bindings ist env sigma cb in + let named_tac = + let tac = Tactics.general_case_analysis ev keep cb in + name_atomic ~env (TacCase(ev,(keep,cb))) tac + in + Tacticals.New.tclWITHHOLES ev named_tac sigma + end } + | TacMutualFix (id,n,l) -> + (* spiwack: until the tactic is in the monad *) + Proofview.Trace.name_tactic (fun () -> Pp.str"<mutual fix>") begin + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + 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 + let (sigma,l_interp) = + Evd.MonadR.List.map_right (fun c sigma -> f sigma c) l (project gl) + in + let tac = Tactics.mutual_fix (interp_ident ist env sigma id) n l_interp 0 in + Sigma.Unsafe.of_pair (tac, sigma) + end } + end + | TacMutualCofix (id,l) -> + (* spiwack: until the tactic is in the monad *) + Proofview.Trace.name_tactic (fun () -> Pp.str"<mutual cofix>") begin + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + 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 + let (sigma,l_interp) = + Evd.MonadR.List.map_right (fun c sigma -> f sigma c) l (project gl) + in + let tac = Tactics.mutual_cofix (interp_ident ist env sigma id) l_interp 0 in + Sigma.Unsafe.of_pair (tac, sigma) + end } + end + | TacAssert (b,t,ipat,c) -> + Proofview.Goal.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = project gl in + let (sigma,c) = + (if Option.is_empty t then interp_constr else interp_type) ist env sigma 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 + (name_atomic ~env + (TacAssert(b,Option.map (Option.map ignore) t,ipat,c)) + (Tactics.forward b tac ipat' c)) sigma + end } + | TacGeneralize cl -> + Proofview.Goal.enter { enter = begin fun gl -> + let sigma = project gl in + let env = Proofview.Goal.env gl in + let sigma, cl = interp_constr_with_occurrences_and_name_as_list ist env sigma cl in + Tacticals.New.tclWITHHOLES false + (name_atomic ~env + (TacGeneralize cl) + (Tactics.generalize_gen cl)) sigma + end } + | TacLetTac (na,c,clp,b,eqpat) -> + Proofview.Goal.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = project gl in + let clp = interp_clause ist env sigma clp in + let eqpat = interp_intro_pattern_naming_option ist env sigma eqpat in + 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 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 + Tactics.letin_tac with_eq na c None cl + in + let na = interp_name ist env sigma na in + Tacticals.New.tclWITHHOLES false + (name_atomic ~env + (TacLetTac(na,c_interp,clp,b,eqpat)) + (let_tac b na c_interp clp eqpat)) sigma + else + (* We try to keep the pattern structure as much as possible *) + let let_pat_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 + Tactics.letin_pat_tac with_eq na c cl + in + let (sigma',c) = interp_pure_open_constr ist env sigma 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,c) clp eqpat) sigma') + end } + + (* Derived basic tactics *) + | TacInductionDestruct (isrec,ev,(l,el)) -> + (* spiwack: some unknown part of destruct needs the goal to be + prenormalised. *) + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = project gl in + let sigma,l = + List.fold_map begin fun sigma (c,(ipato,ipats),cls) -> + (* TODO: move sigma as a side-effect *) + (* spiwack: the [*p] variants are for printing *) + let cp = c in + let c = interp_destruction_arg ist gl c in + let ipato = interp_intro_pattern_naming_option ist env sigma ipato in + let ipatsp = ipats in + let sigma,ipats = interp_or_and_intro_pattern_option ist env sigma ipats in + let cls = Option.map (interp_clause ist env sigma) cls in + sigma,((c,(ipato,ipats),cls),(cp,(ipato,ipatsp),cls)) + end sigma l + in + let l,lp = List.split l in + let sigma,el = + Option.fold_map (interp_constr_with_bindings ist env) sigma el in + let tac = name_atomic ~env + (TacInductionDestruct(isrec,ev,(lp,el))) + (Tactics.induction_destruct isrec ev (l,el)) + in + Sigma.Unsafe.of_pair (tac, sigma) + end } + + (* Conversion *) + | TacReduce (r,cl) -> + Proofview.Goal.nf_s_enter { s_enter = begin fun gl -> + let (sigma,r_interp) = interp_red_expr ist (pf_env gl) (project gl) r in + Sigma.Unsafe.of_pair (Tactics.reduce r_interp (interp_clause ist (pf_env gl) (project gl) cl), sigma) + end } + | TacChange (None,c,cl) -> + (* spiwack: until the tactic is in the monad *) + Proofview.Trace.name_tactic (fun () -> Pp.str"<change>") begin + Proofview.Goal.enter { enter = begin fun gl -> + let is_onhyps = match cl.onhyps with + | None | Some [] -> true + | _ -> false + in + let is_onconcl = match cl.concl_occs with + | AllOccurrences | NoOccurrences -> true + | _ -> false + in + let c_interp patvars = { Sigma.run = begin fun sigma -> + let lfun' = Id.Map.fold (fun id c lfun -> + Id.Map.add id (Value.of_constr c) lfun) + patvars ist.lfun + in + let sigma = Sigma.to_evar_map sigma in + let ist = { ist with lfun = lfun' } in + let (sigma, c) = + if is_onhyps && is_onconcl + then interp_type ist (pf_env gl) sigma c + else interp_constr ist (pf_env gl) sigma c + in + Sigma.Unsafe.of_pair (c, sigma) + end } in + Tactics.change None c_interp (interp_clause ist (pf_env gl) (project gl) cl) + end } + end + | TacChange (Some op,c,cl) -> + (* spiwack: until the tactic is in the monad *) + Proofview.Trace.name_tactic (fun () -> Pp.str"<change>") begin + Proofview.Goal.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = project gl in + let op = interp_typed_pattern ist env sigma op in + let to_catch = function Not_found -> true | e -> CErrors.is_anomaly e in + let c_interp patvars = { Sigma.run = begin fun sigma -> + let lfun' = Id.Map.fold (fun id c lfun -> + Id.Map.add id (Value.of_constr c) lfun) + patvars ist.lfun + in + let ist = { ist with lfun = lfun' } in + try + let sigma = Sigma.to_evar_map sigma in + let (sigma, c) = interp_constr ist env sigma 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.") + end } in + Tactics.change (Some op) c_interp (interp_clause ist env sigma cl) + end } + end + + + (* Equality and inversion *) + | TacRewrite (ev,l,cl,by) -> + Proofview.Goal.enter { enter = begin fun gl -> + let l' = List.map (fun (b,m,(keep,c)) -> + 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 + Sigma.Unsafe.of_pair (c, sigma) + } in + (b,m,keep,f)) l in + let env = Proofview.Goal.env gl in + let sigma = project gl in + let cl = interp_clause ist env sigma cl in + name_atomic ~env + (TacRewrite (ev,l,cl,Option.map ignore by)) + (Equality.general_multi_rewrite ev l' cl + (Option.map (fun by -> Tacticals.New.tclCOMPLETE (interp_tactic ist by), + Equality.Naive) + by)) + end } + | TacInversion (DepInversion (k,c,ids),hyp) -> + Proofview.Goal.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = project gl in + let (sigma,c_interp) = + match c with + | None -> sigma , None + | Some c -> + let (sigma,c_interp) = interp_constr ist env sigma c in + sigma , Some c_interp + in + let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in + let sigma,ids_interp = interp_or_and_intro_pattern_option ist env sigma ids in + Tacticals.New.tclWITHHOLES false + (name_atomic ~env + (TacInversion(DepInversion(k,c_interp,ids),dqhyps)) + (Inv.dinv k c_interp ids_interp dqhyps)) sigma + end } + | TacInversion (NonDepInversion (k,idl,ids),hyp) -> + Proofview.Goal.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = project gl in + let hyps = interp_hyp_list ist env sigma idl in + let dqhyps = interp_declared_or_quantified_hypothesis ist env sigma hyp in + let sigma, ids_interp = interp_or_and_intro_pattern_option ist env sigma ids in + Tacticals.New.tclWITHHOLES false + (name_atomic ~env + (TacInversion (NonDepInversion (k,hyps,ids),dqhyps)) + (Inv.inv_clause k ids_interp hyps dqhyps)) sigma + end } + | TacInversion (InversionUsing (c,idl),hyp) -> + Proofview.Goal.s_enter { s_enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = project gl in + let (sigma,c_interp) = interp_constr ist env sigma c 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 + (TacInversion (InversionUsing (c_interp,hyps),dqhyps)) + (Leminv.lemInv_clause dqhyps c_interp hyps) + in + Sigma.Unsafe.of_pair (tac, sigma) + end } + +(* Initial call for interpretation *) + +let default_ist () = + let extra = TacStore.set TacStore.empty f_debug (get_debug ()) in + { lfun = Id.Map.empty; extra = extra } + +let eval_tactic t = + Proofview.tclUNIT () >>= fun () -> (* delay for [default_ist] *) + Proofview.tclLIFT db_initialize <*> + interp_tactic (default_ist ()) t + +let eval_tactic_ist ist t = + Proofview.tclLIFT db_initialize <*> + interp_tactic ist t + +(* globalization + interpretation *) + + +let interp_tac_gen lfun avoid_ids debug t = + Proofview.Goal.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let extra = TacStore.set TacStore.empty f_debug debug in + let extra = TacStore.set extra f_avoid_ids avoid_ids in + let ist = { lfun = lfun; extra = extra } in + let ltacvars = Id.Map.domain lfun in + interp_tactic ist + (intern_pure_tactic { + ltacvars; genv = env } t) + end } + +let interp t = interp_tac_gen Id.Map.empty [] (get_debug()) t + +(* Used to hide interpretation for pretty-print, now just launch tactics *) +(* [global] means that [t] should be internalized outside of goals. *) +let hide_interp global t ot = + let hide_interp env = + let ist = { ltacvars = Id.Set.empty; genv = env } in + let te = intern_pure_tactic ist t in + let t = eval_tactic te in + match ot with + | None -> t + | Some t' -> Tacticals.New.tclTHEN t t' + in + if global then + Proofview.tclENV >>= fun env -> + hide_interp env + else + Proofview.Goal.enter { enter = begin fun gl -> + hide_interp (Proofview.Goal.env gl) + end } + +(***************************************************************************) +(** Register standard arguments *) + +let register_interp0 wit f = + let open Ftactic.Notations in + let interp ist v = + f ist v >>= fun v -> Ftactic.return (Val.inject (val_tag wit) v) + in + Geninterp.register_interp0 wit interp + +let def_intern ist x = (ist, x) +let def_subst _ x = x +let def_interp ist x = Ftactic.return x + +let declare_uniform t = + Genintern.register_intern0 t def_intern; + Genintern.register_subst0 t def_subst; + register_interp0 t def_interp + +let () = + declare_uniform wit_unit + +let () = + declare_uniform wit_int + +let () = + declare_uniform wit_bool + +let () = + declare_uniform wit_string + +let lift f = (); fun ist x -> Ftactic.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + Ftactic.return (f ist env sigma x) +end } + +let lifts f = (); fun ist x -> Ftactic.nf_s_enter { s_enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Sigma.to_evar_map (Proofview.Goal.sigma gl) in + let (sigma, v) = f ist env sigma x in + Sigma.Unsafe.of_pair (Ftactic.return v, sigma) +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 + Sigma.Unsafe.of_pair (bl, sigma) + } + +let interp_constr_with_bindings' ist c = Ftactic.return { delayed = fun env sigma -> + let (sigma, c) = interp_constr_with_bindings ist env (Sigma.to_evar_map sigma) c in + Sigma.Unsafe.of_pair (c, sigma) + } + +let interp_destruction_arg' ist c = Ftactic.enter { enter = begin fun gl -> + Ftactic.return (interp_destruction_arg ist gl c) +end } + +let interp_pre_ident ist env sigma s = + s |> Id.of_string |> interp_ident ist env sigma |> Id.to_string + +let () = + register_interp0 wit_int_or_var (fun ist n -> Ftactic.return (interp_int_or_var ist n)); + register_interp0 wit_ref (lift interp_reference); + register_interp0 wit_pre_ident (lift interp_pre_ident); + register_interp0 wit_ident (lift interp_ident); + register_interp0 wit_var (lift interp_hyp); + register_interp0 wit_intro_pattern (lifts interp_intro_pattern); + register_interp0 wit_clause_dft_concl (lift interp_clause); + register_interp0 wit_constr (lifts interp_constr); + register_interp0 wit_tacvalue (fun ist v -> Ftactic.return v); + register_interp0 wit_red_expr (lifts interp_red_expr); + register_interp0 wit_quant_hyp (lift interp_declared_or_quantified_hypothesis); + register_interp0 wit_open_constr (lifts interp_open_constr); + register_interp0 wit_bindings interp_bindings'; + register_interp0 wit_constr_with_bindings interp_constr_with_bindings'; + register_interp0 wit_destruction_arg interp_destruction_arg'; + () + +let () = + let interp ist tac = Ftactic.return (Value.of_closure ist tac) in + register_interp0 wit_tactic interp + +let () = + let interp ist tac = interp_tactic ist tac >>= fun () -> Ftactic.return () in + register_interp0 wit_ltac interp + +let () = + register_interp0 wit_uconstr (fun ist c -> Ftactic.enter { enter = begin fun gl -> + Ftactic.return (interp_uconstr ist (Proofview.Goal.env gl) (Tacmach.New.project gl) c) + end }) + +(***************************************************************************) +(* Other entry points *) + +let val_interp ist tac k = Ftactic.run (val_interp ist tac) k + +let interp_ltac_constr ist c k = Ftactic.run (interp_ltac_constr ist c) k + +let interp_redexp env sigma r = + let ist = default_ist () in + let gist = { fully_empty_glob_sign with genv = env; } in + interp_red_expr ist env sigma (intern_red_expr gist r) + +(***************************************************************************) +(* Backwarding recursive needs of tactic glob/interp/eval functions *) + +let _ = + let eval ty env sigma lfun arg = + let ist = { lfun = lfun; extra = TacStore.empty; } in + if Genarg.has_type arg (glbwit wit_tactic) then + let tac = Genarg.out_gen (glbwit wit_tactic) arg in + let tac = interp_tactic ist tac in + let (c, sigma) = Pfedit.refine_by_tactic env sigma ty tac in + (EConstr.of_constr c, sigma) + else + failwith "not a tactic" + in + Hook.set Pretyping.genarg_interp_hook eval + +(** Used in tactic extension **) + +let dummy_id = Id.of_string "_" + +let lift_constr_tac_to_ml_tac vars tac = + let tac _ ist = Proofview.Goal.enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = project gl in + let map = function + | Anonymous -> None + | Name id -> + let c = Id.Map.find id ist.lfun in + try Some (coerce_to_closed_constr env c) + with CannotCoerceTo ty -> + error_ltac_variable Loc.ghost dummy_id (Some (env,sigma)) c ty + in + let args = List.map_filter map vars in + tac args ist + end } in + tac + +let vernac_debug b = + set_debug (if b then Tactic_debug.DebugOn 0 else Tactic_debug.DebugOff) + +let _ = + let open Goptions in + declare_bool_option + { optsync = false; + optdepr = false; + optname = "Ltac debug"; + optkey = ["Ltac";"Debug"]; + optread = (fun () -> get_debug () != Tactic_debug.DebugOff); + optwrite = vernac_debug } + +let _ = + let open Goptions in + declare_bool_option + { optsync = false; + optdepr = false; + optname = "Ltac debug"; + optkey = ["Debug";"Ltac"]; + optread = (fun () -> get_debug () != Tactic_debug.DebugOff); + optwrite = vernac_debug } + +let () = Hook.set Vernacentries.interp_redexp_hook interp_redexp diff --git a/plugins/ltac/tacinterp.mli b/plugins/ltac/tacinterp.mli new file mode 100644 index 000000000..1e5f6bd42 --- /dev/null +++ b/plugins/ltac/tacinterp.mli @@ -0,0 +1,123 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Names +open Tactic_debug +open Term +open EConstr +open Tacexpr +open Genarg +open Redexpr +open Misctypes + +val ltac_trace_info : ltac_trace Exninfo.t + +module Value : +sig + type t = Geninterp.Val.t + val of_constr : constr -> t + val to_constr : t -> constr option + val of_int : int -> t + val to_int : t -> int option + val to_list : t -> t list option + val of_closure : Geninterp.interp_sign -> glob_tactic_expr -> t + val cast : 'a typed_abstract_argument_type -> Geninterp.Val.t -> 'a +end + +(** Values for interpretation *) +type value = Value.t + +module TacStore : Store.S with + type t = Geninterp.TacStore.t + and type 'a field = 'a Geninterp.TacStore.field + +(** Signature for interpretation: val\_interp and interpretation functions *) +type interp_sign = Geninterp.interp_sign = { + lfun : value Id.Map.t; + extra : TacStore.t } + +val f_avoid_ids : Id.t list TacStore.field +val f_debug : debug_info TacStore.field + +val extract_ltac_constr_values : interp_sign -> Environ.env -> + Pattern.constr_under_binders Id.Map.t +(** Given an interpretation signature, extract all values which are coercible to + a [constr]. *) + +(** Sets the debugger mode *) +val set_debug : debug_info -> unit + +(** Gives the state of debug *) +val get_debug : unit -> debug_info + +(** Adds an interpretation function for extra generic arguments *) + +val interp_genarg : interp_sign -> glob_generic_argument -> Value.t Ftactic.t + +(** Interprets any expression *) +val val_interp : interp_sign -> glob_tactic_expr -> (value -> unit Proofview.tactic) -> unit Proofview.tactic + +(** Interprets an expression that evaluates to a constr *) +val interp_ltac_constr : interp_sign -> glob_tactic_expr -> (constr -> unit Proofview.tactic) -> unit Proofview.tactic + +(** Interprets redexp arguments *) +val interp_redexp : Environ.env -> Evd.evar_map -> raw_red_expr -> Evd.evar_map * red_expr + +(** Interprets tactic expressions *) + +val interp_hyp : interp_sign -> Environ.env -> Evd.evar_map -> + Id.t Loc.located -> Id.t + +val interp_constr_gen : Pretyping.typing_constraint -> interp_sign -> + Environ.env -> Evd.evar_map -> glob_constr_and_expr -> Evd.evar_map * constr + +val interp_bindings : interp_sign -> Environ.env -> Evd.evar_map -> + glob_constr_and_expr bindings -> Evd.evar_map * constr bindings + +val interp_open_constr_with_bindings : interp_sign -> Environ.env -> Evd.evar_map -> + glob_constr_and_expr with_bindings -> Evd.evar_map * EConstr.constr with_bindings + +(** Initial call for interpretation *) + +val eval_tactic : glob_tactic_expr -> unit Proofview.tactic + +val eval_tactic_ist : interp_sign -> glob_tactic_expr -> unit Proofview.tactic +(** Same as [eval_tactic], but with the provided [interp_sign]. *) + +val tactic_of_value : interp_sign -> Value.t -> unit Proofview.tactic + +(** Globalization + interpretation *) + +val interp_tac_gen : value Id.Map.t -> Id.t list -> + debug_info -> raw_tactic_expr -> unit Proofview.tactic + +val interp : raw_tactic_expr -> unit Proofview.tactic + +(** Hides interpretation for pretty-print *) + +val hide_interp : bool -> raw_tactic_expr -> unit Proofview.tactic option -> unit Proofview.tactic + +(** Internals that can be useful for syntax extensions. *) + +val interp_ltac_var : (value -> 'a) -> interp_sign -> + (Environ.env * Evd.evar_map) option -> Id.t Loc.located -> 'a + +val interp_int : interp_sign -> Id.t Loc.located -> int + +val interp_int_or_var : interp_sign -> int or_var -> int + +val error_ltac_variable : Loc.t -> Id.t -> + (Environ.env * Evd.evar_map) option -> value -> string -> 'a + +(** Transforms a constr-expecting tactic into a tactic finding its arguments in + the Ltac environment according to the given names. *) +val lift_constr_tac_to_ml_tac : Name.t list -> + (constr list -> Geninterp.interp_sign -> unit Proofview.tactic) -> Tacenv.ml_tactic + +val default_ist : unit -> Geninterp.interp_sign +(** Empty ist with debug set on the current value. *) diff --git a/plugins/ltac/tacsubst.ml b/plugins/ltac/tacsubst.ml new file mode 100644 index 000000000..fe3a9f3b2 --- /dev/null +++ b/plugins/ltac/tacsubst.ml @@ -0,0 +1,309 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Util +open Tacexpr +open Mod_subst +open Genarg +open Stdarg +open Tacarg +open Misctypes +open Globnames +open Term +open Genredexpr +open Patternops + +(** Substitution of tactics at module closing time *) + +(** For generic arguments, we declare and store substitutions + in a table *) + +let subst_quantified_hypothesis _ x = x + +let subst_declared_or_quantified_hypothesis _ x = x + +let subst_glob_constr_and_expr subst (c, e) = + (Detyping.subst_glob_constr subst c, e) + +let subst_glob_constr = subst_glob_constr_and_expr (* shortening *) + +let subst_binding subst (loc,b,c) = + (loc,subst_quantified_hypothesis subst b,subst_glob_constr subst c) + +let subst_bindings subst = function + | NoBindings -> NoBindings + | ImplicitBindings l -> ImplicitBindings (List.map (subst_glob_constr subst) l) + | ExplicitBindings l -> ExplicitBindings (List.map (subst_binding subst) l) + +let subst_glob_with_bindings subst (c,bl) = + (subst_glob_constr subst c, subst_bindings subst bl) + +let subst_glob_with_bindings_arg subst (clear,c) = + (clear,subst_glob_with_bindings subst c) + +let rec subst_intro_pattern subst = function + | loc,IntroAction p -> loc, IntroAction (subst_intro_pattern_action subst p) + | loc, IntroNaming _ | loc, IntroForthcoming _ as x -> x + +and subst_intro_pattern_action subst = function + | IntroApplyOn ((loc,t),pat) -> + IntroApplyOn ((loc,subst_glob_constr subst t),subst_intro_pattern subst pat) + | IntroOrAndPattern l -> + IntroOrAndPattern (subst_intro_or_and_pattern subst l) + | IntroInjection l -> IntroInjection (List.map (subst_intro_pattern subst) l) + | IntroWildcard | IntroRewrite _ as x -> x + +and subst_intro_or_and_pattern subst = function + | IntroAndPattern l -> + IntroAndPattern (List.map (subst_intro_pattern subst) l) + | IntroOrPattern ll -> + IntroOrPattern (List.map (List.map (subst_intro_pattern subst)) ll) + +let subst_destruction_arg subst = function + | clear,ElimOnConstr c -> clear,ElimOnConstr (subst_glob_with_bindings subst c) + | clear,ElimOnAnonHyp n as x -> x + | clear,ElimOnIdent id as x -> x + +let subst_and_short_name f (c,n) = +(* assert (n=None); *)(* since tacdef are strictly globalized *) + (f c,None) + +let subst_or_var f = function + | ArgVar _ as x -> x + | ArgArg x -> ArgArg (f x) + +let dloc = Loc.ghost + +let subst_located f (_loc,id) = (dloc,f id) + +let subst_reference subst = + subst_or_var (subst_located (subst_kn subst)) + +(*CSC: subst_global_reference is used "only" for RefArgType, that propagates + to the syntactic non-terminals "global", used in commands such as + Print. It is also used for non-evaluable references. *) +open Pp +open Printer + +let subst_global_reference subst = + let subst_global ref = + let ref',t' = subst_global subst ref in + if not (eq_constr (Universes.constr_of_global ref') t') then + Feedback.msg_warning (strbrk "The reference " ++ pr_global ref ++ str " is not " ++ + str " expanded to \"" ++ pr_lconstr t' ++ str "\", but to " ++ + pr_global ref') ; + ref' + in + subst_or_var (subst_located subst_global) + +let subst_evaluable subst = + let subst_eval_ref = subst_evaluable_reference subst in + subst_or_var (subst_and_short_name subst_eval_ref) + +let subst_constr_with_occurrences subst (l,c) = (l,subst_glob_constr subst c) + +let subst_glob_constr_or_pattern subst (bvars,c,p) = + (bvars,subst_glob_constr subst c,subst_pattern subst p) + +let subst_redexp subst = + Miscops.map_red_expr_gen + (subst_glob_constr subst) + (subst_evaluable subst) + (subst_glob_constr_or_pattern subst) + +let subst_raw_may_eval subst = function + | ConstrEval (r,c) -> ConstrEval (subst_redexp subst r,subst_glob_constr subst c) + | ConstrContext (locid,c) -> ConstrContext (locid,subst_glob_constr subst c) + | ConstrTypeOf c -> ConstrTypeOf (subst_glob_constr subst c) + | ConstrTerm c -> ConstrTerm (subst_glob_constr subst c) + +let subst_match_pattern subst = function + | Subterm (b,ido,pc) -> Subterm (b,ido,(subst_glob_constr_or_pattern subst pc)) + | Term pc -> Term (subst_glob_constr_or_pattern subst pc) + +let rec subst_match_goal_hyps subst = function + | Hyp (locs,mp) :: tl -> + Hyp (locs,subst_match_pattern subst mp) + :: subst_match_goal_hyps subst tl + | Def (locs,mv,mp) :: tl -> + Def (locs,subst_match_pattern subst mv, subst_match_pattern subst mp) + :: subst_match_goal_hyps subst tl + | [] -> [] + +let rec subst_atomic subst (t:glob_atomic_tactic_expr) = match t with + (* Basic tactics *) + | TacIntroPattern (ev,l) -> TacIntroPattern (ev,List.map (subst_intro_pattern subst) l) + | TacApply (a,ev,cb,cl) -> + TacApply (a,ev,List.map (subst_glob_with_bindings_arg subst) cb,cl) + | TacElim (ev,cb,cbo) -> + TacElim (ev,subst_glob_with_bindings_arg subst cb, + Option.map (subst_glob_with_bindings subst) cbo) + | TacCase (ev,cb) -> TacCase (ev,subst_glob_with_bindings_arg subst cb) + | TacMutualFix (id,n,l) -> + TacMutualFix(id,n,List.map (fun (id,n,c) -> (id,n,subst_glob_constr subst c)) l) + | TacMutualCofix (id,l) -> + TacMutualCofix (id, List.map (fun (id,c) -> (id,subst_glob_constr subst c)) l) + | TacAssert (b,otac,na,c) -> + TacAssert (b,Option.map (Option.map (subst_tactic subst)) otac,na, + subst_glob_constr subst c) + | TacGeneralize cl -> + TacGeneralize (List.map (on_fst (subst_constr_with_occurrences subst))cl) + | TacLetTac (id,c,clp,b,eqpat) -> + TacLetTac (id,subst_glob_constr subst c,clp,b,eqpat) + + (* Derived basic tactics *) + | TacInductionDestruct (isrec,ev,(l,el)) -> + let l' = List.map (fun (c,ids,cls) -> + subst_destruction_arg subst c, ids, cls) l in + let el' = Option.map (subst_glob_with_bindings subst) el in + TacInductionDestruct (isrec,ev,(l',el')) + + (* Conversion *) + | TacReduce (r,cl) -> TacReduce (subst_redexp subst r, cl) + | TacChange (op,c,cl) -> + TacChange (Option.map (subst_glob_constr_or_pattern subst) op, + subst_glob_constr subst c, cl) + + (* Equality and inversion *) + | TacRewrite (ev,l,cl,by) -> + TacRewrite (ev, + List.map (fun (b,m,c) -> + b,m,subst_glob_with_bindings_arg subst c) l, + cl,Option.map (subst_tactic subst) by) + | TacInversion (DepInversion (k,c,l),hyp) -> + TacInversion (DepInversion (k,Option.map (subst_glob_constr subst) c,l),hyp) + | TacInversion (NonDepInversion _,_) as x -> x + | TacInversion (InversionUsing (c,cl),hyp) -> + TacInversion (InversionUsing (subst_glob_constr subst c,cl),hyp) + +and subst_tactic subst (t:glob_tactic_expr) = match t with + | TacAtom (_loc,t) -> TacAtom (dloc, subst_atomic subst t) + | TacFun tacfun -> TacFun (subst_tactic_fun subst tacfun) + | TacLetIn (r,l,u) -> + let l = List.map (fun (n,b) -> (n,subst_tacarg subst b)) l in + TacLetIn (r,l,subst_tactic subst u) + | TacMatchGoal (lz,lr,lmr) -> + TacMatchGoal(lz,lr, subst_match_rule subst lmr) + | TacMatch (lz,c,lmr) -> + TacMatch (lz,subst_tactic subst c,subst_match_rule subst lmr) + | TacId _ | TacFail _ as x -> x + | TacProgress tac -> TacProgress (subst_tactic subst tac:glob_tactic_expr) + | TacShowHyps tac -> TacShowHyps (subst_tactic subst tac:glob_tactic_expr) + | TacAbstract (tac,s) -> TacAbstract (subst_tactic subst tac,s) + | TacThen (t1,t2) -> + TacThen (subst_tactic subst t1, subst_tactic subst t2) + | TacDispatch tl -> TacDispatch (List.map (subst_tactic subst) tl) + | TacExtendTac (tf,t,tl) -> + TacExtendTac (Array.map (subst_tactic subst) tf, + subst_tactic subst t, + Array.map (subst_tactic subst) tl) + | TacThens (t,tl) -> + TacThens (subst_tactic subst t, List.map (subst_tactic subst) tl) + | TacThens3parts (t1,tf,t2,tl) -> + TacThens3parts (subst_tactic subst t1,Array.map (subst_tactic subst) tf, + subst_tactic subst t2,Array.map (subst_tactic subst) tl) + | TacDo (n,tac) -> TacDo (n,subst_tactic subst tac) + | TacTimeout (n,tac) -> TacTimeout (n,subst_tactic subst tac) + | TacTime (s,tac) -> TacTime (s,subst_tactic subst tac) + | TacTry tac -> TacTry (subst_tactic subst tac) + | TacInfo tac -> TacInfo (subst_tactic subst tac) + | TacRepeat tac -> TacRepeat (subst_tactic subst tac) + | TacOr (tac1,tac2) -> + TacOr (subst_tactic subst tac1,subst_tactic subst tac2) + | TacOnce tac -> + TacOnce (subst_tactic subst tac) + | TacExactlyOnce tac -> + TacExactlyOnce (subst_tactic subst tac) + | TacIfThenCatch (tac,tact,tace) -> + TacIfThenCatch ( + subst_tactic subst tac, + subst_tactic subst tact, + subst_tactic subst tace) + | TacOrelse (tac1,tac2) -> + TacOrelse (subst_tactic subst tac1,subst_tactic subst tac2) + | TacFirst l -> TacFirst (List.map (subst_tactic subst) l) + | TacSolve l -> TacSolve (List.map (subst_tactic subst) l) + | TacComplete tac -> TacComplete (subst_tactic subst tac) + | TacArg (_,a) -> TacArg (dloc,subst_tacarg subst a) + | TacSelect (s, tac) -> TacSelect (s, subst_tactic subst tac) + + (* For extensions *) + | TacAlias (_,s,l) -> + let s = subst_kn subst s in + TacAlias (dloc,s,List.map (subst_tacarg subst) l) + | TacML (_loc,opn,l) -> TacML (dloc,opn,List.map (subst_tacarg subst) l) + +and subst_tactic_fun subst (var,body) = (var,subst_tactic subst body) + +and subst_tacarg subst = function + | Reference r -> Reference (subst_reference subst r) + | ConstrMayEval c -> ConstrMayEval (subst_raw_may_eval subst c) + | TacCall (_loc,f,l) -> + TacCall (_loc, subst_reference subst f, List.map (subst_tacarg subst) l) + | TacFreshId _ as x -> x + | TacPretype c -> TacPretype (subst_glob_constr subst c) + | TacNumgoals -> TacNumgoals + | Tacexp t -> Tacexp (subst_tactic subst t) + | TacGeneric arg -> TacGeneric (subst_genarg subst arg) + +(* Reads the rules of a Match Context or a Match *) +and subst_match_rule subst = function + | (All tc)::tl -> + (All (subst_tactic subst tc))::(subst_match_rule subst tl) + | (Pat (rl,mp,tc))::tl -> + let hyps = subst_match_goal_hyps subst rl in + let pat = subst_match_pattern subst mp in + Pat (hyps,pat,subst_tactic subst tc) + ::(subst_match_rule subst tl) + | [] -> [] + +and subst_genarg subst (GenArg (Glbwit wit, x)) = + match wit with + | ListArg wit -> + let map x = + let ans = subst_genarg subst (in_gen (glbwit wit) x) in + out_gen (glbwit wit) ans + in + in_gen (glbwit (wit_list wit)) (List.map map x) + | OptArg wit -> + let ans = match x with + | None -> in_gen (glbwit (wit_opt wit)) None + | Some x -> + let s = out_gen (glbwit wit) (subst_genarg subst (in_gen (glbwit wit) x)) in + in_gen (glbwit (wit_opt wit)) (Some s) + in + ans + | PairArg (wit1, wit2) -> + let p, q = x in + let p = out_gen (glbwit wit1) (subst_genarg subst (in_gen (glbwit wit1) p)) in + let q = out_gen (glbwit wit2) (subst_genarg subst (in_gen (glbwit wit2) q)) in + in_gen (glbwit (wit_pair wit1 wit2)) (p, q) + | ExtraArg s -> + Genintern.generic_substitute subst (in_gen (glbwit wit) x) + +(** Registering *) + +let () = + Genintern.register_subst0 wit_int_or_var (fun _ v -> v); + Genintern.register_subst0 wit_ref subst_global_reference; + Genintern.register_subst0 wit_pre_ident (fun _ v -> v); + Genintern.register_subst0 wit_ident (fun _ v -> v); + Genintern.register_subst0 wit_var (fun _ v -> v); + Genintern.register_subst0 wit_intro_pattern (fun _ v -> v); + Genintern.register_subst0 wit_tactic subst_tactic; + Genintern.register_subst0 wit_ltac subst_tactic; + Genintern.register_subst0 wit_constr subst_glob_constr; + Genintern.register_subst0 wit_clause_dft_concl (fun _ v -> v); + Genintern.register_subst0 wit_uconstr (fun subst c -> subst_glob_constr subst c); + Genintern.register_subst0 wit_open_constr (fun subst c -> subst_glob_constr subst c); + Genintern.register_subst0 wit_red_expr subst_redexp; + Genintern.register_subst0 wit_quant_hyp subst_declared_or_quantified_hypothesis; + Genintern.register_subst0 wit_bindings subst_bindings; + Genintern.register_subst0 wit_constr_with_bindings subst_glob_with_bindings; + Genintern.register_subst0 wit_destruction_arg subst_destruction_arg; + () diff --git a/plugins/ltac/tacsubst.mli b/plugins/ltac/tacsubst.mli new file mode 100644 index 000000000..c1bf27257 --- /dev/null +++ b/plugins/ltac/tacsubst.mli @@ -0,0 +1,30 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Tacexpr +open Mod_subst +open Genarg +open Misctypes + +(** Substitution of tactics at module closing time *) + +val subst_tactic : substitution -> glob_tactic_expr -> glob_tactic_expr + +(** For generic arguments, we declare and store substitutions + in a table *) + +val subst_genarg : substitution -> glob_generic_argument -> glob_generic_argument + +(** Misc *) + +val subst_glob_constr_and_expr : + substitution -> glob_constr_and_expr -> glob_constr_and_expr + +val subst_glob_with_bindings : substitution -> + glob_constr_and_expr with_bindings -> + glob_constr_and_expr with_bindings diff --git a/plugins/ltac/tactic_debug.ml b/plugins/ltac/tactic_debug.ml new file mode 100644 index 000000000..dffeade29 --- /dev/null +++ b/plugins/ltac/tactic_debug.ml @@ -0,0 +1,424 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Util +open Names +open Pp +open Tacexpr +open Termops +open Nameops +open Proofview.Notations + + +let (ltac_trace_info : ltac_trace Exninfo.t) = Exninfo.make () + +let prtac x = + Pptactic.pr_glob_tactic (Global.env()) x +let prmatchpatt env sigma hyp = + Pptactic.pr_match_pattern (Printer.pr_constr_pattern_env env sigma) hyp +let prmatchrl rl = + Pptactic.pr_match_rule false (Pptactic.pr_glob_tactic (Global.env())) + (fun (_,p) -> Printer.pr_constr_pattern p) rl + +(* This module intends to be a beginning of debugger for tactic expressions. + Currently, it is quite simple and we can hope to have, in the future, a more + complete panel of commands dedicated to a proof assistant framework *) + +(* Debug information *) +type debug_info = + | DebugOn of int + | DebugOff + +(* An exception handler *) +let explain_logic_error e = + CErrors.print (fst (ExplainErr.process_vernac_interp_error (e, Exninfo.null))) + +let explain_logic_error_no_anomaly e = + CErrors.print_no_report + (fst (ExplainErr.process_vernac_interp_error (e, Exninfo.null))) + +let msg_tac_debug s = Proofview.NonLogical.print_debug (s++fnl()) +let msg_tac_notice s = Proofview.NonLogical.print_notice (s++fnl()) + +(* Prints the goal *) + +let db_pr_goal gl = + let env = Proofview.Goal.env gl in + let concl = Proofview.Goal.concl gl in + let penv = print_named_context env in + let pc = print_constr_env env (Tacmach.New.project gl) concl in + str" " ++ hv 0 (penv ++ fnl () ++ + str "============================" ++ fnl () ++ + str" " ++ pc) ++ fnl () + +let db_pr_goal = + Proofview.Goal.nf_enter { enter = begin fun gl -> + let pg = db_pr_goal gl in + Proofview.tclLIFT (msg_tac_notice (str "Goal:" ++ fnl () ++ pg)) + end } + + +(* Prints the commands *) +let help () = + msg_tac_debug (str "Commands: <Enter> = Continue" ++ fnl() ++ + str " h/? = Help" ++ fnl() ++ + str " r <num> = Run <num> times" ++ fnl() ++ + str " r <string> = Run up to next idtac <string>" ++ fnl() ++ + str " s = Skip" ++ fnl() ++ + str " x = Exit") + +(* Prints the goal and the command to be executed *) +let goal_com tac = + Proofview.tclTHEN + db_pr_goal + (Proofview.tclLIFT (msg_tac_debug (str "Going to execute:" ++ fnl () ++ prtac tac))) + +(* [run (new_ref _)] gives us a ref shared among [NonLogical.t] + expressions. It avoids parametrizing everything over a + reference. *) +let skipped = Proofview.NonLogical.run (Proofview.NonLogical.ref 0) +let skip = Proofview.NonLogical.run (Proofview.NonLogical.ref 0) +let breakpoint = Proofview.NonLogical.run (Proofview.NonLogical.ref None) + +let rec drop_spaces inst i = + if String.length inst > i && inst.[i] == ' ' then drop_spaces inst (i+1) + else i + +let possibly_unquote s = + if String.length s >= 2 && s.[0] == '"' && s.[String.length s - 1] == '"' then + String.sub s 1 (String.length s - 2) + else + s + +(* (Re-)initialize debugger *) +let db_initialize = + let open Proofview.NonLogical in + (skip:=0) >> (skipped:=0) >> (breakpoint:=None) + +let int_of_string s = + try Proofview.NonLogical.return (int_of_string s) + with e -> Proofview.NonLogical.raise e + +let string_get s i = + try Proofview.NonLogical.return (String.get s i) + with e -> Proofview.NonLogical.raise e + +let run_invalid_arg () = Proofview.NonLogical.raise (Invalid_argument "run_com") + +(* Gives the number of steps or next breakpoint of a run command *) +let run_com inst = + let open Proofview.NonLogical in + string_get inst 0 >>= fun first_char -> + if first_char ='r' then + let i = drop_spaces inst 1 in + if String.length inst > i then + let s = String.sub inst i (String.length inst - i) in + if inst.[0] >= '0' && inst.[0] <= '9' then + int_of_string s >>= fun num -> + (if num<0 then run_invalid_arg () else return ()) >> + (skip:=num) >> (skipped:=0) + else + breakpoint:=Some (possibly_unquote s) + else + run_invalid_arg () + else + run_invalid_arg () + +(* Prints the run counter *) +let run ini = + let open Proofview.NonLogical in + if not ini then + begin + Proofview.NonLogical.print_notice (str"\b\r\b\r") >> + !skipped >>= fun skipped -> + msg_tac_debug (str "Executed expressions: " ++ int skipped ++ fnl()) + end >> + !skipped >>= fun x -> + skipped := x+1 + else + return () + +(* Prints the prompt *) +let rec prompt level = + (* spiwack: avoid overriding by the open below *) + let runtrue = run true in + begin + let open Proofview.NonLogical in + Proofview.NonLogical.print_notice (fnl () ++ str "TcDebug (" ++ int level ++ str ") > ") >> + let exit = (skip:=0) >> (skipped:=0) >> raise Sys.Break in + Proofview.NonLogical.catch Proofview.NonLogical.read_line + begin function (e, info) -> match e with + | End_of_file -> exit + | e -> raise ~info e + end + >>= fun inst -> + match inst with + | "" -> return (DebugOn (level+1)) + | "s" -> return (DebugOff) + | "x" -> Proofview.NonLogical.print_char '\b' >> exit + | "h"| "?" -> + begin + help () >> + prompt level + end + | _ -> + Proofview.NonLogical.catch (run_com inst >> runtrue >> return (DebugOn (level+1))) + begin function (e, info) -> match e with + | Failure _ | Invalid_argument _ -> prompt level + | e -> raise ~info e + end + end + +(* Prints the state and waits for an instruction *) +(* spiwack: the only reason why we need to take the continuation [f] + as an argument rather than returning the new level directly seems to + be that [f] is wrapped in with "explain_logic_error". I don't think + it serves any purpose in the current design, so we could just drop + that. *) +let debug_prompt lev tac f = + (* spiwack: avoid overriding by the open below *) + let runfalse = run false in + let open Proofview.NonLogical in + let (>=) = Proofview.tclBIND in + (* What to print and to do next *) + let newlevel = + Proofview.tclLIFT !skip >= fun initial_skip -> + if Int.equal initial_skip 0 then + Proofview.tclLIFT !breakpoint >= fun breakpoint -> + if Option.is_empty breakpoint then Proofview.tclTHEN (goal_com tac) (Proofview.tclLIFT (prompt lev)) + else Proofview.tclLIFT(runfalse >> return (DebugOn (lev+1))) + else Proofview.tclLIFT begin + (!skip >>= fun s -> skip:=s-1) >> + runfalse >> + !skip >>= fun new_skip -> + (if Int.equal new_skip 0 then skipped:=0 else return ()) >> + return (DebugOn (lev+1)) + end in + newlevel >= fun newlevel -> + (* What to execute *) + Proofview.tclOR + (f newlevel) + begin fun (reraise, info) -> + Proofview.tclTHEN + (Proofview.tclLIFT begin + (skip:=0) >> (skipped:=0) >> + if Logic.catchable_exception reraise then + msg_tac_debug (str "Level " ++ int lev ++ str ": " ++ explain_logic_error reraise) + else return () + end) + (Proofview.tclZERO ~info reraise) + end + +let is_debug db = + let open Proofview.NonLogical in + !breakpoint >>= fun breakpoint -> + match db, breakpoint with + | DebugOff, _ -> return false + | _, Some _ -> return false + | _ -> + !skip >>= fun skip -> + return (Int.equal skip 0) + +(* Prints a constr *) +let db_constr debug env sigma c = + let open Proofview.NonLogical in + is_debug debug >>= fun db -> + if db then + msg_tac_debug (str "Evaluated term: " ++ print_constr_env env sigma c) + else return () + +(* Prints the pattern rule *) +let db_pattern_rule debug num r = + let open Proofview.NonLogical in + is_debug debug >>= fun db -> + if db then + begin + msg_tac_debug (str "Pattern rule " ++ int num ++ str ":" ++ fnl () ++ + str "|" ++ spc () ++ prmatchrl r) + end + else return () + +(* Prints the hypothesis pattern identifier if it exists *) +let hyp_bound = function + | Anonymous -> str " (unbound)" + | Name id -> str " (bound to " ++ pr_id id ++ str ")" + +(* Prints a matched hypothesis *) +let db_matched_hyp debug env sigma (id,_,c) ido = + let open Proofview.NonLogical in + is_debug debug >>= fun db -> + if db then + msg_tac_debug (str "Hypothesis " ++ pr_id id ++ hyp_bound ido ++ + str " has been matched: " ++ print_constr_env env sigma c) + else return () + +(* Prints the matched conclusion *) +let db_matched_concl debug env sigma c = + let open Proofview.NonLogical in + is_debug debug >>= fun db -> + if db then + msg_tac_debug (str "Conclusion has been matched: " ++ print_constr_env env sigma c) + else return () + +(* Prints a success message when the goal has been matched *) +let db_mc_pattern_success debug = + let open Proofview.NonLogical in + is_debug debug >>= fun db -> + if db then + msg_tac_debug (str "The goal has been successfully matched!" ++ fnl() ++ + str "Let us execute the right-hand side part..." ++ fnl()) + else return () + +(* Prints a failure message for an hypothesis pattern *) +let db_hyp_pattern_failure debug env sigma (na,hyp) = + let open Proofview.NonLogical in + is_debug debug >>= fun db -> + if db then + msg_tac_debug (str "The pattern hypothesis" ++ hyp_bound na ++ + str " cannot match: " ++ + prmatchpatt env sigma hyp) + else return () + +(* Prints a matching failure message for a rule *) +let db_matching_failure debug = + let open Proofview.NonLogical in + is_debug debug >>= fun db -> + if db then + msg_tac_debug (str "This rule has failed due to matching errors!" ++ fnl() ++ + str "Let us try the next one...") + else return () + +(* Prints an evaluation failure message for a rule *) +let db_eval_failure debug s = + let open Proofview.NonLogical in + is_debug debug >>= fun db -> + if db then + let s = str "message \"" ++ s ++ str "\"" in + msg_tac_debug + (str "This rule has failed due to \"Fail\" tactic (" ++ + s ++ str ", level 0)!" ++ fnl() ++ str "Let us try the next one...") + else return () + +(* Prints a logic failure message for a rule *) +let db_logic_failure debug err = + let open Proofview.NonLogical in + is_debug debug >>= fun db -> + if db then + begin + msg_tac_debug (explain_logic_error err) >> + msg_tac_debug (str "This rule has failed due to a logic error!" ++ fnl() ++ + str "Let us try the next one...") + end + else return () + +let is_breakpoint brkname s = match brkname, s with + | Some s, MsgString s'::_ -> String.equal s s' + | _ -> false + +let db_breakpoint debug s = + let open Proofview.NonLogical in + !breakpoint >>= fun opt_breakpoint -> + match debug with + | DebugOn lev when not (CList.is_empty s) && is_breakpoint opt_breakpoint s -> + breakpoint:=None + | _ -> + return () + +(** Extrating traces *) + +let is_defined_ltac trace = + let rec aux = function + | (_, Tacexpr.LtacNameCall f) :: _ -> not (Tacenv.is_ltac_for_ml_tactic f) + | (_, Tacexpr.LtacNotationCall f) :: _ -> true + | (_, Tacexpr.LtacAtomCall _) :: _ -> false + | _ :: tail -> aux tail + | [] -> false in + aux (List.rev trace) + +let explain_ltac_call_trace last trace loc = + let calls = last :: List.rev_map snd trace in + let pr_call ck = match ck with + | Tacexpr.LtacNotationCall kn -> quote (Pptactic.pr_alias_key kn) + | Tacexpr.LtacNameCall cst -> quote (Pptactic.pr_ltac_constant cst) + | Tacexpr.LtacMLCall t -> + quote (Pptactic.pr_glob_tactic (Global.env()) t) + | Tacexpr.LtacVarCall (id,t) -> + quote (Nameops.pr_id id) ++ strbrk " (bound to " ++ + Pptactic.pr_glob_tactic (Global.env()) t ++ str ")" + | Tacexpr.LtacAtomCall te -> + quote (Pptactic.pr_glob_tactic (Global.env()) + (Tacexpr.TacAtom (Loc.ghost,te))) + | Tacexpr.LtacConstrInterp (c, { Pretyping.ltac_constrs = vars }) -> + quote (Printer.pr_glob_constr_env (Global.env()) c) ++ + (if not (Id.Map.is_empty vars) then + strbrk " (with " ++ + prlist_with_sep pr_comma + (fun (id,c) -> + pr_id id ++ str ":=" ++ Printer.pr_lconstr_under_binders c) + (List.rev (Id.Map.bindings vars)) ++ str ")" + else mt()) + in + match calls with + | [] -> mt () + | [a] -> hov 0 (str "Ltac call to " ++ pr_call a ++ str " failed.") + | _ -> + let kind_of_last_call = match List.last calls with + | Tacexpr.LtacConstrInterp _ -> ", last term evaluation failed." + | _ -> ", last call failed." + in + hov 0 (str "In nested Ltac calls to " ++ + pr_enum pr_call calls ++ strbrk kind_of_last_call) + +let skip_extensions trace = + let rec aux = function + | (_,Tacexpr.LtacNameCall f as tac) :: _ + when Tacenv.is_ltac_for_ml_tactic f -> [tac] + | (_,Tacexpr.LtacNotationCall _ as tac) :: (_,Tacexpr.LtacMLCall _) :: _ -> + (* Case of an ML defined tactic with entry of the form <<"foo" args>> *) + (* see tacextend.mlp *) + [tac] + | (_,Tacexpr.LtacMLCall _ as tac) :: _ -> [tac] + | t :: tail -> t :: aux tail + | [] -> [] in + List.rev (aux (List.rev trace)) + +let finer_loc loc1 loc2 = Loc.merge loc1 loc2 = loc2 + +let extract_ltac_trace trace eloc = + let trace = skip_extensions trace in + let (loc,c),tail = List.sep_last trace in + if is_defined_ltac trace then + (* We entered a user-defined tactic, + we display the trace with location of the call *) + let msg = hov 0 (explain_ltac_call_trace c tail eloc ++ fnl()) in + Some msg, if finer_loc eloc loc then eloc else loc + else + (* We entered a primitive tactic, we don't display trace but + report on the finest location *) + let best_loc = + (* trace is with innermost call coming first *) + let rec aux best_loc = function + | (loc,_)::tail -> + if Loc.is_ghost best_loc || + not (Loc.is_ghost loc) && finer_loc loc best_loc + then + aux loc tail + else + aux best_loc tail + | [] -> best_loc in + aux eloc trace in + None, best_loc + +let get_ltac_trace (_, info) = + let ltac_trace = Exninfo.get info ltac_trace_info in + let loc = Option.default Loc.ghost (Loc.get_loc info) in + match ltac_trace with + | None -> None + | Some trace -> Some (extract_ltac_trace trace loc) + +let () = ExplainErr.register_additional_error_info get_ltac_trace diff --git a/plugins/ltac/tactic_debug.mli b/plugins/ltac/tactic_debug.mli new file mode 100644 index 000000000..7745d9b7b --- /dev/null +++ b/plugins/ltac/tactic_debug.mli @@ -0,0 +1,81 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Environ +open Pattern +open Names +open Tacexpr +open Term +open EConstr +open Evd + +(** TODO: Move those definitions somewhere sensible *) + +val ltac_trace_info : ltac_trace Exninfo.t + +(** This module intends to be a beginning of debugger for tactic expressions. + Currently, it is quite simple and we can hope to have, in the future, a more + complete panel of commands dedicated to a proof assistant framework *) + +(** Debug information *) +type debug_info = + | DebugOn of int + | DebugOff + +(** Prints the state and waits *) +val debug_prompt : + int -> glob_tactic_expr -> (debug_info -> 'a Proofview.tactic) -> 'a Proofview.tactic + +(** Initializes debugger *) +val db_initialize : unit Proofview.NonLogical.t + +(** Prints a constr *) +val db_constr : debug_info -> env -> evar_map -> constr -> unit Proofview.NonLogical.t + +(** Prints the pattern rule *) +val db_pattern_rule : + debug_info -> int -> (Tacexpr.glob_constr_and_expr * constr_pattern,glob_tactic_expr) match_rule -> unit Proofview.NonLogical.t + +(** Prints a matched hypothesis *) +val db_matched_hyp : + debug_info -> env -> evar_map -> Id.t * constr option * constr -> Name.t -> unit Proofview.NonLogical.t + +(** Prints the matched conclusion *) +val db_matched_concl : debug_info -> env -> evar_map -> constr -> unit Proofview.NonLogical.t + +(** Prints a success message when the goal has been matched *) +val db_mc_pattern_success : debug_info -> unit Proofview.NonLogical.t + +(** Prints a failure message for an hypothesis pattern *) +val db_hyp_pattern_failure : + debug_info -> env -> evar_map -> Name.t * constr_pattern match_pattern -> unit Proofview.NonLogical.t + +(** Prints a matching failure message for a rule *) +val db_matching_failure : debug_info -> unit Proofview.NonLogical.t + +(** Prints an evaluation failure message for a rule *) +val db_eval_failure : debug_info -> Pp.std_ppcmds -> unit Proofview.NonLogical.t + +(** An exception handler *) +val explain_logic_error: exn -> Pp.std_ppcmds + +(** For use in the Ltac debugger: some exception that are usually + consider anomalies are acceptable because they are caught later in + the process that is being debugged. One should not require + from users that they report these anomalies. *) +val explain_logic_error_no_anomaly : exn -> Pp.std_ppcmds + +(** Prints a logic failure message for a rule *) +val db_logic_failure : debug_info -> exn -> unit Proofview.NonLogical.t + +(** Prints a logic failure message for a rule *) +val db_breakpoint : debug_info -> + Id.t Loc.located message_token list -> unit Proofview.NonLogical.t + +val extract_ltac_trace : + Tacexpr.ltac_trace -> Loc.t -> Pp.std_ppcmds option * Loc.t diff --git a/plugins/ltac/tactic_matching.ml b/plugins/ltac/tactic_matching.ml new file mode 100644 index 000000000..5b5cd06cc --- /dev/null +++ b/plugins/ltac/tactic_matching.ml @@ -0,0 +1,377 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** This file extends Matching with the main logic for Ltac's + (lazy)match and (lazy)match goal. *) + +open Names +open Tacexpr +open Context.Named.Declaration + +module NamedDecl = Context.Named.Declaration + +(** [t] is the type of matching successes. It ultimately contains a + {!Tacexpr.glob_tactic_expr} representing the left-hand side of the + corresponding matching rule, a matching substitution to be + applied, a context substitution mapping identifier to context like + those of {!Matching.matching_result}), and a {!Term.constr} + substitution mapping corresponding to matched hypotheses. *) +type 'a t = { + subst : Constr_matching.bound_ident_map * Pattern.extended_patvar_map ; + context : EConstr.constr Id.Map.t; + terms : EConstr.constr Id.Map.t; + lhs : 'a; +} + + + +(** {6 Utilities} *) + + +(** Some of the functions of {!Matching} return the substitution with a + [patvar_map] instead of an [extended_patvar_map]. [adjust] coerces + substitution of the former type to the latter. *) +let adjust : Constr_matching.bound_ident_map * Pattern.patvar_map -> + Constr_matching.bound_ident_map * Pattern.extended_patvar_map = + fun (l, lc) -> (l, Id.Map.map (fun c -> [], c) lc) + + +(** Adds a binding to a {!Id.Map.t} if the identifier is [Some id] *) +let id_map_try_add id x m = + match id with + | Some id -> Id.Map.add id x m + | None -> m + +(** Adds a binding to a {!Id.Map.t} if the name is [Name id] *) +let id_map_try_add_name id x m = + match id with + | Name id -> Id.Map.add id x m + | Anonymous -> m + +(** Takes the union of two {!Id.Map.t}. If there is conflict, + the binding of the right-hand argument shadows that of the left-hand + argument. *) +let id_map_right_biased_union m1 m2 = + if Id.Map.is_empty m1 then m2 (** Don't reconstruct the whole map *) + else Id.Map.fold Id.Map.add m2 m1 + +(** Tests whether the substitution [s] is empty. *) +let is_empty_subst (ln,lm) = + Id.Map.(is_empty ln && is_empty lm) + +(** {6 Non-linear patterns} *) + + +(** The patterns of Ltac are not necessarily linear. Non-linear + pattern are partially handled by the {!Matching} module, however + goal patterns are not primitive to {!Matching}, hence we must deal + with non-linearity between hypotheses and conclusion. Subterms are + considered equal up to the equality implemented in + [equal_instances]. *) +(* spiwack: it doesn't seem to be quite the same rule for non-linear + term patterns and non-linearity between hypotheses and/or + conclusion. Indeed, in [Matching], matching is made modulo + syntactic equality, and here we merge modulo conversion. It may be + a good idea to have an entry point of [Matching] with a partial + substitution as argument instead of merging substitution here. That + would ensure consistency. *) +let equal_instances env sigma (ctx',c') (ctx,c) = + (* How to compare instances? Do we want the terms to be convertible? + unifiable? Do we want the universe levels to be relevant? + (historically, conv_x is used) *) + CList.equal Id.equal ctx ctx' && Reductionops.is_conv env sigma c' c + + +(** Merges two substitutions. Raises [Not_coherent_metas] when + encountering two instances of the same metavariable which are not + equal according to {!equal_instances}. *) +exception Not_coherent_metas +let verify_metas_coherence env sigma (ln1,lcm) (ln,lm) = + let merge id oc1 oc2 = match oc1, oc2 with + | None, None -> None + | None, Some c | Some c, None -> Some c + | Some c1, Some c2 -> + if equal_instances env sigma c1 c2 then Some c1 + else raise Not_coherent_metas + in + let (+++) lfun1 lfun2 = Id.Map.fold Id.Map.add lfun1 lfun2 in + (** ppedrot: Is that even correct? *) + let merged = ln +++ ln1 in + (merged, Id.Map.merge merge lcm lm) + +let matching_error = + CErrors.UserError (Some "tactic matching" , Pp.str "No matching clauses for match.") + +let imatching_error = (matching_error, Exninfo.null) + +(** A functor is introduced to share the environment and the + evar_map. They do not change and it would be a pity to introduce + closures everywhere just for the occasional calls to + {!equal_instances}. *) +module type StaticEnvironment = sig + val env : Environ.env + val sigma : Evd.evar_map +end +module PatternMatching (E:StaticEnvironment) = struct + + + (** {6 The pattern-matching monad } *) + + + (** To focus on the algorithmic portion of pattern-matching, the + bookkeeping is relegated to a monad: the composition of the + bactracking monad of {!IStream.t} with a "writer" effect. *) + (* spiwack: as we don't benefit from the various stream optimisations + of Haskell, it may be costly to give the monad in direct style such as + here. We may want to use some continuation passing style. *) + type 'a tac = 'a Proofview.tactic + type 'a m = { stream : 'r. ('a -> unit t -> 'r tac) -> unit t -> 'r tac } + + (** The empty substitution. *) + let empty_subst = Id.Map.empty , Id.Map.empty + + (** Composes two substitutions using {!verify_metas_coherence}. It + must be a monoid with neutral element {!empty_subst}. Raises + [Not_coherent_metas] when composition cannot be achieved. *) + let subst_prod s1 s2 = + if is_empty_subst s1 then s2 + else if is_empty_subst s2 then s1 + else verify_metas_coherence E.env E.sigma s1 s2 + + (** The empty context substitution. *) + let empty_context_subst = Id.Map.empty + + (** Compose two context substitutions, in case of conflict the + right hand substitution shadows the left hand one. *) + let context_subst_prod = id_map_right_biased_union + + (** The empty term substitution. *) + let empty_term_subst = Id.Map.empty + + (** Compose two terms substitutions, in case of conflict the + right hand substitution shadows the left hand one. *) + let term_subst_prod = id_map_right_biased_union + + (** Merge two writers (and ignore the first value component). *) + let merge m1 m2 = + try Some { + subst = subst_prod m1.subst m2.subst; + context = context_subst_prod m1.context m2.context; + terms = term_subst_prod m1.terms m2.terms; + lhs = m2.lhs; + } + with Not_coherent_metas -> None + + (** Monadic [return]: returns a single success with empty substitutions. *) + let return (type a) (lhs:a) : a m = + { stream = fun k ctx -> k lhs ctx } + + (** Monadic bind: each success of [x] is replaced by the successes + of [f x]. The substitutions of [x] and [f x] are composed, + dropping the apparent successes when the substitutions are not + coherent. *) + let (>>=) (type a) (type b) (m:a m) (f:a -> b m) : b m = + { stream = fun k ctx -> m.stream (fun x ctx -> (f x).stream k ctx) ctx } + + (** A variant of [(>>=)] when the first argument returns [unit]. *) + let (<*>) (type a) (m:unit m) (y:a m) : a m = + { stream = fun k ctx -> m.stream (fun () ctx -> y.stream k ctx) ctx } + + (** Failure of the pattern-matching monad: no success. *) + let fail (type a) : a m = { stream = fun _ _ -> Proofview.tclZERO matching_error } + + let run (m : 'a m) = + let ctx = { + subst = empty_subst ; + context = empty_context_subst ; + terms = empty_term_subst ; + lhs = (); + } in + let eval lhs ctx = Proofview.tclUNIT { ctx with lhs } in + m.stream eval ctx + + (** Chooses in a list, in the same order as the list *) + let rec pick (l:'a list) (e, info) : 'a m = match l with + | [] -> { stream = fun _ _ -> Proofview.tclZERO ~info e } + | x :: l -> + { stream = fun k ctx -> Proofview.tclOR (k x ctx) (fun e -> (pick l e).stream k ctx) } + + let pick l = pick l imatching_error + + (** Declares a subsitution, a context substitution and a term substitution. *) + let put subst context terms : unit m = + let s = { subst ; context ; terms ; lhs = () } in + { stream = fun k ctx -> match merge s ctx with None -> Proofview.tclZERO matching_error | Some s -> k () s } + + (** Declares a substitution. *) + let put_subst subst : unit m = put subst empty_context_subst empty_term_subst + + (** Declares a term substitution. *) + let put_terms terms : unit m = put empty_subst empty_context_subst terms + + + + (** {6 Pattern-matching} *) + + + (** [wildcard_match_term lhs] matches a term against a wildcard + pattern ([_ => lhs]). It has a single success with an empty + substitution. *) + let wildcard_match_term = return + + (** [pattern_match_term refresh pat term lhs] returns the possible + matchings of [term] with the pattern [pat => lhs]. If refresh is + true, refreshes the universes of [term]. *) + let pattern_match_term refresh pat term lhs = +(* let term = if refresh then Termops.refresh_universes_strict term else term in *) + match pat with + | Term p -> + begin + try + put_subst (Constr_matching.extended_matches E.env E.sigma p term) <*> + return lhs + with Constr_matching.PatternMatchingFailure -> fail + end + | Subterm (with_app_context,id_ctxt,p) -> + + let rec map s (e, info) = + { stream = fun k ctx -> match IStream.peek s with + | IStream.Nil -> Proofview.tclZERO ~info e + | IStream.Cons ({ Constr_matching.m_sub ; m_ctx }, s) -> + let subst = adjust m_sub in + let context = id_map_try_add id_ctxt m_ctx Id.Map.empty in + let terms = empty_term_subst in + let nctx = { subst ; context ; terms ; lhs = () } in + match merge ctx nctx with + | None -> (map s (e, info)).stream k ctx + | Some nctx -> Proofview.tclOR (k lhs nctx) (fun e -> (map s e).stream k ctx) + } + in + map (Constr_matching.match_subterm_gen E.env E.sigma with_app_context p term) imatching_error + + + (** [rule_match_term term rule] matches the term [term] with the + matching rule [rule]. *) + let rule_match_term term = function + | All lhs -> wildcard_match_term lhs + | Pat ([],pat,lhs) -> pattern_match_term false pat term lhs + | Pat _ -> + (** Rules with hypotheses, only work in match goal. *) + fail + + (** [match_term term rules] matches the term [term] with the set of + matching rules [rules].*) + let rec match_term (e, info) term rules = match rules with + | [] -> { stream = fun _ _ -> Proofview.tclZERO ~info e } + | r :: rules -> + { stream = fun k ctx -> + let head = rule_match_term term r in + let tail e = match_term e term rules in + Proofview.tclOR (head.stream k ctx) (fun e -> (tail e).stream k ctx) + } + + + (** [hyp_match_type hypname pat hyps] matches a single + hypothesis pattern [hypname:pat] against the hypotheses in + [hyps]. Tries the hypotheses in order. For each success returns + the name of the matched hypothesis. *) + let hyp_match_type hypname pat hyps = + pick hyps >>= fun decl -> + let id = NamedDecl.get_id decl in + let refresh = is_local_def decl in + pattern_match_term refresh pat (NamedDecl.get_type decl) () <*> + put_terms (id_map_try_add_name hypname (EConstr.mkVar id) empty_term_subst) <*> + return id + + (** [hyp_match_type hypname bodypat typepat hyps] matches a single + hypothesis pattern [hypname := bodypat : typepat] against the + hypotheses in [hyps].Tries the hypotheses in order. For each + success returns the name of the matched hypothesis. *) + let hyp_match_body_and_type hypname bodypat typepat hyps = + pick hyps >>= function + | LocalDef (id,body,hyp) -> + pattern_match_term false bodypat body () <*> + pattern_match_term true typepat hyp () <*> + put_terms (id_map_try_add_name hypname (EConstr.mkVar id) empty_term_subst) <*> + return id + | LocalAssum (id,hyp) -> fail + + (** [hyp_match pat hyps] dispatches to + {!hyp_match_type} or {!hyp_match_body_and_type} depending on whether + [pat] is [Hyp _] or [Def _]. *) + let hyp_match pat hyps = + match pat with + | Hyp ((_,hypname),typepat) -> + hyp_match_type hypname typepat hyps + | Def ((_,hypname),bodypat,typepat) -> + hyp_match_body_and_type hypname bodypat typepat hyps + + (** [hyp_pattern_list_match pats hyps lhs], matches the list of + patterns [pats] against the hypotheses in [hyps], and eventually + returns [lhs]. *) + let rec hyp_pattern_list_match pats hyps lhs = + match pats with + | pat::pats -> + hyp_match pat hyps >>= fun matched_hyp -> + (* spiwack: alternatively it is possible to return the list + with the matched hypothesis removed directly in + [hyp_match]. *) + let select_matched_hyp decl = Id.equal (NamedDecl.get_id decl) matched_hyp in + let hyps = CList.remove_first select_matched_hyp hyps in + hyp_pattern_list_match pats hyps lhs + | [] -> return lhs + + (** [rule_match_goal hyps concl rule] matches the rule [rule] + against the goal [hyps|-concl]. *) + let rule_match_goal hyps concl = function + | All lhs -> wildcard_match_term lhs + | Pat (hyppats,conclpat,lhs) -> + (* the rules are applied from the topmost one (in the concrete + syntax) to the bottommost. *) + let hyppats = List.rev hyppats in + pattern_match_term false conclpat concl () <*> + hyp_pattern_list_match hyppats hyps lhs + + (** [match_goal hyps concl rules] matches the goal [hyps|-concl] + with the set of matching rules [rules]. *) + let rec match_goal (e, info) hyps concl rules = match rules with + | [] -> { stream = fun _ _ -> Proofview.tclZERO ~info e } + | r :: rules -> + { stream = fun k ctx -> + let head = rule_match_goal hyps concl r in + let tail e = match_goal e hyps concl rules in + Proofview.tclOR (head.stream k ctx) (fun e -> (tail e).stream k ctx) + } + +end + +(** [match_term env sigma term rules] matches the term [term] with the + set of matching rules [rules]. The environment [env] and the + evar_map [sigma] are not currently used, but avoid code + duplication. *) +let match_term env sigma term rules = + let module E = struct + let env = env + let sigma = sigma + end in + let module M = PatternMatching(E) in + M.run (M.match_term imatching_error term rules) + + +(** [match_goal env sigma hyps concl rules] matches the goal + [hyps|-concl] with the set of matching rules [rules]. The + environment [env] and the evar_map [sigma] are used to check + convertibility for pattern variables shared between hypothesis + patterns or the conclusion pattern. *) +let match_goal env sigma hyps concl rules = + let module E = struct + let env = env + let sigma = sigma + end in + let module M = PatternMatching(E) in + M.run (M.match_goal imatching_error hyps concl rules) diff --git a/plugins/ltac/tactic_matching.mli b/plugins/ltac/tactic_matching.mli new file mode 100644 index 000000000..300b546f1 --- /dev/null +++ b/plugins/ltac/tactic_matching.mli @@ -0,0 +1,49 @@ + (************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2012 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +(** This file extends Matching with the main logic for Ltac's + (lazy)match and (lazy)match goal. *) + + +(** [t] is the type of matching successes. It ultimately contains a + {!Tacexpr.glob_tactic_expr} representing the left-hand side of the + corresponding matching rule, a matching substitution to be + applied, a context substitution mapping identifier to context like + those of {!Matching.matching_result}), and a {!Term.constr} + substitution mapping corresponding to matched hypotheses. *) +type 'a t = { + subst : Constr_matching.bound_ident_map * Pattern.extended_patvar_map ; + context : EConstr.constr Names.Id.Map.t; + terms : EConstr.constr Names.Id.Map.t; + lhs : 'a; +} + + +(** [match_term env sigma term rules] matches the term [term] with the + set of matching rules [rules]. The environment [env] and the + evar_map [sigma] are not currently used, but avoid code + duplication. *) +val match_term : + Environ.env -> + Evd.evar_map -> + EConstr.constr -> + (Tacexpr.binding_bound_vars * Pattern.constr_pattern, Tacexpr.glob_tactic_expr) Tacexpr.match_rule list -> + Tacexpr.glob_tactic_expr t Proofview.tactic + +(** [match_goal env sigma hyps concl rules] matches the goal + [hyps|-concl] with the set of matching rules [rules]. The + environment [env] and the evar_map [sigma] are used to check + convertibility for pattern variables shared between hypothesis + patterns or the conclusion pattern. *) +val match_goal: + Environ.env -> + Evd.evar_map -> + EConstr.named_context -> + EConstr.constr -> + (Tacexpr.binding_bound_vars * Pattern.constr_pattern, Tacexpr.glob_tactic_expr) Tacexpr.match_rule list -> + Tacexpr.glob_tactic_expr t Proofview.tactic diff --git a/plugins/ltac/tactic_option.ml b/plugins/ltac/tactic_option.ml new file mode 100644 index 000000000..a5ba3b837 --- /dev/null +++ b/plugins/ltac/tactic_option.ml @@ -0,0 +1,51 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Libobject +open Pp + +let declare_tactic_option ?(default=Tacexpr.TacId []) name = + let locality = Summary.ref false ~name:(name^"-locality") in + let default_tactic_expr : Tacexpr.glob_tactic_expr ref = + Summary.ref default ~name:(name^"-default-tacexpr") + in + let default_tactic : Tacexpr.glob_tactic_expr ref = + Summary.ref !default_tactic_expr ~name:(name^"-default-tactic") + in + let set_default_tactic local t = + locality := local; + default_tactic_expr := t; + default_tactic := t + in + let cache (_, (local, tac)) = set_default_tactic local tac in + let load (_, (local, tac)) = + if not local then set_default_tactic local tac + in + let subst (s, (local, tac)) = + (local, Tacsubst.subst_tactic s tac) + in + let input : bool * Tacexpr.glob_tactic_expr -> obj = + declare_object + { (default_object name) with + cache_function = cache; + load_function = (fun _ -> load); + open_function = (fun _ -> load); + classify_function = (fun (local, tac) -> + if local then Dispose else Substitute (local, tac)); + subst_function = subst} + in + let put local tac = + set_default_tactic local tac; + Lib.add_anonymous_leaf (input (local, tac)) + in + let get () = !locality, Tacinterp.eval_tactic !default_tactic in + let print () = + Pptactic.pr_glob_tactic (Global.env ()) !default_tactic_expr ++ + (if !locality then str" (locally defined)" else str" (globally defined)") + in + put, get, print diff --git a/plugins/decl_mode/decl_interp.mli b/plugins/ltac/tactic_option.mli index 4303ecdb4..ed759a76d 100644 --- a/plugins/decl_mode/decl_interp.mli +++ b/plugins/ltac/tactic_option.mli @@ -6,10 +6,10 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) -open Tacintern -open Decl_expr +open Tacexpr +open Vernacexpr - -val intern_proof_instr : glob_sign -> raw_proof_instr -> glob_proof_instr -val interp_proof_instr : Decl_mode.pm_info -> - Environ.env -> Evd.evar_map -> glob_proof_instr -> proof_instr +val declare_tactic_option : ?default:Tacexpr.glob_tactic_expr -> string -> + (* put *) (locality_flag -> glob_tactic_expr -> unit) * + (* get *) (unit -> locality_flag * unit Proofview.tactic) * + (* print *) (unit -> Pp.std_ppcmds) diff --git a/plugins/ltac/tauto.ml b/plugins/ltac/tauto.ml new file mode 100644 index 000000000..dc7ee6a23 --- /dev/null +++ b/plugins/ltac/tauto.ml @@ -0,0 +1,288 @@ +(************************************************************************) +(* v * The Coq Proof Assistant / The Coq Development Team *) +(* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) +(* \VV/ **************************************************************) +(* // * This file is distributed under the terms of the *) +(* * GNU Lesser General Public License Version 2.1 *) +(************************************************************************) + +open Term +open EConstr +open Hipattern +open Names +open Pp +open Geninterp +open Misctypes +open Tacexpr +open Tacinterp +open Util +open Tacticals.New +open Proofview.Notations + +let tauto_plugin = "tauto" +let () = Mltop.add_known_module tauto_plugin + +let assoc_var s ist = + let v = Id.Map.find (Names.Id.of_string s) ist.lfun in + match Value.to_constr v with + | Some c -> c + | None -> failwith "tauto: anomaly" + +(** Parametrization of tauto *) + +type tauto_flags = { + +(* Whether conjunction and disjunction are restricted to binary connectives *) + binary_mode : bool; + +(* Whether compatibility for buggy detection of binary connective is on *) + binary_mode_bugged_detection : bool; + +(* Whether conjunction and disjunction are restricted to the connectives *) +(* having the structure of "and" and "or" (up to the choice of sorts) in *) +(* contravariant position in an hypothesis *) + strict_in_contravariant_hyp : bool; + +(* Whether conjunction and disjunction are restricted to the connectives *) +(* having the structure of "and" and "or" (up to the choice of sorts) in *) +(* an hypothesis and in the conclusion *) + strict_in_hyp_and_ccl : bool; + +(* Whether unit type includes equality types *) + strict_unit : bool; +} + +let tag_tauto_flags : tauto_flags Val.typ = Val.create "tauto_flags" + +let assoc_flags ist : tauto_flags = + let Val.Dyn (tag, v) = Id.Map.find (Names.Id.of_string "tauto_flags") ist.lfun in + match Val.eq tag tag_tauto_flags with + | None -> assert false + | Some Refl -> v + +(* Whether inner not are unfolded *) +let negation_unfolding = ref true + +(* Whether inner iff are unfolded *) +let iff_unfolding = ref false + +let unfold_iff () = !iff_unfolding || Flags.version_less_or_equal Flags.V8_2 + +open Goptions +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "unfolding of not in intuition"; + optkey = ["Intuition";"Negation";"Unfolding"]; + optread = (fun () -> !negation_unfolding); + optwrite = (:=) negation_unfolding } + +let _ = + declare_bool_option + { optsync = true; + optdepr = false; + optname = "unfolding of iff in intuition"; + optkey = ["Intuition";"Iff";"Unfolding"]; + optread = (fun () -> !iff_unfolding); + optwrite = (:=) iff_unfolding } + +(** Base tactics *) + +let loc = Loc.ghost +let idtac = Proofview.tclUNIT () +let fail = Proofview.tclINDEPENDENT (tclFAIL 0 (Pp.mt ())) + +let intro = Tactics.intro + +let assert_ ?by c = + let tac = match by with + | None -> None + | Some tac -> Some (Some tac) + in + Proofview.tclINDEPENDENT (Tactics.forward true tac None c) + +let apply c = Tactics.apply c + +let clear id = Tactics.clear [id] + +let assumption = Tactics.assumption + +let split = Tactics.split_with_bindings false [Misctypes.NoBindings] + +(** Test *) + +let is_empty _ ist = + Proofview.tclEVARMAP >>= fun sigma -> + if is_empty_type sigma (assoc_var "X1" ist) then idtac else fail + +(* Strictly speaking, this exceeds the propositional fragment as it + matches also equality types (and solves them if a reflexivity) *) +let is_unit_or_eq _ ist = + Proofview.tclEVARMAP >>= fun sigma -> + let flags = assoc_flags ist in + let test = if flags.strict_unit then is_unit_type else is_unit_or_eq_type in + if test sigma (assoc_var "X1" ist) then idtac else fail + +let bugged_is_binary sigma t = + isApp sigma t && + let (hdapp,args) = decompose_app sigma t in + match EConstr.kind sigma hdapp with + | Ind (ind,u) -> + let (mib,mip) = Global.lookup_inductive ind in + Int.equal mib.Declarations.mind_nparams 2 + | _ -> false + +(** Dealing with conjunction *) + +let is_conj _ ist = + Proofview.tclEVARMAP >>= fun sigma -> + let flags = assoc_flags ist in + let ind = assoc_var "X1" ist in + if (not flags.binary_mode_bugged_detection || bugged_is_binary sigma ind) && + is_conjunction sigma + ~strict:flags.strict_in_hyp_and_ccl + ~onlybinary:flags.binary_mode ind + then idtac + else fail + +let flatten_contravariant_conj _ ist = + Proofview.tclEVARMAP >>= fun sigma -> + let flags = assoc_flags ist in + let typ = assoc_var "X1" ist in + let c = assoc_var "X2" ist in + let hyp = assoc_var "id" ist in + match match_with_conjunction sigma + ~strict:flags.strict_in_contravariant_hyp + ~onlybinary:flags.binary_mode typ + with + | Some (_,args) -> + let newtyp = List.fold_right mkArrow args c in + let intros = tclMAP (fun _ -> intro) args in + let by = tclTHENLIST [intros; apply hyp; split; assumption] in + tclTHENLIST [assert_ ~by newtyp; clear (destVar sigma hyp)] + | _ -> fail + +(** Dealing with disjunction *) + +let is_disj _ ist = + Proofview.tclEVARMAP >>= fun sigma -> + let flags = assoc_flags ist in + let t = assoc_var "X1" ist in + if (not flags.binary_mode_bugged_detection || bugged_is_binary sigma t) && + is_disjunction sigma + ~strict:flags.strict_in_hyp_and_ccl + ~onlybinary:flags.binary_mode t + then idtac + else fail + +let flatten_contravariant_disj _ ist = + Proofview.tclEVARMAP >>= fun sigma -> + let flags = assoc_flags ist in + let typ = assoc_var "X1" ist in + let c = assoc_var "X2" ist 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 map i arg = + let typ = 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 + assert_ ~by typ + in + let tacs = List.mapi map args in + let tac0 = clear (destVar sigma hyp) in + tclTHEN (tclTHENLIST tacs) tac0 + | _ -> fail + +let make_unfold name = + let dir = DirPath.make (List.map Id.of_string ["Logic"; "Init"; "Coq"]) in + let const = Constant.make2 (MPfile dir) (Label.make name) in + (Locus.AllOccurrences, ArgArg (EvalConstRef const, None)) + +let u_iff = make_unfold "iff" +let u_not = make_unfold "not" + +let reduction_not_iff _ ist = + let make_reduce c = TacAtom (loc, TacReduce (Genredexpr.Unfold c, Locusops.allHypsAndConcl)) in + let tac = match !negation_unfolding, unfold_iff () with + | true, true -> make_reduce [u_not; u_iff] + | true, false -> make_reduce [u_not] + | false, true -> make_reduce [u_iff] + | false, false -> TacId [] + in + eval_tactic_ist ist tac + +let coq_nnpp_path = + let dir = List.map Id.of_string ["Classical_Prop";"Logic";"Coq"] in + Libnames.make_path (DirPath.make dir) (Id.of_string "NNPP") + +let apply_nnpp _ ist = + Proofview.tclBIND + (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 + +(* This is the uniform mode dealing with ->, not, iff and types isomorphic to + /\ and *, \/ and +, False and Empty_set, True and unit, _and_ eq-like types. + For the moment not and iff are still always unfolded. *) +let tauto_uniform_unit_flags = { + binary_mode = true; + binary_mode_bugged_detection = false; + strict_in_contravariant_hyp = true; + strict_in_hyp_and_ccl = true; + strict_unit = false +} + +(* This is the compatibility mode (not used) *) +let tauto_legacy_flags = { + binary_mode = true; + binary_mode_bugged_detection = true; + strict_in_contravariant_hyp = true; + strict_in_hyp_and_ccl = false; + strict_unit = false +} + +(* This is the improved mode *) +let tauto_power_flags = { + binary_mode = false; (* support n-ary connectives *) + binary_mode_bugged_detection = false; + strict_in_contravariant_hyp = false; (* supports non-regular connectives *) + strict_in_hyp_and_ccl = false; + strict_unit = false +} + +let with_flags flags _ ist = + let f = (loc, Id.of_string "f") in + let x = (loc, Id.of_string "x") in + let arg = Val.Dyn (tag_tauto_flags, flags) in + let ist = { ist with lfun = Id.Map.add (snd x) arg ist.lfun } in + eval_tactic_ist ist (TacArg (loc, TacCall (loc, ArgVar f, [Reference (ArgVar x)]))) + +let register_tauto_tactic tac name0 args = + let ids = List.map (fun id -> Id.of_string id) args in + let ids = List.map (fun id -> Name id) ids in + let name = { mltac_plugin = tauto_plugin; mltac_tactic = name0; } in + let entry = { mltac_name = name; mltac_index = 0 } in + let () = Tacenv.register_ml_tactic name [| tac |] in + let tac = TacFun (ids, TacML (loc, entry, [])) in + let obj () = Tacenv.register_ltac true true (Id.of_string name0) tac in + Mltop.declare_cache_obj obj tauto_plugin + +let () = register_tauto_tactic is_empty "is_empty" ["tauto_flags"; "X1"] +let () = register_tauto_tactic is_unit_or_eq "is_unit_or_eq" ["tauto_flags"; "X1"] +let () = register_tauto_tactic is_disj "is_disj" ["tauto_flags"; "X1"] +let () = register_tauto_tactic is_conj "is_conj" ["tauto_flags"; "X1"] +let () = register_tauto_tactic flatten_contravariant_disj "flatten_contravariant_disj" ["tauto_flags"; "X1"; "X2"; "id"] +let () = register_tauto_tactic flatten_contravariant_conj "flatten_contravariant_conj" ["tauto_flags"; "X1"; "X2"; "id"] +let () = register_tauto_tactic apply_nnpp "apply_nnpp" [] +let () = register_tauto_tactic reduction_not_iff "reduction_not_iff" [] +let () = register_tauto_tactic (with_flags tauto_uniform_unit_flags) "with_uniform_flags" ["f"] +let () = register_tauto_tactic (with_flags tauto_power_flags) "with_power_flags" ["f"] diff --git a/plugins/ltac/tauto.mli b/plugins/ltac/tauto.mli new file mode 100644 index 000000000..e69de29bb --- /dev/null +++ b/plugins/ltac/tauto.mli diff --git a/plugins/ltac/vo.itarget b/plugins/ltac/vo.itarget new file mode 100644 index 000000000..a28fb770b --- /dev/null +++ b/plugins/ltac/vo.itarget @@ -0,0 +1 @@ +Ltac.vo diff --git a/plugins/micromega/RMicromega.v b/plugins/micromega/RMicromega.v index 2352d78d6..30e475b71 100644 --- a/plugins/micromega/RMicromega.v +++ b/plugins/micromega/RMicromega.v @@ -18,7 +18,7 @@ Require Import Refl. Require Import Raxioms RIneq Rpow_def DiscrR. Require Import QArith. Require Import Qfield. - +Require Import Qreals. Require Setoid. (*Declare ML Module "micromega_plugin".*) @@ -38,15 +38,8 @@ Proof. exact Rplus_opp_r. Qed. -Add Ring Rring : Rsrt. Open Scope R_scope. -Lemma Rmult_neutral : forall x:R , 0 * x = 0. -Proof. - intro ; ring. -Qed. - - Lemma Rsor : SOR R0 R1 Rplus Rmult Rminus Ropp (@eq R) Rle Rlt. Proof. constructor; intros ; subst ; try (intuition (subst; try ring ; auto with real)). @@ -59,142 +52,41 @@ Proof. apply (Rlt_irrefl m) ; auto. apply Rnot_le_lt. auto with real. destruct (total_order_T n m) as [ [H1 | H1] | H1] ; auto. - intros. - rewrite <- (Rmult_neutral m). - apply (Rmult_lt_compat_r) ; auto. -Qed. - -Definition IQR := fun x : Q => (IZR (Qnum x) * / IZR (' Qden x))%R. - - -Lemma Rinv_elim : forall x y z, - y <> 0 -> (z * y = x <-> x * / y = z). -Proof. - intros. - split ; intros. - subst. - rewrite Rmult_assoc. - rewrite Rinv_r; auto. - ring. - subst. - rewrite Rmult_assoc. - rewrite (Rmult_comm (/ y)). - rewrite Rinv_r ; auto. - ring. -Qed. - -Ltac INR_nat_of_P := - match goal with - | H : context[INR (Pos.to_nat ?X)] |- _ => - revert H ; - let HH := fresh in - assert (HH := pos_INR_nat_of_P X) ; revert HH ; generalize (INR (Pos.to_nat X)) - | |- context[INR (Pos.to_nat ?X)] => - let HH := fresh in - assert (HH := pos_INR_nat_of_P X) ; revert HH ; generalize (INR (Pos.to_nat X)) - end. - -Ltac add_eq expr val := set (temp := expr) ; - generalize (eq_refl temp) ; - unfold temp at 1 ; generalize temp ; intro val ; clear temp. - -Ltac Rinv_elim := - match goal with - | |- context[?x * / ?y] => - let z := fresh "v" in - add_eq (x * / y) z ; - let H := fresh in intro H ; rewrite <- Rinv_elim in H - end. - -Lemma Rlt_neq : forall r , 0 < r -> r <> 0. -Proof. - red. intros. - subst. - apply (Rlt_irrefl 0 H). + now apply Rmult_lt_0_compat. Qed. +Notation IQR := Q2R (only parsing). Lemma Rinv_1 : forall x, x * / 1 = x. Proof. intro. - Rinv_elim. - subst ; ring. - apply R1_neq_R0. + rewrite Rinv_1. + apply Rmult_1_r. Qed. -Lemma Qeq_true : forall x y, - Qeq_bool x y = true -> - IQR x = IQR y. +Lemma Qeq_true : forall x y, Qeq_bool x y = true -> IQR x = IQR y. Proof. - unfold IQR. - simpl. - intros. - apply Qeq_bool_eq in H. - unfold Qeq in H. - assert (IZR (Qnum x * ' Qden y) = IZR (Qnum y * ' Qden x))%Z. - rewrite H. reflexivity. - repeat rewrite mult_IZR in H0. - simpl in H0. - revert H0. - repeat INR_nat_of_P. intros. - apply Rinv_elim in H2 ; [| apply Rlt_neq ; auto]. - rewrite <- H2. - field. - split ; apply Rlt_neq ; auto. + now apply Qeq_eqR, Qeq_bool_eq. Qed. Lemma Qeq_false : forall x y, Qeq_bool x y = false -> IQR x <> IQR y. Proof. intros. - apply Qeq_bool_neq in H. - intro. apply H. clear H. - unfold Qeq,IQR in *. - simpl in *. - revert H0. - repeat Rinv_elim. - intros. - subst. - assert (IZR (Qnum x * ' Qden y)%Z = IZR (Qnum y * ' Qden x)%Z). - repeat rewrite mult_IZR. - simpl. - rewrite <- H0. rewrite <- H. - ring. - apply eq_IZR ; auto. - INR_nat_of_P; intros; apply Rlt_neq ; auto. - INR_nat_of_P; intros ; apply Rlt_neq ; auto. + apply Qeq_bool_neq in H. + contradict H. + now apply eqR_Qeq. Qed. - - Lemma Qle_true : forall x y : Q, Qle_bool x y = true -> IQR x <= IQR y. Proof. intros. - apply Qle_bool_imp_le in H. - unfold Qle in H. - unfold IQR. - simpl in *. - apply IZR_le in H. - repeat rewrite mult_IZR in H. - simpl in H. - repeat INR_nat_of_P; intros. - assert (Hr := Rlt_neq r H). - assert (Hr0 := Rlt_neq r0 H0). - replace (IZR (Qnum x) * / r) with ((IZR (Qnum x) * r0) * (/r * /r0)). - replace (IZR (Qnum y) * / r0) with ((IZR (Qnum y) * r) * (/r * /r0)). - apply Rmult_le_compat_r ; auto. - apply Rmult_le_pos. - unfold Rle. left. apply Rinv_0_lt_compat ; auto. - unfold Rle. left. apply Rinv_0_lt_compat ; auto. - field ; intuition. - field ; intuition. + now apply Qle_Rle, Qle_bool_imp_le. Qed. - - Lemma IQR_0 : IQR 0 = 0. Proof. - compute. apply Rinv_1. + apply Rmult_0_l. Qed. Lemma IQR_1 : IQR 1 = 1. @@ -202,160 +94,6 @@ Proof. compute. apply Rinv_1. Qed. -Lemma IQR_plus : forall x y, IQR (x + y) = IQR x + IQR y. -Proof. - intros. - unfold IQR. - simpl in *. - rewrite plus_IZR in *. - rewrite mult_IZR in *. - simpl. - rewrite Pos2Nat.inj_mul. - rewrite mult_INR. - rewrite mult_IZR. - simpl. - repeat INR_nat_of_P. - intros. field. - split ; apply Rlt_neq ; auto. -Qed. - -Lemma IQR_opp : forall x, IQR (- x) = - IQR x. -Proof. - intros. - unfold IQR. - simpl. - rewrite opp_IZR. - ring. -Qed. - -Lemma IQR_minus : forall x y, IQR (x - y) = IQR x - IQR y. -Proof. - intros. - unfold Qminus. - rewrite IQR_plus. - rewrite IQR_opp. - ring. -Qed. - - -Lemma IQR_mult : forall x y, IQR (x * y) = IQR x * IQR y. -Proof. - unfold IQR ; intros. - simpl. - repeat rewrite mult_IZR. - rewrite Pos2Nat.inj_mul. - rewrite mult_INR. - repeat INR_nat_of_P. - intros. field ; split ; apply Rlt_neq ; auto. -Qed. - -Lemma IQR_inv_lt : forall x, (0 < x)%Q -> - IQR (/ x) = / IQR x. -Proof. - unfold IQR ; simpl. - intros. - unfold Qlt in H. - revert H. - simpl. - intros. - unfold Qinv. - destruct x. - destruct Qnum ; simpl in *. - exfalso. auto with zarith. - clear H. - repeat INR_nat_of_P. - intros. - assert (HH := Rlt_neq _ H). - assert (HH0 := Rlt_neq _ H0). - rewrite Rinv_mult_distr ; auto. - rewrite Rinv_involutive ; auto. - ring. - apply Rinv_0_lt_compat in H0. - apply Rlt_neq ; auto. - simpl in H. - exfalso. - rewrite Pos.mul_comm in H. - compute in H. - discriminate. -Qed. - -Lemma Qinv_opp : forall x, (- (/ x) = / ( -x))%Q. -Proof. - destruct x ; destruct Qnum ; reflexivity. -Qed. - -Lemma Qopp_involutive_strong : forall x, (- - x = x)%Q. -Proof. - intros. - destruct x. - unfold Qopp. - simpl. - rewrite Z.opp_involutive. - reflexivity. -Qed. - -Lemma Ropp_0 : forall r , - r = 0 -> r = 0. -Proof. - intros. - rewrite <- (Ropp_involutive r). - apply Ropp_eq_0_compat ; auto. -Qed. - -Lemma IQR_x_0 : forall x, IQR x = 0 -> x == 0%Q. -Proof. - destruct x ; simpl. - unfold IQR. - simpl. - INR_nat_of_P. - intros. - apply Rmult_integral in H0. - destruct H0. - apply eq_IZR_R0 in H0. - subst. - reflexivity. - exfalso. - apply Rinv_0_lt_compat in H. - rewrite <- H0 in H. - apply Rlt_irrefl in H. auto. -Qed. - - -Lemma IQR_inv_gt : forall x, (0 > x)%Q -> - IQR (/ x) = / IQR x. -Proof. - intros. - rewrite <- (Qopp_involutive_strong x). - rewrite <- Qinv_opp. - rewrite IQR_opp. - rewrite IQR_inv_lt. - repeat rewrite IQR_opp. - rewrite Ropp_inv_permute. - auto. - intro. - apply Ropp_0 in H0. - apply IQR_x_0 in H0. - rewrite H0 in H. - compute in H. discriminate. - unfold Qlt in *. - destruct x ; simpl in *. - auto with zarith. -Qed. - -Lemma IQR_inv : forall x, ~ x == 0 -> - IQR (/ x) = / IQR x. -Proof. - intros. - assert ( 0 > x \/ 0 < x)%Q. - destruct x ; unfold Qlt, Qeq in * ; simpl in *. - rewrite Z.mul_1_r in *. - destruct Qnum ; simpl in * ; intuition auto. - right. reflexivity. - left ; reflexivity. - destruct H0. - apply IQR_inv_gt ; auto. - apply IQR_inv_lt ; auto. -Qed. - Lemma IQR_inv_ext : forall x, IQR (/ x) = (if Qeq_bool x 0 then 0 else / IQR x). Proof. @@ -366,18 +104,13 @@ Proof. destruct x ; simpl. unfold Qeq in H. simpl in H. - replace Qnum with 0%Z. - compute. rewrite Rinv_1. - reflexivity. - rewrite <- H. ring. + rewrite Zmult_1_r in H. + rewrite H. + apply Rmult_0_l. intros. - apply IQR_inv. - intro. - rewrite <- Qeq_bool_iff in H0. - congruence. + now apply Q2R_inv, Qeq_bool_neq. Qed. - Notation to_nat := N.to_nat. Lemma QSORaddon : @@ -391,10 +124,10 @@ Proof. constructor ; intros ; try reflexivity. apply IQR_0. apply IQR_1. - apply IQR_plus. - apply IQR_minus. - apply IQR_mult. - apply IQR_opp. + apply Q2R_plus. + apply Q2R_minus. + apply Q2R_mult. + apply Q2R_opp. apply Qeq_true ; auto. apply R_power_theory. apply Qeq_false. @@ -453,13 +186,13 @@ Proof. apply IQR_1. reflexivity. unfold IQR. simpl. rewrite Rinv_1. reflexivity. - apply IQR_plus. - apply IQR_minus. - apply IQR_mult. + apply Q2R_plus. + apply Q2R_minus. + apply Q2R_mult. rewrite <- IHc. apply IQR_inv_ext. rewrite <- IHc. - apply IQR_opp. + apply Q2R_opp. Qed. Require Import EnvRing. diff --git a/plugins/micromega/coq_micromega.ml b/plugins/micromega/coq_micromega.ml index e4b58a56f..eb26c5431 100644 --- a/plugins/micromega/coq_micromega.ml +++ b/plugins/micromega/coq_micromega.ml @@ -20,6 +20,8 @@ open Pp open Mutils open Goptions +module Term = EConstr + (** * Debug flag *) @@ -330,6 +332,8 @@ struct open Coqlib open Term + open Constr + open EConstr (** * Location of the Coq libraries. @@ -364,6 +368,7 @@ struct [["Coq";"Reals" ; "Rdefinitions"]; ["Coq";"Reals" ; "Rpow_def"] ; ["Coq";"Reals" ; "Raxioms"] ; + ["Coq";"QArith"; "Qreals"] ; ] let z_modules = [["Coq";"ZArith";"BinInt"]] @@ -373,6 +378,7 @@ struct * ZMicromega.v *) + let gen_constant_in_modules s m n = EConstr.of_constr (gen_constant_in_modules s m n) let init_constant = gen_constant_in_modules "ZMicromega" init_modules let constant = gen_constant_in_modules "ZMicromega" coq_modules let bin_constant = gen_constant_in_modules "ZMicromega" bin_module @@ -383,7 +389,6 @@ struct let coq_and = lazy (init_constant "and") let coq_or = lazy (init_constant "or") let coq_not = lazy (init_constant "not") - let coq_not_gl_ref = (Nametab.locate ( Libnames.qualid_of_string "Coq.Init.Logic.not")) let coq_iff = lazy (init_constant "iff") let coq_True = lazy (init_constant "True") @@ -480,7 +485,7 @@ struct let coq_Rinv = lazy (r_constant "Rinv") let coq_Rpower = lazy (r_constant "pow") let coq_IZR = lazy (r_constant "IZR") - let coq_IQR = lazy (constant "IQR") + let coq_IQR = lazy (r_constant "Q2R") let coq_PEX = lazy (constant "PEX" ) @@ -599,12 +604,12 @@ struct (* A simple but useful getter function *) - let get_left_construct term = - match Term.kind_of_term term with - | Term.Construct((_,i),_) -> (i,[| |]) - | Term.App(l,rst) -> - (match Term.kind_of_term l with - | Term.Construct((_,i),_) -> (i,rst) + let get_left_construct sigma term = + match EConstr.kind sigma term with + | Constr.Construct((_,i),_) -> (i,[| |]) + | Constr.App(l,rst) -> + (match EConstr.kind sigma l with + | Constr.Construct((_,i),_) -> (i,rst) | _ -> raise ParseError ) | _ -> raise ParseError @@ -613,11 +618,11 @@ struct (* parse/dump/print from numbers up to expressions and formulas *) - let rec parse_nat term = - let (i,c) = get_left_construct term in + let rec parse_nat sigma term = + let (i,c) = get_left_construct sigma term in match i with | 1 -> Mc.O - | 2 -> Mc.S (parse_nat (c.(0))) + | 2 -> Mc.S (parse_nat sigma (c.(0))) | i -> raise ParseError let pp_nat o n = Printf.fprintf o "%i" (CoqToCaml.nat n) @@ -627,11 +632,11 @@ struct | Mc.O -> Lazy.force coq_O | Mc.S p -> Term.mkApp(Lazy.force coq_S,[| dump_nat p |]) - let rec parse_positive term = - let (i,c) = get_left_construct term in + let rec parse_positive sigma term = + let (i,c) = get_left_construct sigma term in match i with - | 1 -> Mc.XI (parse_positive c.(0)) - | 2 -> Mc.XO (parse_positive c.(0)) + | 1 -> Mc.XI (parse_positive sigma c.(0)) + | 2 -> Mc.XO (parse_positive sigma c.(0)) | 3 -> Mc.XH | i -> raise ParseError @@ -661,12 +666,12 @@ struct let dump_pair t1 t2 dump_t1 dump_t2 (x,y) = Term.mkApp(Lazy.force coq_pair,[| t1 ; t2 ; dump_t1 x ; dump_t2 y|]) - let parse_z term = - let (i,c) = get_left_construct term in + let parse_z sigma term = + let (i,c) = get_left_construct sigma term in match i with | 1 -> Mc.Z0 - | 2 -> Mc.Zpos (parse_positive c.(0)) - | 3 -> Mc.Zneg (parse_positive c.(0)) + | 2 -> Mc.Zpos (parse_positive sigma c.(0)) + | 3 -> Mc.Zneg (parse_positive sigma c.(0)) | i -> raise ParseError let dump_z x = @@ -686,10 +691,10 @@ struct Term.mkApp(Lazy.force coq_Qmake, [| dump_z q.Micromega.qnum ; dump_positive q.Micromega.qden|]) - let parse_q term = - match Term.kind_of_term term with - | Term.App(c, args) -> if Constr.equal c (Lazy.force coq_Qmake) then - {Mc.qnum = parse_z args.(0) ; Mc.qden = parse_positive args.(1) } + let parse_q sigma term = + match EConstr.kind sigma term with + | Constr.App(c, args) -> if EConstr.eq_constr sigma c (Lazy.force coq_Qmake) then + {Mc.qnum = parse_z sigma args.(0) ; Mc.qden = parse_positive sigma args.(1) } else raise ParseError | _ -> raise ParseError @@ -719,27 +724,27 @@ struct | Mc.CInv t -> Term.mkApp(Lazy.force coq_CInv, [| dump_Rcst t |]) | Mc.COpp t -> Term.mkApp(Lazy.force coq_COpp, [| dump_Rcst t |]) - let rec parse_Rcst term = - let (i,c) = get_left_construct term in + let rec parse_Rcst sigma term = + let (i,c) = get_left_construct sigma term in match i with | 1 -> Mc.C0 | 2 -> Mc.C1 - | 3 -> Mc.CQ (parse_q c.(0)) - | 4 -> Mc.CPlus(parse_Rcst c.(0), parse_Rcst c.(1)) - | 5 -> Mc.CMinus(parse_Rcst c.(0), parse_Rcst c.(1)) - | 6 -> Mc.CMult(parse_Rcst c.(0), parse_Rcst c.(1)) - | 7 -> Mc.CInv(parse_Rcst c.(0)) - | 8 -> Mc.COpp(parse_Rcst c.(0)) + | 3 -> Mc.CQ (parse_q sigma c.(0)) + | 4 -> Mc.CPlus(parse_Rcst sigma c.(0), parse_Rcst sigma c.(1)) + | 5 -> Mc.CMinus(parse_Rcst sigma c.(0), parse_Rcst sigma c.(1)) + | 6 -> Mc.CMult(parse_Rcst sigma c.(0), parse_Rcst sigma c.(1)) + | 7 -> Mc.CInv(parse_Rcst sigma c.(0)) + | 8 -> Mc.COpp(parse_Rcst sigma c.(0)) | _ -> raise ParseError - let rec parse_list parse_elt term = - let (i,c) = get_left_construct term in + let rec parse_list sigma parse_elt term = + let (i,c) = get_left_construct sigma term in match i with | 1 -> [] - | 2 -> parse_elt c.(1) :: parse_list parse_elt c.(2) + | 2 -> parse_elt sigma c.(1) :: parse_list sigma parse_elt c.(2) | i -> raise ParseError let rec dump_list typ dump_elt l = @@ -872,9 +877,9 @@ struct dump_op o ; dump_expr typ dump_constant e2|]) - let assoc_const x l = + let assoc_const sigma x l = try - snd (List.find (fun (x',y) -> Constr.equal x (Lazy.force x')) l) + snd (List.find (fun (x',y) -> EConstr.eq_constr sigma x (Lazy.force x')) l) with Not_found -> raise ParseError @@ -896,37 +901,36 @@ struct coq_Qeq, Mc.OpEq ] - let has_typ gl t1 typ = - let ty = Retyping.get_type_of (Tacmach.pf_env gl) (Tacmach.project gl) t1 in - Constr.equal ty typ - + type gl = { env : Environ.env; sigma : Evd.evar_map } let is_convertible gl t1 t2 = - Reductionops.is_conv (Tacmach.pf_env gl) (Tacmach.project gl) t1 t2 + Reductionops.is_conv gl.env gl.sigma t1 t2 let parse_zop gl (op,args) = - match kind_of_term op with - | Const (x,_) -> (assoc_const op zop_table, args.(0) , args.(1)) + let sigma = gl.sigma in + match EConstr.kind sigma op with + | Const (x,_) -> (assoc_const sigma op zop_table, args.(0) , args.(1)) | Ind((n,0),_) -> - if Constr.equal op (Lazy.force coq_Eq) && is_convertible gl args.(0) (Lazy.force coq_Z) + if EConstr.eq_constr sigma op (Lazy.force coq_Eq) && is_convertible gl args.(0) (Lazy.force coq_Z) then (Mc.OpEq, args.(1), args.(2)) else raise ParseError | _ -> failwith "parse_zop" let parse_rop gl (op,args) = - match kind_of_term op with - | Const (x,_) -> (assoc_const op rop_table, args.(0) , args.(1)) + let sigma = gl.sigma in + match EConstr.kind sigma op with + | Const (x,_) -> (assoc_const sigma op rop_table, args.(0) , args.(1)) | Ind((n,0),_) -> - if Constr.equal op (Lazy.force coq_Eq) && is_convertible gl args.(0) (Lazy.force coq_R) + if EConstr.eq_constr sigma op (Lazy.force coq_Eq) && is_convertible gl args.(0) (Lazy.force coq_R) then (Mc.OpEq, args.(1), args.(2)) else raise ParseError | _ -> failwith "parse_zop" let parse_qop gl (op,args) = - (assoc_const op qop_table, args.(0) , args.(1)) + (assoc_const gl.sigma op qop_table, args.(0) , args.(1)) - let is_constant t = (* This is an approx *) - match kind_of_term t with + let is_constant sigma t = (* This is an approx *) + match EConstr.kind sigma t with | Construct(i,_) -> true | _ -> false @@ -936,9 +940,9 @@ struct | Power | Ukn of string - let assoc_ops x l = + let assoc_ops sigma x l = try - snd (List.find (fun (x',y) -> Constr.equal x (Lazy.force x')) l) + snd (List.find (fun (x',y) -> EConstr.eq_constr sigma x (Lazy.force x')) l) with Not_found -> Ukn "Oups" @@ -950,12 +954,12 @@ struct struct type t = constr list - let compute_rank_add env v = + let compute_rank_add env sigma v = let rec _add env n v = match env with | [] -> ([v],n) | e::l -> - if eq_constr e v + if eq_constr sigma e v then (env,n) else let (env,n) = _add l ( n+1) v in @@ -963,13 +967,13 @@ struct let (env, n) = _add env 1 v in (env, CamlToCoq.positive n) - let get_rank env v = + let get_rank env sigma v = let rec _get_rank env n = match env with | [] -> raise (Invalid_argument "get_rank") | e::l -> - if eq_constr e v + if eq_constr sigma e v then n else _get_rank l (n+1) in _get_rank env 1 @@ -985,9 +989,9 @@ struct * This is the big generic function for expression parsers. *) - let parse_expr parse_constant parse_exp ops_spec env term = + let parse_expr sigma parse_constant parse_exp ops_spec env term = if debug - then Feedback.msg_debug (Pp.str "parse_expr: " ++ Printer.prterm term); + then Feedback.msg_debug (Pp.str "parse_expr: " ++ Printer.pr_leconstr term); (* let constant_or_variable env term = @@ -998,7 +1002,7 @@ struct (Mc.PEX n , env) in *) let parse_variable env term = - let (env,n) = Env.compute_rank_add env term in + let (env,n) = Env.compute_rank_add env sigma term in (Mc.PEX n , env) in let rec parse_expr env term = @@ -1009,12 +1013,12 @@ struct try (Mc.PEc (parse_constant term) , env) with ParseError -> - match kind_of_term term with + match EConstr.kind sigma term with | App(t,args) -> ( - match kind_of_term t with + match EConstr.kind sigma t with | Const c -> - ( match assoc_ops t ops_spec with + ( match assoc_ops sigma t ops_spec with | Binop f -> combine env f (args.(0),args.(1)) | Opp -> let (expr,env) = parse_expr env args.(0) in (Mc.PEopp expr, env) @@ -1026,12 +1030,12 @@ struct (power , env) with e when CErrors.noncritical e -> (* if the exponent is a variable *) - let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env) + let (env,n) = Env.compute_rank_add env sigma term in (Mc.PEX n, env) end | Ukn s -> if debug then (Printf.printf "unknown op: %s\n" s; flush stdout;); - let (env,n) = Env.compute_rank_add env term in (Mc.PEX n, env) + let (env,n) = Env.compute_rank_add env sigma term in (Mc.PEX n, env) ) | _ -> parse_variable env term ) @@ -1074,60 +1078,60 @@ struct (* coq_Rdiv , (fun x y -> Mc.CMult(x,Mc.CInv y)) ;*) ] - let rec rconstant term = - match Term.kind_of_term term with + let rec rconstant sigma term = + match EConstr.kind sigma term with | Const x -> - if Constr.equal term (Lazy.force coq_R0) + if EConstr.eq_constr sigma term (Lazy.force coq_R0) then Mc.C0 - else if Constr.equal term (Lazy.force coq_R1) + else if EConstr.eq_constr sigma term (Lazy.force coq_R1) then Mc.C1 else raise ParseError | App(op,args) -> begin try (* the evaluation order is important in the following *) - let f = assoc_const op rconst_assoc in - let a = rconstant args.(0) in - let b = rconstant args.(1) in + let f = assoc_const sigma op rconst_assoc in + let a = rconstant sigma args.(0) in + let b = rconstant sigma args.(1) in f a b with ParseError -> match op with - | op when Constr.equal op (Lazy.force coq_Rinv) -> - let arg = rconstant args.(0) in + | op when EConstr.eq_constr sigma op (Lazy.force coq_Rinv) -> + let arg = rconstant sigma args.(0) in if Mc.qeq_bool (Mc.q_of_Rcst arg) {Mc.qnum = Mc.Z0 ; Mc.qden = Mc.XH} then raise ParseError (* This is a division by zero -- no semantics *) else Mc.CInv(arg) - | op when Constr.equal op (Lazy.force coq_IQR) -> Mc.CQ (parse_q args.(0)) - | op when Constr.equal op (Lazy.force coq_IZR) -> Mc.CZ (parse_z args.(0)) + | op when EConstr.eq_constr sigma op (Lazy.force coq_IQR) -> Mc.CQ (parse_q sigma args.(0)) + | op when EConstr.eq_constr sigma op (Lazy.force coq_IZR) -> Mc.CZ (parse_z sigma args.(0)) | _ -> raise ParseError end | _ -> raise ParseError - let rconstant term = + let rconstant sigma term = if debug - then Feedback.msg_debug (Pp.str "rconstant: " ++ Printer.prterm term ++ fnl ()); - let res = rconstant term in + then Feedback.msg_debug (Pp.str "rconstant: " ++ Printer.pr_leconstr term ++ fnl ()); + let res = rconstant sigma term in if debug then (Printf.printf "rconstant -> %a\n" pp_Rcst res ; flush stdout) ; res - let parse_zexpr = parse_expr - zconstant + let parse_zexpr sigma = parse_expr sigma + (zconstant sigma) (fun expr x -> - let exp = (parse_z x) in + let exp = (parse_z sigma x) in match exp with | Mc.Zneg _ -> Mc.PEc Mc.Z0 | _ -> Mc.PEpow(expr, Mc.Z.to_N exp)) zop_spec - let parse_qexpr = parse_expr - qconstant + let parse_qexpr sigma = parse_expr sigma + (qconstant sigma) (fun expr x -> - let exp = parse_z x in + let exp = parse_z sigma x in match exp with | Mc.Zneg _ -> begin @@ -1139,21 +1143,22 @@ struct Mc.PEpow(expr,exp)) qop_spec - let parse_rexpr = parse_expr - rconstant + let parse_rexpr sigma = parse_expr sigma + (rconstant sigma) (fun expr x -> - let exp = Mc.N.of_nat (parse_nat x) in + let exp = Mc.N.of_nat (parse_nat sigma x) in Mc.PEpow(expr,exp)) rop_spec let parse_arith parse_op parse_expr env cstr gl = + let sigma = gl.sigma in if debug - then Feedback.msg_debug (Pp.str "parse_arith: " ++ Printer.prterm cstr ++ fnl ()); - match kind_of_term cstr with + then Feedback.msg_debug (Pp.str "parse_arith: " ++ Printer.pr_leconstr cstr ++ fnl ()); + match EConstr.kind sigma cstr with | App(op,args) -> let (op,lhs,rhs) = parse_op gl (op,args) in - let (e1,env) = parse_expr env lhs in - let (e2,env) = parse_expr env rhs in + let (e1,env) = parse_expr sigma env lhs in + let (e2,env) = parse_expr sigma env rhs in ({Mc.flhs = e1; Mc.fop = op;Mc.frhs = e2},env) | _ -> failwith "error : parse_arith(2)" @@ -1191,6 +1196,7 @@ struct *) let parse_formula gl parse_atom env tg term = + let sigma = gl.sigma in let parse_atom env tg t = try @@ -1199,34 +1205,34 @@ struct with e when CErrors.noncritical e -> (X(t),env,tg) in let is_prop term = - let sort = Retyping.get_sort_of (Tacmach.pf_env gl) (Tacmach.project gl) term in - Term.is_prop_sort sort in + let sort = Retyping.get_sort_of gl.env gl.sigma term in + Sorts.is_prop sort in let rec xparse_formula env tg term = - match kind_of_term term with + match EConstr.kind sigma term with | App(l,rst) -> (match rst with - | [|a;b|] when eq_constr l (Lazy.force coq_and) -> + | [|a;b|] when eq_constr sigma l (Lazy.force coq_and) -> let f,env,tg = xparse_formula env tg a in let g,env, tg = xparse_formula env tg b in mkformula_binary mkC term f g,env,tg - | [|a;b|] when eq_constr l (Lazy.force coq_or) -> + | [|a;b|] when eq_constr sigma l (Lazy.force coq_or) -> let f,env,tg = xparse_formula env tg a in let g,env,tg = xparse_formula env tg b in mkformula_binary mkD term f g,env,tg - | [|a|] when eq_constr l (Lazy.force coq_not) -> + | [|a|] when eq_constr sigma l (Lazy.force coq_not) -> let (f,env,tg) = xparse_formula env tg a in (N(f), env,tg) - | [|a;b|] when eq_constr l (Lazy.force coq_iff) -> + | [|a;b|] when eq_constr sigma l (Lazy.force coq_iff) -> let f,env,tg = xparse_formula env tg a in let g,env,tg = xparse_formula env tg b in mkformula_binary mkIff term f g,env,tg | _ -> parse_atom env tg term) - | Prod(typ,a,b) when not (Termops.dependent (mkRel 1) b)-> + | Prod(typ,a,b) when Vars.noccurn sigma 1 b -> let f,env,tg = xparse_formula env tg a in let g,env,tg = xparse_formula env tg b in mkformula_binary mkI term f g,env,tg - | _ when eq_constr term (Lazy.force coq_True) -> (TT,env,tg) - | _ when eq_constr term (Lazy.force coq_False) -> (FF,env,tg) + | _ when eq_constr sigma term (Lazy.force coq_True) -> (TT,env,tg) + | _ when eq_constr sigma term (Lazy.force coq_False) -> (FF,env,tg) | _ when is_prop term -> X(term),env,tg | _ -> raise ParseError in @@ -1246,10 +1252,10 @@ struct xdump f - let prop_env_of_formula form = + let prop_env_of_formula sigma form = let rec doit env = function | TT | FF | A(_,_,_) -> env - | X t -> fst (Env.compute_rank_add env t) + | X t -> fst (Env.compute_rank_add env sigma t) | C(f1,f2) | D(f1,f2) | I(f1,_,f2) -> doit (doit env f1) f2 | N f -> doit env f in @@ -1380,14 +1386,22 @@ let dump_rexpr = lazy *) -let rec make_goal_of_formula dexpr form = +let prodn n env b = + let rec prodrec = function + | (0, env, b) -> b + | (n, ((v,t)::l), b) -> prodrec (n-1, l, mkProd (v,t,b)) + | _ -> assert false + in + prodrec (n,env,b) + +let make_goal_of_formula sigma dexpr form = let vars_idx = List.mapi (fun i v -> (v, i+1)) (ISet.elements (var_env_of_formula form)) in (* List.iter (fun (v,i) -> Printf.fprintf stdout "var %i has index %i\n" v i) vars_idx ;*) - let props = prop_env_of_formula form in + let props = prop_env_of_formula sigma form in let vars_n = List.map (fun (_,i) -> (Names.id_of_string (Printf.sprintf "__x%i" i)) , dexpr.interp_typ) vars_idx in let props_n = List.mapi (fun i _ -> (Names.id_of_string (Printf.sprintf "__p%i" (i+1))) , Term.mkProp) props in @@ -1428,7 +1442,7 @@ let rec make_goal_of_formula dexpr form = | I(x,_,y) -> mkArrow (xdump pi xi x) (xdump (pi+1) (xi+1) y) | N(x) -> mkArrow (xdump pi xi x) (Lazy.force coq_False) | A(x,_,_) -> dump_cstr xi x - | X(t) -> let idx = Env.get_rank props t in + | X(t) -> let idx = Env.get_rank props sigma t in mkRel (pi+idx) in let nb_vars = List.length vars_n in @@ -1437,13 +1451,13 @@ let rec make_goal_of_formula dexpr form = (* Printf.fprintf stdout "NBProps : %i\n" nb_props ;*) let subst_prop p = - let idx = Env.get_rank props p in + let idx = Env.get_rank props sigma p in mkVar (Names.id_of_string (Printf.sprintf "__p%i" idx)) in let form' = map_prop subst_prop form in - (Term.prodn nb_props (List.map (fun (x,y) -> Names.Name x,y) props_n) - (Term.prodn nb_vars (List.map (fun (x,y) -> Names.Name x,y) vars_n) + (prodn nb_props (List.map (fun (x,y) -> Names.Name x,y) props_n) + (prodn nb_vars (List.map (fun (x,y) -> Names.Name x,y) vars_n) (xdump (List.length vars_n) 0 form)), List.rev props_n, List.rev var_name_pos,form') @@ -1517,19 +1531,19 @@ let rec apply_ids t ids = | [] -> t | i::ids -> apply_ids (Term.mkApp(t,[| Term.mkVar i |])) ids -let coq_Node = lazy - (Coqlib.gen_constant_in_modules "VarMap" - [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Node") -let coq_Leaf = lazy - (Coqlib.gen_constant_in_modules "VarMap" - [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Leaf") -let coq_Empty = lazy - (Coqlib.gen_constant_in_modules "VarMap" - [["Coq" ; "micromega" ;"VarMap"];["VarMap"]] "Empty") - -let coq_VarMap = lazy - (Coqlib.gen_constant_in_modules "VarMap" - [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t") +let coq_Node = + lazy (EConstr.of_constr (Coqlib.gen_constant_in_modules "VarMap" + [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Node")) +let coq_Leaf = + lazy (EConstr.of_constr (Coqlib.gen_constant_in_modules "VarMap" + [["Coq" ; "micromega" ; "VarMap"];["VarMap"]] "Leaf")) +let coq_Empty = + lazy (EConstr.of_constr (Coqlib.gen_constant_in_modules "VarMap" + [["Coq" ; "micromega" ;"VarMap"];["VarMap"]] "Empty")) + +let coq_VarMap = + lazy (EConstr.of_constr (Coqlib.gen_constant_in_modules "VarMap" + [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t")) let rec dump_varmap typ m = @@ -1687,7 +1701,8 @@ let rec mk_topo_order le l = | (Some v,l') -> v :: (mk_topo_order le l') -let topo_sort_constr l = mk_topo_order Termops.dependent l +let topo_sort_constr l = + mk_topo_order (fun c t -> Termops.dependent Evd.empty (** FIXME *) (EConstr.of_constr c) (EConstr.of_constr t)) l (** @@ -1702,7 +1717,6 @@ let micromega_order_change spec cert cert_typ env ff (*: unit Proofview.tactic* let vm = dump_varmap (spec.typ) (vm_of_list env) in (* todo : directly generate the proof term - or generalize before conversion? *) Proofview.Goal.nf_enter { enter = begin fun gl -> - let gl = Tacmach.New.of_old (fun x -> x) gl in Tacticals.New.tclTHENLIST [ Tactics.change_concl @@ -1712,7 +1726,7 @@ let micromega_order_change spec cert cert_typ env ff (*: unit Proofview.tactic* ("__varmap", vm, Term.mkApp(Lazy.force coq_VarMap, [|spec.typ|])); ("__wit", cert, cert_typ) ] - (Tacmach.pf_concl gl)) + (Tacmach.New.pf_concl gl)) ] end } @@ -1903,7 +1917,7 @@ let micromega_tauto negate normalise unsat deduce spec prover env polys1 polys2 let formula_typ = (Term.mkApp(Lazy.force coq_Cstr, [|spec.coeff|])) in let ff = dump_formula formula_typ (dump_cstr spec.typ spec.dump_coeff) ff in - Feedback.msg_notice (Printer.prterm ff); + Feedback.msg_notice (Printer.pr_leconstr ff); Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff end; @@ -1928,7 +1942,7 @@ let micromega_tauto negate normalise unsat deduce spec prover env polys1 polys2 let formula_typ = (Term.mkApp( Lazy.force coq_Cstr,[| spec.coeff|])) in let ff' = dump_formula formula_typ (dump_cstr spec.typ spec.dump_coeff) ff' in - Feedback.msg_notice (Printer.prterm ff'); + Feedback.msg_notice (Printer.pr_leconstr ff'); Printf.fprintf stdout "cnf : %a\n" (pp_cnf (fun o _ -> ())) cnf_ff' end; @@ -1949,11 +1963,13 @@ let micromega_tauto negate normalise unsat deduce spec prover env polys1 polys2 Some (ids,ff',res') - (** * Parse the proof environment, and call micromega_tauto *) +let fresh_id avoid id gl = + Tactics.fresh_id_in_env avoid id (Proofview.Goal.env gl) + let micromega_gen parse_arith (negate:'cst atom -> 'cst mc_cnf) @@ -1961,32 +1977,33 @@ let micromega_gen unsat deduce spec dumpexpr prover tac = Proofview.Goal.nf_enter { enter = begin fun gl -> - let gl = Tacmach.New.of_old (fun x -> x) gl in - let concl = Tacmach.pf_concl gl in - let hyps = Tacmach.pf_hyps_types gl in + let sigma = Tacmach.New.project gl in + let concl = Tacmach.New.pf_concl gl in + let hyps = Tacmach.New.pf_hyps_types gl in try - let (hyps,concl,env) = parse_goal gl parse_arith Env.empty hyps concl in + let gl0 = { env = Tacmach.New.pf_env gl; sigma } in + let (hyps,concl,env) = parse_goal gl0 parse_arith Env.empty hyps concl in let env = Env.elements env in let spec = Lazy.force spec in let dumpexpr = Lazy.force dumpexpr in - match micromega_tauto negate normalise unsat deduce spec prover env hyps concl gl with + match micromega_tauto negate normalise unsat deduce spec prover env hyps concl gl0 with | None -> Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness") | Some (ids,ff',res') -> - let (arith_goal,props,vars,ff_arith) = make_goal_of_formula dumpexpr ff' in + let (arith_goal,props,vars,ff_arith) = make_goal_of_formula sigma dumpexpr ff' in let intro (id,_) = Tactics.introduction id in let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in let intro_props = Tacticals.New.tclTHENLIST (List.map intro props) in let ipat_of_name id = Some (Loc.ghost, Misctypes.IntroNaming (Misctypes.IntroIdentifier id)) in - let goal_name = Tactics.fresh_id [] (Names.Id.of_string "__arith") gl in + let goal_name = fresh_id [] (Names.Id.of_string "__arith") gl in let env' = List.map (fun (id,i) -> Term.mkVar id,i) vars in let tac_arith = Tacticals.New.tclTHENLIST [ intro_props ; intro_vars ; micromega_order_change spec res' (Term.mkApp(Lazy.force coq_list, [|spec.proof_typ|])) env' ff_arith ] in - let goal_props = List.rev (prop_env_of_formula ff') in + let goal_props = List.rev (prop_env_of_formula sigma ff') in let goal_vars = List.map (fun (_,i) -> List.nth env (i-1)) vars in @@ -2038,7 +2055,6 @@ let micromega_order_changer cert env ff = let ff = dump_formula formula_typ (dump_cstr coeff dump_coeff) ff in let vm = dump_varmap (typ) (vm_of_list env) in Proofview.Goal.nf_enter { enter = begin fun gl -> - let gl = Tacmach.New.of_old (fun x -> x) gl in Tacticals.New.tclTHENLIST [ (Tactics.change_concl @@ -2046,11 +2062,11 @@ let micromega_order_changer cert env ff = [ ("__ff", ff, Term.mkApp(Lazy.force coq_Formula, [|formula_typ |])); ("__varmap", vm, Term.mkApp - (Coqlib.gen_constant_in_modules "VarMap" - [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t", [|typ|])); + (EConstr.of_constr (Coqlib.gen_constant_in_modules "VarMap" + [["Coq" ; "micromega" ; "VarMap"] ; ["VarMap"]] "t"), [|typ|])); ("__wit", cert, cert_typ) ] - (Tacmach.pf_concl gl))); + (Tacmach.New.pf_concl gl))); (* Tacticals.New.tclTHENLIST (List.map (fun id -> (Tactics.introduction id)) ids)*) ] end } @@ -2069,38 +2085,39 @@ let micromega_genr prover tac = dump_proof = dump_psatz coq_Q dump_q } in Proofview.Goal.nf_enter { enter = begin fun gl -> - let gl = Tacmach.New.of_old (fun x -> x) gl in - let concl = Tacmach.pf_concl gl in - let hyps = Tacmach.pf_hyps_types gl in + let sigma = Tacmach.New.project gl in + let concl = Tacmach.New.pf_concl gl in + let hyps = Tacmach.New.pf_hyps_types gl in try - let (hyps,concl,env) = parse_goal gl parse_arith Env.empty hyps concl in + let gl0 = { env = Tacmach.New.pf_env gl; sigma } in + let (hyps,concl,env) = parse_goal gl0 parse_arith Env.empty hyps concl in let env = Env.elements env in let spec = Lazy.force spec in let hyps' = List.map (fun (n,f) -> (n, map_atoms (Micromega.map_Formula Micromega.q_of_Rcst) f)) hyps in let concl' = map_atoms (Micromega.map_Formula Micromega.q_of_Rcst) concl in - match micromega_tauto negate normalise unsat deduce spec prover env hyps' concl' gl with + match micromega_tauto negate normalise unsat deduce spec prover env hyps' concl' gl0 with | None -> Tacticals.New.tclFAIL 0 (Pp.str " Cannot find witness") | Some (ids,ff',res') -> let (ff,ids) = formula_hyps_concl (List.filter (fun (n,_) -> List.mem n ids) hyps) concl in let ff' = abstract_wrt_formula ff' ff in - let (arith_goal,props,vars,ff_arith) = make_goal_of_formula (Lazy.force dump_rexpr) ff' in + let (arith_goal,props,vars,ff_arith) = make_goal_of_formula sigma (Lazy.force dump_rexpr) ff' in let intro (id,_) = Tactics.introduction id in let intro_vars = Tacticals.New.tclTHENLIST (List.map intro vars) in let intro_props = Tacticals.New.tclTHENLIST (List.map intro props) in let ipat_of_name id = Some (Loc.ghost, Misctypes.IntroNaming (Misctypes.IntroIdentifier id)) in - let goal_name = Tactics.fresh_id [] (Names.Id.of_string "__arith") gl in + let goal_name = fresh_id [] (Names.Id.of_string "__arith") gl in let env' = List.map (fun (id,i) -> Term.mkVar id,i) vars in let tac_arith = Tacticals.New.tclTHENLIST [ intro_props ; intro_vars ; micromega_order_changer res' env' ff_arith ] in - let goal_props = List.rev (prop_env_of_formula ff') in + let goal_props = List.rev (prop_env_of_formula sigma ff') in let goal_vars = List.map (fun (_,i) -> List.nth env (i-1)) vars in diff --git a/plugins/micromega/g_micromega.ml4 b/plugins/micromega/g_micromega.ml4 index 79020ed03..ccb6daa11 100644 --- a/plugins/micromega/g_micromega.ml4 +++ b/plugins/micromega/g_micromega.ml4 @@ -16,6 +16,7 @@ (*i camlp4deps: "grammar/grammar.cma" i*) +open Ltac_plugin open Stdarg open Tacarg diff --git a/plugins/nsatz/Nsatz.v b/plugins/nsatz/Nsatz.v index b11d15e5c..403f664e2 100644 --- a/plugins/nsatz/Nsatz.v +++ b/plugins/nsatz/Nsatz.v @@ -462,6 +462,11 @@ try (try apply Rsth; exact Rplus_opp_r. Defined. +Class can_compute_Z (z : Z) := dummy_can_compute_Z : True. +Hint Extern 0 (can_compute_Z ?v) => + match isZcst v with true => exact I end : typeclass_instances. +Instance reify_IZR z lvar {_ : can_compute_Z z} : reify (PEc z) lvar (IZR z). + Lemma R_one_zero: 1%R <> 0%R. discrR. Qed. diff --git a/plugins/nsatz/g_nsatz.ml4 b/plugins/nsatz/g_nsatz.ml4 index 5f906a8da..759885253 100644 --- a/plugins/nsatz/g_nsatz.ml4 +++ b/plugins/nsatz/g_nsatz.ml4 @@ -1,5 +1,3 @@ -DECLARE PLUGIN "nsatz_plugin" - (************************************************************************) (* v * The Coq Proof Assistant / The Coq Development Team *) (* <O___,, * INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2016 *) @@ -10,8 +8,11 @@ DECLARE PLUGIN "nsatz_plugin" (*i camlp4deps: "grammar/grammar.cma" i*) +open Ltac_plugin +open Names + DECLARE PLUGIN "nsatz_plugin" TACTIC EXTEND nsatz_compute -| [ "nsatz_compute" constr(lt) ] -> [ Nsatz.nsatz_compute lt ] +| [ "nsatz_compute" constr(lt) ] -> [ Nsatz.nsatz_compute (EConstr.Unsafe.to_constr lt) ] END diff --git a/plugins/nsatz/ideal.ml b/plugins/nsatz/ideal.ml index 48bdad826..b1ff59e78 100644 --- a/plugins/nsatz/ideal.ml +++ b/plugins/nsatz/ideal.ml @@ -23,7 +23,6 @@ exception NotInIdeal Global options *) let lexico = ref false -let use_hmon = ref false (* division of tail monomials *) @@ -33,31 +32,30 @@ let reduire_les_queues = false let nouveaux_pol_en_tete = false -(*********************************************************************** - Functor -*) - -module Make (P:Polynom.S) = struct - - type coef = P.t - let coef0 = P.of_num (Num.Int 0) - let coef1 = P.of_num (Num.Int 1) - let coefm1 = P.of_num (Num.Int (-1)) - let string_of_coef c = "["^(P.to_string c)^"]" - -(*********************************************************************** - Monomials - array of integers, first is the degree -*) - -type mon = int array -type deg = int -type poly = (coef * mon) list -type polynom = - {pol : poly ref; - num : int; - sugar : int} - +type metadata = { + name_var : string list; +} + +module Monomial : +sig +type t +val repr : t -> int array +val make : int array -> t +val deg : t -> int +val nvar : t -> int +val var_mon : int -> int -> t +val mult_mon : t -> t -> t +val compare_mon : t -> t -> int +val div_mon : t -> t -> t +val div_mon_test : t -> t -> bool +val ppcm_mon : t -> t -> t +val const_mon : int -> t +end = +struct +type t = int array +type mon = t +let repr m = m +let make m = m let nvar (m : mon) = Array.length m - 1 let deg (m : mon) = m.(0) @@ -104,9 +102,6 @@ let div_mon m m' = done; m'' -let div_pol_coef p c = - List.map (fun (a,m) -> (P.divP a c,m)) p - (* m' divides m *) let div_mon_test m m' = let d = nvar m in @@ -135,7 +130,46 @@ let ppcm_mon m m' = done; set_deg m'' +(* returns a constant polynom ial with d variables *) +let const_mon d = + let m = Array.make (d+1) 0 in + let m = set_deg m in + m + +let var_mon d i = + let m = Array.make (d+1) 0 in + m.(i) <- 1; + let m = set_deg m in + m + +end + +(*********************************************************************** + Functor +*) + +module Make (P:Polynom.S) = struct + + type coef = P.t + let coef0 = P.of_num (Num.Int 0) + let coef1 = P.of_num (Num.Int 1) + let coefm1 = P.of_num (Num.Int (-1)) + let string_of_coef c = "["^(P.to_string c)^"]" + +(*********************************************************************** + Monomials + array of integers, first is the degree +*) + +open Monomial +type mon = Monomial.t +type deg = int +type poly = (coef * mon) list +type polynom = { + pol : poly; + num : int; +} (********************************************************************** Polynomials @@ -179,8 +213,8 @@ let string_of_pol zeroP hdP tlP coefterm monterm string_of_coef for i=1 to (dimmon m) do (match (string_of_exp m i) with "0" -> () - | "1" -> s:= (!s) @ [(getvar !lvar (i-1))] - | e -> s:= (!s) @ [((getvar !lvar (i-1)) ^ "^" ^ e)]); + | "1" -> s:= (!s) @ [(getvar lvar (i-1))] + | e -> s:= (!s) @ [((getvar lvar (i-1)) ^ "^" ^ e)]); done; (match !s with [] -> if coefone @@ -228,8 +262,8 @@ let print_pol zeroP hdP tlP coefterm monterm string_of_coef for i=1 to (dimmon m) do (match (string_of_exp m i) with "0" -> () - | "1" -> s:= (!s) @ [(getvar !lvar (i-1))] - | e -> s:= (!s) @ [((getvar !lvar (i-1)) ^ "^" ^ e)]); + | "1" -> s:= (!s) @ [(getvar lvar (i-1))] + | e -> s:= (!s) @ [((getvar lvar (i-1)) ^ "^" ^ e)]); done; (match !s with [] -> if coefone @@ -271,9 +305,7 @@ let print_pol zeroP hdP tlP coefterm monterm string_of_coef print_flush() -let name_var= ref [] - -let stringP p = +let stringP metadata (p : poly) = string_of_pol (fun p -> match p with [] -> true | _ -> false) (fun p -> match p with (t::p) -> t |_ -> failwith "print_pol dans dansideal") @@ -281,55 +313,29 @@ let stringP p = (fun (a,m) -> a) (fun (a,m) -> m) string_of_coef - (fun m -> (Array.length m)-1) - (fun m i -> (string_of_int (m.(i)))) - name_var + (fun m -> (Array.length (Monomial.repr m))-1) + (fun m i -> (string_of_int ((Monomial.repr m).(i)))) + metadata.name_var p -let nsP2 = ref max_int +let nsP2 = 10 -let stringPcut p = +let stringPcut metadata (p : poly) = (*Polynomesrec.nsP1:=20;*) - nsP2:=10; let res = - if (List.length p)> !nsP2 - then (stringP [List.hd p])^" + "^(string_of_int (List.length p))^" terms" - else stringP p in + if (List.length p)> nsP2 + then (stringP metadata [List.hd p])^" + "^(string_of_int (List.length p))^" terms" + else stringP metadata p in (*Polynomesrec.nsP1:= max_int;*) - nsP2:= max_int; res -let rec lstringP l = - match l with - [] -> "" - |p::l -> (stringP p)^("\n")^(lstringP l) - -let printP = print_pol - (fun p -> match p with [] -> true | _ -> false) - (fun p -> match p with (t::p) -> t |_ -> failwith "print_pol dans dansideal") - (fun p -> match p with (t::p) -> p |_ -> failwith "print_pol dans dansideal") - (fun (a,m) -> a) - (fun (a,m) -> m) - string_of_coef - (fun m -> (Array.length m)-1) - (fun m i -> (string_of_int (m.(i)))) - name_var - - -let rec lprintP l = - match l with - [] -> () - |p::l -> printP p;print_string "\n"; lprintP l - - (* Operations *) let zeroP = [] (* returns a constant polynom ial with d variables *) let polconst d c = - let m = Array.make (d+1) 0 in - let m = set_deg m in + let m = const_mon d in [(c,m)] let plusP p q = @@ -357,9 +363,7 @@ let coef_of_int x = P.of_num (Num.Int x) (* variable i *) let gen d i = - let m = Array.make (d+1) 0 in - m.(i) <- 1; - let m = set_deg m in + let m = var_mon d i in [((coef_of_int 1),m)] let oppP p = @@ -390,7 +394,7 @@ let puisP p n= |_ -> if n = 0 then let d = nvar (snd (List.hd p)) in - [coef1, Array.make (d+1) 0] + [coef1, const_mon d] else let rec puisP p n = if n = 1 then p @@ -400,49 +404,34 @@ let puisP p n= if n mod 2 = 0 then q else multP p q in puisP p n -let rec contentP p = - match p with - |[] -> coef1 - |[a,m] -> a - |(a,m)::p1 -> - if P.equal a coef1 || P.equal a coefm1 - then a - else P.pgcdP a (contentP p1) - -let contentPlist lp = - match lp with - |[] -> coef1 - |p::l1 -> - List.fold_left - (fun r q -> - if P.equal r coef1 || P.equal r coefm1 - then r - else P.pgcdP r (contentP q)) - (contentP p) l1 - (*********************************************************************** Division of polynomials *) +type table = { + hmon : (mon, poly) Hashtbl.t option; + (* coefficients of polynomials when written with initial polynomials *) + coefpoldep : ((int * int), poly) Hashtbl.t; + mutable nallpol : int; + mutable allpol : polynom array; + (* list of initial polynomials *) +} + let pgcdpos a b = P.pgcdP a b -let polynom0 = {pol = ref []; num = 0; sugar = 0} +let polynom0 = { pol = []; num = 0 } -let ppol p = !(p.pol) +let ppol p = p.pol let lm p = snd (List.hd (ppol p)) -let nallpol = ref 0 - -let allpol = ref (Array.make 1000 polynom0) - -let new_allpol p s = - nallpol := !nallpol + 1; - if !nallpol >= Array.length !allpol +let new_allpol table p = + table.nallpol <- table.nallpol + 1; + if table.nallpol >= Array.length table.allpol then - allpol := Array.append !allpol (Array.make !nallpol polynom0); - let p = {pol = ref p; num = !nallpol; sugar = s} in - !allpol.(!nallpol)<- p; + table.allpol <- Array.append table.allpol (Array.make table.nallpol polynom0); + let p = { pol = p; num = table.nallpol } in + table.allpol.(table.nallpol) <- p; p (* returns a polynomial of l whose head monomial divides m, else [] *) @@ -456,43 +445,42 @@ let rec selectdiv m l = |false -> selectdiv m r let div_pol p q a b m = -(* info ".";*) plusP (emultP a p) (mult_t_pol b m q) -let hmon = Hashtbl.create 1000 - -let use_hmon = ref false - -let find_hmon m = - if !use_hmon - then Hashtbl.find hmon m - else raise Not_found - -let add_hmon m q = - if !use_hmon - then Hashtbl.add hmon m q - else () +let find_hmon table m = match table.hmon with +| None -> raise Not_found +| Some hmon -> Hashtbl.find hmon m + +let add_hmon table m q = +match table.hmon with +| None -> () +| Some hmon -> Hashtbl.add hmon m q + +let selectdiv table m l = + try find_hmon table m + with Not_found -> + let q = selectdiv m l in + let q = ppol q in + match q with + | [] -> q + | _ :: _ -> + let () = add_hmon table m q in + q let div_coef a b = P.divP a b (* remainder r of the division of p by polynomials of l, returns (c,r) where c is the coefficient for pseudo-division : c p = sum_i q_i p_i + r *) -let reduce2 p l = +let reduce2 table p l = let l = if nouveaux_pol_en_tete then List.rev l else l in let rec reduce p = match p with [] -> (coef1,[]) |t::p' -> let (a,m)=t in - let q = (try find_hmon m - with Not_found -> - let q = selectdiv m l in - match (ppol q) with - t'::q' -> (add_hmon m q; - q) - |[] -> q) in - match (ppol q) with + let q = selectdiv table m l in + match q with [] -> if reduire_les_queues then let (c,r)=(reduce p') in @@ -508,37 +496,19 @@ let reduce2 p l = in let (c,r) = reduce p in (c,r) -(* trace of divisions *) - -(* list of initial polynomials *) -let poldep = ref [] -let poldepcontent = ref [] - -(* coefficients of polynomials when written with initial polynomials *) -let coefpoldep = Hashtbl.create 51 - (* coef of q in p = sum_i c_i*q_i *) -let coefpoldep_find p q = - try (Hashtbl.find coefpoldep (p.num,q.num)) +let coefpoldep_find table p q = + try (Hashtbl.find table.coefpoldep (p.num,q.num)) with Not_found -> [] -let coefpoldep_remove p q = - Hashtbl.remove coefpoldep (p.num,q.num) - -let coefpoldep_set p q c = - Hashtbl.add coefpoldep (p.num,q.num) c - -let initcoefpoldep d lp = - poldep:=lp; - poldepcontent:= List.map (fun p -> contentP (ppol p)) lp; - List.iter - (fun p -> coefpoldep_set p p (polconst d (coef_of_int 1))) - lp +let coefpoldep_set table p q c = + Hashtbl.add table.coefpoldep (p.num,q.num) c (* keeps trace in coefpoldep divides without pseudodivisions *) -let reduce2_trace p l lcp = +let reduce2_trace table p l lcp = + let lp = l in let l = if nouveaux_pol_en_tete then List.rev l else l in (* rend (lq,r), ou r = p + sum(lq) *) let rec reduce p = @@ -546,15 +516,8 @@ let reduce2_trace p l lcp = [] -> ([],[]) |t::p' -> let (a,m)=t in - let q = - (try find_hmon m - with Not_found -> - let q = selectdiv m l in - match (ppol q) with - t'::q' -> (add_hmon m q; - q) - |[] -> q) in - match (ppol q) with + let q = selectdiv table m l in + match q with [] -> if reduire_les_queues then @@ -568,19 +531,12 @@ let reduce2_trace p l lcp = let (lq,r)=reduce p1 in ((b',m'',q)::lq, r) in let (lq,r) = reduce p in - (*info "reduce2_trace:\n"; - iter - (fun (a,m,s) -> - let x = mult_t_pol a m s in - info ((stringP x)^"\n")) - lq; - info "ok\n";*) (List.map2 (fun c0 q -> let c = List.fold_left (fun x (a,m,s) -> - if equal (ppol s) (ppol q) + if equal s (ppol q) then plusP x (mult_t_pol a m (polconst (nvar m) (coef_of_int 1))) else x) @@ -588,25 +544,14 @@ let reduce2_trace p l lcp = lq in c) lcp - !poldep, + lp, r) -let homogeneous = ref false -let pol_courant = ref polynom0 - (*********************************************************************** Completion *) -let sugar_flag = ref true - -let compute_sugar p = - List.fold_left (fun s (a,m) -> max s m.(0)) 0 p - -let mk_polynom p = - new_allpol p (compute_sugar p) - -let spol ps qs= +let spol0 ps qs= let p = ppol ps in let q = ppol qs in let m = snd (List.hd p) in @@ -628,14 +573,9 @@ let spol ps qs= (P.oppP (div_coef a c)) m2 q') in let sp = fsp p' q' in - let sps = - new_allpol - sp - (max (m1.(0) + ps.sugar) (m2.(0) + qs.sugar)) in - coefpoldep_set sps ps (fsp (polconst (nvar m) (coef_of_int 1)) []); - coefpoldep_set sps qs (fsp [] (polconst (nvar m) (coef_of_int 1))); - sps - + let p0 = fsp (polconst (nvar m) (coef_of_int 1)) [] in + let q0 = fsp [] (polconst (nvar m) (coef_of_int 1)) in + (sp, p0, q0) let etrangers p p'= let m = snd (List.hd p) in @@ -644,301 +584,186 @@ let etrangers p p'= let res=ref true in let i=ref 1 in while (!res) && (!i<=d) do - res:= (m.(!i) = 0) || (m'.(!i)=0); + res:= ((Monomial.repr m).(!i) = 0) || ((Monomial.repr m').(!i)=0); i:=!i+1; done; !res -(* teste if head monomial of p'' divides lcm of lhead monomials of p and p' *) - -let div_ppcm p p' p'' = - let m = snd (List.hd p) in - let m'= snd (List.hd p') in - let m''= snd (List.hd p'') in - let d = nvar m in - let res=ref true in - let i=ref 1 in - while (!res) && (!i<=d) do - res:= ((max m.(!i) m'.(!i)) >= m''.(!i)); - i:=!i+1; - done; - !res - -(* code from extraction of Laurent Théry Coq program *) - -type 'poly cpRes = - Keep of ('poly list) - | DontKeep of ('poly list) - -let list_rec f0 f1 = - let rec f2 = function - [] -> f0 - | a0::l0 -> f1 a0 l0 (f2 l0) - in f2 - -let addRes i = function - Keep h'0 -> Keep (i::h'0) - | DontKeep h'0 -> DontKeep (i::h'0) - -let slice i a q = - list_rec - (match etrangers (ppol i) (ppol a) with - true -> DontKeep [] - | false -> Keep []) - (fun b q1 rec_ren -> - match div_ppcm (ppol i) (ppol a) (ppol b) with - true -> DontKeep (b::q1) - | false -> - (match div_ppcm (ppol i) (ppol b) (ppol a) with - true -> rec_ren - | false -> addRes b rec_ren)) q - -(* sugar strategy *) - let addS x l = l @ [x] (* oblige de mettre en queue sinon le certificat deconne *) - -let addSsugar x l = - if !sugar_flag - then - let sx = x.sugar in - let rec insere l = - match l with - | [] -> [x] - | y::l1 -> - if sx <= y.sugar - then x::l - else y::(insere l1) - in insere l - else addS x l - -(* ajoute les spolynomes de i avec la liste de polynomes aP, - a la liste q *) - -let genPcPf i aP q = - (let rec genPc aP0 = - match aP0 with - [] -> (fun r -> r) - | a::l1 -> - (fun l -> - (match slice i a l1 with - Keep l2 -> addSsugar (spol i a) (genPc l2 l) - | DontKeep l2 -> genPc l2 l)) - in genPc aP) q - -let genOCPf h' = - list_rec [] (fun a l rec_ren -> - genPcPf a l rec_ren) h' - + (*********************************************************************** critical pairs/s-polynomials *) - -let ordcpair ((i1,j1),m1) ((i2,j2),m2) = -(* let s1 = (max - (!allpol.(i1).sugar + m1.(0) - - (snd (hd (ppol !allpol.(i1)))).(0)) - (!allpol.(j1).sugar + m1.(0) - - (snd (hd (ppol !allpol.(j1)))).(0))) in - let s2 = (max - (!allpol.(i2).sugar + m2.(0) - - (snd (hd (ppol !allpol.(i2)))).(0)) - (!allpol.(j2).sugar + m2.(0) - - (snd (hd (ppol !allpol.(j2)))).(0))) in - match compare s1 s2 with - | 1 -> 1 - |(-1) -> -1 - |0 -> compare_mon m1 m2*) +let ordcpair ((i1,j1),m1) ((i2,j2),m2) = compare_mon m1 m2 -let sortcpairs lcp = - List.sort ordcpair lcp +module CPair = +struct +type t = (int * int) * Monomial.t +let compare ((i1, j1), m1) ((i2, j2), m2) = compare_mon m2 m1 +end -let mergecpairs l1 l2 = - List.merge ordcpair l1 l2 +module Heap : +sig + type elt = (int * int) * Monomial.t + type t + val length : t -> int + val empty : t + val add : elt -> t -> t + val pop : t -> (elt * t) option +end = +struct + include Heap.Functional(CPair) + let length h = fold (fun _ accu -> accu + 1) h 0 + let pop h = try Some (maximum h, remove h) with Heap.EmptyHeap -> None +end let ord i j = if i<j then (i,j) else (j,i) -let cpair p q = - if etrangers (ppol p) (ppol q) - then [] - else [(ord p.num q.num, - ppcm_mon (lm p) (lm q))] - -let cpairs1 p lq = - sortcpairs (List.fold_left (fun r q -> r @ (cpair p q)) [] lq) - -let cpairs lp = - let rec aux l = - match l with - []|[_] -> [] - |p::l1 -> mergecpairs (cpairs1 p l1) (aux l1) - in aux lp - - -let critere2 ((i,j),m) lp lcp = - List.exists - (fun h -> - h.num <> i && h.num <> j - && (div_mon_test m (lm h)) - && (let c1 = ord i h.num in - not (List.exists (fun (c,_) -> c1 = c) lcp)) - && (let c1 = ord j h.num in - not (List.exists (fun (c,_) -> c1 = c) lcp))) - lp +let cpair p q accu = + if etrangers (ppol p) (ppol q) then accu + else Heap.add (ord p.num q.num, ppcm_mon (lm p) (lm q)) accu + +let cpairs1 p lq accu = + List.fold_left (fun r q -> cpair p q r) accu lq -let critere3 ((i,j),m) lp lcp = +let rec cpairs l accu = match l with +| [] | [_] -> accu +| p :: l -> + cpairs l (cpairs1 p l accu) + +let critere3 table ((i,j),m) lp lcp = List.exists (fun h -> h.num <> i && h.num <> j && (div_mon_test m (lm h)) && (h.num < j || not (m = ppcm_mon - (lm (!allpol.(i))) + (lm (table.allpol.(i))) (lm h))) && (h.num < i || not (m = ppcm_mon - (lm (!allpol.(j))) + (lm (table.allpol.(j))) (lm h)))) lp -let add_cpairs p lp lcp = - mergecpairs (cpairs1 p lp) lcp - -let step = ref 0 - let infobuch p q = - if !step = 0 - then (info ("[" ^ (string_of_int (List.length p)) - ^ "," ^ (string_of_int (List.length q)) - ^ "]")) + (info (fun () -> Printf.sprintf "[%i,%i]" (List.length p) (Heap.length q))) (* in lp new polynomials are at the end *) -let coef_courant = ref coef1 - type certificate = { coef : coef; power : int; gb_comb : poly list list; last_comb : poly list } -let test_dans_ideal p lp lp0 = - let (c,r) = reduce2 (ppol !pol_courant) lp in - info ("remainder: "^(stringPcut r)^"\n"); - coef_courant:= P.multP !coef_courant c; - pol_courant:= mk_polynom r; - if r=[] - then (info "polynomial reduced to 0\n"; - let lcp = List.map (fun q -> []) !poldep in - let c = !coef_courant in - let (lcq,r) = reduce2_trace (emultP c p) lp lcp in - info "r ok\n"; - info ("r: "^(stringP r)^"\n"); - let res=ref (emultP c p) in - List.iter2 - (fun cq q -> res:=plusP (!res) (multP cq (ppol q)); - ) - lcq !poldep; - info ("verif sum: "^(stringP (!res))^"\n"); - info ("coefficient: "^(stringP (polconst 1 c))^"\n"); - let rec aux lp = - match lp with - |[] -> [] - |p::lp -> - (List.map - (fun q -> coefpoldep_find p q) - lp)::(aux lp) - in - let coefficient_multiplicateur = c in - let liste_polynomes_de_depart = List.rev lp0 in - let polynome_a_tester = p in - let liste_des_coefficients_intermediaires = - (let lci = List.rev (aux (List.rev lp)) in - let lci = ref lci (* (map rev lci) *) in - List.iter (fun x -> lci := List.tl (!lci)) lp0; - !lci) in - let liste_des_coefficients = - List.map - (fun cq -> emultP (coef_of_int (-1)) cq) - (List.rev lcq) in - (liste_polynomes_de_depart, - polynome_a_tester, - {coef = coefficient_multiplicateur; - power = 1; - gb_comb = liste_des_coefficients_intermediaires; - last_comb = liste_des_coefficients}) - ) - else ((*info "polynomial not reduced to 0\n"; - info ("\nremainder: "^(stringPcut r)^"\n");*) - raise NotInIdeal) - -let divide_rem_with_critical_pair = ref false - -let list_diff l x = - List.filter (fun y -> y <> x) l +type current_problem = { + cur_poly : poly; + cur_coef : coef; +} + +exception NotInIdealUpdate of current_problem + +let test_dans_ideal cur_pb table metadata p lp len0 = + (** Invariant: [lp] is [List.tl (Array.to_list table.allpol)] *) + let (c,r) = reduce2 table cur_pb.cur_poly lp in + info (fun () -> "remainder: "^(stringPcut metadata r)); + let cur_pb = { + cur_coef = P.multP cur_pb.cur_coef c; + cur_poly = r; + } in + match r with + | [] -> + sinfo "polynomial reduced to 0"; + let lcp = List.map (fun q -> []) lp in + let c = cur_pb.cur_coef in + let (lcq,r) = reduce2_trace table (emultP c p) lp lcp in + sinfo "r ok"; + info (fun () -> "r: "^(stringP metadata r)); + info (fun () -> + let fold res cq q = plusP res (multP cq (ppol q)) in + let res = List.fold_left2 fold (emultP c p) lcq lp in + "verif sum: "^(stringP metadata res) + ); + info (fun () -> "coefficient: "^(stringP metadata (polconst 1 c))); + let coefficient_multiplicateur = c in + let liste_des_coefficients_intermediaires = + let rec aux accu lp = + match lp with + | [] -> accu + | p :: lp -> + let elt = List.map (fun q -> coefpoldep_find table p q) lp in + aux (elt :: accu) lp + in + let lci = aux [] (List.rev lp) in + CList.skipn len0 lci + in + let liste_des_coefficients = + List.rev_map (fun cq -> emultP (coef_of_int (-1)) cq) lcq + in + {coef = coefficient_multiplicateur; + power = 1; + gb_comb = liste_des_coefficients_intermediaires; + last_comb = liste_des_coefficients} + | _ -> raise (NotInIdealUpdate cur_pb) let deg_hom p = match p with | [] -> -1 - | (a,m)::_ -> m.(0) - -let pbuchf pq p lp0= - info "computation of the Groebner basis\n"; - step:=0; - Hashtbl.clear hmon; - let rec pbuchf (lp, lpc) = + | (a,m)::_ -> Monomial.deg m + +let pbuchf table metadata cur_pb homogeneous (lp, lpc) p = + (** Invariant: [lp] is [List.tl (Array.to_list table.allpol)] *) + sinfo "computation of the Groebner basis"; + let () = match table.hmon with + | None -> () + | Some hmon -> Hashtbl.clear hmon + in + let len0 = List.length lp in + let rec pbuchf cur_pb (lp, lpc) = infobuch lp lpc; -(* step:=(!step+1)mod 10;*) - match lpc with - [] -> - - (* info ("List of polynomials:\n"^(fold_left (fun r p -> r^(stringP p)^"\n") "" lp)); - info "--------------------\n";*) - test_dans_ideal (ppol p) lp lp0 - | ((i,j),m) :: lpc2 -> -(* info "choosen pair\n";*) - if critere3 ((i,j),m) lp lpc2 - then (info "c"; pbuchf (lp, lpc2)) + match Heap.pop lpc with + | None -> + test_dans_ideal cur_pb table metadata p lp len0 + | Some (((i, j), m), lpc2) -> + if critere3 table ((i,j),m) lp lpc2 + then (sinfo "c"; pbuchf cur_pb (lp, lpc2)) else - let a = spol !allpol.(i) !allpol.(j) in - if !homogeneous && (ppol a)<>[] && deg_hom (ppol a) - > deg_hom (ppol !pol_courant) - then (info "h"; pbuchf (lp, lpc2)) + let (a0, p0, q0) = spol0 table.allpol.(i) table.allpol.(j) in + if homogeneous && a0 <>[] && deg_hom a0 > deg_hom cur_pb.cur_poly + then (sinfo "h"; pbuchf cur_pb (lp, lpc2)) else (* let sa = a.sugar in*) - let (ca,a0)= reduce2 (ppol a) lp in - match a0 with - [] -> info "0";pbuchf (lp, lpc2) - | _ -> + match reduce2 table a0 lp with + _, [] -> sinfo "0";pbuchf cur_pb (lp, lpc2) + | ca, _ :: _ -> (* info "pair reduced\n";*) - a.pol := emultP ca (ppol a); - let (lca,a0) = reduce2_trace (ppol a) lp - (List.map (fun q -> emultP ca (coefpoldep_find a q)) - !poldep) in + let map q = + let r = + if q.num == i then p0 else if q.num == j then q0 else [] + in + emultP ca r + in + let lcp = List.map map lp in + let (lca, a0) = reduce2_trace table (emultP ca a0) lp lcp in (* info "paire re-reduced";*) - a.pol := a0; -(* let a0 = new_allpol a0 sa in*) - List.iter2 (fun c q -> - coefpoldep_remove a q; - coefpoldep_set a q c) lca !poldep; + let a = new_allpol table a0 in + List.iter2 (fun c q -> coefpoldep_set table a q c) lca lp; let a0 = a in - info ("\nnew polynomial: "^(stringPcut (ppol a0))^"\n"); - let ct = coef1 (* contentP a0 *) in - (*info ("content: "^(string_of_coef ct)^"\n");*) - poldep:=addS a0 lp; - poldepcontent:=addS ct (!poldepcontent); - - try test_dans_ideal (ppol p) (addS a0 lp) lp0 - with NotInIdeal -> - let newlpc = add_cpairs a0 lp lpc2 in - pbuchf (((addS a0 lp), newlpc)) - in pbuchf pq + info (fun () -> "new polynomial: "^(stringPcut metadata (ppol a0))); + let nlp = addS a0 lp in + try test_dans_ideal cur_pb table metadata p nlp len0 + with NotInIdealUpdate cur_pb -> + let newlpc = cpairs1 a0 lp lpc2 in + pbuchf cur_pb (nlp, newlpc) + in pbuchf cur_pb (lp, lpc) let is_homogeneous p = match p with | [] -> true - | (a,m)::p1 -> let d = m.(0) in - List.for_all (fun (b,m') -> m'.(0)=d) p1 + | (a,m)::p1 -> let d = deg m in + List.for_all (fun (b,m') -> deg m' =d) p1 (* returns c @@ -955,33 +780,33 @@ let is_homogeneous p = where pn+k = a(n+k,n+k-1)*pn+k-1 + ... + a(n+k,1)* p1 *) -let in_ideal d lp p = - Hashtbl.clear hmon; - Hashtbl.clear coefpoldep; - nallpol := 0; - allpol := Array.make 1000 polynom0; - homogeneous := List.for_all is_homogeneous (p::lp); - if !homogeneous then info "homogeneous polynomials\n"; - info ("p: "^(stringPcut p)^"\n"); - info ("lp:\n"^(List.fold_left (fun r p -> r^(stringPcut p)^"\n") "" lp)); - (*info ("p: "^(stringP p)^"\n"); - info ("lp:\n"^(fold_left (fun r p -> r^(stringP p)^"\n") "" lp));*) - - let lp = List.map mk_polynom lp in - let p = mk_polynom p in - initcoefpoldep d lp; - coef_courant:=coef1; - pol_courant:=p; - - let (lp1,p1,cert) = - try test_dans_ideal (ppol p) lp lp - with NotInIdeal -> pbuchf (lp, (cpairs lp)) p lp in - info "computed\n"; - - (List.map ppol lp1, p1, cert) - -(* *) -end - - +let in_ideal metadata d lp p = + let table = { + hmon = None; + coefpoldep = Hashtbl.create 51; + nallpol = 0; + allpol = Array.make 1000 polynom0; + } in + let homogeneous = List.for_all is_homogeneous (p::lp) in + if homogeneous then sinfo "homogeneous polynomials"; + info (fun () -> "p: "^(stringPcut metadata p)); + info (fun () -> "lp:\n"^(List.fold_left (fun r p -> r^(stringPcut metadata p)^"\n") "" lp)); + + let lp = List.map (fun c -> new_allpol table c) lp in + List.iter (fun p -> coefpoldep_set table p p (polconst d (coef_of_int 1))) lp; + let cur_pb = { + cur_poly = p; + cur_coef = coef1; + } in + + let cert = + try pbuchf table metadata cur_pb homogeneous (lp, Heap.empty) p + with NotInIdealUpdate cur_pb -> + try pbuchf table metadata cur_pb homogeneous (lp, cpairs lp Heap.empty) p + with NotInIdealUpdate _ -> raise NotInIdeal + in + sinfo "computed"; + + cert +end diff --git a/plugins/nsatz/ideal.mli b/plugins/nsatz/ideal.mli index d1a2a0a7d..b7ec901af 100644 --- a/plugins/nsatz/ideal.mli +++ b/plugins/nsatz/ideal.mli @@ -6,6 +6,17 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +type metadata = { + name_var : string list; +} + +module Monomial : +sig +type t +val repr : t -> int array +val make : int array -> t +end + module Make (P : Polynom.S) : sig (* Polynomials *) @@ -14,32 +25,26 @@ type deg = int type coef = P.t type poly -val repr : poly -> (coef * int array) list +val repr : poly -> (coef * Monomial.t) list val polconst : int -> coef -> poly val zeroP : poly val gen : int -> int -> poly val equal : poly -> poly -> bool -val name_var : string list ref val plusP : poly -> poly -> poly val oppP : poly -> poly val multP : poly -> poly -> poly val puisP : poly -> int -> poly -val poldepcontent : coef list ref - type certificate = { coef : coef; power : int; gb_comb : poly list list; last_comb : poly list } -val in_ideal : deg -> poly list -> poly -> poly list * poly * certificate +val in_ideal : metadata -> deg -> poly list -> poly -> certificate module Hashpol : Hashtbl.S with type key = poly -val sugar_flag : bool ref -val divide_rem_with_critical_pair : bool ref - end exception NotInIdeal diff --git a/plugins/nsatz/nsatz.ml b/plugins/nsatz/nsatz.ml index 36bce780b..db8f3e4b2 100644 --- a/plugins/nsatz/nsatz.ml +++ b/plugins/nsatz/nsatz.ml @@ -257,21 +257,19 @@ let rec parse_request lp = (parse_term p)::(parse_request lp1) |_-> assert false -let nvars = ref 0 - -let set_nvars_term t = - let rec aux t = +let set_nvars_term nvars t = + let rec aux t nvars = match t with - | Zero -> () - | Const r -> () + | Zero -> nvars + | Const r -> nvars | Var v -> let n = int_of_string v in - nvars:= max (!nvars) n - | Opp t1 -> aux t1 - | Add (t1,t2) -> aux t1; aux t2 - | Sub (t1,t2) -> aux t1; aux t2 - | Mul (t1,t2) -> aux t1; aux t2 - | Pow (t1,n) -> aux t1 - in aux t + max nvars n + | Opp t1 -> aux t1 nvars + | Add (t1,t2) -> aux t2 (aux t1 nvars) + | Sub (t1,t2) -> aux t2 (aux t1 nvars) + | Mul (t1,t2) -> aux t2 (aux t1 nvars) + | Pow (t1,n) -> aux t1 nvars + in aux t nvars let string_of_term p = let rec aux p = @@ -301,8 +299,8 @@ open PIdeal varaibles <=np are in the coefficients *) -let term_pol_sparse np t= - let d = !nvars in +let term_pol_sparse nvars np t= + let d = nvars in let rec aux t = (* info ("conversion de: "^(string_of_term t)^"\n");*) let res = @@ -336,14 +334,8 @@ let polrec_to_term p = match p with |Poly.Pint n -> const (Coef.to_num n) |Poly.Prec (v,coefs) -> - let res = ref Zero in - Array.iteri - (fun i c -> - res:=add(!res, mul(aux c, - pow (Var (string_of_int v), - i)))) - coefs; - !res + let fold i c res = add (res, mul (aux c, pow (Var (string_of_int v), i))) in + Array.fold_right_i fold coefs Zero in aux p (* approximation of the Horner form used in the tactic ring *) @@ -355,9 +347,11 @@ let pol_sparse_to_term n2 p = match p with [] -> const (num_of_string "0") | (a,m)::p1 -> + let m = Ideal.Monomial.repr m in let n = (Array.length m)-1 in let (i0,e0) = List.fold_left (fun (r,d) (a,m) -> + let m = Ideal.Monomial.repr m in let i0= ref 0 in for k=1 to n do if m.(k)>0 @@ -374,45 +368,28 @@ let pol_sparse_to_term n2 p = p in if Int.equal i0 0 then - let mp = ref (polrec_to_term a) in - if List.is_empty p1 - then !mp - else add(!mp,aux p1) - else ( - let p1=ref [] in - let p2=ref [] in - List.iter - (fun (a,m) -> - if m.(i0)>=e0 - then (m.(i0)<-m.(i0)-e0; - p1:=(a,m)::(!p1)) - else p2:=(a,m)::(!p2)) - p; + let mp = polrec_to_term a in + if List.is_empty p1 then mp else add (mp, aux p1) + else + let fold (p1, p2) (a, m) = + if (Ideal.Monomial.repr m).(i0) >= e0 then begin + let m0 = Array.copy (Ideal.Monomial.repr m) in + let () = m0.(i0) <- m0.(i0) - e0 in + let m0 = Ideal.Monomial.make m0 in + ((a, m0) :: p1, p2) + end else + (p1, (a, m) :: p2) + in + let (p1, p2) = List.fold_left fold ([], []) p in let vm = if Int.equal e0 1 then Var (string_of_int (i0)) else pow (Var (string_of_int (i0)),e0) in - add(mul(vm, aux (List.rev (!p1))), aux (List.rev (!p2)))) + add (mul(vm, aux (List.rev p1)), aux (List.rev p2)) in (*info "-> pol_sparse_to_term\n";*) aux p -let remove_list_tail l i = - let rec aux l i = - if List.is_empty l - then [] - else if i<0 - then l - else if Int.equal i 0 - then List.tl l - else - match l with - |(a::l1) -> - a::(aux l1 (i-1)) - |_ -> assert false - in - List.rev (aux (List.rev l) i) - (* lq = [cn+m+1 n+m ...cn+m+1 1] lci=[[cn+1 n,...,cn1 1] @@ -422,49 +399,35 @@ let remove_list_tail l i = removes intermediate polynomials not useful to compute the last one. *) -let remove_zeros zero lci = - let n = List.length (List.hd lci) in - let m=List.length lci in +let remove_zeros lci = + let m = List.length lci in let u = Array.make m false in let rec utiles k = - if k>=m - then () - else ( - u.(k)<-true; + (** TODO: Find a more reasonable implementation of this traversal. *) + if k >= m || u.(k) then () + else + let () = u.(k) <- true in let lc = List.nth lci k in - for i=0 to List.length lc - 1 do - if not (zero (List.nth lc i)) - then utiles (i+k+1); - done) - in utiles 0; - let lr = ref [] in - for i=0 to m-1 do - if u.(i) - then lr:=(List.nth lci i)::(!lr) - done; - let lr=List.rev !lr in - let lr = List.map - (fun lc -> - let lcr=ref lc in - for i=0 to m-1 do - if not u.(i) - then lcr:=remove_list_tail !lcr (m-i+(n-m)) - done; - !lcr) - lr in - info ("useless spolynomials: " - ^string_of_int (m-List.length lr)^"\n"); - info ("useful spolynomials: " - ^string_of_int (List.length lr)^"\n"); + let iter i c = if not (PIdeal.equal c zeroP) then utiles (i + k + 1) in + List.iteri iter lc + in + let () = utiles 0 in + let filter i l = + let f j l = if m <= i + j + 1 then true else u.(i + j + 1) in + if u.(i) then Some (List.filteri f l) + else None + in + let lr = CList.map_filter_i filter lci in + info (fun () -> Printf.sprintf "useless spolynomials: %i" (m-List.length lr)); + info (fun () -> Printf.sprintf "useful spolynomials: %i " (List.length lr)); lr -let theoremedeszeros lpol p = +let theoremedeszeros metadata nvars lpol p = let t1 = Unix.gettimeofday() in - let m = !nvars in - let (lp0,p,cert) = in_ideal m lpol p in - let lpc = List.rev !poldepcontent in - info ("time: "^Format.sprintf "@[%10.3f@]s\n" (Unix.gettimeofday ()-.t1)); - (cert,lp0,p,lpc) + let m = nvars in + let cert = in_ideal metadata m lpol p in + info (fun () -> Printf.sprintf "time: @[%10.3f@]s" (Unix.gettimeofday ()-.t1)); + cert open Ideal @@ -507,51 +470,33 @@ let expand_pol lb lp = in List.rev (aux lb (List.rev lp)) let theoremedeszeros_termes lp = - nvars:=0;(* mise a jour par term_pol_sparse *) - List.iter set_nvars_term lp; + let nvars = List.fold_left set_nvars_term 0 lp in match lp with | Const (Int sugarparam)::Const (Int nparam)::lp -> ((match sugarparam with - |0 -> info "computation without sugar\n"; + |0 -> sinfo "computation without sugar"; lexico:=false; - sugar_flag := false; - divide_rem_with_critical_pair := false - |1 -> info "computation with sugar\n"; + |1 -> sinfo "computation with sugar"; lexico:=false; - sugar_flag := true; - divide_rem_with_critical_pair := false - |2 -> info "ordre lexico computation without sugar\n"; + |2 -> sinfo "ordre lexico computation without sugar"; lexico:=true; - sugar_flag := false; - divide_rem_with_critical_pair := false - |3 -> info "ordre lexico computation with sugar\n"; + |3 -> sinfo "ordre lexico computation with sugar"; lexico:=true; - sugar_flag := true; - divide_rem_with_critical_pair := false - |4 -> info "computation without sugar, division by pairs\n"; + |4 -> sinfo "computation without sugar, division by pairs"; lexico:=false; - sugar_flag := false; - divide_rem_with_critical_pair := true - |5 -> info "computation with sugar, division by pairs\n"; + |5 -> sinfo "computation with sugar, division by pairs"; lexico:=false; - sugar_flag := true; - divide_rem_with_critical_pair := true - |6 -> info "ordre lexico computation without sugar, division by pairs\n"; + |6 -> sinfo "ordre lexico computation without sugar, division by pairs"; lexico:=true; - sugar_flag := false; - divide_rem_with_critical_pair := true - |7 -> info "ordre lexico computation with sugar, division by pairs\n"; + |7 -> sinfo "ordre lexico computation with sugar, division by pairs"; lexico:=true; - sugar_flag := true; - divide_rem_with_critical_pair := true | _ -> error "nsatz: bad parameter" ); - let m= !nvars in - let lvar=ref [] in - for i=m downto 1 do lvar:=["x"^(string_of_int i)^""]@(!lvar); done; - lvar:=["a";"b";"c";"d";"e";"f";"g";"h";"i";"j";"k";"l";"m";"n";"o";"p";"q";"r";"s";"t";"u";"v";"w";"x";"y";"z"] @ (!lvar); (* pour macaulay *) - name_var:=!lvar; - let lp = List.map (term_pol_sparse nparam) lp in + let lvar = List.init nvars (fun i -> Printf.sprintf "x%i" (i + 1)) in + let lvar = ["a";"b";"c";"d";"e";"f";"g";"h";"i";"j";"k";"l";"m";"n";"o";"p";"q";"r";"s";"t";"u";"v";"w";"x";"y";"z"] @ lvar in + (* pour macaulay *) + let metadata = { name_var = lvar } in + let lp = List.map (term_pol_sparse nvars nparam) lp in match lp with | [] -> assert false | p::lp1 -> @@ -561,16 +506,16 @@ let theoremedeszeros_termes lp = lb is kept in order to fix the certificate in the post-processing *) let lpol, lb = clean_pol lpol in - let (cert,lp0,p,_lct) = theoremedeszeros lpol p in - info "cert ok\n"; + let cert = theoremedeszeros metadata nvars lpol p in + sinfo "cert ok"; let lc = cert.last_comb::List.rev cert.gb_comb in - match remove_zeros (fun x -> equal x zeroP) lc with + match remove_zeros lc with | [] -> assert false | (lq::lci) -> (* post-processing : we apply the correction for the last line *) let lq = expand_pol lb lq in (* lci commence par les nouveaux polynomes *) - let m = !nvars in + let m = nvars in let c = pol_sparse_to_term m (polconst m cert.coef) in let r = Pow(Zero,cert.power) in let lci = List.rev lci in @@ -578,8 +523,8 @@ let theoremedeszeros_termes lp = let lci = List.map (expand_pol lb) lci in let lci = List.map (List.map (pol_sparse_to_term m)) lci in let lq = List.map (pol_sparse_to_term m) lq in - info ("number of parameters: "^string_of_int nparam^"\n"); - info "term computed\n"; + info (fun () -> Printf.sprintf "number of parameters: %i" nparam); + sinfo "term computed"; (c,r,lci,lq) ) |_ -> assert false @@ -619,12 +564,13 @@ let nsatz lpol = mkt_app lcons [tlp ();ltterm;r]) res (mkt_app lnil [tlp ()]) in - info "term computed\n"; + sinfo "term computed"; res 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 = @@ -633,5 +579,3 @@ let nsatz_compute t = with Ideal.NotInIdeal -> error "nsatz cannot solve this problem" in return_term lpol - - diff --git a/plugins/nsatz/utile.ml b/plugins/nsatz/utile.ml index 922432460..d3cfd75e5 100644 --- a/plugins/nsatz/utile.ml +++ b/plugins/nsatz/utile.ml @@ -11,8 +11,8 @@ let prt0 s = () (* print_string s;flush(stdout)*) let prt s = if !Flags.debug then (print_string (s^"\n");flush(stdout)) else () -let info s = - Flags.if_verbose prerr_string s +let sinfo s = if !Flags.debug then Feedback.msg_debug (Pp.str s) +let info s = if !Flags.debug then Feedback.msg_debug (Pp.str (s ())) (* Lists *) diff --git a/plugins/nsatz/utile.mli b/plugins/nsatz/utile.mli index 1f8415752..9308577e0 100644 --- a/plugins/nsatz/utile.mli +++ b/plugins/nsatz/utile.mli @@ -4,7 +4,8 @@ val pr : string -> unit val prn : string -> unit val prt0 : 'a -> unit val prt : string -> unit -val info : string -> unit +val info : (unit -> string) -> unit +val sinfo : string -> unit (* Listes *) val list_mem_eq : ('a -> 'b -> bool) -> 'a -> 'b list -> bool diff --git a/plugins/omega/coq_omega.ml b/plugins/omega/coq_omega.ml index 1afc6500b..92b092ffe 100644 --- a/plugins/omega/coq_omega.ml +++ b/plugins/omega/coq_omega.ml @@ -18,8 +18,9 @@ open Util open Names open Nameops open Term -open Tacticals -open Tacmach +open EConstr +open Tacticals.New +open Tacmach.New open Tactics open Logic open Libnames @@ -37,10 +38,12 @@ open OmegaSolver (* Added by JCF, 09/03/98 *) let elim_id id = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> simplest_elim (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 = Proofview.Goal.enter { enter = begin fun gl -> + apply (Tacmach.New.pf_global id gl) +end } let timing timer_name f arg = f arg @@ -145,14 +148,14 @@ let intern_id,unintern_id,reset_intern_tables = Hashtbl.add table v idx; Hashtbl.add co_table idx v; v), (fun () -> cpt := 0; Hashtbl.clear table) -let mk_then = tclTHENLIST +let mk_then tacs = tclTHENLIST tacs let exists_tac c = constructor_tac false (Some 1) 1 (ImplicitBindings [c]) let generalize_tac t = generalize 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] +let pf_nf gl c = pf_apply Tacred.simpl gl c let rev_assoc k = let rec loop = function @@ -172,8 +175,8 @@ let tag_hypothesis,tag_of_hyp, hyp_of_tag, clear_tags = let hide_constr,find_constr,clear_constr_tables,dump_tables = let l = ref ([]:(constr * (Id.t * Id.t * bool)) list) in (fun h id eg b -> l := (h,(id,eg,b)):: !l), - (fun h -> - try List.assoc_f eq_constr_nounivs h !l with Not_found -> failwith "find_contr"), + (fun sigma h -> + try List.assoc_f (eq_constr_nounivs sigma) h !l with Not_found -> failwith "find_contr"), (fun () -> l := []), (fun () -> !l) @@ -197,6 +200,7 @@ let coq_modules = init_modules @arith_modules @ [logic_dir] @ zarith_base_modules @ [["Coq"; "omega"; "OmegaLemmas"]] +let gen_constant_in_modules n m s = EConstr.of_constr (gen_constant_in_modules n m s) let init_constant = gen_constant_in_modules "Omega" init_modules let constant = gen_constant_in_modules "Omega" coq_modules @@ -348,11 +352,18 @@ let coq_not_iff = lazy (constant "not_iff") let coq_not_not = lazy (constant "not_not") let coq_imp_simp = lazy (constant "imp_simp") let coq_iff = lazy (constant "iff") +let coq_not = lazy (init_constant "not") +let coq_and = lazy (init_constant "and") +let coq_or = lazy (init_constant "or") +let coq_eq = lazy (init_constant "eq") +let coq_ex = lazy (init_constant "ex") +let coq_False = lazy (init_constant "False") +let coq_True = lazy (init_constant "True") (* uses build_coq_and, build_coq_not, build_coq_or, build_coq_ex *) (* For unfold *) -let evaluable_ref_of_constr s c = match kind_of_term (Lazy.force c) with +let evaluable_ref_of_constr s c = match EConstr.kind Evd.empty (Lazy.force c) with | Const (kn,u) when Tacred.is_evaluable (Global.env()) (EvalConstRef kn) -> EvalConstRef kn | _ -> anomaly ~label:"Coq_omega" (Pp.str (s^" is not an evaluable constant")) @@ -364,21 +375,21 @@ let sp_Zle = lazy (evaluable_ref_of_constr "Z.le" coq_Zle) let sp_Zgt = lazy (evaluable_ref_of_constr "Z.gt" coq_Zgt) let sp_Zge = lazy (evaluable_ref_of_constr "Z.ge" coq_Zge) let sp_Zlt = lazy (evaluable_ref_of_constr "Z.lt" coq_Zlt) -let sp_not = lazy (evaluable_ref_of_constr "not" (lazy (build_coq_not ()))) +let sp_not = lazy (evaluable_ref_of_constr "not" coq_not) let mk_var v = mkVar (Id.of_string v) let mk_plus t1 t2 = mkApp (Lazy.force coq_Zplus, [| t1; t2 |]) let mk_times t1 t2 = mkApp (Lazy.force coq_Zmult, [| t1; t2 |]) 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 ()), +let mk_eq t1 t2 = mkApp (Lazy.force 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_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 |]) -let mk_not t = mkApp (build_coq_not (), [| t |]) -let mk_eq_rel t1 t2 = mkApp (Universes.constr_of_global (build_coq_eq ()), +let mk_and t1 t2 = mkApp (Lazy.force coq_and, [| t1; t2 |]) +let mk_or t1 t2 = mkApp (Lazy.force coq_or, [| t1; t2 |]) +let mk_not t = mkApp (Lazy.force coq_not, [| t |]) +let mk_eq_rel t1 t2 = mkApp (Lazy.force coq_eq, [| Lazy.force coq_comparison; t1; t2 |]) let mk_inj t = mkApp (Lazy.force coq_Z_of_nat, [| t |]) @@ -420,22 +431,23 @@ type result = the term parts that we manipulate, but rather Var's. Said otherwise: all constr manipulated here are closed *) -let destructurate_prop t = - let c, args = decompose_app t in - match kind_of_term c, args with - | _, [_;_;_] when is_global (build_coq_eq ()) c -> Kapp (Eq,args) +let destructurate_prop sigma t = + let eq_constr c1 c2 = eq_constr sigma c1 c2 in + let c, args = decompose_app sigma t in + match EConstr.kind sigma c, args with + | _, [_;_;_] when eq_constr (Lazy.force coq_eq) c -> Kapp (Eq,args) | _, [_;_] when eq_constr c (Lazy.force coq_neq) -> Kapp (Neq,args) | _, [_;_] when eq_constr c (Lazy.force coq_Zne) -> Kapp (Zne,args) | _, [_;_] when eq_constr c (Lazy.force coq_Zle) -> Kapp (Zle,args) | _, [_;_] when eq_constr c (Lazy.force coq_Zlt) -> Kapp (Zlt,args) | _, [_;_] when eq_constr c (Lazy.force coq_Zge) -> Kapp (Zge,args) | _, [_;_] when eq_constr c (Lazy.force coq_Zgt) -> Kapp (Zgt,args) - | _, [_;_] when eq_constr c (build_coq_and ()) -> Kapp (And,args) - | _, [_;_] when eq_constr c (build_coq_or ()) -> Kapp (Or,args) + | _, [_;_] when eq_constr c (Lazy.force coq_and) -> Kapp (And,args) + | _, [_;_] when eq_constr c (Lazy.force coq_or) -> Kapp (Or,args) | _, [_;_] when eq_constr c (Lazy.force coq_iff) -> Kapp (Iff, args) - | _, [_] when eq_constr c (build_coq_not ()) -> Kapp (Not,args) - | _, [] when eq_constr c (build_coq_False ()) -> Kapp (False,args) - | _, [] when eq_constr c (build_coq_True ()) -> Kapp (True,args) + | _, [_] when eq_constr c (Lazy.force coq_not) -> Kapp (Not,args) + | _, [] when eq_constr c (Lazy.force coq_False) -> Kapp (False,args) + | _, [] when eq_constr c (Lazy.force coq_True) -> Kapp (True,args) | _, [_;_] when eq_constr c (Lazy.force coq_le) -> Kapp (Le,args) | _, [_;_] when eq_constr c (Lazy.force coq_lt) -> Kapp (Lt,args) | _, [_;_] when eq_constr c (Lazy.force coq_ge) -> Kapp (Ge,args) @@ -451,16 +463,18 @@ let destructurate_prop t = | Prod (Name _,_,_),[] -> error "Omega: Not a quantifier-free goal" | _ -> Kufo -let destructurate_type t = - let c, args = decompose_app t in - match kind_of_term c, args with +let destructurate_type sigma t = + let eq_constr c1 c2 = eq_constr sigma c1 c2 in + let c, args = decompose_app sigma t in + match EConstr.kind sigma c, args with | _, [] when eq_constr c (Lazy.force coq_Z) -> Kapp (Z,args) | _, [] when eq_constr c (Lazy.force coq_nat) -> Kapp (Nat,args) | _ -> Kufo -let destructurate_term t = - let c, args = decompose_app t in - match kind_of_term c, args with +let destructurate_term sigma t = + let eq_constr c1 c2 = eq_constr sigma c1 c2 in + let c, args = decompose_app sigma t in + match EConstr.kind sigma c, args with | _, [_;_] when eq_constr c (Lazy.force coq_Zplus) -> Kapp (Zplus,args) | _, [_;_] when eq_constr c (Lazy.force coq_Zmult) -> Kapp (Zmult,args) | _, [_;_] when eq_constr c (Lazy.force coq_Zminus) -> Kapp (Zminus,args) @@ -480,15 +494,16 @@ let destructurate_term t = | Var id,[] -> Kvar id | _ -> Kufo -let recognize_number t = +let recognize_number sigma t = + let eq_constr c1 c2 = eq_constr sigma c1 c2 in let rec loop t = - match decompose_app t with + match decompose_app sigma t with | f, [t] when eq_constr f (Lazy.force coq_xI) -> one + two * loop t | f, [t] when eq_constr f (Lazy.force coq_xO) -> two * loop t | f, [] when eq_constr f (Lazy.force coq_xH) -> one | _ -> failwith "not a number" in - match decompose_app t with + match decompose_app sigma t with | f, [t] when eq_constr f (Lazy.force coq_Zpos) -> loop t | f, [t] when eq_constr f (Lazy.force coq_Zneg) -> neg (loop t) | f, [] when eq_constr f (Lazy.force coq_Z0) -> zero @@ -504,9 +519,9 @@ type constr_path = | P_ARITY | P_ARG -let context operation path (t : constr) = +let context sigma operation path (t : constr) = let rec loop i p0 t = - match (p0,kind_of_term t) with + match (p0,EConstr.kind sigma t) with | (p, Cast (c,k,t)) -> mkCast (loop i p c,k,t) | ([], _) -> operation i t | ((P_APP n :: p), App (f,v)) -> @@ -517,7 +532,7 @@ let context operation path (t : constr) = let v' = Array.copy v in v'.(n) <- loop i p v'.(n); (mkCase (ci,q,c,v')) | ((P_ARITY :: p), App (f,l)) -> - appvect (loop i p f,l) + mkApp (loop i p f,l) | ((P_ARG :: p), App (f,v)) -> let v' = Array.copy v in v'.(0) <- loop i p v'.(0); mkApp (f,v') @@ -542,8 +557,8 @@ let context operation path (t : constr) = in loop 1 path t -let occurrence path (t : constr) = - let rec loop p0 t = match (p0,kind_of_term t) with +let occurrence sigma path (t : constr) = + let rec loop p0 t = match (p0,EConstr.kind sigma t) with | (p, Cast (c,_,_)) -> loop p c | ([], _) -> t | ((P_APP n :: p), App (f,v)) -> loop p v.(pred n) @@ -562,14 +577,17 @@ let occurrence path (t : constr) = in loop path t -let abstract_path typ path t = +let abstract_path sigma typ path t = let term_occur = ref (mkRel 0) in - let abstract = context (fun i t -> term_occur:= t; mkRel i) path t in + let abstract = context sigma (fun i t -> term_occur:= t; mkRel i) path t in mkLambda (Name (Id.of_string "x"), typ, abstract), !term_occur -let focused_simpl path gl = - let newc = context (fun i t -> pf_nf gl t) (List.rev path) (pf_concl gl) in - Proofview.V82.of_tactic (convert_concl_no_check newc DEFAULTcast) gl +let focused_simpl path = + let open Tacmach.New in + Proofview.Goal.nf_enter { enter = begin fun gl -> + let newc = context (project gl) (fun i t -> pf_nf gl t) (List.rev path) (pf_concl gl) in + convert_concl_no_check newc DEFAULTcast + end } let focused_simpl path = focused_simpl path @@ -627,11 +645,19 @@ let decompile af = in loop af.body -let mkNewMeta () = mkMeta (Evarutil.new_meta()) +(** Backward compat to emulate the old Refine: normalize the goal conclusion *) +let new_hole env sigma c = + let c = Reductionops.nf_betaiota (Sigma.to_evar_map sigma) c in + Evarutil.new_evar env sigma c -let clever_rewrite_base_poly typ p result theorem gl = +let clever_rewrite_base_poly typ p result theorem = + let open Tacmach.New in + let open Sigma in + Proofview.Goal.nf_enter { enter = begin fun gl -> let full = pf_concl gl in - let (abstracted,occ) = abstract_path typ (List.rev p) full in + let env = pf_env gl in + let (abstracted,occ) = abstract_path (project gl) typ (List.rev p) full in + Refine.refine { run = begin fun sigma -> let t = applist (mkLambda @@ -644,13 +670,17 @@ let clever_rewrite_base_poly typ p result theorem gl = [| typ; result; mkRel 2; mkRel 1; occ; theorem |]))), [abstracted]) in - exact (applist(t,[mkNewMeta()])) gl + let argt = mkApp (abstracted, [|result|]) in + let Sigma (hole, sigma, p) = new_hole env sigma argt in + Sigma (applist (t, [hole]), sigma, p) + end } + end } -let clever_rewrite_base p result theorem gl = - clever_rewrite_base_poly (Lazy.force coq_Z) p result theorem gl +let clever_rewrite_base p result theorem = + clever_rewrite_base_poly (Lazy.force coq_Z) p result theorem -let clever_rewrite_base_nat p result theorem gl = - clever_rewrite_base_poly (Lazy.force coq_nat) p result theorem gl +let clever_rewrite_base_nat p result theorem = + clever_rewrite_base_poly (Lazy.force coq_nat) p result theorem let clever_rewrite_gen p result (t,args) = let theorem = applist(t, args) in @@ -660,12 +690,29 @@ let clever_rewrite_gen_nat p result (t,args) = let theorem = applist(t, args) in clever_rewrite_base_nat p result theorem -let clever_rewrite p vpath t gl = +(** Solve using the term the term [t _] *) +let refine_app gl t = + let open Tacmach.New in + let open Sigma in + Refine.refine { run = begin fun sigma -> + let env = pf_env gl in + let ht = match EConstr.kind (Sigma.to_evar_map sigma) (pf_get_type_of gl t) with + | Prod (_, t, _) -> t + | _ -> assert false + in + let Sigma (hole, sigma, p) = new_hole env sigma ht in + Sigma (applist (t, [hole]), sigma, p) + end } + +let clever_rewrite p vpath t = + let open Tacmach.New in + Proofview.Goal.nf_enter { enter = begin fun gl -> let full = pf_concl gl in - let (abstracted,occ) = abstract_path (Lazy.force coq_Z) (List.rev p) full in - let vargs = List.map (fun p -> occurrence p occ) vpath in + let (abstracted,occ) = abstract_path (project gl) (Lazy.force coq_Z) (List.rev p) full in + let vargs = List.map (fun p -> occurrence (project gl) p occ) vpath in let t' = applist(t, (vargs @ [abstracted])) in - exact (applist(t',[mkNewMeta()])) gl + refine_app gl t' + end } let rec shuffle p (t1,t2) = match t1,t2 with @@ -907,10 +954,10 @@ let rec negate p = function | Oz i -> [focused_simpl p],Oz(neg i) | Oufo c -> [], Oufo (mkApp (Lazy.force coq_Zopp, [| c |])) -let rec transform p t = +let rec transform sigma p t = let default isnat t' = try - let v,th,_ = find_constr t' in + let v,th,_ = find_constr sigma t' in [clever_rewrite_base p (mkVar v) (mkVar th)], Oatom v with e when CErrors.noncritical e -> let v = new_identifier_var () @@ -918,29 +965,29 @@ let rec transform p t = hide_constr t' v th isnat; [clever_rewrite_base p (mkVar v) (mkVar th)], Oatom v in - try match destructurate_term t with + try match destructurate_term sigma t with | Kapp(Zplus,[t1;t2]) -> - let tac1,t1' = transform (P_APP 1 :: p) t1 - and tac2,t2' = transform (P_APP 2 :: p) t2 in + let tac1,t1' = transform sigma (P_APP 1 :: p) t1 + and tac2,t2' = transform sigma (P_APP 2 :: p) t2 in let tac,t' = shuffle p (t1',t2') in tac1 @ tac2 @ tac, t' | Kapp(Zminus,[t1;t2]) -> let tac,t = - transform p + transform sigma p (mkApp (Lazy.force coq_Zplus, [| t1; (mkApp (Lazy.force coq_Zopp, [| t2 |])) |])) in - Proofview.V82.of_tactic (unfold sp_Zminus) :: tac,t + unfold sp_Zminus :: tac,t | Kapp(Zsucc,[t1]) -> - let tac,t = transform p (mkApp (Lazy.force coq_Zplus, + let tac,t = transform sigma p (mkApp (Lazy.force coq_Zplus, [| t1; mk_integer one |])) in - Proofview.V82.of_tactic (unfold sp_Zsucc) :: tac,t + unfold sp_Zsucc :: tac,t | Kapp(Zpred,[t1]) -> - let tac,t = transform p (mkApp (Lazy.force coq_Zplus, + let tac,t = transform sigma p (mkApp (Lazy.force coq_Zplus, [| t1; mk_integer negone |])) in - Proofview.V82.of_tactic (unfold sp_Zpred) :: tac,t + unfold sp_Zpred :: tac,t | Kapp(Zmult,[t1;t2]) -> - let tac1,t1' = transform (P_APP 1 :: p) t1 - and tac2,t2' = transform (P_APP 2 :: p) t2 in + let tac1,t1' = transform sigma (P_APP 1 :: p) t1 + and tac2,t2' = transform sigma (P_APP 2 :: p) t2 in begin match t1',t2' with | (_,Oz n) -> let tac,t' = scalar p n t1' in tac1 @ tac2 @ tac,t' | (Oz n,_) -> @@ -951,11 +998,11 @@ let rec transform p t = | _ -> default false t end | Kapp((Zpos|Zneg|Z0),_) -> - (try ([],Oz(recognize_number t)) + (try ([],Oz(recognize_number sigma t)) with e when CErrors.noncritical e -> default false t) | Kvar s -> [],Oatom s | Kapp(Zopp,[t]) -> - let tac,t' = transform (P_APP 1 :: p) t in + let tac,t' = transform sigma (P_APP 1 :: p) t in let tac',t'' = negate p t' in tac @ tac', t'' | Kapp(Z_of_nat,[t']) -> default true t' @@ -1055,7 +1102,7 @@ let replay_history tactic_normalisation = | HYP e :: l -> begin try - Tacticals.New.tclTHEN + tclTHEN (Id.List.assoc (hyp_of_tag e.id) tactic_normalisation) (loop l) with Not_found -> loop l end @@ -1067,16 +1114,16 @@ let replay_history tactic_normalisation = let k = if b then negone else one in let p_initial = [P_APP 1;P_TYPE] in let tac= shuffle_mult_right p_initial e1.body k e2.body in - Tacticals.New.tclTHENLIST [ + tclTHENLIST [ generalize_tac [mkApp (Lazy.force coq_OMEGA17, [| val_of eq1; val_of eq2; mk_integer k; mkVar id1; mkVar id2 |])]; - Proofview.V82.tactic (mk_then tac); + mk_then tac; (intros_using [aux]); - Proofview.V82.tactic (resolve_id aux); + resolve_id aux; reflexivity ] | CONTRADICTION (e1,e2) :: l -> @@ -1085,14 +1132,14 @@ let replay_history tactic_normalisation = let p_initial = [P_APP 2;P_TYPE] in let tac = shuffle_cancel p_initial e1.body in let solve_le = - let not_sup_sup = mkApp (Universes.constr_of_global (build_coq_eq ()), + let not_sup_sup = mkApp (Lazy.force coq_eq, [| Lazy.force coq_comparison; Lazy.force coq_Gt; Lazy.force coq_Gt |]) in - Tacticals.New.tclTHENS - (Tacticals.New.tclTHENLIST [ + tclTHENS + (tclTHENLIST [ unfold sp_Zle; simpl_in_concl; intro; @@ -1105,7 +1152,7 @@ let replay_history tactic_normalisation = mkVar (hyp_of_tag e1.id); mkVar (hyp_of_tag e2.id) |]) in - Proofview.tclTHEN (Proofview.V82.tactic (tclTHEN (Proofview.V82.of_tactic (generalize_tac [theorem])) (mk_then tac))) (solve_le) + Proofview.tclTHEN (tclTHEN (generalize_tac [theorem]) (mk_then tac)) solve_le | DIVIDE_AND_APPROX (e1,e2,k,d) :: l -> let id = hyp_of_tag e1.id in let eq1 = val_of(decompile e1) @@ -1115,10 +1162,10 @@ let replay_history tactic_normalisation = let rhs = mk_plus (mk_times eq2 kk) dd in let state_eg = mk_eq eq1 rhs in let tac = scalar_norm_add [P_APP 3] e2.body in - Tacticals.New.tclTHENS + tclTHENS (cut state_eg) - [ Tacticals.New.tclTHENS - (Tacticals.New.tclTHENLIST [ + [ tclTHENS + (tclTHENLIST [ (intros_using [aux]); (generalize_tac [mkApp (Lazy.force coq_OMEGA1, @@ -1126,9 +1173,9 @@ let replay_history tactic_normalisation = (clear [aux;id]); (intros_using [id]); (cut (mk_gt kk dd)) ]) - [ Tacticals.New.tclTHENS + [ tclTHENS (cut (mk_gt kk izero)) - [ Tacticals.New.tclTHENLIST [ + [ tclTHENLIST [ (intros_using [aux1; aux2]); (generalize_tac [mkApp (Lazy.force coq_Zmult_le_approx, @@ -1136,13 +1183,13 @@ let replay_history tactic_normalisation = (clear [aux1;aux2;id]); (intros_using [id]); (loop l) ]; - Tacticals.New.tclTHENLIST [ + tclTHENLIST [ (unfold sp_Zgt); simpl_in_concl; reflexivity ] ]; - Tacticals.New.tclTHENLIST [ unfold sp_Zgt; simpl_in_concl; reflexivity ] + tclTHENLIST [ unfold sp_Zgt; simpl_in_concl; reflexivity ] ]; - Tacticals.New.tclTHEN (Proofview.V82.tactic (mk_then tac)) reflexivity ] + tclTHEN (mk_then tac) reflexivity ] | NOT_EXACT_DIVIDE (e1,k) :: l -> let c = floor_div e1.constant k in @@ -1153,10 +1200,10 @@ let replay_history tactic_normalisation = let kk = mk_integer k and dd = mk_integer d in let tac = scalar_norm_add [P_APP 2] e2.body in - Tacticals.New.tclTHENS + tclTHENS (cut (mk_gt dd izero)) - [ Tacticals.New.tclTHENS (cut (mk_gt kk dd)) - [Tacticals.New.tclTHENLIST [ + [ tclTHENS (cut (mk_gt kk dd)) + [tclTHENLIST [ (intros_using [aux2;aux1]); (generalize_tac [mkApp (Lazy.force coq_OMEGA4, @@ -1164,14 +1211,14 @@ let replay_history tactic_normalisation = (clear [aux1;aux2]); unfold sp_not; (intros_using [aux]); - Proofview.V82.tactic (resolve_id aux); - Proofview.V82.tactic (mk_then tac); + resolve_id aux; + mk_then tac; assumption ] ; - Tacticals.New.tclTHENLIST [ + tclTHENLIST [ unfold sp_Zgt; simpl_in_concl; reflexivity ] ]; - Tacticals.New.tclTHENLIST [ + tclTHENLIST [ unfold sp_Zgt; simpl_in_concl; reflexivity ] ] @@ -1184,9 +1231,9 @@ let replay_history tactic_normalisation = let state_eq = mk_eq eq1 (mk_times eq2 kk) in if e1.kind == DISE then let tac = scalar_norm [P_APP 3] e2.body in - Tacticals.New.tclTHENS + tclTHENS (cut state_eq) - [Tacticals.New.tclTHENLIST [ + [tclTHENLIST [ (intros_using [aux1]); (generalize_tac [mkApp (Lazy.force coq_OMEGA18, @@ -1194,14 +1241,14 @@ let replay_history tactic_normalisation = (clear [aux1;id]); (intros_using [id]); (loop l) ]; - Tacticals.New.tclTHEN (Proofview.V82.tactic (mk_then tac)) reflexivity ] + tclTHEN (mk_then tac) reflexivity ] else let tac = scalar_norm [P_APP 3] e2.body in - Tacticals.New.tclTHENS (cut state_eq) + tclTHENS (cut state_eq) [ - Tacticals.New.tclTHENS + tclTHENS (cut (mk_gt kk izero)) - [Tacticals.New.tclTHENLIST [ + [tclTHENLIST [ (intros_using [aux2;aux1]); (generalize_tac [mkApp (Lazy.force coq_OMEGA3, @@ -1209,11 +1256,11 @@ let replay_history tactic_normalisation = (clear [aux1;aux2;id]); (intros_using [id]); (loop l) ]; - Tacticals.New.tclTHENLIST [ + tclTHENLIST [ unfold sp_Zgt; simpl_in_concl; reflexivity ] ]; - Tacticals.New.tclTHEN (Proofview.V82.tactic (mk_then tac)) reflexivity ] + tclTHEN (mk_then tac) reflexivity ] | (MERGE_EQ(e3,e1,e2)) :: l -> let id = new_identifier () in tag_hypothesis id e3; @@ -1226,16 +1273,16 @@ let replay_history tactic_normalisation = (Lazy.force coq_fast_Zopp_eq_mult_neg_1) :: scalar_norm [P_APP 3] e1.body in - Tacticals.New.tclTHENS + tclTHENS (cut (mk_eq eq1 (mk_inv eq2))) - [Tacticals.New.tclTHENLIST [ + [tclTHENLIST [ (intros_using [aux]); (generalize_tac [mkApp (Lazy.force coq_OMEGA8, [| eq1;eq2;mkVar id1;mkVar id2; mkVar aux|])]); (clear [id1;id2;aux]); (intros_using [id]); (loop l) ]; - Tacticals.New.tclTHEN (Proofview.V82.tactic (mk_then tac)) reflexivity] + tclTHEN (mk_then tac) reflexivity] | STATE {st_new_eq=e;st_def=def;st_orig=orig;st_coef=m;st_var=v} :: l -> let id = new_identifier () @@ -1245,7 +1292,7 @@ let replay_history tactic_normalisation = and eq2 = val_of(decompile orig) in let vid = unintern_id v in let theorem = - mkApp (build_coq_ex (), [| + mkApp (Lazy.force coq_ex, [| Lazy.force coq_Z; mkLambda (Name vid, @@ -1259,9 +1306,9 @@ let replay_history tactic_normalisation = [[P_APP 1]] (Lazy.force coq_fast_Zopp_eq_mult_neg_1) :: shuffle_mult_right p_initial orig.body m ({c= negone;v= v}::def.body) in - Tacticals.New.tclTHENS + tclTHENS (cut theorem) - [Tacticals.New.tclTHENLIST [ + [tclTHENLIST [ (intros_using [aux]); (elim_id aux); (clear [aux]); @@ -1269,11 +1316,11 @@ let replay_history tactic_normalisation = (generalize_tac [mkApp (Lazy.force coq_OMEGA9, [| mkVar vid;eq2;eq1;mm; mkVar id2;mkVar aux |])]); - Proofview.V82.tactic (mk_then tac); + mk_then tac; (clear [aux]); (intros_using [id]); (loop l) ]; - Tacticals.New.tclTHEN (exists_tac eq1) reflexivity ] + tclTHEN (exists_tac eq1) reflexivity ] | SPLIT_INEQ(e,(e1,act1),(e2,act2)) :: l -> let id1 = new_identifier () and id2 = new_identifier () in @@ -1282,10 +1329,10 @@ let replay_history tactic_normalisation = let tac1 = norm_add [P_APP 2;P_TYPE] e.body in let tac2 = scalar_norm_add [P_APP 2;P_TYPE] e.body in let eq = val_of(decompile e) in - Tacticals.New.tclTHENS + tclTHENS (simplest_elim (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) ]] + [tclTHENLIST [ mk_then tac1; (intros_using [id1]); (loop act1) ]; + tclTHENLIST [ mk_then tac2; (intros_using [id2]); (loop act2) ]] | SUM(e3,(k1,e1),(k2,e2)) :: l -> let id = new_identifier () in tag_hypothesis id e3; @@ -1304,10 +1351,10 @@ let replay_history tactic_normalisation = let p_initial = if e1.kind == DISE then [P_APP 1; P_TYPE] else [P_APP 2; P_TYPE] in let tac = shuffle_mult_right p_initial e1.body k2 e2.body in - Tacticals.New.tclTHENLIST [ + tclTHENLIST [ (generalize_tac [mkApp (tac_thm, [| eq1; eq2; kk; mkVar id1; mkVar id2 |])]); - Proofview.V82.tactic (mk_then tac); + mk_then tac; (intros_using [id]); (loop l) ] @@ -1316,10 +1363,10 @@ let replay_history tactic_normalisation = and kk2 = mk_integer k2 in let p_initial = [P_APP 2;P_TYPE] in let tac= shuffle_mult p_initial k1 e1.body k2 e2.body in - Tacticals.New.tclTHENS (cut (mk_gt kk1 izero)) - [Tacticals.New.tclTHENS + tclTHENS (cut (mk_gt kk1 izero)) + [tclTHENS (cut (mk_gt kk2 izero)) - [Tacticals.New.tclTHENLIST [ + [tclTHENLIST [ (intros_using [aux2;aux1]); (generalize_tac [mkApp (Lazy.force coq_OMEGA7, [| @@ -1327,102 +1374,106 @@ let replay_history tactic_normalisation = mkVar aux1;mkVar aux2; mkVar id1;mkVar id2 |])]); (clear [aux1;aux2]); - Proofview.V82.tactic (mk_then tac); + mk_then tac; (intros_using [id]); (loop l) ]; - Tacticals.New.tclTHENLIST [ + tclTHENLIST [ unfold sp_Zgt; simpl_in_concl; reflexivity ] ]; - Tacticals.New.tclTHENLIST [ + tclTHENLIST [ unfold sp_Zgt; simpl_in_concl; reflexivity ] ] | CONSTANT_NOT_NUL(e,k) :: l -> - Tacticals.New.tclTHEN ((generalize_tac [mkVar (hyp_of_tag e)])) Equality.discrConcl + tclTHEN ((generalize_tac [mkVar (hyp_of_tag e)])) Equality.discrConcl | CONSTANT_NUL(e) :: l -> - Tacticals.New.tclTHEN (Proofview.V82.tactic (resolve_id (hyp_of_tag e))) reflexivity + tclTHEN (resolve_id (hyp_of_tag e)) reflexivity | CONSTANT_NEG(e,k) :: l -> - Tacticals.New.tclTHENLIST [ + tclTHENLIST [ (generalize_tac [mkVar (hyp_of_tag e)]); unfold sp_Zle; simpl_in_concl; unfold sp_not; (intros_using [aux]); - Proofview.V82.tactic (resolve_id aux); + resolve_id aux; reflexivity ] | _ -> Proofview.tclUNIT () in loop -let normalize p_initial t = - let (tac,t') = transform p_initial t in +let normalize sigma p_initial t = + let (tac,t') = transform sigma p_initial t in let (tac',t'') = condense p_initial t' in let (tac'',t''') = clear_zero p_initial t'' in tac @ tac' @ tac'' , t''' -let normalize_equation id flag theorem pos t t1 t2 (tactic,defs) = +let normalize_equation sigma id flag theorem pos t t1 t2 (tactic,defs) = let p_initial = [P_APP pos ;P_TYPE] in - let (tac,t') = normalize p_initial t in + let (tac,t') = normalize sigma p_initial t in let shift_left = tclTHEN - (Proofview.V82.of_tactic (generalize_tac [mkApp (theorem, [| t1; t2; mkVar id |]) ])) - (tclTRY (Proofview.V82.of_tactic (clear [id]))) + (generalize_tac [mkApp (theorem, [| t1; t2; mkVar id |]) ]) + (tclTRY (clear [id])) in if not (List.is_empty tac) then let id' = new_identifier () in - ((id',(Tacticals.New.tclTHENLIST [ Proofview.V82.tactic (shift_left); Proofview.V82.tactic (mk_then tac); (intros_using [id']) ])) + ((id',(tclTHENLIST [ shift_left; mk_then tac; (intros_using [id']) ])) :: tactic, compile id' flag t' :: defs) else (tactic,defs) +let pf_nf gl c = Tacmach.New.pf_apply Tacred.simpl gl c + let destructure_omega gl tac_def (id,c) = + let open Tacmach.New in + let sigma = project gl in if String.equal (atompart_of_id id) "State" then tac_def else - try match destructurate_prop c with + try match destructurate_prop sigma c with | Kapp(Eq,[typ;t1;t2]) - when begin match destructurate_type (pf_nf gl typ) with Kapp(Z,[]) -> true | _ -> false end -> + when begin match destructurate_type sigma (pf_nf gl typ) with Kapp(Z,[]) -> true | _ -> false end -> let t = mk_plus t1 (mk_inv t2) in - normalize_equation + normalize_equation sigma id EQUA (Lazy.force coq_Zegal_left) 2 t t1 t2 tac_def | Kapp(Zne,[t1;t2]) -> let t = mk_plus t1 (mk_inv t2) in - normalize_equation + normalize_equation sigma id DISE (Lazy.force coq_Zne_left) 1 t t1 t2 tac_def | Kapp(Zle,[t1;t2]) -> let t = mk_plus t2 (mk_inv t1) in - normalize_equation + normalize_equation sigma id INEQ (Lazy.force coq_Zle_left) 2 t t1 t2 tac_def | Kapp(Zlt,[t1;t2]) -> let t = mk_plus (mk_plus t2 (mk_integer negone)) (mk_inv t1) in - normalize_equation + normalize_equation sigma id INEQ (Lazy.force coq_Zlt_left) 2 t t1 t2 tac_def | Kapp(Zge,[t1;t2]) -> let t = mk_plus t1 (mk_inv t2) in - normalize_equation + normalize_equation sigma id INEQ (Lazy.force coq_Zge_left) 2 t t1 t2 tac_def | Kapp(Zgt,[t1;t2]) -> let t = mk_plus (mk_plus t1 (mk_integer negone)) (mk_inv t2) in - normalize_equation + normalize_equation sigma id INEQ (Lazy.force coq_Zgt_left) 2 t t1 t2 tac_def | _ -> tac_def with e when catchable_exception e -> tac_def let reintroduce id = (* [id] cannot be cleared if dependent: protect it by a try *) - Tacticals.New.tclTHEN (Tacticals.New.tclTRY (clear [id])) (intro_using id) + tclTHEN (tclTRY (clear [id])) (intro_using id) open Proofview.Notations let coq_omega = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> clear_constr_tables (); let hyps_types = Tacmach.New.pf_hyps_types gl in - let destructure_omega = Tacmach.New.of_old destructure_omega gl in + let destructure_omega = destructure_omega gl in let tactic_normalisation, system = List.fold_left destructure_omega ([],[]) hyps_types in let prelude,sys = @@ -1432,7 +1483,7 @@ let coq_omega = let id = new_identifier () in let i = new_id () in tag_hypothesis id i; - (Tacticals.New.tclTHENLIST [ + (tclTHENLIST [ (simplest_elim (applist (Lazy.force coq_intro_Z, [t]))); (intros_using [v; id]); (elim_id id); @@ -1443,7 +1494,7 @@ let coq_omega = body = [{v=intern_id v; c=one}]; constant = zero; id = i} :: sys else - (Tacticals.New.tclTHENLIST [ + (tclTHENLIST [ (simplest_elim (applist (Lazy.force coq_new_var, [t]))); (intros_using [v;th]); tac ]), @@ -1459,94 +1510,96 @@ let coq_omega = with UNSOLVABLE -> let _,path = depend [] [] (history ()) in if !display_action_flag then display_action display_var path; - (Tacticals.New.tclTHEN prelude (replay_history tactic_normalisation path)) + (tclTHEN prelude (replay_history tactic_normalisation path)) end else begin try let path = simplify_strong (new_id,new_var_num,display_var) system in if !display_action_flag then display_action display_var path; - Tacticals.New.tclTHEN prelude (replay_history tactic_normalisation path) - with NO_CONTRADICTION -> Tacticals.New.tclZEROMSG (Pp.str"Omega can't solve this system") + tclTHEN prelude (replay_history tactic_normalisation path) + with NO_CONTRADICTION -> tclZEROMSG (Pp.str"Omega can't solve this system") end end } let coq_omega = coq_omega let nat_inject = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let is_conv = Tacmach.New.pf_apply Reductionops.is_conv gl in let rec explore p t : unit Proofview.tactic = - try match destructurate_term t with + Proofview.tclEVARMAP >>= fun sigma -> + try match destructurate_term sigma t with | Kapp(Plus,[t1;t2]) -> - Tacticals.New.tclTHENLIST [ - Proofview.V82.tactic (clever_rewrite_gen p (mk_plus (mk_inj t1) (mk_inj t2)) + tclTHENLIST [ + (clever_rewrite_gen p (mk_plus (mk_inj t1) (mk_inj t2)) ((Lazy.force coq_inj_plus),[t1;t2])); (explore (P_APP 1 :: p) t1); (explore (P_APP 2 :: p) t2) ] | Kapp(Mult,[t1;t2]) -> - Tacticals.New.tclTHENLIST [ - Proofview.V82.tactic (clever_rewrite_gen p (mk_times (mk_inj t1) (mk_inj t2)) + tclTHENLIST [ + (clever_rewrite_gen p (mk_times (mk_inj t1) (mk_inj t2)) ((Lazy.force coq_inj_mult),[t1;t2])); (explore (P_APP 1 :: p) t1); (explore (P_APP 2 :: p) t2) ] | Kapp(Minus,[t1;t2]) -> let id = new_identifier () in - Tacticals.New.tclTHENS - (Tacticals.New.tclTHEN + tclTHENS + (tclTHEN (simplest_elim (applist (Lazy.force coq_le_gt_dec, [t2;t1]))) (intros_using [id])) [ - Tacticals.New.tclTHENLIST [ - Proofview.V82.tactic (clever_rewrite_gen p + tclTHENLIST [ + (clever_rewrite_gen p (mk_minus (mk_inj t1) (mk_inj t2)) ((Lazy.force coq_inj_minus1),[t1;t2;mkVar id])); (loop [id,mkApp (Lazy.force coq_le, [| t2;t1 |])]); (explore (P_APP 1 :: p) t1); (explore (P_APP 2 :: p) t2) ]; - (Tacticals.New.tclTHEN - (Proofview.V82.tactic (clever_rewrite_gen p (mk_integer zero) - ((Lazy.force coq_inj_minus2),[t1;t2;mkVar id]))) + (tclTHEN + (clever_rewrite_gen p (mk_integer zero) + ((Lazy.force coq_inj_minus2),[t1;t2;mkVar id])) (loop [id,mkApp (Lazy.force coq_gt, [| t2;t1 |])])) ] | Kapp(S,[t']) -> let rec is_number t = - try match destructurate_term t with + try match destructurate_term sigma t with Kapp(S,[t]) -> is_number t | Kapp(O,[]) -> true | _ -> false with e when catchable_exception e -> false in let rec loop p t : unit Proofview.tactic = - try match destructurate_term t with + try match destructurate_term sigma t with Kapp(S,[t]) -> - (Tacticals.New.tclTHEN - (Proofview.V82.tactic (clever_rewrite_gen p + (tclTHEN + (clever_rewrite_gen p (mkApp (Lazy.force coq_Zsucc, [| mk_inj t |])) - ((Lazy.force coq_inj_S),[t]))) + ((Lazy.force coq_inj_S),[t])) (loop (P_APP 1 :: p) t)) | _ -> explore p t with e when catchable_exception e -> explore p t in - if is_number t' then Proofview.V82.tactic (focused_simpl p) else loop p t + if is_number t' then focused_simpl p else loop p t | Kapp(Pred,[t]) -> let t_minus_one = mkApp (Lazy.force coq_minus, [| t; mkApp (Lazy.force coq_S, [| Lazy.force coq_O |]) |]) in - Tacticals.New.tclTHEN - (Proofview.V82.tactic (clever_rewrite_gen_nat (P_APP 1 :: p) t_minus_one - ((Lazy.force coq_pred_of_minus),[t]))) + tclTHEN + (clever_rewrite_gen_nat (P_APP 1 :: p) t_minus_one + ((Lazy.force coq_pred_of_minus),[t])) (explore p t_minus_one) - | Kapp(O,[]) -> Proofview.V82.tactic (focused_simpl p) + | Kapp(O,[]) -> focused_simpl p | _ -> Proofview.tclUNIT () with e when catchable_exception e -> Proofview.tclUNIT () and loop = function | [] -> Proofview.tclUNIT () | (i,t)::lit -> - begin try match destructurate_prop t with + Proofview.tclEVARMAP >>= fun sigma -> + begin try match destructurate_prop sigma t with Kapp(Le,[t1;t2]) -> - Tacticals.New.tclTHENLIST [ + tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_inj_le, [| t1;t2;mkVar i |]) ]); (explore [P_APP 1; P_TYPE] t1); @@ -1555,7 +1608,7 @@ let nat_inject = (loop lit) ] | Kapp(Lt,[t1;t2]) -> - Tacticals.New.tclTHENLIST [ + tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_inj_lt, [| t1;t2;mkVar i |]) ]); (explore [P_APP 1; P_TYPE] t1); @@ -1564,7 +1617,7 @@ let nat_inject = (loop lit) ] | Kapp(Ge,[t1;t2]) -> - Tacticals.New.tclTHENLIST [ + tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_inj_ge, [| t1;t2;mkVar i |]) ]); (explore [P_APP 1; P_TYPE] t1); @@ -1573,7 +1626,7 @@ let nat_inject = (loop lit) ] | Kapp(Gt,[t1;t2]) -> - Tacticals.New.tclTHENLIST [ + tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_inj_gt, [| t1;t2;mkVar i |]) ]); (explore [P_APP 1; P_TYPE] t1); @@ -1582,7 +1635,7 @@ let nat_inject = (loop lit) ] | Kapp(Neq,[t1;t2]) -> - Tacticals.New.tclTHENLIST [ + tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_inj_neq, [| t1;t2;mkVar i |]) ]); (explore [P_APP 1; P_TYPE] t1); @@ -1592,7 +1645,7 @@ let nat_inject = ] | Kapp(Eq,[typ;t1;t2]) -> if is_conv typ (Lazy.force coq_nat) then - Tacticals.New.tclTHENLIST [ + tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_inj_eq, [| t1;t2;mkVar i |]) ]); (explore [P_APP 2; P_TYPE] t1); @@ -1641,7 +1694,8 @@ let not_binop = function exception Undecidable let rec decidability gl t = - match destructurate_prop t with + let open Tacmach.New in + match destructurate_prop (project gl) t with | Kapp(Or,[t1;t2]) -> mkApp (Lazy.force coq_dec_or, [| t1; t2; decidability gl t1; decidability gl t2 |]) @@ -1659,7 +1713,7 @@ let rec decidability gl t = | Kapp(Not,[t1]) -> mkApp (Lazy.force coq_dec_not, [| t1; decidability gl t1 |]) | Kapp(Eq,[typ;t1;t2]) -> - begin match destructurate_type (pf_nf gl typ) with + begin match destructurate_type (project gl) (pf_nf gl typ) with | Kapp(Z,[]) -> mkApp (Lazy.force coq_dec_eq, [| t1;t2 |]) | Kapp(Nat,[]) -> mkApp (Lazy.force coq_dec_eq_nat, [| t1;t2 |]) | _ -> raise Undecidable @@ -1671,59 +1725,68 @@ let rec decidability gl t = | Kapp(True,[]) -> Lazy.force coq_dec_True | _ -> raise Undecidable +let fresh_id avoid id gl = + fresh_id_in_env avoid id (Proofview.Goal.env gl) + let onClearedName id tac = (* We cannot ensure that hyps can be cleared (because of dependencies), *) (* so renaming may be necessary *) - Tacticals.New.tclTHEN - (Tacticals.New.tclTRY (clear [id])) + tclTHEN + (tclTRY (clear [id])) (Proofview.Goal.nf_enter { enter = begin fun gl -> - let id = Tacmach.New.of_old (fresh_id [] id) gl in - Tacticals.New.tclTHEN (introduction id) (tac id) + let id = fresh_id [] id gl in + tclTHEN (introduction id) (tac id) end }) let onClearedName2 id tac = - Tacticals.New.tclTHEN - (Tacticals.New.tclTRY (clear [id])) + tclTHEN + (tclTRY (clear [id])) (Proofview.Goal.nf_enter { enter = begin fun gl -> - let id1 = Tacmach.New.of_old (fresh_id [] (add_suffix id "_left")) gl in - let id2 = Tacmach.New.of_old (fresh_id [] (add_suffix id "_right")) gl in - Tacticals.New.tclTHENLIST [ introduction id1; introduction id2; tac id1 id2 ] + let id1 = fresh_id [] (add_suffix id "_left") gl in + let id2 = fresh_id [] (add_suffix id "_right") gl in + tclTHENLIST [ introduction id1; introduction id2; tac id1 id2 ] end }) +let rec is_Prop sigma c = match EConstr.kind sigma c with + | Sort s -> Sorts.is_prop (ESorts.kind sigma s) + | Cast (c,_,_) -> is_Prop sigma c + | _ -> false + let destructure_hyps = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let type_of = Tacmach.New.pf_unsafe_type_of gl in - let decidability = Tacmach.New.of_old decidability gl in - let pf_nf = Tacmach.New.of_old pf_nf gl in + let decidability = decidability gl in + let pf_nf = pf_nf gl in let rec loop = function - | [] -> (Tacticals.New.tclTHEN nat_inject coq_omega) + | [] -> (tclTHEN nat_inject coq_omega) | decl::lit -> let i = NamedDecl.get_id decl in - begin try match destructurate_prop (NamedDecl.get_type decl) with + Proofview.tclEVARMAP >>= fun sigma -> + begin try match destructurate_prop sigma (NamedDecl.get_type decl) with | Kapp(False,[]) -> elim_id i | Kapp((Zle|Zge|Zgt|Zlt|Zne),[t1;t2]) -> loop lit | Kapp(Or,[t1;t2]) -> - (Tacticals.New.tclTHENS + (tclTHENS (elim_id i) [ onClearedName i (fun i -> (loop (LocalAssum (i,t1)::lit))); onClearedName i (fun i -> (loop (LocalAssum (i,t2)::lit))) ]) | Kapp(And,[t1;t2]) -> - Tacticals.New.tclTHEN + tclTHEN (elim_id i) (onClearedName2 i (fun i1 i2 -> loop (LocalAssum (i1,t1) :: LocalAssum (i2,t2) :: lit))) | Kapp(Iff,[t1;t2]) -> - Tacticals.New.tclTHEN + tclTHEN (elim_id i) (onClearedName2 i (fun i1 i2 -> loop (LocalAssum (i1,mkArrow t1 t2) :: LocalAssum (i2,mkArrow t2 t1) :: lit))) | Kimp(t1,t2) -> (* t1 and t2 might be in Type rather than Prop. For t1, the decidability check will ensure being Prop. *) - if is_Prop (type_of t2) + if is_Prop sigma (type_of t2) then let d1 = decidability t1 in - Tacticals.New.tclTHENLIST [ + tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_imp_simp, [| t1; t2; d1; mkVar i|])]); (onClearedName i (fun i -> @@ -1732,9 +1795,9 @@ let destructure_hyps = else loop lit | Kapp(Not,[t]) -> - begin match destructurate_prop t with + begin match destructurate_prop sigma t with Kapp(Or,[t1;t2]) -> - Tacticals.New.tclTHENLIST [ + tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_not_or,[| t1; t2; mkVar i |])]); (onClearedName i (fun i -> @@ -1742,7 +1805,7 @@ let destructure_hyps = ] | Kapp(And,[t1;t2]) -> let d1 = decidability t1 in - Tacticals.New.tclTHENLIST [ + tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_not_and, [| t1; t2; d1; mkVar i |])]); @@ -1752,7 +1815,7 @@ let destructure_hyps = | Kapp(Iff,[t1;t2]) -> let d1 = decidability t1 in let d2 = decidability t2 in - Tacticals.New.tclTHENLIST [ + tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_not_iff, [| t1; t2; d1; d2; mkVar i |])]); @@ -1764,7 +1827,7 @@ let destructure_hyps = (* t2 must be in Prop otherwise ~(t1->t2) wouldn't be ok. For t1, being decidable implies being Prop. *) let d1 = decidability t1 in - Tacticals.New.tclTHENLIST [ + tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_not_imp, [| t1; t2; d1; mkVar i |])]); @@ -1773,7 +1836,7 @@ let destructure_hyps = ] | Kapp(Not,[t]) -> let d = decidability t in - Tacticals.New.tclTHENLIST [ + tclTHENLIST [ (generalize_tac [mkApp (Lazy.force coq_not_not, [| t; d; mkVar i |])]); (onClearedName i (fun i -> (loop (LocalAssum (i,t) :: lit)))) @@ -1781,7 +1844,7 @@ let destructure_hyps = | Kapp(op,[t1;t2]) -> (try let thm = not_binop op in - Tacticals.New.tclTHENLIST [ + tclTHENLIST [ (generalize_tac [mkApp (Lazy.force thm, [| t1;t2;mkVar i|])]); (onClearedName i (fun _ -> loop lit)) @@ -1789,16 +1852,16 @@ let destructure_hyps = with Not_found -> loop lit) | Kapp(Eq,[typ;t1;t2]) -> if !old_style_flag then begin - match destructurate_type (pf_nf typ) with + match destructurate_type sigma (pf_nf typ) with | Kapp(Nat,_) -> - Tacticals.New.tclTHENLIST [ + tclTHENLIST [ (simplest_elim (mkApp (Lazy.force coq_not_eq, [|t1;t2;mkVar i|]))); (onClearedName i (fun _ -> loop lit)) ] | Kapp(Z,_) -> - Tacticals.New.tclTHENLIST [ + tclTHENLIST [ (simplest_elim (mkApp (Lazy.force coq_not_Zeq, [|t1;t2;mkVar i|]))); @@ -1806,14 +1869,14 @@ let destructure_hyps = ] | _ -> loop lit end else begin - match destructurate_type (pf_nf typ) with + match destructurate_type sigma (pf_nf typ) with | Kapp(Nat,_) -> - (Tacticals.New.tclTHEN + (tclTHEN (convert_hyp_no_check (NamedDecl.set_type (mkApp (Lazy.force coq_neq, [| t1;t2|])) decl)) (loop lit)) | Kapp(Z,_) -> - (Tacticals.New.tclTHEN + (tclTHEN (convert_hyp_no_check (NamedDecl.set_type (mkApp (Lazy.force coq_Zne, [| t1;t2|])) decl)) (loop lit)) @@ -1832,28 +1895,33 @@ let destructure_hyps = end } let destructure_goal = - Proofview.Goal.nf_enter { enter = begin fun gl -> + Proofview.Goal.enter { enter = begin fun gl -> let concl = Proofview.Goal.concl gl in - let decidability = Tacmach.New.of_old decidability gl in + let decidability = decidability gl in let rec loop t = - match destructurate_prop t with + Proofview.tclEVARMAP >>= fun sigma -> + let prop () = Proofview.tclUNIT (destructurate_prop sigma t) in + Proofview.V82.wrap_exceptions prop >>= fun prop -> + match prop with | Kapp(Not,[t]) -> - (Tacticals.New.tclTHEN - (Tacticals.New.tclTHEN (unfold sp_not) intro) + (tclTHEN + (tclTHEN (unfold sp_not) intro) destructure_hyps) - | Kimp(a,b) -> (Tacticals.New.tclTHEN intro (loop b)) + | Kimp(a,b) -> (tclTHEN intro (loop b)) | Kapp(False,[]) -> destructure_hyps | _ -> let goal_tac = try let dec = decidability t in - Tacticals.New.tclTHEN - (Proofview.V82.tactic (Tacmach.refine - (mkApp (Lazy.force coq_dec_not_not, [| t; dec; mkNewMeta () |])))) + tclTHEN + (Proofview.Goal.nf_enter { enter = begin fun gl -> + refine_app gl (mkApp (Lazy.force coq_dec_not_not, [| t; dec |])) + end }) intro - with Undecidable -> Tactics.elim_type (build_coq_False ()) + with Undecidable -> Tactics.elim_type (Lazy.force coq_False) + | e when Proofview.V82.catchable_exception e -> Proofview.tclZERO e in - Tacticals.New.tclTHEN goal_tac destructure_hyps + tclTHEN goal_tac destructure_hyps in (loop concl) end } diff --git a/plugins/omega/g_omega.ml4 b/plugins/omega/g_omega.ml4 index 27115abec..6b711a176 100644 --- a/plugins/omega/g_omega.ml4 +++ b/plugins/omega/g_omega.ml4 @@ -17,6 +17,7 @@ DECLARE PLUGIN "omega_plugin" +open Ltac_plugin open Names open Coq_omega open Stdarg diff --git a/plugins/quote/g_quote.ml4 b/plugins/quote/g_quote.ml4 index e7e6ecef9..6c3e66112 100644 --- a/plugins/quote/g_quote.ml4 +++ b/plugins/quote/g_quote.ml4 @@ -8,6 +8,7 @@ (*i camlp4deps: "grammar/grammar.cma" i*) +open Ltac_plugin open Names open Misctypes open Tacexpr @@ -22,7 +23,7 @@ let loc = Loc.ghost let cont = Id.of_string "cont" let x = Id.of_string "x" -let make_cont (k : Val.t) (c : Constr.t) = +let make_cont (k : Val.t) (c : EConstr.t) = let c = Tacinterp.Value.of_constr c in let tac = TacCall (loc, ArgVar (loc, cont), [Reference (ArgVar (loc, x))]) in let ist = { lfun = Id.Map.add cont k (Id.Map.singleton x c); extra = TacStore.empty; } in diff --git a/plugins/quote/quote.ml b/plugins/quote/quote.ml index 6405c8ceb..fc9d70ae7 100644 --- a/plugins/quote/quote.ml +++ b/plugins/quote/quote.ml @@ -105,6 +105,7 @@ open CErrors open Util open Names open Term +open EConstr open Pattern open Patternops open Constr_matching @@ -116,7 +117,8 @@ open Proofview.Notations We do that lazily, because this code can be linked before the constants are loaded in the environment *) -let constant dir s = Coqlib.gen_constant "Quote" ("quote"::dir) s +let constant dir s = + EConstr.of_constr (Coqlib.gen_constant "Quote" ("quote"::dir) s) let coq_Empty_vm = lazy (constant ["Quote"] "Empty_vm") let coq_Node_vm = lazy (constant ["Quote"] "Node_vm") @@ -165,7 +167,7 @@ exchange ?1 and ?2 in the example above) module ConstrSet = Set.Make( struct - type t = constr + type t = Constr.constr let compare = constr_ord end) @@ -183,7 +185,7 @@ type inversion_scheme = { let i_can't_do_that () = error "Quote: not a simple fixpoint" -let decomp_term c = kind_of_term (Termops.strip_outer_cast c) +let decomp_term sigma c = EConstr.kind sigma (Termops.strip_outer_cast sigma c) (*s [compute_lhs typ i nargsi] builds the term \texttt{(C ?nargsi ... ?2 ?1)}, where \texttt{C} is the [i]-th constructor of inductive @@ -195,8 +197,8 @@ let coerce_meta_out id = let coerce_meta_in n = Id.of_string ("M" ^ string_of_int n) -let compute_lhs typ i nargsi = - match kind_of_term typ with +let compute_lhs sigma typ i nargsi = + match EConstr.kind sigma typ with | Ind((sp,0),u) -> let argsi = Array.init nargsi (fun j -> mkMeta (nargsi - j)) in mkApp (mkConstructU (((sp,0),i+1),u), argsi) @@ -205,60 +207,62 @@ let compute_lhs typ i nargsi = (*s This function builds the pattern from the RHS. Recursive calls are replaced by meta-variables ?i corresponding to those in the LHS *) -let compute_rhs bodyi index_of_f = +let compute_rhs env sigma bodyi index_of_f = let rec aux c = - match kind_of_term c with - | App (j, args) when isRel j && Int.equal (destRel j) index_of_f (* recursive call *) -> - let i = destRel (Array.last args) in + match EConstr.kind sigma c with + | App (j, args) when isRel sigma j && Int.equal (destRel sigma j) index_of_f (* recursive call *) -> + let i = destRel sigma (Array.last args) in PMeta (Some (coerce_meta_in i)) | App (f,args) -> - PApp (pattern_of_constr (Global.env()) Evd.empty f, Array.map aux args) + PApp (pattern_of_constr env sigma (EConstr.to_constr sigma f), Array.map aux args) | Cast (c,_,_) -> aux c - | _ -> pattern_of_constr (Global.env())(*FIXME*) Evd.empty c + | _ -> pattern_of_constr env sigma (EConstr.to_constr sigma c) in aux bodyi (*s Now the function [compute_ivs] itself *) let compute_ivs f cs gl = - let cst = try destConst f with DestKO -> i_can't_do_that () in - let body = Environ.constant_value_in (Global.env()) cst in - match decomp_term body with + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in + let (cst, u) = try destConst sigma f with DestKO -> i_can't_do_that () in + let u = EInstance.kind sigma u in + let body = Environ.constant_value_in (Global.env()) (cst, u) in + let body = EConstr.of_constr body in + match decomp_term sigma body with | Fix(([| len |], 0), ([| name |], [| typ |], [| body2 |])) -> - let (args3, body3) = decompose_lam body2 in + let (args3, body3) = decompose_lam sigma body2 in let nargs3 = List.length args3 in - let env = Proofview.Goal.env gl in - let sigma = Tacmach.New.project gl in let is_conv = Reductionops.is_conv env sigma in - begin match decomp_term body3 with + begin match decomp_term sigma body3 with | Case(_,p,c,lci) -> (* <p> Case c of c1 ... cn end *) let n_lhs_rhs = ref [] and v_lhs = ref (None : constr option) and c_lhs = ref (None : constr option) in Array.iteri (fun i ci -> - let argsi, bodyi = decompose_lam ci in + let argsi, bodyi = decompose_lam sigma ci in let nargsi = List.length argsi in (* REL (narg3 + nargsi + 1) is f *) (* REL nargsi+1 to REL nargsi + nargs3 are arguments of f *) (* REL 1 to REL nargsi are argsi (reverse order) *) (* First we test if the RHS is the RHS for constants *) - if isRel bodyi && Int.equal (destRel bodyi) 1 then - c_lhs := Some (compute_lhs (snd (List.hd args3)) + if isRel sigma bodyi && Int.equal (destRel sigma bodyi) 1 then + c_lhs := Some (compute_lhs sigma (snd (List.hd args3)) i nargsi) (* Then we test if the RHS is the RHS for variables *) - else begin match decompose_app bodyi with + else begin match decompose_app sigma bodyi with | vmf, [_; _; a3; a4 ] - when isRel a3 && isRel a4 && is_conv vmf - (Lazy.force coq_varmap_find)-> - v_lhs := Some (compute_lhs + when isRel sigma a3 && isRel sigma a4 && is_conv vmf + (Lazy.force coq_varmap_find) -> + v_lhs := Some (compute_lhs sigma (snd (List.hd args3)) i nargsi) (* Third case: this is a normal LHS-RHS *) | _ -> n_lhs_rhs := - (compute_lhs (snd (List.hd args3)) i nargsi, - compute_rhs bodyi (nargs3 + nargsi + 1)) + (compute_lhs sigma (snd (List.hd args3)) i nargsi, + compute_rhs env sigma bodyi (nargs3 + nargsi + 1)) :: !n_lhs_rhs end) lci; @@ -266,7 +270,7 @@ let compute_ivs f cs gl = if Option.is_empty !c_lhs && Option.is_empty !v_lhs then i_can't_do_that (); (* The Cases predicate is a lambda; we assume no dependency *) - let p = match kind_of_term p with + let p = match EConstr.kind sigma p with | Lambda (_,_,p) -> Termops.pop p | _ -> p in @@ -297,11 +301,11 @@ binary search trees (see file \texttt{Quote.v}) *) (* First the function to distinghish between constants (closed terms) and variables (open terms) *) -let rec closed_under cset t = - (ConstrSet.mem t cset) || - (match (kind_of_term t) with - | Cast(c,_,_) -> closed_under cset c - | App(f,l) -> closed_under cset f && Array.for_all (closed_under cset) l +let rec closed_under sigma cset t = + (ConstrSet.mem (EConstr.Unsafe.to_constr t) cset) || + (match EConstr.kind sigma t with + | Cast(c,_,_) -> closed_under sigma cset c + | App(f,l) -> closed_under sigma cset f && Array.for_all (closed_under sigma cset) l | _ -> false) (*s [btree_of_array [| c1; c2; c3; c4; c5 |]] builds the complete @@ -361,7 +365,7 @@ let path_of_int n = let rec subterm gl (t : constr) (t' : constr) = (pf_conv_x gl t t') || - (match (kind_of_term t) with + (match EConstr.kind (project gl) t with | App (f,args) -> Array.exists (fun t -> subterm gl t t') args | Cast(t,_,_) -> (subterm gl t t') | _ -> false) @@ -370,9 +374,10 @@ let rec subterm gl (t : constr) (t' : constr) = (* Since it's a partial order the algoritm of Sort.list won't work !! *) let rec sort_subterm gl l = + let sigma = project gl in let rec insert c = function | [] -> [c] - | (h::t as l) when eq_constr c h -> l (* Avoid doing the same work twice *) + | (h::t as l) when EConstr.eq_constr sigma c h -> l (* Avoid doing the same work twice *) | h::t -> if subterm gl c h then c::h::t else h::(insert c t) in match l with @@ -380,11 +385,15 @@ let rec sort_subterm gl l = | h::t -> insert h (sort_subterm gl t) module Constrhash = Hashtbl.Make - (struct type t = constr - let equal = eq_constr - let hash = hash_constr + (struct type t = Constr.constr + let equal = Term.eq_constr + let hash = Term.hash_constr end) +let subst_meta subst c = + let subst = List.map (fun (i, c) -> i, EConstr.Unsafe.to_constr c) subst in + EConstr.of_constr (Termops.subst_meta subst (EConstr.Unsafe.to_constr c)) + (*s Now we are able to do the inversion itself. We destructurate the term and use an imperative hashtable to store leafs that are already encountered. @@ -392,7 +401,7 @@ module Constrhash = Hashtbl.Make [ivs : inversion_scheme]\\ [lc: constr list]\\ [gl: goal sigma]\\ *) -let quote_terms ivs lc = +let quote_terms env sigma ivs lc = Coqlib.check_required_library ["Coq";"quote";"Quote"]; let varhash = (Constrhash.create 17 : constr Constrhash.t) in let varlist = ref ([] : constr list) in (* list of variables *) @@ -402,34 +411,34 @@ let quote_terms ivs lc = match l with | (lhs, rhs)::tail -> begin try - let s1 = Id.Map.bindings (matches (Global.env ()) Evd.empty rhs c) in + let s1 = Id.Map.bindings (matches env sigma rhs c) in let s2 = List.map (fun (i,c_i) -> (coerce_meta_out i,aux c_i)) s1 in - Termops.subst_meta s2 lhs + subst_meta s2 lhs with PatternMatchingFailure -> auxl tail end | [] -> begin match ivs.variable_lhs with | None -> begin match ivs.constant_lhs with - | Some c_lhs -> Termops.subst_meta [1, c] c_lhs + | Some c_lhs -> subst_meta [1, c] c_lhs | None -> anomaly (Pp.str "invalid inversion scheme for quote") end | Some var_lhs -> begin match ivs.constant_lhs with - | Some c_lhs when closed_under ivs.constants c -> - Termops.subst_meta [1, c] c_lhs + | Some c_lhs when closed_under sigma ivs.constants c -> + subst_meta [1, c] c_lhs | _ -> begin - try Constrhash.find varhash c + try Constrhash.find varhash (EConstr.Unsafe.to_constr c) with Not_found -> let newvar = - Termops.subst_meta [1, (path_of_int !counter)] + subst_meta [1, (path_of_int !counter)] var_lhs in begin incr counter; varlist := c :: !varlist; - Constrhash.add varhash c newvar; + Constrhash.add varhash (EConstr.Unsafe.to_constr c) newvar; newvar end end @@ -448,11 +457,13 @@ let quote_terms ivs lc = let quote f lid = Proofview.Goal.nf_enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in let f = Tacmach.New.pf_global f gl in - let cl = List.map (fun id -> Tacmach.New.pf_global id gl) lid in + let cl = List.map (fun id -> EConstr.to_constr sigma (Tacmach.New.pf_global id gl)) lid in let ivs = compute_ivs f cl gl in let concl = Proofview.Goal.concl gl in - let quoted_terms = quote_terms ivs [concl] in + let quoted_terms = quote_terms env sigma ivs [concl] in let (p, vm) = match quoted_terms with | [p], vm -> (p,vm) | _ -> assert false @@ -464,10 +475,12 @@ let quote f lid = let gen_quote cont c f lid = Proofview.Goal.nf_enter { enter = begin fun gl -> + let env = Proofview.Goal.env gl in + let sigma = Tacmach.New.project gl in let f = Tacmach.New.pf_global f gl in - let cl = List.map (fun id -> Tacmach.New.pf_global id gl) lid in + let cl = List.map (fun id -> EConstr.to_constr sigma (Tacmach.New.pf_global id gl)) lid in let ivs = compute_ivs f cl gl in - let quoted_terms = quote_terms ivs [c] in + let quoted_terms = quote_terms env sigma ivs [c] in let (p, vm) = match quoted_terms with | [p], vm -> (p,vm) | _ -> assert false diff --git a/plugins/romega/const_omega.ml b/plugins/romega/const_omega.ml index 4935fe4bb..8d7ae51fc 100644 --- a/plugins/romega/const_omega.ml +++ b/plugins/romega/const_omega.ml @@ -285,7 +285,7 @@ module type Int = sig val mk : Bigint.bigint -> Term.constr val parse_term : Term.constr -> parse_term - val parse_rel : Proof_type.goal Tacmach.sigma -> Term.constr -> parse_rel + val parse_rel : ([ `NF ], 'r) Proofview.Goal.t -> Term.constr -> parse_rel (* check whether t is built only with numbers and + * - *) val is_scalar : Term.constr -> bool end @@ -350,10 +350,12 @@ let parse_term t = | _ -> Tother with e when Logic.catchable_exception e -> Tother +let pf_nf gl c = Tacmach.New.pf_apply Tacred.simpl gl c + let parse_rel gl t = try match destructurate t with | Kapp("eq",[typ;t1;t2]) - when destructurate (Tacmach.pf_nf gl typ) = Kapp("Z",[]) -> Req (t1,t2) + when destructurate (EConstr.Unsafe.to_constr (pf_nf gl (EConstr.of_constr typ))) = Kapp("Z",[]) -> Req (t1,t2) | Kapp("Zne",[t1;t2]) -> Rne (t1,t2) | Kapp("Z.le",[t1;t2]) -> Rle (t1,t2) | Kapp("Z.lt",[t1;t2]) -> Rlt (t1,t2) diff --git a/plugins/romega/const_omega.mli b/plugins/romega/const_omega.mli index af50ea0ff..ee7ff451a 100644 --- a/plugins/romega/const_omega.mli +++ b/plugins/romega/const_omega.mli @@ -168,7 +168,7 @@ module type Int = (* parsing a term (one level, except if a number is found) *) val parse_term : Term.constr -> parse_term (* parsing a relation expression, including = < <= >= > *) - val parse_rel : Proof_type.goal Tacmach.sigma -> Term.constr -> parse_rel + val parse_rel : ([ `NF ], 'r) Proofview.Goal.t -> Term.constr -> parse_rel (* Is a particular term only made of numbers and + * - ? *) val is_scalar : Term.constr -> bool end diff --git a/plugins/romega/g_romega.ml4 b/plugins/romega/g_romega.ml4 index 2f38688d1..df7e5cb99 100644 --- a/plugins/romega/g_romega.ml4 +++ b/plugins/romega/g_romega.ml4 @@ -10,6 +10,7 @@ DECLARE PLUGIN "romega_plugin" +open Ltac_plugin open Names open Refl_omega open Stdarg @@ -37,7 +38,7 @@ let romega_tactic l = we'd better leave as little as possible in the conclusion, for an easier decidability argument. *) (Tactics.intros) - (Proofview.V82.tactic total_reflexive_omega_tactic)) + (total_reflexive_omega_tactic)) TACTIC EXTEND romega diff --git a/plugins/romega/refl_omega.ml b/plugins/romega/refl_omega.ml index ba882e39a..a20589fb4 100644 --- a/plugins/romega/refl_omega.ml +++ b/plugins/romega/refl_omega.ml @@ -8,6 +8,7 @@ open Pp open Util +open Proofview.Notations open Const_omega module OmegaSolver = Omega_plugin.Omega.MakeOmegaSolver (Bigint) open OmegaSolver @@ -16,13 +17,12 @@ open OmegaSolver (* Especially useful debugging functions *) let debug = ref false -let show_goal gl = - if !debug then (); Tacticals.tclIDTAC gl +let show_goal = Tacticals.New.tclIDTAC let pp i = print_int i; print_newline (); flush stdout (* More readable than the prefix notation *) -let (>>) = Tacticals.tclTHEN +let (>>) = Tacticals.New.tclTHEN let mkApp = Term.mkApp @@ -739,7 +739,8 @@ and oproposition_of_constr env ((negated,depends,origin,path) as ctxt) gl c = (* Destructuration des hypothèses et de la conclusion *) let reify_gl env gl = - let concl = Tacmach.pf_concl gl in + let concl = Tacmach.New.pf_concl gl in + let concl = EConstr.Unsafe.to_constr concl in let t_concl = Pnot (oproposition_of_constr env (true,[],id_concl,[O_mono]) gl concl) in if !debug then begin @@ -748,6 +749,7 @@ let reify_gl env gl = end; let rec loop = function (i,t) :: lhyps -> + let t = EConstr.Unsafe.to_constr t in let t' = oproposition_of_constr env (false,[],i,[]) gl t in if !debug then begin Printf.printf " %s: " (Names.Id.to_string i); @@ -758,7 +760,7 @@ let reify_gl env gl = | [] -> if !debug then print_env_reification env; [] in - let t_lhyps = loop (Tacmach.pf_hyps_types gl) in + let t_lhyps = loop (Tacmach.New.pf_hyps_types gl) in (id_concl,t_concl) :: t_lhyps let rec destructurate_pos_hyp orig list_equations list_depends = function @@ -1222,7 +1224,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 +1260,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) @@ -1280,21 +1283,22 @@ let resolution env full_reified_goal systems_list = CCHyp{o_hyp=id_concl;o_path=[]} :: hyp_stated_vars @ initial_context in 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))) >> - Proofview.V82.of_tactic (Tactics.change_concl reified) >> - Proofview.V82.of_tactic (Tactics.apply (app coq_do_omega [|decompose_tactic; normalization_trace|])) >> + Tactics.generalize + (l_generalize_arg @ List.map EConstr.mkVar (List.tl l_hyps)) >> + Tactics.change_concl reified >> + Tactics.apply (EConstr.of_constr (app coq_do_omega [|decompose_tactic; normalization_trace|])) >> show_goal >> - Proofview.V82.of_tactic (Tactics.normalise_vm_in_concl) >> + Tactics.normalise_vm_in_concl >> (*i Alternatives to the previous line: - Normalisation without VM: Tactics.normalise_in_concl - 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)) + Tactics.apply (EConstr.of_constr (Lazy.force coq_I)) -let total_reflexive_omega_tactic gl = +let total_reflexive_omega_tactic = + Proofview.Goal.nf_enter { enter = begin fun gl -> Coqlib.check_required_library ["Coq";"romega";"ROmega"]; rst_omega_eq (); rst_omega_var (); @@ -1303,9 +1307,9 @@ let total_reflexive_omega_tactic gl = let full_reified_goal = reify_gl env gl in let systems_list = destructurate_hyps full_reified_goal in if !debug then display_systems systems_list; - resolution env full_reified_goal systems_list gl + resolution env full_reified_goal systems_list with NO_CONTRADICTION -> CErrors.error "ROmega can't solve this system" - + end } (*i let tester = Tacmach.hide_atomic_tactic "TestOmega" test_tactic i*) diff --git a/plugins/rtauto/g_rtauto.ml4 b/plugins/rtauto/g_rtauto.ml4 index d27b04834..7e58ef9a3 100644 --- a/plugins/rtauto/g_rtauto.ml4 +++ b/plugins/rtauto/g_rtauto.ml4 @@ -8,6 +8,8 @@ (*i camlp4deps: "grammar/grammar.cma" i*) +open Ltac_plugin + DECLARE PLUGIN "rtauto_plugin" TACTIC EXTEND rtauto diff --git a/plugins/rtauto/proof_search.ml b/plugins/rtauto/proof_search.ml index 8b9261113..1ad4d622b 100644 --- a/plugins/rtauto/proof_search.ml +++ b/plugins/rtauto/proof_search.ml @@ -505,12 +505,12 @@ let pp_mapint map = pp_form obj ++ str " => " ++ pp_list (fun (i,f) -> pp_form f) l ++ cut ()) ) map; - str "{ " ++ vb 0 ++ (!pp) ++ str " }" ++ close () + str "{ " ++ hv 0 (!pp ++ str " }") let pp_connect (i,j,f1,f2) = pp_form f1 ++ str " => " ++ pp_form f2 let pp_gl gl= cut () ++ - str "{ " ++ vb 0 ++ + str "{ " ++ hv 0 ( begin match gl.abs with None -> str "" @@ -520,7 +520,7 @@ let pp_gl gl= cut () ++ str "norev =" ++ pp_intmap gl.norev_hyps ++ cut () ++ str "arrows=" ++ pp_mapint gl.right ++ cut () ++ str "cnx =" ++ pp_list pp_connect gl.cnx ++ cut () ++ - str "goal =" ++ pp_form gl.gl ++ str " }" ++ close () + str "goal =" ++ pp_form gl.gl ++ str " }") let pp = function diff --git a/plugins/rtauto/refl_tauto.ml b/plugins/rtauto/refl_tauto.ml index 367a13333..3655df895 100644 --- a/plugins/rtauto/refl_tauto.ml +++ b/plugins/rtauto/refl_tauto.ml @@ -8,6 +8,7 @@ module Search = Explore.Make(Proof_search) +open Ltac_plugin open CErrors open Util open Term @@ -66,19 +67,18 @@ let l_E_Or = lazy (constant "E_Or") let l_D_Or = lazy (constant "D_Or") -let special_whd gl= - let infos=CClosure.create_clos_infos CClosure.all (pf_env gl) in - (fun t -> CClosure.whd_val infos (CClosure.inject t)) +let special_whd gl c = + Reductionops.clos_whd_flags CClosure.all (pf_env gl) (Tacmach.project gl) c -let special_nf gl= - let infos=CClosure.create_clos_infos CClosure.betaiotazeta (pf_env gl) in - (fun t -> CClosure.norm_val infos (CClosure.inject t)) +let special_nf gl c = + Reductionops.clos_norm_flags CClosure.betaiotazeta (pf_env gl) (Tacmach.project gl) c type atom_env= {mutable next:int; mutable env:(constr*int) list} let make_atom atom_env term= + let term = EConstr.Unsafe.to_constr term in try let (_,i)= List.find (fun (t,_)-> eq_constr term t) atom_env.env @@ -90,13 +90,16 @@ let make_atom atom_env term= Atom i let rec make_form atom_env gls term = + let open EConstr in + let open Vars in let normalize=special_nf gls in let cciterm=special_whd gls term in - match kind_of_term cciterm with + let sigma = Tacmach.project gls in + match EConstr.kind sigma cciterm with Prod(_,a,b) -> - if not (Termops.dependent (mkRel 1) b) && + if noccurn sigma 1 b && Retyping.get_sort_family_of - (pf_env gls) (Tacmach.project gls) a == InProp + (pf_env gls) sigma a == InProp then let fa=make_form atom_env gls a in let fb=make_form atom_env gls b in @@ -113,7 +116,7 @@ let rec make_form atom_env gls term = | App(hd,argv) when Int.equal (Array.length argv) 2 -> begin try - let ind, _ = destInd hd in + let ind, _ = destInd sigma hd in if Names.eq_ind ind (fst (Lazy.force li_and)) then let fa=make_form atom_env gls argv.(0) in let fb=make_form atom_env gls argv.(1) in @@ -134,7 +137,7 @@ let rec make_hyps atom_env gls lenv = function | LocalAssum (id,typ)::rest -> let hrec= make_hyps atom_env gls (typ::lenv) rest in - if List.exists (Termops.dependent (mkVar id)) lenv || + if List.exists (fun c -> Termops.local_occur_var Evd.empty (** FIXME *) id c) lenv || (Retyping.get_sort_family_of (pf_env gls) (Tacmach.project gls) typ != InProp) then @@ -312,6 +315,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/rtauto/refl_tauto.mli b/plugins/rtauto/refl_tauto.mli index 9a14ac6c7..092552364 100644 --- a/plugins/rtauto/refl_tauto.mli +++ b/plugins/rtauto/refl_tauto.mli @@ -12,13 +12,13 @@ type atom_env= mutable env:(Term.constr*int) list} val make_form : atom_env -> - Proof_type.goal Tacmach.sigma -> Term.types -> Proof_search.form + Proof_type.goal Tacmach.sigma -> EConstr.types -> Proof_search.form val make_hyps : atom_env -> Proof_type.goal Tacmach.sigma -> - Term.types list -> - Context.Named.t -> + EConstr.types list -> + EConstr.named_context -> (Names.Id.t * Proof_search.form) list val rtauto_tac : Proof_type.tactic diff --git a/plugins/setoid_ring/RealField.v b/plugins/setoid_ring/RealField.v index 293722125..facd2e062 100644 --- a/plugins/setoid_ring/RealField.v +++ b/plugins/setoid_ring/RealField.v @@ -59,11 +59,12 @@ Notation Rset := (Eqsth R). Notation Rext := (Eq_ext Rplus Rmult Ropp). Lemma Rlt_0_2 : 0 < 2. +Proof. apply Rlt_trans with (0 + 1). apply Rlt_n_Sn. rewrite Rplus_comm. apply Rplus_lt_compat_l. - replace 1 with (0 + 1). + replace R1 with (0 + 1). apply Rlt_n_Sn. apply Rplus_0_l. Qed. @@ -126,9 +127,17 @@ Ltac Rpow_tac t := | _ => constr:(N.of_nat t) end. -Add Field RField : Rfield - (completeness Zeq_bool_complete, power_tac R_power_theory [Rpow_tac]). - - - +Ltac IZR_tac t := + match t with + | R0 => constr:(0%Z) + | R1 => constr:(1%Z) + | IZR ?u => + match isZcst u with + | true => u + | _ => constr:(InitialRing.NotConstant) + end + | _ => constr:(InitialRing.NotConstant) + end. +Add Field RField : Rfield + (completeness Zeq_bool_complete, constants [IZR_tac], power_tac R_power_theory [Rpow_tac]). diff --git a/plugins/setoid_ring/g_newring.ml4 b/plugins/setoid_ring/g_newring.ml4 index 0987c44ae..05ab8ab32 100644 --- a/plugins/setoid_ring/g_newring.ml4 +++ b/plugins/setoid_ring/g_newring.ml4 @@ -8,6 +8,7 @@ (*i camlp4deps: "grammar/grammar.cma" i*) +open Ltac_plugin open Pp open Util open Libnames @@ -77,9 +78,7 @@ END VERNAC COMMAND EXTEND AddSetoidRing CLASSIFIED AS SIDEFF | [ "Add" "Ring" ident(id) ":" constr(t) ring_mods_opt(l) ] -> - [ let l = match l with None -> [] | Some l -> l in - let (k,set,cst,pre,post,power,sign, div) = process_ring_mods l in - add_theory id (ic t) set k cst (pre,post) power sign div] + [ let l = match l with None -> [] | Some l -> l in add_theory id t l] | [ "Print" "Rings" ] => [Vernac_classifier.classify_as_query] -> [ Feedback.msg_notice (strbrk "The following ring structures have been declared:"); Spmap.iter (fun fn fi -> @@ -92,7 +91,7 @@ END TACTIC EXTEND ring_lookup | [ "ring_lookup" tactic0(f) "[" constr_list(lH) "]" ne_constr_list(lrt) ] -> - [ let (t,lr) = List.sep_last lrt in ring_lookup f lH lr t] + [ let (t,lr) = List.sep_last lrt in ring_lookup f lH lr t ] END let pr_field_mod = function @@ -114,9 +113,7 @@ END VERNAC COMMAND EXTEND AddSetoidField CLASSIFIED AS SIDEFF | [ "Add" "Field" ident(id) ":" constr(t) field_mods_opt(l) ] -> - [ let l = match l with None -> [] | Some l -> l in - let (k,set,inj,cst_tac,pre,post,power,sign,div) = process_field_mods l in - add_field_theory id (ic t) set k cst_tac inj (pre,post) power sign div] + [ let l = match l with None -> [] | Some l -> l in add_field_theory id t l ] | [ "Print" "Fields" ] => [Vernac_classifier.classify_as_query] -> [ Feedback.msg_notice (strbrk "The following field structures have been declared:"); Spmap.iter (fun fn fi -> diff --git a/plugins/setoid_ring/newring.ml b/plugins/setoid_ring/newring.ml index 657efe175..dd68eac24 100644 --- a/plugins/setoid_ring/newring.ml +++ b/plugins/setoid_ring/newring.ml @@ -6,11 +6,13 @@ (* * GNU Lesser General Public License Version 2.1 *) (************************************************************************) +open Ltac_plugin open Pp open CErrors open Util open Names open Term +open EConstr open Vars open CClosure open Environ @@ -42,9 +44,9 @@ let tag_arg tag_rec map subs i c = | Prot -> mk_atom c | Rec -> if Int.equal i (-1) then mk_clos subs c else tag_rec c -let global_head_of_constr c = - let f, args = decompose_app c in - try global_of_constr f +let global_head_of_constr sigma c = + let f, args = decompose_app sigma c in + try fst (Termops.global_of_constr sigma f) with Not_found -> anomaly (str "global_head_of_constr") let global_of_constr_nofail c = @@ -52,6 +54,7 @@ let global_of_constr_nofail c = with Not_found -> VarRef (Id.of_string "dummy") let rec mk_clos_but f_map subs t = + let open Term in match f_map (global_of_constr_nofail t) with | Some map -> tag_arg (mk_clos_but f_map subs) map subs (-1) t | None -> @@ -61,6 +64,7 @@ let rec mk_clos_but f_map subs t = | _ -> mk_atom t) and mk_clos_app_but f_map subs f args n = + let open Term in if n >= Array.length args then mk_atom(mkApp(f, args)) else let fargs, args' = Array.chop n args in @@ -81,9 +85,11 @@ let lookup_map map = with Not_found -> user_err ~hdr:"lookup_map" (str"map "++qs map++str"not found") -let protect_red map env sigma c = - kl (create_clos_infos all env) - (mk_clos_but (lookup_map map c) (Esubst.subs_id 0) c);; +let protect_red map env sigma c0 = + let evars ev = Evarutil.safe_evar_value sigma ev in + let c = EConstr.Unsafe.to_constr c0 in + EConstr.of_constr (kl (create_clos_infos ~evars all env) + (mk_clos_but (lookup_map map sigma c0) (Esubst.subs_id 0) c));; let protect_tac map = Tactics.reduct_option (protect_red map,DEFAULTcast) None @@ -96,9 +102,10 @@ let protect_tac_in map id = let closed_term t l = let open Quote_plugin in + Proofview.tclEVARMAP >>= fun sigma -> let l = List.map Universes.constr_of_global l in let cs = List.fold_right Quote.ConstrSet.add l Quote.ConstrSet.empty in - if Quote.closed_under cs t then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (mt()) + if Quote.closed_under sigma cs t then Proofview.tclUNIT () else Tacticals.New.tclFAIL 0 (mt()) (* TACTIC EXTEND echo | [ "echo" constr(t) ] -> @@ -122,7 +129,7 @@ let closed_term_ast l = mltac_index = 0; } in let l = List.map (fun gr -> ArgArg(Loc.ghost,gr)) l in - TacFun([Some(Id.of_string"t")], + TacFun([Name(Id.of_string"t")], TacML(Loc.ghost,tacname, [TacGeneric (Genarg.in_gen (Genarg.glbwit Stdarg.wit_constr) (GVar(Loc.ghost,Id.of_string"t"),None)); TacGeneric (Genarg.in_gen (Genarg.glbwit (Genarg.wit_list Stdarg.wit_ref)) l)])) @@ -135,14 +142,16 @@ let _ = add_tacdef false ((Loc.ghost,Id.of_string"ring_closed_term" let ic c = let env = Global.env() in let sigma = Evd.from_env env in - Constrintern.interp_open_constr env sigma c + let sigma, c = Constrintern.interp_open_constr env sigma c in + (sigma, c) let ic_unsafe c = (*FIXME remove *) let env = Global.env() in let sigma = Evd.from_env env in - fst (Constrintern.interp_constr env sigma c) + EConstr.of_constr (fst (Constrintern.interp_constr env sigma c)) let decl_constant na ctx c = + let open Constr in let vars = Universes.universes_of_constr c in let ctx = Universes.restrict_universe_context (Univ.ContextSet.of_context ctx) vars in mkConst(declare_constant (Id.of_string na) @@ -171,11 +180,11 @@ let ltac_apply (f : Value.t) (args: Tacinterp.Value.t list) = let dummy_goal env sigma = let (gl,_,sigma) = - Goal.V82.mk_goal sigma (named_context_val env) mkProp Evd.Store.empty in + Goal.V82.mk_goal sigma (named_context_val env) EConstr.mkProp Evd.Store.empty in {Evd.it = gl; Evd.sigma = sigma} let constr_of v = match Value.to_constr v with - | Some c -> c + | Some c -> EConstr.Unsafe.to_constr c | None -> failwith "Ring.exec_tactic: anomaly" let tactic_res = ref [||] @@ -205,12 +214,13 @@ let exec_tactic env evd n f args = let lid = List.init n (fun i -> Id.of_string("x"^string_of_int i)) in let n = Genarg.in_gen (Genarg.glbwit Stdarg.wit_int) n in let get_res = TacML (Loc.ghost, get_res, [TacGeneric n]) in - let getter = Tacexp (TacFun (List.map (fun id -> Some id) lid, get_res)) in + let getter = Tacexp (TacFun (List.map (fun n -> Name n) lid, get_res)) in (** Evaluate the whole result *) let gl = dummy_goal env evd in let gls = Proofview.V82.of_tactic (Tacinterp.eval_tactic_ist ist (ltac_call f (args@[getter]))) gl in let evd, nf = Evarutil.nf_evars_and_universes (Refiner.project gls) in - Array.map (fun x -> nf (constr_of x)) !tactic_res, snd (Evd.universe_context evd) + let nf c = nf (constr_of c) in + Array.map nf !tactic_res, snd (Evd.universe_context evd) let stdlib_modules = [["Coq";"Setoids";"Setoid"]; @@ -220,7 +230,7 @@ let stdlib_modules = ] let coq_constant c = - lazy (Coqlib.gen_constant_in_modules "Ring" stdlib_modules c) + lazy (EConstr.of_constr (Coqlib.gen_constant_in_modules "Ring" stdlib_modules c)) let coq_reference c = lazy (Coqlib.gen_reference_in_modules "Ring" stdlib_modules c) @@ -238,19 +248,19 @@ let plapp evd f args = let fc = Evarutil.e_new_global evd (Lazy.force f) in mkApp(fc,args) -let dest_rel0 t = - match kind_of_term t with +let dest_rel0 sigma t = + match EConstr.kind sigma t with | App(f,args) when Array.length args >= 2 -> let rel = mkApp(f,Array.sub args 0 (Array.length args - 2)) in - if closed0 rel then + if closed0 sigma rel then (rel,args.(Array.length args - 2),args.(Array.length args - 1)) else error "ring: cannot find relation (not closed)" | _ -> error "ring: cannot find relation" -let rec dest_rel t = - match kind_of_term t with - | Prod(_,_,c) -> dest_rel c - | _ -> dest_rel0 t +let rec dest_rel sigma t = + match EConstr.kind sigma t with + | Prod(_,_,c) -> dest_rel sigma c + | _ -> dest_rel0 sigma t (****************************************************************************) (* Library linking *) @@ -265,7 +275,7 @@ let plugin_modules = ] let my_constant c = - lazy (Coqlib.gen_constant_in_modules "Ring" plugin_modules c) + lazy (EConstr.of_constr (Coqlib.gen_constant_in_modules "Ring" plugin_modules c)) let my_reference c = lazy (Coqlib.gen_reference_in_modules "Ring" plugin_modules c) @@ -309,31 +319,35 @@ let coq_mkhypo = my_reference "mkhypo" let coq_hypo = my_reference "hypo" (* Equality: do not evaluate but make recursive call on both sides *) -let map_with_eq arg_map c = - let (req,_,_) = dest_rel c in +let map_with_eq arg_map sigma c = + let (req,_,_) = dest_rel sigma c in interp_map - ((global_head_of_constr req,(function -1->Prot|_->Rec)):: + ((global_head_of_constr sigma req,(function -1->Prot|_->Rec)):: List.map (fun (c,map) -> (Lazy.force c,map)) arg_map) -let map_without_eq arg_map _ = +let map_without_eq arg_map _ _ = interp_map (List.map (fun (c,map) -> (Lazy.force c,map)) arg_map) let _ = add_map "ring" (map_with_eq [coq_cons,(function -1->Eval|2->Rec|_->Prot); coq_nil, (function -1->Eval|_ -> Prot); + my_reference "IDphi", (function _->Eval); + my_reference "gen_phiZ", (function _->Eval); (* Pphi_dev: evaluate polynomial and coef operations, protect ring operations and make recursive call on the var map *) pol_cst "Pphi_dev", (function -1|8|9|10|11|12|14->Eval|13->Rec|_->Prot); pol_cst "Pphi_pow", - (function -1|8|9|10|11|13|15|17->Eval|16->Rec|_->Prot); + (function -1|8|9|10|13|15|17->Eval|11|16->Rec|_->Prot); (* PEeval: evaluate morphism and polynomial, protect ring operations and make recursive call on the var map *) - pol_cst "PEeval", (function -1|7|9|12->Eval|11->Rec|_->Prot)]) + pol_cst "PEeval", (function -1|8|10|13->Eval|12->Rec|_->Prot)]) (****************************************************************************) (* Ring database *) +let pr_constr c = pr_econstr c + module Cmap = Map.Make(Constr) let from_carrier = Summary.ref Cmap.empty ~name:"ring-tac-carrier-table" @@ -352,7 +366,7 @@ let find_ring_structure env sigma l = (str"arguments of ring_simplify do not have all the same type") in List.iter check cl'; - (try ring_for_carrier ty + (try ring_for_carrier (EConstr.to_constr sigma ty) with Not_found -> user_err ~hdr:"ring" (str"cannot find a declared ring structure over"++ @@ -379,7 +393,7 @@ let subst_th (subst,th) = let posttac'= Tacsubst.subst_tactic subst th.ring_post_tac in if c' == th.ring_carrier && eq' == th.ring_req && - eq_constr set' th.ring_setoid && + Term.eq_constr set' th.ring_setoid && ext' == th.ring_ext && morph' == th.ring_morph && th' == th.ring_th && @@ -485,8 +499,8 @@ let op_smorph r add mul req m1 m2 = (* (setoid,op_morph) *) let ring_equality env evd (r,add,mul,opp,req) = - match kind_of_term req with - | App (f, [| _ |]) when eq_constr_nounivs f (Lazy.force coq_eq) -> + match EConstr.kind !evd req with + | App (f, [| _ |]) when eq_constr_nounivs !evd f (Lazy.force coq_eq) -> let setoid = plapp evd coq_eq_setoid [|r|] in let op_morph = match opp with @@ -540,15 +554,15 @@ let build_setoid_params env evd r add mul opp req eqth = let dest_ring env sigma th_spec = let th_typ = Retyping.get_type_of env sigma th_spec in - match kind_of_term th_typ with + match EConstr.kind sigma th_typ with App(f,[|r;zero;one;add;mul;sub;opp;req|]) - when eq_constr_nounivs f (Lazy.force coq_almost_ring_theory) -> + when eq_constr_nounivs sigma f (Lazy.force coq_almost_ring_theory) -> (None,r,zero,one,add,mul,Some sub,Some opp,req) | App(f,[|r;zero;one;add;mul;req|]) - when eq_constr_nounivs f (Lazy.force coq_semi_ring_theory) -> + when eq_constr_nounivs sigma f (Lazy.force coq_semi_ring_theory) -> (Some true,r,zero,one,add,mul,None,None,req) | App(f,[|r;zero;one;add;mul;sub;opp;req|]) - when eq_constr_nounivs f (Lazy.force coq_ring_theory) -> + when eq_constr_nounivs sigma f (Lazy.force coq_ring_theory) -> (Some false,r,zero,one,add,mul,Some sub,Some opp,req) | _ -> error "bad ring structure" @@ -581,6 +595,7 @@ let make_hyp_list env evd lH = (plapp evd coq_nil [|carrier|]) in let l' = Typing.e_solve_evars env evd l in + let l' = EConstr.Unsafe.to_constr l' in Evarutil.nf_evars_universes !evd l' let interp_power env evd pow = @@ -616,7 +631,7 @@ let interp_div env evd div = plapp evd coq_Some [|carrier;spec|] (* Same remark on ill-typed terms ... *) -let add_theory name (sigma,rth) eqth morphth cst_tac (pre,post) power sign div = +let add_theory0 name (sigma, rth) eqth morphth cst_tac (pre,post) power sign div = check_required_library (cdir@["Ring_base"]); let env = Global.env() in let (kind,r,zero,one,add,mul,sub,opp,req) = dest_ring env sigma rth in @@ -646,6 +661,9 @@ let add_theory name (sigma,rth) eqth morphth cst_tac (pre,post) power sign div = match post with Some t -> Tacintern.glob_tactic t | _ -> TacId [] in + let r = EConstr.to_constr sigma r in + let req = EConstr.to_constr sigma req in + let sth = EConstr.to_constr sigma sth in let _ = Lib.add_leaf name (theory_to_obj @@ -693,13 +711,18 @@ let process_ring_mods l = let k = match !kind with Some k -> k | None -> Abstract in (k, !set, !cst_tac, !pre, !post, !power, !sign, !div) +let add_theory id rth l = + let (sigma, rth) = ic rth in + let (k,set,cst,pre,post,power,sign, div) = process_ring_mods l in + add_theory0 id (sigma, rth) set k cst (pre,post) power sign div + (*****************************************************************************) (* The tactics consist then only in a lookup in the ring database and call the appropriate ltac. *) -let make_args_list rl t = +let make_args_list sigma rl t = match rl with - | [] -> let (_,t1,t2) = dest_rel0 t in [t1;t2] + | [] -> let (_,t1,t2) = dest_rel0 sigma t in [t1;t2] | _ -> rl let make_term_list env evd carrier rl = @@ -708,7 +731,7 @@ let make_term_list env evd carrier rl = (plapp evd coq_nil [|carrier|]) in Typing.e_solve_evars env evd l -let carg = Tacinterp.Value.of_constr +let carg c = Tacinterp.Value.of_constr (EConstr.of_constr c) let tacarg expr = Tacinterp.Value.of_closure (Tacinterp.default_ist ()) expr @@ -722,8 +745,8 @@ let ltac_ring_structure e = let pow_tac = tacarg e.ring_pow_tac in let lemma1 = carg e.ring_lemma1 in let lemma2 = carg e.ring_lemma2 in - let pretac = tacarg (TacFun([None],e.ring_pre_tac)) in - let posttac = tacarg (TacFun([None],e.ring_post_tac)) in + let pretac = tacarg (TacFun([Anonymous],e.ring_pre_tac)) in + let posttac = tacarg (TacFun([Anonymous],e.ring_post_tac)) in [req;sth;ext;morph;th;cst_tac;pow_tac; lemma1;lemma2;pretac;posttac] @@ -732,10 +755,10 @@ let ring_lookup (f : Value.t) lH rl t = let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in try (* find_ring_strucure can raise an exception *) + let rl = make_args_list sigma rl t in let evdref = ref sigma in - let rl = make_args_list rl t in let e = find_ring_structure env sigma rl in - let rl = carg (make_term_list env evdref e.ring_carrier rl) in + let rl = Value.of_constr (make_term_list env evdref (EConstr.of_constr e.ring_carrier) rl) in let lH = carg (make_hyp_list env evdref lH) in let ring = ltac_ring_structure e in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (ltac_apply f (ring@[lH;rl])) @@ -755,12 +778,14 @@ let _ = add_map "field" (map_with_eq [coq_cons,(function -1->Eval|2->Rec|_->Prot); coq_nil, (function -1->Eval|_ -> Prot); + my_reference "IDphi", (function _->Eval); + my_reference "gen_phiZ", (function _->Eval); (* display_linear: evaluate polynomials and coef operations, protect field operations and make recursive call on the var map *) my_reference "display_linear", (function -1|9|10|11|12|13|15|16->Eval|14->Rec|_->Prot); my_reference "display_pow_linear", - (function -1|9|10|11|12|13|14|16|18|19->Eval|17->Rec|_->Prot); + (function -1|9|10|11|14|16|18|19->Eval|12|17->Rec|_->Prot); (* Pphi_dev: evaluate polynomial and coef operations, protect ring operations and make recursive call on the var map *) pol_cst "Pphi_dev", (function -1|8|9|10|11|12|14->Eval|13->Rec|_->Prot); @@ -768,19 +793,20 @@ let _ = add_map "field" (function -1|8|9|10|11|13|15|17->Eval|16->Rec|_->Prot); (* PEeval: evaluate morphism and polynomial, protect ring operations and make recursive call on the var map *) - pol_cst "PEeval", (function -1|7|9|12->Eval|11->Rec|_->Prot); + pol_cst "PEeval", (function -1|8|10|13->Eval|12->Rec|_->Prot); (* FEeval: evaluate morphism, protect field operations and make recursive call on the var map *) - my_reference "FEeval", (function -1|8|9|10|11|14->Eval|13->Rec|_->Prot)]);; + my_reference "FEeval", (function -1|10|12|15->Eval|14->Rec|_->Prot)]);; let _ = add_map "field_cond" (map_without_eq [coq_cons,(function -1->Eval|2->Rec|_->Prot); coq_nil, (function -1->Eval|_ -> Prot); - (* PCond: evaluate morphism and denum list, protect ring + my_reference "IDphi", (function _->Eval); + my_reference "gen_phiZ", (function _->Eval); + (* PCond: evaluate denum list, protect ring operations and make recursive call on the var map *) - my_reference "PCond", (function -1|9|11|14->Eval|13->Rec|_->Prot)]);; -(* (function -1|9|11->Eval|10->Rec|_->Prot)]);;*) + my_reference "PCond", (function -1|11|14->Eval|9|13->Rec|_->Prot)]);; let _ = Redexpr.declare_reduction "simpl_field_expr" @@ -795,21 +821,22 @@ let af_ar = my_reference"AF_AR" let f_r = my_reference"F_R" let sf_sr = my_reference"SF_SR" let dest_field env evd th_spec = + let open Termops in let th_typ = Retyping.get_type_of env !evd th_spec in - match kind_of_term th_typ with + match EConstr.kind !evd th_typ with | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|]) - when is_global (Lazy.force afield_theory) f -> + when is_global !evd (Lazy.force afield_theory) f -> let rth = plapp evd af_ar [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in (None,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth) | App(f,[|r;zero;one;add;mul;sub;opp;div;inv;req|]) - when is_global (Lazy.force field_theory) f -> + when is_global !evd (Lazy.force field_theory) f -> let rth = plapp evd f_r [|r;zero;one;add;mul;sub;opp;div;inv;req;th_spec|] in (Some false,r,zero,one,add,mul,Some sub,Some opp,div,inv,req,rth) | App(f,[|r;zero;one;add;mul;div;inv;req|]) - when is_global (Lazy.force sfield_theory) f -> + when is_global !evd (Lazy.force sfield_theory) f -> let rth = plapp evd sf_sr [|r;zero;one;add;mul;div;inv;req;th_spec|] in (Some true,r,zero,one,add,mul,None,None,div,inv,req,rth) @@ -832,7 +859,7 @@ let find_field_structure env sigma l = (str"arguments of field_simplify do not have all the same type") in List.iter check cl'; - (try field_for_carrier ty + (try field_for_carrier (EConstr.to_constr sigma ty) with Not_found -> user_err ~hdr:"field" (str"cannot find a declared field structure over"++ @@ -889,9 +916,11 @@ let ftheory_to_obj : field_info -> obj = classify_function = (fun x -> Substitute x) } let field_equality evd r inv req = - match kind_of_term req with - | App (f, [| _ |]) when eq_constr_nounivs f (Lazy.force coq_eq) -> - mkApp(Universes.constr_of_global (Coqlib.build_coq_eq_data()).congr,[|r;r;inv|]) + match EConstr.kind !evd req with + | App (f, [| _ |]) when eq_constr_nounivs !evd f (Lazy.force coq_eq) -> + let c = Universes.constr_of_global (Coqlib.build_coq_eq_data()).congr in + let c = EConstr.of_constr c in + mkApp(c,[|r;r;inv|]) | _ -> let _setoid = setoid_of_relation (Global.env ()) evd r req in let signature = [Some (r,Some req)],Some(r,Some req) in @@ -901,15 +930,17 @@ let field_equality evd r inv req = error "field inverse should be declared as a morphism" in inv_m_lem -let add_field_theory name (sigma,fth) eqth morphth cst_tac inj (pre,post) power sign odiv = +let add_field_theory0 name fth eqth morphth cst_tac inj (pre,post) power sign odiv = + let open Constr in check_required_library (cdir@["Field_tac"]); + let (sigma,fth) = ic fth in let env = Global.env() in let evd = ref sigma in let (kind,r,zero,one,add,mul,sub,opp,div,inv,req,rth) = dest_field env evd fth in let (sth,ext) = build_setoid_params env evd r add mul opp req eqth in let eqth = Some(sth,ext) in - let _ = add_theory name (!evd,rth) eqth morphth cst_tac (None,None) power sign odiv in + let _ = add_theory0 name (!evd,rth) eqth morphth cst_tac (None,None) power sign odiv in let (pow_tac, pspec) = interp_power env evd power in let sspec = interp_sign env evd sign in let dspec = interp_div env evd odiv in @@ -924,7 +955,7 @@ let add_field_theory name (sigma,fth) eqth morphth cst_tac inj (pre,post) power let lemma4 = params.(6) in let cond_lemma = match inj with - | Some thm -> mkApp(params.(8),[|thm|]) + | Some thm -> mkApp(params.(8),[|EConstr.to_constr sigma thm|]) | None -> params.(7) in let lemma1 = decl_constant (Id.to_string name^"_field_lemma1") ctx lemma1 in @@ -946,6 +977,8 @@ let add_field_theory name (sigma,fth) eqth morphth cst_tac inj (pre,post) power match post with Some t -> Tacintern.glob_tactic t | _ -> TacId [] in + let r = EConstr.to_constr sigma r in + let req = EConstr.to_constr sigma req in let _ = Lib.add_leaf name (ftheory_to_obj @@ -985,6 +1018,10 @@ let process_field_mods l = let k = match !kind with Some k -> k | None -> Abstract in (k, !set, !inj, !cst_tac, !pre, !post, !power, !sign, !div) +let add_field_theory id t mods = + let (k,set,inj,cst_tac,pre,post,power,sign,div) = process_field_mods mods in + add_field_theory0 id t set k cst_tac inj (pre,post) power sign div + let ltac_field_structure e = let req = carg e.field_req in let cst_tac = tacarg e.field_cst_tac in @@ -994,8 +1031,8 @@ let ltac_field_structure e = let field_simpl_eq_ok = carg e.field_simpl_eq_ok in let field_simpl_eq_in_ok = carg e.field_simpl_eq_in_ok in let cond_ok = carg e.field_cond in - let pretac = tacarg (TacFun([None],e.field_pre_tac)) in - let posttac = tacarg (TacFun([None],e.field_post_tac)) in + let pretac = tacarg (TacFun([Anonymous],e.field_pre_tac)) in + let posttac = tacarg (TacFun([Anonymous],e.field_post_tac)) in [req;cst_tac;pow_tac;field_ok;field_simpl_ok;field_simpl_eq_ok; field_simpl_eq_in_ok;cond_ok;pretac;posttac] @@ -1004,10 +1041,10 @@ let field_lookup (f : Value.t) lH rl t = let sigma = Tacmach.New.project gl in let env = Proofview.Goal.env gl in try + let rl = make_args_list sigma rl t in let evdref = ref sigma in - let rl = make_args_list rl t in let e = find_field_structure env sigma rl in - let rl = carg (make_term_list env evdref e.field_carrier rl) in + let rl = Value.of_constr (make_term_list env evdref (EConstr.of_constr e.field_carrier) rl) in let lH = carg (make_hyp_list env evdref lH) in let field = ltac_field_structure e in Proofview.tclTHEN (Proofview.Unsafe.tclEVARS !evdref) (ltac_apply f (field@[lH;rl])) diff --git a/plugins/setoid_ring/newring.mli b/plugins/setoid_ring/newring.mli index f417c87cd..4367d021c 100644 --- a/plugins/setoid_ring/newring.mli +++ b/plugins/setoid_ring/newring.mli @@ -8,6 +8,7 @@ open Names open Constr +open EConstr open Libnames open Globnames open Constrexpr @@ -19,28 +20,12 @@ val protect_tac_in : string -> Id.t -> unit Proofview.tactic val protect_tac : string -> unit Proofview.tactic -val closed_term : constr -> global_reference list -> unit Proofview.tactic - -val process_ring_mods : - constr_expr ring_mod list -> - constr coeff_spec * (constr * constr) option * - cst_tac_spec option * raw_tactic_expr option * - raw_tactic_expr option * - (cst_tac_spec * constr_expr) option * - constr_expr option * constr_expr option +val closed_term : EConstr.constr -> global_reference list -> unit Proofview.tactic val add_theory : Id.t -> - Evd.evar_map * constr -> - (constr * constr) option -> - constr coeff_spec -> - cst_tac_spec option -> - raw_tactic_expr option * raw_tactic_expr option -> - (cst_tac_spec * constr_expr) option -> - constr_expr option -> - constr_expr option -> unit - -val ic : constr_expr -> Evd.evar_map * constr + constr_expr -> + constr_expr ring_mod list -> unit val from_name : ring_info Spmap.t ref @@ -49,26 +34,10 @@ val ring_lookup : constr list -> constr list -> constr -> unit Proofview.tactic -val process_field_mods : - constr_expr field_mod list -> - constr coeff_spec * - (constr * constr) option * constr option * - cst_tac_spec option * raw_tactic_expr option * - raw_tactic_expr option * - (cst_tac_spec * constr_expr) option * - constr_expr option * constr_expr option - val add_field_theory : Id.t -> - Evd.evar_map * constr -> - (constr * constr) option -> - constr coeff_spec -> - cst_tac_spec option -> - constr option -> - raw_tactic_expr option * raw_tactic_expr option -> - (cst_tac_spec * constr_expr) option -> - constr_expr option -> - constr_expr option -> unit + constr_expr -> + constr_expr field_mod list -> unit val field_from_name : field_info Spmap.t ref diff --git a/plugins/ssrmatching/ssrmatching.ml4 b/plugins/ssrmatching/ssrmatching.ml4 index fc988a2c5..f3555ebc4 100644 --- a/plugins/ssrmatching/ssrmatching.ml4 +++ b/plugins/ssrmatching/ssrmatching.ml4 @@ -10,11 +10,12 @@ (* Defining grammar rules with "xx" in it automatically declares keywords too, * we thus save the lexer to restore it at the end of the file *) -let frozen_lexer = CLexer.freeze () ;; +let frozen_lexer = CLexer.get_keyword_state () ;; (*i camlp4use: "pa_extend.cmo" i*) (*i camlp4deps: "grammar/grammar.cma" i*) +open Ltac_plugin open Names open Pp open Pcoq @@ -155,7 +156,7 @@ let mkCHole loc = CHole (loc, None, IntroAnonymous, None) let mkCLambda loc name ty t = CLambdaN (loc, [[loc, name], Default Explicit, ty], t) let mkCLetIn loc name bo t = - CLetIn (loc, (loc, name), bo, t) + CLetIn (loc, (loc, name), bo, None, t) let mkCCast loc t ty = CCast (loc,t, dC ty) (** Constructors for rawconstr *) let mkRHole = GHole (dummy_loc, InternalHole, IntroAnonymous, None) @@ -178,6 +179,9 @@ let mk_lterm = mk_term ' ' let pf_type_of gl t = let sigma, ty = pf_type_of gl t in re_sig (sig_it gl) sigma, ty +let nf_evar sigma c = + EConstr.Unsafe.to_constr (Evarutil.nf_evar sigma (EConstr.of_constr c)) + (* }}} *) (** Profiling {{{ *************************************************************) @@ -305,7 +309,7 @@ let unif_HOtype env ise p c = Evarconv.the_conv_x_leq env p c ise let unif_HO_args env ise0 pa i ca = let n = Array.length pa in let rec loop ise j = - if j = n then ise else loop (unif_HO env ise pa.(j) ca.(i + j)) (j + 1) in + if j = n then ise else loop (unif_HO env ise (EConstr.of_constr pa.(j)) (EConstr.of_constr ca.(i + j))) (j + 1) in loop ise0 0 (* FO unification should boil down to calling w_unify with no_delta, but *) @@ -332,10 +336,11 @@ let flags_FO = (Unification.default_no_delta_unify_flags ()).Unification.resolve_evars } let unif_FO env ise p c = - Unification.w_unify env ise Reduction.CONV ~flags:flags_FO p c + Unification.w_unify env ise Reduction.CONV ~flags:flags_FO (EConstr.of_constr p) (EConstr.of_constr c) (* Perform evar substitution in main term and prune substitution. *) let nf_open_term sigma0 ise c = + let c = EConstr.Unsafe.to_constr c in let s = ise and s' = ref sigma0 in let rec nf c' = match kind_of_term c' with | Evar ex -> @@ -352,7 +357,7 @@ let nf_open_term sigma0 ise c = | Evar_defined c' -> s' := Evd.define k (nf c') !s' | _ -> () in let c' = nf c in let _ = Evd.fold copy_def sigma0 () in - !s', Evd.evar_universe_context s, c' + !s', Evd.evar_universe_context s, EConstr.of_constr c' let unif_end env sigma0 ise0 pt ok = let ise = Evarconv.solve_unif_constraints_with_heuristics env ise0 in @@ -427,7 +432,7 @@ type tpattern = { up_a : constr array; up_t : constr; (* equation proof term or matched term *) up_dir : ssrdir; (* direction of the rule *) - up_ok : constr -> evar_map -> bool; (* progess test for rewrite *) + up_ok : constr -> evar_map -> bool; (* progress test for rewrite *) } let all_ok _ _ = true @@ -482,7 +487,9 @@ let evars_for_FO ~hack env sigma0 (ise0:evar_map) c0 = (* p_origin can be passed to obtain a better error message *) let mk_tpattern ?p_origin ?(hack=false) env sigma0 (ise, t) ok dir p = let k, f, a = - let f, a = Reductionops.whd_betaiota_stack ise p in + let f, a = Reductionops.whd_betaiota_stack ise (EConstr.of_constr p) in + let f = EConstr.Unsafe.to_constr f in + let a = List.map EConstr.Unsafe.to_constr a in match kind_of_term f with | Const (p,_) -> let np = proj_nparams p in @@ -639,13 +646,14 @@ let match_upats_FO upats env sigma0 ise orig_c = | _ -> unif_FO env ise u.up_FO c' in let ise' = (* Unify again using HO to assign evars *) let p = mkApp (u.up_f, u.up_a) in - try unif_HO env ise p c' with _ -> raise NoMatch in + try unif_HO env ise (EConstr.of_constr p) (EConstr.of_constr c') with e when CErrors.noncritical e -> raise NoMatch in let lhs = mkSubApp f i a in - let pt' = unif_end env sigma0 ise' u.up_t (u.up_ok lhs) in + let pt' = unif_end env sigma0 ise' (EConstr.of_constr u.up_t) (u.up_ok lhs) in + let pt' = pi1 pt', pi2 pt', EConstr.Unsafe.to_constr (pi3 pt') in raise (FoundUnif (ungen_upat lhs pt' u)) with FoundUnif (s,_,_) as sig_u when dont_impact_evars s -> raise sig_u | Not_found -> CErrors.anomaly (str"incomplete ise in match_upats_FO") - | _ -> () in + | e when CErrors.noncritical e -> () in List.iter one_match fpats done; iter_constr_LR loop f; Array.iter loop a in @@ -658,7 +666,7 @@ let match_upats_FO upats env sigma0 ise c = let match_upats_HO ~on_instance upats env sigma0 ise c = - let dont_impact_evars = dont_impact_evars_in c in + let dont_impact_evars = dont_impact_evars_in c in let it_did_match = ref false in let failed_because_of_TC = ref false in let rec aux upats env sigma0 ise c = @@ -680,16 +688,17 @@ let match_upats_HO ~on_instance upats env sigma0 ise c = | KpatLet -> let x, v, t, b = destLetIn f in let _, pv, _, pb = destLetIn u.up_f in - let ise' = unif_HO env ise pv v in + let ise' = unif_HO env ise (EConstr.of_constr pv) (EConstr.of_constr v) in unif_HO (Environ.push_rel (Context.Rel.Declaration.LocalAssum(x, t)) env) - ise' pb b + ise' (EConstr.of_constr pb) (EConstr.of_constr b) | KpatFlex | KpatProj _ -> - unif_HO env ise u.up_f (mkSubApp f (i - Array.length u.up_a) a) - | _ -> unif_HO env ise u.up_f f in + unif_HO env ise (EConstr.of_constr u.up_f) (EConstr.of_constr(mkSubApp f (i - Array.length u.up_a) a)) + | _ -> unif_HO env ise (EConstr.of_constr u.up_f) (EConstr.of_constr f) in let ise'' = unif_HO_args env ise' u.up_a (i - Array.length u.up_a) a in let lhs = mkSubApp f i a in - let pt' = unif_end env sigma0 ise'' u.up_t (u.up_ok lhs) in + let pt' = unif_end env sigma0 ise'' (EConstr.of_constr u.up_t) (u.up_ok lhs) in + let pt' = pi1 pt', pi2 pt', EConstr.Unsafe.to_constr (pi3 pt') in on_instance (ungen_upat lhs pt' u) with FoundUnif (s,_,_) as sig_u when dont_impact_evars s -> raise sig_u | NoProgress -> it_did_match := true @@ -714,7 +723,7 @@ let match_upats_HO ~on_instance upats env sigma0 ise c = let fixed_upat = function | {up_k = KpatFlex | KpatEvar _ | KpatProj _} -> false -| {up_t = t} -> not (occur_existential t) +| {up_t = t} -> not (occur_existential Evd.empty (EConstr.of_constr t)) (** FIXME *) let do_once r f = match !r with Some _ -> () | None -> r := Some (f ()) @@ -728,13 +737,13 @@ let assert_done_multires r = r := Some (n+1,xs); try List.nth xs n with Failure _ -> raise NoMatch -type subst = Environ.env -> Term.constr -> Term.constr -> int -> Term.constr +type subst = Environ.env -> constr -> constr -> int -> constr type find_P = - Environ.env -> Term.constr -> int -> + Environ.env -> constr -> int -> k:subst -> - Term.constr + constr type conclude = unit -> - Term.constr * ssrdir * (Evd.evar_map * Evd.evar_universe_context * Term.constr) + constr * ssrdir * (Evd.evar_map * Evd.evar_universe_context * constr) (* upats_origin makes a better error message only *) let mk_tpattern_matcher ?(all_instances=false) @@ -790,13 +799,13 @@ let on_instance, instances = let rec uniquize = function | [] -> [] | (sigma,_,{ up_f = f; up_a = a; up_t = t } as x) :: xs -> - let t = Reductionops.nf_evar sigma t in - let f = Reductionops.nf_evar sigma f in - let a = Array.map (Reductionops.nf_evar sigma) a in + let t = nf_evar sigma t in + let f = nf_evar sigma f in + let a = Array.map (nf_evar sigma) a in let neq (sigma1,_,{ up_f = f1; up_a = a1; up_t = t1 }) = - let t1 = Reductionops.nf_evar sigma1 t1 in - let f1 = Reductionops.nf_evar sigma1 f1 in - let a1 = Array.map (Reductionops.nf_evar sigma1) a1 in + let t1 = nf_evar sigma1 t1 in + let f1 = nf_evar sigma1 f1 in + let a1 = Array.map (nf_evar sigma1) a1 in not (Term.eq_constr t t1 && Term.eq_constr f f1 && CArray.for_all2 Term.eq_constr a a1) in x :: uniquize (List.filter neq xs) in @@ -845,8 +854,11 @@ let rec uniquize = function | Context.Rel.Declaration.LocalAssum _ as x -> x | Context.Rel.Declaration.LocalDef (x,_,y) -> Context.Rel.Declaration.LocalAssum(x,y) in - Environ.push_rel ctx_item env, h' + 1 in - let f' = map_constr_with_binders_left_to_right inc_h subst_loop acc f in + EConstr.push_rel ctx_item env, h' + 1 in + let self acc c = EConstr.of_constr (subst_loop acc (EConstr.Unsafe.to_constr c)) in + let f = EConstr.of_constr f in + let f' = map_constr_with_binders_left_to_right sigma inc_h self acc f in + let f' = EConstr.Unsafe.to_constr f' in mkApp (f', Array.map_left (subst_loop acc) a) in subst_loop (env,h) c) : find_P), ((fun () -> @@ -901,7 +913,7 @@ let pr_pattern_aux pr_constr = function | E_As_X_In_T (e,x,t) -> pr_constr e ++ str " as " ++ pr_constr x ++ str " in " ++ pr_constr t let pp_pattern (sigma, p) = - pr_pattern_aux (fun t -> pr_constr_pat (pi3 (nf_open_term sigma sigma t))) p + pr_pattern_aux (fun t -> pr_constr_pat (EConstr.Unsafe.to_constr (pi3 (nf_open_term sigma sigma (EConstr.of_constr t))))) p let pr_cpattern = pr_term let pr_rpattern _ _ _ = pr_pattern @@ -1005,7 +1017,7 @@ type occ = (bool * int list) option type rpattern = (cpattern, cpattern) ssrpattern let pr_rpattern = pr_pattern -type pattern = Evd.evar_map * (Term.constr, Term.constr) ssrpattern +type pattern = Evd.evar_map * (constr, constr) ssrpattern let id_of_cpattern = function @@ -1037,9 +1049,9 @@ let interp_constr = interp_wit wit_constr let interp_open_constr ist gl gc = interp_wit wit_open_constr ist gl gc let pf_intern_term ist gl (_, c) = glob_constr ist (pf_env gl) c -let interp_term ist gl (_, c) = (interp_open_constr ist gl c) +let interp_term ist gl (_, c) = on_snd EConstr.Unsafe.to_constr (interp_open_constr ist gl c) let pr_ssrterm _ _ _ = pr_term -let input_ssrtermkind strm = match Compat.get_tok (stream_nth 0 strm) with +let input_ssrtermkind strm = match stream_nth 0 strm with | Tok.KEYWORD "(" -> '(' | Tok.KEYWORD "@" -> '@' | _ -> ' ' @@ -1056,8 +1068,6 @@ ARGUMENT EXTEND cpattern | [ "Qed" constr(c) ] -> [ mk_lterm c ] END -let (!@) = Compat.to_coqloc - GEXTEND Gram GLOBAL: cpattern; cpattern: [[ k = ssrtermkind; c = constr -> @@ -1145,7 +1155,7 @@ let interp_pattern ?wit_ssrpatternarg ist gl red redty = if k = h_k || List.mem k acc || Evd.mem sigma0 k then acc else (update k; k::acc) | _ -> fold_constr aux acc t in - aux [] (Evarutil.nf_evar sigma rp) in + aux [] (nf_evar sigma rp) in let sigma = List.fold_left (fun sigma e -> if Evd.is_defined sigma e then sigma else (* clear may be recursive *) @@ -1192,7 +1202,7 @@ let interp_pattern ?wit_ssrpatternarg ist gl red redty = pp(lazy(str"typed as: " ++ pr_pattern_w_ids red)); let mkXLetIn loc x (a,(g,c)) = match c with | Some b -> a,(g,Some (mkCLetIn loc x (mkCHole loc) b)) - | None -> a,(GLetIn (loc,x,(GHole (loc, BinderType x, IntroAnonymous, None)), g), None) in + | None -> a,(GLetIn (loc,x,(GHole (loc, BinderType x, IntroAnonymous, None)), None, g), None) in match red with | T t -> let sigma, t = interp_term ist gl t in sigma, T t | In_T t -> let sigma, t = interp_term ist gl t in sigma, In_T t @@ -1202,7 +1212,7 @@ let interp_pattern ?wit_ssrpatternarg ist gl red redty = let sigma, rp = interp_term ist gl rp in let _, h, _, rp = destLetIn rp in let sigma = cleanup_XinE h x rp sigma in - let rp = subst1 h (Evarutil.nf_evar sigma rp) in + let rp = subst1 h (nf_evar sigma rp) in sigma, mk h rp | E_In_X_In_T(e, x, rp) | E_As_X_In_T (e, x, rp) -> let mk e x p = @@ -1211,7 +1221,7 @@ let interp_pattern ?wit_ssrpatternarg ist gl red redty = let sigma, rp = interp_term ist gl rp in let _, h, _, rp = destLetIn rp in let sigma = cleanup_XinE h x rp sigma in - let rp = subst1 h (Evarutil.nf_evar sigma rp) in + let rp = subst1 h (nf_evar sigma rp) in let sigma, e = interp_term ist (re_sig (sig_it gl) sigma) e in sigma, mk e h rp ;; @@ -1227,7 +1237,7 @@ let noindex = Some(false,[]) (* calls do_subst on every sub-term identified by (pattern,occ) *) let eval_pattern ?raise_NoMatch env0 sigma0 concl0 pattern occ do_subst = - let fs sigma x = Reductionops.nf_evar sigma x in + let fs sigma x = nf_evar sigma x in let pop_evar sigma e p = let { Evd.evar_body = e_body } as e_def = Evd.find sigma e in let e_body = match e_body with Evar_defined c -> c @@ -1264,7 +1274,7 @@ let eval_pattern ?raise_NoMatch env0 sigma0 concl0 pattern occ do_subst = let holep = mk_upat_for env0 sigma (sigma, hole) all_ok in let find_X, end_X = mk_tpattern_matcher ?raise_NoMatch sigma occ holep in let concl = find_T env0 concl0 1 (fun env c _ h -> - let p_sigma = unify_HO env (create_evar_defs sigma) c p in + let p_sigma = unify_HO env (create_evar_defs sigma) (EConstr.of_constr c) (EConstr.of_constr p) in let sigma, e_body = pop_evar p_sigma ex p in fs p_sigma (find_X env (fs sigma p) h (fun env _ -> do_subst env e_body))) in @@ -1280,7 +1290,7 @@ let eval_pattern ?raise_NoMatch env0 sigma0 concl0 pattern occ do_subst = let re = mk_upat_for env0 sigma0 (sigma, e) all_ok in let find_E, end_E = mk_tpattern_matcher ?raise_NoMatch sigma0 occ re in let concl = find_T env0 concl0 1 (fun env c _ h -> - let p_sigma = unify_HO env (create_evar_defs sigma) c p in + let p_sigma = unify_HO env (create_evar_defs sigma) (EConstr.of_constr c) (EConstr.of_constr p) in let sigma, e_body = pop_evar p_sigma ex p in fs p_sigma (find_X env (fs sigma p) h (fun env c _ h -> find_E env e_body h do_subst))) in @@ -1290,17 +1300,17 @@ let eval_pattern ?raise_NoMatch env0 sigma0 concl0 pattern occ do_subst = let p, e = fs sigma p, fs sigma e in let ex = ex_value hole in let rp = - let e_sigma = unify_HO env0 sigma hole e in + let e_sigma = unify_HO env0 sigma (EConstr.of_constr hole) (EConstr.of_constr e) in e_sigma, fs e_sigma p in let rp = mk_upat_for ~hack:true env0 sigma0 rp all_ok in let find_TE, end_TE = mk_tpattern_matcher sigma0 noindex rp in let holep = mk_upat_for env0 sigma (sigma, hole) all_ok in let find_X, end_X = mk_tpattern_matcher sigma occ holep in let concl = find_TE env0 concl0 1 (fun env c _ h -> - let p_sigma = unify_HO env (create_evar_defs sigma) c p in + let p_sigma = unify_HO env (create_evar_defs sigma) (EConstr.of_constr c) (EConstr.of_constr p) in let sigma, e_body = pop_evar p_sigma ex p in fs p_sigma (find_X env (fs sigma p) h (fun env c _ h -> - let e_sigma = unify_HO env sigma e_body e in + let e_sigma = unify_HO env sigma (EConstr.of_constr e_body) (EConstr.of_constr e) in let e_body = fs e_sigma e in do_subst env e_body e_body h))) in let _ = end_X () in let _ = end_TE () in @@ -1314,7 +1324,7 @@ let redex_of_pattern ?(resolve_typeclasses=false) env (sigma, p) = let sigma = if not resolve_typeclasses then sigma else Typeclasses.resolve_typeclasses ~fail:false env sigma in - Reductionops.nf_evar sigma e, Evd.evar_universe_context sigma + nf_evar sigma e, Evd.evar_universe_context sigma let fill_occ_pattern ?raise_NoMatch env sigma cl pat occ h = let do_make_rel, occ = @@ -1336,13 +1346,15 @@ let mk_tpattern ?p_origin env sigma0 sigma_t f dir c = ;; let pf_fill_occ env concl occ sigma0 p (sigma, t) ok h = + let p = EConstr.Unsafe.to_constr p in + let concl = EConstr.Unsafe.to_constr concl in let ise = create_evar_defs sigma in - let ise, u = mk_tpattern env sigma0 (ise,t) ok L2R p in + let ise, u = mk_tpattern env sigma0 (ise,EConstr.Unsafe.to_constr t) ok L2R p in let find_U, end_U = mk_tpattern_matcher ~raise_NoMatch:true sigma0 occ (ise,[u]) in let concl = find_U env concl h (fun _ _ _ -> mkRel) in let rdx, _, (sigma, uc, p) = end_U () in - sigma, uc, p, concl, rdx + sigma, uc, EConstr.of_constr p, EConstr.of_constr concl, EConstr.of_constr rdx let fill_occ_term env cl occ sigma0 (sigma, t) = try @@ -1355,7 +1367,7 @@ let fill_occ_term env cl occ sigma0 (sigma, t) = if sigma' != sigma0 then raise NoMatch else cl, (Evd.merge_universe_context sigma' uc, t') with _ -> - errorstrm (str "partial term " ++ pr_constr_pat t + errorstrm (str "partial term " ++ pr_constr_pat (EConstr.Unsafe.to_constr t) ++ str " does not match any subterm of the goal") let pf_fill_occ_term gl occ t = @@ -1395,10 +1407,13 @@ let ssrpatterntac _ist (arg_ist,arg) gl = let pat = interp_rpattern arg_ist gl arg in let sigma0 = project gl in let concl0 = pf_concl gl in + let concl0 = EConstr.Unsafe.to_constr concl0 in let (t, uc), concl_x = fill_occ_pattern (Global.env()) sigma0 concl0 pat noindex 1 in + let t = EConstr.of_constr t in + let concl_x = EConstr.of_constr concl_x in let gl, tty = pf_type_of gl t in - let concl = mkLetIn (Name (id_of_string "selected"), t, tty, concl_x) in + let concl = EConstr.mkLetIn (Name (id_of_string "selected"), t, tty, concl_x) in Proofview.V82.of_tactic (convert_concl concl DEFAULTcast) gl (* Register "ssrpattern" tactic *) @@ -1411,7 +1426,7 @@ let () = let name = { mltac_plugin = "ssrmatching_plugin"; mltac_tactic = "ssrpattern"; } in let () = Tacenv.register_ml_tactic name [|mltac|] in let tac = - TacFun ([Some (Id.of_string "pattern")], + TacFun ([Name (Id.of_string "pattern")], TacML (Loc.ghost, { mltac_name = name; mltac_index = 0 }, [])) in let obj () = Tacenv.register_ltac true false (Id.of_string "ssrpattern") tac in @@ -1421,6 +1436,7 @@ let ssrinstancesof ist arg gl = let ok rhs lhs ise = true in (* not (Term.eq_constr lhs (Evarutil.nf_evar ise rhs)) in *) let env, sigma, concl = pf_env gl, project gl, pf_concl gl in + let concl = EConstr.Unsafe.to_constr concl in let sigma0, cpat = interp_cpattern ist gl arg None in let pat = match cpat with T x -> x | _ -> errorstrm (str"Not supported") in let etpat, tpat = mk_tpattern env sigma (sigma0,pat) (ok pat) L2R pat in @@ -1443,6 +1459,6 @@ END (* The user is supposed to Require Import ssreflect or Require ssreflect *) (* and Import ssreflect.SsrSyntax to obtain these keywords and as a *) (* consequence the extended ssreflect grammar. *) -let () = CLexer.unfreeze frozen_lexer ;; +let () = CLexer.set_keyword_state frozen_lexer ;; (* vim: set filetype=ocaml foldmethod=marker: *) diff --git a/plugins/ssrmatching/ssrmatching.mli b/plugins/ssrmatching/ssrmatching.mli index 288a04e60..894cdb943 100644 --- a/plugins/ssrmatching/ssrmatching.mli +++ b/plugins/ssrmatching/ssrmatching.mli @@ -194,7 +194,7 @@ val mk_tpattern_matcher : (* convenience shortcut: [pf_fill_occ_term gl occ (sigma,t)] returns * the conclusion of [gl] where [occ] occurrences of [t] have been replaced * by [Rel 1] and the instance of [t] *) -val pf_fill_occ_term : goal sigma -> occ -> evar_map * constr -> constr * constr +val pf_fill_occ_term : goal sigma -> occ -> evar_map * EConstr.t -> EConstr.t * EConstr.t (* It may be handy to inject a simple term into the first form of cpattern *) val cpattern_of_term : char * glob_constr_and_expr -> cpattern @@ -216,8 +216,8 @@ val assert_done : 'a option ref -> 'a [solve_unif_constraints_with_heuristics] and [resolve_typeclasses]. In case of failure they raise [NoMatch] *) -val unify_HO : env -> evar_map -> constr -> constr -> evar_map -val pf_unify_HO : goal sigma -> constr -> constr -> goal sigma +val unify_HO : env -> evar_map -> EConstr.constr -> EConstr.constr -> evar_map +val pf_unify_HO : goal sigma -> EConstr.constr -> EConstr.constr -> goal sigma (** Some more low level functions needed to implement the full SSR language on top of the former APIs *) diff --git a/plugins/syntax/r_syntax.ml b/plugins/syntax/r_syntax.ml index 3ae2d45f3..8f065f528 100644 --- a/plugins/syntax/r_syntax.ml +++ b/plugins/syntax/r_syntax.ml @@ -9,6 +9,8 @@ open Util open Names open Globnames +open Glob_term +open Bigint (* Poor's man DECLARE PLUGIN *) let __coq_plugin_name = "r_syntax_plugin" @@ -17,95 +19,105 @@ let () = Mltop.add_known_module __coq_plugin_name exception Non_closed_number (**********************************************************************) -(* Parsing R via scopes *) +(* Parsing positive via scopes *) (**********************************************************************) -open Glob_term -open Bigint +let binnums = ["Coq";"Numbers";"BinNums"] let make_dir l = DirPath.make (List.rev_map Id.of_string l) -let rdefinitions = make_dir ["Coq";"Reals";"Rdefinitions"] -let make_path dir id = Libnames.make_path dir (Id.of_string id) +let make_path dir id = Libnames.make_path (make_dir dir) (Id.of_string id) + +let positive_path = make_path binnums "positive" + +(* TODO: temporary hack *) +let make_kn dir id = Globnames.encode_mind dir id + +let positive_kn = make_kn (make_dir binnums) (Id.of_string "positive") +let glob_positive = IndRef (positive_kn,0) +let path_of_xI = ((positive_kn,0),1) +let path_of_xO = ((positive_kn,0),2) +let path_of_xH = ((positive_kn,0),3) +let glob_xI = ConstructRef path_of_xI +let glob_xO = ConstructRef path_of_xO +let glob_xH = ConstructRef path_of_xH + +let pos_of_bignat dloc x = + let ref_xI = GRef (dloc, glob_xI, None) in + let ref_xH = GRef (dloc, glob_xH, None) in + let ref_xO = GRef (dloc, glob_xO, None) in + let rec pos_of x = + match div2_with_rest x with + | (q,false) -> GApp (dloc, ref_xO,[pos_of q]) + | (q,true) when not (Bigint.equal q zero) -> GApp (dloc,ref_xI,[pos_of q]) + | (q,true) -> ref_xH + in + pos_of x + +(**********************************************************************) +(* Printing positive via scopes *) +(**********************************************************************) + +let rec bignat_of_pos = function + | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_xO -> mult_2(bignat_of_pos a) + | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_xI -> add_1(mult_2(bignat_of_pos a)) + | GRef (_, a, _) when Globnames.eq_gr a glob_xH -> Bigint.one + | _ -> raise Non_closed_number + +(**********************************************************************) +(* Parsing Z via scopes *) +(**********************************************************************) +let z_path = make_path binnums "Z" +let z_kn = make_kn (make_dir binnums) (Id.of_string "Z") +let glob_z = IndRef (z_kn,0) +let path_of_ZERO = ((z_kn,0),1) +let path_of_POS = ((z_kn,0),2) +let path_of_NEG = ((z_kn,0),3) +let glob_ZERO = ConstructRef path_of_ZERO +let glob_POS = ConstructRef path_of_POS +let glob_NEG = ConstructRef path_of_NEG + +let z_of_int dloc n = + if not (Bigint.equal n zero) then + let sgn, n = + if is_pos_or_zero n then glob_POS, n else glob_NEG, Bigint.neg n in + GApp(dloc, GRef (dloc,sgn,None), [pos_of_bignat dloc n]) + else + GRef (dloc, glob_ZERO, None) + +(**********************************************************************) +(* Printing Z via scopes *) +(**********************************************************************) + +let bigint_of_z = function + | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_POS -> bignat_of_pos a + | GApp (_, GRef (_,b,_),[a]) when Globnames.eq_gr b glob_NEG -> Bigint.neg (bignat_of_pos a) + | GRef (_, a, _) when Globnames.eq_gr a glob_ZERO -> Bigint.zero + | _ -> raise Non_closed_number + +(**********************************************************************) +(* Parsing R via scopes *) +(**********************************************************************) + +let rdefinitions = ["Coq";"Reals";"Rdefinitions"] let r_path = make_path rdefinitions "R" (* TODO: temporary hack *) let make_path dir id = Globnames.encode_con dir (Id.of_string id) -let r_kn = make_path rdefinitions "R" -let glob_R = ConstRef r_kn -let glob_R1 = ConstRef (make_path rdefinitions "R1") -let glob_R0 = ConstRef (make_path rdefinitions "R0") -let glob_Ropp = ConstRef (make_path rdefinitions "Ropp") -let glob_Rplus = ConstRef (make_path rdefinitions "Rplus") -let glob_Rmult = ConstRef (make_path rdefinitions "Rmult") - -let two = mult_2 one -let three = add_1 two -let four = mult_2 two - -(* Unary representation of strictly positive numbers *) -let rec small_r dloc n = - if equal one n then GRef (dloc, glob_R1, None) - else GApp(dloc,GRef (dloc,glob_Rplus, None), - [GRef (dloc, glob_R1, None);small_r dloc (sub_1 n)]) - -let r_of_posint dloc n = - let r1 = GRef (dloc, glob_R1, None) in - let r2 = small_r dloc two in - let rec r_of_pos n = - if less_than n four then small_r dloc n - else - let (q,r) = div2_with_rest n in - let b = GApp(dloc,GRef(dloc,glob_Rmult,None),[r2;r_of_pos q]) in - if r then GApp(dloc,GRef(dloc,glob_Rplus,None),[r1;b]) else b in - if not (Bigint.equal n zero) then r_of_pos n else GRef(dloc,glob_R0,None) +let glob_IZR = ConstRef (make_path (make_dir rdefinitions) "IZR") let r_of_int dloc z = - if is_strictly_neg z then - GApp (dloc, GRef(dloc,glob_Ropp,None), [r_of_posint dloc (neg z)]) - else - r_of_posint dloc z + GApp (dloc, GRef(dloc,glob_IZR,None), [z_of_int dloc z]) (**********************************************************************) (* Printing R via scopes *) (**********************************************************************) -let bignat_of_r = -(* for numbers > 1 *) -let rec bignat_of_pos = function - (* 1+1 *) - | GApp (_,GRef (_,p,_), [GRef (_,o1,_); GRef (_,o2,_)]) - when Globnames.eq_gr p glob_Rplus && Globnames.eq_gr o1 glob_R1 && Globnames.eq_gr o2 glob_R1 -> two - (* 1+(1+1) *) - | GApp (_,GRef (_,p1,_), [GRef (_,o1,_); - GApp(_,GRef (_,p2,_),[GRef(_,o2,_);GRef(_,o3,_)])]) - when Globnames.eq_gr p1 glob_Rplus && Globnames.eq_gr p2 glob_Rplus && - Globnames.eq_gr o1 glob_R1 && Globnames.eq_gr o2 glob_R1 && Globnames.eq_gr o3 glob_R1 -> three - (* (1+1)*b *) - | GApp (_,GRef (_,p,_), [a; b]) when Globnames.eq_gr p glob_Rmult -> - if not (Bigint.equal (bignat_of_pos a) two) then raise Non_closed_number; - mult_2 (bignat_of_pos b) - (* 1+(1+1)*b *) - | GApp (_,GRef (_,p1,_), [GRef (_,o,_); GApp (_,GRef (_,p2,_),[a;b])]) - when Globnames.eq_gr p1 glob_Rplus && Globnames.eq_gr p2 glob_Rmult && Globnames.eq_gr o glob_R1 -> - if not (Bigint.equal (bignat_of_pos a) two) then raise Non_closed_number; - add_1 (mult_2 (bignat_of_pos b)) - | _ -> raise Non_closed_number -in -let bignat_of_r = function - | GRef (_,a,_) when Globnames.eq_gr a glob_R0 -> zero - | GRef (_,a,_) when Globnames.eq_gr a glob_R1 -> one - | r -> bignat_of_pos r -in -bignat_of_r - let bigint_of_r = function - | GApp (_,GRef (_,o,_), [a]) when Globnames.eq_gr o glob_Ropp -> - let n = bignat_of_r a in - if Bigint.equal n zero then raise Non_closed_number; - neg n - | a -> bignat_of_r a + | GApp (_,GRef (_,o,_), [a]) when Globnames.eq_gr o glob_IZR -> + bigint_of_z a + | _ -> raise Non_closed_number let uninterp_r p = try @@ -113,12 +125,9 @@ let uninterp_r p = with Non_closed_number -> None -let mkGRef gr = GRef (Loc.ghost,gr,None) - let _ = Notation.declare_numeral_interpreter "R_scope" (r_path,["Coq";"Reals";"Rdefinitions"]) r_of_int - (List.map mkGRef - [glob_Ropp;glob_R0;glob_Rplus;glob_Rmult;glob_R1], + ([GRef (Loc.ghost,glob_IZR,None)], uninterp_r, false) |